{-# language NoImplicitPrelude, DoAndIfThenElse, OverloadedStrings, ExtendedDefaultRules #-}
module IHaskell.Publish
  ( publishResult
  ) where

import           IHaskellPrelude

import qualified Data.Text as T
import qualified Data.Time as Time

import           IHaskell.Display
import           IHaskell.Types

-- | Publish evaluation results, ignore any CommMsgs. This function can be used to create a function
-- of type (EvaluationResult -> IO ()), which can be used to publish results to the frontend. The
-- resultant function shares some state between different calls by storing it inside the MVars
-- passed while creating it using this function. Pager output is accumulated in the MVar passed for
-- this purpose if a pager is being used (indicated by an argument), and sent to the frontend
-- otherwise.
publishResult :: (Message -> IO ()) -- ^ A function to send messages
              -> MessageHeader      -- ^ Message header to use for reply
              -> MVar [Display]     -- ^ A MVar to use for displays
              -> MVar Bool          -- ^ A mutable boolean to decide whether the output need to be cleared and
                                    -- redrawn
              -> MVar [DisplayData] -- ^ A MVar to use for storing pager output
              -> Bool               -- ^ Whether to use the pager
              -> EvaluationResult   -- ^ The evaluation result
              -> ErrorOccurred      -- ^ Whether evaluation completed successfully
              -> IO ()
publishResult :: (Message -> IO ())
-> MessageHeader
-> MVar [Display]
-> MVar Bool
-> MVar [DisplayData]
-> Bool
-> EvaluationResult
-> ErrorOccurred
-> IO ()
publishResult Message -> IO ()
send MessageHeader
replyHeader MVar [Display]
displayed MVar Bool
updateNeeded MVar [DisplayData]
poutput Bool
upager EvaluationResult
result ErrorOccurred
success = do
  let final :: Bool
final =
        case EvaluationResult
result of
          IntermediateResult{} -> Bool
False
          FinalResult{}        -> Bool
True
      outs :: Display
outs = EvaluationResult -> Display
evaluationOutputs EvaluationResult
result

  -- Get time to send to output for unique labels.
  Text
uniqueLabel <- IO Text
getUniqueLabel

  -- If necessary, clear all previous output and redraw.
  Bool
clear <- forall a. MVar a -> IO a
readMVar MVar Bool
updateNeeded
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
clear forall a b. (a -> b) -> a -> b
$ do
    IO ()
clearOutput
    [Display]
disps <- forall a. MVar a -> IO a
readMVar MVar [Display]
displayed
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Text -> Display -> IO ()
sendOutput Text
uniqueLabel) forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse [Display]
disps

  -- Draw this message.
  Text -> Display -> IO ()
sendOutput Text
uniqueLabel Display
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.
  forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar Bool
updateNeeded (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not Bool
final)
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
final forall a b. (a -> b) -> a -> b
$ do
    forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar [Display]
displayed (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Display
outs forall a. a -> [a] -> [a]
:))

    -- If this has some pager output, store it for later.
    case EvaluationResult
result of
      IntermediateResult Display
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      FinalResult Display
_ [DisplayData]
pager [WidgetMsg]
_ ->
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [DisplayData]
pager) forall a b. (a -> b) -> a -> b
$
          if Bool
upager
            then forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar [DisplayData]
poutput (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. [a] -> [a] -> [a]
++ [DisplayData]
pager))
            else Text -> Display -> IO ()
sendOutput Text
uniqueLabel forall a b. (a -> b) -> a -> b
$ [DisplayData] -> Display
Display [DisplayData]
pager

  where
    clearOutput :: IO ()
clearOutput = do
      MessageHeader
hdr <- MessageHeader -> MessageType -> IO MessageHeader
dupHeader MessageHeader
replyHeader MessageType
ClearOutputMessage
      Message -> IO ()
send forall a b. (a -> b) -> a -> b
$ MessageHeader -> Bool -> Message
ClearOutput MessageHeader
hdr Bool
True

    sendOutput :: Text -> Display -> IO ()
sendOutput Text
uniqueLabel (ManyDisplay [Display]
manyOuts) =
      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Text -> Display -> IO ()
sendOutput Text
uniqueLabel) [Display]
manyOuts
    sendOutput Text
uniqueLabel (Display [DisplayData]
outs) = case ErrorOccurred
success of
      ErrorOccurred
Success -> do
        MessageHeader
hdr <- MessageHeader -> MessageType -> IO MessageHeader
dupHeader MessageHeader
replyHeader MessageType
DisplayDataMessage
        Message -> IO ()
send forall a b. (a -> b) -> a -> b
$ MessageHeader -> [DisplayData] -> Maybe Transient -> Message
PublishDisplayData MessageHeader
hdr (forall a b. (a -> b) -> [a] -> [b]
map (Text -> DisplayData -> DisplayData
makeUnique Text
uniqueLabel) [DisplayData]
outs) forall a. Maybe a
Nothing
      ErrorOccurred
Failure -> do
        MessageHeader
hdr <- MessageHeader -> MessageType -> IO MessageHeader
dupHeader MessageHeader
replyHeader MessageType
ExecuteErrorMessage
        Message -> IO ()
send forall a b. (a -> b) -> a -> b
$ MessageHeader -> [Text] -> Text -> Text -> Message
ExecuteError MessageHeader
hdr [String -> Text
T.pack ([DisplayData] -> String
extractPlain [DisplayData]
outs)] Text
"" Text
""

    makeUnique :: Text -> DisplayData -> DisplayData
makeUnique Text
l (DisplayData MimeType
MimeSvg Text
s) =
      MimeType -> Text -> DisplayData
DisplayData MimeType
MimeSvg
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Text -> Text
T.replace Text
"glyph" (Text
"glyph-" forall a. Semigroup a => a -> a -> a
<> Text
l)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Text -> Text
T.replace Text
"\"clip" (Text
"\"clip-" forall a. Semigroup a => a -> a -> a
<> Text
l)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Text -> Text
T.replace Text
"#clip" (Text
"#clip-" forall a. Semigroup a => a -> a -> a
<> Text
l)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Text -> Text
T.replace Text
"\"image" (Text
"\"image-" forall a. Semigroup a => a -> a -> a
<> Text
l)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Text -> Text
T.replace Text
"#image" (Text
"#image-" forall a. Semigroup a => a -> a -> a
<> Text
l)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Text -> Text
T.replace Text
"linearGradient id=\"linear" (Text
"linearGradient id=\"linear-" forall a. Semigroup a => a -> a -> a
<> Text
l)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Text -> Text
T.replace Text
"#linear" (Text
"#linear-" forall a. Semigroup a => a -> a -> a
<> Text
l)
        forall a b. (a -> b) -> a -> b
$ Text
s
    makeUnique Text
_ DisplayData
x = DisplayData
x

    getUniqueLabel :: IO Text
getUniqueLabel =
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Time.UTCTime Day
d DiffTime
s) -> String -> Text
T.pack (forall a. Show a => a -> String
show Day
d) forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (forall a. Show a => a -> String
show DiffTime
s))
        IO UTCTime
Time.getCurrentTime