X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcModule.lhs;h=1f2b513c2c725d47a5f309624b73511bea130606;hb=2f51f1402e6869c0f049ffbe7b019bf6ab80558f;hp=4daf3b4aa34c5ac54fea437b358bc591cd158b0a;hpb=0596517a9b4b2b32e5d375a986351102ac4540fc;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs
index 4daf3b4..1f2b513 100644
--- a/ghc/compiler/typecheck/TcModule.lhs
+++ b/ghc/compiler/typecheck/TcModule.lhs
@@ -15,7 +15,8 @@ import Ubiq
 import HsSyn		( HsModule(..), HsBinds(..), Bind, HsExpr,
 			  TyDecl, SpecDataSig, ClassDecl, InstDecl,
 			  SpecInstSig, DefaultDecl, Sig, Fake, InPat,
- 			  FixityDecl, IE, ImportedInterface )
+ 			  FixityDecl, IE, ImportDecl
+			)
 import RnHsSyn		( RenamedHsModule(..), RenamedFixityDecl(..) )
 import TcHsSyn		( TypecheckedHsBinds(..), TypecheckedHsExpr(..),
 			  TcIdOcc(..), zonkBinds, zonkInst, zonkId )
@@ -38,13 +39,12 @@ import Bag		( listToBag )
 import Class		( GenClass )
 import Id		( GenId, isDataCon, isMethodSelId, idType )
 import Maybes		( catMaybes )
-import Name		( Name(..) )
-import Outputable	( isExported )
+import Name		( isExported, isLocallyDefined )
 import PrelInfo		( unitTy, mkPrimIoTy )
 import Pretty
 import RnUtils		( GlobalNameMappers(..), GlobalNameMapper(..) )
 import TyCon		( TyCon )
-import Type		( applyTyCon )
+import Type		( mkSynTy )
 import Unify		( unifyTauTy )
 import UniqFM		( lookupUFM_Directly, lookupWithDefaultUFM_Directly,
 		          filterUFM, eltsUFM )
@@ -61,7 +61,8 @@ tycon_specs = emptyFM
 \begin{code}
 tcModule :: GlobalNameMappers		-- final renamer info for derivings
 	 -> RenamedHsModule		-- input
-	 -> TcM s ((TypecheckedHsBinds,	-- binds from class decls; does NOT
+	 -> TcM s ((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
@@ -81,7 +82,7 @@ tcModule :: GlobalNameMappers		-- final renamer info for derivings
 		   PprStyle -> Pretty)	-- -ddump-deriving info
 
 tcModule renamer_name_funs
-	(HsModule mod_name exports imports fixities
+	(HsModule mod_name verion exports imports fixities
 		  ty_decls specdata_sigs cls_decls inst_decls specinst_sigs
 		  default_decls val_decls sigs src_loc)
 
@@ -94,30 +95,30 @@ tcModule renamer_name_funs
 	-- pragmas, which is done lazily [ie failure just drops the pragma
 	-- without having any global-failure effect].
 
-    fixTc (\ ~(_, _, _, _, _, sig_ids) ->
+    fixTc (\ ~(_, _, _, _, _, _, sig_ids) ->
 	tcExtendGlobalValEnv sig_ids (
 
 	-- The knot for instance information.  This isn't used at all
 	-- till we type-check value declarations
-	fixTc ( \ ~(rec_inst_mapper, _, _, _, _) ->
+	fixTc ( \ ~(rec_inst_mapper, _, _, _, _, _) ->
 
 	     -- Type-check the type and class decls
-	    trace "tcTyAndClassDecls:"	$
+	    --trace "tcTyAndClassDecls:"	$
 	    tcTyAndClassDecls1 rec_inst_mapper ty_decls_bag cls_decls_bag
-					`thenTc` \ env ->
+					`thenTc` \ (env, record_binds) ->
 
 		-- Typecheck the instance decls, includes deriving
 	    tcSetEnv env (
-	    trace "tcInstDecls:"	$
+	    --trace "tcInstDecls:"	$
 	    tcInstDecls1 inst_decls_bag specinst_sigs
 			 mod_name renamer_name_funs fixities 
 	    )				`thenTc` \ (inst_info, deriv_binds, ddump_deriv) ->
 
 	    buildInstanceEnvs inst_info	`thenTc` \ inst_mapper ->
 
-	    returnTc (inst_mapper, env, inst_info, deriv_binds, ddump_deriv)
+	    returnTc (inst_mapper, env, record_binds, inst_info, deriv_binds, ddump_deriv)
 
-	) `thenTc` \ (_, env, inst_info, deriv_binds, ddump_deriv) ->
+	) `thenTc` \ (_, env, record_binds, inst_info, deriv_binds, ddump_deriv) ->
 	tcSetEnv env (
 
 	    -- Default declarations
@@ -132,16 +133,16 @@ tcModule renamer_name_funs
 	    --   we silently discard the pragma
 	tcInterfaceSigs sigs		`thenTc` \ sig_ids ->
 
-	returnTc (env, inst_info, deriv_binds, ddump_deriv, defaulting_tys, sig_ids)
+	returnTc (env, inst_info, record_binds, deriv_binds, ddump_deriv, defaulting_tys, sig_ids)
 
-    )))) `thenTc` \ (env, inst_info, deriv_binds, ddump_deriv, defaulting_tys, _) ->
+    )))) `thenTc` \ (env, inst_info, record_binds, deriv_binds, ddump_deriv, defaulting_tys, _) ->
 
     tcSetEnv env (				-- to the end...
     tcSetDefaultTys defaulting_tys (		-- ditto
 
 	-- Value declarations next.
 	-- We also typecheck any extra binds that came out of the "deriving" process
-    trace "tcBinds:"			$
+    --trace "tcBinds:"			$
     tcBindsAndThen
 	(\ binds1 (binds2, thing) -> (binds1 `ThenBinds` binds2, thing))
 	(val_decls `ThenBinds` deriv_binds)
@@ -181,6 +182,7 @@ tcModule renamer_name_funs
 	-- simplification step may have instantiated some
 	-- ambiguous types.  So, sadly, we need to back-substitute
 	-- over the whole bunch of bindings.
+    zonkBinds record_binds	 	`thenNF_Tc` \ record_binds' ->
     zonkBinds val_binds		 	`thenNF_Tc` \ val_binds' ->
     zonkBinds inst_binds	 	`thenNF_Tc` \ inst_binds' ->
     zonkBinds cls_binds	 		`thenNF_Tc` \ cls_binds' ->
@@ -189,7 +191,7 @@ tcModule renamer_name_funs
 
 	-- FINISHED AT LAST
     returnTc (
-	(cls_binds', inst_binds', val_binds', const_insts'),
+	(record_binds', cls_binds', inst_binds', val_binds', const_insts'),
 
 	     -- the next collection is just for mkInterface
 	(fixities, exported_ids', tycons, classes, inst_info),
@@ -231,7 +233,7 @@ checkTopLevelIds mod final_env
 	
 	case (maybe_main, maybe_prim) of
 	  (Just main, Nothing) -> tcAddErrCtxt mainCtxt $
-		                  unifyTauTy (applyTyCon io_tc [unitTy])
+		                  unifyTauTy (mkSynTy io_tc [unitTy])
 					     (idType main)
 
 	  (Nothing, Just prim) -> tcAddErrCtxt primCtxt $
@@ -252,7 +254,5 @@ mainBothIdErr sty
   = ppStr "module Main contains definitions for both main and mainPrimIO"
 
 mainNoneIdErr sty
-  = panic "ToDo: sort out mainIdKey"
- -- ppStr "module Main does not contain a definition for main (or mainPrimIO)"
-
+  = ppStr "module Main does not contain a definition for main (or mainPrimIO)"
 \end{code}