diff options
-rw-r--r-- | compiler/basicTypes/OccName.lhs | 5 | ||||
-rw-r--r-- | compiler/prelude/PrelNames.lhs | 13 | ||||
-rw-r--r-- | compiler/typecheck/TcDeriv.lhs | 158 | ||||
-rw-r--r-- | compiler/typecheck/TcGenGenerics.lhs | 514 |
4 files changed, 521 insertions, 169 deletions
diff --git a/compiler/basicTypes/OccName.lhs b/compiler/basicTypes/OccName.lhs index 27e995a839..553797f263 100644 --- a/compiler/basicTypes/OccName.lhs +++ b/compiler/basicTypes/OccName.lhs @@ -63,7 +63,7 @@ module OccName ( mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc, mkClassDataConOcc, mkDictOcc, mkIPOcc, mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2, - mkGenD, mkGenR, mkGenRCo, mkGenC, mkGenS, + mkGenD, mkGenR, mkGen1R, mkGenRCo, mkGenC, mkGenS, mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc, mkSuperDictSelOcc, mkLocalOcc, mkMethodOcc, mkInstTyTcOcc, mkInstTyCoOcc, mkEqPredCoOcc, @@ -575,7 +575,7 @@ isDerivedOccName occ = mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, mkGenDefMethodOcc, mkDerivedTyConOcc, mkClassDataConOcc, mkDictOcc, mkIPOcc, mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2, - mkGenD, mkGenR, mkGenRCo, + mkGenD, mkGenR, mkGen1R, mkGenRCo, mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc, mkNewTyCoOcc, mkInstTyCoOcc, mkEqPredCoOcc, mkClassOpAuxOcc, mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc @@ -618,6 +618,7 @@ mkGenS occ m n = mk_deriv tcName ("S1_" ++ show m ++ "_" ++ show n) (occNameString occ) mkGenR = mk_simple_deriv tcName "Rep_" +mkGen1R = mk_simple_deriv tcName "Rep1_" mkGenRCo = mk_simple_deriv tcName "CoRep_" -- data T = MkT ... deriving( Data ) needs defintions for diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs index 3a39d531bb..31749744e7 100644 --- a/compiler/prelude/PrelNames.lhs +++ b/compiler/prelude/PrelNames.lhs @@ -355,7 +355,6 @@ gHC_PRIM, gHC_TYPES, gHC_GENERICS, gHC_PRIM = mkPrimModule (fsLit "GHC.Prim") -- Primitive types and values gHC_TYPES = mkPrimModule (fsLit "GHC.Types") -gHC_GENERICS = mkPrimModule (fsLit "GHC.Generics") gHC_MAGIC = mkPrimModule (fsLit "GHC.Magic") gHC_CSTRING = mkPrimModule (fsLit "GHC.CString") gHC_CLASSES = mkPrimModule (fsLit "GHC.Classes") @@ -404,6 +403,7 @@ gHC_DESUGAR = mkBaseModule (fsLit "GHC.Desugar") rANDOM = mkBaseModule (fsLit "System.Random") gHC_EXTS = mkBaseModule (fsLit "GHC.Exts") cONTROL_EXCEPTION_BASE = mkBaseModule (fsLit "Control.Exception.Base") +gHC_GENERICS = mkBaseModule (fsLit "GHC.Generics") gHC_TYPELITS = mkBaseModule (fsLit "GHC.TypeLits") gHC_IP = mkBaseModule (fsLit "GHC.IP") @@ -627,8 +627,10 @@ error_RDR = varQual_RDR gHC_ERR (fsLit "error") -- Generics (constructors and functions) u1DataCon_RDR, par1DataCon_RDR, rec1DataCon_RDR, k1DataCon_RDR, m1DataCon_RDR, l1DataCon_RDR, r1DataCon_RDR, - prodDataCon_RDR, comp1DataCon_RDR, from_RDR, from1_RDR, - to_RDR, to1_RDR, datatypeName_RDR, moduleName_RDR, conName_RDR, + prodDataCon_RDR, comp1DataCon_RDR, + unPar1_RDR, unRec1_RDR, unK1_RDR, unComp1_RDR, + from_RDR, from1_RDR, to_RDR, to1_RDR, + datatypeName_RDR, moduleName_RDR, conName_RDR, conFixity_RDR, conIsRecord_RDR, noArityDataCon_RDR, arityDataCon_RDR, selName_RDR, prefixDataCon_RDR, infixDataCon_RDR, leftAssocDataCon_RDR, @@ -646,6 +648,11 @@ r1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "R1") prodDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit ":*:") comp1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Comp1") +unPar1_RDR = varQual_RDR gHC_GENERICS (fsLit "unPar1") +unRec1_RDR = varQual_RDR gHC_GENERICS (fsLit "unRec1") +unK1_RDR = varQual_RDR gHC_GENERICS (fsLit "unK1") +unComp1_RDR = varQual_RDR gHC_GENERICS (fsLit "unComp1") + from_RDR = varQual_RDR gHC_GENERICS (fsLit "from") from1_RDR = varQual_RDR gHC_GENERICS (fsLit "from1") to_RDR = varQual_RDR gHC_GENERICS (fsLit "to") diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index 1dc2d26385..bbda3cfcf0 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -316,25 +316,34 @@ tcDeriving tycl_decls inst_decls deriv_decls ; traceTc "tcDeriving" (ppr is_boot) ; early_specs <- makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls + -- for each type, determine the auxliary declarations that are common + -- to multiple derivations involving that type (e.g. Generic and + -- Generic1 should use the same TcGenGenerics.MetaTyCons) + ; (commonAuxs, auxDerivStuff) <- commonAuxiliaries $ map (either id id) early_specs + ; overlap_flag <- getOverlapFlag ; let (infer_specs, given_specs) = splitEithers early_specs - ; insts1 <- mapM (genInst True overlap_flag) given_specs + ; insts1 <- mapM (genInst True overlap_flag commonAuxs) given_specs + -- the stand-alone derived instances (@insts1@) are used when inferring + -- the contexts for "deriving" clauses' instances (@infer_specs@) ; final_specs <- extendLocalInstEnv (map (iSpec . fst) insts1) $ inferInstanceContexts overlap_flag infer_specs - ; insts2 <- mapM (genInst False overlap_flag) final_specs + ; insts2 <- mapM (genInst False overlap_flag commonAuxs) final_specs ; let (inst_infos, deriv_stuff) = unzip (insts1 ++ insts2) ; loc <- getSrcSpanM ; let (binds, newTyCons, famInsts, extraInstances) = - genAuxBinds loc (unionManyBags deriv_stuff) + genAuxBinds loc (unionManyBags (auxDerivStuff : deriv_stuff)) + ; (inst_info, rn_binds, rn_dus) <- renameDeriv is_boot (inst_infos ++ (bagToList extraInstances)) binds - ; dflags <- getDynFlags - ; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances" - (ddump_deriving inst_info rn_binds newTyCons famInsts)) + ; dflags <- getDynFlags + ; unless (isEmptyBag inst_info) $ + liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances" + (ddump_deriving inst_info rn_binds newTyCons famInsts)) ; let all_tycons = map ATyCon (bagToList newTyCons) ; gbl_env <- tcExtendGlobalEnv all_tycons $ @@ -360,6 +369,25 @@ tcDeriving tycl_decls inst_decls deriv_decls hangP s x = text "" $$ hang (ptext (sLit s)) 2 x + + +-- As of 24 April 2012, this only shares MetaTyCons between derivations of +-- Generic and Generic1; thus the types and logic are quite simple. +type CommonAuxiliary = MetaTyCons +type CommonAuxiliaries = [(TyCon, CommonAuxiliary)] -- NSF what is a more efficient map type? +commonAuxiliaries :: [DerivSpec] -> TcM (CommonAuxiliaries, BagDerivStuff) +commonAuxiliaries = foldM snoc ([], emptyBag) where + snoc acc@(cas, stuff) (DS {ds_name = nm, ds_cls = cls, ds_tc = rep_tycon}) + | getUnique cls `elem` [genClassKey, gen1ClassKey] = + extendComAux $ genGenericMetaTyCons rep_tycon (nameModule nm) + | otherwise = return acc + where extendComAux m -- don't run m if its already in the accumulator + | any ((rep_tycon ==) . fst) cas = return acc + | otherwise = do (ca, new_stuff) <- m + return $ ((rep_tycon, ca) : cas, stuff `unionBags` new_stuff) + + + -- Prints the representable type family instance pprRepTy :: FamInst -> SDoc pprRepTy fi @@ -632,7 +660,7 @@ mkEqnHelp orig tvs cls cls_tys tc_app mtheta mk_alg_eqn tycon tc_args | className cls `elem` typeableClassNames = do { dflags <- getDynFlags - ; case checkTypeableConditions (dflags, tycon) of + ; case checkTypeableConditions (dflags, tycon, tc_args) of Just err -> bale_out err Nothing -> mk_typeable_eqn orig tvs cls tycon tc_args mtheta } @@ -687,7 +715,7 @@ mkDataTypeEqn :: CtOrigin mkDataTypeEqn orig dflags tvs cls cls_tys tycon tc_args rep_tc rep_tc_args mtheta - = case checkSideConditions dflags mtheta cls cls_tys rep_tc of + = case checkSideConditions dflags mtheta cls cls_tys rep_tc rep_tc_args of -- NB: pass the *representation* tycon to checkSideConditions CanDerive -> go_for_it NonDerivableClass -> bale_out (nonStdErr cls) @@ -702,8 +730,11 @@ mk_data_eqn :: CtOrigin -> [TyVar] -> Class mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta = do { dfun_name <- new_dfun_name cls tycon ; loc <- getSrcSpanM + -- TODO NSF 9 April 2012: only recover from the anticipated + -- "base:Data.Functor.Functor could not be found" error + ; (_, functorClass_maybe) <- tryTc $ tcLookupClass functorClassName ; let inst_tys = [mkTyConApp tycon tc_args] - inferred_constraints = inferConstraints tvs cls inst_tys rep_tc rep_tc_args + inferred_constraints = inferConstraints functorClass_maybe tvs cls inst_tys rep_tc rep_tc_args spec = DS { ds_loc = loc, ds_orig = orig , ds_name = dfun_name, ds_tvs = tvs , ds_cls = cls, ds_tys = inst_tys @@ -747,23 +778,29 @@ mk_typeable_eqn orig tvs cls tycon tc_args mtheta , ds_theta = mtheta `orElse` [], ds_newtype = False }) } ---------------------- -inferConstraints :: [TyVar] -> Class -> [TcType] -> TyCon -> [TcType] -> ThetaType +inferConstraints :: Maybe Class -> -- the base:Functor class, if in scope + [TyVar] -> Class -> [TcType] -> TyCon -> [TcType] -> ThetaType -- Generate a sufficiently large set of constraints that typechecking the -- generated method definitions should succeed. This set will be simplified -- before being used in the instance declaration -inferConstraints _ cls inst_tys rep_tc rep_tc_args +inferConstraints functorClass_maybe _ cls inst_tys rep_tc rep_tc_args -- Generic constraints are easy | cls `hasKey` genClassKey = [] + | cls `hasKey` gen1ClassKey + = ASSERT (length rep_tc_tvs > 0) + con_arg_constraints functorClass_maybe (get_gen1_constrained_tys last_tv) -- The others are a bit more complicated | otherwise = ASSERT2( equalLength rep_tc_tvs all_rep_tc_args, ppr cls <+> ppr rep_tc ) stupid_constraints ++ extra_constraints - ++ sc_constraints ++ con_arg_constraints + ++ sc_constraints + ++ con_arg_constraints (Just cls) get_std_constrained_tys where -- Constraints arising from the arguments of each constructor - con_arg_constraints - = [ mkClassPred cls [arg_ty] + con_arg_constraints Nothing _ = [] + con_arg_constraints (Just cls') get_constrained_tys + = [ mkClassPred cls' [arg_ty] | data_con <- tyConDataCons rep_tc, arg_ty <- ASSERT( isVanillaDataCon data_con ) get_constrained_tys $ @@ -778,14 +815,15 @@ inferConstraints _ cls inst_tys rep_tc rep_tc_args -- (b) The rep_tc_args will be one short is_functor_like = getUnique cls `elem` functorLikeClassKeys - get_constrained_tys :: [Type] -> [Type] - get_constrained_tys tys + get_std_constrained_tys :: [Type] -> [Type] + get_std_constrained_tys tys | is_functor_like = concatMap (deepSubtypesContaining last_tv) tys | otherwise = tys rep_tc_tvs = tyConTyVars rep_tc last_tv = last rep_tc_tvs - all_rep_tc_args | is_functor_like = rep_tc_args ++ [mkTyVarTy last_tv] + all_rep_tc_args | cls `hasKey` gen1ClassKey || is_functor_like + = rep_tc_args ++ [mkTyVarTy last_tv] | otherwise = rep_tc_args -- Constraints arising from superclasses @@ -841,10 +879,12 @@ data DerivStatus = CanDerive | DerivableClassError SDoc -- Standard class, but can't do it | NonDerivableClass -- Non-standard class -checkSideConditions :: DynFlags -> DerivContext -> Class -> [TcType] -> TyCon -> DerivStatus -checkSideConditions dflags mtheta cls cls_tys rep_tc +checkSideConditions :: DynFlags -> DerivContext -> Class -> [TcType] + -> TyCon -> [Type] -- tycon and its parameters + -> DerivStatus +checkSideConditions dflags mtheta cls cls_tys rep_tc rep_tc_args | Just cond <- sideConditions mtheta cls - = case (cond (dflags, rep_tc)) of + = case (cond (dflags, rep_tc, rep_tc_args)) of Just err -> DerivableClassError err -- Class-specific error Nothing | null cls_tys -> CanDerive -- All derivable classes are unary, so -- cls_tys (the type args other than last) @@ -879,17 +919,19 @@ sideConditions mtheta cls cond_functorOK False) | cls_key == genClassKey = Just (cond_RepresentableOk `andCond` checkFlag Opt_DeriveGeneric) + | cls_key == gen1ClassKey = Just (cond_Representable1Ok `andCond` + checkFlag Opt_DeriveGeneric) | otherwise = Nothing where cls_key = getUnique cls cond_std = cond_stdOK mtheta -type Condition = (DynFlags, TyCon) -> Maybe SDoc - -- first Bool is whether or not we are allowed to derive Data and Typeable - -- second Bool is whether or not we are allowed to derive Functor - -- TyCon is the *representation* tycon if the - -- data type is an indexed one - -- Nothing => OK +type Condition = (DynFlags, TyCon, [Type]) -> Maybe SDoc + -- first Bool is whether or not we are allowed to derive Data and Typeable + -- second Bool is whether or not we are allowed to derive Functor + -- TyCon is the *representation* tycon if the data type is an indexed one + -- [Type] are the type arguments to the (representation) TyCon + -- Nothing => OK orCond :: Condition -> Condition -> Condition orCond c1 c2 tc @@ -910,7 +952,7 @@ cond_stdOK (Just _) _ = Nothing -- Don't check these conservative conditions for -- standalone deriving; just generate the code -- and let the typechecker handle the result -cond_stdOK Nothing (_, rep_tc) +cond_stdOK Nothing (_, rep_tc, _) | null data_cons = Just (no_cons_why rep_tc $$ suggestion) | not (null con_whys) = Just (vcat con_whys $$ suggestion) | otherwise = Nothing @@ -930,7 +972,10 @@ no_cons_why rep_tc = quotes (pprSourceTyCon rep_tc) <+> ptext (sLit "must have at least one data constructor") cond_RepresentableOk :: Condition -cond_RepresentableOk (_,t) = canDoGenerics t +cond_RepresentableOk (_, tc, tc_args) = canDoGenerics tc tc_args + +cond_Representable1Ok :: Condition +cond_Representable1Ok (_, tc, tc_args) = canDoGenerics1 tc tc_args cond_enumOrProduct :: Class -> Condition cond_enumOrProduct cls = cond_isEnumeration `orCond` @@ -939,7 +984,7 @@ cond_enumOrProduct cls = cond_isEnumeration `orCond` cond_args :: Class -> Condition -- For some classes (eg Eq, Ord) we allow unlifted arg types -- by generating specilaised code. For others (eg Data) we don't. -cond_args cls (_, tc) +cond_args cls (_, tc, _) = case bad_args of [] -> Nothing (ty:_) -> Just (hang (ptext (sLit "Don't know how to derive") <+> quotes (ppr cls)) @@ -962,7 +1007,7 @@ cond_args cls (_, tc) cond_isEnumeration :: Condition -cond_isEnumeration (_, rep_tc) +cond_isEnumeration (_, rep_tc, _) | isEnumerationTyCon rep_tc = Nothing | otherwise = Just why where @@ -972,7 +1017,7 @@ cond_isEnumeration (_, rep_tc) -- See Note [Enumeration types] in TyCon cond_isProduct :: Condition -cond_isProduct (_, rep_tc) +cond_isProduct (_, rep_tc, _) | isProductTyCon rep_tc = Nothing | otherwise = Just why where @@ -983,7 +1028,7 @@ cond_typeableOK :: Condition -- OK for Typeable class -- Currently: (a) args all of kind * -- (b) 7 or fewer args -cond_typeableOK (_, tc) +cond_typeableOK (_, tc, _) | tyConArity tc > 7 = Just too_many | not (all (isSubOpenTypeKind . tyVarKind) (tyConTyVars tc)) = Just bad_kind @@ -1004,7 +1049,7 @@ cond_functorOK :: Bool -> Condition -- (c) don't use argument in the wrong place, e.g. data T a = T (X a a) -- (d) optionally: don't use function types -- (e) no "stupid context" on data type -cond_functorOK allowFunctions (_, rep_tc) +cond_functorOK allowFunctions (_, rep_tc, _) | null tc_tvs = Just (ptext (sLit "Data type") <+> quotes (ppr rep_tc) <+> ptext (sLit "must have some type parameters")) @@ -1044,7 +1089,7 @@ cond_functorOK allowFunctions (_, rep_tc) wrong_arg = ptext (sLit "must use the type variable only as the last argument of a data type") checkFlag :: ExtensionFlag -> Condition -checkFlag flag (dflags, _) +checkFlag flag (dflags, _, _) | xopt flag dflags = Nothing | otherwise = Just why where @@ -1065,11 +1110,11 @@ std_class_via_iso clas non_iso_class :: Class -> Bool --- *Never* derive Read, Show, Typeable, Data, Generic by isomorphism, +-- *Never* derive Read, Show, Typeable, Data, Generic, Generic1 by isomorphism, -- even with -XGeneralizedNewtypeDeriving non_iso_class cls = classKey cls `elem` ([ readClassKey, showClassKey, dataClassKey - , genClassKey] ++ typeableClassKeys) + , genClassKey, gen1ClassKey] ++ typeableClassKeys) typeableClassKeys :: [Unique] typeableClassKeys = map getUnique typeableClassNames @@ -1138,7 +1183,7 @@ mkNewTypeEqn orig dflags tvs else Left spec) } | otherwise - = case checkSideConditions dflags mtheta cls cls_tys rep_tycon of + = case checkSideConditions dflags mtheta cls cls_tys rep_tycon rep_tc_args of CanDerive -> go_for_it -- Use the standard H98 method DerivableClassError msg -- Error with standard class | can_derive_via_isomorphism -> bale_out (msg $$ suggest_nd) @@ -1458,8 +1503,9 @@ the renamer. What a great hack! -- genInst :: Bool -- True <=> standalone deriving -> OverlapFlag + -> CommonAuxiliaries -> DerivSpec -> TcM (InstInfo RdrName, BagDerivStuff) -genInst standalone_deriv oflag +genInst standalone_deriv oflag comauxs spec@(DS { ds_tvs = tvs, ds_tc = rep_tycon, ds_tc_args = rep_tc_args , ds_theta = theta, ds_newtype = is_newtype , ds_name = name, ds_cls = clas }) @@ -1471,6 +1517,7 @@ genInst standalone_deriv oflag = do { fix_env <- getFixityEnv ; (meth_binds, deriv_stuff) <- genDerivStuff (getSrcSpan name) fix_env clas name rep_tycon + (lookup rep_tycon comauxs) ; let inst_info = InstInfo { iSpec = inst_spec , iBinds = VanillaInst meth_binds [] standalone_deriv } @@ -1495,13 +1542,18 @@ genInst standalone_deriv oflag -- co : N [(b,b)] ~ Tree (b,b) genDerivStuff :: SrcSpan -> FixityEnv -> Class -> Name -> TyCon + -> Maybe CommonAuxiliary -> TcM (LHsBinds RdrName, BagDerivStuff) -genDerivStuff loc fix_env clas name tycon +genDerivStuff loc fix_env clas name tycon comaux_maybe | className clas `elem` typeableClassNames = return (gen_Typeable_binds loc tycon, emptyBag) - | classKey clas == genClassKey -- Special case because monadic - = gen_Generic_binds tycon (nameModule name) + | ck `elem` [genClassKey, gen1ClassKey] -- Special case because monadic + = let gk = if ck == genClassKey then Gen0 else Gen1 -- TODO NSF: correctly identify when we're building Both instead of One + Just metaTyCons = comaux_maybe -- well-guarded by commonAuxiliaries and genInst + in do + (binds, faminst) <- gen_Generic_binds gk tycon metaTyCons (nameModule name) + return (binds, DerivFamInst faminst `consBag` emptyBag) | otherwise -- Non-monadic generators = do dflags <- getDynFlags @@ -1509,20 +1561,22 @@ genDerivStuff loc fix_env clas name tycon Just gen_fn -> return (gen_fn loc tycon) Nothing -> pprPanic "genDerivStuff: bad derived class" (ppr clas) where + ck = classKey clas + gen_list :: DynFlags -> [(Unique, SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff))] gen_list dflags - = [(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 dflags) - ,(functorClassKey, gen_Functor_binds) - ,(foldableClassKey, gen_Foldable_binds) - ,(traversableClassKey, gen_Traversable_binds) + = [(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 dflags) + ,(functorClassKey, gen_Functor_binds) + ,(foldableClassKey, gen_Foldable_binds) + ,(traversableClassKey, gen_Traversable_binds) ] \end{code} diff --git a/compiler/typecheck/TcGenGenerics.lhs b/compiler/typecheck/TcGenGenerics.lhs index 27f21c2e25..8745f8e612 100644 --- a/compiler/typecheck/TcGenGenerics.lhs +++ b/compiler/typecheck/TcGenGenerics.lhs @@ -6,6 +6,7 @@ The deriving code for the Generic class (equivalent to the code in TcGenDeriv, for other classes) \begin{code} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS -fno-warn-tabs #-} -- The above warning supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and @@ -14,8 +15,10 @@ The deriving code for the Generic class -- for details -module TcGenGenerics (canDoGenerics, gen_Generic_binds) where - +module TcGenGenerics (canDoGenerics, canDoGenerics1, + GenericKind(..), + MetaTyCons, genGenericMetaTyCons, + gen_Generic_binds, get_gen1_constrained_tys) where import DynFlags import HsSyn @@ -40,11 +43,15 @@ import HscTypes import BuildTyCl import SrcLoc import Bag +import VarSet (elemVarSet) import Outputable import FastString import UniqSupply import Util +import Control.Monad (mplus) +import qualified State as S + #include "HsVersions.h" \end{code} @@ -62,19 +69,14 @@ For the generic representation we need to generate: \end{itemize} \begin{code} -gen_Generic_binds :: TyCon -> Module - -> TcM (LHsBinds RdrName, BagDerivStuff) -gen_Generic_binds tc mod = do - { (metaTyCons, rep0TyInst) <- genGenericRepExtras tc mod - ; metaInsts <- genDtMeta (tc, metaTyCons) - ; dflags <- getDynFlags - ; return ( mkBindsRep dflags tc - , (DerivFamInst rep0TyInst) - `consBag` ((mapBag DerivTyCon (metaTyCons2TyCons metaTyCons)) - `unionBags` metaInsts)) } - -genGenericRepExtras :: TyCon -> Module -> TcM (MetaTyCons, FamInst) -genGenericRepExtras tc mod = +gen_Generic_binds :: GenericKind -> TyCon -> MetaTyCons -> Module + -> TcM (LHsBinds RdrName, FamInst) +gen_Generic_binds gk tc metaTyCons mod = do + repTyInsts <- tc_mkRepFamInsts gk tc metaTyCons mod + return (mkBindsRep gk tc, repTyInsts) + +genGenericMetaTyCons :: TyCon -> Module -> TcM (MetaTyCons, BagDerivStuff) +genGenericMetaTyCons tc mod = do uniqS <- newUniqueSupply let -- Uniques for everyone @@ -110,14 +112,13 @@ genGenericRepExtras tc mod = | s_namesC <- s_names ] metaDts = MetaTyCons metaDTyCon metaCTyCons metaSTyCons - - rep0_tycon <- tc_mkRepTyCon tc metaDts mod - + -- pprTrace "rep0" (ppr rep0_tycon) $ - return (metaDts, rep0_tycon) + (,) metaDts `fmap` metaTyConsToDerivStuff tc metaDts -genDtMeta :: (TyCon, MetaTyCons) -> TcM BagDerivStuff -genDtMeta (tc,metaDts) = +-- both the tycon declarations and related instances +metaTyConsToDerivStuff :: TyCon -> MetaTyCons -> TcM BagDerivStuff +metaTyConsToDerivStuff tc metaDts = do loc <- getSrcSpanM dflags <- getDynFlags dClas <- tcLookupClass datatypeClassName @@ -133,7 +134,7 @@ genDtMeta (tc,metaDts) = let safeOverlap = safeLanguageOn dflags - (dBinds,cBinds,sBinds) = mkBindsMetaD dflags fix_env tc + (dBinds,cBinds,sBinds) = mkBindsMetaD fix_env tc -- Datatype d_metaTycon = metaD metaDts @@ -173,7 +174,8 @@ genDtMeta (tc,metaDts) = ASSERT (and (zipWith (>=) (map length l1) (map length l2))) [ zip x1 x2 | (x1,x2) <- zip l1 l2 ] - return (listToBag (d_mkInst : c_mkInst ++ concat s_mkInst)) + return $ mapBag DerivTyCon (metaTyCons2TyCons metaDts) + `unionBags` listToBag (d_mkInst : c_mkInst ++ concat s_mkInst) \end{code} %************************************************************************ @@ -183,25 +185,47 @@ genDtMeta (tc,metaDts) = %************************************************************************ \begin{code} -canDoGenerics :: TyCon -> Maybe SDoc +get_gen1_constrained_tys :: TyVar -> [Type] -> [Type] +-- called by TcDeriv.inferConstraints; generates a list of types, each of which +-- must be a Functor in order for the Generic1 instance to work. +get_gen1_constrained_tys argVar = + concatMap $ argTyFold argVar $ ArgTyAlg { + ata_rec0 = const [], + ata_par1 = [], ata_rec1 = const [], + ata_comp = (:)} + + + +canDoGenerics :: TyCon -> [Type] -> Maybe SDoc -- Called on source-code data types, to see if we should generate -- generic functions for them. -- Nothing == yes -- Just s == no, because of `s` -canDoGenerics tycon - = mergeErrors ( +canDoGenerics tc tc_args + = mergeErrors ( -- We do not support datatypes with context - (if (not (null (tyConStupidTheta tycon))) - then (Just (ppr tycon <+> text "must not have a datatype context")) - else Nothing) - -- We don't like type families - : (if (isFamilyTyCon tycon) - then (Just (ppr tycon <+> text "must not be a family instance")) - else Nothing) + (if (not (null (tyConStupidTheta tc))) + then (Just (tc_name <+> text "must not have a datatype context")) + else Nothing) : + -- The type should not be instantiated (see #5939) + -- Data family indices can be instantiated; the `tc_args` here are the + -- representation tycon args + (if (all isTyVarTy tc_args) + then Nothing + else Just (tc_name <+> text "must not be instantiated;" <+> + text "try deriving `" <> tc_name <+> tc_tys <> + text "' instead")) -- See comment below - : (map bad_con (tyConDataCons tycon))) + : (map bad_con (tyConDataCons tc))) where + -- The tc can be a representation tycon. When we want to display it to the + -- user (in an error message) we should print its parent + (tc_name, tc_tys) = case tyConParent tc of + FamInstTyCon _ ptc tys -> (ppr ptc, hsep (map ppr + (tys ++ drop (length tys) tc_args))) + _ -> (ppr tc, hsep (map ppr tc_args)) + -- If any of the constructor has an unboxed type as argument, -- then we can't build the embedding-projection pair, because -- it relies on instantiating *polymorphic* sum and product types @@ -215,13 +239,109 @@ canDoGenerics tycon -- Nor can we do the job if it's an existential data constructor, -- Nor if the args are polymorphic types (I don't think) bad_arg_type ty = isUnLiftedType ty || not (isTauTy ty) - - mergeErrors :: [Maybe SDoc] -> Maybe SDoc - mergeErrors [] = Nothing - mergeErrors ((Just s):t) = case mergeErrors t of - Nothing -> Just s - Just s' -> Just (s <> text ", and" $$ s') - mergeErrors (Nothing :t) = mergeErrors t + +mergeErrors :: [Maybe SDoc] -> Maybe SDoc +mergeErrors [] = Nothing +mergeErrors ((Just s):t) = case mergeErrors t of + Nothing -> Just s + Just s' -> Just (s <> text ", and" $$ s') +mergeErrors (Nothing :t) = mergeErrors t + +canDoGenerics1 :: TyCon -> [Type] -> Maybe SDoc +-- Called on source-code data types, to see if we should generate +-- generic functions for them. +-- Nothing == yes +-- Just s == no, because of `s` + +-- (derived from TcDeriv.cond_functorOK; also checks canDoGenerics) + +-- OK for Generic1/Rep1 +-- Currently: (a) at least one argument +-- (b) don't use argument contravariantly +-- (c) don't use argument in the wrong place, e.g. data T a = T (X a a) +-- (d) no "stupid context" on data type +-- (e) not instantiated (except for data family indices) +canDoGenerics1 tc tc_args = canDoGenerics tc tc_args + `mplus` S.evalState (canDoGenerics1_w tc) [] + +-- the state is which tycons we have entered; it avoids divergence when we +-- recur (robust against mutual recursion) +canDoGenerics1_w :: TyCon -> S.State [Name] (Maybe SDoc) +canDoGenerics1_w rep_tc + | null tc_tvs + = return $ Just (ptext (sLit "Data type") <+> quotes (ppr rep_tc) + <+> ptext (sLit "must have some type parameters")) + + | not (null bad_stupid_theta) + = return $ Just (ptext (sLit "Data type") <+> quotes (ppr rep_tc) + <+> ptext (sLit "must not have a class context") <+> pprTheta bad_stupid_theta) + + | otherwise + = (mergeErrors . concat) `fmap` mapM check_con data_cons + where + tc_tvs = tyConTyVars rep_tc + Just (_, last_tv) = snocView tc_tvs + bad_stupid_theta = filter is_bad (tyConStupidTheta rep_tc) + is_bad pred = last_tv `elemVarSet` tyVarsOfType pred + + data_cons = tyConDataCons rep_tc + check_con con = case check_vanilla con of + j@(Just _) -> return [j] + Nothing -> mapM snd $ foldDataConArgs (ft_check con) con + + bad :: DataCon -> SDoc -> SDoc + bad con msg = ptext (sLit "Constructor") <+> quotes (ppr con) <+> msg + + check_vanilla :: DataCon -> Maybe SDoc + check_vanilla con | isVanillaDataCon con = Nothing + | otherwise = Just (bad con existential) + + -- the Bool is if the parameter occurs in the type + ft_check :: DataCon -> FFoldType (Bool, S.State [Name] (Maybe SDoc)) + ft_check con = FT { ft_triv = bmzero, ft_var = (True, return Nothing) + , ft_co_var = (True, return $ Just $ bad con covariant) + -- NB foldDataConArgs caters to Functor/Foldable/etc, + -- which treat applications of functions and tuples + -- specially. But we just treat them like normal + -- applications, so we must compensate with extra logic + -- to ensure that the variable only occurs as the last + -- argument. + , ft_fun = \x y -> if fst x then (True, return $ Just $ bad con wrong_arg) + else x `bmplus` y + , ft_tup = \_ xs -> + if not (null xs) && any fst (init xs) + then (True, return $ Just $ bad con wrong_arg) + else foldr bmplus bmzero xs + , ft_ty_app = \ty x -> bmplus x $ (,) False $ + if fst x then representable ty else return Nothing + , ft_bad_app = (True, return $ Just $ bad con wrong_arg) + , ft_forall = \_ -> id } + + bmzero = (False, return Nothing) + bmplus (b1, m1) (b2, m2) = (b1 || b2, m1 >>= maybe m2 (return . Just)) + + representable :: Type -> S.State [Name] (Maybe SDoc) + representable ty = case tcSplitTyConApp_maybe ty of + Nothing -> return Nothing + -- if it's a type constructor, it has to be representable + Just (tc, tc_args) -> do + let n = tyConName tc + s <- S.get + -- internally assume that recursive occurrences are OK + if n `elem` s then return Nothing else do + S.put (n : s) + fmap {-maybe-} (\_ -> bad_app tc) -- don't give the message, just name what wasn't representable + `fmap` {-state-} case canDoGenerics tc tc_args of + j@(Just _) -> return j + -- only check Generic1 if it passes Generic + Nothing -> canDoGenerics1_w tc + + existential = (ptext . sLit) "must not have existential arguments" + covariant = (ptext . sLit) "must not use the last type parameter in a function argument" + wrong_arg = (ptext . sLit) "must use the last type parameter only as the last argument of a data type, newtype, or (->)" + bad_app tc = (ptext . sLit) "must not apply type constructors that cannot be represented with `Rep1' (such as `" <> ppr (tyConName tc) + <> (ptext . sLit) "') to arguments that involve the last type parameter" + \end{code} %************************************************************************ @@ -234,91 +354,212 @@ canDoGenerics tycon type US = Int -- Local unique supply, just a plain Int type Alt = (LPat RdrName, LHsExpr RdrName) +-- GenericKind serves to mark if a datatype derives Generic (Gen0) or +-- Generic1 (Gen1). +data GenericKind = Gen0 | Gen1 + +-- as above, but with a payload of the TyCon's name for "the" parameter +data GenericKind_ = Gen0_ | Gen1_ TyVar + +-- as above, but using a single datacon's name for "the" parameter +data GenericKind_DC = Gen0_DC | Gen1_DC TyVar + +forgetArgVar :: GenericKind_DC -> GenericKind +forgetArgVar Gen0_DC = Gen0 +forgetArgVar Gen1_DC{} = Gen1 + +-- When working only within a single datacon, "the" parameter's name should +-- match that datacon's name for it. +gk2gkDC :: GenericKind_ -> DataCon -> GenericKind_DC +gk2gkDC Gen0_ _ = Gen0_DC +gk2gkDC Gen1_{} d = Gen1_DC $ last $ dataConUnivTyVars d + + + -- Bindings for the Generic instance -mkBindsRep :: DynFlags -> TyCon -> LHsBinds RdrName -mkBindsRep dflags tycon = - unitBag (L loc (mkFunBind (L loc from_RDR) from_matches)) +mkBindsRep :: GenericKind -> TyCon -> LHsBinds RdrName +mkBindsRep gk tycon = + unitBag (L loc (mkFunBind (L loc from01_RDR) from_matches)) `unionBags` - unitBag (L loc (mkFunBind (L loc to_RDR) to_matches)) + unitBag (L loc (mkFunBind (L loc to01_RDR) to_matches)) where from_matches = [mkSimpleHsAlt pat rhs | (pat,rhs) <- from_alts] to_matches = [mkSimpleHsAlt pat rhs | (pat,rhs) <- to_alts ] loc = srcLocSpan (getSrcLoc tycon) datacons = tyConDataCons tycon + (from01_RDR, to01_RDR) = case gk of + Gen0 -> (from_RDR, to_RDR) + Gen1 -> (from1_RDR, to1_RDR) + -- Recurse over the sum first from_alts, to_alts :: [Alt] - (from_alts, to_alts) = mkSum dflags (1 :: US) tycon datacons + (from_alts, to_alts) = mkSum gk_ (1 :: US) tycon datacons + where gk_ = case gk of + Gen0 -> Gen0_ + Gen1 -> ASSERT (length tyvars >= 1) + Gen1_ (last tyvars) + where tyvars = tyConTyVars tycon -------------------------------------------------------------------------------- --- The type instance synonym and synonym +-- The type synonym instance and synonym -- type instance Rep (D a b) = Rep_D a b -- type Rep_D a b = ...representation type for D ... -------------------------------------------------------------------------------- -tc_mkRepTyCon :: TyCon -- The type to generate representation for +tc_mkRepFamInsts :: GenericKind -- Gen0 or Gen1 + -> TyCon -- The type to generate representation for -> MetaTyCons -- Metadata datatypes to refer to -> Module -- Used as the location of the new RepTy -> TcM FamInst -- Generated representation0 coercion -tc_mkRepTyCon tycon metaDts mod = --- Consider the example input tycon `D`, where data D a b = D_ a - do { -- `rep0` = GHC.Generics.Rep (type family) - rep0 <- tcLookupTyCon repTyConName +tc_mkRepFamInsts gk tycon metaDts mod = + -- Consider the example input tycon `D`, where data D a b = D_ a + -- Also consider `R:DInt`, where { data family D x y :: * -> * + -- ; data instance D Int a b = D_ a } + do { -- `rep` = GHC.Generics.Rep or GHC.Generics.Rep1 (type family) + rep <- case gk of + Gen0 -> tcLookupTyCon repTyConName + Gen1 -> tcLookupTyCon rep1TyConName ; let -- `tyvars` = [a,b] - tyvars = tyConTyVars tycon - tyvar_args = mkTyVarTys tyvars + (tyvars, gk_) = case gk of + Gen0 -> (all_tyvars, Gen0_) + Gen1 -> ASSERT (not $ null all_tyvars) + (init all_tyvars, Gen1_ $ last all_tyvars) + where all_tyvars = tyConTyVars tycon - -- `appT` = D a b - appT = [mkTyConApp tycon tyvar_args] + tyvar_args = mkTyVarTys tyvars - -- `rep0Ty` = D1 ... (C1 ... (S1 ... (Rec0 a))) :: * -> * - ; rep0Ty <- tc_mkRepTy tycon tyvar_args metaDts + appT = case tyConFamInst_maybe tycon of + -- `appT` = D Int a b (data families case) + Just (famtycon, apps) -> + -- `fam` = D + -- `apps` = [Int, a] + let allApps = apps ++ + drop (length apps + length tyvars + - tyConArity famtycon) tyvar_args + in [mkTyConApp famtycon allApps] + -- `appT` = D a b (normal case) + Nothing -> [mkTyConApp tycon tyvar_args] + + -- `repTy` = D1 ... (C1 ... (S1 ... (Rec0 a))) :: * -> * + ; repTy <- tc_mkRepTy gk_ tycon metaDts -- `rep_name` is a name we generate for the synonym - ; rep_name <- newGlobalBinder mod (mkGenR (nameOccName (tyConName tycon))) - (nameSrcSpan (tyConName tycon)) + ; rep_name <- let mkGen = case gk of Gen0 -> mkGenR; Gen1 -> mkGen1R + in newGlobalBinder mod (mkGen (nameOccName (tyConName tycon))) + (nameSrcSpan (tyConName tycon)) - ; return $ mkSynFamInst rep_name tyvars rep0 appT rep0Ty + ; return $ mkSynFamInst rep_name tyvars rep appT repTy } - - -------------------------------------------------------------------------------- -- Type representation -------------------------------------------------------------------------------- -tc_mkRepTy :: -- The type to generate representation for, and instantiating types - TyCon -> [Type] +-- | See documentation of 'argTyFold'; that function uses the fields of this +-- type to interpret the structure of a type when that type is considered as an +-- argument to a constructor that is being represented with 'Rep1'. +data ArgTyAlg a = ArgTyAlg + { ata_rec0 :: (Type -> a) + , ata_par1 :: a, ata_rec1 :: (Type -> a) + , ata_comp :: (Type -> a -> a) + } + +-- | @argTyFold@ implements a generalised and safer variant of the @arg@ +-- function from Figure 3 in <http://dreixel.net/research/pdf/gdmh.pdf>. @arg@ +-- is conceptually equivalent to: +-- +-- > arg t = case t of +-- > _ | isTyVar t -> if (t == argVar) then Par1 else Par0 t +-- > App f [t'] | +-- representable1 f && +-- t' == argVar -> Rec1 f +-- > App f [t'] | +-- representable1 f && +-- t' has tyvars -> f :.: (arg t') +-- > _ -> Rec0 t +-- +-- where @argVar@ is the last type variable in the data type declaration we are +-- finding the representation for. +-- +-- @argTyFold@ is more general than @arg@ because it uses 'ArgTyAlg' to +-- abstract out the concrete invocations of @Par0@, @Rec0@, @Par1@, @Rec1@, and +-- @:.:@. +-- +-- @argTyFold@ is safer than @arg@ because @arg@ would lead to a GHC panic for +-- some data types. The problematic case is when @t@ is an application of a +-- non-representable type @f@ to @argVar@: @App f [argVar]@ is caught by the +-- @_@ pattern, and ends up represented as @Rec0 t@. This type occurs /free/ in +-- the RHS of the eventual @Rep1@ instance, which is therefore ill-formed. Some +-- representable1 checks have been relaxed, and others were moved to +-- @canDoGenerics1@. +argTyFold :: forall a. TyVar -> ArgTyAlg a -> Type -> a +argTyFold argVar (ArgTyAlg {ata_rec0 = mkRec0, + ata_par1 = mkPar1, ata_rec1 = mkRec1, + ata_comp = mkComp}) = + -- mkRec0 is the default; use it if there is no interesting structure + -- (e.g. occurrences of parameters or recursive occurrences) + \t -> maybe (mkRec0 t) id $ go t where + go :: Type -> -- type to fold through + Maybe a -- the result (e.g. representation type), unless it's trivial + go t = isParam `mplus` isApp where + + isParam = do -- handles parameters + t' <- getTyVar_maybe t + Just $ if t' == argVar then mkPar1 -- moreover, it is "the" parameter + else mkRec0 t -- NB mkRec0 instead of the conventional mkPar0 + + isApp = do -- handles applications + (phi, beta) <- tcSplitAppTy_maybe t + + let interesting = argVar `elemVarSet` exactTyVarsOfType beta + + -- Does it have no interesting structure to represent? + if not interesting then Nothing + else -- Is the argument the parameter? Special case for mkRec1. + if Just argVar == getTyVar_maybe beta then Just $ mkRec1 phi + else mkComp phi `fmap` go beta -- It must be a composition. + + +tc_mkRepTy :: -- Gen0_ or Gen1_, for Rep or Rep1 + GenericKind_ + -- The type to generate representation for + -> TyCon -- Metadata datatypes to refer to -> MetaTyCons -- Generated representation0 type -> TcM Type -tc_mkRepTy tycon ty_args metaDts = +tc_mkRepTy gk_ tycon metaDts = do d1 <- tcLookupTyCon d1TyConName c1 <- tcLookupTyCon c1TyConName s1 <- tcLookupTyCon s1TyConName nS1 <- tcLookupTyCon noSelTyConName rec0 <- tcLookupTyCon rec0TyConName - par0 <- tcLookupTyCon par0TyConName + rec1 <- tcLookupTyCon rec1TyConName + par1 <- tcLookupTyCon par1TyConName u1 <- tcLookupTyCon u1TyConName v1 <- tcLookupTyCon v1TyConName plus <- tcLookupTyCon sumTyConName times <- tcLookupTyCon prodTyConName + comp <- tcLookupTyCon compTyConName let mkSum' a b = mkTyConApp plus [a,b] mkProd a b = mkTyConApp times [a,b] + mkComp a b = mkTyConApp comp [a,b] mkRec0 a = mkTyConApp rec0 [a] - mkPar0 a = mkTyConApp par0 [a] + mkRec1 a = mkTyConApp rec1 [a] + mkPar1 = mkTyConTy par1 mkD a = mkTyConApp d1 [metaDTyCon, sumP (tyConDataCons a)] - mkC i d a = mkTyConApp c1 [d, prod i (dataConInstOrigArgTys a ty_args) + mkC i d a = mkTyConApp c1 [d, prod i (dataConInstOrigArgTys a $ mkTyVarTys $ tyConTyVars tycon) (null (dataConFieldLabels a))] -- This field has no label mkS True _ a = mkTyConApp s1 [mkTyConTy nS1, a] -- This field has a label mkS False d a = mkTyConApp s1 [d, a] + -- Sums and products are done in the same way for both Rep and Rep1 sumP [] = mkTyConTy v1 sumP l = ASSERT (length metaCTyCons == length l) foldBal mkSum' [ mkC i d a @@ -334,12 +575,21 @@ tc_mkRepTy tycon ty_args metaDts = | (d,t) <- zip (metaSTyCons !! i) l ] arg :: Type -> Type -> Bool -> Type - arg d t b = mkS b d (recOrPar t (getTyVar_maybe t)) - -- Argument is not a type variable, use Rec0 - recOrPar t Nothing = mkRec0 t - -- Argument is a type variable, use Par0 - recOrPar t (Just _) = mkPar0 t + arg d t b = mkS b d $ case gk_ of + -- Here we previously used Par0 if t was a type variable, but we + -- realized that we can't always guarantee that we are wrapping-up + -- all type variables in Par0. So we decided to stop using Par0 + -- altogether, and use Rec0 all the time. + Gen0_ -> mkRec0 t + Gen1_ argVar -> argPar argVar t + where + -- Builds argument represention for Rep1 (more complicated due to + -- the presence of composition). + argPar argVar = argTyFold argVar $ ArgTyAlg + {ata_rec0 = mkRec0, ata_par1 = mkPar1, + ata_rec1 = mkRec1, ata_comp = mkComp} + metaDTyCon = mkTyConTy (metaD metaDts) metaCTyCons = map mkTyConTy (metaC metaDts) metaSTyCons = map (map mkTyConTy) (metaS metaDts) @@ -365,11 +615,11 @@ metaTyCons2TyCons (MetaTyCons d c s) = listToBag (d : c ++ concat s) -- Bindings for Datatype, Constructor, and Selector instances -mkBindsMetaD :: DynFlags -> FixityEnv -> TyCon +mkBindsMetaD :: FixityEnv -> TyCon -> ( LHsBinds RdrName -- Datatype instance , [LHsBinds RdrName] -- Constructor instances , [[LHsBinds RdrName]]) -- Selector instances -mkBindsMetaD dflags fix_env tycon = (dtBinds, allConBinds, allSelBinds) +mkBindsMetaD fix_env tycon = (dtBinds, allConBinds, allSelBinds) where mkBag l = foldr1 unionBags [ unitBag (L loc (mkFunBind (L loc name) matches)) @@ -401,24 +651,28 @@ mkBindsMetaD dflags fix_env tycon = (dtBinds, allConBinds, allSelBinds) datacons = tyConDataCons tycon datasels = map dataConFieldLabels datacons - dtName_matches = mkStringLHS . showPpr dflags . nameOccName . tyConName - $ tycon + tyConName_user = case tyConFamInst_maybe tycon of + Just (ptycon, _) -> tyConName ptycon + Nothing -> tyConName tycon + + dtName_matches = mkStringLHS . occNameString . nameOccName + $ tyConName_user moduleName_matches = mkStringLHS . moduleNameString . moduleName . nameModule . tyConName $ tycon - conName_matches c = mkStringLHS . showPpr dflags . nameOccName + conName_matches c = mkStringLHS . occNameString . nameOccName . dataConName $ c conFixity_matches c = [mkSimpleHsAlt nlWildPat (fixity c)] conIsRecord_matches _ = [mkSimpleHsAlt nlWildPat (nlHsVar true_RDR)] - selName_matches s = mkStringLHS (showPpr dflags (nameOccName s)) + selName_matches s = mkStringLHS (occNameString (nameOccName s)) -------------------------------------------------------------------------------- -- Dealing with sums -------------------------------------------------------------------------------- -mkSum :: DynFlags +mkSum :: GenericKind_ -- Generic or Generic1? -> US -- Base for generating unique names -> TyCon -- The type constructor -> [DataCon] -- The data constructors @@ -426,42 +680,62 @@ mkSum :: DynFlags [Alt]) -- Alternatives for the Trep->T "to" function -- Datatype without any constructors -mkSum dflags _us tycon [] = ([from_alt], [to_alt]) +mkSum _ _ tycon [] = ([from_alt], [to_alt]) where from_alt = (nlWildPat, mkM1_E (makeError errMsgFrom)) to_alt = (mkM1_P nlWildPat, makeError errMsgTo) -- These M1s are meta-information for the datatype makeError s = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString s)) - errMsgFrom = "No generic representation for empty datatype " ++ showPpr dflags tycon - errMsgTo = "No values for empty datatype " ++ showPpr dflags tycon + tyConStr = occNameString (nameOccName (tyConName tycon)) + errMsgFrom = "No generic representation for empty datatype " ++ tyConStr + errMsgTo = "No values for empty datatype " ++ tyConStr -- Datatype with at least one constructor -mkSum _ us _tycon datacons = - unzip [ mk1Sum us i (length datacons) d | (d,i) <- zip datacons [1..] ] +mkSum gk_ us _ datacons = + -- switch the payload of gk_ to be datacon-centric instead of tycon-centric + unzip [ mk1Sum (gk2gkDC gk_ d) us i (length datacons) d + | (d,i) <- zip datacons [1..] ] -- Build the sum for a particular constructor -mk1Sum :: US -- Base for generating unique names +mk1Sum :: GenericKind_DC -- Generic or Generic1? + -> US -- Base for generating unique names -> Int -- The index of this constructor -> Int -- Total number of constructors -> DataCon -- The data constructor -> (Alt, -- Alternative for the T->Trep "from" function Alt) -- Alternative for the Trep->T "to" function -mk1Sum us i n datacon = (from_alt, to_alt) +mk1Sum gk_ us i n datacon = (from_alt, to_alt) where - n_args = dataConSourceArity datacon -- Existentials already excluded + gk = forgetArgVar gk_ + + -- Existentials already excluded + argTys = dataConOrigArgTys datacon + n_args = dataConSourceArity datacon - datacon_vars = map mkGenericLocal [us .. us+n_args-1] + datacon_varTys = zip (map mkGenericLocal [us .. us+n_args-1]) argTys + datacon_vars = map fst datacon_varTys us' = us + n_args datacon_rdr = getRdrName datacon - app_exp = nlHsVarApps datacon_rdr datacon_vars from_alt = (nlConVarPat datacon_rdr datacon_vars, from_alt_rhs) - from_alt_rhs = mkM1_E (genLR_E i n (mkProd_E us' datacon_vars)) + from_alt_rhs = mkM1_E (genLR_E i n (mkProd_E gk_ us' datacon_varTys)) - to_alt = (mkM1_P (genLR_P i n (mkProd_P us' datacon_vars)), to_alt_rhs) + to_alt = (mkM1_P (genLR_P i n (mkProd_P gk us' datacon_vars)), to_alt_rhs) -- These M1s are meta-information for the datatype - to_alt_rhs = app_exp + to_alt_rhs = case gk_ of + Gen0_DC -> nlHsVarApps datacon_rdr datacon_vars + Gen1_DC argVar -> nlHsApps datacon_rdr $ map argTo datacon_varTys + where + argTo (var, ty) = converter ty `nlHsApp` nlHsVar var where + converter = argTyFold argVar $ ArgTyAlg + {ata_rec0 = const $ nlHsVar unK1_RDR, + ata_par1 = nlHsVar unPar1_RDR, + ata_rec1 = const $ nlHsVar unRec1_RDR, + ata_comp = \_ cnv -> (nlHsVar fmap_RDR `nlHsApp` cnv) + `nlHsCompose` nlHsVar unComp1_RDR} + + -- Generates the L1/R1 sum pattern genLR_P :: Int -> Int -> LPat RdrName -> LPat RdrName @@ -486,34 +760,47 @@ genLR_E i n e -------------------------------------------------------------------------------- -- Build a product expression -mkProd_E :: US -- Base for unique names - -> [RdrName] -- List of variables matched on the lhs +mkProd_E :: GenericKind_DC -- Generic or Generic1? + -> US -- Base for unique names + -> [(RdrName, Type)] -- List of variables matched on the lhs and their types -> LHsExpr RdrName -- Resulting product expression -mkProd_E _ [] = mkM1_E (nlHsVar u1DataCon_RDR) -mkProd_E _ vars = mkM1_E (foldBal prod appVars) - -- These M1s are meta-information for the constructor +mkProd_E _ _ [] = mkM1_E (nlHsVar u1DataCon_RDR) +mkProd_E gk_ _ varTys = mkM1_E (foldBal prod appVars) + -- These M1s are meta-information for the constructor where - appVars = map wrapArg_E vars + appVars = map (wrapArg_E gk_) varTys prod a b = prodDataCon_RDR `nlHsApps` [a,b] -wrapArg_E :: RdrName -> LHsExpr RdrName -wrapArg_E v = mkM1_E (k1DataCon_RDR `nlHsVarApps` [v]) - -- This M1 is meta-information for the selector +wrapArg_E :: GenericKind_DC -> (RdrName, Type) -> LHsExpr RdrName +wrapArg_E Gen0_DC (var, _) = mkM1_E (k1DataCon_RDR `nlHsVarApps` [var]) + -- This M1 is meta-information for the selector +wrapArg_E (Gen1_DC argVar) (var, ty) = mkM1_E $ converter ty `nlHsApp` nlHsVar var + -- This M1 is meta-information for the selector + where converter = argTyFold argVar $ ArgTyAlg + {ata_rec0 = const $ nlHsVar k1DataCon_RDR, + ata_par1 = nlHsVar par1DataCon_RDR, + ata_rec1 = const $ nlHsVar rec1DataCon_RDR, + ata_comp = \_ cnv -> nlHsVar comp1DataCon_RDR `nlHsCompose` + (nlHsVar fmap_RDR `nlHsApp` cnv)} + + -- Build a product pattern -mkProd_P :: US -- Base for unique names +mkProd_P :: GenericKind -- Gen0 or Gen1 + -> US -- Base for unique names -> [RdrName] -- List of variables to match -> LPat RdrName -- Resulting product pattern -mkProd_P _ [] = mkM1_P (nlNullaryConPat u1DataCon_RDR) -mkProd_P _ vars = mkM1_P (foldBal prod appVars) - -- These M1s are meta-information for the constructor +mkProd_P _ _ [] = mkM1_P (nlNullaryConPat u1DataCon_RDR) +mkProd_P gk _ vars = mkM1_P (foldBal prod appVars) + -- These M1s are meta-information for the constructor where - appVars = map wrapArg_P vars + appVars = map (wrapArg_P gk) vars prod a b = prodDataCon_RDR `nlConPat` [a,b] - -wrapArg_P :: RdrName -> LPat RdrName -wrapArg_P v = mkM1_P (k1DataCon_RDR `nlConVarPat` [v]) - -- This M1 is meta-information for the selector + +wrapArg_P :: GenericKind -> RdrName -> LPat RdrName +wrapArg_P Gen0 v = mkM1_P (k1DataCon_RDR `nlConVarPat` [v]) + -- This M1 is meta-information for the selector +wrapArg_P Gen1 v = m1DataCon_RDR `nlConVarPat` [v] mkGenericLocal :: US -> RdrName mkGenericLocal u = mkVarUnqual (mkFastString ("g" ++ show u)) @@ -524,6 +811,9 @@ mkM1_E e = nlHsVar m1DataCon_RDR `nlHsApp` e mkM1_P :: LPat RdrName -> LPat RdrName mkM1_P p = m1DataCon_RDR `nlConPat` [p] +nlHsCompose :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName +nlHsCompose x y = compose_RDR `nlHsApps` [x, y] + -- | Variant of foldr1 for producing balanced lists foldBal :: (a -> a -> a) -> [a] -> a foldBal op = foldBal' op (error "foldBal: empty list") |