--------------------------------------------------------------------------------
{-# 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 qualified Data.Text                      as T
import qualified Data.Text.IO                   as T
import           Patat.Presentation.Instruction
import           Patat.Presentation.Internal
import           System.Exit                    (ExitCode (..))
import qualified System.IO                      as IO
import Data.Maybe (maybeToList)
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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Presentation
presentation
    Just EvalSettingsMap
settings -> do
        [Slide]
slides <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (EvalSettingsMap -> Slide -> IO Slide
evalSlide EvalSettingsMap
settings) (Presentation -> [Slide]
pSlides Presentation
presentation)
        forall (f :: * -> *) a. Applicative f => a -> f a
pure Presentation
presentation {pSlides :: [Slide]
pSlides = [Slide]
slides}


--------------------------------------------------------------------------------
lookupSettings :: [T.Text] -> EvalSettingsMap -> [EvalSettings]
lookupSettings :: [Text] -> EvalSettingsMap -> [EvalSettings]
lookupSettings [Text]
classes EvalSettingsMap
settings = do
    Text
c <- [Text]
classes
    forall a. Maybe a -> [a]
maybeToList forall a b. (a -> b) -> a -> b
$ 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
slide of
    TitleSlide Int
_ [Inline]
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Slide
slide
    ContentSlide Instructions Block
instrs -> Instructions Block -> Slide
ContentSlide forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [Instruction a] -> Instructions a
fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (EvalSettingsMap -> Instruction Block -> IO [Instruction Block]
evalInstruction EvalSettingsMap
settings) (forall a. Instructions a -> [Instruction a]
toList Instructions Block
instrs)


--------------------------------------------------------------------------------
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         -> forall (f :: * -> *) a. Applicative f => a -> f a
pure [forall a. Instruction a
Pause]
    ModifyLast Instruction Block
i  -> forall a b. (a -> b) -> [a] -> [b]
map forall a. Instruction a -> Instruction a
ModifyLast 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 []     -> forall (f :: * -> *) a. Applicative f => a -> f a
pure [forall a. [a] -> Instruction a
Append []]
    Append [Block]
blocks -> forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (EvalSettingsMap -> Block -> IO [Instruction Block]
evalBlock EvalSettingsMap
settings) [Block]
blocks
    Instruction Block
Delete        -> forall (f :: * -> *) a. Applicative f => a -> f a
pure [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
evalFragment :: EvalSettings -> Bool
evalReplace :: EvalSettings -> Bool
evalCommand :: EvalSettings -> Text
evalFragment :: Bool
evalReplace :: Bool
evalCommand :: Text
..}] <- [Text] -> EvalSettingsMap -> [EvalSettings]
lookupSettings [Text]
classes EvalSettingsMap
settings = do
        Text
out <- forall a. IO a -> IO a
unsafeInterleaveIO forall a b. (a -> b) -> a -> b
$ do
            EvalResult {Text
ExitCode
erStderr :: EvalResult -> Text
erStdout :: EvalResult -> Text
erExitCode :: EvalResult -> ExitCode
erStderr :: Text
erStdout :: Text
erExitCode :: ExitCode
..} <-  EvalSettings -> Text -> IO EvalResult
evalCode EvalSettings
s Text
txt
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case ExitCode
erExitCode of
                ExitCode
ExitSuccess -> Text
erStdout
                ExitFailure Int
i ->
                    Text
evalCommand forall a. Semigroup a => a -> a -> a
<> Text
": exit code " forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (forall a. Show a => a -> String
show Int
i) forall a. Semigroup a => a -> a -> a
<> Text
"\n" forall a. Semigroup a => a -> a -> a
<>
                    Text
erStderr
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case (Bool
evalFragment, Bool
evalReplace) of
            (Bool
False, Bool
True) -> [forall a. [a] -> Instruction a
Append [Attr -> Text -> Block
Pandoc.CodeBlock Attr
attr Text
out]]
            (Bool
False, Bool
False) -> [forall a. [a] -> Instruction a
Append [Block
orig, Attr -> Text -> Block
Pandoc.CodeBlock Attr
attr Text
out]]
            (Bool
True, Bool
True) ->
                [ forall a. [a] -> Instruction a
Append [Block
orig], forall a. Instruction a
Pause
                , forall a. Instruction a
Delete, forall a. [a] -> Instruction a
Append [Attr -> Text -> Block
Pandoc.CodeBlock Attr
attr Text
out]
                ]
            (Bool
True, Bool
False) ->
                [forall a. [a] -> Instruction a
Append [Block
orig], forall a. Instruction a
Pause, forall a. [a] -> Instruction a
Append [Attr -> Text -> Block
Pandoc.CodeBlock Attr
attr Text
out]]
    | EvalSettings
_ : EvalSettings
_ : [EvalSettings]
_ <- [Text] -> EvalSettingsMap -> [EvalSettings]
lookupSettings [Text]
classes EvalSettingsMap
settings =
        let msg :: Text
msg = Text
"patat eval matched multiple settings for " forall a. Semigroup a => a -> a -> a
<>
                Text -> [Text] -> Text
T.intercalate Text
"," [Text]
classes in
        forall (f :: * -> *) a. Applicative f => a -> f a
pure [forall a. [a] -> Instruction a
Append [Attr -> Text -> Block
Pandoc.CodeBlock Attr
attr Text
msg]]
evalBlock EvalSettingsMap
_ Block
block =
    forall (f :: * -> *) a. Applicative f => a -> f a
pure [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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [EvalResult] -> ShowS
$cshowList :: [EvalResult] -> ShowS
show :: EvalResult -> String
$cshow :: EvalResult -> String
showsPrec :: Int -> EvalResult -> ShowS
$cshowsPrec :: Int -> EvalResult -> ShowS
Show)


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

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

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