diff --git a/ihaskell.cabal b/ihaskell.cabal --- a/ihaskell.cabal +++ b/ihaskell.cabal @@ -7,7 +7,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.7.1.0 +version: 0.8.0.0 -- A short (one-line) description of the package. synopsis: A Haskell backend kernel for the IPython project. diff --git a/main/Main.hs b/main/Main.hs --- a/main/Main.hs +++ b/main/Main.hs @@ -14,6 +14,7 @@ -- Standard library imports. import Control.Concurrent (threadDelay) import Control.Concurrent.Chan +import Control.Arrow (second) import Data.Aeson import System.Directory import System.Process (readProcess, readProcessWithExitCode) @@ -332,6 +333,44 @@ , historyReply = [] } return (state, reply) + +-- Accomodating the workaround for retrieving list of open comms from the kernel +-- +-- The main idea is that the frontend opens a comm at kernel startup, whose target is a widget that +-- sends back the list of live comms and commits suicide. +-- +-- The message needs to be written to the iopub channel, and not returned from here. If returned, +-- the same message also gets written to the shell channel, which causes issues due to two messages +-- having the same identifiers in their headers. +-- +-- Sending the message only on the shell_reply channel doesn't work, so we send it as a comm message +-- on the iopub channel and return the SendNothing message. +replyTo interface open@CommOpen{} replyHeader state = do + let send msg = liftIO $ writeChan (iopubChannel interface) msg + + incomingUuid = commUuid open + target = commTargetName open + + targetMatches = target == "ipython.widget" + valueMatches = commData open == object ["widget_class" .= "ipywidgets.CommInfo"] + + commMap = openComms state + uuidTargetPairs = map (second targetName) $ Map.toList commMap + + pairProcessor (x, y) = T.pack (UUID.uuidToString x) .= object ["target_name" .= T.pack y] + + currentComms = object $ map pairProcessor $ (incomingUuid, "comm") : uuidTargetPairs + + replyValue = object [ "method" .= "custom" + , "content" .= object ["comms" .= currentComms] + ] + + msg = CommData replyHeader (commUuid open) replyValue + + -- To the iopub channel you go + when (targetMatches && valueMatches) $ send msg + + return (state, SendNothing) -- TODO: What else can be implemented? replyTo _ message _ state = do diff --git a/src/IHaskell/Eval/Widgets.hs b/src/IHaskell/Eval/Widgets.hs --- a/src/IHaskell/Eval/Widgets.hs +++ b/src/IHaskell/Eval/Widgets.hs @@ -52,9 +52,8 @@ 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 +widgetSendOpen :: IHaskellWidget a => a -> Value -> IO () +widgetSendOpen = widgetSend Open -- | Send a state update message widgetSendUpdate :: IHaskellWidget a => a -> Value -> IO () @@ -93,8 +92,9 @@ -> IO KernelState handleMessage send replyHeader state msg = do case msg of - Open widget initVal stateVal -> do - let target = targetName widget + Open widget value -> do + let target_name = targetName widget + target_module = targetModule widget uuid = getCommUUID widget present = isJust $ Map.lookup uuid oldComms @@ -109,12 +109,9 @@ if present then return state else do - -- Send the comm open + -- Send the comm open, with the initial state header <- dupHeader replyHeader CommOpenMessage - send $ CommOpen header target uuid initVal - - -- Initial state update - communicate . toJSON $ UpdateState stateVal + send $ CommOpen header target_name target_module uuid value -- Send anything else the widget requires. open widget communicate @@ -123,8 +120,7 @@ return newState Close widget value -> do - let target = targetName widget - uuid = getCommUUID widget + let uuid = getCommUUID widget present = isJust $ Map.lookup uuid oldComms newComms = Map.delete uuid $ openComms state diff --git a/src/IHaskell/Types.hs b/src/IHaskell/Types.hs --- a/src/IHaskell/Types.hs +++ b/src/IHaskell/Types.hs @@ -65,11 +65,15 @@ -- | Display as an interactive widget. class IHaskellDisplay a => IHaskellWidget a where - -- | 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. + -- | 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" + -- | Target module for this widget. Evaluates to an empty string by default. + targetModule :: a -> String + targetModule _ = "" + -- | Get the uuid for comm associated with this widget. The widget is responsible for storing the -- UUID during initialization. getCommUUID :: a -> UUID @@ -102,6 +106,7 @@ instance IHaskellWidget Widget where targetName (Widget widget) = targetName widget + targetModule (Widget widget) = targetModule widget getCommUUID (Widget widget) = getCommUUID widget open (Widget widget) = open widget comm (Widget widget) = comm widget @@ -185,11 +190,10 @@ deriving (Eq, Show) -- | Send JSON objects with specific formats -data WidgetMsg = Open Widget Value Value +data WidgetMsg = Open Widget 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. + -- the kernelState. Also sends an initial state Value with comm_open. Update Widget Value | -- ^ Cause the interpreter to send a comm_msg containing a state update for the