X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypes%2FTyCon.lhs;h=ddcb6650ef805b13b5644bab9b53b2a920ae725e;hb=467f588c25e6d7825a11eff018a67727b3dea71b;hp=fcd32c6974bce5bed8fb4cfca1ed0574daa1e0c6;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1;p=ghc-hetmet.git diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs index fcd32c6..ddcb665 100644 --- a/compiler/types/TyCon.lhs +++ b/compiler/types/TyCon.lhs @@ -1,23 +1,35 @@ % +% (c) The University of Glasgow 2006 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -\section[TyCon]{The @TyCon@ datatype} + +The @TyCon@ datatype \begin{code} module TyCon( - TyCon, ArgVrcs, FieldLabel, + TyCon, FieldLabel, PrimRep(..), tyConPrimRep, + primRepSizeW, - AlgTyConRhs(..), visibleDataCons, + AlgTyConRhs(..), visibleDataCons, + TyConParent(..), + SynTyConRhs(..), isFunTyCon, isUnLiftedTyCon, isProductTyCon, - isAlgTyCon, isDataTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, - isEnumerationTyCon, + isAlgTyCon, isDataTyCon, + isNewTyCon, unwrapNewTyCon_maybe, + isSynTyCon, isClosedSynTyCon, isOpenSynTyCon, + isPrimTyCon, + + isEnumerationTyCon, isGadtSyntaxTyCon, isOpenTyCon, + assocTyConArgPoss_maybe, isTyConAssoc, setTyConArgPoss, isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, tupleTyConBoxity, - isRecursiveTyCon, newTyConRep, newTyConRhs, - isHiBootTyCon, + isRecursiveTyCon, newTyConRhs, newTyConEtadRhs, newTyConCo_maybe, + isHiBootTyCon, isSuperKindTyCon, + isCoercionTyCon_maybe, isCoercionTyCon, + isImplicitTyCon, tcExpandTyCon_maybe, coreExpandTyCon_maybe, @@ -29,21 +41,24 @@ module TyCon( mkClassTyCon, mkFunTyCon, mkPrimTyCon, + mkVoidPrimTyCon, mkLiftedPrimTyCon, mkTupleTyCon, mkSynTyCon, + mkSuperKindTyCon, + mkCoercionTyCon, tyConName, tyConKind, tyConUnique, tyConTyVars, - tyConArgVrcs, algTyConRhs, tyConDataCons, tyConDataCons_maybe, tyConFamilySize, tyConSelIds, tyConStupidTheta, tyConArity, isClassTyCon, tyConClass_maybe, - synTyConDefn, synTyConRhs, + isFamInstTyCon, tyConFamInst_maybe, tyConFamilyCoercion_maybe, + synTyConDefn, synTyConRhs, synTyConType, synTyConResKind, tyConExtName, -- External name for foreign types maybeTyConSingleCon, @@ -54,22 +69,18 @@ module TyCon( #include "HsVersions.h" -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 #-} TypeRep ( Kind, Type, PredType ) import {-# SOURCE #-} DataCon ( DataCon, isVanillaDataCon ) - -import Var ( TyVar, Id ) -import Class ( Class ) -import Kind ( Kind ) -import BasicTypes ( Arity, RecFlag(..), Boxity(..), isBoxed ) -import Name ( Name, nameUnique, NamedThing(getName) ) -import PrelNames ( Unique, Uniquable(..) ) -import Maybes ( orElse ) +import Var +import Class +import BasicTypes +import Name +import PrelNames +import Maybes import Outputable import FastString +import Constants \end{code} %************************************************************************ @@ -94,36 +105,71 @@ data TyCon tyConName :: Name, tyConKind :: Kind, tyConArity :: Arity, - - tyConTyVars :: [TyVar], -- Scopes over (a) the [PredType] in AlgTyConRhs.DataTyCon - -- (b) the cached types in AlgTyConRhs.NewTyCon + + tyConTyVars :: [TyVar], -- Scopes over (a) the algTcStupidTheta + -- (b) the cached types in + -- algTyConRhs.NewTyCon + -- (c) the family instance + -- types if present -- But not over the data constructors - argVrcs :: ArgVrcs, - algTcSelIds :: [Id], -- Its record selectors (empty if none): + algTcSelIds :: [Id], -- Its record selectors (empty if none) + algTcGadtSyntax :: Bool, -- True <=> the data type was declared using GADT syntax + -- That doesn't mean it's a true GADT; only that the "where" + -- form was used. This field is used only to guide + -- pretty-printinng algTcStupidTheta :: [PredType], -- The "stupid theta" for the data type -- (always empty for GADTs) algTcRhs :: AlgTyConRhs, -- Data constructors in here - algTcRec :: RecFlag, -- Tells whether the data type is part of - -- a mutually-recursive group or not + 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 + algTcParent :: TyConParent -- Gives the class or family tycon for + -- derived tycons representing classes + -- or family instances, respectively. + } + + | TupleTyCon { + tyConUnique :: Unique, + tyConName :: Name, + tyConKind :: Kind, + tyConArity :: Arity, + tyConBoxed :: Boxity, + tyConTyVars :: [TyVar], + dataCon :: DataCon, + hasGenerics :: Bool + } + + | SynTyCon { + tyConUnique :: Unique, + tyConName :: Name, + tyConKind :: Kind, + tyConArity :: Arity, + + tyConTyVars :: [TyVar], -- Bound tyvars + + synTcRhs :: SynTyConRhs, -- Expanded type in here + + synTcParent :: TyConParent -- Gives the family tycon of + -- representation tycons of family + -- instances + } | PrimTyCon { -- Primitive types; cannot be defined in Haskell -- Now includes foreign-imported types + -- Also includes Kinds tyConUnique :: Unique, tyConName :: Name, tyConKind :: Kind, - tyConArity :: Arity, - argVrcs :: ArgVrcs, + tyConArity :: Arity, -- SLPJ Oct06: I'm not sure what the significance + -- of the arity of a primtycon is! primTyConRep :: PrimRep, -- Many primitive tycons are unboxed, but some are @@ -134,47 +180,59 @@ data TyCon tyConExtName :: Maybe FastString -- Just xx for foreign-imported types } - | TupleTyCon { - tyConUnique :: Unique, - tyConName :: Name, - tyConKind :: Kind, - tyConArity :: Arity, - tyConBoxed :: Boxity, - tyConTyVars :: [TyVar], - dataCon :: DataCon, - hasGenerics :: Bool - } - - | SynTyCon { + | CoercionTyCon { -- E.g. (:=:), sym, trans, left, right + -- INVARIANT: coercions are always fully applied tyConUnique :: Unique, - tyConName :: Name, - tyConKind :: Kind, + tyConName :: Name, tyConArity :: Arity, - - tyConTyVars :: [TyVar], -- Bound tyvars - 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 + coKindFun :: [Type] -> (Type,Type) + } -- INVARAINT: coKindFun is always applied to exactly 'arity' args + -- E.g. for trans (c1 :: ta=tb) (c2 :: tb=tc), the coKindFun returns + -- the kind as a pair of types: (ta,tc) + + | SuperKindTyCon { -- Super Kinds, TY (box) and CO (diamond). + -- They have no kind; and arity zero + tyConUnique :: Unique, + tyConName :: Name } type FieldLabel = Name -type ArgVrcs = [(Bool,Bool)] -- Tyvar variance info: [(occPos,occNeg)] - -- [] means "no information, assume the worst" - +-- Right hand sides of type constructors for algebraic types +-- 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 + + -- 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. + -- + = AbstractTyCon + + -- The constructor represents an open family without a fixed right hand + -- side. Additional instances can appear at any time. + -- + -- These are introduced by either a top level decl: + -- data T a :: * + -- or an assoicated data type decl, in a class decl: + -- class C a b where + -- data T b :: * + + | OpenTyCon { + + otArgPoss :: Maybe [Int] + -- Nothing <=> top-level indexed type family + -- Just ns <=> associated (not toplevel) family + -- In the latter case, for each tyvar in the AT decl, 'ns' gives the + -- position of that tyvar in the class argument list (starting from 0). + -- NB: Length is less than tyConArity iff higher kind signature. + + } | 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) + -- (see the tag assignment in DataCon.mkDataCon) is_enum :: Bool -- Cached: True <=> an enumeration type } -- Includes data types with no constructors. @@ -183,34 +241,113 @@ data AlgTyConRhs nt_rhs :: Type, -- Cached: the argument type of the constructor -- = the representation type of the tycon - - nt_etad_rhs :: ([TyVar], Type) , + -- The free tyvars of this type are the tyConTyVars + + nt_co :: Maybe TyCon, -- A CoercionTyCon used to create the newtype + -- from the representation + -- Optional for non-recursive newtypes + -- See Note [Newtype coercions] + -- Invariant: arity = #tvs in nt_etad_rhs; + -- See Note [Newtype eta] + -- Watch out! If any newtypes become transparent + -- again check Trac #1072. + + 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] - - 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 - -- - -- 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. + } visibleDataCons :: AlgTyConRhs -> [DataCon] visibleDataCons AbstractTyCon = [] +visibleDataCons OpenTyCon {} = [] visibleDataCons (DataTyCon{ data_cons = cs }) = cs visibleDataCons (NewTyCon{ data_con = c }) = [c] + +-- Both type classes as well as family instances imply implicit +-- type constructors. These implicit type constructors refer to their parent +-- structure (ie, the class or family from which they derive) using a type of +-- the following form. We use `TyConParent' for both algebraic and synonym +-- types, but the variant `ClassTyCon' will only be used by algebraic tycons. + +data TyConParent + = NoParentTyCon -- An ordinary type constructor has no parent. + + | ClassTyCon -- Type constructors representing a class dictionary. + Class -- INVARIANT: the classTyCon of this Class is the current tycon + + | FamilyTyCon -- Type constructors representing an instance of a type + TyCon -- The type family + [Type] -- Instance types; free variables are the tyConTyVars + -- of the current TyCon (not the family one) + -- INVARIANT: the number of types matches the arity + -- of the family tycon + TyCon -- A CoercionTyCon identifying the representation + -- type with the type instance family. + -- c.f. Note [Newtype coercions] + + -- + -- E.g. data intance T [a] = ... + -- gives a representation tycon: + -- data :R7T a = ... + -- axiom co a :: T [a] ~ :R7T a + -- with :R7T's algTcParent = FamilyTyCon T [a] co + +okParent :: Name -> TyConParent -> Bool -- Checks invariants +okParent _ NoParentTyCon = True +okParent tc_name (ClassTyCon cls) = tyConName (classTyCon cls) == tc_name +okParent _ (FamilyTyCon fam_tc tys _co_tc) = tyConArity fam_tc == length tys + +-------------------- +data SynTyConRhs + = OpenSynTyCon Kind -- Type family: *result* kind given + (Maybe [Int]) -- for associated families: for each tyvars in + -- the AT decl, gives the position of that + -- tyvar in the class argument list (starting + -- from 0). + -- NB: Length is less than tyConArity + -- if higher kind signature. + + | SynonymTyCon Type -- Mentioning head type vars. Acts as a template for + -- the expansion when the tycon is applied to some + -- types. \end{code} +Note [Newtype coercions] +~~~~~~~~~~~~~~~~~~~~~~~~ +The NewTyCon field nt_co is a a TyCon (a coercion constructor in fact) +which is used for coercing from the representation type of the +newtype, to the newtype itself. For example, + + newtype T a = MkT (a -> a) + +the NewTyCon for T will contain nt_co = CoT where CoT t : T t :=: t -> +t. This TyCon is a CoercionTyCon, so it does not have a kind on its +own; it basically has its own typing rule for the fully-applied +version. If the newtype T has k type variables then CoT has arity at +most k. In the case that the right hand side is a type application +ending with the same type variables as the left hand side, we +"eta-contract" the coercion. So if we had + + newtype S a = MkT [a] + +then we would generate the arity 0 coercion CoS : S :=: []. The +primary reason we do this is to make newtype deriving cleaner. + +In the paper we'd write + axiom CoT : (forall t. T t) :=: (forall t. [t]) +and then when we used CoT at a particular type, s, we'd say + CoT @ s +which encodes as (TyConApp instCoercionTyCon [TyConApp CoT [], s]) + +But in GHC we instead make CoT into a new piece of type syntax, CoercionTyCon, +(like instCoercionTyCon, symCoercionTyCon etc), which must always +be saturated, but which encodes as + TyConApp CoT [s] +In the vocabulary of the paper it's as if we had axiom declarations +like + axiom CoT t : T t :=: [t] + Note [Newtype eta] ~~~~~~~~~~~~~~~~~~ Consider @@ -241,6 +378,47 @@ we get: w2 = w1 And now Lint complains unless Foo T == Foo [], and that requires T==[] +This point carries over to the newtype coercion, because we need to +say + w2 = w1 `cast` Foo CoT + +so the coercion tycon CoT must have + kind: T ~ [] + and arity: 0 + + +Note [Indexed data types] (aka data type families) +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + See also Note [Wrappers for data instance tycons] in MkId.lhs + +Consider + data family T a + + data instance T (b,c) where + T1 :: b -> c -> T (b,c) + +Then + * T is the "family TyCon" + + * We make "representation TyCon" :R1T, thus: + data :R1T b c where + T1 :: forall b c. b -> c -> :R1T b c + + * It has a top-level coercion connecting it to the family TyCon + + axiom :Co:R1T b c : T (b,c) ~ :R1T b c + + * The data contructor T1 has a wrapper (which is what the source-level + "T1" invokes): + + $WT1 :: forall b c. b -> c -> T (b,c) + $WT1 b c (x::b) (y::c) = T1 b c x y `cast` sym (:Co:R1T b c) + + * The representation TyCon :R1T has an AlgTyConParent of + + FamilyTyCon T [(b,c)] :Co:R1T + + %************************************************************************ %* * @@ -277,6 +455,22 @@ data PrimRep | AddrRep -- a pointer, but not to a Haskell value | FloatRep | DoubleRep + deriving( Eq, Show ) + +instance Outputable PrimRep where + ppr r = text (show r) + +-- Size of a PrimRep, in words +primRepSizeW :: PrimRep -> Int +primRepSizeW IntRep = 1 +primRepSizeW WordRep = 1 +primRepSizeW Int64Rep = wORD64_SIZE `quot` wORD_SIZE +primRepSizeW Word64Rep= wORD64_SIZE `quot` wORD_SIZE +primRepSizeW FloatRep = 1 -- NB. might not take a full word +primRepSizeW DoubleRep= dOUBLE_SIZE `quot` wORD_SIZE +primRepSizeW AddrRep = 1 +primRepSizeW PtrRep = 1 +primRepSizeW VoidRep = 0 \end{code} %************************************************************************ @@ -304,39 +498,38 @@ 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 sel_ids is_rec gen_info +mkAlgTyCon :: Name + -> Kind + -> [TyVar] + -> [PredType] + -> AlgTyConRhs + -> [Id] + -> TyConParent + -> RecFlag + -> Bool + -> Bool + -> TyCon +mkAlgTyCon name kind tyvars stupid rhs sel_ids parent is_rec gen_info gadt_syn = AlgTyCon { tyConName = name, tyConUnique = nameUnique name, tyConKind = kind, tyConArity = length tyvars, tyConTyVars = tyvars, - argVrcs = argvrcs, algTcStupidTheta = stupid, algTcRhs = rhs, algTcSelIds = sel_ids, - algTcClass = Nothing, + algTcParent = ASSERT( okParent name parent ) parent, algTcRec = is_rec, + algTcGadtSyntax = gadt_syn, 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, - algTcStupidTheta = [], - algTcRhs = rhs, - algTcSelIds = [], - algTcClass = Just clas, - algTcRec = is_rec, - hasGenerics = False - } - +mkClassTyCon :: Name -> Kind -> [TyVar] -> AlgTyConRhs -> Class -> RecFlag -> TyCon +mkClassTyCon name kind tyvars rhs clas is_rec = + mkAlgTyCon name kind tyvars [] rhs [] (ClassTyCon clas) is_rec False False +mkTupleTyCon :: Name -> Kind -> Arity -> [TyVar] -> DataCon -> Boxity -> Bool -> TyCon mkTupleTyCon name kind arity tyvars con boxed gen_info = TupleTyCon { tyConUnique = nameUnique name, @@ -353,13 +546,13 @@ mkTupleTyCon name kind arity tyvars con boxed gen_info -- 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 +mkForeignTyCon :: Name -> Maybe FastString -> Kind -> Arity -> TyCon +mkForeignTyCon name ext_name kind arity = PrimTyCon { tyConName = name, tyConUnique = nameUnique name, tyConKind = kind, tyConArity = arity, - argVrcs = arg_vrcs, primTyConRep = PtrRep, -- they all do isUnLifted = False, tyConExtName = ext_name @@ -367,26 +560,33 @@ mkForeignTyCon name ext_name kind arity arg_vrcs -- most Prim tycons are lifted -mkPrimTyCon name kind arity arg_vrcs rep - = mkPrimTyCon' name kind arity arg_vrcs rep True +mkPrimTyCon :: Name -> Kind -> Arity -> PrimRep -> TyCon +mkPrimTyCon name kind arity rep + = mkPrimTyCon' name kind arity rep True + +mkVoidPrimTyCon :: Name -> Kind -> Arity -> TyCon +mkVoidPrimTyCon name kind arity + = mkPrimTyCon' name kind arity VoidRep True -- but RealWorld is lifted -mkLiftedPrimTyCon name kind arity arg_vrcs rep - = mkPrimTyCon' name kind arity arg_vrcs rep False +mkLiftedPrimTyCon :: Name -> Kind -> Arity -> PrimRep -> TyCon +mkLiftedPrimTyCon name kind arity rep + = mkPrimTyCon' name kind arity rep False -mkPrimTyCon' name kind arity arg_vrcs rep is_unlifted +mkPrimTyCon' :: Name -> Kind -> Arity -> PrimRep -> Bool -> TyCon +mkPrimTyCon' name kind arity 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 +mkSynTyCon :: Name -> Kind -> [TyVar] -> SynTyConRhs -> TyConParent -> TyCon +mkSynTyCon name kind tyvars rhs parent = SynTyCon { tyConName = name, tyConUnique = nameUnique name, @@ -394,8 +594,25 @@ mkSynTyCon name kind tyvars rhs argvrcs tyConArity = length tyvars, tyConTyVars = tyvars, synTcRhs = rhs, - argVrcs = argvrcs + synTcParent = parent + } + +mkCoercionTyCon :: Name -> Arity -> ([Type] -> (Type,Type)) -> TyCon +mkCoercionTyCon name arity kindRule + = CoercionTyCon { + tyConName = name, + tyConUnique = nameUnique name, + tyConArity = arity, + coKindFun = kindRule } + +-- Super kinds always have arity zero +mkSuperKindTyCon :: Name -> TyCon +mkSuperKindTyCon name + = SuperKindTyCon { + tyConName = name, + tyConUnique = nameUnique name + } \end{code} \begin{code} @@ -424,52 +641,100 @@ isUnLiftedTyCon _ = False isAlgTyCon :: TyCon -> Bool isAlgTyCon (AlgTyCon {}) = True isAlgTyCon (TupleTyCon {}) = True -isAlgTyCon other = False +isAlgTyCon _ = False isDataTyCon :: TyCon -> Bool --- isDataTyCon returns True for data types that are represented by --- heap-allocated constructors. +-- isDataTyCon returns True for data types that are definitely +-- 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 tc@(AlgTyCon {algTcRhs = rhs}) +-- type families +-- +-- NB: for a data type family, T, only the *instance* tycons are +-- get an info table etc. The family tycon does not. +-- Hence False for OpenTyCon +isDataTyCon (AlgTyCon {algTcRhs = rhs}) = case rhs of + OpenTyCon {} -> False DataTyCon {} -> True NewTyCon {} -> False - AbstractTyCon -> pprPanic "isDataTyCon" (ppr tc) - + AbstractTyCon -> False -- We don't know, so return False isDataTyCon (TupleTyCon {tyConBoxed = boxity}) = isBoxed boxity -isDataTyCon other = False +isDataTyCon _ = False isNewTyCon :: TyCon -> Bool -isNewTyCon (AlgTyCon {algTcRhs = NewTyCon {}}) = True -isNewTyCon other = False +isNewTyCon (AlgTyCon {algTcRhs = NewTyCon {}}) = True +isNewTyCon _ = False + +unwrapNewTyCon_maybe :: TyCon -> Maybe ([TyVar], Type, Maybe TyCon) +unwrapNewTyCon_maybe (AlgTyCon { tyConTyVars = tvs, + algTcRhs = NewTyCon { nt_co = mb_co, + nt_rhs = rhs }}) + = Just (tvs, rhs, mb_co) +unwrapNewTyCon_maybe _ = Nothing isProductTyCon :: TyCon -> Bool -- A "product" tycon -- has *one* constructor, -- is *not* existential -- but --- may be DataType or NewType, +-- may be DataType, NewType -- may be unboxed or not, -- may be recursive or not +-- isProductTyCon tc@(AlgTyCon {}) = case algTcRhs tc of DataTyCon{ data_cons = [data_con] } -> isVanillaDataCon data_con NewTyCon {} -> True - other -> False + _ -> False isProductTyCon (TupleTyCon {}) = True -isProductTyCon other = False +isProductTyCon _ = False isSynTyCon :: TyCon -> Bool isSynTyCon (SynTyCon {}) = True isSynTyCon _ = False +-- As for newtypes, it is in some contexts important to distinguish between +-- closed synonyms and synonym families, as synonym families have no unique +-- right hand side to which a synonym family application can expand. +-- +isClosedSynTyCon :: TyCon -> Bool +isClosedSynTyCon tycon = isSynTyCon tycon && not (isOpenTyCon tycon) + +isOpenSynTyCon :: TyCon -> Bool +isOpenSynTyCon tycon = isSynTyCon tycon && isOpenTyCon tycon + +isGadtSyntaxTyCon :: TyCon -> Bool +isGadtSyntaxTyCon (AlgTyCon { algTcGadtSyntax = res }) = res +isGadtSyntaxTyCon _ = False + isEnumerationTyCon :: TyCon -> Bool isEnumerationTyCon (AlgTyCon {algTcRhs = DataTyCon { is_enum = res }}) = res -isEnumerationTyCon other = False +isEnumerationTyCon _ = False + +isOpenTyCon :: TyCon -> Bool +isOpenTyCon (SynTyCon {synTcRhs = OpenSynTyCon _ _}) = True +isOpenTyCon (AlgTyCon {algTcRhs = OpenTyCon {} }) = True +isOpenTyCon _ = False + +assocTyConArgPoss_maybe :: TyCon -> Maybe [Int] +assocTyConArgPoss_maybe (AlgTyCon { + algTcRhs = OpenTyCon {otArgPoss = poss}}) = poss +assocTyConArgPoss_maybe (SynTyCon { synTcRhs = OpenSynTyCon _ poss }) = poss +assocTyConArgPoss_maybe _ = Nothing + +isTyConAssoc :: TyCon -> Bool +isTyConAssoc = isJust . assocTyConArgPoss_maybe + +setTyConArgPoss :: TyCon -> [Int] -> TyCon +setTyConArgPoss tc@(AlgTyCon { algTcRhs = rhs }) poss = + tc { algTcRhs = rhs {otArgPoss = Just poss} } +setTyConArgPoss tc@(SynTyCon { synTcRhs = OpenSynTyCon ki _ }) poss = + tc { synTcRhs = OpenSynTyCon ki (Just poss) } +setTyConArgPoss tc _ = pprPanic "setTyConArgPoss" (ppr tc) isTupleTyCon :: TyCon -> Bool -- The unit tycon didn't used to be classed as a tuple tycon @@ -481,31 +746,65 @@ isTupleTyCon :: TyCon -> Bool -- get spat into the interface file as tuple tycons, so I don't think -- it matters. isTupleTyCon (TupleTyCon {}) = True -isTupleTyCon other = False +isTupleTyCon _ = False isUnboxedTupleTyCon :: TyCon -> Bool isUnboxedTupleTyCon (TupleTyCon {tyConBoxed = boxity}) = not (isBoxed boxity) -isUnboxedTupleTyCon other = False +isUnboxedTupleTyCon _ = False isBoxedTupleTyCon :: TyCon -> Bool isBoxedTupleTyCon (TupleTyCon {tyConBoxed = boxity}) = isBoxed boxity -isBoxedTupleTyCon other = False +isBoxedTupleTyCon _ = False +tupleTyConBoxity :: TyCon -> Boxity tupleTyConBoxity tc = tyConBoxed tc isRecursiveTyCon :: TyCon -> Bool isRecursiveTyCon (AlgTyCon {algTcRec = Recursive}) = True -isRecursiveTyCon other = False +isRecursiveTyCon _ = False isHiBootTyCon :: TyCon -> Bool -- Used for knot-tying in hi-boot files isHiBootTyCon (AlgTyCon {algTcRhs = AbstractTyCon}) = True -isHiBootTyCon other = False +isHiBootTyCon _ = False isForeignTyCon :: TyCon -> Bool -- isForeignTyCon identifies foreign-imported type constructors isForeignTyCon (PrimTyCon {tyConExtName = Just _}) = True -isForeignTyCon other = False +isForeignTyCon _ = False + +isSuperKindTyCon :: TyCon -> Bool +isSuperKindTyCon (SuperKindTyCon {}) = True +isSuperKindTyCon _ = False + +isCoercionTyCon_maybe :: TyCon -> Maybe (Arity, [Type] -> (Type,Type)) +isCoercionTyCon_maybe (CoercionTyCon {tyConArity = ar, coKindFun = rule}) + = Just (ar, rule) +isCoercionTyCon_maybe _ = Nothing + +isCoercionTyCon :: TyCon -> Bool +isCoercionTyCon (CoercionTyCon {}) = True +isCoercionTyCon _ = False + +-- Identifies implicit tycons that, in particular, do not go into interface +-- files (because they are implicitly reconstructed when the interface is +-- read). +-- +-- Note that +-- +-- * associated families are implicit, as they are re-constructed from +-- the class declaration in which they reside, and +-- * family instances are *not* implicit as they represent the instance body +-- (similar to a dfun does that for a class instance). +-- +isImplicitTyCon :: TyCon -> Bool +isImplicitTyCon tycon | isTyConAssoc tycon = True + | isSynTyCon tycon = False + | isAlgTyCon tycon = isClassTyCon tycon || + isTupleTyCon tycon +isImplicitTyCon _other = True + -- catches: FunTyCon, PrimTyCon, + -- CoercionTyCon, SuperKindTyCon \end{code} @@ -521,21 +820,24 @@ tcExpandTyCon_maybe, coreExpandTyCon_maybe 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 +-- For the *typechecker* view, we expand (closed) synonyms only +tcExpandTyCon_maybe (SynTyCon {tyConTyVars = tvs, + synTcRhs = SynonymTyCon rhs }) tys = expand tvs rhs tys -tcExpandTyCon_maybe other_tycon tys = Nothing +tcExpandTyCon_maybe _ _ = Nothing --------------- --- For the *Core* view, we expand synonyms *and* non-recursive newtypes +-- For the *Core* view, we expand synonyms only as well + coreExpandTyCon_maybe (AlgTyCon {algTcRec = NonRecursive, -- Not recursive - algTcRhs = NewTyCon { nt_etad_rhs = etad_rhs }}) tys + algTcRhs = NewTyCon { nt_etad_rhs = etad_rhs, nt_co = Nothing }}) 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 @@ -553,7 +855,7 @@ expand tvs rhs tys tyConHasGenerics :: TyCon -> Bool tyConHasGenerics (AlgTyCon {hasGenerics = hg}) = hg tyConHasGenerics (TupleTyCon {hasGenerics = hg}) = hg -tyConHasGenerics other = False -- Synonyms +tyConHasGenerics _ = False -- Synonyms tyConDataCons :: TyCon -> [DataCon] -- It's convenient for tyConDataCons to return the @@ -564,19 +866,19 @@ tyConDataCons_maybe :: TyCon -> Maybe [DataCon] 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 +tyConDataCons_maybe _ = Nothing tyConFamilySize :: TyCon -> Int -tyConFamilySize (AlgTyCon {algTcRhs = DataTyCon { data_cons = cons }}) = length cons -tyConFamilySize (AlgTyCon {algTcRhs = NewTyCon {}}) = 1 -tyConFamilySize (TupleTyCon {}) = 1 -#ifdef DEBUG +tyConFamilySize (AlgTyCon {algTcRhs = DataTyCon {data_cons = cons}}) = + length cons +tyConFamilySize (AlgTyCon {algTcRhs = NewTyCon {}}) = 1 +tyConFamilySize (AlgTyCon {algTcRhs = OpenTyCon {}}) = 0 +tyConFamilySize (TupleTyCon {}) = 1 tyConFamilySize other = pprPanic "tyConFamilySize:" (ppr other) -#endif tyConSelIds :: TyCon -> [Id] tyConSelIds (AlgTyCon {algTcSelIds = fs}) = fs -tyConSelIds other_tycon = [] +tyConSelIds _ = [] algTyConRhs :: TyCon -> AlgTyConRhs algTyConRhs (AlgTyCon {algTcRhs = rhs}) = rhs @@ -589,9 +891,13 @@ newTyConRhs :: TyCon -> ([TyVar], Type) newTyConRhs (AlgTyCon {tyConTyVars = tvs, algTcRhs = NewTyCon { nt_rhs = rhs }}) = (tvs, rhs) newTyConRhs tycon = pprPanic "newTyConRhs" (ppr tycon) -newTyConRep :: TyCon -> ([TyVar], Type) -newTyConRep (AlgTyCon {tyConTyVars = tvs, algTcRhs = NewTyCon { nt_rep = rep }}) = (tvs, rep) -newTyConRep tycon = pprPanic "newTyConRep" (ppr tycon) +newTyConEtadRhs :: TyCon -> ([TyVar], Type) +newTyConEtadRhs (AlgTyCon {algTcRhs = NewTyCon { nt_etad_rhs = tvs_rhs }}) = tvs_rhs +newTyConEtadRhs tycon = pprPanic "newTyConEtadRhs" (ppr tycon) + +newTyConCo_maybe :: TyCon -> Maybe TyCon +newTyConCo_maybe (AlgTyCon {algTcRhs = NewTyCon { nt_co = co }}) = co +newTyConCo_maybe _ = Nothing tyConPrimRep :: TyCon -> PrimRep tyConPrimRep (PrimTyCon {primTyConRep = rep}) = rep @@ -605,26 +911,24 @@ tyConStupidTheta (TupleTyCon {}) = [] tyConStupidTheta tycon = pprPanic "tyConStupidTheta" (ppr tycon) \end{code} -@tyConArgVrcs_maybe@ gives a list of (occPos,occNeg) flags, one for -each tyvar, if available. See @calcAlgTyConArgVrcs@ for how this is -actually computed (in another file). - -\begin{code} -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} synTyConDefn :: TyCon -> ([TyVar], Type) -synTyConDefn (SynTyCon {tyConTyVars = tyvars, synTcRhs = ty}) = (tyvars,ty) +synTyConDefn (SynTyCon {tyConTyVars = tyvars, synTcRhs = SynonymTyCon ty}) + = (tyvars, ty) synTyConDefn tycon = pprPanic "getSynTyConDefn" (ppr tycon) -synTyConRhs :: TyCon -> Type -synTyConRhs tc = synTcRhs tc +synTyConRhs :: TyCon -> SynTyConRhs +synTyConRhs (SynTyCon {synTcRhs = rhs}) = rhs +synTyConRhs tc = pprPanic "synTyConRhs" (ppr tc) + +synTyConType :: TyCon -> Type +synTyConType tc = case synTcRhs tc of + SynonymTyCon t -> t + _ -> pprPanic "synTyConType" (ppr tc) + +synTyConResKind :: TyCon -> Kind +synTyConResKind (SynTyCon {synTcRhs = OpenSynTyCon kind _}) = kind +synTyConResKind tycon = pprPanic "synTyConResKind" (ppr tycon) \end{code} \begin{code} @@ -640,12 +944,33 @@ maybeTyConSingleCon tc = pprPanic "maybeTyConSingleCon: unexpected tycon " $ ppr \begin{code} isClassTyCon :: TyCon -> Bool -isClassTyCon (AlgTyCon {algTcClass = Just _}) = True -isClassTyCon other_tycon = False +isClassTyCon (AlgTyCon {algTcParent = ClassTyCon _}) = True +isClassTyCon _ = False tyConClass_maybe :: TyCon -> Maybe Class -tyConClass_maybe (AlgTyCon {algTcClass = maybe_clas}) = maybe_clas -tyConClass_maybe ther_tycon = Nothing +tyConClass_maybe (AlgTyCon {algTcParent = ClassTyCon clas}) = Just clas +tyConClass_maybe _ = Nothing + +isFamInstTyCon :: TyCon -> Bool +isFamInstTyCon (AlgTyCon {algTcParent = FamilyTyCon _ _ _ }) = True +isFamInstTyCon (SynTyCon {synTcParent = FamilyTyCon _ _ _ }) = True +isFamInstTyCon _ = False + +tyConFamInst_maybe :: TyCon -> Maybe (TyCon, [Type]) +tyConFamInst_maybe (AlgTyCon {algTcParent = FamilyTyCon fam instTys _}) = + Just (fam, instTys) +tyConFamInst_maybe (SynTyCon {synTcParent = FamilyTyCon fam instTys _}) = + Just (fam, instTys) +tyConFamInst_maybe _ = + Nothing + +tyConFamilyCoercion_maybe :: TyCon -> Maybe TyCon +tyConFamilyCoercion_maybe (AlgTyCon {algTcParent = FamilyTyCon _ _ coe}) = + Just coe +tyConFamilyCoercion_maybe (SynTyCon {synTcParent = FamilyTyCon _ _ coe}) = + Just coe +tyConFamilyCoercion_maybe _ = + Nothing \end{code}