X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypes%2FTyCon.lhs;h=5ab8458d9f819f845e1f49c0969d318b4d23d3be;hb=bb106f283663e9c16a4c72ec9ca57109ae57a0ed;hp=fab15fc6821126e025e51a0db6b7e4d99a0fd8ae;hpb=3e0b6b2542d8464bfba365b97a6e4b95c3885f10;p=ghc-hetmet.git diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs index fab15fc..5ab8458 100644 --- a/compiler/types/TyCon.lhs +++ b/compiler/types/TyCon.lhs @@ -11,16 +11,17 @@ module TyCon( tyConPrimRep, AlgTyConRhs(..), visibleDataCons, + SynTyConRhs(..), isFunTyCon, isUnLiftedTyCon, isProductTyCon, isAlgTyCon, isDataTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, - isEnumerationTyCon, isGadtSyntaxTyCon, + isEnumerationTyCon, isGadtSyntaxTyCon, isOpenTyCon, isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, tupleTyConBoxity, isRecursiveTyCon, newTyConRep, newTyConRhs, newTyConCo, isHiBootTyCon, isSuperKindTyCon, isCoercionTyCon_maybe, isCoercionTyCon, - tcExpandTyCon_maybe, coreExpandTyCon_maybe, stgExpandTyCon_maybe, + tcExpandTyCon_maybe, coreExpandTyCon_maybe, makeTyConAbstract, isAbstractTyCon, @@ -46,7 +47,7 @@ module TyCon( tyConStupidTheta, tyConArity, isClassTyCon, tyConClass_maybe, - synTyConDefn, synTyConRhs, + synTyConDefn, synTyConRhs, synTyConType, synTyConResKind, tyConExtName, -- External name for foreign types maybeTyConSingleCon, @@ -93,10 +94,11 @@ data TyCon 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 -- But not over the data constructors - 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" @@ -107,8 +109,8 @@ 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) @@ -135,9 +137,7 @@ data TyCon 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. + synTcRhs :: SynTyConRhs -- Expanded type in here } | PrimTyCon { -- Primitive types; cannot be defined in Haskell @@ -183,6 +183,9 @@ data AlgTyConRhs -- 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 @@ -199,8 +202,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) , @@ -226,8 +230,16 @@ data AlgTyConRhs visibleDataCons :: AlgTyConRhs -> [DataCon] visibleDataCons AbstractTyCon = [] +visibleDataCons OpenDataTyCon = [] +visibleDataCons OpenNewTyCon = [] visibleDataCons (DataTyCon{ data_cons = cs }) = cs visibleDataCons (NewTyCon{ data_con = c }) = [c] + +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] @@ -237,15 +249,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 -> +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] -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. +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]) @@ -253,10 +273,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] ~~~~~~~~~~~~~~~~~~ @@ -498,7 +518,9 @@ 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) @@ -514,9 +536,10 @@ isProductTyCon :: TyCon -> Bool -- 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 @@ -537,6 +560,12 @@ 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 + 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 @@ -600,30 +629,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 @@ -682,7 +703,7 @@ 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 :: TyCon -> Maybe TyCon newTyConCo (AlgTyCon {tyConTyVars = tvs, algTcRhs = NewTyCon { nt_co = co }}) = co newTyConCo tycon = pprPanic "newTyConCo" (ppr tycon) @@ -700,11 +721,22 @@ tyConStupidTheta tycon = pprPanic "tyConStupidTheta" (ppr tycon) \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}