diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,12 @@ # Changelog +- 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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -14,12 +14,13 @@ - 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. +- [Theming](#theming) support including 24-bit RGB. - [Auto advancing](#auto-advancing) with configurable delay. - 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. - Written in [Haskell]. ![screenshot](extra/screenshot.png?raw=true) @@ -47,6 +48,7 @@ - [Theming](#theming) - [Syntax Highlighting](#syntax-highlighting) - [Pandoc Extensions](#pandoc-extensions) + - [Images](#images) - [Trivia](#trivia) Installation @@ -54,6 +56,7 @@ ### Pre-built-packages +- Archlinux: - Debian: - Ubuntu: - openSUSE: @@ -138,24 +141,26 @@ The input format can be anything that Pandoc supports. Plain markdown is usually the most simple solution: - --- - title: This is my presentation - author: Jane Doe - ... +```markdown +--- +title: This is my presentation +author: Jane Doe +... - # This is a slide +# This is a slide - Slide contents. Yay. +Slide contents. Yay. - --- +--- - # Important title +# Important title - Things I like: +Things I like: - - Markdown - - Haskell - - Pandoc +- Markdown +- Haskell +- Pandoc +``` Horizontal rulers (`---`) are used to split slides. @@ -170,65 +175,70 @@ This means the following document is equivalent to the one we saw before: - --- - title: This is my presentation - author: Jane Doe - ... +```markdown +--- +title: This is my presentation +author: Jane Doe +... - # This is a slide +# This is a slide - Slide contents. Yay. +Slide contents. Yay. - # Important title +# Important title - Things I like: +Things I like: - - Markdown - - Haskell - - Pandoc +- Markdown +- Haskell +- Pandoc +``` And that following document contains three slides: a title slide, followed by two content slides. - --- - title: This is my presentation - author: Jane Doe - ... +```markdown +--- +title: This is my presentation +author: Jane Doe +... - # Chapter 1 +# Chapter 1 - ## This is a slide +## This is a slide - Slide contents. Yay. +Slide contents. Yay. - ## Another slide +## Another slide - Things I like: +Things I like: - - Markdown - - Haskell - - Pandoc +- Markdown +- Haskell +- Pandoc +``` For more information, see [Advanced slide splitting](#advanced-slide-splitting). Patat supports comments which can be used as speaker notes. - --- - title: This is my presentation - author: Jane Doe - ... - - # Chapter 1 +```markdown +--- +title: This is my presentation +author: Jane Doe +... - +# Chapter 1 - Slide contents. Yay. + - +Slide contents. Yay. + +``` Configuration ------------- @@ -244,14 +254,16 @@ For example, we set an option `key` to `val` by using the following file: - --- - title: Presentation with options - author: John Doe - patat: - key: val - ... +```markdown +--- +title: Presentation with options +author: John Doe +patat: + key: val +... - Hello world. +Hello world. +``` Or we can use a normal presentation and have the following `$HOME/.patat.yaml`: @@ -262,23 +274,48 @@ Line wrapping can be enabled by setting `wrap: true` in the configuration. This will re-wrap all lines to fit the terminal width better. +### Margins + +Margins can be enabled by setting a `margins` entry in the configuration: + +```markdown +--- +title: Presentation with margins +author: John Doe +patat: + wrap: true + margins: + left: 10 + right: 10 +... + +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. + +It is recommended to enable [line wrapping](#line-wrapping) along with this feature. + ### Auto advancing By setting `autoAdvanceDelay` to a number of seconds, `patat` will automatically advance to the next slide. - --- - title: Auto-advance, yes please - author: John Doe - patat: - autoAdvanceDelay: 2 - ... +```markdown +--- +title: Auto-advance, yes please +author: John Doe +patat: + autoAdvanceDelay: 2 +... - Hello World! +Hello World! - --- +--- - This slide will be shown two seconds after the presentation starts. +This slide will be shown two seconds after the presentation starts. +``` Note that changes to `autoAdvanceDelay` are not picked up automatically if you are running `patat --watch`. This requires restarting `patat`. @@ -290,26 +327,30 @@ non-header, but it can also be explicitly defined. For example, in the following document, the `slideLevel` defaults to **2**: - # This is a slide +```markdown +# This is a slide - ## This is a nested header +## This is a nested header - This is some content +This is some content +``` With `slideLevel` 2, the `h1` will turn into a "title slide", and the `h2` will be displayed at the top of the second slide. We can customize this by setting `slideLevel` manually: - --- - patat: - slideLevel: 1 - ... +```markdown +--- +patat: + slideLevel: 1 +... - # This is a slide +# This is a slide - ## This is a nested header +## This is a nested header - This is some content +This is some content +``` Now, we will only see one slide, which contains a nested header. @@ -322,16 +363,18 @@ This can be configured by settings `incrementalLists` to `true` in the metadata block: - --- - title: Presentation with incremental lists - author: John Doe - patat: - incrementalLists: true - ... +```markdown +--- +title: Presentation with incremental lists +author: John Doe +patat: + incrementalLists: true +... - - This list - - is displayed - - item by item +- This list +- is displayed +- item by item +``` Setting `incrementalLists` works on _all_ lists in the presentation. To flip the setting for a specific list, wrap it in a block quote. This will make the @@ -341,57 +384,63 @@ This example contains a sublist which is also displayed incrementally, and then a sublist which is displayed all at once (by merit of the block quote). - --- - title: Presentation with incremental lists - author: John Doe - patat: - incrementalLists: true - ... +```markdown +--- +title: Presentation with incremental lists +author: John Doe +patat: + incrementalLists: true +... - - This list - - is displayed +- This list +- is displayed - * item - * by item + * item + * by item - - Or sometimes +- Or sometimes - > * all at - > * once + > * all at + > * once +``` Another way to break up slides is to use a pagraph only containing three dots separated by spaces. For example, this slide has two pauses: - Legen +```markdown +Legen - . . . +. . . - wait for it +wait for it - . . . +. . . - Dary! +Dary! +``` ### Theming Colors and other properties can also be changed using this configuration. For example, we can have: - --- - author: 'Jasper Van der Jeugt' - title: 'This is a test' - patat: - wrap: true - theme: - emph: [vividBlue, onVividBlack, bold] - imageTarget: [onDullWhite, vividRed] - ... +```markdown +--- +author: 'Jasper Van der Jeugt' +title: 'This is a test' +patat: + wrap: true + theme: + emph: [vividBlue, onVividBlack, bold] + imageTarget: [onDullWhite, vividRed] +... - # This is a presentation +# This is a presentation - This is _emph_ text. +This is _emph_ text. - ![Hello](foo.png) +![Hello](foo.png) +``` The properties that can be given a list of styles are: @@ -410,19 +459,27 @@ `vividBlue`, `vividCyan`, `vividGreen`, `vividMagenta`, `vividRed`, `vividWhite`, `vividYellow` +Also accepted are styles of the form `rgb#RrGgBb` and `onRgb#RrGgBb`, where `Rr` +`Gg` and `Bb` are hexadecimal bytes (e.g. `rgb#f08000` for an orange foreground, +and `onRgb#101060` for a deep purple background). Naturally, your terminal +needs to support 24-bit RGB for this to work. When creating portable +presentations, it might be better to stick with the named colours listed above. + ### Syntax Highlighting As part of theming, syntax highlighting is also configurable. This can be configured like this: - --- - patat: - theme: - syntaxHighlighting: - decVal: [bold, onDullRed] - ... +``` +--- +patat: + theme: + syntaxHighlighting: + decVal: [bold, onDullRed] +... - ... +... +``` `decVal` refers to "decimal values". This is known as a "token type". For a full list of token types, see [this list] -- the names are derived from there in @@ -432,41 +489,81 @@ ### Pandoc Extensions -Pandoc comes with a fair number of extensions on top of markdown: - - +Pandoc comes with a fair number of extensions on top of markdown, listed [here](https://hackage.haskell.org/package/pandoc-2.0.5/docs/Text-Pandoc-Extensions.html). `patat` enables a number of them by default, but this is also customizable. In order to enable an additional extensions, e.g. `autolink_bare_uris`, add it to the `pandocExtensions` field in the YAML metadata: - --- - patat: - pandocExtensions: - - patat_extensions - - autolink_bare_uris - ... +```markdown +--- +patat: + pandocExtensions: + - patat_extensions + - autolink_bare_uris +... - Document content... +Document content... +``` The `patat_extensions` in the above snippet refers to the default set of extensions enabled by `patat`. If you want to disable those and only use a select few extensions, simply leave it out and choose your own: - --- - patat: - pandocExtensions: - - autolink_bare_uris - - emoji - ... +```markdown +--- +patat: + pandocExtensions: + - autolink_bare_uris + - emoji +... - ... +... - Document content... +Document content... +``` If you don't want to enable any extensions, simply set `pandocExtensions` to the empty list `[]`. + + +### Images + +`patat-0.8.0.0` and newer include images support for some terminal emulators. + +```markdown +--- +patat: + images: + backend: auto +... + +# A slide with only an image. + +![](matterhorn.jpg) +``` + +If `images` is enabled (not by default), `patat` will draw slides that consist +only of a single image just by drawing the image, centered and resized to fit +the terminal window. + +`patat` supports the following image drawing backends: + +- `backend: iterm2`: uses [iTerm2](https://iterm2.com/)'s special escape + sequence to render the image. This even works with animated GIFs! + +- `backend: w3m`: uses the `w3mimgdisplay` executable to draw directly onto + the window. This has been tested in `urxvt` and `xterm`, but is known to + produce weird results in `tmux`. + + If `w3mimgdisplay` is in a non-standard location, you can specify that using + `path`: + + ```yaml + backend: 'w3m + path: '/home/jasper/.local/bin/w3mimgdisplay' + ``` Trivia ------ diff --git a/extra/make-man.hs b/extra/make-man.hs --- a/extra/make-man.hs +++ b/extra/make-man.hs @@ -30,11 +30,6 @@ where locale = Time.defaultTimeLocale -removeLinks :: Pandoc.Pandoc -> Pandoc.Pandoc -removeLinks = Pandoc.bottomUp $ \inline -> case inline of - Pandoc.Link _ inlines _ -> Pandoc.Emph inlines - _ -> inline - type Sections = [(Int, T.Text, [Pandoc.Block])] toSections :: Int -> [Pandoc.Block] -> Sections @@ -120,7 +115,7 @@ ] } - let pandoc1 = reorganizeSections $ removeLinks pandoc0 + let pandoc1 = reorganizeSections $ pandoc0 txt <- Pandoc.writeMan writerOptions pandoc1 liftIO $ do T.putStr txt diff --git a/patat.cabal b/patat.cabal --- a/patat.cabal +++ b/patat.cabal @@ -1,5 +1,5 @@ Name: patat -Version: 0.7.2.0 +Version: 0.8.0.0 Synopsis: Terminal-based presentations using Pandoc Description: Terminal-based presentations using Pandoc License: GPL-2 @@ -32,23 +32,26 @@ Default-language: Haskell2010 Build-depends: - aeson >= 0.9 && < 1.4, + aeson >= 0.9 && < 1.5, ansi-terminal >= 0.6 && < 0.9, ansi-wl-pprint >= 0.6 && < 0.7, base >= 4.6 && < 5, + base64-bytestring >= 1.0 && < 1.1, bytestring >= 0.10 && < 0.11, - containers >= 0.5 && < 0.6, + colour >= 2.3 && < 2.4, + containers >= 0.5 && < 0.7, directory >= 1.2 && < 1.4, filepath >= 1.4 && < 1.5, mtl >= 2.2 && < 2.3, optparse-applicative >= 0.12 && < 0.15, pandoc >= 2.0.4 && < 2.3, + process >= 1.6 && < 1.7, skylighting >= 0.1 && < 0.8, terminal-size >= 0.3 && < 0.4, text >= 1.2 && < 1.3, time >= 1.4 && < 1.10, unordered-containers >= 0.2 && < 0.3, - yaml >= 0.7 && < 0.9, + yaml >= 0.8 && < 0.11, -- We don't even depend on these packages but they can break cabal install -- because of the conflicting 'Network.URI' module. network-uri >= 2.6, @@ -63,6 +66,10 @@ Data.Aeson.TH.Extended Data.Data.Extended Patat.AutoAdvance + Patat.Images + Patat.Images.Internal + Patat.Images.W3m + Patat.Images.ITerm2 Patat.Presentation Patat.Presentation.Display Patat.Presentation.Display.CodeBlock diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -17,6 +17,7 @@ import Data.Version (showVersion) import qualified Options.Applicative as OA import Patat.AutoAdvance +import qualified Patat.Images as Images import Patat.Presentation import qualified Paths_patat import Prelude @@ -127,12 +128,15 @@ unless (oForce options) assertAnsiFeatures + -- (Maybe) initialize images backend. + images <- traverse Images.new (psImages $ pSettings pres) + if oDump options then dumpPresentation pres - else interactiveLoop options pres + else interactiveLoop options images pres where - interactiveLoop :: Options -> Presentation -> IO () - interactiveLoop options pres0 = (`finally` cleanup) $ do + interactiveLoop :: Options -> Maybe Images.Handle -> Presentation -> IO () + interactiveLoop options images pres0 = (`finally` cleanup) $ do IO.hSetBuffering IO.stdin IO.NoBuffering Ansi.hideCursor @@ -155,7 +159,7 @@ let loop :: Presentation -> Maybe String -> IO () loop pres mbError = do case mbError of - Nothing -> displayPresentation pres + Nothing -> displayPresentation images pres Just err -> displayPresentationError pres err c <- Chan.readChan commandChan diff --git a/src/Patat/Images.hs b/src/Patat/Images.hs new file mode 100644 --- /dev/null +++ b/src/Patat/Images.hs @@ -0,0 +1,60 @@ +-------------------------------------------------------------------------------- +{-# LANGUAGE OverloadedStrings #-} +module Patat.Images + ( Backend + , Handle + , new + , drawImage + ) where + + +-------------------------------------------------------------------------------- +import Control.Exception (catch) +import qualified Data.Aeson as A +import qualified Data.Text as T +import Patat.Images.Internal +import qualified Patat.Images.ITerm2 as ITerm2 +import qualified Patat.Images.W3m as W3m +import Patat.Presentation.Internal + + +-------------------------------------------------------------------------------- +new :: ImageSettings -> IO Handle +new is + | isBackend is == "auto" = auto + | Just (Backend b) <- lookup (isBackend is) backends = + case A.fromJSON (A.Object $ isParams is) of + A.Success c -> b (Explicit c) + A.Error err -> fail $ + "Patat.Images.new: Error parsing config for " ++ + show (isBackend is) ++ " image backend: " ++ err +new is = fail $ + "Patat.Images.new: Could not find " ++ show (isBackend is) ++ + " image backend." + + +-------------------------------------------------------------------------------- +auto :: IO Handle +auto = go [] backends + where + go names ((name, Backend b) : bs) = catch + (b Auto) + (\(BackendNotSupported _) -> go (name : names) bs) + go names [] = fail $ + "Could not find a supported backend, tried: " ++ + T.unpack (T.intercalate ", " (reverse names)) + + +-------------------------------------------------------------------------------- +-- | All supported backends. We can use CPP to include or exclude some +-- depending on platform availability. +backends :: [(T.Text, Backend)] +backends = + [ ("iterm2", ITerm2.backend) + , ("w3m", W3m.backend) + ] + + +-------------------------------------------------------------------------------- +drawImage :: Handle -> FilePath -> IO () +drawImage = hDrawImage diff --git a/src/Patat/Images/ITerm2.hs b/src/Patat/Images/ITerm2.hs new file mode 100644 --- /dev/null +++ b/src/Patat/Images/ITerm2.hs @@ -0,0 +1,56 @@ +-------------------------------------------------------------------------------- +{-# LANGUAGE TemplateHaskell #-} +module Patat.Images.ITerm2 + ( backend + ) where + + +-------------------------------------------------------------------------------- +import Control.Exception (throwIO) +import Control.Monad (unless, when) +import qualified Data.Aeson as A +import qualified Data.ByteString.Base64.Lazy as B64 +import qualified Data.ByteString.Lazy as BL +import qualified Data.List as L +import qualified Patat.Images.Internal as Internal +import System.Environment (lookupEnv) + + +-------------------------------------------------------------------------------- +backend :: Internal.Backend +backend = Internal.Backend new + + +-------------------------------------------------------------------------------- +data Config = Config deriving (Eq) +instance A.FromJSON Config where parseJSON _ = return Config + + +-------------------------------------------------------------------------------- +new :: Internal.Config Config -> IO Internal.Handle +new config = do + when (config == Internal.Auto) $ do + termProgram <- lookupEnv "TERM_PROGRAM" + unless (termProgram == Just "iTerm.app") $ throwIO $ + Internal.BackendNotSupported "TERM_PROGRAM not iTerm.app" + + return Internal.Handle {Internal.hDrawImage = drawImage} + + +-------------------------------------------------------------------------------- +drawImage :: FilePath -> IO () +drawImage path = do + content <- BL.readFile path + withEscapeSequence $ do + putStr "1337;File=inline=1;width=100%;height=100%:" + BL.putStr (B64.encode content) + + +-------------------------------------------------------------------------------- +withEscapeSequence :: IO () -> IO () +withEscapeSequence f = do + term <- lookupEnv "TERM" + let inScreen = maybe False ("screen" `L.isPrefixOf`) term + putStr $ if inScreen then "\ESCPtmux;\ESC\ESC]" else "\ESC]" + f + putStrLn $ if inScreen then "\a\ESC\\" else "\a" diff --git a/src/Patat/Images/Internal.hs b/src/Patat/Images/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Patat/Images/Internal.hs @@ -0,0 +1,36 @@ +-------------------------------------------------------------------------------- +{-# LANGUAGE ExistentialQuantification #-} +module Patat.Images.Internal + ( Config (..) + , Backend (..) + , BackendNotSupported (..) + , Handle (..) + ) where + + +-------------------------------------------------------------------------------- +import Control.Exception (Exception) +import qualified Data.Aeson as A + + +-------------------------------------------------------------------------------- +data Config a = Auto | Explicit a deriving (Eq) + + +-------------------------------------------------------------------------------- +data Backend = forall a. A.FromJSON a => Backend (Config a -> IO Handle) + + +-------------------------------------------------------------------------------- +data BackendNotSupported = BackendNotSupported String + deriving (Show) + + +-------------------------------------------------------------------------------- +instance Exception BackendNotSupported + + +-------------------------------------------------------------------------------- +data Handle = Handle + { hDrawImage :: FilePath -> IO () + } diff --git a/src/Patat/Images/W3m.hs b/src/Patat/Images/W3m.hs new file mode 100644 --- /dev/null +++ b/src/Patat/Images/W3m.hs @@ -0,0 +1,145 @@ +-------------------------------------------------------------------------------- +{-# LANGUAGE TemplateHaskell #-} +module Patat.Images.W3m + ( backend + ) where + + +-------------------------------------------------------------------------------- +import Control.Exception (throwIO) +import Control.Monad (unless) +import qualified Data.Aeson.TH.Extended as A +import qualified Patat.Images.Internal as Internal +import qualified System.Directory as Directory +import qualified System.Process as Process +import Text.Read (readMaybe) + + +-------------------------------------------------------------------------------- +backend :: Internal.Backend +backend = Internal.Backend new + + +-------------------------------------------------------------------------------- +data Config = Config + { cPath :: Maybe FilePath + } deriving (Show) + + +-------------------------------------------------------------------------------- +new :: Internal.Config Config -> IO Internal.Handle +new config = do + w3m <- findW3m $ case config of + Internal.Explicit c -> cPath c + _ -> Nothing + + return Internal.Handle {Internal.hDrawImage = drawImage w3m} + + +-------------------------------------------------------------------------------- +newtype W3m = W3m FilePath deriving (Show) + + +-------------------------------------------------------------------------------- +findW3m :: Maybe FilePath -> IO W3m +findW3m mbPath + | Just path <- mbPath = do + exe <- isExecutable path + if exe + then return (W3m path) + else throwIO $ + Internal.BackendNotSupported $ path ++ " is not executable" + | otherwise = W3m <$> find paths + where + find [] = throwIO $ Internal.BackendNotSupported + "w3mimgdisplay executable not found" + find (p : ps) = do + exe <- isExecutable p + if exe then return p else find ps + + paths = + [ "/usr/lib/w3m/w3mimgdisplay" + , "/usr/libexec/w3m/w3mimgdisplay" + , "/usr/lib64/w3m/w3mimgdisplay" + , "/usr/libexec64/w3m/w3mimgdisplay" + , "/usr/local/libexec/w3m/w3mimgdisplay" + ] + + isExecutable path = do + exists <- Directory.doesFileExist path + if exists then do + perms <- Directory.getPermissions path + return (Directory.executable perms) + else + return False + + +-------------------------------------------------------------------------------- +-- | Parses something of the form " \n". +parseWidthHeight :: String -> Maybe (Int, Int) +parseWidthHeight output = case words output of + [ws, hs] | Just w <- readMaybe ws, Just h <- readMaybe hs -> + return (w, h) + _ -> Nothing + + +-------------------------------------------------------------------------------- +getTerminalSize :: W3m -> IO (Int, Int) +getTerminalSize (W3m w3mPath) = do + output <- Process.readProcess w3mPath ["-test"] "" + case parseWidthHeight output of + Just wh -> return wh + _ -> fail $ + "Patat.Images.W3m.getTerminalSize: " ++ + "Could not parse `w3mimgdisplay -test` output" + + +-------------------------------------------------------------------------------- +getImageSize :: W3m -> FilePath -> IO (Int, Int) +getImageSize (W3m w3mPath) path = do + output <- Process.readProcess w3mPath [] ("5;" ++ path ++ "\n") + case parseWidthHeight output of + Just wh -> return wh + _ -> fail $ + "Patat.Images.W3m.getImageSize: " ++ + "Could not parse image size using `w3mimgdisplay` for " ++ + path + + +-------------------------------------------------------------------------------- +drawImage :: W3m -> FilePath -> IO () +drawImage w3m@(W3m w3mPath) path = do + exists <- Directory.doesFileExist path + unless exists $ fail $ + "Patat.Images.W3m.drawImage: file does not exist: " ++ path + + tsize <- getTerminalSize w3m + isize <- getImageSize w3m path + let (x, y, w, h) = fit tsize isize + command = + "0;1;" ++ + show x ++ ";" ++ show y ++ ";" ++ show w ++ ";" ++ show h ++ + ";;;;;" ++ path ++ "\n4;\n3;\n" + + _ <- Process.readProcess w3mPath [] command + return () + where + fit :: (Int, Int) -> (Int, Int) -> (Int, Int, Int, Int) + fit (tw, th) (iw0, ih0) = + -- Scale down to width + let iw1 = if iw0 > tw then tw else iw0 + ih1 = if iw0 > tw then ((ih0 * tw) `div` iw0) else ih0 + + -- Scale down to height + iw2 = if ih1 > th then ((iw1 * th) `div` ih1) else iw1 + ih2 = if ih1 > th then th else ih1 + + -- Find position + x = (tw - iw2) `div` 2 + y = (th - ih2) `div` 2 in + + (x, y, iw2, ih2) + + +-------------------------------------------------------------------------------- +$(A.deriveFromJSON A.dropPrefixOptions ''Config) diff --git a/src/Patat/Presentation/Display.hs b/src/Patat/Presentation/Display.hs --- a/src/Patat/Presentation/Display.hs +++ b/src/Patat/Presentation/Display.hs @@ -19,6 +19,7 @@ import Data.Maybe (fromMaybe) import Data.Monoid (mconcat, mempty, (<>)) import qualified Data.Text as T +import qualified Patat.Images as Images import Patat.Presentation.Display.CodeBlock import Patat.Presentation.Display.Table import Patat.Presentation.Internal @@ -40,7 +41,8 @@ -------------------------------------------------------------------------------- -- | Display something within the presentation borders that draw the title and -- the active slide number and so on. -displayWithBorders :: Presentation -> (CanvasSize -> Theme -> PP.Doc) -> IO () +displayWithBorders + :: Presentation -> (CanvasSize -> Theme -> PP.Doc) -> IO () displayWithBorders Presentation {..} f = do Ansi.clearScreen Ansi.setCursorPosition 0 0 @@ -62,42 +64,74 @@ borders = themed (themeBorders theme) unless (null title) $ do - Ansi.setCursorColumn titleOffset - PP.putDoc $ borders $ PP.string title + let titleRemainder = columns - titleWidth - titleOffset + wrappedTitle = PP.spaces titleOffset <> PP.string title <> PP.spaces titleRemainder + PP.putDoc $ borders wrappedTitle putStrLn "" putStrLn "" let canvasSize = CanvasSize (rows - 2) columns - PP.putDoc $ withWrapSettings settings $ f canvasSize theme + PP.putDoc $ formatWith settings $ f canvasSize theme putStrLn "" - let (sidx, _) = pActiveFragment - active = show (sidx + 1) ++ " / " ++ show (length pSlides) - activeWidth = length active + let (sidx, _) = pActiveFragment + active = show (sidx + 1) ++ " / " ++ show (length pSlides) + activeWidth = length active + author = PP.toString (prettyInlines theme pAuthor) + authorWidth = length author + middleSpaces = PP.spaces $ columns - activeWidth - authorWidth - 2 Ansi.setCursorPosition (rows - 1) 0 - PP.putDoc $ " " <> borders (prettyInlines theme pAuthor) - Ansi.setCursorColumn (columns - activeWidth - 1) - PP.putDoc $ borders $ PP.string active + PP.putDoc $ borders $ PP.space <> PP.string author <> middleSpaces <> PP.string active <> PP.space IO.hFlush IO.stdout -------------------------------------------------------------------------------- -displayPresentation :: Presentation -> IO () -displayPresentation pres@Presentation {..} = displayWithBorders pres $ - \canvasSize theme -> case getActiveFragment pres of - Nothing -> mempty - Just (ActiveContent fragment) -> prettyFragment theme fragment +displayImage :: Images.Handle -> FilePath -> IO () +displayImage images path = do + Ansi.clearScreen + Ansi.setCursorPosition 0 0 + putStrLn "" + IO.hFlush IO.stdout + Images.drawImage images path + + +-------------------------------------------------------------------------------- +displayPresentation :: Maybe Images.Handle -> Presentation -> IO () +displayPresentation mbImages pres@Presentation {..} = + case getActiveFragment pres of + Nothing -> displayWithBorders pres mempty + Just (ActiveContent fragment) + | Just images <- mbImages + , Just image <- onlyImage fragment -> + displayImage images image + Just (ActiveContent fragment) -> + displayWithBorders pres $ \_canvasSize theme -> + prettyFragment theme fragment Just (ActiveTitle block) -> + displayWithBorders pres $ \canvasSize theme -> let pblock = prettyBlock theme block (prows, pcols) = PP.dimensions pblock offsetRow = (csRows canvasSize `div` 2) - (prows `div` 2) offsetCol = (csCols canvasSize `div` 2) - (pcols `div` 2) - spaces = mconcat (replicate offsetCol PP.space) in + spaces = PP.NotTrimmable $ PP.spaces offsetCol in mconcat (replicate (offsetRow - 3) PP.hardline) <$$> - PP.indent (PP.NotTrimmable spaces) (PP.NotTrimmable spaces) pblock + PP.indent spaces spaces pblock + where + -- Check if the fragment consists of just a single image, or a header and + -- some image. + onlyImage (Fragment blocks) + | [Pandoc.Para para] <- filter isVisibleBlock blocks + , [Pandoc.Image _ _ (target, _)] <- para = + Just target + onlyImage (Fragment blocks) + | [Pandoc.Header _ _ _, Pandoc.Para para] <- filter isVisibleBlock blocks + , [Pandoc.Image _ _ (target, _)] <- para = + Just target + onlyImage _ = Nothing + -------------------------------------------------------------------------------- -- | Displays an error in the place of the presentation. This is useful if we -- want to display an error but keep the presentation running. @@ -111,8 +145,9 @@ -------------------------------------------------------------------------------- dumpPresentation :: Presentation -> IO () dumpPresentation pres = - let theme = fromMaybe Theme.defaultTheme (psTheme $ pSettings pres) in - PP.putDoc $ withWrapSettings (pSettings pres) $ + let settings = pSettings pres + theme = fromMaybe Theme.defaultTheme (psTheme $ settings) in + PP.putDoc $ formatWith settings $ PP.vcat $ L.intersperse "----------" $ do slide <- pSlides pres return $ case slide of @@ -123,11 +158,15 @@ -------------------------------------------------------------------------------- -withWrapSettings :: PresentationSettings -> PP.Doc -> PP.Doc -withWrapSettings ps = case (psWrap ps, psColumns ps) of - (Just True, Just (A.FlexibleNum col)) -> PP.wrapAt (Just col) - _ -> id - +formatWith :: PresentationSettings -> PP.Doc -> PP.Doc +formatWith ps = wrap . indent + where + (marginLeft, marginRight) = marginsOf ps + wrap = case (psWrap ps, psColumns ps) of + (Just True, Just (A.FlexibleNum col)) -> PP.wrapAt (Just $ col - marginRight) + _ -> id + spaces = PP.NotTrimmable $ PP.spaces marginLeft + indent = PP.indent spaces spaces -------------------------------------------------------------------------------- prettyFragment :: Theme -> Fragment -> PP.Doc diff --git a/src/Patat/Presentation/Internal.hs b/src/Patat/Presentation/Internal.hs --- a/src/Patat/Presentation/Internal.hs +++ b/src/Patat/Presentation/Internal.hs @@ -7,9 +7,14 @@ , PresentationSettings (..) , defaultPresentationSettings + , Margins (..) + , marginsOf + , ExtensionList (..) , defaultExtensionList + , ImageSettings (..) + , Slide (..) , Fragment (..) , Index @@ -28,7 +33,7 @@ import qualified Data.Aeson.TH.Extended as A import qualified Data.Foldable as Foldable import Data.List (intercalate) -import Data.Maybe (listToMaybe) +import Data.Maybe (fromMaybe, listToMaybe) import Data.Monoid (Monoid (..)) import Data.Semigroup (Semigroup (..)) import qualified Data.Text as T @@ -55,12 +60,14 @@ 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) } deriving (Show) @@ -69,20 +76,23 @@ 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 } + -------------------------------------------------------------------------------- instance Monoid PresentationSettings where mappend = (<>) mempty = PresentationSettings Nothing Nothing Nothing Nothing Nothing Nothing Nothing - Nothing + Nothing Nothing Nothing -------------------------------------------------------------------------------- @@ -90,16 +100,57 @@ defaultPresentationSettings = PresentationSettings { psRows = Nothing , psColumns = Nothing + , psMargins = Just defaultMargins , psWrap = Nothing , psTheme = Just Theme.defaultTheme , psIncrementalLists = Nothing , psAutoAdvanceDelay = Nothing , psSlideLevel = Nothing , psPandocExtensions = Nothing + , psImages = Nothing } -------------------------------------------------------------------------------- +data Margins = Margins + { mLeft :: !(Maybe (A.FlexibleNum Int)) + , mRight :: !(Maybe (A.FlexibleNum 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 + } + + +-------------------------------------------------------------------------------- +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) @@ -153,6 +204,20 @@ -------------------------------------------------------------------------------- +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} + + +-------------------------------------------------------------------------------- data Slide = ContentSlide [Fragment] | TitleSlide Pandoc.Block @@ -198,3 +263,4 @@ -------------------------------------------------------------------------------- $(A.deriveFromJSON A.dropPrefixOptions ''PresentationSettings) +$(A.deriveFromJSON A.dropPrefixOptions ''Margins) diff --git a/src/Patat/Presentation/Read.hs b/src/Patat/Presentation/Read.hs --- a/src/Patat/Presentation/Read.hs +++ b/src/Patat/Presentation/Read.hs @@ -12,7 +12,6 @@ throwError) import Control.Monad.Trans (liftIO) import qualified Data.Aeson as A -import qualified Data.ByteString as B import qualified Data.HashMap.Strict as HMS import Data.Maybe (fromMaybe) import Data.Monoid (mempty, (<>)) @@ -97,8 +96,8 @@ -- since those /can/ contain markdown. parseMetadataBlock :: T.Text -> Maybe A.Value parseMetadataBlock src = do - block <- mbBlock - Yaml.decode $! T.encodeUtf8 block + block <- T.encodeUtf8 <$> mbBlock + either (const Nothing) Just (Yaml.decodeEither' block) where mbBlock :: Maybe T.Text mbBlock = case T.lines src of @@ -132,8 +131,10 @@ if not exists then return (Right mempty) else do - contents <- B.readFile path - return $! Yaml.decodeEither contents + errOrPs <- Yaml.decodeFileEither path + return $! case errOrPs of + Left err -> Left (show err) + Right ps -> Right ps -------------------------------------------------------------------------------- diff --git a/src/Patat/PrettyPrint.hs b/src/Patat/PrettyPrint.hs --- a/src/Patat/PrettyPrint.hs +++ b/src/Patat/PrettyPrint.hs @@ -17,6 +17,7 @@ , string , text , space + , spaces , softline , hardline @@ -319,6 +320,11 @@ -------------------------------------------------------------------------------- +spaces :: Int -> Doc +spaces n = mconcat $ replicate n space + + +-------------------------------------------------------------------------------- softline :: Doc softline = mkDoc Softline @@ -383,15 +389,15 @@ alignLine :: [Chunk] -> [Chunk] alignLine line = - let actual = lineWidth line - spaces n = [StringChunk [] (replicate n ' ')] in + let actual = lineWidth line + chunkSpaces n = [StringChunk [] (replicate n ' ')] in case alignment of - AlignLeft -> line <> spaces (width - actual) - AlignRight -> spaces (width - actual) <> line + AlignLeft -> line <> chunkSpaces (width - actual) + AlignRight -> chunkSpaces (width - actual) <> line AlignCenter -> let r = (width - actual) `div` 2 l = (width - actual) - r in - spaces l <> line <> spaces r + chunkSpaces l <> line <> chunkSpaces r -------------------------------------------------------------------------------- diff --git a/src/Patat/Theme.hs b/src/Patat/Theme.hs --- a/src/Patat/Theme.hs +++ b/src/Patat/Theme.hs @@ -15,20 +15,22 @@ -------------------------------------------------------------------------------- -import Control.Monad (forM_, mplus) -import qualified Data.Aeson as A -import qualified Data.Aeson.TH.Extended as A -import Data.Char (toLower, toUpper) -import Data.List (intercalate, isSuffixOf) -import qualified Data.Map as M -import Data.Maybe (mapMaybe, maybeToList) -import Data.Monoid (Monoid (..)) -import Data.Semigroup (Semigroup (..)) -import qualified Data.Text as T +import Control.Monad (forM_, mplus) +import qualified Data.Aeson as A +import qualified Data.Aeson.TH.Extended as A +import Data.Char (toLower, toUpper) +import Data.Colour.SRGB (RGB(..), sRGB24reads, toSRGB24) +import Data.List (intercalate, isPrefixOf, isSuffixOf) +import qualified Data.Map as M +import Data.Maybe (mapMaybe, maybeToList) +import Data.Monoid (Monoid (..)) +import Data.Semigroup (Semigroup (..)) +import qualified Data.Text as T +import Numeric (showHex) import Prelude -import qualified Skylighting as Skylighting -import qualified System.Console.ANSI as Ansi -import Text.Read (readMaybe) +import qualified Skylighting as Skylighting +import qualified System.Console.ANSI as Ansi +import Text.Read (readMaybe) -------------------------------------------------------------------------------- @@ -140,7 +142,7 @@ -------------------------------------------------------------------------------- instance A.ToJSON Style where - toJSON = A.toJSON . mapMaybe nameForSGR . unStyle + toJSON = A.toJSON . mapMaybe sgrToString . unStyle -------------------------------------------------------------------------------- @@ -150,16 +152,34 @@ sgrs <- mapM toSgr names return $! Style sgrs where - toSgr name = case M.lookup name sgrsByName of + toSgr name = case stringToSgr name of Just sgr -> return sgr Nothing -> fail $! "Unknown style: " ++ show name ++ ". Known styles are: " ++ - intercalate ", " (map show $ M.keys sgrsByName) + intercalate ", " (map show $ M.keys namedSgrs) ++ + ", or \"rgb#RrGgBb\" and \"onRgb#RrGgBb\" where 'Rr', " ++ + "'Gg' and 'Bb' are hexadecimal bytes (e.g. \"rgb#f08000\")." -------------------------------------------------------------------------------- -nameForSGR :: Ansi.SGR -> Maybe String -nameForSGR (Ansi.SetColor layer intensity color) = Just $ +stringToSgr :: String -> Maybe Ansi.SGR +stringToSgr s + | "rgb#" `isPrefixOf` s = rgbToSgr Ansi.Foreground $ drop 4 s + | "onRgb#" `isPrefixOf` s = rgbToSgr Ansi.Background $ drop 6 s + | otherwise = M.lookup s namedSgrs + + +-------------------------------------------------------------------------------- +rgbToSgr :: Ansi.ConsoleLayer -> String -> Maybe Ansi.SGR +rgbToSgr layer rgbHex = + case sRGB24reads rgbHex of + [(color, "")] -> Just $ Ansi.SetRGBColor layer color + _ -> Nothing + + +-------------------------------------------------------------------------------- +sgrToString :: Ansi.SGR -> Maybe String +sgrToString (Ansi.SetColor layer intensity color) = Just $ (\str -> case layer of Ansi.Foreground -> str Ansi.Background -> "on" ++ capitalize str) $ @@ -176,23 +196,34 @@ Ansi.Cyan -> "Cyan" Ansi.White -> "White") -nameForSGR (Ansi.SetUnderlining Ansi.SingleUnderline) = Just "underline" +sgrToString (Ansi.SetUnderlining Ansi.SingleUnderline) = Just "underline" -nameForSGR (Ansi.SetConsoleIntensity Ansi.BoldIntensity) = Just "bold" +sgrToString (Ansi.SetConsoleIntensity Ansi.BoldIntensity) = Just "bold" -nameForSGR _ = Nothing +sgrToString (Ansi.SetRGBColor layer color) = Just $ + (\str -> case layer of + Ansi.Foreground -> str + Ansi.Background -> "on" ++ capitalize str) $ + "rgb#" ++ (toRGBHex $ toSRGB24 color) + where + toRGBHex (RGB r g b) = concat $ map toHexByte [r, g, b] + toHexByte x = showHex2 x "" + showHex2 x | x <= 0xf = ("0" ++) . showHex x + | otherwise = showHex x +sgrToString _ = Nothing + -------------------------------------------------------------------------------- -sgrsByName :: M.Map String Ansi.SGR -sgrsByName = M.fromList +namedSgrs :: M.Map String Ansi.SGR +namedSgrs = M.fromList [ (name, sgr) | sgr <- knownSgrs - , name <- maybeToList (nameForSGR sgr) + , name <- maybeToList (sgrToString sgr) ] where -- | It doesn't really matter if we generate "too much" SGRs here since - -- 'nameForSGR' will only pick the ones we support. + -- 'sgrToString' will only pick the ones we support. knownSgrs = [ Ansi.SetColor l i c | l <- [minBound .. maxBound]