[project @ 2004-07-21 10:07:29 by simonpj]

[ghc-hetmet.git] / ghc / compiler / compMan / CompManager.lhs

diff --git a/ghc/compiler/compMan/CompManager.lhs b/ghc/compiler/compMan/CompManager.lhs
index 2917879..82183f1 100644 (file)
--- a/ghc/compiler/compMan/CompManager.lhs
+++ b/ghc/compiler/compMan/CompManager.lhs
@@ -25,9 +25,7 @@ module CompManager (
     cmSetContext,  -- :: CmState -> DynFlags -> [String] -> [String] -> IO CmState
     cmGetContext,  -- :: CmState -> IO ([String],[String])
 
-    cmInfoThing,   -- :: CmState -> DynFlags -> String
-                  --   -> IO (CmState, [(TyThing,Fixity)])
-
+    cmInfoThing,    -- :: CmState -> String -> IO (CmState, [(TyThing,Fixity)])
     cmBrowseModule, -- :: CmState -> IO [TyThing]
 
     CmRunResult(..),
@@ -37,6 +35,9 @@ module CompManager (
     cmTypeOfExpr,  -- :: CmState -> DynFlags -> String
                   --   -> IO (CmState, Maybe String)
 
+    cmKindOfType,  -- :: CmState -> DynFlags -> String
+                  --   -> IO (CmState, Maybe String)
+
     cmTypeOfName,  -- :: CmState -> Name -> IO (Maybe String)
 
     HValue,
@@ -56,7 +57,7 @@ where
 
 import DriverPipeline  ( CompResult(..), preprocess, compile, link )
 import HscMain         ( newHscEnv )
-import DriverState     ( v_Output_file, v_NoHsMain )
+import DriverState     ( v_Output_file, v_NoHsMain, v_MainModIs )
 import DriverPhases
 import Finder
 import HscTypes
@@ -81,7 +82,7 @@ import Maybes         ( expectJust, orElse, mapCatMaybes )
 import DATA_IOREF      ( readIORef )
 
 #ifdef GHCI
-import HscMain         ( hscThing, hscStmt, hscTcExpr )
+import HscMain         ( hscThing, hscStmt, hscTcExpr, hscKcType )
 import TcRnDriver      ( mkExportEnv, getModuleContents )
 import IfaceSyn                ( IfaceDecl )
 import RdrName         ( GlobalRdrEnv, plusGlobalRdrEnv )
@@ -94,6 +95,7 @@ import BasicTypes     ( Fixity )
 import Linker          ( HValue, unload, extendLinkEnv )
 import GHC.Exts                ( unsafeCoerce# )
 import Foreign
+import SrcLoc          ( SrcLoc )
 import Control.Exception as Exception ( Exception, try )
 #endif
 
@@ -218,7 +220,7 @@ cmSetDFlags cm_state dflags
 -- A string may refer to more than one TyThing (eg. a constructor,
 -- and type constructor), so we return a list of all the possible TyThings.
 
-cmInfoThing :: CmState -> String -> IO [(IfaceDecl,Fixity)]
+cmInfoThing :: CmState -> String -> IO [(IfaceDecl,Fixity,SrcLoc)]
 cmInfoThing cmstate id
    = hscThing (cm_hsc cmstate) (cm_ic cmstate) id
 
@@ -316,14 +318,27 @@ cmTypeOfExpr cmstate expr
 
        case maybe_stuff of
           Nothing -> return Nothing
-          Just ty -> return (Just str)
+          Just ty -> return (Just res_str)
             where 
-               str     = showSDocForUser unqual (text expr <+> dcolon <+> ppr tidy_ty)
+               res_str = showSDocForUser unqual (text expr <+> dcolon <+> ppr tidy_ty)
                unqual  = icPrintUnqual (cm_ic cmstate)
                tidy_ty = tidyType emptyTidyEnv ty
 
 
 -----------------------------------------------------------------------------
+-- cmKindOfType: returns a string representing the kind of a type
+
+cmKindOfType :: CmState -> String -> IO (Maybe String)
+cmKindOfType cmstate str
+   = do maybe_stuff <- hscKcType (cm_hsc cmstate) (cm_ic cmstate) str
+       case maybe_stuff of
+          Nothing -> return Nothing
+          Just kind -> return (Just res_str)
+            where 
+               res_str = showSDocForUser unqual (text str <+> dcolon <+> ppr kind)
+               unqual  = icPrintUnqual (cm_ic cmstate)
+
+-----------------------------------------------------------------------------
 -- cmTypeOfName: returns a string representing the type of a name.
 
 cmTypeOfName :: CmState -> Name -> IO (Maybe String)
@@ -443,8 +458,11 @@ cmLoadModules cmstate1 mg2unsorted
         let verb = verbosity dflags
 
        -- Find out if we have a Main module
-        let a_root_is_Main 
-               = any ((=="Main").moduleNameUserString.modSummaryName) 
+       mb_main_mod <- readIORef v_MainModIs
+        let 
+           main_mod = mb_main_mod `orElse` "Main"
+           a_root_is_Main 
+               = any ((==main_mod).moduleNameUserString.modSummaryName) 
                      mg2unsorted
 
         let mg2unsorted_names = map modSummaryName mg2unsorted
@@ -573,7 +591,7 @@ cmLoadModules cmstate1 mg2unsorted
              let do_linking = a_root_is_Main || no_hs_main
              when (ghci_mode == Batch && isJust ofile && not do_linking
                     && verb > 0) $
-                hPutStrLn stderr "Warning: output was redirected with -o, but no output will be generated\nbecause there is no Main module."
+                hPutStrLn stderr ("Warning: output was redirected with -o, but no output will be generated\nbecause there is no " ++ main_mod ++ " module.")
 
              -- link everything together
               linkresult <- link ghci_mode dflags do_linking (hsc_HPT hsc_env3)