diff options
author | JasperVanDerJeugt <> | 2020-09-11 17:23:00 (GMT) |
---|---|---|
committer | hdiff <hdiff@hdiff.luite.com> | 2020-09-11 17:23:00 (GMT) |
commit | bd610864ffd4c5bde551c47b74409b4817f5aa70 (patch) | |
tree | 98a48bf7b9660141bf7c78c38f2882767c23cd4f | |
parent | 41cf25e2c53dbb58b7d44939f65057f71247c483 (diff) |
version 0.8.6.00.8.6.0
-rw-r--r-- | CHANGELOG.md | 6 | ||||
-rw-r--r-- | README.md | 75 | ||||
-rw-r--r-- | lib/Patat/Eval.hs | 116 | ||||
-rw-r--r-- | lib/Patat/Presentation/Display.hs | 42 | ||||
-rw-r--r-- | lib/Patat/Presentation/Fragment.hs | 134 | ||||
-rw-r--r-- | lib/Patat/Presentation/Instruction.hs | 105 | ||||
-rw-r--r-- | lib/Patat/Presentation/Internal.hs | 87 | ||||
-rw-r--r-- | lib/Patat/Presentation/Read.hs | 101 | ||||
-rw-r--r-- | lib/Patat/PrettyPrint.hs | 8 | ||||
-rw-r--r-- | patat.cabal | 20 | ||||
-rw-r--r-- | tests/haskell/Main.hs | 2 | ||||
-rw-r--r-- | tests/haskell/Patat/Presentation/Read/Tests.hs | 33 |
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 @@ -1,7 +1,7 @@ patat ===== -[](https://circleci.com/gh/jaspervdj/patat) [](https://hackage.haskell.org/package/patat) []() + [](https://hackage.haskell.org/package/patat) []() `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].  @@ -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!" |