diff options
| -rwxr-xr-x[-rw-r--r--] | compiler/ghc.cabal.in | 2 | ||||
| -rwxr-xr-x[-rw-r--r--] | compiler/typecheck/TcDeriv.lhs | 389 | ||||
| -rwxr-xr-x[-rw-r--r--] | compiler/typecheck/TcGenDeriv.lhs | 209 | ||||
| -rwxr-xr-x[-rw-r--r--] | compiler/typecheck/TcGenGenerics.lhs (renamed from compiler/types/Generics.lhs) | 171 | ||||
| -rw-r--r-- | compiler/typecheck/TcInstDcls.lhs | 20 |
5 files changed, 373 insertions, 418 deletions
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 01bbeb067d..09b0fb9335 100644..100755 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -394,6 +394,7 @@ Library TcExpr TcForeign TcGenDeriv + TcGenGenerics TcHsSyn TcHsType TcInstDcls @@ -418,7 +419,6 @@ Library Coercion FamInstEnv FunDeps - Generics InstEnv TyCon Kind diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index b3214f8d7f..d311647db3 100644..100755 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -13,20 +13,22 @@ module TcDeriv ( tcDeriving ) where import HsSyn import DynFlags -import Generics import TcRnMonad import FamInst import TcEnv import TcClassDcl( tcAddDeclCtxt ) -- Small helper import TcGenDeriv -- Deriv stuff +import TcGenGenerics import InstEnv import Inst +import FamInstEnv import TcHsType import TcMType import TcSimplify import RnBinds import RnEnv +import RnSource ( addTcgDUs ) import HscTypes import Class @@ -41,13 +43,10 @@ import Name import NameSet import TyCon import TcType -import BuildTyCl -import BasicTypes import Var import VarSet import PrelNames import SrcLoc -import UniqSupply import Util import ListSetOps import Outputable @@ -299,109 +298,97 @@ both of them. So we gather defs/uses from deriving just like anything else. tcDeriving :: [LTyClDecl Name] -- All type constructors -> [LInstDecl Name] -- All instance declarations -> [LDerivDecl Name] -- All stand-alone deriving declarations - -> TcM ([InstInfo Name] -- The generated "instance decls" - ,HsValBinds Name -- Extra generated top-level bindings - ,DefUses - ,[TyCon] -- Extra generated top-level types - ,[TyCon]) -- Extra generated type family instances - + -> TcM (TcGblEnv, Bag (InstInfo Name), HsValBinds Name) tcDeriving tycl_decls inst_decls deriv_decls - = recoverM (return ([], emptyValBindsOut, emptyDUs, [], [])) $ + = recoverM (do { g <- getGblEnv + ; return (g, emptyBag, emptyValBindsOut)}) $ do { -- Fish the "deriving"-related information out of the TcEnv -- And make the necessary "equations". is_boot <- tcIsHsBoot ; traceTc "tcDeriving" (ppr is_boot) - ; (early_specs, genericsExtras) - <- makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls - ; let (repMetaTys, repTyCons, metaInsts) = unzip3 genericsExtras + ; early_specs <- makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls ; overlap_flag <- getOverlapFlag ; let (infer_specs, given_specs) = splitEithers early_specs ; insts1 <- mapM (genInst True overlap_flag) given_specs ; final_specs <- extendLocalInstEnv (map (iSpec . fst) insts1) $ - inferInstanceContexts overlap_flag infer_specs + inferInstanceContexts overlap_flag infer_specs ; insts2 <- mapM (genInst False overlap_flag) final_specs - -- We no longer generate the old generic to/from functions - -- from each type declaration, so this is emptyBag - ; gen_binds <- return emptyBag -- mkGenericBinds is_boot tycl_decls - - ; (inst_info, rn_binds, rn_dus) - <- renameDeriv is_boot gen_binds (insts1 ++ insts2 ++ concat metaInsts) + ; let (inst_infos, deriv_stuff) = unzip (insts1 ++ insts2) + ; loc <- getSrcSpanM + ; let (binds, newTyCons, famInsts, extraInstances) = + genAuxBinds loc (unionManyBags deriv_stuff) + ; (inst_info, rn_binds, rn_dus) <- + renameDeriv is_boot (inst_infos ++ (bagToList extraInstances)) binds ; dflags <- getDOpts ; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances" - (ddump_deriving inst_info rn_binds repMetaTys repTyCons metaInsts)) + (ddump_deriving inst_info rn_binds newTyCons famInsts extraInstances)) {- ; when (not (null inst_info)) $ dumpDerivingInfo (ddump_deriving inst_info rn_binds) -} - ; return ( inst_info, rn_binds, rn_dus - , concat (map metaTyCons2TyCons repMetaTys), repTyCons) } + + ; let all_tycons = map ATyCon (bagToList newTyCons) + ; gbl_env <- tcExtendGlobalEnv all_tycons $ + tcExtendGlobalEnv (concatMap implicitTyThings all_tycons) $ + tcExtendLocalFamInstEnv (map mkLocalFamInst (bagToList famInsts)) $ + tcExtendLocalInstEnv (map iSpec (bagToList inst_info)) getGblEnv + + ; return (addTcgDUs gbl_env rn_dus, inst_info, rn_binds) } where - ddump_deriving :: [InstInfo Name] -> HsValBinds Name - -> [MetaTyCons] -- ^ Empty data constructors - -> [TyCon] -- ^ Rep type family instances - -> [[(InstInfo RdrName, DerivAuxBinds)]] + ddump_deriving :: Bag (InstInfo Name) -> HsValBinds Name + -> Bag TyCon -- ^ Empty data constructors + -> Bag TyCon -- ^ Rep type family instances + -> Bag (InstInfo RdrName) -- ^ Instances for the repMetaTys -> SDoc ddump_deriving inst_infos extra_binds repMetaTys repTyCons metaInsts - = hang (ptext (sLit "Derived instances")) - 2 (vcat (map (\i -> pprInstInfoDetails i $$ text "") inst_infos) + = hang (ptext (sLit "Derived instances:")) + 2 (vcat (map (\i -> pprInstInfoDetails i $$ text "") (bagToList inst_infos)) $$ ppr extra_binds) - $$ hangP "Generic representation" ( - hangP "Generated datatypes for meta-information" - (vcat (map ppr repMetaTys)) + $$ hangP "Generic representation:" ( + hangP "Generated datatypes for meta-information:" + (vcat (map ppr (bagToList repMetaTys))) -- The Outputable instance for TyCon unfortunately only prints the name... - $$ hangP "Representation types" - (vcat (map ppr repTyCons)) - $$ hangP "Meta-information instances" - (vcat (map (pprInstInfoDetails . fst) (concat metaInsts)))) + $$ hangP "Representation types:" + (vcat (map ppr (bagToList repTyCons))) + $$ hangP "Meta-information instances:" + (vcat (map pprInstInfoDetails (bagToList metaInsts)))) hangP s x = text "" $$ hang (ptext (sLit s)) 2 x -renameDeriv :: Bool -> LHsBinds RdrName - -> [(InstInfo RdrName, DerivAuxBinds)] - -> TcM ([InstInfo Name], HsValBinds Name, DefUses) -renameDeriv is_boot gen_binds insts +renameDeriv :: Bool + -> [InstInfo RdrName] + -> Bag (LHsBind RdrName, LSig RdrName) + -> TcM (Bag (InstInfo Name), HsValBinds Name, DefUses) +renameDeriv is_boot inst_infos bagBinds | is_boot -- If we are compiling a hs-boot file, don't generate any derived bindings -- The inst-info bindings will all be empty, but it's easier to -- just use rn_inst_info to change the type appropriately - = do { (rn_inst_infos, fvs) <- mapAndUnzipM rn_inst_info inst_infos - ; return (rn_inst_infos, emptyValBindsOut, usesOnly (plusFVs fvs)) } + = do { (rn_inst_infos, fvs) <- mapAndUnzipM rn_inst_info inst_infos + ; return ( listToBag rn_inst_infos + , emptyValBindsOut, usesOnly (plusFVs fvs)) } | otherwise = discardWarnings $ -- Discard warnings about unused bindings etc - do { (rn_gen, dus_gen) <- setXOptM Opt_ScopedTypeVariables $ -- Type signatures in patterns - -- are used in the generic binds - rnTopBinds (ValBindsIn gen_binds []) - ; keepAliveSetTc (duDefs dus_gen) -- Mark these guys to be kept alive - - -- Generate and rename any extra not-one-inst-decl-specific binds, - -- notably "con2tag" and/or "tag2con" functions. - -- Bring those names into scope before renaming the instances themselves - ; loc <- getSrcSpanM -- Generic loc for shared bindings - ; let (aux_binds, aux_sigs) = unzip $ map (genAuxBind loc) $ - rm_dups [] $ concat deriv_aux_binds - aux_val_binds = ValBindsIn (listToBag aux_binds) aux_sigs + do { + -- Bring the extra deriving stuff into scope + -- before renaming the instances themselves + ; (aux_binds, aux_sigs) <- mapAndUnzipBagM return bagBinds + ; let aux_val_binds = ValBindsIn aux_binds (bagToList aux_sigs) ; rn_aux_lhs <- rnTopBindsLHS emptyFsEnv aux_val_binds ; bindLocalNames (collectHsValBinders rn_aux_lhs) $ do { (rn_aux, dus_aux) <- rnTopBindsRHS rn_aux_lhs ; (rn_inst_infos, fvs_insts) <- mapAndUnzipM rn_inst_info inst_infos - ; return (rn_inst_infos, rn_aux `plusHsValBinds` rn_gen, - dus_gen `plusDU` dus_aux `plusDU` usesOnly (plusFVs fvs_insts)) } } + ; return (listToBag rn_inst_infos, rn_aux, + dus_aux `plusDU` usesOnly (plusFVs fvs_insts)) } } where - (inst_infos, deriv_aux_binds) = unzip insts - - -- 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 - rn_inst_info :: InstInfo RdrName -> TcM (InstInfo Name, FreeVars) rn_inst_info info@(InstInfo { iBinds = NewTypeDerived coi tc }) @@ -451,75 +438,20 @@ stored in NewTypeDerived. @makeDerivSpecs@ fishes around to find the info about needed derived instances. \begin{code} --- Make the "extras" for the generic representation -mkGenDerivExtras :: TyCon - -> TcRn (MetaTyCons, TyCon, [(InstInfo RdrName, DerivAuxBinds)]) -mkGenDerivExtras tc = do - { (metaTyCons, rep0TyInst) <- genGenericRepExtras tc - ; metaInsts <- genDtMeta (tc, metaTyCons) - ; return (metaTyCons, rep0TyInst, metaInsts) } - makeDerivSpecs :: Bool -> [LTyClDecl Name] -> [LInstDecl Name] -> [LDerivDecl Name] - -> TcM ( [EarlyDerivSpec] - , [(MetaTyCons, TyCon, [(InstInfo RdrName, DerivAuxBinds)])]) + -> TcM [EarlyDerivSpec] makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls | is_boot -- No 'deriving' at all in hs-boot files = do { mapM_ add_deriv_err deriv_locs - ; return ([],[]) } + ; return [] } | otherwise = do { eqns1 <- mapAndRecoverM deriveTyData all_tydata ; eqns2 <- mapAndRecoverM deriveStandalone deriv_decls - - -- Generic representation stuff: we might need to add some "extras" - -- to the instances - ; xDerRep <- getDOpts >>= return . xopt Opt_DeriveGeneric - ; generic_extras_deriv <- if not xDerRep - -- No extras if the flag is off - then (return []) - else do { - let allTyNames = [ tcdName d | L _ d <- tycl_decls, isDataDecl d ] - -- Select only those types that derive Generic - ; let sel_tydata = [ tcdName t | (L _ c, L _ t) <- all_tydata - , isGenClassName c ] - ; let sel_deriv_decls = catMaybes [ getTypeName t - | L _ (DerivDecl (L _ t)) <- deriv_decls ] - ; derTyDecls <- mapM tcLookupTyCon $ - filter (needsExtras xDerRep - (sel_tydata ++ sel_deriv_decls)) allTyNames - -- We need to generate the extras to add to what has - -- already been derived - ; {- pprTrace "sel_tydata" (ppr sel_tydata) $ - pprTrace "sel_deriv_decls" (ppr sel_deriv_decls) $ - pprTrace "derTyDecls" (ppr derTyDecls) $ - pprTrace "deriv_decls" (ppr deriv_decls) $ -} - mapM mkGenDerivExtras derTyDecls } - - -- Merge and return - ; return ( eqns1 ++ eqns2, generic_extras_deriv) } + ; return (eqns1 ++ eqns2) } where - -- We need extras if the flag DeriveGeneric is on and this type is - -- deriving Generic - needsExtras xDerRep tydata tc_name = xDerRep && tc_name `elem` tydata - - -- Extracts the name of the class in the deriving and makes sure it is ours - isGenClassName :: HsType Name -> Bool - isGenClassName ty = case splitHsInstDeclTy_maybe ty of - Just (_, _, cls_name, _) -> cls_name == genClassName - _ -> False - - -- Extracts the name of the type in the deriving - -- This function (and also getClassName above) is not really nice, and I - -- might not have covered all possible cases. I wonder if there is no easier - -- way to extract class and type name from a LDerivDecl... - getTypeName :: HsType Name -> Maybe Name - getTypeName ty = do - (_, _, cls_name, [ty]) <- splitHsInstDeclTy_maybe ty - guard (cls_name == genClassName) - fmap fst $ splitHsClassTy_maybe (unLoc ty) - extractTyDataPreds decls = [(p, d) | d@(L _ (TyData {tcdDerivs = Just preds})) <- decls, p <- preds] @@ -699,8 +631,9 @@ mkEqnHelp orig tvs cls cls_tys tc_app mtheta -- For standalone deriving (mtheta /= Nothing), -- check that all the data constructors are in scope. ; rdr_env <- getGlobalRdrEnv - ; let hidden_data_cons = isAbstractTyCon rep_tc || - any not_in_scope (tyConDataCons rep_tc) + ; let hidden_data_cons = not (isWiredInName (tyConName rep_tc)) && + (isAbstractTyCon rep_tc || + any not_in_scope (tyConDataCons rep_tc)) not_in_scope dc = null (lookupGRE_Name rdr_env (dataConName dc)) ; unless (isNothing mtheta || not hidden_data_cons) (bale_out (derivingHiddenErr tycon)) @@ -1508,31 +1441,30 @@ the renamer. What a great hack! -- genInst :: Bool -- True <=> standalone deriving -> OverlapFlag - -> DerivSpec -> TcM (InstInfo RdrName, DerivAuxBinds) + -> DerivSpec -> TcM (InstInfo RdrName, BagDerivStuff) genInst standalone_deriv oflag spec@(DS { ds_tc = rep_tycon, ds_tc_args = rep_tc_args , ds_theta = theta, ds_newtype = is_newtype , ds_name = name, ds_cls = clas }) | is_newtype = return (InstInfo { iSpec = inst_spec - , iBinds = NewTypeDerived co rep_tycon }, []) + , iBinds = NewTypeDerived co rep_tycon }, emptyBag) | otherwise - = do { fix_env <- getFixityEnv - ; let loc = getSrcSpan name - (meth_binds, aux_binds) = genDerivBinds loc fix_env clas rep_tycon - -- In case of a family instance, we need to use the representation - -- tycon (after all, it has the data constructors) - - ; return (InstInfo { iSpec = inst_spec - , iBinds = VanillaInst meth_binds [] standalone_deriv } - , aux_binds) } + = do { fix_env <- getFixityEnv + ; (meth_binds, deriv_stuff) <- genDerivStuff (getSrcSpan name) + fix_env clas name rep_tycon + ; let inst_info = InstInfo { iSpec = inst_spec + , iBinds = VanillaInst meth_binds [] + standalone_deriv } + ; return ( inst_info, deriv_stuff) } where + inst_spec = mkInstance oflag theta spec co1 = case tyConFamilyCoercion_maybe rep_tycon of Just co_con -> mkAxInstCo co_con rep_tc_args - Nothing -> id_co - -- Not a family => rep_tycon = main tycon + Nothing -> id_co + -- Not a family => rep_tycon = main tycon co2 = mkAxInstCo (newTyConCo rep_tycon) rep_tc_args co = co1 `mkTransCo` co2 id_co = mkReflCo (mkTyConApp rep_tycon rep_tc_args) @@ -1545,174 +1477,35 @@ genInst standalone_deriv oflag -- co2 : R1:N (b,b) ~ Tree (b,b) -- co : N [(b,b)] ~ Tree (b,b) -genDerivBinds :: SrcSpan -> FixityEnv -> Class -> TyCon -> (LHsBinds RdrName, DerivAuxBinds) -genDerivBinds loc fix_env clas tycon +genDerivStuff :: SrcSpan -> FixityEnv -> Class -> Name -> TyCon + -> TcM (LHsBinds RdrName, BagDerivStuff) +genDerivStuff loc fix_env clas name tycon | className clas `elem` typeableClassNames - = (gen_Typeable_binds loc tycon, []) + = return (gen_Typeable_binds loc tycon, emptyBag) - | otherwise + | classKey clas == genClassKey -- Special case because monadic + = gen_Generic_binds tycon (nameModule name) + + | otherwise -- Non-monadic generators = case assocMaybe gen_list (getUnique clas) of - Just gen_fn -> gen_fn loc tycon - Nothing -> pprPanic "genDerivBinds: bad derived class" (ppr clas) + Just gen_fn -> return (gen_fn loc tycon) + Nothing -> pprPanic "genDerivStuff: bad derived class" (ppr clas) where - gen_list :: [(Unique, SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds))] + gen_list :: [(Unique, SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff))] 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) - ,(functorClassKey, gen_Functor_binds) - ,(foldableClassKey, gen_Foldable_binds) - ,(traversableClassKey, gen_Traversable_binds) - ,(genClassKey, genGenericBinds) - ] -\end{code} - -%************************************************************************ -%* * -\subsection[TcDeriv-generic-binds]{Bindings for the new generic deriving mechanism} -%* * -%************************************************************************ - -For the generic representation we need to generate: -\begin{itemize} -\item A Generic instance -\item A Rep type instance -\item Many auxiliary datatypes and instances for them (for the meta-information) -\end{itemize} - -@genGenericBinds@ does (1) -@genGenericRepExtras@ does (2) and (3) -@genGenericAll@ does all of them - -\begin{code} -genGenericBinds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds) -genGenericBinds _ tc = (mkBindsRep tc, [ {- No DerivAuxBinds -} ]) - -genGenericRepExtras :: TyCon -> TcM (MetaTyCons, TyCon) -genGenericRepExtras tc = - do uniqS <- newUniqueSupply - let - -- Uniques for everyone - (uniqD:uniqs) = uniqsFromSupply uniqS - (uniqsC,us) = splitAt (length tc_cons) uniqs - uniqsS :: [[Unique]] -- Unique supply for the S datatypes - uniqsS = mkUniqsS tc_arits us - mkUniqsS [] _ = [] - mkUniqsS (n:t) us = case splitAt n us of - (us1,us2) -> us1 : mkUniqsS t us2 - - tc_name = tyConName tc - tc_cons = tyConDataCons tc - tc_arits = map dataConSourceArity tc_cons - - tc_occ = nameOccName tc_name - d_occ = mkGenD tc_occ - c_occ m = mkGenC tc_occ m - s_occ m n = mkGenS tc_occ m n - mod_name = nameModule (tyConName tc) - d_name = mkExternalName uniqD mod_name d_occ wiredInSrcSpan - c_names = [ mkExternalName u mod_name (c_occ m) wiredInSrcSpan - | (u,m) <- zip uniqsC [0..] ] - s_names = [ [ mkExternalName u mod_name (s_occ m n) wiredInSrcSpan - | (u,n) <- zip us [0..] ] | (us,m) <- zip uniqsS [0..] ] - - mkTyCon name = ASSERT( isExternalName name ) - buildAlgTyCon name [] [] distinctAbstractTyConRhs - NonRecursive False NoParentTyCon Nothing - - metaDTyCon <- mkTyCon d_name - metaCTyCons <- sequence [ mkTyCon c_name | c_name <- c_names ] - metaSTyCons <- mapM sequence - [ [ mkTyCon s_name - | s_name <- s_namesC ] | s_namesC <- s_names ] - - let metaDts = MetaTyCons metaDTyCon metaCTyCons metaSTyCons - - rep0_tycon <- tc_mkRepTyCon tc metaDts - - -- pprTrace "rep0" (ppr rep0_tycon) $ - return (metaDts, rep0_tycon) -{- -genGenericAll :: TyCon - -> TcM ((InstInfo RdrName, DerivAuxBinds), MetaTyCons, TyCon) -genGenericAll tc = - do (metaDts, rep0_tycon) <- genGenericRepExtras tc - clas <- tcLookupClass genClassName - dfun_name <- new_dfun_name clas tc - let - mkInstRep = (InstInfo { iSpec = inst, iBinds = binds } - , [ {- No DerivAuxBinds -} ]) - inst = mkLocalInstance dfun NoOverlap - binds = VanillaInst (mkBindsRep tc) [] False - - tvs = tyConTyVars tc - tc_ty = mkTyConApp tc (mkTyVarTys tvs) - - dfun = mkDictFunId dfun_name (tyConTyVars tc) [] clas [tc_ty] - return (mkInstRep, metaDts, rep0_tycon) --} -genDtMeta :: (TyCon, MetaTyCons) -> TcM [(InstInfo RdrName, DerivAuxBinds)] -genDtMeta (tc,metaDts) = - do dflags <- getDOpts - dClas <- tcLookupClass datatypeClassName - d_dfun_name <- new_dfun_name dClas tc - cClas <- tcLookupClass constructorClassName - c_dfun_names <- sequence [ new_dfun_name cClas tc | _ <- metaC metaDts ] - sClas <- tcLookupClass selectorClassName - s_dfun_names <- sequence (map sequence [ [ new_dfun_name sClas tc - | _ <- x ] - | x <- metaS metaDts ]) - fix_env <- getFixityEnv - - let - safeOverlap = safeLanguageOn dflags - (dBinds,cBinds,sBinds) = mkBindsMetaD fix_env tc - - -- Datatype - d_metaTycon = metaD metaDts - d_inst = mkLocalInstance d_dfun $ NoOverlap safeOverlap - d_binds = VanillaInst dBinds [] False - d_dfun = mkDictFunId d_dfun_name (tyConTyVars tc) [] dClas - [ mkTyConTy d_metaTycon ] - d_mkInst = (InstInfo { iSpec = d_inst, iBinds = d_binds }, []) - - -- Constructor - c_metaTycons = metaC metaDts - c_insts = [ mkLocalInstance (c_dfun c ds) $ NoOverlap safeOverlap - | (c, ds) <- myZip1 c_metaTycons c_dfun_names ] - c_binds = [ VanillaInst c [] False | c <- cBinds ] - c_dfun c dfun_name = mkDictFunId dfun_name (tyConTyVars tc) [] cClas - [ mkTyConTy c ] - c_mkInst = [ (InstInfo { iSpec = is, iBinds = bs }, []) - | (is,bs) <- myZip1 c_insts c_binds ] - - -- Selector - s_metaTycons = metaS metaDts - s_insts = map (map (\(s,ds) -> mkLocalInstance (s_dfun s ds) $ - NoOverlap safeOverlap)) - (myZip2 s_metaTycons s_dfun_names) - s_binds = [ [ VanillaInst s [] False | s <- ss ] | ss <- sBinds ] - s_dfun s dfun_name = mkDictFunId dfun_name (tyConTyVars tc) [] sClas - [ mkTyConTy s ] - s_mkInst = map (map (\(is,bs) -> (InstInfo {iSpec=is, iBinds=bs}, []))) - (myZip2 s_insts s_binds) - - myZip1 :: [a] -> [b] -> [(a,b)] - myZip1 l1 l2 = ASSERT (length l1 == length l2) zip l1 l2 - - myZip2 :: [[a]] -> [[b]] -> [[(a,b)]] - myZip2 l1 l2 = - ASSERT (and (zipWith (>=) (map length l1) (map length l2))) - [ zip x1 x2 | (x1,x2) <- zip l1 l2 ] - - return (d_mkInst : c_mkInst ++ concat s_mkInst) + ,(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) + ,(functorClassKey, gen_Functor_binds) + ,(foldableClassKey, gen_Foldable_binds) + ,(traversableClassKey, gen_Traversable_binds) + ] \end{code} - %************************************************************************ %* * \subsection[TcDeriv-taggery-Names]{What con2tag/tag2con functions are available?} diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs index ad06d6e749..cf9c46a747 100644..100755 --- a/compiler/typecheck/TcGenDeriv.lhs +++ b/compiler/typecheck/TcGenDeriv.lhs @@ -12,7 +12,7 @@ This is where we do all the grimy bindings' generation. \begin{code} module TcGenDeriv ( - DerivAuxBinds, isDupAux, + BagDerivStuff, DerivStuff(..), gen_Bounded_binds, gen_Enum_binds, @@ -28,7 +28,7 @@ module TcGenDeriv ( deepSubtypesContaining, foldDataConArgs, gen_Foldable_binds, gen_Traversable_binds, - genAuxBind, + genAuxBinds, ordOpTbl, boxConTbl ) where @@ -62,32 +62,32 @@ import FastString import Bag import Fingerprint import Constants +import TcEnv (InstInfo) import Data.List ( partition, intersperse ) \end{code} \begin{code} -type DerivAuxBinds = [DerivAuxBind] - -data DerivAuxBind -- Please add these auxiliary top-level bindings - = GenCon2Tag TyCon -- The con2Tag for given TyCon - | GenTag2Con TyCon -- ...ditto tag2Con - | GenMaxTag TyCon -- ...and maxTag - -- All these generate ZERO-BASED tag operations - -- I.e first constructor has tag 0 - - -- Scrap your boilerplate - | MkDataCon DataCon -- For constructor C we get $cC :: Constr - | MkTyCon TyCon -- For tycon T we get $tT :: DataType - - -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 (MkDataCon dc1) (MkDataCon dc2) = dc1 == dc2 -isDupAux (MkTyCon tc1) (MkTyCon tc2) = tc1 == tc2 -isDupAux _ _ = False +type BagDerivStuff = Bag DerivStuff + +data AuxBindSpec + = DerivCon2Tag TyCon -- The con2Tag for given TyCon + | DerivTag2Con TyCon -- ...ditto tag2Con + | DerivMaxTag TyCon -- ...and maxTag + deriving( Eq ) + -- All these generate ZERO-BASED tag operations + -- I.e first constructor has tag 0 + +data DerivStuff -- Please add this auxiliary stuff + = DerivAuxBind AuxBindSpec + + -- Generics + | DerivTyCon TyCon -- New data types + | DerivFamInst TyCon -- New type family instances + + -- New top-level auxiliary bindings + | DerivHsBind (LHsBind RdrName, LSig RdrName) -- Also used for SYB + | DerivInst (InstInfo RdrName) -- New, auxiliary instances \end{code} @@ -166,7 +166,7 @@ instance ... Eq (Foo ...) where \begin{code} -gen_Eq_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds) +gen_Eq_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff) gen_Eq_binds loc tycon = (method_binds, aux_binds) where @@ -186,8 +186,8 @@ gen_Eq_binds loc tycon 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] + aux_binds | no_nullary_cons = emptyBag + | otherwise = unitBag $ DerivAuxBind $ DerivCon2Tag tycon method_binds = listToBag [eq_bind, ne_bind] eq_bind = mk_FunBind loc eq_RDR (map pats_etc nonnullary_cons ++ rest) @@ -324,15 +324,15 @@ gtResult OrdGE = true_Expr gtResult OrdGT = true_Expr ------------ -gen_Ord_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds) +gen_Ord_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff) gen_Ord_binds loc tycon | null tycon_data_cons -- No data-cons => invoke bale-out case - = (unitBag $ mk_FunBind loc compare_RDR [], []) + = (unitBag $ mk_FunBind loc compare_RDR [], emptyBag) | otherwise = (unitBag (mkOrdOp OrdCompare) `unionBags` other_ops, aux_binds) where - aux_binds | single_con_type = [] - | otherwise = [GenCon2Tag tycon] + aux_binds | single_con_type = emptyBag + | otherwise = unitBag $ DerivAuxBind $ DerivCon2Tag tycon -- Note [Do not rely on compare] other_ops | (last_tag - first_tag) <= 2 -- 1-3 constructors @@ -547,7 +547,7 @@ instance ... Enum (Foo ...) where For @enumFromTo@ and @enumFromThenTo@, we use the default methods. \begin{code} -gen_Enum_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds) +gen_Enum_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff) gen_Enum_binds loc tycon = (method_binds, aux_binds) where @@ -559,7 +559,8 @@ gen_Enum_binds loc tycon enum_from_then, from_enum ] - aux_binds = [GenCon2Tag tycon, GenTag2Con tycon, GenMaxTag tycon] + aux_binds = listToBag $ map DerivAuxBind + [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon] occ_nm = getOccString tycon @@ -626,13 +627,13 @@ gen_Enum_binds loc tycon %************************************************************************ \begin{code} -gen_Bounded_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds) +gen_Bounded_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff) gen_Bounded_binds loc tycon | isEnumerationTyCon tycon - = (listToBag [ min_bound_enum, max_bound_enum ], []) + = (listToBag [ min_bound_enum, max_bound_enum ], emptyBag) | otherwise = ASSERT(isSingleton data_cons) - (listToBag [ min_bound_1con, max_bound_1con ], []) + (listToBag [ min_bound_1con, max_bound_1con ], emptyBag) where data_cons = tyConDataCons tycon @@ -713,13 +714,15 @@ we follow the scheme given in Figure~19 of the Haskell~1.2 report (p.~147). \begin{code} -gen_Ix_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds) +gen_Ix_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff) gen_Ix_binds loc tycon | isEnumerationTyCon tycon - = (enum_ixes, [GenCon2Tag tycon, GenTag2Con tycon, GenMaxTag tycon]) + = ( enum_ixes + , listToBag $ map DerivAuxBind + [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon]) | otherwise - = (single_con_ixes, [GenCon2Tag tycon]) + = (single_con_ixes, unitBag (DerivAuxBind (DerivCon2Tag tycon))) where -------------------------------------------------------------- enum_ixes = listToBag [ enum_range, enum_index, enum_inRange ] @@ -872,10 +875,10 @@ instance Read T where \begin{code} -gen_Read_binds :: FixityEnv -> SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds) +gen_Read_binds :: FixityEnv -> SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff) gen_Read_binds get_fixity loc tycon - = (listToBag [read_prec, default_readlist, default_readlistprec], []) + = (listToBag [read_prec, default_readlist, default_readlistprec], emptyBag) where ----------------------------------------------------------------------- default_readlist @@ -1041,10 +1044,10 @@ Example -- the most tightly-binding operator \begin{code} -gen_Show_binds :: FixityEnv -> SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds) +gen_Show_binds :: FixityEnv -> SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff) gen_Show_binds get_fixity loc tycon - = (listToBag [shows_prec, show_list], []) + = (listToBag [shows_prec, show_list], emptyBag) where ----------------------------------------------------------------------- show_list = mkHsVarBind loc showList_RDR @@ -1254,17 +1257,53 @@ we generate gen_Data_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, -- The method bindings - DerivAuxBinds) -- Auxiliary bindings + BagDerivStuff) -- Auxiliary bindings gen_Data_binds loc tycon = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind] `unionBags` gcast_binds, -- Auxiliary definitions: the data type and constructors - MkTyCon tycon : map MkDataCon data_cons) + listToBag ( DerivHsBind (genDataTyCon) + : map (DerivHsBind . genDataDataCon) data_cons)) where data_cons = tyConDataCons tycon n_cons = length data_cons one_constr = n_cons == 1 + genDataTyCon :: (LHsBind RdrName, LSig RdrName) + genDataTyCon -- $dT + = (mkHsVarBind loc rdr_name rhs, + L loc (TypeSig [L loc rdr_name] sig_ty)) + where + rdr_name = mk_data_type_name tycon + sig_ty = nlHsTyVar dataType_RDR + constrs = [nlHsVar (mk_constr_name con) | con <- tyConDataCons tycon] + rhs = nlHsVar mkDataType_RDR + `nlHsApp` nlHsLit (mkHsString (showSDocOneLine (ppr tycon))) + `nlHsApp` nlList constrs + + genDataDataCon :: DataCon -> (LHsBind RdrName, LSig RdrName) + genDataDataCon dc -- $cT1 etc + = (mkHsVarBind loc rdr_name rhs, + L loc (TypeSig [L loc rdr_name] sig_ty)) + where + rdr_name = mk_constr_name dc + sig_ty = nlHsTyVar constr_RDR + rhs = nlHsApps mkConstr_RDR constr_args + + constr_args + = [ -- nlHsIntLit (toInteger (dataConTag dc)), -- Tag + nlHsVar (mk_data_type_name (dataConTyCon dc)), -- DataType + nlHsLit (mkHsString (occNameString dc_occ)), -- String name + nlList labels, -- Field labels + nlHsVar fixity] -- Fixity + + labels = map (nlHsLit . mkHsString . getOccString) + (dataConFieldLabels dc) + dc_occ = getOccName dc + is_infix = isDataSymOcc dc_occ + fixity | is_infix = infix_RDR + | otherwise = prefix_RDR + ------------ gfoldl gfoldl_bind = mk_FunBind loc gfoldl_RDR (map gfoldl_eqn data_cons) @@ -1416,9 +1455,9 @@ This is pretty much the same as $fmap, only without the $(cofmap 'a 'a) case: $(cofmap 'a '(b -> c)) x = \b -> $(cofmap 'a' 'c) (x ($(fmap 'a 'c) b)) \begin{code} -gen_Functor_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds) +gen_Functor_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff) gen_Functor_binds loc tycon - = (unitBag fmap_bind, []) + = (unitBag fmap_bind, emptyBag) where data_cons = tyConDataCons tycon fmap_bind = L loc $ mkRdrFunBind (L loc fmap_RDR) eqns @@ -1587,9 +1626,9 @@ Note that the arguments to the real foldr function are the wrong way around, since (f :: a -> b -> b), while (foldr f :: b -> t a -> b). \begin{code} -gen_Foldable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds) +gen_Foldable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff) gen_Foldable_binds loc tycon - = (unitBag foldr_bind, []) + = (unitBag foldr_bind, emptyBag) where data_cons = tyConDataCons tycon @@ -1639,9 +1678,9 @@ gives the function: traverse f (T x y) = T <$> pure x <*> f y instead of: traverse f (T x y) = T x <$> f y \begin{code} -gen_Traversable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds) +gen_Traversable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff) gen_Traversable_binds loc tycon - = (unitBag traverse_bind, []) + = (unitBag traverse_bind, emptyBag) where data_cons = tyConDataCons tycon @@ -1694,8 +1733,8 @@ The `tags' here start at zero, hence the @fIRST_TAG@ (currently one) fiddling around. \begin{code} -genAuxBind :: SrcSpan -> DerivAuxBind -> (LHsBind RdrName, LSig RdrName) -genAuxBind loc (GenCon2Tag tycon) +genAuxBindSpec :: SrcSpan -> AuxBindSpec -> (LHsBind RdrName, LSig RdrName) +genAuxBindSpec loc (DerivCon2Tag tycon) = (mk_FunBind loc rdr_name eqns, L loc (TypeSig [L loc rdr_name] (L loc sig_ty))) where @@ -1718,7 +1757,7 @@ genAuxBind loc (GenCon2Tag tycon) mk_eqn con = ([nlWildConPat con], nlHsLit (HsIntPrim (toInteger ((dataConTag con) - fIRST_TAG)))) -genAuxBind loc (GenTag2Con tycon) +genAuxBindSpec loc (DerivTag2Con tycon) = (mk_FunBind loc rdr_name [([nlConVarPat intDataCon_RDR [a_RDR]], nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)], @@ -1729,7 +1768,7 @@ genAuxBind loc (GenTag2Con tycon) rdr_name = tag2con_RDR tycon -genAuxBind loc (GenMaxTag tycon) +genAuxBindSpec loc (DerivMaxTag tycon) = (mkHsVarBind loc rdr_name rhs, L loc (TypeSig [L loc rdr_name] (L loc sig_ty))) where @@ -1739,38 +1778,36 @@ genAuxBind loc (GenMaxTag tycon) max_tag = case (tyConDataCons tycon) of data_cons -> toInteger ((length data_cons) - fIRST_TAG) -genAuxBind loc (MkTyCon tycon) -- $dT - = (mkHsVarBind loc rdr_name rhs, - L loc (TypeSig [L loc rdr_name] sig_ty)) - where - rdr_name = mk_data_type_name tycon - sig_ty = nlHsTyVar dataType_RDR - constrs = [nlHsVar (mk_constr_name con) | con <- tyConDataCons tycon] - rhs = nlHsVar mkDataType_RDR - `nlHsApp` nlHsLit (mkHsString (showSDocOneLine (ppr tycon))) - `nlHsApp` nlList constrs - -genAuxBind loc (MkDataCon dc) -- $cT1 etc - = (mkHsVarBind loc rdr_name rhs, - L loc (TypeSig [L loc rdr_name] sig_ty)) - where - rdr_name = mk_constr_name dc - sig_ty = nlHsTyVar constr_RDR - rhs = nlHsApps mkConstr_RDR constr_args - - constr_args - = [ -- nlHsIntLit (toInteger (dataConTag dc)), -- Tag - nlHsVar (mk_data_type_name (dataConTyCon dc)), -- DataType - nlHsLit (mkHsString (occNameString dc_occ)), -- String name - nlList labels, -- Field labels - nlHsVar fixity] -- Fixity - - labels = map (nlHsLit . mkHsString . getOccString) - (dataConFieldLabels dc) - dc_occ = getOccName dc - is_infix = isDataSymOcc dc_occ - fixity | is_infix = infix_RDR - | otherwise = prefix_RDR +type SeparateBagsDerivStuff = -- AuxBinds and SYB bindings + ( Bag (LHsBind RdrName, LSig RdrName) + -- Extra bindings (used by Generic only) + , Bag TyCon -- Extra top-level datatypes + , Bag TyCon -- Extra family instances + , Bag (InstInfo RdrName)) -- Extra instances + +genAuxBinds :: SrcSpan -> BagDerivStuff -> SeparateBagsDerivStuff +genAuxBinds loc b = genAuxBinds' b2 where + (b1,b2) = partitionBagWith splitDerivAuxBind b + splitDerivAuxBind (DerivAuxBind x) = Left x + splitDerivAuxBind x = Right x + + rm_dups = foldrBag dup_check emptyBag + dup_check a b = if anyBag (== a) b then b else consBag a b + + genAuxBinds' :: BagDerivStuff -> SeparateBagsDerivStuff + genAuxBinds' = foldrBag f ( mapBag (genAuxBindSpec loc) (rm_dups b1) + , emptyBag, emptyBag, emptyBag) + f :: DerivStuff -> SeparateBagsDerivStuff -> SeparateBagsDerivStuff + f (DerivAuxBind _) = panic "genAuxBinds'" -- We have removed these before + f (DerivHsBind b) = add1 b + f (DerivTyCon t) = add2 t + f (DerivFamInst t) = add3 t + f (DerivInst i) = add4 i + + add1 x (a,b,c,d) = (x `consBag` a,b,c,d) + add2 x (a,b,c,d) = (a,x `consBag` b,c,d) + add3 x (a,b,c,d) = (a,b,x `consBag` c,d) + add4 x (a,b,c,d) = (a,b,c,x `consBag` d) mk_data_type_name :: TyCon -> RdrName -- "$tT" mk_data_type_name tycon = mkAuxBinderName (tyConName tycon) mkDataTOcc diff --git a/compiler/types/Generics.lhs b/compiler/typecheck/TcGenGenerics.lhs index 323da41d66..543204759c 100644..100755 --- a/compiler/types/Generics.lhs +++ b/compiler/typecheck/TcGenGenerics.lhs @@ -2,45 +2,175 @@ % (c) The University of Glasgow 2011 % +The deriving code for the Generic class +(equivalent to the code in TcGenDeriv, for other classes) + \begin{code} -module Generics ( canDoGenerics, - mkBindsRep, tc_mkRepTyCon, mkBindsMetaD, - MetaTyCons(..), metaTyCons2TyCons - ) where +module TcGenGenerics (canDoGenerics, gen_Generic_binds) where +import DynFlags import HsSyn import Type import TcType +import TcGenDeriv import DataCon - import TyCon import Name hiding (varName) -import Module (moduleName, moduleNameString) +import Module (Module, moduleName, moduleNameString) +import IfaceEnv (newGlobalBinder) import RdrName import BasicTypes import TysWiredIn import PrelNames - --- For generation of representation types -import TcEnv (tcLookupTyCon) +import InstEnv +import TcEnv +import MkId import TcRnMonad import HscTypes import BuildTyCl - import SrcLoc import Bag import Outputable import FastString +import UniqSupply #include "HsVersions.h" \end{code} %************************************************************************ -%* * +%* * +\subsection{Bindings for the new generic deriving mechanism} +%* * +%************************************************************************ + +For the generic representation we need to generate: +\begin{itemize} +\item A Generic instance +\item A Rep type instance +\item Many auxiliary datatypes and instances for them (for the meta-information) +\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) + ; return ( mkBindsRep tc + , (DerivFamInst rep0TyInst) + `consBag` ((mapBag DerivTyCon (metaTyCons2TyCons metaTyCons)) + `unionBags` metaInsts)) } + +genGenericRepExtras :: TyCon -> Module -> TcM (MetaTyCons, TyCon) +genGenericRepExtras tc mod = + do uniqS <- newUniqueSupply + let + -- Uniques for everyone + (uniqD:uniqs) = uniqsFromSupply uniqS + (uniqsC,us) = splitAt (length tc_cons) uniqs + uniqsS :: [[Unique]] -- Unique supply for the S datatypes + uniqsS = mkUniqsS tc_arits us + mkUniqsS [] _ = [] + mkUniqsS (n:t) us = case splitAt n us of + (us1,us2) -> us1 : mkUniqsS t us2 + + tc_name = tyConName tc + tc_cons = tyConDataCons tc + tc_arits = map dataConSourceArity tc_cons + + tc_occ = nameOccName tc_name + d_occ = mkGenD tc_occ + c_occ m = mkGenC tc_occ m + s_occ m n = mkGenS tc_occ m n + d_name = mkExternalName uniqD mod d_occ wiredInSrcSpan + c_names = [ mkExternalName u mod (c_occ m) wiredInSrcSpan + | (u,m) <- zip uniqsC [0..] ] + s_names = [ [ mkExternalName u mod (s_occ m n) wiredInSrcSpan + | (u,n) <- zip us [0..] ] | (us,m) <- zip uniqsS [0..] ] + + mkTyCon name = ASSERT( isExternalName name ) + buildAlgTyCon name [] [] distinctAbstractTyConRhs + NonRecursive False NoParentTyCon Nothing + + metaDTyCon <- mkTyCon d_name + metaCTyCons <- sequence [ mkTyCon c_name | c_name <- c_names ] + metaSTyCons <- mapM sequence + [ [ mkTyCon s_name + | s_name <- s_namesC ] | s_namesC <- s_names ] + + let metaDts = MetaTyCons metaDTyCon metaCTyCons metaSTyCons + + rep0_tycon <- tc_mkRepTyCon tc metaDts mod + + -- pprTrace "rep0" (ppr rep0_tycon) $ + return (metaDts, rep0_tycon) + +genDtMeta :: (TyCon, MetaTyCons) -> TcM BagDerivStuff +genDtMeta (tc,metaDts) = + do loc <- getSrcSpanM + dflags <- getDOpts + dClas <- tcLookupClass datatypeClassName + let new_dfun_name clas tycon = newDFunName clas [mkTyConApp tycon []] loc + d_dfun_name <- new_dfun_name dClas tc + cClas <- tcLookupClass constructorClassName + c_dfun_names <- sequence [ new_dfun_name cClas tc | _ <- metaC metaDts ] + sClas <- tcLookupClass selectorClassName + s_dfun_names <- sequence (map sequence [ [ new_dfun_name sClas tc + | _ <- x ] + | x <- metaS metaDts ]) + fix_env <- getFixityEnv + + let + safeOverlap = safeLanguageOn dflags + (dBinds,cBinds,sBinds) = mkBindsMetaD fix_env tc + + -- Datatype + d_metaTycon = metaD metaDts + d_inst = mkLocalInstance d_dfun $ NoOverlap safeOverlap + d_binds = VanillaInst dBinds [] False + d_dfun = mkDictFunId d_dfun_name (tyConTyVars tc) [] dClas + [ mkTyConTy d_metaTycon ] + d_mkInst = DerivInst (InstInfo { iSpec = d_inst, iBinds = d_binds }) + + -- Constructor + c_metaTycons = metaC metaDts + c_insts = [ mkLocalInstance (c_dfun c ds) $ NoOverlap safeOverlap + | (c, ds) <- myZip1 c_metaTycons c_dfun_names ] + c_binds = [ VanillaInst c [] False | c <- cBinds ] + c_dfun c dfun_name = mkDictFunId dfun_name (tyConTyVars tc) [] cClas + [ mkTyConTy c ] + c_mkInst = [ DerivInst (InstInfo { iSpec = is, iBinds = bs }) + | (is,bs) <- myZip1 c_insts c_binds ] + + -- Selector + s_metaTycons = metaS metaDts + s_insts = map (map (\(s,ds) -> mkLocalInstance (s_dfun s ds) $ + NoOverlap safeOverlap)) + (myZip2 s_metaTycons s_dfun_names) + s_binds = [ [ VanillaInst s [] False | s <- ss ] | ss <- sBinds ] + s_dfun s dfun_name = mkDictFunId dfun_name (tyConTyVars tc) [] sClas + [ mkTyConTy s ] + s_mkInst = map (map (\(is,bs) -> DerivInst (InstInfo { iSpec = is + , iBinds = bs}))) + (myZip2 s_insts s_binds) + + myZip1 :: [a] -> [b] -> [(a,b)] + myZip1 l1 l2 = ASSERT (length l1 == length l2) zip l1 l2 + + myZip2 :: [[a]] -> [[b]] -> [[(a,b)]] + myZip2 l1 l2 = + 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)) +\end{code} + +%************************************************************************ +%* * \subsection{Generating representation types} -%* * +%* * %************************************************************************ \begin{code} @@ -73,9 +203,7 @@ canDoGenerics tycon then (Just (ppr dc <+> text "must be a vanilla data constructor")) else Nothing) - -- 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) @@ -119,10 +247,11 @@ mkBindsRep tycon = -- type Rep_D a b = ...representation type for D ... -------------------------------------------------------------------------------- -tc_mkRepTyCon :: TyCon -- The type to generate representation for +tc_mkRepTyCon :: TyCon -- The type to generate representation for -> MetaTyCons -- Metadata datatypes to refer to + -> Module -- Used as the location of the new RepTy -> TcM TyCon -- Generated representation0 type -tc_mkRepTyCon tycon metaDts = +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 @@ -131,7 +260,9 @@ tc_mkRepTyCon tycon metaDts = ; rep0Ty <- tc_mkRepTy tycon metaDts -- `rep_name` is a name we generate for the synonym - ; rep_name <- newImplicitBinder (tyConName tycon) mkGenR +-- ; rep_name <- newImplicitBinder (tyConName tycon) mkGenR + ; rep_name <- newGlobalBinder mod (mkGenR (nameOccName (tyConName tycon))) + (nameSrcSpan (tyConName tycon)) ; let -- `tyvars` = [a,b] tyvars = tyConTyVars tycon @@ -144,6 +275,8 @@ tc_mkRepTyCon tycon metaDts = ; buildSynTyCon rep_name tyvars (SynonymTyCon rep0Ty) rep_kind NoParentTyCon (Just (rep0, appT)) } + + -------------------------------------------------------------------------------- -- Type representation -------------------------------------------------------------------------------- @@ -220,8 +353,8 @@ data MetaTyCons = MetaTyCons { -- One meta datatype per dataype instance Outputable MetaTyCons where ppr (MetaTyCons d c s) = ppr d $$ vcat (map ppr c) $$ vcat (map ppr (concat s)) -metaTyCons2TyCons :: MetaTyCons -> [TyCon] -metaTyCons2TyCons (MetaTyCons d c s) = d : c ++ concat s +metaTyCons2TyCons :: MetaTyCons -> Bag TyCon +metaTyCons2TyCons (MetaTyCons d c s) = listToBag (d : c ++ concat s) -- Bindings for Datatype, Constructor, and Selector instances diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index 970ce0d8c1..0061e5f6e5 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -25,7 +25,6 @@ import FamInst import FamInstEnv import TcDeriv import TcEnv -import RnSource ( addTcgDUs ) import TcHsType import TcUnify import MkCore ( nO_METHOD_BINDING_ERROR_ID ) @@ -399,29 +398,22 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls failIfErrsM -- If the addInsts stuff gave any errors, don't -- try the deriving stuff, because that may give -- more errors still - ; (deriv_inst_info, deriv_binds, deriv_dus, deriv_tys, deriv_ty_insts) - <- tcDeriving tycl_decls inst_decls deriv_decls - -- Extend the global environment also with the generated datatypes for - -- the generic representation - ; let all_tycons = map ATyCon (deriv_tys ++ deriv_ty_insts) - ; gbl_env <- tcExtendGlobalEnv all_tycons $ - tcExtendGlobalEnvImplicit (concatMap implicitTyThings all_tycons) $ - addFamInsts deriv_ty_insts $ - addInsts deriv_inst_info getGblEnv + ; (gbl_env, deriv_inst_info, deriv_binds) + <- tcDeriving tycl_decls inst_decls deriv_decls -- Check that if the module is compiled with -XSafe, there are no -- hand written instances of Typeable as then unsafe casts could be - -- performed. Derivied instances are OK. + -- performed. Derived instances are OK. ; dflags <- getDOpts ; when (safeLanguageOn dflags) $ mapM_ (\x -> when (is_cls (iSpec x) `elem` typeableClassNames) (addErrAt (getSrcSpan $ iSpec x) typInstErr)) local_info - ; return ( addTcgDUs gbl_env deriv_dus, - deriv_inst_info ++ local_info, - aux_binds `plusHsValBinds` deriv_binds) + ; return ( gbl_env + , (bagToList deriv_inst_info) ++ local_info + , aux_binds `plusHsValBinds` deriv_binds) }}} where typInstErr = ptext $ sLit $ "Can't create hand written instances of Typeable in Safe" |