AlgTyConRhs(..), visibleDataCons,
TyConParent(..),
SynTyConRhs(..),
+ AssocFamilyPermutation,
-- ** Constructing TyCons
mkAlgTyCon,
tyConTyVars,
tyConDataCons, tyConDataCons_maybe, tyConSingleDataCon_maybe,
tyConFamilySize,
- tyConSelIds,
tyConStupidTheta,
tyConArity,
tyConClass_maybe,
import Outputable
import FastString
import Constants
+import Data.List( elemIndex )
\end{code}
%************************************************************************
--
-- 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
-- > 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
-- 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]
-- | 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
-> [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,
tyConTyVars = tyvars,
algTcStupidTheta = stupid,
algTcRhs = rhs,
- algTcSelIds = sel_ids,
algTcParent = ASSERT( okParent name parent ) parent,
algTcRec = is_rec,
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 False
mkTupleTyCon :: Name
-> Kind -- ^ Kind of the resulting 'TyCon'
-- | 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
-- | 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
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
-- ^ 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
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