[project @ 2004-08-16 09:53:47 by simonpj]

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

diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs
index 7437718..4ebb881 100644 (file)
--- a/ghc/compiler/main/HscMain.lhs
+++ b/ghc/compiler/main/HscMain.lhs
@@ -6,9 +6,10 @@
 
 \begin{code}
 module HscMain ( 
-       HscResult(..), hscMain, newHscEnv, hscBufferFrontEnd
+       HscResult(..), hscMain, newHscEnv, hscCmmFile, hscBufferFrontEnd
 #ifdef GHCI
-       , hscStmt, hscTcExpr, hscKcType, hscThing, 
+       , hscStmt, hscTcExpr, hscKcType
+       , hscGetInfo, GetInfoResult
        , compileExpr
 #endif
        ) where
@@ -17,19 +18,20 @@ module HscMain (
 
 #ifdef GHCI
 import HsSyn           ( Stmt(..), LStmt, LHsExpr, LHsType )
-import IfaceSyn                ( IfaceDecl )
+import IfaceSyn                ( IfaceDecl, IfaceInst )
 import CodeOutput      ( outputForeignStubs )
 import ByteCodeGen     ( byteCodeGen, coreExprToBCOs )
 import Linker          ( HValue, linkExpr )
 import TidyPgm         ( tidyCoreExpr )
 import CorePrep                ( corePrepExpr )
 import Flattening      ( flattenExpr )
-import TcRnDriver      ( tcRnStmt, tcRnExpr, tcRnThing, tcRnType ) 
-import RdrName         ( RdrName )
+import TcRnDriver      ( tcRnStmt, tcRnExpr, tcRnGetInfo, tcRnType ) 
+import RdrName         ( RdrName, rdrNameOcc )
+import OccName         ( occNameUserString )
 import Type            ( Type )
 import PrelNames       ( iNTERACTIVE )
 import StringBuffer    ( stringToStringBuffer )
-import SrcLoc          ( noSrcLoc, Located(..) )
+import SrcLoc          ( SrcLoc, noSrcLoc, Located(..) )
 import Kind            ( Kind )
 import Var             ( Id )
 import CoreLint                ( lintUnfolding )
@@ -57,6 +59,7 @@ import CoreToStg      ( coreToStg )
 import Name            ( Name, NamedThing(..) )
 import SimplStg                ( stg2stg )
 import CodeGen         ( codeGen )
+import CmmParse                ( parseCmmFile )
 import CodeOutput      ( codeOutput )
 
 import CmdLineOpts
@@ -176,7 +179,7 @@ hscMain hsc_env msg_act mod location
 -- hscNoRecomp definitely expects to have the old interface available
 hscNoRecomp hsc_env msg_act have_object 
            mod location (Just old_iface)
- | hsc_mode hsc_env == OneShot
+ | isOneShot (hsc_mode hsc_env)
  = do {
       when (verbosity (hsc_dflags hsc_env) > 0) $
          hPutStrLn stderr "compilation IS NOT required";
@@ -202,7 +205,7 @@ hscRecomp hsc_env msg_act have_object
          mod location maybe_checked_iface
  = do  {
          -- what target are we shooting for?
-       ; let one_shot  = hsc_mode hsc_env == OneShot
+       ; let one_shot  = isOneShot (hsc_mode hsc_env)
        ; let dflags    = hsc_dflags hsc_env
        ; let toInterp  = dopt_HscLang dflags == HscInterpreted
        ; let toCore    = isJust (ml_hs_file location) &&
@@ -449,6 +452,18 @@ hscBackEnd dflags
    }
 
 
+hscCmmFile :: DynFlags -> FilePath -> IO Bool
+hscCmmFile dflags filename = do
+  maybe_cmm <- parseCmmFile dflags filename
+  case maybe_cmm of
+    Nothing -> return False
+    Just cmm -> do
+       codeOutput dflags no_mod NoStubs noDependencies [cmm]
+       return True
+  where
+       no_mod = panic "hscCmmFile: no_mod"
+
+
 myParseModule dflags src_filename
  = do --------------------------  Parser  ----------------
       showPass dflags "Parser"
@@ -627,23 +642,29 @@ hscParseThing parser dflags str
 
 \begin{code}
 #ifdef GHCI
-hscThing -- like hscStmt, but deals with a single identifier
+type GetInfoResult = (String, (IfaceDecl, Fixity, SrcLoc, [(IfaceInst,SrcLoc)]))
+
+hscGetInfo -- like hscStmt, but deals with a single identifier
   :: HscEnv
   -> InteractiveContext                -- Context for compiling
   -> String                    -- The identifier
-  -> IO [(IfaceDecl, Fixity)]
+  -> IO [GetInfoResult]
 
-hscThing hsc_env ic str
+hscGetInfo hsc_env ic str
    = do maybe_rdr_name <- hscParseIdentifier (hsc_dflags hsc_env) str
        case maybe_rdr_name of {
          Nothing -> return [];
          Just (L _ rdr_name) -> do
 
-       maybe_tc_result <- tcRnThing hsc_env ic rdr_name
+       maybe_tc_result <- tcRnGetInfo hsc_env ic rdr_name
+
+       let     -- str' is the the naked occurrence name
+               -- after stripping off qualification and parens (+)
+          str' = occNameUserString (rdrNameOcc rdr_name)
 
        case maybe_tc_result of {
             Nothing     -> return [] ;
-            Just things -> return things
+            Just things -> return [(str', t) | t <- things]
        }}
 #endif
 \end{code}