diff --git a/ihaskell.cabal b/ihaskell.cabal
index 6ce41f94..e2a9e416 100644
--- a/ihaskell.cabal
+++ b/ihaskell.cabal
@@ -108,6 +108,7 @@ library
IHaskell.Eval.ParseShell
IHaskell.Eval.Widgets
IHaskell.Eval.Util
+ IHaskell.Publish
IHaskell.IPython
IHaskell.IPython.Stdin
IHaskell.Flags
diff --git a/main/Main.hs b/main/Main.hs
index d9c05a4c..a9b609a3 100644
--- a/main/Main.hs
+++ b/main/Main.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP, ScopedTypeVariables, QuasiQuotes #-}
+{-# LANGUAGE CPP, ScopedTypeVariables #-}
-- | Description : Argument parsing and basic messaging loop, using Haskell
-- Chans to communicate with the ZeroMQ sockets.
@@ -34,6 +34,7 @@ import IHaskell.Eval.Widgets (widgetHandler)
import IHaskell.Flags
import IHaskell.IPython
import IHaskell.Types
+import IHaskell.Publish
import IHaskell.IPython.ZeroMQ
import IHaskell.IPython.Types
import qualified IHaskell.IPython.Message.UUID as UUID
@@ -49,9 +50,6 @@ ghcVersionInts = map (fromJust . readMay) . words . map dotToSpace $ VERSION_ghc
dotToSpace '.' = ' '
dotToSpace x = x
-ihaskellCSS :: String
-ihaskellCSS = [hereFile|html/custom.css|]
-
consoleBanner :: Text
consoleBanner =
"Welcome to IHaskell! Run `IHaskell --help` for more information.\n" <>
@@ -236,58 +234,6 @@ replyTo interface req@ExecuteRequest { getCode = code } replyHeader state = do
displayed <- liftIO $ newMVar []
updateNeeded <- liftIO $ newMVar False
pagerOutput <- liftIO $ newMVar []
- let clearOutput = do
- header <- dupHeader replyHeader ClearOutputMessage
- send $ ClearOutput header True
-
- sendOutput (ManyDisplay manyOuts) = mapM_ sendOutput manyOuts
- sendOutput (Display outs) = do
- header <- dupHeader replyHeader DisplayDataMessage
- send $ PublishDisplayData header "haskell" $ map (convertSvgToHtml . prependCss) outs
-
- convertSvgToHtml (DisplayData MimeSvg svg) = html $ makeSvgImg $ base64 $ E.encodeUtf8 svg
- convertSvgToHtml x = x
-
- makeSvgImg :: Base64 -> String
- makeSvgImg base64data = T.unpack $ "
- base64data <>
- "\"/>"
-
- prependCss (DisplayData MimeHtml html) =
- DisplayData MimeHtml $ mconcat ["", html]
- prependCss x = x
-
- -- Publish outputs, ignore any CommMsgs
- publish :: EvaluationResult -> IO ()
- publish result = do
- let final =
- case result of
- IntermediateResult{} -> False
- FinalResult{} -> True
- outs = outputs result
-
- -- If necessary, clear all previous output and redraw.
- clear <- readMVar updateNeeded
- when clear $ do
- clearOutput
- disps <- readMVar displayed
- mapM_ sendOutput $ reverse disps
-
- -- Draw this message.
- sendOutput outs
-
- -- If this is the final message, add it to the list of completed messages. If it isn't, make sure we
- -- clear it later by marking update needed as true.
- modifyMVar_ updateNeeded (const $ return $ not final)
- when final $ do
- modifyMVar_ displayed (return . (outs :))
-
- -- If this has some pager output, store it for later.
- let pager = pagerOut result
- unless (null pager) $
- if usePager state
- then modifyMVar_ pagerOutput (return . (++ pager))
- else sendOutput $ Display pager
let execCount = getExecutionCounter state
-- Let all frontends know the execution count and code that's about to run
@@ -296,6 +242,7 @@ replyTo interface req@ExecuteRequest { getCode = code } replyHeader state = do
-- Run code and publish to the frontend as we go.
let widgetMessageHandler = widgetHandler send replyHeader
+ publish = publishResult send replyHeader displayed updateNeeded pagerOutput (usePager state)
updatedState <- evaluate state (T.unpack code) publish widgetMessageHandler
-- Notify the frontend that we're done computing.
diff --git a/src/IHaskell/Publish.hs b/src/IHaskell/Publish.hs
new file mode 100644
index 00000000..edaf7f2d
--- /dev/null
+++ b/src/IHaskell/Publish.hs
@@ -0,0 +1,77 @@
+{-# LANGUAGE QuasiQuotes #-}
+
+module IHaskell.Publish
+ ( publishResult
+ ) where
+
+import IHaskellPrelude
+
+import Data.String.Here (hereFile)
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as E
+
+import IHaskell.Display
+import IHaskell.Types
+
+ihaskellCSS :: String
+ihaskellCSS = [hereFile|html/custom.css|]
+
+-- Publish outputs, ignore any CommMsgs
+publishResult :: (Message -> IO ())
+ -> MessageHeader
+ -> MVar [Display]
+ -> MVar Bool
+ -> MVar [DisplayData]
+ -> Bool
+ -> EvaluationResult
+ -> IO ()
+publishResult send replyHeader displayed updateNeeded pagerOutput usePager result = do
+ let final =
+ case result of
+ IntermediateResult{} -> False
+ FinalResult{} -> True
+ outs = outputs result
+
+ -- If necessary, clear all previous output and redraw.
+ clear <- readMVar updateNeeded
+ when clear $ do
+ clearOutput
+ disps <- readMVar displayed
+ mapM_ sendOutput $ reverse disps
+
+ -- Draw this message.
+ sendOutput outs
+
+ -- If this is the final message, add it to the list of completed messages. If it isn't, make sure we
+ -- clear it later by marking update needed as true.
+ modifyMVar_ updateNeeded (const $ return $ not final)
+ when final $ do
+ modifyMVar_ displayed (return . (outs :))
+
+ -- If this has some pager output, store it for later.
+ let pager = pagerOut result
+ unless (null pager) $
+ if usePager
+ then modifyMVar_ pagerOutput (return . (++ pager))
+ else sendOutput $ Display pager
+ where
+ clearOutput = do
+ header <- dupHeader replyHeader ClearOutputMessage
+ send $ ClearOutput header True
+
+ sendOutput (ManyDisplay manyOuts) = mapM_ sendOutput manyOuts
+ sendOutput (Display outs) = do
+ header <- dupHeader replyHeader DisplayDataMessage
+ send $ PublishDisplayData header "haskell" $ map (convertSvgToHtml . prependCss) outs
+
+ convertSvgToHtml (DisplayData MimeSvg svg) = html $ makeSvgImg $ base64 $ E.encodeUtf8 svg
+ convertSvgToHtml x = x
+
+ makeSvgImg :: Base64 -> String
+ makeSvgImg base64data = T.unpack $ "
+ base64data <>
+ "\"/>"
+
+ prependCss (DisplayData MimeHtml html) =
+ DisplayData MimeHtml $ mconcat ["", html]
+ prependCss x = x