patat 0.3.3.0 → 0.4.0.0
raw patch · 9 files changed
+325/−60 lines, 9 files
Files
- CHANGELOG.md +4/−0
- patat.cabal +3/−1
- src/Main.hs +12/−4
- src/Patat/AutoAdvance.hs +52/−0
- src/Patat/Presentation/Display.hs +14/−13
- src/Patat/Presentation/Fragment.hs +129/−0
- src/Patat/Presentation/Interactive.hs +31/−11
- src/Patat/Presentation/Internal.hs +57/−21
- src/Patat/Presentation/Read.hs +23/−10
CHANGELOG.md view
@@ -1,5 +1,9 @@ # Changelog +- 0.4.0.0 (2016-11-15)+ * Add configurable auto advancing.+ * Support fragmented slides.+ - 0.3.3.0 (2016-10-31) * Add a `--version` flag. * Add support for `pandoc-1.18` which includes a new `LineBlock` element.
patat.cabal view
@@ -1,5 +1,5 @@ Name: patat-Version: 0.3.3.0+Version: 0.4.0.0 Synopsis: Terminal-based presentations using Pandoc Description: Terminal-based presentations using Pandoc License: GPL-2@@ -45,10 +45,12 @@ Data.Aeson.Extended Data.Aeson.TH.Extended Data.Data.Extended+ Patat.AutoAdvance Patat.Presentation Patat.Presentation.Display Patat.Presentation.Display.CodeBlock Patat.Presentation.Display.Table+ Patat.Presentation.Fragment Patat.Presentation.Interactive Patat.Presentation.Internal Patat.Presentation.Read
src/Main.hs view
@@ -10,19 +10,21 @@ import Control.Concurrent (forkIO, threadDelay) import qualified Control.Concurrent.Chan as Chan import Control.Monad (forever, unless, when)+import qualified Data.Aeson.Extended as A import Data.Monoid (mempty, (<>)) import Data.Time (UTCTime) import Data.Version (showVersion) import qualified Options.Applicative as OA+import Patat.AutoAdvance import Patat.Presentation import qualified Paths_patat+import Prelude import qualified System.Console.ANSI as Ansi import System.Directory (doesFileExist, getModificationTime) import System.Exit (exitFailure, exitSuccess) import qualified System.IO as IO import qualified Text.PrettyPrint.ANSI.Leijen as PP-import Prelude --------------------------------------------------------------------------------@@ -131,11 +133,17 @@ interactiveLoop :: Options -> Presentation -> IO () interactiveLoop options pres0 = do IO.hSetBuffering IO.stdin IO.NoBuffering- commandChan <- Chan.newChan+ -- Spawn the initial channel that gives us commands based on user input.+ commandChan0 <- Chan.newChan+ _ <- forkIO $ forever $+ readPresentationCommand >>= Chan.writeChan commandChan0 - _ <- forkIO $ forever $- readPresentationCommand >>= Chan.writeChan commandChan+ -- If an auto delay is set, use 'autoAdvance' to create a new one.+ commandChan <- case psAutoAdvanceDelay (pSettings pres0) of+ Nothing -> return commandChan0+ Just (A.FlexibleNum delay) -> autoAdvance delay commandChan0 + -- Spawn a thread that adds 'Reload' commands based on the file time. mtime0 <- getModificationTime (pFilePath pres0) when (oWatch options) $ do _ <- forkIO $ watcher commandChan (pFilePath pres0) mtime0
+ src/Patat/AutoAdvance.hs view
@@ -0,0 +1,52 @@+--------------------------------------------------------------------------------+module Patat.AutoAdvance+ ( autoAdvance+ ) where+++--------------------------------------------------------------------------------+import Control.Concurrent (forkIO, threadDelay)+import qualified Control.Concurrent.Chan as Chan+import Control.Monad (forever)+import qualified Data.IORef as IORef+import Data.Time (diffUTCTime, getCurrentTime)+import Patat.Presentation (PresentationCommand (..))+++--------------------------------------------------------------------------------+-- | This function takes an existing channel for presentation commands+-- (presumably coming from human input) and creates a new one that /also/ sends+-- a 'Forward' command if nothing happens for N seconds.+autoAdvance+ :: Int+ -> Chan.Chan PresentationCommand+ -> IO (Chan.Chan PresentationCommand)+autoAdvance delaySeconds existingChan = do+ let delay = delaySeconds * 1000 -- We are working with ms in this function++ newChan <- Chan.newChan+ latestCommandAt <- IORef.newIORef =<< getCurrentTime++ -- This is a thread that copies 'existingChan' to 'newChan', and writes+ -- whenever the latest command was to 'latestCommandAt'.+ _ <- forkIO $ forever $ do+ cmd <- Chan.readChan existingChan+ getCurrentTime >>= IORef.writeIORef latestCommandAt+ Chan.writeChan newChan cmd++ -- This is a thread that waits around 'delay' seconds and then checks if+ -- there's been a more recent command. If not, we write a 'Forward'.+ _ <- forkIO $ forever $ do+ current <- getCurrentTime+ latest <- IORef.readIORef latestCommandAt+ let elapsed = floor $ 1000 * (current `diffUTCTime` latest) :: Int+ if elapsed >= delay+ then do+ Chan.writeChan newChan Forward+ IORef.writeIORef latestCommandAt current+ threadDelay (delay * 1000)+ else do+ let wait = delay - elapsed+ threadDelay (wait * 1000)++ return newChan
src/Patat/Presentation/Display.hs view
@@ -65,7 +65,8 @@ PP.putDoc $ withWrapSettings settings $ f theme putStrLn "" - let active = show (pActiveSlide + 1) ++ " / " ++ show (length pSlides)+ let (sidx, _) = pActiveFragment+ active = show (sidx + 1) ++ " / " ++ show (length pSlides) activeWidth = length active Ansi.setCursorPosition (rows - 2) 0@@ -78,11 +79,8 @@ -------------------------------------------------------------------------------- displayPresentation :: Presentation -> IO () displayPresentation pres@Presentation {..} = displayWithBorders pres $ \theme ->- let slide = case drop pActiveSlide pSlides of- [] -> mempty- (s : _) -> s in-- prettySlide theme slide+ let fragment = fromMaybe mempty (getActiveFragment pres) in+ prettyFragment theme fragment --------------------------------------------------------------------------------@@ -100,8 +98,11 @@ dumpPresentation pres = let theme = fromMaybe Theme.defaultTheme (psTheme $ pSettings pres) in PP.putDoc $ withWrapSettings (pSettings pres) $- PP.vcat $ intersperse "----------" $- map (prettySlide theme) $ pSlides pres+ PP.vcat $ intersperse "----------" $ do+ Slide fragments <- pSlides pres+ return $ PP.vcat $ intersperse "~~~~~~~~~~" $ do+ fragment <- fragments+ return $ prettyFragment theme fragment --------------------------------------------------------------------------------@@ -112,10 +113,10 @@ ---------------------------------------------------------------------------------prettySlide :: Theme -> Slide -> PP.Doc-prettySlide theme slide@(Slide blocks) =+prettyFragment :: Theme -> Fragment -> PP.Doc+prettyFragment theme fragment@(Fragment blocks) = prettyBlocks theme blocks <>- case prettyReferences theme slide of+ case prettyReferences theme fragment of [] -> mempty refs -> PP.hardline <> PP.vcat refs @@ -284,9 +285,9 @@ ---------------------------------------------------------------------------------prettyReferences :: Theme -> Slide -> [PP.Doc]+prettyReferences :: Theme -> Fragment -> [PP.Doc] prettyReferences theme@Theme {..} =- map prettyReference . getReferences . unSlide+ map prettyReference . getReferences . unFragment where getReferences :: [Pandoc.Block] -> [Pandoc.Inline] getReferences = filter isReferenceLink . grecQ
+ src/Patat/Presentation/Fragment.hs view
@@ -0,0 +1,129 @@+-- | For background info on the spec, see the "Incremental lists" section of the+-- the pandoc manual.+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveTraversable #-}+module Patat.Presentation.Fragment+ ( FragmentSettings (..)+ , fragmentBlocks+ , fragmentBlock+ ) where++import Data.Foldable (Foldable)+import Data.List (foldl', intersperse)+import Data.Maybe (fromMaybe)+import Data.Traversable (Traversable)+import qualified Text.Pandoc as Pandoc+import Prelude++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]++-- | 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)++fragmentBlock :: FragmentSettings -> Pandoc.Block -> Fragmented Pandoc.Block+fragmentBlock _fs block@(Pandoc.Para inlines)+ | inlines == threeDots = Fragmented [Nothing] Nothing+ | otherwise = Unfragmented block+ where+ threeDots = intersperse Pandoc.Space $ replicate 3 (Pandoc.Str ".")++fragmentBlock fs (Pandoc.BulletList bs0) =+ fragmentList fs (fsIncrementalLists fs) Pandoc.BulletList bs0++fragmentBlock fs (Pandoc.OrderedList attr bs0) =+ fragmentList fs (fsIncrementalLists fs) (Pandoc.OrderedList attr) bs0++fragmentBlock fs (Pandoc.BlockQuote [Pandoc.BulletList bs0]) =+ fragmentList fs (not $ fsIncrementalLists fs) 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++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)++ 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])++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+ 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
src/Patat/Presentation/Interactive.hs view
@@ -78,23 +78,43 @@ updatePresentation cmd presentation = case cmd of Exit -> return ExitedPresentation- Forward -> return $ goToSlide (\x -> x + 1)- Backward -> return $ goToSlide (\x -> x - 1)- SkipForward -> return $ goToSlide (\x -> x + 10)- SkipBackward -> return $ goToSlide (\x -> x - 10)- First -> return $ goToSlide (\_ -> 0)- Last -> return $ goToSlide (\_ -> numSlides presentation - 1)+ Forward -> return $ goToSlide $ \(s, f) -> (s, f + 1)+ Backward -> return $ goToSlide $ \(s, f) -> (s, f - 1)+ SkipForward -> return $ goToSlide $ \(s, _) -> (s + 10, 0)+ SkipBackward -> return $ goToSlide $ \(s, _) -> (s - 10, 0)+ First -> return $ goToSlide $ \_ -> (0, 0)+ Last -> return $ goToSlide $ \_ -> (numSlides presentation, 0) Reload -> reloadPresentation where+ numSlides :: Presentation -> Int numSlides pres = length (pSlides pres)- clip idx pres = min (max 0 idx) (numSlides pres - 1) - goToSlide f = UpdatedPresentation $- presentation {pActiveSlide = clip (f $ pActiveSlide presentation) presentation}+ clip :: Index -> Presentation -> Index+ clip (slide, fragment) pres+ | slide >= numSlides pres = (numSlides pres - 1, lastFragments - 1)+ | slide < 0 = (0, 0)+ | fragment >= numFragments slide =+ if slide + 1 >= numSlides pres+ then (slide, lastFragments - 1)+ else (slide + 1, 0)+ | fragment < 0 =+ if slide - 1 >= 0+ then (slide - 1, numFragments (slide - 1) - 1)+ else (slide, 0)+ | otherwise = (slide, fragment)+ where+ numFragments s = maybe 1 (length . unSlide) (getSlide s pres)+ lastFragments = numFragments (numSlides pres - 1) + goToSlide :: (Index -> Index) -> UpdatedPresentation+ goToSlide f = UpdatedPresentation $ presentation+ { pActiveFragment = clip (f $ pActiveFragment presentation) presentation+ }+ reloadPresentation = do errOrPres <- readPresentation (pFilePath presentation) return $ case errOrPres of Left err -> ErroredPresentation err- Right pres -> UpdatedPresentation $- pres {pActiveSlide = clip (pActiveSlide presentation) pres}+ Right pres -> UpdatedPresentation $ pres+ { pActiveFragment = clip (pActiveFragment presentation) pres+ }
src/Patat/Presentation/Internal.hs view
@@ -6,6 +6,11 @@ , PresentationSettings (..) , defaultPresentationSettings , Slide (..)+ , Fragment (..)+ , Index++ , getSlide+ , getActiveFragment ) where @@ -13,7 +18,8 @@ import Control.Monad (mplus) import qualified Data.Aeson.Extended as A import qualified Data.Aeson.TH.Extended as A-import Data.Monoid (Monoid (..))+import Data.Maybe (listToMaybe)+import Data.Monoid (Monoid (..), (<>)) import qualified Patat.Theme as Theme import qualified Text.Pandoc as Pandoc import Prelude@@ -21,12 +27,12 @@ -------------------------------------------------------------------------------- data Presentation = Presentation- { pFilePath :: !FilePath- , pTitle :: ![Pandoc.Inline]- , pAuthor :: ![Pandoc.Inline]- , pSettings :: !PresentationSettings- , pSlides :: [Slide]- , pActiveSlide :: !Int+ { pFilePath :: !FilePath+ , pTitle :: ![Pandoc.Inline]+ , pAuthor :: ![Pandoc.Inline]+ , pSettings :: !PresentationSettings+ , pSlides :: [Slide]+ , pActiveFragment :: !Index } deriving (Show) @@ -34,37 +40,67 @@ -- | These are patat-specific settings. That is where they differ from more -- general metadata (author, title...) data PresentationSettings = PresentationSettings- { psRows :: !(Maybe (A.FlexibleNum Int))- , psColumns :: !(Maybe (A.FlexibleNum Int))- , psWrap :: !(Maybe Bool)- , psTheme :: !(Maybe Theme.Theme)+ { psRows :: !(Maybe (A.FlexibleNum Int))+ , psColumns :: !(Maybe (A.FlexibleNum Int))+ , psWrap :: !(Maybe Bool)+ , psTheme :: !(Maybe Theme.Theme)+ , psIncrementalLists :: !(Maybe Bool)+ , psAutoAdvanceDelay :: !(Maybe (A.FlexibleNum Int)) } deriving (Show) -------------------------------------------------------------------------------- instance Monoid PresentationSettings where- mempty = PresentationSettings Nothing Nothing Nothing Nothing+ mempty = PresentationSettings+ Nothing Nothing Nothing Nothing Nothing Nothing mappend l r = PresentationSettings- { psRows = psRows l `mplus` psRows r- , psColumns = psColumns l `mplus` psColumns r- , psWrap = psWrap l `mplus` psWrap r- , psTheme = psTheme l `mappend` psTheme r+ { psRows = psRows l `mplus` psRows r+ , psColumns = psColumns l `mplus` psColumns r+ , psWrap = psWrap l `mplus` psWrap r+ , psTheme = psTheme l <> psTheme r+ , psIncrementalLists = psIncrementalLists l `mplus` psIncrementalLists r+ , psAutoAdvanceDelay = psAutoAdvanceDelay l `mplus` psAutoAdvanceDelay r } -------------------------------------------------------------------------------- defaultPresentationSettings :: PresentationSettings defaultPresentationSettings = PresentationSettings- { psRows = Nothing- , psColumns = Nothing- , psWrap = Nothing- , psTheme = Just Theme.defaultTheme+ { psRows = Nothing+ , psColumns = Nothing+ , psWrap = Nothing+ , psTheme = Just Theme.defaultTheme+ , psIncrementalLists = Nothing+ , psAutoAdvanceDelay = Nothing } ---------------------------------------------------------------------------------newtype Slide = Slide {unSlide :: [Pandoc.Block]}+newtype Slide = Slide {unSlide :: [Fragment]} deriving (Monoid, Show)+++--------------------------------------------------------------------------------+newtype Fragment = Fragment {unFragment :: [Pandoc.Block]}+ deriving (Monoid, Show)+++--------------------------------------------------------------------------------+-- | Active slide, active fragment.+type Index = (Int, Int)+++--------------------------------------------------------------------------------+getSlide :: Int -> Presentation -> Maybe Slide+getSlide sidx = listToMaybe . drop sidx . pSlides+++--------------------------------------------------------------------------------+getActiveFragment :: Presentation -> Maybe Fragment+getActiveFragment presentation = do+ let (sidx, fidx) = pActiveFragment presentation+ Slide fragments <- getSlide sidx presentation+ listToMaybe $ drop fidx fragments --------------------------------------------------------------------------------
src/Patat/Presentation/Read.hs view
@@ -12,9 +12,11 @@ import Control.Monad.Trans (liftIO) import qualified Data.Aeson as A import qualified Data.ByteString as B+import Data.Maybe (fromMaybe) import Data.Monoid (mempty, (<>)) import qualified Data.Set as Set import qualified Data.Yaml as Yaml+import Patat.Presentation.Fragment import Patat.Presentation.Internal import System.Directory (doesFileExist, getHomeDirectory) import System.FilePath (takeExtension, (</>))@@ -65,10 +67,10 @@ :: FilePath -> PresentationSettings -> Pandoc.Pandoc -> Either String Presentation pandocToPresentation pFilePath pSettings pandoc@(Pandoc.Pandoc meta _) = do- let !pTitle = Pandoc.docTitle meta- !pSlides = pandocToSlides pandoc- !pActiveSlide = 0- !pAuthor = concat (Pandoc.docAuthors meta)+ let !pTitle = Pandoc.docTitle meta+ !pSlides = pandocToSlides pSettings pandoc+ !pActiveFragment = (0, 0)+ !pAuthor = concat (Pandoc.docAuthors meta) return Presentation {..} @@ -100,22 +102,33 @@ --------------------------------------------------------------------------------+pandocToSlides :: PresentationSettings -> Pandoc.Pandoc -> [Slide]+pandocToSlides settings pandoc =+ let blockss = splitSlides pandoc in+ map (Slide . map Fragment . (fragmentBlocks fragmentSettings)) blockss+ where+ fragmentSettings = FragmentSettings+ { fsIncrementalLists = fromMaybe False (psIncrementalLists settings)+ }+++-------------------------------------------------------------------------------- -- | Split a pandoc document into slides. If the document contains horizonal -- rules, we use those as slide delimiters. If there are no horizontal rules, -- we split using h1 headers.-pandocToSlides :: Pandoc.Pandoc -> [Slide]-pandocToSlides (Pandoc.Pandoc _meta blocks0)+splitSlides :: Pandoc.Pandoc -> [[Pandoc.Block]]+splitSlides (Pandoc.Pandoc _meta blocks0) | any (== Pandoc.HorizontalRule) blocks0 = splitAtRules blocks0 | otherwise = splitAtH1s blocks0 where splitAtRules blocks = case break (== Pandoc.HorizontalRule) blocks of- (xs, []) -> [Slide xs]- (xs, (_rule : ys)) -> Slide xs : splitAtRules ys+ (xs, []) -> [xs]+ (xs, (_rule : ys)) -> xs : splitAtRules ys splitAtH1s [] = [] splitAtH1s (b : bs) = case break isH1 bs of- (xs, []) -> [Slide (b : xs)]- (xs, (y : ys)) -> Slide (b : xs) : splitAtH1s (y : ys)+ (xs, []) -> [(b : xs)]+ (xs, (y : ys)) -> (b : xs) : splitAtH1s (y : ys) isH1 (Pandoc.Header i _ _) = i == 1 isH1 _ = False