X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypes%2FTyCon.lhs;h=723a7904f88d63cbf8cc1ce1bf7e6d4e799aa3ba;hb=d76c18e05f6366c23144624b696a02fbaa6d26e8;hp=7fcc52b0d66aab480d8fe3fca2ced43c1e851857;hpb=80c89b80c355b2aaebcd53330e6c6170c3f05aca;p=ghc-hetmet.git diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs index 7fcc52b..723a790 100644 --- a/compiler/types/TyCon.lhs +++ b/compiler/types/TyCon.lhs @@ -14,10 +14,12 @@ module TyCon( SynTyConRhs(..), isFunTyCon, isUnLiftedTyCon, isProductTyCon, - isAlgTyCon, isDataTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, + 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, @@ -47,7 +49,8 @@ module TyCon( tyConStupidTheta, tyConArity, isClassTyCon, tyConClass_maybe, - isFamInstTyCon, tyConFamily_maybe, + isFamInstTyCon, tyConFamInst_maybe, tyConFamilyCoercion_maybe, + tyConFamInstIndex, synTyConDefn, synTyConRhs, synTyConType, synTyConResKind, tyConExtName, -- External name for foreign types @@ -67,6 +70,7 @@ import Class ( Class ) import BasicTypes ( Arity, RecFlag(..), Boxity(..), isBoxed ) import Name ( Name, nameUnique, NamedThing(getName) ) import PrelNames ( Unique, Uniquable(..) ) +import Maybe ( isJust ) import Maybes ( orElse ) import Outputable import FastString @@ -94,11 +98,19 @@ 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 + + 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. + algTcSelIds :: [Id], -- Its record selectors (empty if none) algTcGadtSyntax :: Bool, -- True <=> the data type was declared using GADT syntax @@ -133,13 +145,21 @@ 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 + + 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 @@ -237,9 +257,27 @@ visibleDataCons OpenNewTyCon = [] visibleDataCons (DataTyCon{ data_cons = cs }) = cs visibleDataCons (NewTyCon{ data_con = c }) = [c] -data AlgTyConParent = NoParentTyCon -- ordinary data type - | ClassTyCon Class -- class dictionary - | FamilyTyCon TyCon -- instance of type family +-- 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 + Int -- index to generate unique + -- name (needed here to put + -- into iface) data SynTyConRhs = OpenSynTyCon Kind -- Type family: *result* kind given @@ -384,6 +422,7 @@ mkAlgTyCon name kind tyvars stupid rhs sel_ids parent is_rec gen_info gadt_syn tyConKind = kind, tyConArity = length tyvars, tyConTyVars = tyvars, + tyConArgPoss = Nothing, algTcStupidTheta = stupid, algTcRhs = rhs, algTcSelIds = sel_ids, @@ -453,6 +492,7 @@ mkSynTyCon name kind tyvars rhs tyConKind = kind, tyConArity = length tyvars, tyConTyVars = tyvars, + tyConArgPoss = Nothing, synTcRhs = rhs } @@ -515,13 +555,23 @@ isDataTyCon tc@(AlgTyCon {algTcRhs = rhs}) OpenNewTyCon -> False NewTyCon {} -> False AbstractTyCon -> pprPanic "isDataTyCon" (ppr tc) - 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 @@ -558,6 +608,19 @@ 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 @@ -697,9 +760,9 @@ newTyConRep :: TyCon -> ([TyVar], Type) newTyConRep (AlgTyCon {tyConTyVars = tvs, algTcRhs = NewTyCon { nt_rep = rep }}) = (tvs, rep) newTyConRep tycon = pprPanic "newTyConRep" (ppr tycon) -newTyConCo :: TyCon -> Maybe 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 @@ -754,12 +817,25 @@ 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 - -tyConFamily_maybe :: TyCon -> Maybe TyCon -tyConFamily_maybe (AlgTyCon {algTcParent = FamilyTyCon fam}) = Just fam -tyConFamily_maybe ther_tycon = Nothing +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 + +tyConFamInstIndex :: TyCon -> Int +tyConFamInstIndex (AlgTyCon {algTcParent = FamilyTyCon _ _ _ index}) = index +tyConFamInstIndex _ = + panic "tyConFamInstIndex" \end{code}