[project @ 2005-03-04 14:24:51 by simonmar]

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

diff --git a/ghc/compiler/compMan/CompManager.lhs b/ghc/compiler/compMan/CompManager.lhs
index 87e59fa..829664d 100644 (file)
--- a/ghc/compiler/compMan/CompManager.lhs
+++ b/ghc/compiler/compMan/CompManager.lhs
@@ -60,8 +60,8 @@ import DriverPipeline ( CompResult(..), preprocess, compile, link )
 import HscMain         ( newHscEnv )
 import DriverState     ( v_Output_file, v_NoHsMain, v_MainModIs )
 import DriverPhases    ( HscSource(..), isHsBoot, hscSourceString, isHaskellSrcFilename )
-import Finder          ( findModule, findLinkable, addHomeModuleToFinder, flushFinderCache, 
-                         mkHomeModLocation, FindResult(..), cantFindError )
+import Finder          ( findModule, findLinkable, addHomeModuleToFinder,
+                         flushFinderCache, mkHomeModLocation, FindResult(..), cantFindError )
 import HscTypes                ( ModSummary(..), HomeModInfo(..), ModIface(..), msHsFilePath,
                          HscEnv(..), GhciMode(..), 
                          InteractiveContext(..), emptyInteractiveContext, 
@@ -87,6 +87,7 @@ import FiniteMap
 import DATA_IOREF      ( readIORef )
 
 #ifdef GHCI
+import Finder          ( findPackageModule )
 import HscMain         ( hscGetInfo, GetInfoResult, hscStmt, hscTcExpr, hscKcType )
 import HscTypes                ( TyThing(..), icPrintUnqual, showModMsg )
 import TcRnDriver      ( mkExportEnv, getModuleContents )
@@ -95,13 +96,13 @@ import RdrName              ( GlobalRdrEnv, plusGlobalRdrEnv )
 import Name            ( Name )
 import NameEnv
 import Id              ( idType )
-import Type            ( tidyType )
+import Type            ( tidyType, dropForAlls )
 import VarEnv          ( emptyTidyEnv )
 import Linker          ( HValue, unload, extendLinkEnv )
 import GHC.Exts                ( unsafeCoerce# )
 import Foreign
 import Control.Exception as Exception ( Exception, try )
-import CmdLineOpts     ( DynFlag(..), dopt_unset )
+import CmdLineOpts     ( DynFlag(..), dopt_unset, dopt )
 #endif
 
 import EXCEPTION       ( throwDyn )
@@ -241,7 +242,9 @@ cmSetContext cmstate toplevs exports = do
       hsc_env = cm_hsc cmstate
       hpt     = hsc_HPT hsc_env
 
-  export_env  <- mkExportEnv hsc_env (map mkModule exports)
+  let export_mods = map mkModule exports
+  mapM_ (checkModuleExists (hsc_dflags hsc_env) hpt) export_mods
+  export_env  <- mkExportEnv hsc_env export_mods
   toplev_envs <- mapM (mkTopLevEnv hpt) toplevs
 
   let all_env = foldr plusGlobalRdrEnv export_env toplev_envs
@@ -249,6 +252,17 @@ cmSetContext cmstate toplevs exports = do
                                   ic_exports      = exports,
                                   ic_rn_gbl_env   = all_env } }
 
+checkModuleExists :: DynFlags -> HomePackageTable -> Module -> IO ()
+checkModuleExists dflags hpt mod = 
+  case lookupModuleEnv hpt mod of
+    Just mod_info -> return ()
+    _not_a_home_module -> do
+         res <- findPackageModule dflags mod True
+         case res of
+           Found _ _ -> return  ()
+           err -> let msg = cantFindError dflags mod err in
+                  throwDyn (CmdLineError (showSDoc msg))
+
 mkTopLevEnv :: HomePackageTable -> String -> IO GlobalRdrEnv
 mkTopLevEnv hpt mod
  = case lookupModuleEnv hpt (mkModule mod) of
@@ -395,12 +409,17 @@ cmTypeOfExpr cmstate expr
 
        case maybe_stuff of
           Nothing -> return Nothing
-          Just ty -> return (Just res_str)
+          Just ty -> return (Just (showSDocForUser unqual doc))
             where 
-               res_str = showSDocForUser unqual (text expr <+> dcolon <+> ppr tidy_ty)
+               doc     = text expr <+> dcolon <+> ppr final_ty
                unqual  = icPrintUnqual (cm_ic cmstate)
                tidy_ty = tidyType emptyTidyEnv ty
-
+               dflags  = hsc_dflags (cm_hsc cmstate)
+               -- if -fglasgow-exts is on we show the foralls, otherwise
+               -- we don't.
+               final_ty
+                 | dopt Opt_GlasgowExts dflags = tidy_ty
+                 | otherwise                   = dropForAlls tidy_ty
 
 -----------------------------------------------------------------------------
 -- cmKindOfType: returns a string representing the kind of a type