X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcDeriv.lhs;h=2edd8361058480088578edd57eba6f22d0a69acf;hb=4c6a3f787abcaed009a574196d82237d9ae64fc8;hp=445a1f437a80f9e4a93b0ea63d5f9aa907c0ce7e;hpb=f22f248b88346df835b25f03f8d3372c7bb87950;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index 445a1f4..2edd836 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -46,6 +46,7 @@ import SrcLoc import Util import ListSetOps import Outputable +import FastString import Bag \end{code} @@ -265,7 +266,7 @@ tcDeriving :: [LTyClDecl Name] -- All type constructors HsValBinds Name) -- Extra generated top-level bindings tcDeriving tycl_decls inst_decls deriv_decls - = recoverM (returnM ([], emptyValBindsOut)) $ + = recoverM (return ([], emptyValBindsOut)) $ do { -- Fish the "deriving"-related information out of the TcEnv -- And make the necessary "equations". ; early_specs <- makeDerivSpecs tycl_decls inst_decls deriv_decls @@ -286,8 +287,8 @@ tcDeriving tycl_decls inst_decls deriv_decls ; let inst_info = insts1 ++ insts2 ; dflags <- getDOpts - ; ioToTcRn (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances" - (ddump_deriving inst_info rn_binds)) + ; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances" + (ddump_deriving inst_info rn_binds)) ; return (inst_info, rn_binds) } where @@ -431,11 +432,22 @@ mkEqnHelp :: InstOrigin -> [TyVar] -> Class -> [Type] -> Type -> TcRn (Maybe EarlyDerivSpec) mkEqnHelp orig tvs cls cls_tys tc_app mtheta | Just (tycon, tc_args) <- tcSplitTyConApp_maybe tc_app - = do { (rep_tc, rep_tc_args) <- tcLookupFamInstExact tycon tc_args + = do { + -- For standalone deriving (mtheta /= Nothing), + -- check that all the data constructors are in scope + -- By this time we know that the thing is algebraic + -- because we've called checkInstHead in derivingStandalone + rdr_env <- getGlobalRdrEnv + ; let hidden_data_cons = filter not_in_scope (tyConDataCons tycon) + not_in_scope dc = null (lookupGRE_Name rdr_env (dataConName dc)) + ; checkTc (isNothing mtheta || null hidden_data_cons) + (derivingHiddenErr tycon) ; mayDeriveDataTypeable <- doptM Opt_DeriveDataTypeable ; newtype_deriving <- doptM Opt_GeneralizedNewtypeDeriving + ; (rep_tc, rep_tc_args) <- tcLookupFamInstExact tycon tc_args + -- Be careful to test rep_tc here: in the case of families, we want -- to check the instance tycon, not the family tycon ; if isDataTyCon rep_tc then @@ -519,21 +531,24 @@ mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta dataConInstOrigArgTys data_con rep_tc_args, not (isUnLiftedType arg_ty) ] -- No constraints for unlifted types? + -- See Note [Superclasses of derived instance] + sc_constraints = substTheta (zipOpenTvSubst (classTyVars cls) inst_tys) + (classSCTheta cls) + inst_tys = [mkTyConApp tycon tc_args] + stupid_subst = zipTopTvSubst (tyConTyVars rep_tc) rep_tc_args stupid_constraints = substTheta stupid_subst (tyConStupidTheta rep_tc) - all_constraints = stupid_constraints ++ ordinary_constraints - -- see Note [Data decl contexts] above + all_constraints = stupid_constraints ++ sc_constraints ++ ordinary_constraints spec = DS { ds_loc = loc, ds_orig = orig , ds_name = dfun_name, ds_tvs = tvs - , ds_cls = cls, ds_tys = [mkTyConApp tycon tc_args] + , ds_cls = cls, ds_tys = inst_tys , ds_theta = mtheta `orElse` all_constraints , ds_newtype = False } ; return (if isJust mtheta then Just (Right spec) -- Specified context else Just (Left spec)) } -- Infer context - mk_typeable_eqn orig tvs cls tycon tc_args rep_tc _rep_tc_args mtheta -- The Typeable class is special in several ways -- data T a b = ... deriving( Typeable ) @@ -684,6 +699,30 @@ new_dfun_name clas tycon -- Just a simple wrapper -- a suitable string; hence the empty type arg list \end{code} +Note [Superclasses of derived instance] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In general, a derived instance decl needs the superclasses of the derived +class too. So if we have + data T a = ...deriving( Ord ) +then the initial context for Ord (T a) should include Eq (T a). Often this is +redundant; we'll also generate an Ord constraint for each constructor argument, +and that will probably generate enough constraints to make the Eq (T a) constraint +be satisfied too. But not always; consider: + + data S a = S + instance Eq (S a) + instance Ord (S a) + + data T a = MkT (S a) deriving( Ord ) + instance Num a => Eq (T a) + +The derived instance for (Ord (T a)) must have a (Num a) constraint! +Similarly consider: + data T a = MkT deriving( Data, Typeable ) +Here there *is* no argument field, but we must nevertheless generate +a context for the Data instances: + instance Typable a => Data (T a) where ... + %************************************************************************ %* * @@ -760,10 +799,10 @@ mkNewTypeEqn orig mayDeriveDataTypeable newtype_deriving tvs -- Want to drop 1 arg from (T s a) and (ST s a) -- to get instance Monad (ST s) => Monad (T s) - -- Note [newtype representation] - -- Need newTyConRhs *not* newTyConRep to get the representation - -- type, because the latter looks through all intermediate newtypes - -- For example + -- Note [Newtype representation] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- Need newTyConRhs (*not* a recursive representation finder) + -- to get the representation type. For example -- newtype B = MkB Int -- newtype A = MkA B deriving( Num ) -- We want the Num instance of B, *not* the Num instance of Int, @@ -1125,6 +1164,11 @@ derivingThingErr clas tys ty why where pred = mkClassPred clas (tys ++ [ty]) +derivingHiddenErr :: TyCon -> SDoc +derivingHiddenErr tc + = hang (ptext SLIT("The data constructors of") <+> quotes (ppr tc) <+> ptext SLIT("are not all in scope")) + 2 (ptext SLIT("so you cannot derive an instance for it")) + standaloneCtxt :: LHsType Name -> SDoc standaloneCtxt ty = hang (ptext SLIT("In the stand-alone deriving instance for")) 2 (quotes (ppr ty))