Allow evaluating code blocks

README.md

@@ -21,6 +21,7 @@ Features:
 - Syntax highlighting for nearly one hundred languages generated from [Kate]
   syntax files.
 - Experimental [images](#images) support.
+- Supports [evaluating code snippets and showing the result](#evaluating-code).
 - Written in [Haskell].
 
 ![screenshot](extra/screenshot.png?raw=true)
@@ -50,6 +51,7 @@ Table of Contents
     -   [Pandoc Extensions](#pandoc-extensions)
     -   [Images](#images)
     -   [Breadcrumbs](#breadcrumbs)
+    -   [Evaluating code](#evaluating-code)
 -   [Trivia](#trivia)
 
 Installation
@@ -589,6 +591,63 @@ patat:
   breadcrumbs: false
 ```
 
+### Evaluating code
+
+`patat` can evaluate code blocks and show the result.  You can register an
+_evaluator_ by specifying this in the YAML metadata:
+
+    ---
+    patat:
+      eval:
+        ruby:
+          command: irb --noecho --noverbose
+          fragment: true  # Optional
+          replace: false  # Optional
+    ...
+
+    Here is an example of a code block that is evaluated:
+
+    ```ruby
+    puts "Hi"
+    ```
+
+An arbitrary amount of evaluators can be specified, and whenever a a class
+attribute on a code block matches the evaluator, it will be used.
+
+**Note that executing arbitrary code is always dangerous**, so double check the
+code of presentations downloaded from the internet before running them if they
+contain `eval` settings.
+
+Aside from the command, there are two more options:
+
+ -  `fragment`: Introduce a pause (see [fragments](#fragmented-slides)) in
+    between showing the original code block and the output.  Defaults to `true`.
+ -  `replace`: Remove the original code block and replace it with the output
+    rather than appending the output in a new code block.  Defaults to `false`.
+
+Setting `fragment: false` and `replace: true` offers a way to "filter" code
+blocks, which can be used to render ASCII graphics.
+
+    ---
+    patat:
+      eval:
+        figlet:
+          command: figlet
+          fragment: false
+          replace: true
+    ...
+
+    ```figlet
+    Fancy Font
+    ```
+
+This feature works by simply by:
+
+1.  Spawn a process with the provided command
+2.  Write the contents of the code block to the `stdin` of the process
+3.  Wait for the process to exit
+4.  Render the `stdout` of the process
+
 Trivia
 ------
 

lib/Patat/Eval.hs

@@ -0,0 +1,116 @@
+--------------------------------------------------------------------------------
+{-# 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 = case psEval (pSettings presentation) of
+    Nothing -> pure presentation
+    Just settings -> do
+        slides <- traverse (evalSlide settings) (pSlides presentation)
+        pure presentation {pSlides = slides}
+
+
+--------------------------------------------------------------------------------
+lookupSettings :: [T.Text] -> EvalSettingsMap -> [EvalSettings]
+lookupSettings classes settings = do
+    c <- classes
+    maybeToList $ HMS.lookup c settings
+
+
+--------------------------------------------------------------------------------
+evalSlide :: EvalSettingsMap -> Slide -> IO Slide
+evalSlide settings slide = case slide of
+    TitleSlide _ _ -> pure slide
+    ContentSlide instrs -> ContentSlide . fromList . concat <$>
+        traverse (evalInstruction settings) (toList instrs)
+
+
+--------------------------------------------------------------------------------
+evalInstruction
+    :: EvalSettingsMap -> Instruction Pandoc.Block
+    -> IO [Instruction Pandoc.Block]
+evalInstruction settings instr = case instr of
+    Pause         -> pure [Pause]
+    ModifyLast i  -> map ModifyLast <$> evalInstruction settings i
+    Append []     -> pure [Append []]
+    Append blocks -> concat <$> traverse (evalBlock settings) blocks
+    Delete        -> pure [Delete]
+
+
+--------------------------------------------------------------------------------
+evalBlock :: EvalSettingsMap -> Pandoc.Block -> IO [Instruction Pandoc.Block]
+evalBlock settings orig@(Pandoc.CodeBlock attr@(_, classes, _) txt)
+    | [s@EvalSettings {..}] <- lookupSettings classes settings =
+        unsafeInterleaveIO $ do
+        EvalResult {..} <- evalCode s txt
+        let out = case erExitCode of
+                ExitSuccess -> erStdout
+                ExitFailure i ->
+                    evalCommand <> ": exit code " <> T.pack (show i) <> "\n" <>
+                    erStderr
+        pure $ case (evalFragment, evalReplace) of
+            (False, True) -> [Append [Pandoc.CodeBlock attr out]]
+            (False, False) -> [Append [orig, Pandoc.CodeBlock attr out]]
+            (True, True) ->
+                [ Append [orig], Pause
+                , Delete, Append [Pandoc.CodeBlock attr out]
+                ]
+            (True, False) ->
+                [Append [orig], Pause, Append [Pandoc.CodeBlock attr out]]
+    | _ : _ : _ <- lookupSettings classes settings =
+        let msg = "patat eval matched multiple settings for " <>
+                T.intercalate "," classes in
+        pure [Append [Pandoc.CodeBlock attr msg]]
+evalBlock _ block =
+    pure [Append [block]]
+
+
+--------------------------------------------------------------------------------
+data EvalResult = EvalResult
+    { erExitCode :: !ExitCode
+    , erStdout   :: !T.Text
+    , erStderr   :: !T.Text
+    } deriving (Show)
+
+
+--------------------------------------------------------------------------------
+evalCode :: EvalSettings -> T.Text -> IO EvalResult
+evalCode EvalSettings {..} input = do
+    let proc = (Process.shell $ T.unpack 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.withAsync (T.hPutStr hIn input `finally` IO.hClose hIn) $ \_ ->
+        Async.withAsync (T.hGetContents hOut) $ \outAsync ->
+        Async.withAsync (T.hGetContents hErr) $ \errAsync ->
+        Async.withAsync (Process.waitForProcess hProc) $ \exitCodeAsync -> do
+
+        erExitCode <- Async.wait exitCodeAsync
+        erStdout <- Async.wait outAsync
+        erStderr <- Async.wait errAsync
+        pure $ EvalResult {..}

lib/Patat/Presentation/Fragment.hs

@@ -28,7 +28,9 @@ fragmentInstructions
 fragmentInstructions fs = fromList . concatMap fragmentInstruction . toList
   where
     fragmentInstruction Pause = [Pause]
+    fragmentInstruction (Append []) = [Append []]
     fragmentInstruction (Append xs) = fragmentBlocks fs xs
+    fragmentInstruction Delete = [Delete]
     fragmentInstruction (ModifyLast f) = map ModifyLast $ fragmentInstruction f
 
 fragmentBlocks

lib/Patat/Presentation/Instruction.hs

@@ -41,13 +41,16 @@ data Instruction a
     = Pause
     -- Append items.
     | Append [a]
+    -- Remove the last item.
+    | Delete
     -- Modify the last block with the provided instruction.
     | ModifyLast (Instruction a)
     deriving (Show)
 
 isPause :: Instruction a -> Bool
 isPause Pause = True
 isPause (Append _) = False
+isPause Delete = False
 isPause (ModifyLast i) = isPause i
 
 numPauses :: Instructions a -> Int
@@ -68,6 +71,7 @@ renderFragment = \n (Instructions instrs) -> Fragment $ go [] n instrs
 goBlocks :: Instruction Pandoc.Block -> [Pandoc.Block] -> [Pandoc.Block]
 goBlocks Pause xs = xs
 goBlocks (Append ys) xs = xs ++ ys
+goBlocks Delete xs = sinit xs
 goBlocks (ModifyLast f) xs
     | null xs   = xs  -- Shouldn't happen unless instructions are malformed.
     | otherwise = modifyLast (goBlock f) xs
@@ -79,6 +83,11 @@ goBlock (Append ys) block = case block of
     Pandoc.BulletList xs -> Pandoc.BulletList $ xs ++ [ys]
     Pandoc.OrderedList attr xs -> Pandoc.OrderedList attr $ xs ++ [ys]
     _ -> block
+goBlock Delete block = case block of
+    -- We can only append to a few specific block types for now.
+    Pandoc.BulletList xs -> Pandoc.BulletList $ sinit xs
+    Pandoc.OrderedList attr xs -> Pandoc.OrderedList attr $ sinit xs
+    _ -> block
 goBlock (ModifyLast f) block = case block of
     -- We can only modify the last content of a few specific block types for
     -- now.
@@ -91,3 +100,6 @@ modifyLast :: (a -> a) -> [a] -> [a]
 modifyLast f (x : y : zs) = x : modifyLast f (y : zs)
 modifyLast f (x : [])     = [f x]
 modifyLast _ []           = []
+
+sinit :: [a] -> [a]
+sinit xs = if null xs then [] else init xs

lib/Patat/Presentation/Internal.hs

@@ -16,6 +16,9 @@ module Patat.Presentation.Internal
 
     , ImageSettings (..)
 
+    , EvalSettingsMap
+    , EvalSettings (..)
+
     , Slide (..)
     , Instruction.Fragment (..)
     , Index
@@ -33,6 +36,7 @@ import           Control.Monad                  (mplus)
 import qualified Data.Aeson.Extended            as A
 import qualified Data.Aeson.TH.Extended         as A
 import qualified Data.Foldable                  as Foldable
+import qualified Data.HashMap.Strict            as HMS
 import           Data.List                      (intercalate)
 import           Data.Maybe                     (fromMaybe, listToMaybe)
 import qualified Data.Text                      as T
@@ -74,6 +78,7 @@ data PresentationSettings = PresentationSettings
     , psPandocExtensions :: !(Maybe ExtensionList)
     , psImages           :: !(Maybe ImageSettings)
     , psBreadcrumbs      :: !(Maybe Bool)
+    , psEval             :: !(Maybe EvalSettingsMap)
     } deriving (Show)
 
 
@@ -91,6 +96,7 @@ instance Semigroup PresentationSettings where
         , psPandocExtensions = psPandocExtensions l `mplus` psPandocExtensions r
         , psImages           = psImages           l `mplus` psImages           r
         , psBreadcrumbs      = psBreadcrumbs      l `mplus` psBreadcrumbs      r
+        , psEval             = psEval             l <>      psEval             r
         }
 
 
@@ -99,7 +105,7 @@ instance Monoid PresentationSettings where
     mappend = (<>)
     mempty  = PresentationSettings
                     Nothing Nothing Nothing Nothing Nothing Nothing Nothing
-                    Nothing Nothing Nothing Nothing
+                    Nothing Nothing Nothing Nothing Nothing
 
 
 --------------------------------------------------------------------------------
@@ -116,6 +122,7 @@ defaultPresentationSettings = PresentationSettings
     , psPandocExtensions = Nothing
     , psImages           = Nothing
     , psBreadcrumbs      = Nothing
+    , psEval             = Nothing
     }
 
 
@@ -225,6 +232,26 @@ instance A.FromJSON ImageSettings where
         return ImageSettings {isBackend = t, isParams = o}
 
 
+--------------------------------------------------------------------------------
+type EvalSettingsMap = HMS.HashMap T.Text EvalSettings
+
+
+--------------------------------------------------------------------------------
+data EvalSettings = EvalSettings
+    { evalCommand  :: !T.Text
+    , evalReplace  :: !Bool
+    , evalFragment :: !Bool
+    } deriving (Show)
+
+
+--------------------------------------------------------------------------------
+instance A.FromJSON EvalSettings where
+    parseJSON = A.withObject "FromJSON EvalSettings" $ \o -> EvalSettings
+        <$> o A..: "command"
+        <*> o A..:? "replace" A..!= False
+        <*> o A..:? "fragment" A..!= True
+
+
 --------------------------------------------------------------------------------
 data Slide
     = ContentSlide (Instruction.Instructions Pandoc.Block)

lib/Patat/Presentation/Read.hs

@@ -23,6 +23,7 @@ import qualified Data.Text                      as T
 import qualified Data.Text.Encoding             as T
 import qualified Data.Text.IO                   as T
 import qualified Data.Yaml                      as Yaml
+import           Patat.Eval                     (eval)
 import           Patat.Presentation.Fragment
 import qualified Patat.Presentation.Instruction as Instruction
 import           Patat.Presentation.Internal
@@ -48,11 +49,12 @@ readPresentation filePath = runExceptT $ do
     reader <- case readExtension pexts ext of
         Nothing -> throwError $ "Unknown file extension: " ++ show ext
         Just x  -> return x
-    doc    <- case reader src of
+    doc <- case reader src of
         Left  e -> throwError $ "Could not parse document: " ++ show e
         Right x -> return x
 
-    ExceptT $ return $ pandocToPresentation filePath settings doc
+    pres <- ExceptT $ pure $ pandocToPresentation filePath settings doc
+    liftIO $ eval pres
   where
     ext = takeExtension filePath
 

patat.cabal

@@ -34,6 +34,7 @@ Library
     aeson                >= 0.9  && < 1.5,
     ansi-terminal        >= 0.6  && < 0.11,
     ansi-wl-pprint       >= 0.6  && < 0.7,
+    async                >= 2.2  && < 2.3,
     base                 >= 4.9  && < 5,
     base64-bytestring    >= 1.0  && < 1.1,
     bytestring           >= 0.10 && < 0.11,
@@ -44,6 +45,7 @@ Library
     mtl                  >= 2.2  && < 2.3,
     optparse-applicative >= 0.12 && < 0.16,
     pandoc               >= 2.9  && < 2.10,
+    pandoc-types         >= 1.20 && < 1.21,
     process              >= 1.6  && < 1.7,
     skylighting          >= 0.1  && < 0.9,
     terminal-size        >= 0.3  && < 0.4,
@@ -63,6 +65,7 @@ Library
   Exposed-modules:
     Patat.AutoAdvance
     Patat.Cleanup
+    Patat.Eval
     Patat.Images
     Patat.Images.Internal
     Patat.Images.W3m

tests/golden/inputs/eval01.md

@@ -0,0 +1,22 @@
+---
+patat:
+  eval:
+    eval:
+      command: bash
+      replace: true
+      fragment: true
+...
+
+# Slide 1
+
+ -  This is some code that is not evaluated:
+
+    ```bash
+    echo foo
+    ```
+
+ -  And here is some code that is evaluated:
+
+    ```eval
+    echo foo
+    ```