diff --git a/lib/Patat/Eval.hs b/lib/Patat/Eval.hs index b5cadc8..65f7040 100644 --- a/lib/Patat/Eval.hs +++ b/lib/Patat/Eval.hs @@ -4,8 +4,8 @@ module Patat.Eval ( parseEvalBlocks - , UpdateEvalBlock - , updateEvalBlock + , UpdateVar + , updateVar , evalVar , evalVars , forceEval @@ -91,7 +91,7 @@ evalBlock evalBlock settings orig@(Pandoc.CodeBlock attr@(_, classes, _) txt) | [s@EvalSettings {..}] <- lookupSettings classes settings = do var <- state freshVar - tell $ HMS.singleton var $ EvalBlock s attr txt Nothing mempty + tell $ HMS.singleton var $ EvalBlock s attr txt Nothing pure $ case (evalFragment, evalReplace) of (False, True) -> [AppendVar var] (False, False) -> [Append [orig], AppendVar var] @@ -110,29 +110,39 @@ evalBlock _ block = -------------------------------------------------------------------------------- -data UpdateEvalBlock = UpdateEvalBlock Int Var T.Text +data UpdateVar = UpdateVar Int Var [Pandoc.Block] deriving (Eq, Show) -------------------------------------------------------------------------------- -updateEvalBlock :: UpdateEvalBlock -> Presentation -> Presentation -updateEvalBlock (UpdateEvalBlock version var out) pres +updateVar ::UpdateVar -> Presentation -> Presentation +updateVar (UpdateVar version var out) pres | version /= pVersion pres = pres - | otherwise = pres - { pEvalBlocks = HMS.adjust adjust var $ pEvalBlocks pres - } - where - addLine x = if T.null x then out else x <> "\n" <> out - adjust b = b {ebOutput = addLine (ebOutput b)} + | otherwise = pres {pVars = HMS.insert var out $ pVars pres} -------------------------------------------------------------------------------- -evalVar :: Var -> (UpdateEvalBlock -> IO ()) -> Presentation -> IO Presentation +evalVar :: Var -> (UpdateVar -> IO ()) -> Presentation -> IO Presentation evalVar var writeOutput presentation = case HMS.lookup var evalBlocks of Nothing -> pure presentation Just EvalBlock {..} | Just _ <- ebAsync -> pure presentation Just eb@EvalBlock {..} -> do let EvalSettings {..} = ebSettings + + outRef <- IORef.newIORef "" + let writeLine l = do + t <- IORef.atomicModifyIORef' outRef $ \o -> + let n = if T.null o then l else o <> "\n" <> l in + (n, n) + writeOutput $ UpdateVar (pVersion presentation) var + (renderEvalBlock eb t) + + let copyLines h = catch + (forever $ do + l <- T.hGetLine h + writeLine l) + ((\_ -> pure ()) :: IOException -> IO ()) + let proc = (Process.shell $ T.unpack evalCommand) { Process.std_in = Process.CreatePipe , Process.std_out = Process.CreatePipe @@ -141,15 +151,15 @@ evalVar var writeOutput presentation = case HMS.lookup var evalBlocks of (Just hIn, Just hOut, Just hErr, hProc) <- Process.createProcess proc async <- Async.async $ Async.withAsync (T.hPutStr hIn ebInput `finally` IO.hClose hIn) $ \_ -> - Async.withAsync (getLines hOut) $ \outAsync -> - Async.withAsync (getLines hErr) $ \errAsync -> + Async.withAsync (copyLines hOut) $ \outAsync -> + Async.withAsync (copyLines hErr) $ \errAsync -> Async.withAsync (Process.waitForProcess hProc) $ \exitCodeAsync -> do erExitCode <- Async.wait exitCodeAsync _ <- Async.wait outAsync _ <- Async.wait errAsync case erExitCode of ExitSuccess -> pure () - ExitFailure i -> writeOutput $ mkUpdateEvalBlock $ + ExitFailure i -> writeLine $ evalCommand <> ": exit code " <> T.pack (show i) pure presentation { pEvalBlocks = HMS.insert var eb {ebAsync = Just async} evalBlocks @@ -157,19 +167,12 @@ evalVar var writeOutput presentation = case HMS.lookup var evalBlocks of where evalBlocks = pEvalBlocks presentation - mkUpdateEvalBlock = UpdateEvalBlock (pVersion presentation) var - - getLines h = catch - (forever $ do - l <- T.hGetLine h - writeOutput $ mkUpdateEvalBlock l) - ((\_ -> pure ()) :: IOException -> IO ()) -------------------------------------------------------------------------------- evalVars :: Foldable f - => f Var -> (UpdateEvalBlock -> IO ()) -> Presentation -> IO Presentation + => f Var -> (UpdateVar -> IO ()) -> Presentation -> IO Presentation evalVars vars update presentation = foldM (\p var -> evalVar var update p) presentation vars @@ -189,6 +192,6 @@ forceEval pres = do Just eb -> do for_ (ebAsync eb) Async.wait IORef.atomicModifyIORef' updates $ \l -> - ([], foldl' (\p u -> updateEvalBlock u p) pres1 l) + ([], foldl' (\p u -> updateVar u p) pres1 l) foldM forceEvalVar pres (HMS.keys (pEvalBlocks pres)) diff --git a/lib/Patat/Eval/Internal.hs b/lib/Patat/Eval/Internal.hs index 926e163..429376d 100644 --- a/lib/Patat/Eval/Internal.hs +++ b/lib/Patat/Eval/Internal.hs @@ -3,7 +3,7 @@ module Patat.Eval.Internal ( EvalBlocks , EvalBlock (..) - , evalBlockToBlocks + , renderEvalBlock ) where @@ -27,15 +27,14 @@ data EvalBlock = EvalBlock , ebAttr :: !Pandoc.Attr , ebInput :: !T.Text , ebAsync :: !(Maybe (Async.Async ())) - , ebOutput :: !T.Text } -------------------------------------------------------------------------------- -evalBlockToBlocks :: EvalBlock -> [Pandoc.Block] -evalBlockToBlocks EvalBlock {..} = case evalContainer ebSettings of - EvalContainerCode -> [Pandoc.CodeBlock ebAttr ebOutput] - EvalContainerNone -> [Pandoc.RawBlock fmt ebOutput] - EvalContainerInline -> [Pandoc.Plain [Pandoc.RawInline fmt ebOutput]] +renderEvalBlock :: EvalBlock -> T.Text -> [Pandoc.Block] +renderEvalBlock EvalBlock {..} out = case evalContainer ebSettings of + EvalContainerCode -> [Pandoc.CodeBlock ebAttr out] + EvalContainerNone -> [Pandoc.RawBlock fmt out] + EvalContainerInline -> [Pandoc.Plain [Pandoc.RawInline fmt out]] where fmt = "eval" diff --git a/lib/Patat/Main.hs b/lib/Patat/Main.hs index b7bd9e1..4a3e557 100644 --- a/lib/Patat/Main.hs +++ b/lib/Patat/Main.hs @@ -213,7 +213,7 @@ loop app@App {..} = do -- Start necessary eval blocks presentation <- Eval.evalVars (activeVars aPresentation) - (Chan.writeChan aCommandChan . PresentationCommand . UpdateEvalBlock) + (Chan.writeChan aCommandChan . PresentationCommand . UpdateVar) aPresentation size <- getPresentationSize presentation diff --git a/lib/Patat/Presentation/Interactive.hs b/lib/Patat/Presentation/Interactive.hs index fb5e443..a13e7b9 100644 --- a/lib/Patat/Presentation/Interactive.hs +++ b/lib/Patat/Presentation/Interactive.hs @@ -32,7 +32,7 @@ data PresentationCommand | Last | Reload | Seek Int - | UpdateEvalBlock Eval.UpdateEvalBlock + | UpdateVar Eval.UpdateVar | UnknownCommand String deriving (Eq, Show) @@ -98,17 +98,17 @@ updatePresentation :: PresentationCommand -> Presentation -> IO UpdatedPresentation updatePresentation cmd presentation = case cmd of - Exit -> pure ExitedPresentation - Forward -> pure $ goToSlide $ \(s, f) -> (s, f + 1) - Backward -> pure $ goToSlide $ \(s, f) -> (s, f - 1) - SkipForward -> pure $ goToSlide $ \(s, _) -> (s + 10, 0) - SkipBackward -> pure $ goToSlide $ \(s, _) -> (s - 10, 0) - First -> pure $ goToSlide $ \_ -> (0, 0) - Last -> pure $ goToSlide $ \_ -> (numSlides presentation, 0) - Seek n -> pure $ goToSlide $ \_ -> (n - 1, 0) - Reload -> reloadPresentation - UpdateEvalBlock u -> pure $ UpdatedPresentation $ Eval.updateEvalBlock u presentation - UnknownCommand _ -> pure $ UpdatedPresentation presentation + Exit -> pure ExitedPresentation + Forward -> pure $ goToSlide $ \(s, f) -> (s, f + 1) + Backward -> pure $ goToSlide $ \(s, f) -> (s, f - 1) + SkipForward -> pure $ goToSlide $ \(s, _) -> (s + 10, 0) + SkipBackward -> pure $ goToSlide $ \(s, _) -> (s - 10, 0) + First -> pure $ goToSlide $ \_ -> (0, 0) + Last -> pure $ goToSlide $ \_ -> (numSlides presentation, 0) + Seek n -> pure $ goToSlide $ \_ -> (n - 1, 0) + Reload -> reloadPresentation + UpdateVar u -> pure $ UpdatedPresentation $ Eval.updateVar u presentation + UnknownCommand _ -> pure $ UpdatedPresentation presentation where numSlides :: Presentation -> Int numSlides pres = length (pSlides pres) diff --git a/lib/Patat/Presentation/Internal.hs b/lib/Patat/Presentation/Internal.hs index b249b0c..636bbf5 100644 --- a/lib/Patat/Presentation/Internal.hs +++ b/lib/Patat/Presentation/Internal.hs @@ -79,8 +79,7 @@ data Presentation = Presentation , pActiveFragment :: !Index , pSyntaxMap :: !Skylighting.SyntaxMap , pEvalBlocks :: !Eval.EvalBlocks - -- TODO: these can be a bit more generic than just eval. - -- , pVars :: !(HMS.HashMap Instruction.Var [Pandoc.Block]) + , pVars :: !(HMS.HashMap Instruction.Var [Pandoc.Block]) } @@ -155,9 +154,7 @@ activeFragment presentation = do Instruction.renderFragment resolve $ Instruction.beforePause fidx instrs where - resolve var = case HMS.lookup var (pEvalBlocks presentation) of - Nothing -> [] - Just eb -> Eval.evalBlockToBlocks eb + resolve var = fromMaybe [] $ HMS.lookup var (pVars presentation) -------------------------------------------------------------------------------- diff --git a/lib/Patat/Presentation/Read.hs b/lib/Patat/Presentation/Read.hs index 1b2afdb..d7d83fe 100644 --- a/lib/Patat/Presentation/Read.hs +++ b/lib/Patat/Presentation/Read.hs @@ -135,6 +135,7 @@ pandocToPresentation pFilePath pEncodingFallback pSettings pSyntaxMap !pActiveFragment = (0, 0) !pAuthor = concat (Pandoc.docAuthors meta) !pEvalBlocks = mempty + !pVars = mempty pSlideSettings <- Seq.traverseWithIndex (\i -> first (\err -> "on slide " ++ show (i + 1) ++ ": " ++ err) .