changing :info to use the ipython pager

src/IHaskell/Eval/Evaluate.hs

@@ -188,19 +188,20 @@ initializeItVariable =
 
 -- | Publisher for IHaskell outputs.  The first argument indicates whether
 -- this output is final (true) or intermediate (false).
-type Publisher = (Bool -> [DisplayData] -> IO ())
+type Publisher = (EvaluationResult -> IO ())
 
 -- | Output of a command evaluation.
 data EvalOut = EvalOut {
     evalStatus :: ErrorOccurred,
     evalResult :: [DisplayData],
-    evalState :: KernelState
+    evalState :: KernelState,
+    evalPager :: String
   }
 
 -- | Evaluate some IPython input code.
-evaluate :: KernelState      -- ^ The kernel state.
-         -> String           -- ^ Haskell code or other interpreter commands.
-         -> Publisher        -- ^ Function used to publish data outputs.
+evaluate :: KernelState                  -- ^ The kernel state.
+         -> String                       -- ^ Haskell code or other interpreter commands.
+         -> (EvaluationResult -> IO ())   -- ^ Function used to publish data outputs.
          -> Interpreter KernelState
 evaluate kernelState code output = do
   cmds <- parseString (strip code)
@@ -209,7 +210,7 @@ evaluate kernelState code output = do
   when (getLintStatus kernelState /= LintOff) $ liftIO $ do
     lintSuggestions <- lint cmds
     unless (null lintSuggestions) $
-      output True lintSuggestions
+      output $ FinalResult lintSuggestions ""
 
   updated <- runUntilFailure kernelState (map unloc cmds ++ [storeItCommand execCount])
   return updated {
@@ -223,8 +224,9 @@ evaluate kernelState code output = do
 
       -- Output things only if they are non-empty.
       let result = evalResult evalOut
-      unless (null result) $
-        liftIO $ output True result
+          helpStr = evalPager evalOut
+      unless (null result && null helpStr) $
+        liftIO $ output $ FinalResult result helpStr
 
       let newState = evalState evalOut
       case evalStatus evalOut of
@@ -233,24 +235,29 @@ evaluate kernelState code output = do
 
     storeItCommand execCount = Statement $ printf "let it%d = it" execCount
 
-wrapExecution :: KernelState
-              -> Interpreter [DisplayData]
-              -> Interpreter EvalOut
-wrapExecution state exec = ghandle handler $ exec >>= \res ->
-    return EvalOut {
-      evalStatus = Success,
-      evalResult = res,
-      evalState = state
-    }
+safely :: KernelState -> Interpreter EvalOut -> Interpreter EvalOut
+safely state exec = ghandle handler exec
   where
     handler :: SomeException -> Interpreter EvalOut
     handler exception =
       return EvalOut {
         evalStatus = Failure,
         evalResult = displayError $ show exception,
-        evalState = state
+        evalState = state,
+        evalPager = ""
       }
 
+wrapExecution :: KernelState
+              -> Interpreter [DisplayData]
+              -> Interpreter EvalOut
+wrapExecution state exec = safely state $ exec >>= \res ->
+    return EvalOut {
+      evalStatus = Success,
+      evalResult = res,
+      evalState = state,
+      evalPager = ""
+    }
+
 -- | Return the display data for this command, as well as whether it
 -- resulted in an error.
 evalCommand :: Publisher -> CodeBlock -> KernelState -> Interpreter EvalOut
@@ -386,7 +393,8 @@ evalCommand _ (Directive SetOpt option) state = do
   return EvalOut {
     evalStatus = if isJust newState then Success else Failure,
     evalResult = out,
-    evalState = fromMaybe state newState
+    evalState = fromMaybe state newState,
+    evalPager = ""
   }
 
   where
@@ -450,7 +458,7 @@ evalCommand publish (Directive ShellCmd ('!':cmd)) state = wrapExecution state $
         -- Maximum size of the output (after which we truncate).
         maxSize = 100 * 1000
         incSize = 200
-        output str = publish False [plain str]
+        output str = publish $ IntermediateResult [plain str]
 
         loop = do
           -- Wait and then check if the computation is done.
@@ -492,7 +500,8 @@ evalCommand _ (Directive GetHelp _) state = do
   return EvalOut {
     evalStatus = Success,
     evalResult = [out],
-    evalState = state
+    evalState = state,
+    evalPager = ""
   }
   where out = plain $ intercalate "\n"
           ["The following commands are available:"
@@ -512,7 +521,7 @@ evalCommand _ (Directive GetHelp _) state = do
           ]
 
 -- This is taken largely from GHCi's info section in InteractiveUI.
-evalCommand _ (Directive GetInfo str) state = wrapExecution state $ do
+evalCommand _ (Directive GetInfo str) state = safely state $ do
   write $ "Info: " ++ str
   -- Get all the info for all the names we're given.
   names     <- parseName str
@@ -542,11 +551,17 @@ evalCommand _ (Directive GetInfo str) state = wrapExecution state $ do
   unqual <- getPrintUnqual
   flags <- getSessionDynFlags
   let strings = map (showSDocForUser flags unqual) outs
-  return [plain $ intercalate "\n" strings]
+
+  return EvalOut {
+    evalStatus = Success,
+    evalResult = [],
+    evalState = state,
+    evalPager = unlines strings
+  }
 
 evalCommand output (Statement stmt) state = wrapExecution state $ do
   write $ "Statement:\n" ++ stmt
-  let outputter str = output False [plain str]
+  let outputter str = output $ IntermediateResult [plain str]
   (printed, result) <- capturedStatement outputter stmt
   case result of
     RunOk names -> do
@@ -727,7 +742,8 @@ evalCommand _ (ParseError loc err) state = do
   return EvalOut {
     evalStatus = Failure,
     evalResult = displayError $ formatParseError loc err,
-    evalState = state
+    evalState = state,
+    evalPager = ""
   }
 
 -- Read from a file handle until we hit a delimiter or until we've read

src/IHaskell/Message/Writer.hs

@@ -28,10 +28,16 @@ instance ToJSON Message where
                              "language" .= string "haskell"
                            ]
 
-  toJSON ExecuteReply{ status = status, executionCounter = counter} = object [
+  toJSON ExecuteReply{ status = status, executionCounter = counter, pagerOutput = pager} = object [
                              "status" .= show status,
                              "execution_count" .= counter,
-                             "payload" .= emptyList,
+                             "payload" .= 
+                               if null pager
+                               then []
+                               else [object [
+                                    "source" .= string "page",
+                                    "text" .= pager
+                                ]],
                              "user_variables" .= emptyMap,
                              "user_expressions" .= emptyMap
                            ]
@@ -61,7 +67,7 @@ instance ToJSON Message where
                              "matches" .= m,
                              "matched_text" .= mt,
                              "text" .= t,
-                             "status" .= if s then "ok" :: String else "error"
+                             "status" .= if s then string "ok" else "error"
                            ]
   toJSON o@ObjectInfoReply{} = object [
                             "oname" .= objectName o,

src/IHaskell/Types.hs

@@ -14,6 +14,7 @@ module IHaskell.Types (
   StreamType(..),
   MimeType(..),
   DisplayData(..),
+  EvaluationResult(..),
   ExecuteReplyStatus(..),
   InitInfo(..),
   KernelState(..),
@@ -220,6 +221,7 @@ data Message
   | ExecuteReply {
       header :: MessageHeader,
       status :: ExecuteReplyStatus,         -- ^ The status of the output.
+      pagerOutput :: String,                -- ^ The help string to show in the pager.
       executionCounter :: Int               -- ^ The execution count, i.e. which output this is.
     }
 
@@ -358,7 +360,6 @@ extractPlain disps =
   where
     isPlain (Display mime _) = mime == PlainText
 
-
 instance Show MimeType where
   show PlainText = "text/plain"
   show MimeHtml  = "text/html"
@@ -367,6 +368,18 @@ instance Show MimeType where
   show MimeSvg   = "image/svg+xml"
   show MimeLatex = "text/latex"
 
+-- | Output of evaluation.
+data EvaluationResult =
+  -- | An intermediate result which communicates what has been printed thus
+  -- far.
+  IntermediateResult {
+    outputs :: [DisplayData]      -- ^ Display outputs.
+  }
+  | FinalResult {
+    outputs :: [DisplayData],     -- ^ Display outputs.
+    pagerOut :: String            -- ^ Text to display in the IPython pager.
+  }
+
 -- | Input and output streams.
 data StreamType = Stdin | Stdout deriving Show
 

src/Main.hs

@@ -234,7 +234,7 @@ runKernel profileSrc initInfo = do
     -- command line flags. This includes enabling some extensions and also
     -- running some code.
     let extLines = map (":extension " ++) $ extensions initInfo
-        noPublish _ _ = return ()       
+        noPublish _ = return ()       
         evaluator line = do
           -- Create a new state each time.
           stateVar <- liftIO initialKernelState
@@ -325,8 +325,9 @@ replyTo interface req@ExecuteRequest{ getCode = code } replyHeader state = do
   -- output and the thing to display. Store the final outputs in a list so
   -- that when we receive an updated non-final output, we can clear the
   -- entire output and re-display with the updated output.
-  displayed <- liftIO $ newMVar []
+  displayed    <- liftIO $ newMVar []
   updateNeeded <- liftIO $ newMVar False
+  pagerOutput  <- liftIO $ newMVar ""
   let clearOutput = do
         header <- dupHeader replyHeader ClearOutputMessage
         send $ ClearOutput header True
@@ -335,8 +336,13 @@ replyTo interface req@ExecuteRequest{ getCode = code } replyHeader state = do
         header <- dupHeader replyHeader DisplayDataMessage
         send $ PublishDisplayData header "haskell" outs
 
-      publish :: Bool -> [DisplayData] -> IO ()
-      publish final outputs = do
+      publish :: EvaluationResult -> IO ()
+      publish result = do
+        let final = case result of
+                      IntermediateResult {} -> False
+                      FinalResult {} -> True
+            outs = outputs result
+
         -- If necessary, clear all previous output and redraw.
         clear <- readMVar updateNeeded
         when clear $ do
@@ -345,14 +351,19 @@ replyTo interface req@ExecuteRequest{ getCode = code } replyHeader state = do
           mapM_ sendOutput $ reverse disps
 
         -- Draw this message.
-        sendOutput outputs
+        sendOutput outs
 
         -- If this is the final message, add it to the list of completed
         -- messages. If it isn't, make sure we clear it later by marking
         -- update needed as true.
         modifyMVar_ updateNeeded (const $ return $ not final)
-        when final $
-          modifyMVar_ displayed (return . (outputs:))
+        when final $ do
+          modifyMVar_ displayed (return . (outs:))
+
+          -- If this has some pager output, store it for later.
+          let pager = pagerOut result
+          unless (null pager) $
+            modifyMVar_ pagerOutput (return . (++ pager ++ "\n"))
 
   -- Run code and publish to the frontend as we go.
   let execCount = getExecutionCounter state
@@ -362,8 +373,10 @@ replyTo interface req@ExecuteRequest{ getCode = code } replyHeader state = do
   idleHeader <- liftIO $ dupHeader replyHeader StatusMessage
   send $ PublishStatus idleHeader Idle
 
+  pager <- liftIO $ readMVar pagerOutput
   return (updatedState, ExecuteReply {
     header = replyHeader,
+    pagerOutput = pager,
     executionCounter = execCount,
     status = Ok
   })