From 25f84fa7e4b84c3db5ba745a7881c009b778e0b1 Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Wed, 5 Sep 2007 17:07:30 +0000 Subject: [PATCH] Refactor, improve, and document the deriving mechanism This patch does a fairly major clean-up of the code that implements 'deriving. * The big changes are in TcDeriv, which is dramatically cleaned up. In particular, there is a clear split into a) inference of instance contexts for deriving clauses b) generation of the derived code, given a context Step (a) is skipped for standalone instance decls, which have an explicitly provided context. * The handling of "taggery", which is cooperative between TcDeriv and TcGenDeriv, is cleaned up a lot * I have added documentation for standalone deriving (which was previously wrong). * The Haskell report is vague on exactly when a deriving clause should succeed. Prodded by Conal I have loosened the rules slightly, thereyb making drv015 work again, and documented the rules in the user manual. I believe this patch validates ok (once I've update the test suite) and can go into the 6.8 branch. --- compiler/typecheck/TcDeriv.lhs | 544 +++++++++++++++++-------------------- compiler/typecheck/TcEnv.lhs | 16 +- compiler/typecheck/TcGenDeriv.lhs | 226 ++++++++------- compiler/typecheck/TcInstDcls.lhs | 132 +++++---- compiler/typecheck/TcMType.lhs | 71 ++++- compiler/typecheck/TcSimplify.lhs | 49 +--- compiler/types/TyCon.lhs | 21 +- compiler/types/Type.lhs | 10 +- docs/users_guide/flags.xml | 16 +- docs/users_guide/glasgow_exts.xml | 263 ++++++++++-------- 10 files changed, 697 insertions(+), 651 deletions(-) diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index c992dac..bbdd9b2 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -6,13 +6,6 @@ Handles @deriving@ clauses on @data@ declarations. \begin{code} -{-# OPTIONS -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details - module TcDeriv ( tcDeriving ) where #include "HsVersions.h" @@ -58,10 +51,54 @@ import Bag %************************************************************************ %* * -\subsection[TcDeriv-intro]{Introduction to how we do deriving} + Overview %* * %************************************************************************ +Overall plan +~~~~~~~~~~~~ +1. Convert the decls (i.e. data/newtype deriving clauses, + plus standalone deriving) to [EarlyDerivSpec] + +2. Infer the missing contexts for the Left DerivSpecs + +3. Add the derived bindings, generating InstInfos + +\begin{code} +-- DerivSpec is purely local to this module +data DerivSpec = DS { ds_loc :: SrcSpan + , ds_orig :: InstOrigin + , ds_name :: Name + , ds_tvs :: [TyVar] + , ds_theta :: ThetaType + , ds_cls :: Class + , ds_tys :: [Type] + , ds_newtype :: Bool } + -- This spec implies a dfun declaration of the form + -- df :: forall tvs. theta => C tys + -- The Name is the name for the DFun we'll build + -- The tyvars bind all the variables in the theta + -- For family indexes, the tycon is the *family* tycon + -- (not the representation tycon) + + -- ds_newtype = True <=> Newtype deriving + -- False <=> Vanilla deriving + +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 + +pprDerivSpec :: DerivSpec -> SDoc +pprDerivSpec (DS { ds_loc = l, ds_name = n, ds_tvs = tvs, + ds_cls = c, ds_tys = tys, ds_theta = rhs }) + = parens (hsep [ppr l, ppr n, ppr tvs, ppr c, ppr tys] + <+> equals <+> ppr rhs) +\end{code} + + +Inferring missing contexts +~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider data T a b = C1 (Foo a) (Bar b) @@ -140,27 +177,9 @@ this by simplifying the RHS to a form in which So, here are the synonyms for the ``equation'' structures: -\begin{code} -type DerivRhs = ThetaType -type DerivSoln = DerivRhs -type DerivEqn = (SrcSpan, InstOrigin, Name, [TyVar], Class, Type, DerivRhs) - -- (span, orig, df, tvs, C, ty, rhs) - -- implies a dfun declaration of the form - -- df :: forall tvs. rhs => C ty - -- The Name is the name for the DFun we'll build - -- The tyvars bind all the variables in the RHS - -- For family indexes, the tycon is the *family* tycon - -- (not the representation tycon) - -pprDerivEqn :: DerivEqn -> SDoc -pprDerivEqn (l, _, n, tvs, c, ty, rhs) - = parens (hsep [ppr l, ppr n, ppr tvs, ppr c, ppr ty] - <+> equals <+> ppr rhs) -\end{code} - -[Data decl contexts] A note about contexts on data decls -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [Data decl contexts] +~~~~~~~~~~~~~~~~~~~~~~~~~ Consider data (RealFloat a) => Complex a = !a :+ !a deriving( Read ) @@ -187,8 +206,8 @@ pattern matching against a constructor from a data type with a context gives rise to the constraints for that context -- or at least the thinned version. So now all classes are "offending". -[Newtype deriving] -~~~~~~~~~~~~~~~~~~ +Note [Newtype deriving] +~~~~~~~~~~~~~~~~~~~~~~~ Consider this: class C a b instance C [a] Char @@ -201,6 +220,27 @@ And then translate it to: instance C [a] Char => C [a] T where ... +Note [Newtype deriving superclasses] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The 'tys' here come from the partial application in the deriving +clause. The last arg is the new instance type. + +We must pass the superclasses; the newtype might be an instance +of them in a different way than the representation type +E.g. newtype Foo a = Foo a deriving( Show, Num, Eq ) +Then the Show instance is not done via isomorphism; it shows + Foo 3 as "Foo 3" +The Num instance is derived via isomorphism, but the Show superclass +dictionary must the Show instance for Foo, *not* the Show dictionary +gotten from the Num dictionary. So we must build a whole new dictionary +not just use the Num one. The instance we want is something like: + instance (Num a, Show (Foo a), Eq (Foo a)) => Num (Foo a) where + (+) = ((+)@a) + ...etc... +There may be a coercion needed which we get from the tycon for the newtype +when the dict is constructed in TcInstDcls.tcInstDecl2 + + %************************************************************************ @@ -219,78 +259,65 @@ tcDeriving :: [LTyClDecl Name] -- All type constructors tcDeriving tycl_decls inst_decls deriv_decls = recoverM (returnM ([], emptyValBindsOut)) $ do { -- Fish the "deriving"-related information out of the TcEnv - -- and make the necessary "equations". - ; (ordinary_eqns, newtype_inst_info) - <- makeDerivEqns tycl_decls inst_decls deriv_decls - - ; (ordinary_inst_info, deriv_binds) - <- extendLocalInstEnv (map iSpec newtype_inst_info) $ - deriveOrdinaryStuff ordinary_eqns - -- Add the newtype-derived instances to the inst env - -- before tacking the "ordinary" ones + -- And make the necessary "equations". + ; early_specs <- makeDerivSpecs tycl_decls inst_decls deriv_decls - ; let inst_info = newtype_inst_info ++ ordinary_inst_info + ; overlap_flag <- getOverlapFlag + ; let (infer_specs, given_specs) = splitEithers early_specs + ; (insts1, aux_binds1) <- mapAndUnzipM (genInst overlap_flag) given_specs - -- If we are compiling a hs-boot file, - -- don't generate any derived bindings - ; is_boot <- tcIsHsBoot - ; if is_boot then - return (inst_info, emptyValBindsOut) - else do - { + ; final_specs <- extendLocalInstEnv (map iSpec insts1) $ + inferInstanceContexts overlap_flag infer_specs - -- Generate the generic to/from functions from each type declaration - ; gen_binds <- mkGenericBinds tycl_decls + ; (insts2, aux_binds2) <- mapAndUnzipM (genInst overlap_flag) final_specs - -- Rename these extra bindings, discarding warnings about unused bindings etc - -- Type signatures in patterns are used in the generic binds - ; rn_binds - <- discardWarnings $ - setOptM Opt_PatternSignatures $ - do - { (rn_deriv, _dus1) <- rnTopBinds (ValBindsIn deriv_binds []) - ; (rn_gen, dus_gen) <- rnTopBinds (ValBindsIn gen_binds []) - ; keepAliveSetTc (duDefs dus_gen) -- Mark these guys to - -- be kept alive - ; return (rn_deriv `plusHsValBinds` rn_gen) } + ; is_boot <- tcIsHsBoot + ; rn_binds <- makeAuxBinds is_boot tycl_decls + (concat aux_binds1 ++ concat aux_binds2) + ; let inst_info = insts1 ++ insts2 ; dflags <- getDOpts ; ioToTcRn (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances" (ddump_deriving inst_info rn_binds)) - ; returnM (inst_info, rn_binds) - }} + ; return (inst_info, rn_binds) } where ddump_deriving :: [InstInfo] -> HsValBinds Name -> SDoc ddump_deriving inst_infos extra_binds = vcat (map pprInstInfoDetails inst_infos) $$ ppr extra_binds ------------------------------------------ -deriveOrdinaryStuff [] -- Short cut - = returnM ([], emptyLHsBinds) +makeAuxBinds :: Bool -> [LTyClDecl Name] -> DerivAuxBinds -> TcM (HsValBinds Name) +makeAuxBinds is_boot tycl_decls deriv_aux_binds + | is_boot -- If we are compiling a hs-boot file, + -- don't generate any derived bindings + = return emptyValBindsOut -deriveOrdinaryStuff eqns - = do { -- Take the equation list and solve it, to deliver a list of - -- solutions, a.k.a. the contexts for the instance decls - -- required for the corresponding equations. - overlap_flag <- getOverlapFlag - ; inst_specs <- solveDerivEqns overlap_flag eqns - - -- Generate the InstInfo for each dfun, - -- plus any auxiliary bindings it needs - ; (inst_infos, aux_binds_s) <- mapAndUnzipM genInst inst_specs + | otherwise + = do { let aux_binds = listToBag (map genAuxBind (rm_dups [] deriv_aux_binds)) + -- Generate any extra not-one-inst-decl-specific binds, + -- notably "con2tag" and/or "tag2con" functions. - -- Generate any extra not-one-inst-decl-specific binds, - -- notably "con2tag" and/or "tag2con" functions. - ; extra_binds <- genTaggeryBinds inst_infos + -- Generate the generic to/from functions from each type declaration + ; gen_binds <- mkGenericBinds tycl_decls - -- Done - ; returnM (map fst inst_infos, - unionManyBags (extra_binds : aux_binds_s)) - } + -- Rename these extra bindings, discarding warnings about unused bindings etc + -- Type signatures in patterns are used in the generic binds + ; discardWarnings $ + setOptM Opt_PatternSignatures $ + do { (rn_deriv, _dus1) <- rnTopBinds (ValBindsIn aux_binds []) + ; (rn_gen, dus_gen) <- rnTopBinds (ValBindsIn gen_binds []) + ; keepAliveSetTc (duDefs dus_gen) -- Mark these guys to + -- be kept alive + ; return (rn_deriv `plusHsValBinds` rn_gen) } } + where + -- Remove duplicate requests for auxilliary bindings + rm_dups acc [] = acc + rm_dups acc (b:bs) | any (isDupAux b) acc = rm_dups acc bs + | otherwise = rm_dups (b:acc) bs ----------------------------------------- +mkGenericBinds :: [LTyClDecl Name] -> TcM (LHsBinds RdrName) mkGenericBinds tycl_decls = do { tcs <- mapM tcLookupTyCon [ tc_name | @@ -304,11 +331,11 @@ mkGenericBinds tycl_decls %************************************************************************ %* * -\subsection[TcDeriv-eqns]{Forming the equations} + From HsSyn to DerivSpec %* * %************************************************************************ -@makeDerivEqns@ fishes around to find the info about needed derived +@makeDerivSpecs@ fishes around to find the info about needed derived instances. Complicating factors: \begin{itemize} \item @@ -323,50 +350,27 @@ or} has just one data constructor (e.g., tuples). [See Appendix~E in the Haskell~1.2 report.] This code here deals w/ all those. -Note [Newtype deriving superclasses] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The 'tys' here come from the partial application in the deriving -clause. The last arg is the new instance type. - -We must pass the superclasses; the newtype might be an instance -of them in a different way than the representation type -E.g. newtype Foo a = Foo a deriving( Show, Num, Eq ) -Then the Show instance is not done via isomorphism; it shows - Foo 3 as "Foo 3" -The Num instance is derived via isomorphism, but the Show superclass -dictionary must the Show instance for Foo, *not* the Show dictionary -gotten from the Num dictionary. So we must build a whole new dictionary -not just use the Num one. The instance we want is something like: - instance (Num a, Show (Foo a), Eq (Foo a)) => Num (Foo a) where - (+) = ((+)@a) - ...etc... -There may be a coercion needed which we get from the tycon for the newtype -when the dict is constructed in TcInstDcls.tcInstDecl2 - - \begin{code} -makeDerivEqns :: [LTyClDecl Name] - -> [LInstDecl Name] - -> [LDerivDecl Name] - -> TcM ([DerivEqn], -- Ordinary derivings - [InstInfo]) -- Special newtype derivings +makeDerivSpecs :: [LTyClDecl Name] + -> [LInstDecl Name] + -> [LDerivDecl Name] + -> TcM [EarlyDerivSpec] -makeDerivEqns tycl_decls inst_decls deriv_decls +makeDerivSpecs tycl_decls inst_decls deriv_decls = do { eqns1 <- mapM deriveTyData $ extractTyDataPreds tycl_decls ++ [ pd -- traverse assoc data families | L _ (InstDecl _ _ _ ats) <- inst_decls , pd <- extractTyDataPreds ats ] ; eqns2 <- mapM deriveStandalone deriv_decls - ; return ([eqn | (Just eqn, _) <- eqns1 ++ eqns2], - [inst | (_, Just inst) <- eqns1 ++ eqns2]) } + ; return (catMaybes (eqns1 ++ eqns2)) } where extractTyDataPreds decls = [(p, d) | d@(L _ (TyData {tcdDerivs = Just preds})) <- decls, p <- preds] ------------------------------------------------------------------ -deriveStandalone :: LDerivDecl Name -> TcM (Maybe DerivEqn, Maybe InstInfo) +deriveStandalone :: LDerivDecl Name -> TcM (Maybe EarlyDerivSpec) -- Standalone deriving declarations -- e.g. deriving instance show a => Show (T a) -- Rather like tcLocalInstDecl @@ -391,7 +395,7 @@ deriveStandalone (L loc (DerivDecl deriv_ty)) (Just theta) } ------------------------------------------------------------------ -deriveTyData :: (LHsType Name, LTyClDecl Name) -> TcM (Maybe DerivEqn, Maybe InstInfo) +deriveTyData :: (LHsType Name, LTyClDecl Name) -> TcM (Maybe EarlyDerivSpec) deriveTyData (deriv_pred, L loc decl@(TyData { tcdLName = L _ tycon_name, tcdTyVars = tv_names, tcdTyPats = ty_pats })) @@ -408,13 +412,15 @@ deriveTyData (deriv_pred, L loc decl@(TyData { tcdLName = L _ tycon_name, -- The "deriv_pred" is a LHsType to take account of the fact that for -- newtype deriving we allow deriving (forall a. C [a]). ; mkEqnHelp DerivOrigin (tvs++deriv_tvs) cls cls_tys tc_app Nothing } } -deriveTyData (deriv_pred, other_decl) + +deriveTyData _other = panic "derivTyData" -- Caller ensures that only TyData can happen ------------------------------------------------------------------ mkEqnHelp :: InstOrigin -> [TyVar] -> Class -> [Type] -> Type - -> Maybe DerivRhs - -> TcRn (Maybe DerivEqn, Maybe InstInfo) + -> Maybe ThetaType -- Just => context supplied + -- Nothing => context inferred + -> 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 @@ -429,7 +435,6 @@ mkEqnHelp orig tvs cls cls_tys tc_app mtheta ; mayDeriveDataTypeable <- doptM Opt_DeriveDataTypeable ; newtype_deriving <- doptM Opt_GeneralizedNewtypeDeriving - ; overlap_flag <- getOverlapFlag -- Be careful to test rep_tc here: in the case of families, we want -- to check the instance tycon, not the family tycon @@ -437,14 +442,15 @@ mkEqnHelp orig tvs cls cls_tys tc_app mtheta mkDataTypeEqn orig mayDeriveDataTypeable full_tvs cls cls_tys tycon full_tc_args rep_tc rep_tc_args mtheta else - mkNewTypeEqn orig mayDeriveDataTypeable newtype_deriving overlap_flag - full_tvs cls cls_tys - tycon full_tc_args rep_tc rep_tc_args mtheta } + mkNewTypeEqn orig mayDeriveDataTypeable newtype_deriving + full_tvs cls cls_tys + tycon full_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"))) -baleOut err = addErrTc err >> returnM (Nothing, Nothing) +baleOut :: Message -> TcM (Maybe a) +baleOut err = do { addErrTc err; return Nothing } \end{code} Auxiliary lookup wrapper which requires that looked up family instances are @@ -482,8 +488,9 @@ tcLookupFamInstExact tycon tys \begin{code} mkDataTypeEqn :: InstOrigin -> Bool -> [Var] -> Class -> [Type] - -> TyCon -> [Type] -> TyCon -> [Type] -> Maybe DerivRhs - -> TcRn (Maybe DerivEqn, Maybe InstInfo) + -> TyCon -> [Type] -> TyCon -> [Type] -> Maybe ThetaType + -> TcRn (Maybe EarlyDerivSpec) -- Return 'Nothing' if error + mkDataTypeEqn orig mayDeriveDataTypeable tvs cls cls_tys tycon tc_args rep_tc rep_tc_args mtheta | Just err <- checkSideConditions mayDeriveDataTypeable cls cls_tys rep_tc @@ -492,15 +499,12 @@ mkDataTypeEqn orig mayDeriveDataTypeable tvs cls cls_tys | otherwise = ASSERT( null cls_tys ) - do { loc <- getSrcSpanM - ; eqn <- mk_data_eqn loc orig tvs cls tycon tc_args rep_tc - rep_tc_args mtheta - ; return (Just eqn, Nothing) } - -mk_data_eqn :: SrcSpan -> InstOrigin -> [TyVar] -> Class - -> TyCon -> [TcType] -> TyCon -> [TcType] -> Maybe DerivRhs - -> TcM DerivEqn -mk_data_eqn loc orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta + 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 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 ) @@ -513,27 +517,35 @@ mk_data_eqn loc orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta -- Typeable; it depends on the arity of the type do { real_clas <- tcLookupClass (typeableClassNames !! tyConArity tycon) ; dfun_name <- new_dfun_name real_clas tycon - ; let theta = fromMaybe [] mtheta - ; return (loc, orig, dfun_name, [], real_clas, mkTyConApp tycon [], theta) - } + ; 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 }) } | otherwise = do { dfun_name <- new_dfun_name cls tycon + ; loc <- getSrcSpanM ; let ordinary_constraints = [ mkClassPred cls [arg_ty] | data_con <- tyConDataCons rep_tc, arg_ty <- ASSERT( isVanillaDataCon data_con ) dataConInstOrigArgTys data_con rep_tc_args, not (isUnLiftedType arg_ty) ] -- No constraints for unlifted types? - theta = fromMaybe ordinary_constraints mtheta - tiresome_subst = zipTopTvSubst (tyConTyVars rep_tc) rep_tc_args - stupid_constraints = substTheta tiresome_subst (tyConStupidTheta rep_tc) - -- see note [Data decl contexts] above + 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 - ; return (loc, orig, dfun_name, tvs, cls, mkTyConApp tycon tc_args, - stupid_constraints ++ theta) - } + 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_theta = mtheta `orElse` all_constraints + , ds_newtype = False } + + ; return (if isJust mtheta then Just (Right spec) -- Specified context + else Just (Left spec)) } -- Infer context ------------------------------------------------------------------ -- Check side conditions that dis-allow derivability for particular classes @@ -551,10 +563,11 @@ checkSideConditions mayDeriveDataTypeable cls cls_tys rep_tc = case [cond | (key,cond) <- sideConditions, key == getUnique cls] of [] -> Just (non_std_why cls) [cond] -> cond (mayDeriveDataTypeable, rep_tc) - other -> pprPanic "checkSideConditions" (ppr cls) + _other -> pprPanic "checkSideConditions" (ppr cls) 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)] @@ -585,6 +598,7 @@ orCond c1 c2 tc Just y -> Just (x $$ ptext SLIT(" and") $$ y) -- Both fail +andCond :: Condition -> Condition -> Condition andCond c1 c2 tc = case c1 tc of Nothing -> c2 tc -- c1 succeeds Just x -> Just x -- c1 fails @@ -642,6 +656,7 @@ cond_mayDeriveDataTypeable (mayDeriveDataTypeable, _) where why = ptext SLIT("You need -fglasgow-exts 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 -- using the isomorphism trick *even if no -fglasgow-exts* = classKey clas `elem` [eqClassKey, ordClassKey, ixClassKey, boundedClassKey] @@ -649,6 +664,7 @@ std_class_via_iso clas -- These standard classes can be derived for a newtype -- Not Enum, because newtypes are never in Enum +new_dfun_name :: Class -> TyCon -> TcM Name new_dfun_name clas tycon -- Just a simple wrapper = newDFunName clas [mkTyConApp tycon []] (getSrcSpan tycon) -- The type passed to newDFunName is only used to generate @@ -663,28 +679,30 @@ new_dfun_name clas tycon -- Just a simple wrapper %************************************************************************ \begin{code} -mkNewTypeEqn :: InstOrigin -> Bool -> Bool -> OverlapFlag -> [Var] -> Class +mkNewTypeEqn :: InstOrigin -> Bool -> Bool -> [Var] -> Class -> [Type] -> TyCon -> [Type] -> TyCon -> [Type] - -> Maybe DerivRhs - -> TcRn (Maybe DerivEqn, Maybe InstInfo) -mkNewTypeEqn orig mayDeriveDataTypeable newtype_deriving overlap_flag tvs + -> Maybe ThetaType + -> TcRn (Maybe EarlyDerivSpec) +mkNewTypeEqn orig mayDeriveDataTypeable newtype_deriving tvs cls cls_tys tycon tc_args rep_tycon rep_tc_args mtheta | can_derive_via_isomorphism && (newtype_deriving || std_class_via_iso cls) = do { traceTc (text "newtype deriving:" <+> ppr tycon <+> ppr rep_tys) - ; -- Go ahead and use the isomorphism - dfun_name <- new_dfun_name cls tycon - ; return (Nothing, Just (InstInfo { iSpec = mk_inst_spec dfun_name, - iBinds = NewTypeDerived ntd_info })) } + ; dfun_name <- new_dfun_name cls tycon + ; loc <- getSrcSpanM + ; let spec = DS { ds_loc = loc, ds_orig = orig + , ds_name = dfun_name, ds_tvs = dict_tvs + , ds_cls = cls, ds_tys = inst_tys + , ds_theta = mtheta `orElse` all_preds + , ds_newtype = True } + ; return (if isJust mtheta then Just (Right spec) + else Just (Left spec)) } | isNothing mb_std_err -- Use the standard H98 method - = do { loc <- getSrcSpanM - ; eqn <- mk_data_eqn loc orig tvs cls tycon tc_args rep_tycon - rep_tc_args mtheta - ; return (Just eqn, Nothing) } + = mk_data_eqn orig tvs cls tycon tc_args rep_tycon rep_tc_args mtheta -- Otherwise we can't derive | newtype_deriving = baleOut cant_derive_err -- Too hard - | otherwise = baleOut std_err -- Just complain about being a non-std instance + | otherwise = baleOut std_err -- Just complain about being a non-std instance where mb_std_err = checkSideConditions mayDeriveDataTypeable cls cls_tys rep_tycon std_err = derivingThingErr cls cls_tys tc_app $ @@ -773,13 +791,6 @@ mkNewTypeEqn orig mayDeriveDataTypeable newtype_deriving overlap_flag tvs -- instance C Int => C T dict_tvs = filterOut (`elemVarSet` dropped_tvs) tvs all_preds = rep_pred : sc_theta -- NB: rep_pred comes first - (dict_args, ntd_info) | null dict_tvs = ([], Just all_preds) - | otherwise = (all_preds, Nothing) - - -- Finally! Here's where we build the dictionary Id - mk_inst_spec dfun_name = mkLocalInstance dfun overlap_flag - where - dfun = mkDictFunId dfun_name dict_tvs dict_args cls inst_tys ------------------------------------------------------------------- -- Figuring out whether we can only do this newtype-deriving thing @@ -869,56 +880,56 @@ ordered by sorting on type varible, tv, (major key) and then class, k, \end{itemize} \begin{code} -solveDerivEqns :: OverlapFlag - -> [DerivEqn] - -> TcM [Instance]-- Solns in same order as eqns. - -- This bunch is Absolutely minimal... - -solveDerivEqns overlap_flag orig_eqns - = do { traceTc (text "solveDerivEqns" <+> vcat (map pprDerivEqn orig_eqns)) - ; iterateDeriv 1 initial_solutions } +inferInstanceContexts :: OverlapFlag -> [DerivSpec] -> TcM [DerivSpec] + +inferInstanceContexts _ [] = return [] + +inferInstanceContexts oflag infer_specs + = do { traceTc (text "inferInstanceContexts" <+> vcat (map pprDerivSpec infer_specs)) + ; iterate_deriv 1 initial_solutions } where + ------------------------------------------------------------------ -- The initial solutions for the equations claim that each -- instance has an empty context; this solution is certainly -- in canonical form. - initial_solutions :: [DerivSoln] - initial_solutions = [ [] | _ <- orig_eqns ] + initial_solutions :: [ThetaType] + initial_solutions = [ [] | _ <- infer_specs ] ------------------------------------------------------------------ - -- iterateDeriv calculates the next batch of solutions, + -- iterate_deriv calculates the next batch of solutions, -- compares it with the current one; finishes if they are the -- same, otherwise recurses with the new solutions. -- It fails if any iteration fails - iterateDeriv :: Int -> [DerivSoln] -> TcM [Instance] - iterateDeriv n current_solns + iterate_deriv :: Int -> [ThetaType] -> TcM [DerivSpec] + iterate_deriv n current_solns | n > 20 -- Looks as if we are in an infinite loop -- This can happen if we have -fallow-undecidable-instances -- (See TcSimplify.tcSimplifyDeriv.) = pprPanic "solveDerivEqns: probable loop" - (vcat (map pprDerivEqn orig_eqns) $$ ppr current_solns) + (vcat (map pprDerivSpec infer_specs) $$ ppr current_solns) | otherwise - = let - inst_specs = zipWithEqual "add_solns" mk_inst_spec - orig_eqns current_solns - in - checkNoErrs ( - -- Extend the inst info from the explicit instance decls + = do { -- Extend the inst info from the explicit instance decls -- with the current set of solutions, and simplify each RHS - extendLocalInstEnv inst_specs $ - mappM gen_soln orig_eqns - ) `thenM` \ new_solns -> - if (current_solns == new_solns) then - returnM inst_specs - else - iterateDeriv (n+1) new_solns + let inst_specs = zipWithEqual "add_solns" (mkInstance2 oflag) + current_solns infer_specs + ; new_solns <- checkNoErrs $ + extendLocalInstEnv inst_specs $ + mapM gen_soln infer_specs + + ; if (current_solns == new_solns) then + return [ spec { ds_theta = soln } + | (spec, soln) <- zip infer_specs current_solns ] + else + iterate_deriv (n+1) new_solns } ------------------------------------------------------------------ - gen_soln :: DerivEqn -> TcM [PredType] - gen_soln (loc, orig, _, tyvars, clas, inst_ty, deriv_rhs) + gen_soln :: DerivSpec -> TcM [PredType] + gen_soln (DS { ds_loc = loc, ds_orig = orig, ds_tvs = tyvars + , ds_cls = clas, ds_tys = inst_tys, ds_theta = deriv_rhs }) = setSrcSpan loc $ - addErrCtxt (derivInstCtxt clas [inst_ty]) $ + addErrCtxt (derivInstCtxt clas inst_tys) $ do { theta <- tcSimplifyDeriv orig tyvars deriv_rhs - -- checkValidInstance tyvars theta clas [inst_ty] + -- checkValidInstance tyvars theta clas inst_tys -- Not necessary; see Note [Exotic derived instance contexts] -- in TcSimplify @@ -936,12 +947,18 @@ solveDerivEqns overlap_flag orig_eqns -- checkValidInstance tyvars theta clas inst_tys ; return (sortLe (<=) theta) } -- Canonicalise before returning the solution - ------------------------------------------------------------------ - mk_inst_spec :: DerivEqn -> DerivSoln -> Instance - mk_inst_spec (loc, orig, dfun_name, tyvars, clas, inst_ty, _) theta - = mkLocalInstance dfun overlap_flag - where - dfun = mkDictFunId dfun_name tyvars theta clas [inst_ty] +------------------------------------------------------------------ +mkInstance1 :: OverlapFlag -> DerivSpec -> Instance +mkInstance1 overlap_flag spec = mkInstance2 overlap_flag (ds_theta spec) spec + +mkInstance2 :: OverlapFlag -> ThetaType -> DerivSpec -> Instance +mkInstance2 overlap_flag theta + (DS { ds_name = dfun_name + , ds_tvs = tyvars, ds_cls = clas, ds_tys = tys }) + = mkLocalInstance dfun overlap_flag + where + dfun = mkDictFunId dfun_name tyvars theta clas tys + extendLocalInstEnv :: [Instance] -> TcM a -> TcM a -- Add new locally-defined instances; don't bother to check @@ -1024,11 +1041,17 @@ the renamer. What a great hack! -- Representation tycons differ from the tycon in the instance signature in -- case of instances for indexed families. -- -genInst :: Instance -> TcM ((InstInfo, TyCon), LHsBinds RdrName) -genInst spec +genInst :: OverlapFlag -> DerivSpec -> TcM (InstInfo, DerivAuxBinds) +genInst oflag spec + | ds_newtype spec + = return (InstInfo { iSpec = mkInstance1 oflag spec + , iBinds = NewTypeDerived }, []) + + | otherwise = do { fix_env <- getFixityEnv ; let - (tyvars,_,clas,[ty]) = instanceHead spec + inst = mkInstance1 oflag spec + (tyvars,_,clas,[ty]) = instanceHead inst clas_nm = className clas (visible_tycon, tyArgs) = tcSplitTyConApp ty @@ -1043,39 +1066,34 @@ genInst spec -- *non-renamed* auxiliary bindings ; (rn_meth_binds, _fvs) <- discardWarnings $ bindLocalNames (map Var.varName tyvars) $ - rnMethodBinds clas_nm (\n -> []) [] meth_binds + rnMethodBinds clas_nm (\_ -> []) [] meth_binds -- Build the InstInfo - ; return ((InstInfo { iSpec = spec, - iBinds = VanillaInst rn_meth_binds [] }, tycon), + ; return (InstInfo { iSpec = inst, + iBinds = VanillaInst rn_meth_binds [] }, aux_binds) } +genDerivBinds :: Class -> FixityEnv -> TyCon -> (LHsBinds RdrName, DerivAuxBinds) genDerivBinds clas fix_env tycon | className clas `elem` typeableClassNames - = (gen_Typeable_binds tycon, emptyLHsBinds) + = (gen_Typeable_binds tycon, []) | otherwise = case assocMaybe gen_list (getUnique clas) of - Just gen_fn -> gen_fn fix_env tycon + Just gen_fn -> gen_fn tycon Nothing -> pprPanic "genDerivBinds: bad derived class" (ppr clas) where - gen_list :: [(Unique, FixityEnv -> TyCon -> (LHsBinds RdrName, LHsBinds RdrName))] - gen_list = [(eqClassKey, no_aux_binds (ignore_fix_env gen_Eq_binds)) - ,(ordClassKey, no_aux_binds (ignore_fix_env gen_Ord_binds)) - ,(enumClassKey, no_aux_binds (ignore_fix_env gen_Enum_binds)) - ,(boundedClassKey, no_aux_binds (ignore_fix_env gen_Bounded_binds)) - ,(ixClassKey, no_aux_binds (ignore_fix_env gen_Ix_binds)) - ,(typeableClassKey,no_aux_binds (ignore_fix_env gen_Typeable_binds)) - ,(showClassKey, no_aux_binds gen_Show_binds) - ,(readClassKey, no_aux_binds gen_Read_binds) - ,(dataClassKey, gen_Data_binds) + gen_list :: [(Unique, TyCon -> (LHsBinds RdrName, DerivAuxBinds))] + gen_list = [(eqClassKey, gen_Eq_binds) + ,(ordClassKey, gen_Ord_binds) + ,(enumClassKey, gen_Enum_binds) + ,(boundedClassKey, gen_Bounded_binds) + ,(ixClassKey, gen_Ix_binds) + ,(showClassKey, gen_Show_binds fix_env) + ,(readClassKey, gen_Read_binds fix_env) + ,(dataClassKey, gen_Data_binds fix_env) ] - - -- no_aux_binds is used for generators that don't - -- need to produce any auxiliary bindings - no_aux_binds f fix_env tc = (f fix_env tc, emptyLHsBinds) - ignore_fix_env f fix_env tc = f tc \end{code} @@ -1085,79 +1103,8 @@ genDerivBinds clas fix_env tycon %* * %************************************************************************ - -data Foo ... = ... - -con2tag_Foo :: Foo ... -> Int# -tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int# -maxtag_Foo :: Int -- ditto (NB: not unlifted) - - -We have a @con2tag@ function for a tycon if: -\begin{itemize} -\item -We're deriving @Eq@ and the tycon has nullary data constructors. - -\item -Or: we're deriving @Ord@ (unless single-constructor), @Enum@, @Ix@ -(enum type only????) -\end{itemize} - -We have a @tag2con@ function for a tycon if: -\begin{itemize} -\item -We're deriving @Enum@, or @Ix@ (enum type only???) -\end{itemize} - -If we have a @tag2con@ function, we also generate a @maxtag@ constant. - -\begin{code} -genTaggeryBinds :: [(InstInfo, TyCon)] -> TcM (LHsBinds RdrName) -genTaggeryBinds infos - = do { names_so_far <- foldlM do_con2tag [] tycons_of_interest - ; nm_alist_etc <- foldlM do_tag2con names_so_far tycons_of_interest - ; return (listToBag (map gen_tag_n_con_monobind nm_alist_etc)) } - where - all_CTs = [ (fst (simpleInstInfoClsTy info), tc) - | (info, tc) <- infos] - all_tycons = map snd all_CTs - (tycons_of_interest, _) = removeDups compare all_tycons - - do_con2tag acc_Names tycon - | isDataTyCon tycon && - ((we_are_deriving eqClassKey tycon - && any isNullarySrcDataCon (tyConDataCons tycon)) - || (we_are_deriving ordClassKey tycon - && not (isProductTyCon tycon)) - || (we_are_deriving enumClassKey tycon) - || (we_are_deriving ixClassKey tycon)) - - = returnM ((con2tag_RDR tycon, tycon, GenCon2Tag) - : acc_Names) - | otherwise - = returnM acc_Names - - do_tag2con acc_Names tycon - | isDataTyCon tycon && - (we_are_deriving enumClassKey tycon || - we_are_deriving ixClassKey tycon - && isEnumerationTyCon tycon) - = returnM ( (tag2con_RDR tycon, tycon, GenTag2Con) - : (maxtag_RDR tycon, tycon, GenMaxTag) - : acc_Names) - | otherwise - = returnM acc_Names - - we_are_deriving clas_key tycon - = is_in_eqns clas_key tycon all_CTs - where - is_in_eqns clas_key tycon [] = False - is_in_eqns clas_key tycon ((c,t):cts) - = (clas_key == classKey c && tycon == t) - || is_in_eqns clas_key tycon cts -\end{code} - \begin{code} +derivingThingErr :: Class -> [Type] -> Type -> Message -> Message derivingThingErr clas tys ty why = sep [hsep [ptext SLIT("Can't make a derived instance of"), quotes (ppr pred)], @@ -1168,14 +1115,17 @@ derivingThingErr clas tys ty why standaloneCtxt :: LHsType Name -> SDoc standaloneCtxt ty = ptext SLIT("In the stand-alone deriving instance for") <+> quotes (ppr ty) +derivInstCtxt :: Class -> [Type] -> Message derivInstCtxt 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)] +famInstNotFound :: TyCon -> [Type] -> Bool -> TcM a famInstNotFound tycon tys notExact = failWithTc (msg <+> quotes (pprTypeApp tycon (ppr tycon) tys)) where diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs index 93229d3..63b73fc 100644 --- a/compiler/typecheck/TcEnv.lhs +++ b/compiler/typecheck/TcEnv.lhs @@ -635,30 +635,20 @@ iDFunId info = instanceDFunId (iSpec info) data InstBindings = VanillaInst -- The normal case - (LHsBinds Name) -- Bindings + (LHsBinds Name) -- Bindings for the instance methods [LSig Name] -- User pragmas recorded for generating -- specialised instances | NewTypeDerived -- Used for deriving instances of newtypes, where the -- witness dictionary is identical to the argument -- dictionary. Hence no bindings, no pragmas. - (Maybe [PredType]) - -- Nothing => The newtype-derived instance involves type variables, - -- and the dfun has a type like df :: forall a. Eq a => Eq (T a) - -- Just (r:scs) => The newtype-defined instance has no type variables - -- so the dfun is just a constant, df :: Eq T - -- In this case we need to know waht the rep dict, r, and the - -- superclasses, scs, are. (In the Nothing case these are in the - -- dict fun's type.) - -- Invariant: these PredTypes have no free variables - -- NB: In both cases, the representation dict is the *first* dict. pprInstInfo info = vcat [ptext SLIT("InstInfo:") <+> ppr (idType (iDFunId info))] pprInstInfoDetails info = pprInstInfo info $$ nest 2 (details (iBinds info)) where - details (VanillaInst b _) = pprLHsBinds b - details (NewTypeDerived _) = text "Derived from the representation type" + details (VanillaInst b _) = pprLHsBinds b + details NewTypeDerived = text "Derived from the representation type" simpleInstInfoClsTy :: InstInfo -> (Class, Type) simpleInstInfoClsTy info = case instanceHead (iSpec info) of diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs index cb4bab3..d67ffc0 100644 --- a/compiler/typecheck/TcGenDeriv.lhs +++ b/compiler/typecheck/TcGenDeriv.lhs @@ -19,6 +19,8 @@ This is where we do all the grimy bindings' generation. -- for details module TcGenDeriv ( + DerivAuxBind(..), DerivAuxBinds, isDupAux, + gen_Bounded_binds, gen_Enum_binds, gen_Eq_binds, @@ -28,11 +30,9 @@ module TcGenDeriv ( gen_Show_binds, gen_Data_binds, gen_Typeable_binds, - gen_tag_n_con_monobind, - - con2tag_RDR, tag2con_RDR, maxtag_RDR, + genAuxBind, - TagThingWanted(..) + con2tag_RDR, tag2con_RDR, maxtag_RDR ) where #include "HsVersions.h" @@ -62,15 +62,26 @@ import Bag import Data.List ( partition, intersperse ) \end{code} -%************************************************************************ -%* * -\subsection{Generating code, by derivable class} -%* * -%************************************************************************ +\begin{code} +type DerivAuxBinds = [DerivAuxBind] + +data DerivAuxBind -- Please add these auxiliary top-level bindings + = DerivAuxBind (LHsBind RdrName) + | GenCon2Tag TyCon -- The con2Tag for given TyCon + | GenTag2Con TyCon -- ...ditto tag2Con + | GenMaxTag TyCon -- ...and maxTag + +isDupAux :: DerivAuxBind -> DerivAuxBind -> Bool +isDupAux (GenCon2Tag tc1) (GenCon2Tag tc2) = tc1==tc2 +isDupAux (GenTag2Con tc1) (GenTag2Con tc2) = tc1==tc2 +isDupAux (GenMaxTag tc1) (GenMaxTag tc2) = tc1==tc2 +isDupAux b1 b2 = False +\end{code} + %************************************************************************ %* * -\subsubsection{Generating @Eq@ instance declarations} + Eq instances %* * %************************************************************************ @@ -143,33 +154,36 @@ instance ... Eq (Foo ...) where \begin{code} -gen_Eq_binds :: TyCon -> LHsBinds RdrName - +gen_Eq_binds :: TyCon -> (LHsBinds RdrName, DerivAuxBinds) gen_Eq_binds tycon - = let - tycon_loc = getSrcSpan tycon - - (nullary_cons, nonnullary_cons) - | isNewTyCon tycon = ([], tyConDataCons tycon) - | otherwise = partition isNullarySrcDataCon (tyConDataCons tycon) - - rest - = if (null nullary_cons) then - case maybeTyConSingleCon tycon of - Just _ -> [] - Nothing -> -- if cons don't match, then False - [([nlWildPat, nlWildPat], false_Expr)] - else -- calc. and compare the tags - [([a_Pat, b_Pat], - untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)] - (genOpApp (nlHsVar ah_RDR) eqInt_RDR (nlHsVar bh_RDR)))] - in - listToBag [ - mk_FunBind tycon_loc eq_RDR ((map pats_etc nonnullary_cons) ++ rest), - mk_easy_FunBind tycon_loc ne_RDR [a_Pat, b_Pat] ( - nlHsApp (nlHsVar not_RDR) (nlHsPar (nlHsVarApps eq_RDR [a_RDR, b_RDR]))) - ] + = (method_binds, aux_binds) where + tycon_loc = getSrcSpan tycon + + (nullary_cons, nonnullary_cons) + | isNewTyCon tycon = ([], tyConDataCons tycon) + | otherwise = partition isNullarySrcDataCon (tyConDataCons tycon) + + no_nullary_cons = null nullary_cons + + rest | no_nullary_cons + = case maybeTyConSingleCon tycon of + Just _ -> [] + Nothing -> -- if cons don't match, then False + [([nlWildPat, nlWildPat], false_Expr)] + | otherwise -- calc. and compare the tags + = [([a_Pat, b_Pat], + untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)] + (genOpApp (nlHsVar ah_RDR) eqInt_RDR (nlHsVar bh_RDR)))] + + aux_binds | no_nullary_cons = [] + | otherwise = [GenCon2Tag tycon] + + method_binds = listToBag [ + mk_FunBind tycon_loc eq_RDR ((map pats_etc nonnullary_cons) ++ rest), + mk_easy_FunBind tycon_loc ne_RDR [a_Pat, b_Pat] ( + nlHsApp (nlHsVar not_RDR) (nlHsPar (nlHsVarApps eq_RDR [a_RDR, b_RDR])))] + ------------------------------------------------------------------ pats_etc data_con = let @@ -193,7 +207,7 @@ gen_Eq_binds tycon %************************************************************************ %* * -\subsubsection{Generating @Ord@ instance declarations} + Ord instances %* * %************************************************************************ @@ -288,14 +302,17 @@ If there is only one constructor in the Data Type we don't need the WildCard Pat JJQC-30-Nov-1997 \begin{code} -gen_Ord_binds :: TyCon -> LHsBinds RdrName +gen_Ord_binds :: TyCon -> (LHsBinds RdrName, DerivAuxBinds) gen_Ord_binds tycon - = unitBag compare -- `AndMonoBinds` compare - -- The default declaration in PrelBase handles this + = (unitBag compare, aux_binds) + -- `AndMonoBinds` compare + -- The default declaration in PrelBase handles this where tycon_loc = getSrcSpan tycon -------------------------------------------------------------------- + aux_binds | single_con_type = [] + | otherwise = [GenCon2Tag tycon] compare = L tycon_loc (mkFunBind (L tycon_loc compare_RDR) compare_matches) compare_matches = [mkMatch [a_Pat, b_Pat] compare_rhs cmp_eq_binds] @@ -333,38 +350,37 @@ gen_Ord_binds tycon else [([nlWildPat, nlWildPat], default_rhs)]) - where - pats_etc data_con - = ([con1_pat, con2_pat], - nested_compare_expr tys_needed as_needed bs_needed) - where - con1_pat = nlConVarPat data_con_RDR as_needed - con2_pat = nlConVarPat data_con_RDR bs_needed + default_rhs | null nullary_cons = impossible_Expr -- Keep desugarer from complaining about + -- inexhaustive patterns + | otherwise = eqTag_Expr -- Some nullary constructors; + -- Tags are equal, no args => return EQ + pats_etc data_con + = ([con1_pat, con2_pat], + nested_compare_expr tys_needed as_needed bs_needed) + where + con1_pat = nlConVarPat data_con_RDR as_needed + con2_pat = nlConVarPat data_con_RDR bs_needed - data_con_RDR = getRdrName data_con - con_arity = length tys_needed - as_needed = take con_arity as_RDRs - bs_needed = take con_arity bs_RDRs - tys_needed = dataConOrigArgTys data_con + data_con_RDR = getRdrName data_con + con_arity = length tys_needed + as_needed = take con_arity as_RDRs + bs_needed = take con_arity bs_RDRs + tys_needed = dataConOrigArgTys data_con - nested_compare_expr [ty] [a] [b] - = careful_compare_Case tycon ty eqTag_Expr (nlHsVar a) (nlHsVar b) + nested_compare_expr [ty] [a] [b] + = careful_compare_Case tycon ty eqTag_Expr (nlHsVar a) (nlHsVar b) - nested_compare_expr (ty:tys) (a:as) (b:bs) - = let eq_expr = nested_compare_expr tys as bs + nested_compare_expr (ty:tys) (a:as) (b:bs) + = let eq_expr = nested_compare_expr tys as bs in careful_compare_Case tycon ty eq_expr (nlHsVar a) (nlHsVar b) - nested_compare_expr _ _ _ = panic "nested_compare_expr" -- Args always equal length + nested_compare_expr _ _ _ = panic "nested_compare_expr" -- Args always equal length - default_rhs | null nullary_cons = impossible_Expr -- Keep desugarer from complaining about - -- inexhaustive patterns - | otherwise = eqTag_Expr -- Some nullary constructors; - -- Tags are equal, no args => return EQ \end{code} %************************************************************************ %* * -\subsubsection{Generating @Enum@ instance declarations} + Enum instances %* * %************************************************************************ @@ -404,18 +420,20 @@ instance ... Enum (Foo ...) where For @enumFromTo@ and @enumFromThenTo@, we use the default methods. \begin{code} -gen_Enum_binds :: TyCon -> LHsBinds RdrName - +gen_Enum_binds :: TyCon -> (LHsBinds RdrName, DerivAuxBinds) gen_Enum_binds tycon - = listToBag [ - succ_enum, - pred_enum, - to_enum, - enum_from, - enum_from_then, - from_enum - ] + = (method_binds, aux_binds) where + method_binds = listToBag [ + succ_enum, + pred_enum, + to_enum, + enum_from, + enum_from_then, + from_enum + ] + aux_binds = [GenCon2Tag tycon, GenTag2Con tycon, GenMaxTag tycon] + tycon_loc = getSrcSpan tycon occ_nm = getOccString tycon @@ -477,17 +495,18 @@ gen_Enum_binds tycon %************************************************************************ %* * -\subsubsection{Generating @Bounded@ instance declarations} + Bounded instances %* * %************************************************************************ \begin{code} +gen_Bounded_binds :: TyCon -> (LHsBinds RdrName, DerivAuxBinds) gen_Bounded_binds tycon - = if isEnumerationTyCon tycon then - listToBag [ min_bound_enum, max_bound_enum ] - else - ASSERT(isSingleton data_cons) - listToBag [ min_bound_1con, max_bound_1con ] + | isEnumerationTyCon tycon + = (listToBag [ min_bound_enum, max_bound_enum ], []) + | otherwise + = ASSERT(isSingleton data_cons) + (listToBag [ min_bound_1con, max_bound_1con ], []) where data_cons = tyConDataCons tycon tycon_loc = getSrcSpan tycon @@ -512,7 +531,7 @@ gen_Bounded_binds tycon %************************************************************************ %* * -\subsubsection{Generating @Ix@ instance declarations} + Ix instances %* * %************************************************************************ @@ -569,12 +588,13 @@ we follow the scheme given in Figure~19 of the Haskell~1.2 report (p.~147). \begin{code} -gen_Ix_binds :: TyCon -> LHsBinds RdrName +gen_Ix_binds :: TyCon -> (LHsBinds RdrName, DerivAuxBinds) gen_Ix_binds tycon - = if isEnumerationTyCon tycon - then enum_ixes - else single_con_ixes + | isEnumerationTyCon tycon + = (enum_ixes, [GenCon2Tag tycon, GenTag2Con tycon, GenMaxTag tycon]) + | otherwise + = (single_con_ixes, [GenCon2Tag tycon]) where tycon_loc = getSrcSpan tycon @@ -685,7 +705,7 @@ gen_Ix_binds tycon %************************************************************************ %* * -\subsubsection{Generating @Read@ instance declarations} + Read instances %* * %************************************************************************ @@ -728,10 +748,10 @@ instance Read T where \begin{code} -gen_Read_binds :: FixityEnv -> TyCon -> LHsBinds RdrName +gen_Read_binds :: FixityEnv -> TyCon -> (LHsBinds RdrName, DerivAuxBinds) gen_Read_binds get_fixity tycon - = listToBag [read_prec, default_readlist, default_readlistprec] + = (listToBag [read_prec, default_readlist, default_readlistprec], []) where ----------------------------------------------------------------------- default_readlist @@ -853,7 +873,7 @@ gen_Read_binds get_fixity tycon %************************************************************************ %* * -\subsubsection{Generating @Show@ instance declarations} + Show instances %* * %************************************************************************ @@ -881,10 +901,10 @@ Example -- the most tightly-binding operator \begin{code} -gen_Show_binds :: FixityEnv -> TyCon -> LHsBinds RdrName +gen_Show_binds :: FixityEnv -> TyCon -> (LHsBinds RdrName, DerivAuxBinds) gen_Show_binds get_fixity tycon - = listToBag [shows_prec, show_list] + = (listToBag [shows_prec, show_list], []) where tycon_loc = getSrcSpan tycon ----------------------------------------------------------------------- @@ -1032,7 +1052,7 @@ mk_typeOf_RDR tycon = varQual_RDR tYPEABLE (mkFastString ("typeOf" ++ suffix)) %************************************************************************ %* * -\subsection{Data} + Data instances %* * %************************************************************************ @@ -1065,11 +1085,11 @@ we generate gen_Data_binds :: FixityEnv -> TyCon -> (LHsBinds RdrName, -- The method bindings - LHsBinds RdrName) -- Auxiliary bindings + DerivAuxBinds) -- Auxiliary bindings gen_Data_binds fix_env tycon = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind], -- Auxiliary definitions: the data type and constructors - datatype_bind `consBag` listToBag (map mk_con_bind data_cons)) + DerivAuxBind datatype_bind : map mk_con_bind data_cons) where tycon_loc = getSrcSpan tycon tycon_name = tyConName tycon @@ -1136,7 +1156,8 @@ gen_Data_binds fix_env tycon ------------ $cT1 etc mk_constr_name con = mkDerivedRdrName (dataConName con) mkDataCOcc - mk_con_bind dc = mkVarBind + mk_con_bind dc = DerivAuxBind $ + mkVarBind tycon_loc (mk_constr_name dc) (nlHsApps mkConstr_RDR (constr_args dc)) @@ -1183,16 +1204,12 @@ The `tags' here start at zero, hence the @fIRST_TAG@ (currently one) fiddling around. \begin{code} -data TagThingWanted - = GenCon2Tag | GenTag2Con | GenMaxTag +genAuxBind :: DerivAuxBind -> LHsBind RdrName -gen_tag_n_con_monobind - :: ( RdrName, -- (proto)Name for the thing in question - TyCon, -- tycon in question - TagThingWanted) - -> LHsBind RdrName +genAuxBind (DerivAuxBind bind) + = bind -gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag) +genAuxBind (GenCon2Tag tycon) | lots_of_constructors = mk_FunBind tycon_loc rdr_name [([], get_tag_rhs)] @@ -1200,6 +1217,7 @@ gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag) = mk_FunBind tycon_loc rdr_name (map mk_stuff (tyConDataCons tycon)) where + rdr_name = con2tag_RDR tycon tycon_loc = getSrcSpan tycon tvs = map (mkRdrUnqual . getOccName) (tyConTyVars tycon) @@ -1226,19 +1244,21 @@ gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag) mk_stuff con = ([nlWildConPat con], nlHsLit (HsIntPrim (toInteger ((dataConTag con) - fIRST_TAG)))) -gen_tag_n_con_monobind (rdr_name, tycon, GenTag2Con) +genAuxBind (GenTag2Con tycon) = mk_FunBind (getSrcSpan tycon) rdr_name [([nlConVarPat intDataCon_RDR [a_RDR]], noLoc (ExprWithTySig (nlHsApp (nlHsVar tagToEnum_RDR) a_Expr) (nlHsTyVar (getRdrName tycon))))] + where + rdr_name = tag2con_RDR tycon -gen_tag_n_con_monobind (rdr_name, tycon, GenMaxTag) +genAuxBind (GenMaxTag tycon) = mkVarBind (getSrcSpan tycon) rdr_name (nlHsApp (nlHsVar intDataCon_RDR) (nlHsLit (HsIntPrim max_tag))) where + rdr_name = maxtag_RDR tycon max_tag = case (tyConDataCons tycon) of data_cons -> toInteger ((length data_cons) - fIRST_TAG) - \end{code} %************************************************************************ diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index 27de230..7b2ca58 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -403,39 +403,37 @@ tcInstDecls2 tycl_decls inst_decls The main purpose of @tcInstDecl2@ is to return a @HsBinds@ which defines the dictionary function for this instance declaration. For example -\begin{verbatim} + instance Foo a => Foo [a] where op1 x = ... op2 y = ... -\end{verbatim} + might generate something like -\begin{verbatim} + dfun.Foo.List dFoo_a = let op1 x = ... op2 y = ... in Dict [op1, op2] -\end{verbatim} HOWEVER, if the instance decl has no context, then it returns a bigger @HsBinds@ with declarations for each method. For example -\begin{verbatim} + instance Foo [a] where op1 x = ... op2 y = ... -\end{verbatim} + might produce -\begin{verbatim} + dfun.Foo.List a = Dict [Foo.op1.List a, Foo.op2.List a] const.Foo.op1.List a x = ... const.Foo.op2.List a y = ... -\end{verbatim} + This group may be mutually recursive, because (for example) there may be no method supplied for op2 in which case we'll get -\begin{verbatim} + const.Foo.op2.List a = default.Foo.op2 (dfun.Foo.List a) -\end{verbatim} -that is, the default method applied to the dictionary at this type. +that is, the default method applied to the dictionary at this type. What we actually produce in either case is: AbsBinds [a] [dfun_theta_dicts] @@ -447,7 +445,6 @@ What we actually produce in either case is: The "maybe" says that we only ask AbsBinds to make global constant methods if the dfun_theta is empty. - For an instance declaration, say, @@ -463,8 +460,6 @@ Notice that we pass it the superclass dictionaries at the instance type; this is the ``Mark Jones optimisation''. The stuff before the "=>" here is the @dfun_theta@ below. -First comes the easy case of a non-local instance decl. - \begin{code} tcInstDecl2 :: InstInfo -> TcM (LHsBinds Id) @@ -473,23 +468,23 @@ tcInstDecl2 :: InstInfo -> TcM (LHsBinds Id) ------------------------ -- Derived newtype instances; surprisingly tricky! -- --- In the case of a newtype, things are rather easy -- class Show a => Foo a b where ... --- newtype T a = MkT (Tree [a]) deriving( Foo Int ) +-- newtype N a = MkN (Tree [a]) deriving( Foo Int ) +-- -- The newtype gives an FC axiom looking like --- axiom CoT a :: T a :=: Tree [a] +-- axiom CoN a :: N a :=: Tree [a] -- (see Note [Newtype coercions] in TyCon for this unusual form of axiom) -- -- So all need is to generate a binding looking like: --- dfunFooT :: forall a. (Foo Int (Tree [a], Show (T a)) => Foo Int (T a) --- dfunFooT = /\a. \(ds:Show (T a)) (df:Foo (Tree [a])). --- case df `cast` (Foo Int (sym (CoT a))) of +-- dfunFooT :: forall a. (Foo Int (Tree [a], Show (N a)) => Foo Int (N a) +-- dfunFooT = /\a. \(ds:Show (N a)) (df:Foo (Tree [a])). +-- case df `cast` (Foo Int (sym (CoN a))) of -- Foo _ op1 .. opn -> Foo ds op1 .. opn -- -- If there are no superclasses, matters are simpler, because we don't need the case -- see Note [Newtype deriving superclasses] in TcDeriv.lhs -tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = NewTypeDerived mb_preds }) +tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = NewTypeDerived }) = do { let dfun_id = instanceDFunId ispec rigid_info = InstSkol origin = SigOrigin rigid_info @@ -497,46 +492,43 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = NewTypeDerived mb_preds }) ; (tvs, theta, inst_head_ty) <- tcSkolSigType rigid_info inst_ty -- inst_head_ty is a PredType - ; inst_loc <- getInstLoc origin - ; (rep_dict_id : sc_dict_ids, wrap_fn, sc_binds) - <- make_wrapper inst_loc tvs theta mb_preds - -- Here, we are relying on the order of dictionary - -- arguments built by NewTypeDerived in TcDeriv; - -- namely, that the rep_dict_id comes first - ; let (cls, cls_inst_tys) = tcSplitDFunHead inst_head_ty - cls_tycon = classTyCon cls - the_coercion = make_coercion cls_tycon cls_inst_tys - coerced_rep_dict = mkHsWrap the_coercion (HsVar rep_dict_id) - - ; body <- make_body cls_tycon cls_inst_tys sc_dict_ids coerced_rep_dict + (class_tyvars, sc_theta, _, op_items) = classBigSig cls + cls_tycon = classTyCon cls + sc_theta' = substTheta (zipOpenTvSubst class_tyvars cls_inst_tys) sc_theta + + Just (initial_cls_inst_tys, last_ty) = snocView cls_inst_tys + (nt_tycon, tc_args) = tcSplitTyConApp last_ty -- Can't fail + rep_ty = newTyConInstRhs nt_tycon tc_args + + rep_pred = mkClassPred cls (initial_cls_inst_tys ++ [rep_ty]) + -- In our example, rep_pred is (Foo Int (Tree [a])) + the_coercion = make_coercion cls_tycon initial_cls_inst_tys nt_tycon tc_args + -- Coercion of kind (Foo Int (Tree [a]) ~ Foo Int (N a) - ; return (sc_binds `snocBag` (noLoc $ VarBind dfun_id $ noLoc $ mkHsWrap wrap_fn body)) } + ; inst_loc <- getInstLoc origin + ; sc_loc <- getInstLoc InstScOrigin + ; dfun_dicts <- newDictBndrs inst_loc theta + ; sc_dicts <- newDictBndrs sc_loc sc_theta' + ; this_dict <- newDictBndr inst_loc (mkClassPred cls cls_inst_tys) + ; rep_dict <- newDictBndr inst_loc rep_pred + + -- Figure out bindings for the superclass context from dfun_dicts + -- Don't include this_dict in the 'givens', else + -- wanted_sc_insts get bound by just selecting from this_dict!! + ; sc_binds <- addErrCtxt superClassCtxt $ + tcSimplifySuperClasses inst_loc dfun_dicts (rep_dict:sc_dicts) + + ; let coerced_rep_dict = mkHsWrap the_coercion (HsVar (instToId rep_dict)) + + ; body <- make_body cls_tycon cls_inst_tys sc_dicts coerced_rep_dict + ; let dict_bind = noLoc $ VarBind (instToId this_dict) (noLoc body) + + ; return (unitBag $ noLoc $ + AbsBinds tvs (map instToId dfun_dicts) + [(tvs, dfun_id, instToId this_dict, [])] + (dict_bind `consBag` sc_binds)) } where - - ----------------------- - -- make_wrapper - -- We distinguish two cases: - -- (a) there is no tyvar abstraction in the dfun, so all dicts are constant, - -- and the new dict can just be a constant - -- (mb_preds = Just preds) - -- (b) there are tyvars, so we must make a dict *fun* - -- (mb_preds = Nothing) - -- See the defn of NewTypeDerived for the meaning of mb_preds - make_wrapper inst_loc tvs theta (Just preds) -- Case (a) - = ASSERT( null tvs && null theta ) - do { dicts <- newDictBndrs inst_loc preds - ; sc_binds <- addErrCtxt superClassCtxt $ - tcSimplifySuperClasses inst_loc [] dicts - -- Use tcSimplifySuperClasses to avoid creating loops, for the - -- same reason as Note [SUPERCLASS-LOOP 1] in TcSimplify - ; return (map instToId dicts, idHsWrapper, sc_binds) } - - make_wrapper inst_loc tvs theta Nothing -- Case (b) - = do { dicts <- newDictBndrs inst_loc theta - ; let dict_ids = map instToId dicts - ; return (dict_ids, mkWpTyLams tvs <.> mkWpLams dict_ids, emptyBag) } - ----------------------- -- make_coercion -- The inst_head looks like (C s1 .. sm (T a1 .. ak)) @@ -546,25 +538,24 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = NewTypeDerived mb_preds }) -- So we just replace T with CoT, and insert a 'sym' -- NB: we know that k will be >= arity of CoT, because the latter fully eta-reduced - make_coercion cls_tycon cls_inst_tys - | Just (all_tys_but_last, last_ty) <- snocView cls_inst_tys - , (tycon, tc_args) <- tcSplitTyConApp last_ty -- Should not fail - , Just co_con <- newTyConCo_maybe tycon + make_coercion cls_tycon initial_cls_inst_tys nt_tycon tc_args + | Just co_con <- newTyConCo_maybe nt_tycon , let co = mkSymCoercion (mkTyConApp co_con tc_args) - = WpCo (mkTyConApp cls_tycon (all_tys_but_last ++ [co])) + = WpCo (mkTyConApp cls_tycon (initial_cls_inst_tys ++ [co])) | otherwise -- The newtype is transparent; no need for a cast = idHsWrapper ----------------------- - -- make_body - -- Two cases; see Note [Newtype deriving superclasses] in TcDeriv.lhs - -- (a) no superclasses; then we can just use the coerced dict - -- (b) one or more superclasses; then new need to do the unpack/repack + -- (make_body C tys scs coreced_rep_dict) + -- returns + -- (case coerced_rep_dict of { C _ ops -> C scs ops }) + -- But if there are no superclasses, it returns just coerced_rep_dict + -- See Note [Newtype deriving superclasses] in TcDeriv.lhs - make_body cls_tycon cls_inst_tys sc_dict_ids coerced_rep_dict - | null sc_dict_ids -- Case (a) + make_body cls_tycon cls_inst_tys sc_dicts coerced_rep_dict + | null sc_dicts -- Case (a) = return coerced_rep_dict - | otherwise -- Case (b) + | otherwise -- Case (b) = do { op_ids <- newSysLocalIds FSLIT("op") op_tys ; dummy_sc_dict_ids <- newSysLocalIds FSLIT("sc") (map idType sc_dict_ids) ; let the_pat = ConPatOut { pat_con = noLoc cls_data_con, pat_tvs = [], @@ -582,6 +573,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = NewTypeDerived mb_preds }) ; return (HsCase (noLoc coerced_rep_dict) $ MatchGroup [the_match] (mkFunTy pat_ty pat_ty)) } where + sc_dict_ids = map instToId sc_dicts pat_ty = mkTyConApp cls_tycon cls_inst_tys cls_data_con = head (tyConDataCons cls_tycon) cls_arg_tys = dataConInstArgTys cls_data_con cls_inst_tys diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs index e4f27a4..c574820 100644 --- a/compiler/typecheck/TcMType.lhs +++ b/compiler/typecheck/TcMType.lhs @@ -49,7 +49,7 @@ module TcMType ( SourceTyCtxt(..), checkValidTheta, checkFreeness, checkValidInstHead, checkValidInstance, checkAmbiguity, checkInstTermination, checkValidTypeInst, checkTyFamFreeness, - arityErr, + validDerivPred, arityErr, -------------------------------- -- Zonking @@ -935,6 +935,7 @@ check_valid_theta ctxt theta (_,dups) = removeDups tcCmpPred theta ------------------------- +check_pred_ty :: DynFlags -> SourceTyCtxt -> PredType -> TcM () check_pred_ty dflags ctxt pred@(ClassP cls tys) = do { -- Class predicates are valid in all contexts ; checkTc (arity == n_tys) arity_err @@ -978,6 +979,7 @@ check_pred_ty dflags SigmaCtxt (IParam _ ty) = check_arg_type ty check_pred_ty dflags ctxt sty = failWithTc (badPredTyErr sty) ------------------------- +check_class_pred_tys :: DynFlags -> SourceTyCtxt -> [Type] -> Bool check_class_pred_tys dflags ctxt tys = case ctxt of TypeCtxt -> True -- {-# SPECIALISE instance Eq (T Int) #-} is fine @@ -1245,7 +1247,72 @@ undecidableMsg = ptext SLIT("Use -fallow-undecidable-instances to permit this") %************************************************************************ %* * -\subsection{Checking type instance well-formedness and termination} + Checking the context of a derived instance declaration +%* * +%************************************************************************ + +Note [Exotic derived instance contexts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In a 'derived' instance declaration, we *infer* the context. It's a +bit unclear what rules we should apply for this; the Haskell report is +silent. Obviously, constraints like (Eq a) are fine, but what about + data T f a = MkT (f a) deriving( Eq ) +where we'd get an Eq (f a) constraint. That's probably fine too. + +One could go further: consider + data T a b c = MkT (Foo a b c) deriving( Eq ) + instance (C Int a, Eq b, Eq c) => Eq (Foo a b c) + +Notice that this instance (just) satisfies the Paterson termination +conditions. Then we *could* derive an instance decl like this: + + instance (C Int a, Eq b, Eq c) => Eq (T a b c) + +even though there is no instance for (C Int a), because there just +*might* be an instance for, say, (C Int Bool) at a site where we +need the equality instance for T's. + +However, this seems pretty exotic, and it's quite tricky to allow +this, and yet give sensible error messages in the (much more common) +case where we really want that instance decl for C. + +So for now we simply require that the derived instance context +should have only type-variable constraints. + +Here is another example: + data Fix f = In (f (Fix f)) deriving( Eq ) +Here, if we are prepared to allow -fallow-undecidable-instances we +could derive the instance + instance Eq (f (Fix f)) => Eq (Fix f) +but this is so delicate that I don't think it should happen inside +'deriving'. If you want this, write it yourself! + +NB: if you want to lift this condition, make sure you still meet the +termination conditions! If not, the deriving mechanism generates +larger and larger constraints. Example: + data Succ a = S a + data Seq a = Cons a (Seq (Succ a)) | Nil deriving Show + +Note the lack of a Show instance for Succ. First we'll generate + instance (Show (Succ a), Show a) => Show (Seq a) +and then + instance (Show (Succ (Succ a)), Show (Succ a), Show a) => Show (Seq a) +and so on. Instead we want to complain of no instance for (Show (Succ a)). + +The bottom line +~~~~~~~~~~~~~~~ +Allow constraints which consist only of type variables, with no repeats. + +\begin{code} +validDerivPred :: PredType -> Bool +validDerivPred (ClassP cls tys) = hasNoDups fvs && sizeTypes tys == length fvs + where fvs = fvTypes tys +validDerivPred otehr = False +\end{code} + +%************************************************************************ +%* * + Checking type instance well-formedness and termination %* * %************************************************************************ diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs index 13a85ab..62a7151 100644 --- a/compiler/typecheck/TcSimplify.lhs +++ b/compiler/typecheck/TcSimplify.lhs @@ -2769,7 +2769,6 @@ tcSimplifyDeriv :: InstOrigin -> TcM ThetaType -- Needed -- Given instance (wanted) => C inst_ty -- Simplify 'wanted' as much as possible --- The inst_ty is needed only for the termination check tcSimplifyDeriv orig tyvars theta = do { (tvs, _, tenv) <- tcInstTyVars tyvars @@ -2779,8 +2778,9 @@ tcSimplifyDeriv orig tyvars theta ; wanteds <- newDictBndrsO orig (substTheta tenv theta) ; (irreds, _) <- tryHardCheckLoop doc wanteds - ; let (tv_dicts, others) = partition isTyVarDict irreds + ; let (tv_dicts, others) = partition ok irreds ; addNoInstanceErrs others + -- See Note [Exotic derived instance contexts] in TcMType ; let rev_env = zipTopTvSubst tvs (mkTyVarTys tyvars) simpl_theta = substTheta rev_env (map dictPred tv_dicts) @@ -2790,49 +2790,10 @@ tcSimplifyDeriv orig tyvars theta ; return simpl_theta } where doc = ptext SLIT("deriving classes for a data type") -\end{code} - -Note [Exotic derived instance contexts] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data T a b c = MkT (Foo a b c) deriving( Eq ) - instance (C Int a, Eq b, Eq c) => Eq (Foo a b c) - -Notice that this instance (just) satisfies the Paterson termination -conditions. Then we *could* derive an instance decl like this: - - instance (C Int a, Eq b, Eq c) => Eq (T a b c) -even though there is no instance for (C Int a), because there just -*might* be an instance for, say, (C Int Bool) at a site where we -need the equality instance for T's. - -However, this seems pretty exotic, and it's quite tricky to allow -this, and yet give sensible error messages in the (much more common) -case where we really want that instance decl for C. - -So for now we simply require that the derived instance context -should have only type-variable constraints. - -Here is another example: - data Fix f = In (f (Fix f)) deriving( Eq ) -Here, if we are prepared to allow -fallow-undecidable-instances we -could derive the instance - instance Eq (f (Fix f)) => Eq (Fix f) -but this is so delicate that I don't think it should happen inside -'deriving'. If you want this, write it yourself! - -NB: if you want to lift this condition, make sure you still meet the -termination conditions! If not, the deriving mechanism generates -larger and larger constraints. Example: - data Succ a = S a - data Seq a = Cons a (Seq (Succ a)) | Nil deriving Show - -Note the lack of a Show instance for Succ. First we'll generate - instance (Show (Succ a), Show a) => Show (Seq a) -and then - instance (Show (Succ (Succ a)), Show (Succ a), Show a) => Show (Seq a) -and so on. Instead we want to complain of no instance for (Show (Succ a)). + ok dict | isDict dict = validDerivPred (dictPred dict) + | otherwise = False +\end{code} @tcSimplifyDefault@ just checks class-type constraints, essentially; diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs index e2b756b..87ae25d 100644 --- a/compiler/types/TyCon.lhs +++ b/compiler/types/TyCon.lhs @@ -33,7 +33,7 @@ module TyCon( isEnumerationTyCon, isGadtSyntaxTyCon, isOpenTyCon, assocTyConArgPoss_maybe, isTyConAssoc, setTyConArgPoss, isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, tupleTyConBoxity, - isRecursiveTyCon, newTyConRep, newTyConRhs, newTyConCo_maybe, + isRecursiveTyCon, newTyConRep, newTyConRhs, newTyConEtadRhs, newTyConCo_maybe, isHiBootTyCon, isSuperKindTyCon, isCoercionTyCon_maybe, isCoercionTyCon, isImplicitTyCon, @@ -250,10 +250,12 @@ data AlgTyConRhs -- = the representation type of the tycon -- The free tyvars of this type are the tyConTyVars - nt_co :: Maybe TyCon, -- The coercion used to create the newtype + nt_co :: Maybe TyCon, -- A CoercionTyCon used to create the newtype -- from the representation - -- optional for non-recursive newtypes + -- Optional for non-recursive newtypes -- See Note [Newtype coercions] + -- Invariant: arity = #tvs in nt_etad_rhs; + -- See Note [Newtype eta] nt_etad_rhs :: ([TyVar], Type) , -- The same again, but this time eta-reduced @@ -333,7 +335,6 @@ data SynTyConRhs Note [Newtype coercions] ~~~~~~~~~~~~~~~~~~~~~~~~ - The NewTyCon field nt_co is a a TyCon (a coercion constructor in fact) which is used for coercing from the representation type of the newtype, to the newtype itself. For example, @@ -397,6 +398,14 @@ we get: w2 = w1 And now Lint complains unless Foo T == Foo [], and that requires T==[] +This point carries over to the newtype coercion, because we need to +say + w2 = w1 `cast` Foo CoT + +so the coercion tycon CoT must have + kind: T ~ [] + and arity: 0 + Note [Indexed data types] (aka data type families) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -878,6 +887,10 @@ newTyConRhs :: TyCon -> ([TyVar], Type) newTyConRhs (AlgTyCon {tyConTyVars = tvs, algTcRhs = NewTyCon { nt_rhs = rhs }}) = (tvs, rhs) newTyConRhs tycon = pprPanic "newTyConRhs" (ppr tycon) +newTyConEtadRhs :: TyCon -> ([TyVar], Type) +newTyConEtadRhs (AlgTyCon {algTcRhs = NewTyCon { nt_etad_rhs = tvs_rhs }}) = tvs_rhs +newTyConEtadRhs tycon = pprPanic "newTyConEtadRhs" (ppr tycon) + newTyConRep :: TyCon -> ([TyVar], Type) newTyConRep (AlgTyCon {tyConTyVars = tvs, algTcRhs = NewTyCon { nt_rep = rep }}) = (tvs, rep) newTyConRep tycon = pprPanic "newTyConRep" (ppr tycon) diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs index 4bf5417..aa3cd07 100644 --- a/compiler/types/Type.lhs +++ b/compiler/types/Type.lhs @@ -415,8 +415,14 @@ splitNewTyConApp_maybe (FunTy arg res) = Just (funTyCon, [arg,res]) splitNewTyConApp_maybe other = Nothing newTyConInstRhs :: TyCon -> [Type] -> Type -newTyConInstRhs tycon tys = - let (tvs, ty) = newTyConRhs tycon in substTyWith tvs tys ty +-- Unwrap one 'layer' of newtype +-- Use the eta'd version if possible +newTyConInstRhs tycon tys + = ASSERT2( equalLength tvs tys1, ppr tycon $$ ppr tys $$ ppr tvs ) + mkAppTys (substTyWith tvs tys1 ty) tys2 + where + (tvs, ty) = newTyConEtadRhs tycon + (tys1, tys2) = splitAtList tvs tys \end{code} diff --git a/docs/users_guide/flags.xml b/docs/users_guide/flags.xml index 19e3c3d..e5c3289 100644 --- a/docs/users_guide/flags.xml +++ b/docs/users_guide/flags.xml @@ -873,17 +873,23 @@ - Enable standalone deriving. + Enable standalone deriving. dynamic - Enable deriving for the Data and Typeable classes. + Enable deriving for the Data and Typeable classes. dynamic + + Enable newtype deriving. + dynamic + + + Enable type synonyms. dynamic @@ -919,12 +925,6 @@ dynamic - - - Enable newtype deriving. - dynamic - - diff --git a/docs/users_guide/glasgow_exts.xml b/docs/users_guide/glasgow_exts.xml index 4d9a977..372ebab 100644 --- a/docs/users_guide/glasgow_exts.xml +++ b/docs/users_guide/glasgow_exts.xml @@ -1916,9 +1916,77 @@ their selector functions actually have different types: + + +Extensions to the "deriving" mechanism + + +Inferred context for deriving clauses + + +The Haskell Report is vague about exactly when a deriving clause is +legal. For example: + + data T0 f a = MkT0 a deriving( Eq ) + data T1 f a = MkT1 (f a) deriving( Eq ) + data T2 f a = MkT2 (f (f a)) deriving( Eq ) + +The natural generated Eq code would result in these instance declarations: + + instance Eq a => Eq (T0 f a) where ... + instance Eq (f a) => Eq (T1 f a) where ... + instance Eq (f (f a)) => Eq (T2 f a) where ... + +The first of these is obviously fine. The second is still fine, although less obviously. +The third is not Haskell 98, and risks losing termination of instances. + + +GHC takes a conservative position: it accepts the first two, but not the third. The rule is this: +each constraint in the inferred instance context must consist only of type variables, +with no repititions. + + +This rule is applied regardless of flags. If you want a more exotic context, you can write +it yourself, using the standalone deriving mechanism. + + + + +Stand-alone deriving declarations + + +GHC now allows stand-alone deriving declarations, enabled by -XStandaloneDeriving: + + data Foo a = Bar a | Baz String + + deriving instance Eq a => Eq (Foo a) + +The syntax is identical to that of an ordinary instance declaration apart from (a) the keyword +deriving, and (b) the absence of the where part. +You must supply a context (in the example the context is (Eq a)), +exactly as you would in an ordinary instance declaration. +(In contrast the context is inferred in a deriving clause +attached to a data type declaration.) These deriving instance +rules obey the same rules concerning form and termination as ordinary instance declarations, +controlled by the same flags; see . + +The stand-alone syntax is generalised for newtypes in exactly the same +way that ordinary deriving clauses are generalised (). +For example: + + newtype Foo a = MkFoo (State Int a) + + deriving instance MonadState Int Foo + +GHC always treats the last parameter of the instance +(Foo in this exmample) as the type whose instance is being derived. + + + + Deriving clause for classes <literal>Typeable</literal> and <literal>Data</literal> @@ -1932,7 +2000,7 @@ classes Eq, Ord, GHC extends this list with two more classes that may be automatically derived -(provided the flag is specified): +(provided the flag is specified): Typeable, and Data. These classes are defined in the library modules Data.Typeable and Data.Generics respectively, and the appropriate class must be in scope before it can be mentioned in the deriving clause. @@ -1986,7 +2054,9 @@ dictionary, only slower! Generalising the deriving clause -GHC now permits such instances to be derived instead, so one can write +GHC now permits such instances to be derived instead, +using the flag , +so one can write newtype Dollars = Dollars Int deriving (Eq,Show,Num) @@ -2032,7 +2102,7 @@ In this case the derived instance declaration is of the form Notice that, since Monad is a constructor class, the instance is a partial application of the new type, not the entire left hand side. We can imagine that the type declaration is -``eta-converted'' to generate the context of the instance +"eta-converted" to generate the context of the instance declaration. @@ -2148,41 +2218,13 @@ and Data, for which the built-in derivation applies (section the standard method is used or the one described here.) - - - -Stand-alone deriving declarations - - -GHC now allows stand-alone deriving declarations, enabled by -fglasgow-exts: - - data Foo a = Bar a | Baz String - - derive instance Eq (Foo a) - -The token "derive" is a keyword only when followed by "instance"; -you can use it as a variable name elsewhere. -The stand-alone syntax is generalised for newtypes in exactly the same -way that ordinary deriving clauses are generalised (). -For example: - - newtype Foo a = MkFoo (State Int a) - - derive instance MonadState Int Foo - -GHC always treats the last parameter of the instance -(Foo in this exmample) as the type whose instance is being derived. - - - - - -Other type system extensions + +Class and instances declarations Class declarations @@ -2940,6 +2982,86 @@ reversed, but it makes sense to me. + +Overloaded string literals + + + +GHC supports overloaded string literals. Normally a +string literal has type String, but with overloaded string +literals enabled (with -XOverloadedStrings) + a string literal has type (IsString a) => a. + + +This means that the usual string syntax can be used, e.g., for packed strings +and other variations of string like types. String literals behave very much +like integer literals, i.e., they can be used in both expressions and patterns. +If used in a pattern the literal with be replaced by an equality test, in the same +way as an integer literal is. + + +The class IsString is defined as: + +class IsString a where + fromString :: String -> a + +The only predefined instance is the obvious one to make strings work as usual: + +instance IsString [Char] where + fromString cs = cs + +The class IsString is not in scope by default. If you want to mention +it explicitly (for exmaple, to give an instance declaration for it), you can import it +from module GHC.Exts. + + +Haskell's defaulting mechanism is extended to cover string literals, when is specified. +Specifically: + + +Each type in a default declaration must be an +instance of Num or of IsString. + + + +The standard defaulting rule (Haskell Report, Section 4.3.4) +is extended thus: defaulting applies when all the unresolved constraints involve standard classes +or IsString; and at least one is a numeric class +or IsString. + + + + +A small example: + +module Main where + +import GHC.Exts( IsString(..) ) + +newtype MyString = MyString String deriving (Eq, Show) +instance IsString MyString where + fromString = MyString + +greet :: MyString -> MyString +greet "hello" = "world" +greet other = other + +main = do + print $ greet "hello" + print $ greet "fool" + + + +Note that deriving Eq is necessary for the pattern matching +to work since it gets translated into an equality comparison. + + + + + + +Other type system extensions + Type signatures @@ -4155,81 +4277,6 @@ pattern binding must have the same context. For example, this is fine: - -Overloaded string literals - - - -GHC supports overloaded string literals. Normally a -string literal has type String, but with overloaded string -literals enabled (with -XOverloadedStrings) - a string literal has type (IsString a) => a. - - -This means that the usual string syntax can be used, e.g., for packed strings -and other variations of string like types. String literals behave very much -like integer literals, i.e., they can be used in both expressions and patterns. -If used in a pattern the literal with be replaced by an equality test, in the same -way as an integer literal is. - - -The class IsString is defined as: - -class IsString a where - fromString :: String -> a - -The only predefined instance is the obvious one to make strings work as usual: - -instance IsString [Char] where - fromString cs = cs - -The class IsString is not in scope by default. If you want to mention -it explicitly (for exmaple, to give an instance declaration for it), you can import it -from module GHC.Exts. - - -Haskell's defaulting mechanism is extended to cover string literals, when is specified. -Specifically: - - -Each type in a default declaration must be an -instance of Num or of IsString. - - - -The standard defaulting rule (Haskell Report, Section 4.3.4) -is extended thus: defaulting applies when all the unresolved constraints involve standard classes -or IsString; and at least one is a numeric class -or IsString. - - - - -A small example: - -module Main where - -import GHC.Exts( IsString(..) ) - -newtype MyString = MyString String deriving (Eq, Show) -instance IsString MyString where - fromString = MyString - -greet :: MyString -> MyString -greet "hello" = "world" -greet other = other - -main = do - print $ greet "hello" - print $ greet "fool" - - - -Note that deriving Eq is necessary for the pattern matching -to work since it gets translated into an equality comparison. - - - Type families -- 1.7.10.4