tcExtendGlobalValEnv, tcExtendLocalValEnv,
tcLookupLocalValue, tcLookupLocalValueOK, tcLookupLocalValueByKey,
tcLookupGlobalValue, tcLookupGlobalValueByKey, tcLookupGlobalValueMaybe,
- tcAddImportedIdInfo,
+ tcAddImportedIdInfo, tcExplicitLookupGlobal,
tcLookupGlobalValueByKeyMaybe,
newMonoIds, newLocalIds, newLocalId,
IMP_Ubiq()
#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
IMPORT_DELOOPER(TcMLoop) -- for paranoia checking
-#else
-import {-# SOURCE #-} TcType
#endif
import HsTypes ( HsTyVar(..) )
import PprType ( GenTyVar )
import Type ( tyVarsOfTypes, splitForAllTy )
import TyCon ( TyCon, tyConKind, synTyConArity, SYN_IE(Arity) )
-import Class ( SYN_IE(Class), GenClass, classSig )
+import Class ( SYN_IE(Class), GenClass )
import TcMonad
import IdInfo ( noIdInfo )
import Name ( Name, OccName(..), getSrcLoc, occNameString,
- maybeWiredInTyConName, maybeWiredInIdName,
+ maybeWiredInTyConName, maybeWiredInIdName, isLocallyDefined,
NamedThing(..)
)
import Pretty
tcLookupGlobalValue :: Name -> NF_TcM s Id
-
tcLookupGlobalValue name
= case maybeWiredInIdName name of
Just id -> returnNF_Tc id
def = pprPanic "tcLookupGlobalValue:" (ppr PprDebug name)
tcLookupGlobalValueMaybe :: Name -> NF_TcM s (Maybe Id)
-
tcLookupGlobalValueMaybe name
= case maybeWiredInIdName name of
Just id -> returnNF_Tc (Just id)
= tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
returnNF_Tc (lookupUFM_Directly gve uniq)
+
+-- Non-monadic version, environment given explicitly
+tcExplicitLookupGlobal :: TcEnv s -> Name -> Maybe Id
+tcExplicitLookupGlobal (TcEnv tve tce ce gve lve gtvs) name
+ = case maybeWiredInIdName name of
+ Just id -> Just id
+ Nothing -> lookupUFM gve name
+
-- Extract the IdInfo from an IfaceSig imported from an interface file
-tcAddImportedIdInfo :: Id -> NF_TcM s Id
-tcAddImportedIdInfo id
- = tcLookupGlobalValueMaybe (getName id) `thenNF_Tc` \ maybe_id ->
- let
- new_info = case maybe_id of
+tcAddImportedIdInfo :: TcEnv s -> Id -> Id
+tcAddImportedIdInfo unf_env id
+ | isLocallyDefined id -- Don't look up locally defined Ids, because they
+ -- have explicit local definitions, so we get a black hole!
+ = id
+ | otherwise
+ = id `replaceIdInfo` new_info
+ -- The Id must be returned without a data dependency on maybe_id
+ where
+ new_info = -- pprTrace "tcAdd" (ppr PprDebug id) $
+ case tcExplicitLookupGlobal unf_env (getName id) of
Nothing -> noIdInfo
Just imported_id -> getIdInfo imported_id
-- ToDo: could check that types are the same
- in
- returnNF_Tc (id `replaceIdInfo` new_info)
- -- The Id must be returned without a data dependency on maybe_id
\end{code}
newTyVarTy, newTyVarTys, zonkTcTyVars, zonkTcType )
import TcKind ( TcKind )
-import Class ( SYN_IE(Class), classSig )
+import Class ( SYN_IE(Class) )
import FieldLabel ( FieldLabel, fieldLabelName, fieldLabelType )
import Id ( idType, dataConFieldLabels, dataConSig, recordSelectorFieldLabel,
isRecordSelector,
where
tc_expr expr = tcExpr expr `thenTc` \ (expr', lie, ty) ->
returnTc ((expr',ty), lie)
- combiner bind (expr, ty) = (HsLet bind expr, ty)
+ combiner is_rec bind (expr, ty) = (HsLet (MonoBind bind [] is_rec) expr, ty)
tcExpr in_expr@(HsCase expr matches src_loc)
= tcAddSrcLoc src_loc $
binds
do_next
where
- combine' binds' thing' = combine (LetStmt binds') Nothing thing'
+ combine' is_rec binds' thing' = combine (LetStmt (MonoBind binds' [] is_rec)) Nothing thing'
\end{code}
%************************************************************************
) `thenTc` \ (grhss_and_binds'@(GRHSsAndBindsOut _ _ result_ty), lie) ->
returnTc (grhss_and_binds', lie, result_ty)
where
- combiner binds1 (GRHSsAndBindsOut grhss binds2 ty)
- = GRHSsAndBindsOut grhss (binds1 `ThenBinds` binds2) ty
+ combiner is_rec binds1 (GRHSsAndBindsOut grhss binds2 ty)
+ = GRHSsAndBindsOut grhss ((MonoBind binds1 [] is_rec) `ThenBinds` binds2) ty
\end{code}
import RdrHsSyn ( RdrName(..), varQual, varUnqual, mkOpApp,
SYN_IE(RdrNameMonoBinds), SYN_IE(RdrNameHsExpr), SYN_IE(RdrNamePat)
)
+import BasicTypes ( IfaceFlavour(..) )
import Id ( GenId, isNullaryDataCon, dataConTag,
dataConRawArgTys, fIRST_TAG,
isDataCon, SYN_IE(DataCon), SYN_IE(ConTag),
\end{code}
\begin{code}
-qual_orig_name n = case modAndOcc n of { (m,n) -> Qual m n }
+qual_orig_name n = case modAndOcc n of { (m,n) -> Qual m n HiFile }
a_RDR = varUnqual SLIT("a")
b_RDR = varUnqual SLIT("b")
mkHsTyLam, mkHsDictLam,
tcIdType, tcIdTyVars,
- zonkBinds, zonkMonoBinds
+ zonkTopBinds, zonkBinds, zonkMonoBinds
) where
IMP_Ubiq(){-uitous-}
import HsSyn -- oodles of it
import Id ( GenId(..), IdDetails, -- Can meddle modestly with Ids
SYN_IE(DictVar), idType,
- SYN_IE(IdEnv), growIdEnvList, lookupIdEnv,
SYN_IE(Id)
)
-- others:
import Name ( Name{--O only-}, NamedThing(..) )
+import BasicTypes ( IfaceFlavour )
+import TcEnv ( tcLookupGlobalValueMaybe, tcExtendGlobalValEnv )
import TcMonad
import TcType ( SYN_IE(TcType), TcMaybe, SYN_IE(TcTyVar),
zonkTcTypeToType, zonkTcTyVarToTyVar
import PprType ( GenType, GenTyVar ) -- instances
import Type ( mkTyVarTy, tyVarsOfType, SYN_IE(Type) )
import TyVar ( GenTyVar {- instances -}, SYN_IE(TyVar),
- SYN_IE(TyVarEnv), growTyVarEnvList, emptyTyVarSet )
+ SYN_IE(TyVarEnv), nullTyVarEnv, growTyVarEnvList, emptyTyVarSet )
import TysPrim ( voidTy )
import CoreSyn ( GenCoreExpr )
import Unique ( Unique ) -- instances
+import Bag
import UniqFM
import Outputable
import Pretty
a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc
b) convert unbound TcTyVar to Void
+ c) convert each TcIdBndr to an Id by zonking its type
We pass an environment around so that
+
a) we know which TyVars are unbound
b) we maintain sharing; eg an Id is zonked at its binding site and they
all occurrences of that Id point to the common zonked copy
+Actually, since this is all in the Tc monad, it's convenient to keep the
+mapping from TcIds to Ids in the GVE of the Tc monad. (Those TcIds
+were previously in the LVE of the Tc monad.)
+
It's all pretty boring stuff, because HsSyn is such a large type, and
the environment manipulation is tiresome.
\begin{code}
+extend_te te tyvars = growTyVarEnvList te [(tyvar, mkTyVarTy tyvar) | tyvar <- tyvars]
+
zonkIdBndr :: TyVarEnv Type -> TcIdOcc s -> NF_TcM s Id
zonkIdBndr te (TcId (Id u n ty details prags info))
= zonkTcTypeToType te ty `thenNF_Tc` \ ty' ->
zonkIdBndr te (RealId id) = returnNF_Tc id
-zonkIdOcc :: IdEnv Id -> TcIdOcc s -> Id
-zonkIdOcc ve (RealId id) = id
-zonkIdOcc ve (TcId id) = case (lookupIdEnv ve id) of
- Just id' -> id'
- Nothing -> pprTrace "zonkIdOcc: " (ppr PprDebug id) $
- Id u n voidTy details prags info
- where
- Id u n _ details prags info = id
-
-extend_ve ve ids = growIdEnvList ve [(id,id) | id <- ids]
-extend_te te tyvars = growTyVarEnvList te [(tyvar, mkTyVarTy tyvar) | tyvar <- tyvars]
+zonkIdOcc :: TcIdOcc s -> NF_TcM s Id
+zonkIdOcc (RealId id) = returnNF_Tc id
+zonkIdOcc (TcId id)
+ = tcLookupGlobalValueMaybe (getName id) `thenNF_Tc` \ maybe_id' ->
+ let
+ new_id = case maybe_id' of
+ Just id' -> id'
+ Nothing -> pprTrace "zonkIdOcc: " (ppr PprDebug id) $
+ Id u n voidTy details prags info
+ where
+ Id u n _ details prags info = id
+ in
+ returnNF_Tc new_id
\end{code}
\begin{code}
-zonkBinds :: TyVarEnv Type -> IdEnv Id
- -> TcHsBinds s -> NF_TcM s (TypecheckedHsBinds, IdEnv Id)
-
-zonkBinds te ve EmptyBinds = returnNF_Tc (EmptyBinds, ve)
-
-zonkBinds te ve (ThenBinds binds1 binds2)
- = zonkBinds te ve binds1 `thenNF_Tc` \ (new_binds1, ve1) ->
- zonkBinds te ve1 binds2 `thenNF_Tc` \ (new_binds2, ve2) ->
- returnNF_Tc (ThenBinds new_binds1 new_binds2, ve2)
-
-zonkBinds te ve (MonoBind bind sigs is_rec)
- = ASSERT( null sigs )
- fixNF_Tc (\ ~(_,new_ve) ->
- zonkMonoBinds te new_ve bind `thenNF_Tc` \ (new_bind, new_ids) ->
- returnNF_Tc (MonoBind new_bind [] is_rec, extend_ve ve new_ids)
- )
+zonkTopBinds :: TcMonoBinds s -> NF_TcM s (TypecheckedMonoBinds, TcEnv s)
+zonkTopBinds binds -- Top level is implicitly recursive
+ = fixNF_Tc (\ ~(_, new_ids) ->
+ tcExtendGlobalValEnv (bagToList new_ids) $
+ zonkMonoBinds nullTyVarEnv binds `thenNF_Tc` \ (binds', new_ids) ->
+ tcGetEnv `thenNF_Tc` \ env ->
+ returnNF_Tc ((binds', env), new_ids)
+ ) `thenNF_Tc` \ (stuff, _) ->
+ returnNF_Tc stuff
+
+
+zonkBinds :: TyVarEnv Type
+ -> TcHsBinds s
+ -> NF_TcM s (TypecheckedHsBinds, TcEnv s)
+
+zonkBinds te binds
+ = go binds (\ binds' -> tcGetEnv `thenNF_Tc` \ env -> returnNF_Tc (binds', env))
+ where
+ -- go :: TcHsBinds s -> (TypecheckedHsBinds -> NF_TcM s (TypecheckedHsBinds, TcEnv s))
+ -- -> NF_TcM s (TypecheckedHsBinds, TcEnv s)
+ go (ThenBinds b1 b2) thing_inside = go b1 $ \ b1' ->
+ go b2 $ \ b2' ->
+ thing_inside (b1' `ThenBinds` b2')
+
+ go EmptyBinds thing_inside = thing_inside EmptyBinds
+
+ go (MonoBind bind sigs is_rec) thing_inside
+ = ASSERT( null sigs )
+ fixNF_Tc (\ ~(_, new_ids) ->
+ tcExtendGlobalValEnv (bagToList new_ids) $
+ zonkMonoBinds te bind `thenNF_Tc` \ (new_bind, new_ids) ->
+ thing_inside (MonoBind new_bind [] is_rec) `thenNF_Tc` \ stuff ->
+ returnNF_Tc (stuff, new_ids)
+ ) `thenNF_Tc` \ (stuff, _) ->
+ returnNF_Tc stuff
\end{code}
\begin{code}
-------------------------------------------------------------------------
-zonkMonoBinds :: TyVarEnv Type -> IdEnv Id
- -> TcMonoBinds s -> NF_TcM s (TypecheckedMonoBinds, [Id])
+zonkMonoBinds :: TyVarEnv Type
+ -> TcMonoBinds s
+ -> NF_TcM s (TypecheckedMonoBinds, Bag Id)
-zonkMonoBinds te ve EmptyMonoBinds = returnNF_Tc (EmptyMonoBinds, [])
+zonkMonoBinds te EmptyMonoBinds = returnNF_Tc (EmptyMonoBinds, emptyBag)
-zonkMonoBinds te ve (AndMonoBinds mbinds1 mbinds2)
- = zonkMonoBinds te ve mbinds1 `thenNF_Tc` \ (new_mbinds1, ids1) ->
- zonkMonoBinds te ve mbinds2 `thenNF_Tc` \ (new_mbinds2, ids2) ->
- returnNF_Tc (AndMonoBinds new_mbinds1 new_mbinds2, ids1 ++ ids2)
+zonkMonoBinds te (AndMonoBinds mbinds1 mbinds2)
+ = zonkMonoBinds te mbinds1 `thenNF_Tc` \ (b1', ids1) ->
+ zonkMonoBinds te mbinds2 `thenNF_Tc` \ (b2', ids2) ->
+ returnNF_Tc (b1' `AndMonoBinds` b2', ids1 `unionBags` ids2)
-zonkMonoBinds te ve (PatMonoBind pat grhss_w_binds locn)
- = zonkPat te ve pat `thenNF_Tc` \ (new_pat, ids) ->
- zonkGRHSsAndBinds te ve grhss_w_binds `thenNF_Tc` \ new_grhss_w_binds ->
+zonkMonoBinds te (PatMonoBind pat grhss_w_binds locn)
+ = zonkPat te pat `thenNF_Tc` \ (new_pat, ids) ->
+ zonkGRHSsAndBinds te grhss_w_binds `thenNF_Tc` \ new_grhss_w_binds ->
returnNF_Tc (PatMonoBind new_pat new_grhss_w_binds locn, ids)
-zonkMonoBinds te ve (VarMonoBind var expr)
+zonkMonoBinds te (VarMonoBind var expr)
= zonkIdBndr te var `thenNF_Tc` \ new_var ->
- zonkExpr te ve expr `thenNF_Tc` \ new_expr ->
- returnNF_Tc (VarMonoBind new_var new_expr, [new_var])
+ zonkExpr te expr `thenNF_Tc` \ new_expr ->
+ returnNF_Tc (VarMonoBind new_var new_expr, unitBag new_var)
-zonkMonoBinds te ve (CoreMonoBind var core_expr)
+zonkMonoBinds te (CoreMonoBind var core_expr)
= zonkIdBndr te var `thenNF_Tc` \ new_var ->
- returnNF_Tc (CoreMonoBind new_var core_expr, [new_var])
+ returnNF_Tc (CoreMonoBind new_var core_expr, unitBag new_var)
-zonkMonoBinds te ve (FunMonoBind var inf ms locn)
+zonkMonoBinds te (FunMonoBind var inf ms locn)
= zonkIdBndr te var `thenNF_Tc` \ new_var ->
- mapNF_Tc (zonkMatch te ve) ms `thenNF_Tc` \ new_ms ->
- returnNF_Tc (FunMonoBind new_var inf new_ms locn, [new_var])
+ mapNF_Tc (zonkMatch te) ms `thenNF_Tc` \ new_ms ->
+ returnNF_Tc (FunMonoBind new_var inf new_ms locn, unitBag new_var)
-zonkMonoBinds te ve (AbsBinds tyvars dicts exports val_bind)
+zonkMonoBinds te (AbsBinds tyvars dicts exports val_bind)
= mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars ->
let
new_te = extend_te te new_tyvars
in
mapNF_Tc (zonkIdBndr new_te) dicts `thenNF_Tc` \ new_dicts ->
- let
- ve1 = extend_ve ve new_dicts
- in
- fixNF_Tc (\ ~(_, _, ve2) ->
- zonkMonoBinds new_te ve2 val_bind `thenNF_Tc` \ (new_val_bind, new_ids) ->
- mapNF_Tc (zonkExport new_te ve2) exports `thenNF_Tc` \ new_exports ->
- returnNF_Tc (new_val_bind, new_exports, extend_ve ve1 new_ids)
+ tcExtendGlobalValEnv new_dicts $
+ fixNF_Tc (\ ~(_, _, val_bind_ids) ->
+ tcExtendGlobalValEnv (bagToList val_bind_ids) $
+ zonkMonoBinds new_te val_bind `thenNF_Tc` \ (new_val_bind, val_bind_ids) ->
+ mapNF_Tc (zonkExport new_te) exports `thenNF_Tc` \ new_exports ->
+ returnNF_Tc (new_val_bind, new_exports, val_bind_ids)
) `thenNF_Tc ` \ (new_val_bind, new_exports, _) ->
-
let
- new_globals = [global | (_, global, local) <- new_exports]
+ new_globals = listToBag [global | (_, global, local) <- new_exports]
in
returnNF_Tc (AbsBinds new_tyvars new_dicts new_exports new_val_bind,
new_globals)
-
where
- zonkExport te ve (tyvars, global, local)
+ zonkExport te (tyvars, global, local)
= mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars ->
zonkIdBndr te global `thenNF_Tc` \ new_global ->
- returnNF_Tc (new_tyvars, new_global, zonkIdOcc ve local)
+ zonkIdOcc local `thenNF_Tc` \ new_local ->
+ returnNF_Tc (new_tyvars, new_global, new_local)
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-zonkMatch :: TyVarEnv Type -> IdEnv Id
+zonkMatch :: TyVarEnv Type
-> TcMatch s -> NF_TcM s TypecheckedMatch
-zonkMatch te ve (PatMatch pat match)
- = zonkPat te ve pat `thenNF_Tc` \ (new_pat, ids) ->
- let
- new_ve = extend_ve ve ids
- in
- zonkMatch te new_ve match `thenNF_Tc` \ new_match ->
+zonkMatch te (PatMatch pat match)
+ = zonkPat te pat `thenNF_Tc` \ (new_pat, ids) ->
+ tcExtendGlobalValEnv (bagToList ids) $
+ zonkMatch te match `thenNF_Tc` \ new_match ->
returnNF_Tc (PatMatch new_pat new_match)
-zonkMatch te ve (GRHSMatch grhss_w_binds)
- = zonkGRHSsAndBinds te ve grhss_w_binds `thenNF_Tc` \ new_grhss_w_binds ->
+zonkMatch te (GRHSMatch grhss_w_binds)
+ = zonkGRHSsAndBinds te grhss_w_binds `thenNF_Tc` \ new_grhss_w_binds ->
returnNF_Tc (GRHSMatch new_grhss_w_binds)
-zonkMatch te ve (SimpleMatch expr)
- = zonkExpr te ve expr `thenNF_Tc` \ new_expr ->
+zonkMatch te (SimpleMatch expr)
+ = zonkExpr te expr `thenNF_Tc` \ new_expr ->
returnNF_Tc (SimpleMatch new_expr)
-------------------------------------------------------------------------
-zonkGRHSsAndBinds :: TyVarEnv Type -> IdEnv Id
+zonkGRHSsAndBinds :: TyVarEnv Type
-> TcGRHSsAndBinds s
-> NF_TcM s TypecheckedGRHSsAndBinds
-zonkGRHSsAndBinds te ve (GRHSsAndBindsOut grhss binds ty)
- = zonkBinds te ve binds `thenNF_Tc` \ (new_binds, new_ve) ->
+zonkGRHSsAndBinds te (GRHSsAndBindsOut grhss binds ty)
+ = zonkBinds te binds `thenNF_Tc` \ (new_binds, new_env) ->
+ tcSetEnv new_env $
let
zonk_grhs (GRHS guard expr locn)
- = zonkStmts te new_ve guard `thenNF_Tc` \ (new_guard, new_ve2) ->
- zonkExpr te new_ve2 expr `thenNF_Tc` \ new_expr ->
+ = zonkStmts te guard `thenNF_Tc` \ (new_guard, new_env) ->
+ tcSetEnv new_env $
+ zonkExpr te expr `thenNF_Tc` \ new_expr ->
returnNF_Tc (GRHS new_guard new_expr locn)
zonk_grhs (OtherwiseGRHS expr locn)
- = zonkExpr te new_ve expr `thenNF_Tc` \ new_expr ->
+ = zonkExpr te expr `thenNF_Tc` \ new_expr ->
returnNF_Tc (OtherwiseGRHS new_expr locn)
in
mapNF_Tc zonk_grhs grhss `thenNF_Tc` \ new_grhss ->
%************************************************************************
\begin{code}
-{-
-zonkExpr :: TyVarEnv Type -> IdEnv Id
+zonkExpr :: TyVarEnv Type
-> TcExpr s -> NF_TcM s TypecheckedHsExpr
--}
-zonkExpr te ve (HsVar name)
- = returnNF_Tc (HsVar (zonkIdOcc ve name))
-zonkExpr te ve (HsLit _) = panic "zonkExpr te ve:HsLit"
+zonkExpr te (HsVar id)
+ = zonkIdOcc id `thenNF_Tc` \ id' ->
+ returnNF_Tc (HsVar id')
-zonkExpr te ve (HsLitOut lit ty)
+zonkExpr te (HsLit _) = panic "zonkExpr te:HsLit"
+
+zonkExpr te (HsLitOut lit ty)
= zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
returnNF_Tc (HsLitOut lit new_ty)
-zonkExpr te ve (HsLam match)
- = zonkMatch te ve match `thenNF_Tc` \ new_match ->
+zonkExpr te (HsLam match)
+ = zonkMatch te match `thenNF_Tc` \ new_match ->
returnNF_Tc (HsLam new_match)
-zonkExpr te ve (HsApp e1 e2)
- = zonkExpr te ve e1 `thenNF_Tc` \ new_e1 ->
- zonkExpr te ve e2 `thenNF_Tc` \ new_e2 ->
+zonkExpr te (HsApp e1 e2)
+ = zonkExpr te e1 `thenNF_Tc` \ new_e1 ->
+ zonkExpr te e2 `thenNF_Tc` \ new_e2 ->
returnNF_Tc (HsApp new_e1 new_e2)
-zonkExpr te ve (OpApp e1 op fixity e2)
- = zonkExpr te ve e1 `thenNF_Tc` \ new_e1 ->
- zonkExpr te ve op `thenNF_Tc` \ new_op ->
- zonkExpr te ve e2 `thenNF_Tc` \ new_e2 ->
+zonkExpr te (OpApp e1 op fixity e2)
+ = zonkExpr te e1 `thenNF_Tc` \ new_e1 ->
+ zonkExpr te op `thenNF_Tc` \ new_op ->
+ zonkExpr te e2 `thenNF_Tc` \ new_e2 ->
returnNF_Tc (OpApp new_e1 new_op fixity new_e2)
-zonkExpr te ve (NegApp _ _) = panic "zonkExpr te ve:NegApp"
-zonkExpr te ve (HsPar _) = panic "zonkExpr te ve:HsPar"
+zonkExpr te (NegApp _ _) = panic "zonkExpr te:NegApp"
+zonkExpr te (HsPar _) = panic "zonkExpr te:HsPar"
-zonkExpr te ve (SectionL expr op)
- = zonkExpr te ve expr `thenNF_Tc` \ new_expr ->
- zonkExpr te ve op `thenNF_Tc` \ new_op ->
+zonkExpr te (SectionL expr op)
+ = zonkExpr te expr `thenNF_Tc` \ new_expr ->
+ zonkExpr te op `thenNF_Tc` \ new_op ->
returnNF_Tc (SectionL new_expr new_op)
-zonkExpr te ve (SectionR op expr)
- = zonkExpr te ve op `thenNF_Tc` \ new_op ->
- zonkExpr te ve expr `thenNF_Tc` \ new_expr ->
+zonkExpr te (SectionR op expr)
+ = zonkExpr te op `thenNF_Tc` \ new_op ->
+ zonkExpr te expr `thenNF_Tc` \ new_expr ->
returnNF_Tc (SectionR new_op new_expr)
-zonkExpr te ve (HsCase expr ms src_loc)
- = zonkExpr te ve expr `thenNF_Tc` \ new_expr ->
- mapNF_Tc (zonkMatch te ve) ms `thenNF_Tc` \ new_ms ->
+zonkExpr te (HsCase expr ms src_loc)
+ = zonkExpr te expr `thenNF_Tc` \ new_expr ->
+ mapNF_Tc (zonkMatch te) ms `thenNF_Tc` \ new_ms ->
returnNF_Tc (HsCase new_expr new_ms src_loc)
-zonkExpr te ve (HsIf e1 e2 e3 src_loc)
- = zonkExpr te ve e1 `thenNF_Tc` \ new_e1 ->
- zonkExpr te ve e2 `thenNF_Tc` \ new_e2 ->
- zonkExpr te ve e3 `thenNF_Tc` \ new_e3 ->
+zonkExpr te (HsIf e1 e2 e3 src_loc)
+ = zonkExpr te e1 `thenNF_Tc` \ new_e1 ->
+ zonkExpr te e2 `thenNF_Tc` \ new_e2 ->
+ zonkExpr te e3 `thenNF_Tc` \ new_e3 ->
returnNF_Tc (HsIf new_e1 new_e2 new_e3 src_loc)
-zonkExpr te ve (HsLet binds expr)
- = zonkBinds te ve binds `thenNF_Tc` \ (new_binds, new_ve) ->
- zonkExpr te new_ve expr `thenNF_Tc` \ new_expr ->
+zonkExpr te (HsLet binds expr)
+ = zonkBinds te binds `thenNF_Tc` \ (new_binds, new_env) ->
+ tcSetEnv new_env $
+ zonkExpr te expr `thenNF_Tc` \ new_expr ->
returnNF_Tc (HsLet new_binds new_expr)
-zonkExpr te ve (HsDo _ _ _) = panic "zonkExpr te ve:HsDo"
+zonkExpr te (HsDo _ _ _) = panic "zonkExpr te:HsDo"
-zonkExpr te ve (HsDoOut do_or_lc stmts return_id then_id zero_id ty src_loc)
- = zonkStmts te ve stmts `thenNF_Tc` \ (new_stmts, _) ->
+zonkExpr te (HsDoOut do_or_lc stmts return_id then_id zero_id ty src_loc)
+ = zonkStmts te stmts `thenNF_Tc` \ (new_stmts, _) ->
zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
- returnNF_Tc (HsDoOut do_or_lc new_stmts
- (zonkIdOcc ve return_id)
- (zonkIdOcc ve then_id)
- (zonkIdOcc ve zero_id)
+ zonkIdOcc return_id `thenNF_Tc` \ new_return_id ->
+ zonkIdOcc then_id `thenNF_Tc` \ new_then_id ->
+ zonkIdOcc zero_id `thenNF_Tc` \ new_zero_id ->
+ returnNF_Tc (HsDoOut do_or_lc new_stmts new_return_id new_then_id new_zero_id
new_ty src_loc)
-zonkExpr te ve (ExplicitList _) = panic "zonkExpr te ve:ExplicitList"
+zonkExpr te (ExplicitList _) = panic "zonkExpr te:ExplicitList"
-zonkExpr te ve (ExplicitListOut ty exprs)
+zonkExpr te (ExplicitListOut ty exprs)
= zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
- mapNF_Tc (zonkExpr te ve) exprs `thenNF_Tc` \ new_exprs ->
+ mapNF_Tc (zonkExpr te) exprs `thenNF_Tc` \ new_exprs ->
returnNF_Tc (ExplicitListOut new_ty new_exprs)
-zonkExpr te ve (ExplicitTuple exprs)
- = mapNF_Tc (zonkExpr te ve) exprs `thenNF_Tc` \ new_exprs ->
+zonkExpr te (ExplicitTuple exprs)
+ = mapNF_Tc (zonkExpr te) exprs `thenNF_Tc` \ new_exprs ->
returnNF_Tc (ExplicitTuple new_exprs)
-zonkExpr te ve (RecordCon con rbinds)
- = zonkExpr te ve con `thenNF_Tc` \ new_con ->
- zonkRbinds te ve rbinds `thenNF_Tc` \ new_rbinds ->
+zonkExpr te (RecordCon con rbinds)
+ = zonkExpr te con `thenNF_Tc` \ new_con ->
+ zonkRbinds te rbinds `thenNF_Tc` \ new_rbinds ->
returnNF_Tc (RecordCon new_con new_rbinds)
-zonkExpr te ve (RecordUpd _ _) = panic "zonkExpr te ve:RecordUpd"
+zonkExpr te (RecordUpd _ _) = panic "zonkExpr te:RecordUpd"
-zonkExpr te ve (RecordUpdOut expr ty dicts rbinds)
- = zonkExpr te ve expr `thenNF_Tc` \ new_expr ->
+zonkExpr te (RecordUpdOut expr ty dicts rbinds)
+ = zonkExpr te expr `thenNF_Tc` \ new_expr ->
zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
- zonkRbinds te ve rbinds `thenNF_Tc` \ new_rbinds ->
+ mapNF_Tc zonkIdOcc dicts `thenNF_Tc` \ new_dicts ->
+ zonkRbinds te rbinds `thenNF_Tc` \ new_rbinds ->
returnNF_Tc (RecordUpdOut new_expr new_ty new_dicts new_rbinds)
- where
- new_dicts = map (zonkIdOcc ve) dicts
-zonkExpr te ve (ExprWithTySig _ _) = panic "zonkExpr te ve:ExprWithTySig"
-zonkExpr te ve (ArithSeqIn _) = panic "zonkExpr te ve:ArithSeqIn"
+zonkExpr te (ExprWithTySig _ _) = panic "zonkExpr te:ExprWithTySig"
+zonkExpr te (ArithSeqIn _) = panic "zonkExpr te:ArithSeqIn"
-zonkExpr te ve (ArithSeqOut expr info)
- = zonkExpr te ve expr `thenNF_Tc` \ new_expr ->
- zonkArithSeq te ve info `thenNF_Tc` \ new_info ->
+zonkExpr te (ArithSeqOut expr info)
+ = zonkExpr te expr `thenNF_Tc` \ new_expr ->
+ zonkArithSeq te info `thenNF_Tc` \ new_info ->
returnNF_Tc (ArithSeqOut new_expr new_info)
-zonkExpr te ve (CCall fun args may_gc is_casm result_ty)
- = mapNF_Tc (zonkExpr te ve) args `thenNF_Tc` \ new_args ->
+zonkExpr te (CCall fun args may_gc is_casm result_ty)
+ = mapNF_Tc (zonkExpr te) args `thenNF_Tc` \ new_args ->
zonkTcTypeToType te result_ty `thenNF_Tc` \ new_result_ty ->
returnNF_Tc (CCall fun new_args may_gc is_casm new_result_ty)
-zonkExpr te ve (HsSCC label expr)
- = zonkExpr te ve expr `thenNF_Tc` \ new_expr ->
+zonkExpr te (HsSCC label expr)
+ = zonkExpr te expr `thenNF_Tc` \ new_expr ->
returnNF_Tc (HsSCC label new_expr)
-zonkExpr te ve (TyLam tyvars expr)
+zonkExpr te (TyLam tyvars expr)
= mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars ->
let
new_te = extend_te te new_tyvars
in
- zonkExpr new_te ve expr `thenNF_Tc` \ new_expr ->
+ zonkExpr new_te expr `thenNF_Tc` \ new_expr ->
returnNF_Tc (TyLam new_tyvars new_expr)
-zonkExpr te ve (TyApp expr tys)
- = zonkExpr te ve expr `thenNF_Tc` \ new_expr ->
+zonkExpr te (TyApp expr tys)
+ = zonkExpr te expr `thenNF_Tc` \ new_expr ->
mapNF_Tc (zonkTcTypeToType te) tys `thenNF_Tc` \ new_tys ->
returnNF_Tc (TyApp new_expr new_tys)
-zonkExpr te ve (DictLam dicts expr)
+zonkExpr te (DictLam dicts expr)
= mapNF_Tc (zonkIdBndr te) dicts `thenNF_Tc` \ new_dicts ->
- let
- new_ve = extend_ve ve new_dicts
- in
- zonkExpr te new_ve expr `thenNF_Tc` \ new_expr ->
+ tcExtendGlobalValEnv new_dicts $
+ zonkExpr te expr `thenNF_Tc` \ new_expr ->
returnNF_Tc (DictLam new_dicts new_expr)
-zonkExpr te ve (DictApp expr dicts)
- = zonkExpr te ve expr `thenNF_Tc` \ new_expr ->
+zonkExpr te (DictApp expr dicts)
+ = zonkExpr te expr `thenNF_Tc` \ new_expr ->
+ mapNF_Tc zonkIdOcc dicts `thenNF_Tc` \ new_dicts ->
returnNF_Tc (DictApp new_expr new_dicts)
- where
- new_dicts = map (zonkIdOcc ve) dicts
-zonkExpr te ve (ClassDictLam dicts methods expr)
- = zonkExpr te ve expr `thenNF_Tc` \ new_expr ->
+zonkExpr te (ClassDictLam dicts methods expr)
+ = zonkExpr te expr `thenNF_Tc` \ new_expr ->
+ mapNF_Tc zonkIdOcc dicts `thenNF_Tc` \ new_dicts ->
+ mapNF_Tc zonkIdOcc methods `thenNF_Tc` \ new_methods ->
returnNF_Tc (ClassDictLam new_dicts new_methods new_expr)
- where
- new_dicts = map (zonkIdOcc ve) dicts
- new_methods = map (zonkIdOcc ve) methods
-
-zonkExpr te ve (Dictionary dicts methods)
- = returnNF_Tc (Dictionary new_dicts new_methods)
- where
- new_dicts = map (zonkIdOcc ve) dicts
- new_methods = map (zonkIdOcc ve) methods
+zonkExpr te (Dictionary dicts methods)
+ = mapNF_Tc zonkIdOcc dicts `thenNF_Tc` \ new_dicts ->
+ mapNF_Tc zonkIdOcc methods `thenNF_Tc` \ new_methods ->
+ returnNF_Tc (Dictionary new_dicts new_methods)
-zonkExpr te ve (SingleDict name)
- = returnNF_Tc (SingleDict (zonkIdOcc ve name))
+zonkExpr te (SingleDict name)
+ = zonkIdOcc name `thenNF_Tc` \ name' ->
+ returnNF_Tc (SingleDict name')
-------------------------------------------------------------------------
-zonkArithSeq :: TyVarEnv Type -> IdEnv Id
+zonkArithSeq :: TyVarEnv Type
-> TcArithSeqInfo s -> NF_TcM s TypecheckedArithSeqInfo
-zonkArithSeq te ve (From e)
- = zonkExpr te ve e `thenNF_Tc` \ new_e ->
+zonkArithSeq te (From e)
+ = zonkExpr te e `thenNF_Tc` \ new_e ->
returnNF_Tc (From new_e)
-zonkArithSeq te ve (FromThen e1 e2)
- = zonkExpr te ve e1 `thenNF_Tc` \ new_e1 ->
- zonkExpr te ve e2 `thenNF_Tc` \ new_e2 ->
+zonkArithSeq te (FromThen e1 e2)
+ = zonkExpr te e1 `thenNF_Tc` \ new_e1 ->
+ zonkExpr te e2 `thenNF_Tc` \ new_e2 ->
returnNF_Tc (FromThen new_e1 new_e2)
-zonkArithSeq te ve (FromTo e1 e2)
- = zonkExpr te ve e1 `thenNF_Tc` \ new_e1 ->
- zonkExpr te ve e2 `thenNF_Tc` \ new_e2 ->
+zonkArithSeq te (FromTo e1 e2)
+ = zonkExpr te e1 `thenNF_Tc` \ new_e1 ->
+ zonkExpr te e2 `thenNF_Tc` \ new_e2 ->
returnNF_Tc (FromTo new_e1 new_e2)
-zonkArithSeq te ve (FromThenTo e1 e2 e3)
- = zonkExpr te ve e1 `thenNF_Tc` \ new_e1 ->
- zonkExpr te ve e2 `thenNF_Tc` \ new_e2 ->
- zonkExpr te ve e3 `thenNF_Tc` \ new_e3 ->
+zonkArithSeq te (FromThenTo e1 e2 e3)
+ = zonkExpr te e1 `thenNF_Tc` \ new_e1 ->
+ zonkExpr te e2 `thenNF_Tc` \ new_e2 ->
+ zonkExpr te e3 `thenNF_Tc` \ new_e3 ->
returnNF_Tc (FromThenTo new_e1 new_e2 new_e3)
-------------------------------------------------------------------------
-zonkStmts :: TyVarEnv Type -> IdEnv Id
- -> [TcStmt s] -> NF_TcM s ([TypecheckedStmt], IdEnv Id)
+zonkStmts :: TyVarEnv Type
+ -> [TcStmt s] -> NF_TcM s ([TypecheckedStmt], TcEnv s)
-zonkStmts te ve [] = returnNF_Tc ([], ve)
+zonkStmts te [] = tcGetEnv `thenNF_Tc` \ env ->
+ returnNF_Tc ([], env)
-zonkStmts te ve [ReturnStmt expr]
- = zonkExpr te ve expr `thenNF_Tc` \ new_expr ->
- returnNF_Tc ([ReturnStmt new_expr], ve)
+zonkStmts te [ReturnStmt expr]
+ = zonkExpr te expr `thenNF_Tc` \ new_expr ->
+ tcGetEnv `thenNF_Tc` \ env ->
+ returnNF_Tc ([ReturnStmt new_expr], env)
-zonkStmts te ve (ExprStmt expr locn : stmts)
- = zonkExpr te ve expr `thenNF_Tc` \ new_expr ->
- zonkStmts te ve stmts `thenNF_Tc` \ (new_stmts, new_ve) ->
- returnNF_Tc (ExprStmt new_expr locn : new_stmts, new_ve)
+zonkStmts te (ExprStmt expr locn : stmts)
+ = zonkExpr te expr `thenNF_Tc` \ new_expr ->
+ zonkStmts te stmts `thenNF_Tc` \ (new_stmts, new_env) ->
+ returnNF_Tc (ExprStmt new_expr locn : new_stmts, new_env)
-zonkStmts te ve (GuardStmt expr locn : stmts)
- = zonkExpr te ve expr `thenNF_Tc` \ new_expr ->
- zonkStmts te ve stmts `thenNF_Tc` \ (new_stmts, new_ve) ->
- returnNF_Tc (GuardStmt new_expr locn : new_stmts, new_ve)
+zonkStmts te (GuardStmt expr locn : stmts)
+ = zonkExpr te expr `thenNF_Tc` \ new_expr ->
+ zonkStmts te stmts `thenNF_Tc` \ (new_stmts, new_env) ->
+ returnNF_Tc (GuardStmt new_expr locn : new_stmts, new_env)
-zonkStmts te ve (LetStmt binds : stmts)
- = zonkBinds te ve binds `thenNF_Tc` \ (new_binds, new_ve) ->
- zonkStmts te new_ve stmts `thenNF_Tc` \ (new_stmts, new_ve2) ->
- returnNF_Tc (LetStmt new_binds : new_stmts, new_ve2)
+zonkStmts te (LetStmt binds : stmts)
+ = zonkBinds te binds `thenNF_Tc` \ (new_binds, new_env) ->
+ tcSetEnv new_env $
+ zonkStmts te stmts `thenNF_Tc` \ (new_stmts, new_env2) ->
+ returnNF_Tc (LetStmt new_binds : new_stmts, new_env2)
-zonkStmts te ve (BindStmt pat expr locn : stmts)
- = zonkPat te ve pat `thenNF_Tc` \ (new_pat, ids) ->
- zonkExpr te ve expr `thenNF_Tc` \ new_expr ->
- let
- new_ve = extend_ve ve ids
- in
- zonkStmts te new_ve stmts `thenNF_Tc` \ (new_stmts, new_ve2) ->
- returnNF_Tc (BindStmt new_pat new_expr locn : new_stmts, new_ve2)
+zonkStmts te (BindStmt pat expr locn : stmts)
+ = zonkPat te pat `thenNF_Tc` \ (new_pat, ids) ->
+ zonkExpr te expr `thenNF_Tc` \ new_expr ->
+ tcExtendGlobalValEnv (bagToList ids) $
+ zonkStmts te stmts `thenNF_Tc` \ (new_stmts, new_env) ->
+ returnNF_Tc (BindStmt new_pat new_expr locn : new_stmts, new_env)
-------------------------------------------------------------------------
-zonkRbinds :: TyVarEnv Type -> IdEnv Id
+zonkRbinds :: TyVarEnv Type
-> TcRecordBinds s -> NF_TcM s TypecheckedRecordBinds
-zonkRbinds te ve rbinds
+zonkRbinds te rbinds
= mapNF_Tc zonk_rbind rbinds
where
zonk_rbind (field, expr, pun)
- = zonkExpr te ve expr `thenNF_Tc` \ new_expr ->
- returnNF_Tc (zonkIdOcc ve field, new_expr, pun)
+ = zonkExpr te expr `thenNF_Tc` \ new_expr ->
+ zonkIdOcc field `thenNF_Tc` \ new_field ->
+ returnNF_Tc (new_field, new_expr, pun)
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-{-
-zonkPat :: TyVarEnv Type -> IdEnv Id
- -> TcPat s -> NF_TcM s (TypecheckedPat, [Id])
--}
-zonkPat te ve (WildPat ty)
+zonkPat :: TyVarEnv Type
+ -> TcPat s -> NF_TcM s (TypecheckedPat, Bag Id)
+
+zonkPat te (WildPat ty)
= zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
- returnNF_Tc (WildPat new_ty, [])
+ returnNF_Tc (WildPat new_ty, emptyBag)
-zonkPat te ve (VarPat v)
+zonkPat te (VarPat v)
= zonkIdBndr te v `thenNF_Tc` \ new_v ->
- returnNF_Tc (VarPat new_v, [new_v])
+ returnNF_Tc (VarPat new_v, unitBag new_v)
-zonkPat te ve (LazyPat pat)
- = zonkPat te ve pat `thenNF_Tc` \ (new_pat, ids) ->
+zonkPat te (LazyPat pat)
+ = zonkPat te pat `thenNF_Tc` \ (new_pat, ids) ->
returnNF_Tc (LazyPat new_pat, ids)
-zonkPat te ve (AsPat n pat)
+zonkPat te (AsPat n pat)
= zonkIdBndr te n `thenNF_Tc` \ new_n ->
- zonkPat te ve pat `thenNF_Tc` \ (new_pat, ids) ->
- returnNF_Tc (AsPat new_n new_pat, new_n:ids)
+ zonkPat te pat `thenNF_Tc` \ (new_pat, ids) ->
+ returnNF_Tc (AsPat new_n new_pat, new_n `consBag` ids)
-zonkPat te ve (ConPat n ty pats)
+zonkPat te (ConPat n ty pats)
= zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
- zonkPats te ve pats `thenNF_Tc` \ (new_pats, ids) ->
+ zonkPats te pats `thenNF_Tc` \ (new_pats, ids) ->
returnNF_Tc (ConPat n new_ty new_pats, ids)
-zonkPat te ve (ConOpPat pat1 op pat2 ty)
- = zonkPat te ve pat1 `thenNF_Tc` \ (new_pat1, ids1) ->
- zonkPat te ve pat2 `thenNF_Tc` \ (new_pat2, ids2) ->
+zonkPat te (ConOpPat pat1 op pat2 ty)
+ = zonkPat te pat1 `thenNF_Tc` \ (new_pat1, ids1) ->
+ zonkPat te pat2 `thenNF_Tc` \ (new_pat2, ids2) ->
zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
- returnNF_Tc (ConOpPat new_pat1 op new_pat2 new_ty, ids1 ++ ids2)
+ returnNF_Tc (ConOpPat new_pat1 op new_pat2 new_ty, ids1 `unionBags` ids2)
-zonkPat te ve (ListPat ty pats)
+zonkPat te (ListPat ty pats)
= zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
- zonkPats te ve pats `thenNF_Tc` \ (new_pats, ids) ->
+ zonkPats te pats `thenNF_Tc` \ (new_pats, ids) ->
returnNF_Tc (ListPat new_ty new_pats, ids)
-zonkPat te ve (TuplePat pats)
- = zonkPats te ve pats `thenNF_Tc` \ (new_pats, ids) ->
+zonkPat te (TuplePat pats)
+ = zonkPats te pats `thenNF_Tc` \ (new_pats, ids) ->
returnNF_Tc (TuplePat new_pats, ids)
-zonkPat te ve (RecPat n ty rpats)
+zonkPat te (RecPat n ty rpats)
= zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
mapAndUnzipNF_Tc zonk_rpat rpats `thenNF_Tc` \ (new_rpats, ids_s) ->
- returnNF_Tc (RecPat n new_ty new_rpats, concat ids_s)
+ returnNF_Tc (RecPat n new_ty new_rpats, unionManyBags ids_s)
where
zonk_rpat (f, pat, pun)
- = zonkPat te ve pat `thenNF_Tc` \ (new_pat, ids) ->
+ = zonkPat te pat `thenNF_Tc` \ (new_pat, ids) ->
returnNF_Tc ((f, new_pat, pun), ids)
-zonkPat te ve (LitPat lit ty)
+zonkPat te (LitPat lit ty)
= zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
- returnNF_Tc (LitPat lit new_ty, [])
+ returnNF_Tc (LitPat lit new_ty, emptyBag)
-zonkPat te ve (NPat lit ty expr)
+zonkPat te (NPat lit ty expr)
= zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
- zonkExpr te ve expr `thenNF_Tc` \ new_expr ->
- returnNF_Tc (NPat lit new_ty new_expr, [])
+ zonkExpr te expr `thenNF_Tc` \ new_expr ->
+ returnNF_Tc (NPat lit new_ty new_expr, emptyBag)
-zonkPat te ve (NPlusKPat n k ty e1 e2)
+zonkPat te (NPlusKPat n k ty e1 e2)
= zonkIdBndr te n `thenNF_Tc` \ new_n ->
zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
- zonkExpr te ve e1 `thenNF_Tc` \ new_e1 ->
- zonkExpr te ve e2 `thenNF_Tc` \ new_e2 ->
- returnNF_Tc (NPlusKPat new_n k new_ty new_e1 new_e2, [new_n])
+ zonkExpr te e1 `thenNF_Tc` \ new_e1 ->
+ zonkExpr te e2 `thenNF_Tc` \ new_e2 ->
+ returnNF_Tc (NPlusKPat new_n k new_ty new_e1 new_e2, unitBag new_n)
-zonkPat te ve (DictPat ds ms)
+zonkPat te (DictPat ds ms)
= mapNF_Tc (zonkIdBndr te) ds `thenNF_Tc` \ new_ds ->
mapNF_Tc (zonkIdBndr te) ms `thenNF_Tc` \ new_ms ->
- returnNF_Tc (DictPat new_ds new_ms, new_ds ++ new_ms)
-
+ returnNF_Tc (DictPat new_ds new_ms,
+ listToBag new_ds `unionBags` listToBag new_ms)
-zonkPats te ve []
- = returnNF_Tc ([], [])
-zonkPats te ve (pat:pats)
- = zonkPat te ve pat `thenNF_Tc` \ (pat', ids1) ->
- zonkPats te ve pats `thenNF_Tc` \ (pats', ids2) ->
- returnNF_Tc (pat':pats', ids1 ++ ids2)
+zonkPats te []
+ = returnNF_Tc ([], emptyBag)
+zonkPats te (pat:pats)
+ = zonkPat te pat `thenNF_Tc` \ (pat', ids1) ->
+ zonkPats te pats `thenNF_Tc` \ (pats', ids2) ->
+ returnNF_Tc (pat':pats', ids1 `unionBags` ids2)
\end{code}
import TcMonad
import TcMonoType ( tcHsType, tcHsTypeKind )
import TcEnv ( tcLookupGlobalValue, tcExtendTyVarEnv, tcExtendGlobalValEnv,
- tcLookupTyConByKey, tcLookupGlobalValueMaybe, tcLookupLocalValue
+ tcLookupTyConByKey, tcLookupGlobalValueMaybe, tcLookupLocalValue,
+ tcExplicitLookupGlobal
)
import TcKind ( TcKind, kindToTcKind )
Fake, InPat, HsType )
import RnHsSyn ( RenamedHsDecl(..) )
import HsCore
-import HsDecls ( HsIdInfo(..) )
+import HsDecls ( HsIdInfo(..), HsStrictnessInfo(..) )
import Literal ( Literal(..) )
import CoreSyn
import CoreUtils ( coreExprType )
import Id ( GenId, mkImported, mkUserId, addInlinePragma,
isPrimitiveId_maybe, dataConArgTys, SYN_IE(Id) )
import Type ( mkSynTy, getAppDataTyConExpandingDicts )
-import TyVar ( mkTyVar )
+import TyVar ( mkSysTyVar )
import Name ( Name )
-import Unique ( rationalTyConKey )
+import Unique ( rationalTyConKey, uniqueOf )
import TysWiredIn ( integerTy )
import PragmaInfo ( PragmaInfo(..) )
import ErrUtils ( pprBagOfErrors )
signatures.
\begin{code}
-tcInterfaceSigs :: [RenamedHsDecl] -> TcM s [Id]
- -- Ignore non-sig-decls in these decls
-
-tcInterfaceSigs (SigD (IfaceSig name ty id_infos src_loc) : rest)
- = tcAddSrcLoc src_loc $
- tcAddErrCtxt (ifaceSigCtxt name) $
- tcHsType ty `thenTc` \ sigma_ty ->
- tcIdInfo name sigma_ty noIdInfo id_infos `thenTc` \ id_info' ->
- let
- imp_id = mkImported name sigma_ty id_info'
- sig_id | any inline_please id_infos = addInlinePragma imp_id
- | otherwise = imp_id
+tcInterfaceSigs :: TcEnv s -- Envt to use when checking unfoldings
+ -> [RenamedHsDecl] -- Ignore non-sig-decls in these decls
+ -> TcM s [Id]
+
+
+tcInterfaceSigs unf_env (SigD (IfaceSig name ty id_infos src_loc) : rest)
+ = tcAddSrcLoc src_loc (
+ tcAddErrCtxt (ifaceSigCtxt name) (
+ tcHsType ty `thenTc` \ sigma_ty ->
+ tcIdInfo unf_env name sigma_ty noIdInfo id_infos `thenTc` \ id_info' ->
+ let
+ imp_id = mkImported name sigma_ty id_info'
+ sig_id | any inline_please id_infos = addInlinePragma imp_id
+ | otherwise = imp_id
- inline_please (HsUnfold inline _) = inline
- inline_please other = False
- in
- tcInterfaceSigs rest `thenTc` \ sig_ids ->
+ inline_please (HsUnfold inline _) = inline
+ inline_please other = False
+ in
+ returnTc sig_id
+ )) `thenTc` \ sig_id ->
+ tcInterfaceSigs unf_env rest `thenTc` \ sig_ids ->
returnTc (sig_id : sig_ids)
-tcInterfaceSigs (other_decl : rest) = tcInterfaceSigs rest
+tcInterfaceSigs unf_env (other_decl : rest) = tcInterfaceSigs unf_env rest
-tcInterfaceSigs [] = returnTc []
+tcInterfaceSigs unf_env [] = returnTc []
\end{code}
\begin{code}
-tcIdInfo name ty info [] = returnTc info
-
-tcIdInfo name ty info (HsArity arity : rest)
- = tcIdInfo name ty (info `addArityInfo` arity) rest
-
-tcIdInfo name ty info (HsUpdate upd : rest)
- = tcIdInfo name ty (info `addUpdateInfo` upd) rest
-
-tcIdInfo name ty info (HsFBType fb : rest)
- = tcIdInfo name ty (info `addFBTypeInfo` fb) rest
-
-tcIdInfo name ty info (HsArgUsage au : rest)
- = tcIdInfo name ty (info `addArgUsageInfo` au) rest
-
-tcIdInfo name ty info (HsDeforest df : rest)
- = tcIdInfo name ty (info `addDeforestInfo` df) rest
-
-tcIdInfo name ty info (HsUnfold inline expr : rest)
- = tcUnfolding name expr `thenNF_Tc` \ unfold_info ->
- tcIdInfo name ty (info `addUnfoldInfo` unfold_info) rest
-
-tcIdInfo name ty info (HsStrictness strict : rest)
- = tcStrictness ty info strict `thenTc` \ info' ->
- tcIdInfo name ty info' rest
+tcIdInfo unf_env name ty info info_ins
+ = go noIdInfo info_ins
+ where
+ go info_so_far [] = returnTc info_so_far
+ go info (HsArity arity : rest) = go (info `addArityInfo` arity) rest
+ go info (HsUpdate upd : rest) = go (info `addUpdateInfo` upd) rest
+ go info (HsFBType fb : rest) = go (info `addFBTypeInfo` fb) rest
+ go info (HsArgUsage au : rest) = go (info `addArgUsageInfo` au) rest
+ go info (HsDeforest df : rest) = go (info `addDeforestInfo` df) rest
+
+ go info (HsUnfold inline expr : rest) = tcUnfolding unf_env name expr `thenNF_Tc` \ unfold_info ->
+ go (info `addUnfoldInfo` unfold_info) rest
+
+ go info (HsStrictness strict : rest) = tcStrictness unf_env ty info strict `thenTc` \ info' ->
+ go info' rest
\end{code}
\begin{code}
-tcStrictness ty info (StrictnessInfo demands maybe_worker)
- = tcWorker maybe_worker `thenNF_Tc` \ maybe_worker_id ->
+tcStrictness unf_env ty info (HsStrictnessInfo demands maybe_worker)
+ = tcWorker unf_env maybe_worker `thenNF_Tc` \ maybe_worker_id ->
uniqSMToTcM (mkWrapper ty demands) `thenNF_Tc` \ wrap_fn ->
let
-- Watch out! We can't pull on maybe_worker_id too eagerly!
info' = case maybe_worker_id of
- Just (worker_id,_) -> info `addUnfoldInfo` mkUnfolding NoPragmaInfo (wrap_fn worker_id)
- Nothing -> info
+ Just worker_id -> info `addUnfoldInfo` mkUnfolding NoPragmaInfo (wrap_fn worker_id)
+ Nothing -> info
+ has_worker = maybeToBool maybe_worker_id
in
- returnTc (info' `addStrictnessInfo` StrictnessInfo demands maybe_worker_id)
+ returnTc (info' `addStrictnessInfo` StrictnessInfo demands has_worker)
-- Boring to write these out, but the result type differs from the arg type...
-tcStrictness ty info BottomGuaranteed
+tcStrictness unf_env ty info HsBottom
= returnTc (info `addStrictnessInfo` BottomGuaranteed)
-tcStrictness ty info NoStrictnessInfo
- = returnTc info
\end{code}
\begin{code}
-tcWorker Nothing = returnNF_Tc Nothing
+tcWorker unf_env Nothing = returnNF_Tc Nothing
-tcWorker (Just (worker_name,_))
- = tcLookupGlobalValueMaybe worker_name `thenNF_Tc` \ maybe_worker_id ->
- returnNF_Tc (trace_maybe maybe_worker_id)
+tcWorker unf_env (Just (worker_name,_))
+ = returnNF_Tc (trace_maybe maybe_worker_id)
where
+ maybe_worker_id = tcExplicitLookupGlobal unf_env worker_name
+
-- The trace is so we can see what's getting dropped
trace_maybe Nothing = pprTrace "tcWorker failed:" (ppr PprDebug worker_name) Nothing
- trace_maybe (Just x) = Just (x, [])
+ trace_maybe (Just x) = Just x
\end{code}
For unfoldings we try to do the job lazily, so that we never type check
an unfolding that isn't going to be looked at.
\begin{code}
-tcUnfolding name core_expr
+tcUnfolding unf_env name core_expr
= forkNF_Tc (
recoverNF_Tc no_unfolding (
+ tcSetEnv unf_env $
tcCoreExpr core_expr `thenTc` \ core_expr' ->
returnTc (mkUnfolding NoPragmaInfo core_expr')
))
tcCoreLamBndr (UfTyBinder name kind) thing_inside
= let
- tyvar = mkTyVar name kind
+ tyvar = mkSysTyVar (uniqueOf name) kind
in
tcExtendTyVarEnv [name] [(kindToTcKind kind, tyvar)] $
thing_inside (TyBinder tyvar)
mkHsTyLam, mkHsTyApp,
mkHsDictLam, mkHsDictApp )
-import TcBinds ( tcBindWithSigs, tcPragmaSigs, TcSigInfo(..) )
+import TcBinds ( tcBindWithSigs, tcPragmaSigs, TcSigInfo(..), checkSigTyVars )
import TcMonad
import RnMonad ( SYN_IE(RnNameSupply) )
import Inst ( Inst, InstOrigin(..), SYN_IE(InstanceMapper),
instToId, newDicts, newMethod, SYN_IE(LIE), emptyLIE, plusLIE )
-import TcBinds ( tcPragmaSigs, checkSigTyVars )
import PragmaInfo ( PragmaInfo(..) )
import TcDeriv ( tcDeriving )
-import TcEnv ( tcLookupClass, newLocalId, tcExtendGlobalTyVars, tcGetGlobalTyVars )
+import TcEnv ( tcLookupClass, newLocalId, tcExtendGlobalTyVars, tcGetGlobalTyVars,
+ tcExtendGlobalValEnv, tcAddImportedIdInfo
+ )
import SpecEnv ( SpecEnv )
import TcGRHSs ( tcGRHSsAndBinds )
import TcInstUtil ( InstInfo(..), mkInstanceRelatedIds, buildInstanceEnvs )
concatBag, foldBag, bagToList, listToBag,
Bag )
import CmdLineOpts ( opt_GlasgowExts, opt_CompilingGhcInternals,
- opt_OmitDefaultInstanceMethods,
+ opt_OmitDefaultInstanceMethods, opt_PprUserLength,
opt_SpecialiseOverloaded
)
-import Class ( GenClass, GenClassOp,
- classBigSig, classOps, classOpLocalType,
+import Class ( GenClass,
+ classBigSig,
classDefaultMethodId, SYN_IE(Class)
)
-import Id ( GenId, idType, isDefaultMethodId_maybe, replacePragmaInfo,
+import Id ( GenId, idType, replacePragmaInfo,
isNullaryDataCon, dataConArgTys, SYN_IE(Id) )
import ListSetOps ( minusList )
-import Maybes ( maybeToBool, expectJust, seqMaybe )
-import Name ( nameOccName, getOccString, occNameString, moduleString,
+import Maybes ( maybeToBool, expectJust, seqMaybe, catMaybes )
+import Name ( nameOccName, getOccString, occNameString, moduleString, getSrcLoc,
isLocallyDefined, OccName, Name{--O only-}, SYN_IE(Module),
NamedThing(..)
)
-import PrelVals ( nO_EXPLICIT_METHOD_ERROR_ID )
-import PprType ( GenType, GenTyVar, GenClass, GenClassOp, TyCon,
+import PrelVals ( nO_EXPLICIT_METHOD_ERROR_ID, nO_DEFAULT_METHOD_ERROR_ID )
+import PprType ( GenType, GenTyVar, GenClass, TyCon,
pprParendGenType
)
import Outputable
import TysPrim ( byteArrayPrimTyCon, mutableByteArrayPrimTyCon )
import TysWiredIn ( stringTy )
import Unique ( Unique, cCallableClassKey, cReturnableClassKey, Uniquable(..) )
-import Util ( zipEqual, panic, pprPanic, pprTrace, removeDups, Ord3(..),
+import Util ( zipEqual, panic, pprPanic, pprTrace, removeDups, Ord3(..)
#if __GLASGOW_HASKELL__ < 202
, trace
#endif
\end{enumerate}
\begin{code}
-tcInstDecls1 :: [RenamedHsDecl]
+tcInstDecls1 :: TcEnv s -- Contains IdInfo for dfun ids
+ -> [RenamedHsDecl]
-> Module -- module name for deriving
-> RnNameSupply -- for renaming derivings
-> TcM s (Bag InstInfo,
RenamedHsBinds,
PprStyle -> Doc)
-tcInstDecls1 decls mod_name rn_name_supply
+tcInstDecls1 unf_env decls mod_name rn_name_supply
= -- Do the ordinary instance declarations
- mapNF_Tc (tcInstDecl1 mod_name)
+ mapNF_Tc (tcInstDecl1 unf_env mod_name)
[inst_decl | InstD inst_decl <- decls] `thenNF_Tc` \ inst_info_bags ->
let
decl_inst_info = unionManyBags inst_info_bags
returnTc (full_inst_info, deriv_binds, ddump_deriv)
-tcInstDecl1 :: Module -> RenamedInstDecl -> NF_TcM s (Bag InstInfo)
+tcInstDecl1 :: TcEnv s -> Module -> RenamedInstDecl -> NF_TcM s (Bag InstInfo)
-tcInstDecl1 mod_name (InstDecl poly_ty binds uprags (Just dfun_name) src_loc)
+tcInstDecl1 unf_env mod_name (InstDecl poly_ty binds uprags (Just dfun_name) src_loc)
= -- Prime error recovery, set source location
recoverNF_Tc (returnNF_Tc emptyBag) $
tcAddSrcLoc src_loc $
`thenTc` \ (inst_tycon,arg_tys) ->
-- Make the dfun id and constant-method ids
- mkInstanceRelatedIds dfun_name
- clas inst_tyvars inst_tau inst_theta
- `thenNF_Tc` \ (dfun_id, dfun_theta) ->
-
+ let
+ (dfun_id, dfun_theta) = mkInstanceRelatedIds dfun_name
+ clas inst_tyvars inst_tau inst_theta
+ -- Add info from interface file
+ final_dfun_id = tcAddImportedIdInfo unf_env dfun_id
+ in
returnTc (unitBag (InstInfo clas inst_tyvars inst_tau inst_theta
- dfun_theta dfun_id
+ dfun_theta final_dfun_id
binds src_loc uprags))
where
(tyvar_names, context, dict_ty) = case poly_ty of
\begin{code}
tcInstDecls2 :: Bag InstInfo
- -> NF_TcM s (LIE s, TcHsBinds s)
+ -> NF_TcM s (LIE s, TcMonoBinds s)
tcInstDecls2 inst_decls
- = foldBag combine tcInstDecl2 (returnNF_Tc (emptyLIE, EmptyBinds)) inst_decls
+ = foldBag combine tcInstDecl2 (returnNF_Tc (emptyLIE, EmptyMonoBinds)) inst_decls
where
combine tc1 tc2 = tc1 `thenNF_Tc` \ (lie1, binds1) ->
tc2 `thenNF_Tc` \ (lie2, binds2) ->
returnNF_Tc (lie1 `plusLIE` lie2,
- binds1 `ThenBinds` binds2)
+ binds1 `AndMonoBinds` binds2)
\end{code}
First comes the easy case of a non-local instance decl.
\begin{code}
-tcInstDecl2 :: InstInfo -> NF_TcM s (LIE s, TcHsBinds s)
+tcInstDecl2 :: InstInfo -> NF_TcM s (LIE s, TcMonoBinds s)
tcInstDecl2 (InstInfo clas inst_tyvars inst_ty
inst_decl_theta dfun_theta
dfun_id monobinds
locn uprags)
| not (isLocallyDefined dfun_id)
- = returnNF_Tc (emptyLIE, EmptyBinds)
+ = returnNF_Tc (emptyLIE, EmptyMonoBinds)
{-
-- I deleted this "optimisation" because when importing these
| otherwise
= -- Prime error recovery
- recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyBinds)) $
- tcAddSrcLoc locn $
+ recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyMonoBinds)) $
+ tcAddSrcLoc locn $
-- Get the class signature
tcInstSigTyVars inst_tyvars `thenNF_Tc` \ (inst_tyvars', _, tenv) ->
origin = InstanceDeclOrigin
(class_tyvar,
super_classes, sc_sel_ids,
- class_ops, op_sel_ids, defm_ids) = classBigSig clas
+ op_sel_ids, defm_ids) = classBigSig clas
in
tcInstType tenv inst_ty `thenNF_Tc` \ inst_ty' ->
tcInstTheta tenv dfun_theta `thenNF_Tc` \ dfun_theta' ->
in
mapTc check_from_this_class (bagToList (collectMonoBinders monobinds)) `thenTc_`
tcExtendGlobalTyVars inst_tyvars_set' (
- mapAndUnzip3Tc (tcMethodBind (getDefmRhs clas) inst_ty' prag_fn monobinds)
- (op_sel_ids `zip` [0..])
+ tcExtendGlobalValEnv (catMaybes defm_ids) $
+ -- Default-method Ids may be mentioned in synthesised RHSs
+ mapAndUnzip3Tc (tcMethodBind clas inst_ty' monobinds)
+ (op_sel_ids `zip` defm_ids)
) `thenTc` \ (method_binds_s, insts_needed_s, meth_lies_w_ids) ->
-- Check the overloading constraints of the methods and superclasses
method_binds = andMonoBinds method_binds_s
main_bind
- = MonoBind (
- AbsBinds
+ = AbsBinds
inst_tyvars'
dfun_arg_dicts_ids
[(inst_tyvars', RealId dfun_id, this_dict_id)]
(super_binds `AndMonoBinds`
method_binds `AndMonoBinds`
- dict_bind))
- [] recursive -- Recursive to play safe
+ dict_bind)
in
returnTc (const_lie `plusLIE` spec_lie,
- main_bind `ThenBinds` spec_binds)
-\end{code}
-
-The next function looks for a method binding; if there isn't one it
-manufactures one that just calls the global default method.
-
-See the notes under default decls in TcClassDcl.lhs.
-
-\begin{code}
-getDefmRhs :: Class -> Int -> RenamedHsExpr
-getDefmRhs clas idx = HsVar (getName (classDefaultMethodId clas idx))
+ main_bind `AndMonoBinds` spec_binds)
\end{code}
\begin{code}
tcMethodBind
- :: (Int -> RenamedHsExpr) -- Function mapping a tag to default RHS
+ :: Class
-> TcType s -- Instance type
- -> (Name -> PragmaInfo)
-> RenamedMonoBinds -- Method binding
- -> (Id, Int) -- Selector ID (and its 0-indexed tag)
- -- for which binding is wanted
+ -> (Id, Maybe Id) -- Selector id and default-method id
-> TcM s (TcMonoBinds s, LIE s, (LIE s, TcIdOcc s))
-tcMethodBind deflt_fn inst_ty prag_fn meth_binds (sel_id, idx)
- = newMethod origin (RealId sel_id) [inst_ty] `thenNF_Tc` \ meth@(_, TcId meth_id) ->
- tcInstSigTcType (idType meth_id) `thenNF_Tc` \ (tyvars', rho_ty') ->
+tcMethodBind clas inst_ty meth_binds (sel_id, maybe_dm_id)
+ = newMethod origin (RealId sel_id) [inst_ty] `thenNF_Tc` \ meth@(_, TcId local_meth_id) ->
+ tcInstSigTcType (idType local_meth_id) `thenNF_Tc` \ (tyvars', rho_ty') ->
let
- meth_name = getName meth_id
- default_bind = PatMonoBind (VarPatIn meth_name)
- (GRHSsAndBindsIn [OtherwiseGRHS (deflt_fn idx) noSrcLoc] EmptyBinds)
- noSrcLoc
+ meth_name = getName local_meth_id
- (op_name, op_bind) = case go (getOccName sel_id) meth_binds of
- Just stuff -> stuff
- Nothing -> (meth_name, default_bind)
+ maybe_meth_bind = go (getOccName sel_id) meth_binds
+ (bndr_name, op_bind) = case maybe_meth_bind of
+ Just stuff -> stuff
+ Nothing -> (meth_name, mk_default_bind meth_name)
(theta', tau') = splitRhoTy rho_ty'
- meth_id_w_prags = replacePragmaInfo meth_id (prag_fn meth_name)
- sig_info = TySigInfo op_name meth_id_w_prags tyvars' theta' tau' noSrcLoc
+ sig_info = TySigInfo bndr_name local_meth_id tyvars' theta' tau' noSrcLoc
in
- tcBindWithSigs [op_name] op_bind [sig_info]
+
+ -- Warn if no method binding
+ warnTc (not (maybeToBool maybe_meth_bind) && not (maybeToBool maybe_dm_id))
+ (omittedMethodWarn sel_id clas) `thenNF_Tc_`
+
+ tcBindWithSigs [bndr_name] op_bind [sig_info]
nonRecursive (\_ -> NoPragmaInfo) `thenTc` \ (binds, insts, _) ->
returnTc (binds, insts, meth)
go occ b@(PatMonoBind (VarPatIn op_name) _ locn) | nameOccName op_name == occ = Just (op_name, b)
| otherwise = Nothing
go occ other = panic "Urk! Bad instance method binding"
+
+
+ mk_default_bind local_meth_name
+ = PatMonoBind (VarPatIn local_meth_name)
+ (GRHSsAndBindsIn [OtherwiseGRHS default_expr noSrcLoc] EmptyBinds)
+ noSrcLoc
+
+ default_expr = case maybe_dm_id of
+ Just dm_id -> HsVar (getName dm_id) -- There's a default method
+ Nothing -> error_expr -- No default method
+
+ error_expr = HsApp (HsVar (getName nO_DEFAULT_METHOD_ERROR_ID))
+ (HsLit (HsString (_PK_ error_msg)))
+
+ error_msg = show (hcat [ppr (PprForUser opt_PprUserLength) (getSrcLoc sel_id), text "|",
+ ppr (PprForUser opt_PprUserLength) sel_id
+ ])
\end{code}
= case ty of
SynTy tc _ _ -> hsep [ptext SLIT("The type synonym"), ppr sty tc, rest_of_msg]
TyVarTy tv -> hsep [ptext SLIT("The type variable"), ppr sty tv, rest_of_msg]
- other -> hsep [ptext SLIT("The type"), ppr sty ty, rest_of_msg]
+ other -> sep [ptext SLIT("The type"), nest 4 (ppr sty ty), rest_of_msg]
where
rest_of_msg = ptext SLIT("cannot be used as an instance type")
ptext SLIT("type"), ppr sty tycon])
4 (ptext SLIT("when an explicit instance exists"))
-derivingWhenInstanceImportedErr inst_mod clas tycon sty
- = hang (hsep [ptext SLIT("Deriving class"),
- ppr sty clas,
- ptext SLIT("type"), ppr sty tycon])
- 4 (hsep [ptext SLIT("when an instance declared in module"),
- pp_mod, ptext SLIT("has been imported")])
- where
- pp_mod = hsep [ptext SLIT("module"), ptext inst_mod]
-
nonBoxedPrimCCallErr clas inst_ty sty
= hang (ptext SLIT("Unacceptable instance type for ccall-ish class"))
4 (hsep [ ptext SLIT("class"), ppr sty clas, ptext SLIT("type"),
ppr sty inst_ty])
-omitDefaultMethodWarn clas_op clas_name inst_ty sty
- = hsep [ptext SLIT("Warning: Omitted default method for"),
- ppr sty clas_op, ptext SLIT("in instance"),
- text clas_name, pprParendGenType sty inst_ty]
+omittedMethodWarn sel_id clas sty
+ = sep [ptext SLIT("No explicit method nor default method for") <+> ppr sty sel_id,
+ ptext SLIT("in an instance declaration for") <+> ppr sty clas]
instMethodNotInClassErr occ clas sty
= hang (ptext SLIT("Instance mentions a method not in the class"))
superClassSigCtxt sty
= ptext SLIT("When checking superclass constraints of an instance declaration")
-
\end{code}
import RnHsSyn ( SYN_IE(RenamedMonoBinds), RenamedSig(..),
RenamedInstancePragmas(..) )
-import TcEnv ( tcAddImportedIdInfo )
import TcMonad
import Inst ( SYN_IE(InstanceMapper) )
import Bag ( bagToList, Bag )
-import Class ( GenClass, GenClassOp, SYN_IE(ClassInstEnv),
- classBigSig, classOps, classOpLocalType,
- SYN_IE(ClassOp), SYN_IE(Class)
+import Class ( GenClass, SYN_IE(ClassInstEnv),
+ classBigSig, SYN_IE(Class)
)
import CoreSyn ( GenCoreExpr(..), mkValLam, mkTyApp )
-import Id ( GenId, mkDictFunId, mkConstMethodId, mkSysLocal, SYN_IE(Id) )
+import Id ( GenId, mkDictFunId, mkSysLocal, SYN_IE(Id) )
import MatchEnv ( nullMEnv, insertMEnv )
import Maybes ( MaybeErr(..), mkLookupFunDef )
import Name ( getSrcLoc, Name{--O only-} )
import Unique ( Unique )
import Util ( equivClasses, zipWithEqual, panic{-, pprTrace-}, Ord3(..) )
-#if __GLASGOW_HASKELL__ >= 202
import Outputable
-#endif
\end{code}
instance c => k (t tvs) where b
-> [TyVar]
-> Type
-> ThetaType
- -> NF_TcM s (Id, ThetaType)
+ -> (Id, ThetaType)
mkInstanceRelatedIds dfun_name clas inst_tyvars inst_ty inst_decl_theta
- = tcAddImportedIdInfo dfun_id `thenNF_Tc` \ new_dfun_id ->
- returnNF_Tc (new_dfun_id, dfun_theta)
+ = (dfun_id, dfun_theta)
where
- (_, super_classes, _, _, _, _) = classBigSig clas
+ (_, super_classes, _, _, _) = classBigSig clas
super_class_theta = super_classes `zip` repeat inst_ty
dfun_theta = case inst_decl_theta of
in
mapTc buildInstanceEnv info_by_class `thenTc` \ inst_env_entries ->
let
- class_lookup_fn = mkLookupFunDef (==) inst_env_entries
- (nullMEnv, \ o -> nullSpecEnv)
+ class_lookup_fn = mkLookupFunDef (==) inst_env_entries nullMEnv
in
returnTc class_lookup_fn
\end{code}
\begin{code}
buildInstanceEnv :: [InstInfo] -- Non-empty, and all for same class
- -> TcM s (Class, (ClassInstEnv, (ClassOp -> SpecEnv)))
+ -> TcM s (Class, ClassInstEnv)
buildInstanceEnv inst_infos@((InstInfo clas _ _ _ _ _ _ _ _) : _)
= foldlTc addClassInstance
- (nullMEnv, [(op, nullSpecEnv) | op <- classOps clas])
- inst_infos
- `thenTc` \ (class_inst_env, op_inst_envs) ->
- returnTc (clas, (class_inst_env,
- mkLookupFunDef (==) op_inst_envs
- (panic "buildInstanceEnv")))
+ nullMEnv
+ inst_infos `thenTc` \ class_inst_env ->
+ returnTc (clas, class_inst_env)
\end{code}
@addClassInstance@ adds the appropriate stuff to the @ClassInstEnv@
\begin{code}
addClassInstance
- :: (ClassInstEnv, [(ClassOp,SpecEnv)])
+ :: ClassInstEnv
-> InstInfo
- -> TcM s (ClassInstEnv, [(ClassOp,SpecEnv)])
+ -> TcM s ClassInstEnv
-addClassInstance
- input_stuff@(class_inst_env, op_spec_envs)
+addClassInstance class_inst_env
(InstInfo clas inst_tyvars inst_ty _ _
dfun_id _ src_loc _)
- =
-
--- We only add specialised/overlapped instances
--- if we are specialising the overloading
--- ToDo ... This causes getConstMethodId errors!
---
--- if not (is_plain_instance inst_ty) && not opt_SpecialiseOverloaded
--- then
--- -- Drop this specialised/overlapped instance
--- returnTc (class_inst_env, op_spec_envs)
--- else
-
- -- Add the instance to the class's instance environment
- case insertMEnv matchTy class_inst_env inst_ty dfun_id of {
- Failed (ty', dfun_id') -> recoverTc (returnTc input_stuff) $
+ = -- Add the instance to the class's instance environment
+ case insertMEnv matchTy class_inst_env inst_ty dfun_id of
+ Failed (ty', dfun_id') -> recoverTc (returnTc class_inst_env) $
dupInstFailure clas (inst_ty, src_loc)
(ty', getSrcLoc dfun_id');
- Succeeded class_inst_env' ->
-
- returnTc (class_inst_env', op_spec_envs)
+ Succeeded class_inst_env' -> returnTc class_inst_env'
{- OLD STUFF FOR CONSTANT METHODS
returnTc (class_inst_env', op_spec_envs')
END OF OLD STUFF -}
- }
\end{code}
\begin{code}
= tcAddErrCtxt ctxt $
failTc (\sty -> ptext SLIT("Duplicate or overlapping instance declarations"))
where
- ctxt sty = hang (sep [ptext SLIT("Class"), ppr sty clas,
- ptext SLIT("type"), ppr sty ty1])
- 4 (sep [hcat [ptext SLIT("at "), ppr sty locn1],
- hcat [ptext SLIT("and "), ppr sty locn2]])
+ ctxt sty = sep [hsep [ptext SLIT("for"),
+ pprQuote sty $ \ sty -> ppr sty clas <+> ppr sty ty1],
+ nest 4 (sep [ptext SLIT("at") <+> ppr sty locn1,
+ ptext SLIT("and") <+> ppr sty locn2])]
\end{code}
import Unique ( Unique, pprUnique10 )
import Pretty
import Util ( nOfThem )
-#if __GLASGOW_HASKELL__ >= 202
import Outputable
-#endif
\end{code}
\begin{code}
instance Outputable (TcKind s) where
- ppr sty kind = ppr_kind sty kind
+ ppr sty kind = pprQuote sty $ \ sty -> ppr_kind sty kind
ppr_kind sty TcTypeKind
= char '*'
module TcModule (
typecheckModule,
SYN_IE(TcResults),
- SYN_IE(TcResultBinds),
SYN_IE(TcSpecialiseRequests),
SYN_IE(TcDDumpDeriv)
) where
IMP_Ubiq(){-uitous-}
-import HsSyn ( HsDecl(..), HsModule(..), HsBinds(..), HsExpr, MonoBinds,
+import HsSyn ( HsDecl(..), HsModule(..), HsBinds(..), HsExpr, MonoBinds(..),
TyDecl, SpecDataSig, ClassDecl, InstDecl, IfaceSig,
SpecInstSig, DefaultDecl, Sig, Fake, InPat,
- SYN_IE(RecFlag), nonRecursive,
+ SYN_IE(RecFlag), nonRecursive, GRHSsAndBinds, Match,
FixityDecl, IE, ImportDecl
)
import RnHsSyn ( SYN_IE(RenamedHsModule), RenamedFixityDecl(..) )
import TcHsSyn ( SYN_IE(TypecheckedHsBinds), SYN_IE(TypecheckedHsExpr),
- SYN_IE(TypecheckedDictBinds),
- TcIdOcc(..), zonkBinds )
+ SYN_IE(TypecheckedDictBinds), SYN_IE(TcMonoBinds),
+ SYN_IE(TypecheckedMonoBinds),
+ TcIdOcc(..), zonkTopBinds )
import TcMonad
-import Inst ( Inst, plusLIE )
+import Inst ( Inst, emptyLIE, plusLIE )
import TcBinds ( tcBindsAndThen )
import TcClassDcl ( tcClassDecls2 )
import TcDefaults ( tcDefaults )
import Name ( Name, isLocallyDefined, pprModule )
import Pretty
import TyCon ( TyCon, isSynTyCon )
-import Class ( GenClass, SYN_IE(Class), classGlobalIds )
+import Class ( GenClass, SYN_IE(Class), classSelIds )
import Type ( applyTyCon, mkSynTy, SYN_IE(Type) )
import PprType ( GenType, GenTyVar )
import TysWiredIn ( unitTy )
Outside-world interface:
\begin{code}
+--ToDo: put this in HsVersions
+#if __GLASGOW_HASKELL__ >= 200
+# define REAL_WORLD RealWorld
+#else
+# define REAL_WORLD _RealWorld
+#endif
+
+
-- Convenient type synonyms first:
type TcResults
- = (TcResultBinds,
+ = (TypecheckedMonoBinds,
[TyCon], [Class],
Bag InstInfo, -- Instance declaration information
TcSpecialiseRequests,
TcDDumpDeriv)
-type TcResultBinds
- = (TypecheckedHsBinds, -- record selector binds
- TypecheckedHsBinds, -- binds from class decls; does NOT
- -- include default-methods bindings
- TypecheckedHsBinds, -- binds from instance decls; INCLUDES
- -- class default-methods binds
- TypecheckedHsBinds, -- binds from value decls
-
- TypecheckedHsBinds) -- constant instance binds
-
type TcSpecialiseRequests
= FiniteMap TyCon [(Bool, [Maybe Type])]
-- source tycon specialisation requests
-> RnNameSupply
-> RenamedHsModule
-> MaybeErr
- (TcResults, -- if all goes well...
- Bag Warning) -- (we can still get warnings)
- (Bag Error, -- if we had errors...
+ (TcResults, -- if all goes well...
+ Bag Warning) -- (we can still get warnings)
+ (Bag Error, -- if we had errors...
Bag Warning)
typecheckModule us rn_name_supply mod
(HsModule mod_name verion exports imports fixities decls src_loc)
= tcAddSrcLoc src_loc $ -- record where we're starting
- -- Tie the knot for inteface-file value declaration signatures
- -- This info is only used inside the knot for type-checking the
- -- pragmas, which is done lazily [ie failure just drops the pragma
+ fixTc (\ ~(unf_env ,_) ->
+ -- unf_env is used for type-checking interface pragmas
+ -- which is done lazily [ie failure just drops the pragma
-- without having any global-failure effect].
+ --
+ -- unf_env is also used to get the pragam info for dfuns.
+
+ -- The knot for instance information. This isn't used at all
+ -- till we type-check value declarations
+ fixTc ( \ ~(rec_inst_mapper, _, _, _, _) ->
+
+ -- Type-check the type and class decls
+ -- trace "tcTyAndClassDecls:" $
+ tcTyAndClassDecls1 unf_env rec_inst_mapper decls `thenTc` \ env ->
+
+ -- trace "tc3" $
+ -- Typecheck the instance decls, includes deriving
+ tcSetEnv env (
+ -- trace "tcInstDecls:" $
+ tcInstDecls1 unf_env decls mod_name rn_name_supply
+ ) `thenTc` \ (inst_info, deriv_binds, ddump_deriv) ->
+
+ -- trace "tc4" $
+ buildInstanceEnvs inst_info `thenTc` \ inst_mapper ->
+
+ returnTc (inst_mapper, env, inst_info, deriv_binds, ddump_deriv)
+
+ -- End of inner fix loop
+ ) `thenTc` \ (_, env, inst_info, deriv_binds, ddump_deriv) ->
+
+ -- trace "tc5" $
+ tcSetEnv env $
+
+ -- Default declarations
+ tcDefaults decls `thenTc` \ defaulting_tys ->
+ tcSetDefaultTys defaulting_tys $
+
+ -- Create any necessary record selector Ids and their bindings
+ -- "Necessary" includes data and newtype declarations
+ let
+ tycons = getEnv_TyCons env
+ classes = getEnv_Classes env
+ in
+ mkDataBinds tycons `thenTc` \ (data_ids, data_binds) ->
+
+ -- Extend the global value environment with
+ -- (a) constructors
+ -- (b) record selectors
+ -- (c) class op selectors
+ -- (d) default-method ids
+ tcExtendGlobalValEnv data_ids $
+ tcExtendGlobalValEnv (concat (map classSelIds classes)) $
- -- trace "tc1" $
-
- fixTc (\ ~(_, _, _, _, _, _, sig_ids) ->
-
- -- trace "tc2" $
- tcExtendGlobalValEnv sig_ids (
- -- The knot for instance information. This isn't used at all
- -- till we type-check value declarations
- fixTc ( \ ~(rec_inst_mapper, _, _, _, _) ->
+ -- Interface type signatures
+ -- We tie a knot so that the Ids read out of interfaces are in scope
+ -- when we read their pragmas.
+ -- What we rely on is that pragmas are typechecked lazily; if
+ -- any type errors are found (ie there's an inconsistency)
+ -- we silently discard the pragma
+ tcInterfaceSigs unf_env decls `thenTc` \ sig_ids ->
+ tcExtendGlobalValEnv sig_ids $
- -- Type-check the type and class decls
- -- trace "tcTyAndClassDecls:" $
- tcTyAndClassDecls1 rec_inst_mapper decls `thenTc` \ env ->
- -- trace "tc3" $
- -- Typecheck the instance decls, includes deriving
- tcSetEnv env (
- -- trace "tcInstDecls:" $
- tcInstDecls1 decls mod_name rn_name_supply
- ) `thenTc` \ (inst_info, deriv_binds, ddump_deriv) ->
+ -- Value declarations next.
+ -- We also typecheck any extra binds that came out of the "deriving" process
+ -- trace "tcBinds:" $
+ tcBindsAndThen
+ (\ is_rec binds1 (binds2, thing) -> (binds1 `AndMonoBinds` binds2, thing))
+ (get_val_decls decls `ThenBinds` deriv_binds)
+ ( tcGetEnv `thenNF_Tc` \ env ->
+ returnTc ((EmptyMonoBinds, env), emptyLIE)
+ ) `thenTc` \ ((val_binds, final_env), lie_valdecls) ->
+ tcSetEnv final_env $
- -- trace "tc4" $
- buildInstanceEnvs inst_info `thenTc` \ inst_mapper ->
- returnTc (inst_mapper, env, inst_info, deriv_binds, ddump_deriv)
+ -- Second pass over class and instance declarations,
+ -- to compile the bindings themselves.
+ -- trace "tc8" $
+ tcInstDecls2 inst_info `thenNF_Tc` \ (lie_instdecls, inst_binds) ->
+ tcClassDecls2 decls `thenNF_Tc` \ (lie_clasdecls, cls_binds) ->
- ) `thenTc` \ (_, env, inst_info, deriv_binds, ddump_deriv) ->
- -- trace "tc5" $
- tcSetEnv env (
- -- Default declarations
- tcDefaults decls `thenTc` \ defaulting_tys ->
- tcSetDefaultTys defaulting_tys ( -- for the iface sigs...
+ -- Check that "main" has the right signature
+ tcCheckMainSig mod_name `thenTc_`
- -- Create any necessary record selector Ids and their bindings
- -- "Necessary" includes data and newtype declarations
+ -- Deal with constant or ambiguous InstIds. How could
+ -- there be ambiguous ones? They can only arise if a
+ -- top-level decl falls under the monomorphism
+ -- restriction, and no subsequent decl instantiates its
+ -- type. (Usually, ambiguous type variables are resolved
+ -- during the generalisation step.)
+ -- trace "tc9" $
let
- tycons = getEnv_TyCons env
- classes = getEnv_Classes env
+ lie_alldecls = lie_valdecls `plusLIE` lie_instdecls `plusLIE` lie_clasdecls
in
- mkDataBinds tycons `thenTc` \ (data_ids, data_binds) ->
+ tcSimplifyTop lie_alldecls `thenTc` \ const_inst_binds ->
- -- Extend the global value environment with
- -- a) constructors
- -- b) record selectors
- -- c) class op selectors
- -- d) default-method ids
- tcExtendGlobalValEnv data_ids $
- tcExtendGlobalValEnv (concat (map classGlobalIds classes)) $
- -- Interface type signatures
- -- We tie a knot so that the Ids read out of interfaces are in scope
- -- when we read their pragmas.
- -- What we rely on is that pragmas are typechecked lazily; if
- -- any type errors are found (ie there's an inconsistency)
- -- we silently discard the pragma
- tcInterfaceSigs decls `thenTc` \ sig_ids ->
- tcGetEnv `thenNF_Tc` \ env ->
- -- trace "tc6" $
-
- returnTc (env, inst_info, data_binds, deriv_binds, ddump_deriv, defaulting_tys, sig_ids)
-
- )))) `thenTc` \ (env, inst_info, data_binds, deriv_binds, ddump_deriv, defaulting_tys, _) ->
+ -- Backsubstitution. This must be done last.
+ -- Even tcCheckMainSig and tcSimplifyTop may do some unification.
+ let
+ all_binds = data_binds `AndMonoBinds`
+ val_binds `AndMonoBinds`
+ inst_binds `AndMonoBinds`
+ cls_binds `AndMonoBinds`
+ const_inst_binds
+ in
+ zonkTopBinds all_binds `thenNF_Tc` \ (all_binds', really_final_env) ->
- -- trace "tc7" $
- tcSetEnv env ( -- to the end...
- tcSetDefaultTys defaulting_tys ( -- ditto
+ returnTc (really_final_env, (all_binds', inst_info, ddump_deriv))
- -- Value declarations next.
- -- We also typecheck any extra binds that came out of the "deriving" process
- -- trace "tcBinds:" $
- tcBindsAndThen
- (\ binds1 (binds2, thing) -> (binds1 `ThenBinds` binds2, thing))
- (get_val_decls decls `ThenBinds` deriv_binds)
- ( -- Second pass over instance declarations,
- -- to compile the bindings themselves.
- -- trace "tc8" $
- tcInstDecls2 inst_info `thenNF_Tc` \ (lie_instdecls, inst_binds) ->
- tcClassDecls2 decls `thenNF_Tc` \ (lie_clasdecls, cls_binds) ->
- tcCheckMainSig mod_name `thenTc_`
- tcGetEnv `thenNF_Tc` \ env ->
- returnTc ( (EmptyBinds, (inst_binds, cls_binds, env)),
- lie_instdecls `plusLIE` lie_clasdecls
- )
- )
-
- `thenTc` \ ((val_binds, (inst_binds, cls_binds, final_env)), lie_alldecls) ->
-
- -- Deal with constant or ambiguous InstIds. How could
- -- there be ambiguous ones? They can only arise if a
- -- top-level decl falls under the monomorphism
- -- restriction, and no subsequent decl instantiates its
- -- type. (Usually, ambiguous type variables are resolved
- -- during the generalisation step.)
- -- trace "tc9" $
- tcSimplifyTop lie_alldecls `thenTc` \ const_insts ->
-
-
- -- Backsubstitution. Monomorphic top-level decls may have
- -- been instantiated by subsequent decls, and the final
- -- simplification step may have instantiated some
- -- ambiguous types. So, sadly, we need to back-substitute
- -- over the whole bunch of bindings.
- --
- -- More horrible still, we have to do it in a careful order, so that
- -- all the TcIds are in scope when we come across them.
- --
- -- These bindings ought really to be bundled together in a huge
- -- recursive group, but HsSyn doesn't have recursion among Binds, only
- -- among MonoBinds. Sigh again.
- zonkBinds nullTyVarEnv nullIdEnv (MonoBind const_insts [] nonRecursive)
- `thenNF_Tc` \ (const_insts', ve1) ->
- zonkBinds nullTyVarEnv ve1 val_binds `thenNF_Tc` \ (val_binds', ve2) ->
+ -- End of outer fix loop
+ ) `thenTc` \ (final_env, (all_binds', inst_info, ddump_deriv)) ->
- zonkBinds nullTyVarEnv ve2 data_binds `thenNF_Tc` \ (data_binds', _) ->
- zonkBinds nullTyVarEnv ve2 inst_binds `thenNF_Tc` \ (inst_binds', _) ->
- zonkBinds nullTyVarEnv ve2 cls_binds `thenNF_Tc` \ (cls_binds', _) ->
let
- localids = getEnv_LocalIds final_env
tycons = getEnv_TyCons final_env
classes = getEnv_Classes final_env
in
-- FINISHED AT LAST
returnTc (
- (data_binds', cls_binds', inst_binds', val_binds', const_insts'),
+ all_binds',
local_tycons, local_classes, inst_info, tycon_specs,
ddump_deriv
- )))
+ )
get_val_decls decls = foldr ThenBinds EmptyBinds [binds | ValD binds <- decls]
\end{code}
projects / ghc-hetmet.git / commitdiff