tcExtendLocalValEnv, tcExtendLocalValEnv2,
tcLookup, tcLookupLocalIds, tcLookup_maybe,
tcLookupId, tcLookupIdLvl,
- getLclEnvElts, getInLocalScope,
- findGlobals,
+ lclEnvElts, getInLocalScope, findGlobals,
-- Instance environment
tcExtendLocalInstEnv, tcExtendInstEnv,
Just (ATcId id lvl1) -> ASSERT( lvl == lvl1 ) id
other -> pprPanic "tcLookupLocalIds" (ppr name)
-getLclEnvElts :: TcM [TcTyThing]
-getLclEnvElts = getLclEnv `thenM` \ env ->
- return (nameEnvElts (tcl_env env))
+lclEnvElts :: TcLclEnv -> [TcTyThing]
+lclEnvElts env = nameEnvElts (tcl_env env)
getInLocalScope :: TcM (Name -> Bool)
-- Ids only
-> TcM (TidyEnv, [SDoc])
findGlobals tvs tidy_env
- = getLclEnvElts `thenM` \ lcl_env ->
- go tidy_env [] lcl_env
+ = getLclEnv `thenM` \ lcl_env ->
+ go tidy_env [] (lclEnvElts lcl_env)
where
go tidy_env acc [] = returnM (tidy_env, acc)
go tidy_env acc (thing : things)
Brack use_lvl ps_var lie_var
| use_lvl > bind_lvl && not (isExternalName name)
-> -- E.g. \x -> [| h x |]
- -- We must behave as if the reference to x was
- -- h $(lift x)
- -- We use 'x' itself as the splice proxy, used by
- -- the desugarer to stitch it all back together
- -- NB: isExernalName is true of top level things,
- -- and false of nested bindings
+ -- We must behave as if the reference to x was
+ -- h $(lift x)
+ -- We use 'x' itself as the splice proxy, used by
+ -- the desugarer to stitch it all back together.
+ -- If 'x' occurs many times we may get many identical
+ -- bindings of the same splice proxy, but that doesn't
+ -- matter, although it's a mite untidy.
+ -- NB: isExernalName is true of top level things,
+ -- and false of nested bindings
let
id_ty = idType id
signatures.
\begin{code}
-tcInterfaceSigs :: RecTcGblEnv -- Envt to use when checking unfoldings
- -> [RenamedTyClDecl] -- Ignore non-sig-decls in these decls
- -> TcM [Id]
+tcInterfaceSigs :: [RenamedTyClDecl] -- Ignore non-sig-decls in these decls
+ -> TcM TcGblEnv
-
-tcInterfaceSigs unf_env decls
- = sequenceM [ do_one name ty id_infos src_loc
- | IfaceSig {tcdName = name, tcdType = ty,
- tcdIdInfo = id_infos, tcdLoc =src_loc} <- decls]
+tcInterfaceSigs decls = fixM (tc_interface_sigs decls)
+ -- 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
+ --
+ -- We used to have a much bigger loop (in TcRnDriver), so that the
+ -- interface pragmas could mention variables bound in this module
+ -- (by mutual recn), but
+ -- (a) the knot is tiresomely big, and
+ -- (b) it black-holes when we have Template Haskell
+ --
+ -- For (b) consider: f = $(...h....)
+ -- where h is imported, and calls f via an hi-boot file.
+ -- This is bad! But it is not seen as a staging error, because h
+ -- is indeed imported. We don't want the type-checker to black-hole
+ -- when simplifying and compiling the splice!
+ --
+ -- Simple solution: discard any unfolding that mentions a variable
+ -- bound in this module (and hence not yet processed).
+ -- The discarding happens when forkM finds a type error.
+
+tc_interface_sigs decls unf_env
+ = sequenceM [do_one d | d@(IfaceSig {}) <- decls] `thenM` \ sig_ids ->
+ tcExtendGlobalValEnv sig_ids getGblEnv
+ -- Return the extended environment
where
in_scope_vars = typeEnvIds (tcg_type_env unf_env)
-- When we have hi-boot files, an unfolding might refer to
-- suitable in-scope set. This thunk will only be poked
-- if -dcore-lint is on.
- do_one name ty id_infos src_loc
- = addSrcLoc src_loc $
+ do_one IfaceSig {tcdName = name, tcdType = ty,
+ tcdIdInfo = id_infos, tcdLoc = src_loc}
+ = addSrcLoc src_loc $
addErrCtxt (ifaceSigCtxt name) $
- tcIfaceType ty `thenM` \ sigma_ty ->
+ tcIfaceType ty `thenM` \ sigma_ty ->
tcIdInfo unf_env in_scope_vars name
- sigma_ty id_infos `thenM` \ id_info ->
+ sigma_ty id_infos `thenM` \ id_info ->
returnM (mkVanillaGlobal name sigma_ty id_info)
\end{code}
-> RdrNameStmt
-> IO (PersistentCompilerState,
Maybe (InteractiveContext, [Name], TypecheckedHsExpr))
- -- The returned [Id] is the same as the input except for
+ -- The returned [Name] is the same as the input except for
-- ExprStmt, in which case the returned [Name] is [itName]
+ --
+ -- The returned TypecheckedHsExpr is of type IO [ () ],
+ -- a list of the bound values, coerced to ().
tcRnStmt hsc_env pcs ictxt rdr_stmt
= initTc hsc_env pcs iNTERACTIVE $
-- Type check the decls up to, but not including, the first splice
(tcg_env, src_fvs1) <- tcRnGroup first_group ;
- -- If there is no splice, we're done
- case group_tail of
- Nothing -> return (tcg_env, src_fvs1)
- Just (SpliceDecl splice_expr splice_loc, rest_ds) -> do {
-
- setGblEnv tcg_env $ do {
+ -- Bale out if errors; for example, error recovery when checking
+ -- the RHS of 'main' can mean that 'main' is not in the envt for
+ -- the subsequent checkMain test
+ failIfErrsM ;
+ -- If there is no splice, we're done
+ case group_tail of {
+ Nothing -> return (tcg_env, src_fvs1) ;
+ Just (SpliceDecl splice_expr splice_loc, rest_ds) ->
#ifndef GHCI
failWithTc (text "Can't do a top-level splice; need a bootstrapped compiler")
#else
+ setGblEnv tcg_env $ do {
+
-- Rename the splice expression, and get its supporting decls
(rn_splice_expr, fvs) <- initRn SourceMode $
addSrcLoc splice_loc $
(tcg_env, src_fvs2) <- tcRnSrcDecls (spliced_decls ++ rest_ds) ;
return (tcg_env, src_fvs1 `plusFV` src_fvs2)
- }
+ }}
#endif /* GHCI */
- }}}
+ }}
\end{code}
------------------------------------------------
tcTopSrcDecls :: HsGroup Name -> TcM TcGblEnv
tcTopSrcDecls rn_decls
- = fixM (\ unf_env -> do {
- -- Loop back the final environment, including the fully zonked
- -- versions of bindings from this module. In the presence of mutual
- -- recursion, interface type signatures may mention variables defined
- -- in this module, which is why the knot is so big
-
- -- Do the main work
+ = do { -- Do the main work
((tcg_env, lcl_env, binds, rules, fords), lie) <- getLIE (
- tc_src_decls unf_env rn_decls
+ tc_src_decls rn_decls
) ;
-- tcSimplifyTop deals with constant or ambiguous InstIds.
setLclTypeEnv lcl_env $
tcSimplifyTop lie ;
-- The setGblEnv exposes the instances to tcSimplifyTop
- -- The steLclTypeEnv exposes the local Ids, so that
+ -- The setLclTypeEnv exposes the local Ids, so that
-- we get better error messages (monomorphism restriction)
-- Backsubstitution. This must be done last.
-- Even tcSimplifyTop may do some unification.
traceTc (text "Tc9") ;
- (ids, binds', fords', rules') <- zonkTopDecls (binds `andMonoBinds` inst_binds)
- rules fords ;
+ (bind_ids, binds', fords', rules') <- zonkTopDecls (binds `andMonoBinds` inst_binds)
+ rules fords ;
- let { tcg_env' = tcg_env { tcg_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) ids,
+ let { tcg_env' = tcg_env { tcg_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env)
+ bind_ids,
tcg_binds = tcg_binds tcg_env `andMonoBinds` binds',
tcg_rules = tcg_rules tcg_env ++ rules',
tcg_fords = tcg_fords tcg_env ++ fords' } } ;
return tcg_env'
- })
+ }
-tc_src_decls unf_env
+tc_src_decls
(HsGroup { hs_tyclds = tycl_decls,
hs_instds = inst_decls,
hs_fords = foreign_decls,
hs_valds = val_binds })
= do { -- Type-check the type and class decls, and all imported decls
traceTc (text "Tc2") ;
- tcg_env <- tcTyClDecls unf_env tycl_decls ;
+ tcg_env <- tcTyClDecls tycl_decls ;
setGblEnv tcg_env $ do {
-- Source-language instances, including derivings,
\end{code}
\begin{code}
-tcTyClDecls :: RecTcGblEnv
- -> [RenamedTyClDecl]
+tcTyClDecls :: [RenamedTyClDecl]
-> TcM TcGblEnv
-- tcTyClDecls deals with
-- persistent compiler state to reflect the things imported from
-- other modules
-tcTyClDecls unf_env tycl_decls
- -- (unf_env :: RecTcGblEnv) is used for type-checking interface pragmas
- -- which is done lazily [ie failure just drops the pragma
- -- without having any global-failure effect].
-
+tcTyClDecls tycl_decls
= checkNoErrs $
-- tcTyAndClassDecls recovers internally, but if anything gave rise to
-- an error we'd better stop now, to avoid a cascade
traceTc (text "TyCl1") `thenM_`
tcTyAndClassDecls tycl_decls `thenM` \ tycl_things ->
tcExtendGlobalEnv tycl_things $
-
- -- 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
- traceTc (text "TyCl2") `thenM_`
- tcInterfaceSigs unf_env tycl_decls `thenM` \ sig_ids ->
- tcExtendGlobalValEnv sig_ids $
-
- getGblEnv -- Return the TcLocals environment
+
+ traceTc (text "TyCl2") `thenM_`
+ tcInterfaceSigs tycl_decls `thenM` \ tcg_env ->
+ -- Returns the extended environment
+
+ returnM tcg_env
\end{code}
hs_instds = inst_decls,
hs_ruleds = rule_decls })
= do { -- Typecheck the type, class, and interface-sig decls
- tcg_env <- fixM (\ unf_env -> tcTyClDecls unf_env tycl_decls) ;
+ tcg_env <- tcTyClDecls tycl_decls ;
setGblEnv tcg_env $ do {
-- Typecheck the instance decls, and rules
#include "HsVersions.h"
import {-# SOURCE #-} TcUnify( unifyTauTy )
-import TcEnv -- temp
+import TcEnv -- temp
import HsSyn ( MonoBinds(..), HsExpr(..), andMonoBinds, andMonoBindList )
import TcHsSyn ( TcExpr, TcId,
TcMonoBinds, TcDictBinds
\begin{code}
tcSimplifyTop :: [Inst] -> TcM TcDictBinds
tcSimplifyTop wanteds
- = getLclEnvElts `thenM` \ lcl_env ->
- traceTc (text "tcSimplifyTop" <+> ppr lcl_env) `thenM_`
+ = getLclEnv `thenM` \ lcl_env ->
+ traceTc (text "tcSimplifyTop" <+> ppr (lclEnvElts lcl_env)) `thenM_`
simpleReduceLoop (text "tcSimplTop") reduceMe wanteds `thenM` \ (frees, binds, irreds) ->
ASSERT( null frees )
import DsMeta ( exprTyConName, declTyConName, decTyConName, qTyConName )
import ErrUtils (Message)
import Outputable
+import Panic ( showException )
import GHC.Base ( unsafeCoerce# ) -- Should have a better home in the module hierarchy
import Monad (liftM)
\end{code}
-- inner escape before dealing with the outer one
tcTopSplice expr res_ty
- = tcMetaTy exprTyConName `thenM` \ meta_exp_ty ->
- setStage topSpliceStage (
- getLIE (tcMonoExpr expr meta_exp_ty)
- ) `thenM` \ (expr', lie) ->
+ = checkNoErrs (
+ -- checkNoErrs: must not try to run the thing
+ -- if the type checker fails!
+
+ tcMetaTy exprTyConName `thenM` \ meta_exp_ty ->
+ setStage topSpliceStage (
+ getLIE (tcMonoExpr expr meta_exp_ty)
+ ) `thenM` \ (expr', lie) ->
-- Solve the constraints
- tcSimplifyTop lie `thenM` \ const_binds ->
- let
- q_expr = mkHsLet const_binds expr'
- in
- zonkTopExpr q_expr `thenM` \ zonked_q_expr ->
+ tcSimplifyTop lie `thenM` \ const_binds ->
+
+ -- Wrap the bindings around it and zonk
+ zonkTopExpr (mkHsLet const_binds expr')
+ ) `thenM` \ zonked_q_expr ->
-- Run the expression
traceTc (text "About to run" <+> ppr zonked_q_expr) `thenM_`
-> TcM [Meta.Dec] -- Of type [Dec]
runMetaD e = runMeta e
-tcRunQ :: Meta.Q a -> TcM a
-tcRunQ thing = ioToTcRn (Meta.runQ thing)
-
runMeta :: TypecheckedHsExpr -- Of type X
-> TcM t -- Of type t
runMeta expr
type_env = tcg_type_env tcg_env
rdr_env = tcg_rdr_env tcg_env
in
- ioToTcRn (HscMain.compileExpr
- hsc_env pcs this_mod
- rdr_env type_env expr) `thenM` \ hval ->
-
- tryM (tcRunQ (unsafeCoerce# hval)) `thenM` \ either_tval ->
+ -- Wrap the compile-and-run in an exception-catcher
+ -- Compiling might fail if linking fails
+ -- Running might fail if it throws an exception
+ tryM (ioToTcRn (do
+ hval <- HscMain.compileExpr
+ hsc_env pcs this_mod
+ rdr_env type_env expr
+ Meta.runQ (unsafeCoerce# hval) -- Coerce it to Q t, and run it
+ )) `thenM` \ either_tval ->
case either_tval of
- Left exn -> failWithTc (vcat [text "Exception when running compile-time code:",
+ Left exn -> failWithTc (vcat [text "Exception when trying to run compile-time code:",
nest 4 (vcat [text "Code:" <+> ppr expr,
- text ("Exn: " ++ show exn)])])
+ text ("Exn: " ++ Panic.showException exn)])])
Right v -> returnM v
\end{code}
projects / ghc-hetmet.git / commitdiff