X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypes%2FTyCon.lhs;h=5ab8458d9f819f845e1f49c0969d318b4d23d3be;hb=bb106f283663e9c16a4c72ec9ca57109ae57a0ed;hp=fcd32c6974bce5bed8fb4cfca1ed0574daa1e0c6;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1;p=ghc-hetmet.git diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs index fcd32c6..5ab8458 100644 --- a/compiler/types/TyCon.lhs +++ b/compiler/types/TyCon.lhs @@ -5,19 +5,21 @@ \begin{code} module TyCon( - TyCon, ArgVrcs, FieldLabel, + TyCon, FieldLabel, PrimRep(..), tyConPrimRep, AlgTyConRhs(..), visibleDataCons, + SynTyConRhs(..), isFunTyCon, isUnLiftedTyCon, isProductTyCon, isAlgTyCon, isDataTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, - isEnumerationTyCon, + isEnumerationTyCon, isGadtSyntaxTyCon, isOpenTyCon, isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, tupleTyConBoxity, - isRecursiveTyCon, newTyConRep, newTyConRhs, - isHiBootTyCon, + isRecursiveTyCon, newTyConRep, newTyConRhs, newTyConCo, + isHiBootTyCon, isSuperKindTyCon, + isCoercionTyCon_maybe, isCoercionTyCon, tcExpandTyCon_maybe, coreExpandTyCon_maybe, @@ -29,21 +31,23 @@ 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, + synTyConDefn, synTyConRhs, synTyConType, synTyConResKind, tyConExtName, -- External name for foreign types maybeTyConSingleCon, @@ -54,16 +58,11 @@ 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, Coercion, 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(..) ) @@ -95,20 +94,23 @@ 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 - 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) @@ -117,13 +119,34 @@ data TyCon -- Just cl if this tycon came from a class declaration } + | 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 + } + | 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, primTyConRep :: PrimRep, -- Many primitive tycons are unboxed, but some are @@ -134,41 +157,35 @@ data TyCon tyConExtName :: Maybe FastString -- Just xx for foreign-imported types } - | TupleTyCon { + | CoercionTyCon { -- E.g. (:=:), sym, trans, left, right + -- INVARIANT: coercions are always fully applied tyConUnique :: Unique, - tyConName :: Name, - tyConKind :: Kind, + tyConName :: Name, tyConArity :: Arity, - tyConBoxed :: Boxity, - tyConTyVars :: [TyVar], - dataCon :: DataCon, - hasGenerics :: Bool + coKindFun :: [Type] -> Kind + } + + | SuperKindTyCon { -- Super Kinds, TY (box) and CO (diamond). + -- They have no kind; and arity zero + tyConUnique :: Unique, + tyConName :: Name } - | SynTyCon { - tyConUnique :: Unique, - tyConName :: Name, - tyConKind :: Kind, - tyConArity :: Arity, +type KindCon = TyCon - 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 - } +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 @@ -183,6 +200,12 @@ data AlgTyConRhs nt_rhs :: Type, -- Cached: the argument type of the constructor -- = the representation type of the tycon + -- The free tyvars of this type are the tyConTyVars + + 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) , -- The same again, but this time eta-reduced @@ -207,10 +230,54 @@ 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] +~~~~~~~~~~~~~~~~~~~~~~~~ + +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 +(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 @@ -304,35 +371,35 @@ 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 tyvars stupid rhs sel_ids 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, algTcRec = is_rec, + algTcGadtSyntax = gadt_syn, hasGenerics = gen_info } -mkClassTyCon name kind tyvars argvrcs rhs clas is_rec +mkClassTyCon name kind tyvars 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 } @@ -353,13 +420,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 @@ -367,35 +433,51 @@ 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 + = 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 + synTcRhs = rhs + } + +mkCoercionTyCon name arity kindRule + = CoercionTyCon { + tyConName = name, + tyConUnique = nameUnique name, + tyConArity = arity, + coKindFun = kindRule } + +-- Super kinds always have arity zero +mkSuperKindTyCon name + = SuperKindTyCon { + tyConName = name, + tyConUnique = nameUnique name + } \end{code} \begin{code} @@ -436,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) @@ -452,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 @@ -467,10 +552,20 @@ isSynTyCon :: TyCon -> Bool isSynTyCon (SynTyCon {}) = True isSynTyCon _ = False +isGadtSyntaxTyCon :: TyCon -> Bool +isGadtSyntaxTyCon (AlgTyCon { algTcGadtSyntax = res }) = res +isGadtSyntaxTyCon other = False + 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 @@ -506,6 +601,18 @@ isForeignTyCon :: TyCon -> Bool -- isForeignTyCon identifies foreign-imported type constructors isForeignTyCon (PrimTyCon {tyConExtName = Just _}) = True isForeignTyCon other = False + +isSuperKindTyCon :: TyCon -> Bool +isSuperKindTyCon (SuperKindTyCon {}) = True +isSuperKindTyCon other = False + +isCoercionTyCon_maybe :: TyCon -> Maybe (Arity, [Type] -> Kind) +isCoercionTyCon_maybe (CoercionTyCon {tyConArity = ar, coKindFun = rule}) + = Just (ar, rule) +isCoercionTyCon_maybe other = Nothing + +isCoercionTyCon (CoercionTyCon {}) = True +isCoercionTyCon other = False \end{code} @@ -522,20 +629,23 @@ 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 *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 @@ -593,6 +703,10 @@ 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) + tyConPrimRep :: TyCon -> PrimRep tyConPrimRep (PrimTyCon {primTyConRep = rep}) = rep tyConPrimRep tc = ASSERT(not (isUnboxedTupleTyCon tc)) PtrRep @@ -605,26 +719,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}