--------------------------------------------------------------------------------
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}
module Patat.Eval
    ( parseEvalBlocks

    , evalVar
    , evalActiveVars
    , evalAllVars
    ) where


--------------------------------------------------------------------------------
import qualified Control.Concurrent.Async    as Async
import           Control.Exception           (IOException, catch, finally)
import           Control.Monad               (foldM, when)
import           Control.Monad.State         (StateT, runStateT, state)
import           Control.Monad.Writer        (Writer, runWriter, tell)
import           Data.CaseInsensitive        (CI)
import qualified Data.CaseInsensitive        as CI
import           Data.Foldable               (for_)
import qualified Data.HashMap.Strict         as HMS
import qualified Data.IORef                  as IORef
import           Data.List                   (foldl')
import           Data.Maybe                  (maybeToList)
import qualified Data.Set                    as S
import qualified Data.Text                   as T
import qualified Data.Text.IO                as T
import           Patat.Eval.Internal
import           Patat.Presentation.Internal
import           Patat.Presentation.Syntax
import           Patat.Unique
import           System.Exit                 (ExitCode (..))
import qualified System.IO                   as IO
import qualified System.Process              as Process


--------------------------------------------------------------------------------
parseEvalBlocks :: Presentation -> Presentation
parseEvalBlocks :: Presentation -> Presentation
parseEvalBlocks Presentation
presentation =
    let ((Presentation
pres, UniqueGen
varGen), HashMap Var EvalBlock
evalBlocks) = Writer (HashMap Var EvalBlock) (Presentation, UniqueGen)
-> ((Presentation, UniqueGen), HashMap Var EvalBlock)
forall w a. Writer w a -> (a, w)
runWriter (Writer (HashMap Var EvalBlock) (Presentation, UniqueGen)
 -> ((Presentation, UniqueGen), HashMap Var EvalBlock))
-> Writer (HashMap Var EvalBlock) (Presentation, UniqueGen)
-> ((Presentation, UniqueGen), HashMap Var EvalBlock)
forall a b. (a -> b) -> a -> b
$
            StateT UniqueGen (Writer (HashMap Var EvalBlock)) Presentation
-> UniqueGen
-> Writer (HashMap Var EvalBlock) (Presentation, UniqueGen)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT StateT UniqueGen (Writer (HashMap Var EvalBlock)) Presentation
work (Presentation -> UniqueGen
pUniqueGen Presentation
presentation) in
    Presentation
pres {pEvalBlocks = evalBlocks, pUniqueGen = varGen}
  where
    work :: StateT UniqueGen (Writer (HashMap Var EvalBlock)) Presentation
work = case PresentationSettings -> Maybe EvalSettingsMap
psEval (Presentation -> PresentationSettings
pSettings Presentation
presentation) of
        Maybe EvalSettingsMap
Nothing -> Presentation
-> StateT UniqueGen (Writer (HashMap Var EvalBlock)) Presentation
forall a. a -> StateT UniqueGen (Writer (HashMap Var EvalBlock)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Presentation
presentation
        Just EvalSettingsMap
settings -> do
            slides <- (Slide -> StateT UniqueGen (Writer (HashMap Var EvalBlock)) Slide)
-> Seq Slide
-> StateT UniqueGen (Writer (HashMap Var EvalBlock)) (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 -> StateT UniqueGen (Writer (HashMap Var EvalBlock)) Slide
evalSlide EvalSettingsMap
settings) (Presentation -> Seq Slide
pSlides Presentation
presentation)
            pure presentation {pSlides = slides}


--------------------------------------------------------------------------------
lookupSettings :: [CI T.Text] -> EvalSettingsMap -> [EvalSettings]
lookupSettings :: [CI Text] -> EvalSettingsMap -> [EvalSettings]
lookupSettings [CI Text]
classes (EvalSettingsMap HashMap (CI Text) EvalSettings
settings) = do
    c <- [CI Text]
classes
    maybeToList $ HMS.lookup c settings


--------------------------------------------------------------------------------
-- | Monad used for identifying and extracting the evaluation blocks from a
-- presentation.
type ExtractEvalM a = StateT UniqueGen (Writer (HMS.HashMap Var EvalBlock)) a


--------------------------------------------------------------------------------
evalSlide :: EvalSettingsMap -> Slide -> ExtractEvalM Slide
evalSlide :: EvalSettingsMap
-> Slide -> StateT UniqueGen (Writer (HashMap Var EvalBlock)) Slide
evalSlide EvalSettingsMap
settings Slide
slide = case Slide -> SlideContent
slideContent Slide
slide of
    TitleSlide Int
_ [Inline]
_ -> Slide -> StateT UniqueGen (Writer (HashMap Var EvalBlock)) Slide
forall a. a -> StateT UniqueGen (Writer (HashMap Var EvalBlock)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Slide
slide
    ContentSlide [Block]
blocks -> do
        blocks1 <- (Block
 -> StateT UniqueGen (Writer (HashMap Var EvalBlock)) [Block])
-> (Inline
    -> StateT UniqueGen (Writer (HashMap Var EvalBlock)) [Inline])
-> [Block]
-> StateT UniqueGen (Writer (HashMap Var EvalBlock)) [Block]
forall (m :: * -> *).
Monad m =>
(Block -> m [Block])
-> (Inline -> m [Inline]) -> [Block] -> m [Block]
dftBlocks (EvalSettingsMap
-> Block
-> StateT UniqueGen (Writer (HashMap Var EvalBlock)) [Block]
evalBlock EvalSettingsMap
settings) ([Inline]
-> StateT UniqueGen (Writer (HashMap Var EvalBlock)) [Inline]
forall a. a -> StateT UniqueGen (Writer (HashMap Var EvalBlock)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Inline]
 -> StateT UniqueGen (Writer (HashMap Var EvalBlock)) [Inline])
-> (Inline -> [Inline])
-> Inline
-> StateT UniqueGen (Writer (HashMap Var EvalBlock)) [Inline]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Inline -> [Inline]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure) [Block]
blocks
        pure slide {slideContent = ContentSlide blocks1}


--------------------------------------------------------------------------------
evalBlock
    :: EvalSettingsMap -> Block
    -> ExtractEvalM [Block]
evalBlock :: EvalSettingsMap
-> Block
-> StateT UniqueGen (Writer (HashMap Var EvalBlock)) [Block]
evalBlock EvalSettingsMap
settings orig :: Block
orig@(CodeBlock [CI Text]
classes Text
txt)
    | [s :: EvalSettings
s@EvalSettings {Bool
Maybe (CI Text)
Text
EvalSettingsContainer
evalCommand :: Text
evalReplace :: Bool
evalReveal :: Bool
evalContainer :: EvalSettingsContainer
evalStderr :: Bool
evalSyntax :: Maybe (CI Text)
evalSyntax :: EvalSettings -> Maybe (CI Text)
evalStderr :: EvalSettings -> Bool
evalContainer :: EvalSettings -> EvalSettingsContainer
evalReveal :: EvalSettings -> Bool
evalReplace :: EvalSettings -> Bool
evalCommand :: EvalSettings -> Text
..}] <- [CI Text] -> EvalSettingsMap -> [EvalSettings]
lookupSettings [CI Text]
classes EvalSettingsMap
settings = do
        var <- Unique -> Var
Var (Unique -> Var)
-> StateT UniqueGen (Writer (HashMap Var EvalBlock)) Unique
-> StateT UniqueGen (Writer (HashMap Var EvalBlock)) Var
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (UniqueGen -> (Unique, UniqueGen))
-> StateT UniqueGen (Writer (HashMap Var EvalBlock)) Unique
forall a.
(UniqueGen -> (a, UniqueGen))
-> StateT UniqueGen (Writer (HashMap Var EvalBlock)) a
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state UniqueGen -> (Unique, UniqueGen)
freshUnique
        tell $ HMS.singleton var $ EvalBlock s classes txt Nothing
        case (evalReveal, evalReplace) of
            (Bool
False, Bool
True) -> [Block]
-> StateT UniqueGen (Writer (HashMap Var EvalBlock)) [Block]
forall a. a -> StateT UniqueGen (Writer (HashMap Var EvalBlock)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Var -> Block
VarBlock Var
var]
            (Bool
False, Bool
False) -> [Block]
-> StateT UniqueGen (Writer (HashMap Var EvalBlock)) [Block]
forall a. a -> StateT UniqueGen (Writer (HashMap Var EvalBlock)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Block
orig, Var -> Block
VarBlock Var
var]
            (Bool
True, Bool
True) -> do
                revealID <- Unique -> RevealID
RevealID (Unique -> RevealID)
-> StateT UniqueGen (Writer (HashMap Var EvalBlock)) Unique
-> StateT UniqueGen (Writer (HashMap Var EvalBlock)) RevealID
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (UniqueGen -> (Unique, UniqueGen))
-> StateT UniqueGen (Writer (HashMap Var EvalBlock)) Unique
forall a.
(UniqueGen -> (a, UniqueGen))
-> StateT UniqueGen (Writer (HashMap Var EvalBlock)) a
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state UniqueGen -> (Unique, UniqueGen)
freshUnique
                pure $ pure $ Reveal ConcatWrapper $ RevealSequence
                    revealID
                    [revealID]
                    [ (S.singleton 0, [orig])
                    , (S.singleton 1, [VarBlock var])
                    ]
            (Bool
True, Bool
False) -> do
                revealID <- Unique -> RevealID
RevealID (Unique -> RevealID)
-> StateT UniqueGen (Writer (HashMap Var EvalBlock)) Unique
-> StateT UniqueGen (Writer (HashMap Var EvalBlock)) RevealID
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (UniqueGen -> (Unique, UniqueGen))
-> StateT UniqueGen (Writer (HashMap Var EvalBlock)) Unique
forall a.
(UniqueGen -> (a, UniqueGen))
-> StateT UniqueGen (Writer (HashMap Var EvalBlock)) a
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state UniqueGen -> (Unique, UniqueGen)
freshUnique
                pure $ pure $ Reveal ConcatWrapper $ RevealSequence
                    revealID
                    [revealID]
                    [ (S.fromList [0, 1], [orig])
                    , (S.fromList [1], [VarBlock var])
                    ]
    | EvalSettings
_ : EvalSettings
_ : [EvalSettings]
_ <- [CI Text] -> EvalSettingsMap -> [EvalSettings]
lookupSettings [CI 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
"," ((CI Text -> Text) -> [CI Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map CI Text -> Text
forall s. CI s -> s
CI.original [CI Text]
classes) in
        [Block]
-> StateT UniqueGen (Writer (HashMap Var EvalBlock)) [Block]
forall a. a -> StateT UniqueGen (Writer (HashMap Var EvalBlock)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [[CI Text] -> Text -> Block
CodeBlock [CI Text]
classes Text
msg]
evalBlock EvalSettingsMap
_ Block
block =
    [Block]
-> StateT UniqueGen (Writer (HashMap Var EvalBlock)) [Block]
forall a. a -> StateT UniqueGen (Writer (HashMap Var EvalBlock)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Block
block]


--------------------------------------------------------------------------------
newAccum :: Monoid m => (m -> IO ()) -> IO (m -> IO ())
newAccum :: forall m. Monoid m => (m -> IO ()) -> IO (m -> IO ())
newAccum m -> IO ()
f = do
    ref <- m -> IO (IORef m)
forall a. a -> IO (IORef a)
IORef.newIORef m
forall a. Monoid a => a
mempty
    pure $ \m
x ->
        IORef m -> (m -> (m, m)) -> IO m
forall a b. IORef a -> (a -> (a, b)) -> IO b
IORef.atomicModifyIORef' IORef m
ref (\m
y -> let z :: m
z = m
y m -> m -> m
forall a. Semigroup a => a -> a -> a
<> m
x in (m
z, m
z)) IO m -> (m -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= m -> IO ()
f


--------------------------------------------------------------------------------
evalVar :: Var -> ([Block] -> IO ()) -> Presentation -> IO Presentation
evalVar :: Var -> ([Block] -> IO ()) -> Presentation -> IO Presentation
evalVar Var
var [Block] -> IO ()
writeOutput Presentation
presentation = case Var -> HashMap Var EvalBlock -> Maybe EvalBlock
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HMS.lookup Var
var HashMap Var EvalBlock
evalBlocks of
    Maybe EvalBlock
Nothing -> Presentation -> IO Presentation
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Presentation
presentation
    Just EvalBlock {[CI Text]
Maybe (Async ())
Text
EvalSettings
ebSettings :: EvalSettings
ebClasses :: [CI Text]
ebInput :: Text
ebAsync :: Maybe (Async ())
ebAsync :: EvalBlock -> Maybe (Async ())
ebInput :: EvalBlock -> Text
ebClasses :: EvalBlock -> [CI Text]
ebSettings :: EvalBlock -> EvalSettings
..} | Just Async ()
_ <- Maybe (Async ())
ebAsync -> Presentation -> IO Presentation
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Presentation
presentation
    Just eb :: EvalBlock
eb@EvalBlock {[CI Text]
Maybe (Async ())
Text
EvalSettings
ebAsync :: EvalBlock -> Maybe (Async ())
ebInput :: EvalBlock -> Text
ebClasses :: EvalBlock -> [CI Text]
ebSettings :: EvalBlock -> EvalSettings
ebSettings :: EvalSettings
ebClasses :: [CI Text]
ebInput :: Text
ebAsync :: Maybe (Async ())
..} -> do
        let EvalSettings {Bool
Maybe (CI Text)
Text
EvalSettingsContainer
evalSyntax :: EvalSettings -> Maybe (CI Text)
evalStderr :: EvalSettings -> Bool
evalContainer :: EvalSettings -> EvalSettingsContainer
evalReveal :: EvalSettings -> Bool
evalReplace :: EvalSettings -> Bool
evalCommand :: EvalSettings -> Text
evalCommand :: Text
evalReplace :: Bool
evalReveal :: Bool
evalContainer :: EvalSettingsContainer
evalStderr :: Bool
evalSyntax :: Maybe (CI Text)
..} = EvalSettings
ebSettings

        writeChunk <- (Text -> IO ()) -> IO (Text -> IO ())
forall m. Monoid m => (m -> IO ()) -> IO (m -> IO ())
newAccum ([Block] -> IO ()
writeOutput ([Block] -> IO ()) -> (Text -> [Block]) -> Text -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EvalBlock -> Text -> [Block]
renderEvalBlock EvalBlock
eb)
        let drainLines Bool
copy Handle
h = do
                c <- IO Text -> (IOException -> IO Text) -> IO Text
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (Handle -> IO Text
T.hGetChunk Handle
h) ((\IOException
_ -> Text -> IO Text
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"") :: IOException -> IO T.Text)
                when (c /= "") $ do
                    when copy $ writeChunk c
                    drainLines copy h

        let 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 hIn, Just hOut, Just hErr, hProc) <- Process.createProcess proc
        async <- Async.async $
            Async.withAsync (T.hPutStr hIn ebInput `finally` IO.hClose hIn) $ \Async ()
_ ->
            IO () -> (Async () -> IO ()) -> IO ()
forall a b. IO a -> (Async a -> IO b) -> IO b
Async.withAsync (Bool -> Handle -> IO ()
drainLines Bool
True Handle
hOut) ((Async () -> IO ()) -> IO ()) -> (Async () -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Async ()
outAsync ->
            IO () -> (Async () -> IO ()) -> IO ()
forall a b. IO a -> (Async a -> IO b) -> IO b
Async.withAsync (Bool -> Handle -> IO ()
drainLines Bool
evalStderr Handle
hErr) ((Async () -> IO ()) -> IO ()) -> (Async () -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Async ()
errAsync ->
            IO ExitCode -> (Async ExitCode -> IO ()) -> IO ()
forall a b. IO a -> (Async a -> IO b) -> IO b
Async.withAsync (ProcessHandle -> IO ExitCode
Process.waitForProcess ProcessHandle
hProc) ((Async ExitCode -> IO ()) -> IO ())
-> (Async ExitCode -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Async ExitCode
exitCodeAsync -> do
            erExitCode <- Async ExitCode -> IO ExitCode
forall a. Async a -> IO a
Async.wait Async ExitCode
exitCodeAsync
            _ <- Async.wait outAsync
            _ <- Async.wait errAsync
            case erExitCode of
                ExitCode
ExitSuccess -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                ExitFailure Int
i -> Text -> IO ()
writeChunk (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$
                    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"
        pure presentation
            { pEvalBlocks = HMS.insert var eb {ebAsync = Just async} evalBlocks
            }
  where
    evalBlocks :: HashMap Var EvalBlock
evalBlocks = Presentation -> HashMap Var EvalBlock
pEvalBlocks Presentation
presentation



--------------------------------------------------------------------------------
evalActiveVars
    :: (Var -> [Block] -> IO ()) -> Presentation -> IO Presentation
evalActiveVars :: (Var -> [Block] -> IO ()) -> Presentation -> IO Presentation
evalActiveVars Var -> [Block] -> IO ()
update Presentation
presentation = (Presentation -> Var -> IO Presentation)
-> Presentation -> HashSet Var -> IO Presentation
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM
    (\Presentation
p Var
var -> Var -> ([Block] -> IO ()) -> Presentation -> IO Presentation
evalVar Var
var (Var -> [Block] -> IO ()
update Var
var) Presentation
p)
    Presentation
presentation
    (Presentation -> HashSet Var
activeVars Presentation
presentation)


--------------------------------------------------------------------------------
evalAllVars :: Presentation -> IO Presentation
evalAllVars :: Presentation -> IO Presentation
evalAllVars Presentation
pres = do
    updates <- [[Block]] -> IO (IORef [[Block]])
forall a. a -> IO (IORef a)
IORef.newIORef []

    let forceEvalVar Presentation
pres0 Var
var = do
            pres1 <- Var -> ([Block] -> IO ()) -> Presentation -> IO Presentation
evalVar
                Var
var
                (\[Block]
u -> IORef [[Block]] -> ([[Block]] -> ([[Block]], ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
IORef.atomicModifyIORef' IORef [[Block]]
updates (\[[Block]]
l -> ([[Block]]
l [[Block]] -> [[Block]] -> [[Block]]
forall a. [a] -> [a] -> [a]
++ [[Block]
u], ())))
                Presentation
pres0
            case HMS.lookup var (pEvalBlocks pres1) of
                Maybe EvalBlock
Nothing -> Presentation -> IO Presentation
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Presentation
pres1
                Just EvalBlock
eb -> do
                    Maybe (Async ()) -> (Async () -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (EvalBlock -> Maybe (Async ())
ebAsync EvalBlock
eb) Async () -> IO ()
forall a. Async a -> IO a
Async.wait
                    IORef [[Block]]
-> ([[Block]] -> ([[Block]], Presentation)) -> IO Presentation
forall a b. IORef a -> (a -> (a, b)) -> IO b
IORef.atomicModifyIORef' IORef [[Block]]
updates (([[Block]] -> ([[Block]], Presentation)) -> IO Presentation)
-> ([[Block]] -> ([[Block]], Presentation)) -> IO Presentation
forall a b. (a -> b) -> a -> b
$ \[[Block]]
l ->
                        ([], (Presentation -> [Block] -> Presentation)
-> Presentation -> [[Block]] -> Presentation
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Presentation
p [Block]
u -> Var -> [Block] -> Presentation -> Presentation
updateVar Var
var [Block]
u Presentation
p) Presentation
pres1 [[Block]]
l)

    foldM forceEvalVar pres (HMS.keys (pEvalBlocks pres))