patat 0.8.5.0 → 0.8.6.0

raw patch · 12 files changed

+554/−175 lines, 12 filesdep +asyncdep +pandoc-typesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: async, pandoc-types

API changes (from Hackage documentation)

Files

• CHANGELOG.md +6/−0
• README.md +74/−1
• lib/Patat/Eval.hs +116/−0
• lib/Patat/Presentation/Display.hs +29/−13
• lib/Patat/Presentation/Fragment.hs +47/−87
• lib/Patat/Presentation/Instruction.hs +105/−0
• lib/Patat/Presentation/Internal.hs +61/−26
• lib/Patat/Presentation/Read.hs +61/−40
• lib/Patat/PrettyPrint.hs +7/−1
• patat.cabal +13/−7
• tests/haskell/Main.hs +2/−0
• tests/haskell/Patat/Presentation/Read/Tests.hs +33/−0

@@ -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 ===== -[![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 @@ - 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 @@     -   [Syntax Highlighting](#syntax-highlighting)     -   [Pandoc Extensions](#pandoc-extensions)     -   [Images](#images)+    -   [Breadcrumbs](#breadcrumbs)+    -   [Evaluating code](#evaluating-code) -   [Trivia](#trivia)  Installation@@ -574,6 +577,76 @@     backend: 'w3m'     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 ------

@@ -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 {..}

@@ -15,12 +15,13 @@ 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 @@             (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 @@     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 @@         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 @@     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 @@   ---------------------------------------------------------------------------------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

@@ -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.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])--    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)+fragmentBlock _ block@(Pandoc.BlockQuote _)     = [Append [block]] -    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)

@@ -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

@@ -3,7 +3,8 @@ {-# LANGUAGE OverloadedStrings          #-} {-# LANGUAGE TemplateHaskell            #-} module Patat.Presentation.Internal-    ( Presentation (..)+    ( Breadcrumbs+    , Presentation (..)     , PresentationSettings (..)     , defaultPresentationSettings @@ -15,8 +16,11 @@      , ImageSettings (..) +    , EvalSettingsMap+    , EvalSettings (..)+     , Slide (..)-    , Fragment (..)+    , Instruction.Fragment (..)     , Index      , getSlide@@ -28,26 +32,33 @@   ---------------------------------------------------------------------------------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])]+++-------------------------------------------------------------------------------- data Presentation = Presentation     { pFilePath       :: !FilePath     , pTitle          :: ![Pandoc.Inline]     , pAuthor         :: ![Pandoc.Inline]     , pSettings       :: !PresentationSettings     , pSlides         :: [Slide]+    , pBreadcrumbs    :: [Breadcrumbs]  -- One for each slide.     , pActiveFragment :: !Index     } deriving (Show) @@ -66,6 +77,8 @@     , psSlideLevel       :: !(Maybe Int)     , psPandocExtensions :: !(Maybe ExtensionList)     , psImages           :: !(Maybe ImageSettings)+    , psBreadcrumbs      :: !(Maybe Bool)+    , psEval             :: !(Maybe EvalSettingsMap)     } deriving (Show)  @@ -82,6 +95,8 @@         , 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 @@     mappend = (<>)     mempty  = PresentationSettings                     Nothing Nothing Nothing Nothing Nothing Nothing Nothing-                    Nothing Nothing Nothing+                    Nothing Nothing Nothing Nothing Nothing   --------------------------------------------------------------------------------@@ -106,6 +121,8 @@     , psSlideLevel       = Nothing     , psPandocExtensions = Nothing     , psImages           = Nothing+    , psBreadcrumbs      = Nothing+    , psEval             = Nothing     }  @@ -216,18 +233,33 @@   ---------------------------------------------------------------------------------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)+++-------------------------------------------------------------------------------- -- | Active slide, active fragment. type Index = (Int, Int) @@ -239,12 +271,14 @@  -------------------------------------------------------------------------------- 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 = 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   --------------------------------------------------------------------------------

@@ -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 @@     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 @@     :: 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 @@ -- 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 @@         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 @@   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 @@      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

@@ -31,6 +31,7 @@     , (<+>)     , (<$$>)     , vcat+    , intersperse      -- * Exotic combinators     , Alignment (..)@@ -363,7 +364,12 @@  -------------------------------------------------------------------------------- vcat :: [Doc] -> Doc-vcat = mconcat . L.intersperse hardline+vcat = intersperse hardline+++--------------------------------------------------------------------------------+intersperse :: Doc -> [Doc] -> Doc+intersperse sep = mconcat . L.intersperse sep   --------------------------------------------------------------------------------

@@ -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 @@     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 @@     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 @@   Exposed-modules:     Patat.AutoAdvance     Patat.Cleanup+    Patat.Eval     Patat.Images     Patat.Images.Internal     Patat.Images.W3m@@ -73,6 +76,7 @@     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 @@    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

@@ -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     ]

@@ -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!"