--------------------------------------------------------------------------------
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}
module Patat.Eval
    ( eval
    ) where


--------------------------------------------------------------------------------
import qualified Control.Concurrent.Async       as Async
import           Control.Exception              (finally)
import qualified Data.HashMap.Strict            as HMS
import           Data.Maybe                     (maybeToList)
import qualified Data.Text                      as T
import qualified Data.Text.IO                   as T
import           Patat.Presentation.Instruction
import           Patat.Presentation.Internal
import           Patat.Presentation.Settings
import           System.Exit                    (ExitCode (..))
import qualified System.IO                      as IO
import           System.IO.Unsafe               (unsafeInterleaveIO)
import qualified System.Process                 as Process
import qualified Text.Pandoc.Definition         as Pandoc


--------------------------------------------------------------------------------
eval :: Presentation -> IO Presentation
eval :: Presentation -> IO Presentation
eval Presentation
presentation = case PresentationSettings -> Maybe EvalSettingsMap
psEval (Presentation -> PresentationSettings
pSettings Presentation
presentation) of
    Maybe EvalSettingsMap
Nothing -> Presentation -> IO Presentation
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Presentation
presentation
    Just EvalSettingsMap
settings -> do
        Seq Slide
slides <- (Slide -> IO Slide) -> Seq Slide -> IO (Seq Slide)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Seq a -> f (Seq b)
traverse (EvalSettingsMap -> Slide -> IO Slide
evalSlide EvalSettingsMap
settings) (Presentation -> Seq Slide
pSlides Presentation
presentation)
        Presentation -> IO Presentation
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Presentation
presentation {pSlides = slides}


--------------------------------------------------------------------------------
lookupSettings :: [T.Text] -> EvalSettingsMap -> [EvalSettings]
lookupSettings :: [Text] -> EvalSettingsMap -> [EvalSettings]
lookupSettings [Text]
classes EvalSettingsMap
settings = do
    Text
c <- [Text]
classes
    Maybe EvalSettings -> [EvalSettings]
forall a. Maybe a -> [a]
maybeToList (Maybe EvalSettings -> [EvalSettings])
-> Maybe EvalSettings -> [EvalSettings]
forall a b. (a -> b) -> a -> b
$ Text -> EvalSettingsMap -> Maybe EvalSettings
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HMS.lookup Text
c EvalSettingsMap
settings


--------------------------------------------------------------------------------
evalSlide :: EvalSettingsMap -> Slide -> IO Slide
evalSlide :: EvalSettingsMap -> Slide -> IO Slide
evalSlide EvalSettingsMap
settings Slide
slide = case Slide -> SlideContent
slideContent Slide
slide of
    TitleSlide Int
_ [Inline]
_ -> Slide -> IO Slide
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Slide
slide
    ContentSlide Instructions Block
instrs0 -> do
        [[Instruction Block]]
instrs1 <- (Instruction Block -> IO [Instruction Block])
-> [Instruction Block] -> IO [[Instruction Block]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (EvalSettingsMap -> Instruction Block -> IO [Instruction Block]
evalInstruction EvalSettingsMap
settings) (Instructions Block -> [Instruction Block]
forall a. Instructions a -> [Instruction a]
toList Instructions Block
instrs0)
        Slide -> IO Slide
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Slide
slide {slideContent = ContentSlide . fromList $ concat instrs1}


--------------------------------------------------------------------------------
evalInstruction
    :: EvalSettingsMap -> Instruction Pandoc.Block
    -> IO [Instruction Pandoc.Block]
evalInstruction :: EvalSettingsMap -> Instruction Block -> IO [Instruction Block]
evalInstruction EvalSettingsMap
settings Instruction Block
instr = case Instruction Block
instr of
    Instruction Block
Pause         -> [Instruction Block] -> IO [Instruction Block]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Instruction Block
forall a. Instruction a
Pause]
    ModifyLast Instruction Block
i  -> (Instruction Block -> Instruction Block)
-> [Instruction Block] -> [Instruction Block]
forall a b. (a -> b) -> [a] -> [b]
map Instruction Block -> Instruction Block
forall a. Instruction a -> Instruction a
ModifyLast ([Instruction Block] -> [Instruction Block])
-> IO [Instruction Block] -> IO [Instruction Block]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EvalSettingsMap -> Instruction Block -> IO [Instruction Block]
evalInstruction EvalSettingsMap
settings Instruction Block
i
    Append []     -> [Instruction Block] -> IO [Instruction Block]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [[Block] -> Instruction Block
forall a. [a] -> Instruction a
Append []]
    Append [Block]
blocks -> [[Instruction Block]] -> [Instruction Block]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Instruction Block]] -> [Instruction Block])
-> IO [[Instruction Block]] -> IO [Instruction Block]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Block -> IO [Instruction Block])
-> [Block] -> IO [[Instruction Block]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (EvalSettingsMap -> Block -> IO [Instruction Block]
evalBlock EvalSettingsMap
settings) [Block]
blocks
    Instruction Block
Delete        -> [Instruction Block] -> IO [Instruction Block]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Instruction Block
forall a. Instruction a
Delete]


--------------------------------------------------------------------------------
evalBlock :: EvalSettingsMap -> Pandoc.Block -> IO [Instruction Pandoc.Block]
evalBlock :: EvalSettingsMap -> Block -> IO [Instruction Block]
evalBlock EvalSettingsMap
settings orig :: Block
orig@(Pandoc.CodeBlock attr :: Attr
attr@(Text
_, [Text]
classes, [(Text, Text)]
_) Text
txt)
    | [s :: EvalSettings
s@EvalSettings {Bool
Text
EvalSettingsContainer
evalCommand :: Text
evalReplace :: Bool
evalFragment :: Bool
evalContainer :: EvalSettingsContainer
evalCommand :: EvalSettings -> Text
evalReplace :: EvalSettings -> Bool
evalFragment :: EvalSettings -> Bool
evalContainer :: EvalSettings -> EvalSettingsContainer
..}] <- [Text] -> EvalSettingsMap -> [EvalSettings]
lookupSettings [Text]
classes EvalSettingsMap
settings = do
        Text
out <- IO Text -> IO Text
forall a. IO a -> IO a
unsafeInterleaveIO (IO Text -> IO Text) -> IO Text -> IO Text
forall a b. (a -> b) -> a -> b
$ do
            EvalResult {Text
ExitCode
erExitCode :: ExitCode
erStdout :: Text
erStderr :: Text
erExitCode :: EvalResult -> ExitCode
erStdout :: EvalResult -> Text
erStderr :: EvalResult -> Text
..} <-  EvalSettings -> Text -> IO EvalResult
evalCode EvalSettings
s Text
txt
            Text -> IO Text
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> IO Text) -> Text -> IO Text
forall a b. (a -> b) -> a -> b
$ case ExitCode
erExitCode of
                ExitCode
ExitSuccess -> Text
erStdout
                ExitFailure Int
i ->
                    Text
evalCommand Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": exit code " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
i) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                    Text
erStderr
        let fmt :: Format
fmt = Format
"eval"
            blocks :: [Block]
blocks = case EvalSettingsContainer
evalContainer of
                EvalSettingsContainer
EvalContainerCode   -> [Attr -> Text -> Block
Pandoc.CodeBlock Attr
attr Text
out]
                EvalSettingsContainer
EvalContainerNone   -> [Format -> Text -> Block
Pandoc.RawBlock Format
fmt Text
out]
                EvalSettingsContainer
EvalContainerInline -> [[Inline] -> Block
Pandoc.Plain [Format -> Text -> Inline
Pandoc.RawInline Format
fmt Text
out]]
        [Instruction Block] -> IO [Instruction Block]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Instruction Block] -> IO [Instruction Block])
-> [Instruction Block] -> IO [Instruction Block]
forall a b. (a -> b) -> a -> b
$ case (Bool
evalFragment, Bool
evalReplace) of
            (Bool
False, Bool
True) -> [[Block] -> Instruction Block
forall a. [a] -> Instruction a
Append [Block]
blocks]
            (Bool
False, Bool
False) -> [[Block] -> Instruction Block
forall a. [a] -> Instruction a
Append (Block
orig Block -> [Block] -> [Block]
forall a. a -> [a] -> [a]
: [Block]
blocks)]
            (Bool
True, Bool
True) ->
                [ [Block] -> Instruction Block
forall a. [a] -> Instruction a
Append [Block
orig], Instruction Block
forall a. Instruction a
Pause
                , Instruction Block
forall a. Instruction a
Delete, [Block] -> Instruction Block
forall a. [a] -> Instruction a
Append [Block]
blocks
                ]
            (Bool
True, Bool
False) ->
                [[Block] -> Instruction Block
forall a. [a] -> Instruction a
Append [Block
orig], Instruction Block
forall a. Instruction a
Pause, [Block] -> Instruction Block
forall a. [a] -> Instruction a
Append [Block]
blocks]
    | EvalSettings
_ : EvalSettings
_ : [EvalSettings]
_ <- [Text] -> EvalSettingsMap -> [EvalSettings]
lookupSettings [Text]
classes EvalSettingsMap
settings =
        let msg :: Text
msg = Text
"patat eval matched multiple settings for " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                Text -> [Text] -> Text
T.intercalate Text
"," [Text]
classes in
        [Instruction Block] -> IO [Instruction Block]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [[Block] -> Instruction Block
forall a. [a] -> Instruction a
Append [Attr -> Text -> Block
Pandoc.CodeBlock Attr
attr Text
msg]]
evalBlock EvalSettingsMap
_ Block
block =
    [Instruction Block] -> IO [Instruction Block]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [[Block] -> Instruction Block
forall a. [a] -> Instruction a
Append [Block
block]]


--------------------------------------------------------------------------------
data EvalResult = EvalResult
    { EvalResult -> ExitCode
erExitCode :: !ExitCode
    , EvalResult -> Text
erStdout   :: !T.Text
    , EvalResult -> Text
erStderr   :: !T.Text
    } deriving (Int -> EvalResult -> ShowS
[EvalResult] -> ShowS
EvalResult -> String
(Int -> EvalResult -> ShowS)
-> (EvalResult -> String)
-> ([EvalResult] -> ShowS)
-> Show EvalResult
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> EvalResult -> ShowS
showsPrec :: Int -> EvalResult -> ShowS
$cshow :: EvalResult -> String
show :: EvalResult -> String
$cshowList :: [EvalResult] -> ShowS
showList :: [EvalResult] -> ShowS
Show)


--------------------------------------------------------------------------------
evalCode :: EvalSettings -> T.Text -> IO EvalResult
evalCode :: EvalSettings -> Text -> IO EvalResult
evalCode EvalSettings {Bool
Text
EvalSettingsContainer
evalCommand :: EvalSettings -> Text
evalReplace :: EvalSettings -> Bool
evalFragment :: EvalSettings -> Bool
evalContainer :: EvalSettings -> EvalSettingsContainer
evalCommand :: Text
evalReplace :: Bool
evalFragment :: Bool
evalContainer :: EvalSettingsContainer
..} Text
input = do
    let proc :: CreateProcess
proc = (String -> CreateProcess
Process.shell (String -> CreateProcess) -> String -> CreateProcess
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
evalCommand)
            { Process.std_in  = Process.CreatePipe
            , Process.std_out = Process.CreatePipe
            , Process.std_err = Process.CreatePipe
            }

    (Just Handle
hIn, Just Handle
hOut, Just Handle
hErr, ProcessHandle
hProc) <- CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
Process.createProcess CreateProcess
proc

    IO () -> (Async () -> IO EvalResult) -> IO EvalResult
forall a b. IO a -> (Async a -> IO b) -> IO b
Async.withAsync (Handle -> Text -> IO ()
T.hPutStr Handle
hIn Text
input IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`finally` Handle -> IO ()
IO.hClose Handle
hIn) ((Async () -> IO EvalResult) -> IO EvalResult)
-> (Async () -> IO EvalResult) -> IO EvalResult
forall a b. (a -> b) -> a -> b
$ \Async ()
_ ->
        IO Text -> (Async Text -> IO EvalResult) -> IO EvalResult
forall a b. IO a -> (Async a -> IO b) -> IO b
Async.withAsync (Handle -> IO Text
T.hGetContents Handle
hOut) ((Async Text -> IO EvalResult) -> IO EvalResult)
-> (Async Text -> IO EvalResult) -> IO EvalResult
forall a b. (a -> b) -> a -> b
$ \Async Text
outAsync ->
        IO Text -> (Async Text -> IO EvalResult) -> IO EvalResult
forall a b. IO a -> (Async a -> IO b) -> IO b
Async.withAsync (Handle -> IO Text
T.hGetContents Handle
hErr) ((Async Text -> IO EvalResult) -> IO EvalResult)
-> (Async Text -> IO EvalResult) -> IO EvalResult
forall a b. (a -> b) -> a -> b
$ \Async Text
errAsync ->
        IO ExitCode -> (Async ExitCode -> IO EvalResult) -> IO EvalResult
forall a b. IO a -> (Async a -> IO b) -> IO b
Async.withAsync (ProcessHandle -> IO ExitCode
Process.waitForProcess ProcessHandle
hProc) ((Async ExitCode -> IO EvalResult) -> IO EvalResult)
-> (Async ExitCode -> IO EvalResult) -> IO EvalResult
forall a b. (a -> b) -> a -> b
$ \Async ExitCode
exitCodeAsync -> do

        ExitCode
erExitCode <- Async ExitCode -> IO ExitCode
forall a. Async a -> IO a
Async.wait Async ExitCode
exitCodeAsync
        Text
erStdout <- Async Text -> IO Text
forall a. Async a -> IO a
Async.wait Async Text
outAsync
        Text
erStderr <- Async Text -> IO Text
forall a. Async a -> IO a
Async.wait Async Text
errAsync
        EvalResult -> IO EvalResult
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EvalResult -> IO EvalResult) -> EvalResult -> IO EvalResult
forall a b. (a -> b) -> a -> b
$ EvalResult {Text
ExitCode
erExitCode :: ExitCode
erStdout :: Text
erStderr :: Text
erExitCode :: ExitCode
erStdout :: Text
erStderr :: Text
..}