Finalize Output Widget

- Add support for `clear_output`
- Rename `setOutput` to `appendOutput`

ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Output.hs

@@ -12,7 +12,10 @@ module IHaskell.Display.Widgets.Output (
     modifyOutputWidth,
     modifyOutputWidth_,
     -- * Output to widget
-    setOutput,
+    appendOutput,
+    clearOutput,
+    clearOutput_,
+    replaceOutput,
     ) where
 
 -- To keep `cabal repl` happy when running from the ihaskell repo
@@ -72,13 +75,31 @@ modifyOutputWidth widget modifier = getOutputWidth widget >>= modifier >>= setOu
 
 -- | Modify the output widget width (with pure modifier)
 modifyOutputWidth_ :: OutputWidget -> (Int -> Int) -> IO ()
-modifyOutputWidth_ widget modifier = getOutputWidth widget >>= setOutputWidth widget . modifier
+modifyOutputWidth_ widget modifier = do
+  w <- getOutputWidth widget
+  let newWidth = modifier w
+  setOutputWidth widget newWidth
 
-setOutput :: IHaskellDisplay a => OutputWidget -> a -> IO ()
-setOutput widget out = do
+-- | Append to the output widget
+appendOutput :: IHaskellDisplay a => OutputWidget -> a -> IO ()
+appendOutput widget out = do
   disp <- display out
   widgetPublishDisplay widget disp
 
+-- | Clear the output widget immediately
+clearOutput :: OutputWidget -> IO ()
+clearOutput widget = widgetClearOutput widget False
+
+-- | Clear the output widget on next append
+clearOutput_ :: OutputWidget -> IO ()
+clearOutput_ widget = widgetClearOutput widget True
+
+-- | Replace the currently displayed output for output widget
+replaceOutput :: IHaskellDisplay a => OutputWidget -> a -> IO ()
+replaceOutput widget d = do
+  clearOutput_ widget
+  appendOutput widget d
+
 instance ToJSON OutputWidget where
   toJSON b = object
                [ "_view_module" .= str ""

ipython-kernel/src/IHaskell/IPython/Types.hs

@@ -25,6 +25,7 @@ module IHaskell.IPython.Types (
     HistoryAccessType(..),
     HistoryReplyElement(..),
     replyType,
+    showMessageType,
 
     -- ** IPython display data message
     DisplayData(..),
@@ -63,7 +64,7 @@ data Profile =
        Profile
          { ip :: IP                     -- ^ The IP on which to listen.
          , transport :: Transport       -- ^ The transport mechanism.
-         , stdinPort :: Port            -- ^ The stdin channel port. 
+         , stdinPort :: Port            -- ^ The stdin channel port.
          , controlPort :: Port          -- ^ The control channel port.
          , hbPort :: Port               -- ^ The heartbeat channel port.
          , shellPort :: Port            -- ^ The shell command port.
@@ -114,7 +115,7 @@ instance ToJSON Transport where
 -------------------- IPython Kernelspec Types ----------------------
 data KernelSpec =
        KernelSpec
-         { 
+         {
          -- | Name shown to users to describe this kernel (e.g. "Haskell")
          kernelDisplayName :: String
          -- | Name for the kernel; unique kernel identifier (e.g. "haskell")

src/IHaskell/Eval/Widgets.hs

@@ -6,6 +6,7 @@ module IHaskell.Eval.Widgets (
     widgetSendClose,
     widgetSendValue,
     widgetPublishDisplay,
+    widgetClearOutput,
     relayWidgetMessages,
     widgetHandler,
     ) where
@@ -22,6 +23,7 @@ import           System.IO.Unsafe (unsafePerformIO)
 
 import           IHaskell.Display
 import           IHaskell.Eval.Util (unfoldM)
+import           IHaskell.IPython.Types (showMessageType)
 import           IHaskell.IPython.Message.UUID
 import           IHaskell.IPython.Message.Writer
 import           IHaskell.Types
@@ -78,6 +80,10 @@ widgetSendValue widget = queue . JSONValue (Widget widget)
 widgetPublishDisplay :: (IHaskellWidget a, IHaskellDisplay b) => a -> b -> IO ()
 widgetPublishDisplay widget disp = display disp >>= queue . DispMsg (Widget widget)
 
+-- | Send a `clear_output` message as a [method .= custom] message
+widgetClearOutput :: IHaskellWidget a => a -> Bool -> IO ()
+widgetClearOutput widget wait = queue $ ClrOutput (Widget widget) wait
+
 -- | Handle a single widget message. Takes necessary actions according to the message type, such as
 -- opening comms, storing and updating widget representation in the kernel state etc.
 handleMessage :: (Message -> IO ())
@@ -142,16 +148,13 @@ handleMessage send replyHeader state msg = do
 
     DispMsg widget disp -> do
       dispHeader <- dupHeader replyHeader DisplayDataMessage
-
       let dmsg = WidgetDisplay dispHeader "haskell" $ unwrap disp
-          uuid = getCommUUID widget
-          present = isJust $ Map.lookup uuid oldComms
+      sendMessage widget (toJSON $ CustomContent $ toJSON dmsg)
 
-      -- If the widget is present, we send an update message on its comm.
-      when present $ do
-        header <- dupHeader replyHeader CommDataMessage
-        send $ CommData header uuid $ toJSON $ CustomContent $ toJSON dmsg
-      return state
+    ClrOutput widget wait -> do
+      header <- dupHeader replyHeader ClearOutputMessage
+      let cmsg = WidgetClear header wait
+      sendMessage widget (toJSON $ CustomContent $ toJSON cmsg)
 
   where
     oldComms = openComms state
@@ -175,12 +178,27 @@ data WidgetDisplay = WidgetDisplay MessageHeader String [DisplayData]
 instance ToJSON WidgetDisplay where
   toJSON (WidgetDisplay replyHeader source ddata) =
     let pbval = toJSON $ PublishDisplayData replyHeader source ddata
-    in object
-         [ "header" .= replyHeader
-         , "parent_header" .= str ""
-         , "metadata" .= str "{}"
-         , "content" .= pbval
-         ]
+    in toJSON $ IPythonMessage replyHeader pbval DisplayDataMessage
+
+-- Override toJSON for ClearOutput
+data WidgetClear = WidgetClear MessageHeader Bool
+
+instance ToJSON WidgetClear where
+  toJSON (WidgetClear replyHeader wait) =
+    let clrVal = toJSON $ ClearOutput replyHeader wait
+    in toJSON $ IPythonMessage replyHeader clrVal ClearOutputMessage
+
+data IPythonMessage = IPythonMessage MessageHeader Value MessageType
+
+instance ToJSON IPythonMessage where
+  toJSON (IPythonMessage replyHeader val msgType) =
+    object
+      [ "header" .= replyHeader
+      , "parent_header" .= str ""
+      , "metadata" .= str "{}"
+      , "content" .= val
+      , "msg_type" .= (toJSON . showMessageType $ msgType)
+      ]
 
 str :: String -> String
 str = id

src/IHaskell/Types.hs

@@ -208,7 +208,10 @@ data WidgetMsg = Open Widget Value Value
                |
                -- ^ A json object that is sent to the widget without modifications.
                 DispMsg Widget Display
-  -- ^ A 'display_data' message, sent as a [method .= custom] comm_msg
+               -- ^ A 'display_data' message, sent as a [method .= custom] comm_msg
+               |
+                ClrOutput Widget Bool
+  -- ^ A 'clear_output' message, sent as a [method .= custom] comm_msg
   deriving (Show, Typeable)
 
 data WidgetMethod = UpdateState Value