[project @ 2003-02-14 14:22:24 by simonpj]

-------------------------------------
   Do the top-level tcSimpifyTop (to resolve monomorphic constraints)
   once for the whole program, rather than once per splice group
	-------------------------------------

This change makes the trivial program

	main = return ()

work again.  It had stopped working (emitting an error about Monad m
being unconstrained) because the 'checkMain' stuff (which knows special
things about 'main' was happening only *after* all the groups of
decls in the module had been dealt with and zonked (incl tcSimplifyTop).

Better to postpone.  A little more plumbing, but one fewer unexpected
happenings.

4 files changed, 88 insertions, 77 deletions

diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs
index 0ca5d6035e..79fbcd1ced 100644
--- a/ghc/compiler/typecheck/TcHsSyn.lhs
+++ b/ghc/compiler/typecheck/TcHsSyn.lhs
@@ -818,6 +818,8 @@ zonkForeignExports env ls = mappM (zonkForeignExport env) ls
 zonkForeignExport :: ZonkEnv -> TcForeignDecl -> TcM (TypecheckedForeignDecl)
 zonkForeignExport env (ForeignExport i hs_ty spec isDeprec src_loc) =
    returnM (ForeignExport (zonkIdOcc env i) undefined spec isDeprec src_loc)
+zonkForeignExport env for_imp 
+  = returnM for_imp	-- Foreign imports don't need zonking
 \end{code}
 
 \begin{code}
diff --git a/ghc/compiler/typecheck/TcRnDriver.lhs b/ghc/compiler/typecheck/TcRnDriver.lhs
index d225b6c167..89dc247c32 100644
--- a/ghc/compiler/typecheck/TcRnDriver.lhs
+++ b/ghc/compiler/typecheck/TcRnDriver.lhs
@@ -156,11 +156,6 @@ tcRnModule hsc_env pcs
 		-- 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 ;
-	setGblEnv tcg_env		$ do {
 
 	traceRn (text "rn3") ;
 		-- Check whether the entire module is deprecated
@@ -191,13 +186,13 @@ tcRnModule hsc_env pcs
 	setGblEnv tcg_env $ do {
 
 		-- Report unused names
-	let { used_fvs = src_fvs `plusFV` main_fvs `plusFV` export_fvs } ;
+	let { used_fvs = src_fvs `plusFV` export_fvs } ;
  	reportUnusedNames tcg_env used_fvs ;
 
 		-- Dump output and return
 	tcDump tcg_env ;
 	return tcg_env
-    }}}}}}}}
+    }}}}}}}
 \end{code}
 
 
@@ -600,26 +595,67 @@ tcRnExtCore hsc_env pcs
 tcRnSrcDecls :: [RdrNameHsDecl] -> TcM (TcGblEnv, FreeVars)
 	-- 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, fvs), 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' }, 
+		fvs)
+    }}
+
+tc_rn_src_decls :: [RdrNameHsDecl] -> TcM ((TcGblEnv, TcLclEnv), FreeVars)
+
+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_fvs1) <- 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) ;
+	   Nothing -> do { 	-- Last thing: check for `main'
+			   (tcg_env, main_fvs) <- checkMain ;
+			   return ((tcg_env, tcl_env), src_fvs1 `plusFV` main_fvs)
+		      } ;
+
+	-- If there's a splice, we must carry on
 	   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 $
@@ -632,10 +668,10 @@ tcRnSrcDecls ds
 	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_fvs2) <- tc_rn_src_decls (spliced_decls ++ rest_ds) ;
 
-	return (tcg_env, src_fvs1 `plusFV` src_fvs2)
-    }}
+	return (tc_envs, src_fvs1 `plusFV` src_fvs2)
+    }
 #endif /* GHCI */
     }}
 \end{code}
@@ -659,16 +695,16 @@ declarations.  It expects there to be an incoming TcGblEnv in the
 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), FreeVars)
+	-- 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 ;
 	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_fvs)
   }}
 
 ------------------------------------------------
@@ -702,43 +738,8 @@ rnTopSrcDecls group
   }}}
 
 ------------------------------------------------
-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,
@@ -806,9 +807,15 @@ tc_src_decls
 	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}
 
@@ -1091,26 +1098,19 @@ check_main ghci_mode 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) <- tcExpr_id 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)
     }}
diff --git a/ghc/compiler/typecheck/TcRnMonad.lhs b/ghc/compiler/typecheck/TcRnMonad.lhs
index 03e2186f0e..927f7e2992 100644
--- a/ghc/compiler/typecheck/TcRnMonad.lhs
+++ b/ghc/compiler/typecheck/TcRnMonad.lhs
@@ -246,6 +246,12 @@ updLclEnv upd = updEnv (\ env@(Env { env_lcl = lcl }) ->
 
 setLclEnv :: m -> TcRn m a -> TcRn n a
 setLclEnv lcl_env = updEnv (\ env -> env { env_lcl = lcl_env })
+
+getEnvs :: TcRn m (TcGblEnv, m)
+getEnvs = do { env <- getEnv; return (env_gbl env, env_lcl env) }
+
+setEnvs :: (TcGblEnv, m) -> TcRn m a -> TcRn m a
+setEnvs (gbl_env, lcl_env) = updEnv (\ env -> env { env_gbl = gbl_env, env_lcl = lcl_env })
 \end{code}
 
 Command-line flags
diff --git a/ghc/compiler/typecheck/TcRnTypes.lhs b/ghc/compiler/typecheck/TcRnTypes.lhs
index a42cbc8599..790911baa6 100644
--- a/ghc/compiler/typecheck/TcRnTypes.lhs
+++ b/ghc/compiler/typecheck/TcRnTypes.lhs
@@ -278,7 +278,7 @@ data TcGblEnv
 					--	tc_pcs, tc_hpt, *and* tc_insts
 		-- This field is mutable so that it can be updated inside a
 		-- Template Haskell splice, which might suck in some new
-		-- instance declarations.  This is a slightly differen strategy
+		-- instance declarations.  This is a slightly different strategy
 		-- than for the type envt, where we look up first in tcg_type_env
 		-- and then in the mutable EPS, because the InstEnv for this module
 		-- is constructed (in principle at least) only from the modules
@@ -292,7 +292,10 @@ data TcGblEnv
 	tcg_imports :: ImportAvails,		-- Information about what was imported 
 						--    from where, including things bound
 						--    in this module
-		-- The next fields are always fully zonked
+
+		-- The next fields accumulate the payload of the module
+		-- The binds, rules and foreign-decl fiels are collected
+		-- initially in un-zonked form and are finally zonked in tcRnSrcDecls
 	tcg_binds   :: MonoBinds Id,		-- Value bindings in this module
 	tcg_deprecs :: Deprecations,		-- ...Deprecations 
 	tcg_insts   :: [DFunId],		-- ...Instances