From: simonmar <unknown>
Date: Sun, 11 Feb 2001 14:33:27 +0000 (+0000)
Subject: [project @ 2001-02-11 14:33:27 by simonmar]
X-Git-Tag: Approximately_9120_patches~2687
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=3be030c261124cfa5934b6a65e0c9fe097696cd7;p=ghc-hetmet.git

[project @ 2001-02-11 14:33:27 by simonmar]
Experimental implementation of a bizarre, and probably not well
thought out, idea I had last week: making GHCi extensible, in Haskell.

Two new commands:

	:def <name> <expr>
	:undef <name>

:def defines a new command, :<name>, with the semantics that

	(<expr> :: String -> IO String)

is run, passed the argument to :<name>, and the resulting string is
fed back through GHCi's command-line interpreter (\n may be used to
separate commands in the returned string).  <expr> is compiled once,
when the :def command is entered.

Simple example:

Prelude> :def date (\s -> Time.getClockTime >>= print >> return "")
Prelude> :date
Sun Feb 11 13:44:28 GMT 2001
Prelude>

Implementing built-in GHCi commands with macros:

Prelude> :def mycd (\s -> Directory.setCurrentDirectory s >> return "")
Prelude> :mycd /home/simonm
Prelude> :!ls
...

Define new functions from the command-line:

Prelude> :! echo "module Tmp where" >/tmp/Tmp.hs
Prelude> :def let (\s -> return (":! echo " ++ s ++ ">> /tmp/Tmp.hs\n:load /tmp/Tmp.hs"))
Prelude> :let x = 42
Compiling Tmp ... compilation IS required
Ok, modules loaded: Tmp.
Tmp> x
42
Tmp> :let y = x
Compiling Tmp ... compilation IS required
Ok, modules loaded: Tmp.
Tmp> y
42
Tmp>

I'm sure the possibilities are endless...
---

diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs
index a6a07f3..6416e23 100644
--- a/ghc/compiler/ghci/InteractiveUI.hs
+++ b/ghc/compiler/ghci/InteractiveUI.hs
@@ -1,5 +1,5 @@
 -----------------------------------------------------------------------------
--- $Id: InteractiveUI.hs,v 1.40 2001/02/09 17:29:59 simonmar Exp $
+-- $Id: InteractiveUI.hs,v 1.41 2001/02/11 14:33:27 simonmar Exp $
 --
 -- GHC Interactive User Interface
 --
@@ -43,6 +43,7 @@ import IO
 import Char
 import Monad ( when )
 
+import PrelGHC 		( unsafeCoerce# )
 
 -----------------------------------------------------------------------------
 
@@ -53,10 +54,13 @@ ghciWelcomeMsg = "\
 \/ /_\\\\/ __  / /___| |      http://www.haskell.org/ghc/\n\ 
 \\\____/\\/ /_/\\____/|_|      Type :? for help.\n"
 
-commands :: [(String, String -> GHCi Bool)]
-commands = [
+GLOBAL_VAR(commands, builtin_commands, [(String, String -> GHCi Bool)])
+
+builtin_commands :: [(String, String -> GHCi Bool)]
+builtin_commands = [
   ("add",	keepGoing addModule),
   ("cd",    	keepGoing changeDirectory),
+  ("def",	keepGoing defineMacro),
   ("help",	keepGoing help),
   ("?",		keepGoing help),
   ("load",	keepGoing loadModule),
@@ -65,6 +69,7 @@ commands = [
   ("set",	keepGoing setOptions),
   ("type",	keepGoing typeOfExpr),
   ("unset",	keepGoing unsetOptions),
+  ("undef",     keepGoing undefineMacro),
   ("quit",	quit)
   ]
 
@@ -190,6 +195,15 @@ fileLoop hdl prompt = do
 	    l  -> do quit <- runCommand l
           	     if quit then return () else fileLoop hdl prompt
 
+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
+
 #ifndef NO_READLINE
 readlineLoop :: GHCi ()
 readlineLoop = do
@@ -278,7 +292,8 @@ specialCommand :: String -> GHCi Bool
 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
 specialCommand str = do
   let (cmd,rest) = break isSpace str
-  case [ (s,f) | (s,f) <- commands, prefixMatch cmd s ] of
+  cmds <- io (readIORef commands)
+  case [ (s,f) | (s,f) <- cmds, prefixMatch cmd s ] of
      []      -> io (hPutStr stdout ("unknown command `:" ++ cmd ++ "'\n" 
 		                    ++ shortHelpText) >> return False)
      [(_,f)] -> f (dropWhile isSpace rest)
@@ -322,6 +337,52 @@ moduleNameToModule mn
 changeDirectory :: String -> GHCi ()
 changeDirectory d = io (setCurrentDirectory d)
 
+defineMacro :: String -> GHCi ()
+defineMacro s = do
+  let (macro_name, definition) = break isSpace s
+  cmds <- io (readIORef commands)
+  if (null macro_name) 
+	then throwDyn (OtherError "invalid macro name") 
+	else do
+  if (macro_name `elem` map fst cmds) 
+	then throwDyn (OtherError 
+		("command `" ++ macro_name ++ "' already defined"))
+	else do
+
+  -- give the expression a type signature, so we can be sure we're getting
+  -- something of the right type.
+  let new_expr = '(' : definition ++ ") :: String -> IO String"
+
+  -- compile the expression
+  st <- getGHCiState
+  dflags <- io (getDynFlags)
+  (new_cmstate, maybe_stuff) <- 
+      	 io (cmGetExpr (cmstate st) dflags False (current_module st) 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))
+
+runMacro :: HValue{-String -> IO String-} -> String -> GHCi ()
+runMacro fun s = do
+  str <- io ((unsafeCoerce# fun :: String -> IO String) s)
+  stringLoop (lines str)
+
+undefineMacro :: String -> GHCi ()
+undefineMacro macro_name = do
+  cmds <- io (readIORef commands)
+  if (macro_name `elem` map fst builtin_commands) 
+	then throwDyn (OtherError
+		("command `" ++ macro_name ++ "' cannot be undefined"))
+	else do
+  if (macro_name `notElem` map fst cmds) 
+	then throwDyn (OtherError 
+		("command `" ++ macro_name ++ "' not defined"))
+	else do
+  io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
+
 loadModule :: String -> GHCi ()
 loadModule path = timeIt (loadModule' path)