tyConStupidTheta, isProductTyCon, isDataTyCon,
isRecursiveTyCon, isFamInstTyCon,
tyConFamInst_maybe, tyConFamilyCoercion_maybe,
- newTyConCo )
+ newTyConCo_maybe )
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
- = 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
- | otherwise -- Algebraic, no wrapper
+ | otherwise -- Algebraic, no wrapper
= DCIds Nothing wrk_id
where
(univ_tvs, ex_tvs, eq_spec,
= 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
--
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
-- 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")
-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.
--
-mkInstTyCoOcc :: Unique -- Unique
+mkInstTyCoOcc :: Int -- Index
-> 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)
\end{code}
\begin{code}
-> 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
-- (3) Produce a `AlgTyConParent' value containing the parent and coercion
-- information.
--
- maybeComputeFamilyInfo Nothing rep_tycon =
+ maybeComputeFamilyInfo Nothing rep_tycon =
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
- ; uniq <- newUnique
- ; final_name <- newImplicitBinder tc_name (mkInstTyTcOcc uniq)
+ ; final_name <- newImplicitBinder tc_name (mkInstTyTcOcc index)
-- (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.
- ; 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
- [IfaceType]) -- Instance types
+ [IfaceType], -- Instance types
+ Int ) -- Unique index for naming
}
| IfaceSyn { ifName :: OccName, -- Type constructor
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
-- 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) &&&
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 Binary ( getBinFileWithDict )
import Panic ( ghcError, tryMost, showException, GhcException(..) )
import List ( nub )
+import Maybe ( isJust )
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)
- ; 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
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
+ ++ famInstCo famInst tc_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)
+ || not (null . ifConEqSpec $ con_decl)
+ || isJust famInst
-- 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]
\end{code}
isTupleTyCon, tupleTyConBoxity, tyConStupidTheta,
tyConHasGenerics, synTyConRhs, isGadtSyntaxTyCon,
tyConArity, tyConTyVars, algTyConRhs, tyConExtName,
- tyConFamInst_maybe )
+ tyConFamInst_maybe, tyConFamInstIndex )
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
- 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
- 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`
- 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,
- ifFamInst = famInstToIface $ tyConFamInst_maybe tycon }
+ ifFamInst = famInstToIface (tyConFamInst_maybe tycon)
+ (tyConFamInstIndex tycon) }
| isForeignTyCon tycon
= IfaceForeign { ifName = getOccName tycon,
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
{ 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
- ; return $ Just (famTyCon, insttys)
+ ; return $ Just (famTyCon, insttys, index)
}
; cons <- tcIfaceDataCons tc_name tycon tyvars rdr_cons
; buildAlgTyCon tc_name tyvars stupid_theta
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 DATA_IOREF ( IORef, readIORef )
import StringBuffer ( StringBuffer )
+import Maybe ( catMaybes )
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?
-implicitTyThings (ATyCon tc) = implicitNewCoTyCon tc ++
+implicitTyThings (ATyCon tc) = implicitCoTyCon 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 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
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 )
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
; 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))
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
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 )
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}
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,
tyConArity,
isClassTyCon, tyConClass_maybe,
isFamInstTyCon, tyConFamInst_maybe, tyConFamilyCoercion_maybe,
+ tyConFamInstIndex,
synTyConDefn, synTyConRhs, synTyConType, synTyConResKind,
tyConExtName, -- External name for foreign types
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
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
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 (AlgTyCon {algTcParent = FamilyTyCon fam instTys _}) =
+tyConFamInst_maybe (AlgTyCon {algTcParent = FamilyTyCon fam instTys _ _}) =
Just (fam, instTys)
-tyConFamInst_maybe ther_tycon =
+tyConFamInst_maybe ther_tycon =
Nothing
tyConFamilyCoercion_maybe :: TyCon -> Maybe TyCon
-tyConFamilyCoercion_maybe (AlgTyCon {algTcParent = FamilyTyCon _ _ coe}) =
+tyConFamilyCoercion_maybe (AlgTyCon {algTcParent = FamilyTyCon _ _ coe _}) =
Just coe
-tyConFamilyCoercion_maybe ther_tycon =
+tyConFamilyCoercion_maybe ther_tycon =
Nothing
+
+tyConFamInstIndex :: TyCon -> Int
+tyConFamInstIndex (AlgTyCon {algTcParent = FamilyTyCon _ _ _ index}) = index
+tyConFamInstIndex _ =
+ panic "tyConFamInstIndex"
\end{code}
projects / ghc-hetmet.git / commitdiff