Basic framework for widgets

ihaskell.cabal

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

main/Main.hs

@@ -124,11 +124,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
@@ -260,18 +261,7 @@ replyTo interface req@ExecuteRequest { getCode = code } replyHeader state = do
         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 outputs, ignore any CommMsgs
       publish :: EvaluationResult -> IO ()
       publish result = do
         let final =
@@ -296,9 +286,6 @@ replyTo interface req@ExecuteRequest { getCode = code } replyHeader state = do
         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) $
@@ -306,13 +293,92 @@ replyTo interface req@ExecuteRequest { getCode = code } replyHeader state = do
               then modifyMVar_ pagerOutput (return . (++ pager))
               else sendOutput $ Display pager
 
+      handleMessage :: KernelState -> WidgetMsg -> IO KernelState
+      handleMessage state (Open widget value) = do
+        -- Check whether the widget is already present in the state
+        let oldComms = openComms state
+            uuid     = getCommUUID widget
+            present  = isJust $ Map.lookup uuid oldComms
+
+            newComms = Map.insert uuid widget $ openComms state
+            newState = state { openComms = newComms }
+
+            target   = targetName widget
+
+            communicate value = do
+              head <- dupHeader replyHeader CommDataMessage
+              writeChan (iopubChannel interface) $ CommData head uuid value
+
+        if present
+          then return state
+          else do -- Send the comm open
+                  header <- dupHeader replyHeader CommOpenMessage
+                  send $ CommOpen header target uuid value
+
+                  -- Send anything else the widget requires.
+                  open widget communicate
+
+                  -- Store the widget in the kernelState
+                  return newState
+
+      handleMessage state (Close widget value) = do
+        let oldComms = openComms state
+            present  = isJust $ Map.lookup (getCommUUID widget) oldComms
+
+            target   = targetName widget
+            uuid     = getCommUUID widget
+
+            newComms = Map.delete uuid $ openComms state
+            newState = state { openComms = newComms }
+
+        if present
+          then do header <- dupHeader replyHeader CommCloseMessage
+                  send $ CommClose header uuid value
+                  return newState
+          else return state
+
+      handleMessage state (View widget) = do
+        let oldComms = openComms state
+            uuid     = getCommUUID widget
+            present  = isJust $ Map.lookup (getCommUUID widget) oldComms
+
+        when present $ do
+          header <- dupHeader replyHeader CommDataMessage
+          send . CommData header uuid $ toJSON DisplayWidget
+
+        return state
+
+      -- Assume that a state update means that it is time the stored widget also gets updated.
+      -- Thus replace the stored widget with the copy passed in the CommMsg.
+      handleMessage state (Update widget value) = do
+        let oldComms = openComms state
+            present  = isJust $ Map.lookup (getCommUUID widget) oldComms
+
+            target   = targetName widget
+            uuid     = getCommUUID widget
+
+            newComms = Map.insert uuid widget $ openComms state
+            newState = state { openComms = newComms }
+
+        if present
+          then do header <- dupHeader replyHeader CommDataMessage
+                  send . CommData header uuid . toJSON $ UpdateState value
+                  return newState
+          else return state
+
+      widgetHandler :: KernelState -> [WidgetMsg] -> IO KernelState
+      widgetHandler state []     = return state
+      widgetHandler state (x:xs) = do
+        newState <- handleMessage state x
+        widgetHandler newState xs
+
   let execCount = getExecutionCounter state
   -- Let all frontends know the execution count and code that's about to run
   inputHeader <- liftIO $ dupHeader replyHeader InputMessage
   send $ PublishInput inputHeader (T.unpack code) execCount
 
   -- Run code and publish to the frontend as we go.
-  updatedState <- evaluate state (T.unpack code) publish
+  updatedState <- evaluate state (T.unpack code) publish widgetHandler
 
   -- Notify the frontend that we're done computing.
   idleHeader <- liftIO $ dupHeader replyHeader StatusMessage

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

@@ -84,6 +84,7 @@ import qualified IHaskell.Eval.Hoogle as Hoogle
 import           IHaskell.Eval.Util
 import           IHaskell.BrokenPackages
 import qualified IHaskell.IPython.Message.UUID as UUID
+import           IHaskell.Eval.Widgets
 import           StringUtils (replace, split, strip, rstrip)
 
 import           Paths_ihaskell (version)
@@ -253,7 +254,7 @@ data EvalOut =
          , evalResult :: Display
          , evalState  :: KernelState
          , evalPager  :: String
-         , evalComms :: [CommInfo]
+         , evalMsgs   :: [WidgetMsg]
          }
 
 cleanString :: String -> String
@@ -275,8 +276,9 @@ cleanString x = if allBrackets
 evaluate :: KernelState                  -- ^ The kernel state.
          -> String                       -- ^ Haskell code or other interpreter commands.
          -> (EvaluationResult -> IO ())   -- ^ 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
 
@@ -321,13 +323,18 @@ evaluate kernelState code output = do
               Just disps -> evalResult evalOut <> disps
           helpStr = evalPager evalOut
 
+      -- Capture all widget messages queued during code execution
+      messagesIO <- extractValue "IHaskell.Eval.Widgets.relayWidgetMessages"
+      messages <- liftIO messagesIO
+      let commMessages = evalMsgs evalOut ++ messages
+
       -- 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 = [] }
+      -- Handle all the widget messages
+      newState <- liftIO $ widgetHandler (evalState evalOut) commMessages
 
       case evalStatus evalOut of
         Success -> runUntilFailure newState rest
@@ -353,7 +360,7 @@ safely state = ghandle handler . ghandle sourceErrorHandler
           , evalResult = displayError $ show exception
           , evalState = state
           , evalPager = ""
-          , evalComms = []
+          , evalMsgs = []
           }
 
     sourceErrorHandler :: SourceError -> Interpreter EvalOut
@@ -372,7 +379,7 @@ safely state = ghandle handler . ghandle sourceErrorHandler
           , evalResult = displayError fullErr
           , evalState = state
           , evalPager = ""
-          , evalComms = []
+          , evalMsgs = []
           }
 
 wrapExecution :: KernelState
@@ -386,7 +393,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,7 +483,7 @@ 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
@@ -502,7 +509,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 +543,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 +553,7 @@ evalCommand a (Directive SetOption opts) state = do
                 , evalResult = mempty
                 , evalState = updater state
                 , evalPager = ""
-                , evalComms = []
+                , evalMsgs = []
                 }
 
   where
@@ -680,7 +687,7 @@ evalCommand _ (Directive GetHelp _) state = do
       , evalResult = Display [out]
       , evalState = state
       , evalPager = ""
-      , evalComms = []
+      , evalMsgs = []
       }
 
   where
@@ -729,7 +736,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
@@ -814,7 +821,7 @@ evalCommand output (Expression expr) state = do
           , evalResult = mempty
           , evalState = state
           , evalPager = ""
-          , evalComms = []
+          , evalMsgs = []
           }
     else do
       if canRunDisplay
@@ -822,9 +829,8 @@ evalCommand output (Expression expr) state = do
           -- Use the display. As a result, `it` is set to the output.
           out <- useDisplay displayExpr
 
-          -- Register the `it` object as a widget.
           if isWidget
-            then registerWidget out
+            then displayWidget 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
@@ -897,27 +903,22 @@ evalCommand output (Expression expr) state = do
                       then display :: Display
                       else removeSvg display
 
-    registerWidget :: EvalOut -> Ghc EvalOut
-    registerWidget evalOut =
+    displayWidget :: EvalOut -> Ghc EvalOut
+    displayWidget 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'
-                  }
+            Just (Widget widget) -> do
+              let oldComms = openComms state
+                  uuid = getCommUUID widget
+              case Map.lookup uuid oldComms of
+               Nothing -> error "Unregistered widget"
+               Just w  -> do
+                 liftIO $ widgetSendView widget
+                 return evalOut
 
     isIO expr = attempt $ exprType $ printf "((\\x -> x) :: IO a -> IO a) (%s)" expr
 
@@ -987,7 +988,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 +1005,7 @@ hoogleResults state results =
     , evalResult = mempty
     , evalState = state
     , evalPager = output
-    , evalComms = []
+    , evalMsgs = []
     }
   where
     -- TODO: Make pager work with plaintext

src/IHaskell/Eval/Util.hs

@@ -21,6 +21,9 @@ module IHaskell.Eval.Util (
     doc,
     pprDynFlags,
     pprLanguages,
+
+    -- * Monad-loops
+    unfoldM,
     ) where
 
 import           IHaskellPrelude
@@ -385,3 +388,9 @@ getDescription str = do
       if fixity == GHC.defaultFixity
         then O.empty
         else O.ppr fixity O.<+> pprInfixName (getName thing)
+
+-- | 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

src/IHaskell/Eval/Widgets.hs

+module IHaskell.Eval.Widgets
+       ( widgetSendOpen
+       , widgetSendUpdate
+       , widgetSendView
+       , widgetSendClose
+       ) where
+
+import IHaskellPrelude
+
+import Data.Aeson (Value)
+import Control.Concurrent.STM (atomically)
+import Control.Concurrent.STM.TChan
+import System.IO.Unsafe (unsafePerformIO)
+
+import IHaskell.Display
+import IHaskell.Types (Message (..), WidgetMsg (..))
+import IHaskell.IPython.Message.UUID
+import IHaskell.Eval.Util (unfoldM)
+
+-- 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
+
+widgetSendOpen :: IHaskellWidget a => a -> Value -> IO ()
+widgetSendOpen = widgetSend Open
+
+widgetSendUpdate :: IHaskellWidget a => a -> Value -> IO ()
+widgetSendUpdate = widgetSend Update
+
+widgetSendView :: IHaskellWidget a => a -> IO ()
+widgetSendView = queue . View . Widget
+
+widgetSendClose :: IHaskellWidget a => a -> Value -> IO ()
+widgetSendClose = widgetSend Close

src/IHaskell/Types.hs

-{-# LANGUAGE NoImplicitPrelude, OverloadedStrings, DeriveDataTypeable, DeriveGeneric, ExistentialQuantification #-}
+{-# LANGUAGE DeriveDataTypeable        #-}
+{-# LANGUAGE DeriveGeneric             #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE NoImplicitPrelude         #-}
+{-# LANGUAGE OverloadedStrings         #-}
 
 -- | Description : All message type definitions.
 module IHaskell.Types (
@@ -26,28 +30,32 @@ module IHaskell.Types (
     IHaskellDisplay(..),
     IHaskellWidget(..),
     Widget(..),
-    CommInfo(..),
+    WidgetMsg(..),
+    WidgetMethod(..),
     KernelSpec(..),
     ) where
 
 import           IHaskellPrelude
-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 qualified Data.ByteString.Lazy    as LBS
+import qualified Data.Text               as T
+import qualified Data.Text.Lazy          as LT
 
+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
 
 -- | A class for displayable Haskell types.
 --
--- IHaskell's displaying of results behaves as if these two overlapping/undecidable instances also
--- existed:
+-- 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
@@ -56,25 +64,34 @@ 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.
+  -- | 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.
+       -> (Value -> IO ()) -- ^ A function for sending messages.
        -> IO ()
   open _ _ = return ()
 
-  -- | Respond to a comm data message.
+  -- | 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           -- ^ Sent data.
+       -> 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 +103,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,8 +111,11 @@ instance IHaskellWidget Widget where
 instance Show Widget where
   show _ = "<Widget>"
 
--- | Wrapper for ipython-kernel's DisplayData which allows sending multiple results from the same
--- expression.
+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]
              | ManyDisplay [Display]
   deriving (Show, Typeable, Generic)
@@ -139,8 +160,7 @@ data KernelOpt =
        KernelOpt
          { 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.
+         , getUpdateKernelState :: KernelState -> KernelState -- ^ Function to update the kernel state.
          }
 
 kernelOpts :: [KernelOpt]
@@ -162,21 +182,42 @@ data LintStatus = LintOn
                 | LintOff
   deriving (Eq, Show)
 
-data CommInfo = CommInfo Widget UUID String
+data WidgetMsg = Open Widget Value
+                 -- ^ Cause the interpreter to open a new comm, and
+                 -- register the associated widget in the
+                 -- kernelState.
+               | 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.
   deriving Show
 
+data WidgetMethod = UpdateState Value
+                  | DisplayWidget
+
+instance ToJSON WidgetMethod where
+  toJSON DisplayWidget   = object [ "method" .= "display" ]
+  toJSON (UpdateState v) = object [ "method" .= "update"
+                                  , "state"  .= v ]
+
 -- | Output of evaluation.
 data EvaluationResult =
-                      -- | An intermediate result which communicates what has been printed thus
-                      -- far.
+                      -- | An intermediate result which communicates what has been printed thus far.
                         IntermediateResult
                           { outputs :: Display -- ^ Display outputs.
                           }
                       |
                         FinalResult
                           { outputs  :: Display       -- ^ Display outputs.
-                          , pagerOut :: [DisplayData] -- ^ Mimebundles to display in the IPython
-                                                      -- pager.
-                          , startComms :: [CommInfo]  -- ^ Comms to start.
+                          , pagerOut :: [DisplayData] -- ^ Mimebundles to display in the IPython pager.
+                          , commMsgs :: [WidgetMsg]  -- ^ Comm operations
                           }
   deriving Show