X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypes%2FTyCon.lhs;h=915207621ff2a6652a9110156efff7d1930f5d48;hb=7867349134ee26e4276ff04ace7c815c1de43338;hp=12f3935b24a0938750f87be7992abcf3fb49117e;hpb=628c40615eaa124605ad8f380296059bd71182ce;p=ghc-hetmet.git diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs index 12f3935..9152076 100644 --- a/compiler/types/TyCon.lhs +++ b/compiler/types/TyCon.lhs @@ -11,10 +11,11 @@ module TyCon( TyCon, FieldLabel, AlgTyConRhs(..), visibleDataCons, - TyConParent(..), + TyConParent(..), isNoParent, SynTyConRhs(..), - CoTyConDesc(..), - AssocFamilyPermutation, + + -- ** Coercion axiom constructors + CoAxiom(..), coAxiomName, coAxiomArity, -- ** Constructing TyCons mkAlgTyCon, @@ -26,7 +27,6 @@ module TyCon( mkTupleTyCon, mkSynTyCon, mkSuperKindTyCon, - mkCoercionTyCon, mkForeignTyCon, mkAnyTyCon, @@ -36,20 +36,20 @@ module TyCon( isFunTyCon, isPrimTyCon, isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, - isSynTyCon, isClosedSynTyCon, isOpenSynTyCon, + isSynTyCon, isClosedSynTyCon, isSuperKindTyCon, isDecomposableTyCon, - isCoercionTyCon, isCoercionTyCon_maybe, isForeignTyCon, isAnyTyCon, tyConHasKind, isInjectiveTyCon, isDataTyCon, isProductTyCon, isEnumerationTyCon, - isNewTyCon, isAbstractTyCon, isOpenTyCon, + isNewTyCon, isAbstractTyCon, + isFamilyTyCon, isSynFamilyTyCon, isDataFamilyTyCon, isUnLiftedTyCon, isGadtSyntaxTyCon, isTyConAssoc, isRecursiveTyCon, isHiBootTyCon, - isImplicitTyCon, tyConHasGenerics, + isImplicitTyCon, -- ** Extracting information out of TyCons tyConName, @@ -60,20 +60,19 @@ module TyCon( tyConFamilySize, tyConStupidTheta, tyConArity, + tyConParent, tyConClass_maybe, - tyConFamInst_maybe, tyConFamilyCoercion_maybe, - synTyConDefn, synTyConRhs, synTyConType, synTyConResKind, - tyConExtName, -- External name for foreign types + tyConFamInst_maybe, tyConFamilyCoercion_maybe,tyConFamInstSig_maybe, + synTyConDefn, synTyConRhs, synTyConType, + tyConExtName, -- External name for foreign types algTyConRhs, newTyConRhs, newTyConEtadRhs, unwrapNewTyCon_maybe, - assocTyConArgPoss_maybe, - tupleTyConBoxity, + tupleTyConBoxity, tupleTyConArity, -- ** Manipulating TyCons tcExpandTyCon_maybe, coreExpandTyCon_maybe, makeTyConAbstract, - newTyConCo_maybe, - setTyConArgPoss, + newTyConCo, newTyConCo_maybe, -- * Primitive representations of Types PrimRep(..), @@ -97,7 +96,6 @@ import FastString import Constants import Util import qualified Data.Data as Data -import Data.List( elemIndex ) \end{code} ----------------------------------------------- @@ -113,8 +111,10 @@ Note [Type synonym families] type instance F Int = Bool ..etc... -* From the user's point of view (F Int) and Bool are simply equivalent - types. +* Reply "yes" to isSynFamilyTyCon, and isFamilyTyCon + +* From the user's point of view (F Int) and Bool are simply + equivalent types. * A Haskell 98 type synonym is a degenerate form of a type synonym family. @@ -122,6 +122,53 @@ Note [Type synonym families] * Type functions can't appear in the LHS of a type function: type instance F (F Int) = ... -- BAD! +* Translation of type family decl: + type family F a :: * + translates to + a SynTyCon 'F', whose SynTyConRhs is SynFamilyTyCon + +* Translation of type instance decl: + type instance F [a] = Maybe a + translates to a "representation TyCon", 'R:FList', where + R:FList is a SynTyCon, whose + SynTyConRhs is (SynonymTyCon (Maybe a)) + TyConParent is (FamInstTyCon F [a] co) + where co :: F [a] ~ R:FList a + + It's very much as if the user had written + type instance F [a] = R:FList a + type R:FList a = Maybe a + Indeed, in GHC's internal representation, the RHS of every + 'type instance' is simply an application of the representation + TyCon to the quantified varaibles. + + The intermediate representation TyCon is a bit gratuitous, but + it means that: + + each 'type instance' decls is in 1-1 correspondance + with its representation TyCon + + So the result of typechecking a 'type instance' decl is just a + TyCon. In turn this means that type and data families can be + treated uniformly. + +* Translation of type family decl: + type family F a :: * + translates to + a SynTyCon 'F', whose SynTyConRhs is SynFamilyTyCon + +* Translation of type instance decl: + type instance F [a] = Maybe a + translates to + A SynTyCon 'R:FList a', whose + SynTyConRhs is (SynonymTyCon (Maybe a)) + TyConParent is (FamInstTyCon F [a] co) + where co :: F [a] ~ R:FList a + Notice that we introduce a gratuitous vanilla type synonym + type R:FList a = Maybe a + solely so that type and data families can be treated more + uniformly, via a single FamInstTyCon descriptor + * In the future we might want to support * closed type families (esp when we have proper kinds) * injective type families (allow decomposition) @@ -137,6 +184,10 @@ See also Note [Wrappers for data instance tycons] in MkId.lhs Here T is the "family TyCon". +* Reply "yes" to isDataFamilyTyCon, and isFamilyTyCon + +* Reply "yes" to isDataFamilyTyCon, and isFamilyTyCon + * The user does not see any "equivalent types" as he did with type synonym families. He just sees constructors with types T1 :: T Int @@ -150,7 +201,7 @@ See also Note [Wrappers for data instance tycons] in MkId.lhs The R:TInt is the "representation TyCons". It has an AlgTyConParent of - FamilyTyCon T [Int] ax_ti + FamInstTyCon T [Int] ax_ti * The data contructor T2 has a wrapper (which is what the source-level "T2" invokes): @@ -181,7 +232,7 @@ See also Note [Wrappers for data instance tycons] in MkId.lhs The representation TyCon R:TList, has an AlgTyConParent of - FamilyTyCon T [(a,b)] ax_pr + FamInstTyCon T [(a,b)] ax_pr * Notice that T is NOT translated to a FC type function; it just becomes a "data type" with no constructors, which can be coerced inot @@ -234,9 +285,6 @@ See also Note [Wrappers for data instance tycons] in MkId.lhs -- -- 4) Class declarations: @class Foo where@ creates the @Foo@ type constructor of kind @*@ -- --- 5) Type coercions! This is because we represent a coercion from @t1@ to @t2@ --- as a 'Type', where that type has kind @t1 ~ t2@. See "Coercion" for more on this --- -- This data type also encodes a number of primitive, built in type constructors such as those -- for function and tuple types. data TyCon @@ -285,11 +333,7 @@ data TyCon algTcRec :: RecFlag, -- ^ Tells us whether the data type is part -- of a mutually-recursive group or not - - hasGenerics :: Bool, -- ^ Whether generic (in the -XGenerics sense) - -- to\/from functions are available in the exports - -- of the data type's source module. - + algTcParent :: TyConParent -- ^ Gives the class or family declaration 'TyCon' -- for derived 'TyCon's representing class -- or family instances, respectively. @@ -305,8 +349,7 @@ data TyCon tyConArity :: Arity, tyConBoxed :: Boxity, tyConTyVars :: [TyVar], - dataCon :: DataCon, -- ^ Corresponding tuple data constructor - hasGenerics :: Bool + dataCon :: DataCon -- ^ Corresponding tuple data constructor } -- | Represents type synonyms @@ -349,17 +392,6 @@ data TyCon -- holds the name of the imported thing } - -- | Type coercions, such as @(~)@, @sym@, @trans@, @left@ and @right@. - -- INVARIANT: Coercion TyCons are always fully applied - -- But note that a CoTyCon can be *over*-saturated in a type. - -- E.g. (sym g1) Int will be represented as (TyConApp sym [g1,Int]) - | CoTyCon { - tyConUnique :: Unique, - tyConName :: Name, - tyConArity :: Arity, - coTcDesc :: CoTyConDesc - } - -- | 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 @@ -369,7 +401,7 @@ data TyCon | AnyTyCon { tyConUnique :: Unique, tyConName :: Name, - tc_kind :: Kind -- Never = *; that is done via PrimTyCon + tc_kind :: Kind -- Never = *; that is done via PrimTyCon -- See Note [Any types] in TysPrim } @@ -403,13 +435,11 @@ data AlgTyConRhs -- -- > data T a :: * -- - -- Or an assoicated data type declaration, within a class declaration: + -- Or an associated data type declaration, within a class declaration: -- -- > class C a b where -- > data T b :: * - | OpenTyCon { - otArgPoss :: AssocFamilyPermutation - } + | DataFamilyTyCon -- | Information about those 'TyCon's derived from a @data@ -- declaration. This includes data types with no constructors at @@ -423,7 +453,7 @@ data AlgTyConRhs -- (see the tag assignment in DataCon.mkDataCon) is_enum :: Bool -- ^ Cached value: is this an enumeration type? - -- (See 'isEnumerationTyCon') + -- See Note [Enumeration types] } -- | Information about those 'TyCon's derived from a @newtype@ declaration @@ -445,38 +475,22 @@ data AlgTyConRhs -- shorter than the declared arity of the 'TyCon'. -- See Note [Newtype eta] - - nt_co :: Maybe TyCon -- ^ A 'TyCon' (which is always a 'CoTyCon') that can - -- have a 'Coercion' extracted from it to create - -- the @newtype@ from the representation 'Type'. - -- - -- This field is optional for non-recursive @newtype@s only. - - -- See Note [Newtype coercions] - -- Invariant: arity = #tvs in nt_etad_rhs; - -- See Note [Newtype eta] - -- Watch out! If any newtypes become transparent - -- again check Trac #1072. + nt_co :: CoAxiom -- The axiom coercion that creates the @newtype@ from + -- the representation 'Type'. + + -- See Note [Newtype coercions] + -- Invariant: arity = #tvs in nt_etad_rhs; + -- See Note [Newtype eta] + -- Watch out! If any newtypes become transparent + -- again check Trac #1072. } -type AssocFamilyPermutation - = Maybe [Int] -- Nothing for *top-level* type families - -- For *associated* type families, gives the position - -- of that 'TyVar' in the class argument list (0-indexed) - -- e.g. class C a b c where { type F c a :: *->* } - -- Then we get Just [2,0] - -- For *synonyms*, the length of the list is identical to - -- the TyCon's arity - -- For *data types*, the length may be smaller than the - -- TyCon's arity; e.g. class C a where { data D a :: *->* } - -- here D gets arity 2 - -- | Extract those 'DataCon's that we are able to learn about. Note -- that visibility in this sense does not correspond to visibility in -- the context of any particular user program! visibleDataCons :: AlgTyConRhs -> [DataCon] visibleDataCons AbstractTyCon = [] -visibleDataCons OpenTyCon {} = [] +visibleDataCons DataFamilyTyCon {} = [] visibleDataCons (DataTyCon{ data_cons = cs }) = cs visibleDataCons (NewTyCon{ data_con = c }) = [c] @@ -493,6 +507,27 @@ data TyConParent | ClassTyCon Class -- INVARIANT: the classTyCon of this Class is the current tycon + -- | An *associated* type of a class. + | AssocFamilyTyCon + Class -- The class in whose declaration the family is declared + -- The 'tyConTyVars' of this 'TyCon' may mention some + -- of the same type variables as the classTyVars of the + -- parent 'Class'. E.g. + -- + -- @ + -- class C a b where + -- data T c a + -- @ + -- + -- Here the 'a' is shared with the 'Class', and that is + -- important. In an instance declaration we expect the + -- two to be instantiated the same way. Eg. + -- + -- @ + -- instanc C [x] (Tree y) where + -- data T c [x] = T1 x | T2 c + -- @ + -- | Type constructors representing an instance of a type family. Parameters: -- -- 1) The type family in question @@ -503,46 +538,63 @@ data TyConParent -- -- 3) A 'CoTyCon' identifying the representation -- type with the type instance family - | FamilyTyCon -- See Note [Data type families] - TyCon - [Type] - TyCon -- c.f. Note [Newtype coercions] - + | FamInstTyCon -- See Note [Data type families] + -- and Note [Type synonym families] + TyCon -- The family TyCon + [Type] -- Argument types (mentions the tyConTyVars of this TyCon) + CoAxiom -- The coercion constructor + + -- E.g. data intance T [a] = ... + -- gives a representation tycon: + -- data R:TList a = ... + -- axiom co a :: T [a] ~ R:TList a + -- with R:TList's algTcParent = FamInstTyCon T [a] co -- | Checks the invariants of a 'TyConParent' given the appropriate type class name, if any okParent :: Name -> TyConParent -> Bool -okParent _ NoParentTyCon = True -okParent tc_name (ClassTyCon cls) = tyConName (classTyCon cls) == tc_name -okParent _ (FamilyTyCon fam_tc tys _co_tc) = tyConArity fam_tc == length tys +okParent _ NoParentTyCon = True +okParent tc_name (AssocFamilyTyCon cls) = tc_name `elem` map tyConName (classATs cls) +okParent tc_name (ClassTyCon cls) = tc_name == tyConName (classTyCon cls) +okParent _ (FamInstTyCon fam_tc tys _co_tc) = tyConArity fam_tc == length tys + +isNoParent :: TyConParent -> Bool +isNoParent NoParentTyCon = True +isNoParent _ = False -------------------- -- | Information pertaining to the expansion of a type synonym (@type@) data SynTyConRhs - = OpenSynTyCon -- e.g. type family F x y :: * -> * - Kind -- Kind of the "rhs"; ie *excluding type indices* - -- In the example, the kind is (*->*) - AssocFamilyPermutation - - | SynonymTyCon Type -- ^ The synonym mentions head type variables. It acts as a - -- template for the expansion when the 'TyCon' is applied to some - -- types. - --------------------- -data CoTyConDesc - = CoSym | CoTrans - | CoLeft | CoRight - | CoCsel1 | CoCsel2 | CoCselR - | CoInst - - | CoAxiom -- C tvs : F lhs-tys ~ rhs-ty - { co_ax_tvs :: [TyVar] - , co_ax_lhs :: Type - , co_ax_rhs :: Type } - - | CoUnsafe + = -- | An ordinary type synonyn. + SynonymTyCon + Type -- This 'Type' is the rhs, and may mention from 'tyConTyVars'. + -- It acts as a template for the expansion when the 'TyCon' + -- is applied to some types. + + -- | A type synonym family e.g. @type family F x y :: * -> *@ + | SynFamilyTyCon \end{code} +Note [Enumeration types] +~~~~~~~~~~~~~~~~~~~~~~~~ +We define datatypes with no constructors to *not* be +enumerations; this fixes trac #2578, Otherwise we +end up generating an empty table for + __closure_tbl +which is used by tagToEnum# to map Int# to constructors +in an enumeration. The empty table apparently upset +the linker. + +Moreover, all the data constructor must be enumerations, meaning +they have type (forall abc. T a b c). GADTs are not enumerations. +For example consider + data T a where + T1 :: T Int + T2 :: T Bool + T3 :: T a +What would [T1 ..] be? [T1,T3] :: T Int? Easiest thing is to exclude them. +See Trac #4528. + Note [Newtype coercions] ~~~~~~~~~~~~~~~~~~~~~~~~ The NewTyCon field nt_co is a a TyCon (a coercion constructor in fact) @@ -619,6 +671,31 @@ so the coercion tycon CoT must have %************************************************************************ %* * + Coercion axioms +%* * +%************************************************************************ + +\begin{code} +-- | A 'CoAxiom' is a \"coercion constructor\", i.e. a named equality axiom. +data CoAxiom + = CoAxiom -- type equality axiom. + { co_ax_unique :: Unique -- unique identifier + , co_ax_name :: Name -- name for pretty-printing + , co_ax_tvs :: [TyVar] -- bound type variables + , co_ax_lhs :: Type -- left-hand side of the equality + , co_ax_rhs :: Type -- right-hand side of the equality + } + +coAxiomArity :: CoAxiom -> Arity +coAxiomArity ax = length (co_ax_tvs ax) + +coAxiomName :: CoAxiom -> Name +coAxiomName = co_ax_name +\end{code} + + +%************************************************************************ +%* * \subsection{PrimRep} %* * %************************************************************************ @@ -706,10 +783,9 @@ mkAlgTyCon :: Name -> AlgTyConRhs -- ^ Information about dat aconstructors -> TyConParent -> RecFlag -- ^ Is the 'TyCon' recursive? - -> Bool -- ^ Does it have generic functions? See 'hasGenerics' -> Bool -- ^ Was the 'TyCon' declared with GADT syntax? -> TyCon -mkAlgTyCon name kind tyvars stupid rhs parent is_rec gen_info gadt_syn +mkAlgTyCon name kind tyvars stupid rhs parent is_rec gadt_syn = AlgTyCon { tyConName = name, tyConUnique = nameUnique name, @@ -720,14 +796,13 @@ mkAlgTyCon name kind tyvars stupid rhs parent is_rec gen_info gadt_syn algTcRhs = rhs, algTcParent = ASSERT( okParent name parent ) parent, algTcRec = is_rec, - algTcGadtSyntax = gadt_syn, - hasGenerics = gen_info + algTcGadtSyntax = gadt_syn } -- | Simpler specialization of 'mkAlgTyCon' for classes mkClassTyCon :: Name -> Kind -> [TyVar] -> AlgTyConRhs -> Class -> RecFlag -> TyCon mkClassTyCon name kind tyvars rhs clas is_rec = - mkAlgTyCon name kind tyvars [] rhs (ClassTyCon clas) is_rec False False + mkAlgTyCon name kind tyvars [] rhs (ClassTyCon clas) is_rec False mkTupleTyCon :: Name -> Kind -- ^ Kind of the resulting 'TyCon' @@ -735,9 +810,8 @@ mkTupleTyCon :: Name -> [TyVar] -- ^ 'TyVar's scoped over: see 'tyConTyVars' -> DataCon -> Boxity -- ^ Whether the tuple is boxed or unboxed - -> Bool -- ^ Does it have generic functions? See 'hasGenerics' -> TyCon -mkTupleTyCon name kind arity tyvars con boxed gen_info +mkTupleTyCon name kind arity tyvars con boxed = TupleTyCon { tyConUnique = nameUnique name, tyConName = name, @@ -745,8 +819,7 @@ mkTupleTyCon name kind arity tyvars con boxed gen_info tyConArity = arity, tyConBoxed = boxed, tyConTyVars = tyvars, - dataCon = con, - hasGenerics = gen_info + dataCon = con } -- ^ Foreign-imported (.NET) type constructors are represented @@ -810,17 +883,6 @@ mkSynTyCon name kind tyvars rhs parent synTcParent = parent } --- | Create a coercion 'TyCon' -mkCoercionTyCon :: Name -> Arity - -> CoTyConDesc - -> TyCon -mkCoercionTyCon name arity desc - = CoTyCon { - tyConName = name, - tyConUnique = nameUnique name, - tyConArity = arity, - coTcDesc = desc } - mkAnyTyCon :: Name -> Kind -> TyCon mkAnyTyCon name kind = AnyTyCon { tyConName = name, @@ -883,7 +945,7 @@ isDataTyCon :: TyCon -> Bool -- get an info table. The family declaration 'TyCon' does not isDataTyCon (AlgTyCon {algTcRhs = rhs}) = case rhs of - OpenTyCon {} -> False + DataFamilyTyCon {} -> False DataTyCon {} -> True NewTyCon {} -> False AbstractTyCon -> False -- We don't know, so return False @@ -898,11 +960,11 @@ isNewTyCon _ = False -- | 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. -unwrapNewTyCon_maybe :: TyCon -> Maybe ([TyVar], Type, Maybe TyCon) +unwrapNewTyCon_maybe :: TyCon -> Maybe ([TyVar], Type, CoAxiom) unwrapNewTyCon_maybe (AlgTyCon { tyConTyVars = tvs, - algTcRhs = NewTyCon { nt_co = mb_co, + algTcRhs = NewTyCon { nt_co = co, nt_rhs = rhs }}) - = Just (tvs, rhs, mb_co) + = Just (tvs, rhs, co) unwrapNewTyCon_maybe _ = Nothing isProductTyCon :: TyCon -> Bool @@ -932,19 +994,10 @@ isSynTyCon _ = False -- right hand side to which a synonym family application can expand. -- --- | Is this a synonym 'TyCon' that can have no further instances appear? -isClosedSynTyCon :: TyCon -> Bool -isClosedSynTyCon tycon = isSynTyCon tycon && not (isOpenTyCon tycon) - --- | Is this a synonym 'TyCon' that can have may have further instances appear? -isOpenSynTyCon :: TyCon -> Bool -isOpenSynTyCon tycon = isSynTyCon tycon && isOpenTyCon tycon - isDecomposableTyCon :: TyCon -> Bool -- True iff we can decompose (T a b c) into ((T a b) c) --- Specifically NOT true of synonyms (open and otherwise) and coercions +-- Specifically NOT true of synonyms (open and otherwise) isDecomposableTyCon (SynTyCon {}) = False -isDecomposableTyCon (CoTyCon {}) = False isDecomposableTyCon _other = True -- | Is this an algebraic 'TyCon' declared with the GADT syntax? @@ -954,15 +1007,30 @@ isGadtSyntaxTyCon _ = False -- | Is this an algebraic 'TyCon' which is just an enumeration of values? isEnumerationTyCon :: TyCon -> Bool +-- See Note [Enumeration types] in TyCon 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? -isOpenTyCon :: TyCon -> Bool -isOpenTyCon (SynTyCon {synTcRhs = OpenSynTyCon {}}) = True -isOpenTyCon (AlgTyCon {algTcRhs = OpenTyCon {}}) = True -isOpenTyCon _ = False +isFamilyTyCon :: TyCon -> Bool +isFamilyTyCon (SynTyCon {synTcRhs = SynFamilyTyCon {}}) = True +isFamilyTyCon (AlgTyCon {algTcRhs = DataFamilyTyCon {}}) = True +isFamilyTyCon _ = False + +-- | Is this a synonym 'TyCon' that can have may have further instances appear? +isSynFamilyTyCon :: TyCon -> Bool +isSynFamilyTyCon (SynTyCon {synTcRhs = SynFamilyTyCon {}}) = True +isSynFamilyTyCon _ = False + +-- | Is this a synonym 'TyCon' that can have may have further instances appear? +isDataFamilyTyCon :: TyCon -> Bool +isDataFamilyTyCon (AlgTyCon {algTcRhs = DataFamilyTyCon {}}) = True +isDataFamilyTyCon _ = False + +-- | Is this a synonym 'TyCon' that can have no further instances appear? +isClosedSynTyCon :: TyCon -> Bool +isClosedSynTyCon tycon = isSynTyCon tycon && not (isFamilyTyCon tycon) -- | Injective 'TyCon's can be decomposed, so that -- T ty1 ~ T ty2 => ty1 ~ ty2 @@ -971,40 +1039,16 @@ isInjectiveTyCon tc = not (isSynTyCon tc) -- Ultimately we may have injective associated types -- in which case this test will become more interesting -- - -- It'd be unusual to call isInjectiveTyCon on a regular H98 + -- It'd be unusual to call isInjectiveTyCon on a regular H98 -- type synonym, because you should probably have expanded it first -- But regardless, it's not injective! --- | Extract the mapping from 'TyVar' indexes to indexes in the corresponding family --- argument lists form an open 'TyCon' of any sort, if the given 'TyCon' is indeed --- such a beast and that information is available -assocTyConArgPoss_maybe :: TyCon -> Maybe [Int] -assocTyConArgPoss_maybe (AlgTyCon { - algTcRhs = OpenTyCon {otArgPoss = poss}}) = poss -assocTyConArgPoss_maybe (SynTyCon { synTcRhs = OpenSynTyCon _ poss }) = poss -assocTyConArgPoss_maybe _ = Nothing - -- | Are we able to extract informationa 'TyVar' to class argument list -- mappping from a given 'TyCon'? isTyConAssoc :: TyCon -> Bool -isTyConAssoc = isJust . assocTyConArgPoss_maybe - --- | Set the AssocFamilyPermutation structure in an --- associated data or type synonym. The [TyVar] are the --- class type variables. Remember, the tyvars of an associated --- data/type are a subset of the class tyvars; except that an --- associated data type can have extra type variables at the --- end (see Note [Avoid name clashes for associated data types] in TcHsType) -setTyConArgPoss :: [TyVar] -> TyCon -> TyCon -setTyConArgPoss clas_tvs tc - = case tc of - AlgTyCon { algTcRhs = rhs } -> tc { algTcRhs = rhs {otArgPoss = Just ps} } - SynTyCon { synTcRhs = OpenSynTyCon ki _ } -> tc { synTcRhs = OpenSynTyCon ki (Just ps) } - _ -> pprPanic "setTyConArgPoss" (ppr tc) - where - ps = catMaybes [tv `elemIndex` clas_tvs | tv <- tyConTyVars tc] - -- We will get Nothings for the "extra" type variables in an - -- associated data type +isTyConAssoc tc = case tyConParent tc of + AssocFamilyTyCon {} -> True + _ -> False -- The unit tycon didn't used to be classed as a tuple tycon -- but I thought that was silly so I've undone it @@ -1034,6 +1078,11 @@ isBoxedTupleTyCon _ = False tupleTyConBoxity :: TyCon -> Boxity tupleTyConBoxity tc = tyConBoxed tc +-- | Extract the arity of the given 'TyCon', if it is a 'TupleTyCon'. +-- Panics otherwise +tupleTyConArity :: TyCon -> Arity +tupleTyConArity tc = tyConArity tc + -- | Is this a recursive 'TyCon'? isRecursiveTyCon :: TyCon -> Bool isRecursiveTyCon (AlgTyCon {algTcRec = Recursive}) = True @@ -1060,19 +1109,6 @@ 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, CoTyConDesc) -isCoercionTyCon_maybe (CoTyCon {tyConArity = ar, coTcDesc = desc}) - = Just (ar, desc) -isCoercionTyCon_maybe _ = Nothing - --- | Is this a 'TyCon' that represents a coercion? -isCoercionTyCon :: TyCon -> Bool -isCoercionTyCon (CoTyCon {}) = True -isCoercionTyCon _ = False - -- | Identifies implicit tycons that, in particular, do not go into interface -- files (because they are implicitly reconstructed when the interface is -- read). @@ -1102,14 +1138,15 @@ isImplicitTyCon _other = True \begin{code} tcExpandTyCon_maybe, coreExpandTyCon_maybe :: TyCon - -> [Type] -- ^ Arguments to 'TyCon' - -> Maybe ([(TyVar,Type)], + -> [tyco] -- ^ Arguments to 'TyCon' + -> Maybe ([(TyVar,tyco)], Type, - [Type]) -- ^ Returns a 'TyVar' substitution, the body type - -- of the synonym (not yet substituted) and any arguments - -- remaining from the application + [tyco]) -- ^ Returns a 'TyVar' substitution, the body type + -- of the synonym (not yet substituted) and any arguments + -- remaining from the application --- ^ Used to create the view the /typechecker/ has on 'TyCon's. We expand (closed) synonyms only, cf. 'coreExpandTyCon_maybe' +-- ^ Used to create the view the /typechecker/ has on 'TyCon's. +-- We expand (closed) synonyms only, cf. 'coreExpandTyCon_maybe' tcExpandTyCon_maybe (SynTyCon {tyConTyVars = tvs, synTcRhs = SynonymTyCon rhs }) tys = expand tvs rhs tys @@ -1117,36 +1154,26 @@ tcExpandTyCon_maybe _ _ = Nothing --------------- --- ^ Used to create the view /Core/ has on 'TyCon's. We expand not only closed synonyms like 'tcExpandTyCon_maybe', +-- ^ Used to create the view /Core/ has on 'TyCon's. We expand +-- not only closed synonyms like 'tcExpandTyCon_maybe', -- but also non-recursive @newtype@s -coreExpandTyCon_maybe (AlgTyCon { - 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 - -> Maybe ([(TyVar,Type)], Type, [Type]) -- Expansion +expand :: [TyVar] -> Type -- Template + -> [a] -- Args + -> Maybe ([(TyVar,a)], Type, [a]) -- Expansion expand tvs rhs tys = case n_tvs `compare` length tys of LT -> Just (tvs `zip` tys, rhs, drop n_tvs tys) EQ -> Just (tvs `zip` tys, rhs, []) - GT -> Nothing + GT -> Nothing where n_tvs = length tvs \end{code} \begin{code} --- | Does this 'TyCon' have any generic to\/from functions available? See also 'hasGenerics' -tyConHasGenerics :: TyCon -> Bool -tyConHasGenerics (AlgTyCon {hasGenerics = hg}) = hg -tyConHasGenerics (TupleTyCon {hasGenerics = hg}) = hg -tyConHasGenerics _ = False -- Synonyms tyConKind :: TyCon -> Kind tyConKind (FunTyCon { tc_kind = k }) = k @@ -1159,7 +1186,6 @@ tyConKind tc = pprPanic "tyConKind" (ppr tc) -- SuperKindTyCon and CoTyCon tyConHasKind :: TyCon -> Bool tyConHasKind (SuperKindTyCon {}) = False -tyConHasKind (CoTyCon {}) = False tyConHasKind _ = True -- | As 'tyConDataCons_maybe', but returns the empty list of constructors if no constructors @@ -1182,9 +1208,9 @@ tyConDataCons_maybe _ = Not tyConFamilySize :: TyCon -> Int tyConFamilySize (AlgTyCon {algTcRhs = DataTyCon {data_cons = cons}}) = length cons -tyConFamilySize (AlgTyCon {algTcRhs = NewTyCon {}}) = 1 -tyConFamilySize (AlgTyCon {algTcRhs = OpenTyCon {}}) = 0 -tyConFamilySize (TupleTyCon {}) = 1 +tyConFamilySize (AlgTyCon {algTcRhs = NewTyCon {}}) = 1 +tyConFamilySize (AlgTyCon {algTcRhs = DataFamilyTyCon {}}) = 0 +tyConFamilySize (TupleTyCon {}) = 1 tyConFamilySize other = pprPanic "tyConFamilySize:" (ppr other) -- | Extract an 'AlgTyConRhs' with information about data constructors from an algebraic or tuple @@ -1212,9 +1238,14 @@ newTyConEtadRhs tycon = pprPanic "newTyConEtadRhs" (ppr tycon) -- | Extracts the @newtype@ coercion from such a 'TyCon', which can be used to construct something -- with the @newtype@s type from its representation type (right hand side). If the supplied 'TyCon' -- is not a @newtype@, returns @Nothing@ -newTyConCo_maybe :: TyCon -> Maybe TyCon -newTyConCo_maybe (AlgTyCon {algTcRhs = NewTyCon { nt_co = co }}) = co -newTyConCo_maybe _ = Nothing +newTyConCo_maybe :: TyCon -> Maybe CoAxiom +newTyConCo_maybe (AlgTyCon {algTcRhs = NewTyCon { nt_co = co }}) = Just co +newTyConCo_maybe _ = Nothing + +newTyConCo :: TyCon -> CoAxiom +newTyConCo tc = case newTyConCo_maybe tc of + Just co -> co + Nothing -> pprPanic "newTyConCo" (ppr tc) -- | Find the primitive representation of a 'TyCon' tyConPrimRep :: TyCon -> PrimRep @@ -1252,11 +1283,6 @@ synTyConType :: TyCon -> Type synTyConType tc = case synTcRhs tc of SynonymTyCon t -> t _ -> pprPanic "synTyConType" (ppr tc) - --- | Find the 'Kind' of an open type synonym. Panics if the 'TyCon' is not an open type synonym -synTyConResKind :: TyCon -> Kind -synTyConResKind (SynTyCon {synTcRhs = OpenSynTyCon kind _}) = kind -synTyConResKind tycon = pprPanic "synTyConResKind" (ppr tycon) \end{code} \begin{code} @@ -1283,33 +1309,42 @@ tyConClass_maybe :: TyCon -> Maybe Class tyConClass_maybe (AlgTyCon {algTcParent = ClassTyCon clas}) = Just clas tyConClass_maybe _ = Nothing +---------------------------------------------------------------------------- +tyConParent :: TyCon -> TyConParent +tyConParent (AlgTyCon {algTcParent = parent}) = parent +tyConParent (SynTyCon {synTcParent = parent}) = parent +tyConParent _ = NoParentTyCon + +---------------------------------------------------------------------------- -- | Is this 'TyCon' that for a family instance, be that for a synonym or an -- algebraic family instance? isFamInstTyCon :: TyCon -> Bool -isFamInstTyCon (AlgTyCon {algTcParent = FamilyTyCon _ _ _ }) = True -isFamInstTyCon (SynTyCon {synTcParent = FamilyTyCon _ _ _ }) = True -isFamInstTyCon _ = False +isFamInstTyCon tc = case tyConParent tc of + FamInstTyCon {} -> True + _ -> False + +tyConFamInstSig_maybe :: TyCon -> Maybe (TyCon, [Type], CoAxiom) +tyConFamInstSig_maybe tc + = case tyConParent tc of + FamInstTyCon f ts co_tc -> Just (f, ts, co_tc) + _ -> Nothing -- | If this 'TyCon' is that of a family instance, return the family in question -- and the instance types. Otherwise, return @Nothing@ tyConFamInst_maybe :: TyCon -> Maybe (TyCon, [Type]) -tyConFamInst_maybe (AlgTyCon {algTcParent = FamilyTyCon fam instTys _}) = - Just (fam, instTys) -tyConFamInst_maybe (SynTyCon {synTcParent = FamilyTyCon fam instTys _}) = - Just (fam, instTys) -tyConFamInst_maybe _ = - Nothing +tyConFamInst_maybe tc + = case tyConParent tc of + FamInstTyCon f ts _ -> Just (f, ts) + _ -> Nothing -- | If this 'TyCon' is that of a family instance, return a 'TyCon' which represents -- a coercion identifying the representation type with the type instance family. -- Otherwise, return @Nothing@ -tyConFamilyCoercion_maybe :: TyCon -> Maybe TyCon -tyConFamilyCoercion_maybe (AlgTyCon {algTcParent = FamilyTyCon _ _ coe}) = - Just coe -tyConFamilyCoercion_maybe (SynTyCon {synTcParent = FamilyTyCon _ _ coe}) = - Just coe -tyConFamilyCoercion_maybe _ = - Nothing +tyConFamilyCoercion_maybe :: TyCon -> Maybe CoAxiom +tyConFamilyCoercion_maybe tc + = case tyConParent tc of + FamInstTyCon _ _ co -> Just co + _ -> Nothing \end{code} @@ -1339,18 +1374,6 @@ instance Ord TyCon where instance Uniquable TyCon where getUnique tc = tyConUnique tc -instance Outputable CoTyConDesc where - ppr CoSym = ptext (sLit "SYM") - ppr CoTrans = ptext (sLit "TRANS") - ppr CoLeft = ptext (sLit "LEFT") - ppr CoRight = ptext (sLit "RIGHT") - ppr CoCsel1 = ptext (sLit "CSEL1") - ppr CoCsel2 = ptext (sLit "CSEL2") - ppr CoCselR = ptext (sLit "CSELR") - ppr CoInst = ptext (sLit "INST") - ppr CoUnsafe = ptext (sLit "UNSAFE") - ppr (CoAxiom {}) = ptext (sLit "AXIOM") - instance Outputable TyCon where ppr tc = ppr (getName tc) @@ -1365,4 +1388,34 @@ instance Data.Data TyCon where toConstr _ = abstractConstr "TyCon" gunfold _ _ = error "gunfold" dataTypeOf _ = mkNoRepType "TyCon" + +------------------- +instance Eq CoAxiom where + a == b = case (a `compare` b) of { EQ -> True; _ -> False } + a /= b = case (a `compare` b) of { EQ -> False; _ -> True } + +instance Ord CoAxiom where + a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False } + a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False } + a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True } + a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True } + compare a b = getUnique a `compare` getUnique b + +instance Uniquable CoAxiom where + getUnique = co_ax_unique + +instance Outputable CoAxiom where + ppr = ppr . getName + +instance NamedThing CoAxiom where + getName = co_ax_name + +instance Data.Typeable CoAxiom where + typeOf _ = Data.mkTyConApp (Data.mkTyCon "CoAxiom") [] + +instance Data.Data CoAxiom where + -- don't traverse? + toConstr _ = abstractConstr "CoAxiom" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "CoAxiom" \end{code}