X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypes%2FTyCon.lhs;h=959575900470d3efc578565cd4cb4af4dadd4af6;hp=c80e3a7dc7c8b3b818104eb3f39595e44e13a776;hb=84923cc7de2a93c22a2f72daf9ac863959efae13;hpb=5653634ead7a7f31f1a584483e53b23e78b047c2 diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs index c80e3a7..9595759 100644 --- a/compiler/types/TyCon.lhs +++ b/compiler/types/TyCon.lhs @@ -1,26 +1,33 @@ % +% (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, - AlgTyConRhs(..), visibleDataCons, + AlgTyConRhs(..), visibleDataCons, + AlgTyConParent(..), + SynTyConRhs(..), isFunTyCon, isUnLiftedTyCon, isProductTyCon, - isAlgTyCon, isDataTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, - isEnumerationTyCon, isGadtSyntaxTyCon, + isAlgTyCon, isDataTyCon, isSynTyCon, isNewTyCon, isClosedNewTyCon, + isPrimTyCon, + isEnumerationTyCon, isGadtSyntaxTyCon, isOpenTyCon, + assocTyConArgPoss_maybe, isTyConAssoc, setTyConArgPoss, isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, tupleTyConBoxity, - isRecursiveTyCon, newTyConRep, newTyConRhs, newTyConCo, + isRecursiveTyCon, newTyConRep, newTyConRhs, newTyConCo_maybe, isHiBootTyCon, isSuperKindTyCon, isCoercionTyCon_maybe, isCoercionTyCon, + isImplicitTyCon, - tcExpandTyCon_maybe, coreExpandTyCon_maybe, stgExpandTyCon_maybe, + tcExpandTyCon_maybe, coreExpandTyCon_maybe, makeTyConAbstract, isAbstractTyCon, @@ -41,13 +48,13 @@ module TyCon( 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, @@ -58,15 +65,15 @@ module TyCon( #include "HsVersions.h" -import {-# SOURCE #-} TypeRep ( Kind, Type, Coercion, PredType ) +import {-# SOURCE #-} TypeRep ( Kind, Type, PredType ) import {-# SOURCE #-} DataCon ( DataCon, isVanillaDataCon ) -import Var ( TyVar, Id ) -import Class ( Class ) -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 \end{code} @@ -93,13 +100,24 @@ 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): + tyConArgPoss :: Maybe [Int], -- for associated families: for each + -- tyvar 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. + -- NB: Just _ <=> associated (not + -- toplevel) family + + 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" @@ -110,14 +128,15 @@ data TyCon 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 :: AlgTyConParent -- Gives the class or family tycon for + -- derived tycons representing classes + -- or family instances, respectively. } | TupleTyCon { @@ -132,16 +151,21 @@ data TyCon } | SynTyCon { - tyConUnique :: Unique, - tyConName :: Name, - tyConKind :: Kind, - 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 + tyConUnique :: Unique, + tyConName :: Name, + tyConKind :: Kind, + tyConArity :: Arity, + + tyConTyVars :: [TyVar], -- Bound tyvars + + tyConArgPoss :: Maybe [Int], -- for associated families: for each + -- tyvar 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. + + synTcRhs :: SynTyConRhs -- Expanded type in here } | PrimTyCon { -- Primitive types; cannot be defined in Haskell @@ -150,8 +174,8 @@ data TyCon 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 @@ -167,8 +191,10 @@ data TyCon tyConUnique :: Unique, tyConName :: Name, tyConArity :: Arity, - coKindFun :: [Type] -> Kind - } + 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 @@ -176,21 +202,17 @@ data TyCon tyConName :: Name } -type KindCon = TyCon - -type SuperKindCon = TyCon - type FieldLabel = Name -type ArgVrcs = [(Bool,Bool)] -- Tyvar variance info: [(occPos,occNeg)] - -- [] 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 + | OpenDataTyCon -- data family (further instances can appear + | OpenNewTyCon -- newtype family at any time) + | DataTyCon { data_cons :: [DataCon], -- The constructors; can be empty if the user declares @@ -207,8 +229,9 @@ data AlgTyConRhs -- = the representation type of the tycon -- The free tyvars of this type are the tyConTyVars - nt_co :: TyCon, -- The coercion used to create the newtype + nt_co :: Maybe TyCon, -- The coercion used to create the newtype -- from the representation + -- optional for non-recursive newtypes -- See Note [Newtype coercions] nt_etad_rhs :: ([TyVar], Type) , @@ -234,8 +257,35 @@ data AlgTyConRhs visibleDataCons :: AlgTyConRhs -> [DataCon] visibleDataCons AbstractTyCon = [] +visibleDataCons OpenDataTyCon = [] +visibleDataCons OpenNewTyCon = [] visibleDataCons (DataTyCon{ data_cons = cs }) = cs visibleDataCons (NewTyCon{ data_con = c }) = [c] + +-- Both type classes as well as data/newtype 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. +-- +data AlgTyConParent = -- An ordinary type constructor has no parent. + NoParentTyCon + + -- Type constructors representing a class dictionary. + | ClassTyCon Class + + -- Type constructors representing an instances of a type + -- family. + | FamilyTyCon TyCon -- the type family + [Type] -- instance types + TyCon -- a *coercion* identifying + -- the representation type + -- with the type instance + +data SynTyConRhs + = OpenSynTyCon Kind -- Type family: *result* kind given + | 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] @@ -245,15 +295,23 @@ 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] + newtype T a = MkT (a -> a) -the NewTyCon for T will contain nt_co = CoT where CoT 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 k. +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]) :=: (forall t. T t) + 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]) @@ -261,10 +319,10 @@ which encodes as (TyConApp instCoercionTyCon [TyConApp CoT [], s]) But in GHC we instead make CoT into a new piece of type syntax (like instCoercionTyCon, symCoercionTyCon etc), which must always be saturated, but which encodes as - TyConAp CoT [s] + TyConApp CoT [s] In the vocabulary of the paper it's as if we had axiom declarations like - axiom CoT t : ([t] :=: T t) + axiom CoT t : T t :=: [t] Note [Newtype eta] ~~~~~~~~~~~~~~~~~~ @@ -359,40 +417,25 @@ 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 gadt_syn +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, + tyConArgPoss = Nothing, algTcStupidTheta = stupid, algTcRhs = rhs, algTcSelIds = sel_ids, - algTcClass = Nothing, + algTcParent = 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, - algTcGadtSyntax = False, -- Doesn't really matter - hasGenerics = False - } - +mkClassTyCon name kind tyvars rhs clas is_rec = + mkAlgTyCon name kind tyvars [] rhs [] (ClassTyCon clas) is_rec False False mkTupleTyCon name kind arity tyvars con boxed gen_info = TupleTyCon { @@ -410,13 +453,12 @@ 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 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 @@ -424,37 +466,36 @@ 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 rep + = mkPrimTyCon' name kind arity rep True -mkVoidPrimTyCon name kind arity arg_vrcs - = mkPrimTyCon' name kind arity arg_vrcs VoidRep True +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 rep + = mkPrimTyCon' name kind arity rep False -mkPrimTyCon' name kind arity arg_vrcs rep is_unlifted +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 tyvars rhs = SynTyCon { tyConName = name, tyConUnique = nameUnique name, tyConKind = kind, tyConArity = length tyvars, tyConTyVars = tyvars, - synTcRhs = rhs, - argVrcs = argvrcs + tyConArgPoss = Nothing, + synTcRhs = rhs } mkCoercionTyCon name arity kindRule @@ -502,8 +543,8 @@ isAlgTyCon (TupleTyCon {}) = True isAlgTyCon other = 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 @@ -511,25 +552,38 @@ isDataTyCon :: TyCon -> Bool -- unboxed tuples isDataTyCon tc@(AlgTyCon {algTcRhs = rhs}) = case rhs of + OpenDataTyCon -> True DataTyCon {} -> True + OpenNewTyCon -> False 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 isNewTyCon :: TyCon -> Bool -isNewTyCon (AlgTyCon {algTcRhs = NewTyCon {}}) = True -isNewTyCon other = False +isNewTyCon (AlgTyCon {algTcRhs = rhs}) = case rhs of + OpenNewTyCon -> True + NewTyCon {} -> True + _ -> False +isNewTyCon other = False + +-- This is an important refinement as typical newtype optimisations do *not* +-- hold for newtype families. Why? Given a type `T a', if T is a newtype +-- family, there is no unique right hand side by which `T a' can be replaced +-- by a cast. +-- +isClosedNewTyCon :: TyCon -> Bool +isClosedNewTyCon tycon = isNewTyCon tycon && not (isOpenTyCon tycon) 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 @@ -550,6 +604,25 @@ isEnumerationTyCon :: TyCon -> Bool isEnumerationTyCon (AlgTyCon {algTcRhs = DataTyCon { is_enum = res }}) = res isEnumerationTyCon other = False +isOpenTyCon :: TyCon -> Bool +isOpenTyCon (SynTyCon {synTcRhs = OpenSynTyCon _}) = True +isOpenTyCon (AlgTyCon {algTcRhs = OpenDataTyCon }) = True +isOpenTyCon (AlgTyCon {algTcRhs = OpenNewTyCon }) = True +isOpenTyCon _ = False + +assocTyConArgPoss_maybe :: TyCon -> Maybe [Int] +assocTyConArgPoss_maybe (AlgTyCon { tyConArgPoss = poss }) = poss +assocTyConArgPoss_maybe (SynTyCon { tyConArgPoss = poss }) = poss +assocTyConArgPoss_maybe _ = Nothing + +isTyConAssoc :: TyCon -> Bool +isTyConAssoc = isJust . assocTyConArgPoss_maybe + +setTyConArgPoss :: TyCon -> [Int] -> TyCon +setTyConArgPoss tc@(AlgTyCon {}) poss = tc { tyConArgPoss = Just poss } +setTyConArgPoss tc@(SynTyCon {}) poss = tc { tyConArgPoss = Just poss } +setTyConArgPoss tc _ = pprPanic "setTyConArgPoss" (ppr tc) + 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 @@ -590,13 +663,34 @@ isSuperKindTyCon :: TyCon -> Bool isSuperKindTyCon (SuperKindTyCon {}) = True isSuperKindTyCon other = False -isCoercionTyCon_maybe :: TyCon -> Maybe (Arity, [Type] -> Kind) +isCoercionTyCon_maybe :: TyCon -> Maybe (Arity, [Type] -> (Type,Type)) isCoercionTyCon_maybe (CoercionTyCon {tyConArity = ar, coKindFun = rule}) = Just (ar, rule) isCoercionTyCon_maybe other = Nothing +isCoercionTyCon :: TyCon -> Bool isCoercionTyCon (CoercionTyCon {}) = True isCoercionTyCon other = 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} @@ -613,30 +707,22 @@ tcExpandTyCon_maybe, coreExpandTyCon_maybe [Type]) -- Leftover args -- For the *typechecker* view, we expand synonyms only -tcExpandTyCon_maybe (SynTyCon {tyConTyVars = tvs, synTcRhs = rhs }) tys +tcExpandTyCon_maybe (SynTyCon {tyConTyVars = tvs, + synTcRhs = SynonymTyCon rhs }) tys = expand tvs rhs tys tcExpandTyCon_maybe other_tycon tys = Nothing --------------- -- 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 ---------------- --- For the *STG* view, we expand synonyms *and* non-recursive newtypes -stgExpandTyCon_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 -stgExpandTyCon_maybe tycon tys = coreExpandTyCon_maybe tycon tys ---------------- expand :: [TyVar] -> Type -- Template @@ -669,9 +755,11 @@ tyConDataCons_maybe (TupleTyCon {dataCon = con}) = Just [con] tyConDataCons_maybe other = Nothing tyConFamilySize :: TyCon -> Int -tyConFamilySize (AlgTyCon {algTcRhs = DataTyCon { data_cons = 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 (AlgTyCon {algTcRhs = OpenDataTyCon}) = 0 +tyConFamilySize (TupleTyCon {}) = 1 #ifdef DEBUG tyConFamilySize other = pprPanic "tyConFamilySize:" (ppr other) #endif @@ -695,9 +783,9 @@ newTyConRep :: TyCon -> ([TyVar], Type) newTyConRep (AlgTyCon {tyConTyVars = tvs, algTcRhs = NewTyCon { nt_rep = rep }}) = (tvs, rep) newTyConRep tycon = pprPanic "newTyConRep" (ppr tycon) -newTyConCo :: TyCon -> TyCon -newTyConCo (AlgTyCon {tyConTyVars = tvs, algTcRhs = NewTyCon { nt_co = co }}) = co -newTyConCo tycon = pprPanic "newTyConCo" (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 @@ -711,26 +799,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} @@ -746,12 +832,28 @@ 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 other_tycon = 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 other_tycon = Nothing + +isFamInstTyCon :: TyCon -> Bool +isFamInstTyCon (AlgTyCon {algTcParent = FamilyTyCon _ _ _ }) = True +isFamInstTyCon other_tycon = False + +tyConFamInst_maybe :: TyCon -> Maybe (TyCon, [Type]) +tyConFamInst_maybe (AlgTyCon {algTcParent = FamilyTyCon fam instTys _}) = + Just (fam, instTys) +tyConFamInst_maybe other_tycon = + Nothing + +tyConFamilyCoercion_maybe :: TyCon -> Maybe TyCon +tyConFamilyCoercion_maybe (AlgTyCon {algTcParent = FamilyTyCon _ _ coe}) = + Just coe +tyConFamilyCoercion_maybe other_tycon = + Nothing \end{code}