X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcDeriv.lhs;h=2bd438d489963ee061c8fe04d417912b094d11d2;hp=1798be31000767eb58731395b4dee68c7f84f8cc;hb=924142621ebc30a3c16368e0df3466ee14185ddd;hpb=f67b457bb0271dd1590efcaa912fc441388531d9 diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index 1798be3..2bd438d 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -40,10 +40,13 @@ 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 @@ -125,6 +128,9 @@ pprDerivSpec (DS { ds_loc = l, ds_name = n, ds_tvs = tvs, ds_cls = c, ds_tys = tys, ds_theta = rhs }) = parens (hsep [ppr l, ppr n, ppr tvs, ppr c, ppr tys] <+> equals <+> ppr rhs) + +instance Outputable DerivSpec where + ppr = pprDerivSpec \end{code} @@ -292,17 +298,21 @@ 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) + -> 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 tcDeriving tycl_decls inst_decls deriv_decls - = recoverM (return ([], emptyValBindsOut, emptyDUs)) $ + = recoverM (return ([], emptyValBindsOut, emptyDUs, [], [])) $ 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 <- makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls + ; (early_specs, genericsExtras) + <- makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls + ; let (repMetaTys, repTyCons, metaInsts) = unzip3 genericsExtras ; overlap_flag <- getOverlapFlag ; let (infer_specs, given_specs) = splitEithers early_specs @@ -313,14 +323,31 @@ tcDeriving tycl_decls inst_decls deriv_decls ; insts2 <- mapM (genInst False overlap_flag) final_specs - -- Generate the generic to/from functions from each type declaration - ; gen_binds <- mkGenericBinds is_boot tycl_decls - ; (inst_info, rn_binds, rn_dus) <- renameDeriv is_boot gen_binds (insts1 ++ insts2) - + -- 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 + +{- + -- Generate the generic Representable0 instances + -- from each type declaration + ; repInstsMeta <- genGenericRepBinds is_boot tycl_decls + + ; let repInsts = concat (map (\(a,_,_) -> a) repInstsMeta) + repMetaTys = map (\(_,b,_) -> b) repInstsMeta + repTyCons = map (\(_,_,c) -> c) repInstsMeta +-} + ; (inst_info, rn_binds, rn_dus) + <- renameDeriv is_boot gen_binds (insts1 ++ insts2 ++ concat metaInsts {- ++ repInsts -}) + + ; dflags <- getDOpts + ; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances" + (ddump_deriving inst_info rn_binds)) +{- ; when (not (null inst_info)) $ dumpDerivingInfo (ddump_deriving inst_info rn_binds) - - ; return (inst_info, rn_binds, rn_dus) } +-} + ; return ( inst_info, rn_binds, rn_dus + , concat (map metaTyCons2TyCons repMetaTys), repTyCons) } where ddump_deriving :: [InstInfo Name] -> HsValBinds Name -> SDoc ddump_deriving inst_infos extra_binds @@ -328,6 +355,7 @@ tcDeriving tycl_decls inst_decls deriv_decls 2 (vcat (map (\i -> pprInstInfoDetails i $$ text "") inst_infos) $$ ppr extra_binds) + renameDeriv :: Bool -> LHsBinds RdrName -> [(InstInfo RdrName, DerivAuxBinds)] -> TcM ([InstInfo Name], HsValBinds Name, DefUses) @@ -387,6 +415,7 @@ renameDeriv is_boot gen_binds insts clas_nm = className clas ----------------------------------------- +{- Now unused mkGenericBinds :: Bool -> [LTyClDecl Name] -> TcM (LHsBinds RdrName) mkGenericBinds is_boot tycl_decls | is_boot @@ -399,6 +428,7 @@ mkGenericBinds is_boot tycl_decls -- We are only interested in the data type declarations, -- and then only in the ones whose 'has-generics' flag is on -- The predicate tyConHasGenerics finds both of these +-} \end{code} Note [Newtype deriving and unused constructors] @@ -430,21 +460,95 @@ stored in NewTypeDerived. @makeDerivSpecs@ fishes around to find the info about needed derived instances. \begin{code} +-- Make the EarlyDerivSpec for Representable0 +mkGenDerivSpec :: TyCon -> TcRn (EarlyDerivSpec) +mkGenDerivSpec tc = do + { cls <- tcLookupClass rep0ClassName + ; let tc_tvs = tyConTyVars tc + ; let tc_app = mkTyConApp tc (mkTyVarTys tc_tvs) + ; let cls_tys = [] + ; let mtheta = Just [] + ; ds <- mkEqnHelp StandAloneDerivOrigin tc_tvs cls cls_tys tc_app mtheta + -- JPM TODO: StandAloneDerivOrigin?... + ; {- pprTrace "mkGenDerivSpec" (ppr (tc, ds)) $ -} return ds } + +-- 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] + -> [LInstDecl Name] -> [LDerivDecl Name] - -> TcM [EarlyDerivSpec] - + -> TcM ( [EarlyDerivSpec] + , [(MetaTyCons, TyCon, [(InstInfo RdrName, DerivAuxBinds)])]) 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 - ; return (eqns1 ++ eqns2) } + -- Generate EarlyDerivSpec's for Representable, if asked for + ; (xGenerics, xDeriveRepresentable) <- genericsFlags + ; let allTyNames = [ tcdName d | L _ d <- tycl_decls, isDataDecl d ] + ; allTyDecls <- mapM tcLookupTyCon allTyNames + -- Select only those types that derive Representable + ; let sel_tydata = [ tcdName t | (L _ c, L _ t) <- all_tydata + , getClassName c == Just rep0ClassName ] + ; let sel_deriv_decls = catMaybes [ getTypeName t + | L _ (DerivDecl (L _ t)) <- deriv_decls + , getClassName t == Just rep0ClassName ] + ; derTyDecls <- mapM tcLookupTyCon $ + filter (needsExtras xDeriveRepresentable + (sel_tydata ++ sel_deriv_decls)) allTyNames + -- We need to generate the extras to add to what has + -- already been derived + ; generic_extras_deriv <- mapM mkGenDerivExtras derTyDecls + -- For the remaining types, if Generics is on, we need to + -- generate both the instances and the extras, but only for the + -- types we can represent. + ; let repTyDecls = filter canDoGenerics allTyDecls + ; let remTyDecls = filter (\x -> not (x `elem` derTyDecls)) repTyDecls + ; generic_instances <- if xGenerics + then mapM mkGenDerivSpec remTyDecls + else return [] + ; generic_extras_flag <- if xGenerics + then mapM mkGenDerivExtras remTyDecls + else return [] + -- Merge and return everything + ; {- pprTrace "allTyDecls" (ppr allTyDecls) $ + pprTrace "derTyDecls" (ppr derTyDecls) $ + pprTrace "repTyDecls" (ppr repTyDecls) $ + pprTrace "remTyDecls" (ppr remTyDecls) $ + pprTrace "xGenerics" (ppr xGenerics) $ + pprTrace "xDeriveRep" (ppr xDeriveRepresentable) $ + pprTrace "all_tydata" (ppr all_tydata) $ + pprTrace "eqns1" (ppr eqns1) $ + pprTrace "eqns2" (ppr eqns2) $ +-} + return ( eqns1 ++ eqns2 ++ generic_instances + , generic_extras_deriv ++ generic_extras_flag) } where + needsExtras xDeriveRepresentable tydata tc_name = + -- We need extras if the flag DeriveGenerics is on and this type is + -- deriving Representable + xDeriveRepresentable && tc_name `elem` tydata + + -- Extracts the name of the class in the deriving + getClassName :: HsType Name -> Maybe Name + getClassName (HsPredTy (HsClassP n _)) = Just n + getClassName _ = Nothing + + -- Extracts the name of the type in the deriving + getTypeName :: HsType Name -> Maybe Name + getTypeName (HsPredTy (HsClassP _ [L _ (HsTyVar n)])) = Just n + getTypeName _ = Nothing + extractTyDataPreds decls = [(p, d) | d@(L _ (TyData {tcdDerivs = Just preds})) <- decls, p <- preds] @@ -459,6 +563,11 @@ makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls addErr (hang (ptext (sLit "Deriving not permitted in hs-boot file")) 2 (ptext (sLit "Use an instance declaration instead"))) +genericsFlags :: TcM (Bool, Bool) +genericsFlags = do dOpts <- getDOpts + return ( xopt Opt_Generics dOpts + , xopt Opt_DeriveRepresentable dOpts) + ------------------------------------------------------------------ deriveStandalone :: LDerivDecl Name -> TcM EarlyDerivSpec -- Standalone deriving declarations @@ -727,6 +836,11 @@ inferConstraints :: [TyVar] -> Class -> [TcType] -> TyCon -> [TcType] -> ThetaTy -- 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 + -- Representable0 constraints are easy + | cls `hasKey` rep0ClassKey + = [] + -- 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 @@ -830,6 +944,9 @@ sideConditions mtheta cls cond_functorOK False) -- Functor/Fold/Trav works ok for rank-n types | cls_key == traversableClassKey = Just (checkFlag Opt_DeriveTraversable `andCond` cond_functorOK False) + | cls_key == rep0ClassKey = Just (cond_RepresentableOk `andCond` + (checkFlag Opt_DeriveRepresentable `orCond` + checkFlag Opt_Generics)) | otherwise = Nothing where cls_key = getUnique cls @@ -880,6 +997,11 @@ no_cons_why :: TyCon -> SDoc no_cons_why rep_tc = quotes (pprSourceTyCon rep_tc) <+> ptext (sLit "has no data constructors") +-- JPM TODO: should give better error message +cond_RepresentableOk :: Condition +cond_RepresentableOk (_,t) | canDoGenerics t = Nothing + | otherwise = Just (ptext (sLit "Cannot derive Representable for type") <+> ppr t) + cond_enumOrProduct :: Condition cond_enumOrProduct = cond_isEnumeration `orCond` (cond_isProduct `andCond` cond_noUnliftedArgs) @@ -999,11 +1121,11 @@ std_class_via_iso clas non_iso_class :: Class -> Bool --- *Never* derive Read,Show,Typeable,Data by isomorphism, +-- *Never* derive Read,Show,Typeable,Data,Representable0 by isomorphism, -- even with -XGeneralizedNewtypeDeriving non_iso_class cls - = classKey cls `elem` ([readClassKey, showClassKey, dataClassKey] ++ - typeableClassKeys) + = classKey cls `elem` ([ readClassKey, showClassKey, dataClassKey + , rep0ClassKey] ++ typeableClassKeys) typeableClassKeys :: [Unique] typeableClassKeys = map getUnique typeableClassNames @@ -1453,20 +1575,177 @@ genDerivBinds loc fix_env clas tycon Nothing -> pprPanic "genDerivBinds: bad derived class" (ppr clas) where gen_list :: [(Unique, SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds))] - gen_list = [(eqClassKey, gen_Eq_binds) - ,(ordClassKey, gen_Ord_binds) - ,(enumClassKey, gen_Enum_binds) - ,(boundedClassKey, gen_Bounded_binds) - ,(ixClassKey, gen_Ix_binds) - ,(showClassKey, gen_Show_binds fix_env) - ,(readClassKey, gen_Read_binds fix_env) - ,(dataClassKey, gen_Data_binds) - ,(functorClassKey, gen_Functor_binds) - ,(foldableClassKey, gen_Foldable_binds) - ,(traversableClassKey, gen_Traversable_binds) + 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) + ,(rep0ClassKey, gen_Rep0_binds) ] \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 Representable0 instance +\item A Rep0 type instance +\item Many auxiliary datatypes and instances for them (for the meta-information) +\end{itemize} + +@gen_Rep0_binds@ does (1) +@genGenericRepExtras@ does (2) and (3) +@genGenericRepBind@ does all of them + +\begin{code} +{- +genGenericRepBinds :: Bool -> [LTyClDecl Name] + -> TcM [([(InstInfo RdrName, DerivAuxBinds)] + , MetaTyCons, TyCon)] +genGenericRepBinds isBoot tyclDecls + | isBoot = return [] + | otherwise = do + allTyDecls <- mapM tcLookupTyCon [ tcdName d | L _ d <- tyclDecls + , isDataDecl d ] + let tyDecls = filter tyConHasGenerics allTyDecls + inst1 <- mapM genGenericRepBind tyDecls + let (_repInsts, metaTyCons, _repTys) = unzip3 inst1 + metaInsts <- ASSERT (length tyDecls == length metaTyCons) + mapM genDtMeta (zip tyDecls metaTyCons) + return (ASSERT (length inst1 == length metaInsts) + [ (ri : mi, ms, rt) + | ((ri, ms, rt), mi) <- zip inst1 metaInsts ]) +-} + +gen_Rep0_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds) +gen_Rep0_binds _ tc = (mkBindsRep0 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 [] [] mkAbstractTyConRhs + 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_mkRep0TyCon tc metaDts + + return (metaDts, rep0_tycon) +{- +genGenericRepBind :: TyCon + -> TcM ((InstInfo RdrName, DerivAuxBinds), MetaTyCons, TyCon) +genGenericRepBind tc = + do (metaDts, rep0_tycon) <- genGenericRepExtras tc + clas <- tcLookupClass rep0ClassName + dfun_name <- new_dfun_name clas tc + let + mkInstRep0 = (InstInfo { iSpec = inst, iBinds = binds } + , [ {- No DerivAuxBinds -} ]) + inst = mkLocalInstance dfun NoOverlap + binds = VanillaInst (mkBindsRep0 tc) [] False + + tvs = tyConTyVars tc + tc_ty = mkTyConApp tc (mkTyVarTys tvs) + + dfun = mkDictFunId dfun_name (tyConTyVars tc) [] clas [tc_ty] + return (mkInstRep0, metaDts, rep0_tycon) +-} +genDtMeta :: (TyCon, MetaTyCons) -> TcM [(InstInfo RdrName, DerivAuxBinds)] +genDtMeta (tc,metaDts) = + do 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 + (dBinds,cBinds,sBinds) = mkBindsMetaD fix_env tc + + -- Datatype + d_metaTycon = metaD metaDts + d_inst = mkLocalInstance d_dfun NoOverlap + 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 + | (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)) + (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) +\end{code} + %************************************************************************ %* *