X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcRnDriver.lhs;h=7e3aae25065f3690da869f1a2997abe2ea8ce944;hb=9d7da331989abcd1844e9d03b8d1e4163796fa85;hp=8e427fe1e63beeba00ae28bf9c64bc9799b61093;hpb=a7ecdf96844404b7bc8273d4ff6d85759278427c;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcRnDriver.lhs b/ghc/compiler/typecheck/TcRnDriver.lhs
index 8e427fe..7e3aae2 100644
--- a/ghc/compiler/typecheck/TcRnDriver.lhs
+++ b/ghc/compiler/typecheck/TcRnDriver.lhs
@@ -33,7 +33,7 @@ import HsSyn		( HsModule(..), HsExtCore(..), HsGroup(..), LHsDecl,
 			  nlHsApp, nlHsVar, pprLHsBinds )
 import RdrHsSyn		( findSplice )
 
-import PrelNames	( runMainIOName, rootMainName, mAIN,
+import PrelNames	( runMainIOName, rootMainKey, rOOT_MAIN, mAIN,
 			  main_RDR_Unqual )
 import RdrName		( RdrName, mkRdrUnqual, emptyGlobalRdrEnv )
 import TcHsSyn		( zonkTopDecls )
@@ -62,9 +62,10 @@ import DataCon		( dataConWrapId )
 import ErrUtils		( Messages, mkDumpDoc, showPass )
 import Id		( Id, mkExportedLocalId, isLocalId, idName, idType )
 import Var		( Var )
-import Module           ( Module, ModuleEnv, mkModule, moduleEnvElts, elemModuleEnv )
-import OccName		( mkVarOcc )
-import Name		( Name, NamedThing(..), isExternalName, getSrcLoc, isWiredInName )
+import Module           ( Module, ModuleEnv, moduleEnvElts, elemModuleEnv )
+import OccName		( mkVarOccFS )
+import Name		( Name, NamedThing(..), isExternalName, getSrcLoc, isWiredInName,
+			  mkExternalName )
 import NameSet
 import TyCon		( tyConHasGenerics, isSynTyCon, getSynTyConDefn, tyConKind )
 import SrcLoc		( srcLocSpan, Located(..), noLoc )
@@ -83,7 +84,7 @@ import Outputable
 #ifdef GHCI
 import HsSyn		( HsStmtContext(..), Stmt(..), HsExpr(..), 
 			  HsLocalBinds(..), HsValBinds(..),
-			  LStmt, LHsExpr, LHsType, mkVarBind,
+			  LStmt, LHsExpr, LHsType, mkMatchGroup, mkMatch, emptyLocalBinds,
 			  collectLStmtsBinders, collectLStmtBinders, nlVarPat,
 		   	  placeHolderType, noSyntaxExpr )
 import RdrName		( GlobalRdrElt(..), globalRdrEnvElts,
@@ -120,8 +121,8 @@ import PrelNames	( iNTERACTIVE, ioTyConName, printName, itName,
 import HscTypes		( InteractiveContext(..),
 			  ModIface(..), icPrintUnqual,
 			  Dependencies(..) )
-import BasicTypes	( Fixity )
-import SrcLoc		( unLoc, noSrcSpan )
+import BasicTypes	( Fixity, RecFlag(..) )
+import SrcLoc		( unLoc )
 #endif
 
 import FastString	( mkFastString )
@@ -731,11 +732,9 @@ checkMain
   = do { ghci_mode <- getGhciMode ;
 	 tcg_env   <- getGblEnv ;
 	 dflags    <- getDOpts ;
-	 let { main_mod = case mainModIs dflags of {
-				Just mod -> mkModule mod ;
-				Nothing  -> mAIN } ;
+	 let { main_mod = mainModIs dflags ;
 	       main_fn  = case mainFunIs dflags of {
-				Just fn -> mkRdrUnqual (mkVarOcc (mkFastString fn)) ;
+				Just fn -> mkRdrUnqual (mkVarOccFS (mkFastString fn)) ;
 				Nothing -> main_RDR_Unqual } } ;
 	
 	 check_main ghci_mode tcg_env main_mod main_fn
@@ -764,8 +763,23 @@ check_main ghci_mode tcg_env main_mod main_fn
 	; (main_expr, ty) <- setSrcSpan (srcLocSpan (getSrcLoc main_name)) $
 			     tcInferRho rhs
 
-	; let { root_main_id = mkExportedLocalId rootMainName ty ;
-	        main_bind    = noLoc (VarBind root_main_id main_expr) }
+	-- The function that the RTS invokes is always :Main.main,
+	-- which we call root_main_id.  
+	-- (Because GHC allows the user to have a module not called 
+	-- Main as the main module, we can't rely on the main function
+	-- being called "Main.main".  That's why root_main_id has a fixed
+	-- module ":Main".)
+	-- We also make root_main_id an implicit Id, by making main_name
+	-- its parent (hence (Just main_name)).  That has the effect
+	-- of preventing its type and unfolding from getting out into
+	-- the interface file. Otherwise we can end up with two defns
+	-- for 'main' in the interface file!
+
+	; let { root_main_name =  mkExternalName rootMainKey rOOT_MAIN 
+				   (mkVarOccFS FSLIT("main")) 
+				   (Just main_name) (getSrcLoc main_name)
+	      ; root_main_id = mkExportedLocalId root_main_name ty
+	      ; main_bind    = noLoc (VarBind root_main_id main_expr) }
 
 	; return (tcg_env { tcg_binds = tcg_binds tcg_env 
 					`snocBag` main_bind,
@@ -934,8 +948,9 @@ mkPlan :: LStmt Name -> TcM PlanResult
 mkPlan (L loc (ExprStmt expr _ _))	-- An expression typed at the prompt 
   = do	{ uniq <- newUnique		-- is treated very specially
 	; let fresh_it  = itName uniq
-	      the_bind  = mkVarBind noSrcSpan fresh_it expr
-	      let_stmt  = L loc $ LetStmt (HsValBinds (ValBindsIn (unitBag the_bind) []))
+	      the_bind  = L loc $ FunBind (L loc fresh_it) False matches emptyNameSet
+	      matches   = mkMatchGroup [mkMatch [] expr emptyLocalBinds]
+	      let_stmt  = L loc $ LetStmt (HsValBinds (ValBindsOut [(NonRecursive,unitBag the_bind)] []))
 	      bind_stmt = L loc $ BindStmt (nlVarPat fresh_it) expr
 					   (HsVar bindIOName) noSyntaxExpr 
 	      print_it  = L loc $ ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar fresh_it))