[project @ 1999-02-04 13:45:24 by simonpj]

a) Fix black hole bug when doing -dshow-rn-trace
   (Involved reorganising where fixity exports are dealt with
    in RnNames/RnIfaces.)

b) Arrange to apply Lint to imported unfoldings when -dcore-lint

c) Add -fwarn-type-defaults to report use of the defaulting rules for types

d) Make it so that f (error "help) --> error "help", if f is strict
   (Changes in Simplify.lhs.)

ghc/compiler/basicTypes/Var.lhs

@@ -150,12 +150,24 @@ setTyVarName   = setVarName
 
 \begin{code}
 mkTyVar :: Name -> Kind -> TyVar
-mkTyVar name kind = Var { varName = name, realUnique = getKey (nameUnique name),
-			  varType = kind, varDetails = TyVar }
+mkTyVar name kind = Var { varName    = name
+			, realUnique = getKey (nameUnique name)
+			, varType    = kind
+			, varDetails = TyVar
+#ifdef DEBUG
+			, varInfo = pprPanic "mkTyVar" (ppr name)
+#endif
+			}
 
 mkSysTyVar :: Unique -> Kind -> TyVar
-mkSysTyVar uniq kind = Var { varName = name, realUnique = getKey uniq,
-			     varType = kind, varDetails = TyVar }
+mkSysTyVar uniq kind = Var { varName    = name
+			   , realUnique = getKey uniq
+			   , varType    = kind
+			   , varDetails = TyVar
+#ifdef DEBUG
+			   , varInfo = pprPanic "mkSysTyVar" (ppr name)
+#endif
+			   }
 		     where
 		       name = mkSysLocalName uniq SLIT("t")
 

ghc/compiler/coreSyn/CoreLint.lhs

@@ -21,7 +21,7 @@ import CoreUtils	( idFreeVars )
 import Bag
 import Const		( Con(..), DataCon, conType, conOkForApp, conOkForAlt )
 import Id		( isConstantId, idMustBeINLINEd )
-import Var		( IdOrTyVar, Id, TyVar, idType, tyVarKind, isTyVar )
+import Var		( IdOrTyVar, Id, TyVar, idType, tyVarKind, isTyVar, isId )
 import VarSet
 import VarEnv		( mkVarEnv )
 import Name		( isLocallyDefined, getSrcLoc )
@@ -147,11 +147,20 @@ We use this to check all unfoldings that come in from interfaces
 (it is very painful to catch errors otherwise):
 
 \begin{code}
-lintUnfolding :: SrcLoc -> CoreExpr -> Maybe CoreExpr
+lintUnfolding :: SrcLoc
+	      -> [IdOrTyVar]		-- Treat these as in scope
+	      -> CoreExpr
+	      -> Maybe CoreExpr
 
-lintUnfolding locn expr
+lintUnfolding locn vars expr
+  | not opt_DoCoreLinting
+  = Just expr
+
+  | otherwise
   = case
-      initL (addLoc (ImportedUnfolding locn) (lintCoreExpr expr))
+      initL (addLoc (ImportedUnfolding locn) $
+	     addInScopeVars vars	     $
+	     lintCoreExpr expr)
     of
       Nothing  -> Just expr
       Just msg ->
@@ -560,13 +569,13 @@ checkBndrIdInScope binder id
 	   ppr binder
 
 checkInScope :: SDoc -> IdOrTyVar -> LintM ()
-checkInScope loc_msg id loc scope errs
-  |  isLocallyDefined id 
-  && not (id `elemVarSet` scope)
-  && not (idMustBeINLINEd id)	-- Constructors and dict selectors 
-				-- don't have bindings, 
-				-- just MustInline prags
-  = (Nothing, addErr errs (hsep [ppr id, loc_msg]) loc)
+checkInScope loc_msg var loc scope errs
+  |  isLocallyDefined var 
+  && not (var `elemVarSet` scope)
+  && not (isId var && idMustBeINLINEd var)	-- Constructors and dict selectors 
+						-- don't have bindings, 
+						-- just MustInline prags
+  = (Nothing, addErr errs (hsep [ppr var, loc_msg]) loc)
   | otherwise
   = (Nothing,errs)
 

ghc/compiler/main/CmdLineOpts.lhs

@@ -91,6 +91,7 @@ module CmdLineOpts (
 	opt_UnfoldingKeenessFactor,
 
 	opt_Verbose,
+
 	opt_WarnNameShadowing,
 	opt_WarnUnusedMatches,
 	opt_WarnUnusedBinds,
@@ -98,6 +99,7 @@ module CmdLineOpts (
 	opt_WarnIncompletePatterns,
 	opt_WarnOverlappingPatterns,
 	opt_WarnSimplePatterns,
+	opt_WarnTypeDefaults,
 	opt_WarnMissingMethods,
 	opt_WarnDuplicateExports,
 	opt_WarnHiShadows,
@@ -352,6 +354,7 @@ opt_WarnHiShadows		= lookUp  SLIT("-fwarn-hi-shadowing")
 opt_WarnIncompletePatterns	= lookUp  SLIT("-fwarn-incomplete-patterns")
 opt_WarnOverlappingPatterns	= lookUp  SLIT("-fwarn-overlapping-patterns")
 opt_WarnSimplePatterns	     	= lookUp  SLIT("-fwarn-simple-patterns")
+opt_WarnTypeDefaults		= lookUp  SLIT("-fwarn-type-defaults")
 opt_WarnUnusedMatches		= lookUp  SLIT("-fwarn-unused-matches")
 opt_WarnUnusedBinds		= lookUp  SLIT("-fwarn-unused-binds")
 opt_WarnUnusedImports		= lookUp  SLIT("-fwarn-unused-imports")

ghc/compiler/rename/RnIfaces.lhs

@@ -11,7 +11,7 @@ module RnIfaces (
 	importDecl, recordSlurp,
 	getImportVersions, getSlurpedNames, getRnStats, getImportedFixities,
 
-	checkUpToDate, loadHomeInterface,
+	checkUpToDate,
 
 	getDeclBinders,
 	mkSearchPath
@@ -72,7 +72,6 @@ import Outputable
 
 import IO	( isDoesNotExistError )
 import List	( nub )
-
 \end{code}
 
 
@@ -784,10 +783,26 @@ getSpecialInstModules
   = getIfacesRn						`thenRn` \ ifaces ->
     returnRn (iInstMods ifaces)
 
-getImportedFixities :: RnMG FixityEnv
-getImportedFixities
-  = getIfacesRn						`thenRn` \ ifaces ->
+getImportedFixities :: GlobalRdrEnv -> RnMG FixityEnv
+	-- Get all imported fixities
+	-- We first make sure that all the home modules
+	-- of all in-scope variables are loaded.
+getImportedFixities gbl_env
+  = let
+	home_modules = [ nameModule name | names <- rdrEnvElts gbl_env,
+					   name <- names,
+					   not (isLocallyDefined name)
+		       ]
+    in
+    mapRn load (nub home_modules)	`thenRn_`
+
+	-- Now we can snaffle the fixity env
+    getIfacesRn						`thenRn` \ ifaces ->
     returnRn (iFixes ifaces)
+  where
+    load mod = loadInterface doc_str mod
+	     where
+	       doc_str = ptext SLIT("Need fixities from") <+> ppr mod
 \end{code}
 
 

ghc/compiler/rename/RnNames.lhs

@@ -24,7 +24,7 @@ import RdrHsSyn	( RdrNameIE, RdrNameImportDecl,
 		  RdrNameHsModule, RdrNameHsDecl
 		)
 import RnIfaces	( getInterfaceExports, getDeclBinders, getImportedFixities, 
-		  recordSlurp, checkUpToDate, loadHomeInterface
+		  recordSlurp, checkUpToDate
 		)
 import RnEnv
 import RnMonad
@@ -42,7 +42,6 @@ import NameSet	( elemNameSet, emptyNameSet )
 import Outputable
 import Unique	( getUnique )
 import Util	( removeDups, equivClassesByUniq, sortLt )
-import List	( nubBy )
 \end{code}
 
 
@@ -65,12 +64,15 @@ getGlobalNames :: RdrNameHsModule
 getGlobalNames (HsModule this_mod _ exports imports decls mod_loc)
   = 	-- These two fix-loops are to get the right
 	-- provenance information into a Name
-    fixRn (\ ~(rec_exp_fn, _) ->
+    fixRn (\ ~(rec_exported_avails, _) ->
 
       fixRn (\ ~(rec_rn_env, _) ->
 	let
 	   rec_unqual_fn :: Name -> Bool	-- Is this chap in scope unqualified?
 	   rec_unqual_fn = unQualInScope rec_rn_env
+
+	   rec_exp_fn :: Name -> ExportFlag
+	   rec_exp_fn = mk_export_fn (availsToNameSet rec_exported_avails)
 	in
 	setOmitQualFn rec_unqual_fn		$
 	setModuleRn this_mod			$
@@ -91,11 +93,11 @@ getGlobalNames (HsModule this_mod _ exports imports decls mod_loc)
 	    imp_gbl_env = foldr plusGlobalRdrEnv emptyRdrEnv imp_gbl_envs
 	    gbl_env     = imp_gbl_env `plusGlobalRdrEnv` local_gbl_env
 
-	    export_avails :: ExportAvails
-	    export_avails = foldr plusExportAvails local_mod_avails imp_avails_s
+	    all_avails :: ExportAvails
+	    all_avails = foldr plusExportAvails local_mod_avails imp_avails_s
 	in
-	returnRn (gbl_env, export_avails)
-      )							`thenRn` \ (gbl_env, export_avails) ->
+	returnRn (gbl_env, all_avails)
+      )							`thenRn` \ (gbl_env, all_avails) ->
 
 	-- TRY FOR EARLY EXIT
 	-- We can't go for an early exit before this because we have to check
@@ -117,23 +119,42 @@ getGlobalNames (HsModule this_mod _ exports imports decls mod_loc)
 	returnRn (junk_exp_fn, Nothing)
       else
  
-	-- FIXITIES
-      fixitiesFromLocalDecls gbl_env decls		`thenRn` \ local_fixity_env ->
-      getImportedFixities				`thenRn` \ imp_fixity_env ->
-      let
-	fixity_env = imp_fixity_env `plusNameEnv` local_fixity_env
-	rn_env     = RnEnv gbl_env fixity_env
-	(_, global_avail_env) = export_avails
-      in
-      traceRn (text "fixity env" <+> vcat (map ppr (nameEnvElts fixity_env)))	`thenRn_`
-
 	-- PROCESS EXPORT LISTS
-      exportsFromAvail this_mod exports export_avails rn_env	`thenRn` \ (export_fn, export_env) ->
+      exportsFromAvail this_mod exports all_avails gbl_env 	`thenRn` \ exported_avails ->
 
 	-- DONE
-      returnRn (export_fn, Just (export_env, rn_env, global_avail_env))
-    )							`thenRn` \ (_, result) ->
-    returnRn result
+      returnRn (exported_avails, Just (all_avails, gbl_env))
+    )		`thenRn` \ (exported_avails, maybe_stuff) ->
+
+    case maybe_stuff of {
+	Nothing -> returnRn Nothing ;
+	Just (all_avails, gbl_env) ->
+
+
+	-- DEAL WITH FIXITIES
+   fixitiesFromLocalDecls gbl_env decls		`thenRn` \ local_fixity_env ->
+   getImportedFixities gbl_env			`thenRn` \ imp_fixity_env ->
+   let
+	-- Export only those fixities that are for names that are
+	--	(a) defined in this module
+	--	(b) exported
+	exported_fixities :: [(Name,Fixity)]
+	exported_fixities = [(name,fixity) | FixitySig name fixity _ <- nameEnvElts local_fixity_env,
+					     isLocallyDefined name
+			    ]
+
+	fixity_env = imp_fixity_env `plusNameEnv` local_fixity_env
+   in
+   traceRn (text "fixity env" <+> vcat (map ppr (nameEnvElts fixity_env)))	`thenRn_`
+
+	--- TIDY UP 
+   let
+	export_env	      = ExportEnv exported_avails exported_fixities
+	rn_env                = RnEnv gbl_env fixity_env
+	(_, global_avail_env) = all_avails
+   in
+   returnRn (Just (export_env, rn_env, global_avail_env))
+   }
   where
     junk_exp_fn = error "RnNames:export_fn"
 
@@ -198,26 +219,6 @@ importsFromImportDecl (ImportDecl imp_mod qual_only as_mod import_spec iloc)
 
     filterImports imp_mod import_spec avails	`thenRn` \ (filtered_avails, hides, explicits) ->
 
-	-- Load all the home modules for the things being
-	-- bought into scope.  This makes sure their fixities
-	-- are loaded before we grab the FixityEnv from Ifaces
-    let
-	home_modules = [name | avail <- filtered_avails,
-				-- Doesn't take account of hiding, but that doesn't matter
-		
-			       let name = availName avail,
-			       not (isLocallyDefined name || nameModule name == imp_mod)
-				-- Don't try to load the module being compiled
-				--	(this can happen in mutual-recursion situations)
-				-- or from the module being imported (it's already loaded)
-			]
-				
-	same_module n1 n2 = nameModule n1 == nameModule n2
-	load n		  = loadHomeInterface (doc_str n) n
-	doc_str n	  = ptext SLIT("Need fixities from") <+> ppr (nameModule n) <+> parens (ppr n)
-    in
-    mapRn load (nubBy same_module home_modules)			`thenRn_`
-    
 	-- We 'improve' the provenance by setting
 	--	(a) the import-reason field, so that the Name says how it came into scope
 	--		including whether it's explicitly imported
@@ -515,40 +516,25 @@ type ExportOccMap = FiniteMap OccName (Name, RdrNameIE)
 exportsFromAvail :: Module
 		 -> Maybe [RdrNameIE]	-- Export spec
 		 -> ExportAvails
-		 -> RnEnv
-		 -> RnMG (Name -> ExportFlag, ExportEnv)
+		 -> GlobalRdrEnv 
+		 -> RnMG Avails
 	-- Complains if two distinct exports have same OccName
         -- Warns about identical exports.
 	-- Complains about exports items not in scope
-exportsFromAvail this_mod Nothing export_avails rn_env
-  = exportsFromAvail this_mod (Just [IEModuleContents this_mod]) export_avails rn_env
+exportsFromAvail this_mod Nothing export_avails global_name_env
+  = exportsFromAvail this_mod (Just [IEModuleContents this_mod]) 
+		     export_avails global_name_env
 
 exportsFromAvail this_mod (Just export_items) 
 		 (mod_avail_env, entity_avail_env)
-	         (RnEnv global_name_env fixity_env)
+	         global_name_env
   = foldlRn exports_from_item
 	    ([], emptyFM, emptyNameEnv) export_items	`thenRn` \ (_, _, export_avail_map) ->
     let
 	export_avails :: [AvailInfo]
 	export_avails   = nameEnvElts export_avail_map
-
-	export_names :: NameSet
-        export_names = availsToNameSet export_avails
-
-	-- Export only those fixities that are for names that are
-	--	(a) defined in this module
-	--	(b) exported
-	export_fixities :: [(Name,Fixity)]
-	export_fixities = [ (name,fixity) 
-			  | FixitySig name fixity _ <- nameEnvElts fixity_env,
-			    name `elemNameSet` export_names,
-			    isLocallyDefined name
-			  ]
-
-	export_fn :: Name -> ExportFlag
-	export_fn = mk_export_fn export_names
     in
-    returnRn (export_fn, ExportEnv export_avails export_fixities)
+    returnRn export_avails
 
   where
     exports_from_item :: ExportAccum -> RdrNameIE -> RnMG ExportAccum

ghc/compiler/simplCore/SimplCore.lhs

@@ -50,7 +50,7 @@ import PrelInfo		( unpackCStringId, unpackCString2Id,
 			  int2IntegerId, addr2IntegerId
 			)
 import Type		( Type, splitAlgTyConApp_maybe, 
-			  isUnLiftedType, mkTyVarTy, 
+			  isUnLiftedType,
 			  tidyType, tidyTypes, tidyTopType, tidyTyVar, tidyTyVars,
 			  Type
 			)

ghc/compiler/simplCore/SimplUtils.lhs

@@ -30,8 +30,8 @@ import Maybes		( maybeToBool )
 import Const		( Con(..) )
 import Name		( isLocalName )
 import SimplMonad
-import Type		( Type, tyVarsOfType, tyVarsOfTypes, mkForAllTys, mkTyVarTys,
-			  splitTyConApp_maybe, mkTyVarTy, substTyVar
+import Type		( Type, tyVarsOfType, tyVarsOfTypes, mkForAllTys,
+			  splitTyConApp_maybe, substTyVar, mkTyVarTys
 			)
 import Var		( setVarUnique )
 import VarSet

ghc/compiler/simplCore/Simplify.lhs

@@ -1032,7 +1032,13 @@ rebuild :: OutExpr -> SimplCont -> SimplM OutExprStuff
 
 rebuild expr cont
   = tick LeavesExamined					`thenSmpl_`
-    do_rebuild expr cont
+    case expr of
+	Var v -> case getIdStrictness v of
+		    NoStrictnessInfo		        -> do_rebuild expr cont
+		    StrictnessInfo demands result_bot _ -> ASSERT( not (null demands) || result_bot )
+								-- If this happened we'd get an infinite loop
+							   rebuild_strict demands result_bot expr (idType v) cont
+	other  -> do_rebuild expr cont
 
 rebuild_done expr
   = getInScope			`thenSmpl` \ in_scope ->		
@@ -1053,16 +1059,8 @@ do_rebuild expr (ArgOf _ cont_fn _) = cont_fn expr
 --	ApplyTo continuation
 
 do_rebuild expr cont@(ApplyTo _ arg se cont')
-  = case expr of
-	Var v -> case getIdStrictness v of
-		    NoStrictnessInfo		        -> non_strict_case
-		    StrictnessInfo demands result_bot _ -> ASSERT( not (null demands) || result_bot )
-								-- If this happened we'd get an infinite loop
-							   rebuild_strict demands result_bot expr (idType v) cont
-	other -> non_strict_case
-  where
-    non_strict_case = setSubstEnv se (simplArg arg)	`thenSmpl` \ arg' ->
-		      do_rebuild (App expr arg') cont'
+  = setSubstEnv se (simplArg arg)	`thenSmpl` \ arg' ->
+    do_rebuild (App expr arg') cont'
 
 
 ---------------------------------------------------------
@@ -1072,9 +1070,6 @@ do_rebuild expr (CoerceIt _ to_ty se cont)
   = setSubstEnv se	$
     simplType to_ty	`thenSmpl` \ to_ty' ->
     do_rebuild (mk_coerce to_ty' expr) cont
-  where
-    mk_coerce to_ty' (Note (Coerce _ from_ty) expr) = Note (Coerce to_ty' from_ty) expr
-    mk_coerce to_ty' expr			    = Note (Coerce to_ty' (coreExprType expr)) expr
 
 
 ---------------------------------------------------------
@@ -1209,6 +1204,8 @@ If so, then we can replace the case with one of the rhss.
 \begin{code}
 ---------------------------------------------------------
 --	Rebuiling a function with strictness info
+--	This just a version of do_rebuild, enhanced with info about
+--	the strictness of the thing being rebuilt.
 
 rebuild_strict :: [Demand] -> Bool 	-- Stricness info
 	       -> OutExpr -> OutType	-- Function and type
@@ -1218,6 +1215,11 @@ rebuild_strict :: [Demand] -> Bool 	-- Stricness info
 rebuild_strict [] True  fun fun_ty cont = rebuild_bot fun fun_ty cont
 rebuild_strict [] False fun fun_ty cont = do_rebuild fun cont
 
+rebuild_strict ds result_bot fun fun_ty (CoerceIt _ to_ty se cont)
+	= setSubstEnv se	$
+	  simplType to_ty	`thenSmpl` \ to_ty' ->
+	  rebuild_strict ds result_bot (mk_coerce to_ty' fun) to_ty' cont
+
 rebuild_strict ds result_bot fun fun_ty (ApplyTo _ (Type ty_arg) se cont)
 				-- Type arg; don't consume a demand
 	= setSubstEnv se (simplType ty_arg)	`thenSmpl` \ ty_arg' ->
@@ -1225,7 +1227,8 @@ rebuild_strict ds result_bot fun fun_ty (ApplyTo _ (Type ty_arg) se cont)
 			 (applyTy fun_ty ty_arg') cont
 
 rebuild_strict (d:ds) result_bot fun fun_ty (ApplyTo _ val_arg se cont)
-	| isStrict d || isUnLiftedType arg_ty	-- Strict value argument
+	| isStrict d || isUnLiftedType arg_ty
+				-- Strict value argument
 	= getInScope 				`thenSmpl` \ in_scope ->
 	  let
 		cont_ty = contResultType in_scope res_ty cont
@@ -1248,6 +1251,7 @@ rebuild_strict ds result_bot fun fun_ty cont = do_rebuild fun cont
 -- 	Dealing with
 --	* case (error "hello") of { ... }
 --	* (error "Hello") arg
+--	* f (error "Hello") where f is strict
 --	etc
 
 rebuild_bot expr expr_ty Stop				-- No coerce needed
@@ -1259,13 +1263,17 @@ rebuild_bot expr expr_ty (CoerceIt _ to_ty se Stop)	-- Don't "tick" on this,
     simplType to_ty	`thenSmpl` \ to_ty' ->
     rebuild_done (mkNote (Coerce to_ty' expr_ty) expr)
 
-rebuild_bot expr expr_ty cont
+rebuild_bot expr expr_ty cont				-- Abandon the (strict) continuation,
+							-- and just return expr
   = tick CaseOfError		`thenSmpl_`
     getInScope			`thenSmpl` \ in_scope ->
     let
 	result_ty = contResultType in_scope expr_ty cont
     in
     rebuild_done (mkNote (Coerce result_ty expr_ty) expr)
+
+mk_coerce to_ty (Note (Coerce _ from_ty) expr) = Note (Coerce to_ty from_ty) expr
+mk_coerce to_ty expr			       = Note (Coerce to_ty (coreExprType expr)) expr
 \end{code}
 
 Blob of helper functions for the "case-of-something-else" situation.

ghc/compiler/typecheck/TcBinds.lhs

@@ -24,6 +24,7 @@ import Inst		( Inst, LIE, emptyLIE, mkLIE, plusLIE, plusLIEs, InstOrigin(..),
 			)
 import TcEnv		( tcExtendLocalValEnv,
 			  newSpecPragmaId,
+			  tcLookupTyCon, 
 			  tcGetGlobalTyVars, tcExtendGlobalTyVars
 			)
 import TcSimplify	( tcSimplify, tcSimplifyAndCheck )
@@ -39,11 +40,13 @@ import TcType		( TcType, TcThetaType,
 			)
 import TcUnify		( unifyTauTy, unifyTauTyLists )
 
+import PrelInfo		( main_NAME, ioTyCon_NAME )
+
 import Id		( mkUserId )
 import Var		( idType, idName, setIdInfo )
 import IdInfo		( IdInfo, noIdInfo, setInlinePragInfo, InlinePragInfo(..) )
-import Name		( Name )
-import Type		( mkTyVarTy, tyVarsOfTypes,
+import Name		( Name, getName )
+import Type		( mkTyVarTy, tyVarsOfTypes, mkTyConApp,
 			  splitSigmaTy, mkForAllTys, mkFunTys, getTyVar, 
 			  mkDictTy, splitRhoTy, mkForAllTy, isUnLiftedType, 
 			  isUnboxedType, unboxedTypeKind, boxedTypeKind
@@ -52,6 +55,7 @@ import Var		( TyVar, tyVarKind )
 import VarSet
 import Bag
 import Util		( isIn )
+import Maybes		( maybeToBool )
 import BasicTypes	( TopLevelFlag(..), RecFlag(..) )
 import SrcLoc           ( SrcLoc )
 import Outputable
@@ -250,18 +254,17 @@ tcBindWithSigs top_lvl mbind tc_ty_sigs is_rec prag_info_fn
 	-- TYPECHECK THE BINDINGS
     tcMonoBinds mbind tc_ty_sigs is_rec	`thenTc` \ (mbind', lie_req, binder_names, mono_ids) ->
 
-    let
-	mono_id_tys = map idType mono_ids
-    in
-
 	-- CHECK THAT THE SIGNATURES MATCH
 	-- (must do this before getTyVarsToGen)
-    checkSigMatch tc_ty_sigs				`thenTc` \ (sig_theta, lie_avail) ->	
+    checkSigMatch top_lvl binder_names mono_ids tc_ty_sigs	`thenTc` \ maybe_sig_theta ->	
 
 	-- COMPUTE VARIABLES OVER WHICH TO QUANTIFY, namely tyvars_to_gen
 	-- The tyvars_not_to_gen are free in the environment, and hence
 	-- candidates for generalisation, but sometimes the monomorphism
 	-- restriction means we can't generalise them nevertheless
+    let
+	mono_id_tys = map idType mono_ids
+    in
     getTyVarsToGen is_unrestricted mono_id_tys lie_req	`thenNF_Tc` \ (tyvars_not_to_gen, tyvars_to_gen) ->
 
 	-- Finally, zonk the generalised type variables to real TyVars
@@ -288,7 +291,8 @@ tcBindWithSigs top_lvl mbind tc_ty_sigs is_rec prag_info_fn
 		-- No polymorphism, so no need to simplify context
 	    returnTc (lie_req, EmptyMonoBinds, [])
 	else
-	if null tc_ty_sigs then
+	case maybe_sig_theta of
+	  Nothing ->
 		-- No signatures, so just simplify the lie
 		-- NB: no signatures => no polymorphic recursion, so no
 		-- need to use lie_avail (which will be empty anyway)
@@ -296,7 +300,11 @@ tcBindWithSigs top_lvl mbind tc_ty_sigs is_rec prag_info_fn
 		       top_lvl real_tyvars_to_gen lie_req	`thenTc` \ (lie_free, dict_binds, lie_bound) ->
 	    returnTc (lie_free, dict_binds, map instToId (bagToList lie_bound))
 
-	else
+	  Just (sig_theta, lie_avail) ->
+		-- There are signatures, and their context is sig_theta
+		-- Furthermore, lie_avail is an LIE containing the 'method insts'
+		-- for the things bound here
+
 	    zonkTcThetaType sig_theta			`thenNF_Tc` \ sig_theta' ->
 	    newDicts SignatureOrigin sig_theta'		`thenNF_Tc` \ (dicts_sig, dict_ids) ->
 		-- It's important that sig_theta is zonked, because
@@ -682,13 +690,46 @@ The error message here is somewhat unsatisfactory, but it'll do for
 now (ToDo).
 
 \begin{code}
-checkSigMatch []
-  = returnTc (error "checkSigMatch", emptyLIE)
+checkSigMatch top_lvl binder_names mono_ids sigs
+  | main_bound_here
+  = mapTc check_one_sig sigs			`thenTc_`
+    mapTc check_main_ctxt sigs			`thenTc_` 
+
+	-- Now unify the main_id with IO t, for any old t
+    tcSetErrCtxt mainTyCheckCtxt (
+	tcLookupTyCon ioTyCon_NAME		`thenTc`    \ ioTyCon ->
+	newTyVarTy boxedTypeKind		`thenNF_Tc` \ t_tv ->
+	unifyTauTy ((mkTyConApp ioTyCon [t_tv]))
+		   (idType main_mono_id)
+    )						`thenTc_`
+    returnTc (Just ([], emptyLIE))
+
+  | not (null sigs)
+  = mapTc check_one_sig sigs			`thenTc_`
+    mapTc check_one_ctxt all_sigs_but_first	`thenTc_`
+    returnTc (Just (theta1, sig_lie))
+
+  | otherwise
+  = returnTc Nothing		-- No constraints from type sigs
+
+  where
+    (TySigInfo _ id1 _ theta1 _ _ _ _ : all_sigs_but_first) = sigs
+
+    sig1_dict_tys	= mk_dict_tys theta1
+    n_sig1_dict_tys	= length sig1_dict_tys
+    sig_lie 		= mkLIE [inst | TySigInfo _ _ _ _ _ _ inst _ <- sigs]
 
-checkSigMatch tc_ty_sigs@( sig1@(TySigInfo _ id1 _ theta1 _ _ _ _) : all_sigs_but_first )
-  = 	-- CHECK THAT THE SIGNATURE TYVARS AND TAU_TYPES ARE OK
+    maybe_main        = find_main top_lvl binder_names mono_ids
+    main_bound_here   = maybeToBool maybe_main
+    Just main_mono_id = maybe_main
+		      
+   	-- CHECK THAT THE SIGNATURE TYVARS AND TAU_TYPES ARE OK
 	-- Doesn't affect substitution
-    mapTc check_one_sig tc_ty_sigs	`thenTc_`
+    check_one_sig (TySigInfo _ id sig_tyvars _ sig_tau _ _ src_loc)
+      = tcAddSrcLoc src_loc					$
+	tcAddErrCtxtM (sigCtxt (sig_msg id) (idType id))	$
+	checkSigTyVars sig_tyvars
+
 
 	-- CHECK THAT ALL THE SIGNATURE CONTEXTS ARE UNIFIABLE
 	-- The type signatures on a mutually-recursive group of definitions
@@ -697,15 +738,7 @@ checkSigMatch tc_ty_sigs@( sig1@(TySigInfo _ id1 _ theta1 _ _ _ _) : all_sigs_bu
 	-- We unify them because, with polymorphic recursion, their types
 	-- might not otherwise be related.  This is a rather subtle issue.
 	-- ToDo: amplify
-    mapTc check_one_cxt all_sigs_but_first		`thenTc_`
-
-    returnTc (theta1, sig_lie)
-  where
-    sig1_dict_tys	= mk_dict_tys theta1
-    n_sig1_dict_tys	= length sig1_dict_tys
-    sig_lie 		= mkLIE [inst | TySigInfo _ _ _ _ _ _ inst _ <- tc_ty_sigs]
-
-    check_one_cxt sig@(TySigInfo _ id _ theta _ _ _ src_loc)
+    check_one_ctxt sig@(TySigInfo _ id _ theta _ _ _ src_loc)
        = tcAddSrcLoc src_loc	$
 	 tcAddErrCtxt (sigContextsCtxt id1 id) $
 	 checkTc (length this_sig_dict_tys == n_sig1_dict_tys)
@@ -714,15 +747,23 @@ checkSigMatch tc_ty_sigs@( sig1@(TySigInfo _ id1 _ theta1 _ _ _ _) : all_sigs_bu
       where
 	 this_sig_dict_tys = mk_dict_tys theta
 
-    check_one_sig (TySigInfo _ id sig_tyvars _ sig_tau _ _ src_loc)
-      = tcAddSrcLoc src_loc					$
-	tcAddErrCtxtM (sigCtxt (sig_msg id) (idType id))	$
-	checkSigTyVars sig_tyvars
+	-- CHECK THAT FOR A GROUP INVOLVING Main.main, all 
+	-- the signature contexts are empty (what a bore)
+    check_main_ctxt sig@(TySigInfo _ id _ theta _ _ _ src_loc)
+	= tcAddSrcLoc src_loc	$
+	  checkTc (null theta) (mainContextsErr id)
 
     mk_dict_tys theta = [mkDictTy c ts | (c,ts) <- theta]
 
     sig_msg id tidy_ty = sep [ptext SLIT("When checking the type signature"),
 			      nest 4 (ppr id <+> dcolon <+> ppr tidy_ty)]
+
+	-- Search for Main.main in the binder_names, return corresponding mono_id
+    find_main NotTopLevel binder_names mono_ids = Nothing
+    find_main TopLevel    binder_names mono_ids = go binder_names mono_ids
+    go [] [] = Nothing
+    go (n:ns) (m:ms) | n == main_NAME = Just m
+		     | otherwise      = go ns ms
 \end{code}
 
 
@@ -904,11 +945,20 @@ bindSigsCtxt ids
 -----------------------------------------------
 sigContextsErr
   = ptext SLIT("Mismatched contexts")
+
 sigContextsCtxt s1 s2
   = hang (hsep [ptext SLIT("When matching the contexts of the signatures for"), 
 		quotes (ppr s1), ptext SLIT("and"), quotes (ppr s2)])
 	 4 (ptext SLIT("(the signature contexts in a mutually recursive group should all be identical)"))
 
+mainContextsErr id
+  | getName id == main_NAME = ptext SLIT("Main.main cannot be overloaded")
+  | otherwise
+  = quotes (ppr id) <+> ptext SLIT("cannot be overloaded, because it is mutually recursive with Main.main")
+
+mainTyCheckCtxt
+  = hsep [ptext SLIT("When checking that"), ppr main_NAME, ptext SLIT("has the required type")]
+
 -----------------------------------------------
 unliftedBindErr flavour mbind
   = hang (text flavour <+> ptext SLIT("bindings for unlifted types aren't allowed"))

ghc/compiler/typecheck/TcEnv.lhs

@@ -265,7 +265,9 @@ tcLookupTy name
 		   maybe_arity | isSynTyCon tc = Just (tyConArity tc)