X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcDeriv.lhs;h=a3ce1a9f2729265157cb6e2c9b7f788d9f552e38;hb=61d89bc49eb75d74ed9196ba5f7b7b32018b914b;hp=2658f0b1e27602335560788a3faae87686be5a2a;hpb=1cf00bfef1c35b89c21d1eaa9f6be7354a40f016;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index 2658f0b..a3ce1a9 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} @@ -325,9 +328,9 @@ tcDeriving tycl_decls inst_decls deriv_decls ; gen_binds <- return emptyBag -- mkGenericBinds is_boot tycl_decls {- - -- Generate the generic Representable0 instances + -- Generate the Generic instances -- from each type declaration - ; repInstsMeta <- genGenericRepBinds is_boot tycl_decls + ; repInstsMeta <- genGenericAlls is_boot tycl_decls ; let repInsts = concat (map (\(a,_,_) -> a) repInstsMeta) repMetaTys = map (\(_,b,_) -> b) repInstsMeta @@ -404,7 +407,7 @@ 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 @@ -457,11 +460,11 @@ stored in NewTypeDerived. @makeDerivSpecs@ fishes around to find the info about needed derived instances. \begin{code} --- Make the EarlyDerivSpec for Representable0 +{- +-- Make the EarlyDerivSpec for Generic mkGenDerivSpec :: TyCon -> TcRn (EarlyDerivSpec) mkGenDerivSpec tc = do - { let tvs = [] - ; cls <- tcLookupClass rep0ClassName + { cls <- tcLookupClass genClassName ; let tc_tvs = tyConTyVars tc ; let tc_app = mkTyConApp tc (mkTyVarTys tc_tvs) ; let cls_tys = [] @@ -469,7 +472,7 @@ mkGenDerivSpec tc = do ; ds <- mkEqnHelp StandAloneDerivOrigin tc_tvs cls cls_tys tc_app mtheta -- JPM TODO: StandAloneDerivOrigin?... ; return ds } - +-} -- Make the "extras" for the generic representation mkGenDerivExtras :: TyCon -> TcRn (MetaTyCons, TyCon, [(InstInfo RdrName, DerivAuxBinds)]) @@ -491,42 +494,55 @@ makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls | otherwise = do { eqns1 <- mapAndRecoverM deriveTyData all_tydata ; eqns2 <- mapAndRecoverM deriveStandalone deriv_decls - -- Generate EarlyDerivSpec's for Representable, if asked for - ; (xGenerics, xDeriveRepresentable) <- genericsFlags + -- Generate EarlyDerivSpec's for Generic, if asked for + -- ; (xGenerics, xDerRep) <- genericsFlags + ; xDerRep <- genericsFlag ; let allTyNames = [ tcdName d | L _ d <- tycl_decls, isDataDecl d ] - ; allTyDecls <- mapM tcLookupTyCon allTyNames - -- Select only those types that derive Representable + -- ; allTyDecls <- mapM tcLookupTyCon allTyNames + -- 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 all_tydata deriv_decls - xDeriveRepresentable) allTyNames + filter (needsExtras xDerRep + (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 - ; let remTyDecls = filter (\x -> not (x `elem` derTyDecls)) allTyDecls + -- 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 - ; return ( eqns1 ++ eqns2 ++ generic_instances - , generic_extras_deriv ++ generic_extras_flag) } + ; return ( eqns1 ++ eqns2 -- ++ generic_instances + , generic_extras_deriv {- ++ generic_extras_flag -}) } where - needsExtras all_tydata deriv_decls xDeriveRepresentable tc_name - | xDeriveRepresentable - -- The flag DeriveGenerics is on, so the types the are - -- deriving Representable should get the extras defined - && ( tc_name `elem` map (tcdName . unLoc . snd) all_tydata - || False) --tc_name `elem` map (unLoc . deriv_type . unLoc) deriv_decls) - -- JPM TODO: we should check in deriv_decls too, for now we - -- don't accept standalone deriving... - = True - | otherwise - -- Don't generate anything - = False + -- 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 (HsPredTy (HsClassP n _)) = Just n + getClassName _ = Nothing + + -- Extracts the name of the type in the deriving + getTypeName :: HsType Name -> Maybe Name + getTypeName (HsTyVar n) = Just n + getTypeName (HsOpTy _ (L _ n) _) = Just n + getTypeName (HsPredTy (HsClassP _ [L _ n])) = getTypeName n + getTypeName _ = Nothing extractTyDataPreds decls = [(p, d) | d@(L _ (TyData {tcdDerivs = Just preds})) <- decls, p <- preds] @@ -542,10 +558,10 @@ 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) +genericsFlag :: TcM Bool +genericsFlag = do dOpts <- getDOpts + return ( xopt Opt_Generics dOpts + || xopt Opt_DeriveGeneric dOpts) ------------------------------------------------------------------ deriveStandalone :: LDerivDecl Name -> TcM EarlyDerivSpec @@ -815,6 +831,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 @@ -918,9 +939,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 == rep0ClassKey = Just (checkFlag Opt_DeriveRepresentable `orCond` - checkFlag Opt_Generics) - -- JPM TODO: we should use canDoGenerics + | cls_key == genClassKey = Just (cond_RepresentableOk `andCond` + checkFlag Opt_DeriveGeneric) | otherwise = Nothing where cls_key = getUnique cls @@ -939,7 +959,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 @@ -965,11 +985,19 @@ 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") + +-- JPM TODO: should give better error message +cond_RepresentableOk :: Condition +{- +cond_RepresentableOk (_,t) | canDoGenerics t = Nothing + | otherwise = Just (ptext (sLit "Cannot derive Generic for type") <+> ppr t) +-} +cond_RepresentableOk (_,t) = canDoGenerics t cond_enumOrProduct :: Condition cond_enumOrProduct = cond_isEnumeration `orCond` @@ -984,7 +1012,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) @@ -992,7 +1020,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 @@ -1002,7 +1030,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 @@ -1015,9 +1043,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] @@ -1032,11 +1060,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 @@ -1063,10 +1091,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, _) @@ -1090,11 +1118,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 @@ -1555,7 +1583,7 @@ genDerivBinds loc fix_env clas tycon ,(functorClassKey, gen_Functor_binds) ,(foldableClassKey, gen_Foldable_binds) ,(traversableClassKey, gen_Traversable_binds) - ,(rep0ClassKey, gen_Rep0_binds) + ,(genClassKey, genGenericBinds) ] \end{code} @@ -1567,37 +1595,18 @@ genDerivBinds loc fix_env clas tycon For the generic representation we need to generate: \begin{itemize} -\item A Representable0 instance -\item A Rep0 type instance +\item A Generic instance +\item A Rep type instance \item Many auxiliary datatypes and instances for them (for the meta-information) \end{itemize} -@gen_Rep0_binds@ does (1) +@genGenericBinds@ does (1) @genGenericRepExtras@ does (2) and (3) -@genGenericRepBind@ does all of them +@genGenericAll@ 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 -} ]) +genGenericBinds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds) +genGenericBinds _ tc = (mkBindsRep tc, [ {- No DerivAuxBinds -} ]) genGenericRepExtras :: TyCon -> TcM (MetaTyCons, TyCon) genGenericRepExtras tc = @@ -1629,7 +1638,7 @@ genGenericRepExtras tc = 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 ] @@ -1639,28 +1648,28 @@ genGenericRepExtras tc = let metaDts = MetaTyCons metaDTyCon metaCTyCons metaSTyCons - rep0_tycon <- tc_mkRep0TyCon tc metaDts + rep0_tycon <- tc_mkRepTyCon tc metaDts return (metaDts, rep0_tycon) - -genGenericRepBind :: TyCon +{- +genGenericAll :: TyCon -> TcM ((InstInfo RdrName, DerivAuxBinds), MetaTyCons, TyCon) -genGenericRepBind tc = +genGenericAll tc = do (metaDts, rep0_tycon) <- genGenericRepExtras tc - clas <- tcLookupClass rep0ClassName + 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