diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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. diff --git a/patat.cabal b/patat.cabal --- a/patat.cabal +++ b/patat.cabal @@ -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 diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -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 diff --git a/src/Patat/AutoAdvance.hs b/src/Patat/AutoAdvance.hs new file mode 100644 --- /dev/null +++ b/src/Patat/AutoAdvance.hs @@ -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 diff --git a/src/Patat/Presentation/Display.hs b/src/Patat/Presentation/Display.hs --- a/src/Patat/Presentation/Display.hs +++ b/src/Patat/Presentation/Display.hs @@ -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 diff --git a/src/Patat/Presentation/Fragment.hs b/src/Patat/Presentation/Fragment.hs new file mode 100644 --- /dev/null +++ b/src/Patat/Presentation/Fragment.hs @@ -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 diff --git a/src/Patat/Presentation/Interactive.hs b/src/Patat/Presentation/Interactive.hs --- a/src/Patat/Presentation/Interactive.hs +++ b/src/Patat/Presentation/Interactive.hs @@ -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 + } diff --git a/src/Patat/Presentation/Internal.hs b/src/Patat/Presentation/Internal.hs --- a/src/Patat/Presentation/Internal.hs +++ b/src/Patat/Presentation/Internal.hs @@ -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 -------------------------------------------------------------------------------- diff --git a/src/Patat/Presentation/Read.hs b/src/Patat/Presentation/Read.hs --- a/src/Patat/Presentation/Read.hs +++ b/src/Patat/Presentation/Read.hs @@ -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