X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypes%2FGenerics.lhs;h=323da41d66a4b54cb24a6e6937e5b515b8b34898;hp=b17670df1be7fbb6a02fce82833037b79d946503;hb=927df6486bc0dcb598b82702ca40c8fad0d9b25f;hpb=91b9cdf8c6104ed3ebdbcc17aaee68b352f13882 diff --git a/compiler/types/Generics.lhs b/compiler/types/Generics.lhs index b17670d..323da41 100644 --- a/compiler/types/Generics.lhs +++ b/compiler/types/Generics.lhs @@ -5,7 +5,7 @@ \begin{code} module Generics ( canDoGenerics, - mkBindsRep0, tc_mkRep0TyCon, mkBindsMetaD, + mkBindsRep, tc_mkRepTyCon, mkBindsMetaD, MetaTyCons(..), metaTyCons2TyCons ) where @@ -22,10 +22,12 @@ import RdrName 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 @@ -42,31 +44,47 @@ import FastString %************************************************************************ \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} %************************************************************************ @@ -79,42 +97,74 @@ canDoGenerics stupid_theta data_cs 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 - 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] @@ -122,23 +172,29 @@ tc_mkRep0Ty tycon metaDts = 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 @@ -150,41 +206,6 @@ tc_mkRep0Ty tycon 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 -------------------------------------------------------------------------------- @@ -197,7 +218,7 @@ data MetaTyCons = MetaTyCons { -- One meta datatype per dataype , 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