import RnHsSyn ( RenamedStmt, RenamedTyClDecl,
ruleDeclFVs, instDeclFVs, tyClDeclFVs )
import TcHsSyn ( TypecheckedHsExpr, TypecheckedRuleDecl,
- zonkTopBinds, zonkTopDecls, mkHsLet,
+ zonkTopDecls, mkHsLet,
zonkTopExpr, zonkTopBndrs
)
-import TcExpr ( tcExpr_id )
+import TcExpr ( tcInferRho )
import TcRnMonad
import TcMType ( newTyVarTy, zonkTcType )
import TcType ( Type, liftedTypeKind,
import TcClassDcl ( tcClassDecls2 )
import TcDefaults ( tcDefaults )
import TcEnv ( tcExtendGlobalValEnv,
- tcExtendGlobalEnv,
tcExtendInstEnv, tcExtendRules,
tcLookupTyCon, tcLookupGlobal,
tcLookupId
isLocalGRE )
#endif
-import Maybe ( catMaybes )
import Panic ( showException )
import List ( partition )
import Util ( sortLt )
traceRn (text "rn1a") ;
-- Rename and type check the declarations
- (tcg_env, src_fvs) <- tcRnSrcDecls local_decls ;
- setGblEnv tcg_env $ do {
- traceRn (text "rn2") ;
-
- -- Check for 'main'
- (tcg_env, main_fvs) <- checkMain ;
+ (tcg_env, src_dus) <- tcRnSrcDecls local_decls ;
setGblEnv tcg_env $ do {
traceRn (text "rn3") ;
setGblEnv tcg_env $ do {
-- Report unused names
- let { used_fvs = src_fvs `plusFV` main_fvs `plusFV` export_fvs } ;
- reportUnusedNames tcg_env used_fvs ;
+ let { all_dus = src_dus `plusDU` usesOnly export_fvs } ;
+ reportUnusedNames tcg_env all_dus ;
-- Dump output and return
tcDump tcg_env ;
return tcg_env
- }}}}}}}}
+ }}}}}}}
\end{code}
-- Now typecheck the expression;
-- it might have a rank-2 type (e.g. :t runST)
- -- Hence the hole type (c.f. TcExpr.tcExpr_id)
- ((tc_expr, res_ty), lie) <- getLIE (tcExpr_id rn_expr) ;
+ ((tc_expr, res_ty), lie) <- getLIE (tcInferRho rn_expr) ;
((qtvs, _, dict_ids), lie_top) <- getLIE (tcSimplifyInfer smpl_doc (tyVarsOfType res_ty) lie) ;
tcSimplifyTop lie_top ;
-- constructor and type class identifiers.
let { rdr_names = dataTcOccs rdr_name } ;
- (msgs_s, mb_names) <- initRnInteractive ictxt
- (mapAndUnzipM (tryTc . lookupOccRn) rdr_names) ;
- let { names = catMaybes mb_names } ;
+ -- results :: [(Messages, Maybe Name)]
+ results <- initRnInteractive ictxt
+ (mapM (tryTc . lookupOccRn) rdr_names) ;
- if null names then
- do { addMessages (head msgs_s) ; failM }
- else do {
-
- -- Add deprecation warnings
- mapM_ addMessages msgs_s ;
+ -- The successful lookups will be (Just name)
+ let { (warns_s, good_names) = unzip [ (msgs, name)
+ | (msgs, Just name) <- results] ;
+ errs_s = [msgs | (msgs, Nothing) <- results] } ;
+ -- Fail if nothing good happened, else add warnings
+ if null good_names then -- Fail
+ do { addMessages (head errs_s) ; failM }
+ else -- Add deprecation warnings
+ mapM_ addMessages warns_s ;
+
-- Slurp in the supporting declarations
- tcg_env <- importSupportingDecls (mkFVs names) ;
+ tcg_env <- importSupportingDecls (mkFVs good_names) ;
setGblEnv tcg_env $ do {
-- And lookup up the entities
- mapM tcLookupGlobal names
- }}}
+ mapM tcLookupGlobal good_names
+ }}
\end{code}
-- rnSrcDecls handles fixity decls etc too, which won't occur
-- but that doesn't matter
let { local_group = mkGroup local_decls } ;
- (_, rn_local_decls, fvs) <- initRn (InterfaceMode this_mod)
+ (_, rn_local_decls, dus) <- initRn (InterfaceMode this_mod)
(rnSrcDecls local_group) ;
failIfErrsM ;
- -- Get the supporting decls, and typecheck them all together
- -- so that any mutually recursive types are done right
- extra_decls <- slurpImpDecls fvs ;
- tcg_env <- typecheckIfaceDecls (rn_local_decls `addImpDecls` extra_decls) ;
+ -- Get the supporting decls
+ rn_imp_decls <- slurpImpDecls (duUses dus) ;
+ let { rn_decls = rn_local_decls `addImpDecls` rn_imp_decls } ;
+
+ -- Dump trace of renaming part
+ rnDump (ppr rn_decls) ;
+ rnStats rn_imp_decls ;
+
+ -- Typecheck them all together so that
+ -- any mutually recursive types are done right
+ tcg_env <- typecheckIfaceDecls rn_decls ;
setGblEnv tcg_env $ do {
-- Now the core bindings
%************************************************************************
\begin{code}
-tcRnSrcDecls :: [RdrNameHsDecl] -> TcM (TcGblEnv, FreeVars)
+tcRnSrcDecls :: [RdrNameHsDecl] -> TcM (TcGblEnv, DefUses)
-- Returns the variables free in the decls
-- Reason: solely to report unused imports and bindings
-tcRnSrcDecls [] = do { tcg_env <- getGblEnv ; return (tcg_env, emptyFVs) }
-tcRnSrcDecls ds
+tcRnSrcDecls decls
+ = do { -- Do all the declarations
+ ((tc_envs, dus), lie) <- getLIE (tc_rn_src_decls decls) ;
+
+ -- tcSimplifyTop deals 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.)
+ traceTc (text "Tc8") ;
+ setEnvs tc_envs $ do {
+ -- Setting the global env exposes the instances to tcSimplifyTop
+ -- Setting the local env exposes the local Ids, so that
+ -- we get better error messages (monomorphism restriction)
+ inst_binds <- tcSimplifyTop lie ;
+
+ -- Backsubstitution. This must be done last.
+ -- Even tcSimplifyTop may do some unification.
+ traceTc (text "Tc9") ;
+ let { (tcg_env, _) = tc_envs ;
+ TcGblEnv { tcg_type_env = type_env, tcg_binds = binds,
+ tcg_rules = rules, tcg_fords = fords } = tcg_env } ;
+
+ (bind_ids, binds', fords', rules') <- zonkTopDecls (binds `andMonoBinds` inst_binds)
+ rules fords ;
+
+ return (tcg_env { tcg_type_env = extendTypeEnvWithIds type_env bind_ids,
+ tcg_binds = binds', tcg_rules = rules', tcg_fords = fords' },
+ dus)
+ }}
+
+tc_rn_src_decls :: [RdrNameHsDecl] -> TcM ((TcGblEnv, TcLclEnv), DefUses)
+
+tc_rn_src_decls ds
= do { let { (first_group, group_tail) = findSplice ds } ;
+ -- If ds is [] we get ([], Nothing)
-- Type check the decls up to, but not including, the first splice
- (tcg_env, src_fvs1) <- tcRnGroup first_group ;
+ (tc_envs@(_,tcl_env), src_dus1) <- tcRnGroup first_group ;
-- 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
+ setEnvs tc_envs $
+
+ -- If there is no splice, we're nearlydone
case group_tail of {
- Nothing -> return (tcg_env, src_fvs1) ;
- Just (SpliceDecl splice_expr splice_loc, rest_ds) ->
+ Nothing -> do { -- Last thing: check for `main'
+ (tcg_env, main_fvs) <- checkMain ;
+ return ((tcg_env, tcl_env),
+ src_dus1 `plusDU` usesOnly main_fvs)
+ } ;
+
+ -- If there's a splice, we must carry on
+ Just (SpliceDecl splice_expr splice_loc, rest_ds) -> do {
#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 $
- rnExpr splice_expr ;
- tcg_env <- importSupportingDecls (fvs `plusFV` templateHaskellNames) ;
+ (rn_splice_expr, splice_fvs) <- initRn SourceMode $
+ addSrcLoc splice_loc $
+ rnExpr splice_expr ;
+ tcg_env <- importSupportingDecls (splice_fvs `plusFV` templateHaskellNames) ;
setGblEnv tcg_env $ do {
-- Execute the splice
spliced_decls <- tcSpliceDecls rn_splice_expr ;
-- Glue them on the front of the remaining decls and loop
- (tcg_env, src_fvs2) <- tcRnSrcDecls (spliced_decls ++ rest_ds) ;
+ (tc_envs, src_dus2) <- tc_rn_src_decls (spliced_decls ++ rest_ds) ;
- return (tcg_env, src_fvs1 `plusFV` src_fvs2)
- }}
+ return (tc_envs, src_dus1 `plusDU` usesOnly splice_fvs `plusDU` src_dus2)
+ }
#endif /* GHCI */
- }}
+ }}}
\end{code}
monad; it augments it and returns the new TcGblEnv.
\begin{code}
-tcRnGroup :: HsGroup RdrName -> TcM (TcGblEnv, FreeVars)
- -- Returns the variables free in the decls
+tcRnGroup :: HsGroup RdrName -> TcM ((TcGblEnv, TcLclEnv), DefUses)
+ -- Returns the variables free in the decls, for unused-binding reporting
tcRnGroup decls
= do { -- Rename the declarations
- (tcg_env, rn_decls, src_fvs) <- rnTopSrcDecls decls ;
+ (tcg_env, rn_decls, src_dus) <- rnTopSrcDecls decls ;
setGblEnv tcg_env $ do {
-- Typecheck the declarations
- tcg_env <- tcTopSrcDecls rn_decls ;
- return (tcg_env, src_fvs)
+ tc_envs <- tcTopSrcDecls rn_decls ;
+
+ return (tc_envs, src_dus)
}}
------------------------------------------------
-rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name, FreeVars)
+rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name, DefUses)
rnTopSrcDecls group
= do { -- Bring top level binders into scope
(rdr_env, imports) <- importsFromLocalDecls group ;
failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations
-- Rename the source decls
- (tcg_env, rn_src_decls, src_fvs) <- initRn SourceMode (rnSrcDecls group) ;
+ (tcg_env, rn_src_decls, src_dus) <- initRn SourceMode (rnSrcDecls group) ;
setGblEnv tcg_env $ do {
failIfErrsM ;
-- Import consquential imports
+ let { src_fvs = duUses src_dus } ;
rn_imp_decls <- slurpImpDecls (src_fvs `plusFV` implicitModuleFVs src_fvs) ;
let { rn_decls = rn_src_decls `addImpDecls` rn_imp_decls } ;
rnDump (ppr rn_decls) ;
rnStats rn_imp_decls ;
- return (tcg_env, rn_decls, src_fvs)
+ return (tcg_env, rn_decls, src_dus)
}}}
------------------------------------------------
-tcTopSrcDecls :: HsGroup Name -> TcM TcGblEnv
-tcTopSrcDecls rn_decls
- = do { -- Do the main work
- ((tcg_env, lcl_env, binds, rules, fords), lie) <- getLIE (
- tc_src_decls rn_decls
- ) ;
-
- -- tcSimplifyTop deals 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.)
- traceTc (text "Tc8") ;
- inst_binds <- setGblEnv tcg_env $
- setLclTypeEnv lcl_env $
- tcSimplifyTop lie ;
- -- The setGblEnv exposes the instances to tcSimplifyTop
- -- 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") ;
- (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)
- 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
+tcTopSrcDecls :: HsGroup Name -> TcM (TcGblEnv, TcLclEnv)
+tcTopSrcDecls
(HsGroup { hs_tyclds = tycl_decls,
hs_instds = inst_decls,
hs_fords = foreign_decls,
(cls_dm_binds, dm_ids) <- tcClassDecls2 tycl_decls ;
tcExtendGlobalValEnv dm_ids $ do {
inst_binds <- tcInstDecls2 inst_infos ;
- showLIE "after instDecls2" ;
+ showLIE (text "after instDecls2") ;
-- Foreign exports
-- They need to be zonked, so we return them
let { all_binds = tc_val_binds `AndMonoBinds`
inst_binds `AndMonoBinds`
cls_dm_binds `AndMonoBinds`
- foe_binds } ;
+ foe_binds ;
- return (tcg_env, lcl_env, all_binds, src_rules, foe_decls)
+ -- Extend the GblEnv with the (as yet un-zonked)
+ -- bindings, rules, foreign decls
+ tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env `andMonoBinds` all_binds,
+ tcg_rules = tcg_rules tcg_env ++ src_rules,
+ tcg_fords = tcg_fords tcg_env ++ foe_decls } } ;
+
+ return (tcg_env', lcl_env)
}}}}}}}}}
\end{code}
-- an error we'd better stop now, to avoid a cascade
traceTc (text "TyCl1") `thenM_`
- tcTyAndClassDecls tycl_decls `thenM` \ tycl_things ->
- tcExtendGlobalEnv tycl_things $
+ tcTyAndClassDecls tycl_decls `thenM` \ tcg_env ->
+ -- Returns the extended environment
+ setGblEnv tcg_env $
traceTc (text "TyCl2") `thenM_`
tcInterfaceSigs tycl_decls `thenM` \ tcg_env ->
= do { main_name <- lookupSrcName main_RDR_Unqual ;
tcg_env <- importSupportingDecls (unitFV runIOName) ;
- setGblEnv tcg_env $ do {
+
+ addSrcLoc (getSrcLoc main_name) $
+ addErrCtxt mainCtxt $
+ setGblEnv tcg_env $ do {
-- $main :: IO () = runIO main
let { rhs = HsApp (HsVar runIOName) (HsVar main_name) } ;
+ (main_expr, ty) <- tcInferRho rhs ;
- (main_bind, top_lie) <- getLIE (
- addSrcLoc (getSrcLoc main_name) $
- addErrCtxt mainCtxt $ do {
- (main_expr, ty) <- tcExpr_id rhs ;
- let { dollar_main_id = setIdLocalExported (mkLocalId dollarMainName ty) } ;
- return (VarMonoBind dollar_main_id main_expr)
- }) ;
-
- inst_binds <- tcSimplifyTop top_lie ;
-
- (ids, binds') <- zonkTopBinds (main_bind `andMonoBinds` inst_binds) ;
-
- let { tcg_env' = tcg_env {
- tcg_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) ids,
- tcg_binds = tcg_binds tcg_env `andMonoBinds` binds' } } ;
+ let { dollar_main_id = setIdLocalExported (mkLocalId dollarMainName ty) ;
+ main_bind = VarMonoBind dollar_main_id main_expr ;
+ tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env
+ `andMonoBinds` main_bind } } ;
return (tcg_env', unitFV main_name)
}}
projects / ghc-hetmet.git / blobdiff