patat 0.7.2.0 → 0.8.0.0
raw patch · 14 files changed
+763/−213 lines, 14 filesdep +base64-bytestringdep +colourdep +processdep ~aesondep ~basedep ~containers
Dependencies added: base64-bytestring, colour, process
Dependency ranges changed: aeson, base, containers, yaml
Files
- CHANGELOG.md +7/−0
- README.md +235/−138
- extra/make-man.hs +1/−6
- patat.cabal +11/−4
- src/Main.hs +8/−4
- src/Patat/Images.hs +60/−0
- src/Patat/Images/ITerm2.hs +56/−0
- src/Patat/Images/Internal.hs +36/−0
- src/Patat/Images/W3m.hs +145/−0
- src/Patat/Presentation/Display.hs +63/−24
- src/Patat/Presentation/Internal.hs +68/−2
- src/Patat/Presentation/Read.hs +6/−5
- src/Patat/PrettyPrint.hs +11/−5
- src/Patat/Theme.hs +56/−25
CHANGELOG.md view
@@ -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
README.md view
@@ -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]. @@ -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: <https://aur.archlinux.org/packages/patat-bin> - Debian: <https://packages.debian.org/unstable/patat> - Ubuntu: <https://packages.ubuntu.com/artful/patat> - openSUSE: <https://build.opensuse.org/package/show/openSUSE:Factory:ARM/patat>@@ -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+... - <!--- Note: I should not bore the audience with my thoughts on powerpoint but- just get straight to the point.- -->+# Chapter 1 - Slide contents. Yay.+<!--+Note: I should not bore the audience with my thoughts on powerpoint but+just get straight to the point.+--> - <!-- TODO: Finish the rest of the presentation. -->+Slide contents. Yay. +<!-- TODO: Finish the rest of the presentation. -->+``` 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. - ++``` 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:-- <https://hackage.haskell.org/package/pandoc-2.0.5/docs/Text-Pandoc-Extensions.html>+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.+++```++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 ------
extra/make-man.hs view
@@ -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
patat.cabal view
@@ -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
src/Main.hs view
@@ -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
+ src/Patat/Images.hs view
@@ -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
+ src/Patat/Images/ITerm2.hs view
@@ -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"
+ src/Patat/Images/Internal.hs view
@@ -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 ()+ }
+ src/Patat/Images/W3m.hs view
@@ -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 "<width> <height>\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)
src/Patat/Presentation/Display.hs view
@@ -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
src/Patat/Presentation/Internal.hs view
@@ -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)
src/Patat/Presentation/Read.hs view
@@ -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 --------------------------------------------------------------------------------
src/Patat/PrettyPrint.hs view
@@ -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 --------------------------------------------------------------------------------
src/Patat/Theme.hs view
@@ -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]