Backend should now start comms. Untested.

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
@@ -220,7 +221,8 @@ data EvalOut = EvalOut {
     evalStatus :: ErrorOccurred,
     evalResult :: Display,
     evalState :: KernelState,
-    evalPager :: String
+    evalPager :: String,
+    evalComms :: [CommInfo]
   }
 
 -- | Evaluate some IPython input code.
@@ -235,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 {
@@ -262,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
@@ -287,7 +291,8 @@ safely state = ghandle handler . ghandle sourceErrorHandler
         evalStatus = Failure,
         evalResult = displayError $ show exception,
         evalState = state,
-        evalPager = ""
+        evalPager = "",
+        evalComms = []
       }
 
     sourceErrorHandler :: SourceError -> Interpreter EvalOut
@@ -304,7 +309,8 @@ safely state = ghandle handler . ghandle sourceErrorHandler
         evalStatus = Failure,
         evalResult = displayError fullErr,
         evalState = state,
-        evalPager = ""
+        evalPager = "",
+        evalComms = []
       }
 
 wrapExecution :: KernelState
@@ -315,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
@@ -391,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.
@@ -404,7 +412,8 @@ evalCommand output (Directive SetDynFlag flags) state =
             evalStatus = Success,
             evalResult = display,
             evalState = state,
-            evalPager = ""
+            evalPager = "",
+            evalComms = []
           }
 
     -- Apply many flags.
@@ -435,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
@@ -444,7 +454,8 @@ evalCommand a (Directive SetOption opts) state = do
         evalStatus = Success,
         evalResult = mempty,
         evalState = updater state,
-        evalPager = ""
+        evalPager = "",
+        evalComms = []
       }
   where
     optionExists = isJust . findOption
@@ -553,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:"
@@ -618,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
@@ -691,10 +704,10 @@ evalCommand output (Expression expr) state = do
     out <- useDisplay displayExpr
 
     -- Register the `it` object as a widget.
-    newState <- if isWidget
-               then registerWidget out
-               else return state
-    return out { evalState = newState }
+    out' <- if isWidget
+           then registerWidget out
+           else return out
+    return out'
 
   else do
     -- Evaluate this expression as though it's just a statement.
@@ -770,30 +783,26 @@ evalCommand output (Expression expr) state = do
                     then display :: Display
                     else removeSvg display
 
-    registerWidget state evalOut =
-      when (evalStatus 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 <- UUID.random
-            let newComms = Map.insert uuid widget $ openComms state
-                newState = state { openComms = newComms }
-
-            -- Start the comm.
-            startComm uuid widget
-            -- HOW DO WE START A COMM?
-            -- 1. Add field to EvalOut
-            -- that describes commes to start
-            -- 2. Add method to IHaskellWidget that describes the
-            -- target_name.
-            -- 3. Store UUID and target_name in EvalOut field.
-            -- 4. When EvalOut is returned, have Main.hs start the comm.
-            -- 5. Have JS receive the comm and create a widget, just like
-            -- it does in the real IPython example.
-
-            return newState
+    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
 
@@ -860,7 +869,8 @@ evalCommand _ (ParseError loc err) state = do
     evalStatus = Failure,
     evalResult = displayError $ formatParseError loc err,
     evalState = state,
-    evalPager = ""
+    evalPager = "",
+    evalComms = []
   }
 
 
@@ -869,7 +879,8 @@ hoogleResults state results = EvalOut {
     evalStatus = Success,
     evalResult = mempty,
     evalState = state,
-    evalPager = output
+    evalPager = output,
+    evalComms = []
   }
   where
     fmt =

src/IHaskell/Types.hs

@@ -28,6 +28,7 @@ module IHaskell.Types (
   IHaskellDisplay(..),
   IHaskellWidget(..),
   Widget(..),
+  CommInfo(..),
   ) where
 
 import            ClassyPrelude
@@ -82,6 +83,10 @@ 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.
+  targetName :: a -> String
+
   open :: a               -- ^ Widget to open a comm port with.
        -> Value           -- ^ Comm open metadata.
        -> (Value -> IO ()) -- ^ Way to respond to the message.
@@ -99,6 +104,15 @@ class IHaskellDisplay a => IHaskellWidget a where
 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
+  open (Widget widget) = open widget
+  comm (Widget widget) = comm widget
+  close (Widget widget) = close widget
+
 instance Show Widget where
   show _ = "<Widget>"
 
@@ -182,6 +196,7 @@ data LintStatus
      | LintOff
      deriving (Eq, Show)
 
+data CommInfo = CommInfo UUID String
 
 -- | Output of evaluation.
 data EvaluationResult =
@@ -191,6 +206,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

@@ -292,6 +292,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
@@ -316,15 +321,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