summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJasperVanDerJeugt <>2020-09-11 17:23:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2020-09-11 17:23:00 (GMT)
commitbd610864ffd4c5bde551c47b74409b4817f5aa70 (patch)
tree98a48bf7b9660141bf7c78c38f2882767c23cd4f
parent41cf25e2c53dbb58b7d44939f65057f71247c483 (diff)
version 0.8.6.00.8.6.0
-rw-r--r--CHANGELOG.md6
-rw-r--r--README.md75
-rw-r--r--lib/Patat/Eval.hs116
-rw-r--r--lib/Patat/Presentation/Display.hs42
-rw-r--r--lib/Patat/Presentation/Fragment.hs134
-rw-r--r--lib/Patat/Presentation/Instruction.hs105
-rw-r--r--lib/Patat/Presentation/Internal.hs87
-rw-r--r--lib/Patat/Presentation/Read.hs101
-rw-r--r--lib/Patat/PrettyPrint.hs8
-rw-r--r--patat.cabal20
-rw-r--r--tests/haskell/Main.hs2
-rw-r--r--tests/haskell/Patat/Presentation/Read/Tests.hs33
12 files changed, 554 insertions, 175 deletions
diff --git a/CHANGELOG.md b/CHANGELOG.md
index 8479b19..dd8a821 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -1,5 +1,11 @@
# Changelog
+- 0.8.6.0 (2020-09-11)
+ * Allow evaluating code blocks (see README for more info)
+ * Refactor implementation of fragments
+ * Add breadcrumbs to title based on headers
+ * Error out when YAML parsing fails
+
- 0.8.5.0 (2020-06-29)
* Bump `pandoc` dependency to 2.9
* Switch to `goldplate` for testing
diff --git a/README.md b/README.md
index 7fdd15c..b8e36ba 100644
--- a/README.md
+++ b/README.md
@@ -1,7 +1,7 @@
patat
=====
-[![Build Status](https://img.shields.io/circleci/project/github/jaspervdj/patat.svg)](https://circleci.com/gh/jaspervdj/patat) [![Hackage](https://img.shields.io/hackage/v/patat.svg)](https://hackage.haskell.org/package/patat) [![GitHub tag](https://img.shields.io/github/tag/jaspervdj/patat.svg)]()
+![CI](https://github.com/jaspervdj/patat/workflows/CI/badge.svg) [![Hackage](https://img.shields.io/hackage/v/patat.svg)](https://hackage.haskell.org/package/patat) [![GitHub tag](https://img.shields.io/github/tag/jaspervdj/patat.svg)]()
`patat` (**P**resentations **A**top **T**he **A**NSI **T**erminal) is a small
tool that allows you to show presentations using only an ANSI terminal. It does
@@ -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)
@@ -49,6 +50,8 @@ Table of Contents
- [Syntax Highlighting](#syntax-highlighting)
- [Pandoc Extensions](#pandoc-extensions)
- [Images](#images)
+ - [Breadcrumbs](#breadcrumbs)
+ - [Evaluating code](#evaluating-code)
- [Trivia](#trivia)
Installation
@@ -575,6 +578,76 @@ the terminal window.
path: '/home/jasper/.local/bin/w3mimgdisplay'
```
+### Breadcrumbs
+
+By default, `patat` will print a breadcrumbs-style header, e.g.:
+
+ example.md > This is a title > This is a subtitle
+
+This feature can be turned off by using:
+
+```yaml
+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
------
diff --git a/lib/Patat/Eval.hs b/lib/Patat/Eval.hs
new file mode 100644
index 0000000..5b3b539
--- /dev/null
+++ b/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 {..}
diff --git a/lib/Patat/Presentation/Display.hs b/lib/Patat/Presentation/Display.hs
index 456bcd8..da73f97 100644
--- a/lib/Patat/Presentation/Display.hs
+++ b/lib/Patat/Presentation/Display.hs
@@ -15,12 +15,13 @@ import Control.Monad (mplus, unless)
import qualified Data.Aeson.Extended as A
import Data.Data.Extended (grecQ)
import qualified Data.List as L
-import Data.Maybe (fromMaybe)
+import Data.Maybe (fromMaybe, listToMaybe)
import qualified Data.Text as T
import Patat.Cleanup
import qualified Patat.Images as Images
import Patat.Presentation.Display.CodeBlock
import Patat.Presentation.Display.Table
+import qualified Patat.Presentation.Instruction as Instruction
import Patat.Presentation.Internal
import Patat.PrettyPrint ((<$$>), (<+>))
import qualified Patat.PrettyPrint as PP
@@ -55,9 +56,22 @@ displayWithBorders Presentation {..} f = do
(A.unFlexibleNum <$> psRows pSettings) `mplus`
(Terminal.height <$> mbWindow)
- let settings = pSettings {psColumns = Just $ A.FlexibleNum columns}
+ let (sidx, _) = pActiveFragment
+ settings = pSettings {psColumns = Just $ A.FlexibleNum columns}
theme = fromMaybe Theme.defaultTheme (psTheme settings)
- title = PP.toString (prettyInlines theme pTitle)
+
+ let breadcrumbs = fromMaybe [] . listToMaybe $ drop sidx pBreadcrumbs
+ plainTitle = PP.toString $ prettyInlines theme pTitle
+ breadTitle = mappend plainTitle $ mconcat
+ [ s
+ | b <- map (prettyInlines theme . snd) breadcrumbs
+ , s <- [" > ", PP.toString b]
+ ]
+ title
+ | not . fromMaybe True $ psBreadcrumbs settings = plainTitle
+ | length breadTitle > columns = plainTitle
+ | otherwise = breadTitle
+
titleWidth = length title
titleOffset = (columns - titleWidth) `div` 2
borders = themed (themeBorders theme)
@@ -73,8 +87,7 @@ displayWithBorders Presentation {..} f = do
PP.putDoc $ formatWith settings $ f canvasSize theme
putStrLn ""
- let (sidx, _) = pActiveFragment
- active = show (sidx + 1) ++ " / " ++ show (length pSlides)
+ let active = show (sidx + 1) ++ " / " ++ show (length pSlides)
activeWidth = length active
author = PP.toString (prettyInlines theme pAuthor)
authorWidth = length author
@@ -153,10 +166,12 @@ dumpPresentation pres =
PP.vcat $ L.intersperse "----------" $ do
slide <- pSlides pres
return $ case slide of
- TitleSlide block -> "~~~title" <$$> prettyBlock theme block
- ContentSlide fragments -> PP.vcat $ L.intersperse "~~~frag" $ do
- fragment <- fragments
- return $ prettyFragment theme fragment
+ TitleSlide l inlines -> "~~~title" <$$>
+ prettyBlock theme (Pandoc.Header l Pandoc.nullAttr inlines)
+ ContentSlide instrs -> PP.vcat $ L.intersperse "~~~frag" $ do
+ n <- [0 .. Instruction.numFragments instrs - 1]
+ return $ prettyFragment theme $
+ Instruction.renderFragment n instrs
--------------------------------------------------------------------------------
@@ -170,11 +185,12 @@ formatWith ps = wrap . indent
spaces = PP.NotTrimmable $ PP.spaces marginLeft
indent = PP.indent spaces spaces
+
--------------------------------------------------------------------------------
prettyFragment :: Theme -> Fragment -> PP.Doc
-prettyFragment theme fragment@(Fragment blocks) =
+prettyFragment theme (Fragment blocks) =
prettyBlocks theme blocks <>
- case prettyReferences theme fragment of
+ case prettyReferences theme blocks of
[] -> mempty
refs -> PP.hardline <> PP.vcat refs
@@ -343,9 +359,9 @@ prettyInlines theme = mconcat . map (prettyInline theme)
--------------------------------------------------------------------------------
-prettyReferences :: Theme -> Fragment -> [PP.Doc]
+prettyReferences :: Theme -> [Pandoc.Block] -> [PP.Doc]
prettyReferences theme@Theme {..} =
- map prettyReference . getReferences . unFragment
+ map prettyReference . getReferences
where
getReferences :: [Pandoc.Block] -> [Pandoc.Inline]
getReferences = filter isReferenceLink . grecQ
diff --git a/lib/Patat/Presentation/Fragment.hs b/lib/Patat/Presentation/Fragment.hs
index 4688c69..8e7131f 100644
--- a/lib/Patat/Presentation/Fragment.hs
+++ b/lib/Patat/Presentation/Fragment.hs
@@ -7,53 +7,40 @@
{-# LANGUAGE OverloadedStrings #-}
module Patat.Presentation.Fragment
( FragmentSettings (..)
+
+ , fragmentInstructions
, fragmentBlocks
, fragmentBlock
) where
-import Data.List (foldl', intersperse)
-import Data.Maybe (fromMaybe)
+import Data.List (intersperse, intercalate)
+import Patat.Presentation.Instruction
import Prelude
-import qualified Text.Pandoc as Pandoc
+import qualified Text.Pandoc as Pandoc
data FragmentSettings = FragmentSettings
{ fsIncrementalLists :: !Bool
} deriving (Show)
--- fragmentBlocks :: [Pandoc.Block] -> [[Pandoc.Block]]
--- fragmentBlocks = NonEmpty.toList . joinFragmentedBlocks . map fragmentBlock
-fragmentBlocks :: FragmentSettings -> [Pandoc.Block] -> [[Pandoc.Block]]
-fragmentBlocks fs blocks0 =
- case joinFragmentedBlocks (map (fragmentBlock fs) blocks0) of
- Unfragmented bs -> [bs]
- Fragmented xs bs -> map (fromMaybe []) xs ++ [fromMaybe [] bs]
+fragmentInstructions
+ :: FragmentSettings
+ -> Instructions Pandoc.Block -> Instructions Pandoc.Block
+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
--- | This is all the ways we can "present" a block, after splitting in
--- fragments.
---
--- In the simplest (and most common case) a block can only be presented in a
--- single way ('Unfragmented').
---
--- Alternatively, we might want to show different (partial) versions of the
--- block first before showing the final complete one. These partial or complete
--- versions can be empty, hence the 'Maybe'.
---
--- For example, imagine that we display the following bullet list incrementally:
---
--- > [1, 2, 3]
---
--- Then we would get something like:
---
--- > Fragmented [Nothing, Just [1], Just [1, 2]] (Just [1, 2, 3])
-data Fragmented a
- = Unfragmented a
- | Fragmented [Maybe a] (Maybe a)
- deriving (Functor, Foldable, Show, Traversable)
+fragmentBlocks
+ :: FragmentSettings -> [Pandoc.Block] -> [Instruction Pandoc.Block]
+fragmentBlocks = concatMap . fragmentBlock
-fragmentBlock :: FragmentSettings -> Pandoc.Block -> Fragmented Pandoc.Block
+fragmentBlock :: FragmentSettings -> Pandoc.Block -> [Instruction Pandoc.Block]
fragmentBlock _fs block@(Pandoc.Para inlines)
- | inlines == threeDots = Fragmented [Nothing] Nothing
- | otherwise = Unfragmented block
+ | inlines == threeDots = [Pause]
+ | otherwise = [Append [block]]
where
threeDots = intersperse Pandoc.Space $ replicate 3 (Pandoc.Str ".")
@@ -69,65 +56,38 @@ fragmentBlock fs (Pandoc.BlockQuote [Pandoc.BulletList bs0]) =
fragmentBlock fs (Pandoc.BlockQuote [Pandoc.OrderedList attr bs0]) =
fragmentList fs (not $ fsIncrementalLists fs) (Pandoc.OrderedList attr) bs0
-fragmentBlock _ block@(Pandoc.BlockQuote _) = Unfragmented block
-
-fragmentBlock _ block@(Pandoc.Header _ _ _) = Unfragmented block
-fragmentBlock _ block@(Pandoc.Plain _) = Unfragmented block
-fragmentBlock _ block@(Pandoc.CodeBlock _ _) = Unfragmented block
-fragmentBlock _ block@(Pandoc.RawBlock _ _) = Unfragmented block
-fragmentBlock _ block@(Pandoc.DefinitionList _) = Unfragmented block
-fragmentBlock _ block@(Pandoc.Table _ _ _ _ _) = Unfragmented block
-fragmentBlock _ block@(Pandoc.Div _ _) = Unfragmented block
-fragmentBlock _ block@Pandoc.HorizontalRule = Unfragmented block
-fragmentBlock _ block@Pandoc.Null = Unfragmented block
-
-#if MIN_VERSION_pandoc(1,18,0)
-fragmentBlock _ block@(Pandoc.LineBlock _) = Unfragmented block
-#endif
-
-joinFragmentedBlocks :: [Fragmented block] -> Fragmented [block]
-joinFragmentedBlocks =
- foldl' append (Unfragmented [])
- where
- append (Unfragmented xs) (Unfragmented y) =
- Unfragmented (xs ++ [y])
+fragmentBlock _ block@(Pandoc.BlockQuote _) = [Append [block]]
- append (Fragmented xs x) (Unfragmented y) =
- Fragmented xs (appendMaybe x (Just y))
-
- append (Unfragmented x) (Fragmented ys y) =
- Fragmented
- [appendMaybe (Just x) y' | y' <- ys]
- (appendMaybe (Just x) y)
-
- append (Fragmented xs x) (Fragmented ys y) =
- Fragmented
- (xs ++ [appendMaybe x y' | y' <- ys])
- (appendMaybe x y)
-
- appendMaybe :: Maybe [a] -> Maybe a -> Maybe [a]
- appendMaybe Nothing Nothing = Nothing
- appendMaybe Nothing (Just x) = Just [x]
- appendMaybe (Just xs) Nothing = Just xs
- appendMaybe (Just xs) (Just x) = Just (xs ++ [x])
+fragmentBlock _ block@(Pandoc.Header _ _ _) = [Append [block]]
+fragmentBlock _ block@(Pandoc.Plain _) = [Append [block]]
+fragmentBlock _ block@(Pandoc.CodeBlock _ _) = [Append [block]]
+fragmentBlock _ block@(Pandoc.RawBlock _ _) = [Append [block]]
+fragmentBlock _ block@(Pandoc.DefinitionList _) = [Append [block]]
+fragmentBlock _ block@(Pandoc.Table _ _ _ _ _) = [Append [block]]
+fragmentBlock _ block@(Pandoc.Div _ _) = [Append [block]]
+fragmentBlock _ block@Pandoc.HorizontalRule = [Append [block]]
+fragmentBlock _ block@Pandoc.Null = [Append [block]]
+fragmentBlock _ block@(Pandoc.LineBlock _) = [Append [block]]
fragmentList
:: FragmentSettings -- ^ Global settings
-> Bool -- ^ Fragment THIS list?
-> ([[Pandoc.Block]] -> Pandoc.Block) -- ^ List constructor
-> [[Pandoc.Block]] -- ^ List items
- -> Fragmented Pandoc.Block -- ^ Resulting list
-fragmentList fs fragmentThisList constructor blocks0 =
- fmap constructor fragmented
+ -> [Instruction Pandoc.Block] -- ^ Resulting list
+fragmentList fs fragmentThisList constructor items =
+ -- Insert the new list, initially empty.
+ (if fragmentThisList then [Pause] else []) ++
+ [Append [constructor []]] ++
+ (map ModifyLast $
+ (if fragmentThisList then intercalate [Pause] else concat) $
+ map fragmentItem items)
where
-- The fragmented list per list item.
- items :: [Fragmented [Pandoc.Block]]
- items = map (joinFragmentedBlocks . map (fragmentBlock fs)) blocks0
-
- fragmented :: Fragmented [[Pandoc.Block]]
- fragmented = joinFragmentedBlocks $
- map (if fragmentThisList then insertPause else id) items
-
- insertPause :: Fragmented a -> Fragmented a
- insertPause (Unfragmented x) = Fragmented [Nothing] (Just x)
- insertPause (Fragmented xs x) = Fragmented (Nothing : xs) x
+ fragmentItem :: [Pandoc.Block] -> [Instruction Pandoc.Block]
+ fragmentItem item =
+ -- Append a new item to the list so we can start adding
+ -- content there.
+ Append [] :
+ -- Modify this new item to add the content.
+ map ModifyLast (fragmentBlocks fs item)
diff --git a/lib/Patat/Presentation/Instruction.hs b/lib/Patat/Presentation/Instruction.hs
new file mode 100644
index 0000000..3928e85
--- /dev/null
+++ b/lib/Patat/Presentation/Instruction.hs
@@ -0,0 +1,105 @@
+--------------------------------------------------------------------------------
+-- | The Pandoc AST is not extensible, so we need to use another way to model
+-- different parts of slides that we want to appear bit by bit.
+--
+-- We do this by modelling a slide as a list of instructions, that manipulate
+-- the contents on a slide in a (for now) very basic way.
+module Patat.Presentation.Instruction
+ ( Instructions
+ , fromList
+ , toList
+
+ , Instruction (..)
+ , numFragments
+
+ , Fragment (..)
+ , renderFragment
+ ) where
+
+import qualified Text.Pandoc as Pandoc
+
+newtype Instructions a = Instructions [Instruction a] deriving (Show)
+
+-- A smart constructor that guarantees some invariants:
+--
+-- * No consecutive pauses.
+-- * All pauses moved to the top level.
+-- * No pauses at the end.
+fromList :: [Instruction a] -> Instructions a
+fromList = Instructions . go
+ where
+ go instrs = case break (not . isPause) instrs of
+ (_, []) -> []
+ (_ : _, remainder) -> Pause : go remainder
+ ([], x : remainder) -> x : go remainder
+
+toList :: Instructions a -> [Instruction a]
+toList (Instructions xs) = xs
+
+data Instruction a
+ -- Pause.
+ = 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
+numPauses (Instructions xs) = length $ filter isPause xs
+
+numFragments :: Instructions a -> Int
+numFragments = succ . numPauses
+
+newtype Fragment = Fragment [Pandoc.Block] deriving (Show)
+
+renderFragment :: Int -> Instructions Pandoc.Block -> Fragment
+renderFragment = \n (Instructions instrs) -> Fragment $ go [] n instrs
+ where
+ go acc _ [] = acc
+ go acc n (Pause : instrs) = if n <= 0 then acc else go acc (n - 1) instrs
+ go acc n (instr : instrs) = go (goBlocks instr acc) 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
+
+goBlock :: Instruction Pandoc.Block -> Pandoc.Block -> Pandoc.Block
+goBlock Pause x = x
+goBlock (Append ys) block = case block of
+ -- We can only append to a few specific block types for now.
+ 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.
+ Pandoc.BulletList xs -> Pandoc.BulletList $ modifyLast (goBlocks f) xs
+ Pandoc.OrderedList attr xs ->
+ Pandoc.OrderedList attr $ modifyLast (goBlocks f) xs
+ _ -> block
+
+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
diff --git a/lib/Patat/Presentation/Internal.hs b/lib/Patat/Presentation/Internal.hs
index 027a228..55f018d 100644
--- a/lib/Patat/Presentation/Internal.hs
+++ b/lib/Patat/Presentation/Internal.hs
@@ -3,7 +3,8 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module Patat.Presentation.Internal
- ( Presentation (..)
+ ( Breadcrumbs
+ , Presentation (..)
, PresentationSettings (..)
, defaultPresentationSettings
@@ -15,8 +16,11 @@ module Patat.Presentation.Internal
, ImageSettings (..)
+ , EvalSettingsMap
+ , EvalSettings (..)
+
, Slide (..)
- , Fragment (..)
+ , Instruction.Fragment (..)
, Index
, getSlide
@@ -28,17 +32,23 @@ module Patat.Presentation.Internal
--------------------------------------------------------------------------------
-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 Data.List (intercalate)
-import Data.Maybe (fromMaybe, listToMaybe)
-import qualified Data.Text as T
-import qualified Patat.Theme as Theme
+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
+import qualified Patat.Presentation.Instruction as Instruction
+import qualified Patat.Theme as Theme
import Prelude
-import qualified Text.Pandoc as Pandoc
-import Text.Read (readMaybe)
+import qualified Text.Pandoc as Pandoc
+import Text.Read (readMaybe)
+
+
+--------------------------------------------------------------------------------
+type Breadcrumbs = [(Int, [Pandoc.Inline])]
--------------------------------------------------------------------------------
@@ -48,6 +58,7 @@ data Presentation = Presentation
, pAuthor :: ![Pandoc.Inline]
, pSettings :: !PresentationSettings
, pSlides :: [Slide]
+ , pBreadcrumbs :: [Breadcrumbs] -- One for each slide.
, pActiveFragment :: !Index
} deriving (Show)
@@ -66,6 +77,8 @@ data PresentationSettings = PresentationSettings
, psSlideLevel :: !(Maybe Int)
, psPandocExtensions :: !(Maybe ExtensionList)
, psImages :: !(Maybe ImageSettings)
+ , psBreadcrumbs :: !(Maybe Bool)
+ , psEval :: !(Maybe EvalSettingsMap)
} deriving (Show)
@@ -82,6 +95,8 @@ instance Semigroup PresentationSettings where
, psSlideLevel = psSlideLevel l `mplus` psSlideLevel r
, psPandocExtensions = psPandocExtensions l `mplus` psPandocExtensions r
, psImages = psImages l `mplus` psImages r
+ , psBreadcrumbs = psBreadcrumbs l `mplus` psBreadcrumbs r
+ , psEval = psEval l <> psEval r
}
@@ -90,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
--------------------------------------------------------------------------------
@@ -106,6 +121,8 @@ defaultPresentationSettings = PresentationSettings
, psSlideLevel = Nothing
, psPandocExtensions = Nothing
, psImages = Nothing
+ , psBreadcrumbs = Nothing
+ , psEval = Nothing
}
@@ -216,15 +233,30 @@ instance A.FromJSON ImageSettings where
--------------------------------------------------------------------------------
-data Slide
- = ContentSlide [Fragment]
- | TitleSlide Pandoc.Block
- deriving (Show)
+type EvalSettingsMap = HMS.HashMap T.Text EvalSettings
--------------------------------------------------------------------------------
-newtype Fragment = Fragment {unFragment :: [Pandoc.Block]}
- deriving (Monoid, Semigroup, Show)
+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)
+ | TitleSlide Int [Pandoc.Inline]
+ deriving (Show)
--------------------------------------------------------------------------------
@@ -239,12 +271,14 @@ getSlide sidx = listToMaybe . drop sidx . pSlides
--------------------------------------------------------------------------------
numFragments :: Slide -> Int
-numFragments (ContentSlide fragments) = length fragments
-numFragments (TitleSlide _) = 1
+numFragments (ContentSlide instrs) = Instruction.numFragments instrs
+numFragments (TitleSlide _ _) = 1
--------------------------------------------------------------------------------
-data ActiveFragment = ActiveContent Fragment | ActiveTitle Pandoc.Block
+data ActiveFragment
+ = ActiveContent Instruction.Fragment
+ | ActiveTitle Pandoc.Block
deriving (Show)
@@ -253,10 +287,11 @@ getActiveFragment :: Presentation -> Maybe ActiveFragment
getActiveFragment presentation = do
let (sidx, fidx) = pActiveFragment presentation
slide <- getSlide sidx presentation
- case slide of
- TitleSlide block -> return (ActiveTitle block)
- ContentSlide fragments ->
- fmap ActiveContent . listToMaybe $ drop fidx fragments
+ pure $ case slide of
+ TitleSlide lvl is -> ActiveTitle $
+ Pandoc.Header lvl Pandoc.nullAttr is
+ ContentSlide instrs -> ActiveContent $
+ Instruction.renderFragment fidx instrs
--------------------------------------------------------------------------------
diff --git a/lib/Patat/Presentation/Read.hs b/lib/Patat/Presentation/Read.hs
index d8aa3c8..a465d1f 100644
--- a/lib/Patat/Presentation/Read.hs
+++ b/lib/Patat/Presentation/Read.hs
@@ -1,30 +1,39 @@
-- | Read a presentation from disk.
{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Patat.Presentation.Read
( readPresentation
+
+ -- Exposed for testing mostly.
+ , readMetaSettings
) where
--------------------------------------------------------------------------------
-import Control.Monad.Except (ExceptT (..), runExceptT,
- throwError)
-import Control.Monad.Trans (liftIO)
-import qualified Data.Aeson as A
-import qualified Data.HashMap.Strict as HMS
-import Data.Maybe (fromMaybe)
-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 Control.Monad.Except (ExceptT (..), runExceptT,
+ throwError)
+import Control.Monad.Trans (liftIO)
+import qualified Data.Aeson as A
+import Data.Bifunctor (first)
+import qualified Data.HashMap.Strict as HMS
+import Data.Maybe (fromMaybe)
+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
import Prelude
-import System.Directory (doesFileExist, getHomeDirectory)
-import System.FilePath (takeExtension, (</>))
-import qualified Text.Pandoc.Error as Pandoc
-import qualified Text.Pandoc.Extended as Pandoc
+import System.Directory (doesFileExist,
+ getHomeDirectory)
+import System.FilePath (splitFileName, takeExtension,
+ (</>))
+import qualified Text.Pandoc.Error as Pandoc
+import qualified Text.Pandoc.Extended as Pandoc
--------------------------------------------------------------------------------
@@ -40,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
@@ -81,8 +91,11 @@ pandocToPresentation
:: FilePath -> PresentationSettings -> Pandoc.Pandoc
-> Either String Presentation
pandocToPresentation pFilePath pSettings pandoc@(Pandoc.Pandoc meta _) = do
- let !pTitle = Pandoc.docTitle meta
+ let !pTitle = case Pandoc.docTitle meta of
+ [] -> [Pandoc.Str . T.pack . snd $ splitFileName pFilePath]
+ title -> title
!pSlides = pandocToSlides pSettings pandoc
+ !pBreadcrumbs = collectBreadcrumbs pSlides
!pActiveFragment = (0, 0)
!pAuthor = concat (Pandoc.docAuthors meta)
return Presentation {..}
@@ -93,26 +106,24 @@ pandocToPresentation pFilePath pSettings pandoc@(Pandoc.Pandoc meta _) = do
-- avoids the problems caused by pandoc involving rendering Markdown. This
-- should only be used for settings though, not things like title / authors
-- since those /can/ contain markdown.
-parseMetadataBlock :: T.Text -> Maybe A.Value
-parseMetadataBlock src = do
- block <- T.encodeUtf8 <$> mbBlock
- either (const Nothing) Just (Yaml.decodeEither' block)
- where
- mbBlock :: Maybe T.Text
- mbBlock = case T.lines src of
- ("---" : ls) -> case break (`elem` ["---", "..."]) ls of
- (_, []) -> Nothing
- (block, (_ : _)) -> Just (T.unlines block)
- _ -> Nothing
+parseMetadataBlock :: T.Text -> Maybe (Either String A.Value)
+parseMetadataBlock src = case T.lines src of
+ ("---" : ls) -> case break (`elem` ["---", "..."]) ls of
+ (_, []) -> Nothing
+ (block, (_ : _)) -> Just . first Yaml.prettyPrintParseException .
+ Yaml.decodeEither' . T.encodeUtf8 . T.unlines $! block
+ _ -> Nothing
--------------------------------------------------------------------------------
-- | Read settings from the metadata block in the Pandoc document.
readMetaSettings :: T.Text -> Either String PresentationSettings
-readMetaSettings src = fromMaybe (Right mempty) $ do
- A.Object obj <- parseMetadataBlock src
- val <- HMS.lookup "patat" obj
- return $! resultToEither $! A.fromJSON val
+readMetaSettings src = case parseMetadataBlock src of
+ Nothing -> Right mempty
+ Just (Left err) -> Left err
+ Just (Right (A.Object obj)) | Just val <- HMS.lookup "patat" obj ->
+ resultToEither $! A.fromJSON val
+ Just (Right _) -> Right mempty
where
resultToEither :: A.Result a -> Either String a
resultToEither (A.Success x) = Right x
@@ -143,11 +154,9 @@ pandocToSlides settings pandoc =
unfragmented = splitSlides slideLevel pandoc
fragmented =
[ case slide of
- TitleSlide _ -> slide
- ContentSlide fragments0 ->
- let blocks = concatMap unFragment fragments0
- blockss = fragmentBlocks fragmentSettings blocks in
- ContentSlide (map Fragment blockss)
+ TitleSlide _ _ -> slide
+ ContentSlide instrs0 -> ContentSlide $
+ fragmentInstructions fragmentSettings instrs0
| slide <- unfragmented
] in
fragmented
@@ -186,7 +195,8 @@ splitSlides slideLevel (Pandoc.Pandoc _meta blocks0)
where
mkContentSlide :: [Pandoc.Block] -> [Slide]
mkContentSlide [] = [] -- Never create empty slides
- mkContentSlide bs = [ContentSlide [Fragment bs]]
+ mkContentSlide bs =
+ [ContentSlide $ Instruction.fromList [Instruction.Append bs]]
splitAtRules blocks = case break (== Pandoc.HorizontalRule) blocks of
(xs, []) -> mkContentSlide xs
@@ -194,11 +204,22 @@ splitSlides slideLevel (Pandoc.Pandoc _meta blocks0)
splitAtHeaders acc [] =
mkContentSlide (reverse acc)
- splitAtHeaders acc (b@(Pandoc.Header i _ _) : bs)
+ splitAtHeaders acc (b@(Pandoc.Header i _ txt) : bs)
| i > slideLevel = splitAtHeaders (b : acc) bs
| i == slideLevel =
mkContentSlide (reverse acc) ++ splitAtHeaders [b] bs
| otherwise =
- mkContentSlide (reverse acc) ++ [TitleSlide b] ++ splitAtHeaders [] bs
+ mkContentSlide (reverse acc) ++ [TitleSlide i txt] ++
+ splitAtHeaders [] bs
splitAtHeaders acc (b : bs) =
splitAtHeaders (b : acc) bs
+
+collectBreadcrumbs :: [Slide] -> [Breadcrumbs]
+collectBreadcrumbs = go []
+ where
+ go breadcrumbs = \case
+ [] -> []
+ ContentSlide _ : slides -> breadcrumbs : go breadcrumbs slides
+ TitleSlide lvl inlines : slides ->
+ let parent = filter ((< lvl) . fst) breadcrumbs in
+ parent : go (parent ++ [(lvl, inlines)]) slides
diff --git a/lib/Patat/PrettyPrint.hs b/lib/Patat/PrettyPrint.hs
index a000be6..60d5523 100644
--- a/lib/Patat/PrettyPrint.hs
+++ b/lib/Patat/PrettyPrint.hs
@@ -31,6 +31,7 @@ module Patat.PrettyPrint
, (<+>)
, (<$$>)
, vcat
+ , intersperse
-- * Exotic combinators
, Alignment (..)
@@ -363,7 +364,12 @@ infixr 5 <$$>
--------------------------------------------------------------------------------
vcat :: [Doc] -> Doc
-vcat = mconcat . L.intersperse hardline
+vcat = intersperse hardline
+
+
+--------------------------------------------------------------------------------
+intersperse :: Doc -> [Doc] -> Doc
+intersperse sep = mconcat . L.intersperse sep
--------------------------------------------------------------------------------
diff --git a/patat.cabal b/patat.cabal
index b8ae68d..47da073 100644
--- a/patat.cabal
+++ b/patat.cabal
@@ -1,5 +1,5 @@
Name: patat
-Version: 0.8.5.0
+Version: 0.8.6.0
Synopsis: Terminal-based presentations using Pandoc
Description: Terminal-based presentations using Pandoc.
License: GPL-2
@@ -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
@@ -73,6 +76,7 @@ Library
Patat.Presentation.Display.CodeBlock
Patat.Presentation.Display.Table
Patat.Presentation.Fragment
+ Patat.Presentation.Instruction
Patat.Presentation.Interactive
Patat.Presentation.Internal
Patat.Presentation.Read
@@ -122,12 +126,14 @@ Test-suite patat-tests
Other-modules:
Patat.Presentation.Interactive.Tests
+ Patat.Presentation.Read.Tests
Build-depends:
patat,
- base >= 4.8 && < 5,
- directory >= 1.2 && < 1.4,
- tasty >= 1.2 && < 1.3,
- tasty-hunit >= 0.10 && < 0.11,
- tasty-quickcheck >= 0.10 && < 0.11,
- QuickCheck >= 2.8 && < 2.14
+ base >= 4.8 && < 5,
+ directory >= 1.2 && < 1.4,
+ tasty >= 1.2 && < 1.3,
+ tasty-hunit >= 0.10 && < 0.11,
+ tasty-quickcheck >= 0.10 && < 0.11,
+ text >= 1.2 && < 1.3,
+ QuickCheck >= 2.8 && < 2.14
diff --git a/tests/haskell/Main.hs b/tests/haskell/Main.hs
index 82e9f2b..651d428 100644
--- a/tests/haskell/Main.hs
+++ b/tests/haskell/Main.hs
@@ -1,9 +1,11 @@
module Main where
import qualified Patat.Presentation.Interactive.Tests
+import qualified Patat.Presentation.Read.Tests
import qualified Test.Tasty as Tasty
main :: IO ()
main = Tasty.defaultMain $ Tasty.testGroup "patat"
[ Patat.Presentation.Interactive.Tests.tests
+ , Patat.Presentation.Read.Tests.tests
]
diff --git a/tests/haskell/Patat/Presentation/Read/Tests.hs b/tests/haskell/Patat/Presentation/Read/Tests.hs
new file mode 100644
index 0000000..dd5bfe9
--- /dev/null
+++ b/tests/haskell/Patat/Presentation/Read/Tests.hs
@@ -0,0 +1,33 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Patat.Presentation.Read.Tests
+ ( tests
+ ) where
+
+import qualified Data.Text as T
+import Patat.Presentation.Read
+import qualified Test.Tasty as Tasty
+import qualified Test.Tasty.HUnit as Tasty
+
+tests :: Tasty.TestTree
+tests = Tasty.testGroup "Patat.Presentation.Read.Tests"
+ [ Tasty.testCase "readMetaSettings" $
+ case readMetaSettings invalidMetadata of
+ Left _ -> pure ()
+ Right _ -> Tasty.assertFailure "expecting invalid metadata"
+ ]
+
+invalidMetadata :: T.Text
+invalidMetadata =
+ "---\n\
+ \title: mixing tabs and spaces bad\n\
+ \author: thoastbrot\n\
+ \patat:\n\
+ \ images:\n\
+ \ backend: 'w3m'\n\
+ \ path: '/usr/lib/w3m/w3mimgdisplay'\n\
+ \ theme:\n\
+ \\theader: [vividBlue,onDullBlack]\n\
+ \ emph: [dullBlue,italic]\n\
+ \...\n\
+ \\n\
+ \Hi!"