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`

4 files changed, 154 insertions, 12 deletions

diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index 9237384efc..5e6535678e 100644
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -51,6 +51,7 @@ module Lexer (
    failLocMsgP, failSpanMsgP, srcParseFail,
    getMessages, 
    popContext, pushCurrentContext, setLastToken, setSrcLoc,
+   activeContext, nextIsEOF,
    getLexState, popLexState, pushLexState,
    extension, bangPatEnabled, datatypeContextsEnabled,
    addWarning,
@@ -1670,6 +1671,11 @@ getInput = P $ \s@PState{ loc=l, buffer=b } -> POk s (AI l b)
 setInput :: AlexInput -> P ()
 setInput (AI l b) = P $ \s -> POk s{ loc=l, buffer=b } ()
 
+nextIsEOF :: P Bool
+nextIsEOF = do
+  AI _ s <- getInput
+  return $ atEnd s
+
 pushLexState :: Int -> P ()
 pushLexState ls = P $ \s@PState{ lex_state=l } -> POk s{lex_state=ls:l} ()
 
@@ -1684,6 +1690,15 @@ popNextToken
     = P $ \s@PState{ alr_next_token = m } ->
               POk (s {alr_next_token = Nothing}) m
 
+activeContext :: P Bool
+activeContext = do
+  ctxt <- getALRContext
+  expc <- getAlrExpectingOCurly
+  impt <- implicitTokenPending
+  case (ctxt,expc) of
+    ([],Nothing) -> return impt
+    _other       -> return True
+
 setAlrLastLoc :: SrcSpan -> P ()
 setAlrLastLoc l = P $ \s -> POk (s {alr_last_loc = l}) ()
 
@@ -1707,6 +1722,13 @@ setJustClosedExplicitLetBlock b
 setNextToken :: Located Token -> P ()
 setNextToken t = P $ \s -> POk (s {alr_next_token = Just t}) ()
 
+implicitTokenPending :: P Bool
+implicitTokenPending
+    = P $ \s@PState{ alr_pending_implicit_tokens = ts } ->
+              case ts of
+              [] -> POk s False
+              _  -> POk s True
+
 popPendingImplicitToken :: P (Maybe (Located Token))
 popPendingImplicitToken
     = P $ \s@PState{ alr_pending_implicit_tokens = ts } ->
diff --git a/docs/users_guide/ghci.xml b/docs/users_guide/ghci.xml
index 80205954e5..ebf195b2a6 100644
--- a/docs/users_guide/ghci.xml
+++ b/docs/users_guide/ghci.xml
@@ -58,8 +58,52 @@ Prelude>
 </screen>
 
     <para>GHCi interprets the whole line as an expression to evaluate.
-    The expression may not span several lines - as soon as you press
-    enter, GHCi will attempt to evaluate it.</para>
+    The expression may not span several lines - as soon as you press enter, 
+    GHCi will attempt to evaluate it.</para>
+
+    <para>GHCi also has a multiline mode, 
+    <indexterm><primary><literal>:set +m</literal></primary></indexterm>,
+    which is terminated by an empty line:</para>
+
+<screen>
+Prelude> :set +m
+Prelude> let x = 42 in x / 9
+Prelude| 
+4.666666666666667
+Prelude> 
+</screen>
+    
+    <para>In Haskell, a <literal>let</literal> expression is followed
+    by <literal>in</literal>.  However, in GHCi, since the expression 
+    can also be interpreted in the <literal>IO</literal> monad, 
+    a <literal>let</literal> binding with no accompanying 
+    <literal>in</literal> statement can be signalled by an empty line, 
+    as in the above example.</para>
+
+    <para>Multiline mode is useful when entering monadic 
+    <literal>do<literal> statements:</para>
+
+<screen>
+Control.Monad.State> flip evalStateT 0 $ do
+Control.Monad.State| i <- get
+Control.Monad.State| lift $ do
+Control.Monad.State|   putStrLn "Hello World!"
+Control.Monad.State|   print i
+Control.Monad.State|
+"Hello World!"
+0
+Control.Monad.State>
+</screen>
+  
+   <para>During a multiline interaction, the user can interrupt and
+   return to the top-level prompt.</para>
+
+<screen>
+Prelude> do
+Prelude| putStrLn "Hello, World!"
+Prelude| ^C
+Prelude>
+</screen>
   </sect1>
 
   <sect1 id="loading-source-files">
@@ -2627,6 +2671,18 @@ bar
       <variablelist>
 	<varlistentry>
 	  <term>
+            <literal>+m</literal>
+            <indexterm><primary><literal>+m</literal></primary></indexterm>
+          </term>
+	  <listitem>
+	    <para>Enable parsing of multiline commands.  A multiline command
+	    is prompted for when the current input line contains open layout
+	    contexts.</para>
+	  </listitem>
+	</varlistentry>
+
+	<varlistentry>
+	  <term>
             <literal>+r</literal>
             <indexterm><primary><literal>+r</literal></primary></indexterm>
             <indexterm><primary>CAFs</primary><secondary>in GHCi</secondary></indexterm>
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"