diff --git a/build.sh b/build.sh index 59b1769e..422862a4 100755 --- a/build.sh +++ b/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 diff --git a/ipython-kernel/src/IPython/Message/Parser.hs b/ipython-kernel/src/IPython/Message/Parser.hs index 8a2f4c63..cc6df0c1 100644 --- a/ipython-kernel/src/IPython/Message/Parser.hs +++ b/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 diff --git a/ipython-kernel/src/IPython/Message/UUID.hs b/ipython-kernel/src/IPython/Message/UUID.hs index 35c9fed9..f0e4fbb2 100644 --- a/ipython-kernel/src/IPython/Message/UUID.hs +++ b/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. diff --git a/ipython-kernel/src/IPython/Message/Writer.hs b/ipython-kernel/src/IPython/Message/Writer.hs index 603e9e4e..223faed7 100644 --- a/ipython-kernel/src/IPython/Message/Writer.hs +++ b/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 diff --git a/ipython-kernel/src/IPython/Types.hs b/ipython-kernel/src/IPython/Types.hs index 79174c0f..4131854f 100644 --- a/ipython-kernel/src/IPython/Types.hs +++ b/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. diff --git a/src/IHaskell/Display.hs b/src/IHaskell/Display.hs index 41d4ef21..c62b212b 100644 --- a/src/IHaskell/Display.hs +++ b/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 diff --git a/src/IHaskell/Types.hs b/src/IHaskell/Types.hs index 704e716f..3de4d4c0 100644 --- a/src/IHaskell/Types.hs +++ b/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 _ = "" + + -- | 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 diff --git a/src/Main.hs b/src/Main.hs index 49e12c4c..e01028e1 100644 --- a/src/Main.hs +++ b/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 }