summary |
shortlog |
log |
commit | commitdiff |
tree
raw |
patch |
inline | side by side (from parent 1:
a1899ed)
Mon Sep 18 19:35:24 EDT 2006 Manuel M T Chakravarty <chak@cse.unsw.edu.au>
* Straightened out implicit coercions for indexed types
Mon Sep 4 23:46:14 EDT 2006 Manuel M T Chakravarty <chak@cse.unsw.edu.au>
* Straightened out implicit coercions for indexed types
- HscTypes.implicitTyThings and LoadIface.ifaceDeclSubBndrs now
include the coercion of indexed data/newtypes.
- Name generation for the internal names of indexed data/newtypes now uses
the same counter that generates the dfun unique indexes (ie, class and type
instances are counted with the one counter). We could make this two
separate counters if that's what's preferred.
- The unique index of a data/newtype instances needs to go into the iface, so
that we can generate the same names on slurping in the iface as when the
original module was generated. This is a bit yucky, but I don't see a way
to avoid that (other than putting the full blown internal tycon name and
coercion name into the iface, which IMHO would be worse).
- The predicate for when a datacon has a wrapper didn't take GADT
equations nor whether it comes froma family instance into account.
*** WARNING! This patch changed the interface file format. ***
*** Please recompile from scratch. ***
12 files changed:
tyConStupidTheta, isProductTyCon, isDataTyCon,
isRecursiveTyCon, isFamInstTyCon,
tyConFamInst_maybe, tyConFamilyCoercion_maybe,
tyConStupidTheta, isProductTyCon, isDataTyCon,
isRecursiveTyCon, isFamInstTyCon,
tyConFamInst_maybe, tyConFamilyCoercion_maybe,
import Class ( Class, classTyCon, classSelIds )
import Var ( Id, TyVar, Var, setIdType )
import VarSet ( isEmptyVarSet, subVarSet, varSetElems )
import Class ( Class, classTyCon, classSelIds )
import Var ( Id, TyVar, Var, setIdType )
import VarSet ( isEmptyVarSet, subVarSet, varSetElems )
mkDataConIds :: Name -> Name -> DataCon -> DataConIds
mkDataConIds wrap_name wkr_name data_con
| isNewTyCon tycon
mkDataConIds :: Name -> Name -> DataCon -> DataConIds
mkDataConIds wrap_name wkr_name data_con
| isNewTyCon tycon
- = DCIds Nothing nt_work_id -- Newtype, only has a worker
+ = DCIds Nothing nt_work_id -- Newtype, only has a worker
- | any isMarkedStrict all_strict_marks -- Algebraic, needs wrapper
- || not (null eq_spec)
- || isFamInstTyCon tycon
+ | any isMarkedStrict all_strict_marks -- Algebraic, needs wrapper
+ || not (null eq_spec) -- NB: LoadIface.ifaceDeclSubBndrs
+ || isFamInstTyCon tycon -- depends on this test
= DCIds (Just alg_wrap_id) wrk_id
= DCIds (Just alg_wrap_id) wrk_id
- | otherwise -- Algebraic, no wrapper
+ | otherwise -- Algebraic, no wrapper
= DCIds Nothing wrk_id
where
(univ_tvs, ex_tvs, eq_spec,
= DCIds Nothing wrk_id
where
(univ_tvs, ex_tvs, eq_spec,
= wrapFamInstBody tycon args inner
where
inner
= wrapFamInstBody tycon args inner
where
inner
- | Just co_con <- newTyConCo tycon
+ | Just co_con <- newTyConCo_maybe tycon
= mkCoerce (mkSymCoercion (mkTyConApp co_con args)) result_expr
| otherwise
= result_expr
= mkCoerce (mkSymCoercion (mkTyConApp co_con args)) result_expr
| otherwise
= result_expr
--
unwrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
unwrapNewTypeBody tycon args result_expr
--
unwrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
unwrapNewTypeBody tycon args result_expr
- | Just co_con <- newTyConCo tycon
+ | Just co_con <- newTyConCo_maybe tycon
= mkCoerce (mkTyConApp co_con args) result_expr
| otherwise
= result_expr
= mkCoerce (mkTyConApp co_con args) result_expr
| otherwise
= result_expr
-- Derive a name for the representation type constructor of a data/newtype
-- instance.
--
-- Derive a name for the representation type constructor of a data/newtype
-- instance.
--
-mkInstTyTcOcc :: Unique -- Unique
+mkInstTyTcOcc :: Int -- Index
-> OccName -- Local name (e.g. "Map")
-> OccName -- Nice unique version (":R23Map")
-> OccName -- Local name (e.g. "Map")
-> OccName -- Nice unique version (":R23Map")
-mkInstTyTcOcc uniq occ
- = mk_deriv varName (":R" ++ show uniq) (occNameString occ)
+mkInstTyTcOcc index occ
+ = mk_deriv varName (":R" ++ show index) (occNameString occ)
-- Derive a name for the coercion of a data/newtype instance.
--
-- Derive a name for the coercion of a data/newtype instance.
--
-mkInstTyCoOcc :: Unique -- Unique
+mkInstTyCoOcc :: Int -- Index
-> OccName -- Local name (e.g. "Map")
-> OccName -- Local name (e.g. "Map")
- -> OccName -- Nice unique version ("Co23Map")
-mkInstTyCoOcc uniq occ
- = mk_deriv varName ("Co" ++ show uniq) (occNameString occ)
-
+ -> OccName -- Nice unique version (":Co23Map")
+mkInstTyCoOcc index occ
+ = mk_deriv varName (":Co" ++ show index) (occNameString occ)
-> RecFlag
-> Bool -- True <=> want generics functions
-> Bool -- True <=> was declared in GADT syntax
-> RecFlag
-> Bool -- True <=> want generics functions
-> Bool -- True <=> was declared in GADT syntax
- -> Maybe (TyCon, [Type]) -- Just (family, tys)
+ -> Maybe (TyCon, [Type],
+ Int) -- Just (family, tys, index)
-- <=> instance of `family' at `tys'
-> TcRnIf m n TyCon
-- <=> instance of `family' at `tys'
-> TcRnIf m n TyCon
-- (3) Produce a `AlgTyConParent' value containing the parent and coercion
-- information.
--
-- (3) Produce a `AlgTyConParent' value containing the parent and coercion
-- information.
--
- maybeComputeFamilyInfo Nothing rep_tycon =
+ maybeComputeFamilyInfo Nothing rep_tycon =
return (tc_name, NoParentTyCon)
return (tc_name, NoParentTyCon)
- maybeComputeFamilyInfo (Just (family, instTys)) rep_tycon =
+ maybeComputeFamilyInfo (Just (family, instTys, index)) rep_tycon =
do { -- (1) New, derived name for the instance tycon
do { -- (1) New, derived name for the instance tycon
- ; uniq <- newUnique
- ; final_name <- newImplicitBinder tc_name (mkInstTyTcOcc uniq)
+ ; final_name <- newImplicitBinder tc_name (mkInstTyTcOcc index)
-- (2) Create the coercion.
-- (2) Create the coercion.
- ; co_tycon_name <- newImplicitBinder tc_name (mkInstTyCoOcc uniq)
+ ; co_tycon_name <- newImplicitBinder tc_name (mkInstTyCoOcc index)
; let co_tycon = mkDataInstCoercion co_tycon_name tvs
family instTys rep_tycon
-- (3) Produce parent information.
; let co_tycon = mkDataInstCoercion co_tycon_name tvs
family instTys rep_tycon
-- (3) Produce parent information.
- ; return (final_name, FamilyTyCon family instTys co_tycon)
+ ; return (final_name, FamilyTyCon family instTys co_tycon index)
-- current compilation unit
ifFamInst :: Maybe -- Just _ <=> instance of fam
(IfaceTyCon, -- Family tycon
-- current compilation unit
ifFamInst :: Maybe -- Just _ <=> instance of fam
(IfaceTyCon, -- Family tycon
- [IfaceType]) -- Instance types
+ [IfaceType], -- Instance types
+ Int ) -- Unique index for naming
}
| IfaceSyn { ifName :: OccName, -- Type constructor
}
| IfaceSyn { ifName :: OccName, -- Type constructor
pprGen True = ptext SLIT("Generics: yes")
pprGen False = ptext SLIT("Generics: no")
pprGen True = ptext SLIT("Generics: yes")
pprGen False = ptext SLIT("Generics: no")
-pprFamily Nothing = ptext SLIT("FamilyInstance: none")
-pprFamily (Just (fam, tys)) = ptext SLIT("FamilyInstance:") <+>
- ppr fam <+> hsep (map ppr tys)
+pprFamily Nothing = ptext SLIT("FamilyInstance: none")
+pprFamily (Just (fam, tys, index)) = ptext SLIT("FamilyInstance:") <+>
+ ppr fam <+> hsep (map ppr tys) <+>
+ brackets (ppr index)
instance Outputable IfaceClassOp where
ppr (IfaceClassOp n dm ty) = ppr n <+> ppr dm <+> dcolon <+> ppr ty
instance Outputable IfaceClassOp where
ppr (IfaceClassOp n dm ty) = ppr n <+> ppr dm <+> dcolon <+> ppr ty
-- over the constructors (any more), but they do scope
-- over the stupid context in the IfaceConDecls
where
-- over the constructors (any more), but they do scope
-- over the stupid context in the IfaceConDecls
where
- Nothing `eqIfTc_fam` Nothing = Equal
- (Just (fam1, tys1)) `eqIfTc_fam` (Just (fam2, tys2)) =
- fam1 `eqIfTc` fam2 &&& eqListBy eqIfType tys1 tys2
- _ `eqIfTc_fam` _ = NotEqual
+ Nothing `eqIfTc_fam` Nothing = Equal
+ (Just (fam1, tys1, co1)) `eqIfTc_fam` (Just (fam2, tys2, co2)) =
+ fam1 `eqIfTc` fam2 &&& eqListBy eqIfType tys1 tys2 &&& bool (co1 == co2)
+ _ `eqIfTc_fam` _ = NotEqual
eqIfDecl d1@(IfaceSyn {}) d2@(IfaceSyn {})
= bool (ifName d1 == ifName d2) &&&
eqIfDecl d1@(IfaceSyn {}) d2@(IfaceSyn {})
= bool (ifName d1 == ifName d2) &&&
import MkId ( seqId )
import Module
import OccName ( OccName, mkOccEnv, lookupOccEnv, mkClassTyConOcc,
import MkId ( seqId )
import Module
import OccName ( OccName, mkOccEnv, lookupOccEnv, mkClassTyConOcc,
- mkClassDataConOcc, mkSuperDictSelOcc,
- mkDataConWrapperOcc, mkDataConWorkerOcc,
- mkNewTyCoOcc )
+ mkClassDataConOcc, mkSuperDictSelOcc,
+ mkDataConWrapperOcc, mkDataConWorkerOcc,
+ mkNewTyCoOcc, mkInstTyTcOcc, mkInstTyCoOcc )
import SrcLoc ( importedSrcLoc )
import Maybes ( MaybeErr(..) )
import ErrUtils ( Message )
import SrcLoc ( importedSrcLoc )
import Maybes ( MaybeErr(..) )
import ErrUtils ( Message )
import Binary ( getBinFileWithDict )
import Panic ( ghcError, tryMost, showException, GhcException(..) )
import List ( nub )
import Binary ( getBinFileWithDict )
import Panic ( ghcError, tryMost, showException, GhcException(..) )
import List ( nub )
import DATA_IOREF ( writeIORef )
\end{code}
import DATA_IOREF ( writeIORef )
\end{code}
main_name <- mk_new_bndr mod Nothing (ifName decl)
; implicit_names <- mapM (mk_new_bndr mod (Just main_name))
(ifaceDeclSubBndrs decl)
main_name <- mk_new_bndr mod Nothing (ifName decl)
; implicit_names <- mapM (mk_new_bndr mod (Just main_name))
(ifaceDeclSubBndrs decl)
- ; at_names <- mapM (mk_new_bndr mod Nothing) (atNames decl)
+ ; at_names <- mapM (mk_new_bndr mod (Just main_name)) (atNames decl)
-- Typecheck the thing, lazily
-- NB. firstly, the laziness is there in case we never need the
-- Typecheck the thing, lazily
-- NB. firstly, the laziness is there in case we never need the
ifaceDeclSubBndrs (IfaceData {ifName = tc_occ,
ifCons = IfNewTyCon (
IfCon { ifConOcc = con_occ,
ifaceDeclSubBndrs (IfaceData {ifName = tc_occ,
ifCons = IfNewTyCon (
IfCon { ifConOcc = con_occ,
- ifConFields = fields})})
- = fields ++ [con_occ, mkDataConWrapperOcc con_occ, mkNewTyCoOcc tc_occ]
+ ifConFields = fields
+ }),
+ ifFamInst = famInst})
+ = fields ++ [con_occ, mkDataConWorkerOcc con_occ, mkNewTyCoOcc tc_occ]
+ ++ famInstCo famInst tc_occ
-ifaceDeclSubBndrs (IfaceData {ifCons = IfDataTyCon cons})
+ifaceDeclSubBndrs (IfaceData {ifName = tc_occ,
+ ifCons = IfDataTyCon cons,
+ ifFamInst = famInst})
= nub (concatMap ifConFields cons) -- Eliminate duplicate fields
++ concatMap dc_occs cons
= nub (concatMap ifConFields cons) -- Eliminate duplicate fields
++ concatMap dc_occs cons
+ ++ famInstCo famInst tc_occ
where
dc_occs con_decl
| has_wrapper = [con_occ, work_occ, wrap_occ]
where
dc_occs con_decl
| has_wrapper = [con_occ, work_occ, wrap_occ]
wrap_occ = mkDataConWrapperOcc con_occ
work_occ = mkDataConWorkerOcc con_occ
has_wrapper = any isMarkedStrict strs -- See MkId.mkDataConIds (sigh)
wrap_occ = mkDataConWrapperOcc con_occ
work_occ = mkDataConWorkerOcc con_occ
has_wrapper = any isMarkedStrict strs -- See MkId.mkDataConIds (sigh)
+ || not (null . ifConEqSpec $ con_decl)
+ || isJust famInst
-- ToDo: may miss strictness in existential dicts
ifaceDeclSubBndrs _other = []
-- ToDo: may miss strictness in existential dicts
ifaceDeclSubBndrs _other = []
+
+-- coercion for data/newtype family instances
+famInstCo Nothing baseOcc = []
+famInstCo (Just (_, _, index)) baseOcc = [mkInstTyTcOcc index baseOcc,
+ mkInstTyCoOcc index baseOcc]
isTupleTyCon, tupleTyConBoxity, tyConStupidTheta,
tyConHasGenerics, synTyConRhs, isGadtSyntaxTyCon,
tyConArity, tyConTyVars, algTyConRhs, tyConExtName,
isTupleTyCon, tupleTyConBoxity, tyConStupidTheta,
tyConHasGenerics, synTyConRhs, isGadtSyntaxTyCon,
tyConArity, tyConTyVars, algTyConRhs, tyConExtName,
+ tyConFamInst_maybe, tyConFamInstIndex )
import DataCon ( dataConName, dataConFieldLabels, dataConStrictMarks,
dataConTyCon, dataConIsInfix, dataConUnivTyVars,
dataConExTyVars, dataConEqSpec, dataConTheta,
import DataCon ( dataConName, dataConFieldLabels, dataConStrictMarks,
dataConTyCon, dataConIsInfix, dataConUnivTyVars,
dataConExTyVars, dataConEqSpec, dataConTheta,
occ = nameOccName name
par_occ = nameOccName (nameParent name)
-- The version of the *parent* is the one want
occ = nameOccName name
par_occ = nameOccName (nameParent name)
-- The version of the *parent* is the one want
- vers = lookupVersion mod par_occ
+ vers = lookupVersion mod par_occ occ
- lookupVersion :: Module -> OccName -> Version
+ lookupVersion :: Module -> OccName -> OccName -> Version
-- Even though we're looking up a home-package thing, in
-- one-shot mode the imported interfaces may be in the PIT
-- Even though we're looking up a home-package thing, in
-- one-shot mode the imported interfaces may be in the PIT
- lookupVersion mod occ
- = mi_ver_fn iface occ `orElse`
- pprPanic "lookupVers1" (ppr mod <+> ppr occ)
+ lookupVersion mod par_occ occ
+ = mi_ver_fn iface par_occ `orElse`
+ pprPanic "lookupVers1" (ppr mod <+> ppr par_occ <+> ppr occ)
where
iface = lookupIfaceByModule (hsc_dflags hsc_env) hpt pit mod `orElse`
where
iface = lookupIfaceByModule (hsc_dflags hsc_env) hpt pit mod `orElse`
- pprPanic "lookupVers2" (ppr mod <+> ppr occ)
+ pprPanic "lookupVers2" (ppr mod <+> ppr par_occ <+> ppr occ)
ifRec = boolToRecFlag (isRecursiveTyCon tycon),
ifGadtSyntax = isGadtSyntaxTyCon tycon,
ifGeneric = tyConHasGenerics tycon,
ifRec = boolToRecFlag (isRecursiveTyCon tycon),
ifGadtSyntax = isGadtSyntaxTyCon tycon,
ifGeneric = tyConHasGenerics tycon,
- ifFamInst = famInstToIface $ tyConFamInst_maybe tycon }
+ ifFamInst = famInstToIface (tyConFamInst_maybe tycon)
+ (tyConFamInstIndex tycon) }
| isForeignTyCon tycon
= IfaceForeign { ifName = getOccName tycon,
| isForeignTyCon tycon
= IfaceForeign { ifName = getOccName tycon,
to_eq_spec spec = [(getOccName tv, toIfaceType ext ty) | (tv,ty) <- spec]
to_eq_spec spec = [(getOccName tv, toIfaceType ext ty) | (tv,ty) <- spec]
- famInstToIface Nothing = Nothing
- famInstToIface (Just (famTyCon, instTys)) =
- Just (toIfaceTyCon ext famTyCon, map (toIfaceType ext) instTys)
+ famInstToIface Nothing _ = Nothing
+ famInstToIface (Just (famTyCon, instTys)) index =
+ Just (toIfaceTyCon ext famTyCon, map (toIfaceType ext) instTys, index)
tyThingToIfaceDecl ext (ADataCon dc)
= pprPanic "toIfaceDecl" (ppr dc) -- Should be trimmed out earlier
tyThingToIfaceDecl ext (ADataCon dc)
= pprPanic "toIfaceDecl" (ppr dc) -- Should be trimmed out earlier
{ stupid_theta <- tcIfaceCtxt ctxt
; famInst <-
case mb_family of
{ stupid_theta <- tcIfaceCtxt ctxt
; famInst <-
case mb_family of
- Nothing -> return Nothing
- Just (fam, tys) ->
+ Nothing -> return Nothing
+ Just (fam, tys, index) ->
do { famTyCon <- tcIfaceTyCon fam
; insttys <- mapM tcIfaceType tys
do { famTyCon <- tcIfaceTyCon fam
; insttys <- mapM tcIfaceType tys
- ; return $ Just (famTyCon, insttys)
+ ; return $ Just (famTyCon, insttys, index)
}
; cons <- tcIfaceDataCons tc_name tycon tyvars rdr_cons
; buildAlgTyCon tc_name tyvars stupid_theta
}
; cons <- tcIfaceDataCons tc_name tycon tyvars rdr_cons
; buildAlgTyCon tc_name tyvars stupid_theta
import Type ( TyThing(..) )
import Class ( Class, classSelIds, classTyCon )
import Type ( TyThing(..) )
import Class ( Class, classSelIds, classTyCon )
-import TyCon ( TyCon, tyConSelIds, tyConDataCons, isNewTyCon, newTyConCo )
+import TyCon ( TyCon, tyConSelIds, tyConDataCons, isNewTyCon,
+ newTyConCo_maybe, tyConFamilyCoercion_maybe )
import DataCon ( dataConImplicitIds )
import PrelNames ( gHC_PRIM )
import Packages ( PackageId )
import DataCon ( dataConImplicitIds )
import PrelNames ( gHC_PRIM )
import Packages ( PackageId )
import DATA_IOREF ( IORef, readIORef )
import StringBuffer ( StringBuffer )
import DATA_IOREF ( IORef, readIORef )
import StringBuffer ( StringBuffer )
+import Maybe ( catMaybes )
import Time ( ClockTime )
\end{code}
import Time ( ClockTime )
\end{code}
-- and the selectors and generic-programming Ids too
--
-- Newtypes don't have a worker Id, so don't generate that?
-- and the selectors and generic-programming Ids too
--
-- Newtypes don't have a worker Id, so don't generate that?
-implicitTyThings (ATyCon tc) = implicitNewCoTyCon tc ++
+implicitTyThings (ATyCon tc) = implicitCoTyCon tc ++
map AnId (tyConSelIds tc) ++
map AnId (tyConSelIds tc) ++
- concatMap (extras_plus . ADataCon) (tyConDataCons tc)
+ concatMap (extras_plus . ADataCon)
+ (tyConDataCons tc)
-- For classes, add the class TyCon too (and its extras)
-- and the class selector Ids
-- For classes, add the class TyCon too (and its extras)
-- and the class selector Ids
-- For data cons add the worker and wrapper (if any)
implicitTyThings (ADataCon dc) = map AnId (dataConImplicitIds dc)
-- For data cons add the worker and wrapper (if any)
implicitTyThings (ADataCon dc) = map AnId (dataConImplicitIds dc)
- -- For newtypes, add the implicit coercion tycon
-implicitNewCoTyCon tc
- | isNewTyCon tc, Just co_con <- newTyConCo tc = [ATyCon co_con]
- | otherwise = []
+ -- For newtypes and indexed data types, add the implicit coercion tycon
+implicitCoTyCon tc
+ = map ATyCon . catMaybes $ [newTyConCo_maybe tc,
+ tyConFamilyCoercion_maybe tc]
extras_plus thing = thing : implicitTyThings thing
extras_plus thing = thing : implicitTyThings thing
splitFunTys, TyThing(ATyCon), isTyVarTy, tcEqType,
substTys, emptyTvSubst, extendTvSubst )
import Coercion ( mkSymCoercion )
splitFunTys, TyThing(ATyCon), isTyVarTy, tcEqType,
substTys, emptyTvSubst, extendTvSubst )
import Coercion ( mkSymCoercion )
-import TyCon ( TyCon, tyConName, newTyConCo, tyConTyVars,
+import TyCon ( TyCon, tyConName, newTyConCo_maybe, tyConTyVars,
isTyConAssoc, tyConFamInst_maybe,
assocTyConArgPoss_maybe )
import DataCon ( classDataCon, dataConTyCon, dataConInstArgTys )
isTyConAssoc, tyConFamInst_maybe,
assocTyConArgPoss_maybe )
import DataCon ( classDataCon, dataConTyCon, dataConInstArgTys )
where
-- For newtype T a = MkT <ty>
-- The returned coercion has kind :: C (T a):=:C <ty>
where
-- For newtype T a = MkT <ty>
-- The returned coercion has kind :: C (T a):=:C <ty>
- co_fn tvs cls_tycon cls_inst_tys | Just co_con <- newTyConCo tycon
+ co_fn tvs cls_tycon cls_inst_tys | Just co_con <- newTyConCo_maybe tycon
= ExprCoFn (mkTyConApp cls_tycon (drop_tail 1 cls_inst_tys ++
[mkSymCoercion (mkTyConApp co_con (map mkTyVarTy tvs))]))
| otherwise
= ExprCoFn (mkTyConApp cls_tycon (drop_tail 1 cls_inst_tys ++
[mkSymCoercion (mkTyConApp co_con (map mkTyVarTy tvs))]))
| otherwise
; t_typats <- mappM tcHsKindedType k_typats
; stupid_theta <- tcHsKindedContext k_ctxt
; t_typats <- mappM tcHsKindedType k_typats
; stupid_theta <- tcHsKindedContext k_ctxt
+ ; index <- nextDFunIndex -- to generate unique names
; tycon <- fixM (\ tycon -> do
{ data_cons <- mappM (addLocM (tcConDecl unbox_strict new_or_data
tycon t_tvs))
; tycon <- fixM (\ tycon -> do
{ data_cons <- mappM (addLocM (tcConDecl unbox_strict new_or_data
tycon t_tvs))
ASSERT( isSingleton data_cons )
mkNewTyConRhs tc_name tycon (head data_cons)
; buildAlgTyCon tc_name t_tvs stupid_theta tc_rhs Recursive
ASSERT( isSingleton data_cons )
mkNewTyConRhs tc_name tycon (head data_cons)
; buildAlgTyCon tc_name t_tvs stupid_theta tc_rhs Recursive
- False h98_syntax (Just (family, t_typats))
+ False h98_syntax (Just (family, t_typats, index))
-- We always assume that indexed types are recursive. Why?
-- (1) Due to their open nature, we can never be sure that a
-- further instance might not introduce a new recursive
-- We always assume that indexed types are recursive. Why?
-- (1) Due to their open nature, we can never be sure that a
-- further instance might not introduce a new recursive
tyVarsOfType, mkTyVarTys
)
import TyCon ( TyCon, tyConArity, mkCoercionTyCon, isClosedNewTyCon,
tyVarsOfType, mkTyVarTys
)
import TyCon ( TyCon, tyConArity, mkCoercionTyCon, isClosedNewTyCon,
- newTyConRhs, newTyConCo,
+ newTyConRhs, newTyConCo_maybe,
isCoercionTyCon, isCoercionTyCon_maybe )
import Var ( Var, TyVar, isTyVar, tyVarKind )
import VarSet ( elemVarSet )
isCoercionTyCon, isCoercionTyCon_maybe )
import Var ( Var, TyVar, isTyVar, tyVarKind )
import VarSet ( elemVarSet )
ASSERT( length tvs == length tys )
Just (substTyWith tvs tys rep_ty, mkTyConApp co_con tys)
where
ASSERT( length tvs == length tys )
Just (substTyWith tvs tys rep_ty, mkTyConApp co_con tys)
where
- co_con = maybe (pprPanic "splitNewTypeRepCo_maybe" (ppr tc)) id (newTyConCo tc)
+ co_con = maybe (pprPanic "splitNewTypeRepCo_maybe" (ppr tc)) id (newTyConCo_maybe tc)
splitNewTypeRepCo_maybe other = Nothing
\end{code}
splitNewTypeRepCo_maybe other = Nothing
\end{code}
isEnumerationTyCon, isGadtSyntaxTyCon, isOpenTyCon,
assocTyConArgPoss_maybe, isTyConAssoc, setTyConArgPoss,
isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, tupleTyConBoxity,
isEnumerationTyCon, isGadtSyntaxTyCon, isOpenTyCon,
assocTyConArgPoss_maybe, isTyConAssoc, setTyConArgPoss,
isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, tupleTyConBoxity,
- isRecursiveTyCon, newTyConRep, newTyConRhs, newTyConCo,
+ isRecursiveTyCon, newTyConRep, newTyConRhs, newTyConCo_maybe,
isHiBootTyCon, isSuperKindTyCon,
isCoercionTyCon_maybe, isCoercionTyCon,
isHiBootTyCon, isSuperKindTyCon,
isCoercionTyCon_maybe, isCoercionTyCon,
tyConArity,
isClassTyCon, tyConClass_maybe,
isFamInstTyCon, tyConFamInst_maybe, tyConFamilyCoercion_maybe,
tyConArity,
isClassTyCon, tyConClass_maybe,
isFamInstTyCon, tyConFamInst_maybe, tyConFamilyCoercion_maybe,
synTyConDefn, synTyConRhs, synTyConType, synTyConResKind,
tyConExtName, -- External name for foreign types
synTyConDefn, synTyConRhs, synTyConType, synTyConResKind,
tyConExtName, -- External name for foreign types
TyCon -- a *coercion* identifying
-- the representation type
-- with the type instance
TyCon -- a *coercion* identifying
-- the representation type
-- with the type instance
+ Int -- index to generate unique
+ -- name (needed here to put
+ -- into iface)
data SynTyConRhs
= OpenSynTyCon Kind -- Type family: *result* kind given
data SynTyConRhs
= OpenSynTyCon Kind -- Type family: *result* kind given
newTyConRep (AlgTyCon {tyConTyVars = tvs, algTcRhs = NewTyCon { nt_rep = rep }}) = (tvs, rep)
newTyConRep tycon = pprPanic "newTyConRep" (ppr tycon)
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 (AlgTyCon {tyConTyVars = tvs, algTcRhs = OpenNewTyCon})
- = Nothing
-newTyConCo tycon = pprPanic "newTyConCo" (ppr tycon)
+newTyConCo_maybe :: TyCon -> Maybe TyCon
+newTyConCo_maybe (AlgTyCon {algTcRhs = NewTyCon { nt_co = co }}) = co
+newTyConCo_maybe _ = Nothing
tyConPrimRep :: TyCon -> PrimRep
tyConPrimRep (PrimTyCon {primTyConRep = rep}) = rep
tyConPrimRep :: TyCon -> PrimRep
tyConPrimRep (PrimTyCon {primTyConRep = rep}) = rep
tyConClass_maybe ther_tycon = Nothing
isFamInstTyCon :: TyCon -> Bool
tyConClass_maybe ther_tycon = Nothing
isFamInstTyCon :: TyCon -> Bool
-isFamInstTyCon (AlgTyCon {algTcParent = FamilyTyCon _ _ _}) = True
-isFamInstTyCon other_tycon = False
+isFamInstTyCon (AlgTyCon {algTcParent = FamilyTyCon _ _ _ _}) = True
+isFamInstTyCon other_tycon = False
tyConFamInst_maybe :: TyCon -> Maybe (TyCon, [Type])
tyConFamInst_maybe :: TyCon -> Maybe (TyCon, [Type])
-tyConFamInst_maybe (AlgTyCon {algTcParent = FamilyTyCon fam instTys _}) =
+tyConFamInst_maybe (AlgTyCon {algTcParent = FamilyTyCon fam instTys _ _}) =
-tyConFamInst_maybe ther_tycon =
+tyConFamInst_maybe ther_tycon =
Nothing
tyConFamilyCoercion_maybe :: TyCon -> Maybe TyCon
Nothing
tyConFamilyCoercion_maybe :: TyCon -> Maybe TyCon
-tyConFamilyCoercion_maybe (AlgTyCon {algTcParent = FamilyTyCon _ _ coe}) =
+tyConFamilyCoercion_maybe (AlgTyCon {algTcParent = FamilyTyCon _ _ coe _}) =
-tyConFamilyCoercion_maybe ther_tycon =
+tyConFamilyCoercion_maybe ther_tycon =
+
+tyConFamInstIndex :: TyCon -> Int
+tyConFamInstIndex (AlgTyCon {algTcParent = FamilyTyCon _ _ _ index}) = index
+tyConFamInstIndex _ =
+ panic "tyConFamInstIndex"