\begin{code}
module Generics ( canDoGenerics,
- mkBindsRep0, tc_mkRep0TyCon, mkBindsMetaD,
+ mkBindsRep, tc_mkRepTyCon, mkBindsMetaD,
MetaTyCons(..), metaTyCons2TyCons
) where
%************************************************************************
\begin{code}
-canDoGenerics :: TyCon -> Bool
+canDoGenerics :: TyCon -> Maybe SDoc
-- Called on source-code data types, to see if we should generate
-- generic functions for them.
+-- Nothing == yes
+-- Just s == no, because of `s`
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
+ = 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)
+
+ 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
--------------------------------------------------------------------------------
-- 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
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)
(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)))
-
+-}
+ -- co : forall a b. Rep (D a b) ~ `rep0Ty` a b
+ (CoAxiom uniq2 coName tyvars (mkTyConApp rep0 appT) rep0Ty))
return res
--------------------------------------------------------------------------------
projects / ghc-hetmet.git / blobdiff