[project @ 2000-11-16 14:43:05 by simonpj]

Add stuff to support hscExpr

7 files changed, 139 insertions, 83 deletions

diff --git a/ghc/compiler/deSugar/Desugar.lhs b/ghc/compiler/deSugar/Desugar.lhs
index 49f8939bbd..fb217653b9 100644
--- a/ghc/compiler/deSugar/Desugar.lhs
+++ b/ghc/compiler/deSugar/Desugar.lhs
@@ -4,18 +4,18 @@
 \section[Desugar]{@deSugar@: the main function}
 
 \begin{code}
-module Desugar ( deSugar ) where
+module Desugar ( deSugar, deSugarExpr ) where
 
 #include "HsVersions.h"
 
 import CmdLineOpts	( DynFlags, DynFlag(..), dopt, opt_SccProfilingOn )
 import HsSyn		( MonoBinds, RuleDecl(..), RuleBndr(..), 
 			  HsExpr(..), HsBinds(..), MonoBinds(..) )
-import TcHsSyn		( TypecheckedRuleDecl )
+import TcHsSyn		( TypecheckedRuleDecl, TypecheckedHsExpr )
 import TcModule		( TcResults(..) )
 import Id		( Id )
 import CoreSyn
-import PprCore		( pprIdCoreRule )
+import PprCore		( pprIdCoreRule, pprCoreExpr )
 import Subst		( substExpr, mkSubst, mkInScopeSet )
 import DsMonad
 import DsExpr		( dsExpr )
@@ -25,6 +25,7 @@ import DsExpr		()	-- Forces DsExpr to be compiled; DsBinds only
 				-- depends on DsExpr.hi-boot.
 import Module		( Module )
 import Id		( Id )
+import Name		( lookupNameEnv )
 import VarEnv
 import VarSet
 import Bag		( isEmptyBag )
@@ -32,7 +33,7 @@ import CoreLint		( showPass, endPass )
 import ErrUtils		( doIfSet, pprBagOfWarnings )
 import Outputable
 import UniqSupply	( mkSplitUniqSupply )
-import HscTypes		( HomeSymbolTable )
+import HscTypes		( HomeSymbolTable, PersistentCompilerState(..), TyThing(..), lookupType,  )
 \end{code}
 
 %************************************************************************
@@ -46,14 +47,13 @@ start.
 
 \begin{code}
 deSugar :: DynFlags
+	-> PersistentCompilerState -> HomeSymbolTable
 	-> Module -> PrintUnqualified
-	-> HomeSymbolTable
         -> TcResults
 	-> IO ([CoreBind], [(Id,CoreRule)], SDoc, SDoc, [CoreBndr])
 
-deSugar dflags mod_name unqual hst
-        (TcResults {tc_env   = global_val_env,
-		    tc_pcs   = pcs,
+deSugar dflags pcs hst mod_name unqual
+        (TcResults {tc_env   = local_type_env,
 		    tc_binds = all_binds,
 		    tc_rules = rules,
 		    tc_fords = fo_decls})
@@ -61,7 +61,7 @@ deSugar dflags mod_name unqual hst
 	; us <- mkSplitUniqSupply 'd'
 
 	-- Do desugaring
-	; let (result, ds_warns) = initDs dflags us (hst,pcs,global_val_env) mod_name
+	; let (result, ds_warns) = initDs dflags us lookup mod_name
 					  (dsProgram mod_name all_binds rules fo_decls)    
 	      (ds_binds, ds_rules, _, _, _) = result
 
@@ -79,8 +79,47 @@ deSugar dflags mod_name unqual hst
         ; return result
 	}
 
--- deSugarExpr dflags unqual hst tc_expr
---  = do	{
+  where
+	-- The lookup function passed to initDs is used for well-known Ids, 
+	-- such as fold, build, cons etc, so the chances are
+	-- it'll be found in the package symbol table.  That's
+	-- why we don't merge all these tables
+    pte      = pcs_PTE pcs
+    lookup n = case lookupType hst pte n of {
+		 Just (AnId v) -> v ;
+		 other -> 
+	       case lookupNameEnv local_type_env n of
+		 Just (AnId v) -> v ;
+		 other	       -> pprPanic "Desugar: lookup:" (ppr n)
+               }
+
+deSugarExpr :: DynFlags
+	    -> PersistentCompilerState -> HomeSymbolTable
+	    -> Module -> PrintUnqualified
+ 	    -> TypecheckedHsExpr
+	    -> IO CoreExpr
+deSugarExpr dflags pcs hst mod_name unqual tc_expr
+  = do	{ showPass dflags "Desugar"
+	; us <- mkSplitUniqSupply 'd'
+
+	-- Do desugaring
+	; let (core_expr, ds_warns) = initDs dflags us lookup mod_name (dsExpr tc_expr)    
+
+	-- Display any warnings
+        ; doIfSet (not (isEmptyBag ds_warns))
+		  (printErrs unqual (pprBagOfWarnings ds_warns))
+
+	-- Dump output
+        ; let do_dump_ds = dopt Opt_D_dump_ds dflags
+	; doIfSet do_dump_ds (printDump (pprCoreExpr core_expr))
+
+        ; return core_expr
+	}
+  where
+    pte      = pcs_PTE pcs
+    lookup n = case lookupType hst pte n of
+		 Just (AnId v) -> v 
+		 other	       -> pprPanic "Desugar: lookup:" (ppr n)
 
 dsProgram mod_name all_binds rules fo_decls
   = dsMonoBinds auto_scc all_binds []	`thenDs` \ core_prs ->
diff --git a/ghc/compiler/deSugar/DsMonad.lhs b/ghc/compiler/deSugar/DsMonad.lhs
index bf73147772..83b21bd566 100644
--- a/ghc/compiler/deSugar/DsMonad.lhs
+++ b/ghc/compiler/deSugar/DsMonad.lhs
@@ -39,9 +39,6 @@ import UniqSupply	( initUs_, splitUniqSupply, uniqFromSupply, uniqsFromSupply,
 import Unique		( Unique )
 import Util		( zipWithEqual )
 import Name		( Name )
-import Name		( lookupNameEnv )
-import HscTypes		( HomeSymbolTable, PersistentCompilerState(..), 
-			  TyThing(..), TypeEnv, lookupType )
 import CmdLineOpts	( DynFlags )
 
 infixr 9 `thenDs`
@@ -71,26 +68,13 @@ type DsWarnings = Bag WarnMsg           -- The desugarer reports matches which a
 
 initDs  :: DynFlags
 	-> UniqSupply
-	-> (HomeSymbolTable, PersistentCompilerState, TypeEnv)
+	-> (Name -> Id)
 	-> Module   -- module name: for profiling
 	-> DsM a
 	-> (a, DsWarnings)
 
-initDs dflags init_us (hst,pcs,local_type_env) mod action
+initDs dflags init_us lookup mod action
   = action dflags init_us lookup noSrcLoc mod emptyBag
-  where
-	-- This lookup is used for well-known Ids, 
-	-- such as fold, build, cons etc, so the chances are
-	-- it'll be found in the package symbol table.  That's
-	-- why we don't merge all these tables
-    pte = pcs_PTE pcs
-    lookup n = case lookupType hst pte n of {
-		 Just (AnId v) -> v ;
-		 other -> 
-	       case lookupNameEnv local_type_env n of
-		 Just (AnId v) -> v ;
-		 other	       -> pprPanic "initDS: lookup:" (ppr n)
-               }
 
 thenDs :: DsM a -> (a -> DsM b) -> DsM b
 andDs  :: (a -> a -> a) -> DsM a -> DsM a -> DsM a
diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs
index 3ba9df3ea7..f7abbb087e 100644
--- a/ghc/compiler/main/HscMain.lhs
+++ b/ghc/compiler/main/HscMain.lhs
@@ -120,7 +120,6 @@ hscNoRecomp dflags location maybe_checked_iface hst hit pcs_ch
       let old_iface = case maybe_checked_iface of 
                          Just old_if -> old_if
                          Nothing -> panic "hscNoRecomp:old_iface"
-          this_mod = mi_module old_iface
       ;
       -- CLOSURE
       (pcs_cl, closure_errs, cl_hs_decls) 
@@ -130,14 +129,13 @@ hscNoRecomp dflags location maybe_checked_iface hst hit pcs_ch
       else do {
 
       -- TYPECHECK
-      maybe_tc_result <- typecheckModule dflags this_mod pcs_cl hst 
+      maybe_tc_result <- typecheckModule dflags pcs_cl hst 
 					 old_iface alwaysQualify cl_hs_decls;
       case maybe_tc_result of {
          Nothing -> return (HscFail pcs_cl);
-         Just tc_result -> do {
+         Just (pcs_tc, tc_result) -> do {
 
-      let pcs_tc      = tc_pcs tc_result
-          env_tc      = tc_env tc_result
+      let env_tc      = tc_env tc_result
           local_insts = tc_insts tc_result
           local_rules = tc_rules tc_result
       ;
@@ -175,28 +173,27 @@ hscRecomp dflags location maybe_checked_iface hst hit pcs_ch
       	     <- renameModule dflags hit hst pcs_ch this_mod rdr_module
       	; case maybe_rn_result of {
       	     Nothing -> return (HscFail pcs_rn);
-      	     Just (print_unqualified, is_exported, new_iface, rn_hs_decls) -> do {
+      	     Just (print_unqualified, (is_exported, new_iface, rn_hs_decls)) -> do {
     
  	    -------------------
  	    -- TYPECHECK
  	    -------------------
-	; maybe_tc_result <- typecheckModule dflags this_mod pcs_rn hst new_iface 
+	; maybe_tc_result <- typecheckModule dflags pcs_rn hst new_iface 
 					     print_unqualified rn_hs_decls
 	; case maybe_tc_result of {
       	     Nothing -> do { hPutStrLn stderr "Typecheck failed" 
  			   ; return (HscFail pcs_rn) } ;
-      	     Just tc_result -> do {
+      	     Just (pcs_tc, tc_result) -> do {
     
-	; let pcs_tc        = tc_pcs tc_result
-      	      env_tc        = tc_env tc_result
+	; let env_tc        = tc_env tc_result
       	      local_insts   = tc_insts tc_result
 
  	    -------------------
  	    -- DESUGAR, SIMPLIFY, TIDY-CORE
  	    -------------------
       	  -- We grab the the unfoldings at this point.
-	; simpl_result <- dsThenSimplThenTidy dflags (pcs_rules pcs_tc) this_mod 
- 					      print_unqualified is_exported tc_result hst
+	; simpl_result <- dsThenSimplThenTidy dflags pcs_tc hst this_mod 
+ 					      print_unqualified is_exported tc_result
 	; let (tidy_binds, orphan_rules, foreign_stuff) = simpl_result
       	    
  	    -------------------
@@ -316,16 +313,16 @@ restOfCodeGeneration dflags toInterp this_mod imported_module_names cost_centre_
                        (ppr nm)
 
 
-dsThenSimplThenTidy dflags rule_base this_mod print_unqual is_exported tc_result hst
+dsThenSimplThenTidy dflags pcs hst this_mod print_unqual is_exported tc_result
  = do --------------------------  Desugaring ----------------
       -- _scc_     "DeSugar"
       (desugared, rules, h_code, c_code, fe_binders) 
-         <- deSugar dflags this_mod print_unqual hst tc_result
+         <- deSugar dflags pcs hst this_mod print_unqual tc_result
 
       --------------------------  Main Core-language transformations ----------------
       -- _scc_     "Core2Core"
       (simplified, orphan_rules) 
-         <- core2core dflags rule_base hst is_exported desugared rules
+         <- core2core dflags pcs hst is_exported desugared rules
 
       -- Do the final tidy-up
       (tidy_binds, tidy_orphan_rules) 
@@ -375,6 +372,7 @@ hscExpr
 
 hscExpr dflags hst hit pcs this_module expr
   = do	{ 	-- Parse it
+	  let unqual = unQualInScope 
 	; maybe_parsed <- myParseExpr dflags expr
 	; case maybe_parsed of {
       	     Nothing -> return (HscFail pcs_ch);
@@ -384,13 +382,22 @@ hscExpr dflags hst hit pcs this_module expr
 	  (new_pcs, maybe_renamed_expr) <- renameExpr dflags hit hst pcs this_module parsed_expr ;
 	; case maybe_renamed_expr of {
 		Nothing -> FAIL
-		Just renamed_expr -> 
+		Just (print_unqual, rn_expr) -> 
 
 		-- Typecheck it
-	  maybe_tc_expr <- typecheckExpr dflags pcs hst unqual renamed_expr 
+	  maybe_tc_expr <- typecheckExpr dflags pcs hst print_unqual rn_expr 
 	; case maybe_tc_expr of
 		Nothing -> FAIL
-		Just typechecked_expr ->
+		Just tc_expr ->
+
+		-- Desugar it
+	; ds_expr <- deSugarExpr dflags pcs hst this_module print_unqual tc_expr
+	
+		-- Simplify it
+	; simpl_expr <- simplifyExpr dflags pcs hst ds_expr
+
+	; return I'M NOT SURE
+	}
 
 	
 
diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs
index 9ff18cbceb..3a6402a1ce 100644
--- a/ghc/compiler/main/MkIface.lhs
+++ b/ghc/compiler/main/MkIface.lhs
@@ -103,7 +103,7 @@ mkModDetails type_env dfun_ids tidy_binds stg_ids orphan_rules
 	--	a) the orphan rules
 	--	b) rules embedded in the top-level Ids
     rule_dcls | opt_OmitInterfacePragmas = []
-	      | otherwise		  = getRules orphan_rules tidy_binds (mkVarSet final_ids)
+	      | otherwise		 = getRules orphan_rules tidy_binds (mkVarSet final_ids)
 
     orphan_rule_ids = unionVarSets [ ruleSomeFreeVars interestingId rule 
 				   | (_, rule) <- orphan_rules]
diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs
index 7677e22081..841d7fc976 100644
--- a/ghc/compiler/rename/Rename.lhs
+++ b/ghc/compiler/rename/Rename.lhs
@@ -87,15 +87,12 @@ renameModule :: DynFlags
 	     -> HomeIfaceTable -> HomeSymbolTable
 	     -> PersistentCompilerState 
 	     -> Module -> RdrNameHsModule 
-	     -> IO (PersistentCompilerState, Maybe (PrintUnqualified, IsExported, ModIface, [RenamedHsDecl]))
+	     -> IO (PersistentCompilerState, Maybe (PrintUnqualified, (IsExported, ModIface, [RenamedHsDecl])))
 	-- Nothing => some error occurred in the renamer
 
 renameModule dflags hit hst pcs this_module rdr_module
-  = renameSource dflags hit hst pcs this_module get_unqual $
+  = renameSource dflags hit hst pcs this_module $
     rename this_module rdr_module
-  where
-    get_unqual (Just (unqual, _, _, _)) = unqual
-    get_unqual Nothing			= alwaysQualify
 \end{code}
 
 
@@ -104,16 +101,16 @@ renameExpr :: DynFlags
 	   -> HomeIfaceTable -> HomeSymbolTable
 	   -> PersistentCompilerState 
 	   -> Module -> RdrNameHsExpr
-	   -> IO (PersistentCompilerState, Maybe RenamedHsExpr)
+	   -> IO (PersistentCompilerState, Maybe (PrintUnqualified, RenamedHsExpr))
 
 renameExpr dflags hit hst pcs this_module expr
   | Just iface <- lookupModuleEnv hit this_module
   = do	{ let rdr_env      = mi_globals iface
-	; let get_unqual _ = unQualInScope rdr_env
+	; let print_unqual = unQualInScope rdr_env
 	  
-	; renameSource dflags hit hst pcs this_module get_unqual $
+	; renameSource dflags hit hst pcs this_module $
 	  initRnMS rdr_env emptyLocalFixityEnv SourceMode $
-	  (rnExpr expr `thenRn` \ (e,_) -> returnRn (Just e))
+	  (rnExpr expr `thenRn` \ (e,_) -> returnRn (Just (print_unqual, e)))
 	}
 
   | otherwise
@@ -134,19 +131,22 @@ renameSource :: DynFlags
 	     -> HomeIfaceTable -> HomeSymbolTable
 	     -> PersistentCompilerState 
 	     -> Module 
-	     -> (Maybe r -> PrintUnqualified)
-	     -> RnMG (Maybe r)
-	     -> IO (PersistentCompilerState, Maybe r)
+	     -> RnMG (Maybe (PrintUnqualified, r))
+	     -> IO (PersistentCompilerState, Maybe (PrintUnqualified, r))
 	-- Nothing => some error occurred in the renamer
 
-renameSource dflags hit hst old_pcs this_module get_unqual thing_inside
+renameSource dflags hit hst old_pcs this_module thing_inside
   = do	{ showPass dflags "Renamer"
 
 		-- Initialise the renamer monad
 	; (new_pcs, msgs, maybe_rn_stuff) <- initRn dflags hit hst old_pcs this_module thing_inside
 
 	 	-- Print errors from renaming
-	;  printErrorsAndWarnings (get_unqual maybe_rn_stuff) msgs ;
+	;  let print_unqual = case maybe_rn_stuff of
+				Just (unqual, _) -> unqual
+				Nothing		 -> alwaysQualify
+
+	;  printErrorsAndWarnings print_unqual msgs ;
 
 		-- Return results.  No harm in updating the PCS
 	; if errorsFound msgs then
@@ -157,7 +157,7 @@ renameSource dflags hit hst old_pcs this_module get_unqual thing_inside
 \end{code}
 
 \begin{code}
-rename :: Module -> RdrNameHsModule -> RnMG (Maybe (PrintUnqualified, IsExported, ModIface, [RenamedHsDecl]))
+rename :: Module -> RdrNameHsModule -> RnMG (Maybe (PrintUnqualified, (IsExported, ModIface, [RenamedHsDecl])))
 rename this_module contents@(HsModule _ _ exports imports local_decls mod_deprec loc)
   = pushSrcLocRn loc		$
 
@@ -249,7 +249,7 @@ rename this_module contents@(HsModule _ _ exports imports local_decls mod_deprec
 		      imports global_avail_env
 		      source_fvs export_avails rn_imp_decls 	`thenRn_`
 
-    returnRn (Just (print_unqualified, is_exported, mod_iface, final_decls))
+    returnRn (Just (print_unqualified, (is_exported, mod_iface, final_decls)))
   where
     mod_name = moduleName this_module
 \end{code}
diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs
index b744da9134..3fcfad5cff 100644
--- a/ghc/compiler/simplCore/SimplCore.lhs
+++ b/ghc/compiler/simplCore/SimplCore.lhs
@@ -4,7 +4,7 @@
 \section[SimplCore]{Driver for simplifying @Core@ programs}
 
 \begin{code}
-module SimplCore ( core2core ) where
+module SimplCore ( core2core, simplifyExpr ) where
 
 #include "HsVersions.h"
 
@@ -15,13 +15,15 @@ import CmdLineOpts	( CoreToDo(..), SimplifierSwitch(..),
 import CoreLint		( showPass, endPass )
 import CoreSyn
 import CoreFVs		( ruleRhsFreeVars )
-import HscTypes		( PackageRuleBase, HomeSymbolTable, IsExported, ModDetails(..) )
+import HscTypes		( PersistentCompilerState(..),
+			  PackageRuleBase, HomeSymbolTable, IsExported, ModDetails(..)
+			)
 import CSE		( cseProgram )
 import Rules		( RuleBase, emptyRuleBase, ruleBaseFVs, ruleBaseIds, 
 			  extendRuleBaseList, addRuleBaseFVs )
 import Module		( moduleEnvElts )
 import CoreUnfold
-import PprCore		( pprCoreBindings, pprIdCoreRule )
+import PprCore		( pprCoreBindings, pprIdCoreRule, pprCoreExpr )
 import OccurAnal	( occurAnalyseBinds )
 import CoreUtils	( etaReduceExpr, coreBindsSize )
 import Simplify		( simplTopBinds, simplExpr )
@@ -56,16 +58,18 @@ import List             ( partition )
 
 \begin{code}
 core2core :: DynFlags		-- includes spec of what core-to-core passes to do
-	  -> PackageRuleBase	-- Rule-base accumulated from imported packages
+	  -> PersistentCompilerState
 	  -> HomeSymbolTable
 	  -> IsExported
 	  -> [CoreBind]		-- Binds in
 	  -> [IdCoreRule]	-- Rules in
 	  -> IO ([CoreBind], [IdCoreRule])  -- binds, local orphan rules out
 
-core2core dflags pkg_rule_base hst is_exported binds rules
+core2core dflags pcs hst is_exported binds rules
   = do
-        let core_todos = dopt_CoreToDo dflags
+        let core_todos    = dopt_CoreToDo dflags
+	let pkg_rule_base = pcs_rules pcs		-- Rule-base accumulated from imported packages
+
 	us <-  mkSplitUniqSupply 's'
 	let (cp_us, ru_us) = splitUniqSupply us
 
@@ -90,6 +94,28 @@ core2core dflags pkg_rule_base hst is_exported binds rules
 	return (processed_binds, orphan_rules)
 
 
+simplifyExpr :: DynFlags		-- includes spec of what core-to-core passes to do
+	     -> PersistentCompilerState
+	     -> HomeSymbolTable
+	     -> CoreExpr
+	     -> IO CoreExpr
+simplifyExpr dflags pcs hst expr
+  = do	{
+	; us <-  mkSplitUniqSupply 's'
+
+	; let (expr', counts) = initSmpl dflags sw_chkr us emptyVarSet black_list_all 	
+		                         (simplExpr expr)
+
+	; dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplfied expression"
+			(pprCoreExpr expr')
+
+	; return expr'
+	}
+  where
+    sw_chkr any	     = SwBool False	-- A bit bogus
+    black_list_all v = True		-- Black list everything
+
+
 doCorePasses :: DynFlags
              -> RuleBase        -- the main rule base
 	     -> SimplCount      -- simplifier stats
diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs
index ea69f29062..256e5bbad0 100644
--- a/ghc/compiler/typecheck/TcModule.lhs
+++ b/ghc/compiler/typecheck/TcModule.lhs
@@ -65,9 +65,6 @@ Outside-world interface:
 -- Convenient type synonyms first:
 data TcResults
   = TcResults {
-	tc_pcs	   :: PersistentCompilerState,	-- Augmented with imported information,
-						-- (but not stuff from this module)
-
 	-- All these fields have info *just for this module*
 	tc_env	   :: TypeEnv,			-- The top level TypeEnv
 	tc_insts   :: [DFunId],			-- Instances
@@ -79,20 +76,23 @@ data TcResults
 ---------------
 typecheckModule
 	:: DynFlags
-	-> Module
 	-> PersistentCompilerState
 	-> HomeSymbolTable
 	-> ModIface		-- Iface for this module
 	-> PrintUnqualified	-- For error printing
 	-> [RenamedHsDecl]
-	-> IO (Maybe TcResults)
+	-> IO (Maybe (PersistentCompilerState, TcResults))
+			-- The new PCS is Augmented with imported information,
+						-- (but not stuff from this module)
+
 
-typecheckModule dflags this_mod pcs hst mod_iface unqual decls
+typecheckModule dflags pcs hst mod_iface unqual decls
   = do	{ maybe_tc_result <- typecheck dflags pcs hst unqual $
-			    tcModule pcs hst get_fixity this_mod decls
+			     tcModule pcs hst get_fixity this_mod decls
 	; printTcDump dflags maybe_tc_result
 	; return maybe_tc_result }
   where
+    this_mod   = mi_module   mod_iface
     fixity_env = mi_fixities mod_iface
 
     get_fixity :: Name -> Maybe Fixity
@@ -121,8 +121,8 @@ typecheck :: DynFlags
 	  -> TcM r
 	  -> IO (Maybe r)
 
-typecheck dflags pcs hst unqual thing_inside
-  = do	{ showPass dflags "Typechecker";
+typecheck dflags pcs hst unqual thing_inside 
+ = do	{ showPass dflags "Typechecker";
 	; env <- initTcEnv hst (pcs_PTE pcs)
 
 	; (maybe_tc_result, (warns,errs)) <- initTc dflags env thing_inside
@@ -143,7 +143,7 @@ tcModule :: PersistentCompilerState
 	 -> (Name -> Maybe Fixity)
 	 -> Module
 	 -> [RenamedHsDecl]
-	 -> TcM TcResults
+	 -> TcM (PersistentCompilerState, TcResults)
 
 tcModule pcs hst get_fixity this_mod decls
   = 		 -- Type-check the type and class decls
@@ -283,8 +283,8 @@ tcModule pcs hst get_fixity this_mod decls
 		    }
     in  
 --  traceTc (text "Tc10")		`thenNF_Tc_`
-    returnTc (TcResults { tc_pcs     = final_pcs,
-			  tc_env     = local_type_env,
+    returnTc (final_pcs,
+	      TcResults { tc_env     = local_type_env,
 			  tc_binds   = all_binds', 
 			  tc_insts   = map iDFunId local_inst_info,
 			  tc_fords   = foi_decls ++ foe_decls',
@@ -305,7 +305,7 @@ get_binds decls = foldr ThenBinds EmptyBinds [binds | ValD binds <- decls]
 
 \begin{code}
 printTcDump dflags Nothing = return ()
-printTcDump dflags (Just results)
+printTcDump dflags (Just (_, results))
   = do dumpIfSet_dyn dflags Opt_D_dump_types 
                      "Type signatures" (dump_sigs results)
        dumpIfSet_dyn dflags Opt_D_dump_tc