\begin{code}
module Generics ( canDoGenerics,
- mkBindsRep0, tc_mkRep0TyCon, mkBindsMetaD,
+ mkBindsRep, tc_mkRepTyCon, mkBindsMetaD,
MetaTyCons(..), metaTyCons2TyCons
) where
import BasicTypes
import TysWiredIn
import PrelNames
+
-- For generation of representation types
import TcEnv (tcLookupTyCon)
-import TcRnMonad (TcM, newUnique)
+import TcRnMonad
import HscTypes
-
+import BuildTyCl
+
import SrcLoc
import Bag
import Outputable
%************************************************************************
\begin{code}
-canDoGenerics :: ThetaType -> [DataCon] -> Bool
+canDoGenerics :: TyCon -> Maybe SDoc
-- 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.
+-- Nothing == yes
+-- Just s == no, because of `s`
+
+canDoGenerics tycon
+ = mergeErrors (
+ -- We do not support datatypes with context
+ (if (not (null (tyConStupidTheta tycon)))
+ then (Just (ppr tycon <+> text "must not have a datatype context"))
+ else Nothing)
+ -- We don't like type families
+ : (if (isFamilyTyCon tycon)
+ then (Just (ppr tycon <+> text "must not be a family instance"))
+ else Nothing)
+ -- See comment below
+ : (map bad_con (tyConDataCons tycon)))
where
- bad_con dc = any bad_arg_type (dataConOrigArgTys dc) || not (isVanillaDataCon dc)
- -- If any of the constructor has an unboxed type as argument,
- -- then we can't build the embedding-projection pair, because
- -- it relies on instantiating *polymorphic* sum and product types
- -- at the argument types of the constructors
+ -- If any of the constructor has an unboxed type as argument,
+ -- then we can't build the embedding-projection pair, because
+ -- it relies on instantiating *polymorphic* sum and product types
+ -- at the argument types of the constructors
+ bad_con dc = if (any bad_arg_type (dataConOrigArgTys dc))
+ then (Just (ppr dc <+> text "must not have unlifted or polymorphic arguments"))
+ else (if (not (isVanillaDataCon dc))
+ then (Just (ppr dc <+> text "must be a vanilla data constructor"))
+ else Nothing)
+
-- Nor can we do the job if it's an existential data constructor,
-- 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...
+
+ mergeErrors :: [Maybe SDoc] -> Maybe SDoc
+ mergeErrors [] = Nothing
+ mergeErrors ((Just s):t) = case mergeErrors t of
+ Nothing -> Just s
+ Just s' -> Just (s <> text ", and" $$ s')
+ mergeErrors (Nothing :t) = mergeErrors t
\end{code}
%************************************************************************
type US = Int -- Local unique supply, just a plain Int
type Alt = (LPat RdrName, LHsExpr RdrName)
--- Bindings for the Representable0 instance
-mkBindsRep0 :: TyCon -> LHsBinds RdrName
-mkBindsRep0 tycon =
- unitBag (L loc (mkFunBind (L loc from0_RDR) from0_matches))
+-- Bindings for the Generic instance
+mkBindsRep :: TyCon -> LHsBinds RdrName
+mkBindsRep tycon =
+ unitBag (L loc (mkFunBind (L loc from_RDR) from_matches))
`unionBags`
- unitBag (L loc (mkFunBind (L loc to0_RDR) to0_matches))
+ unitBag (L loc (mkFunBind (L loc to_RDR) to_matches))
where
- from0_matches = [mkSimpleHsAlt pat rhs | (pat,rhs) <- from0_alts]
- to0_matches = [mkSimpleHsAlt pat rhs | (pat,rhs) <- to0_alts ]
+ from_matches = [mkSimpleHsAlt pat rhs | (pat,rhs) <- from_alts]
+ to_matches = [mkSimpleHsAlt pat rhs | (pat,rhs) <- to_alts ]
loc = srcLocSpan (getSrcLoc tycon)
datacons = tyConDataCons tycon
-- Recurse over the sum first
- from0_alts, to0_alts :: [Alt]
- (from0_alts, to0_alts) = mkSum (1 :: US) tycon datacons
+ from_alts, to_alts :: [Alt]
+ (from_alts, to_alts) = mkSum (1 :: US) tycon datacons
--------------------------------------------------------------------------------
+-- The type instance synonym and synonym
+-- type instance Rep (D a b) = Rep_D a b
+-- type Rep_D a b = ...representation type for D ...
+--------------------------------------------------------------------------------
+
+tc_mkRepTyCon :: TyCon -- The type to generate representation for
+ -> MetaTyCons -- Metadata datatypes to refer to
+ -> TcM TyCon -- Generated representation0 type
+tc_mkRepTyCon tycon metaDts =
+-- Consider the example input tycon `D`, where data D a b = D_ a
+ do { -- `rep0` = GHC.Generics.Rep (type family)
+ rep0 <- tcLookupTyCon repTyConName
+
+ -- `rep0Ty` = D1 ... (C1 ... (S1 ... (Rec0 a))) :: * -> *
+ ; rep0Ty <- tc_mkRepTy tycon metaDts
+
+ -- `rep_name` is a name we generate for the synonym
+ ; rep_name <- newImplicitBinder (tyConName tycon) mkGenR
+ ; let -- `tyvars` = [a,b]
+ tyvars = tyConTyVars tycon
+
+ -- rep0Ty has kind * -> *
+ rep_kind = liftedTypeKind `mkArrowKind` liftedTypeKind
+
+ -- `appT` = D a b
+ appT = [mkTyConApp tycon (mkTyVarTys tyvars)]
+
+ ; buildSynTyCon rep_name tyvars (SynonymTyCon rep0Ty) rep_kind
+ NoParentTyCon (Just (rep0, appT)) }
+
+--------------------------------------------------------------------------------
-- Type representation
--------------------------------------------------------------------------------
-tc_mkRep0Ty :: -- The type to generate representation for
+tc_mkRepTy :: -- The type to generate representation for
TyCon
-- Metadata datatypes to refer to
-> MetaTyCons
-- Generated representation0 type
-> TcM Type
-tc_mkRep0Ty tycon metaDts =
+tc_mkRepTy tycon metaDts =
do
- d1 <- tcLookupTyCon d1TyConName
- c1 <- tcLookupTyCon c1TyConName
- s1 <- tcLookupTyCon s1TyConName
- rec0 <- tcLookupTyCon rec0TyConName
- u1 <- tcLookupTyCon u1TyConName
- v1 <- tcLookupTyCon v1TyConName
- plus <- tcLookupTyCon sumTyConName
+ d1 <- tcLookupTyCon d1TyConName
+ c1 <- tcLookupTyCon c1TyConName
+ s1 <- tcLookupTyCon s1TyConName
+ nS1 <- tcLookupTyCon noSelTyConName
+ rec0 <- tcLookupTyCon rec0TyConName
+ par0 <- tcLookupTyCon par0TyConName
+ u1 <- tcLookupTyCon u1TyConName
+ v1 <- tcLookupTyCon v1TyConName
+ plus <- tcLookupTyCon sumTyConName
times <- tcLookupTyCon prodTyConName
let mkSum' a b = mkTyConApp plus [a,b]
mkProd a b = mkTyConApp times [a,b]
mkRec0 a = mkTyConApp rec0 [a]
+ mkPar0 a = mkTyConApp par0 [a]
mkD a = mkTyConApp d1 [metaDTyCon, sumP (tyConDataCons a)]
- mkC i d a = mkTyConApp c1 [d, prod i (dataConOrigArgTys a)]
- mkS d a = mkTyConApp s1 [d, a]
+ mkC i d a = mkTyConApp c1 [d, prod i (dataConOrigArgTys a)
+ (null (dataConFieldLabels a))]
+ -- This field has no label
+ mkS True _ a = mkTyConApp s1 [mkTyConTy nS1, a]
+ -- This field has a label
+ mkS False d a = mkTyConApp s1 [d, a]
sumP [] = mkTyConTy v1
sumP l = ASSERT (length metaCTyCons == length l)
foldBal mkSum' [ mkC i d a
| (d,(a,i)) <- zip metaCTyCons (zip l [0..])]
- prod :: Int -> [Type] -> Type
- prod i [] = ASSERT (length metaSTyCons > i)
- ASSERT (length (metaSTyCons !! i) == 0)
- mkTyConTy u1
- prod i l = ASSERT (length metaSTyCons > i)
- ASSERT (length l == length (metaSTyCons !! i))
- foldBal mkProd [ arg d a
- | (d,a) <- zip (metaSTyCons !! i) l ]
+ -- The Bool is True if this constructor has labelled fields
+ prod :: Int -> [Type] -> Bool -> Type
+ prod i [] _ = ASSERT (length metaSTyCons > i)
+ ASSERT (length (metaSTyCons !! i) == 0)
+ mkTyConTy u1
+ prod i l b = ASSERT (length metaSTyCons > i)
+ ASSERT (length l == length (metaSTyCons !! i))
+ foldBal mkProd [ arg d t b
+ | (d,t) <- zip (metaSTyCons !! i) l ]
- arg d t = mkS d (mkRec0 t)
+ arg :: Type -> Type -> Bool -> Type
+ arg d t b = mkS b d (recOrPar t (getTyVar_maybe t))
+ -- Argument is not a type variable, use Rec0
+ recOrPar t Nothing = mkRec0 t
+ -- Argument is a type variable, use Par0
+ recOrPar t (Just _) = mkPar0 t
metaDTyCon = mkTyConTy (metaD metaDts)
metaCTyCons = map mkTyConTy (metaC metaDts)
return (mkD tycon)
-tc_mkRep0TyCon :: TyCon -- The type to generate representation for
- -> MetaTyCons -- Metadata datatypes to refer to
- -> TcM TyCon -- Generated representation0 type
-tc_mkRep0TyCon tycon metaDts =
--- Consider the example input tycon `D`, where data D a b = D_ a
- do
- uniq1 <- newUnique
- uniq2 <- newUnique
- -- `rep0Ty` = D1 ... (C1 ... (S1 ... (Rec0 a))) :: * -> *
- rep0Ty <- tc_mkRep0Ty tycon metaDts
- -- `rep0` = GHC.Generics.Rep0 (type family)
- rep0 <- tcLookupTyCon rep0TyConName
-
- let modl = nameModule (tyConName tycon)
- loc = nameSrcSpan (tyConName tycon)
- -- `repName` is a name we generate for the synonym
- repName = mkExternalName uniq1 modl (mkGenR0 (nameOccName (tyConName tycon))) loc
- -- `coName` is a name for the coercion
- coName = mkExternalName uniq2 modl (mkGenR0 (nameOccName (tyConName tycon))) loc
- -- `tyvars` = [a,b]
- tyvars = tyConTyVars tycon
- -- `appT` = D a b
- appT = [mkTyConApp tycon (mkTyVarTys tyvars)]
- -- Result
- res = mkSynTyCon repName
- -- rep0Ty has kind `kind of D` -> *
- (tyConKind tycon `mkArrowKind` liftedTypeKind)
- tyvars (SynonymTyCon rep0Ty)
- (FamInstTyCon rep0 appT
- (mkCoercionTyCon coName (tyConArity tycon)
- -- co : forall a b. Rep0 (D a b) ~ `rep0Ty` a b
- (CoAxiom tyvars (mkTyConApp rep0 appT) rep0Ty)))
-
- return res
-
--------------------------------------------------------------------------------
-- Meta-information
--------------------------------------------------------------------------------
, metaS :: [[TyCon]] }
instance Outputable MetaTyCons where
- ppr (MetaTyCons d c s) = ppr d <+> ppr c <+> ppr s
+ ppr (MetaTyCons d c s) = ppr d $$ vcat (map ppr c) $$ vcat (map ppr (concat s))
metaTyCons2TyCons :: MetaTyCons -> [TyCon]
metaTyCons2TyCons (MetaTyCons d c s) = d : c ++ concat s
--------------------------------------------------------------------------------
-- Build a product expression
-mkProd_E :: US -- Base for unique names
- -> [RdrName] -- List of variables matched on the lhs
- -> LHsExpr RdrName -- Resulting product expression
+mkProd_E :: US -- Base for unique names
+ -> [RdrName] -- List of variables matched on the lhs
+ -> LHsExpr RdrName -- Resulting product expression
mkProd_E _ [] = mkM1_E (nlHsVar u1DataCon_RDR)
mkProd_E _ vars = mkM1_E (foldBal prod appVars)
-- These M1s are meta-information for the constructor
appVars = map wrapArg_E vars
prod a b = prodDataCon_RDR `nlHsApps` [a,b]
--- TODO: Produce a P0 when v is a parameter
wrapArg_E :: RdrName -> LHsExpr RdrName
wrapArg_E v = mkM1_E (k1DataCon_RDR `nlHsVarApps` [v])
-- This M1 is meta-information for the selector
appVars = map wrapArg_P vars
prod a b = prodDataCon_RDR `nlConPat` [a,b]
--- TODO: Produce a P0 when v is a parameter
wrapArg_P :: RdrName -> LPat RdrName
wrapArg_P v = mkM1_P (k1DataCon_RDR `nlConVarPat` [v])
-- This M1 is meta-information for the selector
projects / ghc-hetmet.git / blobdiff