From 924142621ebc30a3c16368e0df3466ee14185ddd Mon Sep 17 00:00:00 2001 From: Jose Pedro Magalhaes Date: Mon, 2 May 2011 16:00:43 +0200 Subject: [PATCH] Remove the hasGenerics field of TyCon, improve the way the Generics flags is handled, allow for standalone deriving of Representable0. --- compiler/iface/BinIface.hs | 6 +- compiler/iface/BuildTyCl.lhs | 7 +- compiler/iface/IfaceSyn.lhs | 16 +---- compiler/iface/MkIface.lhs | 1 - compiler/iface/TcIface.lhs | 3 +- compiler/prelude/TysWiredIn.lhs | 5 +- compiler/typecheck/TcDeriv.lhs | 89 ++++++++++++++++-------- compiler/typecheck/TcRnDriver.lhs | 6 -- compiler/typecheck/TcTyClsDecls.lhs | 9 +-- compiler/types/Generics.lhs | 30 ++++---- compiler/types/TyCon.lhs | 30 +++----- compiler/vectorise/Vectorise/Type/PData.hs | 1 - compiler/vectorise/Vectorise/Type/TyConDecl.hs | 1 - 13 files changed, 97 insertions(+), 107 deletions(-) diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index b1c97cd..993159b 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -1291,7 +1291,7 @@ instance Binary IfaceDecl where put_ bh idinfo put_ _ (IfaceForeign _ _) = error "Binary.put_(IfaceDecl): IfaceForeign" - put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8) = do + put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7) = do putByte bh 2 put_ bh (occNameFS a1) put_ bh a2 @@ -1300,7 +1300,6 @@ instance Binary IfaceDecl where put_ bh a5 put_ bh a6 put_ bh a7 - put_ bh a8 put_ bh (IfaceSyn a1 a2 a3 a4 a5) = do putByte bh 3 put_ bh (occNameFS a1) @@ -1335,9 +1334,8 @@ instance Binary IfaceDecl where a5 <- get bh a6 <- get bh a7 <- get bh - a8 <- get bh occ <- return $! mkOccNameFS tcName a1 - return (IfaceData occ a2 a3 a4 a5 a6 a7 a8) + return (IfaceData occ a2 a3 a4 a5 a6 a7) 3 -> do a1 <- get bh a2 <- get bh diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs index 805fcd7..9522024 100644 --- a/compiler/iface/BuildTyCl.lhs +++ b/compiler/iface/BuildTyCl.lhs @@ -59,13 +59,12 @@ buildAlgTyCon :: Name -> [TyVar] -> ThetaType -- ^ Stupid theta -> AlgTyConRhs -> RecFlag - -> Bool -- ^ True <=> want generics functions -> Bool -- ^ True <=> was declared in GADT syntax -> TyConParent -> Maybe (TyCon, [Type]) -- ^ family instance if applicable -> TcRnIf m n TyCon -buildAlgTyCon tc_name tvs stupid_theta rhs is_rec want_generics gadt_syn +buildAlgTyCon tc_name tvs stupid_theta rhs is_rec gadt_syn parent mb_family | Just fam_inst_info <- mb_family = -- We need to tie a knot as the coercion of a data instance depends @@ -74,11 +73,11 @@ buildAlgTyCon tc_name tvs stupid_theta rhs is_rec want_generics gadt_syn fixM $ \ tycon_rec -> do { fam_parent <- mkFamInstParentInfo tc_name tvs fam_inst_info tycon_rec ; return (mkAlgTyCon tc_name kind tvs stupid_theta rhs - fam_parent is_rec want_generics gadt_syn) } + fam_parent is_rec gadt_syn) } | otherwise = return (mkAlgTyCon tc_name kind tvs stupid_theta rhs - parent is_rec want_generics gadt_syn) + parent is_rec gadt_syn) where kind = mkArrowKinds (map tyVarKind tvs) liftedTypeKind diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index 3eae7a3..ea1ace8 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -67,14 +67,6 @@ data IfaceDecl ifRec :: RecFlag, -- Recursive or not? ifGadtSyntax :: Bool, -- True <=> declared using -- GADT syntax - ifGeneric :: Bool, -- True <=> generic converter - -- functions available - -- We need this for imported - -- data decls, since the - -- imported modules may have - -- been compiled with - -- different flags to the - -- current compilation unit ifFamInst :: Maybe (IfaceTyCon, [IfaceType]) -- Just <=> instance of family -- Invariant: @@ -471,11 +463,11 @@ pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, = hang (ptext (sLit "type family") <+> pprIfaceDeclHead [] tycon tyvars) 4 (dcolon <+> ppr kind) -pprIfaceDecl (IfaceData {ifName = tycon, ifGeneric = gen, ifCtxt = context, +pprIfaceDecl (IfaceData {ifName = tycon, ifCtxt = context, ifTyVars = tyvars, ifCons = condecls, ifRec = isrec, ifFamInst = mbFamInst}) = hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars) - 4 (vcat [pprRec isrec, pprGen gen, pp_condecls tycon condecls, + 4 (vcat [pprRec isrec, pp_condecls tycon condecls, pprFamily mbFamInst]) where pp_nd = case condecls of @@ -495,10 +487,6 @@ pprIfaceDecl (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars, pprRec :: RecFlag -> SDoc pprRec isrec = ptext (sLit "RecFlag") <+> ppr isrec -pprGen :: Bool -> SDoc -pprGen True = ptext (sLit "Generics: yes") -pprGen False = ptext (sLit "Generics: no") - pprFamily :: Maybe (IfaceTyCon, [IfaceType]) -> SDoc pprFamily Nothing = ptext (sLit "FamilyInstance: none") pprFamily (Just famInst) = ptext (sLit "FamilyInstance:") <+> ppr famInst diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index 39f8e06..847e7c7 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -1357,7 +1357,6 @@ tyThingToIfaceDecl (ATyCon tycon) ifCons = ifaceConDecls (algTyConRhs tycon), ifRec = boolToRecFlag (isRecursiveTyCon tycon), ifGadtSyntax = isGadtSyntaxTyCon tycon, - ifGeneric = tyConHasGenerics tycon, ifFamInst = famInstToIface (tyConFamInst_maybe tycon)} | isForeignTyCon tycon diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index 8dccc72..a4da138 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -433,7 +433,6 @@ tc_iface_decl parent _ (IfaceData {ifName = occ_name, ifCtxt = ctxt, ifGadtSyntax = gadt_syn, ifCons = rdr_cons, ifRec = is_rec, - ifGeneric = want_generic, ifFamInst = mb_family }) = bindIfaceTyVars_AT tv_bndrs $ \ tyvars -> do { tc_name <- lookupIfaceTop occ_name @@ -442,7 +441,7 @@ tc_iface_decl parent _ (IfaceData {ifName = occ_name, ; cons <- tcIfaceDataCons tc_name tycon tyvars rdr_cons ; mb_fam_inst <- tcFamInst mb_family ; buildAlgTyCon tc_name tyvars stupid_theta cons is_rec - want_generic gadt_syn parent mb_fam_inst + gadt_syn parent mb_fam_inst }) ; traceIf (text "tcIfaceDecl4" <+> ppr tycon) ; return (ATyCon tycon) } diff --git a/compiler/prelude/TysWiredIn.lhs b/compiler/prelude/TysWiredIn.lhs index db2ea1b..e0d23dd 100644 --- a/compiler/prelude/TysWiredIn.lhs +++ b/compiler/prelude/TysWiredIn.lhs @@ -211,7 +211,6 @@ pcTyCon is_enum is_rec name tyvars cons (DataTyCon cons is_enum) NoParentTyCon is_rec - True -- All the wired-in tycons have generics False -- Not in GADT syntax pcDataCon :: Name -> [TyVar] -> [Type] -> TyCon -> DataCon @@ -276,7 +275,7 @@ unboxedTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple Unboxed i | i <- [0..mA mk_tuple :: Boxity -> Int -> (TyCon,DataCon) mk_tuple boxity arity = (tycon, tuple_con) where - tycon = mkTupleTyCon tc_name tc_kind arity tyvars tuple_con boxity gen_info + tycon = mkTupleTyCon tc_name tc_kind arity tyvars tuple_con boxity modu = mkTupleModule boxity arity tc_name = mkWiredInName modu (mkTupleOcc tcName boxity arity) tc_uniq (ATyCon tycon) BuiltInSyntax @@ -293,8 +292,6 @@ mk_tuple boxity arity = (tycon, tuple_con) (ADataCon tuple_con) BuiltInSyntax tc_uniq = mkTupleTyConUnique boxity arity dc_uniq = mkTupleDataConUnique boxity arity - gen_info = True -- Tuples all have generics.. - -- hmm: that's a *lot* of code unitTyCon :: TyCon unitTyCon = tupleTyCon Boxed 0 diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index 2658f0b..2bd438d 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} @@ -460,15 +463,14 @@ stored in NewTypeDerived. -- Make the EarlyDerivSpec for Representable0 mkGenDerivSpec :: TyCon -> TcRn (EarlyDerivSpec) mkGenDerivSpec tc = do - { let tvs = [] - ; cls <- tcLookupClass rep0ClassName + { 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?... - ; return ds } + ; {- pprTrace "mkGenDerivSpec" (ppr (tc, ds)) $ -} return ds } -- Make the "extras" for the generic representation mkGenDerivExtras :: TyCon @@ -496,15 +498,22 @@ makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls ; 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 all_tydata deriv_decls - xDeriveRepresentable) allTyNames + 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 - ; 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 [] @@ -512,21 +521,33 @@ makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls then mapM mkGenDerivExtras remTyDecls else return [] -- Merge and return everything - ; return ( eqns1 ++ eqns2 ++ generic_instances + ; {- 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 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 + 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] @@ -815,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 @@ -918,9 +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 (checkFlag Opt_DeriveRepresentable `orCond` - checkFlag Opt_Generics) - -- JPM TODO: we should use canDoGenerics + | cls_key == rep0ClassKey = Just (cond_RepresentableOk `andCond` + (checkFlag Opt_DeriveRepresentable `orCond` + checkFlag Opt_Generics)) | otherwise = Nothing where cls_key = getUnique cls @@ -971,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) @@ -1090,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 @@ -1629,7 +1660,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 ] @@ -1642,7 +1673,7 @@ genGenericRepExtras tc = rep0_tycon <- tc_mkRep0TyCon tc metaDts return (metaDts, rep0_tycon) - +{- genGenericRepBind :: TyCon -> TcM ((InstInfo RdrName, DerivAuxBinds), MetaTyCons, TyCon) genGenericRepBind tc = @@ -1660,7 +1691,7 @@ genGenericRepBind tc = 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 diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 46852c6..4017167 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -1587,7 +1587,6 @@ pprTcGblEnv (TcGblEnv { tcg_type_env = type_env, , ppr_fam_insts fam_insts , vcat (map ppr rules) , vcat (map ppr vects) - , ppr_gen_tycons (typeEnvTyCons type_env) , ptext (sLit "Dependent modules:") <+> ppr (sortBy cmp_mp $ eltsUFM (imp_dep_mods imports)) , ptext (sLit "Dependent packages:") <+> @@ -1667,9 +1666,4 @@ ppr_rules [] = empty ppr_rules rs = vcat [ptext (sLit "{-# RULES"), nest 2 (pprRules rs), ptext (sLit "#-}")] - -ppr_gen_tycons :: [TyCon] -> SDoc -ppr_gen_tycons [] = empty -ppr_gen_tycons tcs = vcat [ptext (sLit "Tycons with generics:"), - nest 2 (fsep (map ppr (filter tyConHasGenerics tcs)))] \end{code} diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index c50dc99..284972e 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -25,7 +25,6 @@ import TcMType import TcType import TysWiredIn ( unitTy ) import Type -import Generics import Class import TyCon import DataCon @@ -272,7 +271,7 @@ tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name, NewType -> ASSERT( not (null data_cons) ) mkNewTyConRhs rep_tc_name rep_tycon (head data_cons) ; buildAlgTyCon rep_tc_name t_tvs stupid_theta tc_rhs Recursive - False h98_syntax NoParentTyCon (Just (fam_tycon, t_typats)) + h98_syntax NoParentTyCon (Just (fam_tycon, t_typats)) -- We always assume that indexed types are recursive. Why? -- (1) Due to their open nature, we can never be sure that a -- further instance might not introduce a new recursive @@ -640,7 +639,7 @@ tcTyClDecl1 parent _calc_isrec ; checkTc idx_tys $ badFamInstDecl tc_name ; tycon <- buildAlgTyCon tc_name final_tvs [] - DataFamilyTyCon Recursive False True + DataFamilyTyCon Recursive True parent Nothing ; return [ATyCon tycon] } @@ -666,7 +665,6 @@ tcTyClDecl1 _parent calc_isrec { extra_tvs <- tcDataKindSig mb_ksig ; let final_tvs = tvs' ++ extra_tvs ; stupid_theta <- tcHsKindedContext ctxt - ; want_generic <- xoptM Opt_Generics ; unbox_strict <- doptM Opt_UnboxStrictFields ; empty_data_decls <- xoptM Opt_EmptyDataDecls ; kind_signatures <- xoptM Opt_KindSignatures @@ -708,8 +706,7 @@ tcTyClDecl1 _parent calc_isrec NewType -> ASSERT( not (null data_cons) ) mkNewTyConRhs tc_name tycon (head data_cons) ; buildAlgTyCon tc_name final_tvs stupid_theta tc_rhs is_rec - (want_generic && canDoGenerics stupid_theta data_cons) (not h98_syntax) - NoParentTyCon Nothing + (not h98_syntax) NoParentTyCon Nothing }) ; return [ATyCon tycon] } diff --git a/compiler/types/Generics.lhs b/compiler/types/Generics.lhs index b17670d..6aebe4c 100644 --- a/compiler/types/Generics.lhs +++ b/compiler/types/Generics.lhs @@ -42,18 +42,24 @@ import FastString %************************************************************************ \begin{code} -canDoGenerics :: ThetaType -> [DataCon] -> Bool +canDoGenerics :: TyCon -> Bool -- Called on source-code data types, to see if we should generate --- generic functions for them. (This info is recorded in the interface file for --- imported data types.) - -canDoGenerics stupid_theta data_cs - = not (any bad_con data_cs) -- See comment below - - -- && not (null data_cs) -- No values of the type - -- JPM: we now support empty datatypes - - && null stupid_theta -- We do not support datatypes with context (for now) +-- generic functions for them. + +canDoGenerics tycon + = let result = not (any bad_con (tyConDataCons tycon)) -- See comment below + -- We do not support datatypes with context (for now) + && null (tyConStupidTheta tycon) +{- + -- Primitives are (probably) not representable either + && not (isPrimTyCon tycon) + -- Foreigns are (probably) not representable either + && not (isForeignTyCon tycon) +-} + -- We don't like type families + && not (isFamilyTyCon tycon) + + in {- pprTrace "canDoGenerics" (ppr (tycon,result)) -} result where bad_con dc = any bad_arg_type (dataConOrigArgTys dc) || not (isVanillaDataCon dc) -- If any of the constructor has an unboxed type as argument, @@ -65,8 +71,6 @@ canDoGenerics stupid_theta data_cs -- Nor if the args are polymorphic types (I don't think) bad_arg_type ty = isUnLiftedType ty || not (isTauTy ty) - -- JPM: TODO: I'm not sure I know what isTauTy checks for, so I'm leaving it - -- like this for now... \end{code} %************************************************************************ diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs index 0baa312..5804d49 100644 --- a/compiler/types/TyCon.lhs +++ b/compiler/types/TyCon.lhs @@ -49,7 +49,7 @@ module TyCon( isTyConAssoc, isRecursiveTyCon, isHiBootTyCon, - isImplicitTyCon, tyConHasGenerics, + isImplicitTyCon, -- ** Extracting information out of TyCons tyConName, @@ -317,11 +317,7 @@ data TyCon algTcRec :: RecFlag, -- ^ Tells us whether the data type is part -- of a mutually-recursive group or not - - hasGenerics :: Bool, -- ^ Whether generic (in the -XGenerics sense) - -- to\/from functions are available in the exports - -- of the data type's source module. - + algTcParent :: TyConParent -- ^ Gives the class or family declaration 'TyCon' -- for derived 'TyCon's representing class -- or family instances, respectively. @@ -337,8 +333,7 @@ data TyCon tyConArity :: Arity, tyConBoxed :: Boxity, tyConTyVars :: [TyVar], - dataCon :: DataCon, -- ^ Corresponding tuple data constructor - hasGenerics :: Bool + dataCon :: DataCon -- ^ Corresponding tuple data constructor } -- | Represents type synonyms @@ -776,10 +771,9 @@ mkAlgTyCon :: Name -> AlgTyConRhs -- ^ Information about dat aconstructors -> TyConParent -> RecFlag -- ^ Is the 'TyCon' recursive? - -> Bool -- ^ Does it have generic functions? See 'hasGenerics' -> Bool -- ^ Was the 'TyCon' declared with GADT syntax? -> TyCon -mkAlgTyCon name kind tyvars stupid rhs parent is_rec gen_info gadt_syn +mkAlgTyCon name kind tyvars stupid rhs parent is_rec gadt_syn = AlgTyCon { tyConName = name, tyConUnique = nameUnique name, @@ -790,14 +784,13 @@ mkAlgTyCon name kind tyvars stupid rhs parent is_rec gen_info gadt_syn algTcRhs = rhs, algTcParent = ASSERT( okParent name parent ) parent, algTcRec = is_rec, - algTcGadtSyntax = gadt_syn, - hasGenerics = gen_info + algTcGadtSyntax = gadt_syn } -- | Simpler specialization of 'mkAlgTyCon' for classes mkClassTyCon :: Name -> Kind -> [TyVar] -> AlgTyConRhs -> Class -> RecFlag -> TyCon mkClassTyCon name kind tyvars rhs clas is_rec = - mkAlgTyCon name kind tyvars [] rhs (ClassTyCon clas) is_rec False False + mkAlgTyCon name kind tyvars [] rhs (ClassTyCon clas) is_rec False mkTupleTyCon :: Name -> Kind -- ^ Kind of the resulting 'TyCon' @@ -805,9 +798,8 @@ mkTupleTyCon :: Name -> [TyVar] -- ^ 'TyVar's scoped over: see 'tyConTyVars' -> DataCon -> Boxity -- ^ Whether the tuple is boxed or unboxed - -> Bool -- ^ Does it have generic functions? See 'hasGenerics' -> TyCon -mkTupleTyCon name kind arity tyvars con boxed gen_info +mkTupleTyCon name kind arity tyvars con boxed = TupleTyCon { tyConUnique = nameUnique name, tyConName = name, @@ -815,8 +807,7 @@ mkTupleTyCon name kind arity tyvars con boxed gen_info tyConArity = arity, tyConBoxed = boxed, tyConTyVars = tyvars, - dataCon = con, - hasGenerics = gen_info + dataCon = con } -- ^ Foreign-imported (.NET) type constructors are represented @@ -1200,11 +1191,6 @@ expand tvs rhs tys \end{code} \begin{code} --- | Does this 'TyCon' have any generic to\/from functions available? See also 'hasGenerics' -tyConHasGenerics :: TyCon -> Bool -tyConHasGenerics (AlgTyCon {hasGenerics = hg}) = hg -tyConHasGenerics (TupleTyCon {hasGenerics = hg}) = hg -tyConHasGenerics _ = False -- Synonyms tyConKind :: TyCon -> Kind tyConKind (FunTyCon { tc_kind = k }) = k diff --git a/compiler/vectorise/Vectorise/Type/PData.hs b/compiler/vectorise/Vectorise/Type/PData.hs index 332344b..b7bd95e 100644 --- a/compiler/vectorise/Vectorise/Type/PData.hs +++ b/compiler/vectorise/Vectorise/Type/PData.hs @@ -31,7 +31,6 @@ buildPDataTyCon orig_tc vect_tc repr = fixV $ \repr_tc -> [] -- no stupid theta rhs rec_flag -- FIXME: is this ok? - False -- FIXME: no generics False -- not GADT syntax NoParentTyCon (Just $ mk_fam_inst pdata vect_tc) diff --git a/compiler/vectorise/Vectorise/Type/TyConDecl.hs b/compiler/vectorise/Vectorise/Type/TyConDecl.hs index 0fa8482..cbfea45 100644 --- a/compiler/vectorise/Vectorise/Type/TyConDecl.hs +++ b/compiler/vectorise/Vectorise/Type/TyConDecl.hs @@ -82,7 +82,6 @@ vectTyConDecl tycon [] -- no stupid theta. rhs' -- new constructor defs. rec_flag -- FIXME: is this ok? - False -- FIXME: no generics False -- not GADT syntax NoParentTyCon Nothing -- not a family instance -- 1.7.10.4