\begin{code}
module Generics ( canDoGenerics,
- mkBindsRep0, tc_mkRep0TyCon, mkBindsMetaD,
+ mkBindsRep, tc_mkRepTyCon, mkBindsMetaD,
MetaTyCons(..), metaTyCons2TyCons
) where
= 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)
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
--------------------------------------------------------------------------------
-- 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
- par0 <- tcLookupTyCon par0TyConName
- 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]
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 (recOrPar t (getTyVar_maybe 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
return (mkD tycon)
-tc_mkRep0TyCon :: TyCon -- The type to generate representation for
+tc_mkRepTyCon :: TyCon -- The type to generate representation for
-> MetaTyCons -- Metadata datatypes to refer to
-> TcM TyCon -- Generated representation0 type
-tc_mkRep0TyCon tycon metaDts =
+tc_mkRepTyCon 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
+ rep0Ty <- tc_mkRepTy tycon metaDts
+ -- `rep0` = GHC.Generics.Rep (type family)
+ rep0 <- tcLookupTyCon repTyConName
let modl = nameModule (tyConName tycon)
loc = nameSrcSpan (tyConName tycon)
tyvars (SynonymTyCon rep0Ty)
(FamInstTyCon rep0 appT
(mkCoercionTyCon coName (tyConArity tycon)
- -- co : forall a b. Rep0 (D a b) ~ `rep0Ty` a b
+ -- co : forall a b. Rep (D a b) ~ `rep0Ty` a b
(CoAxiom tyvars (mkTyConApp rep0 appT) rep0Ty)))
return res
projects / ghc-hetmet.git / blobdiff