[project @ 2001-10-03 08:16:49 by simonmar]

[ghc-hetmet.git] / ghc / compiler / main / HscMain.lhs

diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs
index 2e38352..5da7b8d 100644 (file)
--- a/ghc/compiler/main/HscMain.lhs
+++ b/ghc/compiler/main/HscMain.lhs
@@ -14,6 +14,7 @@ module HscMain ( HscResult(..), hscMain,
 #include "HsVersions.h"
 
 #ifdef GHCI
+import Interpreter
 import ByteCodeGen     ( byteCodeGen )
 import CoreTidy                ( tidyCoreExpr )
 import CorePrep                ( corePrepExpr )
@@ -29,12 +30,12 @@ import HscTypes             ( InteractiveContext(..) )
 import PrelNames       ( iNTERACTIVE )
 import StringBuffer    ( stringToStringBuffer )
 import FastString       ( mkFastString )
-import Char            ( isUpper )
-import DriverUtil      ( split_longest_prefix )
+import Maybes          ( catMaybes )
 #endif
 
 import HsSyn
 
+import RdrName         ( mkRdrOrig )
 import Id              ( idName )
 import IdInfo          ( CafInfo(..), CgInfoEnv, CgInfo(..) )
 import StringBuffer    ( hGetStringBuffer, freeStringBuffer )
@@ -45,6 +46,7 @@ import Finder         ( findModule )
 import Rename          ( checkOldIface, renameModule, closeIfaceDecls )
 import Rules           ( emptyRuleBase )
 import PrelInfo                ( wiredInThingEnv, wiredInThings )
+import PrelRules       ( builtinRules )
 import PrelNames       ( knownKeyNames )
 import MkIface         ( mkFinalIface )
 import TcModule
@@ -67,9 +69,8 @@ import ErrUtils               ( dumpIfSet_dyn, showPass, printError )
 import Util            ( unJust )
 import UniqSupply      ( mkSplitUniqSupply )
 
-import Bag             ( emptyBag )
+import Bag             ( consBag, emptyBag )
 import Outputable
-import Interpreter
 import HscStats                ( ppSourceStats )
 import HscTypes
 import FiniteMap       ( FiniteMap, plusFM, emptyFM, addToFM )
@@ -81,7 +82,7 @@ import Module         ( Module )
 import IOExts          ( newIORef, readIORef, writeIORef, unsafePerformIO )
 
 import Monad           ( when )
-import Maybe           ( isJust, fromJust, catMaybes )
+import Maybe           ( isJust, fromJust )
 import IO
 
 import MkExternalCore  ( emitExternalCore )
@@ -160,7 +161,8 @@ hscNoRecomp ghci_mode dflags have_object
            mod location (Just old_iface) hst hit pcs_ch
  | ghci_mode == OneShot
  = do {
-      hPutStrLn stderr "compilation IS NOT required";
+      when (verbosity dflags > 0) $
+         hPutStrLn stderr "compilation IS NOT required";
       let { bomb = panic "hscNoRecomp:OneShot" };
       return (HscNoRecomp pcs_ch bomb bomb)
       }
@@ -499,13 +501,7 @@ A naked expression returns a singleton Name [it].
 
 \begin{code}
 hscStmt dflags hst hit pcs0 icontext stmt just_expr
-   = let 
-       InteractiveContext { 
-            ic_rn_env   = rn_env, 
-            ic_type_env = type_env,
-            ic_module   = scope_mod } = icontext
-     in
-     do { maybe_stmt <- hscParseStmt dflags stmt
+   =  do { maybe_stmt <- hscParseStmt dflags stmt
        ; case maybe_stmt of
             Nothing -> return (pcs0, Nothing)
             Just parsed_stmt -> do {
@@ -521,8 +517,8 @@ hscStmt dflags hst hit pcs0 icontext stmt just_expr
 
                -- Rename it
          (pcs1, print_unqual, maybe_renamed_stmt)
-                <- renameStmt dflags hit hst pcs0 scope_mod 
-                               iNTERACTIVE rn_env parsed_stmt
+                <- renameStmt dflags hit hst pcs0 
+                       iNTERACTIVE icontext parsed_stmt
 
        ; case maybe_renamed_stmt of
                Nothing -> return (pcs0, Nothing)
@@ -532,9 +528,9 @@ hscStmt dflags hst hit pcs0 icontext stmt just_expr
          maybe_tc_return <- 
            if just_expr 
                then case rn_stmt of { (ExprStmt e _ _, decls) -> 
-                    typecheckExpr dflags pcs1 hst type_env
+                    typecheckExpr dflags pcs1 hst (ic_type_env icontext)
                           print_unqual iNTERACTIVE (e,decls) }
-               else typecheckStmt dflags pcs1 hst type_env
+               else typecheckStmt dflags pcs1 hst (ic_type_env icontext)
                           print_unqual iNTERACTIVE bound_names rn_stmt
 
        ; case maybe_tc_return of
@@ -621,12 +617,7 @@ hscThing -- like hscStmt, but deals with a single identifier
          [TyThing] )
 
 hscThing dflags hst hit pcs0 icontext str
-   = do let 
-         InteractiveContext {
-            ic_rn_env   = rn_env,
-            ic_module   = scope_mod } = icontext
-
-       maybe_rdr_name <- myParseIdentifier dflags str
+   = do maybe_rdr_name <- myParseIdentifier dflags str
        case maybe_rdr_name of {
          Nothing -> return (pcs0, []);
          Just rdr_name -> do
@@ -643,8 +634,7 @@ hscThing dflags hst hit pcs0 icontext str
                tccls_name = setRdrNameOcc rdr_name tccls_occ
 
        (pcs, unqual, maybe_rn_result) <- 
-          renameRdrName dflags hit hst pcs0 scope_mod scope_mod 
-               rn_env rdr_names
+          renameRdrName dflags hit hst pcs0 iNTERACTIVE icontext rdr_names
 
        case maybe_rn_result of {
             Nothing -> return (pcs, []);
@@ -708,10 +698,18 @@ initPersistentRenamerState :: IO PersistentRenamerState
                                      nsIPs   = emptyFM },
              prsDecls   = (emptyNameEnv, 0),
              prsInsts   = (emptyBag, 0),
-             prsRules   = (emptyBag, 0),
+             prsRules   = foldr add_rule (emptyBag, 0) builtinRules,
              prsImpMods = emptyFM
             }
         )
+  where
+    add_rule (name,rule) (rules, n_rules)
+        = (gated_decl `consBag` rules, n_rules+1)
+       where
+          gated_decl = (gate_fn, (mod, IfaceRuleOut rdr_name rule))
+          mod        = nameModule name
+          rdr_name   = mkRdrOrig (moduleName mod) (nameOccName name)
+          gate_fn vis_fn = vis_fn name -- Load the rule whenever name is visible
 
 initOrigNames :: FiniteMap (ModuleName,OccName) Name
 initOrigNames