X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypes%2FTyCon.lhs;h=befc4e6f938bfe3c0d7c3b27e002aa9bc3b23ad0;hb=da2e18b9ab29131bda1ac8e3962dc50b635589a5;hp=256b1412f417ec3fbb9576eee24ae0a9be95ba45;hpb=5e5310b3cb4f78e30cc7b90879eb016e97c214cb;p=ghc-hetmet.git diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs index 256b141..befc4e6 100644 --- a/compiler/types/TyCon.lhs +++ b/compiler/types/TyCon.lhs @@ -13,6 +13,7 @@ module TyCon( AlgTyConRhs(..), visibleDataCons, TyConParent(..), SynTyConRhs(..), + AssocFamilyPermutation, -- ** Constructing TyCons mkAlgTyCon, @@ -38,6 +39,7 @@ module TyCon( isCoercionTyCon, isCoercionTyCon_maybe, isForeignTyCon, + isInjectiveTyCon, isDataTyCon, isProductTyCon, isEnumerationTyCon, isNewTyCon, isAbstractTyCon, isOpenTyCon, isUnLiftedTyCon, @@ -54,7 +56,6 @@ module TyCon( tyConTyVars, tyConDataCons, tyConDataCons_maybe, tyConSingleDataCon_maybe, tyConFamilySize, - tyConSelIds, tyConStupidTheta, tyConArity, tyConClass_maybe, @@ -92,6 +93,7 @@ import Maybes import Outputable import FastString import Constants +import Data.List( elemIndex ) \end{code} %************************************************************************ @@ -144,8 +146,6 @@ data TyCon -- -- Note that it does /not/ scope over the data constructors. - algTcSelIds :: [Id], -- ^ The record selectors of this type (possibly emptys) - algTcGadtSyntax :: Bool, -- ^ Was the data type declared with GADT syntax? If so, -- that doesn't mean it's a true GADT; only that the "where" -- form was used. This field is used only to guide @@ -260,17 +260,7 @@ data AlgTyConRhs -- > data T b :: * | OpenTyCon { - - otArgPoss :: Maybe [Int] - -- ^ @Nothing@ iff this is a top-level indexed type family. - -- @Just ns@ iff this is an associated (not top-level) family - -- - -- In the latter case, for each 'TyVar' in the associated type declaration, - -- @ns@ gives the position of that tyvar in the class argument list (starting - -- from 0). - -- - -- NB: The length of this list is less than the accompanying 'tyConArity' iff - -- we have a higher kind signature. + otArgPoss :: AssocFamilyPermutation } -- | Information about those 'TyCon's derived from a @data@ declaration. This includes @@ -316,6 +306,18 @@ data AlgTyConRhs -- 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] @@ -369,16 +371,10 @@ okParent _ (FamilyTyCon fam_tc tys _co_tc) = tyConArity fam_tc == length t -- | Information pertaining to the expansion of a type synonym (@type@) data SynTyConRhs - = OpenSynTyCon Kind - (Maybe [Int]) -- ^ A Type family synonym. The /result/ 'Kind' is - -- given for associated families, and in this case the - -- list of @Int@s is not empty, and for each 'TyVar' in - -- the associated type declaration, it gives the position - -- of that 'TyVar' in the class argument list (starting - -- from 0). - -- - -- NB: The length of this list will be less than 'tyConArity' iff - -- the family has a higher kind signature. + = 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 @@ -576,13 +572,12 @@ mkAlgTyCon :: Name -> [TyVar] -- ^ 'TyVar's scoped over: see 'tyConTyVars'. Arity is inferred from the length of this list -> [PredType] -- ^ Stupid theta: see 'algTcStupidTheta' -> AlgTyConRhs -- ^ Information about dat aconstructors - -> [Id] -- ^ Selector 'Id's -> 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 sel_ids parent is_rec gen_info gadt_syn +mkAlgTyCon name kind tyvars stupid rhs parent is_rec gen_info gadt_syn = AlgTyCon { tyConName = name, tyConUnique = nameUnique name, @@ -591,7 +586,6 @@ mkAlgTyCon name kind tyvars stupid rhs sel_ids parent is_rec gen_info gadt_syn tyConTyVars = tyvars, algTcStupidTheta = stupid, algTcRhs = rhs, - algTcSelIds = sel_ids, algTcParent = ASSERT( okParent name parent ) parent, algTcRec = is_rec, algTcGadtSyntax = gadt_syn, @@ -601,7 +595,7 @@ mkAlgTyCon name kind tyvars stupid rhs sel_ids parent is_rec gen_info 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 False mkTupleTyCon :: Name -> Kind -- ^ Kind of the resulting 'TyCon' @@ -818,9 +812,20 @@ 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 +isOpenTyCon (SynTyCon {synTcRhs = OpenSynTyCon {}}) = True +isOpenTyCon (AlgTyCon {algTcRhs = OpenTyCon {}}) = True +isOpenTyCon _ = False + +-- | Injective 'TyCon's can be decomposed, so that +-- T ty1 ~ T ty2 => ty1 ~ ty2 +isInjectiveTyCon :: TyCon -> Bool +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 + -- 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 @@ -836,14 +841,22 @@ assocTyConArgPoss_maybe _ = Nothing isTyConAssoc :: TyCon -> Bool isTyConAssoc = isJust . assocTyConArgPoss_maybe --- | Sets up a 'TyVar' to family argument-list mapping in the given 'TyCon' if it is --- an open 'TyCon'. Panics otherwise -setTyConArgPoss :: TyCon -> [Int] -> TyCon -setTyConArgPoss tc@(AlgTyCon { algTcRhs = rhs }) poss = - tc { algTcRhs = rhs {otArgPoss = Just poss} } -setTyConArgPoss tc@(SynTyCon { synTcRhs = OpenSynTyCon ki _ }) poss = - tc { synTcRhs = OpenSynTyCon ki (Just poss) } -setTyConArgPoss tc _ = pprPanic "setTyConArgPoss" (ppr tc) +-- | 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 -- The unit tycon didn't used to be classed as a tuple tycon -- but I thought that was silly so I've undone it @@ -953,7 +966,7 @@ tcExpandTyCon_maybe _ _ = Nothing -- ^ 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 {algTcRec = NonRecursive, -- Not recursive +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 @@ -1007,11 +1020,6 @@ tyConFamilySize (AlgTyCon {algTcRhs = OpenTyCon {}}) = 0 tyConFamilySize (TupleTyCon {}) = 1 tyConFamilySize other = pprPanic "tyConFamilySize:" (ppr other) --- | Extract the record selector 'Id's from an algebraic 'TyCon' and returns the empty list otherwise -tyConSelIds :: TyCon -> [Id] -tyConSelIds (AlgTyCon {algTcSelIds = fs}) = fs -tyConSelIds _ = [] - -- | Extract an 'AlgTyConRhs' with information about data constructors from an algebraic or tuple -- 'TyCon'. Panics for any other sort of 'TyCon' algTyConRhs :: TyCon -> AlgTyConRhs