Merge pull request #508 from sumitsahrawat/widgets

Backbone widgets

Hspec.hs

@@ -70,10 +70,11 @@ eval string = do
         FinalResult outs page [] -> do
           modifyIORef outputAccum (outs :)
           modifyIORef pagerAccum (page :)
+      noWidgetHandling s _ = return s
 
   getTemporaryDirectory >>= setCurrentDirectory
   let state = defaultKernelState { getLintStatus = LintOff }
-  interpret libdir False $ Eval.evaluate state string publish
+  interpret libdir False $ Eval.evaluate state string publish noWidgetHandling
   out <- readIORef outputAccum
   pagerOut <- readIORef pagerAccum
   return (reverse out, unlines . map extractPlain . reverse $ pagerOut)

ihaskell-display/ihaskell-widgets/LICENSE

@@ -0,0 +1,20 @@
+Copyright (c) 2015 Sumit Sahrawat
+
+Permission is hereby granted, free of charge, to any person obtaining
+a copy of this software and associated documentation files (the
+"Software"), to deal in the Software without restriction, including
+without limitation the rights to use, copy, modify, merge, publish,
+distribute, sublicense, and/or sell copies of the Software, and to
+permit persons to whom the Software is furnished to do so, subject to
+the following conditions:
+
+The above copyright notice and this permission notice shall be included
+in all copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

ihaskell-display/ihaskell-widgets/Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

ihaskell-display/ihaskell-widgets/ihaskell-widgets.cabal

@@ -0,0 +1,83 @@
+-- Initial ihaskell-widgets.cabal generated by cabal init.  For 
+-- further documentation, see http://haskell.org/cabal/users-guide/
+
+-- The name of the package.
+name:                ihaskell-widgets
+
+-- The package version.  See the Haskell package versioning policy (PVP) 
+-- for standards guiding when and how versions should be incremented.
+-- http://www.haskell.org/haskellwiki/Package_versioning_policy
+-- PVP summary:      +-+------- breaking API changes
+--                   | | +----- non-breaking API additions
+--                   | | | +--- code changes with no API change
+version:             0.1.0.0
+
+-- A short (one-line) description of the package.
+synopsis:            IPython standard widgets for IHaskell.
+
+-- A longer description of the package.
+-- description:         
+
+-- URL for the project homepage or repository.
+homepage:            http://www.github.com/gibiansky/IHaskell
+
+-- The license under which the package is released.
+license:             MIT
+
+-- The file containing the license text.
+license-file:        LICENSE
+
+-- The package author(s).
+author:              Sumit Sahrawat
+
+-- An email address to which users can send suggestions, bug reports, and 
+-- patches.
+maintainer:          Sumit Sahrawat <sumit.sahrawat.apm13@iitbhu.ac.in>,
+                     Andrew Gibiansky <andrew.gibiansky@gmail.com>
+
+-- A copyright notice.
+-- copyright:           
+
+-- category:            
+
+build-type:          Simple
+
+-- Extra files to be distributed with the package, such as examples or a 
+-- README.
+-- extra-source-files:  
+
+-- Constraint on the version of Cabal needed to build this package.
+cabal-version:       >=1.10
+
+library
+  -- Modules exported by the library.
+  exposed-modules:     IHaskell.Display.Widgets
+  
+  -- Modules included in this library but not exported.
+  other-modules:       IHaskell.Display.Widgets.Button
+                       IHaskell.Display.Widgets.Image
+                       IHaskell.Display.Widgets.String.HTML
+                       IHaskell.Display.Widgets.String.Latex
+                       IHaskell.Display.Widgets.String.Text
+                       IHaskell.Display.Widgets.String.TextArea
+                       IHaskell.Display.Widgets.Common
+  
+  -- LANGUAGE extensions used by modules in this package.
+  -- other-extensions:    
+  
+  -- Other library packages from which modules are imported.
+  build-depends:       aeson >= 0.8.1.0
+                     , base >=4.7 && <4.9
+                     , ipython-kernel >= 0.6.1.0
+                     , text >= 1.2.1.0
+                     , unordered-containers >= 0.2.5.1
+
+                       -- Waiting for the next release
+                     , ihaskell -any
+
+  -- Directories containing source files.
+  hs-source-dirs:      src
+  
+  -- Base language which the package is written in.
+  default-language:    Haskell2010
+  

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

@@ -0,0 +1,12 @@
+module IHaskell.Display.Widgets (module X) where
+
+import           IHaskell.Display.Widgets.Button as X
+
+import           IHaskell.Display.Widgets.Image as X
+
+import           IHaskell.Display.Widgets.String.HTML as X
+import           IHaskell.Display.Widgets.String.Latex as X
+import           IHaskell.Display.Widgets.String.Text as X
+import           IHaskell.Display.Widgets.String.TextArea as X
+
+import           IHaskell.Display.Widgets.Common as X (ButtonStyle(..), ImageFormat(..))

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

@@ -0,0 +1,184 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module IHaskell.Display.Widgets.Button (
+    -- * The Button Widget
+    Button,
+    -- * Create a new button
+    mkButton,
+    -- * Set button properties
+    setButtonStyle,
+    setButtonLabel,
+    setButtonTooltip,
+    setButtonStatus,
+    toggleButtonStatus,
+    -- * Get button properties
+    getButtonStyle,
+    getButtonLabel,
+    getButtonTooltip,
+    getButtonStatus,
+    -- * Click handlers
+    setClickHandler,
+    getClickHandler,
+    triggerClick,
+    ) where
+
+-- To keep `cabal repl` happy when running from the ihaskell repo
+import           Prelude
+
+import           Control.Monad (when)
+import           Data.Aeson (ToJSON, Value(..), object, toJSON, (.=))
+import           Data.Aeson.Types (Pair)
+import           Data.HashMap.Strict as Map
+import           Data.IORef
+import           Data.Text (Text)
+import qualified Data.Text as T
+import           System.IO.Unsafe (unsafePerformIO)
+
+import           IHaskell.Display
+import           IHaskell.Eval.Widgets
+import qualified IHaskell.IPython.Message.UUID as U
+import           IHaskell.Types (WidgetMethod(..))
+
+import           IHaskell.Display.Widgets.Common
+
+-- | A 'Button' represents a Button from IPython.html.widgets.
+data Button =
+       Button
+         { uuid :: U.UUID       -- ^ The UUID for the comm
+         , description :: IORef Text -- ^ The label displayed on the button
+         , tooltip :: IORef Text     -- ^ The tooltip shown on mouseover
+         , disabled :: IORef Bool    -- ^ Whether the button is disabled
+         , buttonStyle :: IORef ButtonStyle -- ^ The button_style
+         , clickHandler :: IORef (Button -> IO ()) -- ^ Function executed when button is clicked
+         }
+
+-- | Create a new button
+mkButton :: IO Button
+mkButton = do
+  -- Default properties, with a random uuid
+  commUUID <- U.random
+  desc <- newIORef "label"      -- Non-empty to get a display
+  ttip <- newIORef ""
+  dis <- newIORef False
+  sty <- newIORef None
+  fun <- newIORef $ const $ return ()
+
+  let b = Button
+        { uuid = commUUID
+        , description = desc
+        , tooltip = ttip
+        , disabled = dis
+        , buttonStyle = sty
+        , clickHandler = fun
+        }
+
+  -- Open a comm for this widget, and store it in the kernel state
+  widgetSendOpen b (toJSON ButtonInitData) (toJSON b)
+
+  -- Return the button widget
+  return b
+
+-- | Set the button style
+setButtonStyle :: Button -> ButtonStyle -> IO ()
+setButtonStyle b bst = do
+  modify b buttonStyle bst
+  update b ["button_style" .= bst]
+
+-- | Set the button label
+setButtonLabel :: Button -> Text -> IO ()
+setButtonLabel b txt = do
+  modify b description txt
+  update b ["description" .= txt]
+
+-- | Set the button tooltip
+setButtonTooltip :: Button -> Text -> IO ()
+setButtonTooltip b txt = do
+  modify b tooltip txt
+  update b ["tooltip" .= txt]
+
+-- | Set buttton status. True: Enabled, False: Disabled
+setButtonStatus :: Button -> Bool -> IO ()
+setButtonStatus b stat = do
+  let newStatus = not stat
+  modify b disabled newStatus
+  update b ["disabled" .= newStatus]
+
+-- | Toggle the button
+toggleButtonStatus :: Button -> IO ()
+toggleButtonStatus b = do
+  oldVal <- getButtonStatus b
+  let newVal = not oldVal
+  modify b disabled newVal
+  update b ["disabled" .= newVal]
+
+-- | Get the button style
+getButtonStyle :: Button -> IO ButtonStyle
+getButtonStyle = readIORef . buttonStyle
+
+-- | Get the button label
+getButtonLabel :: Button -> IO Text
+getButtonLabel = readIORef . description
+
+-- | Get the button tooltip
+getButtonTooltip :: Button -> IO Text
+getButtonTooltip = readIORef . tooltip
+
+-- | Check whether the button is enabled / disabled
+getButtonStatus :: Button -> IO Bool
+getButtonStatus = fmap not . readIORef . disabled
+
+-- | Set a function to be activated on click
+setClickHandler :: Button -> (Button -> IO ()) -> IO ()
+setClickHandler = writeIORef . clickHandler
+
+-- | Get the click handler for a button
+getClickHandler :: Button -> IO (Button -> IO ())
+getClickHandler = readIORef . clickHandler
+
+-- | Artificially trigger a button click
+triggerClick :: Button -> IO ()
+triggerClick button = do
+  handler <- getClickHandler button
+  handler button
+
+data ViewName = ButtonWidget
+
+instance ToJSON ViewName where
+  toJSON ButtonWidget = "ButtonView"
+
+data InitData = ButtonInitData
+
+instance ToJSON InitData where
+  toJSON ButtonInitData = object
+                            [ "model_name" .= str "WidgetModel"
+                            , "widget_class" .= str "IPython.Button"
+                            ]
+
+instance ToJSON Button where
+  toJSON b = object
+               [ "_view_name" .= toJSON ButtonWidget
+               , "visible" .= True
+               , "_css" .= object []
+               , "msg_throttle" .= (3 :: Int)
+               , "disabled" .= get disabled b
+               , "description" .= get description b
+               , "tooltip" .= get tooltip b
+               , "button_style" .= get buttonStyle b
+               ]
+    where
+      get x y = unsafePerformIO . readIORef . x $ y
+
+instance IHaskellDisplay Button where
+  display b = do
+    widgetSendView b
+    return $ Display []
+
+instance IHaskellWidget Button where
+  getCommUUID = uuid
+  comm widget (Object dict1) _ = do
+    let key1 = "content" :: Text
+        key2 = "event" :: Text
+        Just (Object dict2) = Map.lookup key1 dict1
+        Just (String event) = Map.lookup key2 dict2
+    when (event == "click") $ triggerClick widget

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

@@ -0,0 +1,72 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module IHaskell.Display.Widgets.Common (
+    -- * Convenience types
+    ButtonStyle(..),
+    ImageFormat(..),
+    PosInt(..),
+    -- * Convenience functions (for internal use)
+    update,
+    modify,
+    str,
+    ) where
+
+import           Data.Aeson hiding (Success)
+import           Data.Aeson.Types (Pair)
+import qualified Data.Text as T
+import           Data.IORef
+
+import           IHaskell.Display
+import           IHaskell.Eval.Widgets
+
+-- | Pre-defined button-styles
+data ButtonStyle = Primary
+                 | Success
+                 | Info
+                 | Warning
+                 | Danger
+                 | None
+  deriving (Eq, Show)
+
+instance ToJSON ButtonStyle where
+  toJSON Primary = "primary"
+  toJSON Success = "success"
+  toJSON Info = "info"
+  toJSON Warning = "warning"
+  toJSON Danger = "danger"
+  toJSON None = ""
+
+-- | A wrapper around Int. 'toJSON' gives the no. for positive numbers, and empty string otherwise
+newtype PosInt = PosInt { unwrap :: Int }
+
+instance ToJSON PosInt where
+  toJSON (PosInt n)
+    | n > 0 = toJSON $ str $ show n
+    | otherwise = toJSON $ str $ ""
+
+-- | Image formats for ImageWidget
+data ImageFormat = PNG
+                 | SVG
+                 | JPG
+  deriving Eq
+
+instance Show ImageFormat where
+  show PNG = "png"
+  show SVG = "svg"
+  show JPG = "jpg"
+
+instance ToJSON ImageFormat where
+  toJSON = toJSON . T.pack . show
+
+-- | Send an update msg for a widget, with custom json. Make it easy to update fragments of the
+-- state, by accepting a Pair instead of a Value.
+update :: IHaskellWidget a => a -> [Pair] -> IO ()
+update widget = widgetSendUpdate widget . toJSON . object
+
+-- | Modify attributes of a widget, stored inside it as IORefs
+modify :: IHaskellWidget a => a -> (a -> IORef b) -> b -> IO ()
+modify widget attr newval = writeIORef (attr widget) newval
+
+-- | Useful with toJSON
+str :: String -> String
+str = id

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

@@ -0,0 +1,146 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module IHaskell.Display.Widgets.Image (
+    -- * The Image Widget
+    ImageWidget,
+    -- * Create a new image widget
+    mkImageWidget,
+    -- * Set image properties
+    setImageFormat,
+    setImageB64Value,
+    setImageWidth,
+    setImageHeight,
+    -- * Get image properties
+    getImageFormat,
+    getImageB64Value,
+    getImageWidth,
+    getImageHeight,
+    ) where
+
+-- To keep `cabal repl` happy when running from the ihaskell repo
+import           Prelude
+
+import           Control.Monad (when)
+import           Data.Aeson (ToJSON, Value(..), object, toJSON, (.=))
+import           Data.Aeson.Types (Pair)
+import           Data.HashMap.Strict as Map
+import           Data.IORef
+import           Data.Text (Text)
+import qualified Data.Text as T
+import           System.IO.Unsafe (unsafePerformIO)
+
+import           IHaskell.Display
+import           IHaskell.Eval.Widgets
+import qualified IHaskell.IPython.Message.UUID as U
+import           IHaskell.Types (WidgetMethod(..))
+
+import           IHaskell.Display.Widgets.Common
+
+-- | A 'Image' represents a Image from IPython.html.widgets.
+data ImageWidget =
+       ImageWidget
+         { uuid :: U.UUID
+         , format :: IORef ImageFormat
+         , height :: IORef PosInt
+         , width :: IORef PosInt
+         , b64value :: IORef Base64
+         }
+
+-- | Create a new image widget
+mkImageWidget :: IO ImageWidget
+mkImageWidget = do
+  -- Default properties, with a random uuid
+  commUUID <- U.random
+  fmt <- newIORef PNG
+  hgt <- newIORef (PosInt 0)
+  wdt <- newIORef (PosInt 0)
+  val <- newIORef ""
+
+  let initData = object ["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.Image"]
+      b = ImageWidget { uuid = commUUID, format = fmt, height = hgt, width = wdt, b64value = val }
+
+  -- Open a comm for this widget, and store it in the kernel state
+  widgetSendOpen b initData (toJSON b)
+
+  -- Return the image widget
+  return b
+
+-- | Set the image style
+setImageFormat :: ImageWidget -> ImageFormat -> IO ()
+setImageFormat b fmt = do
+  modify b format fmt
+  update b ["format" .= fmt]
+
+-- | Set the image value (encoded in base64)
+setImageB64Value :: ImageWidget -> Base64 -> IO ()
+setImageB64Value b val = do
+  modify b b64value val
+  update b ["_b64value" .= val]
+
+-- | Set the image width
+setImageWidth :: ImageWidget -> Int -> IO ()
+setImageWidth b wdt = do
+  let w = PosInt wdt
+  modify b width w
+  update b ["width" .= w]
+
+-- | Set the image height
+setImageHeight :: ImageWidget -> Int -> IO ()
+setImageHeight b hgt = do
+  let h = PosInt hgt
+  modify b height h
+  update b ["height" .= h]
+
+-- | Get the image format
+getImageFormat :: ImageWidget -> IO ImageFormat
+getImageFormat = readIORef . format
+
+-- | Get the image value (encoded in base64)
+getImageB64Value :: ImageWidget -> IO Base64
+getImageB64Value = readIORef . b64value
+
+-- | Get the image width
+getImageWidth :: ImageWidget -> IO Int
+getImageWidth = fmap unwrap . readIORef . width
+
+-- | Get the image height
+getImageHeight :: ImageWidget -> IO Int
+getImageHeight = fmap unwrap . readIORef . height
+
+instance ToJSON ImageWidget where
+  toJSON b = object
+               [ "_view_module" .= str ""
+               , "background_color" .= str ""
+               , "border_width" .= str ""
+               , "border_color" .= str ""
+               , "width" .= get width b
+               , "_dom_classes" .= object []
+               , "margin" .= str ""
+               , "font_style" .= str ""
+               , "font_weight" .= str ""
+               , "height" .= get height b
+               , "font_size" .= str ""
+               , "border_style" .= str ""
+               , "padding" .= str ""
+               , "border_radius" .= str ""
+               , "version" .= (0 :: Int)
+               , "font_family" .= str ""
+               , "color" .= str ""
+               , "_view_name" .= str "ImageView"
+               , "visible" .= True
+               , "_css" .= object []
+               , "msg_throttle" .= (3 :: Int)
+               , "format" .= get format b
+               , "_b64value" .= get b64value b
+               ]
+    where
+      get x y = unsafePerformIO . readIORef . x $ y
+
+instance IHaskellDisplay ImageWidget where
+  display b = do
+    widgetSendView b
+    return $ Display []
+
+instance IHaskellWidget ImageWidget where
+  getCommUUID = uuid

ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/String/HTML.hs

@@ -0,0 +1,110 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module IHaskell.Display.Widgets.String.HTML (
+    -- * The HTML Widget
+    HTMLWidget,
+    -- * Constructor
+    mkHTMLWidget,
+    -- * Set properties
+    setHTMLValue,
+    setHTMLDescription,
+    setHTMLPlaceholder,
+    -- * Get properties
+    getHTMLValue,
+    getHTMLDescription,
+    getHTMLPlaceholder,
+    ) where
+
+-- To keep `cabal repl` happy when running from the ihaskell repo
+import           Prelude
+
+import           Control.Monad (when)
+import           Data.Aeson (ToJSON, Value(..), object, toJSON, (.=))
+import           Data.Aeson.Types (Pair)
+import           Data.HashMap.Strict as Map
+import           Data.IORef
+import           Data.Text (Text)
+import qualified Data.Text as T
+import           System.IO.Unsafe (unsafePerformIO)
+
+import           IHaskell.Display
+import           IHaskell.Eval.Widgets
+import qualified IHaskell.IPython.Message.UUID as U
+
+import           IHaskell.Display.Widgets.Common
+
+data HTMLWidget =
+       HTMLWidget
+         { uuid :: U.UUID
+         , value :: IORef Text
+         , description :: IORef Text
+         , placeholder :: IORef Text
+         }
+
+-- | Create a new HTML widget
+mkHTMLWidget :: IO HTMLWidget
+mkHTMLWidget = do
+  -- Default properties, with a random uuid
+  commUUID <- U.random
+  val <- newIORef ""
+  des <- newIORef ""
+  plc <- newIORef ""
+
+  let b = HTMLWidget { uuid = commUUID, value = val, description = des, placeholder = plc }
+
+  let initData = object ["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.HTML"]
+
+  -- Open a comm for this widget, and store it in the kernel state
+  widgetSendOpen b initData (toJSON b)
+
+  -- Return the string widget
+  return b
+
+-- | Set the HTML string value.
+setHTMLValue :: HTMLWidget -> Text -> IO ()
+setHTMLValue b txt = do
+  modify b value txt
+  update b ["value" .= txt]
+
+-- | Set the HTML description
+setHTMLDescription :: HTMLWidget -> Text -> IO ()
+setHTMLDescription b txt = do
+  modify b description txt
+  update b ["description" .= txt]
+
+-- | Set the HTML placeholder, i.e. text displayed in empty widget
+setHTMLPlaceholder :: HTMLWidget -> Text -> IO ()
+setHTMLPlaceholder b txt = do
+  modify b placeholder txt
+  update b ["placeholder" .= txt]
+
+-- | Get the HTML string value.
+getHTMLValue :: HTMLWidget -> IO Text
+getHTMLValue = readIORef . value
+
+-- | Get the HTML description value.
+getHTMLDescription :: HTMLWidget -> IO Text
+getHTMLDescription = readIORef . description
+
+-- | Get the HTML placeholder value.
+getHTMLPlaceholder :: HTMLWidget -> IO Text
+getHTMLPlaceholder = readIORef . placeholder
+
+instance ToJSON HTMLWidget where
+  toJSON b = object
+               [ "_view_name" .= str "HTMLView"
+               , "visible" .= True
+               , "_css" .= object []
+               , "msg_throttle" .= (3 :: Int)
+               , "value" .= get value b
+               ]
+    where
+      get x y = unsafePerformIO . readIORef . x $ y
+
+instance IHaskellDisplay HTMLWidget where
+  display b = do
+    widgetSendView b
+    return $ Display []
+
+instance IHaskellWidget HTMLWidget where
+  getCommUUID = uuid

ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/String/Latex.hs

@@ -0,0 +1,130 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module IHaskell.Display.Widgets.String.Latex (
+    -- * The Latex Widget
+    LatexWidget,
+    -- * Constructor
+    mkLatexWidget,
+    -- * Set properties
+    setLatexValue,
+    setLatexPlaceholder,
+    setLatexDescription,
+    setLatexWidth,
+    -- * Get properties
+    getLatexValue,
+    getLatexPlaceholder,
+    getLatexDescription,
+    getLatexWidth,
+    ) where
+
+-- To keep `cabal repl` happy when running from the ihaskell repo
+import           Prelude
+
+import           Control.Monad (when)
+import           Data.Aeson (ToJSON, Value(..), object, toJSON, (.=))
+import           Data.Aeson.Types (Pair)
+import           Data.HashMap.Strict as Map
+import           Data.IORef
+import           Data.Text (Text)
+import qualified Data.Text as T
+import           System.IO.Unsafe (unsafePerformIO)
+
+import           IHaskell.Display
+import           IHaskell.Eval.Widgets
+import qualified IHaskell.IPython.Message.UUID as U
+
+import           IHaskell.Display.Widgets.Common
+
+data LatexWidget =
+       LatexWidget
+         { uuid :: U.UUID
+         , value :: IORef Text
+         , description :: IORef Text
+         , placeholder :: IORef Text
+         , width :: IORef Int
+         }
+
+-- | Create a new Latex widget
+mkLatexWidget :: IO LatexWidget
+mkLatexWidget = do
+  -- Default properties, with a random uuid
+  commUUID <- U.random
+  val <- newIORef ""
+  des <- newIORef ""
+  plc <- newIORef ""
+  width <- newIORef 400
+
+  let b = LatexWidget
+        { uuid = commUUID
+        , value = val
+        , description = des
+        , placeholder = plc
+        , width = width
+        }
+
+  let initData = object ["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.Latex"]
+
+  -- Open a comm for this widget, and store it in the kernel state
+  widgetSendOpen b initData (toJSON b)
+
+  -- Return the string widget
+  return b
+
+-- | Set the Latex string value.
+setLatexValue :: LatexWidget -> Text -> IO ()
+setLatexValue b txt = do
+  modify b value txt
+  update b ["value" .= txt]
+
+-- | Set the Latex description
+setLatexDescription :: LatexWidget -> Text -> IO ()
+setLatexDescription b txt = do
+  modify b description txt
+  update b ["description" .= txt]
+
+-- | Set the Latex placeholder, i.e. text displayed in empty widget
+setLatexPlaceholder :: LatexWidget -> Text -> IO ()
+setLatexPlaceholder b txt = do
+  modify b placeholder txt
+  update b ["placeholder" .= txt]
+
+-- | Set the Latex widget width.
+setLatexWidth :: LatexWidget -> Int -> IO ()
+setLatexWidth b wid = do
+  modify b width wid
+  update b ["width" .= wid]
+
+-- | Get the Latex string value.
+getLatexValue :: LatexWidget -> IO Text
+getLatexValue = readIORef . value
+
+-- | Get the Latex description value.
+getLatexDescription :: LatexWidget -> IO Text
+getLatexDescription = readIORef . description
+
+-- | Get the Latex placeholder value.
+getLatexPlaceholder :: LatexWidget -> IO Text
+getLatexPlaceholder = readIORef . placeholder
+
+-- | Get the Latex widget width.
+getLatexWidth :: LatexWidget -> IO Int
+getLatexWidth = readIORef . width
+
+instance ToJSON LatexWidget where
+  toJSON b = object
+               [ "_view_name" .= str "LatexView"
+               , "visible" .= True
+               , "_css" .= object []
+               , "msg_throttle" .= (3 :: Int)
+               , "value" .= get value b
+               ]
+    where
+      get x y = unsafePerformIO . readIORef . x $ y
+
+instance IHaskellDisplay LatexWidget where
+  display b = do
+    widgetSendView b
+    return $ Display []
+
+instance IHaskellWidget LatexWidget where
+  getCommUUID = uuid

ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/String/Text.hs

@@ -0,0 +1,152 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module IHaskell.Display.Widgets.String.Text (
+    -- * The Text Widget
+    TextWidget,
+    -- * Constructor
+    mkTextWidget,
+    -- * Set properties
+    setTextValue,
+    setTextDescription,
+    setTextPlaceholder,
+    -- * Get properties
+    getTextValue,
+    getTextDescription,
+    getTextPlaceholder,
+    -- * Submit handling
+    setSubmitHandler,
+    getSubmitHandler,
+    triggerSubmit,
+    ) where
+
+-- To keep `cabal repl` happy when running from the ihaskell repo
+import           Prelude
+
+import           Control.Monad (when, void)
+import           Data.Aeson (ToJSON, Value(..), object, toJSON, (.=))
+import           Data.Aeson.Types (Pair)
+import           Data.HashMap.Strict as Map
+import           Data.IORef
+import           Data.Text (Text)
+import qualified Data.Text as T
+import           System.IO.Unsafe (unsafePerformIO)
+
+import           IHaskell.Display
+import           IHaskell.Eval.Widgets
+import qualified IHaskell.IPython.Message.UUID as U
+
+import           IHaskell.Display.Widgets.Common
+
+data TextWidget =
+       TextWidget
+         { uuid :: U.UUID
+         , value :: IORef Text
+         , description :: IORef Text
+         , placeholder :: IORef Text
+         , submitHandler :: IORef (TextWidget -> IO ())
+         }
+
+-- | Create a new Text widget
+mkTextWidget :: IO TextWidget
+mkTextWidget = do
+  -- Default properties, with a random uuid
+  commUUID <- U.random
+  val <- newIORef ""
+  des <- newIORef ""
+  plc <- newIORef ""
+  sh <- newIORef $ const $ return ()
+
+  let b = TextWidget
+        { uuid = commUUID
+        , value = val
+        , description = des
+        , placeholder = plc
+        , submitHandler = sh
+        }
+
+  let initData = object ["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.Text"]
+
+  -- Open a comm for this widget, and store it in the kernel state
+  widgetSendOpen b initData (toJSON b)
+
+  -- Return the string widget
+  return b
+
+-- | Set the Text string value.
+setTextValue :: TextWidget -> Text -> IO ()
+setTextValue b txt = do
+  modify b value txt
+  update b ["value" .= txt]
+
+-- | Set the text widget "description"
+setTextDescription :: TextWidget -> Text -> IO ()
+setTextDescription b txt = do
+  modify b description txt
+  update b ["description" .= txt]
+
+-- | Set the text widget "placeholder", i.e. text displayed in empty text widget
+setTextPlaceholder :: TextWidget -> Text -> IO ()
+setTextPlaceholder b txt = do
+  modify b placeholder txt
+  update b ["placeholder" .= txt]
+
+-- | Get the Text string value.
+getTextValue :: TextWidget -> IO Text
+getTextValue = readIORef . value
+
+-- | Get the Text widget "description" value.
+getTextDescription :: TextWidget -> IO Text
+getTextDescription = readIORef . description
+
+-- | Get the Text widget placeholder value.
+getTextPlaceholder :: TextWidget -> IO Text
+getTextPlaceholder = readIORef . placeholder
+
+-- | Set a function to be activated on click
+setSubmitHandler :: TextWidget -> (TextWidget -> IO ()) -> IO ()
+setSubmitHandler = writeIORef . submitHandler
+
+-- | Get the submit handler for a TextWidget
+getSubmitHandler :: TextWidget -> IO (TextWidget -> IO ())
+getSubmitHandler = readIORef . submitHandler
+
+-- | Artificially trigger a TextWidget submit
+triggerSubmit :: TextWidget -> IO ()
+triggerSubmit tw = do
+  handler <- getSubmitHandler tw
+  handler tw
+
+instance ToJSON TextWidget where
+  toJSON b = object
+               [ "_view_name" .= str "TextView"
+               , "visible" .= True
+               , "_css" .= object []
+               , "msg_throttle" .= (3 :: Int)
+               , "value" .= get value b
+               , "description" .= get description b
+               , "placeholder" .= get placeholder b
+               ]
+    where
+      get x y = unsafePerformIO . readIORef . x $ y
+
+instance IHaskellDisplay TextWidget where
+  display b = do
+    widgetSendView b
+    return $ Display []
+
+instance IHaskellWidget TextWidget where
+  getCommUUID = uuid
+  -- Two possibilities: 1. content -> event -> "submit" 2. sync_data -> value -> <new_value>
+  comm tw (Object dict1) _ =
+    case Map.lookup "sync_data" dict1 of
+      Just (Object dict2) ->
+        case Map.lookup "value" dict2 of
+          Just (String val) -> setTextValue tw val
+          Nothing           -> return ()
+      Nothing ->
+        case Map.lookup "content" dict1 of
+          Just (Object dict2) ->
+            case Map.lookup "event" dict2 of
+              Just (String event) -> when (event == "submit") $ triggerSubmit tw
+              Nothing             -> return ()
+          Nothing -> return ()

ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/String/TextArea.hs

@@ -0,0 +1,113 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module IHaskell.Display.Widgets.String.TextArea (
+    -- * The TextArea Widget
+    TextAreaWidget,
+    -- * Constructor
+    mkTextAreaWidget,
+    -- * Set properties
+    setTextAreaValue,
+    setTextAreaDescription,
+    setTextAreaPlaceholder,
+    -- * Get properties
+    getTextAreaValue,
+    getTextAreaDescription,
+    getTextAreaPlaceholder,
+    ) where
+
+-- To keep `cabal repl` happy when running from the ihaskell repo
+import           Prelude
+
+import           Control.Monad (when)
+import           Data.Aeson (ToJSON, Value(..), object, toJSON, (.=))
+import           Data.Aeson.Types (Pair)
+import           Data.HashMap.Strict as Map
+import           Data.IORef
+import           Data.Text (Text)
+import qualified Data.Text as T
+import           System.IO.Unsafe (unsafePerformIO)
+
+import           IHaskell.Display
+import           IHaskell.Eval.Widgets
+import qualified IHaskell.IPython.Message.UUID as U
+
+import           IHaskell.Display.Widgets.Common
+
+data TextAreaWidget =
+       TextAreaWidget
+         { uuid :: U.UUID
+         , value :: IORef Text
+         , description :: IORef Text
+         , placeholder :: IORef Text
+         }
+
+-- | Create a new TextArea widget
+mkTextAreaWidget :: IO TextAreaWidget
+mkTextAreaWidget = do
+  -- Default properties, with a random uuid
+  commUUID <- U.random
+  val <- newIORef ""
+  des <- newIORef ""
+  plc <- newIORef ""
+
+  let b = TextAreaWidget { uuid = commUUID, value = val, description = des, placeholder = plc }
+
+  let initData = object
+                   ["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.Textarea"]
+
+  -- Open a comm for this widget, and store it in the kernel state
+  widgetSendOpen b initData (toJSON b)
+
+  -- Return the string widget
+  return b
+
+-- | Set the TextArea string value.
+setTextAreaValue :: TextAreaWidget -> Text -> IO ()
+setTextAreaValue b txt = do
+  modify b value txt
+  update b ["value" .= txt]
+
+-- | Set the TextArea widget "description"
+setTextAreaDescription :: TextAreaWidget -> Text -> IO ()
+setTextAreaDescription b txt = do
+  modify b description txt
+  update b ["description" .= txt]
+
+-- | Set the TextArea widget "placeholder", i.e. text displayed in empty widget
+setTextAreaPlaceholder :: TextAreaWidget -> Text -> IO ()
+setTextAreaPlaceholder b txt = do
+  modify b placeholder txt
+  update b ["placeholder" .= txt]
+
+-- | Get the TextArea string value.
+getTextAreaValue :: TextAreaWidget -> IO Text
+getTextAreaValue = readIORef . value
+
+-- | Get the TextArea widget "description" value.
+getTextAreaDescription :: TextAreaWidget -> IO Text
+getTextAreaDescription = readIORef . description
+
+-- | Get the TextArea widget placeholder value.
+getTextAreaPlaceholder :: TextAreaWidget -> IO Text
+getTextAreaPlaceholder = readIORef . placeholder
+
+instance ToJSON TextAreaWidget where
+  toJSON b = object
+               [ "_view_name" .= str "TextareaView"
+               , "visible" .= True
+               , "_css" .= object []
+               , "msg_throttle" .= (3 :: Int)
+               , "value" .= get value b
+               , "description" .= get description b
+               , "placeholder" .= get placeholder b
+               ]
+    where
+      get x y = unsafePerformIO . readIORef . x $ y
+
+instance IHaskellDisplay TextAreaWidget where
+  display b = do
+    widgetSendView b
+    return $ Display []
+
+instance IHaskellWidget TextAreaWidget where
+  getCommUUID = uuid

ihaskell.cabal

@@ -106,7 +106,9 @@ library
                    IHaskell.Eval.Parser
                    IHaskell.Eval.Hoogle
                    IHaskell.Eval.ParseShell
+                   IHaskell.Eval.Widgets
                    IHaskell.Eval.Util
+                   IHaskell.Publish
                    IHaskell.IPython
                    IHaskell.IPython.Stdin
                    IHaskell.Flags

main/Main.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP, ScopedTypeVariables, QuasiQuotes #-}
+{-# LANGUAGE CPP, ScopedTypeVariables #-}
 
 -- | Description : Argument parsing and basic messaging loop, using Haskell
 --                 Chans to communicate with the ZeroMQ sockets.
@@ -30,9 +30,11 @@ import           IHaskell.Eval.Inspect (inspect)
 import           IHaskell.Eval.Evaluate
 import           IHaskell.Display
 import           IHaskell.Eval.Info
+import           IHaskell.Eval.Widgets (widgetHandler)
 import           IHaskell.Flags
 import           IHaskell.IPython
 import           IHaskell.Types
+import           IHaskell.Publish
 import           IHaskell.IPython.ZeroMQ
 import           IHaskell.IPython.Types
 import qualified IHaskell.IPython.Message.UUID as UUID
@@ -48,9 +50,6 @@ ghcVersionInts = map (fromJust . readMay) . words . map dotToSpace $ VERSION_ghc
     dotToSpace '.' = ' '
     dotToSpace x = x
 
-ihaskellCSS :: String
-ihaskellCSS = [hereFile|html/custom.css|]
-
 consoleBanner :: Text
 consoleBanner =
   "Welcome to IHaskell! Run `IHaskell --help` for more information.\n" <>
@@ -124,11 +123,12 @@ runKernel kernelOpts profileSrc = do
 
     -- Initialize the context by evaluating everything we got from the command line flags.
     let noPublish _ = return ()
+        noWidget s _ = return s
         evaluator line = void $ do
           -- Create a new state each time.
           stateVar <- liftIO initialKernelState
           state <- liftIO $ takeMVar stateVar
-          evaluate state line noPublish
+          evaluate state line noPublish noWidget
 
     confFile <- liftIO $ kernelSpecConfFile kernelOpts
     case confFile of
@@ -145,12 +145,14 @@ runKernel kernelOpts profileSrc = do
       -- We handle comm messages and normal ones separately. The normal ones are a standard
       -- request/response style, while comms can be anything, and don't necessarily require a response.
       if isCommMessage request
-        then liftIO $ do
-          oldState <- takeMVar state
+        then do
+          oldState <- liftIO $ takeMVar state
           let replier = writeChan (iopubChannel interface)
-          newState <- handleComm replier oldState request replyHeader
-          putMVar state newState
-          writeChan (shellReplyChannel interface) SendNothing
+              widgetMessageHandler = widgetHandler replier replyHeader
+          tempState <- handleComm replier oldState request replyHeader
+          newState <- flushWidgetMessages tempState [] widgetMessageHandler
+          liftIO $ putMVar state newState
+          liftIO $ writeChan (shellReplyChannel interface) SendNothing
         else do
           -- Create the reply, possibly modifying kernel state.
           oldState <- liftIO $ takeMVar state
@@ -171,13 +173,6 @@ runKernel kernelOpts profileSrc = do
 initialKernelState :: IO (MVar KernelState)
 initialKernelState = newMVar defaultKernelState
 
--- | Duplicate a message header, giving it a new UUID and message type.
-dupHeader :: MessageHeader -> MessageType -> IO MessageHeader
-dupHeader header messageType = do
-  uuid <- liftIO UUID.random
-
-  return header { messageId = uuid, msgType = messageType }
-
 -- | Create a new message header, given a parent message header.
 createReplyHeader :: MessageHeader -> Interpreter MessageHeader
 createReplyHeader parent = do
@@ -239,72 +234,6 @@ replyTo interface req@ExecuteRequest { getCode = code } replyHeader state = do
   displayed <- liftIO $ newMVar []
   updateNeeded <- liftIO $ newMVar False
   pagerOutput <- liftIO $ newMVar []
-  let clearOutput = do
-        header <- dupHeader replyHeader ClearOutputMessage
-        send $ ClearOutput header True
-
-      sendOutput (ManyDisplay manyOuts) = mapM_ sendOutput manyOuts
-      sendOutput (Display outs) = do
-        header <- dupHeader replyHeader DisplayDataMessage
-        send $ PublishDisplayData header "haskell" $ map (convertSvgToHtml . prependCss) outs
-
-      convertSvgToHtml (DisplayData MimeSvg svg) = html $ makeSvgImg $ base64 $ E.encodeUtf8 svg
-      convertSvgToHtml x = x
-
-      makeSvgImg :: Base64 -> String
-      makeSvgImg base64data = T.unpack $ "<img src=\"data:image/svg+xml;base64," <>
-                                         base64data <>
-                                         "\"/>"
-
-      prependCss (DisplayData MimeHtml html) =
-        DisplayData MimeHtml $ mconcat ["<style>", T.pack ihaskellCSS, "</style>", html]
-      prependCss x = x
-
-      startComm :: CommInfo -> IO ()
-      startComm (CommInfo widget uuid target) = do
-        -- Send the actual comm open.
-        header <- dupHeader replyHeader CommOpenMessage
-        send $ CommOpen header target uuid (Object mempty)
-
-        -- Send anything else the widget requires.
-        let communicate value = do
-              head <- dupHeader replyHeader CommDataMessage
-              writeChan (iopubChannel interface) $ CommData head uuid value
-        open widget communicate
-
-      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
-          clearOutput
-          disps <- readMVar displayed
-          mapM_ sendOutput $ reverse disps
-
-        -- Draw this message.
-        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 $ do
-          modifyMVar_ displayed (return . (outs :))
-
-          -- Start all comms that need to be started.
-          mapM_ startComm $ startComms result
-
-          -- If this has some pager output, store it for later.
-          let pager = pagerOut result
-          unless (null pager) $
-            if usePager state
-              then modifyMVar_ pagerOutput (return . (++ pager))
-              else sendOutput $ Display pager
 
   let execCount = getExecutionCounter state
   -- Let all frontends know the execution count and code that's about to run
@@ -312,7 +241,9 @@ replyTo interface req@ExecuteRequest { getCode = code } replyHeader state = do
   send $ PublishInput inputHeader (T.unpack code) execCount
 
   -- Run code and publish to the frontend as we go.
-  updatedState <- evaluate state (T.unpack code) publish
+  let widgetMessageHandler = widgetHandler send replyHeader
+      publish = publishResult send replyHeader displayed updateNeeded pagerOutput (usePager state)
+  updatedState <- evaluate state (T.unpack code) publish widgetMessageHandler
 
   -- Notify the frontend that we're done computing.
   idleHeader <- liftIO $ dupHeader replyHeader StatusMessage
@@ -362,21 +293,49 @@ replyTo _ HistoryRequest{} replyHeader state = do
         }
   return (state, reply)
 
-handleComm :: (Message -> IO ()) -> KernelState -> Message -> MessageHeader -> IO KernelState
-handleComm replier kernelState req replyHeader = do
+-- | Handle comm messages
+handleComm :: (Message -> IO ()) -> KernelState -> Message -> MessageHeader -> Interpreter KernelState
+handleComm send kernelState req replyHeader = do
+  -- MVars to hold intermediate data during publishing
+  displayed <- liftIO $ newMVar []
+  updateNeeded <- liftIO $ newMVar False
+  pagerOutput <- liftIO $ newMVar []
+
   let widgets = openComms kernelState
       uuid = commUuid req
       dat = commData req
       communicate value = do
         head <- dupHeader replyHeader CommDataMessage
-        replier $ CommData head uuid value
-  case Map.lookup uuid widgets of
-    Nothing -> fail $ "no widget with uuid " ++ show uuid
+        send $ CommData head uuid value
+      toUsePager = usePager kernelState
+
+  -- Create a publisher according to current state, use that to build
+  -- a function that executes an IO action and publishes the output to
+  -- the frontend simultaneously.
+  let run = capturedIO publish kernelState
+      publish = publishResult send replyHeader displayed updateNeeded pagerOutput toUsePager
+
+  -- Notify the frontend that the kernel is busy
+  busyHeader <- liftIO $ dupHeader replyHeader StatusMessage
+  liftIO . send $ PublishStatus busyHeader Busy
+
+  newState <- case Map.lookup uuid widgets of
+    Nothing -> return kernelState
     Just (Widget widget) ->
       case msgType $ header req of
         CommDataMessage -> do
-          comm widget dat communicate
+          disp <- run $ comm widget dat communicate
+          pgrOut <- liftIO $ readMVar pagerOutput
+          liftIO $ publish $ FinalResult disp (if toUsePager then pgrOut else []) []
           return kernelState
         CommCloseMessage -> do
-          close widget dat
+          disp <- run $ close widget dat
+          pgrOut <- liftIO $ readMVar pagerOutput
+          liftIO $ publish $ FinalResult disp (if toUsePager then pgrOut else []) []
           return kernelState { openComms = Map.delete uuid widgets }
+
+  -- Notify the frontend that the kernel is idle once again
+  idleHeader <- liftIO $ dupHeader replyHeader StatusMessage
+  liftIO . send $ PublishStatus idleHeader Idle
+
+  return newState

src/IHaskell/Display.hs

@@ -68,6 +68,7 @@ import           System.IO.Unsafe (unsafePerformIO)
 import qualified Data.Text.Encoding as E
 
 import           IHaskell.Types
+import           IHaskell.Eval.Util (unfoldM)
 import           StringUtils (rstrip)
 
 type Base64 = Text
@@ -154,12 +155,6 @@ displayFromChan :: IO (Maybe Display)
 displayFromChan =
   Just . many <$> unfoldM (atomically $ tryReadTChan displayChan)
 
--- | This is unfoldM from monad-loops. It repeatedly runs an IO action until it return Nothing, and
--- puts all the Justs in a list. If you find yourself using more functionality from monad-loops,
--- just add the package dependency instead of copying more code from it.
-unfoldM :: IO (Maybe a) -> IO [a]
-unfoldM f = maybe (return []) (\r -> (r :) <$> unfoldM f) =<< f
-
 -- | Write to the display channel. The contents will be displayed in the notebook once the current
 -- execution call ends.
 printDisplay :: IHaskellDisplay a => a -> IO ()

src/IHaskell/Eval/Evaluate.hs

@@ -8,11 +8,13 @@ This module exports all functions used for evaluation of IHaskell input.
 module IHaskell.Eval.Evaluate (
     interpret,
     evaluate,
+    flushWidgetMessages,
     Interpreter,
     liftIO,
     typeCleaner,
     globalImports,
     formatType,
+    capturedIO,
     ) where
 
 import           IHaskellPrelude
@@ -82,6 +84,7 @@ import           IHaskell.Eval.Lint
 import           IHaskell.Display
 import qualified IHaskell.Eval.Hoogle as Hoogle
 import           IHaskell.Eval.Util
+import           IHaskell.Eval.Widgets
 import           IHaskell.BrokenPackages
 import qualified IHaskell.IPython.Message.UUID as UUID
 import           StringUtils (replace, split, strip, rstrip)
@@ -133,6 +136,7 @@ globalImports =
   , "import qualified System.Directory as IHaskellDirectory"
   , "import qualified IHaskell.Display"
   , "import qualified IHaskell.IPython.Stdin"
+  , "import qualified IHaskell.Eval.Widgets"
   , "import qualified System.Posix.IO as IHaskellIO"
   , "import qualified System.IO as IHaskellSysIO"
   , "import qualified Language.Haskell.TH as IHaskellTH"
@@ -223,7 +227,7 @@ initializeImports = do
       dropFirstAndLast = reverse . drop 1 . reverse . drop 1
 
       toImportStmt :: String -> String
-      toImportStmt = printf importFmt . concat . map capitalize . dropFirstAndLast . split "-"
+      toImportStmt = printf importFmt . concatMap capitalize . dropFirstAndLast . split "-"
 
       displayImports = map toImportStmt displayPackages
 
@@ -237,7 +241,7 @@ initializeImports = do
 
 -- | Give a value for the `it` variable.
 initializeItVariable :: Interpreter ()
-initializeItVariable = do
+initializeItVariable =
   -- This is required due to the way we handle `it` in the wrapper statements - if it doesn't exist,
   -- the first statement will fail.
   void $ runStmt "let it = ()" RunToCompletion
@@ -253,7 +257,7 @@ data EvalOut =
          , evalResult :: Display
          , evalState :: KernelState
          , evalPager :: String
-         , evalComms :: [CommInfo]
+         , evalMsgs :: [WidgetMsg]
          }
 
 cleanString :: String -> String
@@ -274,9 +278,10 @@ cleanString x = if allBrackets
 -- | Evaluate some IPython input code.
 evaluate :: KernelState                  -- ^ The kernel state.
          -> String                       -- ^ Haskell code or other interpreter commands.
-         -> (EvaluationResult -> IO ())   -- ^ Function used to publish data outputs.
+         -> Publisher                    -- ^ Function used to publish data outputs.
+         -> (KernelState -> [WidgetMsg] -> IO KernelState) -- ^ Function to handle widget messages
          -> Interpreter KernelState
-evaluate kernelState code output = do
+evaluate kernelState code output widgetHandler = do
   cmds <- parseString (cleanString code)
   let execCount = getExecutionCounter kernelState
 
@@ -322,12 +327,15 @@ evaluate kernelState code output = do
           helpStr = evalPager evalOut
 
       -- Output things only if they are non-empty.
-      let empty = noResults result && null helpStr && null (evalComms evalOut)
+      let empty = noResults result && null helpStr
       unless empty $
-        liftIO $ output $ FinalResult result [plain helpStr] (evalComms evalOut)
+        liftIO $ output $ FinalResult result [plain helpStr] []
 
-      -- Make sure to clear all comms we've started.
-      let newState = evalState evalOut { evalComms = [] }
+      let tempMsgs = evalMsgs evalOut
+          tempState = evalState evalOut { evalMsgs = [] }
+
+      -- Handle the widget messages
+      newState <- flushWidgetMessages tempState tempMsgs widgetHandler
 
       case evalStatus evalOut of
         Success -> runUntilFailure newState rest
@@ -335,12 +343,27 @@ evaluate kernelState code output = do
 
     storeItCommand execCount = Statement $ printf "let it%d = it" execCount
 
-    extractValue :: Typeable a => String -> Interpreter a
-    extractValue expr = do
-      compiled <- dynCompileExpr expr
-      case fromDynamic compiled of
-        Nothing     -> error "Error casting types in Evaluate.hs"
-        Just result -> return result
+-- | Compile a string and extract a value from it. Effectively extract the result of an expression
+-- from inside the notebook environment.
+extractValue :: Typeable a => String -> Interpreter a
+extractValue expr = do
+  compiled <- dynCompileExpr expr
+  case fromDynamic compiled of
+    Nothing     -> error "Error casting types in Evaluate.hs"
+    Just result -> return result
+
+flushWidgetMessages :: KernelState
+                    -> [WidgetMsg]
+                    -> (KernelState -> [WidgetMsg] -> IO KernelState)
+                    -> Interpreter KernelState
+flushWidgetMessages state evalMsgs widgetHandler = do
+  -- Capture all widget messages queued during code execution
+  messagesIO <- extractValue "IHaskell.Eval.Widgets.relayWidgetMessages"
+  messages <- liftIO messagesIO
+
+  -- Handle all the widget messages
+  let commMessages = evalMsgs ++ messages
+  liftIO $ widgetHandler state commMessages
 
 safely :: KernelState -> Interpreter EvalOut -> Interpreter EvalOut
 safely state = ghandle handler . ghandle sourceErrorHandler
@@ -353,7 +376,7 @@ safely state = ghandle handler . ghandle sourceErrorHandler
           , evalResult = displayError $ show exception
           , evalState = state
           , evalPager = ""
-          , evalComms = []
+          , evalMsgs = []
           }
 
     sourceErrorHandler :: SourceError -> Interpreter EvalOut
@@ -372,7 +395,7 @@ safely state = ghandle handler . ghandle sourceErrorHandler
           , evalResult = displayError fullErr
           , evalState = state
           , evalPager = ""
-          , evalComms = []
+          , evalMsgs = []
           }
 
 wrapExecution :: KernelState
@@ -386,7 +409,7 @@ wrapExecution state exec = safely state $
         , evalResult = res
         , evalState = state
         , evalPager = ""
-        , evalComms = []
+        , evalMsgs = []
         }
 
 -- | Return the display data for this command, as well as whether it resulted in an error.
@@ -476,11 +499,11 @@ evalCommand output (Directive SetDynFlag flagsStr) state = safely state $ do
                            ]
           , evalState = state
           , evalPager = ""
-          , evalComms = []
+          , evalMsgs = []
           }
     else do
       -- Apply all IHaskell flag updaters to the state to get the new state
-      let state' = (foldl' (.) id (map (fromJust . ihaskellFlagUpdater) ihaskellFlags)) state
+      let state' = foldl' (.) id (map (fromJust . ihaskellFlagUpdater) ihaskellFlags) state
       errs <- setFlags ghcFlags
       let display =
             case errs of
@@ -502,7 +525,7 @@ evalCommand output (Directive SetDynFlag flagsStr) state = safely state $ do
           , evalResult = display
           , evalState = state'
           , evalPager = ""
-          , evalComms = []
+          , evalMsgs = []
           }
 
 evalCommand output (Directive SetExtension opts) state = do
@@ -536,7 +559,7 @@ evalCommand a (Directive SetOption opts) state = do
                 , evalResult = displayError err
                 , evalState = state
                 , evalPager = ""
-                , evalComms = []
+                , evalMsgs = []
                 }
     else let options = mapMaybe findOption $ words opts
              updater = foldl' (.) id $ map getUpdateKernelState options
@@ -546,7 +569,7 @@ evalCommand a (Directive SetOption opts) state = do
                 , evalResult = mempty
                 , evalState = updater state
                 , evalPager = ""
-                , evalComms = []
+                , evalMsgs = []
                 }
 
   where
@@ -680,7 +703,7 @@ evalCommand _ (Directive GetHelp _) state = do
       , evalResult = Display [out]
       , evalState = state
       , evalPager = ""
-      , evalComms = []
+      , evalMsgs = []
       }
 
   where
@@ -729,7 +752,7 @@ evalCommand _ (Directive GetInfo str) state = safely state $ do
       , evalResult = mempty
       , evalState = state
       , evalPager = output
-      , evalComms = []
+      , evalMsgs = []
       }
 
 evalCommand _ (Directive SearchHoogle query) state = safely state $ do
@@ -740,44 +763,8 @@ evalCommand _ (Directive GetDoc query) state = safely state $ do
   results <- liftIO $ Hoogle.document query
   return $ hoogleResults state results
 
-evalCommand output (Statement stmt) state = wrapExecution state $ do
-  write state $ "Statement:\n" ++ stmt
-  let outputter str = output $ IntermediateResult $ Display [plain str]
-  (printed, result) <- capturedStatement outputter stmt
-  case result of
-    RunOk names -> do
-      dflags <- getSessionDynFlags
-
-      let allNames = map (showPpr dflags) names
-          isItName name =
-            name == "it" ||
-            name == "it" ++ show (getExecutionCounter state)
-          nonItNames = filter (not . isItName) allNames
-          output = [plain printed | not . null $ strip printed]
-
-      write state $ "Names: " ++ show allNames
-
-      -- Display the types of all bound names if the option is on. This is similar to GHCi :set +t.
-      if not $ useShowTypes state
-        then return $ Display output
-        else do
-          -- Get all the type strings.
-          types <- forM nonItNames $ \name -> do
-                     theType <- showSDocUnqual dflags . ppr <$> exprType name
-                     return $ name ++ " :: " ++ theType
-
-          let joined = unlines types
-              htmled = unlines $ map formatGetType types
-
-          return $
-            case extractPlain output of
-              "" -> Display [html htmled]
-
-              -- Return plain and html versions. Previously there was only a plain version.
-              text -> Display [plain $ joined ++ "\n" ++ text, html $ htmled ++ mono text]
-
-    RunException exception -> throw exception
-    RunBreak{} -> error "Should not break."
+evalCommand output (Statement stmt) state = wrapExecution state $ evalStatementOrIO output state
+                                                                    (CapturedStmt stmt)
 
 evalCommand output (Expression expr) state = do
   write state $ "Expression:\n" ++ expr
@@ -806,7 +793,7 @@ evalCommand output (Expression expr) state = do
     -- If it typechecks as a DecsQ, we do not want to display the DecsQ, we just want the
     -- declaration made.
     do
-      write state $ "Suppressing display for template haskell declaration"
+      write state "Suppressing display for template haskell declaration"
       GHC.runDecls expr
       return
         EvalOut
@@ -814,31 +801,25 @@ evalCommand output (Expression expr) state = do
           , evalResult = mempty
           , evalState = state
           , evalPager = ""
-          , evalComms = []
+          , evalMsgs = []
           }
-    else do
-      if canRunDisplay
-        then do
-          -- Use the display. As a result, `it` is set to the output.
-          out <- useDisplay displayExpr
+    else if canRunDisplay
+           then 
+           -- Use the display. As a result, `it` is set to the output.
+           useDisplay displayExpr
+           else do
+             -- Evaluate this expression as though it's just a statement. The output is bound to 'it', so we can
+             -- then use it.
+             evalOut <- evalCommand output (Statement expr) state
 
-          -- Register the `it` object as a widget.
-          if isWidget
-            then registerWidget out
-            else return out
-        else do
-          -- Evaluate this expression as though it's just a statement. The output is bound to 'it', so we can
-          -- then use it.
-          evalOut <- evalCommand output (Statement expr) state
+             let out = evalResult evalOut
+                 showErr = isShowError out
 
-          let out = evalResult evalOut
-              showErr = isShowError out
-
-          -- If evaluation failed, return the failure. If it was successful, we may be able to use the
-          -- IHaskellDisplay typeclass.
-          return $ if not showErr || useShowErrors state
-                     then evalOut
-                     else postprocessShowError evalOut
+             -- If evaluation failed, return the failure. If it was successful, we may be able to use the
+             -- IHaskellDisplay typeclass.
+             return $ if not showErr || useShowErrors state
+                        then evalOut
+                        else postprocessShowError evalOut
 
   where
     -- Try to evaluate an action. Return True if it succeeds and False if it throws an exception. The
@@ -897,28 +878,6 @@ evalCommand output (Expression expr) state = do
                       then display :: Display
                       else removeSvg display
 
-    registerWidget :: EvalOut -> Ghc EvalOut
-    registerWidget evalOut =
-      case evalStatus evalOut of
-        Failure -> return evalOut
-        Success -> do
-          element <- dynCompileExpr "IHaskell.Display.Widget it"
-          case fromDynamic element of
-            Nothing -> error "Expecting widget"
-            Just widget -> do
-              -- Stick the widget in the kernel state.
-              uuid <- liftIO UUID.random
-              let state = evalState evalOut
-                  newComms = Map.insert uuid widget $ openComms state
-                  state' = state { openComms = newComms }
-
-              -- Store the fact that we should start this comm.
-              return
-                evalOut
-                  { evalComms = CommInfo widget uuid (targetName widget) : evalComms evalOut
-                  , evalState = state'
-                  }
-
     isIO expr = attempt $ exprType $ printf "((\\x -> x) :: IO a -> IO a) (%s)" expr
 
     postprocessShowError :: EvalOut -> EvalOut
@@ -987,7 +946,7 @@ evalCommand _ (ParseError loc err) state = do
       , evalResult = displayError $ formatParseError loc err
       , evalState = state
       , evalPager = ""
-      , evalComms = []
+      , evalMsgs = []
       }
 
 evalCommand _ (Pragma (PragmaUnsupported pragmaType) pragmas) state = wrapExecution state $
@@ -1004,7 +963,7 @@ hoogleResults state results =
     , evalResult = mempty
     , evalState = state
     , evalPager = output
-    , evalComms = []
+    , evalMsgs = []
     }
   where
     -- TODO: Make pager work with plaintext
@@ -1031,7 +990,7 @@ doLoadModule name modName = do
     oldTargets <- getTargets
     -- Add a target, but make sure targets are unique!
     addTarget target
-    getTargets >>= return . (nubBy ((==) `on` targetId)) >>= setTargets
+    getTargets >>= return . nubBy ((==) `on` targetId) >>= setTargets
     result <- load LoadAllTargets
 
     -- Reset the context, since loading things screws it up.
@@ -1093,10 +1052,13 @@ keepingItVariable act = do
   goStmt $ printf "let it = %s" itVariable
   act
 
-capturedStatement :: (String -> IO ())         -- ^ Function used to publish intermediate output.
-                  -> String                            -- ^ Statement to evaluate.
-                  -> Interpreter (String, RunResult)   -- ^ Return the output and result.
-capturedStatement output stmt = do
+data Captured a = CapturedStmt String
+                | CapturedIO (IO a)
+
+capturedEval :: (String -> IO ()) -- ^ Function used to publish intermediate output.
+             -> Captured a -- ^ Statement to evaluate.
+             -> Interpreter (String, RunResult) -- ^ Return the output and result.
+capturedEval output stmt = do
   -- Generate random variable names to use so that we cannot accidentally override the variables by
   -- using the right names in the terminal.
   gen <- liftIO getStdGen
@@ -1140,6 +1102,14 @@ capturedStatement output stmt = do
       goStmt :: String -> Ghc RunResult
       goStmt s = runStmt s RunToCompletion
 
+      runWithResult (CapturedStmt str) = goStmt str
+      runWithResult (CapturedIO io) = do
+        status <- gcatch (liftIO io >> return NoException) (return . AnyException)
+        return $
+          case status of
+            NoException    -> RunOk []
+            AnyException e -> RunException e
+
   -- Initialize evaluation context.
   void $ forM initStmts goStmt
 
@@ -1155,7 +1125,6 @@ capturedStatement output stmt = do
             fd <- head <$> unsafeCoerce hValues
             fdToHandle fd
 
-
   -- Keep track of whether execution has completed.
   completed <- liftIO $ newMVar False
   finishedReading <- liftIO newEmptyMVar
@@ -1198,7 +1167,7 @@ capturedStatement output stmt = do
 
   liftIO $ forkIO loop
 
-  result <- gfinally (goStmt stmt) $ do
+  result <- gfinally (runWithResult stmt) $ do
               -- Execution is done.
               liftIO $ modifyMVar_ completed (const $ return True)
 
@@ -1212,6 +1181,63 @@ capturedStatement output stmt = do
   printedOutput <- liftIO $ readMVar outputAccum
   return (printedOutput, result)
 
+data AnyException = NoException
+                  | AnyException SomeException
+
+capturedIO :: Publisher -> KernelState -> IO a -> Interpreter Display
+capturedIO publish state action = do
+  let showError = return . displayError . show
+      handler e@SomeException{} = showError e
+  gcatch (evalStatementOrIO publish state (CapturedIO action)) handler
+
+-- | Evaluate a @Captured@, and then publish the final result to the frontend. Returns the final
+-- Display.
+evalStatementOrIO :: Publisher -> KernelState -> Captured a -> Interpreter Display
+evalStatementOrIO publish state cmd = do
+  let output str = publish . IntermediateResult $ Display [plain str]
+
+  case cmd of
+    CapturedStmt stmt ->
+      write state $ "Statement:\n" ++ stmt
+    CapturedIO io ->
+      write state "Evaluating Action"
+
+  (printed, result) <- capturedEval output cmd
+  case result of
+    RunOk names -> do
+      dflags <- getSessionDynFlags
+
+      let allNames = map (showPpr dflags) names
+          isItName name =
+            name == "it" ||
+            name == "it" ++ show (getExecutionCounter state)
+          nonItNames = filter (not . isItName) allNames
+          output = [plain printed | not . null $ strip printed]
+
+      write state $ "Names: " ++ show allNames
+
+      -- Display the types of all bound names if the option is on. This is similar to GHCi :set +t.
+      if not $ useShowTypes state
+        then return $ Display output
+        else do
+          -- Get all the type strings.
+          types <- forM nonItNames $ \name -> do
+                     theType <- showSDocUnqual dflags . ppr <$> exprType name
+                     return $ name ++ " :: " ++ theType
+
+          let joined = unlines types
+              htmled = unlines $ map formatGetType types
+
+          return $
+            case extractPlain output of
+              "" -> Display [html htmled]
+
+              -- Return plain and html versions. Previously there was only a plain version.
+              text -> Display [plain $ joined ++ "\n" ++ text, html $ htmled ++ mono text]
+
+    RunException exception -> throw exception
+    RunBreak{} -> error "Should not break."
+
 -- Read from a file handle until we hit a delimiter or until we've read as many characters as
 -- requested
 readChars :: Handle -> String -> Int -> IO String

src/IHaskell/Eval/Util.hs

@@ -21,6 +21,9 @@ module IHaskell.Eval.Util (
     doc,
     pprDynFlags,
     pprLanguages,
+
+    -- * Monad-loops
+    unfoldM,
     ) where
 
 import           IHaskellPrelude
@@ -338,6 +341,12 @@ getType expr = do
   let typeStr = O.showSDocUnqual flags $ O.ppr result
   return typeStr
 
+-- | This is unfoldM from monad-loops. It repeatedly runs an IO action until it return Nothing, and
+-- puts all the Justs in a list. If you find yourself using more functionality from monad-loops,
+-- just add the package dependency instead of copying more code from it.
+unfoldM :: IO (Maybe a) -> IO [a]
+unfoldM f = maybe (return []) (\r -> (r :) <$> unfoldM f) =<< f
+
 -- | A wrapper around @getInfo@. Return info about each name in the string.
 getDescription :: GhcMonad m => String -> m [String]
 getDescription str = do

src/IHaskell/Eval/Widgets.hs

@@ -0,0 +1,155 @@
+module IHaskell.Eval.Widgets (
+    widgetSendOpen,
+    widgetSendView,
+    widgetSendUpdate,
+    widgetSendCustom,
+    widgetSendClose,
+    widgetSendValue,
+    relayWidgetMessages,
+    widgetHandler,
+    ) where
+
+import           IHaskellPrelude
+
+import           Control.Concurrent.Chan (writeChan)
+import           Control.Concurrent.STM (atomically)
+import           Control.Concurrent.STM.TChan
+import           Control.Monad (foldM)
+import           Data.Aeson
+import qualified Data.Map as Map
+import           System.IO.Unsafe (unsafePerformIO)
+
+import           IHaskell.Display
+import           IHaskell.Eval.Util (unfoldM)
+import           IHaskell.IPython.Message.UUID
+import           IHaskell.Types
+
+-- All comm_open messages go here
+widgetMessages :: TChan WidgetMsg
+{-# NOINLINE widgetMessages #-}
+widgetMessages = unsafePerformIO newTChanIO
+
+-- | Return all pending comm_close messages
+relayWidgetMessages :: IO [WidgetMsg]
+relayWidgetMessages = relayMessages widgetMessages
+
+-- | Extract all messages from a TChan and wrap them in a list
+relayMessages :: TChan a -> IO [a]
+relayMessages = unfoldM . atomically . tryReadTChan
+
+-- | Write a widget message to the chan
+queue :: WidgetMsg -> IO ()
+queue = atomically . writeTChan widgetMessages
+
+-- | Send a message
+widgetSend :: IHaskellWidget a
+           => (Widget -> Value -> WidgetMsg)
+           -> a -> Value -> IO ()
+widgetSend msgType widget value = queue $ msgType (Widget widget) value
+
+-- | Send a message to open a comm
+widgetSendOpen :: IHaskellWidget a => a -> Value -> Value -> IO ()
+widgetSendOpen widget initVal stateVal =
+  queue $ Open (Widget widget) initVal stateVal
+
+-- | Send a state update message
+widgetSendUpdate :: IHaskellWidget a => a -> Value -> IO ()
+widgetSendUpdate = widgetSend Update
+
+-- | Send a [method .= display] comm_msg
+widgetSendView :: IHaskellWidget a => a -> IO ()
+widgetSendView = queue . View . Widget
+
+-- | Send a comm_close
+widgetSendClose :: IHaskellWidget a => a -> Value -> IO ()
+widgetSendClose = widgetSend Close
+
+-- | Send a [method .= custom, content .= value] comm_msg
+widgetSendCustom :: IHaskellWidget a => a -> Value -> IO ()
+widgetSendCustom = widgetSend Custom
+
+-- | Send a custom Value
+widgetSendValue :: IHaskellWidget a => a -> Value -> IO ()
+widgetSendValue widget = queue . JSONValue (Widget widget)
+
+-- | 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 ())
+              -> MessageHeader
+              -> KernelState
+              -> WidgetMsg
+              -> IO KernelState
+handleMessage send replyHeader state msg = do
+  case msg of
+    Open widget initVal stateVal -> do
+      let target = targetName widget
+          uuid = getCommUUID widget
+          present = isJust $ Map.lookup uuid oldComms
+
+          newComms = Map.insert uuid widget oldComms
+          newState = state { openComms = newComms }
+
+          communicate val = do
+            head <- dupHeader replyHeader CommDataMessage
+            send $ CommData head uuid val
+
+      -- If the widget is present, don't open it again.
+      if present
+        then return state
+        else do
+          -- Send the comm open
+          header <- dupHeader replyHeader CommOpenMessage
+          send $ CommOpen header target uuid initVal
+
+          -- Initial state update
+          communicate . toJSON $ UpdateState stateVal
+
+          -- Send anything else the widget requires.
+          open widget communicate
+
+          -- Store the widget in the kernelState
+          return newState
+
+    Close widget value -> do
+      let target = targetName widget
+          uuid = getCommUUID widget
+          present = isJust $ Map.lookup uuid oldComms
+
+          newComms = Map.delete uuid $ openComms state
+          newState = state { openComms = newComms }
+
+      -- If the widget is not present in the state, we don't close it.
+      if present
+        then do
+          header <- dupHeader replyHeader CommCloseMessage
+          send $ CommClose header uuid value
+          return newState
+        else return state
+
+    View widget -> sendMessage widget (toJSON DisplayWidget)
+
+    Update widget value -> sendMessage widget (toJSON $ UpdateState value)
+
+    Custom widget value -> sendMessage widget (toJSON $ CustomContent value)
+
+    JSONValue widget value -> sendMessage widget value
+
+  where
+    oldComms = openComms state
+    sendMessage widget value = do
+      let uuid = getCommUUID widget
+          present = isJust $ Map.lookup uuid oldComms
+
+      -- If the widget is present, we send an update message on its comm.
+      when present $ do
+        header <- dupHeader replyHeader CommDataMessage
+        send $ CommData header uuid value
+      return state
+
+-- Handle messages one-by-one, while updating state simultaneously
+widgetHandler :: (Message -> IO ())
+              -> MessageHeader
+              -> KernelState
+              -> [WidgetMsg]
+              -> IO KernelState
+widgetHandler sender header = foldM (handleMessage sender header)

src/IHaskell/Publish.hs

@@ -0,0 +1,82 @@
+{-# LANGUAGE QuasiQuotes #-}
+
+module IHaskell.Publish (publishResult) where
+
+import           IHaskellPrelude
+
+import           Data.String.Here (hereFile)
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as E
+
+import           IHaskell.Display
+import           IHaskell.Types
+
+ihaskellCSS :: String
+ihaskellCSS = [hereFile|html/custom.css|]
+
+-- | Publish evaluation results, ignore any CommMsgs. This function can be used to create a function
+-- of type (EvaluationResult -> IO ()), which can be used to publish results to the frontend. The
+-- resultant function shares some state between different calls by storing it inside the MVars
+-- passed while creating it using this function. Pager output is accumulated in the MVar passed for
+-- this purpose if a pager is being used (indicated by an argument), and sent to the frontend
+-- otherwise.
+publishResult :: (Message -> IO ()) -- ^ A function to send messages
+              -> MessageHeader      -- ^ Message header to use for reply
+              -> MVar [Display]     -- ^ A MVar to use for displays
+              -> MVar Bool          -- ^ A mutable boolean to decide whether the output need to be cleared and
+                                    -- redrawn
+              -> MVar [DisplayData] -- ^ A MVar to use for storing pager output
+              -> Bool               -- ^ Whether to use the pager
+              -> EvaluationResult   -- ^ The evaluation result
+              -> IO ()
+publishResult send replyHeader displayed updateNeeded pagerOutput usePager 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
+    clearOutput
+    disps <- readMVar displayed
+    mapM_ sendOutput $ reverse disps
+
+  -- Draw this message.
+  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 $ do
+    modifyMVar_ displayed (return . (outs :))
+
+    -- If this has some pager output, store it for later.
+    let pager = pagerOut result
+    unless (null pager) $
+      if usePager
+        then modifyMVar_ pagerOutput (return . (++ pager))
+        else sendOutput $ Display pager
+
+  where
+    clearOutput = do
+      header <- dupHeader replyHeader ClearOutputMessage
+      send $ ClearOutput header True
+
+    sendOutput (ManyDisplay manyOuts) = mapM_ sendOutput manyOuts
+    sendOutput (Display outs) = do
+      header <- dupHeader replyHeader DisplayDataMessage
+      send $ PublishDisplayData header "haskell" $ map (convertSvgToHtml . prependCss) outs
+
+    convertSvgToHtml (DisplayData MimeSvg svg) = html $ makeSvgImg $ base64 $ E.encodeUtf8 svg
+    convertSvgToHtml x = x
+
+    makeSvgImg :: Base64 -> String
+    makeSvgImg base64data = T.unpack $ "<img src=\"data:image/svg+xml;base64," <>
+                                       base64data <>
+                                       "\"/>"
+
+    prependCss (DisplayData MimeHtml html) =
+      DisplayData MimeHtml $ mconcat ["<style>", T.pack ihaskellCSS, "</style>", html]
+    prependCss x = x

src/IHaskell/Types.hs

@@ -1,10 +1,15 @@
-{-# LANGUAGE NoImplicitPrelude, OverloadedStrings, DeriveDataTypeable, DeriveGeneric, ExistentialQuantification #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
 
 -- | Description : All message type definitions.
 module IHaskell.Types (
     Message(..),
     MessageHeader(..),
     MessageType(..),
+    dupHeader,
     Username,
     Metadata(..),
     replyType,
@@ -26,21 +31,25 @@ module IHaskell.Types (
     IHaskellDisplay(..),
     IHaskellWidget(..),
     Widget(..),
-    CommInfo(..),
+    WidgetMsg(..),
+    WidgetMethod(..),
     KernelSpec(..),
     ) where
 
 import           IHaskellPrelude
+
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Char8 as CBS
+import qualified Data.ByteString.Lazy as LBS
 import qualified Data.Text as T
 import qualified Data.Text.Lazy as LT
-import qualified Data.ByteString as BS
-import qualified Data.ByteString.Lazy as LBS
-import qualified Data.ByteString.Char8 as CBS
 
+import           Data.Aeson (Value, (.=), object)
+import           Data.Aeson.Types (emptyObject)
 import qualified Data.ByteString.Char8 as Char
+import           Data.Function (on)
 import           Data.Serialize
 import           GHC.Generics
-import           Data.Aeson (Value)
 
 import           IHaskell.IPython.Kernel
 
@@ -48,7 +57,7 @@ import           IHaskell.IPython.Kernel
 --
 -- IHaskell's displaying of results behaves as if these two overlapping/undecidable instances also
 -- existed:
--- 
+--
 -- > instance (Show a) => IHaskellDisplay a
 -- > instance Show a where shows _ = id
 class IHaskellDisplay a where
@@ -56,25 +65,32 @@ class IHaskellDisplay a where
 
 -- | Display as an interactive widget.
 class IHaskellDisplay a => IHaskellWidget a where
-  -- | Output target name for this widget. The actual input parameter should be ignored.
+  -- | Output target name for this widget. The actual input parameter should be ignored. By default
+  -- evaluate to "ipython.widget", which is used by IPython for its backbone widgets.
   targetName :: a -> String
+  targetName _ = "ipython.widget"
+
+  -- | Get the uuid for comm associated with this widget. The widget is responsible for storing the
+  -- UUID during initialization.
+  getCommUUID :: a -> UUID
 
   -- | Called when the comm is opened. Allows additional messages to be sent after comm open.
-  open :: a               -- ^ Widget to open a comm port with.
-       -> (Value -> IO ()) -- ^ Way to respond to the message.
+  open :: a                -- ^ Widget to open a comm port with.
+       -> (Value -> IO ()) -- ^ A function for sending messages.
        -> IO ()
   open _ _ = return ()
 
-  -- | Respond to a comm data message.
-  comm :: a               -- ^ Widget which is being communicated with.
-       -> Value           -- ^ Sent data.
+  -- | Respond to a comm data message. Called when a message is recieved on the comm associated with
+  -- the widget.
+  comm :: a                -- ^ Widget which is being communicated with.
+       -> Value            -- ^ Data recieved from the frontend.
        -> (Value -> IO ()) -- ^ Way to respond to the message.
        -> IO ()
   comm _ _ _ = return ()
 
-  -- | Close the comm, releasing any resources we might need to.
+  -- | Called when a comm_close is recieved from the frontend.
   close :: a               -- ^ Widget to close comm port with.
-        -> Value           -- ^ Sent data.
+        -> Value           -- ^ Data recieved from the frontend.
         -> IO ()
   close _ _ = return ()
 
@@ -86,6 +102,7 @@ instance IHaskellDisplay Widget where
 
 instance IHaskellWidget Widget where
   targetName (Widget widget) = targetName widget
+  getCommUUID (Widget widget) = getCommUUID widget
   open (Widget widget) = open widget
   comm (Widget widget) = comm widget
   close (Widget widget) = close widget
@@ -93,6 +110,9 @@ instance IHaskellWidget Widget where
 instance Show Widget where
   show _ = "<Widget>"
 
+instance Eq Widget where
+  (==) = (==) `on` getCommUUID
+
 -- | Wrapper for ipython-kernel's DisplayData which allows sending multiple results from the same
 -- expression.
 data Display = Display [DisplayData]
@@ -112,7 +132,7 @@ instance Monoid Display where
 data KernelState =
        KernelState
          { getExecutionCounter :: Int
-         , getLintStatus :: LintStatus   -- Whether to use hlint, and what arguments to pass it. 
+         , getLintStatus :: LintStatus   -- Whether to use hlint, and what arguments to pass it.
          , useSvg :: Bool
          , useShowErrors :: Bool
          , useShowTypes :: Bool
@@ -137,8 +157,8 @@ defaultKernelState = KernelState
 -- | Kernel options to be set via `:set` and `:option`.
 data KernelOpt =
        KernelOpt
-         { getOptionName :: [String]                          -- ^ Ways to set this option via `:option`
-         , getSetName :: [String]                             -- ^ Ways to set this option via `:set`
+         { getOptionName :: [String] -- ^ Ways to set this option via `:option`
+         , getSetName :: [String] -- ^ Ways to set this option via `:set`
          , getUpdateKernelState :: KernelState -> KernelState -- ^ Function to update the kernel
                                                               -- state.
          }
@@ -162,21 +182,60 @@ data LintStatus = LintOn
                 | LintOff
   deriving (Eq, Show)
 
-data CommInfo = CommInfo Widget UUID String
-  deriving Show
+-- | Send JSON objects with specific formats
+data WidgetMsg = Open Widget Value Value
+               |
+               -- ^ Cause the interpreter to open a new comm, and register the associated widget in
+               -- the kernelState. Also sends a Value with comm_open, and then sends an initial
+               -- state update Value.
+                Update Widget Value
+               |
+               -- ^ Cause the interpreter to send a comm_msg containing a state update for the
+               -- widget. Can be used to send fragments of state for update. Also updates the value
+               -- of widget stored in the kernelState
+                View Widget
+               |
+               -- ^ Cause the interpreter to send a comm_msg containing a display command for the
+               -- frontend.
+                Close Widget Value
+               |
+               -- ^ Cause the interpreter to close the comm associated with the widget. Also sends
+               -- data with comm_close.
+                Custom Widget Value
+               |
+               -- ^ A [method .= custom, content = value] message
+                JSONValue Widget Value
+  -- ^ A json object that is sent to the widget without modifications.
+  deriving (Show, Typeable)
+
+data WidgetMethod = UpdateState Value
+                  | CustomContent Value
+                  | DisplayWidget
+
+instance ToJSON WidgetMethod where
+  toJSON DisplayWidget = object ["method" .= "display"]
+  toJSON (UpdateState v) = object ["method" .= "update", "state" .= v]
+  toJSON (CustomContent v) = object ["method" .= "custom", "content" .= v]
 
 -- | Output of evaluation.
 data EvaluationResult =
                       -- | An intermediate result which communicates what has been printed thus
                       -- far.
                         IntermediateResult
-                          { outputs :: Display      -- ^ Display outputs.
+                          { outputs :: Display -- ^ Display outputs.
                           }
                       |
                         FinalResult
-                          { outputs :: Display        -- ^ Display outputs.
+                          { outputs :: Display       -- ^ Display outputs.
                           , pagerOut :: [DisplayData] -- ^ Mimebundles to display in the IPython
                                                       -- pager.
-                          , startComms :: [CommInfo]  -- ^ Comms to start.
+                          , commMsgs :: [WidgetMsg]  -- ^ Comm operations
                           }
   deriving Show
+
+-- | Duplicate a message header, giving it a new UUID and message type.
+dupHeader :: MessageHeader -> MessageType -> IO MessageHeader
+dupHeader header messageType = do
+  uuid <- liftIO random
+
+  return header { messageId = uuid, msgType = messageType }