[project @ 2002-01-23 16:50:46 by simonmar]

- Implement an alternative :module syntax so we can play around with it.

- Implement ':show bindings' and ':show modules'

- Fix a bug whereby doing :info on a local binding would cause a panic
  (this needs to be merged to STABLE - the change is part of the patch
  to HscMain).

- Some cleanups in InteractiveUI.hs

ghc/compiler/compMan/CompManager.lhs

@@ -25,7 +25,8 @@ module CompManager (
     cmSetContext,  -- :: CmState -> DynFlags -> [String] -> [String] -> IO CmState
     cmGetContext,  -- :: CmState -> IO ([String],[String])
 
-    cmInfoThing,   -- :: CmState -> DynFlags -> String -> IO (Maybe TyThing)
+    cmInfoThing,   -- :: CmState -> DynFlags -> String
+		   --	-> IO (CmState, [(TyThing,Fixity)])
 
     CmRunResult(..),
     cmRunStmt,	   -- :: CmState -> DynFlags -> String
@@ -39,12 +40,24 @@ module CompManager (
     HValue,
     cmCompileExpr, -- :: CmState -> DynFlags -> String 
 		   --	-> IO (CmState, Maybe HValue)
+
+    cmGetModuleGraph,		-- :: CmState -> ModuleGraph
+    cmGetLinkables,		-- :: CmState -> [Linkable]
+
+    cmGetBindings, 	-- :: CmState -> [TyThing]
+    cmGetPrintUnqual,	-- :: CmState -> PrintUnqualified
 #endif
+
+    -- utils
+    showModMsg,		-- 
   )
 where
 
 #include "HsVersions.h"
 
+import MkIface --tmp
+import HsSyn 	-- tmp
+
 import CmLink
 import CmTypes
 import DriverPipeline
@@ -59,7 +72,7 @@ import HscMain		( initPersistentCompilerState )
 #endif
 import HscTypes
 import Name		( Name, NamedThing(..), nameRdrName, nameModule,
-			  isHomePackageName )
+			  isHomePackageName, isGlobalName )
 import Rename		( mkGlobalContext )
 import RdrName		( emptyRdrEnv )
 import Module
@@ -155,6 +168,15 @@ emptyMG = []
 cmInit :: GhciMode -> IO CmState
 cmInit mode = emptyCmState mode
 
+-----------------------------------------------------------------------------
+-- Grab information from the CmState
+
+cmGetModuleGraph        = mg
+cmGetLinkables          = ui
+
+cmGetBindings cmstate = nameEnvElts (ic_type_env (ic cmstate))
+cmGetPrintUnqual cmstate = ic_print_unqual (ic cmstate)
+
 -----------------------------------------------------------------------------
 -- Setting the context doesn't throw away any bindings; the bindings
 -- we've built up in the InteractiveContext simply move to the new
@@ -219,19 +241,18 @@ cmModuleIsInterpreted cmstate str
 -- and type constructor), so we return a list of all the possible TyThings.
 
 #ifdef GHCI
-cmInfoThing :: CmState -> DynFlags -> String 
-	-> IO (CmState, PrintUnqualified, [(TyThing,Fixity)])
+cmInfoThing :: CmState -> DynFlags -> String -> IO (CmState, [(TyThing,Fixity)])
 cmInfoThing cmstate dflags id
    = do (new_pcs, things) <- hscThing dflags hst hit pcs icontext id
 	let pairs = map (\x -> (x, getFixity new_pcs (getName x))) things
-	return (cmstate{ pcs=new_pcs }, unqual, pairs)
-   where 
+	return (cmstate{ pcs=new_pcs }, pairs)
+   where
      CmState{ hst=hst, hit=hit, pcs=pcs, pls=pls, ic=icontext } = cmstate
-     unqual = ic_print_unqual icontext
 
      getFixity :: PersistentCompilerState -> Name -> Fixity
      getFixity pcs name
-	| Just iface  <- lookupModuleEnv iface_table (nameModule name),
+	| isGlobalName name,
+	  Just iface  <- lookupModuleEnv iface_table (nameModule name),
 	  Just fixity <- lookupNameEnv (mi_fixities iface) name
 	  = fixity
 	| otherwise

ghc/compiler/ghci/InteractiveUI.hs

 {-# OPTIONS -#include "Linker.h" -#include "SchedAPI.h" #-}
 -----------------------------------------------------------------------------
--- $Id: InteractiveUI.hs,v 1.108 2002/01/22 16:50:29 simonmar Exp $
+-- $Id: InteractiveUI.hs,v 1.109 2002/01/23 16:50:49 simonmar Exp $
 --
 -- GHC Interactive User Interface
 --
@@ -13,8 +13,12 @@ module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where
 #include "HsVersions.h"
 
 import Packages
+
 import CompManager
-import HscTypes		( TyThing(..) )
+import CmTypes		( Linkable, isObjectLinkable, ModSummary(..) )
+import CmLink		( findModuleLinkable_maybe )
+
+import HscTypes		( TyThing(..), showModMsg, InteractiveContext(..) )
 import MkIface		( ifaceTyThing )
 import DriverFlags
 import DriverState
@@ -28,13 +32,15 @@ import Class		( className )
 import TyCon		( tyConName, tyConClass_maybe, isPrimTyCon )
 import FieldLabel	( fieldLabelTyCon )
 import SrcLoc		( isGoodSrcLoc )
+import Module		( moduleName )
+import NameEnv		( nameEnvElts )
 import Name		( Name, isHomePackageName, nameSrcLoc, nameOccName,
 			  NamedThing(..) )
 import OccName		( isSymOcc )
 import BasicTypes	( defaultFixity )
 import Outputable
-import CmdLineOpts	( DynFlag(..), getDynFlags, saveDynFlags, restoreDynFlags, 
-			  dopt_unset )
+import CmdLineOpts	( DynFlag(..), getDynFlags, saveDynFlags,
+			  restoreDynFlags, dopt_unset )
 import Panic		( GhcException(..), showGhcException )
 import Config
 
@@ -58,7 +64,7 @@ import CPUTime
 import Directory
 import IO
 import Char
-import Monad 		( when, join )
+import Monad
 
 import PrelGHC 		( unsafeCoerce# )
 import Foreign		( nullPtr )
@@ -83,11 +89,11 @@ builtin_commands = [
   ("help",	keepGoing help),
   ("?",		keepGoing help),
   ("info",      keepGoing info),
-  ("import",    keepGoing importModules),
   ("load",	keepGoing loadModule),
   ("module",	keepGoing setContext),
   ("reload",	keepGoing reloadModule),
   ("set",	keepGoing setCmd),
+  ("show",	keepGoing showCmd),
   ("type",	keepGoing typeOfExpr),
   ("unset",	keepGoing unsetOptions),
   ("undef",     keepGoing undefineMacro),
@@ -111,11 +117,16 @@ helpText = "\
 \   :load <filename> ...   load module(s) and their dependents\n\ 
 \   :module <mod>	   set the context for expression evaluation to <mod>\n\ 
 \   :reload		   reload the current module set\n\ 
+\\n\ 
 \   :set <option> ...	   set options\n\ 
 \   :set args <arg> ...	   set the arguments returned by System.getArgs\n\ 
 \   :set prog <progname>   set the value returned by System.getProgName\n\ 
-\   :undef <cmd> 	   undefine user-defined command :<cmd>\n\ 
+\\n\ 
+\   :show modules	   show the currently loaded modules\n\ 
+\   :show bindings	   show the current bindings made at the prompt\n\ 
+\\n\ 
 \   :type <expr>	   show the type of <expr>\n\ 
+\   :undef <cmd> 	   undefine user-defined command :<cmd>\n\ 
 \   :unset <option> ...	   unset options\n\ 
 \   :quit		   exit GHCi\n\ 
 \   :!<command>		   run the shell command <command>\n\ 
@@ -271,8 +282,8 @@ checkPerms name =
 
 fileLoop :: Handle -> Bool -> GHCi ()
 fileLoop hdl prompt = do
-   st <- getGHCiState
-   (mod,imports) <- io (cmGetContext (cmstate st))
+   cmstate <- getCmState
+   (mod,imports) <- io (cmGetContext cmstate)
    when prompt (io (putStr (mkPrompt mod imports)))
    l <- io (IO.try (hGetLine hdl))
    case l of
@@ -287,24 +298,19 @@ fileLoop hdl prompt = do
 stringLoop :: [String] -> GHCi ()
 stringLoop [] = return ()
 stringLoop (s:ss) = do
-   st <- getGHCiState
    case remove_spaces s of
 	"" -> stringLoop ss
 	l  -> do quit <- runCommand l
                  if quit then return () else stringLoop ss
 
 mkPrompt toplevs exports
-   =  concat (intersperse "," toplevs)
-   ++ (if not (null exports) 
-	then "[" ++ concat (intersperse "," exports) ++ "]" 
-	else "")
-   ++ "> "
+   = concat (intersperse " " (toplevs ++ map ('*':) exports)) ++ "> "
 
 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
 readlineLoop :: GHCi ()
 readlineLoop = do
-   st <- getGHCiState
-   (mod,imports) <- io (cmGetContext (cmstate st))
+   cmstate <- getCmState
+   (mod,imports) <- io (cmGetContext cmstate)
    io yield
    l <- io (readline (mkPrompt mod imports))
    case l of
@@ -364,8 +370,8 @@ runStmt stmt
 -- possibly print the type and revert CAFs after evaluating an expression
 finishEvalExpr names
  = do b <- isOptionSet ShowType
-      st <- getGHCiState
-      when b (mapM_ (showTypeOfName (cmstate st)) names)
+      cmstate <- getCmState
+      when b (mapM_ (showTypeOfName cmstate) names)
 
       b <- isOptionSet RevertCAFs
       io (when b revertCAFs)
@@ -411,17 +417,19 @@ info :: String -> GHCi ()
 info "" = throwDyn (CmdLineError "syntax: `:i <thing-you-want-info-about>'")
 info s = do
   let names = words s
-  state <- getGHCiState
+  init_cms <- getCmState
   dflags <- io getDynFlags
   let 
     infoThings cms [] = return cms
     infoThings cms (name:names) = do
-      (cms, unqual, stuff) <- io (cmInfoThing cms dflags name)
+      (cms, stuff) <- io (cmInfoThing cms dflags name)
       io (putStrLn (showSDocForUser unqual (
 	    vcat (intersperse (text "") (map showThing stuff))))
          )
       infoThings cms names
 
+    unqual = cmGetPrintUnqual init_cms
+
     showThing (ty_thing, fixity) 
 	= vcat [ text "-- " <> showTyThing ty_thing, 
 		 showFixity fixity (getName ty_thing),
@@ -461,8 +469,8 @@ info s = do
 	= empty
 	where loc = nameSrcLoc name
 
-  cms <- infoThings (cmstate state) names
-  setGHCiState state{ cmstate = cms }
+  cms <- infoThings init_cms names
+  setCmState cms
   return ()
 
 addModule :: String -> GHCi ()
@@ -501,10 +509,10 @@ defineMacro s = do
   let new_expr = '(' : definition ++ ") :: String -> IO String"
 
   -- compile the expression
-  st <- getGHCiState
+  cms <- getCmState
   dflags <- io getDynFlags
-  (new_cmstate, maybe_hv) <- io (cmCompileExpr (cmstate st) dflags new_expr)
-  setGHCiState st{cmstate = new_cmstate}
+  (new_cmstate, maybe_hv) <- io (cmCompileExpr cms dflags new_expr)
+  setCmState new_cmstate
   case maybe_hv of
      Nothing -> return ()
      Just hv -> io (writeIORef commands --
@@ -529,10 +537,6 @@ undefineMacro macro_name = do
   io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
 
 
-importModules :: String -> GHCi ()
-importModules str = return ()
-
-
 loadModule :: String -> GHCi ()
 loadModule str = timeIt (loadModule' str)
 
@@ -578,7 +582,10 @@ reloadModule "" = do
 reloadModule _ = noArgs ":reload"
 
 setContextAfterLoad [] = setContext prel
-setContextAfterLoad (m:_) = setContext m
+setContextAfterLoad (m:_) = do
+  cmstate <- getCmState
+  b <- io (cmModuleIsInterpreted cmstate m)
+  if b then setContext m else setContext ('*':m)
 
 modulesLoadedMsg ok mods = do
   let mod_commas 
@@ -594,10 +601,10 @@ modulesLoadedMsg ok mods = do
 
 typeOfExpr :: String -> GHCi ()
 typeOfExpr str 
-  = do st <- getGHCiState
+  = do cms <- getCmState
        dflags <- io getDynFlags
-       (new_cmstate, maybe_tystr) <- io (cmTypeOfExpr (cmstate st) dflags str)
-       setGHCiState st{cmstate = new_cmstate}
+       (new_cmstate, maybe_tystr) <- io (cmTypeOfExpr cms dflags str)
+       setCmState new_cmstate
        case maybe_tystr of
 	  Nothing    -> return ()
 	  Just tystr -> io (putStrLn tystr)
@@ -612,57 +619,63 @@ shellEscape str = io (system str >> return False)
 -- Setting the module context
 
 setContext str
- | all sensible  mods = newContext mods	-- default is to set the empty context
- | all plusminus mods = adjustContext mods
- | otherwise
-   = throwDyn (CmdLineError "syntax:  :module M1 .. Mn | :module [+/-]M1 ... [+/-]Mn")
- where
-    mods = words str
-
-    sensible (c:cs) = isUpper c && all isAlphaNumEx cs
+  | all sensible mods = fn mods
+  | otherwise = throwDyn (CmdLineError "syntax:  :module [+/-] [*]M1 ... [*]Mn")
+  where
+    (fn, mods) = case str of 
+			'+':stuff -> (addToContext,      words stuff)
+			'-':stuff -> (removeFromContext, words stuff)
+			stuff     -> (newContext,        words stuff) 
+
+    sensible ('*':c:cs) = isUpper c && all isAlphaNumEx cs
+    sensible (c:cs)     = isUpper c && all isAlphaNumEx cs
     isAlphaNumEx c = isAlphaNum c || c == '_'
 
-    plusminus ('-':mod) = sensible mod
-    plusminus ('+':mod) = sensible mod
-    plusminus _ = False
-
 newContext mods = do
-  state@GHCiState{cmstate=cmstate} <- getGHCiState
+  cms <- getCmState
   dflags <- io getDynFlags
-
-  let separate [] as bs = return (as,bs)
-      separate (m:ms) as bs = do 
-	 b <- io (cmModuleIsInterpreted cmstate m)
- 	 if b then separate ms (m:as) bs
-	      else separate ms as (m:bs)
-				
-  (as,bs) <- separate mods [] []
+  (as,bs) <- separate cms mods [] []
   let bs' = if null as && prel `notElem` bs then prel:bs else bs
-  cmstate' <- io (cmSetContext cmstate dflags as bs')
-  setGHCiState state{cmstate=cmstate'}
-
+  cms' <- io (cmSetContext cms dflags as bs')
+  setCmState cms'
+
+separate cmstate []           as bs = return (as,bs)
+separate cmstate (('*':m):ms) as bs = separate cmstate ms as (m:bs)
+separate cmstate (m:ms)       as bs = do 
+   b <- io (cmModuleIsInterpreted cmstate m)
+   if b then separate cmstate ms (m:as) bs
+   	else throwDyn (CmdLineError ("module `" ++ m ++ "' is not interpreted"))
+	
 prel = "Prelude"
 
-adjustContext mods = do
-  state@GHCiState{cmstate=cmstate} <- getGHCiState
+
+addToContext mods = do
+  cms <- getCmState
   dflags <- io getDynFlags
+  (as,bs) <- io (cmGetContext cms)
 
-  let adjust [] as bs = return (as,bs)
-      adjust (('-':m) : ms) as bs
-	| m `elem` as  = adjust ms (delete m as) bs
-	| m `elem` bs  = adjust ms as (delete m bs)
- 	| otherwise = throwDyn (CmdLineError ("module `" ++ m ++ "' is not currently in scope"))
-      adjust (('+':m) : ms) as bs
-	| m `elem` as || m `elem` bs = adjust ms as bs -- continue silently
-	| otherwise = do b <- io (cmModuleIsInterpreted cmstate m)
-			 if b then adjust ms (m:as) bs
-			      else adjust ms as (m:bs)
-
-  (as,bs) <- io (cmGetContext cmstate)
-  (as,bs) <- adjust mods as bs
-  let bs' = if null as && prel `notElem` bs then prel:bs else bs
-  cmstate' <- io (cmSetContext cmstate dflags as bs')
-  setGHCiState state{cmstate=cmstate'}
+  (as',bs') <- separate cms mods [] []
+
+  let as_to_add = as' \\ (as ++ bs)
+      bs_to_add = bs' \\ (as ++ bs)
+
+  cms' <- io (cmSetContext cms dflags 
+			(as ++ as_to_add) (bs ++ bs_to_add))
+  setCmState cms'
+
+
+removeFromContext mods = do
+  cms <- getCmState
+  dflags <- io getDynFlags
+  (as,bs) <- io (cmGetContext cms)
+
+  (as_to_remove,bs_to_remove) <- separate cms mods [] []
+
+  let as' = as \\ (as_to_remove ++ bs_to_remove)
+      bs' = bs \\ (as_to_remove ++ bs_to_remove)
+
+  cms' <- io (cmSetContext cms dflags as' bs')
+  setCmState cms'
 
 ----------------------------------------------------------------------------
 -- Code for `:set'
@@ -784,6 +797,38 @@ newPackages new_pkgs = do
     new_pkg_info <- getPackageDetails new_pkgs
     mapM_ linkPackage (reverse new_pkg_info)
 
+-----------------------------------------------------------------------------
+-- code for `:show'
+
+showCmd str =
+  case words str of
+	["modules" ] -> showModules
+	["bindings"] -> showBindings
+	_ -> throwDyn (CmdLineError "syntax:  :show [modules|bindings]")
+
+showModules = do
+  cms <- getCmState
+  let mg = cmGetModuleGraph cms
+      ls = cmGetLinkables   cms
+      maybe_linkables = map (findModuleLinkable_maybe ls) 
+				(map (moduleName.ms_mod) mg)
+  zipWithM showModule mg maybe_linkables
+  return ()
+
+showModule :: ModSummary -> Maybe Linkable -> GHCi ()
+showModule m (Just l) = do
+  io (putStrLn (showModMsg (isObjectLinkable l) (ms_mod m) (ms_location m)))
+showModule _ Nothing = panic "missing linkable"
+
+showBindings = do
+  cms <- getCmState
+  let
+	unqual = cmGetPrintUnqual cms
+	showBinding b = putStrLn (showSDocForUser unqual (ppr (ifaceTyThing b)))
+
+  io (mapM showBinding (cmGetBindings cms))
+  return ()
+
 -----------------------------------------------------------------------------
 -- GHCi monad
 
@@ -821,6 +866,10 @@ ghciHandleDyn h (GHCi m) = GHCi $ \s ->
 getGHCiState   = GHCi $ \r -> readIORef r
 setGHCiState s = GHCi $ \r -> writeIORef r s
 
+-- for convenience...
+getCmState = getGHCiState >>= return . cmstate
+setCmState cms = do s <- getGHCiState; setGHCiState s{cmstate=cms}
+
 isOptionSet :: GHCiOption -> GHCi Bool
 isOptionSet opt
  = do st <- getGHCiState

ghc/compiler/main/HscMain.lhs

@@ -26,7 +26,8 @@ import OccName          ( dataName, tcClsName,
 import Type		( Type )
 import Id		( Id, idName, setGlobalIdDetails )
 import IdInfo		( GlobalIdDetails(VanillaGlobal) )
-import HscTypes		( InteractiveContext(..) )
+import Name		( isLocalName )
+import NameEnv		( lookupNameEnv )
 import PrelNames	( iNTERACTIVE )
 import StringBuffer	( stringToStringBuffer )
 import FastString       ( mkFastString )
@@ -171,7 +172,7 @@ hscNoRecomp ghci_mode dflags have_object
  = do {
       when (verbosity dflags >= 1) $
 		hPutStrLn stderr ("Skipping  " ++ 
-			compMsg have_object mod location);
+			showModMsg have_object mod location);
 
       -- CLOSURE
       (pcs_cl, closure_errs, cl_hs_decls) 
@@ -191,16 +192,6 @@ hscNoRecomp ghci_mode dflags have_object
       return (HscNoRecomp pcs_tc new_details old_iface)
       }}}
 
-compMsg use_object mod location =
-    mod_str ++ replicate (max 0 (16 - length mod_str)) ' '
-    ++" ( " ++ unJust "hscRecomp" (ml_hs_file location) ++ ", "
-    ++ (if use_object
-	  then unJust "hscRecomp" (ml_obj_file location)
-	  else "interpreted")
-    ++ " )"
- where mod_str = moduleUserString mod
-
-
 hscRecomp ghci_mode dflags have_object 
 	  mod location maybe_checked_iface hst hit pcs_ch
  = do	{
@@ -210,7 +201,7 @@ hscRecomp ghci_mode dflags have_object
 
       	; when (ghci_mode /= OneShot && verbosity dflags >= 1) $
 		hPutStrLn stderr ("Compiling " ++ 
-			compMsg (not toInterp) mod location);
+			showModMsg (not toInterp) mod location);
 
  	    -------------------
  	    -- PARSE
@@ -625,7 +616,7 @@ hscThing -- like hscStmt, but deals with a single identifier
   -> IO ( PersistentCompilerState,
 	  [TyThing] )
 
-hscThing dflags hst hit pcs0 icontext str
+hscThing dflags hst hit pcs0 ic str
    = do maybe_rdr_name <- myParseIdentifier dflags str
 	case maybe_rdr_name of {
 	  Nothing -> return (pcs0, []);
@@ -643,7 +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 icontext rdr_names
+	   renameRdrName dflags hit hst pcs0 ic rdr_names
 
 	case maybe_rn_result of {
 	     Nothing -> return (pcs, []);
@@ -655,7 +646,11 @@ hscThing dflags hst hit pcs0 icontext str
 	case maybe_pcs of {
 	     Nothing -> return (pcs, []);
 	     Just pcs ->
-		let maybe_ty_things = map (lookupType hst (pcs_PTE pcs)) names
+		let do_lookup n
+			| isLocalName n = lookupNameEnv (ic_type_env ic) n
+			| otherwise     = lookupType hst (pcs_PTE pcs) n
+		
+		    maybe_ty_things = map do_lookup names
 		in
 		return (pcs, catMaybes maybe_ty_things) }
         }}}

ghc/compiler/main/HscTypes.lhs

@@ -7,7 +7,7 @@
 module HscTypes ( 
 	GhciMode(..),
 
-	ModuleLocation(..),
+	ModuleLocation(..), showModMsg,
 
 	ModDetails(..),	ModIface(..), 
 	HomeSymbolTable, emptySymbolTable,
@@ -59,7 +59,8 @@ import Name		( Name, NamedThing, getName, nameOccName, nameModule, nameSrcLoc )
 import NameEnv
 import OccName		( OccName )
 import Module		( Module, ModuleName, ModuleEnv,
-			  lookupModuleEnv, lookupModuleEnvByName, emptyModuleEnv
+			  lookupModuleEnv, lookupModuleEnvByName, 
+			  emptyModuleEnv, moduleUserString
 			)
 import InstEnv		( InstEnv, ClsInstEnv, DFunId )
 import Rules		( RuleBase )
@@ -82,7 +83,7 @@ import Bag		( Bag )
 import Maybes		( seqMaybe, orElse )
 import Outputable
 import SrcLoc		( SrcLoc, isGoodSrcLoc )
-import Util		( thenCmp, sortLt )
+import Util		( thenCmp, sortLt, unJust )
 import UniqSupply	( UniqSupply )
 \end{code}
 
@@ -116,6 +117,18 @@ data ModuleLocation
 
 instance Outputable ModuleLocation where
    ppr = text . show
+
+-- Probably doesn't really belong here, but used in HscMain and InteractiveUI.
+
+showModMsg :: Bool -> Module -> ModuleLocation -> String
+showModMsg use_object mod location =
+    mod_str ++ replicate (max 0 (16 - length mod_str)) ' '
+    ++" ( " ++ unJust "showModMsg" (ml_hs_file location) ++ ", "
+    ++ (if use_object
+	  then unJust "showModMsg" (ml_obj_file location)
+	  else "interpreted")
+    ++ " )"
+ where mod_str = moduleUserString mod
 \end{code}
 
 For a module in another package, the hs_file and obj_file