Merge branch 'comm'

Conflicts:
	notebooks/Test.ipynb

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

ihaskell-display/ihaskell-parsec/IHaskell/Display/Parsec.hs

+{-# LANGUAGE NoImplicitPrelude, TypeSynonymInstances, QuasiQuotes, FlexibleInstances, OverloadedStrings #-}
+module IHaskell.Display.Parsec () where
+
+import ClassyPrelude hiding (fromList)
+import System.Random
+import Data.String.Here
+import Data.HashMap.Strict as Map
+
+import Text.Parsec
+import Text.Parsec.Prim
+import Text.Parsec.String
+import Text.Parsec.Error
+
+import Data.Aeson
+
+import IHaskell.Display
+
+instance Show a => IHaskellDisplay (Parser a) where
+  display renderable = return $ Display [html dom]
+    where 
+      dom = [hereFile|widget.html|]
+
+-- | Text to parse.
+data ParseText = ParseText String
+
+instance FromJSON ParseText where
+  parseJSON (Object v) = ParseText <$> v .: "text"
+  parseJSON _          = fail "Expecting object"
+
+-- | Output of parsing.
+instance Show a => ToJSON (Either ParseError a) where
+  toJSON (Left err) = object [
+                        "status" .= ("error" :: String),
+                        "line" .= sourceLine (errorPos err),
+                        "col" .= sourceColumn (errorPos err),
+                        "msg" .= show err
+                      ]
+  toJSON (Right result) = object [
+                               "status" .= ("success" :: String),
+                               "result" .= show result
+                            ]
+
+instance Show a => IHaskellWidget (Parser a) where
+  -- Name for this widget.
+  targetName _ = "parsec"
+
+  -- When we rece
+  comm widget (Object dict) publisher = do
+    let key = "text" :: Text
+        Just (String text) = Map.lookup key dict
+        result = parse widget "<interactive>" $ unpack text
+    publisher $ toJSON result
+
+  -- We have no resources to close.
+  close widget value = return ()

ihaskell-display/ihaskell-parsec/LICENSE

+The MIT License (MIT)
+
+Copyright (c) 2013 Andrew Gibiansky
+
+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-parsec/Setup.hs

+import Distribution.Simple
+main = defaultMain

ihaskell-display/ihaskell-parsec/ihaskell-parsec.cabal

+-- The name of the package.
+name:                ihaskell-parsec
+
+-- 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:            IHaskell display instances for Parsec
+
+-- 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:              Andrew Gibiansky
+
+-- An email address to which users can send suggestions, bug reports, and 
+-- patches.
+maintainer:          andrew.gibiansky@gmail.com
+
+-- A copyright notice.
+-- copyright:           
+
+category:            Development
+
+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.16
+
+library
+  -- Modules exported by the library.
+  exposed-modules:     IHaskell.Display.Parsec
+  
+  -- Modules included in this library but not exported.
+  -- other-modules:       
+  
+  -- Language extensions.
+  default-extensions: DoAndIfThenElse
+              OverloadedStrings
+             
+  -- Other library packages from which modules are imported.
+  build-depends:       base ==4.6.*,
+                       aeson ==0.7.*,
+                       unordered-containers,
+                       classy-prelude,
+                       random >= 1,
+                       parsec,
+                       here,
+                       ihaskell >= 0.3
+  
+  -- Directories containing source files.
+  -- hs-source-dirs:      
+  
+  -- Base language which the package is written in.
+  default-language:    Haskell2010

ihaskell-display/ihaskell-parsec/widget.html

+<!-- CodeMirror component -->
+<link rel="stylesheet" href="/static/components/codemirror/addon/lint/lint.css">
+<script src="/static/components/codemirror/addon/lint/lint.js" charset="utf-8"></script>
+
+<!-- Parsec widget -->
+<script>
+// Only load this script once.
+var kernel = IPython.notebook.kernel;
+var initialized = kernel !== undefined && kernel != null;
+if (initialized && window.parsecWidgetRegistered === undefined) {
+
+// Do not load this script again.
+window.parsecWidgetRegistered = true;
+
+// Register the comm target.
+var ParsecWidget = function (comm) {
+    this.comm = comm;
+    this.comm.on_msg($.proxy(this.handler, this));
+
+    // Get the cell that was probably executed.
+    // The msg_id:cell mapping will make this possible without guessing.
+    this.cell = IPython.notebook.get_cell(IPython.notebook.get_selected_index()-1);
+
+    // Store this widget so we can use it from callbacks.
+    var widget = this;
+
+    // Editor options.
+    var options = {
+        lineNumbers: true,
+        // Show parsec errors as lint errors.
+        gutters: ["CodeMirror-lint-markers"],
+        lintWith: {
+            "getAnnotations": function(cm, update, opts) {
+                var errs = [];
+                if (widget.hasError) {
+                    var col = widget.error["col"];
+                    var line = widget.error["line"];
+                    errs = [{
+                        from: CodeMirror.Pos(line - 1, col - 1),
+                        to: CodeMirror.Pos(line - 1, col),
+                        message: widget.error["msg"],
+                        severity: "error"
+                    }];
+                }
+                update(cm, errs);
+            },
+            "async": true,
+        }
+    };
+
+    // Create the editor.
+    var out = this.cell.output_area.element;
+    this.textarea = out.find("#parsec-editor")[0];
+    this.output = out.find("#parsec-output")[0];
+
+    var editor = CodeMirror.fromTextArea(this.textarea, options);
+    var editor = editor;
+
+    // Update every key press.
+    editor.on("keyup", function() {
+        var text = editor.getDoc().getValue();
+        comm.send({"text": text});
+    });
+};
+
+ParsecWidget.prototype.handler = function(msg) {
+    var data = msg.content.data;
+    this.hasError = data["status"] == "error";
+    if (this.hasError) {
+        out = data["msg"];
+        this.error = data;
+    } else {
+        out = data["result"];
+    }
+    // Update viewed output.
+    this.output.innerHTML = out;
+};
+
+// Register this widget.
+IPython.notebook.kernel.comm_manager.register_target('parsec', IPython.utils.always_new(ParsecWidget));
+console.log("Registering Parsec widget.");
+}
+</script>
+
+<!-- Parsec widget DOM -->
+<form><textarea id="parsec-editor">Insert parser text here...</textarea></form>
+<pre id="parsec-output"></pre>

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,26 @@ 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
+  }
+
+  | SendNothing -- Dummy message; nothing is sent.
     deriving Show
 
 -- | Possible statuses in the execution reply messages.

ipython-kernel/src/IPython/ZeroMQ.hs

@@ -179,6 +179,7 @@ receiveMessage socket = do
 -- | Encode a message in the IPython ZeroMQ communication protocol 
 -- | and send it through the provided socket.
 sendMessage :: Sender a => Socket a -> Message -> IO ()
+sendMessage _ SendNothing = return ()
 sendMessage socket message = do
   let head = header message
       parentHeaderStr = maybe "{}" encodeStrict $ parentHeader head

notebooks/Test.ipynb

@@ -40,7 +40,7 @@
       "    float = do\n",
       "      value <- many1 $ oneOf \"0123456789\"\n",
       "      char '.'\n",
-      "      after <- many $ oneOf \"0123456789\"\n",
+      "      after <- many1 $ oneOf \"0123456789\"\n",
       "      optional $ char ','\n",
       "      whitespace\n",
       "      return (read (value ++ \".\" ++ after) :: Float)\n",
@@ -70,10 +70,14 @@
         "\n",
         "<!-- Parsec widget -->\n",
         "<script>\n",
+        "// Only load this script once.\n",
         "var kernel = IPython.notebook.kernel;\n",
         "var initialized = kernel !== undefined && kernel != null;\n",
         "if (initialized && window.parsecWidgetRegistered === undefined) {\n",
+        "\n",
+        "// Do not load this script again.\n",
         "window.parsecWidgetRegistered = true;\n",
+        "\n",
         "// Register the comm target.\n",
         "var ParsecWidget = function (comm) {\n",
         "    this.comm = comm;\n",
@@ -121,11 +125,13 @@
         "    // Update every key press.\n",
         "    editor.on(\"keyup\", function() {\n",
         "        var text = editor.getDoc().getValue();\n",
+        "        console.log(\"Sent\",text); \n",
         "        comm.send({\"text\": text});\n",
         "    });\n",
         "};\n",
         "\n",
         "ParsecWidget.prototype.handler = function(msg) {\n",
+        "    console.log(\"Handler\", msg); \n",
         "    var data = msg.content.data;\n",
         "    this.hasError = data[\"status\"] == \"error\";\n",
         "    if (this.hasError) {\n",
@@ -155,11 +161,111 @@
      "prompt_number": 2
     },
     {
-     "cell_type": "raw",
-     "metadata": {},
-     "source": [
+     "cell_type": "code",
+     "collapsed": false,
+     "input": [
       "float"
-     ]
+     ],
+     "language": "python",
+     "metadata": {},
+     "outputs": [
+      {
+       "html": [
+        "<!-- CodeMirror component -->\n",
+        "<link rel=\"stylesheet\" href=\"/static/components/codemirror/addon/lint/lint.css\">\n",
+        "<script src=\"/static/components/codemirror/addon/lint/lint.js\" charset=\"utf-8\"></script>\n",
+        "\n",
+        "<!-- Parsec widget -->\n",
+        "<script>\n",
+        "// Only load this script once.\n",
+        "var kernel = IPython.notebook.kernel;\n",
+        "var initialized = kernel !== undefined && kernel != null;\n",
+        "if (initialized && window.parsecWidgetRegistered === undefined) {\n",
+        "\n",
+        "// Do not load this script again.\n",
+        "window.parsecWidgetRegistered = true;\n",
+        "\n",
+        "// Register the comm target.\n",
+        "var ParsecWidget = function (comm) {\n",
+        "    this.comm = comm;\n",
+        "    this.comm.on_msg($.proxy(this.handler, this));\n",
+        "\n",
+        "    // Get the cell that was probably executed.\n",
+        "    // The msg_id:cell mapping will make this possible without guessing.\n",
+        "    this.cell = IPython.notebook.get_cell(IPython.notebook.get_selected_index()-1);\n",
+        "\n",
+        "    // Store this widget so we can use it from callbacks.\n",
+        "    var widget = this;\n",
+        "\n",
+        "    // Editor options.\n",
+        "    var options = {\n",
+        "        lineNumbers: true,\n",
+        "        // Show parsec errors as lint errors.\n",
+        "        gutters: [\"CodeMirror-lint-markers\"],\n",
+        "        lintWith: {\n",
+        "            \"getAnnotations\": function(cm, update, opts) {\n",
+        "                var errs = [];\n",
+        "                if (widget.hasError) {\n",
+        "                    var col = widget.error[\"col\"];\n",
+        "                    var line = widget.error[\"line\"];\n",
+        "                    errs = [{\n",
+        "                        from: CodeMirror.Pos(line - 1, col - 1),\n",
+        "                        to: CodeMirror.Pos(line - 1, col),\n",
+        "                        message: widget.error[\"msg\"],\n",
+        "                        severity: \"error\"\n",
+        "                    }];\n",
+        "                }\n",
+        "                update(cm, errs);\n",
+        "            },\n",
+        "            \"async\": true,\n",
+        "        }\n",
+        "    };\n",
+        "\n",
+        "    // Create the editor.\n",
+        "    var out = this.cell.output_area.element;\n",
+        "    this.textarea = out.find(\"#parsec-editor\")[0];\n",
+        "    this.output = out.find(\"#parsec-output\")[0];\n",
+        "\n",
+        "    var editor = CodeMirror.fromTextArea(this.textarea, options);\n",
+        "    var editor = editor;\n",
+        "\n",
+        "    // Update every key press.\n",
+        "    editor.on(\"keyup\", function() {\n",
+        "        var text = editor.getDoc().getValue();\n",
+        "        console.log(\"Sent\",text); \n",
+        "        comm.send({\"text\": text});\n",
+        "    });\n",
+        "};\n",
+        "\n",
+        "ParsecWidget.prototype.handler = function(msg) {\n",
+        "    console.log(\"Handler\", msg); \n",
+        "    var data = msg.content.data;\n",
+        "    this.hasError = data[\"status\"] == \"error\";\n",
+        "    if (this.hasError) {\n",
+        "        out = data[\"msg\"];\n",
+        "        this.error = data;\n",
+        "    } else {\n",
+        "        out = data[\"result\"];\n",
+        "    }\n",
+        "    // Update viewed output.\n",
+        "    this.output.innerHTML = out;\n",
+        "};\n",
+        "\n",
+        "// Register this widget.\n",
+        "IPython.notebook.kernel.comm_manager.register_target('parsec', IPython.utils.always_new(ParsecWidget));\n",
+        "console.log(\"Registering Parsec widget.\");\n",
+        "}\n",
+        "</script>\n",
+        "\n",
+        "<!-- Parsec widget DOM -->\n",
+        "<form><textarea id=\"parsec-editor\">Insert parser text here...</textarea></form>\n",
+        "<pre id=\"parsec-output\"></pre>\n"
+       ],
+       "metadata": {},
+       "output_type": "display_data"
+      }
+     ],
+     "prompt_number": 3
     },
     {
      "cell_type": "code",

src/IHaskell/Display.hs

 {-# LANGUAGE NoImplicitPrelude, OverloadedStrings, FlexibleInstances #-}
 module IHaskell.Display (
   IHaskellDisplay(..),
+  IHaskellWidget(..),
   plain, html, png, jpg, svg, latex,
   serializeDisplay,
   Width, Height, Base64(..),
@@ -10,7 +11,8 @@ module IHaskell.Display (
   printDisplay,
 
   -- Internal only use
-  displayFromChan
+  displayFromChan,
+  Widget(..),
   ) where
 
 import ClassyPrelude
@@ -19,6 +21,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 +31,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/Eval/Evaluate.hs

@@ -33,6 +33,7 @@ import Data.Maybe (fromJust)
 import qualified Control.Monad.IO.Class as MonadIO (MonadIO, liftIO)
 import qualified MonadUtils (MonadIO, liftIO)
 import System.Environment (getEnv)
+import qualified Data.Map as Map
 
 import NameSet
 import Name
@@ -69,6 +70,7 @@ import IHaskell.Display
 import qualified IHaskell.Eval.Hoogle as Hoogle
 import IHaskell.Eval.Util
 import IHaskell.BrokenPackages
+import qualified  IPython.Message.UUID      as UUID
 
 import Paths_ihaskell (version)
 import Data.Version (versionBranch)
@@ -219,7 +221,8 @@ data EvalOut = EvalOut {
     evalStatus :: ErrorOccurred,
     evalResult :: Display,
     evalState :: KernelState,
-    evalPager :: String
+    evalPager :: String,
+    evalComms :: [CommInfo]
   }
 
 -- | Evaluate some IPython input code.
@@ -234,7 +237,7 @@ evaluate kernelState code output = do
   when (getLintStatus kernelState /= LintOff) $ liftIO $ do
     lintSuggestions <- lint cmds
     unless (noResults lintSuggestions) $
-      output $ FinalResult lintSuggestions ""
+      output $ FinalResult lintSuggestions "" []
 
   updated <- runUntilFailure kernelState (map unloc cmds ++ [storeItCommand execCount])
   return updated {
@@ -261,9 +264,11 @@ evaluate kernelState code output = do
 
       -- Output things only if they are non-empty.
       unless (noResults result && null helpStr) $
-        liftIO $ output $ FinalResult result helpStr
+        liftIO $ output $ FinalResult result helpStr (evalComms evalOut)
+
+      -- Make sure to clear all comms we've started.
+      let newState = evalState evalOut { evalComms = [] }
 
-      let newState = evalState evalOut
       case evalStatus evalOut of
         Success -> runUntilFailure newState rest
         Failure -> return newState
@@ -286,7 +291,8 @@ safely state = ghandle handler . ghandle sourceErrorHandler
         evalStatus = Failure,
         evalResult = displayError $ show exception,
         evalState = state,
-        evalPager = ""
+        evalPager = "",
+        evalComms = []
       }
 
     sourceErrorHandler :: SourceError -> Interpreter EvalOut
@@ -303,7 +309,8 @@ safely state = ghandle handler . ghandle sourceErrorHandler
         evalStatus = Failure,
         evalResult = displayError fullErr,
         evalState = state,
-        evalPager = ""
+        evalPager = "",
+        evalComms = []
       }
 
 wrapExecution :: KernelState
@@ -314,7 +321,8 @@ wrapExecution state exec = safely state $ exec >>= \res ->
       evalStatus = Success,
       evalResult = res,
       evalState = state,
-      evalPager = ""
+      evalPager = "",
+      evalComms = []
     }
 
 -- | Return the display data for this command, as well as whether it
@@ -390,7 +398,8 @@ evalCommand output (Directive SetDynFlag flags) state =
               evalStatus = Success,
               evalResult = mempty,
               evalState = updater state,
-              evalPager = ""
+              evalPager = "",
+              evalComms = []
             }
 
         -- If not a kernel option, must be a dyn flag.
@@ -403,7 +412,8 @@ evalCommand output (Directive SetDynFlag flags) state =
             evalStatus = Success,
             evalResult = display,
             evalState = state,
-            evalPager = ""
+            evalPager = "",
+            evalComms = []
           }
 
     -- Apply many flags.
@@ -434,7 +444,8 @@ evalCommand a (Directive SetOption opts) state = do
       evalStatus = Failure,
       evalResult = displayError err,
       evalState = state,
-      evalPager = ""
+      evalPager = "",
+      evalComms = []
     }
   else
     let options = mapMaybe findOption $ words opts
@@ -443,7 +454,8 @@ evalCommand a (Directive SetOption opts) state = do
         evalStatus = Success,
         evalResult = mempty,
         evalState = updater state,
-        evalPager = ""
+        evalPager = "",
+        evalComms = []
       }
   where
     optionExists = isJust . findOption
@@ -552,7 +564,8 @@ evalCommand _ (Directive GetHelp _) state = do
     evalStatus = Success,
     evalResult = Display [out],
     evalState = state,
-    evalPager = ""
+    evalPager = "",
+    evalComms = []
   }
   where out = plain $ intercalate "\n"
           ["The following commands are available:"
@@ -617,7 +630,8 @@ evalCommand _ (Directive GetInfo str) state = safely state $ do
     evalStatus = Success,
     evalResult = mempty,
     evalState = state,
-    evalPager = output
+    evalPager = output,
+    evalComms = []
   }
 
 evalCommand _ (Directive SearchHoogle query) state = safely state $ do
@@ -680,8 +694,21 @@ evalCommand output (Expression expr) state = do
   let displayExpr = printf "(IHaskell.Display.display (%s))" expr :: String
   canRunDisplay <- attempt $ exprType displayExpr
 
+  -- Check if this is a widget.
+  let widgetExpr = printf "(IHaskell.Display.Widget (%s))" expr :: String
+  isWidget <- attempt $ exprType widgetExpr
+
   if canRunDisplay
-  then useDisplay displayExpr
+  then do
+    -- Use the display. As a result, `it` is set to the output.
+    out <- useDisplay displayExpr
+
+    -- Register the `it` object as a widget.
+    out' <- if isWidget
+           then registerWidget out
+           else return out
+    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.
@@ -756,6 +783,27 @@ 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 uuid (targetName widget) : evalComms evalOut,
+                evalState = state'
+              }
+
     isIO expr = attempt $ exprType $ printf "((\\x -> x) :: IO a -> IO a) (%s)" expr
 
     postprocessShowError :: EvalOut -> EvalOut
@@ -821,7 +869,8 @@ evalCommand _ (ParseError loc err) state = do
     evalStatus = Failure,
     evalResult = displayError $ formatParseError loc err,
     evalState = state,
-    evalPager = ""
+    evalPager = "",
+    evalComms = []
   }
 
 
@@ -830,7 +879,8 @@ hoogleResults state results = EvalOut {
     evalStatus = Success,
     evalResult = mempty,
     evalState = state,
-    evalPager = output
+    evalPager = output,
+    evalComms = []
   }
   where
     fmt =

src/IHaskell/Types.hs

 {-# LANGUAGE NoImplicitPrelude, OverloadedStrings, DeriveDataTypeable, DeriveGeneric #-}
+{-# LANGUAGE ExistentialQuantification #-}
 -- | Description : All message type definitions.
 module IHaskell.Types (
   Message (..),
@@ -24,20 +25,24 @@ module IHaskell.Types (
   extractPlain,
   kernelOpts,
   KernelOpt(..),
+  IHaskellDisplay(..),
+  IHaskellWidget(..),
+  Widget(..),
+  CommInfo(..),
   ) 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 +71,51 @@ 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
+  -- Output target name for this widget.
+  -- The actual input parameter should be ignored.
+  targetName :: a -> String
+
+  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
+            deriving Typeable
+
+instance IHaskellDisplay Widget where
+  display (Widget widget) = display widget
+
+instance IHaskellWidget Widget where
+  targetName (Widget widget) = targetName widget
+  comm (Widget widget) = comm widget
+  close (Widget widget) = close widget
+
+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 +140,8 @@ data KernelState = KernelState
     getFrontend :: FrontendType,
     useSvg :: Bool,
     useShowErrors :: Bool,
-    useShowTypes :: Bool
+    useShowTypes :: Bool,
+    openComms :: Map UUID Widget
   }
   deriving Show
 
@@ -101,7 +152,8 @@ defaultKernelState = KernelState
     getFrontend = IPythonConsole,
     useSvg = True,
     useShowErrors = False,
-    useShowTypes = False
+    useShowTypes = False,
+    openComms = empty
   }
 
 data FrontendType
@@ -143,6 +195,7 @@ data LintStatus
      | LintOff
      deriving (Eq, Show)
 
+data CommInfo = CommInfo UUID String
 
 -- | Output of evaluation.
 data EvaluationResult =
@@ -152,6 +205,7 @@ data EvaluationResult =
     outputs :: Display      -- ^ Display outputs.
   }
   | FinalResult {
-    outputs :: Display,     -- ^ Display outputs.
-    pagerOut :: String            -- ^ Text to display in the IPython pager.
+    outputs :: Display,       -- ^ Display outputs.
+    pagerOut :: String,       -- ^ Text to display in the IPython pager.
+    startComms :: [CommInfo]  -- ^ Comms to start.
   }

src/Main.hs

@@ -180,17 +180,30 @@ 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
-
-      -- Write the reply to the reply channel.
-      liftIO $ writeChan (shellReplyChannel interface) reply
+      -- 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 (iopubChannel interface)
+        newState <- handleComm replier oldState request replyHeader
+        putMVar state newState
+        writeChan (shellReplyChannel interface) SendNothing
+      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
   where
     ignoreCtrlC =
       installHandler keyboardSignal (CatchOnce $ putStrLn "Press Ctrl-C again to quit kernel.") Nothing
 
+    isCommMessage req = msgType (header req) `elem` [CommDataMessage, CommCloseMessage]
+
 -- Initial kernel state.
 initialKernelState :: IO (MVar KernelState)
 initialKernelState =
@@ -280,6 +293,11 @@ replyTo interface req@ExecuteRequest{ getCode = code } replyHeader state = do
       convertSvgToHtml x = x
       makeSvgImg base64data = unpack $ "<img src=\"data:image/svg+xml;base64," ++ base64data ++ "\"/>"
 
+      startComm :: CommInfo -> IO ()
+      startComm (CommInfo uuid target) = do
+        header <- dupHeader replyHeader CommOpenMessage
+        send $ CommOpen header target uuid (Object mempty)
+
       publish :: EvaluationResult -> IO ()
       publish result = do
         let final = case result of
@@ -304,15 +322,20 @@ 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) $
             modifyMVar_ pagerOutput (return . (++ pager ++ "\n"))
+            
 
   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 (unpack code) execCount
+
   -- Run code and publish to the frontend as we go.
   updatedState <- evaluate state (unpack code) publish
 
@@ -348,3 +371,22 @@ 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
+        CommDataMessage -> do
+          comm widget dat communicate
+          return kernelState
+        CommCloseMessage -> do
+          close widget dat
+          return kernelState { openComms = Map.delete uuid widgets }