X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypes%2FTyCon.lhs;h=fcd32c6974bce5bed8fb4cfca1ed0574daa1e0c6;hb=ac10f8408520a30e8437496d320b8b86afda2e8f;hp=944d0ab1b061a8746de545150b374118c54e0884;hpb=dd313897eb9a14bcc7b81f97e4f2292c30039efd;p=ghc-hetmet.git diff --git a/ghc/compiler/types/TyCon.lhs b/ghc/compiler/types/TyCon.lhs index 944d0ab..fcd32c6 100644 --- a/ghc/compiler/types/TyCon.lhs +++ b/ghc/compiler/types/TyCon.lhs @@ -16,7 +16,10 @@ module TyCon( isAlgTyCon, isDataTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, isEnumerationTyCon, isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, tupleTyConBoxity, - isRecursiveTyCon, newTyConRep, newTyConRhs, newTyConRhs_maybe, isHiBootTyCon, + isRecursiveTyCon, newTyConRep, newTyConRhs, + isHiBootTyCon, + + tcExpandTyCon_maybe, coreExpandTyCon_maybe, makeTyConAbstract, isAbstractTyCon, @@ -36,11 +39,11 @@ module TyCon( tyConTyVars, tyConArgVrcs, algTyConRhs, tyConDataCons, tyConDataCons_maybe, tyConFamilySize, - tyConFields, tyConSelIds, + tyConSelIds, tyConStupidTheta, tyConArity, isClassTyCon, tyConClass_maybe, - getSynTyConDefn, + synTyConDefn, synTyConRhs, tyConExtName, -- External name for foreign types maybeTyConSingleCon, @@ -65,7 +68,6 @@ import BasicTypes ( Arity, RecFlag(..), Boxity(..), isBoxed ) import Name ( Name, nameUnique, NamedThing(getName) ) import PrelNames ( Unique, Uniquable(..) ) import Maybes ( orElse ) -import Util ( equalLength ) import Outputable import FastString \end{code} @@ -95,15 +97,10 @@ data TyCon tyConTyVars :: [TyVar], -- Scopes over (a) the [PredType] in AlgTyConRhs.DataTyCon -- (b) the cached types in AlgTyConRhs.NewTyCon - -- (c) the types in algTcFields -- But not over the data constructors argVrcs :: ArgVrcs, - algTcFields :: [(FieldLabel, Type, Id)], - -- Its fields (empty if none): - -- * field name - -- * its type (scoped over tby tyConTyVars) - -- * record selector (name = field name) + algTcSelIds :: [Id], -- Its record selectors (empty if none): algTcStupidTheta :: [PredType], -- The "stupid theta" for the data type -- (always empty for GADTs) @@ -155,7 +152,7 @@ data TyCon tyConArity :: Arity, tyConTyVars :: [TyVar], -- Bound tyvars - synTyConDefn :: Type, -- Right-hand side, mentioning these type vars. + synTcRhs :: Type, -- Right-hand side, mentioning these type vars. -- Acts as a template for the expansion when -- the tycon is applied to some types. argVrcs :: ArgVrcs @@ -172,39 +169,79 @@ data AlgTyConRhs -- Used when we export a data type abstractly into -- an hi file - | DataTyCon - [DataCon] -- The constructors; can be empty if the user declares + | DataTyCon { + data_cons :: [DataCon], + -- The constructors; can be empty if the user declares -- the type to have no constructors -- INVARIANT: Kept in order of increasing tag -- (see the tag assignment in DataCon.mkDataCon) - Bool -- Cached: True <=> an enumeration type + is_enum :: Bool -- Cached: True <=> an enumeration type + } -- Includes data types with no constructors. + + | NewTyCon { + data_con :: DataCon, -- The unique constructor; it has no existentials + + nt_rhs :: Type, -- Cached: the argument type of the constructor + -- = the representation type of the tycon - | NewTyCon -- Newtypes always have exactly one constructor - DataCon -- The unique constructor; it has no existentials - Type -- Cached: the argument type of the constructor - -- = the representation type of the tycon + nt_etad_rhs :: ([TyVar], Type) , + -- The same again, but this time eta-reduced + -- hence the [TyVar] which may be shorter than the declared + -- arity of the TyCon. See Note [Newtype eta] - Type -- Cached: the *ultimate* representation type - -- By 'ultimate' I mean that the rep type is not itself - -- a newtype or type synonym. + nt_rep :: Type -- Cached: the *ultimate* representation type + -- By 'ultimate' I mean that the top-level constructor + -- of the rep type is not itself a newtype or type synonym. -- The rep type isn't entirely simple: -- for a recursive newtype we pick () as the rep type -- newtype T = MkT T - -- - -- The rep type has free type variables the tyConTyVars + -- + -- This one does not need to be eta reduced; hence its + -- free type variables are conveniently tyConTyVars -- Thus: -- newtype T a = MkT [(a,Int)] -- The rep type is [(a,Int)] - -- NB: the rep type isn't necessarily the original RHS of the - -- newtype decl, because the rep type looks through other - -- newtypes. + -- NB: the rep type isn't necessarily the original RHS of the + -- newtype decl, because the rep type looks through other + } -- newtypes. visibleDataCons :: AlgTyConRhs -> [DataCon] -visibleDataCons AbstractTyCon = [] -visibleDataCons (DataTyCon cs _) = cs -visibleDataCons (NewTyCon c _ _) = [c] +visibleDataCons AbstractTyCon = [] +visibleDataCons (DataTyCon{ data_cons = cs }) = cs +visibleDataCons (NewTyCon{ data_con = c }) = [c] \end{code} +Note [Newtype eta] +~~~~~~~~~~~~~~~~~~ +Consider + newtype Parser m a = MkParser (Foogle m a) +Are these two types equal (to Core)? + Monad (Parser m) + Monad (Foogle m) +Well, yes. But to see that easily we eta-reduce the RHS type of +Parser, in this case to ([], Froogle), so that even unsaturated applications +of Parser will work right. This eta reduction is done when the type +constructor is built, and cached in NewTyCon. The cached field is +only used in coreExpandTyCon_maybe. + +Here's an example that I think showed up in practice +Source code: + newtype T a = MkT [a] + newtype Foo m = MkFoo (forall a. m a -> Int) + + w1 :: Foo [] + w1 = ... + + w2 :: Foo T + w2 = MkFoo (\(MkT x) -> case w1 of MkFoo f -> f x) + +After desugaring, and discading the data constructors for the newtypes, +we get: + w2 :: Foo T + w2 = w1 +And now Lint complains unless Foo T == Foo [], and that requires T==[] + + %************************************************************************ %* * \subsection{PrimRep} @@ -267,7 +304,7 @@ mkFunTyCon name kind -- This is the making of a TyCon. Just the same as the old mkAlgTyCon, -- but now you also have to pass in the generic information about the type -- constructor - you can get hold of it easily (see Generics module) -mkAlgTyCon name kind tyvars argvrcs stupid rhs flds is_rec gen_info +mkAlgTyCon name kind tyvars argvrcs stupid rhs sel_ids is_rec gen_info = AlgTyCon { tyConName = name, tyConUnique = nameUnique name, @@ -277,7 +314,7 @@ mkAlgTyCon name kind tyvars argvrcs stupid rhs flds is_rec gen_info argVrcs = argvrcs, algTcStupidTheta = stupid, algTcRhs = rhs, - algTcFields = flds, + algTcSelIds = sel_ids, algTcClass = Nothing, algTcRec = is_rec, hasGenerics = gen_info @@ -293,7 +330,7 @@ mkClassTyCon name kind tyvars argvrcs rhs clas is_rec argVrcs = argvrcs, algTcStupidTheta = [], algTcRhs = rhs, - algTcFields = [], + algTcSelIds = [], algTcClass = Just clas, algTcRec = is_rec, hasGenerics = False @@ -356,7 +393,7 @@ mkSynTyCon name kind tyvars rhs argvrcs tyConKind = kind, tyConArity = length tyvars, tyConTyVars = tyvars, - synTyConDefn = rhs, + synTcRhs = rhs, argVrcs = argvrcs } \end{code} @@ -397,18 +434,18 @@ isDataTyCon :: TyCon -> Bool -- True for all @data@ types -- False for newtypes -- unboxed tuples -isDataTyCon (AlgTyCon {algTcRhs = rhs}) +isDataTyCon tc@(AlgTyCon {algTcRhs = rhs}) = case rhs of - DataTyCon _ _ -> True - NewTyCon _ _ _ -> False - AbstractTyCon -> panic "isDataTyCon" + DataTyCon {} -> True + NewTyCon {} -> False + AbstractTyCon -> pprPanic "isDataTyCon" (ppr tc) isDataTyCon (TupleTyCon {tyConBoxed = boxity}) = isBoxed boxity isDataTyCon other = False isNewTyCon :: TyCon -> Bool -isNewTyCon (AlgTyCon {algTcRhs = NewTyCon _ _ _}) = True -isNewTyCon other = False +isNewTyCon (AlgTyCon {algTcRhs = NewTyCon {}}) = True +isNewTyCon other = False isProductTyCon :: TyCon -> Bool -- A "product" tycon @@ -419,9 +456,10 @@ isProductTyCon :: TyCon -> Bool -- may be unboxed or not, -- may be recursive or not isProductTyCon tc@(AlgTyCon {}) = case algTcRhs tc of - DataTyCon [data_con] _ -> isVanillaDataCon data_con - NewTyCon _ _ _ -> True - other -> False + DataTyCon{ data_cons = [data_con] } + -> isVanillaDataCon data_con + NewTyCon {} -> True + other -> False isProductTyCon (TupleTyCon {}) = True isProductTyCon other = False @@ -430,13 +468,18 @@ isSynTyCon (SynTyCon {}) = True isSynTyCon _ = False isEnumerationTyCon :: TyCon -> Bool -isEnumerationTyCon (AlgTyCon {algTcRhs = DataTyCon _ is_enum}) = is_enum -isEnumerationTyCon other = False +isEnumerationTyCon (AlgTyCon {algTcRhs = DataTyCon { is_enum = res }}) = res +isEnumerationTyCon other = False isTupleTyCon :: TyCon -> Bool -- The unit tycon didn't used to be classed as a tuple tycon -- but I thought that was silly so I've undone it -- If it can't be for some reason, it should be a AlgTyCon +-- +-- NB: when compiling Data.Tuple, the tycons won't reply True to +-- isTupleTyCon, becuase they are built as AlgTyCons. However they +-- get spat into the interface file as tuple tycons, so I don't think +-- it matters. isTupleTyCon (TupleTyCon {}) = True isTupleTyCon other = False @@ -465,6 +508,47 @@ isForeignTyCon (PrimTyCon {tyConExtName = Just _}) = True isForeignTyCon other = False \end{code} + +----------------------------------------------- +-- Expand type-constructor applications +----------------------------------------------- + +\begin{code} +tcExpandTyCon_maybe, coreExpandTyCon_maybe + :: TyCon + -> [Type] -- Args to tycon + -> Maybe ([(TyVar,Type)], -- Substitution + Type, -- Body type (not yet substituted) + [Type]) -- Leftover args + +-- For the *typechecker* view, we expand synonyms only +tcExpandTyCon_maybe (SynTyCon {tyConTyVars = tvs, synTcRhs = rhs }) tys + = expand tvs rhs tys +tcExpandTyCon_maybe other_tycon tys = Nothing + +--------------- +-- For the *Core* view, we expand synonyms *and* non-recursive newtypes +coreExpandTyCon_maybe (AlgTyCon {algTcRec = NonRecursive, -- Not recursive + algTcRhs = NewTyCon { nt_etad_rhs = etad_rhs }}) tys + = case etad_rhs of -- Don't do this in the pattern match, lest we accidentally + -- match the etad_rhs of a *recursive* newtype + (tvs,rhs) -> expand tvs rhs tys + +coreExpandTyCon_maybe tycon tys = tcExpandTyCon_maybe tycon tys + +---------------- +expand :: [TyVar] -> Type -- Template + -> [Type] -- Args + -> Maybe ([(TyVar,Type)], Type, [Type]) -- Expansion +expand tvs rhs tys + = case n_tvs `compare` length tys of + LT -> Just (tvs `zip` tys, rhs, drop n_tvs tys) + EQ -> Just (tvs `zip` tys, rhs, []) + GT -> Nothing + where + n_tvs = length tvs +\end{code} + \begin{code} tyConHasGenerics :: TyCon -> Bool tyConHasGenerics (AlgTyCon {hasGenerics = hg}) = hg @@ -477,55 +561,36 @@ tyConDataCons :: TyCon -> [DataCon] tyConDataCons tycon = tyConDataCons_maybe tycon `orElse` [] tyConDataCons_maybe :: TyCon -> Maybe [DataCon] -tyConDataCons_maybe (AlgTyCon {algTcRhs = DataTyCon cons _}) = Just cons -tyConDataCons_maybe (AlgTyCon {algTcRhs = NewTyCon con _ _}) = Just [con] -tyConDataCons_maybe (TupleTyCon {dataCon = con}) = Just [con] -tyConDataCons_maybe other = Nothing +tyConDataCons_maybe (AlgTyCon {algTcRhs = DataTyCon { data_cons = cons }}) = Just cons +tyConDataCons_maybe (AlgTyCon {algTcRhs = NewTyCon { data_con = con }}) = Just [con] +tyConDataCons_maybe (TupleTyCon {dataCon = con}) = Just [con] +tyConDataCons_maybe other = Nothing tyConFamilySize :: TyCon -> Int -tyConFamilySize (AlgTyCon {algTcRhs = DataTyCon cons _}) = length cons -tyConFamilySize (AlgTyCon {algTcRhs = NewTyCon _ _ _}) = 1 -tyConFamilySize (TupleTyCon {}) = 1 +tyConFamilySize (AlgTyCon {algTcRhs = DataTyCon { data_cons = cons }}) = length cons +tyConFamilySize (AlgTyCon {algTcRhs = NewTyCon {}}) = 1 +tyConFamilySize (TupleTyCon {}) = 1 #ifdef DEBUG tyConFamilySize other = pprPanic "tyConFamilySize:" (ppr other) #endif -tyConFields :: TyCon -> [(FieldLabel,Type,Id)] -tyConFields (AlgTyCon {algTcFields = fs}) = fs -tyConFields other_tycon = [] - tyConSelIds :: TyCon -> [Id] -tyConSelIds tc = [id | (_,_,id) <- tyConFields tc] +tyConSelIds (AlgTyCon {algTcSelIds = fs}) = fs +tyConSelIds other_tycon = [] algTyConRhs :: TyCon -> AlgTyConRhs algTyConRhs (AlgTyCon {algTcRhs = rhs}) = rhs -algTyConRhs (TupleTyCon {dataCon = con}) = DataTyCon [con] False +algTyConRhs (TupleTyCon {dataCon = con}) = DataTyCon { data_cons = [con], is_enum = False } algTyConRhs other = pprPanic "algTyConRhs" (ppr other) \end{code} \begin{code} newTyConRhs :: TyCon -> ([TyVar], Type) -newTyConRhs (AlgTyCon {tyConTyVars = tvs, algTcRhs = NewTyCon _ rhs _}) = (tvs, rhs) +newTyConRhs (AlgTyCon {tyConTyVars = tvs, algTcRhs = NewTyCon { nt_rhs = rhs }}) = (tvs, rhs) newTyConRhs tycon = pprPanic "newTyConRhs" (ppr tycon) -newTyConRhs_maybe :: TyCon - -> [Type] -- Args to tycon - -> Maybe ([(TyVar,Type)], -- Substitution - Type) -- Body type (not yet substituted) --- Non-recursive newtypes are transparent to Core; --- Given an application to some types, return Just (tenv, ty) --- if it's a saturated, non-recursive newtype. -newTyConRhs_maybe (AlgTyCon {tyConTyVars = tvs, - algTcRec = NonRecursive, -- Not recursive - algTcRhs = NewTyCon _ rhs _}) tys - | tvs `equalLength` tys -- Saturated - = Just (tvs `zip` tys, rhs) - -newTyConRhs_maybe other_tycon tys = Nothing - - newTyConRep :: TyCon -> ([TyVar], Type) -newTyConRep (AlgTyCon {tyConTyVars = tvs, algTcRhs = NewTyCon _ _ rep}) = (tvs, rep) +newTyConRep (AlgTyCon {tyConTyVars = tvs, algTcRhs = NewTyCon { nt_rep = rep }}) = (tvs, rep) newTyConRep tycon = pprPanic "newTyConRep" (ppr tycon) tyConPrimRep :: TyCon -> PrimRep @@ -554,19 +619,22 @@ tyConArgVrcs (SynTyCon {argVrcs = oi}) = oi \end{code} \begin{code} -getSynTyConDefn :: TyCon -> ([TyVar], Type) -getSynTyConDefn (SynTyCon {tyConTyVars = tyvars, synTyConDefn = ty}) = (tyvars,ty) -getSynTyConDefn tycon = pprPanic "getSynTyConDefn" (ppr tycon) +synTyConDefn :: TyCon -> ([TyVar], Type) +synTyConDefn (SynTyCon {tyConTyVars = tyvars, synTcRhs = ty}) = (tyvars,ty) +synTyConDefn tycon = pprPanic "getSynTyConDefn" (ppr tycon) + +synTyConRhs :: TyCon -> Type +synTyConRhs tc = synTcRhs tc \end{code} \begin{code} maybeTyConSingleCon :: TyCon -> Maybe DataCon -maybeTyConSingleCon (AlgTyCon {algTcRhs = DataTyCon [c] _}) = Just c -maybeTyConSingleCon (AlgTyCon {algTcRhs = NewTyCon c _ _}) = Just c -maybeTyConSingleCon (AlgTyCon {}) = Nothing -maybeTyConSingleCon (TupleTyCon {dataCon = con}) = Just con -maybeTyConSingleCon (PrimTyCon {}) = Nothing -maybeTyConSingleCon (FunTyCon {}) = Nothing -- case at funty +maybeTyConSingleCon (AlgTyCon {algTcRhs = DataTyCon {data_cons = [c] }}) = Just c +maybeTyConSingleCon (AlgTyCon {algTcRhs = NewTyCon { data_con = c }}) = Just c +maybeTyConSingleCon (AlgTyCon {}) = Nothing +maybeTyConSingleCon (TupleTyCon {dataCon = con}) = Just con +maybeTyConSingleCon (PrimTyCon {}) = Nothing +maybeTyConSingleCon (FunTyCon {}) = Nothing -- case at funty maybeTyConSingleCon tc = pprPanic "maybeTyConSingleCon: unexpected tycon " $ ppr tc \end{code}