diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,47 @@ # Changelog +## 0.10.0.0 (2023-10-12) + + * Add transition effects (#149) + + This adds a framework for setting transition effects in between slides. Only + a single transition type is implemented at this point, `slideLeft`. + + Example configuration: + + patat: + transition: + type: slideLeft + frames: 24 # Optional + duration: 1 # Seconds, optional + + + * Allow overriding certain settings in slides (#148) + + Configuration was typically done in the metadata block of the input file, + or in a per-user configuration. These settings are applied to the entire + presentation. + + We now allow selectively overriding these settings on a per-slide basis, + by adding one or more config blocks to those slides. Config blocks are + comments that start with `config:`. They can be placed anywhere in the + slide. + + # This is a normal slide + + Normal slide content + + # This slide has a different colour header + + + + Wow, how did that happen? + + * Allow configuring top margin (#147) + ## 0.9.2.0 (2023-09-26) * Read configuration from XDG standard directory (#146) diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -15,6 +15,7 @@ - Display [speaker notes](#speaker-notes) in a second window or monitor. - [Incremental slide display](#fragmented-slides). - Experimental [images](#images) support. +- [Transition effects](#transitions). - Supports [smart slide splitting](#input-format). - [Auto advancing](#auto-advancing) with configurable delay. - Optionally [re-wrapping](#line-wrapping) text to terminal width with proper @@ -42,6 +43,7 @@ - [Input format](#input-format) - [Configuration](#configuration) - [Line wrapping](#line-wrapping) + - [Margins](#margins) - [Auto advancing](#auto-advancing) - [Advanced slide splitting](#advanced-slide-splitting) - [Fragmented slides](#fragmented-slides) @@ -50,8 +52,10 @@ - [Pandoc Extensions](#pandoc-extensions) - [Images](#images) - [Breadcrumbs](#breadcrumbs) + - [Slide numbers](#slide-numbers) - [Evaluating code](#evaluating-code) - [Speaker notes](#speaker-notes) + - [Transitions](#transitions) - [Trivia](#trivia) Installation @@ -249,32 +253,61 @@ 1. For per-user configuration you can use `$XDG_CONFIG_DIRECTORY/patat/config.yaml` - (typically `$HOME/.config/patat/config.yaml`) or `$HOME/.patat.yaml`. + (typically `$HOME/.config/patat/config.yaml`) or `$HOME/.patat.yaml`, for + example: + + ```yaml + slideNumber: false + ``` + 2. In the presentation file itself, using the [Pandoc metadata header]. These settings take precedence over anything specified in the per-user - configuration file. + configuration file. They must be placed in a `patat:` section, so they + don't conflict with metadata: -[YAML]: http://yaml.org/ -[Pandoc metadata header]: http://pandoc.org/MANUAL.html#extension-yaml_metadata_block + ```markdown + --- + title: Presentation with options + author: John Doe + patat: + slideNumber: false + ... -For example, we set an option `key` to `val` by using the following file: + Hello world. + ``` -```markdown ---- -title: Presentation with options -author: John Doe -patat: - key: val -... +3. Within a slide, using a comment starting with ` + + Slide numbers are turned off here. + ``` + + The following settings can **not** be set in a slide configuration block, + and doing so will result in an error: + + - `autoAdvanceDelay` + - `eval` + - `images` + - `incrementalLists` + - `pandocExtensions` + - `slideLevel` + - `speakerNotes` + +[YAML]: http://yaml.org/ +[Pandoc metadata header]: http://pandoc.org/MANUAL.html#extension-yaml_metadata_block + ### Line wrapping Line wrapping can be enabled by setting `wrap: true` in the configuration. This @@ -293,16 +326,23 @@ margins: left: 10 right: 10 + top: 5 ... Lorem ipsum dolor sit amet, ... ``` -This example configuration will generate slides with a margin of 10 characters on the left, -and break lines 10 characters before they reach the end of the terminal's width. +This example configuration will generate slides with a margin of 10 columns on +the left, and it will wrap long lines 10 columns before the right side of the +terminal. Additionally, there will be 5 empty lines in between the title bar +and slide content. -It is recommended to enable [line wrapping](#line-wrapping) along with this feature. +[Line wrapping](#line-wrapping) should be enabled when using non-zero `right` +margin. +By default, the `left` and `right` margin are set to 0, and the `top` margin is +set to 1. + ### Auto advancing By setting `autoAdvanceDelay` to a number of seconds, `patat` will automatically @@ -724,6 +764,51 @@ patat -w /tmp/notes.txt ``` +Note that speaker notes should not start with ` + +Slide two content. +``` + +Supported transitions `type`s: + + - `slideLeft`: slides the new slide in from right to left. + + Arguments: + + - `frameRate`: number of frames per second. Defaults to 24. + - `duration`: duration of the animation in seconds. Defaults to 1. + Trivia ------ @@ -740,3 +825,7 @@ [MDP]: https://github.com/visit1985/mdp [VTMC]: https://github.com/jclulow/vtmc [Literate Haskell]: https://wiki.haskell.org/Literate_programming + +[Alacritty]: https://alacritty.org/ +[iTerm2]: https://iterm2.com/ +[Kitty]: https://sw.kovidgoyal.net/kitty/ diff --git a/lib/Control/Concurrent/Chan/Extended.hs b/lib/Control/Concurrent/Chan/Extended.hs new file mode 100644 --- /dev/null +++ b/lib/Control/Concurrent/Chan/Extended.hs @@ -0,0 +1,15 @@ +module Control.Concurrent.Chan.Extended + ( module Control.Concurrent.Chan + , withMapChan + ) where + +import qualified Control.Concurrent.Async as Async +import Control.Concurrent.Chan +import Control.Monad (forever) + +withMapChan :: (a -> b) -> Chan a -> (Chan b -> IO r) -> IO r +withMapChan f chan cont = do + new <- newChan + Async.withAsync + (forever $ readChan chan >>= writeChan new . f) + (\_ -> cont new) diff --git a/lib/Patat/AutoAdvance.hs b/lib/Patat/AutoAdvance.hs --- a/lib/Patat/AutoAdvance.hs +++ b/lib/Patat/AutoAdvance.hs @@ -1,11 +1,13 @@ -------------------------------------------------------------------------------- module Patat.AutoAdvance - ( autoAdvance + ( maybeAutoAdvance + , autoAdvance ) where -------------------------------------------------------------------------------- -import Control.Concurrent (forkIO, threadDelay) +import Control.Concurrent (threadDelay) +import qualified Control.Concurrent.Async as Async import qualified Control.Concurrent.Chan as Chan import Control.Monad (forever) import qualified Data.IORef as IORef @@ -14,14 +16,26 @@ -------------------------------------------------------------------------------- +-- | Utility to make auto advancing optional. +maybeAutoAdvance + :: Maybe Int + -> Chan.Chan PresentationCommand + -> (Chan.Chan PresentationCommand -> IO a) + -> IO a +maybeAutoAdvance Nothing chan f = f chan +maybeAutoAdvance (Just delaySeconds) chan f = autoAdvance delaySeconds chan f + + +-------------------------------------------------------------------------------- -- | 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 + -> (Chan.Chan PresentationCommand -> IO a) + -> IO a +autoAdvance delaySeconds existingChan f = do let delay = delaySeconds * 1000 -- We are working with ms in this function newChan <- Chan.newChan @@ -29,24 +43,25 @@ -- This is a thread that copies 'existingChan' to 'newChan', and writes -- whenever the latest command was to 'latestCommandAt'. - _ <- forkIO $ forever $ do + (forever $ do cmd <- Chan.readChan existingChan getCurrentTime >>= IORef.writeIORef latestCommandAt - Chan.writeChan newChan cmd + Chan.writeChan newChan cmd) `Async.withAsync` \_ -> - -- 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) + -- 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'. + (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)) `Async.withAsync` \_ -> - return newChan + -- Continue main thread. + f newChan diff --git a/lib/Patat/Images.hs b/lib/Patat/Images.hs --- a/lib/Patat/Images.hs +++ b/lib/Patat/Images.hs @@ -3,7 +3,7 @@ module Patat.Images ( Backend , Handle - , new + , withHandle , drawImage ) where @@ -21,16 +21,16 @@ -------------------------------------------------------------------------------- -new :: ImageSettings -> IO Handle -new is - | isBackend is == "auto" = auto +withHandle :: ImageSettings -> (Handle -> IO a) -> IO a +withHandle is f + | isBackend is == "auto" = auto >>= f | Just (Backend b) <- lookup (isBackend is) backends = case A.fromJSON (A.Object $ isParams is) of - A.Success c -> b (Explicit c) + A.Success c -> b (Explicit c) >>= f A.Error err -> fail $ "Patat.Images.new: Error parsing config for " ++ show (isBackend is) ++ " image backend: " ++ err -new is = fail $ +withHandle is _ = fail $ "Patat.Images.new: Could not find " ++ show (isBackend is) ++ " image backend." diff --git a/lib/Patat/Main.hs b/lib/Patat/Main.hs --- a/lib/Patat/Main.hs +++ b/lib/Patat/Main.hs @@ -8,33 +8,37 @@ -------------------------------------------------------------------------------- -import Control.Concurrent (forkIO, killThread, - threadDelay) -import Control.Concurrent.Chan (Chan) -import qualified Control.Concurrent.Chan as Chan -import Control.Exception (bracket) -import Control.Monad (forever, unless, when) -import qualified Data.Aeson.Extended as A -import Data.Foldable (for_) -import Data.Functor (($>)) -import Data.Time (UTCTime) -import Data.Version (showVersion) -import qualified Options.Applicative as OA -import qualified Options.Applicative.Help.Pretty as OA.PP +import Control.Concurrent (forkIO, threadDelay) +import qualified Control.Concurrent.Async as Async +import Control.Concurrent.Chan.Extended (Chan) +import qualified Control.Concurrent.Chan.Extended as Chan +import Control.Exception (bracket) +import Control.Monad (forever, join, unless, void, + when) +import qualified Data.Aeson.Extended as A +import Data.Foldable (for_) +import Data.Functor (($>)) +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Sequence.Extended as Seq +import Data.Version (showVersion) +import qualified Options.Applicative as OA +import qualified Options.Applicative.Help.Pretty as OA.PP import Patat.AutoAdvance -import qualified Patat.EncodingFallback as EncodingFallback -import qualified Patat.Images as Images +import qualified Patat.EncodingFallback as EncodingFallback +import qualified Patat.Images as Images import Patat.Presentation -import qualified Patat.Presentation.SpeakerNotes as SpeakerNotes -import qualified Patat.PrettyPrint as PP +import qualified Patat.Presentation.Comments as Comments +import qualified Patat.PrettyPrint as PP +import Patat.PrettyPrint.Matrix (hPutMatrix) +import Patat.Transition 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.Pandoc as Pandoc +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.Pandoc as Pandoc -------------------------------------------------------------------------------- @@ -120,6 +124,28 @@ -------------------------------------------------------------------------------- +data App = App + { aOptions :: Options + , aImages :: Maybe Images.Handle + , aSpeakerNotes :: Maybe Comments.SpeakerNotesHandle + , aCommandChan :: Chan AppCommand + , aPresentation :: Presentation + , aView :: AppView + } + + +-------------------------------------------------------------------------------- +data AppView + = PresentationView + | ErrorView String + | TransitionView TransitionInstance + + +-------------------------------------------------------------------------------- +data AppCommand = PresentationCommand PresentationCommand | TransitionTick TransitionId + + +-------------------------------------------------------------------------------- main :: IO () main = do options <- OA.customExecParser parserPrefs parserInfo @@ -137,78 +163,121 @@ errOrPres <- readPresentation filePath pres <- either (errorAndExit . return) return errOrPres + let settings = pSettings pres unless (oForce options) assertAnsiFeatures - -- (Maybe) initialize images backend. - images <- traverse Images.new $ psImages $ pSettings pres + if oDump options then + EncodingFallback.withHandle IO.stdout (pEncodingFallback pres) $ + dumpPresentation pres + else + -- (Maybe) initialize images backend. + withMaybeHandle Images.withHandle (psImages settings) $ \images -> - -- (Maybe) initialize speaker notes. - withMaybeHandle SpeakerNotes.with - (psSpeakerNotes $ pSettings pres) $ \speakerNotes -> + -- (Maybe) initialize speaker notes. + withMaybeHandle Comments.withSpeakerNotesHandle + (psSpeakerNotes settings) $ \speakerNotes -> - if oDump options then - EncodingFallback.withHandle IO.stdout (pEncodingFallback pres) $ - dumpPresentation pres - else - interactiveLoop options images speakerNotes pres - where - interactiveLoop - :: Options -> Maybe Images.Handle -> Maybe SpeakerNotes.Handle - -> Presentation -> IO () - interactiveLoop options images speakerNotes pres0 = - interactively readPresentationCommand $ \commandChan0 -> do + -- Read presentation commands + interactively (readPresentationCommand) $ \commandChan0 -> -- 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 + maybeAutoAdvance + (A.unFlexibleNum <$> psAutoAdvanceDelay settings) + commandChan0 $ \commandChan1 -> + -- Change to AppCommand + Chan.withMapChan PresentationCommand commandChan1 $ \commandChan -> + -- 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 - return () + withWatcher (oWatch options) commandChan (pFilePath pres) + (PresentationCommand Reload) $ - let loop :: Presentation -> Maybe String -> IO () - loop pres mbError = do - for_ speakerNotes $ \sn -> SpeakerNotes.write sn - (pEncodingFallback pres) - (activeSpeakerNotes pres) + loop App + { aOptions = options + , aImages = images + , aSpeakerNotes = speakerNotes + , aCommandChan = commandChan + , aPresentation = pres + , aView = PresentationView + } - size <- getDisplaySize pres - let display = case mbError of - Nothing -> displayPresentation size pres - Just err -> DisplayDoc $ - displayPresentationError size pres err - Ansi.clearScreen - Ansi.setCursorPosition 0 0 - cleanup <- case display of - DisplayDoc doc -> EncodingFallback.withHandle - IO.stdout (pEncodingFallback pres) $ - PP.putDoc doc $> mempty - DisplayImage path -> case images of - Nothing -> do - PP.putDoc $ displayPresentationError - size pres "image backend not initialized" - pure mempty - Just img -> do - putStrLn "" - IO.hFlush IO.stdout - Images.drawImage img path +-------------------------------------------------------------------------------- +loop :: App -> IO () +loop app@App {..} = do + for_ aSpeakerNotes $ \sn -> Comments.writeSpeakerNotes sn + (pEncodingFallback aPresentation) + (activeSpeakerNotes aPresentation) - c <- Chan.readChan commandChan - update <- updatePresentation c pres - cleanup - case update of - ExitedPresentation -> return () - UpdatedPresentation pres' -> loop pres' Nothing - ErroredPresentation err -> loop pres (Just err) + size <- getPresentationSize aPresentation + Ansi.clearScreen + Ansi.setCursorPosition 0 0 + cleanup <- case aView of + PresentationView -> case displayPresentation size aPresentation of + DisplayDoc doc -> drawDoc doc + DisplayImage path -> drawImg size path + ErrorView err -> drawDoc $ + displayPresentationError size aPresentation err + TransitionView tr -> do + drawMatrix (tiSize tr) . fst . NonEmpty.head $ tiFrames tr + pure mempty - loop pres0 Nothing + appCmd <- Chan.readChan aCommandChan + cleanup + case appCmd of + TransitionTick eid -> case aView of + PresentationView -> loop app + ErrorView _ -> loop app + TransitionView tr0 -> case stepTransition eid tr0 of + Just tr1 -> do + scheduleTransitionTick tr1 + loop app {aView = TransitionView tr1} + Nothing -> loop app {aView = PresentationView} + PresentationCommand c -> do + update <- updatePresentation c aPresentation + case update of + ExitedPresentation -> return () + UpdatedPresentation pres + | Just tgen <- mbTransition c size aPresentation pres -> do + tr <- tgen + scheduleTransitionTick tr + loop app + {aPresentation = pres, aView = TransitionView tr} + | otherwise -> loop app + {aPresentation = pres, aView = PresentationView} + ErroredPresentation err -> + loop app {aView = ErrorView err} + where + drawDoc doc = EncodingFallback.withHandle + IO.stdout (pEncodingFallback aPresentation) $ + PP.putDoc doc $> mempty + drawImg size path =case aImages of + Nothing -> drawDoc $ displayPresentationError + size aPresentation "image backend not initialized" + Just img -> do + putStrLn "" + IO.hFlush IO.stdout + Images.drawImage img path + drawMatrix size raster = hPutMatrix IO.stdout size raster + mbTransition c size old new + | c == Forward + , oldSlide + 1 == newSlide + , DisplayDoc oldDoc <- displayPresentation size old + , DisplayDoc newDoc <- displayPresentation size new + , Just (Just tgen) <- pTransitionGens new `Seq.safeIndex` newSlide = + Just $ newTransition tgen size oldDoc newDoc + | otherwise = Nothing + where + (oldSlide, _) = pActiveFragment old + (newSlide, _) = pActiveFragment new + scheduleTransitionTick tr = void $ forkIO $ do + threadDelayDuration . snd . NonEmpty.head $ tiFrames tr + Chan.writeChan aCommandChan $ TransitionTick $ tiId tr + + -------------------------------------------------------------------------------- -- | Utility for dealing with pecularities of stdin & interactive applications -- on the terminal. Tries to restore the original state of the terminal as much @@ -221,7 +290,10 @@ -- ^ Application to run. -> IO () -- ^ Returns when application finishes. -interactively reader app = bracket setup teardown $ \(_, _, _, chan) -> app chan +interactively reader app = bracket setup teardown $ \(_, _, chan) -> + Async.withAsync + (forever $ reader IO.stdin >>= Chan.writeChan chan) + (\_ -> app chan) where setup = do chan <- Chan.newChan @@ -230,30 +302,33 @@ IO.hSetEcho IO.stdin False IO.hSetBuffering IO.stdin IO.NoBuffering Ansi.hideCursor - readerThreadId <- forkIO $ forever $ - reader IO.stdin >>= Chan.writeChan chan - return (echo, buff, readerThreadId, chan) + return (echo, buff, chan) - teardown (echo, buff, readerThreadId, _chan) = do + teardown (echo, buff, _chan) = do Ansi.showCursor Ansi.clearScreen Ansi.setCursorPosition 0 0 - killThread readerThreadId IO.hSetEcho IO.stdin echo IO.hSetBuffering IO.stdin buff -------------------------------------------------------------------------------- -watcher :: Chan.Chan PresentationCommand -> FilePath -> UTCTime -> IO a -watcher chan filePath mtime0 = do - -- The extra exists check helps because some editors temporarily make the - -- file disappear while writing. - exists <- doesFileExist filePath - mtime1 <- if exists then getModificationTime filePath else return mtime0 +withWatcher + :: Bool -> Chan.Chan cmd -> FilePath -> cmd -> IO a -> IO a +withWatcher False _ _ _ mx = mx +withWatcher True chan filePath cmd mx = do + mtime0 <- getModificationTime filePath + Async.withAsync (watcher mtime0) (\_ -> mx) + where + watcher mtime0 = do + -- The extra exists check helps because some editors temporarily make + -- the file disappear while writing. + exists <- doesFileExist filePath + mtime1 <- if exists then getModificationTime filePath else return mtime0 - when (mtime1 > mtime0) $ Chan.writeChan chan Reload - threadDelay (200 * 1000) - watcher chan filePath mtime1 + when (mtime1 > mtime0) $ Chan.writeChan chan cmd + threadDelay (200 * 1000) + watcher mtime1 -------------------------------------------------------------------------------- diff --git a/lib/Patat/Presentation.hs b/lib/Patat/Presentation.hs --- a/lib/Patat/Presentation.hs +++ b/lib/Patat/Presentation.hs @@ -8,7 +8,7 @@ , activeSpeakerNotes , Size - , getDisplaySize + , getPresentationSize , Display (..) , displayPresentation diff --git a/lib/Patat/Presentation/Comments.hs b/lib/Patat/Presentation/Comments.hs new file mode 100644 --- /dev/null +++ b/lib/Patat/Presentation/Comments.hs @@ -0,0 +1,174 @@ +-------------------------------------------------------------------------------- +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +module Patat.Presentation.Comments + ( Comment (..) + , parse + , remove + , split + , partition + + , SpeakerNotes + , speakerNotesToText + + , SpeakerNotesHandle + , withSpeakerNotesHandle + , writeSpeakerNotes + + , parseSlideSettings + ) where + + +-------------------------------------------------------------------------------- +import Control.Applicative ((<|>)) +import Control.Exception (bracket) +import Control.Monad (unless, when) +import Data.Function (on) +import qualified Data.IORef as IORef +import Data.List (intercalate, intersperse) +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.EncodingFallback (EncodingFallback) +import qualified Patat.EncodingFallback as EncodingFallback +import Patat.Presentation.Settings +import System.Directory (removeFile) +import qualified System.IO as IO +import qualified Text.Pandoc as Pandoc + + +-------------------------------------------------------------------------------- +data Comment = Comment + { cSpeakerNotes :: SpeakerNotes + , cConfig :: Either String PresentationSettings + } deriving (Show) + + +-------------------------------------------------------------------------------- +instance Semigroup Comment where + l <> r = Comment + { cSpeakerNotes = on (<>) cSpeakerNotes l r + , cConfig = case (cConfig l, cConfig r) of + (Left err, _ ) -> Left err + (Right _, Left err) -> Left err + (Right x, Right y ) -> Right (x <> y) + } + + +-------------------------------------------------------------------------------- +instance Monoid Comment where + mappend = (<>) + mempty = Comment mempty (Right mempty) + + +-------------------------------------------------------------------------------- +parse :: Pandoc.Block -> Maybe Comment +parse (Pandoc.RawBlock "html" t0) = + (do + t1 <- T.stripPrefix "" t1 + pure . Comment mempty $ case Yaml.decodeEither' (T.encodeUtf8 t2) of + Left err -> Left (show err) + Right obj -> Right obj) <|> + (do + t1 <- T.stripPrefix "" t1 + pure $ Comment (SpeakerNotes [T.strip t2]) (Right mempty)) +parse _ = Nothing + + +-------------------------------------------------------------------------------- +remove :: [Pandoc.Block] -> [Pandoc.Block] +remove = snd . partition + + +-------------------------------------------------------------------------------- +-- | Take all comments from the front of the list. Return those and the +-- remaining blocks. +split :: [Pandoc.Block] -> (Comment, [Pandoc.Block]) +split = go [] + where + go sn [] = (mconcat (reverse sn), []) + go sn (x : xs) | Just s <- parse x = go (s : sn) xs + go sn xs = (mconcat (reverse sn), xs) + + +-------------------------------------------------------------------------------- +-- | Partition the list into speaker notes and other blocks. +partition :: [Pandoc.Block] -> (Comment, [Pandoc.Block]) +partition = go [] [] + where + go sn bs [] = (mconcat (reverse sn), reverse bs) + go sn bs (x : xs) | Just s <- parse x = go (s : sn) bs xs + go sn bs (x : xs) = go sn (x : bs) xs + + +-------------------------------------------------------------------------------- +newtype SpeakerNotes = SpeakerNotes [T.Text] + deriving (Eq, Monoid, Semigroup, Show) + + +-------------------------------------------------------------------------------- +speakerNotesToText :: SpeakerNotes -> T.Text +speakerNotesToText (SpeakerNotes sn) = T.unlines $ intersperse mempty sn + + +-------------------------------------------------------------------------------- +data SpeakerNotesHandle = SpeakerNotesHandle + { snhSettings :: !SpeakerNotesSettings + , snhActive :: !(IORef.IORef SpeakerNotes) + } + + +-------------------------------------------------------------------------------- +withSpeakerNotesHandle + :: SpeakerNotesSettings -> (SpeakerNotesHandle -> IO a) -> IO a +withSpeakerNotesHandle settings = bracket + (SpeakerNotesHandle settings <$> IORef.newIORef mempty) + (\_ -> removeFile (snsFile settings)) + + +-------------------------------------------------------------------------------- +writeSpeakerNotes + :: SpeakerNotesHandle -> EncodingFallback -> SpeakerNotes -> IO () +writeSpeakerNotes h encodingFallback sn = do + change <- IORef.atomicModifyIORef' (snhActive h) $ \old -> (sn, old /= sn) + when change $ IO.withFile (snsFile $ snhSettings h) IO.WriteMode $ \ioh -> + EncodingFallback.withHandle ioh encodingFallback $ + T.hPutStr ioh $ speakerNotesToText sn + + +-------------------------------------------------------------------------------- +data Setting where + Setting :: String -> (PresentationSettings -> Maybe a) -> Setting + + +-------------------------------------------------------------------------------- +unsupportedSlideSettings :: [Setting] +unsupportedSlideSettings = + [ Setting "incrementalLists" psIncrementalLists + , Setting "autoAdvanceDelay" psAutoAdvanceDelay + , Setting "slideLevel" psSlideLevel + , Setting "pandocExtensions" psPandocExtensions + , Setting "images" psImages + , Setting "eval" psEval + , Setting "speakerNotes" psSpeakerNotes + ] + + +-------------------------------------------------------------------------------- +parseSlideSettings :: Comment -> Either String PresentationSettings +parseSlideSettings c = do + settings <- cConfig c + let unsupported = do + setting <- unsupportedSlideSettings + case setting of + Setting name f | Just _ <- f settings -> [name] + Setting _ _ -> [] + unless (null unsupported) $ Left $ + "the following settings are not supported in slide config blocks: " ++ + intercalate ", " unsupported + pure settings diff --git a/lib/Patat/Presentation/Display.hs b/lib/Patat/Presentation/Display.hs --- a/lib/Patat/Presentation/Display.hs +++ b/lib/Patat/Presentation/Display.hs @@ -2,10 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} module Patat.Presentation.Display - ( Size - , getDisplaySize - - , Display (..) + ( Display (..) , displayPresentation , displayPresentationError , dumpPresentation @@ -13,7 +10,7 @@ -------------------------------------------------------------------------------- -import Control.Monad (guard, mplus) +import Control.Monad (guard) import qualified Data.Aeson.Extended as A import Data.Char.WCWidth.Extended (wcstrwidth) import Data.Data.Extended (grecQ) @@ -21,39 +18,22 @@ import Data.Maybe (fromMaybe, maybeToList) import qualified Data.Sequence.Extended as Seq import qualified Data.Text as T +import qualified Patat.Presentation.Comments as Comments import Patat.Presentation.Display.CodeBlock import Patat.Presentation.Display.Internal import Patat.Presentation.Display.Table import Patat.Presentation.Internal -import qualified Patat.Presentation.SpeakerNotes as SpeakerNotes import Patat.PrettyPrint ((<$$>), (<+>)) import qualified Patat.PrettyPrint as PP +import Patat.Size import Patat.Theme (Theme (..)) import qualified Patat.Theme as Theme import Prelude -import qualified System.Console.Terminal.Size as Terminal import qualified Text.Pandoc.Extended as Pandoc import qualified Text.Pandoc.Writers.Shared as Pandoc -------------------------------------------------------------------------------- -data Size = Size {sRows :: Int, sCols :: Int} deriving (Show) - - --------------------------------------------------------------------------------- -getDisplaySize :: Presentation -> IO Size -getDisplaySize Presentation {..} = do - mbWindow <- Terminal.size - let sRows = fromMaybe 24 $ - (A.unFlexibleNum <$> psRows pSettings) `mplus` - (Terminal.height <$> mbWindow) - sCols = fromMaybe 72 $ - (A.unFlexibleNum <$> psColumns pSettings) `mplus` - (Terminal.width <$> mbWindow) - pure $ Size {..} - - --------------------------------------------------------------------------------- data Display = DisplayDoc PP.Doc | DisplayImage FilePath deriving (Show) @@ -62,13 +42,14 @@ -- the active slide number and so on. displayWithBorders :: Size -> Presentation -> (Size -> DisplaySettings -> PP.Doc) -> PP.Doc -displayWithBorders (Size rows columns) Presentation {..} f = +displayWithBorders (Size rows columns) pres@Presentation {..} f = (if null title then mempty else let titleRemainder = columns - titleWidth - titleOffset wrappedTitle = PP.spaces titleOffset <> PP.string title <> PP.spaces titleRemainder in - borders wrappedTitle <> PP.hardline <> PP.hardline) <> + borders wrappedTitle <> PP.hardline) <> + mconcat (replicate topMargin PP.hardline) <> formatWith settings (f canvasSize ds) <> PP.hardline <> PP.goToLine (rows - 2) <> borders (PP.space <> PP.string author <> middleSpaces <> PP.string active <> PP.space) <> @@ -76,7 +57,7 @@ where -- Get terminal width/title (sidx, _) = pActiveFragment - settings = pSettings {psColumns = Just $ A.FlexibleNum columns} + settings = (activeSettings pres) {psColumns = Just $ A.FlexibleNum columns} ds = DisplaySettings { dsTheme = fromMaybe Theme.defaultTheme (psTheme settings) , dsSyntaxMap = pSyntaxMap @@ -101,7 +82,8 @@ borders = themed ds themeBorders -- Room left for content - canvasSize = Size (rows - 2) columns + topMargin = mTop $ margins settings + canvasSize = Size (rows - 2 - topMargin) columns -- Compute footer. active @@ -127,12 +109,12 @@ prettyFragment theme fragment Just (ActiveTitle block) -> DisplayDoc $ displayWithBorders size pres $ \canvasSize theme -> - let pblock = prettyBlock theme block - (prows, pcols) = PP.dimensions pblock - (mLeft, mRight) = marginsOf pSettings - offsetRow = (sRows canvasSize `div` 2) - (prows `div` 2) - offsetCol = ((sCols canvasSize - mLeft - mRight) `div` 2) - (pcols `div` 2) - spaces = PP.NotTrimmable $ PP.spaces offsetCol in + let pblock = prettyBlock theme block + (prows, pcols) = PP.dimensions pblock + Margins {..} = margins (activeSettings pres) + offsetRow = (sRows canvasSize `div` 2) - (prows `div` 2) + offsetCol = ((sCols canvasSize - mLeft - mRight) `div` 2) - (pcols `div` 2) + spaces = PP.NotTrimmable $ PP.spaces offsetCol in mconcat (replicate (offsetRow - 3) PP.hardline) <$$> PP.indent spaces spaces pblock @@ -160,44 +142,50 @@ -------------------------------------------------------------------------------- dumpPresentation :: Presentation -> IO () dumpPresentation pres@Presentation {..} = - PP.putDoc $ PP.removeControls $ formatWith pSettings $ + PP.putDoc $ PP.removeControls $ PP.vcat $ L.intercalate ["{slide}"] $ map dumpSlide [0 .. length pSlides - 1] where dumpSlide :: Int -> [PP.Doc] dumpSlide i = do slide <- maybeToList $ getSlide i pres - dumpSpeakerNotes slide <> L.intercalate ["{fragment}"] - [ dumpFragment (i, j) - | j <- [0 .. numFragments slide - 1] - ] + map (formatWith (getSettings i pres)) $ + dumpComment slide <> L.intercalate ["{fragment}"] + [ dumpFragment (i, j) + | j <- [0 .. numFragments slide - 1] + ] - dumpSpeakerNotes :: Slide -> [PP.Doc] - dumpSpeakerNotes slide = do - guard $ slideSpeakerNotes slide /= mempty + dumpComment :: Slide -> [PP.Doc] + dumpComment slide = do + guard (Comments.cSpeakerNotes comment /= mempty) pure $ PP.text $ "{speakerNotes: " <> - SpeakerNotes.toText (slideSpeakerNotes slide) <> "}" + Comments.speakerNotesToText (Comments.cSpeakerNotes comment) <> "}" + where + comment = slideComment slide dumpFragment :: Index -> [PP.Doc] dumpFragment idx = - case displayPresentation size pres {pActiveFragment = idx} of + case displayPresentation (getSize idx) pres {pActiveFragment = idx} of DisplayDoc doc -> [doc] DisplayImage filepath -> [PP.string $ "{image: " ++ filepath ++ "}"] - sRows = fromMaybe 24 $ A.unFlexibleNum <$> psRows pSettings - sCols = fromMaybe 72 $ A.unFlexibleNum <$> psColumns pSettings - size = Size {..} + getSize :: Index -> Size + getSize idx = + let settings = activeSettings pres {pActiveFragment = idx} + sRows = fromMaybe 24 $ A.unFlexibleNum <$> psRows settings + sCols = fromMaybe 72 $ A.unFlexibleNum <$> psColumns settings in + Size {..} -------------------------------------------------------------------------------- formatWith :: PresentationSettings -> PP.Doc -> PP.Doc formatWith ps = wrap . indent where - (marginLeft, marginRight) = marginsOf ps + Margins {..} = margins ps wrap = case (psWrap ps, psColumns ps) of - (Just True, Just (A.FlexibleNum col)) -> PP.wrapAt (Just $ col - marginRight) + (Just True, Just (A.FlexibleNum col)) -> PP.wrapAt (Just $ col - mRight) _ -> id - spaces = PP.NotTrimmable $ PP.spaces marginLeft + spaces = PP.NotTrimmable $ PP.spaces mLeft indent = PP.indent spaces spaces diff --git a/lib/Patat/Presentation/Interactive.hs b/lib/Patat/Presentation/Interactive.hs --- a/lib/Patat/Presentation/Interactive.hs +++ b/lib/Patat/Presentation/Interactive.hs @@ -89,7 +89,6 @@ = UpdatedPresentation !Presentation | ExitedPresentation | ErroredPresentation String - deriving (Show) -------------------------------------------------------------------------------- diff --git a/lib/Patat/Presentation/Internal.hs b/lib/Patat/Presentation/Internal.hs --- a/lib/Patat/Presentation/Internal.hs +++ b/lib/Patat/Presentation/Internal.hs @@ -8,8 +8,9 @@ , PresentationSettings (..) , defaultPresentationSettings + , MarginSettings (..) , Margins (..) - , marginsOf + , margins , ExtensionList (..) , defaultExtensionList @@ -30,29 +31,29 @@ , ActiveFragment (..) , activeFragment , activeSpeakerNotes + + , getSettings + , activeSettings + + , Size + , getPresentationSize ) where -------------------------------------------------------------------------------- -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.Function (on) -import qualified Data.HashMap.Strict as HMS -import Data.List (intercalate) -import Data.Maybe (fromMaybe) -import Data.Sequence.Extended (Seq) -import qualified Data.Sequence.Extended as Seq -import qualified Data.Text as T -import Patat.EncodingFallback (EncodingFallback) -import qualified Patat.Presentation.Instruction as Instruction -import qualified Patat.Presentation.SpeakerNotes as SpeakerNotes -import qualified Patat.Theme as Theme +import qualified Data.Aeson.Extended as A +import Data.Maybe (fromMaybe) +import Data.Sequence.Extended (Seq) +import qualified Data.Sequence.Extended as Seq +import Patat.EncodingFallback (EncodingFallback) +import qualified Patat.Presentation.Comments as Comments +import qualified Patat.Presentation.Instruction as Instruction +import Patat.Presentation.Settings +import Patat.Size +import Patat.Transition (TransitionGen) import Prelude -import qualified Skylighting as Skylighting -import qualified Text.Pandoc as Pandoc -import Text.Read (readMaybe) +import qualified Skylighting as Skylighting +import qualified Text.Pandoc as Pandoc -------------------------------------------------------------------------------- @@ -67,204 +68,37 @@ , pAuthor :: ![Pandoc.Inline] , pSettings :: !PresentationSettings , pSlides :: !(Seq Slide) - , pBreadcrumbs :: !(Seq Breadcrumbs) -- One for each slide. + , pBreadcrumbs :: !(Seq Breadcrumbs) -- One for each slide. + , pSlideSettings :: !(Seq PresentationSettings) -- One for each slide. + , pTransitionGens :: !(Seq (Maybe TransitionGen)) -- One for each slide. , pActiveFragment :: !Index , pSyntaxMap :: !Skylighting.SyntaxMap - } deriving (Show) - - --------------------------------------------------------------------------------- --- | 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)) - , psMargins :: !(Maybe Margins) - , psWrap :: !(Maybe Bool) - , psTheme :: !(Maybe Theme.Theme) - , psIncrementalLists :: !(Maybe Bool) - , psAutoAdvanceDelay :: !(Maybe (A.FlexibleNum Int)) - , psSlideLevel :: !(Maybe Int) - , psPandocExtensions :: !(Maybe ExtensionList) - , psImages :: !(Maybe ImageSettings) - , psBreadcrumbs :: !(Maybe Bool) - , psEval :: !(Maybe EvalSettingsMap) - , psSlideNumber :: !(Maybe Bool) - , psSyntaxDefinitions :: !(Maybe [FilePath]) - , psSpeakerNotes :: !(Maybe SpeakerNotes.Settings) - } deriving (Show) - - --------------------------------------------------------------------------------- -instance Semigroup PresentationSettings where - l <> r = PresentationSettings - { psRows = on mplus psRows l r - , psColumns = on mplus psColumns l r - , psMargins = on (<>) psMargins l r - , psWrap = on mplus psWrap l r - , psTheme = on (<>) psTheme l r - , psIncrementalLists = on mplus psIncrementalLists l r - , psAutoAdvanceDelay = on mplus psAutoAdvanceDelay l r - , psSlideLevel = on mplus psSlideLevel l r - , psPandocExtensions = on mplus psPandocExtensions l r - , psImages = on mplus psImages l r - , psBreadcrumbs = on mplus psBreadcrumbs l r - , psEval = on (<>) psEval l r - , psSlideNumber = on mplus psSlideNumber l r - , psSyntaxDefinitions = on (<>) psSyntaxDefinitions l r - , psSpeakerNotes = on mplus psSpeakerNotes l r - } - - --------------------------------------------------------------------------------- -instance Monoid PresentationSettings where - mappend = (<>) - mempty = PresentationSettings - Nothing Nothing Nothing Nothing Nothing Nothing Nothing - Nothing Nothing Nothing Nothing Nothing Nothing Nothing - Nothing - - --------------------------------------------------------------------------------- -defaultPresentationSettings :: PresentationSettings -defaultPresentationSettings = mempty - { psMargins = Just defaultMargins - , psTheme = Just Theme.defaultTheme } -------------------------------------------------------------------------------- data Margins = Margins - { mLeft :: !(Maybe (A.FlexibleNum Int)) - , mRight :: !(Maybe (A.FlexibleNum Int)) + { mTop :: Int + , mLeft :: Int + , mRight :: Int } deriving (Show) -------------------------------------------------------------------------------- -instance Semigroup Margins where - l <> r = Margins - { mLeft = mLeft l `mplus` mLeft r - , mRight = mRight l `mplus` mRight r - } - - --------------------------------------------------------------------------------- -instance Monoid Margins where - mappend = (<>) - mempty = Margins Nothing Nothing - - --------------------------------------------------------------------------------- -defaultMargins :: Margins -defaultMargins = Margins - { mLeft = Nothing - , mRight = Nothing +margins :: PresentationSettings -> Margins +margins ps = Margins + { mLeft = get 0 msLeft + , mRight = get 0 msRight + , mTop = get 1 msTop } - - --------------------------------------------------------------------------------- -marginsOf :: PresentationSettings -> (Int, Int) -marginsOf presentationSettings = - (marginLeft, marginRight) where - margins = fromMaybe defaultMargins $ psMargins presentationSettings - marginLeft = fromMaybe 0 (A.unFlexibleNum <$> mLeft margins) - marginRight = fromMaybe 0 (A.unFlexibleNum <$> mRight margins) - - --------------------------------------------------------------------------------- -newtype ExtensionList = ExtensionList {unExtensionList :: Pandoc.Extensions} - deriving (Show) - - --------------------------------------------------------------------------------- -instance A.FromJSON ExtensionList where - parseJSON = A.withArray "FromJSON ExtensionList" $ - fmap (ExtensionList . mconcat) . mapM parseExt . Foldable.toList - where - parseExt = A.withText "FromJSON ExtensionList" $ \txt -> case txt of - -- Our default extensions - "patat_extensions" -> return (unExtensionList defaultExtensionList) - - -- Individuals - _ -> case readMaybe ("Ext_" ++ T.unpack txt) of - Just e -> return $ Pandoc.extensionsFromList [e] - Nothing -> fail $ - "Unknown extension: " ++ show txt ++ - ", known extensions are: " ++ - intercalate ", " (map (drop 4 . show) allExts) - where - -- This is an approximation since we can't enumerate extensions - -- anymore in the latest pandoc... - allExts = Pandoc.extensionsToList $ - Pandoc.getAllExtensions "markdown" - - --------------------------------------------------------------------------------- -defaultExtensionList :: ExtensionList -defaultExtensionList = ExtensionList $ - Pandoc.readerExtensions Pandoc.def `mappend` Pandoc.extensionsFromList - [ Pandoc.Ext_yaml_metadata_block - , Pandoc.Ext_table_captions - , Pandoc.Ext_simple_tables - , Pandoc.Ext_multiline_tables - , Pandoc.Ext_grid_tables - , Pandoc.Ext_pipe_tables - , Pandoc.Ext_raw_html - , Pandoc.Ext_tex_math_dollars - , Pandoc.Ext_fenced_code_blocks - , Pandoc.Ext_fenced_code_attributes - , Pandoc.Ext_backtick_code_blocks - , Pandoc.Ext_inline_code_attributes - , Pandoc.Ext_fancy_lists - , Pandoc.Ext_four_space_rule - , Pandoc.Ext_definition_lists - , Pandoc.Ext_compact_definition_lists - , Pandoc.Ext_example_lists - , Pandoc.Ext_strikeout - , Pandoc.Ext_superscript - , Pandoc.Ext_subscript - ] - - --------------------------------------------------------------------------------- -data ImageSettings = ImageSettings - { isBackend :: !T.Text - , isParams :: !A.Object - } deriving (Show) - - --------------------------------------------------------------------------------- -instance A.FromJSON ImageSettings where - parseJSON = A.withObject "FromJSON ImageSettings" $ \o -> do - t <- o A..: "backend" - return ImageSettings {isBackend = t, isParams = o} - - --------------------------------------------------------------------------------- -type EvalSettingsMap = HMS.HashMap T.Text EvalSettings - - --------------------------------------------------------------------------------- -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 + get def f = fromMaybe def . fmap A.unFlexibleNum $ psMargins ps >>= f -------------------------------------------------------------------------------- data Slide = Slide - { slideSpeakerNotes :: !SpeakerNotes.SpeakerNotes - , slideContent :: !SlideContent + { slideComment :: !Comments.Comment + , slideContent :: !SlideContent } deriving (Show) @@ -312,13 +146,32 @@ -------------------------------------------------------------------------------- -activeSpeakerNotes :: Presentation -> SpeakerNotes.SpeakerNotes +activeSpeakerNotes :: Presentation -> Comments.SpeakerNotes activeSpeakerNotes presentation = fromMaybe mempty $ do let (sidx, _) = pActiveFragment presentation slide <- getSlide sidx presentation - pure $ slideSpeakerNotes slide + pure . Comments.cSpeakerNotes $ slideComment slide -------------------------------------------------------------------------------- -$(A.deriveFromJSON A.dropPrefixOptions ''Margins) -$(A.deriveFromJSON A.dropPrefixOptions ''PresentationSettings) +getSettings :: Int -> Presentation -> PresentationSettings +getSettings sidx pres = + fromMaybe mempty (Seq.safeIndex (pSlideSettings pres) sidx) <> + pSettings pres + + +-------------------------------------------------------------------------------- +activeSettings :: Presentation -> PresentationSettings +activeSettings pres = + let (sidx, _) = pActiveFragment pres in getSettings sidx pres + + +-------------------------------------------------------------------------------- +getPresentationSize :: Presentation -> IO Size +getPresentationSize pres = do + term <- getTerminalSize + let rows = fromMaybe (sRows term) $ A.unFlexibleNum <$> psRows settings + cols = fromMaybe (sCols term) $ A.unFlexibleNum <$> psColumns settings + pure $ Size {sRows = rows, sCols = cols} + where + settings = activeSettings pres diff --git a/lib/Patat/Presentation/Read.hs b/lib/Patat/Presentation/Read.hs --- a/lib/Patat/Presentation/Read.hs +++ b/lib/Patat/Presentation/Read.hs @@ -13,35 +13,37 @@ -------------------------------------------------------------------------------- -import Control.Monad.Except (ExceptT (..), runExceptT, - throwError) -import Control.Monad.Trans (liftIO) -import qualified Data.Aeson as A -import qualified Data.Aeson.KeyMap as AKM -import Data.Bifunctor (first) -import Data.Maybe (fromMaybe) -import Data.Sequence.Extended (Seq) -import qualified Data.Sequence.Extended as Seq -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.Yaml as Yaml -import Patat.EncodingFallback (EncodingFallback) -import qualified Patat.EncodingFallback as EncodingFallback -import Patat.Eval (eval) +import Control.Monad.Except (ExceptT (..), runExceptT, + throwError) +import Control.Monad.Trans (liftIO) +import qualified Data.Aeson as A +import qualified Data.Aeson.KeyMap as AKM +import Data.Bifunctor (first) +import Data.Maybe (fromMaybe) +import Data.Sequence.Extended (Seq) +import qualified Data.Sequence.Extended as Seq +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Data.Traversable (for) +import qualified Data.Yaml as Yaml +import Patat.EncodingFallback (EncodingFallback) +import qualified Patat.EncodingFallback as EncodingFallback +import Patat.Eval (eval) +import qualified Patat.Presentation.Comments as Comments import Patat.Presentation.Fragment -import qualified Patat.Presentation.Instruction as Instruction +import qualified Patat.Presentation.Instruction as Instruction import Patat.Presentation.Internal -import qualified Patat.Presentation.SpeakerNotes as SpeakerNotes +import Patat.Transition (parseTransitionSettings) import Prelude -import qualified Skylighting as Skylighting -import System.Directory (XdgDirectory (XdgConfig), - doesFileExist, - getHomeDirectory, - getXdgDirectory) -import System.FilePath (splitFileName, takeExtension, - ()) -import qualified Text.Pandoc.Error as Pandoc -import qualified Text.Pandoc.Extended as Pandoc +import qualified Skylighting as Skylighting +import System.Directory (XdgDirectory (XdgConfig), + doesFileExist, + getHomeDirectory, + getXdgDirectory) +import System.FilePath (splitFileName, takeExtension, + ()) +import qualified Text.Pandoc.Error as Pandoc +import qualified Text.Pandoc.Extended as Pandoc -------------------------------------------------------------------------------- @@ -131,6 +133,15 @@ !pBreadcrumbs = collectBreadcrumbs pSlides !pActiveFragment = (0, 0) !pAuthor = concat (Pandoc.docAuthors meta) + pSlideSettings <- Seq.traverseWithIndex + (\i -> + first (\err -> "on slide " ++ show (i + 1) ++ ": " ++ err) . + Comments.parseSlideSettings . slideComment) + pSlides + pTransitionGens <- for pSlideSettings $ \slideSettings -> + case psTransition (slideSettings <> pSettings) of + Nothing -> pure Nothing + Just ts -> Just <$> parseTransitionSettings ts return Presentation {..} @@ -217,7 +228,7 @@ -- header that occurs before a non-header in the blocks. detectSlideLevel :: Pandoc.Pandoc -> Int detectSlideLevel (Pandoc.Pandoc _meta blocks0) = - go 6 $ SpeakerNotes.remove blocks0 + go 6 $ Comments.remove blocks0 where go level (Pandoc.Header n _ _ : x : xs) | n < level && not (isHeader x) = go n xs @@ -240,7 +251,7 @@ | otherwise = splitAtHeaders [] blocks0 where mkContentSlide :: [Pandoc.Block] -> [Slide] - mkContentSlide bs0 = case SpeakerNotes.partition bs0 of + mkContentSlide bs0 = case Comments.partition bs0 of (_, []) -> [] -- Never create empty slides (sn, bs1) -> pure . Slide sn . ContentSlide $ Instruction.fromList [Instruction.Append bs1] @@ -256,7 +267,7 @@ | i == slideLevel = mkContentSlide (reverse acc) ++ splitAtHeaders [b] bs0 | otherwise = - let (sn, bs1) = SpeakerNotes.split bs0 in + let (sn, bs1) = Comments.split bs0 in mkContentSlide (reverse acc) ++ [Slide sn $ TitleSlide i txt] ++ splitAtHeaders [] bs1 diff --git a/lib/Patat/Presentation/Settings.hs b/lib/Patat/Presentation/Settings.hs new file mode 100644 --- /dev/null +++ b/lib/Patat/Presentation/Settings.hs @@ -0,0 +1,236 @@ +-------------------------------------------------------------------------------- +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +module Patat.Presentation.Settings + ( PresentationSettings (..) + , defaultPresentationSettings + + , MarginSettings (..) + + , ExtensionList (..) + , defaultExtensionList + + , ImageSettings (..) + + , EvalSettingsMap + , EvalSettings (..) + + , SpeakerNotesSettings (..) + + , TransitionSettings (..) + ) where + + +-------------------------------------------------------------------------------- +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.Function (on) +import qualified Data.HashMap.Strict as HMS +import Data.List (intercalate) +import qualified Data.Text as T +import qualified Patat.Theme as Theme +import Prelude +import qualified Text.Pandoc as Pandoc +import Text.Read (readMaybe) + + +-------------------------------------------------------------------------------- +-- | 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)) + , psMargins :: !(Maybe MarginSettings) + , psWrap :: !(Maybe Bool) + , psTheme :: !(Maybe Theme.Theme) + , psIncrementalLists :: !(Maybe Bool) + , psAutoAdvanceDelay :: !(Maybe (A.FlexibleNum Int)) + , psSlideLevel :: !(Maybe Int) + , psPandocExtensions :: !(Maybe ExtensionList) + , psImages :: !(Maybe ImageSettings) + , psBreadcrumbs :: !(Maybe Bool) + , psEval :: !(Maybe EvalSettingsMap) + , psSlideNumber :: !(Maybe Bool) + , psSyntaxDefinitions :: !(Maybe [FilePath]) + , psSpeakerNotes :: !(Maybe SpeakerNotesSettings) + , psTransition :: !(Maybe TransitionSettings) + } deriving (Show) + + +-------------------------------------------------------------------------------- +instance Semigroup PresentationSettings where + l <> r = PresentationSettings + { psRows = on mplus psRows l r + , psColumns = on mplus psColumns l r + , psMargins = on (<>) psMargins l r + , psWrap = on mplus psWrap l r + , psTheme = on (<>) psTheme l r + , psIncrementalLists = on mplus psIncrementalLists l r + , psAutoAdvanceDelay = on mplus psAutoAdvanceDelay l r + , psSlideLevel = on mplus psSlideLevel l r + , psPandocExtensions = on mplus psPandocExtensions l r + , psImages = on mplus psImages l r + , psBreadcrumbs = on mplus psBreadcrumbs l r + , psEval = on (<>) psEval l r + , psSlideNumber = on mplus psSlideNumber l r + , psSyntaxDefinitions = on (<>) psSyntaxDefinitions l r + , psSpeakerNotes = on mplus psSpeakerNotes l r + , psTransition = on mplus psTransition l r + } + + +-------------------------------------------------------------------------------- +instance Monoid PresentationSettings where + mappend = (<>) + mempty = PresentationSettings + Nothing Nothing Nothing Nothing Nothing Nothing Nothing + Nothing Nothing Nothing Nothing Nothing Nothing Nothing + Nothing Nothing + + +-------------------------------------------------------------------------------- +defaultPresentationSettings :: PresentationSettings +defaultPresentationSettings = mempty + { psMargins = Nothing + , psTheme = Just Theme.defaultTheme + } + + +-------------------------------------------------------------------------------- +data MarginSettings = MarginSettings + { msTop :: !(Maybe (A.FlexibleNum Int)) + , msLeft :: !(Maybe (A.FlexibleNum Int)) + , msRight :: !(Maybe (A.FlexibleNum Int)) + } deriving (Show) + + +-------------------------------------------------------------------------------- +instance Semigroup MarginSettings where + l <> r = MarginSettings + { msTop = on mplus msTop l r + , msLeft = on mplus msLeft l r + , msRight = on mplus msRight l r + } + + +-------------------------------------------------------------------------------- +instance Monoid MarginSettings where + mappend = (<>) + mempty = MarginSettings Nothing Nothing Nothing + + +-------------------------------------------------------------------------------- +newtype ExtensionList = ExtensionList {unExtensionList :: Pandoc.Extensions} + deriving (Show) + + +-------------------------------------------------------------------------------- +instance A.FromJSON ExtensionList where + parseJSON = A.withArray "FromJSON ExtensionList" $ + fmap (ExtensionList . mconcat) . mapM parseExt . Foldable.toList + where + parseExt = A.withText "FromJSON ExtensionList" $ \txt -> case txt of + -- Our default extensions + "patat_extensions" -> return (unExtensionList defaultExtensionList) + + -- Individuals + _ -> case readMaybe ("Ext_" ++ T.unpack txt) of + Just e -> return $ Pandoc.extensionsFromList [e] + Nothing -> fail $ + "Unknown extension: " ++ show txt ++ + ", known extensions are: " ++ + intercalate ", " (map (drop 4 . show) allExts) + where + -- This is an approximation since we can't enumerate extensions + -- anymore in the latest pandoc... + allExts = Pandoc.extensionsToList $ + Pandoc.getAllExtensions "markdown" + + +-------------------------------------------------------------------------------- +defaultExtensionList :: ExtensionList +defaultExtensionList = ExtensionList $ + Pandoc.readerExtensions Pandoc.def `mappend` Pandoc.extensionsFromList + [ Pandoc.Ext_yaml_metadata_block + , Pandoc.Ext_table_captions + , Pandoc.Ext_simple_tables + , Pandoc.Ext_multiline_tables + , Pandoc.Ext_grid_tables + , Pandoc.Ext_pipe_tables + , Pandoc.Ext_raw_html + , Pandoc.Ext_tex_math_dollars + , Pandoc.Ext_fenced_code_blocks + , Pandoc.Ext_fenced_code_attributes + , Pandoc.Ext_backtick_code_blocks + , Pandoc.Ext_inline_code_attributes + , Pandoc.Ext_fancy_lists + , Pandoc.Ext_four_space_rule + , Pandoc.Ext_definition_lists + , Pandoc.Ext_compact_definition_lists + , Pandoc.Ext_example_lists + , Pandoc.Ext_strikeout + , Pandoc.Ext_superscript + , Pandoc.Ext_subscript + ] + + +-------------------------------------------------------------------------------- +data ImageSettings = ImageSettings + { isBackend :: !T.Text + , isParams :: !A.Object + } deriving (Show) + + +-------------------------------------------------------------------------------- +instance A.FromJSON ImageSettings where + parseJSON = A.withObject "FromJSON ImageSettings" $ \o -> do + t <- o A..: "backend" + return ImageSettings {isBackend = t, isParams = o} + + +-------------------------------------------------------------------------------- +type EvalSettingsMap = HMS.HashMap T.Text EvalSettings + + +-------------------------------------------------------------------------------- +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 SpeakerNotesSettings = SpeakerNotesSettings + { snsFile :: !FilePath + } deriving (Show) + + +-------------------------------------------------------------------------------- +data TransitionSettings = TransitionSettings + { tsType :: !T.Text + , tsParams :: !A.Object + } deriving (Show) + + +-------------------------------------------------------------------------------- +instance A.FromJSON TransitionSettings where + parseJSON = A.withObject "FromJSON TransitionSettings" $ \o -> + TransitionSettings <$> o A..: "type" <*> pure o + + +-------------------------------------------------------------------------------- +$(A.deriveFromJSON A.dropPrefixOptions ''MarginSettings) +$(A.deriveFromJSON A.dropPrefixOptions ''SpeakerNotesSettings) +$(A.deriveFromJSON A.dropPrefixOptions ''PresentationSettings) diff --git a/lib/Patat/Presentation/SpeakerNotes.hs b/lib/Patat/Presentation/SpeakerNotes.hs deleted file mode 100644 --- a/lib/Patat/Presentation/SpeakerNotes.hs +++ /dev/null @@ -1,110 +0,0 @@ --------------------------------------------------------------------------------- -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -module Patat.Presentation.SpeakerNotes - ( SpeakerNotes - , parse - , toText - , remove - , split - , partition - - , Settings - , Handle - , with - , write - ) where - - --------------------------------------------------------------------------------- -import Control.Exception (bracket) -import Control.Monad (when) -import qualified Data.Aeson.TH.Extended as A -import qualified Data.IORef as IORef -import Data.List (intersperse) -import qualified Data.Text as T -import qualified Data.Text.IO as T -import Patat.EncodingFallback (EncodingFallback) -import qualified Patat.EncodingFallback as EncodingFallback -import System.Directory (removeFile) -import qualified System.IO as IO -import qualified Text.Pandoc as Pandoc - - --------------------------------------------------------------------------------- -newtype SpeakerNotes = SpeakerNotes [T.Text] - deriving (Eq, Monoid, Semigroup, Show) - - --------------------------------------------------------------------------------- -parse :: Pandoc.Block -> Maybe SpeakerNotes -parse (Pandoc.RawBlock "html" t0) = do - t1 <- T.stripPrefix "" t1 - pure $ SpeakerNotes [T.strip t2] -parse _ = Nothing - - --------------------------------------------------------------------------------- -toText :: SpeakerNotes -> T.Text -toText (SpeakerNotes sn) = T.unlines $ intersperse mempty sn - - --------------------------------------------------------------------------------- -remove :: [Pandoc.Block] -> [Pandoc.Block] -remove = snd . partition - - --------------------------------------------------------------------------------- --- | Take all speaker notes from the front of the list. Return those and the --- remaining blocks. -split :: [Pandoc.Block] -> (SpeakerNotes, [Pandoc.Block]) -split = go [] - where - go sn [] = (mconcat (reverse sn), []) - go sn (x : xs) | Just s <- parse x = go (s : sn) xs - go sn xs = (mconcat (reverse sn), xs) - - --------------------------------------------------------------------------------- --- | Partition the list into speaker notes and other blocks. -partition :: [Pandoc.Block] -> (SpeakerNotes, [Pandoc.Block]) -partition = go [] [] - where - go sn bs [] = (mconcat (reverse sn), reverse bs) - go sn bs (x : xs) | Just s <- parse x = go (s : sn) bs xs - go sn bs (x : xs) = go sn (x : bs) xs - - --------------------------------------------------------------------------------- -data Settings = Settings - { sFile :: !FilePath - } deriving (Show) - - --------------------------------------------------------------------------------- -data Handle = Handle - { hSettings :: !Settings - , hActive :: !(IORef.IORef SpeakerNotes) - } - - --------------------------------------------------------------------------------- -with :: Settings -> (Handle -> IO a) -> IO a -with settings = bracket - (Handle settings <$> IORef.newIORef mempty) - (\_ -> removeFile (sFile settings)) - - --------------------------------------------------------------------------------- -write :: Handle -> EncodingFallback -> SpeakerNotes -> IO () -write h encodingFallback sn = do - change <- IORef.atomicModifyIORef' (hActive h) $ \old -> (sn, old /= sn) - when change $ IO.withFile (sFile $ hSettings h) IO.WriteMode $ \ioh -> - EncodingFallback.withHandle ioh encodingFallback $ - T.hPutStr ioh $ toText sn - - --------------------------------------------------------------------------------- -$(A.deriveFromJSON A.dropPrefixOptions ''Settings) diff --git a/lib/Patat/PrettyPrint.hs b/lib/Patat/PrettyPrint.hs --- a/lib/Patat/PrettyPrint.hs +++ b/lib/Patat/PrettyPrint.hs @@ -14,6 +14,7 @@ , hPutDoc , putDoc + , char , string , text , space @@ -46,292 +47,17 @@ -------------------------------------------------------------------------------- -import Control.Monad.Reader (asks, local) -import Control.Monad.RWS (RWS, runRWS) -import Control.Monad.State (get, gets, modify) -import Control.Monad.Writer (tell) import Data.Char.WCWidth.Extended (wcstrwidth) import qualified Data.List as L -import Data.String (IsString (..)) import qualified Data.Text as T +import Patat.PrettyPrint.Internal import Prelude hiding (null) import qualified System.Console.ANSI as Ansi -import qualified System.IO as IO -------------------------------------------------------------------------------- --- | Control actions for the terminal. -data Control - = ClearScreenControl - | GoToLineControl Int - deriving (Eq) - - --------------------------------------------------------------------------------- --- | A simple chunk of text. All ANSI codes are "reset" after printing. -data Chunk - = StringChunk [Ansi.SGR] String - | NewlineChunk - | ControlChunk Control - deriving (Eq) - - --------------------------------------------------------------------------------- -type Chunks = [Chunk] - - --------------------------------------------------------------------------------- -hPutChunk :: IO.Handle -> Chunk -> IO () -hPutChunk h NewlineChunk = IO.hPutStrLn h "" -hPutChunk h (StringChunk codes str) = do - Ansi.hSetSGR h (reverse codes) - IO.hPutStr h str - Ansi.hSetSGR h [Ansi.Reset] -hPutChunk h (ControlChunk ctrl) = case ctrl of - ClearScreenControl -> Ansi.hClearScreen h - GoToLineControl l -> Ansi.hSetCursorPosition h l 0 - - --------------------------------------------------------------------------------- -chunkToString :: Chunk -> String -chunkToString NewlineChunk = "\n" -chunkToString (StringChunk _ str) = str -chunkToString (ControlChunk _) = "" - - --------------------------------------------------------------------------------- --- | If two neighboring chunks have the same set of ANSI codes, we can group --- them together. -optimizeChunks :: Chunks -> Chunks -optimizeChunks (StringChunk c1 s1 : StringChunk c2 s2 : chunks) - | c1 == c2 = optimizeChunks (StringChunk c1 (s1 <> s2) : chunks) - | otherwise = - StringChunk c1 s1 : optimizeChunks (StringChunk c2 s2 : chunks) -optimizeChunks (x : chunks) = x : optimizeChunks chunks -optimizeChunks [] = [] - - --------------------------------------------------------------------------------- -chunkLines :: Chunks -> [Chunks] -chunkLines chunks = case break (== NewlineChunk) chunks of - (xs, _newline : ys) -> xs : chunkLines ys - (xs, []) -> [xs] - - --------------------------------------------------------------------------------- -data DocE d - = String String - | Softspace - | Hardspace - | Softline - | Hardline - | WrapAt - { wrapAtCol :: Maybe Int - , wrapDoc :: d - } - | Ansi - { ansiCode :: [Ansi.SGR] -> [Ansi.SGR] -- ^ Modifies current codes. - , ansiDoc :: d - } - | Indent - { indentFirstLine :: LineBuffer - , indentOtherLines :: LineBuffer - , indentDoc :: d - } - | Control Control - deriving (Functor) - - --------------------------------------------------------------------------------- -chunkToDocE :: Chunk -> DocE Doc -chunkToDocE NewlineChunk = Hardline -chunkToDocE (StringChunk c1 str) = Ansi (\c0 -> c1 ++ c0) (Doc [String str]) -chunkToDocE (ControlChunk ctrl) = Control ctrl - - --------------------------------------------------------------------------------- -newtype Doc = Doc {unDoc :: [DocE Doc]} - deriving (Monoid, Semigroup) - - --------------------------------------------------------------------------------- -instance IsString Doc where - fromString = string - - --------------------------------------------------------------------------------- -instance Show Doc where - show = toString - - --------------------------------------------------------------------------------- -data DocEnv = DocEnv - { deCodes :: [Ansi.SGR] -- ^ Most recent ones first in the list - , deIndent :: LineBuffer -- ^ Don't need to store first-line indent - , deWrap :: Maybe Int -- ^ Wrap at columns - } - - --------------------------------------------------------------------------------- -type DocM = RWS DocEnv Chunks LineBuffer - - --------------------------------------------------------------------------------- -data Trimmable a - = NotTrimmable !a - | Trimmable !a - deriving (Foldable, Functor, Traversable) - - --------------------------------------------------------------------------------- --- | Note that this is reversed so we have fast append -type LineBuffer = [Trimmable Chunk] - - --------------------------------------------------------------------------------- -bufferToChunks :: LineBuffer -> Chunks -bufferToChunks = map trimmableToChunk . reverse . dropWhile isTrimmable - where - isTrimmable (NotTrimmable _) = False - isTrimmable (Trimmable _) = True - - trimmableToChunk (NotTrimmable c) = c - trimmableToChunk (Trimmable c) = c - - --------------------------------------------------------------------------------- -docToChunks :: Doc -> Chunks -docToChunks doc0 = - let env0 = DocEnv [] [] Nothing - ((), b, cs) = runRWS (go $ unDoc doc0) env0 mempty in - optimizeChunks (cs <> bufferToChunks b) - where - go :: [DocE Doc] -> DocM () - - go [] = return () - - go (String str : docs) = do - chunk <- makeChunk str - modify (NotTrimmable chunk :) - go docs - - go (Softspace : docs) = do - hard <- softConversion Softspace docs - go (hard : docs) - - go (Hardspace : docs) = do - chunk <- makeChunk " " - modify (NotTrimmable chunk :) - go docs - - go (Softline : docs) = do - hard <- softConversion Softline docs - go (hard : docs) - - go (Hardline : docs) = do - buffer <- get - tell $ bufferToChunks buffer <> [NewlineChunk] - indentation <- asks deIndent - modify $ \_ -> if L.null docs then [] else indentation - go docs - - go (WrapAt {..} : docs) = do - local (\env -> env {deWrap = wrapAtCol}) $ go (unDoc wrapDoc) - go docs - - go (Ansi {..} : docs) = do - local (\env -> env {deCodes = ansiCode (deCodes env)}) $ - go (unDoc ansiDoc) - go docs - - go (Indent {..} : docs) = do - local (\env -> env {deIndent = indentOtherLines ++ deIndent env}) $ do - modify (indentFirstLine ++) - go (unDoc indentDoc) - go docs - - go (Control ctrl : docs) = do - tell [ControlChunk ctrl] - go docs - - - makeChunk :: String -> DocM Chunk - makeChunk str = do - codes <- asks deCodes - return $ StringChunk codes str - - -- Convert 'Softspace' or 'Softline' to 'Hardspace' or 'Hardline' - softConversion :: DocE Doc -> [DocE Doc] -> DocM (DocE Doc) - softConversion soft docs = do - mbWrapCol <- asks deWrap - case mbWrapCol of - Nothing -> return hard - Just maxCol -> do - -- Slow. - currentLine <- gets (concatMap chunkToString . bufferToChunks) - let currentCol = wcstrwidth currentLine - case nextWordLength docs of - Nothing -> return hard - Just l - | currentCol + 1 + l <= maxCol -> return Hardspace - | otherwise -> return Hardline - where - hard = case soft of - Softspace -> Hardspace - Softline -> Hardline - _ -> soft - - nextWordLength :: [DocE Doc] -> Maybe Int - nextWordLength [] = Nothing - nextWordLength (String x : xs) - | L.null x = nextWordLength xs - | otherwise = Just (wcstrwidth x) - nextWordLength (Softspace : xs) = nextWordLength xs - nextWordLength (Hardspace : xs) = nextWordLength xs - nextWordLength (Softline : xs) = nextWordLength xs - nextWordLength (Hardline : _) = Nothing - nextWordLength (WrapAt {..} : xs) = nextWordLength (unDoc wrapDoc ++ xs) - nextWordLength (Ansi {..} : xs) = nextWordLength (unDoc ansiDoc ++ xs) - nextWordLength (Indent {..} : xs) = nextWordLength (unDoc indentDoc ++ xs) - nextWordLength (Control _ : _) = Nothing - - --------------------------------------------------------------------------------- -toString :: Doc -> String -toString = concat . map chunkToString . docToChunks - - --------------------------------------------------------------------------------- --- | Returns the rows and columns necessary to render this document -dimensions :: Doc -> (Int, Int) -dimensions doc = - let ls = lines (toString doc) in - (length ls, foldr max 0 (map wcstrwidth ls)) - - --------------------------------------------------------------------------------- -null :: Doc -> Bool -null doc = case unDoc doc of [] -> True; _ -> False - - --------------------------------------------------------------------------------- -hPutDoc :: IO.Handle -> Doc -> IO () -hPutDoc h = mapM_ (hPutChunk h) . docToChunks - - --------------------------------------------------------------------------------- -putDoc :: Doc -> IO () -putDoc = hPutDoc IO.stdout - - --------------------------------------------------------------------------------- -mkDoc :: DocE Doc -> Doc -mkDoc e = Doc [e] - - --------------------------------------------------------------------------------- -string :: String -> Doc -string = mkDoc . String -- TODO (jaspervdj): Newline conversion +char :: Char -> Doc +char = string . pure -------------------------------------------------------------------------------- diff --git a/lib/Patat/PrettyPrint/Internal.hs b/lib/Patat/PrettyPrint/Internal.hs new file mode 100644 --- /dev/null +++ b/lib/Patat/PrettyPrint/Internal.hs @@ -0,0 +1,319 @@ +-------------------------------------------------------------------------------- +-- | This is a small pretty-printing library. +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE RecordWildCards #-} +module Patat.PrettyPrint.Internal + ( Control (..) + , Chunk (..) + , Chunks + , chunkToString + , chunkLines + + , DocE (..) + , chunkToDocE + + , Doc (..) + , docToChunks + + , Trimmable (..) + + , toString + , dimensions + , null + + , hPutDoc + , putDoc + , mkDoc + , string + ) where + + +-------------------------------------------------------------------------------- +import Control.Monad.Reader (asks, local) +import Control.Monad.RWS (RWS, runRWS) +import Control.Monad.State (get, gets, modify) +import Control.Monad.Writer (tell) +import Data.Char.WCWidth.Extended (wcstrwidth) +import qualified Data.List as L +import Data.String (IsString (..)) +import Prelude hiding (null) +import qualified System.Console.ANSI as Ansi +import qualified System.IO as IO + + +-------------------------------------------------------------------------------- +-- | Control actions for the terminal. +data Control + = ClearScreenControl + | GoToLineControl Int + deriving (Eq) + + +-------------------------------------------------------------------------------- +-- | A simple chunk of text. All ANSI codes are "reset" after printing. +data Chunk + = StringChunk [Ansi.SGR] String + | NewlineChunk + | ControlChunk Control + deriving (Eq) + + +-------------------------------------------------------------------------------- +type Chunks = [Chunk] + + +-------------------------------------------------------------------------------- +hPutChunk :: IO.Handle -> Chunk -> IO () +hPutChunk h NewlineChunk = IO.hPutStrLn h "" +hPutChunk h (StringChunk codes str) = do + Ansi.hSetSGR h (reverse codes) + IO.hPutStr h str + Ansi.hSetSGR h [Ansi.Reset] +hPutChunk h (ControlChunk ctrl) = case ctrl of + ClearScreenControl -> Ansi.hClearScreen h + GoToLineControl l -> Ansi.hSetCursorPosition h l 0 + + +-------------------------------------------------------------------------------- +chunkToString :: Chunk -> String +chunkToString NewlineChunk = "\n" +chunkToString (StringChunk _ str) = str +chunkToString (ControlChunk _) = "" + + +-------------------------------------------------------------------------------- +-- | If two neighboring chunks have the same set of ANSI codes, we can group +-- them together. +optimizeChunks :: Chunks -> Chunks +optimizeChunks (StringChunk c1 s1 : StringChunk c2 s2 : chunks) + | c1 == c2 = optimizeChunks (StringChunk c1 (s1 <> s2) : chunks) + | otherwise = + StringChunk c1 s1 : optimizeChunks (StringChunk c2 s2 : chunks) +optimizeChunks (x : chunks) = x : optimizeChunks chunks +optimizeChunks [] = [] + + +-------------------------------------------------------------------------------- +chunkLines :: Chunks -> [Chunks] +chunkLines chunks = case break (== NewlineChunk) chunks of + (xs, _newline : ys) -> xs : chunkLines ys + (xs, []) -> [xs] + + +-------------------------------------------------------------------------------- +data DocE d + = String String + | Softspace + | Hardspace + | Softline + | Hardline + | WrapAt + { wrapAtCol :: Maybe Int + , wrapDoc :: d + } + | Ansi + { ansiCode :: [Ansi.SGR] -> [Ansi.SGR] -- ^ Modifies current codes. + , ansiDoc :: d + } + | Indent + { indentFirstLine :: LineBuffer + , indentOtherLines :: LineBuffer + , indentDoc :: d + } + | Control Control + deriving (Functor) + + +-------------------------------------------------------------------------------- +chunkToDocE :: Chunk -> DocE Doc +chunkToDocE NewlineChunk = Hardline +chunkToDocE (StringChunk c1 str) = Ansi (\c0 -> c1 ++ c0) (Doc [String str]) +chunkToDocE (ControlChunk ctrl) = Control ctrl + + +-------------------------------------------------------------------------------- +newtype Doc = Doc {unDoc :: [DocE Doc]} + deriving (Monoid, Semigroup) + + +-------------------------------------------------------------------------------- +instance Show Doc where + show = toString + + +-------------------------------------------------------------------------------- +instance IsString Doc where + fromString = string + + +-------------------------------------------------------------------------------- +data DocEnv = DocEnv + { deCodes :: [Ansi.SGR] -- ^ Most recent ones first in the list + , deIndent :: LineBuffer -- ^ Don't need to store first-line indent + , deWrap :: Maybe Int -- ^ Wrap at columns + } + + +-------------------------------------------------------------------------------- +type DocM = RWS DocEnv Chunks LineBuffer + + +-------------------------------------------------------------------------------- +data Trimmable a + = NotTrimmable !a + | Trimmable !a + deriving (Foldable, Functor, Traversable) + + +-------------------------------------------------------------------------------- +-- | Note that this is reversed so we have fast append +type LineBuffer = [Trimmable Chunk] + + +-------------------------------------------------------------------------------- +bufferToChunks :: LineBuffer -> Chunks +bufferToChunks = map trimmableToChunk . reverse . dropWhile isTrimmable + where + isTrimmable (NotTrimmable _) = False + isTrimmable (Trimmable _) = True + + trimmableToChunk (NotTrimmable c) = c + trimmableToChunk (Trimmable c) = c + + +-------------------------------------------------------------------------------- +docToChunks :: Doc -> Chunks +docToChunks doc0 = + let env0 = DocEnv [] [] Nothing + ((), b, cs) = runRWS (go $ unDoc doc0) env0 mempty in + optimizeChunks (cs <> bufferToChunks b) + where + go :: [DocE Doc] -> DocM () + + go [] = return () + + go (String str : docs) = do + chunk <- makeChunk str + modify (NotTrimmable chunk :) + go docs + + go (Softspace : docs) = do + hard <- softConversion Softspace docs + go (hard : docs) + + go (Hardspace : docs) = do + chunk <- makeChunk " " + modify (NotTrimmable chunk :) + go docs + + go (Softline : docs) = do + hard <- softConversion Softline docs + go (hard : docs) + + go (Hardline : docs) = do + buffer <- get + tell $ bufferToChunks buffer <> [NewlineChunk] + indentation <- asks deIndent + modify $ \_ -> if L.null docs then [] else indentation + go docs + + go (WrapAt {..} : docs) = do + local (\env -> env {deWrap = wrapAtCol}) $ go (unDoc wrapDoc) + go docs + + go (Ansi {..} : docs) = do + local (\env -> env {deCodes = ansiCode (deCodes env)}) $ + go (unDoc ansiDoc) + go docs + + go (Indent {..} : docs) = do + local (\env -> env {deIndent = indentOtherLines ++ deIndent env}) $ do + modify (indentFirstLine ++) + go (unDoc indentDoc) + go docs + + go (Control ctrl : docs) = do + tell [ControlChunk ctrl] + go docs + + + makeChunk :: String -> DocM Chunk + makeChunk str = do + codes <- asks deCodes + return $ StringChunk codes str + + -- Convert 'Softspace' or 'Softline' to 'Hardspace' or 'Hardline' + softConversion :: DocE Doc -> [DocE Doc] -> DocM (DocE Doc) + softConversion soft docs = do + mbWrapCol <- asks deWrap + case mbWrapCol of + Nothing -> return hard + Just maxCol -> do + -- Slow. + currentLine <- gets (concatMap chunkToString . bufferToChunks) + let currentCol = wcstrwidth currentLine + case nextWordLength docs of + Nothing -> return hard + Just l + | currentCol + 1 + l <= maxCol -> return Hardspace + | otherwise -> return Hardline + where + hard = case soft of + Softspace -> Hardspace + Softline -> Hardline + _ -> soft + + nextWordLength :: [DocE Doc] -> Maybe Int + nextWordLength [] = Nothing + nextWordLength (String x : xs) + | L.null x = nextWordLength xs + | otherwise = Just (wcstrwidth x) + nextWordLength (Softspace : xs) = nextWordLength xs + nextWordLength (Hardspace : xs) = nextWordLength xs + nextWordLength (Softline : xs) = nextWordLength xs + nextWordLength (Hardline : _) = Nothing + nextWordLength (WrapAt {..} : xs) = nextWordLength (unDoc wrapDoc ++ xs) + nextWordLength (Ansi {..} : xs) = nextWordLength (unDoc ansiDoc ++ xs) + nextWordLength (Indent {..} : xs) = nextWordLength (unDoc indentDoc ++ xs) + nextWordLength (Control _ : _) = Nothing + + +-------------------------------------------------------------------------------- +toString :: Doc -> String +toString = concat . map chunkToString . docToChunks + + +-------------------------------------------------------------------------------- +-- | Returns the rows and columns necessary to render this document +dimensions :: Doc -> (Int, Int) +dimensions doc = + let ls = lines (toString doc) in + (length ls, foldr max 0 (map wcstrwidth ls)) + + +-------------------------------------------------------------------------------- +null :: Doc -> Bool +null doc = case unDoc doc of [] -> True; _ -> False + + +-------------------------------------------------------------------------------- +hPutDoc :: IO.Handle -> Doc -> IO () +hPutDoc h = mapM_ (hPutChunk h) . docToChunks + + +-------------------------------------------------------------------------------- +putDoc :: Doc -> IO () +putDoc = hPutDoc IO.stdout + + +-------------------------------------------------------------------------------- +mkDoc :: DocE Doc -> Doc +mkDoc e = Doc [e] + + +-------------------------------------------------------------------------------- +string :: String -> Doc +string = mkDoc . String -- TODO (jaspervdj): Newline conversion? diff --git a/lib/Patat/PrettyPrint/Matrix.hs b/lib/Patat/PrettyPrint/Matrix.hs new file mode 100644 --- /dev/null +++ b/lib/Patat/PrettyPrint/Matrix.hs @@ -0,0 +1,75 @@ +-------------------------------------------------------------------------------- +{-# LANGUAGE BangPatterns #-} +module Patat.PrettyPrint.Matrix + ( Matrix + , Cell (..) + , emptyCell + , docToMatrix + , hPutMatrix + ) where + + +-------------------------------------------------------------------------------- +import Control.Monad (unless, when) +import Data.Char.WCWidth.Extended (wcwidth) +import qualified Data.Vector as V +import qualified Data.Vector.Mutable as VM +import Patat.PrettyPrint.Internal hiding (null) +import Patat.Size (Size (..)) +import qualified System.Console.ANSI as Ansi +import qualified System.IO as IO + + +-------------------------------------------------------------------------------- +data Cell = Cell [Ansi.SGR] Char deriving (Eq, Show) + + +-------------------------------------------------------------------------------- +type Matrix = V.Vector Cell + + +-------------------------------------------------------------------------------- +emptyCell :: Cell +emptyCell = Cell [] ' ' + + +-------------------------------------------------------------------------------- +docToMatrix :: Size -> Doc -> Matrix +docToMatrix size doc = V.create $ do + matrix <- VM.replicate (sRows size * sCols size) emptyCell + go matrix 0 0 $ docToChunks doc + pure matrix + where + go _ _ _ [] = pure () + go _ y _ _ | y >= sRows size = pure () + go r y _ (NewlineChunk : cs) = go r (y + 1) 0 cs + go r y x cs | x > sCols size = go r (y + 1) 0 cs + go r y x (ControlChunk ClearScreenControl : cs) = go r y x cs -- ? + go r _ x (ControlChunk (GoToLineControl y) : cs) = go r y x cs + go r y x (StringChunk _ [] : cs) = go r y x cs + go r y x (StringChunk codes (z : zs) : cs) = do + VM.write r (y * sCols size + x) (Cell codes z) + go r y (x + wcwidth z) (StringChunk codes zs : cs) + + +-------------------------------------------------------------------------------- +hPutMatrix :: IO.Handle -> Size -> Matrix -> IO () +hPutMatrix h size matrix = go 0 0 0 [] + where + go !y !x !empties prevCodes + | x >= sCols size = IO.hPutStrLn h "" >> go (y + 1) 0 0 prevCodes + | y >= sRows size = Ansi.hSetSGR h [Ansi.Reset] + -- Try to not print empty things (e.g. fill the screen with spaces) as + -- an optimization. Instead, store the number of empties and print them + -- when something actually follows. + | cell == emptyCell = do + unless (null prevCodes) $ Ansi.hSetSGR h [Ansi.Reset] + go y (x + 1) (empties + 1) [] + | otherwise = do + unless (empties == 0) $ IO.hPutStr h (replicate empties ' ') + when (prevCodes /= codes) $ + Ansi.hSetSGR h (Ansi.Reset : reverse codes) + IO.hPutStr h [c] + go y (x + wcwidth c) 0 codes + where + cell@(Cell codes c) = matrix V.! (y * sCols size + x) diff --git a/lib/Patat/Size.hs b/lib/Patat/Size.hs new file mode 100644 --- /dev/null +++ b/lib/Patat/Size.hs @@ -0,0 +1,23 @@ +-------------------------------------------------------------------------------- +module Patat.Size + ( Size (..) + , getTerminalSize + ) where + + +-------------------------------------------------------------------------------- +import Data.Maybe (fromMaybe) +import qualified System.Console.Terminal.Size as Terminal + + +-------------------------------------------------------------------------------- +data Size = Size {sRows :: Int, sCols :: Int} deriving (Show) + + +-------------------------------------------------------------------------------- +getTerminalSize :: IO Size +getTerminalSize = do + mbWindow <- Terminal.size + let rows = fromMaybe 24 $ Terminal.height <$> mbWindow + cols = fromMaybe 72 $ Terminal.width <$> mbWindow + pure $ Size {sRows = rows, sCols = cols} diff --git a/lib/Patat/Transition.hs b/lib/Patat/Transition.hs new file mode 100644 --- /dev/null +++ b/lib/Patat/Transition.hs @@ -0,0 +1,42 @@ +-------------------------------------------------------------------------------- +{-# LANGUAGE OverloadedStrings #-} +module Patat.Transition + ( Duration (..) + , threadDelayDuration + , TransitionGen + , TransitionId + , TransitionInstance (..) + , parseTransitionSettings + , newTransition + , stepTransition + ) where + + +-------------------------------------------------------------------------------- +import qualified Data.Aeson as A +import qualified Data.HashMap.Strict as HMS +import Data.Text (Text) +import qualified Data.Text as T +import Patat.Presentation.Settings (TransitionSettings (..)) +import Patat.Transition.Internal +import qualified Patat.Transition.SlideLeft as SlideLeft + + +-------------------------------------------------------------------------------- +transitions :: HMS.HashMap Text Transition +transitions = HMS.fromList + [ ("slideLeft", Transition SlideLeft.slideLeft) + ] + + +-------------------------------------------------------------------------------- +parseTransitionSettings + :: TransitionSettings -> Either String TransitionGen +parseTransitionSettings ts = case HMS.lookup ty transitions of + Nothing -> Left $ "unknown transition type: " ++ show ty + Just (Transition f) -> case A.fromJSON (A.Object $ tsParams ts) of + A.Success conf -> Right $ f conf + A.Error err -> Left $ + "could not parse " ++ T.unpack ty ++ " transition: " ++ err + where + ty = tsType ts diff --git a/lib/Patat/Transition/Internal.hs b/lib/Patat/Transition/Internal.hs new file mode 100644 --- /dev/null +++ b/lib/Patat/Transition/Internal.hs @@ -0,0 +1,81 @@ +-------------------------------------------------------------------------------- +{-# LANGUAGE GADTs #-} +module Patat.Transition.Internal + ( Duration (..) + , threadDelayDuration + + , Transition (..) + , TransitionGen + , TransitionId + , TransitionInstance (..) + , newTransition + , stepTransition + ) where + + +-------------------------------------------------------------------------------- +import Control.Concurrent (threadDelay) +import qualified Data.Aeson as A +import Data.List.NonEmpty (NonEmpty ((:|))) +import Data.Unique (Unique, newUnique) +import qualified Patat.PrettyPrint as PP +import Patat.PrettyPrint.Matrix +import Patat.Size (Size (..)) +import System.Random (StdGen, newStdGen) + + +-------------------------------------------------------------------------------- +newtype Duration = Duration Double -- Duration in seconds + deriving (Show) + + +-------------------------------------------------------------------------------- +threadDelayDuration :: Duration -> IO () +threadDelayDuration (Duration seconds) = + threadDelay . round $ seconds * 1000 * 1000 + + +-------------------------------------------------------------------------------- +data Transition where + Transition :: A.FromJSON conf => (conf -> TransitionGen) -> Transition + + +-------------------------------------------------------------------------------- +type TransitionGen = + Size -> Matrix -> Matrix -> StdGen -> NonEmpty (Matrix, Duration) + + +-------------------------------------------------------------------------------- +newtype TransitionId = TransitionId Unique deriving (Eq) + + +-------------------------------------------------------------------------------- +data TransitionInstance = TransitionInstance + { tiId :: TransitionId + , tiSize :: Size + , tiFrames :: NonEmpty (Matrix, Duration) + } + + +-------------------------------------------------------------------------------- +newTransition + :: TransitionGen -> Size -> PP.Doc -> PP.Doc -> IO TransitionInstance +newTransition tgen termSize frame0 frame1 = do + unique <- newUnique + rgen <- newStdGen + let frames = tgen size matrix0 matrix1 rgen + pure $ TransitionInstance (TransitionId unique) size frames + where + -- The actual part we want to animate does not cover the last row, which is + -- always empty. + size = termSize {sRows = sRows termSize - 1} + matrix0 = docToMatrix size frame0 + matrix1 = docToMatrix size frame1 + + +-------------------------------------------------------------------------------- +stepTransition :: TransitionId -> TransitionInstance -> Maybe TransitionInstance +stepTransition transId trans | transId /= tiId trans = Just trans +stepTransition _ trans = case tiFrames trans of + _ :| [] -> Nothing + _ :| f : fs -> Just trans {tiFrames = f :| fs} diff --git a/lib/Patat/Transition/SlideLeft.hs b/lib/Patat/Transition/SlideLeft.hs new file mode 100644 --- /dev/null +++ b/lib/Patat/Transition/SlideLeft.hs @@ -0,0 +1,59 @@ +-------------------------------------------------------------------------------- +{-# LANGUAGE TemplateHaskell #-} +module Patat.Transition.SlideLeft + ( slideLeft + ) where + + +-------------------------------------------------------------------------------- +import qualified Data.Aeson.Extended as A +import qualified Data.Aeson.TH.Extended as A +import Data.Foldable (for_) +import Data.List.NonEmpty (NonEmpty ((:|))) +import Data.Maybe (fromMaybe) +import qualified Data.Vector as V +import qualified Data.Vector.Mutable as VM +import Patat.PrettyPrint.Matrix +import Patat.Size (Size (..)) +import Patat.Transition.Internal + + +-------------------------------------------------------------------------------- +data Config = Config + { cDuration :: Maybe (A.FlexibleNum Double) + , cFrameRate :: Maybe (A.FlexibleNum Int) + } + + +-------------------------------------------------------------------------------- +slideLeft :: Config -> TransitionGen +slideLeft config (Size rows cols) initial final _rgen = + fmap (\f -> (f, Duration delay)) $ + frame 0 :| map frame [1 .. frames - 1] + where + duration = fromMaybe 1 $ A.unFlexibleNum <$> cDuration config + frameRate = fromMaybe 24 $ A.unFlexibleNum <$> cFrameRate config + + frames = round $ duration * fromIntegral frameRate :: Int + delay = duration / fromIntegral (frames + 1) + + frame :: Int -> Matrix + frame idx = V.create $ do + ini <- V.unsafeThaw initial + fin <- V.unsafeThaw final + mat <- VM.replicate (rows * cols) emptyCell + for_ [0 .. rows - 1] $ \y -> do + VM.copy + (VM.slice (y * cols) (cols - offset) mat) + (VM.slice (y * cols + offset) (cols - offset) ini) + VM.copy + (VM.slice (y * cols + cols - offset) offset mat) + (VM.slice (y * cols) offset fin) + pure mat + where + offset = max 0 . min cols . (round :: Double -> Int) $ + fromIntegral (idx + 1) / fromIntegral frames * fromIntegral cols + + +-------------------------------------------------------------------------------- +$(A.deriveFromJSON A.dropPrefixOptions ''Config) diff --git a/patat.cabal b/patat.cabal --- a/patat.cabal +++ b/patat.cabal @@ -1,5 +1,5 @@ Name: patat -Version: 0.9.2.0 +Version: 0.10.0.0 Synopsis: Terminal-based presentations using Pandoc Description: Terminal-based presentations using Pandoc. License: GPL-2 @@ -47,12 +47,14 @@ pandoc >= 3.1 && < 3.2, pandoc-types >= 1.23 && < 1.24, process >= 1.6 && < 1.7, + random >= 1.1 && < 1.3, skylighting >= 0.10 && < 0.15, terminal-size >= 0.3 && < 0.4, text >= 1.2 && < 2.1, time >= 1.4 && < 1.13, unordered-containers >= 0.2 && < 0.3, yaml >= 0.8 && < 0.12, + vector >= 0.13 && < 0.14, wcwidth >= 0.0 && < 0.1, -- We don't even depend on these packages but they can break cabal install -- because of the conflicting 'Network.URI' module. @@ -75,6 +77,7 @@ Patat.Images.W3m Patat.Main Patat.Presentation + Patat.Presentation.Comments Patat.Presentation.Display Patat.Presentation.Display.CodeBlock Patat.Presentation.Display.Internal @@ -84,11 +87,18 @@ Patat.Presentation.Interactive Patat.Presentation.Internal Patat.Presentation.Read - Patat.Presentation.SpeakerNotes + Patat.Presentation.Settings Patat.PrettyPrint + Patat.PrettyPrint.Internal + Patat.PrettyPrint.Matrix + Patat.Size Patat.Theme + Patat.Transition + Patat.Transition.Internal + Patat.Transition.SlideLeft Other-modules: + Control.Concurrent.Chan.Extended Data.Aeson.Extended Data.Aeson.TH.Extended Data.Char.WCWidth.Extended