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