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
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)
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
-> 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
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
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:
= 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
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
ifCons = ifaceConDecls (algTyConRhs tycon),
ifRec = boolToRecFlag (isRecursiveTyCon tycon),
ifGadtSyntax = isGadtSyntaxTyCon tycon,
- ifGeneric = tyConHasGenerics tycon,
ifFamInst = famInstToIface (tyConFamInst_maybe tycon)}
| isForeignTyCon tycon
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
; 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) }
(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
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
(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
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}
-- 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
; 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 []
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]
-- 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
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
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)
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
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 ]
rep0_tycon <- tc_mkRep0TyCon tc metaDts
return (metaDts, rep0_tycon)
-
+{-
genGenericRepBind :: TyCon
-> TcM ((InstInfo RdrName, DerivAuxBinds), MetaTyCons, TyCon)
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
, 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:") <+>
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}
import TcType
import TysWiredIn ( unitTy )
import Type
-import Generics
import Class
import TyCon
import DataCon
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
; checkTc idx_tys $ badFamInstDecl tc_name
; tycon <- buildAlgTyCon tc_name final_tvs []
- DataFamilyTyCon Recursive False True
+ DataFamilyTyCon Recursive True
parent Nothing
; return [ATyCon tycon]
}
{ 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
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]
}
%************************************************************************
\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,
-- 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}
%************************************************************************
isTyConAssoc,
isRecursiveTyCon,
isHiBootTyCon,
- isImplicitTyCon, tyConHasGenerics,
+ isImplicitTyCon,
-- ** Extracting information out of TyCons
tyConName,
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.
tyConArity :: Arity,
tyConBoxed :: Boxity,
tyConTyVars :: [TyVar],
- dataCon :: DataCon, -- ^ Corresponding tuple data constructor
- hasGenerics :: Bool
+ dataCon :: DataCon -- ^ Corresponding tuple data constructor
}
-- | Represents type synonyms
-> 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,
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'
-> [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,
tyConArity = arity,
tyConBoxed = boxed,
tyConTyVars = tyvars,
- dataCon = con,
- hasGenerics = gen_info
+ dataCon = con
}
-- ^ Foreign-imported (.NET) type constructors are represented
\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
[] -- 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)
[] -- 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
projects / ghc-hetmet.git / commitdiff