From 54e655536ecf7eba755b334058d5c22dab251bea Mon Sep 17 00:00:00 2001 From: Simon Peyton Jones Date: Mon, 7 Apr 2014 15:45:35 +0100 Subject: Derive Typable for promoted data constructors (Trac #8950) I got sucked into a significant refactoring of the way that Typeable instances are derived. This makes it simpler and more uniform. I also improved the documentation in the user manual. Typeable really is different to other classes, and now gets its own subsection. --- compiler/typecheck/TcDeriv.lhs | 257 +++++++++++---------- docs/users_guide/flags.xml | 2 +- docs/users_guide/glasgow_exts.xml | 93 +++++--- testsuite/tests/deriving/should_fail/T2604.stderr | 8 +- testsuite/tests/deriving/should_fail/T5863a.stderr | 8 +- testsuite/tests/parser/should_compile/T5682.hs | 2 +- 6 files changed, 203 insertions(+), 167 deletions(-) diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index 2f03b1fced..ce200b23ad 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -528,53 +528,46 @@ makeDerivSpecs :: Bool -> [LDerivDecl Name] -> TcM [EarlyDerivSpec] makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls - = do { eqns1 <- concatMapM (recoverM (return []) . deriveTyDecl) tycl_decls - ; eqns2 <- concatMapM (recoverM (return []) . deriveInstDecl) inst_decls - ; eqns3 <- mapAndRecoverM deriveStandalone deriv_decls - ; let eqns = eqns1 ++ eqns2 ++ eqns3 + = do { eqns1 <- concatMapM (recoverM (return []) . deriveTyDecl) tycl_decls + ; eqns2 <- concatMapM (recoverM (return []) . deriveInstDecl) inst_decls + ; eqns3 <- concatMapM (recoverM (return []) . deriveStandalone) deriv_decls -- If AutoDeriveTypeable is set, we automatically add Typeable instances -- for every data type and type class declared in the module - ; isAutoTypeable <- xoptM Opt_AutoDeriveTypeable - ; eqns4 <- if isAutoTypeable then concatMapM (deriveTypeable eqns) tycl_decls - else return [] - ; eqns4' <- setXOptM Opt_PolyKinds $ - mapAndRecoverM deriveStandalone eqns4 - ; let eqns' = eqns ++ eqns4' + ; auto_typeable <- xoptM Opt_AutoDeriveTypeable + ; eqns4 <- deriveAutoTypeable auto_typeable (eqns1 ++ eqns3) tycl_decls + + ; let eqns = eqns1 ++ eqns2 ++ eqns3 ++ eqns4 ; if is_boot then -- No 'deriving' at all in hs-boot files - do { unless (null eqns') (add_deriv_err (head eqns')) + do { unless (null eqns) (add_deriv_err (head eqns)) ; return [] } - else return eqns' } + else return eqns } where add_deriv_err eqn = setSrcSpan (earlyDSLoc eqn) $ addErr (hang (ptext (sLit "Deriving not permitted in hs-boot file")) 2 (ptext (sLit "Use an instance declaration instead"))) - deriveTypeable :: [EarlyDerivSpec] -> LTyClDecl Name -> TcM [LDerivDecl Name] - deriveTypeable dss (L l decl) - = do { tc <- tcLookupTyCon (tcdName decl) - ; let prom_dcs = mapMaybe promoteDataCon_maybe (tyConDataCons tc) - deriv_decls = mapMaybe mk_typeable_deriv_decl (tc : prom_dcs) - ; return deriv_decls } - - where - mk_typeable_deriv_decl :: TyCon -> Maybe (LDerivDecl Name) - mk_typeable_deriv_decl tc - | not (isSynTyCon tc) - , not (hasInstance tc) -- avoid duplicate instances - = Just $ L l (DerivDecl (L l (HsAppTy (noLoc (HsTyVar typeableClassName)) - (L l (HsTyVar (tyConName tc)))))) - | otherwise - = Nothing - +deriveAutoTypeable :: Bool -> [EarlyDerivSpec] -> [LTyClDecl Name] -> TcM [EarlyDerivSpec] +-- Runs over *all* TyCl declarations, including classes and data families +-- i.e. not just data type decls +deriveAutoTypeable auto_typeable done_specs tycl_decls + | not auto_typeable = return [] + | otherwise = do { cls <- tcLookupClass typeableClassName + ; concatMapM (do_one cls) tycl_decls } + where + done_tcs = mkNameSet [ tyConName (earlyDSTyCon spec) + | spec <- done_specs + , className (earlyDSClass spec) == typeableClassName ] -- Check if an automatically generated DS for deriving Typeable should be - -- ommitted because the user had manually requested for an instance - hasInstance :: TyCon -> Bool - hasInstance tc = any (\ds -> tc == earlyDSTyCon ds - && typeableClassName == className (earlyDSClass ds)) - dss + -- ommitted because the user had manually requested an instance + + do_one cls (L _ decl) + = do { tc <- tcLookupTyCon (tcdName decl) + ; if (isSynTyCon tc || tyConName tc `elemNameSet` done_tcs) + then return [] + else mkPolyKindedTypeableEqn cls tc } ------------------------------------------------------------------ deriveTyDecl :: LTyClDecl Name -> TcM [EarlyDerivSpec] @@ -584,8 +577,9 @@ deriveTyDecl (L _ decl@(DataDecl { tcdLName = L _ tc_name do { tc <- tcLookupTyCon tc_name ; let tvs = tyConTyVars tc tys = mkTyVarTys tvs + ; case preds of - Just preds' -> mapM (deriveTyData tvs tc tys) preds' + Just preds' -> concatMapM (deriveTyData False tvs tc tys) preds' Nothing -> return [] } deriveTyDecl _ = return [] @@ -606,7 +600,7 @@ deriveFamInst decl@(DataFamInstDecl { dfid_tycon = L _ tc_name, dfid_pats = pats do { fam_tc <- tcLookupTyCon tc_name ; tcFamTyPats tc_name (tyConKind fam_tc) pats (\_ -> return ()) $ \ tvs' pats' _ -> - mapM (deriveTyData tvs' fam_tc pats') preds } + concatMapM (deriveTyData True tvs' fam_tc pats') preds } -- Tiresomely we must figure out the "lhs", which is awkward for type families -- E.g. data T a b = .. deriving( Eq ) -- Here, the lhs is (T a b) @@ -618,7 +612,7 @@ deriveFamInst decl@(DataFamInstDecl { dfid_tycon = L _ tc_name, dfid_pats = pats deriveFamInst _ = return [] ------------------------------------------------------------------ -deriveStandalone :: LDerivDecl Name -> TcM EarlyDerivSpec +deriveStandalone :: LDerivDecl Name -> TcM [EarlyDerivSpec] -- Standalone deriving declarations -- e.g. deriving instance Show a => Show (T a) -- Rather like tcLocalInstDecl @@ -644,23 +638,70 @@ deriveStandalone (L loc (DerivDecl deriv_ty)) , text "type:" <+> ppr inst_ty ] ; case tcSplitTyConApp_maybe inst_ty of - Just (tycon, tc_args) - | className cls == typeableClassName || isAlgTyCon tycon - -> mkEqnHelp tvs cls cls_tys tycon tc_args (Just theta) + Just (tc, tc_args) + | className cls == typeableClassName -- Works for algebraic TyCons + -- _and_ data families + -> do { check_standalone_typeable theta tc tc_args + ; mkPolyKindedTypeableEqn cls tc } + + | isAlgTyCon tc -- All other classes + -> do { spec <- mkEqnHelp tvs cls cls_tys tc tc_args (Just theta) + ; return [spec] } _ -> -- Complain about functions, primitive types, etc, -- except for the Typeable class failWithTc $ derivingThingErr False cls cls_tys inst_ty $ ptext (sLit "The last argument of the instance must be a data or newtype application") } + where + check_standalone_typeable theta tc tc_args + -- We expect to see + -- deriving Typeable T + -- for some tycon T. But if S is kind-polymorphic, + -- say (S :: forall k. k -> *), we might see + -- deriving Typable (S k) + -- + -- But we should NOT see + -- deriving Typeable (T Int) + -- or deriving Typeable (S *) where S is kind-polymorphic + -- + -- So all the tc_args should be distinct kind variables + | null theta + , allDistinctTyVars tc_args + , all is_kind_var tc_args + = return () + + | otherwise + = do { polykinds <- xoptM Opt_PolyKinds + ; failWith (mk_msg polykinds theta tc tc_args) } + + is_kind_var tc_arg = case tcGetTyVar_maybe tc_arg of + Just v -> isKindVar v + Nothing -> False + + mk_msg polykinds theta tc tc_args + | not polykinds + , all isKind tc_args -- Non-empty, all kinds, at least one not a kind variable + , null theta + = hang (ptext (sLit "To make a Typeable instance of poly-kinded") + <+> quotes (ppr tc) <> comma) + 2 (ptext (sLit "use XPolyKinds")) + + | otherwise + = hang (ptext (sLit "Derived Typeable instance must be of form")) + 2 (ptext (sLit "deriving instance Typeable") <+> ppr tc) + ------------------------------------------------------------------ -deriveTyData :: [TyVar] -> TyCon -> [Type] -- LHS of data or data instance +deriveTyData :: Bool -- False <=> data/newtype + -- True <=> data/newtype *instance* + -> [TyVar] -> TyCon -> [Type] -- LHS of data or data instance -- Can be a data instance, hence [Type] args -> LHsType Name -- The deriving predicate - -> TcM EarlyDerivSpec + -> TcM [EarlyDerivSpec] -- The deriving clause of a data or newtype declaration -deriveTyData tvs tc tc_args (L loc deriv_pred) +-- I.e. not standalone deriving +deriveTyData is_instance tvs tc tc_args (L loc deriv_pred) = setSrcSpan loc $ -- Use the location of the 'deriving' item do { (deriv_tvs, cls, cls_tys) <- tcExtendTyVarEnv tvs $ tcHsDeriv deriv_pred @@ -673,11 +714,11 @@ deriveTyData tvs tc tc_args (L loc deriv_pred) -- so the argument kind 'k' is not decomposable by splitKindFunTys -- as is the case for all other derivable type classes ; if className cls == typeableClassName - then derivePolyKindedTypeable cls cls_tys tvs tc tc_args - else do { + then derivePolyKindedTypeable is_instance cls cls_tys tvs tc tc_args + else - -- Given data T a b c = ... deriving( C d ), - -- we want to drop type variables from T so that (C d (T a)) is well-kinded + do { -- Given data T a b c = ... deriving( C d ), + -- we want to drop type variables from T so that (C d (T a)) is well-kinded ; let cls_tyvars = classTyVars cls ; checkTc (not (null cls_tyvars)) derivingNullaryErr @@ -729,33 +770,29 @@ deriveTyData tvs tc tc_args (L loc deriv_pred) -- newtype T a s = ... deriving( ST s ) -- newtype K a a = ... deriving( Monad ) - ; mkEqnHelp (univ_kvs' ++ univ_tvs') - cls final_cls_tys tc final_tc_args Nothing } } + ; spec <- mkEqnHelp (univ_kvs' ++ univ_tvs') + cls final_cls_tys tc final_tc_args Nothing + ; return [spec] } } -derivePolyKindedTypeable :: Class -> [Type] +derivePolyKindedTypeable :: Bool -> Class -> [Type] -> [TyVar] -> TyCon -> [Type] - -> TcM EarlyDerivSpec -derivePolyKindedTypeable cls cls_tys _tvs tc tc_args - = do { checkTc (isSingleton cls_tys) $ -- Typeable k + -> TcM [EarlyDerivSpec] +-- The deriving( Typeable ) clause of a data/newtype decl +-- I.e. not standalone deriving +derivePolyKindedTypeable is_instance cls cls_tys _tvs tc tc_args + | is_instance + = failWith (sep [ ptext (sLit "Deriving Typeable is not allowed for family instances;") + , ptext (sLit "derive Typeable for") + <+> quotes (pprSourceTyCon tc) + <+> ptext (sLit "alone") ]) + + | otherwise + = ASSERT( allDistinctTyVars tc_args ) -- Came from a data/newtype decl + do { checkTc (isSingleton cls_tys) $ -- Typeable k derivingThingErr False cls cls_tys (mkTyConApp tc tc_args) (classArgsErr cls cls_tys) - -- Check that we have not said, for example - -- deriving Typeable (T Int) - -- or deriving Typeable (S :: * -> *) where S is kind-polymorphic - ; checkTc (allDistinctTyVars tc_args) $ - derivingEtaErr cls cls_tys (mkTyConApp tc tc_kind_args) - - ; mkEqnHelp kind_vars cls cls_tys tc tc_kind_args Nothing } - where - kind_vars = kindVarsOnly tc_args - tc_kind_args = mkTyVarTys kind_vars - - kindVarsOnly :: [Type] -> [KindVar] - kindVarsOnly [] = [] - kindVarsOnly (t:ts) | Just v <- getTyVar_maybe t - , isKindVar v = v : kindVarsOnly ts - | otherwise = kindVarsOnly ts + ; mkPolyKindedTypeableEqn cls tc } \end{code} Note [Unify kinds in deriving] @@ -833,12 +870,6 @@ mkEqnHelp tvs cls cls_tys tycon tc_args mtheta Just err -> bale_out err Nothing -> mkOldTypeableEqn tvs cls tycon tc_args mtheta } - | className cls == typeableClassName -- Polykinded Typeable - = do { dflags <- getDynFlags - ; case checkTypeableConditions (dflags, tycon, tc_args) of - Just err -> bale_out err - Nothing -> mkPolyKindedTypeableEqn tvs cls tycon tc_args mtheta } - | otherwise = do { (rep_tc, rep_tc_args) <- lookup_data_fam tycon tc_args -- Be careful to test rep_tc here: in the case of families, @@ -1045,43 +1076,34 @@ mkOldTypeableEqn tvs cls tycon tc_args mtheta , ds_tc = tycon, ds_tc_args = [] , ds_theta = mtheta `orElse` [], ds_newtype = False }) } -mkPolyKindedTypeableEqn :: [TyVar] -> Class - -> TyCon -> [TcType] -> DerivContext - -> TcM EarlyDerivSpec +mkPolyKindedTypeableEqn :: Class -> TyCon -> TcM [EarlyDerivSpec] -- We can arrive here from a 'deriving' clause -- or from standalone deriving -mkPolyKindedTypeableEqn tvs cls tycon tc_args mtheta - = do { -- Check that we have not said, for example - -- deriving Typeable (T Int) - -- or deriving Typeable (S :: * -> *) where S is kind-polymorphic - - polykinds <- xoptM Opt_PolyKinds - ; checkTc (all is_kind_var tc_args) (mk_msg polykinds) - ; dfun_name <- new_dfun_name cls tycon - ; loc <- getSrcSpanM - ; let tc_app = mkTyConApp tycon tc_args - ; return (GivenTheta $ - DS { ds_loc = loc, ds_name = dfun_name - , ds_tvs = filter isKindVar tvs, ds_cls = cls - , ds_tys = typeKind tc_app : [tc_app] - -- Remember, Typeable :: forall k. k -> * - , ds_tc = tycon, ds_tc_args = tc_args - , ds_theta = mtheta `orElse` [] -- Context is empty for polykinded Typeable - , ds_newtype = False }) } +mkPolyKindedTypeableEqn cls tc + = do { dflags <- getDynFlags -- It's awkward to re-used checkFlag here, + ; checkTc(xopt Opt_DeriveDataTypeable dflags) -- so we do a DIY job + (hang (ptext (sLit "Can't make a Typeable instance of") <+> quotes (ppr tc)) + 2 (ptext (sLit "You need DeriveDataTypeable to derive Typeable instances"))) + + ; loc <- getSrcSpanM + ; let prom_dcs = mapMaybe promoteDataCon_maybe (tyConDataCons tc) + ; mapM (mk_one loc) (tc : prom_dcs) } where - is_kind_var tc_arg = case tcGetTyVar_maybe tc_arg of - Just v -> isKindVar v - Nothing -> False - - mk_msg polykinds | not polykinds - , all isKind tc_args -- Non-empty, all kinds, at least one not a kind variable - = hang (ptext (sLit "To make a Typeable instance of poly-kinded") - <+> quotes (ppr tycon) <> comma) - 2 (ptext (sLit "use XPolyKinds")) - | otherwise - = ptext (sLit "Derived Typeable instance must be of form") - <+> parens (ptext (sLit "Typeable") <+> ppr tycon) - + mk_one loc tc = do { traceTc "mkPolyKindedTypeableEqn" (ppr tc) + ; dfun_name <- new_dfun_name cls tc + ; return $ GivenTheta $ + DS { ds_loc = loc, ds_name = dfun_name + , ds_tvs = kvs, ds_cls = cls + , ds_tys = [tc_app_kind, tc_app] + -- Remember, Typeable :: forall k. k -> * + -- so we must instantiate it appropiately + , ds_tc = tc, ds_tc_args = tc_args + , ds_theta = [] -- Context is empty for polykinded Typeable + , ds_newtype = False } } + where + (kvs,tc_app_kind) = splitForAllTys (tyConKind tc) + tc_args = mkTyVarTys kvs + tc_app = mkTyConApp tc tc_args inferConstraints :: Class -> [TcType] -> TyCon -> [TcType] @@ -1205,8 +1227,7 @@ checkSideConditions dflags mtheta cls cls_tys rep_tc rep_tc_args classArgsErr :: Class -> [Type] -> SDoc classArgsErr cls cls_tys = quotes (ppr (mkClassPred cls cls_tys)) <+> ptext (sLit "is not a class") -checkTypeableConditions, checkOldTypeableConditions :: Condition -checkTypeableConditions = checkFlag Opt_DeriveDataTypeable `andCond` cond_TypeableOK +checkOldTypeableConditions :: Condition checkOldTypeableConditions = checkFlag Opt_DeriveDataTypeable `andCond` cond_oldTypeableOK nonStdErr :: Class -> SDoc @@ -1368,20 +1389,6 @@ cond_oldTypeableOK (_, tc, _) bad_kind = quotes (pprSourceTyCon tc) <+> ptext (sLit "must only have arguments of kind `*'") -cond_TypeableOK :: Condition --- Only not ok if it's a data instance -cond_TypeableOK (_, tc, tc_args) - | isDataFamilyTyCon tc && not (null tc_args) - = Just no_families - - | otherwise - = Nothing - where - no_families = sep [ ptext (sLit "Deriving Typeable is not allowed for family instances;") - , ptext (sLit "derive Typeable for") - <+> quotes (pprSourceTyCon tc) - <+> ptext (sLit "alone") ] - functorLikeClassKeys :: [Unique] functorLikeClassKeys = [functorClassKey, foldableClassKey, traversableClassKey] diff --git a/docs/users_guide/flags.xml b/docs/users_guide/flags.xml index 6acd28dc0a..0ad6fc2f6c 100644 --- a/docs/users_guide/flags.xml +++ b/docs/users_guide/flags.xml @@ -745,7 +745,7 @@ - Automatically derive Typeable instances for every datatype and type class declaration. + Automatically derive Typeable instances for every datatype and type class declaration. Implies . dynamic diff --git a/docs/users_guide/glasgow_exts.xml b/docs/users_guide/glasgow_exts.xml index 33124122ef..44f0d98ab2 100644 --- a/docs/users_guide/glasgow_exts.xml +++ b/docs/users_guide/glasgow_exts.xml @@ -3842,9 +3842,8 @@ GHC always treats the last parameter of the instance - - -Deriving clause for extra classes (<literal>Typeable</literal>, <literal>Data</literal>, etc) + +Deriving instances of extra classes (<literal>Data</literal>, etc) Haskell 98 allows the programmer to add "deriving( Eq, Ord )" to a data type @@ -3856,27 +3855,6 @@ classes Eq, Ord, GHC extends this list with several more classes that may be automatically derived: - With , you can derive instances of the classes -Typeable, and Data, defined in the library -modules Data.Typeable and Data.Data respectively. - -Since GHC 7.8.1, Typeable is kind-polymorphic (see -) and can be derived for any datatype and -type class. Instances for datatypes can be derived by attaching a -deriving Typeable clause to the datatype declaration, or by -using standalone deriving (see ). -Instances for type classes can only be derived using standalone deriving. -For data families, Typeable should only be derived for the -uninstantiated family type; each instance will then automatically have a -Typeable instance too. -See also . - - -Also since GHC 7.8.1, handwritten (ie. not derived) instances of -Typeable are forbidden, and will result in an error. - - - With , you can derive instances of the classes Generic and Generic1, defined in GHC.Generics. @@ -3889,6 +3867,12 @@ the class Functor, defined in GHC.Base. + With , you can derive instances of +the class Data, +defined in Data.Data. See for +deriving Typeable. + + With , you can derive instances of the class Foldable, defined in Data.Foldable. @@ -3899,21 +3883,66 @@ the class Traversable, defined in Data.Traversable. +You can also use a standalone deriving declaration instead +(see ). + + In each case the appropriate class must be in scope before it can be mentioned in the deriving clause. - -Automatically deriving <literal>Typeable</literal> instances + +Deriving <literal>Typeable</literal> instances - +The class Typeable is very special: + + +Typeable is kind-polymorphic (see +). + + + +Only derived instances of Typeable are allowed; +i.e. handwritten instances are forbidden. This ensures that the +programmer cannot subert the type system by writing bogus instances. + + + +With +GHC allows you to derive instances of Typeable for data types or newtypes, +using a deriving clause, or using +a standalone deriving declaration (). + + + +With , deriving Typeable for a data +type (whether via a deriving clause or standalone deriving) +also derives Typeable for the promoted data constructors (). + + + +However, using standalone deriving, you can also derive +a Typeable instance for a data family. +You may not add a deriving(Typeable) clause to a +data instance declaration; instead you must use a +standalone deriving declaration for the data family. + + + +Using standalone deriving, you can also derive +a Typeable instance for a type class. + + + The flag triggers the generation -of derived Typeable instances for every datatype and type -class declaration in the module it is used. It will also generate -Typeable instances for any promoted data constructors -(). This flag implies - (). +of derived Typeable instances for every datatype, data family, +and type class declaration in the module it is used, unless a manually-specified one is +already provided. +This flag implies . + + + diff --git a/testsuite/tests/deriving/should_fail/T2604.stderr b/testsuite/tests/deriving/should_fail/T2604.stderr index 1479a141fa..3000b5002f 100644 --- a/testsuite/tests/deriving/should_fail/T2604.stderr +++ b/testsuite/tests/deriving/should_fail/T2604.stderr @@ -1,10 +1,10 @@ T2604.hs:7:35: - Can't make a derived instance of ‘Typeable DList’: - You need DeriveDataTypeable to derive an instance for this class + Can't make a Typeable instance of ‘DList’ + You need DeriveDataTypeable to derive Typeable instances In the data declaration for ‘DList’ T2604.hs:9:38: - Can't make a derived instance of ‘Typeable NList’: - You need DeriveDataTypeable to derive an instance for this class + Can't make a Typeable instance of ‘NList’ + You need DeriveDataTypeable to derive Typeable instances In the newtype declaration for ‘NList’ diff --git a/testsuite/tests/deriving/should_fail/T5863a.stderr b/testsuite/tests/deriving/should_fail/T5863a.stderr index 1bd2c77ac7..d64f1b20ce 100644 --- a/testsuite/tests/deriving/should_fail/T5863a.stderr +++ b/testsuite/tests/deriving/should_fail/T5863a.stderr @@ -1,10 +1,10 @@ T5863a.hs:9:31: - Cannot eta-reduce to an instance of form - instance (...) => Typeable T + Deriving Typeable is not allowed for family instances; + derive Typeable for ‘T’ alone In the data instance declaration for ‘T’ T5863a.hs:12:32: - Cannot eta-reduce to an instance of form - instance (...) => Typeable T + Deriving Typeable is not allowed for family instances; + derive Typeable for ‘T’ alone In the data instance declaration for ‘T’ diff --git a/testsuite/tests/parser/should_compile/T5682.hs b/testsuite/tests/parser/should_compile/T5682.hs index cdfe46f229..c5510edc8f 100644 --- a/testsuite/tests/parser/should_compile/T5682.hs +++ b/testsuite/tests/parser/should_compile/T5682.hs @@ -10,4 +10,4 @@ data Foo = Bool :+: Bool type X = True ':+: False deriving instance Typeable '(:+:) -deriving instance Typeable '(,,) + -- cgit v1.2.1