diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,238 +1,333 @@ # Changelog -- 0.8.9.0 (2023-06-27) - * Apply block quote theming to entire block (#119) (#111) - * Fix table header theming (#128) - * Dependency updates: - - `aeson` to 2.1 - - `optparse-applicative` to 0.18 - - `pandoc` to 3.1 - - `pandoc-types` to 1.23 - - `text` to 2.0 - - `time` to 1.12 +## 0.9.0.0 (2023-09-13) -- 0.8.8.0 (2022-10-26) - * Allow hiding slide number (contribution by Paweł Dybiec) - * Support additional markdown extensions (contribution by Spreadcat) - * Dependency updates: - - `aeson` to 2.0 - - `ansi-terminal` to 0.11 - - `base64-bytestring` to 1.2 - - `bytestring` to 0.11 - - `optparse-applicative` to 1.16 - - `pandoc` to 2.19 - - `skylighting` to 0.13 + * Add proper support for speaker notes (#142) -- 0.8.7.0 (2021-03-12) - * Fix alignment and display of CJK characters in presentation title, author - and tables - * Add support for showing images in Kitty terminal - * Search in `$PATH` for `w3mimgdisplay` - * Bump `pandoc` dependency to 2.11 - * Refactor `Patat.Presentation.Display` module to make it pure + You can configure `patat` to write the speaker notes for the current slide + to a file whenever the slide changes: -- 0.8.6.1 (2020-09-18) - * Fix issue with laziness for evaluted code blocks, they should only be - evaluated when we actually want to show them - * Bump stack resolver to `lts-16.9` + patat: + speakerNotes: + file: /tmp/notes.txt -- 0.8.6.0 (2020-09-11) - * Allow evaluating code blocks (see README for more info) - * Refactor implementation of fragments - * Add breadcrumbs to title based on headers - * Error out when YAML parsing fails + Then, you can display these in a second terminal (presumably on a second + monitor) by just displaying this file whenever it changes. [entr] is one + way to do that: -- 0.8.5.0 (2020-06-29) - * Bump `pandoc` dependency to 2.9 - * Switch to `goldplate` for testing + echo /tmp/notes.txt | entr -s 'clear; cat /tmp/notes.txt' -- 0.8.4.3 (2020-01-21) - * Fix Haddock syntax in some comments (contribution by Asad Saeeduddin) + [entr]: http://eradman.com/entrproject/ -- 0.8.4.2 (2020-01-18) - * Add builds for Mac OS - * Refactor CircleCI config & Makefile + Alternatively, just use a second `patat` instance with `--watch` enabled: -- 0.8.4.1 (2019-10-29) - * Bump CircleCI configuration - * Bump release script - * Add slide seeking to `--help` output + patat -w /tmp/notes.txt -- 0.8.4.0 (2019-10-09) - * Add slide seeking (enter slide number + `enter`) - * Fix turning tty echo off/on during presentation - * Run `w3mimgdisplay` cleanup action, fixing image issues on some terminals + * Add support for showing plain text files (#141) -- 0.8.3.0 (2019-09-07) - * Fix test failure again, and ensure that it works for multiple pandoc - versions by slightly modifying test input - * Include pandoc version info in `patat --version` + This isn't super useful on its own, it's meant to support speaker notes. -- 0.8.2.5 (2019-08-12) - * Fix test failure caused by slightly different pandoc output for lists + * Add syntaxDefinitions to settings (#140) -- 0.8.2.4 (2019-08-12) - * Bump `optparse-applicative` upper bound to 0.16 - * Bump `skylighting` upper bound to 0.9 + This allows users to add custom kate highlighting XML files in the settings: -- 0.8.2.3 (2019-06-25) - * Bump upper `pandoc` dependency to 2.8 + --- + patat: + syntaxDefinitions: + - 'impurescript.xml' + ... -- 0.8.2.2 (2019-02-04) - * Bump lower `base` dependency to 4.8 + Here is some *im*purescript: -- 0.8.2.1 (2019-02-03) - * Bump `pandoc` to 2.6 - * Bump `ansi-terminal` to 0.10 + ```impurescript + ... + ``` -- 0.8.2.0 (2019-01-24) - * GHC 7.8 compatibility +## 0.8.9.0 (2023-06-27) -- 0.8.1.3 (2019-01-24) - * Bump `pandoc` to 2.4 - * Bump `yaml` to 0.11 +* Apply block quote theming to entire block (#119) (#111) +* Fix table header theming (#128) +* Dependency updates: + - `aeson` to 2.1 + - `optparse-applicative` to 0.18 + - `pandoc` to 3.1 + - `pandoc-types` to 1.23 + - `text` to 2.0 + - `time` to 1.12 -- 0.8.1.2 (2018-10-29) - * Work around test failure caused by slightly different syntax highlighting - in different pandoc versions +## 0.8.8.0 (2022-10-26) -- 0.8.1.1 (2018-10-26) - * Tickle CircleCI cache +* Allow hiding slide number (contribution by Paweł Dybiec) +* Support additional markdown extensions (contribution by Spreadcat) +* Dependency updates: + - `aeson` to 2.0 + - `ansi-terminal` to 0.11 + - `base64-bytestring` to 1.2 + - `bytestring` to 0.11 + - `optparse-applicative` to 1.16 + - `pandoc` to 2.19 + - `skylighting` to 0.13 -- 0.8.1.0 (2018-10-26) - * Add support for italic ansi code in themes - * Fix centered titles not being centered (contribution by Hamza Haiken) +## 0.8.7.0 (2021-03-12) -- 0.8.0.0 (2018-08-31) - * Themed border rendering improvements (contribution by Hamza Haiken) - * Add support for margins (contribution by Hamza Haiken) - * Add RGB colour support for themes (contribution by Hamza Haiken) - * Add experimental images support - * Add images support for iTerm2 (contribution by @2mol) +* Fix alignment and display of CJK characters in presentation title, author + and tables +* Add support for showing images in Kitty terminal +* Search in `$PATH` for `w3mimgdisplay` +* Bump `pandoc` dependency to 2.11 +* Refactor `Patat.Presentation.Display` module to make it pure -- 0.7.2.0 (2018-05-08) - * GHC 8.4 compatibility +## 0.8.6.1 (2020-09-18) -- 0.7.1.0 (2018-05-08) - * GHC 8.4 compatibility +* Fix issue with laziness for evaluted code blocks, they should only be + evaluated when we actually want to show them +* Bump stack resolver to `lts-16.9` -- 0.7.0.0 (2018-05-04) - * Support HTML-style comments +## 0.8.6.0 (2020-09-11) -- 0.6.1.2 (2018-04-30) - * Bump `pandoc` to 2.2 +* Allow evaluating code blocks (see README for more info) +* Refactor implementation of fragments +* Add breadcrumbs to title based on headers +* Error out when YAML parsing fails -- 0.6.1.1 (2018-04-27) - * Bump `aeson` to 1.3 - * Bump `skylighting` to 0.7 - * Bump `time` to 1.9 - * Bump `ansi-terminal` to 0.8 +## 0.8.5.0 (2020-06-29) -- 0.6.1.0 (2018-01-28) - * Bump `skylighting` to 0.6 - * Bump `pandoc` to 2.1 - * Bump `ansi-terminal` to 0.7 +* Bump `pandoc` dependency to 2.9 +* Switch to `goldplate` for testing -- 0.6.0.1 (2017-12-24) - * Automatically upload linux binary to GitHub +## 0.8.4.3 (2020-01-21) -- 0.6.0.0 (2017-12-19) - * Make pandoc extensions customizable in the configuration - * Bump `pandoc` to 2.0 +* Fix Haddock syntax in some comments (contribution by Asad Saeeduddin) -- 0.5.2.2 (2017-06-14) - * Add `network-uri` dependency to fix travis build +## 0.8.4.2 (2020-01-18) -- 0.5.2.1 (2017-06-14) - * Bump `optparse-applicative-0.14` dependency +* Add builds for Mac OS +* Refactor CircleCI config & Makefile -- 0.5.2.0 (2017-05-16) - * Add navigation using `PageUp` and `PageDown`. - * Use `skylighting` instead of deprecated `highlighting-kate` for syntax - highlighting. +## 0.8.4.1 (2019-10-29) -- 0.5.1.2 (2017-04-26) - * Make build reproducible even if timezone changes (patch by Félix Sipma) +* Bump CircleCI configuration +* Bump release script +* Add slide seeking to `--help` output -- 0.5.1.1 (2017-04-23) - * Include `README` in `Extra-source-files` so it gets displayed on Hackage +## 0.8.4.0 (2019-10-09) -- 0.5.1.0 (2017-04-23) - * Bump `aeson-1.2` dependency - * Fix vertical alignment of title slides - * Fix wrapping issue with inline code at end of line - * Add bash-completion script generation to Makefile +* Add slide seeking (enter slide number + `enter`) +* Fix turning tty echo off/on during presentation +* Run `w3mimgdisplay` cleanup action, fixing image issues on some terminals -- 0.5.0.0 (2017-02-06) - * Add a `slideLevel` option & autodetect it. This changes the way `patat` - splits slides. For more information, see the `README` or the `man` page. - If you just want to get the old behavior back, just add: +## 0.8.3.0 (2019-09-07) - --- - patat: - slideLevel: 1 - ... +* Fix test failure again, and ensure that it works for multiple pandoc + versions by slightly modifying test input +* Include pandoc version info in `patat --version` - To the top of your presentation. +## 0.8.2.5 (2019-08-12) - * Clear the screen when finished with the presentation. +* Fix test failure caused by slightly different pandoc output for lists -- 0.4.7.1 (2017-01-22) - * Bump `directory-1.3` dependency - * Bump `time-1.7` dependency +## 0.8.2.4 (2019-08-12) -- 0.4.7.0 (2017-01-20) - * Bump `aeson-1.1` dependency - * Parse YAML for settings using `yaml` instead of pandoc - * Clarify watch & autoAdvance combination in documentation. +* Bump `optparse-applicative` upper bound to 0.16 +* Bump `skylighting` upper bound to 0.9 -- 0.4.6.0 (2016-12-28) - * Redraw the screen on unknown commands to prevent accidental typing from - showing up. - * Make the cursor invisible during the presentation. - * Move the footer down one more line to gain some screen real estate. +## 0.8.2.3 (2019-06-25) -- 0.4.5.0 (2016-12-05) - * Render the date in a locale-independent manner (patch by Daniel - Shahaf). +* Bump upper `pandoc` dependency to 2.8 -- 0.4.4.0 (2016-12-03) - * Force the use of UTF-8 when generating the man page. +## 0.8.2.2 (2019-02-04) -- 0.4.3.0 (2016-12-02) - * Use `SOURCE_DATE_EPOCH` if it is present instead of getting the date from - `git log`. +* Bump lower `base` dependency to 4.8 -- 0.4.2.0 (2016-12-01) - * Fix issues with man page generation on Travis. +## 0.8.2.1 (2019-02-03) -- 0.4.1.0 (2016-12-01) - * Fix compatibility with `pandoc-1.18` and `pandoc-1.19`. - * Add a man page. +* Bump `pandoc` to 2.6 +* Bump `ansi-terminal` to 0.10 -- 0.4.0.0 (2016-11-15) - * Add configurable auto advancing. - * Support fragmented slides. +## 0.8.2.0 (2019-01-24) -- 0.3.3.0 (2016-10-31) - * Add a `--version` flag. - * Add support for `pandoc-1.18` which includes a new `LineBlock` element. +* GHC 7.8 compatibility -- 0.3.2.0 (2016-10-20) - * Keep running even if errors are encountered during reload. +## 0.8.1.3 (2019-01-24) -- 0.3.1.0 (2016-10-18) - * Fix compilation with `lts-6.22`. +* Bump `pandoc` to 2.4 +* Bump `yaml` to 0.11 -- 0.3.0.0 (2016-10-17) - * Add syntax highlighting support. - * Fixed slide clipping after reload. +## 0.8.1.2 (2018-10-29) -- 0.2.0.0 (2016-10-13) - * Add theming support. - * Fix links display. - * Add support for wrapping. - * Allow org mode as input format. +* Work around test failure caused by slightly different syntax highlighting + in different pandoc versions -- 0.1.0.0 (2016-10-02) - * Upload first version from hotel wifi in Kalaw. +## 0.8.1.1 (2018-10-26) + +* Tickle CircleCI cache + +## 0.8.1.0 (2018-10-26) + +* Add support for italic ansi code in themes +* Fix centered titles not being centered (contribution by Hamza Haiken) + +## 0.8.0.0 (2018-08-31) + +* Themed border rendering improvements (contribution by Hamza Haiken) +* Add support for margins (contribution by Hamza Haiken) +* Add RGB colour support for themes (contribution by Hamza Haiken) +* Add experimental images support +* Add images support for iTerm2 (contribution by @2mol) + +## 0.7.2.0 (2018-05-08) + +* GHC 8.4 compatibility + +## 0.7.1.0 (2018-05-08) + +* GHC 8.4 compatibility + +## 0.7.0.0 (2018-05-04) + +* Support HTML-style comments + +## 0.6.1.2 (2018-04-30) + +* Bump `pandoc` to 2.2 + +## 0.6.1.1 (2018-04-27) + +* Bump `aeson` to 1.3 +* Bump `skylighting` to 0.7 +* Bump `time` to 1.9 +* Bump `ansi-terminal` to 0.8 + +## 0.6.1.0 (2018-01-28) + +* Bump `skylighting` to 0.6 +* Bump `pandoc` to 2.1 +* Bump `ansi-terminal` to 0.7 + +## 0.6.0.1 (2017-12-24) + +* Automatically upload linux binary to GitHub + +## 0.6.0.0 (2017-12-19) + +* Make pandoc extensions customizable in the configuration +* Bump `pandoc` to 2.0 + +## 0.5.2.2 (2017-06-14) + +* Add `network-uri` dependency to fix travis build + +## 0.5.2.1 (2017-06-14) + +* Bump `optparse-applicative-0.14` dependency + +## 0.5.2.0 (2017-05-16) + +* Add navigation using `PageUp` and `PageDown`. +* Use `skylighting` instead of deprecated `highlighting-kate` for syntax + highlighting. + +## 0.5.1.2 (2017-04-26) + +* Make build reproducible even if timezone changes (patch by Félix Sipma) + +## 0.5.1.1 (2017-04-23) + +* Include `README` in `Extra-source-files` so it gets displayed on Hackage + +## 0.5.1.0 (2017-04-23) + +* Bump `aeson-1.2` dependency +* Fix vertical alignment of title slides +* Fix wrapping issue with inline code at end of line +* Add bash-completion script generation to Makefile + +## 0.5.0.0 (2017-02-06) + +* Add a `slideLevel` option & autodetect it. This changes the way `patat` + splits slides. For more information, see the `README` or the `man` page. + If you just want to get the old behavior back, just add: + + --- + patat: + slideLevel: 1 + ... + + To the top of your presentation. + +* Clear the screen when finished with the presentation. + +## 0.4.7.1 (2017-01-22) + +* Bump `directory-1.3` dependency +* Bump `time-1.7` dependency + +## 0.4.7.0 (2017-01-20) + +* Bump `aeson-1.1` dependency +* Parse YAML for settings using `yaml` instead of pandoc +* Clarify watch & autoAdvance combination in documentation. + +## 0.4.6.0 (2016-12-28) + +* Redraw the screen on unknown commands to prevent accidental typing from + showing up. +* Make the cursor invisible during the presentation. +* Move the footer down one more line to gain some screen real estate. + +## 0.4.5.0 (2016-12-05) + +* Render the date in a locale-independent manner (patch by Daniel + Shahaf). + +## 0.4.4.0 (2016-12-03) + +* Force the use of UTF-8 when generating the man page. + +## 0.4.3.0 (2016-12-02) + +* Use `SOURCE_DATE_EPOCH` if it is present instead of getting the date from + `git log`. + +## 0.4.2.0 (2016-12-01) + +* Fix issues with man page generation on Travis. + +## 0.4.1.0 (2016-12-01) + +* Fix compatibility with `pandoc-1.18` and `pandoc-1.19`. +* Add a man page. + +## 0.4.0.0 (2016-11-15) + +* Add configurable auto advancing. +* Support fragmented slides. + +## 0.3.3.0 (2016-10-31) + +* Add a `--version` flag. +* Add support for `pandoc-1.18` which includes a new `LineBlock` element. + +## 0.3.2.0 (2016-10-20) + +* Keep running even if errors are encountered during reload. + +## 0.3.1.0 (2016-10-18) + +* Fix compilation with `lts-6.22`. + +## 0.3.0.0 (2016-10-17) + +* Add syntax highlighting support. +* Fixed slide clipping after reload. + +## 0.2.0.0 (2016-10-13) + +* Add theming support. +* Fix links display. +* Add support for wrapping. +* Allow org mode as input format. + +## 0.1.0.0 (2016-10-02) + +* Upload first version from hotel wifi in Kalaw. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -14,17 +14,18 @@ - Supports [smart slide splitting](#input-format). - Slides can be split up into [multiple fragments](#fragmented-slides) - There is a [live reload](#running) mode. -- [Theming](#theming) support including 24-bit RGB. +- Supports [evaluating code snippets and showing the result](#evaluating-code). +- Display [speaker notes](#speaker-notes) in a second window or monitor. - [Auto advancing](#auto-advancing) with configurable delay. +- Experimental [images](#images) support. - Optionally [re-wrapping](#line-wrapping) text to terminal width with proper indentation. - Syntax highlighting for nearly one hundred languages generated from [Kate] syntax files. -- Experimental [images](#images) support. -- Supports [evaluating code snippets and showing the result](#evaluating-code). +- [Theming](#theming) support including 24-bit RGB. - Written in [Haskell]. -![screenshot](extra/screenshot.png?raw=true) +![screenshot](extra/demo.gif?raw=true) [Kate]: https://kate-editor.org/ [Haskell]: http://haskell.org/ @@ -53,6 +54,7 @@ - [Images](#images) - [Breadcrumbs](#breadcrumbs) - [Evaluating code](#evaluating-code) + - [Speaker notes](#speaker-notes) - [Trivia](#trivia) Installation @@ -241,26 +243,6 @@ For more information, see [Advanced slide splitting](#advanced-slide-splitting). -Patat supports comments which can be used as speaker notes. - -```markdown ---- -title: This is my presentation -author: Jane Doe -... - -# Chapter 1 - - - -Slide contents. Yay. - - -``` - Configuration ------------- @@ -489,6 +471,20 @@ ### Syntax Highlighting +`patat` uses [Kate] Syntax Highlighting files. `patat` ships with support for +nearly one hundred languages thanks to Pandoc. However, if your language is +not yet available, you can add the highlighting XML file in the settings: + +```markdown +--- +patat: + syntaxDefinitions: + - 'impurescript.xml' +... + +... +``` + As part of theming, syntax highlighting is also configurable. This can be configured like this: @@ -677,6 +673,53 @@ 2. Write the contents of the code block to the `stdin` of the process 3. Wait for the process to exit 4. Render the `stdout` of the process + +### Speaker Notes + +`patat` supports comments which can be used as speaker notes. + +```markdown +--- +title: This is my presentation +author: Jane Doe +... + +# Chapter 1 + + + +Slide contents. Yay. + + +``` + +You can also configure `patat` to write the speaker notes for the current slide +to a file whenever the slide changes: + +```yaml +patat: + speakerNotes: + file: /tmp/notes.txt +``` + +Then, you can display these in a second terminal (presumably on a second +monitor) by just displaying this file whenever it changes. [entr] is one +way to do that: + +[entr]: http://eradman.com/entrproject/ + +```bash +echo /tmp/notes.txt | entr -s 'clear; cat /tmp/notes.txt' +``` + +Alternatively, just use a second `patat` instance with `--watch` enabled: + +```bash +patat -w /tmp/notes.txt +``` Trivia ------ diff --git a/lib/Data/Sequence/Extended.hs b/lib/Data/Sequence/Extended.hs new file mode 100644 --- /dev/null +++ b/lib/Data/Sequence/Extended.hs @@ -0,0 +1,16 @@ +module Data.Sequence.Extended + ( module Data.Sequence + , cons + , safeIndex + ) where + +import Data.Sequence + +cons :: a -> Seq a -> Seq a +cons x xs = singleton x <> xs + +safeIndex :: Seq a -> Int -> Maybe a +safeIndex s n + | n < 0 = Nothing + | n >= Data.Sequence.length s = Nothing + | otherwise = Just $ index s n diff --git a/lib/Patat/Eval.hs b/lib/Patat/Eval.hs --- a/lib/Patat/Eval.hs +++ b/lib/Patat/Eval.hs @@ -10,13 +10,13 @@ import qualified Control.Concurrent.Async as Async import Control.Exception (finally) import qualified Data.HashMap.Strict as HMS +import Data.Maybe (maybeToList) import qualified Data.Text as T import qualified Data.Text.IO as T import Patat.Presentation.Instruction import Patat.Presentation.Internal import System.Exit (ExitCode (..)) import qualified System.IO as IO -import Data.Maybe (maybeToList) import System.IO.Unsafe (unsafeInterleaveIO) import qualified System.Process as Process import qualified Text.Pandoc.Definition as Pandoc @@ -40,10 +40,11 @@ -------------------------------------------------------------------------------- evalSlide :: EvalSettingsMap -> Slide -> IO Slide -evalSlide settings slide = case slide of +evalSlide settings slide = case slideContent slide of TitleSlide _ _ -> pure slide - ContentSlide instrs -> ContentSlide . fromList . concat <$> - traverse (evalInstruction settings) (toList instrs) + ContentSlide instrs0 -> do + instrs1 <- traverse (evalInstruction settings) (toList instrs0) + pure slide {slideContent = ContentSlide . fromList $ concat instrs1} -------------------------------------------------------------------------------- diff --git a/lib/Patat/Main.hs b/lib/Patat/Main.hs --- a/lib/Patat/Main.hs +++ b/lib/Patat/Main.hs @@ -15,6 +15,7 @@ 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) @@ -23,6 +24,7 @@ import Patat.AutoAdvance import qualified Patat.Images as Images import Patat.Presentation +import qualified Patat.Presentation.SpeakerNotes as SpeakerNotes import qualified Patat.PrettyPrint as PP import qualified Paths_patat import Prelude @@ -137,14 +139,20 @@ unless (oForce options) assertAnsiFeatures -- (Maybe) initialize images backend. - images <- traverse Images.new (psImages $ pSettings pres) + images <- traverse Images.new $ psImages $ pSettings pres - if oDump options - then dumpPresentation pres - else interactiveLoop options images pres + -- (Maybe) initialize speaker notes. + withMaybeHandle SpeakerNotes.with + (psSpeakerNotes $ pSettings pres) $ \speakerNotes -> + + if oDump options + then dumpPresentation pres + else interactiveLoop options images speakerNotes pres where - interactiveLoop :: Options -> Maybe Images.Handle -> Presentation -> IO () - interactiveLoop options images pres0 = + interactiveLoop + :: Options -> Maybe Images.Handle -> Maybe SpeakerNotes.Handle + -> Presentation -> IO () + interactiveLoop options images speakerNotes pres0 = interactively readPresentationCommand $ \commandChan0 -> do -- If an auto delay is set, use 'autoAdvance' to create a new one. @@ -160,6 +168,9 @@ let loop :: Presentation -> Maybe String -> IO () loop pres mbError = do + for_ speakerNotes $ \sn -> + SpeakerNotes.write sn $ activeSpeakerNotes pres + size <- getDisplaySize pres let display = case mbError of Nothing -> displayPresentation size pres @@ -236,3 +247,14 @@ when (mtime1 > mtime0) $ Chan.writeChan chan Reload threadDelay (200 * 1000) watcher chan filePath mtime1 + + +-------------------------------------------------------------------------------- +-- | Wrapper for optional handles. +withMaybeHandle + :: (settings -> (handle -> IO a) -> IO a) + -> Maybe settings + -> (Maybe handle -> IO a) + -> IO a +withMaybeHandle _ Nothing f = f Nothing +withMaybeHandle impl (Just settings) f = impl settings (f . Just) diff --git a/lib/Patat/Presentation.hs b/lib/Patat/Presentation.hs --- a/lib/Patat/Presentation.hs +++ b/lib/Patat/Presentation.hs @@ -5,6 +5,8 @@ , Presentation (..) , readPresentation + , activeSpeakerNotes + , Size , getDisplaySize 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 @@ -13,17 +13,19 @@ -------------------------------------------------------------------------------- -import Control.Monad (mplus) +import Control.Monad (guard, mplus) import qualified Data.Aeson.Extended as A import Data.Char.WCWidth.Extended (wcstrwidth) import Data.Data.Extended (grecQ) import qualified Data.List as L -import Data.Maybe (fromMaybe, listToMaybe, - maybeToList) +import Data.Maybe (fromMaybe, maybeToList) +import qualified Data.Sequence.Extended as Seq import qualified Data.Text as T 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.Theme (Theme (..)) @@ -59,7 +61,7 @@ -- | Display something within the presentation borders that draw the title and -- the active slide number and so on. displayWithBorders - :: Size -> Presentation -> (Size -> Theme -> PP.Doc) -> PP.Doc + :: Size -> Presentation -> (Size -> DisplaySettings -> PP.Doc) -> PP.Doc displayWithBorders (Size rows columns) Presentation {..} f = (if null title then mempty @@ -67,7 +69,7 @@ let titleRemainder = columns - titleWidth - titleOffset wrappedTitle = PP.spaces titleOffset <> PP.string title <> PP.spaces titleRemainder in borders wrappedTitle <> PP.hardline <> PP.hardline) <> - formatWith settings (f canvasSize theme) <> 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) <> PP.hardline @@ -75,14 +77,17 @@ -- Get terminal width/title (sidx, _) = pActiveFragment settings = pSettings {psColumns = Just $ A.FlexibleNum columns} - theme = fromMaybe Theme.defaultTheme (psTheme settings) + ds = DisplaySettings + { dsTheme = fromMaybe Theme.defaultTheme (psTheme settings) + , dsSyntaxMap = pSyntaxMap + } -- Compute title. - breadcrumbs = fromMaybe [] . listToMaybe $ drop sidx pBreadcrumbs - plainTitle = PP.toString $ prettyInlines theme pTitle + breadcrumbs = fromMaybe [] $ Seq.safeIndex pBreadcrumbs sidx + plainTitle = PP.toString $ prettyInlines ds pTitle breadTitle = mappend plainTitle $ mconcat [ s - | b <- map (prettyInlines theme . snd) breadcrumbs + | b <- map (prettyInlines ds . snd) breadcrumbs , s <- [" > ", PP.toString b] ] title @@ -93,7 +98,7 @@ -- Dimensions of title. titleWidth = wcstrwidth title titleOffset = (columns - titleWidth) `div` 2 - borders = themed (themeBorders theme) + borders = themed ds themeBorders -- Room left for content canvasSize = Size (rows - 2) columns @@ -103,7 +108,7 @@ | fromMaybe True $ psSlideNumber settings = show (sidx + 1) ++ " / " ++ show (length pSlides) | otherwise = "" activeWidth = wcstrwidth active - author = PP.toString (prettyInlines theme pAuthor) + author = PP.toString (prettyInlines ds pAuthor) authorWidth = wcstrwidth author middleSpaces = PP.spaces $ columns - activeWidth - authorWidth - 2 @@ -111,7 +116,7 @@ -------------------------------------------------------------------------------- displayPresentation :: Size -> Presentation -> Display displayPresentation size pres@Presentation {..} = - case getActiveFragment pres of + case activeFragment pres of Nothing -> DisplayDoc $ displayWithBorders size pres mempty Just (ActiveContent fragment) | Just _ <- psImages pSettings @@ -135,10 +140,10 @@ -- Check if the fragment consists of "just a single image". Discard -- headers. onlyImage (Fragment (Pandoc.Header{} : bs)) = onlyImage (Fragment bs) - onlyImage (Fragment bs) = case filter isVisibleBlock bs of - [Pandoc.Figure _ _ bs'] -> onlyImage (Fragment bs') + onlyImage (Fragment bs) = case bs of + [Pandoc.Figure _ _ bs'] -> onlyImage (Fragment bs') [Pandoc.Para [Pandoc.Image _ _ (target, _)]] -> Just target - _ -> Nothing + _ -> Nothing -------------------------------------------------------------------------------- @@ -146,8 +151,8 @@ -- want to display an error but keep the presentation running. displayPresentationError :: Size -> Presentation -> String -> PP.Doc displayPresentationError size pres err = - displayWithBorders size pres $ \_ Theme {..} -> - themed themeStrong "Error occurred in the presentation:" <$$> + displayWithBorders size pres $ \_ ds -> + themed ds themeStrong "Error occurred in the presentation:" <$$> "" <$$> (PP.string err) @@ -155,19 +160,35 @@ -------------------------------------------------------------------------------- dumpPresentation :: Presentation -> IO () dumpPresentation pres@Presentation {..} = - let sRows = fromMaybe 24 $ A.unFlexibleNum <$> psRows pSettings - sCols = fromMaybe 72 $ A.unFlexibleNum <$> psColumns pSettings - size = Size {..} in PP.putDoc $ PP.removeControls $ formatWith pSettings $ - PP.vcat $ L.intersperse "----------" $ do - i <- [0 .. length pSlides - 1] + PP.vcat $ L.intercalate ["{slide}"] $ + map dumpSlide [0 .. length pSlides - 1] + where + dumpSlide :: Int -> [PP.Doc] + dumpSlide i = do slide <- maybeToList $ getSlide i pres - j <- [0 .. numFragments slide - 1] - case displayPresentation size pres {pActiveFragment = (i, j)} of - DisplayDoc doc -> [doc] - DisplayImage filepath -> [PP.string $ "image:" ++ filepath] + dumpSpeakerNotes slide <> L.intercalate ["{fragment}"] + [ dumpFragment (i, j) + | j <- [0 .. numFragments slide - 1] + ] + dumpSpeakerNotes :: Slide -> [PP.Doc] + dumpSpeakerNotes slide = do + guard $ slideSpeakerNotes slide /= mempty + pure $ PP.text $ "{speakerNotes: " <> + SpeakerNotes.toText (slideSpeakerNotes slide) <> "}" + dumpFragment :: Index -> [PP.Doc] + dumpFragment idx = + case displayPresentation size 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 {..} + + -------------------------------------------------------------------------------- formatWith :: PresentationSettings -> PP.Doc -> PP.Doc formatWith ps = wrap . indent @@ -181,34 +202,34 @@ -------------------------------------------------------------------------------- -prettyFragment :: Theme -> Fragment -> PP.Doc -prettyFragment theme (Fragment blocks) = - prettyBlocks theme blocks <> - case prettyReferences theme blocks of +prettyFragment :: DisplaySettings -> Fragment -> PP.Doc +prettyFragment ds (Fragment blocks) = + prettyBlocks ds blocks <> + case prettyReferences ds blocks of [] -> mempty refs -> PP.hardline <> PP.vcat refs -------------------------------------------------------------------------------- -prettyBlock :: Theme -> Pandoc.Block -> PP.Doc +prettyBlock :: DisplaySettings -> Pandoc.Block -> PP.Doc -prettyBlock theme (Pandoc.Plain inlines) = prettyInlines theme inlines +prettyBlock ds (Pandoc.Plain inlines) = prettyInlines ds inlines -prettyBlock theme (Pandoc.Para inlines) = - prettyInlines theme inlines <> PP.hardline +prettyBlock ds (Pandoc.Para inlines) = + prettyInlines ds inlines <> PP.hardline -prettyBlock theme@Theme {..} (Pandoc.Header i _ inlines) = - themed themeHeader (PP.string (replicate i '#') <+> prettyInlines theme inlines) <> +prettyBlock ds (Pandoc.Header i _ inlines) = + themed ds themeHeader (PP.string (replicate i '#') <+> prettyInlines ds inlines) <> PP.hardline -prettyBlock theme (Pandoc.CodeBlock (_, classes, _) txt) = - prettyCodeBlock theme classes txt +prettyBlock ds (Pandoc.CodeBlock (_, classes, _) txt) = + prettyCodeBlock ds classes txt -prettyBlock theme (Pandoc.BulletList bss) = PP.vcat +prettyBlock ds (Pandoc.BulletList bss) = PP.vcat [ PP.indent - (PP.NotTrimmable $ themed (themeBulletList theme) prefix) + (PP.NotTrimmable $ themed ds themeBulletList prefix) (PP.Trimmable " ") - (prettyBlocks theme' bs) + (prettyBlocks ds' bs) | bs <- bss ] <> PP.hardline where @@ -218,16 +239,18 @@ _ -> '-' -- Cycle the markers. + theme = dsTheme ds theme' = theme { themeBulletListMarkers = (\ls -> T.drop 1 ls <> T.take 1 ls) <$> themeBulletListMarkers theme } + ds' = ds {dsTheme = theme'} -prettyBlock theme@Theme {..} (Pandoc.OrderedList _ bss) = PP.vcat +prettyBlock ds (Pandoc.OrderedList _ bss) = PP.vcat [ PP.indent - (PP.NotTrimmable $ themed themeOrderedList $ PP.string prefix) + (PP.NotTrimmable $ themed ds themeOrderedList $ PP.string prefix) (PP.Trimmable " ") - (prettyBlocks theme bs) + (prettyBlocks ds bs) | (prefix, bs) <- zip padded bss ] <> PP.hardline where @@ -237,34 +260,34 @@ | i <- [1 .. length bss] ] -prettyBlock _theme (Pandoc.RawBlock _ t) = PP.text t <> PP.hardline +prettyBlock _ds (Pandoc.RawBlock _ t) = PP.text t <> PP.hardline -prettyBlock _theme Pandoc.HorizontalRule = "---" +prettyBlock _ds Pandoc.HorizontalRule = "---" -prettyBlock theme@Theme {..} (Pandoc.BlockQuote bs) = - let quote = PP.NotTrimmable (themed themeBlockQuote "> ") in - PP.indent quote quote (themed themeBlockQuote $ prettyBlocks theme bs) +prettyBlock ds (Pandoc.BlockQuote bs) = + let quote = PP.NotTrimmable (themed ds themeBlockQuote "> ") in + PP.indent quote quote (themed ds themeBlockQuote $ prettyBlocks ds bs) -prettyBlock theme@Theme {..} (Pandoc.DefinitionList terms) = +prettyBlock ds (Pandoc.DefinitionList terms) = PP.vcat $ map prettyDefinition terms where prettyDefinition (term, definitions) = - themed themeDefinitionTerm (prettyInlines theme term) <$$> + themed ds themeDefinitionTerm (prettyInlines ds term) <$$> PP.hardline <> PP.vcat [ PP.indent - (PP.NotTrimmable (themed themeDefinitionList ": ")) + (PP.NotTrimmable (themed ds themeDefinitionList ": ")) (PP.Trimmable " ") $ - prettyBlocks theme (Pandoc.plainToPara definition) + prettyBlocks ds (Pandoc.plainToPara definition) | definition <- definitions ] -prettyBlock theme (Pandoc.Table _ caption specs thead tbodies tfoot) = +prettyBlock ds (Pandoc.Table _ caption specs thead tbodies tfoot) = PP.wrapAt Nothing $ - prettyTable theme Table - { tCaption = prettyInlines theme caption' + prettyTable ds Table + { tCaption = prettyInlines ds caption' , tAligns = map align aligns - , tHeaders = map (prettyBlocks theme) headers - , tRows = map (map (prettyBlocks theme)) rows + , tHeaders = map (prettyBlocks ds) headers + , tRows = map (map (prettyBlocks ds)) rows } where (caption', aligns, _, headers, rows) = Pandoc.toLegacyTable @@ -275,90 +298,91 @@ align Pandoc.AlignDefault = PP.AlignLeft align Pandoc.AlignRight = PP.AlignRight -prettyBlock theme (Pandoc.Div _attrs blocks) = prettyBlocks theme blocks +prettyBlock ds (Pandoc.Div _attrs blocks) = prettyBlocks ds blocks -prettyBlock theme@Theme {..} (Pandoc.LineBlock inliness) = - let ind = PP.NotTrimmable (themed themeLineBlock "| ") in +prettyBlock ds (Pandoc.LineBlock inliness) = + let ind = PP.NotTrimmable (themed ds themeLineBlock "| ") in PP.wrapAt Nothing $ PP.indent ind ind $ PP.vcat $ - map (prettyInlines theme) inliness + map (prettyInlines ds) inliness -prettyBlock theme (Pandoc.Figure _attr _caption blocks) = - prettyBlocks theme blocks +prettyBlock ds (Pandoc.Figure _attr _caption blocks) = + prettyBlocks ds blocks + -------------------------------------------------------------------------------- -prettyBlocks :: Theme -> [Pandoc.Block] -> PP.Doc -prettyBlocks theme = PP.vcat . map (prettyBlock theme) . filter isVisibleBlock +prettyBlocks :: DisplaySettings -> [Pandoc.Block] -> PP.Doc +prettyBlocks ds = PP.vcat . map (prettyBlock ds) -------------------------------------------------------------------------------- -prettyInline :: Theme -> Pandoc.Inline -> PP.Doc +prettyInline :: DisplaySettings -> Pandoc.Inline -> PP.Doc -prettyInline _theme Pandoc.Space = PP.space +prettyInline _ds Pandoc.Space = PP.space -prettyInline _theme (Pandoc.Str str) = PP.text str +prettyInline _ds (Pandoc.Str str) = PP.text str -prettyInline theme@Theme {..} (Pandoc.Emph inlines) = - themed themeEmph $ - prettyInlines theme inlines +prettyInline ds (Pandoc.Emph inlines) = + themed ds themeEmph $ + prettyInlines ds inlines -prettyInline theme@Theme {..} (Pandoc.Strong inlines) = - themed themeStrong $ - prettyInlines theme inlines +prettyInline ds (Pandoc.Strong inlines) = + themed ds themeStrong $ + prettyInlines ds inlines -prettyInline theme@Theme {..} (Pandoc.Underline inlines) = - themed themeUnderline $ - prettyInlines theme inlines +prettyInline ds (Pandoc.Underline inlines) = + themed ds themeUnderline $ + prettyInlines ds inlines -prettyInline Theme {..} (Pandoc.Code _ txt) = - themed themeCode $ +prettyInline ds (Pandoc.Code _ txt) = + themed ds themeCode $ PP.text (" " <> txt <> " ") -prettyInline theme@Theme {..} link@(Pandoc.Link _attrs text (target, _title)) +prettyInline ds link@(Pandoc.Link _attrs text (target, _title)) | isReferenceLink link = - "[" <> themed themeLinkText (prettyInlines theme text) <> "]" + "[" <> themed ds themeLinkText (prettyInlines ds text) <> "]" | otherwise = - "<" <> themed themeLinkTarget (PP.text target) <> ">" + "<" <> themed ds themeLinkTarget (PP.text target) <> ">" -prettyInline _theme Pandoc.SoftBreak = PP.softline +prettyInline _ds Pandoc.SoftBreak = PP.softline -prettyInline _theme Pandoc.LineBreak = PP.hardline +prettyInline _ds Pandoc.LineBreak = PP.hardline -prettyInline theme@Theme {..} (Pandoc.Strikeout t) = - "~~" <> themed themeStrikeout (prettyInlines theme t) <> "~~" +prettyInline ds (Pandoc.Strikeout t) = + "~~" <> themed ds themeStrikeout (prettyInlines ds t) <> "~~" -prettyInline theme@Theme {..} (Pandoc.Quoted Pandoc.SingleQuote t) = - "'" <> themed themeQuoted (prettyInlines theme t) <> "'" -prettyInline theme@Theme {..} (Pandoc.Quoted Pandoc.DoubleQuote t) = - "'" <> themed themeQuoted (prettyInlines theme t) <> "'" +prettyInline ds (Pandoc.Quoted Pandoc.SingleQuote t) = + "'" <> themed ds themeQuoted (prettyInlines ds t) <> "'" +prettyInline ds (Pandoc.Quoted Pandoc.DoubleQuote t) = + "'" <> themed ds themeQuoted (prettyInlines ds t) <> "'" -prettyInline Theme {..} (Pandoc.Math _ t) = - themed themeMath (PP.text t) +prettyInline ds (Pandoc.Math _ t) = + themed ds themeMath (PP.text t) -prettyInline theme@Theme {..} (Pandoc.Image _attrs text (target, _title)) = - "![" <> themed themeImageText (prettyInlines theme text) <> "](" <> - themed themeImageTarget (PP.text target) <> ")" +prettyInline ds (Pandoc.Image _attrs text (target, _title)) = + "![" <> themed ds themeImageText (prettyInlines ds text) <> "](" <> + themed ds themeImageTarget (PP.text target) <> ")" -- These elements aren't really supported. -prettyInline theme (Pandoc.Cite _ t) = prettyInlines theme t -prettyInline theme (Pandoc.Span _ t) = prettyInlines theme t -prettyInline _theme (Pandoc.RawInline _ t) = PP.text t -prettyInline theme (Pandoc.Note t) = prettyBlocks theme t -prettyInline theme (Pandoc.Superscript t) = prettyInlines theme t -prettyInline theme (Pandoc.Subscript t) = prettyInlines theme t -prettyInline theme (Pandoc.SmallCaps t) = prettyInlines theme t +prettyInline ds (Pandoc.Cite _ t) = prettyInlines ds t +prettyInline ds (Pandoc.Span _ t) = prettyInlines ds t +prettyInline _ds (Pandoc.RawInline _ t) = PP.text t +prettyInline ds (Pandoc.Note t) = prettyBlocks ds t +prettyInline ds (Pandoc.Superscript t) = prettyInlines ds t +prettyInline ds (Pandoc.Subscript t) = prettyInlines ds t +prettyInline ds (Pandoc.SmallCaps t) = prettyInlines ds t -- prettyInline unsupported = PP.ondullred $ PP.string $ show unsupported -------------------------------------------------------------------------------- -prettyInlines :: Theme -> [Pandoc.Inline] -> PP.Doc -prettyInlines theme = mconcat . map (prettyInline theme) +prettyInlines :: DisplaySettings -> [Pandoc.Inline] -> PP.Doc +prettyInlines ds = mconcat . map (prettyInline ds) -------------------------------------------------------------------------------- -prettyReferences :: Theme -> [Pandoc.Block] -> [PP.Doc] -prettyReferences theme@Theme {..} = +prettyReferences :: DisplaySettings -> [Pandoc.Block] -> [PP.Doc] +prettyReferences ds = map prettyReference . getReferences where getReferences :: [Pandoc.Block] -> [Pandoc.Inline] @@ -367,9 +391,10 @@ prettyReference :: Pandoc.Inline -> PP.Doc prettyReference (Pandoc.Link _attrs text (target, title)) = "[" <> - themed themeLinkText (prettyInlines theme $ Pandoc.newlineToSpace text) <> + themed ds themeLinkText + (prettyInlines ds $ Pandoc.newlineToSpace text) <> "](" <> - themed themeLinkTarget (PP.text target) <> + themed ds themeLinkTarget (PP.text target) <> (if T.null title then mempty else PP.space <> "\"" <> PP.text title <> "\"") @@ -382,10 +407,3 @@ isReferenceLink (Pandoc.Link _attrs text (target, _)) = [Pandoc.Str target] /= text isReferenceLink _ = False - - --------------------------------------------------------------------------------- -isVisibleBlock :: Pandoc.Block -> Bool -isVisibleBlock (Pandoc.RawBlock (Pandoc.Format "html") t) = - not ("" `T.isSuffixOf` t) -isVisibleBlock _ = True diff --git a/lib/Patat/Presentation/Display/CodeBlock.hs b/lib/Patat/Presentation/Display/CodeBlock.hs --- a/lib/Patat/Presentation/Display/CodeBlock.hs +++ b/lib/Patat/Presentation/Display/CodeBlock.hs @@ -1,30 +1,31 @@ -------------------------------------------------------------------------------- -- | Displaying code blocks, optionally with syntax highlighting. {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} module Patat.Presentation.Display.CodeBlock ( prettyCodeBlock ) where -------------------------------------------------------------------------------- -import Data.Maybe (mapMaybe) -import qualified Data.Text as T -import Patat.Presentation.Display.Table (themed) -import qualified Patat.PrettyPrint as PP +import Data.Maybe (mapMaybe) +import qualified Data.Text as T +import Patat.Presentation.Display.Internal +import qualified Patat.PrettyPrint as PP import Patat.Theme import Prelude -import qualified Skylighting as Skylighting +import qualified Skylighting as Skylighting -------------------------------------------------------------------------------- -highlight :: [T.Text] -> T.Text -> [Skylighting.SourceLine] -highlight classes rawCodeBlock = case mapMaybe getSyntax classes of - [] -> zeroHighlight rawCodeBlock - (syn : _) -> - case Skylighting.tokenize config syn rawCodeBlock of - Left _ -> zeroHighlight rawCodeBlock - Right sl -> sl +highlight + :: Skylighting.SyntaxMap -> [T.Text] -> T.Text -> [Skylighting.SourceLine] +highlight extraSyntaxMap classes rawCodeBlock = + case mapMaybe getSyntax classes of + [] -> zeroHighlight rawCodeBlock + (syn : _) -> + case Skylighting.tokenize config syn rawCodeBlock of + Left _ -> zeroHighlight rawCodeBlock + Right sl -> sl where getSyntax :: T.Text -> Maybe Skylighting.Syntax getSyntax c = Skylighting.lookupSyntax c syntaxMap @@ -36,7 +37,7 @@ } syntaxMap :: Skylighting.SyntaxMap - syntaxMap = Skylighting.defaultSyntaxMap + syntaxMap = extraSyntaxMap <> Skylighting.defaultSyntaxMap -------------------------------------------------------------------------------- @@ -49,21 +50,22 @@ -------------------------------------------------------------------------------- -prettyCodeBlock :: Theme -> [T.Text] -> T.Text -> PP.Doc -prettyCodeBlock theme@Theme {..} classes rawCodeBlock = - PP.vcat (map blockified sourceLines) <> - PP.hardline +prettyCodeBlock :: DisplaySettings -> [T.Text] -> T.Text -> PP.Doc +prettyCodeBlock ds classes rawCodeBlock = + PP.vcat (map blockified sourceLines) <> PP.hardline where sourceLines :: [Skylighting.SourceLine] sourceLines = - [[]] ++ highlight classes rawCodeBlock ++ [[]] + [[]] ++ highlight (dsSyntaxMap ds) classes rawCodeBlock ++ [[]] prettySourceLine :: Skylighting.SourceLine -> PP.Doc prettySourceLine = mconcat . map prettyToken prettyToken :: Skylighting.Token -> PP.Doc - prettyToken (tokenType, str) = - themed (syntaxHighlight theme tokenType) (PP.string $ T.unpack str) + prettyToken (tokenType, str) = themed + ds + (\theme -> syntaxHighlight theme tokenType) + (PP.string $ T.unpack str) sourceLineLength :: Skylighting.SourceLine -> Int sourceLineLength line = sum [T.length str | (_, str) <- line] @@ -76,7 +78,7 @@ let len = sourceLineLength line indent = PP.NotTrimmable " " in PP.indent indent indent $ - themed themeCodeBlock $ + themed ds themeCodeBlock $ " " <> prettySourceLine line <> PP.string (replicate (blockWidth - len) ' ') <> " " diff --git a/lib/Patat/Presentation/Display/Internal.hs b/lib/Patat/Presentation/Display/Internal.hs new file mode 100644 --- /dev/null +++ b/lib/Patat/Presentation/Display/Internal.hs @@ -0,0 +1,27 @@ +-------------------------------------------------------------------------------- +module Patat.Presentation.Display.Internal + ( DisplaySettings (..) + , themed + ) where + + +-------------------------------------------------------------------------------- +import qualified Patat.PrettyPrint as PP +import qualified Patat.Theme as Theme +import qualified Skylighting as Skylighting + + +-------------------------------------------------------------------------------- +data DisplaySettings = DisplaySettings + { dsTheme :: !Theme.Theme + , dsSyntaxMap :: !Skylighting.SyntaxMap + } + + +-------------------------------------------------------------------------------- +themed + :: DisplaySettings -> (Theme.Theme -> Maybe Theme.Style) -> PP.Doc -> PP.Doc +themed ds f = case f (dsTheme ds) of + Nothing -> id + Just (Theme.Style []) -> id + Just (Theme.Style codes) -> PP.ansi codes diff --git a/lib/Patat/Presentation/Display/Table.hs b/lib/Patat/Presentation/Display/Table.hs --- a/lib/Patat/Presentation/Display/Table.hs +++ b/lib/Patat/Presentation/Display/Table.hs @@ -10,11 +10,11 @@ -------------------------------------------------------------------------------- -import Data.List (intersperse, transpose) -import Patat.PrettyPrint ((<$$>)) -import qualified Patat.PrettyPrint as PP -import Patat.Theme (Theme (..)) -import qualified Patat.Theme as Theme +import Data.List (intersperse, transpose) +import Patat.Presentation.Display.Internal +import Patat.PrettyPrint ((<$$>)) +import qualified Patat.PrettyPrint as PP +import Patat.Theme (Theme (..)) import Prelude @@ -28,15 +28,15 @@ -------------------------------------------------------------------------------- -prettyTable - :: Theme -> Table -> PP.Doc -prettyTable theme@Theme {..} Table {..} = +prettyTable :: DisplaySettings -> Table -> PP.Doc +prettyTable ds Table {..} = PP.indent (PP.Trimmable " ") (PP.Trimmable " ") $ lineIf (not isHeaderLess) (hcat2 headerHeight - [ themed themeTableHeader (PP.align w a (vpad headerHeight header)) + [ themed ds themeTableHeader $ + PP.align w a (vpad headerHeight header) | (w, a, header) <- zip3 columnWidths tAligns tHeaders ]) <> - dashedHeaderSeparator theme columnWidths <$$> + dashedHeaderSeparator ds columnWidths <$$> joinRows [ hcat2 rowHeight [ PP.align w a (vpad rowHeight cell) @@ -44,7 +44,7 @@ ] | (rowHeight, row) <- zip rowHeights tRows ] <$$> - lineIf isHeaderLess (dashedHeaderSeparator theme columnWidths) <> + lineIf isHeaderLess (dashedHeaderSeparator ds columnWidths) <> lineIf (not $ PP.null tCaption) (PP.hardline <> "Table: " <> tCaption) where @@ -90,17 +90,9 @@ -------------------------------------------------------------------------------- -dashedHeaderSeparator :: Theme -> [Int] -> PP.Doc -dashedHeaderSeparator Theme {..} columnWidths = +dashedHeaderSeparator :: DisplaySettings -> [Int] -> PP.Doc +dashedHeaderSeparator ds columnWidths = mconcat $ intersperse (PP.string " ") - [ themed themeTableSeparator (PP.string (replicate w '-')) + [ themed ds themeTableSeparator (PP.string (replicate w '-')) | w <- columnWidths ] - - --------------------------------------------------------------------------------- --- | This does not really belong in the module. -themed :: Maybe Theme.Style -> PP.Doc -> PP.Doc -themed Nothing = id -themed (Just (Theme.Style [])) = id -themed (Just (Theme.Style codes)) = PP.ansi codes 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 @@ -20,6 +20,7 @@ , EvalSettings (..) , Slide (..) + , SlideContent (..) , Instruction.Fragment (..) , Index @@ -27,24 +28,30 @@ , numFragments , ActiveFragment (..) - , getActiveFragment + , activeFragment + , activeSpeakerNotes ) 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 qualified Data.HashMap.Strict as HMS -import Data.List (intercalate) -import Data.Maybe (fromMaybe, listToMaybe) -import qualified Data.Text as T -import qualified Patat.Presentation.Instruction as Instruction -import qualified Patat.Theme as Theme +import 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 qualified Patat.Presentation.Instruction as Instruction +import qualified Patat.Presentation.SpeakerNotes as SpeakerNotes +import qualified Patat.Theme as Theme import Prelude -import qualified Text.Pandoc as Pandoc -import Text.Read (readMaybe) +import qualified Skylighting as Skylighting +import qualified Text.Pandoc as Pandoc +import Text.Read (readMaybe) -------------------------------------------------------------------------------- @@ -57,9 +64,10 @@ , pTitle :: ![Pandoc.Inline] , pAuthor :: ![Pandoc.Inline] , pSettings :: !PresentationSettings - , pSlides :: [Slide] - , pBreadcrumbs :: [Breadcrumbs] -- One for each slide. + , pSlides :: !(Seq Slide) + , pBreadcrumbs :: !(Seq Breadcrumbs) -- One for each slide. , pActiveFragment :: !Index + , pSyntaxMap :: !Skylighting.SyntaxMap } deriving (Show) @@ -67,38 +75,42 @@ -- | 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) + { 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 = psRows l `mplus` psRows r - , psColumns = psColumns l `mplus` psColumns r - , psMargins = psMargins l <> psMargins r - , psWrap = psWrap l `mplus` psWrap r - , psTheme = psTheme l <> psTheme r - , psIncrementalLists = psIncrementalLists l `mplus` psIncrementalLists r - , psAutoAdvanceDelay = psAutoAdvanceDelay l `mplus` psAutoAdvanceDelay r - , psSlideLevel = psSlideLevel l `mplus` psSlideLevel r - , psPandocExtensions = psPandocExtensions l `mplus` psPandocExtensions r - , psImages = psImages l `mplus` psImages r - , psBreadcrumbs = psBreadcrumbs l `mplus` psBreadcrumbs r - , psEval = psEval l <> psEval r - , psSlideNumber = psSlideNumber l `mplus` psSlideNumber r + { 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 } @@ -107,25 +119,15 @@ mappend = (<>) mempty = PresentationSettings Nothing Nothing Nothing Nothing Nothing Nothing Nothing - Nothing Nothing Nothing Nothing Nothing Nothing + Nothing Nothing Nothing Nothing Nothing Nothing Nothing + Nothing -------------------------------------------------------------------------------- defaultPresentationSettings :: PresentationSettings -defaultPresentationSettings = PresentationSettings - { psRows = Nothing - , psColumns = Nothing - , psMargins = Just defaultMargins - , psWrap = Nothing +defaultPresentationSettings = mempty + { psMargins = Just defaultMargins , psTheme = Just Theme.defaultTheme - , psIncrementalLists = Nothing - , psAutoAdvanceDelay = Nothing - , psSlideLevel = Nothing - , psPandocExtensions = Nothing - , psImages = Nothing - , psBreadcrumbs = Nothing - , psEval = Nothing - , psSlideNumber = Nothing } @@ -258,7 +260,14 @@ -------------------------------------------------------------------------------- -data Slide +data Slide = Slide + { slideSpeakerNotes :: !SpeakerNotes.SpeakerNotes + , slideContent :: !SlideContent + } deriving (Show) + + +-------------------------------------------------------------------------------- +data SlideContent = ContentSlide (Instruction.Instructions Pandoc.Block) | TitleSlide Int [Pandoc.Inline] deriving (Show) @@ -271,13 +280,14 @@ -------------------------------------------------------------------------------- getSlide :: Int -> Presentation -> Maybe Slide -getSlide sidx = listToMaybe . drop sidx . pSlides +getSlide sidx = (`Seq.safeIndex` sidx) . pSlides -------------------------------------------------------------------------------- numFragments :: Slide -> Int -numFragments (ContentSlide instrs) = Instruction.numFragments instrs -numFragments (TitleSlide _ _) = 1 +numFragments slide = case slideContent slide of + ContentSlide instrs -> Instruction.numFragments instrs + TitleSlide _ _ -> 1 -------------------------------------------------------------------------------- @@ -288,15 +298,23 @@ -------------------------------------------------------------------------------- -getActiveFragment :: Presentation -> Maybe ActiveFragment -getActiveFragment presentation = do +activeFragment :: Presentation -> Maybe ActiveFragment +activeFragment presentation = do let (sidx, fidx) = pActiveFragment presentation slide <- getSlide sidx presentation - pure $ case slide of + pure $ case slideContent slide of TitleSlide lvl is -> ActiveTitle $ Pandoc.Header lvl Pandoc.nullAttr is ContentSlide instrs -> ActiveContent $ Instruction.renderFragment fidx instrs + + +-------------------------------------------------------------------------------- +activeSpeakerNotes :: Presentation -> SpeakerNotes.SpeakerNotes +activeSpeakerNotes presentation = fromMaybe mempty $ do + let (sidx, _) = pActiveFragment presentation + slide <- getSlide sidx presentation + pure $ slideSpeakerNotes slide -------------------------------------------------------------------------------- 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 @@ -7,33 +7,38 @@ ( readPresentation -- Exposed for testing mostly. + , detectSlideLevel , readMetaSettings ) where -------------------------------------------------------------------------------- -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 qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.Text.IO as T -import qualified Data.Yaml as Yaml -import Patat.Eval (eval) +import 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.Text.IO as T +import qualified Data.Yaml as Yaml +import Patat.Eval (eval) import Patat.Presentation.Fragment -import qualified Patat.Presentation.Instruction as Instruction +import qualified Patat.Presentation.Instruction as Instruction import Patat.Presentation.Internal +import qualified Patat.Presentation.SpeakerNotes as SpeakerNotes import Prelude -import System.Directory (doesFileExist, - getHomeDirectory) -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 (doesFileExist, + getHomeDirectory) +import System.FilePath (splitFileName, takeExtension, + ()) +import qualified Text.Pandoc.Error as Pandoc +import qualified Text.Pandoc.Extended as Pandoc -------------------------------------------------------------------------------- @@ -45,6 +50,8 @@ metaSettings <- ExceptT $ return $ readMetaSettings src let settings = metaSettings <> homeSettings <> defaultPresentationSettings + syntaxMap <- ExceptT $ readSyntaxMap $ fromMaybe [] $ + psSyntaxDefinitions settings let pexts = fromMaybe defaultExtensionList (psPandocExtensions settings) reader <- case readExtension pexts ext of Nothing -> throwError $ "Unknown file extension: " ++ show ext @@ -53,29 +60,39 @@ Left e -> throwError $ "Could not parse document: " ++ show e Right x -> return x - pres <- ExceptT $ pure $ pandocToPresentation filePath settings doc + pres <- ExceptT $ pure $ + pandocToPresentation filePath settings syntaxMap doc liftIO $ eval pres where ext = takeExtension filePath -------------------------------------------------------------------------------- +readSyntaxMap :: [FilePath] -> IO (Either String Skylighting.SyntaxMap) +readSyntaxMap = + runExceptT . + fmap (foldr Skylighting.addSyntaxDefinition mempty) . + traverse (ExceptT . Skylighting.loadSyntaxFromFile) + + +-------------------------------------------------------------------------------- readExtension :: ExtensionList -> String -> Maybe (T.Text -> Either Pandoc.PandocError Pandoc.Pandoc) readExtension (ExtensionList extensions) fileExt = case fileExt of - ".markdown" -> Just $ Pandoc.runPure . Pandoc.readMarkdown readerOpts - ".md" -> Just $ Pandoc.runPure . Pandoc.readMarkdown readerOpts - ".mdown" -> Just $ Pandoc.runPure . Pandoc.readMarkdown readerOpts - ".mdtext" -> Just $ Pandoc.runPure . Pandoc.readMarkdown readerOpts - ".mdtxt" -> Just $ Pandoc.runPure . Pandoc.readMarkdown readerOpts - ".mdwn" -> Just $ Pandoc.runPure . Pandoc.readMarkdown readerOpts - ".mkd" -> Just $ Pandoc.runPure . Pandoc.readMarkdown readerOpts - ".mkdn" -> Just $ Pandoc.runPure . Pandoc.readMarkdown readerOpts - ".lhs" -> Just $ Pandoc.runPure . Pandoc.readMarkdown lhsOpts - "" -> Just $ Pandoc.runPure . Pandoc.readMarkdown readerOpts - ".org" -> Just $ Pandoc.runPure . Pandoc.readOrg readerOpts - _ -> Nothing + ".markdown" -> Just $ Pandoc.runPure . Pandoc.readMarkdown readerOpts + ".md" -> Just $ Pandoc.runPure . Pandoc.readMarkdown readerOpts + ".mdown" -> Just $ Pandoc.runPure . Pandoc.readMarkdown readerOpts + ".mdtext" -> Just $ Pandoc.runPure . Pandoc.readMarkdown readerOpts + ".mdtxt" -> Just $ Pandoc.runPure . Pandoc.readMarkdown readerOpts + ".mdwn" -> Just $ Pandoc.runPure . Pandoc.readMarkdown readerOpts + ".mkd" -> Just $ Pandoc.runPure . Pandoc.readMarkdown readerOpts + ".mkdn" -> Just $ Pandoc.runPure . Pandoc.readMarkdown readerOpts + ".lhs" -> Just $ Pandoc.runPure . Pandoc.readMarkdown lhsOpts + "" -> Just $ Pandoc.runPure . Pandoc.readMarkdown readerOpts + ".org" -> Just $ Pandoc.runPure . Pandoc.readOrg readerOpts + ".txt" -> Just $ pure . Pandoc.readPlainText + _ -> Nothing where readerOpts = Pandoc.def @@ -95,9 +112,11 @@ -------------------------------------------------------------------------------- pandocToPresentation - :: FilePath -> PresentationSettings -> Pandoc.Pandoc + :: FilePath -> PresentationSettings -> Skylighting.SyntaxMap + -> Pandoc.Pandoc -> Either String Presentation -pandocToPresentation pFilePath pSettings pandoc@(Pandoc.Pandoc meta _) = do +pandocToPresentation pFilePath pSettings pSyntaxMap + pandoc@(Pandoc.Pandoc meta _) = do let !pTitle = case Pandoc.docTitle meta of [] -> [Pandoc.Str . T.pack . snd $ splitFileName pFilePath] title -> title @@ -155,19 +174,19 @@ -------------------------------------------------------------------------------- -pandocToSlides :: PresentationSettings -> Pandoc.Pandoc -> [Slide] +pandocToSlides :: PresentationSettings -> Pandoc.Pandoc -> Seq.Seq Slide pandocToSlides settings pandoc = let slideLevel = fromMaybe (detectSlideLevel pandoc) (psSlideLevel settings) unfragmented = splitSlides slideLevel pandoc - fragmented = - [ case slide of - TitleSlide _ _ -> slide - ContentSlide instrs0 -> ContentSlide $ - fragmentInstructions fragmentSettings instrs0 - | slide <- unfragmented - ] in - fragmented + fragmented = map fragmentSlide unfragmented in + Seq.fromList fragmented where + fragmentSlide slide = case slideContent slide of + TitleSlide _ _ -> slide + ContentSlide instrs0 -> + let instrs1 = fragmentInstructions fragmentSettings instrs0 in + slide {slideContent = ContentSlide instrs1} + fragmentSettings = FragmentSettings { fsIncrementalLists = fromMaybe False (psIncrementalLists settings) } @@ -178,16 +197,16 @@ -- header that occurs before a non-header in the blocks. detectSlideLevel :: Pandoc.Pandoc -> Int detectSlideLevel (Pandoc.Pandoc _meta blocks0) = - go 6 blocks0 + go 6 $ SpeakerNotes.remove blocks0 where go level (Pandoc.Header n _ _ : x : xs) - | n < level && nonHeader x = go n xs - | otherwise = go level (x:xs) - go level (_ : xs) = go level xs - go level [] = level + | n < level && not (isHeader x) = go n xs + | otherwise = go level (x:xs) + go level (_ : xs) = go level xs + go level [] = level - nonHeader (Pandoc.Header _ _ _) = False - nonHeader _ = True + isHeader (Pandoc.Header _ _ _) = True + isHeader _ = False -------------------------------------------------------------------------------- @@ -201,9 +220,10 @@ | otherwise = splitAtHeaders [] blocks0 where mkContentSlide :: [Pandoc.Block] -> [Slide] - mkContentSlide [] = [] -- Never create empty slides - mkContentSlide bs = - [ContentSlide $ Instruction.fromList [Instruction.Append bs]] + mkContentSlide bs0 = case SpeakerNotes.partition bs0 of + (_, []) -> [] -- Never create empty slides + (sn, bs1) -> pure . Slide sn . ContentSlide $ + Instruction.fromList [Instruction.Append bs1] splitAtRules blocks = case break (== Pandoc.HorizontalRule) blocks of (xs, []) -> mkContentSlide xs @@ -211,22 +231,27 @@ splitAtHeaders acc [] = mkContentSlide (reverse acc) - splitAtHeaders acc (b@(Pandoc.Header i _ txt) : bs) - | i > slideLevel = splitAtHeaders (b : acc) bs + splitAtHeaders acc (b@(Pandoc.Header i _ txt) : bs0) + | i > slideLevel = splitAtHeaders (b : acc) bs0 | i == slideLevel = - mkContentSlide (reverse acc) ++ splitAtHeaders [b] bs + mkContentSlide (reverse acc) ++ splitAtHeaders [b] bs0 | otherwise = - mkContentSlide (reverse acc) ++ [TitleSlide i txt] ++ - splitAtHeaders [] bs + let (sn, bs1) = SpeakerNotes.split bs0 in + mkContentSlide (reverse acc) ++ + [Slide sn $ TitleSlide i txt] ++ + splitAtHeaders [] bs1 splitAtHeaders acc (b : bs) = splitAtHeaders (b : acc) bs -collectBreadcrumbs :: [Slide] -> [Breadcrumbs] -collectBreadcrumbs = go [] + +-------------------------------------------------------------------------------- +collectBreadcrumbs :: Seq Slide -> Seq Breadcrumbs +collectBreadcrumbs = go [] . fmap slideContent where - go breadcrumbs = \case - [] -> [] - ContentSlide _ : slides -> breadcrumbs : go breadcrumbs slides - TitleSlide lvl inlines : slides -> + go breadcrumbs slides0 = case Seq.viewl slides0 of + Seq.EmptyL -> Seq.empty + ContentSlide _ Seq.:< slides -> + breadcrumbs `Seq.cons` go breadcrumbs slides + TitleSlide lvl inlines Seq.:< slides -> let parent = filter ((< lvl) . fst) breadcrumbs in - parent : go (parent ++ [(lvl, inlines)]) slides + parent `Seq.cons` go (parent ++ [(lvl, inlines)]) slides diff --git a/lib/Patat/Presentation/SpeakerNotes.hs b/lib/Patat/Presentation/SpeakerNotes.hs new file mode 100644 --- /dev/null +++ b/lib/Patat/Presentation/SpeakerNotes.hs @@ -0,0 +1,105 @@ +-------------------------------------------------------------------------------- +{-# 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 System.Directory (removeFile) +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 -> SpeakerNotes -> IO () +write h sn = do + change <- IORef.atomicModifyIORef' (hActive h) $ \old -> (sn, old /= sn) + when change $ T.writeFile (sFile $ hSettings h) $ toText sn + + +-------------------------------------------------------------------------------- +$(A.deriveFromJSON A.dropPrefixOptions ''Settings) diff --git a/lib/Text/Pandoc/Extended.hs b/lib/Text/Pandoc/Extended.hs --- a/lib/Text/Pandoc/Extended.hs +++ b/lib/Text/Pandoc/Extended.hs @@ -1,18 +1,21 @@ -------------------------------------------------------------------------------- -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} module Text.Pandoc.Extended ( module Text.Pandoc , plainToPara , newlineToSpace + + , readPlainText ) where -------------------------------------------------------------------------------- +import Data.Char (isSpace) import Data.Data.Extended (grecT) -import Text.Pandoc +import qualified Data.Text as T import Prelude +import Text.Pandoc -------------------------------------------------------------------------------- @@ -28,3 +31,18 @@ SoftBreak -> Space LineBreak -> Space inline -> inline + + +-------------------------------------------------------------------------------- +-- | A plain-text reader. Always returns empty metadata. +readPlainText :: T.Text -> Pandoc +readPlainText = Pandoc mempty . pure . Plain . go + where + go txt0 = case T.uncons txt0 of + Nothing -> [] + Just (' ', txt1) -> Space : go txt1 + Just ('\r', txt1) -> go txt1 + Just ('\n', txt1) -> SoftBreak : go txt1 + Just (c, txt1) -> + let (pre, post) = T.break isSpace txt1 in + Str (T.cons c pre) : go post diff --git a/patat.cabal b/patat.cabal --- a/patat.cabal +++ b/patat.cabal @@ -1,5 +1,5 @@ Name: patat -Version: 0.8.9.0 +Version: 0.9.0.0 Synopsis: Terminal-based presentations using Pandoc Description: Terminal-based presentations using Pandoc. License: GPL-2 @@ -76,12 +76,14 @@ Patat.Presentation Patat.Presentation.Display Patat.Presentation.Display.CodeBlock + Patat.Presentation.Display.Internal Patat.Presentation.Display.Table Patat.Presentation.Fragment Patat.Presentation.Instruction Patat.Presentation.Interactive Patat.Presentation.Internal Patat.Presentation.Read + Patat.Presentation.SpeakerNotes Patat.PrettyPrint Patat.Theme @@ -90,6 +92,7 @@ Data.Aeson.TH.Extended Data.Char.WCWidth.Extended Data.Data.Extended + Data.Sequence.Extended Paths_patat Text.Pandoc.Extended @@ -135,6 +138,7 @@ patat, base >= 4.8 && < 5, directory >= 1.2 && < 1.4, + pandoc >= 3.1 && < 3.2, tasty >= 1.2 && < 1.5, tasty-hunit >= 0.10 && < 0.11, tasty-quickcheck >= 0.10 && < 0.11, diff --git a/tests/haskell/Patat/Presentation/Read/Tests.hs b/tests/haskell/Patat/Presentation/Read/Tests.hs --- a/tests/haskell/Patat/Presentation/Read/Tests.hs +++ b/tests/haskell/Patat/Presentation/Read/Tests.hs @@ -3,31 +3,64 @@ ( tests ) where -import qualified Data.Text as T + +-------------------------------------------------------------------------------- import Patat.Presentation.Read import qualified Test.Tasty as Tasty import qualified Test.Tasty.HUnit as Tasty +import qualified Text.Pandoc as Pandoc + +-------------------------------------------------------------------------------- tests :: Tasty.TestTree tests = Tasty.testGroup "Patat.Presentation.Read.Tests" - [ Tasty.testCase "readMetaSettings" $ + [ testReadMetaSettings + , testDetectSlideLevel + ] + + +-------------------------------------------------------------------------------- +testReadMetaSettings :: Tasty.TestTree +testReadMetaSettings = Tasty.testCase "readMetaSettings" $ case readMetaSettings invalidMetadata of Left _ -> pure () Right _ -> Tasty.assertFailure "expecting invalid metadata" - ] + where + invalidMetadata = + "---\n\ + \title: mixing tabs and spaces bad\n\ + \author: thoastbrot\n\ + \patat:\n\ + \ images:\n\ + \ backend: 'w3m'\n\ + \ path: '/usr/lib/w3m/w3mimgdisplay'\n\ + \ theme:\n\ + \\theader: [vividBlue,onDullBlack]\n\ + \ emph: [dullBlue,italic]\n\ + \...\n\ + \\n\ + \Hi!" -invalidMetadata :: T.Text -invalidMetadata = - "---\n\ - \title: mixing tabs and spaces bad\n\ - \author: thoastbrot\n\ - \patat:\n\ - \ images:\n\ - \ backend: 'w3m'\n\ - \ path: '/usr/lib/w3m/w3mimgdisplay'\n\ - \ theme:\n\ - \\theader: [vividBlue,onDullBlack]\n\ - \ emph: [dullBlue,italic]\n\ - \...\n\ - \\n\ - \Hi!" + +-------------------------------------------------------------------------------- +testDetectSlideLevel :: Tasty.TestTree +testDetectSlideLevel = Tasty.testGroup "detectSlideLevel" + [ Tasty.testCase "01" $ + (Tasty.@=?) 1 $ detectSlideLevel $ Pandoc.Pandoc mempty + [ Pandoc.Header 1 mempty [Pandoc.Str "Intro"] + , Pandoc.Para [Pandoc.Str "Hi"] + ] + , Tasty.testCase "02" $ + (Tasty.@=?) 2 $ detectSlideLevel $ Pandoc.Pandoc mempty + [ Pandoc.Header 1 mempty [Pandoc.Str "Intro"] + , Pandoc.Header 2 mempty [Pandoc.Str "Detail"] + , Pandoc.Para [Pandoc.Str "Hi"] + ] + , Tasty.testCase "03" $ + (Tasty.@=?) 2 $ detectSlideLevel $ Pandoc.Pandoc mempty + [ Pandoc.Header 1 mempty [Pandoc.Str "Intro"] + , Pandoc.RawBlock "html" "" + , Pandoc.Header 2 mempty [Pandoc.Str "Detail"] + , Pandoc.Para [Pandoc.Str "Hi"] + ] + ]