X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcDeriv.lhs;h=3aecc43dc35483afb0663d814aef3027bf4ee36f;hb=79011516105291b58324ce71a87f6bb26a131090;hp=bbdd9b2011a8d519178569a49609a76c54c80c3b;hpb=25f84fa7e4b84c3db5ba745a7881c009b778e0b1;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index bbdd9b2..3aecc43 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} @@ -86,8 +87,13 @@ data DerivSpec = DS { ds_loc :: SrcSpan type EarlyDerivSpec = Either DerivSpec DerivSpec -- Left ds => the context for the instance should be inferred - -- (ds_theta is required) - -- Right ds => the context for the instance is supplied by the programmer + -- In this case ds_theta is the list of all the + -- constraints needed, such as (Eq [a], Eq a) + -- The inference process is to reduce this to a + -- simpler form (e.g. Eq a) + -- + -- Right ds => the exact context for the instance is supplied + -- by the programmer; it is ds_theta pprDerivSpec :: DerivSpec -> SDoc pprDerivSpec (DS { ds_loc = l, ds_name = n, ds_tvs = tvs, @@ -222,6 +228,9 @@ And then translate it to: Note [Newtype deriving superclasses] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +(See also Trac #1220 for an interesting exchange on newtype +deriving and superclasses.) + The 'tys' here come from the partial application in the deriving clause. The last arg is the new instance type. @@ -257,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 @@ -278,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 @@ -357,12 +366,12 @@ makeDerivSpecs :: [LTyClDecl Name] -> TcM [EarlyDerivSpec] makeDerivSpecs tycl_decls inst_decls deriv_decls - = do { eqns1 <- mapM deriveTyData $ + = do { eqns1 <- mapAndRecoverM deriveTyData $ extractTyDataPreds tycl_decls ++ [ pd -- traverse assoc data families | L _ (InstDecl _ _ _ ats) <- inst_decls , pd <- extractTyDataPreds ats ] - ; eqns2 <- mapM deriveStandalone deriv_decls + ; eqns2 <- mapAndRecoverM deriveStandalone deriv_decls ; return (catMaybes (eqns1 ++ eqns2)) } where extractTyDataPreds decls = @@ -418,36 +427,39 @@ deriveTyData _other ------------------------------------------------------------------ mkEqnHelp :: InstOrigin -> [TyVar] -> Class -> [Type] -> Type - -> Maybe ThetaType -- Just => context supplied - -- Nothing => context inferred + -> Maybe ThetaType -- Just => context supplied (standalone deriving) + -- Nothing => context inferred (deriving on data decl) -> TcRn (Maybe EarlyDerivSpec) mkEqnHelp orig tvs cls cls_tys tc_app mtheta | Just (tycon, tc_args) <- tcSplitTyConApp_maybe tc_app - = do { -- Make tc_app saturated, because that's what the - -- mkDataTypeEqn things expect - -- It might not be saturated in the standalone deriving case - -- derive instance Monad (T a) - let extra_tvs = dropList tc_args (tyConTyVars tycon) - full_tc_args = tc_args ++ mkTyVarTys extra_tvs - full_tvs = tvs ++ extra_tvs - - ; (rep_tc, rep_tc_args) <- tcLookupFamInstExact tycon full_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 - mkDataTypeEqn orig mayDeriveDataTypeable full_tvs cls cls_tys - tycon full_tc_args rep_tc rep_tc_args mtheta + mkDataTypeEqn orig mayDeriveDataTypeable tvs cls cls_tys + tycon tc_args rep_tc rep_tc_args mtheta else mkNewTypeEqn orig mayDeriveDataTypeable newtype_deriving - full_tvs cls cls_tys - tycon full_tc_args rep_tc rep_tc_args mtheta } + tvs cls cls_tys + tycon tc_args rep_tc rep_tc_args mtheta } | otherwise = baleOut (derivingThingErr cls cls_tys tc_app - (ptext SLIT("Last argument of the instance must be a type application"))) + (ptext (sLit "Last argument of the instance must be a type application"))) baleOut :: Message -> TcM (Maybe a) baleOut err = do { addErrTc err; return Nothing } @@ -501,27 +513,13 @@ mkDataTypeEqn orig mayDeriveDataTypeable tvs cls cls_tys = ASSERT( null cls_tys ) mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta -mk_data_eqn :: InstOrigin -> [TyVar] -> Class - -> TyCon -> [TcType] -> TyCon -> [TcType] -> Maybe ThetaType - -> TcM (Maybe EarlyDerivSpec) +mk_data_eqn, mk_typeable_eqn + :: InstOrigin -> [TyVar] -> Class + -> TyCon -> [TcType] -> TyCon -> [TcType] -> Maybe ThetaType + -> TcM (Maybe EarlyDerivSpec) mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta - | cls `hasKey` typeableClassKey - = -- The Typeable class is special in several ways - -- data T a b = ... deriving( Typeable ) - -- gives - -- instance Typeable2 T where ... - -- Notice that: - -- 1. There are no constraints in the instance - -- 2. There are no type variables either - -- 3. The actual class we want to generate isn't necessarily - -- Typeable; it depends on the arity of the type - do { real_clas <- tcLookupClass (typeableClassNames !! tyConArity tycon) - ; dfun_name <- new_dfun_name real_clas tycon - ; loc <- getSrcSpanM - ; return (Just $ Right $ - DS { ds_loc = loc, ds_orig = orig, ds_name = dfun_name, ds_tvs = [] - , ds_cls = real_clas, ds_tys = [mkTyConApp tycon []] - , ds_theta = mtheta `orElse` [], ds_newtype = False }) } + | getName cls `elem` typeableClassNames + = mk_typeable_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta | otherwise = do { dfun_name <- new_dfun_name cls tycon @@ -533,20 +531,51 @@ 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 ) + -- gives + -- instance Typeable2 T where ... + -- Notice that: + -- 1. There are no constraints in the instance + -- 2. There are no type variables either + -- 3. The actual class we want to generate isn't necessarily + -- Typeable; it depends on the arity of the type + | isNothing mtheta -- deriving on a data type decl + = do { checkTc (cls `hasKey` typeableClassKey) + (ptext (sLit "Use deriving( Typeable ) on a data type declaration")) + ; real_cls <- tcLookupClass (typeableClassNames !! tyConArity tycon) + ; mk_typeable_eqn orig tvs real_cls tycon [] rep_tc [] (Just []) } + + | otherwise -- standaone deriving + = do { checkTc (null tc_args) + (ptext (sLit "Derived typeable instance must be of form (Typeable") + <> int (tyConArity tycon) <+> ppr tycon <> rparen) + ; dfun_name <- new_dfun_name cls tycon + ; loc <- getSrcSpanM + ; return (Just $ Right $ + DS { ds_loc = loc, ds_orig = orig, ds_name = dfun_name, ds_tvs = [] + , ds_cls = cls, ds_tys = [mkTyConApp tycon []] + , ds_theta = mtheta `orElse` [], ds_newtype = False }) } + ------------------------------------------------------------------ -- Check side conditions that dis-allow derivability for particular classes -- This is *apart* from the newtype-deriving mechanism @@ -560,28 +589,27 @@ checkSideConditions mayDeriveDataTypeable cls cls_tys rep_tc | notNull cls_tys = Just ty_args_why -- e.g. deriving( Foo s ) | otherwise - = case [cond | (key,cond) <- sideConditions, key == getUnique cls] of - [] -> Just (non_std_why cls) - [cond] -> cond (mayDeriveDataTypeable, rep_tc) - _other -> pprPanic "checkSideConditions" (ppr cls) + = case sideConditions cls of + Just cond -> cond (mayDeriveDataTypeable, rep_tc) + Nothing -> Just non_std_why where - ty_args_why = quotes (ppr (mkClassPred cls cls_tys)) <+> ptext SLIT("is not a class") - -non_std_why :: Class -> SDoc -non_std_why cls = quotes (ppr cls) <+> ptext SLIT("is not a derivable class") - -sideConditions :: [(Unique, Condition)] -sideConditions - = [ (eqClassKey, cond_std), - (ordClassKey, cond_std), - (readClassKey, cond_std), - (showClassKey, cond_std), - (enumClassKey, cond_std `andCond` cond_isEnumeration), - (ixClassKey, cond_std `andCond` (cond_isEnumeration `orCond` cond_isProduct)), - (boundedClassKey, cond_std `andCond` (cond_isEnumeration `orCond` cond_isProduct)), - (typeableClassKey, cond_mayDeriveDataTypeable `andCond` cond_typeableOK), - (dataClassKey, cond_mayDeriveDataTypeable `andCond` cond_std) - ] + ty_args_why = quotes (ppr (mkClassPred cls cls_tys)) <+> ptext (sLit "is not a class") + non_std_why = quotes (ppr cls) <+> ptext (sLit "is not a derivable class") + +sideConditions :: Class -> Maybe Condition +sideConditions cls + | cls_key == eqClassKey = Just cond_std + | cls_key == ordClassKey = Just cond_std + | cls_key == readClassKey = Just cond_std + | cls_key == showClassKey = Just cond_std + | cls_key == enumClassKey = Just (cond_std `andCond` cond_isEnumeration) + | cls_key == ixClassKey = Just (cond_std `andCond` (cond_isEnumeration `orCond` cond_isProduct)) + | cls_key == boundedClassKey = Just (cond_std `andCond` (cond_isEnumeration `orCond` cond_isProduct)) + | cls_key == dataClassKey = Just (cond_mayDeriveDataTypeable `andCond` cond_std) + | getName cls `elem` typeableClassNames = Just (cond_mayDeriveDataTypeable `andCond` cond_typeableOK) + | otherwise = Nothing + where + cls_key = getUnique cls type Condition = (Bool, TyCon) -> Maybe SDoc -- Bool is whether or not we are allowed to derive Data and Typeable @@ -595,7 +623,7 @@ orCond c1 c2 tc Nothing -> Nothing -- c1 succeeds Just x -> case c2 tc of -- c1 fails Nothing -> Nothing - Just y -> Just (x $$ ptext SLIT(" and") $$ y) + Just y -> Just (x $$ ptext (sLit " and") $$ y) -- Both fail andCond :: Condition -> Condition -> Condition @@ -611,9 +639,9 @@ cond_std (_, rep_tc) where data_cons = tyConDataCons rep_tc no_cons_why = quotes (pprSourceTyCon rep_tc) <+> - ptext SLIT("has no data constructors") + ptext (sLit "has no data constructors") existential_why = quotes (pprSourceTyCon rep_tc) <+> - ptext SLIT("has non-Haskell-98 constructor(s)") + ptext (sLit "has non-Haskell-98 constructor(s)") cond_isEnumeration :: Condition cond_isEnumeration (_, rep_tc) @@ -621,7 +649,7 @@ cond_isEnumeration (_, rep_tc) | otherwise = Just why where why = quotes (pprSourceTyCon rep_tc) <+> - ptext SLIT("has non-nullary constructors") + ptext (sLit "has non-nullary constructors") cond_isProduct :: Condition cond_isProduct (_, rep_tc) @@ -629,7 +657,7 @@ cond_isProduct (_, rep_tc) | otherwise = Just why where why = quotes (pprSourceTyCon rep_tc) <+> - ptext SLIT("has more than one constructor") + ptext (sLit "has more than one constructor") cond_typeableOK :: Condition -- OK for Typeable class @@ -643,18 +671,18 @@ cond_typeableOK (_, rep_tc) | otherwise = Nothing where too_many = quotes (pprSourceTyCon rep_tc) <+> - ptext SLIT("has too many arguments") + ptext (sLit "has too many arguments") bad_kind = quotes (pprSourceTyCon rep_tc) <+> - ptext SLIT("has arguments of kind other than `*'") + ptext (sLit "has arguments of kind other than `*'") fam_inst = quotes (pprSourceTyCon rep_tc) <+> - ptext SLIT("is a type family") + ptext (sLit "is a type family") cond_mayDeriveDataTypeable :: Condition cond_mayDeriveDataTypeable (mayDeriveDataTypeable, _) | mayDeriveDataTypeable = Nothing | otherwise = Just why where - why = ptext SLIT("You need -fglasgow-exts to derive an instance for this class") + why = ptext (sLit "You need -XDeriveDataTypeable to derive an instance for this class") std_class_via_iso :: Class -> Bool std_class_via_iso clas -- These standard classes can be derived for a newtype @@ -671,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 ... + %************************************************************************ %* * @@ -707,7 +759,7 @@ mkNewTypeEqn orig mayDeriveDataTypeable newtype_deriving tvs mb_std_err = checkSideConditions mayDeriveDataTypeable cls cls_tys rep_tycon std_err = derivingThingErr cls cls_tys tc_app $ vcat [fromJust mb_std_err, - ptext SLIT("Try -XGeneralizedNewtypeDeriving for GHC's newtype-deriving extension")] + ptext (sLit "Try -XGeneralizedNewtypeDeriving for GHC's newtype-deriving extension")] -- Here is the plan for newtype derivings. We see -- newtype T a1...an = MkT (t ak+1...an) deriving (.., C s1 .. sm, ...) @@ -747,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, @@ -841,19 +893,19 @@ mkNewTypeEqn orig mayDeriveDataTypeable newtype_deriving tvs -- arguments must be type variables (not more complex indexes) cant_derive_err = derivingThingErr cls cls_tys tc_app - (vcat [ptext SLIT("even with cunning newtype deriving:"), + (vcat [ptext (sLit "even with cunning newtype deriving:"), if isRecursiveTyCon tycon then - ptext SLIT("the newtype may be recursive") + ptext (sLit "the newtype may be recursive") else empty, if not right_arity then - quotes (ppr (mkClassPred cls cls_tys)) <+> ptext SLIT("does not have arity 1") + quotes (ppr (mkClassPred cls cls_tys)) <+> ptext (sLit "does not have arity 1") else empty, if not (n_tyargs_to_keep >= 0) then - ptext SLIT("the type constructor has wrong kind") + ptext (sLit "the type constructor has wrong kind") else if not (n_args_to_keep >= 0) then - ptext SLIT("the representation type has wrong kind") + ptext (sLit "the representation type has wrong kind") else if not eta_ok then - ptext SLIT("the eta-reduction property does not hold") + ptext (sLit "the eta-reduction property does not hold") else empty ]) \end{code} @@ -1106,30 +1158,36 @@ genDerivBinds clas fix_env tycon \begin{code} derivingThingErr :: Class -> [Type] -> Type -> Message -> Message derivingThingErr clas tys ty why - = sep [hsep [ptext SLIT("Can't make a derived instance of"), + = sep [hsep [ptext (sLit "Can't make a derived instance of"), quotes (ppr pred)], nest 2 (parens 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 = ptext SLIT("In the stand-alone deriving instance for") <+> quotes (ppr ty) +standaloneCtxt ty = hang (ptext (sLit "In the stand-alone deriving instance for")) + 2 (quotes (ppr ty)) derivInstCtxt :: Class -> [Type] -> Message derivInstCtxt clas inst_tys - = ptext SLIT("When deriving the instance for") <+> parens (pprClassPred clas inst_tys) + = ptext (sLit "When deriving the instance for") <+> parens (pprClassPred clas inst_tys) badDerivedPred :: PredType -> Message badDerivedPred pred - = vcat [ptext SLIT("Can't derive instances where the instance context mentions"), - ptext SLIT("type variables that are not data type parameters"), - nest 2 (ptext SLIT("Offending constraint:") <+> ppr pred)] + = vcat [ptext (sLit "Can't derive instances where the instance context mentions"), + ptext (sLit "type variables that are not data type parameters"), + nest 2 (ptext (sLit "Offending constraint:") <+> ppr pred)] famInstNotFound :: TyCon -> [Type] -> Bool -> TcM a famInstNotFound tycon tys notExact = failWithTc (msg <+> quotes (pprTypeApp tycon (ppr tycon) tys)) where msg = ptext $ if notExact - then SLIT("No family instance exactly matching") - else SLIT("More than one family instance for") + then sLit "No family instance exactly matching" + else sLit "More than one family instance for" \end{code}