X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcDeriv.lhs;h=fab7c61ff07cd2e388a1bf4a0d7141255c112e18;hp=34baafb7a65bd19f00d88fc23e1e3407c9c2ab3f;hb=HEAD;hpb=ff843f76541ab39ed30c050ae41c7c07c8980d3a diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index 34baafb..fab7c61 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -128,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} @@ -307,7 +310,9 @@ tcDeriving tycl_decls inst_decls deriv_decls -- 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 @@ -322,31 +327,40 @@ tcDeriving tycl_decls inst_decls deriv_decls -- 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 ++ repInsts) + <- renameDeriv is_boot gen_binds (insts1 ++ insts2 ++ concat metaInsts) ; dflags <- getDOpts ; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances" - (ddump_deriving inst_info rn_binds)) - + (ddump_deriving inst_info rn_binds repMetaTys repTyCons metaInsts)) +{- ; when (not (null inst_info)) $ dumpDerivingInfo (ddump_deriving inst_info rn_binds) +-} ; 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 - = hang (ptext (sLit "Derived instances")) - 2 (vcat (map (\i -> pprInstInfoDetails i $$ text "") inst_infos) - $$ ppr extra_binds) + ddump_deriving :: [InstInfo Name] -> HsValBinds Name + -> [MetaTyCons] -- ^ Empty data constructors + -> [TyCon] -- ^ Rep type family instances + -> [[(InstInfo RdrName, DerivAuxBinds)]] + -- ^ 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) + $$ ppr extra_binds) + $$ hangP "Generic representation" ( + hangP "Generated datatypes for meta-information" + (vcat (map ppr 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 s x = text "" $$ hang (ptext (sLit s)) 2 x + renameDeriv :: Bool -> LHsBinds RdrName -> [(InstInfo RdrName, DerivAuxBinds)] @@ -399,28 +413,12 @@ renameDeriv is_boot gen_binds insts -- scope (yuk), and rename the method binds ASSERT( null sigs ) bindLocalNames (map Var.varName tyvars) $ - do { (rn_binds, fvs) <- rnMethodBinds clas_nm (\_ -> []) [] binds + do { (rn_binds, fvs) <- rnMethodBinds clas_nm (\_ -> []) binds ; let binds' = VanillaInst rn_binds [] standalone_deriv ; return (inst_info { iBinds = binds' }, fvs) } where (tyvars,_, clas,_) = instanceHead inst clas_nm = className clas - ------------------------------------------ -{- Now unused -mkGenericBinds :: Bool -> [LTyClDecl Name] -> TcM (LHsBinds RdrName) -mkGenericBinds is_boot tycl_decls - | is_boot - = return emptyBag - | otherwise - = do { tcs <- mapM tcLookupTyCon [ tcdName d - | L _ d <- tycl_decls, isDataDecl d ] - ; return (unionManyBags [ mkTyConGenericBinds tc - | tc <- tcs, tyConHasGenerics tc ]) } - -- 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] @@ -452,34 +450,93 @@ 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] + -> [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 [] } + | is_boot -- No 'deriving' at all in hs-boot files + = do { mapM_ add_deriv_err deriv_locs + ; return ([],[]) } | otherwise - = do { eqns1 <- mapAndRecoverM deriveTyData all_tydata - ; eqns2 <- mapAndRecoverM deriveStandalone deriv_decls - ; return (eqns1 ++ eqns2) } + = 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 + , getClassName c == Just genClassName ] + ; let sel_deriv_decls = catMaybes [ getTypeName t + | L _ (DerivDecl (L _ t)) <- deriv_decls + , getClassName t == Just genClassName ] + ; 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) } 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 + getClassName :: HsType Name -> Maybe Name + getClassName (HsForAllTy _ _ _ (L _ n)) = getClassName n + getClassName (HsPredTy (HsClassP n _)) = Just n + getClassName _ = Nothing + + -- 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 (HsForAllTy _ _ _ (L _ n)) = getTypeName n + getTypeName (HsTyVar n) = Just n + getTypeName (HsOpTy _ (L _ n) _) = Just n + getTypeName (HsPredTy (HsClassP _ [L _ n])) = getTypeName n + getTypeName (HsAppTy (L _ n) _) = getTypeName n + getTypeName (HsParTy (L _ n)) = getTypeName n + getTypeName (HsKindSig (L _ n) _) = getTypeName n + getTypeName _ = Nothing + extractTyDataPreds decls = [(p, d) | d@(L _ (TyData {tcdDerivs = Just preds})) <- decls, p <- preds] all_tydata :: [(LHsType Name, LTyClDecl Name)] - -- Derived predicate paired with its data type declaration + -- Derived predicate paired with its data type declaration all_tydata = extractTyDataPreds (instDeclATs inst_decls ++ tycl_decls) deriv_locs = map (getLoc . snd) all_tydata - ++ map getLoc deriv_decls + ++ map getLoc deriv_decls add_deriv_err loc = setSrcSpan loc $ - addErr (hang (ptext (sLit "Deriving not permitted in hs-boot file")) - 2 (ptext (sLit "Use an instance declaration instead"))) + addErr (hang (ptext (sLit "Deriving not permitted in hs-boot file")) + 2 (ptext (sLit "Use an instance declaration instead"))) ------------------------------------------------------------------ deriveStandalone :: LDerivDecl Name -> TcM EarlyDerivSpec @@ -749,6 +806,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 + -- Generic constraints are easy + | cls `hasKey` genClassKey + = [] + -- 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 @@ -852,6 +914,8 @@ 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 == genClassKey = Just (cond_RepresentableOk `andCond` + checkFlag Opt_DeriveGeneric) | otherwise = Nothing where cls_key = getUnique cls @@ -870,7 +934,7 @@ orCond c1 c2 tc Nothing -> Nothing -- c1 succeeds Just x -> case c2 tc of -- c1 fails Nothing -> Nothing - Just y -> Just (x $$ ptext (sLit " and") $$ y) + Just y -> Just (x $$ ptext (sLit " or") $$ y) -- Both fail andCond :: Condition -> Condition -> Condition @@ -896,11 +960,14 @@ cond_stdOK Nothing (_, rep_tc) check_con con | isVanillaDataCon con , all isTauTy (dataConOrigArgTys con) = Nothing - | otherwise = Just (badCon con (ptext (sLit "does not have a Haskell-98 type"))) + | otherwise = Just (badCon con (ptext (sLit "must have a Haskell-98 type"))) no_cons_why :: TyCon -> SDoc no_cons_why rep_tc = quotes (pprSourceTyCon rep_tc) <+> - ptext (sLit "has no data constructors") + ptext (sLit "must have at least one data constructor") + +cond_RepresentableOk :: Condition +cond_RepresentableOk (_,t) = canDoGenerics t cond_enumOrProduct :: Condition cond_enumOrProduct = cond_isEnumeration `orCond` @@ -915,7 +982,7 @@ cond_noUnliftedArgs (_, tc) where bad_cons = [ con | con <- tyConDataCons tc , any isUnLiftedType (dataConOrigArgTys con) ] - why = badCon (head bad_cons) (ptext (sLit "has arguments of unlifted type")) + why = badCon (head bad_cons) (ptext (sLit "must have only arguments of lifted type")) cond_isEnumeration :: Condition cond_isEnumeration (_, rep_tc) @@ -923,7 +990,7 @@ cond_isEnumeration (_, rep_tc) | otherwise = Just why where why = sep [ quotes (pprSourceTyCon rep_tc) <+> - ptext (sLit "is not an enumeration type") + ptext (sLit "must be an enumeration type") , ptext (sLit "(an enumeration consists of one or more nullary, non-GADT constructors)") ] -- See Note [Enumeration types] in TyCon @@ -933,7 +1000,7 @@ cond_isProduct (_, rep_tc) | otherwise = Just why where why = quotes (pprSourceTyCon rep_tc) <+> - ptext (sLit "does not have precisely one constructor") + ptext (sLit "must have precisely one constructor") cond_typeableOK :: Condition -- OK for Typeable class @@ -946,9 +1013,9 @@ cond_typeableOK (_, tc) | otherwise = Nothing where too_many = quotes (pprSourceTyCon tc) <+> - ptext (sLit "has too many arguments") + ptext (sLit "must have 7 or fewer arguments") bad_kind = quotes (pprSourceTyCon tc) <+> - ptext (sLit "has arguments of kind other than `*'") + ptext (sLit "must only have arguments of kind `*'") functorLikeClassKeys :: [Unique] functorLikeClassKeys = [functorClassKey, foldableClassKey, traversableClassKey] @@ -963,11 +1030,11 @@ cond_functorOK :: Bool -> Condition cond_functorOK allowFunctions (_, rep_tc) | null tc_tvs = Just (ptext (sLit "Data type") <+> quotes (ppr rep_tc) - <+> ptext (sLit "has no parameters")) + <+> ptext (sLit "must have some type parameters")) | not (null bad_stupid_theta) = Just (ptext (sLit "Data type") <+> quotes (ppr rep_tc) - <+> ptext (sLit "has a class context") <+> pprTheta bad_stupid_theta) + <+> ptext (sLit "must not have a class context") <+> pprTheta bad_stupid_theta) | otherwise = msum (map check_con data_cons) -- msum picks the first 'Just', if any @@ -994,10 +1061,10 @@ cond_functorOK allowFunctions (_, rep_tc) , ft_bad_app = Just (badCon con wrong_arg) , ft_forall = \_ x -> x } - existential = ptext (sLit "has existential arguments") - covariant = ptext (sLit "uses the type variable in a function argument") - functions = ptext (sLit "contains function types") - wrong_arg = ptext (sLit "uses the type variable in an argument other than the last") + existential = ptext (sLit "must not have existential arguments") + covariant = ptext (sLit "must not use the type variable in a function argument") + functions = ptext (sLit "must not contain function types") + wrong_arg = ptext (sLit "must not use the type variable in an argument other than the last") checkFlag :: ExtensionFlag -> Condition checkFlag flag (dflags, _) @@ -1021,11 +1088,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, Generic by isomorphism, -- even with -XGeneralizedNewtypeDeriving non_iso_class cls - = classKey cls `elem` ([readClassKey, showClassKey, dataClassKey] ++ - typeableClassKeys) + = classKey cls `elem` ([ readClassKey, showClassKey, dataClassKey + , genClassKey] ++ typeableClassKeys) typeableClassKeys :: [Unique] typeableClassKeys = map getUnique typeableClassNames @@ -1316,7 +1383,7 @@ inferInstanceContexts oflag infer_specs ; let tv_set = mkVarSet tyvars weird_preds = [pred | pred <- deriv_rhs - , not (tyVarsOfPred pred `subVarSet` tv_set)] + , not (tyVarsOfPred pred `subVarSet` tv_set)] ; mapM_ (addErrTc . badDerivedPred) weird_preds ; theta <- simplifyDeriv orig the_pred tyvars deriv_rhs @@ -1447,14 +1514,12 @@ genInst standalone_deriv oflag where inst_spec = mkInstance oflag theta spec co1 = case tyConFamilyCoercion_maybe rep_tycon of - Just co_con -> ACo (mkTyConApp co_con rep_tc_args) + Just co_con -> mkAxInstCo co_con rep_tc_args Nothing -> id_co -- Not a family => rep_tycon = main tycon - co2 = case newTyConCo_maybe rep_tycon of - Just co_con -> ACo (mkTyConApp co_con rep_tc_args) - Nothing -> id_co -- The newtype is transparent; no need for a cast - co = co1 `mkTransCoI` co2 - id_co = IdCo (mkTyConApp rep_tycon rep_tc_args) + co2 = mkAxInstCo (newTyConCo rep_tycon) rep_tc_args + co = co1 `mkTransCo` co2 + id_co = mkReflCo (mkTyConApp rep_tycon rep_tc_args) -- Example: newtype instance N [a] = N1 (Tree a) -- deriving instance Eq b => Eq (N [(b,b)]) @@ -1475,43 +1540,45 @@ 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) + ,(genClassKey, genGenericBinds) ] +\end{code} --- Generate the binds for the generic representation -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 ]) - -genGenericRepBind :: TyCon -> TcM ((InstInfo RdrName, DerivAuxBinds) - , MetaTyCons, TyCon) -genGenericRepBind tc = - do clas <- tcLookupClass rep0ClassName - uniqS <- newUniqueSupply - dfun_name <- new_dfun_name clas tc +%************************************************************************ +%* * +\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 @@ -1536,12 +1603,10 @@ genGenericRepBind tc = | (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..] ] - tvs = tyConTyVars tc - tc_ty = mkTyConApp tc (mkTyVarTys tvs) mkTyCon name = ASSERT( isExternalName name ) buildAlgTyCon name [] [] mkAbstractTyConRhs - NonRecursive False False NoParentTyCon Nothing + NonRecursive False NoParentTyCon Nothing metaDTyCon <- mkTyCon d_name metaCTyCons <- sequence [ mkTyCon c_name | c_name <- c_names ] @@ -1551,17 +1616,29 @@ genGenericRepBind tc = let metaDts = MetaTyCons metaDTyCon metaCTyCons metaSTyCons - rep0_tycon <- tc_mkRep0TyCon tc metaDts - + 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 - mkInstRep0 = (InstInfo { iSpec = inst, iBinds = binds } + mkInstRep = (InstInfo { iSpec = inst, iBinds = binds } , [ {- No DerivAuxBinds -} ]) inst = mkLocalInstance dfun NoOverlap - binds = VanillaInst (mkBindsRep0 tc) [] False + binds = VanillaInst (mkBindsRep 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) - + return (mkInstRep, metaDts, rep0_tycon) +-} genDtMeta :: (TyCon, MetaTyCons) -> TcM [(InstInfo RdrName, DerivAuxBinds)] genDtMeta (tc,metaDts) = do dClas <- tcLookupClass datatypeClassName