[project @ 2001-02-27 15:26:04 by simonmar]

- make flushing and :def work again in the interpreter

ghc/compiler/compMan/CompManager.lhs

@@ -6,14 +6,27 @@
 \begin{code}
 module CompManager ( 
     cmInit, 	  -- :: GhciMode -> IO CmState
+
     cmLoadModule, -- :: CmState -> FilePath -> IO (CmState, [String])
+
     cmUnload,	  -- :: CmState -> IO CmState
+
     cmTypeOfName, -- :: CmState -> Name -> IO (Maybe String)
 
     cmSetContext, -- :: CmState -> String -> IO CmState
+
     cmGetContext, -- :: CmState -> IO String
+
 #ifdef GHCI
     cmRunStmt,	  --  :: CmState -> DynFlags -> String -> IO (CmState, [Name])
+
+    cmTypeOfExpr, --  :: CmState -> DynFlags -> String
+		  --  -> IO (CmState, Maybe String)
+
+    cmTypeOfName, -- :: CmState -> Name -> IO (Maybe String)
+
+    cmCompileExpr,-- :: CmState -> DynFlags -> String 
+		  -- -> IO (CmState, Maybe HValue)#endif
 #endif
     CmState, emptyCmState  -- abstract
   )
@@ -165,19 +178,24 @@ moduleNameToModule mn
 -- cmRunStmt:  Run a statement/expr.
 
 #ifdef GHCI
-cmRunStmt :: CmState -> DynFlags -> String -> IO (CmState, [Name])
+cmRunStmt :: CmState -> DynFlags -> String
+	-> IO (CmState,			-- new state
+	       [Name])			-- names bound by this evaluation
 cmRunStmt cmstate dflags expr
    = do 
-	let icontext = ic cmstate
-	    InteractiveContext { 
+	let InteractiveContext { 
 	       	ic_rn_env = rn_env, 
 	       	ic_type_env = type_env,
 	       	ic_module   = this_mod } = icontext
 
-        (new_pcs, maybe_stuff) <- hscStmt dflags hst hit pcs icontext expr
+        (new_pcs, maybe_stuff) 
+	    <- hscStmt dflags hst hit pcs icontext expr
+
         case maybe_stuff of
 	   Nothing -> return (cmstate{ pcs=new_pcs }, [])
 	   Just (ids, bcos) -> do
+
+		-- update the interactive context
 	        let 
 		    new_rn_env   = extendLocalRdrEnv rn_env (map idName ids)
 
@@ -190,20 +208,40 @@ cmRunStmt cmstate dflags expr
 		    new_ic = icontext { ic_rn_env   = new_rn_env, 
 			  	  	ic_type_env = new_type_env }
 
+		-- link it
 		hval <- linkExpr pls bcos
-		hvals <- unsafeCoerce# hval :: IO [HValue]
+
+		-- run it!
+		let thing_to_run = unsafeCoerce# hval :: IO [HValue]
+		hvals <- thing_to_run
+
+		-- get the newly bound things, and bind them
 		let names = map idName ids
 		new_pls <- updateClosureEnv pls (zip names hvals)
-	        return (cmstate{ pcs=new_pcs, pls=new_pls, ic=new_ic }, names)
 
-   -- ToDo: check that the module we passed in is sane/exists?
+	        return (cmstate{ pcs=new_pcs, pls=new_pls, ic=new_ic }, names)
    where
-       CmState{ hst=hst, hit=hit, pcs=pcs, pls=pls } = cmstate
+       CmState{ hst=hst, hit=hit, pcs=pcs, pls=pls, ic=icontext } = cmstate
+#endif
+
+-----------------------------------------------------------------------------
+-- cmTypeOfExpr: returns a string representing the type of an expression
+
+#ifdef GHCI
+cmTypeOfExpr :: CmState -> DynFlags -> String -> IO (CmState, Maybe String)
+cmTypeOfExpr cmstate dflags expr
+  = do (new_cmstate, names)
+	   <- cmRunStmt cmstate dflags ("let __cmTypeOfExpr=" ++ expr)
+       case names of
+	 [name] -> do maybe_tystr <- cmTypeOfName new_cmstate name
+		      return (new_cmstate, maybe_tystr)
+	 _other -> pprPanic "cmTypeOfExpr" (ppr names)
 #endif
 
 -----------------------------------------------------------------------------
--- cmTypeOf: returns a string representing the type of a name.
+-- cmTypeOfName: returns a string representing the type of a name.
 
+#ifdef GHCI
 cmTypeOfName :: CmState -> Name -> IO (Maybe String)
 cmTypeOfName CmState{ hit=hit, pcs=pcs, ic=ic } name
  = case lookupNameEnv (ic_type_env ic) name of
@@ -219,6 +257,42 @@ cmTypeOfName CmState{ hit=hit, pcs=pcs, ic=ic } name
 	   in return (Just str)
 
 	_ -> panic "cmTypeOfName"
+#endif
+
+-----------------------------------------------------------------------------
+-- cmCompileExpr: compile an expression and deliver an HValue
+
+#ifdef GHCI
+cmCompileExpr :: CmState -> DynFlags -> String -> IO (CmState, Maybe HValue)
+cmCompileExpr cmstate dflags expr
+   = do 
+	let InteractiveContext { 
+	       	ic_rn_env = rn_env, 
+	       	ic_type_env = type_env,
+	       	ic_module   = this_mod } = icontext
+
+        (new_pcs, maybe_stuff) 
+	    <- hscStmt dflags hst hit pcs icontext 
+		  ("let __cmCompileExpr="++expr)
+
+        case maybe_stuff of
+	   Nothing -> return (cmstate{ pcs=new_pcs }, Nothing)
+	   Just (ids, bcos) -> do
+
+		-- link it
+		hval <- linkExpr pls bcos
+
+		-- run it!
+		let thing_to_run = unsafeCoerce# hval :: IO [HValue]
+		hvals <- thing_to_run
+
+		case (ids,hvals) of
+		  ([id],[hv]) -> return (cmstate{ pcs=new_pcs }, Just hv)
+		  _ -> panic "cmCompileExpr"
+
+   where
+       CmState{ hst=hst, hit=hit, pcs=pcs, pls=pls, ic=icontext } = cmstate
+#endif
 
 -----------------------------------------------------------------------------
 -- cmInfo: return "info" about an expression.  The info might be:

ghc/compiler/ghci/InteractiveUI.hs

 -----------------------------------------------------------------------------
--- $Id: InteractiveUI.hs,v 1.52 2001/02/26 15:06:58 simonmar Exp $
+-- $Id: InteractiveUI.hs,v 1.53 2001/02/27 15:26:04 simonmar Exp $
 --
 -- GHC Interactive User Interface
 --
@@ -60,7 +60,7 @@ builtin_commands :: [(String, String -> GHCi Bool)]
 builtin_commands = [
   ("add",	keepGoing addModule),
   ("cd",    	keepGoing changeDirectory),
---  ("def",	keepGoing defineMacro),
+  ("def",	keepGoing defineMacro),
   ("help",	keepGoing help),
   ("?",		keepGoing help),
   ("load",	keepGoing loadModule),
@@ -124,20 +124,18 @@ interactiveUI cmstate mod cmdline_libs = do
 
    dflags <- getDynFlags
 
-{-
-   (cmstate, _) <- cmRunStmt cmstate dflags False prel 
-		  	"PrelHandle.hFlush PrelHandle.stdout"
-   case maybe_stuff of
-	Nothing -> return ()
-	Just (hv,_,_) -> writeIORef flush_stdout hv
-   
-   (cmstate, _) <- cmGetExpr cmstate dflags False prel 
-		  		"PrelHandle.hFlush PrelHandle.stdout"
-   case maybe_stuff of
-	Nothing -> return ()
-	Just (hv,_,_) -> writeIORef flush_stderr hv
--}
-   
+   (cmstate, maybe_hval) 
+	<- cmCompileExpr cmstate dflags "IO.hFlush PrelHandle.stderr"
+   case maybe_hval of
+	Just hval -> writeIORef flush_stderr (unsafeCoerce# hval :: IO ())
+	_ -> panic "interactiveUI:stderr"
+
+   (cmstate, maybe_hval) 
+	<- cmCompileExpr cmstate dflags "IO.hFlush PrelHandle.stdout"
+   case maybe_hval of
+	Just hval -> writeIORef flush_stdout (unsafeCoerce# hval :: IO ())
+	_ -> panic "interactiveUI:stdout"
+
    (unGHCi runGHCi) GHCiState{ target = mod,
 			       cmstate = cmstate,
 			       options = [ShowTiming] }
@@ -278,11 +276,11 @@ showTypeOfName cmstate n
 
 flushEverything :: GHCi ()
 flushEverything
-   = io $ {-do flush_so <- readIORef flush_stdout
-     	     cmRunExpr flush_so
+   = io $ do flush_so <- readIORef flush_stdout
+     	     flush_so
      	     flush_se <- readIORef flush_stdout
-     	     cmRunExpr flush_se
-	  -} (return ())
+     	     flush_se
+             return ()
 
 specialCommand :: String -> GHCi Bool
 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
@@ -322,7 +320,6 @@ setContext str
 changeDirectory :: String -> GHCi ()
 changeDirectory d = io (setCurrentDirectory d)
 
-{-
 defineMacro :: String -> GHCi ()
 defineMacro s = do
   let (macro_name, definition) = break isSpace s
@@ -332,7 +329,7 @@ defineMacro s = do
 	else do
   if (macro_name `elem` map fst cmds) 
 	then throwDyn (OtherError 
-		("command `" ++ macro_name ++ "' already defined"))
+		("command `" ++ macro_name ++ "' is already defined"))
 	else do
 
   -- give the expression a type signature, so we can be sure we're getting
@@ -342,15 +339,17 @@ defineMacro s = do
   -- compile the expression
   st <- getGHCiState
   dflags <- io (getDynFlags)
-  (new_cmstate, maybe_stuff) <- 
-      	 io (cmGetExpr (cmstate st) dflags new_expr)
+  (new_cmstate, maybe_hv) <- io (cmCompileExpr (cmstate st) dflags new_expr)
   setGHCiState st{cmstate = new_cmstate}
-  case maybe_stuff of
-     Nothing -> return ()
-     Just (hv, unqual, ty) 
-	-> io (writeIORef commands 
-		 ((macro_name, keepGoing (runMacro hv)) : cmds))
--}
+  case maybe_hv of
+	Nothing -> return ()
+	Just hv -> 
+	  do funs <- io (unsafeCoerce# hv :: IO [HValue])
+	     case funs of
+		[fun] -> io (writeIORef commands 	
+		 		((macro_name, keepGoing (runMacro fun))
+				 : cmds))
+		_ -> throwDyn (OtherError "defineMacro: bizarre")
 
 runMacro :: HValue{-String -> IO String-} -> String -> GHCi ()
 runMacro fun s = do
@@ -414,15 +413,11 @@ typeOfExpr :: String -> GHCi ()
 typeOfExpr str 
   = do st <- getGHCiState
        dflags <- io (getDynFlags)
-       (new_cmstate, names) 
-	  <- io (cmRunStmt (cmstate st) dflags ("let it=" ++ str))
+       (new_cmstate, maybe_tystr) <- io (cmTypeOfExpr (cmstate st) dflags str)
        setGHCiState st{cmstate = new_cmstate}
-       case names of
-	 [name] -> do maybe_tystr <- io (cmTypeOfName new_cmstate name)
-		      case maybe_tystr of
-			Nothing    -> return ()
-			Just tystr -> io (putStrLn (":: " ++  tystr))
-	 _other -> pprPanic "typeOfExpr" (ppr names)
+       case maybe_tystr of
+	  Nothing    -> return ()
+	  Just tystr -> io (putStrLn tystr)
 
 quit :: String -> GHCi Bool
 quit _ = return True
@@ -540,8 +535,8 @@ data GHCiOption
 	| RevertCAFs		-- revert CAFs after every evaluation
 	deriving Eq
 
-GLOBAL_VAR(flush_stdout, error "no flush_stdout", HValue)
-GLOBAL_VAR(flush_stderr, error "no flush_stdout", HValue)
+GLOBAL_VAR(flush_stdout, error "no flush_stdout", IO ())
+GLOBAL_VAR(flush_stderr, error "no flush_stdout", IO ())
 
 newtype GHCi a = GHCi { unGHCi :: GHCiState -> IO (GHCiState, a) }