multiline commands in GHCi #4316

This patch adds support for multiline commands in GHCi.

The first line of input is lexed.  If there is an active
layout context once the lexer reaches the end of file, the
user is prompted for more input.

Multiline input is exited by an empty line and can be escaped 
with a user interrupt.

Multiline mode is toggled with `:set +m`

2 files changed, 74 insertions, 10 deletions

diff --git a/ghc/GhciMonad.hs b/ghc/GhciMonad.hs
index fd6349720e..779fad23e9 100644
--- a/ghc/GhciMonad.hs
+++ b/ghc/GhciMonad.hs
@@ -90,6 +90,7 @@ data GHCiOption
 	= ShowTiming		-- show time/allocs after evaluation
 	| ShowType		-- show the type of expressions
 	| RevertCAFs		-- revert CAFs after every evaluation
+        | Multiline             -- use multiline commands
 	deriving Eq
 
 data BreakLocation
diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs
index ac056a6a7e..cf90ae78ba 100644
--- a/ghc/InteractiveUI.hs
+++ b/ghc/InteractiveUI.hs
@@ -27,6 +27,8 @@ import GHC              ( LoadHowMuch(..), Target(..),  TargetId(..),
                           Ghc, handleSourceError )
 import PprTyThing
 import DynFlags
+import qualified Lexer
+import StringBuffer
 
 import Packages
 -- import PackageConfig
@@ -257,6 +259,7 @@ helpText =
  "\n" ++
  "  Options for ':set' and ':unset':\n" ++
  "\n" ++
+ "    +m            allow multiline commands\n" ++             
  "    +r            revert top-level expressions after each evaluation\n" ++
  "    +s            print timing/memory stats after each evaluation\n" ++
  "    +t            print type after evaluation\n" ++
@@ -585,30 +588,34 @@ runCommands' :: (SomeException -> GHCi Bool) -- Exception handler
              -> InputT GHCi (Maybe String) -> InputT GHCi ()
 runCommands' eh getCmd = do
     b <- ghandle (\e -> case fromException e of
-                          Just UserInterrupt -> return False
+                          Just UserInterrupt -> return $ Just False
                           _ -> case fromException e of
                                  Just ghc_e ->
                                    do liftIO (print (ghc_e :: GhcException))
-                                      return True
+                                      return Nothing
                                  _other ->
                                    liftIO (Exception.throwIO e))
             (runOneCommand eh getCmd)
-    if b then return () else runCommands' eh getCmd
+    case b of
+      Nothing -> return ()
+      Just _  -> runCommands' eh getCmd
 
 runOneCommand :: (SomeException -> GHCi Bool) -> InputT GHCi (Maybe String)
-            -> InputT GHCi Bool
+            -> InputT GHCi (Maybe Bool)
 runOneCommand eh getCmd = do
   mb_cmd <- noSpace (lift queryQueue)
   mb_cmd <- maybe (noSpace getCmd) (return . Just) mb_cmd
   case mb_cmd of
-    Nothing -> return True
-    Just c  -> ghciHandle (lift . eh) $
+    Nothing -> return Nothing
+    Just c  -> ghciHandle (\e -> lift $ eh e >>= return . Just) $
              handleSourceError printErrorAndKeepGoing
                (doCommand c)
+               -- source error's are handled by runStmt
+               -- is the handler necessary here?
   where
     printErrorAndKeepGoing err = do
         GHC.printException err
-        return False
+        return $ Just True
 
     noSpace q = q >>= maybe (return Nothing)
                             (\c->case removeSpaces c of 
@@ -639,9 +646,63 @@ runOneCommand eh getCmd = do
             normSpace   c  = c
     -- QUESTION: is userError the one to use here?
     collectError = userError "unterminated multiline command :{ .. :}"
-    doCommand (':' : cmd) = specialCommand cmd
-    doCommand stmt        = do _ <- timeIt $ lift $ runStmt stmt GHC.RunToCompletion
-                               return False
+    doCommand (':' : cmd) = do
+      result <- specialCommand cmd
+      case result of
+        True -> return Nothing
+        _    -> return $ Just True
+    doCommand stmt        = do 
+      ml <- lift $ isOptionSet Multiline
+      if ml
+        then do 
+          mb_stmt <- checkInputForLayout stmt getCmd 
+          case mb_stmt of
+            Nothing      -> return $ Just True
+            Just ml_stmt -> do
+              result <- timeIt $ lift $ runStmt ml_stmt GHC.RunToCompletion
+              return $ Just result
+        else do
+          result <- timeIt $ lift $ runStmt stmt GHC.RunToCompletion
+          return $ Just result
+
+-- #4316
+-- lex the input.  If there is an unclosed layout context, request input
+checkInputForLayout :: String -> InputT GHCi (Maybe String) 
+                    -> InputT GHCi (Maybe String)
+checkInputForLayout stmt getStmt = do
+   dflags' <- lift $ getDynFlags
+   let dflags = xopt_set dflags' Opt_AlternativeLayoutRule
+   st <- lift $ getGHCiState
+   let buf =  stringToStringBuffer stmt
+       loc  = mkSrcLoc (fsLit (progname st)) (line_number st) 1
+       pstate = Lexer.mkPState dflags buf loc
+   case Lexer.unP goToEnd pstate of
+     (Lexer.POk _ False) -> return $ Just stmt
+     _other              -> do
+       st <- lift getGHCiState
+       let p = prompt st
+       lift $ setGHCiState st{ prompt = "%s| " }
+       mb_stmt <- ghciHandle (\ex -> case fromException ex of
+                            Just UserInterrupt -> return Nothing
+                            _ -> case fromException ex of
+                                 Just ghc_e ->
+                                   do liftIO (print (ghc_e :: GhcException))
+                                      return Nothing
+                                 _other -> liftIO (Exception.throwIO ex)) 
+                     getStmt
+       lift $ getGHCiState >>= \st->setGHCiState st{ prompt = p }
+       -- the recursive call does not recycle parser state
+       -- as we use a new string buffer
+       case mb_stmt of
+         Nothing  -> return Nothing
+         Just str -> if str == ""
+           then return $ Just stmt
+           else checkInputForLayout (stmt++"\n"++str) getStmt
+     where goToEnd = do
+             eof <- Lexer.nextIsEOF
+             if eof 
+               then Lexer.activeContext
+               else Lexer.lexer return >> goToEnd
 
 enqueueCommands :: [String] -> GHCi ()
 enqueueCommands cmds = do
@@ -1569,12 +1630,14 @@ unsetOpt str
 	Just o  -> unsetOption o
 
 strToGHCiOpt :: String -> (Maybe GHCiOption)
+strToGHCiOpt "m" = Just Multiline
 strToGHCiOpt "s" = Just ShowTiming
 strToGHCiOpt "t" = Just ShowType
 strToGHCiOpt "r" = Just RevertCAFs
 strToGHCiOpt _   = Nothing
 
 optToStr :: GHCiOption -> String
+optToStr Multiline  = "m"
 optToStr ShowTiming = "s"
 optToStr ShowType   = "t"
 optToStr RevertCAFs = "r"