X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypes%2FTyCon.lhs;h=3c1f92302cedef3f7619f187f7c8b845ea660dbe;hb=07806d2b66986825ff7c5cd51240f920d91ee2f9;hp=51b81d6e995072d957b78474f71eb8d1a0cebf92;hpb=423d477bfecd490de1449c59325c8776f91d7aac;p=ghc-hetmet.git diff --git a/ghc/compiler/types/TyCon.lhs b/ghc/compiler/types/TyCon.lhs index 51b81d6..3c1f923 100644 --- a/ghc/compiler/types/TyCon.lhs +++ b/ghc/compiler/types/TyCon.lhs @@ -5,18 +5,20 @@ \begin{code} module TyCon( - TyCon, ArgVrcs, + TyCon, ArgVrcs, FieldLabel, PrimRep(..), tyConPrimRep, AlgTyConRhs(..), visibleDataCons, - isFunTyCon, isUnLiftedTyCon, isProductTyCon, isAbstractTyCon, + isFunTyCon, isUnLiftedTyCon, isProductTyCon, isAlgTyCon, isDataTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, isEnumerationTyCon, isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, tupleTyConBoxity, - isRecursiveTyCon, newTyConRep, newTyConRhs, isHiBootTyCon, + isRecursiveTyCon, newTyConRep, newTyConRhs, newTyConRhs_maybe, isHiBootTyCon, + + makeTyConAbstract, isAbstractTyCon, mkForeignTyCon, isForeignTyCon, @@ -35,7 +37,7 @@ module TyCon( tyConArgVrcs, algTyConRhs, tyConDataCons, tyConDataCons_maybe, tyConFamilySize, tyConSelIds, - tyConTheta, + tyConStupidTheta, tyConArity, isClassTyCon, tyConClass_maybe, getSynTyConDefn, @@ -53,7 +55,7 @@ import {-# SOURCE #-} TypeRep ( Type, PredType ) -- Should just be Type(Type), but this fails due to bug present up to -- and including 4.02 involving slurping of hi-boot files. Bug is now fixed. -import {-# SOURCE #-} DataCon ( DataCon, isExistentialDataCon ) +import {-# SOURCE #-} DataCon ( DataCon, isVanillaDataCon ) import Var ( TyVar, Id ) @@ -63,6 +65,7 @@ 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} @@ -90,21 +93,25 @@ data TyCon tyConKind :: Kind, tyConArity :: Arity, - tyConTyVars :: [TyVar], - argVrcs :: ArgVrcs, - algTyConTheta :: [PredType], + tyConTyVars :: [TyVar], -- Scopes over (a) the [PredType] in AlgTyConRhs.DataTyCon + -- (b) the cached types in AlgTyConRhs.NewTyCon + -- But not over the data constructors + argVrcs :: ArgVrcs, + + algTcSelIds :: [Id], -- Its record selectors (empty if none): - selIds :: [Id], -- Its record selectors (if any) + algTcStupidTheta :: [PredType], -- The "stupid theta" for the data type + -- (always empty for GADTs) - algRhs :: AlgTyConRhs, -- Data constructors in here + algTcRhs :: AlgTyConRhs, -- Data constructors in here - algTyConRec :: RecFlag, -- Tells whether the data type is part of + algTcRec :: RecFlag, -- Tells whether the data type is part of -- a mutually-recursive group or not hasGenerics :: Bool, -- True <=> generic to/from functions are available - -- (in the exports of the data type's source module) + -- (in the exports of the data type's source module) - algTyConClass :: Maybe Class + algTcClass :: Maybe Class -- Just cl if this tycon came from a class declaration } @@ -149,6 +156,8 @@ data TyCon argVrcs :: ArgVrcs } +type FieldLabel = Name + type ArgVrcs = [(Bool,Bool)] -- Tyvar variance info: [(occPos,occNeg)] -- [] means "no information, assume the worst" @@ -161,7 +170,10 @@ data AlgTyConRhs | DataTyCon [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 + -- Includes data types with no constructors. | NewTyCon -- Newtypes always have exactly one constructor DataCon -- The unique constructor; it has no existentials @@ -251,36 +263,36 @@ 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 theta argvrcs rhs sels is_rec gen_info +mkAlgTyCon name kind tyvars argvrcs stupid rhs sel_ids is_rec gen_info = AlgTyCon { - tyConName = name, - tyConUnique = nameUnique name, - tyConKind = kind, - tyConArity = length tyvars, - tyConTyVars = tyvars, - argVrcs = argvrcs, - algTyConTheta = theta, - algRhs = rhs, - selIds = sels, - algTyConClass = Nothing, - algTyConRec = is_rec, - hasGenerics = gen_info + tyConName = name, + tyConUnique = nameUnique name, + tyConKind = kind, + tyConArity = length tyvars, + tyConTyVars = tyvars, + argVrcs = argvrcs, + algTcStupidTheta = stupid, + algTcRhs = rhs, + algTcSelIds = sel_ids, + algTcClass = Nothing, + algTcRec = is_rec, + hasGenerics = gen_info } mkClassTyCon name kind tyvars argvrcs rhs clas is_rec = AlgTyCon { - tyConName = name, - tyConUnique = nameUnique name, - tyConKind = kind, - tyConArity = length tyvars, - tyConTyVars = tyvars, - argVrcs = argvrcs, - algTyConTheta = [], - algRhs = rhs, - selIds = [], - algTyConClass = Just clas, - algTyConRec = is_rec, - hasGenerics = False + tyConName = name, + tyConUnique = nameUnique name, + tyConKind = kind, + tyConArity = length tyvars, + tyConTyVars = tyvars, + argVrcs = argvrcs, + algTcStupidTheta = [], + algTcRhs = rhs, + algTcSelIds = [], + algTcClass = Just clas, + algTcRec = is_rec, + hasGenerics = False } @@ -351,9 +363,13 @@ isFunTyCon (FunTyCon {}) = True isFunTyCon _ = False isAbstractTyCon :: TyCon -> Bool -isAbstractTyCon (AlgTyCon { algRhs = AbstractTyCon }) = True +isAbstractTyCon (AlgTyCon { algTcRhs = AbstractTyCon }) = True isAbstractTyCon _ = False +makeTyConAbstract :: TyCon -> TyCon +makeTyConAbstract tc@(AlgTyCon {}) = tc { algTcRhs = AbstractTyCon } +makeTyConAbstract tc = pprPanic "makeTyConAbstract" (ppr tc) + isPrimTyCon :: TyCon -> Bool isPrimTyCon (PrimTyCon {}) = True isPrimTyCon _ = False @@ -369,10 +385,6 @@ isAlgTyCon (AlgTyCon {}) = True isAlgTyCon (TupleTyCon {}) = True isAlgTyCon other = False -algTyConRhs :: TyCon -> AlgTyConRhs -algTyConRhs (AlgTyCon {algRhs = rhs}) = rhs -algTyConRhs (TupleTyCon {dataCon = dc}) = DataTyCon [dc] False - isDataTyCon :: TyCon -> Bool -- isDataTyCon returns True for data types that are represented by -- heap-allocated constructors. @@ -381,18 +393,18 @@ isDataTyCon :: TyCon -> Bool -- True for all @data@ types -- False for newtypes -- unboxed tuples -isDataTyCon (AlgTyCon {algRhs = rhs}) +isDataTyCon tc@(AlgTyCon {algTcRhs = rhs}) = case rhs of DataTyCon _ _ -> True NewTyCon _ _ _ -> False - AbstractTyCon -> panic "isDataTyCon" + AbstractTyCon -> pprPanic "isDataTyCon" (ppr tc) isDataTyCon (TupleTyCon {tyConBoxed = boxity}) = isBoxed boxity isDataTyCon other = False isNewTyCon :: TyCon -> Bool -isNewTyCon (AlgTyCon {algRhs = NewTyCon _ _ _}) = True -isNewTyCon other = False +isNewTyCon (AlgTyCon {algTcRhs = NewTyCon _ _ _}) = True +isNewTyCon other = False isProductTyCon :: TyCon -> Bool -- A "product" tycon @@ -402,8 +414,8 @@ isProductTyCon :: TyCon -> Bool -- may be DataType or NewType, -- may be unboxed or not, -- may be recursive or not -isProductTyCon tc@(AlgTyCon {}) = case algRhs tc of - DataTyCon [data_con] _ -> not (isExistentialDataCon data_con) +isProductTyCon tc@(AlgTyCon {}) = case algTcRhs tc of + DataTyCon [data_con] _ -> isVanillaDataCon data_con NewTyCon _ _ _ -> True other -> False isProductTyCon (TupleTyCon {}) = True @@ -414,13 +426,18 @@ isSynTyCon (SynTyCon {}) = True isSynTyCon _ = False isEnumerationTyCon :: TyCon -> Bool -isEnumerationTyCon (AlgTyCon {algRhs = DataTyCon _ is_enum}) = is_enum -isEnumerationTyCon other = False +isEnumerationTyCon (AlgTyCon {algTcRhs = DataTyCon _ is_enum}) = is_enum +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 @@ -435,13 +452,13 @@ isBoxedTupleTyCon other = False tupleTyConBoxity tc = tyConBoxed tc isRecursiveTyCon :: TyCon -> Bool -isRecursiveTyCon (AlgTyCon {algTyConRec = Recursive}) = True +isRecursiveTyCon (AlgTyCon {algTcRec = Recursive}) = True isRecursiveTyCon other = False isHiBootTyCon :: TyCon -> Bool -- Used for knot-tying in hi-boot files -isHiBootTyCon (AlgTyCon {algRhs = AbstractTyCon}) = True -isHiBootTyCon other = False +isHiBootTyCon (AlgTyCon {algTcRhs = AbstractTyCon}) = True +isHiBootTyCon other = False isForeignTyCon :: TyCon -> Bool -- isForeignTyCon identifies foreign-imported type constructors @@ -461,43 +478,64 @@ tyConDataCons :: TyCon -> [DataCon] tyConDataCons tycon = tyConDataCons_maybe tycon `orElse` [] tyConDataCons_maybe :: TyCon -> Maybe [DataCon] -tyConDataCons_maybe (AlgTyCon {algRhs = DataTyCon cons _}) = Just cons -tyConDataCons_maybe (AlgTyCon {algRhs = NewTyCon con _ _}) = Just [con] -tyConDataCons_maybe (TupleTyCon {dataCon = con}) = Just [con] -tyConDataCons_maybe other = Nothing +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 tyConFamilySize :: TyCon -> Int -tyConFamilySize (AlgTyCon {algRhs = DataTyCon cons _}) = length cons -tyConFamilySize (AlgTyCon {algRhs = NewTyCon _ _ _}) = 1 -tyConFamilySize (TupleTyCon {}) = 1 +tyConFamilySize (AlgTyCon {algTcRhs = DataTyCon cons _}) = length cons +tyConFamilySize (AlgTyCon {algTcRhs = NewTyCon _ _ _}) = 1 +tyConFamilySize (TupleTyCon {}) = 1 #ifdef DEBUG tyConFamilySize other = pprPanic "tyConFamilySize:" (ppr other) #endif tyConSelIds :: TyCon -> [Id] -tyConSelIds (AlgTyCon {selIds = sels}) = sels -tyConSelIds other_tycon = [] +tyConSelIds (AlgTyCon {algTcSelIds = fs}) = fs +tyConSelIds other_tycon = [] + +algTyConRhs :: TyCon -> AlgTyConRhs +algTyConRhs (AlgTyCon {algTcRhs = rhs}) = rhs +algTyConRhs (TupleTyCon {dataCon = con}) = DataTyCon [con] False +algTyConRhs other = pprPanic "algTyConRhs" (ppr other) \end{code} \begin{code} -newTyConRep :: TyCon -> ([TyVar], Type) -newTyConRep (AlgTyCon {tyConTyVars = tvs, algRhs = NewTyCon _ _ rep}) = (tvs, rep) - newTyConRhs :: TyCon -> ([TyVar], Type) -newTyConRhs (AlgTyCon {tyConTyVars = tvs, algRhs = NewTyCon _ rhs _}) = (tvs, rhs) -\end{code} +newTyConRhs (AlgTyCon {tyConTyVars = tvs, algTcRhs = NewTyCon _ 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 tycon = pprPanic "newTyConRep" (ppr tycon) -\begin{code} tyConPrimRep :: TyCon -> PrimRep tyConPrimRep (PrimTyCon {primTyConRep = rep}) = rep tyConPrimRep tc = ASSERT(not (isUnboxedTupleTyCon tc)) PtrRep \end{code} \begin{code} -tyConTheta :: TyCon -> [PredType] -tyConTheta (AlgTyCon {algTyConTheta = theta}) = theta -tyConTheta (TupleTyCon {}) = [] --- shouldn't ask about anything else +tyConStupidTheta :: TyCon -> [PredType] +tyConStupidTheta (AlgTyCon {algTcStupidTheta = stupid}) = stupid +tyConStupidTheta (TupleTyCon {}) = [] +tyConStupidTheta tycon = pprPanic "tyConStupidTheta" (ppr tycon) \end{code} @tyConArgVrcs_maybe@ gives a list of (occPos,occNeg) flags, one for @@ -516,26 +554,27 @@ tyConArgVrcs (SynTyCon {argVrcs = oi}) = oi \begin{code} getSynTyConDefn :: TyCon -> ([TyVar], Type) getSynTyConDefn (SynTyCon {tyConTyVars = tyvars, synTyConDefn = ty}) = (tyvars,ty) +getSynTyConDefn tycon = pprPanic "getSynTyConDefn" (ppr tycon) \end{code} \begin{code} maybeTyConSingleCon :: TyCon -> Maybe DataCon -maybeTyConSingleCon (AlgTyCon {algRhs = DataTyCon [c] _}) = Just c -maybeTyConSingleCon (AlgTyCon {algRhs = 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 [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 tc = pprPanic "maybeTyConSingleCon: unexpected tycon " $ ppr tc \end{code} \begin{code} isClassTyCon :: TyCon -> Bool -isClassTyCon (AlgTyCon {algTyConClass = Just _}) = True +isClassTyCon (AlgTyCon {algTcClass = Just _}) = True isClassTyCon other_tycon = False tyConClass_maybe :: TyCon -> Maybe Class -tyConClass_maybe (AlgTyCon {algTyConClass = maybe_clas}) = maybe_clas +tyConClass_maybe (AlgTyCon {algTcClass = maybe_clas}) = maybe_clas tyConClass_maybe ther_tycon = Nothing \end{code}