X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypes%2FTyCon.lhs;h=40cfa069b7a68f737d6ac27502b0e03166dc2287;hb=feb584b7ffd49827ff2b6e716965cfdcd344570e;hp=5ab8458d9f819f845e1f49c0969d318b4d23d3be;hpb=e8a591c1a3dbdeccec2dd2aacccd7435004b0d51;p=ghc-hetmet.git diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs index 5ab8458..40cfa06 100644 --- a/compiler/types/TyCon.lhs +++ b/compiler/types/TyCon.lhs @@ -10,12 +10,13 @@ module TyCon( PrimRep(..), tyConPrimRep, - AlgTyConRhs(..), visibleDataCons, + AlgTyConRhs(..), visibleDataCons, AlgTyConParent(..), SynTyConRhs(..), isFunTyCon, isUnLiftedTyCon, isProductTyCon, isAlgTyCon, isDataTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, - isEnumerationTyCon, isGadtSyntaxTyCon, isOpenTyCon, + isEnumerationTyCon, isGadtSyntaxTyCon, isOpenTyCon, isAssocTyCon, + makeTyConAssoc, isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, tupleTyConBoxity, isRecursiveTyCon, newTyConRep, newTyConRhs, newTyConCo, isHiBootTyCon, isSuperKindTyCon, @@ -47,6 +48,7 @@ module TyCon( tyConStupidTheta, tyConArity, isClassTyCon, tyConClass_maybe, + isFamInstTyCon, tyConFamInst_maybe, tyConFamilyCoercion_maybe, synTyConDefn, synTyConRhs, synTyConType, synTyConResKind, tyConExtName, -- External name for foreign types @@ -93,11 +95,14 @@ data TyCon tyConName :: Name, tyConKind :: Kind, tyConArity :: Arity, - + tyConTyVars :: [TyVar], -- Scopes over (a) the algTcStupidTheta -- (b) the cached types in -- algTyConRhs.NewTyCon -- But not over the data constructors + + tyConIsAssoc :: Bool, -- for families: declared in a class? + algTcSelIds :: [Id], -- Its record selectors (empty if none) algTcGadtSyntax :: Bool, -- True <=> the data type was declared using GADT syntax @@ -115,8 +120,9 @@ data TyCon 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 { @@ -131,13 +137,14 @@ data TyCon } | SynTyCon { - tyConUnique :: Unique, - tyConName :: Name, - tyConKind :: Kind, - tyConArity :: Arity, - - tyConTyVars :: [TyVar], -- Bound tyvars - synTcRhs :: SynTyConRhs -- Expanded type in here + tyConUnique :: Unique, + tyConName :: Name, + tyConKind :: Kind, + tyConArity :: Arity, + + tyConTyVars :: [TyVar], -- Bound tyvars + tyConIsAssoc :: Bool, -- for families: declared in a class? + synTcRhs :: SynTyConRhs -- Expanded type in here } | PrimTyCon { -- Primitive types; cannot be defined in Haskell @@ -235,6 +242,25 @@ 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 @@ -371,38 +397,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 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, + tyConIsAssoc = False, algTcStupidTheta = stupid, algTcRhs = rhs, algTcSelIds = sel_ids, - algTcClass = Nothing, + algTcParent = parent, algTcRec = is_rec, algTcGadtSyntax = gadt_syn, hasGenerics = gen_info } -mkClassTyCon name kind tyvars rhs clas is_rec - = AlgTyCon { - tyConName = name, - tyConUnique = nameUnique name, - tyConKind = kind, - tyConArity = length tyvars, - tyConTyVars = tyvars, - 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 { @@ -461,6 +474,7 @@ mkSynTyCon name kind tyvars rhs tyConKind = kind, tyConArity = length tyvars, tyConTyVars = tyvars, + tyConIsAssoc = False, synTcRhs = rhs } @@ -566,6 +580,16 @@ isOpenTyCon (AlgTyCon {algTcRhs = OpenDataTyCon }) = True isOpenTyCon (AlgTyCon {algTcRhs = OpenNewTyCon }) = True isOpenTyCon _ = False +isAssocTyCon :: TyCon -> Bool +isAssocTyCon (AlgTyCon { tyConIsAssoc = isAssoc }) = isAssoc +isAssocTyCon (SynTyCon { tyConIsAssoc = isAssoc }) = isAssoc +isAssocTyCon _ = False + +makeTyConAssoc :: TyCon -> TyCon +makeTyConAssoc tc@(AlgTyCon {}) = tc { tyConIsAssoc = True } +makeTyConAssoc tc@(SynTyCon {}) = tc { tyConIsAssoc = True } +makeTyConAssoc tc = pprPanic "makeTyConAssoc" (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 @@ -677,9 +701,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 @@ -752,12 +778,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 ther_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 ther_tycon = + Nothing + +tyConFamilyCoercion_maybe :: TyCon -> Maybe TyCon +tyConFamilyCoercion_maybe (AlgTyCon {algTcParent = FamilyTyCon _ _ coe}) = + Just coe +tyConFamilyCoercion_maybe ther_tycon = + Nothing \end{code}