X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Fcompiler%2Ftypes%2FTyCon.lhs;h=7fdf2e3a296e56de2085861212d84094968b5a6a;hb=7f05f1095e9a2c7b2b378859da00fde7ca907080;hp=48445e4e9c1734c0ac4baaf48cea33e78fe952b5;hpb=495ef8bd9ef30bffe50ea399b91e3ba09646b59a;p=ghc-hetmet.git diff --git a/ghc/compiler/types/TyCon.lhs b/ghc/compiler/types/TyCon.lhs index 48445e4..7fdf2e3 100644 --- a/ghc/compiler/types/TyCon.lhs +++ b/ghc/compiler/types/TyCon.lhs @@ -5,59 +5,67 @@ \begin{code} module TyCon( - TyCon, KindCon, SuperKindCon, ArgVrcs, AlgTyConFlavour(..), + TyCon, ArgVrcs, FieldLabel, - isFunTyCon, isUnLiftedTyCon, isBoxedTyCon, isProductTyCon, + PrimRep(..), + tyConPrimRep, + + AlgTyConRhs(..), visibleDataCons, + + isFunTyCon, isUnLiftedTyCon, isProductTyCon, isAbstractTyCon, isAlgTyCon, isDataTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, isEnumerationTyCon, isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, tupleTyConBoxity, - isRecursiveTyCon, newTyConRep, + isRecursiveTyCon, newTyConRep, newTyConRhs, newTyConRhs_maybe, isHiBootTyCon, + + mkForeignTyCon, isForeignTyCon, mkAlgTyCon, mkClassTyCon, mkFunTyCon, mkPrimTyCon, + mkLiftedPrimTyCon, mkTupleTyCon, mkSynTyCon, - mkKindCon, - mkSuperKindCon, - - setTyConName, + tyConName, tyConKind, tyConUnique, tyConTyVars, - tyConArgVrcs_maybe, - tyConDataCons, tyConDataConsIfAvailable, - tyConFamilySize, - tyConDerivings, - tyConTheta, - tyConPrimRep, + tyConArgVrcs, + algTyConRhs, tyConDataCons, tyConDataCons_maybe, tyConFamilySize, + tyConFields, tyConSelIds, + tyConStupidTheta, tyConArity, - tyConClass_maybe, + isClassTyCon, tyConClass_maybe, getSynTyConDefn, + tyConExtName, -- External name for foreign types maybeTyConSingleCon, - matchesTyCon + -- Generics + tyConHasGenerics ) where #include "HsVersions.h" -import {-# SOURCE #-} TypeRep ( Type, Kind, SuperKind ) +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 Class ( Class, ClassContext ) -import Var ( TyVar ) -import BasicTypes ( Arity, NewOrData(..), RecFlag(..), Boxity(..), isBoxed ) -import Maybes + +import Var ( TyVar, Id ) +import Class ( Class ) +import Kind ( Kind ) +import BasicTypes ( Arity, RecFlag(..), Boxity(..), isBoxed ) import Name ( Name, nameUnique, NamedThing(getName) ) -import Unique ( Unique, Uniquable(..), anyBoxConKey ) -import PrimRep ( PrimRep(..), isFollowableRep ) +import PrelNames ( Unique, Uniquable(..) ) +import Maybes ( orElse ) +import Util ( equalLength ) import Outputable +import FastString \end{code} %************************************************************************ @@ -67,9 +75,6 @@ import Outputable %************************************************************************ \begin{code} -type KindCon = TyCon -type SuperKindCon = TyCon - data TyCon = FunTyCon { tyConUnique :: Unique, @@ -79,63 +84,63 @@ data TyCon } - | AlgTyCon { -- Tuples, data type, and newtype decls. + | AlgTyCon { -- Data type, and newtype decls. -- All lifted, all boxed tyConUnique :: Unique, tyConName :: Name, tyConKind :: Kind, tyConArity :: Arity, - tyConTyVars :: [TyVar], - tyConArgVrcs :: ArgVrcs, - algTyConTheta :: ClassContext, - - dataCons :: [DataCon], - -- Its data constructors, with fully polymorphic types - -- This list can be empty, when we import a data type abstractly, - -- either (a) the interface is hand-written and doesn't give - -- the constructors, or - -- (b) in a quest for fast compilation we don't import - -- the constructors - - noOfDataCons :: Int, -- Number of data constructors - -- Usually this is the same as the length of the - -- dataCons field, but the latter may be empty if - -- we imported the type abstractly. But even if we import - -- abstractly we still need to know the number of constructors - -- so we can get the return convention right. Tiresome! - - algTyConDerivings :: [Class], -- Classes which have derived instances - - algTyConFlavour :: AlgTyConFlavour, - algTyConRec :: RecFlag, -- Tells whether the data type is part of - -- a mutually-recursive group or not - - algTyConClass_maybe :: Maybe Class -- Nothing for ordinary types; - -- Just c for the type constructor - -- for dictionaries of class c. + 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) + + algTcRhs :: AlgTyConRhs, -- Data constructors in here + + 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) + + algTcClass :: Maybe Class + -- Just cl if this tycon came from a class declaration } - | PrimTyCon { -- Primitive types; cannot be defined in Haskell - -- NB: All of these guys are *unlifted*, but not all are *unboxed* - tyConUnique :: Unique, - tyConName :: Name, - tyConKind :: Kind, - tyConArity :: Arity, - tyConArgVrcs :: ArgVrcs, - primTyConRep :: PrimRep + | PrimTyCon { -- Primitive types; cannot be defined in Haskell + -- Now includes foreign-imported types + tyConUnique :: Unique, + tyConName :: Name, + tyConKind :: Kind, + tyConArity :: Arity, + argVrcs :: ArgVrcs, + + primTyConRep :: PrimRep, + -- Many primitive tycons are unboxed, but some are + -- boxed (represented by pointers). The CgRep tells. + + isUnLifted :: Bool, -- Most primitive tycons are unlifted, + -- but foreign-imported ones may not be + tyConExtName :: Maybe FastString -- Just xx for foreign-imported types } | TupleTyCon { - tyConUnique :: Unique, tyConName :: Name, tyConKind :: Kind, tyConArity :: Arity, tyConBoxed :: Boxity, tyConTyVars :: [TyVar], - dataCon :: DataCon + dataCon :: DataCon, + hasGenerics :: Bool } | SynTyCon { @@ -148,40 +153,95 @@ data TyCon synTyConDefn :: Type, -- Right-hand side, mentioning these type vars. -- Acts as a template for the expansion when -- the tycon is applied to some types. - tyConArgVrcs :: ArgVrcs - } - - | KindCon { -- Type constructor at the kind level - tyConUnique :: Unique, - tyConName :: Name, - tyConKind :: SuperKind, - tyConArity :: Arity + argVrcs :: ArgVrcs } - | SuperKindCon { -- The type of kind variables or boxity variables, - tyConUnique :: Unique, - tyConName :: Name - } +type FieldLabel = Name type ArgVrcs = [(Bool,Bool)] -- Tyvar variance info: [(occPos,occNeg)] - -- *NB*: this is tyvar variance info, *not* - -- termvar usage info. - -data AlgTyConFlavour - = DataTyCon -- Data type - | EnumTyCon -- Special sort of enumeration type - | NewTyCon Type -- Newtype, with its *ultimate* representation type + -- [] means "no information, assume the worst" + +data AlgTyConRhs + = AbstractTyCon -- We know nothing about this data type, except + -- that it's represented by a pointer + -- Used when we export a data type abstractly into + -- an hi file + + | DataTyCon + (Maybe [PredType]) -- Just theta => this tycon was declared in H98 syntax + -- with the specified "stupid theta" + -- e.g. data Ord a => T a = ... + -- Nothing => this tycon was declared by giving the + -- type signatures for each constructor + -- (new GADT stuff) + -- e.g. data T a where { ... } + [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 + + | 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 + + Type -- Cached: the *ultimate* representation type -- By 'ultimate' I mean that the rep type is not itself -- a newtype or type synonym. - - -- The rep type has explicit for-alls for the tyvars of - -- the TyCon. Thus: - -- newtype T a = MkT [(a,Int)] - -- The rep type is forall a. [(a,Int)] - -- -- 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 + -- 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. + +visibleDataCons :: AlgTyConRhs -> [DataCon] +visibleDataCons AbstractTyCon = [] +visibleDataCons (DataTyCon _ cs _) = cs +visibleDataCons (NewTyCon c _ _) = [c] +\end{code} + +%************************************************************************ +%* * +\subsection{PrimRep} +%* * +%************************************************************************ + +A PrimRep is an abstraction of a type. It contains information that +the code generator needs in order to pass arguments, return results, +and store values of this type. + +A PrimRep is somewhat similar to a CgRep (see codeGen/SMRep) and a +MachRep (see cmm/MachOp), although each of these types has a distinct +and clearly defined purpose: + + - A PrimRep is a CgRep + information about signedness + information + about primitive pointers (AddrRep). Signedness and primitive + pointers are required when passing a primitive type to a foreign + function, but aren't needed for call/return conventions of Haskell + functions. + + - A MachRep is a basic machine type (non-void, doesn't contain + information on pointerhood or signedness, but contains some + reps that don't have corresponding Haskell types). + +\begin{code} +data PrimRep + = VoidRep + | PtrRep + | IntRep -- signed, word-sized + | WordRep -- unsinged, word-sized + | Int64Rep -- signed, 64 bit (32-bit words only) + | Word64Rep -- unsigned, 64 bit (32-bit words only) + | AddrRep -- a pointer, but not to a Haskell value + | FloatRep + | DoubleRep \end{code} %************************************************************************ @@ -197,21 +257,6 @@ module mutual-recursion. And they aren't called from many places. So we compromise, and move their Kind calculation to the call site. \begin{code} -mkSuperKindCon :: Name -> SuperKindCon -mkSuperKindCon name = SuperKindCon { - tyConUnique = nameUnique name, - tyConName = name - } - -mkKindCon :: Name -> SuperKind -> KindCon -mkKindCon name kind - = KindCon { - tyConUnique = nameUnique name, - tyConName = name, - tyConArity = 0, - tyConKind = kind - } - mkFunTyCon :: Name -> Kind -> TyCon mkFunTyCon name kind = FunTyCon { @@ -220,43 +265,42 @@ mkFunTyCon name kind tyConKind = kind, tyConArity = 2 } - -mkAlgTyCon name kind tyvars theta argvrcs cons ncons derivs flavour rec + +-- 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 rhs flds is_rec gen_info = AlgTyCon { - tyConName = name, - tyConUnique = nameUnique name, - tyConKind = kind, - tyConArity = length tyvars, - tyConTyVars = tyvars, - tyConArgVrcs = argvrcs, - algTyConTheta = theta, - dataCons = cons, - noOfDataCons = ncons, - algTyConDerivings = derivs, - algTyConClass_maybe = Nothing, - algTyConFlavour = flavour, - algTyConRec = rec + tyConName = name, + tyConUnique = nameUnique name, + tyConKind = kind, + tyConArity = length tyvars, + tyConTyVars = tyvars, + argVrcs = argvrcs, + algTcRhs = rhs, + algTcFields = flds, + algTcClass = Nothing, + algTcRec = is_rec, + hasGenerics = gen_info } -mkClassTyCon name kind tyvars argvrcs con clas flavour +mkClassTyCon name kind tyvars argvrcs rhs clas is_rec = AlgTyCon { - tyConName = name, - tyConUnique = nameUnique name, - tyConKind = kind, - tyConArity = length tyvars, - tyConTyVars = tyvars, - tyConArgVrcs = argvrcs, - algTyConTheta = [], - dataCons = [con], - noOfDataCons = 1, - algTyConDerivings = [], - algTyConClass_maybe = Just clas, - algTyConFlavour = flavour, - algTyConRec = NonRecursive + tyConName = name, + tyConUnique = nameUnique name, + tyConKind = kind, + tyConArity = length tyvars, + tyConTyVars = tyvars, + argVrcs = argvrcs, + algTcRhs = rhs, + algTcFields = [], + algTcClass = Just clas, + algTcRec = is_rec, + hasGenerics = False } -mkTupleTyCon name kind arity tyvars con boxed +mkTupleTyCon name kind arity tyvars con boxed gen_info = TupleTyCon { tyConUnique = nameUnique name, tyConName = name, @@ -264,68 +308,105 @@ mkTupleTyCon name kind arity tyvars con boxed tyConArity = arity, tyConBoxed = boxed, tyConTyVars = tyvars, - dataCon = con + dataCon = con, + hasGenerics = gen_info } -mkPrimTyCon name kind arity arg_vrcs rep +-- Foreign-imported (.NET) type constructors are represented +-- as primitive, but *lifted*, TyCons for now. They are lifted +-- because the Haskell type T representing the (foreign) .NET +-- type T is actually implemented (in ILX) as a thunk +mkForeignTyCon name ext_name kind arity arg_vrcs = PrimTyCon { - tyConName = name, - tyConUnique = nameUnique name, - tyConKind = kind, - tyConArity = arity, - tyConArgVrcs = arg_vrcs, - primTyConRep = rep + tyConName = name, + tyConUnique = nameUnique name, + tyConKind = kind, + tyConArity = arity, + argVrcs = arg_vrcs, + primTyConRep = PtrRep, -- they all do + isUnLifted = False, + tyConExtName = ext_name } -mkSynTyCon name kind arity tyvars rhs argvrcs + +-- most Prim tycons are lifted +mkPrimTyCon name kind arity arg_vrcs rep + = mkPrimTyCon' name kind arity arg_vrcs rep True + +-- but RealWorld is lifted +mkLiftedPrimTyCon name kind arity arg_vrcs rep + = mkPrimTyCon' name kind arity arg_vrcs rep False + +mkPrimTyCon' name kind arity arg_vrcs rep is_unlifted + = PrimTyCon { + tyConName = name, + tyConUnique = nameUnique name, + tyConKind = kind, + tyConArity = arity, + argVrcs = arg_vrcs, + primTyConRep = rep, + isUnLifted = is_unlifted, + tyConExtName = Nothing + } + +mkSynTyCon name kind tyvars rhs argvrcs = SynTyCon { tyConName = name, tyConUnique = nameUnique name, tyConKind = kind, - tyConArity = arity, + tyConArity = length tyvars, tyConTyVars = tyvars, synTyConDefn = rhs, - tyConArgVrcs = argvrcs + argVrcs = argvrcs } - -setTyConName tc name = tc {tyConName = name, tyConUnique = nameUnique name} \end{code} \begin{code} +isFunTyCon :: TyCon -> Bool isFunTyCon (FunTyCon {}) = True isFunTyCon _ = False +isAbstractTyCon :: TyCon -> Bool +isAbstractTyCon (AlgTyCon { algTcRhs = AbstractTyCon }) = True +isAbstractTyCon _ = False + +isPrimTyCon :: TyCon -> Bool isPrimTyCon (PrimTyCon {}) = True isPrimTyCon _ = False -isUnLiftedTyCon (PrimTyCon {}) = True -isUnLiftedTyCon (TupleTyCon { tyConBoxed = boxity}) = not (isBoxed boxity) -isUnLiftedTyCon _ = False - --- isBoxedTyCon should not be applied to SynTyCon, nor KindCon -isBoxedTyCon (AlgTyCon {}) = True -isBoxedTyCon (FunTyCon {}) = True -isBoxedTyCon (TupleTyCon {tyConBoxed = boxity}) = isBoxed boxity -isBoxedTyCon (PrimTyCon {primTyConRep = rep}) = isFollowableRep rep +isUnLiftedTyCon :: TyCon -> Bool +isUnLiftedTyCon (PrimTyCon {isUnLifted = is_unlifted}) = is_unlifted +isUnLiftedTyCon (TupleTyCon {tyConBoxed = boxity}) = not (isBoxed boxity) +isUnLiftedTyCon _ = False -- isAlgTyCon returns True for both @data@ and @newtype@ +isAlgTyCon :: TyCon -> Bool isAlgTyCon (AlgTyCon {}) = True isAlgTyCon (TupleTyCon {}) = True isAlgTyCon other = False --- isDataTyCon returns False for @newtype@ and for unboxed tuples -isDataTyCon (AlgTyCon {algTyConFlavour = new_or_data}) = case new_or_data of - NewTyCon _ -> False - other -> True +isDataTyCon :: TyCon -> Bool +-- isDataTyCon returns True for data types that are represented by +-- heap-allocated constructors. +-- These are srcutinised by Core-level @case@ expressions, and they +-- get info tables allocated for them. +-- True for all @data@ types +-- False for newtypes +-- unboxed tuples +isDataTyCon (AlgTyCon {algTcRhs = rhs}) + = case rhs of + DataTyCon _ _ _ -> True + NewTyCon _ _ _ -> False + AbstractTyCon -> panic "isDataTyCon" + isDataTyCon (TupleTyCon {tyConBoxed = boxity}) = isBoxed boxity isDataTyCon other = False -isNewTyCon (AlgTyCon {algTyConFlavour = NewTyCon _}) = True -isNewTyCon other = False - -newTyConRep (AlgTyCon {algTyConFlavour = NewTyCon rep}) = Just rep -newTyConRep other = Nothing +isNewTyCon :: TyCon -> Bool +isNewTyCon (AlgTyCon {algTcRhs = NewTyCon _ _ _}) = True +isNewTyCon other = False +isProductTyCon :: TyCon -> Bool -- A "product" tycon -- has *one* constructor, -- is *not* existential @@ -333,69 +414,125 @@ newTyConRep other = Nothing -- may be DataType or NewType, -- may be unboxed or not, -- may be recursive or not -isProductTyCon (AlgTyCon {dataCons = [data_con]}) = not (isExistentialDataCon data_con) -isProductTyCon (TupleTyCon {}) = True -isProductTyCon other = False - +isProductTyCon tc@(AlgTyCon {}) = case algTcRhs tc of + DataTyCon _ [data_con] _ -> isVanillaDataCon data_con + NewTyCon _ _ _ -> True + other -> False +isProductTyCon (TupleTyCon {}) = True +isProductTyCon other = False + +isSynTyCon :: TyCon -> Bool isSynTyCon (SynTyCon {}) = True isSynTyCon _ = False -isEnumerationTyCon (AlgTyCon {algTyConFlavour = EnumTyCon}) = True -isEnumerationTyCon other = False +isEnumerationTyCon :: TyCon -> Bool +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 isTupleTyCon (TupleTyCon {}) = True isTupleTyCon other = False +isUnboxedTupleTyCon :: TyCon -> Bool isUnboxedTupleTyCon (TupleTyCon {tyConBoxed = boxity}) = not (isBoxed boxity) isUnboxedTupleTyCon other = False +isBoxedTupleTyCon :: TyCon -> Bool isBoxedTupleTyCon (TupleTyCon {tyConBoxed = boxity}) = isBoxed boxity isBoxedTupleTyCon other = False tupleTyConBoxity tc = tyConBoxed tc -isRecursiveTyCon (AlgTyCon {algTyConRec = Recursive}) = True +isRecursiveTyCon :: TyCon -> Bool +isRecursiveTyCon (AlgTyCon {algTcRec = Recursive}) = True isRecursiveTyCon other = False + +isHiBootTyCon :: TyCon -> Bool +-- Used for knot-tying in hi-boot files +isHiBootTyCon (AlgTyCon {algTcRhs = AbstractTyCon}) = True +isHiBootTyCon other = False + +isForeignTyCon :: TyCon -> Bool +-- isForeignTyCon identifies foreign-imported type constructors +isForeignTyCon (PrimTyCon {tyConExtName = Just _}) = True +isForeignTyCon other = False \end{code} \begin{code} +tyConHasGenerics :: TyCon -> Bool +tyConHasGenerics (AlgTyCon {hasGenerics = hg}) = hg +tyConHasGenerics (TupleTyCon {hasGenerics = hg}) = hg +tyConHasGenerics other = False -- Synonyms + tyConDataCons :: TyCon -> [DataCon] -tyConDataCons tycon = ASSERT2( not (null cons), ppr tycon ) cons - where - cons = tyConDataConsIfAvailable tycon +-- It's convenient for tyConDataCons to return the +-- empty list for type synonyms etc +tyConDataCons tycon = tyConDataCons_maybe tycon `orElse` [] -tyConDataConsIfAvailable (AlgTyCon {dataCons = cons}) = cons -- Empty for abstract types -tyConDataConsIfAvailable (TupleTyCon {dataCon = con}) = [con] -tyConDataConsIfAvailable other = [] - -- You may think this last equation should fail, - -- but it's quite convenient to return no constructors for - -- a synonym; see for example the call in TcTyClsDecls. +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 tyConFamilySize :: TyCon -> Int -tyConFamilySize (AlgTyCon {noOfDataCons = n}) = n -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 -tyConPrimRep :: TyCon -> PrimRep -tyConPrimRep (PrimTyCon {primTyConRep = rep}) = rep -tyConPrimRep _ = PtrRep +tyConFields :: TyCon -> [(FieldLabel,Type,Id)] +tyConFields (AlgTyCon {algTcFields = fs}) = fs +tyConFields other_tycon = [] + +tyConSelIds :: TyCon -> [Id] +tyConSelIds tc = [id | (_,_,id) <- tyConFields tc] + +algTyConRhs :: TyCon -> AlgTyConRhs +algTyConRhs (AlgTyCon {algTcRhs = rhs}) = rhs +algTyConRhs (TupleTyCon {dataCon = con}) = DataTyCon (Just []) [con] False +algTyConRhs other = pprPanic "algTyConRhs" (ppr other) \end{code} \begin{code} -tyConDerivings :: TyCon -> [Class] -tyConDerivings (AlgTyCon {algTyConDerivings = derivs}) = derivs -tyConDerivings other = [] +newTyConRhs :: TyCon -> ([TyVar], Type) +newTyConRhs (AlgTyCon {tyConTyVars = tvs, algTcRhs = NewTyCon _ rhs _}) = (tvs, rhs) + +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) + +tyConPrimRep :: TyCon -> PrimRep +tyConPrimRep (PrimTyCon {primTyConRep = rep}) = rep +tyConPrimRep tc = ASSERT(not (isUnboxedTupleTyCon tc)) PtrRep \end{code} \begin{code} -tyConTheta :: TyCon -> ClassContext -tyConTheta (AlgTyCon {algTyConTheta = theta}) = theta --- should ask about anything else +tyConStupidTheta :: TyCon -> [PredType] +tyConStupidTheta (AlgTyCon {algTcRhs = DataTyCon mb_th _ _}) = mb_th `orElse` [] +tyConStupidTheta (AlgTyCon {algTcRhs = other}) = [] +tyConStupidTheta (TupleTyCon {}) = [] +-- shouldn't ask about anything else \end{code} @tyConArgVrcs_maybe@ gives a list of (occPos,occNeg) flags, one for @@ -403,14 +540,12 @@ each tyvar, if available. See @calcAlgTyConArgVrcs@ for how this is actually computed (in another file). \begin{code} -tyConArgVrcs_maybe :: TyCon -> Maybe ArgVrcs - -tyConArgVrcs_maybe (FunTyCon {} ) = Just [(False,True),(True,False)] -tyConArgVrcs_maybe (AlgTyCon {tyConArgVrcs = oi}) = Just oi -tyConArgVrcs_maybe (PrimTyCon {tyConArgVrcs = oi}) = Just oi -tyConArgVrcs_maybe (TupleTyCon {tyConArity = arity }) = Just (replicate arity (True,False)) -tyConArgVrcs_maybe (SynTyCon {tyConArgVrcs = oi }) = Just oi -tyConArgVrcs_maybe _ = Nothing +tyConArgVrcs :: TyCon -> ArgVrcs +tyConArgVrcs (FunTyCon {}) = [(False,True),(True,False)] +tyConArgVrcs (AlgTyCon {argVrcs = oi}) = oi +tyConArgVrcs (PrimTyCon {argVrcs = oi}) = oi +tyConArgVrcs (TupleTyCon {tyConArity = arity}) = (replicate arity (True,False)) +tyConArgVrcs (SynTyCon {argVrcs = oi}) = oi \end{code} \begin{code} @@ -420,19 +555,23 @@ getSynTyConDefn (SynTyCon {tyConTyVars = tyvars, synTyConDefn = ty}) = (tyvars,t \begin{code} maybeTyConSingleCon :: TyCon -> Maybe DataCon -maybeTyConSingleCon (AlgTyCon {dataCons = [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 +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 {algTcClass = Just _}) = True +isClassTyCon other_tycon = False + tyConClass_maybe :: TyCon -> Maybe Class -tyConClass_maybe (AlgTyCon {algTyConClass_maybe = maybe_cls}) = maybe_cls -tyConClass_maybe other_tycon = Nothing +tyConClass_maybe (AlgTyCon {algTcClass = maybe_clas}) = maybe_clas +tyConClass_maybe ther_tycon = Nothing \end{code} @@ -463,30 +602,8 @@ instance Uniquable TyCon where getUnique tc = tyConUnique tc instance Outputable TyCon where - ppr tc = ppr (getName tc) + ppr tc = ppr (getName tc) instance NamedThing TyCon where getName = tyConName \end{code} - - -%************************************************************************ -%* * -\subsection{Kind constructors} -%* * -%************************************************************************ - -@matchesTyCon tc1 tc2@ checks whether an appliation -(tc1 t1..tn) matches (tc2 t1..tn). By "matches" we basically mean "equals", -except that at the kind level tc2 might have more boxity info than tc1. - -\begin{code} -matchesTyCon :: TyCon -- Expected (e.g. arg type of function) - -> TyCon -- Inferred (e.g. type of actual arg to function) - -> Bool - -matchesTyCon tc1 tc2 = uniq1 == uniq2 || uniq1 == anyBoxConKey - where - uniq1 = tyConUnique tc1 - uniq2 = tyConUnique tc2 -\end{code}