Adding types and scaffold for widgets.

build.sh

@@ -36,8 +36,9 @@ INSTALLS="$INSTALLS ."
 if [ $# -gt 0 ]; then
   if [ $1 = "display" ]; then
         # Install all the display libraries
+        # However, install ihaskell-diagrams separately...
         cd ihaskell-display
-        for dir in `ls`
+        for dir in `ls | grep -v diagrams`
         do
             INSTALLS="$INSTALLS ihaskell-display/$dir"
         done
@@ -57,3 +58,10 @@ done
 # Stick a "./" before everything.
 INSTALL_DIRS=`echo $INSTALLS | tr ' ' '\n' | sed 's#^#./#' | tr ' ' '\n'`
 cabal install -j $INSTALL_DIRS --force-reinstalls
+
+# Finish installing ihaskell-diagrams.
+if [ $# -gt 0 ]; then
+  if [ $1 = "display" ]; then
+      cabal install -j ihaskell-display/ihaskell-diagrams --force-reinstalls
+    fi
+fi

ipython-kernel/src/IPython/Message/Parser.hs

@@ -82,6 +82,9 @@ parser CompleteRequestMessage    = completeRequestParser
 parser ObjectInfoRequestMessage  = objectInfoRequestParser
 parser ShutdownRequestMessage    = shutdownRequestParser
 parser InputReplyMessage         = inputReplyParser
+parser CommOpenMessage           = commOpenParser
+parser CommDataMessage           = commDataParser
+parser CommCloseMessage          = commCloseParser
 parser other = error $ "Unknown message type " ++ show other
 
 -- | Parse a kernel info request.
@@ -155,3 +158,34 @@ inputReplyParser content = parsed
         return $ InputReply noHeader value
 
   Just decoded = decode content
+
+commOpenParser :: LByteString -> Message
+commOpenParser content = parsed
+  where
+  Success parsed = flip parse decoded $ \ obj -> do
+        uuid <- obj .: "comm_id"
+        name <- obj .: "target_name"
+        value <- obj .: "data"
+        return $ CommOpen noHeader name uuid value
+
+  Just decoded = decode content
+
+commDataParser :: LByteString -> Message
+commDataParser content = parsed
+  where
+  Success parsed = flip parse decoded $ \ obj -> do
+        uuid <- obj .: "comm_id"
+        value <- obj .: "data"
+        return $ CommData noHeader uuid value
+
+  Just decoded = decode content
+
+commCloseParser :: LByteString -> Message
+commCloseParser content = parsed
+  where
+  Success parsed = flip parse decoded $ \ obj -> do
+        uuid <- obj .: "comm_id"
+        value <- obj .: "data"
+        return $ CommClose noHeader uuid value
+
+  Just decoded = decode content

ipython-kernel/src/IPython/Message/UUID.hs

@@ -23,7 +23,7 @@ import Text.Read as Read hiding (pfail, String)
 -- them.
 
 -- | A UUID (universally unique identifier).
-data UUID = UUID String deriving (Show, Read, Eq)
+data UUID = UUID String deriving (Show, Read, Eq, Ord)
 
 -- | Generate a list of random UUIDs.
 randoms :: Int      -- ^ Number of UUIDs to generate.

ipython-kernel/src/IPython/Message/Writer.hs

@@ -87,6 +87,21 @@ instance ToJSON Message where
                             "prompt" .= prompt
                            ]
 
+  toJSON req@CommOpen{} = object [
+                            "comm_id" .= commUuid req,
+                            "target_name" .= commTargetName req,
+                            "data" .= commData req
+                           ]
+
+  toJSON req@CommData{} = object [
+                            "comm_id" .= commUuid req,
+                            "data" .= commData req
+                           ]
+
+  toJSON req@CommClose{} = object [
+                            "comm_id" .= commUuid req,
+                            "data" .= commData req
+                           ]
 
   toJSON body = error $ "Do not know how to convert to JSON for message " ++ show body
 

ipython-kernel/src/IPython/Types.hs

@@ -148,7 +148,10 @@ data MessageType = KernelInfoReplyMessage
                  | ClearOutputMessage
                  | InputRequestMessage
                  | InputReplyMessage
-                 deriving (Show, Read)
+                 | CommOpenMessage
+                 | CommDataMessage
+                 | CommCloseMessage
+                 deriving (Show, Read, Eq)
 
 showMessageType :: MessageType -> String
 showMessageType KernelInfoReplyMessage     = "kernel_info_reply"
@@ -169,6 +172,9 @@ showMessageType ShutdownReplyMessage       = "shutdown_reply"
 showMessageType ClearOutputMessage         = "clear_output"
 showMessageType InputRequestMessage        = "input_request"
 showMessageType InputReplyMessage          = "input_reply"
+showMessageType CommOpenMessage            = "comm_open"           
+showMessageType CommDataMessage            = "comm_msg"            
+showMessageType CommCloseMessage           = "comm_close"          
 
 instance FromJSON MessageType where
   parseJSON (String s) = case s of
@@ -190,6 +196,9 @@ instance FromJSON MessageType where
     "clear_output"        -> return ClearOutputMessage
     "input_request"       -> return InputRequestMessage
     "input_reply"         -> return InputReplyMessage
+    "comm_open"           -> return CommOpenMessage
+    "comm_msg"            -> return CommDataMessage
+    "comm_close"          -> return CommCloseMessage
 
     _                     -> fail ("Unknown message type: " ++ show s)
   parseJSON _ = fail "Must be a string."
@@ -315,6 +324,24 @@ data Message
       inputValue :: String      
   }
 
+  | CommOpen {
+      header :: MessageHeader,
+      commTargetName :: String,
+      commUuid :: UUID,
+      commData :: Value
+  }
+
+  | CommData {
+      header :: MessageHeader,
+      commUuid :: UUID,
+      commData :: Value
+  }
+
+  | CommClose {
+      header :: MessageHeader,
+      commUuid :: UUID,
+      commData :: Value
+  }
     deriving Show
 
 -- | Possible statuses in the execution reply messages.

src/IHaskell/Display.hs

@@ -19,6 +19,7 @@ import Data.ByteString hiding (map, pack)
 import Data.String.Utils (rstrip) 
 import qualified Data.ByteString.Base64 as Base64
 import qualified Data.ByteString.Char8 as Char
+import Data.Aeson (Value)
 
 import Control.Concurrent.STM.TChan
 import Control.Monad.STM
@@ -28,16 +29,6 @@ import IHaskell.Types
 
 type Base64 = Text
 
--- | A class for displayable Haskell types.
---
--- 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
-  display :: a -> IO Display
-
 -- | these instances cause the image, html etc. which look like:
 --
 -- > Display

src/IHaskell/Types.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE NoImplicitPrelude, OverloadedStrings, DeriveDataTypeable, DeriveGeneric #-}
+{-# LANGUAGE ExistentialQuantification #-}
 -- | Description : All message type definitions.
 module IHaskell.Types (
   Message (..),
@@ -24,20 +25,23 @@ module IHaskell.Types (
   extractPlain,
   kernelOpts,
   KernelOpt(..),
+  IHaskellDisplay(..),
+  IHaskellWidget(..),
+  Widget(..),
   ) where
 
 import            ClassyPrelude
 import qualified  Data.ByteString.Char8           as Char
 import            Data.Serialize
 import            GHC.Generics
+import            Data.Map                        (Map, empty)
+import            Data.Aeson                      (Value)
 
 import            Text.Read                       as Read hiding (pfail, String)
 import            Text.ParserCombinators.ReadP
 
 import IPython.Kernel
 
-data Test = Test
-
 data ViewFormat
      = Pdf
      | Html
@@ -66,6 +70,38 @@ instance Read ViewFormat where
       "md" -> return Markdown
       _ -> pfail
 
+-- | A class for displayable Haskell types.
+--
+-- 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
+  display :: a -> IO Display
+
+-- | Display as an interactive widget.
+class IHaskellDisplay a => IHaskellWidget a where
+  open :: a               -- ^ Widget to open a comm port with.
+       -> Value           -- ^ Comm open metadata.
+       -> (Value -> IO ()) -- ^ Way to respond to the message.
+       -> IO ()
+
+  comm :: a               -- ^ Widget which is being communicated with.
+       -> Value           -- ^ Sent data.
+       -> (Value -> IO ()) -- ^ Way to respond to the message.
+       -> IO ()
+
+  close :: a               -- ^ Widget to close comm port with.
+        -> Value           -- ^ Sent data.
+        -> IO ()
+
+data Widget = forall a. IHaskellWidget a => Widget a
+
+instance Show Widget where
+  show _ = "<Widget>"
+
+
 -- | Wrapper for ipython-kernel's DisplayData which allows sending multiple
 -- results from the same expression.
 data Display = Display [DisplayData]
@@ -90,7 +126,8 @@ data KernelState = KernelState
     getFrontend :: FrontendType,
     useSvg :: Bool,
     useShowErrors :: Bool,
-    useShowTypes :: Bool
+    useShowTypes :: Bool,
+    openComms :: Map UUID Widget
   }
   deriving Show
 
@@ -101,7 +138,8 @@ defaultKernelState = KernelState
     getFrontend = IPythonConsole,
     useSvg = True,
     useShowErrors = False,
-    useShowTypes = False
+    useShowTypes = False,
+    openComms = empty
   }
 
 data FrontendType

src/Main.hs

@@ -180,17 +180,29 @@ runKernel profileSrc initInfo = do
       -- Create a header for the reply.
       replyHeader <- createReplyHeader (header request)
 
-      -- Create the reply, possibly modifying kernel state.
-      oldState <- liftIO $ takeMVar state
-      (newState, reply) <- replyTo interface request replyHeader oldState
-      liftIO $ putMVar state newState
+      -- 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
+        let replier = writeChan (shellReplyChannel interface)
+        newState <- handleComm replier oldState request replyHeader
+        putMVar state newState
+      else do
+        -- Create the reply, possibly modifying kernel state.
+        oldState <- liftIO $ takeMVar state
+        (newState, reply) <- replyTo interface request replyHeader oldState
+        liftIO $ putMVar state newState
 
-      -- Write the reply to the reply channel.
-      liftIO $ writeChan (shellReplyChannel interface) reply
+        -- Write the reply to the reply channel.
+        liftIO $ writeChan (shellReplyChannel interface) reply
   where
     ignoreCtrlC =
       installHandler keyboardSignal (CatchOnce $ putStrLn "Press Ctrl-C again to quit kernel.") Nothing
 
+    isCommMessage req = msgType (header req) `elem` [CommOpenMessage, CommDataMessage, CommCloseMessage]
+
 -- Initial kernel state.
 initialKernelState :: IO (MVar KernelState)
 initialKernelState =
@@ -348,3 +360,25 @@ replyTo _ ObjectInfoRequest{objectName = oname} replyHeader state = do
                 objectDocString  = docs
               }
   return (state, reply)
+
+handleComm :: (Message -> IO ()) -> KernelState -> Message -> MessageHeader -> IO KernelState
+handleComm replier kernelState req replyHeader = do
+  let widgets = openComms kernelState
+      uuid = commUuid req
+      dat = commData req
+      communicate value = do
+        head <- dupHeader replyHeader CommDataMessage
+        replier $ CommData head uuid value
+  case lookup uuid widgets of
+    Nothing -> fail $ "no widget with uuid " ++ show uuid
+    Just (Widget widget) ->
+      case msgType $ header req of
+        CommOpenMessage -> do
+          open widget dat communicate
+          return kernelState
+        CommDataMessage -> do
+          comm widget dat communicate
+          return kernelState
+        CommCloseMessage -> do
+          close widget dat
+          return kernelState { openComms = Map.delete uuid widgets }