X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypes%2FTyCon.lhs;h=958a0cb8a2b39d579ee4bd46b6d2f4d38539773e;hb=0e73a9fbdc8555ffb948cfd72401a700b122c395;hp=a7b0594bcfc5de6d21e5b72f4f96f4a011d29307;hpb=c2a8617aad5a6fb29e4857771f785e5d5fe68b54;p=ghc-hetmet.git diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs index a7b0594..958a0cb 100644 --- a/compiler/types/TyCon.lhs +++ b/compiler/types/TyCon.lhs @@ -8,7 +8,7 @@ The @TyCon@ datatype \begin{code} module TyCon( -- * Main TyCon data types - TyCon, FieldLabel, + TyCon, FieldLabel, CoTyConKindChecker, AlgTyConRhs(..), visibleDataCons, TyConParent(..), @@ -20,13 +20,14 @@ module TyCon( mkClassTyCon, mkFunTyCon, mkPrimTyCon, - mkVoidPrimTyCon, + mkKindTyCon, mkLiftedPrimTyCon, mkTupleTyCon, mkSynTyCon, mkSuperKindTyCon, mkCoercionTyCon, mkForeignTyCon, + mkAnyTyCon, -- ** Predicates on TyCons isAlgTyCon, @@ -35,9 +36,9 @@ module TyCon( isPrimTyCon, isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, isSynTyCon, isClosedSynTyCon, isOpenSynTyCon, - isSuperKindTyCon, + isSuperKindTyCon, isDecomposableTyCon, isCoercionTyCon, isCoercionTyCon_maybe, - isForeignTyCon, + isForeignTyCon, isAnyTyCon, tyConHasKind, isInjectiveTyCon, isDataTyCon, isProductTyCon, isEnumerationTyCon, @@ -103,7 +104,7 @@ import Data.List( elemIndex ) %************************************************************************ \begin{code} --- | Represents type constructors. Type constructors are introduced by things such as: +-- | TyCons represent type constructors. Type constructors are introduced by things such as: -- -- 1) Data declarations: @data Foo = ...@ creates the @Foo@ type constructor of kind @*@ -- @@ -123,7 +124,7 @@ data TyCon FunTyCon { tyConUnique :: Unique, tyConName :: Name, - tyConKind :: Kind, + tc_kind :: Kind, tyConArity :: Arity } @@ -132,7 +133,7 @@ data TyCon | AlgTyCon { tyConUnique :: Unique, tyConName :: Name, - tyConKind :: Kind, + tc_kind :: Kind, tyConArity :: Arity, tyConTyVars :: [TyVar], -- ^ The type variables used in the type constructor. @@ -150,6 +151,7 @@ data TyCon -- that doesn't mean it's a true GADT; only that the "where" -- form was used. This field is used only to guide -- pretty-printing + algTcStupidTheta :: [PredType], -- ^ The \"stupid theta\" for the data type (always empty for GADTs). -- A \"stupid theta\" is the context to the left of an algebraic type -- declaration, e.g. @Eq a@ in the declaration @data Eq a => T a ...@. @@ -169,7 +171,7 @@ data TyCon | TupleTyCon { tyConUnique :: Unique, tyConName :: Name, - tyConKind :: Kind, + tc_kind :: Kind, tyConArity :: Arity, tyConBoxed :: Boxity, tyConTyVars :: [TyVar], @@ -181,7 +183,7 @@ data TyCon | SynTyCon { tyConUnique :: Unique, tyConName :: Name, - tyConKind :: Kind, + tc_kind :: Kind, tyConArity :: Arity, tyConTyVars :: [TyVar], -- Bound tyvars @@ -197,33 +199,44 @@ data TyCon | PrimTyCon { tyConUnique :: Unique, tyConName :: Name, - tyConKind :: Kind, - 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 - -- boxed (represented by pointers). This 'PrimRep' holds - -- that information - - isUnLifted :: Bool, -- ^ Most primitive tycons are unlifted (may not contain bottom) - -- but foreign-imported ones may be lifted - tyConExtName :: Maybe FastString -- ^ @Just e@ for foreign-imported types, holds the name of the imported thing + tc_kind :: Kind, + 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 + -- boxed (represented by pointers). This 'PrimRep' holds + -- that information. + -- Only relevant if tc_kind = * + + isUnLifted :: Bool, -- ^ Most primitive tycons are unlifted (may not contain bottom) + -- but foreign-imported ones may be lifted + + tyConExtName :: Maybe FastString -- ^ @Just e@ for foreign-imported types, + -- holds the name of the imported thing } -- | Type coercions, such as @(~)@, @sym@, @trans@, @left@ and @right@. - -- INVARIANT: coercions are always fully applied + -- INVARIANT: Coercion TyCons are always fully applied + -- But note that a CoercionTyCon can be over-saturated in a type. + -- E.g. (sym g1) Int will be represented as (TyConApp sym [g1,Int]) | CoercionTyCon { tyConUnique :: Unique, tyConName :: Name, tyConArity :: Arity, - coKindFun :: [Type] -> (Type,Type) - -- ^ Function that when given a list of the type arguments to the 'TyCon' - -- constructs the types that the resulting coercion relates. - -- - -- INVARIANT: 'coKindFun' is always applied to exactly 'tyConArity' args - -- E.g. for @trans (c1 :: ta=tb) (c2 :: tb=tc)@, the 'coKindFun' returns - -- the kind as a pair of types: @(ta, tc)@ + coKindFun :: CoTyConKindChecker + } + + -- | Any types. Like tuples, this is a potentially-infinite family of TyCons + -- one for each distinct Kind. They have no values at all. + -- Because there are infinitely many of them (like tuples) they are + -- defined in GHC.Prim and have names like "Any(*->*)". + -- Their Unique is derived from the OccName. + -- See Note [Any types] in TysPrim + | AnyTyCon { + tyConUnique :: Unique, + tyConName :: Name, + tc_kind :: Kind -- Never = *; that is done via PrimTyCon + -- See Note [Any types] in TysPrim } -- | Super-kinds. These are "kinds-of-kinds" and are never seen in Haskell source programs. @@ -237,6 +250,23 @@ data TyCon tyConName :: Name } +type CoTyConKindChecker = forall m. Monad m => CoTyConKindCheckerFun m + +type CoTyConKindCheckerFun m + = (Type -> m Kind) -- Kind checker for types + -> (Type -> m (Type,Type)) -- and for coercions + -> Bool -- True => apply consistency checks + -> [Type] -- Exactly right number of args + -> m (Type, Type) -- Kind of this application + + -- ^ Function that when given a list of the type arguments to the 'TyCon' + -- constructs the types that the resulting coercion relates. + -- Returns Nothing if ill-kinded. + -- + -- INVARIANT: 'coKindFun' is always applied to exactly 'tyConArity' args + -- E.g. for @trans (c1 :: ta=tb) (c2 :: tb=tc)@, the 'coKindFun' returns + -- the kind as a pair of types: @(ta, tc)@ + -- | Names of the fields in an algebraic record type type FieldLabel = Name @@ -561,7 +591,7 @@ mkFunTyCon name kind = FunTyCon { tyConUnique = nameUnique name, tyConName = name, - tyConKind = kind, + tc_kind = kind, tyConArity = 2 } @@ -581,7 +611,7 @@ mkAlgTyCon name kind tyvars stupid rhs parent is_rec gen_info gadt_syn = AlgTyCon { tyConName = name, tyConUnique = nameUnique name, - tyConKind = kind, + tc_kind = kind, tyConArity = length tyvars, tyConTyVars = tyvars, algTcStupidTheta = stupid, @@ -609,7 +639,7 @@ mkTupleTyCon name kind arity tyvars con boxed gen_info = TupleTyCon { tyConUnique = nameUnique name, tyConName = name, - tyConKind = kind, + tc_kind = kind, tyConArity = arity, tyConBoxed = boxed, tyConTyVars = tyvars, @@ -630,7 +660,7 @@ mkForeignTyCon name ext_name kind arity = PrimTyCon { tyConName = name, tyConUnique = nameUnique name, - tyConKind = kind, + tc_kind = kind, tyConArity = arity, primTyConRep = PtrRep, -- they all do isUnLifted = False, @@ -643,10 +673,10 @@ mkPrimTyCon :: Name -> Kind -> Arity -> PrimRep -> TyCon mkPrimTyCon name kind arity rep = mkPrimTyCon' name kind arity rep True --- | Create the special void 'TyCon' which is unlifted and has 'VoidRep' -mkVoidPrimTyCon :: Name -> Kind -> Arity -> TyCon -mkVoidPrimTyCon name kind arity - = mkPrimTyCon' name kind arity VoidRep True +-- | Kind constructors +mkKindTyCon :: Name -> Kind -> TyCon +mkKindTyCon name kind + = mkPrimTyCon' name kind 0 VoidRep True -- | Create a lifted primitive 'TyCon' such as @RealWorld@ mkLiftedPrimTyCon :: Name -> Kind -> Arity -> PrimRep -> TyCon @@ -658,7 +688,7 @@ mkPrimTyCon' name kind arity rep is_unlifted = PrimTyCon { tyConName = name, tyConUnique = nameUnique name, - tyConKind = kind, + tc_kind = kind, tyConArity = arity, primTyConRep = rep, isUnLifted = is_unlifted, @@ -671,7 +701,7 @@ mkSynTyCon name kind tyvars rhs parent = SynTyCon { tyConName = name, tyConUnique = nameUnique name, - tyConKind = kind, + tc_kind = kind, tyConArity = length tyvars, tyConTyVars = tyvars, synTcRhs = rhs, @@ -679,15 +709,29 @@ mkSynTyCon name kind tyvars rhs parent } -- | Create a coercion 'TyCon' -mkCoercionTyCon :: Name -> Arity -> ([Type] -> (Type,Type)) -> TyCon -mkCoercionTyCon name arity kindRule +mkCoercionTyCon :: Name -> Arity + -> CoTyConKindChecker + -> TyCon +mkCoercionTyCon name arity rule_fn = CoercionTyCon { - tyConName = name, + tyConName = name, tyConUnique = nameUnique name, - tyConArity = arity, - coKindFun = kindRule + tyConArity = arity, +#ifdef DEBUG + coKindFun = \ ty co fail args -> + ASSERT2( length args == arity, ppr name ) + rule_fn ty co fail args +#else + coKindFun = rule_fn +#endif } +mkAnyTyCon :: Name -> Kind -> TyCon +mkAnyTyCon name kind + = AnyTyCon { tyConName = name, + tc_kind = kind, + tyConUnique = nameUnique name } + -- | Create a super-kind 'TyCon' mkSuperKindTyCon :: Name -> TyCon -- Super kinds always have arity zero mkSuperKindTyCon name @@ -755,6 +799,11 @@ isNewTyCon :: TyCon -> Bool isNewTyCon (AlgTyCon {algTcRhs = NewTyCon {}}) = True isNewTyCon _ = False +tyConHasKind :: TyCon -> Bool +tyConHasKind (SuperKindTyCon {}) = False +tyConHasKind (CoercionTyCon {}) = False +tyConHasKind _ = True + -- | Take a 'TyCon' apart into the 'TyVar's it scopes over, the 'Type' it expands -- into, and (possibly) a coercion from the representation type to the @newtype@. -- Returns @Nothing@ if this is not possible. @@ -800,6 +849,13 @@ isClosedSynTyCon tycon = isSynTyCon tycon && not (isOpenTyCon tycon) isOpenSynTyCon :: TyCon -> Bool isOpenSynTyCon tycon = isSynTyCon tycon && isOpenTyCon tycon +isDecomposableTyCon :: TyCon -> Bool +-- True iff we can deocmpose (T a b c) into ((T a b) c) +-- Specifically NOT true of synonyms (open and otherwise) and coercions +isDecomposableTyCon (SynTyCon {}) = False +isDecomposableTyCon (CoercionTyCon {}) = False +isDecomposableTyCon _other = True + -- | Is this an algebraic 'TyCon' declared with the GADT syntax? isGadtSyntaxTyCon :: TyCon -> Bool isGadtSyntaxTyCon (AlgTyCon { algTcGadtSyntax = res }) = res @@ -808,6 +864,7 @@ isGadtSyntaxTyCon _ = False -- | Is this an algebraic 'TyCon' which is just an enumeration of values? isEnumerationTyCon :: TyCon -> Bool isEnumerationTyCon (AlgTyCon {algTcRhs = DataTyCon { is_enum = res }}) = res +isEnumerationTyCon (TupleTyCon {tyConArity = arity}) = arity == 0 isEnumerationTyCon _ = False -- | Is this a 'TyCon', synonym or otherwise, that may have further instances appear? @@ -907,10 +964,15 @@ isSuperKindTyCon :: TyCon -> Bool isSuperKindTyCon (SuperKindTyCon {}) = True isSuperKindTyCon _ = False +-- | Is this an AnyTyCon? +isAnyTyCon :: TyCon -> Bool +isAnyTyCon (AnyTyCon {}) = True +isAnyTyCon _ = False + -- | Attempt to pull a 'TyCon' apart into the arity and 'coKindFun' of -- a coercion 'TyCon'. Returns @Nothing@ if the 'TyCon' is not of the -- appropriate kind -isCoercionTyCon_maybe :: TyCon -> Maybe (Arity, [Type] -> (Type,Type)) +isCoercionTyCon_maybe :: Monad m => TyCon -> Maybe (Arity, CoTyConKindCheckerFun m) isCoercionTyCon_maybe (CoercionTyCon {tyConArity = ar, coKindFun = rule}) = Just (ar, rule) isCoercionTyCon_maybe _ = Nothing @@ -995,6 +1057,15 @@ tyConHasGenerics (AlgTyCon {hasGenerics = hg}) = hg tyConHasGenerics (TupleTyCon {hasGenerics = hg}) = hg tyConHasGenerics _ = False -- Synonyms +tyConKind :: TyCon -> Kind +tyConKind (FunTyCon { tc_kind = k }) = k +tyConKind (AlgTyCon { tc_kind = k }) = k +tyConKind (TupleTyCon { tc_kind = k }) = k +tyConKind (SynTyCon { tc_kind = k }) = k +tyConKind (PrimTyCon { tc_kind = k }) = k +tyConKind (AnyTyCon { tc_kind = k }) = k +tyConKind tc = pprPanic "tyConKind" (ppr tc) + -- | As 'tyConDataCons_maybe', but returns the empty list of constructors if no constructors -- could be found tyConDataCons :: TyCon -> [DataCon] @@ -1023,8 +1094,9 @@ tyConFamilySize other = pprPanic "tyConFamilySize:" (ppr other) -- | Extract an 'AlgTyConRhs' with information about data constructors from an algebraic or tuple -- 'TyCon'. Panics for any other sort of 'TyCon' algTyConRhs :: TyCon -> AlgTyConRhs -algTyConRhs (AlgTyCon {algTcRhs = rhs}) = rhs -algTyConRhs (TupleTyCon {dataCon = con}) = DataTyCon { data_cons = [con], is_enum = False } +algTyConRhs (AlgTyCon {algTcRhs = rhs}) = rhs +algTyConRhs (TupleTyCon {dataCon = con, tyConArity = arity}) + = DataTyCon { data_cons = [con], is_enum = arity == 0 } algTyConRhs other = pprPanic "algTyConRhs" (ppr other) \end{code} @@ -1097,13 +1169,10 @@ synTyConResKind tycon = pprPanic "synTyConResKind" (ppr tycon) -- has more than one constructor, or represents a primitive or function type constructor then -- @Nothing@ is returned. In any other case, the function panics tyConSingleDataCon_maybe :: TyCon -> Maybe DataCon -tyConSingleDataCon_maybe (AlgTyCon {algTcRhs = DataTyCon {data_cons = [c] }}) = Just c -tyConSingleDataCon_maybe (AlgTyCon {algTcRhs = NewTyCon { data_con = c }}) = Just c -tyConSingleDataCon_maybe (AlgTyCon {}) = Nothing -tyConSingleDataCon_maybe (TupleTyCon {dataCon = con}) = Just con -tyConSingleDataCon_maybe (PrimTyCon {}) = Nothing -tyConSingleDataCon_maybe (FunTyCon {}) = Nothing -- case at funty -tyConSingleDataCon_maybe tc = pprPanic "tyConSingleDataCon_maybe: unexpected tycon " $ ppr tc +tyConSingleDataCon_maybe (TupleTyCon {dataCon = c}) = Just c +tyConSingleDataCon_maybe (AlgTyCon {algTcRhs = DataTyCon { data_cons = [c] }}) = Just c +tyConSingleDataCon_maybe (AlgTyCon {algTcRhs = NewTyCon { data_con = c }}) = Just c +tyConSingleDataCon_maybe _ = Nothing \end{code} \begin{code}