summaryrefslogtreecommitdiff
path: root/lib
diff options
context:
space:
mode:
Diffstat (limited to 'lib')
-rw-r--r--lib/Data/Aeson/Extended.hs22
-rw-r--r--lib/Data/Aeson/TH/Extended.hs21
-rw-r--r--lib/Data/Data/Extended.hs23
-rw-r--r--lib/Patat/AutoAdvance.hs52
-rw-r--r--lib/Patat/Cleanup.hs10
-rw-r--r--lib/Patat/Images.hs61
-rw-r--r--lib/Patat/Images/ITerm2.hs58
-rw-r--r--lib/Patat/Images/Internal.hs40
-rw-r--r--lib/Patat/Images/W3m.hs151
-rw-r--r--lib/Patat/Main.hs219
-rw-r--r--lib/Patat/Presentation.hs20
-rw-r--r--lib/Patat/Presentation/Display.hs380
-rw-r--r--lib/Patat/Presentation/Display/CodeBlock.hs83
-rw-r--r--lib/Patat/Presentation/Display/Table.hs107
-rw-r--r--lib/Patat/Presentation/Fragment.hs134
-rw-r--r--lib/Patat/Presentation/Interactive.hs142
-rw-r--r--lib/Patat/Presentation/Internal.hs266
-rw-r--r--lib/Patat/Presentation/Read.hs205
-rw-r--r--lib/Patat/PrettyPrint.hs411
-rw-r--r--lib/Patat/Theme.hs324
-rw-r--r--lib/Text/Pandoc/Extended.hs30
21 files changed, 2759 insertions, 0 deletions
diff --git a/lib/Data/Aeson/Extended.hs b/lib/Data/Aeson/Extended.hs
new file mode 100644
index 0000000..9b95cec
--- /dev/null
+++ b/lib/Data/Aeson/Extended.hs
@@ -0,0 +1,22 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+module Data.Aeson.Extended
+ ( module Data.Aeson
+
+ , FlexibleNum (..)
+ ) where
+
+import Control.Applicative ((<$>))
+import Data.Aeson
+import qualified Data.Text as T
+import Text.Read (readMaybe)
+import Prelude
+
+-- | This can be parsed from a JSON string in addition to a JSON number.
+newtype FlexibleNum a = FlexibleNum {unFlexibleNum :: a}
+ deriving (Show, ToJSON)
+
+instance (FromJSON a, Read a) => FromJSON (FlexibleNum a) where
+ parseJSON (String str) = case readMaybe (T.unpack str) of
+ Nothing -> fail $ "Could not parse " ++ T.unpack str ++ " as a number"
+ Just x -> return (FlexibleNum x)
+ parseJSON val = FlexibleNum <$> parseJSON val
diff --git a/lib/Data/Aeson/TH/Extended.hs b/lib/Data/Aeson/TH/Extended.hs
new file mode 100644
index 0000000..0fa5487
--- /dev/null
+++ b/lib/Data/Aeson/TH/Extended.hs
@@ -0,0 +1,21 @@
+--------------------------------------------------------------------------------
+module Data.Aeson.TH.Extended
+ ( module Data.Aeson.TH
+ , dropPrefixOptions
+ ) where
+
+
+--------------------------------------------------------------------------------
+import Data.Aeson.TH
+import Data.Char (isUpper, toLower)
+
+
+--------------------------------------------------------------------------------
+dropPrefixOptions :: Options
+dropPrefixOptions = defaultOptions
+ { fieldLabelModifier = dropPrefix
+ }
+ where
+ dropPrefix str = case break isUpper str of
+ (_, (y : ys)) -> toLower y : ys
+ _ -> str
diff --git a/lib/Data/Data/Extended.hs b/lib/Data/Data/Extended.hs
new file mode 100644
index 0000000..636591e
--- /dev/null
+++ b/lib/Data/Data/Extended.hs
@@ -0,0 +1,23 @@
+module Data.Data.Extended
+ ( module Data.Data
+
+ , grecQ
+ , grecT
+ ) where
+
+import Data.Data
+
+-- | Recursively find all values of a certain type.
+grecQ :: (Data a, Data b) => a -> [b]
+grecQ = concat . gmapQ (\x -> maybe id (:) (cast x) $ grecQ x)
+
+-- | Recursively apply an update to a certain type.
+grecT :: (Data a, Data b) => (a -> a) -> b -> b
+grecT f x = gmapT (grecT f) (castMap f x)
+
+castMap :: (Typeable a, Typeable b) => (a -> a) -> b -> b
+castMap f x = case cast x of
+ Nothing -> x
+ Just y -> case cast (f y) of
+ Nothing -> x
+ Just z -> z
diff --git a/lib/Patat/AutoAdvance.hs b/lib/Patat/AutoAdvance.hs
new file mode 100644
index 0000000..236e0cb
--- /dev/null
+++ b/lib/Patat/AutoAdvance.hs
@@ -0,0 +1,52 @@
+--------------------------------------------------------------------------------
+module Patat.AutoAdvance
+ ( autoAdvance
+ ) where
+
+
+--------------------------------------------------------------------------------
+import Control.Concurrent (forkIO, threadDelay)
+import qualified Control.Concurrent.Chan as Chan
+import Control.Monad (forever)
+import qualified Data.IORef as IORef
+import Data.Time (diffUTCTime, getCurrentTime)
+import Patat.Presentation (PresentationCommand (..))
+
+
+--------------------------------------------------------------------------------
+-- | This function takes an existing channel for presentation commands
+-- (presumably coming from human input) and creates a new one that /also/ sends
+-- a 'Forward' command if nothing happens for N seconds.
+autoAdvance
+ :: Int
+ -> Chan.Chan PresentationCommand
+ -> IO (Chan.Chan PresentationCommand)
+autoAdvance delaySeconds existingChan = do
+ let delay = delaySeconds * 1000 -- We are working with ms in this function
+
+ newChan <- Chan.newChan
+ latestCommandAt <- IORef.newIORef =<< getCurrentTime
+
+ -- This is a thread that copies 'existingChan' to 'newChan', and writes
+ -- whenever the latest command was to 'latestCommandAt'.
+ _ <- forkIO $ forever $ do
+ cmd <- Chan.readChan existingChan
+ getCurrentTime >>= IORef.writeIORef latestCommandAt
+ Chan.writeChan newChan cmd
+
+ -- This is a thread that waits around 'delay' seconds and then checks if
+ -- there's been a more recent command. If not, we write a 'Forward'.
+ _ <- forkIO $ forever $ do
+ current <- getCurrentTime
+ latest <- IORef.readIORef latestCommandAt
+ let elapsed = floor $ 1000 * (current `diffUTCTime` latest) :: Int
+ if elapsed >= delay
+ then do
+ Chan.writeChan newChan Forward
+ IORef.writeIORef latestCommandAt current
+ threadDelay (delay * 1000)
+ else do
+ let wait = delay - elapsed
+ threadDelay (wait * 1000)
+
+ return newChan
diff --git a/lib/Patat/Cleanup.hs b/lib/Patat/Cleanup.hs
new file mode 100644
index 0000000..2519681
--- /dev/null
+++ b/lib/Patat/Cleanup.hs
@@ -0,0 +1,10 @@
+--------------------------------------------------------------------------------
+-- | Defines a cleanup action that needs to be run after we're done with a slide
+-- or image.
+module Patat.Cleanup
+ ( Cleanup
+ ) where
+
+
+--------------------------------------------------------------------------------
+type Cleanup = IO ()
diff --git a/lib/Patat/Images.hs b/lib/Patat/Images.hs
new file mode 100644
index 0000000..3ea7e0f
--- /dev/null
+++ b/lib/Patat/Images.hs
@@ -0,0 +1,61 @@
+--------------------------------------------------------------------------------
+{-# 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.Cleanup
+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 Cleanup
+drawImage = hDrawImage
diff --git a/lib/Patat/Images/ITerm2.hs b/lib/Patat/Images/ITerm2.hs
new file mode 100644
index 0000000..a6e7ad4
--- /dev/null
+++ b/lib/Patat/Images/ITerm2.hs
@@ -0,0 +1,58 @@
+--------------------------------------------------------------------------------
+{-# 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 Patat.Cleanup (Cleanup)
+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 Cleanup
+drawImage path = do
+ content <- BL.readFile path
+ withEscapeSequence $ do
+ putStr "1337;File=inline=1;width=100%;height=100%:"
+ BL.putStr (B64.encode content)
+ return mempty
+
+
+--------------------------------------------------------------------------------
+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/lib/Patat/Images/Internal.hs b/lib/Patat/Images/Internal.hs
new file mode 100644
index 0000000..246fb44
--- /dev/null
+++ b/lib/Patat/Images/Internal.hs
@@ -0,0 +1,40 @@
+--------------------------------------------------------------------------------
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE ExistentialQuantification #-}
+module Patat.Images.Internal
+ ( Config (..)
+ , Backend (..)
+ , BackendNotSupported (..)
+ , Handle (..)
+ ) where
+
+
+--------------------------------------------------------------------------------
+import Control.Exception (Exception)
+import qualified Data.Aeson as A
+import Data.Data (Data)
+import Data.Typeable (Typeable)
+import Patat.Cleanup
+
+
+--------------------------------------------------------------------------------
+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 (Data, Show, Typeable)
+
+
+--------------------------------------------------------------------------------
+instance Exception BackendNotSupported
+
+
+--------------------------------------------------------------------------------
+data Handle = Handle
+ { hDrawImage :: FilePath -> IO Cleanup
+ }
diff --git a/lib/Patat/Images/W3m.hs b/lib/Patat/Images/W3m.hs
new file mode 100644
index 0000000..60795a4
--- /dev/null
+++ b/lib/Patat/Images/W3m.hs
@@ -0,0 +1,151 @@
+--------------------------------------------------------------------------------
+{-# LANGUAGE TemplateHaskell #-}
+module Patat.Images.W3m
+ ( backend
+ ) where
+
+
+--------------------------------------------------------------------------------
+import Control.Exception (throwIO)
+import Control.Monad (unless, void)
+import qualified Data.Aeson.TH.Extended as A
+import Data.List (intercalate)
+import Patat.Cleanup (Cleanup)
+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 Cleanup
+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"
+
+ -- Draw image.
+ _ <- Process.readProcess w3mPath [] command
+
+ -- Return a 'Cleanup' that clears the image.
+ return $ void $ Process.readProcess w3mPath [] $
+ "6;" ++ intercalate ";" (map show [x, y, w, h])
+ 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/lib/Patat/Main.hs b/lib/Patat/Main.hs
new file mode 100644
index 0000000..e844ce5
--- /dev/null
+++ b/lib/Patat/Main.hs
@@ -0,0 +1,219 @@
+--------------------------------------------------------------------------------
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+module Patat.Main
+ ( main
+ ) where
+
+
+--------------------------------------------------------------------------------
+import Control.Applicative ((<$>), (<*>))
+import Control.Concurrent (forkIO, killThread, threadDelay)
+import Control.Concurrent.Chan (Chan)
+import qualified Control.Concurrent.Chan as Chan
+import Control.Exception (bracket)
+import Control.Monad (forever, unless, when)
+import qualified Data.Aeson.Extended as A
+import Data.Monoid (mempty, (<>))
+import Data.Time (UTCTime)
+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
+import qualified System.Console.ANSI as Ansi
+import System.Directory (doesFileExist,
+ getModificationTime)
+import System.Exit (exitFailure, exitSuccess)
+import qualified System.IO as IO
+import qualified Text.Pandoc as Pandoc
+import qualified Text.PrettyPrint.ANSI.Leijen as PP
+
+
+--------------------------------------------------------------------------------
+data Options = Options
+ { oFilePath :: !(Maybe FilePath)
+ , oForce :: !Bool
+ , oDump :: !Bool
+ , oWatch :: !Bool
+ , oVersion :: !Bool
+ } deriving (Show)
+
+
+--------------------------------------------------------------------------------
+parseOptions :: OA.Parser Options
+parseOptions = Options
+ <$> (OA.optional $ OA.strArgument $
+ OA.metavar "FILENAME" <>
+ OA.help "Input file")
+ <*> (OA.switch $
+ OA.long "force" <>
+ OA.short 'f' <>
+ OA.help "Force ANSI terminal" <>
+ OA.hidden)
+ <*> (OA.switch $
+ OA.long "dump" <>
+ OA.short 'd' <>
+ OA.help "Just dump all slides and exit" <>
+ OA.hidden)
+ <*> (OA.switch $
+ OA.long "watch" <>
+ OA.short 'w' <>
+ OA.help "Watch file for changes")
+ <*> (OA.switch $
+ OA.long "version" <>
+ OA.help "Display version info and exit" <>
+ OA.hidden)
+
+
+--------------------------------------------------------------------------------
+parserInfo :: OA.ParserInfo Options
+parserInfo = OA.info (OA.helper <*> parseOptions) $
+ OA.fullDesc <>
+ OA.header ("patat v" <> showVersion Paths_patat.version) <>
+ OA.progDescDoc (Just desc)
+ where
+ desc = PP.vcat
+ [ "Terminal-based presentations using Pandoc"
+ , ""
+ , "Controls:"
+ , "- Next slide: space, enter, l, right, pagedown"
+ , "- Previous slide: backspace, h, left, pageup"
+ , "- Go forward 10 slides: j, down"
+ , "- Go backward 10 slides: k, up"
+ , "- First slide: 0"
+ , "- Last slide: G"
+ , "- Reload file: r"
+ , "- Quit: q"
+ ]
+
+
+--------------------------------------------------------------------------------
+parserPrefs :: OA.ParserPrefs
+parserPrefs = OA.prefs OA.showHelpOnError
+
+
+--------------------------------------------------------------------------------
+errorAndExit :: [String] -> IO a
+errorAndExit msg = do
+ mapM_ (IO.hPutStrLn IO.stderr) msg
+ exitFailure
+
+
+--------------------------------------------------------------------------------
+assertAnsiFeatures :: IO ()
+assertAnsiFeatures = do
+ supports <- Ansi.hSupportsANSI IO.stdout
+ unless supports $ errorAndExit
+ [ "It looks like your terminal does not support ANSI codes."
+ , "If you still want to run the presentation, use `--force`."
+ ]
+
+
+--------------------------------------------------------------------------------
+main :: IO ()
+main = do
+ options <- OA.customExecParser parserPrefs parserInfo
+
+ when (oVersion options) $ do
+ putStrLn (showVersion Paths_patat.version)
+ putStrLn $ "Using pandoc: " ++ Pandoc.pandocVersion
+ exitSuccess
+
+ filePath <- case oFilePath options of
+ Just fp -> return fp
+ Nothing -> OA.handleParseResult $ OA.Failure $
+ OA.parserFailure parserPrefs parserInfo OA.ShowHelpText mempty
+
+ errOrPres <- readPresentation filePath
+ pres <- either (errorAndExit . return) return errOrPres
+
+ unless (oForce options) assertAnsiFeatures
+
+ -- (Maybe) initialize images backend.
+ images <- traverse Images.new (psImages $ pSettings pres)
+
+ if oDump options
+ then dumpPresentation pres
+ else interactiveLoop options images pres
+ where
+ interactiveLoop :: Options -> Maybe Images.Handle -> Presentation -> IO ()
+ interactiveLoop options images pres0 =
+ interactively readPresentationCommand $ \commandChan0 -> do
+
+ -- If an auto delay is set, use 'autoAdvance' to create a new one.
+ commandChan <- case psAutoAdvanceDelay (pSettings pres0) of
+ Nothing -> return commandChan0
+ Just (A.FlexibleNum delay) -> autoAdvance delay commandChan0
+
+ -- Spawn a thread that adds 'Reload' commands based on the file time.
+ mtime0 <- getModificationTime (pFilePath pres0)
+ when (oWatch options) $ do
+ _ <- forkIO $ watcher commandChan (pFilePath pres0) mtime0
+ return ()
+
+ let loop :: Presentation -> Maybe String -> IO ()
+ loop pres mbError = do
+ cleanup <- case mbError of
+ Nothing -> displayPresentation images pres
+ Just err -> displayPresentationError pres err
+
+ c <- Chan.readChan commandChan
+ update <- updatePresentation c pres
+ cleanup
+ case update of
+ ExitedPresentation -> return ()
+ UpdatedPresentation pres' -> loop pres' Nothing
+ ErroredPresentation err -> loop pres (Just err)
+
+ loop pres0 Nothing
+
+
+--------------------------------------------------------------------------------
+-- | Utility for dealing with pecularities of stdin & interactive applications
+-- on the terminal. Tries to restore the original state of the terminal as much
+-- as possible.
+interactively
+ -- | Reads a command from stdin (or from some other IO). This will be
+ -- interrupted by 'killThread' when the application finishes.
+ :: (IO.Handle -> IO a)
+ -- | Application to run.
+ -> (Chan a -> IO ())
+ -- | Returns when application finishes.
+ -> IO ()
+interactively reader app = bracket setup teardown $ \(_, _, _, chan) -> app chan
+ where
+ setup = do
+ chan <- Chan.newChan
+ echo <- IO.hGetEcho IO.stdin
+ buff <- IO.hGetBuffering IO.stdin
+ IO.hSetEcho IO.stdin False
+ IO.hSetBuffering IO.stdin IO.NoBuffering
+ Ansi.hideCursor
+ readerThreadId <- forkIO $ forever $
+ reader IO.stdin >>= Chan.writeChan chan
+ return (echo, buff, readerThreadId, chan)
+
+ teardown (echo, buff, readerThreadId, _chan) = do
+ Ansi.showCursor
+ Ansi.clearScreen
+ Ansi.setCursorPosition 0 0
+ killThread readerThreadId
+ IO.hSetEcho IO.stdin echo
+ IO.hSetBuffering IO.stdin buff
+
+
+--------------------------------------------------------------------------------
+watcher :: Chan.Chan PresentationCommand -> FilePath -> UTCTime -> IO a
+watcher chan filePath mtime0 = do
+ -- The extra exists check helps because some editors temporarily make the
+ -- file disappear while writing.
+ exists <- doesFileExist filePath
+ mtime1 <- if exists then getModificationTime filePath else return mtime0
+
+ when (mtime1 > mtime0) $ Chan.writeChan chan Reload
+ threadDelay (200 * 1000)
+ watcher chan filePath mtime1
diff --git a/lib/Patat/Presentation.hs b/lib/Patat/Presentation.hs
new file mode 100644
index 0000000..8da5a30
--- /dev/null
+++ b/lib/Patat/Presentation.hs
@@ -0,0 +1,20 @@
+module Patat.Presentation
+ ( PresentationSettings (..)
+ , defaultPresentationSettings
+
+ , Presentation (..)
+ , readPresentation
+ , displayPresentation
+ , displayPresentationError
+ , dumpPresentation
+
+ , PresentationCommand (..)
+ , readPresentationCommand
+ , UpdatedPresentation (..)
+ , updatePresentation
+ ) where
+
+import Patat.Presentation.Display
+import Patat.Presentation.Interactive
+import Patat.Presentation.Internal
+import Patat.Presentation.Read
diff --git a/lib/Patat/Presentation/Display.hs b/lib/Patat/Presentation/Display.hs
new file mode 100644
index 0000000..876311d
--- /dev/null
+++ b/lib/Patat/Presentation/Display.hs
@@ -0,0 +1,380 @@
+--------------------------------------------------------------------------------
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+module Patat.Presentation.Display
+ ( displayPresentation
+ , displayPresentationError
+ , dumpPresentation
+ ) where
+
+
+--------------------------------------------------------------------------------
+import Control.Applicative ((<$>))
+import Control.Monad (mplus, unless)
+import qualified Data.Aeson.Extended as A
+import Data.Data.Extended (grecQ)
+import qualified Data.List as L
+import Data.Maybe (fromMaybe)
+import Data.Monoid (mconcat, mempty, (<>))
+import qualified Data.Text as T
+import Patat.Cleanup
+import qualified Patat.Images as Images
+import Patat.Presentation.Display.CodeBlock
+import Patat.Presentation.Display.Table
+import Patat.Presentation.Internal
+import Patat.PrettyPrint ((<$$>), (<+>))
+import qualified Patat.PrettyPrint as PP
+import Patat.Theme (Theme (..))
+import qualified Patat.Theme as Theme
+import Prelude
+import qualified System.Console.ANSI as Ansi
+import qualified System.Console.Terminal.Size as Terminal
+import qualified System.IO as IO
+import qualified Text.Pandoc.Extended as Pandoc
+
+
+--------------------------------------------------------------------------------
+data CanvasSize = CanvasSize {csRows :: Int, csCols :: Int} deriving (Show)
+
+
+--------------------------------------------------------------------------------
+-- | 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 Cleanup
+displayWithBorders Presentation {..} f = do
+ Ansi.clearScreen
+ Ansi.setCursorPosition 0 0
+
+ -- Get terminal width/title
+ mbWindow <- Terminal.size
+ let columns = fromMaybe 72 $
+ (A.unFlexibleNum <$> psColumns pSettings) `mplus`
+ (Terminal.width <$> mbWindow)
+ rows = fromMaybe 24 $
+ (A.unFlexibleNum <$> psRows pSettings) `mplus`
+ (Terminal.height <$> mbWindow)
+
+ let settings = pSettings {psColumns = Just $ A.FlexibleNum columns}
+ theme = fromMaybe Theme.defaultTheme (psTheme settings)
+ title = PP.toString (prettyInlines theme pTitle)
+ titleWidth = length title
+ titleOffset = (columns - titleWidth) `div` 2
+ borders = themed (themeBorders theme)
+
+ unless (null title) $ do
+ 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 $ formatWith settings $ f canvasSize theme
+ putStrLn ""
+
+ 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 $ PP.space <> PP.string author <> middleSpaces <> PP.string active <> PP.space
+ IO.hFlush IO.stdout
+
+ return mempty
+
+
+--------------------------------------------------------------------------------
+displayImage :: Images.Handle -> FilePath -> IO Cleanup
+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 Cleanup
+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
+ (mLeft, mRight) = marginsOf pSettings
+ offsetRow = (csRows canvasSize `div` 2) - (prows `div` 2)
+ offsetCol = ((csCols canvasSize - mLeft - mRight) `div` 2) - (pcols `div` 2)
+ spaces = PP.NotTrimmable $ PP.spaces offsetCol in
+ mconcat (replicate (offsetRow - 3) PP.hardline) <$$>
+ PP.indent spaces spaces pblock
+
+ 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.
+displayPresentationError :: Presentation -> String -> IO Cleanup
+displayPresentationError pres err = displayWithBorders pres $ \_ Theme {..} ->
+ themed themeStrong "Error occurred in the presentation:" <$$>
+ "" <$$>
+ (PP.string err)
+
+
+--------------------------------------------------------------------------------
+dumpPresentation :: Presentation -> IO ()
+dumpPresentation 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
+ TitleSlide block -> "~~~title" <$$> prettyBlock theme block
+ ContentSlide fragments -> PP.vcat $ L.intersperse "~~~frag" $ do
+ fragment <- fragments
+ return $ prettyFragment theme fragment
+
+
+--------------------------------------------------------------------------------
+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
+prettyFragment theme fragment@(Fragment blocks) =
+ prettyBlocks theme blocks <>
+ case prettyReferences theme fragment of
+ [] -> mempty
+ refs -> PP.hardline <> PP.vcat refs
+
+
+--------------------------------------------------------------------------------
+prettyBlock :: Theme -> Pandoc.Block -> PP.Doc
+
+prettyBlock theme (Pandoc.Plain inlines) = prettyInlines theme inlines
+
+prettyBlock theme (Pandoc.Para inlines) =
+ prettyInlines theme inlines <> PP.hardline
+
+prettyBlock theme@Theme {..} (Pandoc.Header i _ inlines) =
+ themed themeHeader (PP.string (replicate i '#') <+> prettyInlines theme inlines) <>
+ PP.hardline
+
+prettyBlock theme (Pandoc.CodeBlock (_, classes, _) txt) =
+ prettyCodeBlock theme classes txt
+
+prettyBlock theme (Pandoc.BulletList bss) = PP.vcat
+ [ PP.indent
+ (PP.NotTrimmable $ themed (themeBulletList theme) prefix)
+ (PP.Trimmable " ")
+ (prettyBlocks theme' bs)
+ | bs <- bss
+ ] <> PP.hardline
+ where
+ prefix = " " <> PP.string [marker] <> " "
+ marker = case T.unpack <$> themeBulletListMarkers theme of
+ Just (x : _) -> x
+ _ -> '-'
+
+ -- Cycle the markers.
+ theme' = theme
+ { themeBulletListMarkers =
+ (\ls -> T.drop 1 ls <> T.take 1 ls) <$> themeBulletListMarkers theme
+ }
+
+prettyBlock theme@Theme {..} (Pandoc.OrderedList _ bss) = PP.vcat
+ [ PP.indent
+ (PP.NotTrimmable $ themed themeOrderedList $ PP.string prefix)
+ (PP.Trimmable " ")
+ (prettyBlocks theme bs)
+ | (prefix, bs) <- zip padded bss
+ ] <> PP.hardline
+ where
+ padded = [n ++ replicate (4 - length n) ' ' | n <- numbers]
+ numbers =
+ [ show i ++ "."
+ | i <- [1 .. length bss]
+ ]
+
+prettyBlock _theme (Pandoc.RawBlock _ t) = PP.string t <> PP.hardline
+
+prettyBlock _theme Pandoc.HorizontalRule = "---"
+
+prettyBlock theme@Theme {..} (Pandoc.BlockQuote bs) =
+ let quote = PP.NotTrimmable (themed themeBlockQuote "> ") in
+ PP.indent quote quote (prettyBlocks theme bs)
+
+prettyBlock theme@Theme {..} (Pandoc.DefinitionList terms) =
+ PP.vcat $ map prettyDefinition terms
+ where
+ prettyDefinition (term, definitions) =
+ themed themeDefinitionTerm (prettyInlines theme term) <$$>
+ PP.hardline <> PP.vcat
+ [ PP.indent
+ (PP.NotTrimmable (themed themeDefinitionList ": "))
+ (PP.Trimmable " ") $
+ prettyBlocks theme (Pandoc.plainToPara definition)
+ | definition <- definitions
+ ]
+
+prettyBlock theme (Pandoc.Table caption aligns _ headers rows) =
+ PP.wrapAt Nothing $
+ prettyTable theme Table
+ { tCaption = prettyInlines theme caption
+ , tAligns = map align aligns
+ , tHeaders = map (prettyBlocks theme) headers
+ , tRows = map (map (prettyBlocks theme)) rows
+ }
+ where
+ align Pandoc.AlignLeft = PP.AlignLeft
+ align Pandoc.AlignCenter = PP.AlignCenter
+ align Pandoc.AlignDefault = PP.AlignLeft
+ align Pandoc.AlignRight = PP.AlignRight
+
+prettyBlock theme (Pandoc.Div _attrs blocks) = prettyBlocks theme blocks
+
+prettyBlock _theme Pandoc.Null = mempty
+
+#if MIN_VERSION_pandoc(1,18,0)
+-- 'LineBlock' elements are new in pandoc-1.18
+prettyBlock theme@Theme {..} (Pandoc.LineBlock inliness) =
+ let ind = PP.NotTrimmable (themed themeLineBlock "| ") in
+ PP.wrapAt Nothing $
+ PP.indent ind ind $
+ PP.vcat $
+ map (prettyInlines theme) inliness
+#endif
+
+
+--------------------------------------------------------------------------------
+prettyBlocks :: Theme -> [Pandoc.Block] -> PP.Doc
+prettyBlocks theme = PP.vcat . map (prettyBlock theme) . filter isVisibleBlock
+
+
+--------------------------------------------------------------------------------
+prettyInline :: Theme -> Pandoc.Inline -> PP.Doc
+
+prettyInline _theme Pandoc.Space = PP.space
+
+prettyInline _theme (Pandoc.Str str) = PP.string str
+
+prettyInline theme@Theme {..} (Pandoc.Emph inlines) =
+ themed themeEmph $
+ prettyInlines theme inlines
+
+prettyInline theme@Theme {..} (Pandoc.Strong inlines) =
+ themed themeStrong $
+ prettyInlines theme inlines
+
+prettyInline Theme {..} (Pandoc.Code _ txt) =
+ themed themeCode $
+ PP.string (" " <> txt <> " ")
+
+prettyInline theme@Theme {..} link@(Pandoc.Link _attrs text (target, _title))
+ | isReferenceLink link =
+ "[" <> themed themeLinkText (prettyInlines theme text) <> "]"
+ | otherwise =
+ "<" <> themed themeLinkTarget (PP.string target) <> ">"
+
+prettyInline _theme Pandoc.SoftBreak = PP.softline
+
+prettyInline _theme Pandoc.LineBreak = PP.hardline
+
+prettyInline theme@Theme {..} (Pandoc.Strikeout t) =
+ "~~" <> themed themeStrikeout (prettyInlines theme 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 Theme {..} (Pandoc.Math _ t) =
+ themed themeMath (PP.string t)
+
+prettyInline theme@Theme {..} (Pandoc.Image _attrs text (target, _title)) =
+ "![" <> themed themeImageText (prettyInlines theme text) <> "](" <>
+ themed themeImageTarget (PP.string 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.string 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 unsupported = PP.ondullred $ PP.string $ show unsupported
+
+
+--------------------------------------------------------------------------------
+prettyInlines :: Theme -> [Pandoc.Inline] -> PP.Doc
+prettyInlines theme = mconcat . map (prettyInline theme)
+
+
+--------------------------------------------------------------------------------
+prettyReferences :: Theme -> Fragment -> [PP.Doc]
+prettyReferences theme@Theme {..} =
+ map prettyReference . getReferences . unFragment
+ where
+ getReferences :: [Pandoc.Block] -> [Pandoc.Inline]
+ getReferences = filter isReferenceLink . grecQ
+
+ prettyReference :: Pandoc.Inline -> PP.Doc
+ prettyReference (Pandoc.Link _attrs text (target, title)) =
+ "[" <>
+ themed themeLinkText (prettyInlines theme $ Pandoc.newlineToSpace text) <>
+ "](" <>
+ themed themeLinkTarget (PP.string target) <>
+ (if null title
+ then mempty
+ else PP.space <> "\"" <> PP.string title <> "\"")
+ <> ")"
+ prettyReference _ = mempty
+
+
+--------------------------------------------------------------------------------
+isReferenceLink :: Pandoc.Inline -> Bool
+isReferenceLink (Pandoc.Link _attrs text (target, _)) =
+ [Pandoc.Str target] /= text
+isReferenceLink _ = False
+
+
+--------------------------------------------------------------------------------
+isVisibleBlock :: Pandoc.Block -> Bool
+isVisibleBlock Pandoc.Null = False
+isVisibleBlock (Pandoc.RawBlock (Pandoc.Format "html") t) =
+ not ("<!--" `L.isPrefixOf` t && "-->" `L.isSuffixOf` t)
+isVisibleBlock _ = True
diff --git a/lib/Patat/Presentation/Display/CodeBlock.hs b/lib/Patat/Presentation/Display/CodeBlock.hs
new file mode 100644
index 0000000..149bc68
--- /dev/null
+++ b/lib/Patat/Presentation/Display/CodeBlock.hs
@@ -0,0 +1,83 @@
+--------------------------------------------------------------------------------
+-- | Displaying code blocks, optionally with syntax highlighting.
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+module Patat.Presentation.Display.CodeBlock
+ ( prettyCodeBlock
+ ) where
+
+
+--------------------------------------------------------------------------------
+import Data.Maybe (mapMaybe)
+import Data.Monoid (mconcat, (<>))
+import qualified Data.Text as T
+import Patat.Presentation.Display.Table (themed)
+import qualified Patat.PrettyPrint as PP
+import Patat.Theme
+import Prelude
+import qualified Skylighting as Skylighting
+
+
+--------------------------------------------------------------------------------
+highlight :: [String] -> String -> [Skylighting.SourceLine]
+highlight classes rawCodeBlock = case mapMaybe getSyntax classes of
+ [] -> zeroHighlight rawCodeBlock
+ (syn : _) ->
+ case Skylighting.tokenize config syn (T.pack rawCodeBlock) of
+ Left _ -> zeroHighlight rawCodeBlock
+ Right sl -> sl
+ where
+ getSyntax :: String -> Maybe Skylighting.Syntax
+ getSyntax c = Skylighting.lookupSyntax (T.pack c) syntaxMap
+
+ config :: Skylighting.TokenizerConfig
+ config = Skylighting.TokenizerConfig
+ { Skylighting.syntaxMap = syntaxMap
+ , Skylighting.traceOutput = False
+ }
+
+ syntaxMap :: Skylighting.SyntaxMap
+ syntaxMap = Skylighting.defaultSyntaxMap
+
+
+--------------------------------------------------------------------------------
+-- | This does fake highlighting, everything becomes a normal token. That makes
+-- things a bit easier, since we only need to deal with one cases in the
+-- renderer.
+zeroHighlight :: String -> [Skylighting.SourceLine]
+zeroHighlight str =
+ [[(Skylighting.NormalTok, T.pack line)] | line <- lines str]
+
+
+--------------------------------------------------------------------------------
+prettyCodeBlock :: Theme -> [String] -> String -> PP.Doc
+prettyCodeBlock theme@Theme {..} classes rawCodeBlock =
+ PP.vcat (map blockified sourceLines) <>
+ PP.hardline
+ where
+ sourceLines :: [Skylighting.SourceLine]
+ sourceLines =
+ [[]] ++ highlight 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)
+
+ sourceLineLength :: Skylighting.SourceLine -> Int
+ sourceLineLength line = sum [T.length str | (_, str) <- line]
+
+ blockWidth :: Int
+ blockWidth = foldr max 0 (map sourceLineLength sourceLines)
+
+ blockified :: Skylighting.SourceLine -> PP.Doc
+ blockified line =
+ let len = sourceLineLength line
+ indent = PP.NotTrimmable " " in
+ PP.indent indent indent $
+ themed themeCodeBlock $
+ " " <>
+ prettySourceLine line <>
+ PP.string (replicate (blockWidth - len) ' ') <> " "
diff --git a/lib/Patat/Presentation/Display/Table.hs b/lib/Patat/Presentation/Display/Table.hs
new file mode 100644
index 0000000..fee68c9
--- /dev/null
+++ b/lib/Patat/Presentation/Display/Table.hs
@@ -0,0 +1,107 @@
+--------------------------------------------------------------------------------
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+module Patat.Presentation.Display.Table
+ ( Table (..)
+ , prettyTable
+
+ , themed
+ ) where
+
+
+--------------------------------------------------------------------------------
+import Data.List (intersperse, transpose)
+import Data.Monoid (mconcat, mempty, (<>))
+import Patat.PrettyPrint ((<$$>))
+import qualified Patat.PrettyPrint as PP
+import Patat.Theme (Theme (..))
+import qualified Patat.Theme as Theme
+import Prelude
+
+
+--------------------------------------------------------------------------------
+data Table = Table
+ { tCaption :: PP.Doc
+ , tAligns :: [PP.Alignment]
+ , tHeaders :: [PP.Doc]
+ , tRows :: [[PP.Doc]]
+ }
+
+
+--------------------------------------------------------------------------------
+prettyTable
+ :: Theme -> Table -> PP.Doc
+prettyTable theme@Theme {..} Table {..} =
+ PP.indent (PP.Trimmable " ") (PP.Trimmable " ") $
+ lineIf (not isHeaderLess) (hcat2 headerHeight
+ [ themed themeTableHeader (PP.align w a (vpad headerHeight header))
+ | (w, a, header) <- zip3 columnWidths tAligns tHeaders
+ ]) <>
+ dashedHeaderSeparator theme columnWidths <$$>
+ joinRows
+ [ hcat2 rowHeight
+ [ PP.align w a (vpad rowHeight cell)
+ | (w, a, cell) <- zip3 columnWidths tAligns row
+ ]
+ | (rowHeight, row) <- zip rowHeights tRows
+ ] <$$>
+ lineIf isHeaderLess (dashedHeaderSeparator theme columnWidths) <>
+ lineIf
+ (not $ PP.null tCaption) (PP.hardline <> "Table: " <> tCaption)
+ where
+ lineIf cond line = if cond then line <> PP.hardline else mempty
+
+ joinRows
+ | all (all isSimpleCell) tRows = PP.vcat
+ | otherwise = PP.vcat . intersperse ""
+
+ isHeaderLess = all PP.null tHeaders
+
+ headerDimensions = map PP.dimensions tHeaders :: [(Int, Int)]
+ rowDimensions = map (map PP.dimensions) tRows :: [[(Int, Int)]]
+
+ columnWidths :: [Int]
+ columnWidths =
+ [ safeMax (map snd col)
+ | col <- transpose (headerDimensions : rowDimensions)
+ ]
+
+ rowHeights = map (safeMax . map fst) rowDimensions :: [Int]
+ headerHeight = safeMax (map fst headerDimensions) :: Int
+
+ vpad :: Int -> PP.Doc -> PP.Doc
+ vpad height doc =
+ let (actual, _) = PP.dimensions doc in
+ doc <> mconcat (replicate (height - actual) PP.hardline)
+
+ safeMax = foldr max 0
+
+ hcat2 :: Int -> [PP.Doc] -> PP.Doc
+ hcat2 rowHeight = PP.paste . intersperse (spaces2 rowHeight)
+
+ spaces2 :: Int -> PP.Doc
+ spaces2 rowHeight =
+ mconcat $ intersperse PP.hardline $
+ replicate rowHeight (PP.string " ")
+
+
+--------------------------------------------------------------------------------
+isSimpleCell :: PP.Doc -> Bool
+isSimpleCell = (<= 1) . fst . PP.dimensions
+
+
+--------------------------------------------------------------------------------
+dashedHeaderSeparator :: Theme -> [Int] -> PP.Doc
+dashedHeaderSeparator Theme {..} columnWidths =
+ mconcat $ intersperse (PP.string " ")
+ [ themed 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/Fragment.hs b/lib/Patat/Presentation/Fragment.hs
new file mode 100644
index 0000000..0908381
--- /dev/null
+++ b/lib/Patat/Presentation/Fragment.hs
@@ -0,0 +1,134 @@
+-- | For background info on the spec, see the "Incremental lists" section of the
+-- the pandoc manual.
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveTraversable #-}
+module Patat.Presentation.Fragment
+ ( FragmentSettings (..)
+ , fragmentBlocks
+ , fragmentBlock
+ ) where
+
+import Data.Foldable (Foldable)
+import Data.List (foldl', intersperse)
+import Data.Maybe (fromMaybe)
+import Data.Traversable (Traversable)
+import Prelude
+import qualified Text.Pandoc as Pandoc
+
+data FragmentSettings = FragmentSettings
+ { fsIncrementalLists :: !Bool
+ } deriving (Show)
+
+-- fragmentBlocks :: [Pandoc.Block] -> [[Pandoc.Block]]
+-- fragmentBlocks = NonEmpty.toList . joinFragmentedBlocks . map fragmentBlock
+fragmentBlocks :: FragmentSettings -> [Pandoc.Block] -> [[Pandoc.Block]]
+fragmentBlocks fs blocks0 =
+ case joinFragmentedBlocks (map (fragmentBlock fs) blocks0) of
+ Unfragmented bs -> [bs]
+ Fragmented xs bs -> map (fromMaybe []) xs ++ [fromMaybe [] bs]
+
+-- | This is all the ways we can "present" a block, after splitting in
+-- fragments.
+--
+-- In the simplest (and most common case) a block can only be presented in a
+-- single way ('Unfragmented').
+--
+-- Alternatively, we might want to show different (partial) versions of the
+-- block first before showing the final complete one. These partial or complete
+-- versions can be empty, hence the 'Maybe'.
+--
+-- For example, imagine that we display the following bullet list incrementally:
+--
+-- > [1, 2, 3]
+--
+-- Then we would get something like:
+--
+-- > Fragmented [Nothing, Just [1], Just [1, 2]] (Just [1, 2, 3])
+data Fragmented a
+ = Unfragmented a
+ | Fragmented [Maybe a] (Maybe a)
+ deriving (Functor, Foldable, Show, Traversable)
+
+fragmentBlock :: FragmentSettings -> Pandoc.Block -> Fragmented Pandoc.Block
+fragmentBlock _fs block@(Pandoc.Para inlines)
+ | inlines == threeDots = Fragmented [Nothing] Nothing
+ | otherwise = Unfragmented block
+ where
+ threeDots = intersperse Pandoc.Space $ replicate 3 (Pandoc.Str ".")
+
+fragmentBlock fs (Pandoc.BulletList bs0) =
+ fragmentList fs (fsIncrementalLists fs) Pandoc.BulletList bs0
+
+fragmentBlock fs (Pandoc.OrderedList attr bs0) =
+ fragmentList fs (fsIncrementalLists fs) (Pandoc.OrderedList attr) bs0
+
+fragmentBlock fs (Pandoc.BlockQuote [Pandoc.BulletList bs0]) =
+ fragmentList fs (not $ fsIncrementalLists fs) Pandoc.BulletList bs0
+
+fragmentBlock fs (Pandoc.BlockQuote [Pandoc.OrderedList attr bs0]) =
+ fragmentList fs (not $ fsIncrementalLists fs) (Pandoc.OrderedList attr) bs0
+
+fragmentBlock _ block@(Pandoc.BlockQuote _) = Unfragmented block
+
+fragmentBlock _ block@(Pandoc.Header _ _ _) = Unfragmented block
+fragmentBlock _ block@(Pandoc.Plain _) = Unfragmented block
+fragmentBlock _ block@(Pandoc.CodeBlock _ _) = Unfragmented block
+fragmentBlock _ block@(Pandoc.RawBlock _ _) = Unfragmented block
+fragmentBlock _ block@(Pandoc.DefinitionList _) = Unfragmented block
+fragmentBlock _ block@(Pandoc.Table _ _ _ _ _) = Unfragmented block
+fragmentBlock _ block@(Pandoc.Div _ _) = Unfragmented block
+fragmentBlock _ block@Pandoc.HorizontalRule = Unfragmented block
+fragmentBlock _ block@Pandoc.Null = Unfragmented block
+
+#if MIN_VERSION_pandoc(1,18,0)
+fragmentBlock _ block@(Pandoc.LineBlock _) = Unfragmented block
+#endif
+
+joinFragmentedBlocks :: [Fragmented block] -> Fragmented [block]
+joinFragmentedBlocks =
+ foldl' append (Unfragmented [])
+ where
+ append (Unfragmented xs) (Unfragmented y) =
+ Unfragmented (xs ++ [y])
+
+ append (Fragmented xs x) (Unfragmented y) =
+ Fragmented xs (appendMaybe x (Just y))
+
+ append (Unfragmented x) (Fragmented ys y) =
+ Fragmented
+ [appendMaybe (Just x) y' | y' <- ys]
+ (appendMaybe (Just x) y)
+
+ append (Fragmented xs x) (Fragmented ys y) =
+ Fragmented
+ (xs ++ [appendMaybe x y' | y' <- ys])
+ (appendMaybe x y)
+
+ appendMaybe :: Maybe [a] -> Maybe a -> Maybe [a]
+ appendMaybe Nothing Nothing = Nothing
+ appendMaybe Nothing (Just x) = Just [x]
+ appendMaybe (Just xs) Nothing = Just xs
+ appendMaybe (Just xs) (Just x) = Just (xs ++ [x])
+
+fragmentList
+ :: FragmentSettings -- ^ Global settings
+ -> Bool -- ^ Fragment THIS list?
+ -> ([[Pandoc.Block]] -> Pandoc.Block) -- ^ List constructor
+ -> [[Pandoc.Block]] -- ^ List items
+ -> Fragmented Pandoc.Block -- ^ Resulting list
+fragmentList fs fragmentThisList constructor blocks0 =
+ fmap constructor fragmented
+ where
+ -- The fragmented list per list item.
+ items :: [Fragmented [Pandoc.Block]]
+ items = map (joinFragmentedBlocks . map (fragmentBlock fs)) blocks0
+
+ fragmented :: Fragmented [[Pandoc.Block]]
+ fragmented = joinFragmentedBlocks $
+ map (if fragmentThisList then insertPause else id) items
+
+ insertPause :: Fragmented a -> Fragmented a
+ insertPause (Unfragmented x) = Fragmented [Nothing] (Just x)
+ insertPause (Fragmented xs x) = Fragmented (Nothing : xs) x
diff --git a/lib/Patat/Presentation/Interactive.hs b/lib/Patat/Presentation/Interactive.hs
new file mode 100644
index 0000000..6707e09
--- /dev/null
+++ b/lib/Patat/Presentation/Interactive.hs
@@ -0,0 +1,142 @@
+--------------------------------------------------------------------------------
+-- | Module that allows the user to interact with the presentation
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+module Patat.Presentation.Interactive
+ ( PresentationCommand (..)
+ , readPresentationCommand
+
+ , UpdatedPresentation (..)
+ , updatePresentation
+ ) where
+
+
+--------------------------------------------------------------------------------
+import Data.Char (isDigit)
+import Patat.Presentation.Internal
+import Patat.Presentation.Read
+import qualified System.IO as IO
+import Text.Read (readMaybe)
+
+
+--------------------------------------------------------------------------------
+data PresentationCommand
+ = Exit
+ | Forward
+ | Backward
+ | SkipForward
+ | SkipBackward
+ | First
+ | Last
+ | Reload
+ | Seek Int
+ | UnknownCommand String
+ deriving (Eq, Show)
+
+
+--------------------------------------------------------------------------------
+readPresentationCommand :: IO.Handle -> IO PresentationCommand
+readPresentationCommand h = do
+ k <- readKeys
+ case k of
+ "q" -> return Exit
+ "\n" -> return Forward
+ "\DEL" -> return Backward
+ "h" -> return Backward
+ "j" -> return SkipForward
+ "k" -> return SkipBackward
+ "l" -> return Forward
+ -- Arrow keys
+ "\ESC[C" -> return Forward
+ "\ESC[D" -> return Backward
+ "\ESC[B" -> return SkipForward
+ "\ESC[A" -> return SkipBackward
+ -- PageUp and PageDown
+ "\ESC[6" -> return Forward
+ "\ESC[5" -> return Backward
+ "0" -> return First
+ "G" -> return Last
+ "r" -> return Reload
+ -- Number followed by enter
+ _ | Just n <- readMaybe k -> return (Seek n)
+ _ -> return (UnknownCommand k)
+ where
+ readKeys :: IO String
+ readKeys = do
+ c0 <- IO.hGetChar h
+ case c0 of
+ '\ESC' -> do
+ c1 <- IO.hGetChar h
+ case c1 of
+ '[' -> do
+ c2 <- IO.hGetChar h
+ return [c0, c1, c2]
+ _ -> return [c0, c1]
+
+ _ | isDigit c0 && c0 /= '0' -> (c0 :) <$> readDigits
+
+ _ -> return [c0]
+
+ readDigits :: IO String
+ readDigits = do
+ c <- IO.hGetChar h
+ if isDigit c then (c :) <$> readDigits else return [c]
+
+
+--------------------------------------------------------------------------------
+data UpdatedPresentation
+ = UpdatedPresentation !Presentation
+ | ExitedPresentation
+ | ErroredPresentation String
+ deriving (Show)
+
+
+--------------------------------------------------------------------------------
+updatePresentation
+ :: PresentationCommand -> Presentation -> IO UpdatedPresentation
+
+updatePresentation cmd presentation = case cmd of
+ Exit -> return ExitedPresentation
+ Forward -> return $ goToSlide $ \(s, f) -> (s, f + 1)
+ Backward -> return $ goToSlide $ \(s, f) -> (s, f - 1)
+ SkipForward -> return $ goToSlide $ \(s, _) -> (s + 10, 0)
+ SkipBackward -> return $ goToSlide $ \(s, _) -> (s - 10, 0)
+ First -> return $ goToSlide $ \_ -> (0, 0)
+ Last -> return $ goToSlide $ \_ -> (numSlides presentation, 0)
+ Seek n -> return $ goToSlide $ \_ -> (n - 1, 0)
+ Reload -> reloadPresentation
+ UnknownCommand _ -> return (UpdatedPresentation presentation)
+ where
+ numSlides :: Presentation -> Int
+ numSlides pres = length (pSlides pres)
+
+ clip :: Index -> Presentation -> Index
+ clip (slide, fragment) pres
+ | slide >= numSlides pres = (numSlides pres - 1, lastFragments - 1)
+ | slide < 0 = (0, 0)
+ | fragment >= numFragments' slide =
+ if slide + 1 >= numSlides pres
+ then (slide, lastFragments - 1)
+ else (slide + 1, 0)
+ | fragment < 0 =
+ if slide - 1 >= 0
+ then (slide - 1, numFragments' (slide - 1) - 1)
+ else (slide, 0)
+ | otherwise = (slide, fragment)
+ where
+ numFragments' s = maybe 1 numFragments (getSlide s pres)
+ lastFragments = numFragments' (numSlides pres - 1)
+
+ goToSlide :: (Index -> Index) -> UpdatedPresentation
+ goToSlide f = UpdatedPresentation $ presentation
+ { pActiveFragment = clip (f $ pActiveFragment presentation) presentation
+ }
+
+ reloadPresentation = do
+ errOrPres <- readPresentation (pFilePath presentation)
+ return $ case errOrPres of
+ Left err -> ErroredPresentation err
+ Right pres -> UpdatedPresentation $ pres
+ { pActiveFragment = clip (pActiveFragment presentation) pres
+ }
diff --git a/lib/Patat/Presentation/Internal.hs b/lib/Patat/Presentation/Internal.hs
new file mode 100644
index 0000000..db8d16b
--- /dev/null
+++ b/lib/Patat/Presentation/Internal.hs
@@ -0,0 +1,266 @@
+--------------------------------------------------------------------------------
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
+module Patat.Presentation.Internal
+ ( Presentation (..)
+ , PresentationSettings (..)
+ , defaultPresentationSettings
+
+ , Margins (..)
+ , marginsOf
+
+ , ExtensionList (..)
+ , defaultExtensionList
+
+ , ImageSettings (..)
+
+ , Slide (..)
+ , Fragment (..)
+ , Index
+
+ , getSlide
+ , numFragments
+
+ , ActiveFragment (..)
+ , getActiveFragment
+ ) where
+
+
+--------------------------------------------------------------------------------
+import Control.Monad (mplus)
+import qualified Data.Aeson.Extended as A
+import qualified Data.Aeson.TH.Extended as A
+import qualified Data.Foldable as Foldable
+import Data.List (intercalate)
+import Data.Maybe (fromMaybe, listToMaybe)
+import Data.Monoid (Monoid (..))
+import Data.Semigroup (Semigroup (..))
+import qualified Data.Text as T
+import qualified Patat.Theme as Theme
+import Prelude
+import qualified Text.Pandoc as Pandoc
+import Text.Read (readMaybe)
+
+
+--------------------------------------------------------------------------------
+data Presentation = Presentation
+ { pFilePath :: !FilePath
+ , pTitle :: ![Pandoc.Inline]
+ , pAuthor :: ![Pandoc.Inline]
+ , pSettings :: !PresentationSettings
+ , pSlides :: [Slide]
+ , pActiveFragment :: !Index
+ } deriving (Show)
+
+
+--------------------------------------------------------------------------------
+-- | These are patat-specific settings. That is where they differ from more
+-- general metadata (author, title...)
+data PresentationSettings = PresentationSettings
+ { psRows :: !(Maybe (A.FlexibleNum Int))
+ , psColumns :: !(Maybe (A.FlexibleNum Int))
+ , psMargins :: !(Maybe Margins)
+ , psWrap :: !(Maybe Bool)
+ , psTheme :: !(Maybe Theme.Theme)
+ , psIncrementalLists :: !(Maybe Bool)
+ , psAutoAdvanceDelay :: !(Maybe (A.FlexibleNum Int))
+ , psSlideLevel :: !(Maybe Int)
+ , psPandocExtensions :: !(Maybe ExtensionList)
+ , psImages :: !(Maybe ImageSettings)
+ } 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
+ }
+
+
+--------------------------------------------------------------------------------
+instance Monoid PresentationSettings where
+ mappend = (<>)
+ mempty = PresentationSettings
+ Nothing Nothing Nothing Nothing Nothing Nothing Nothing
+ Nothing Nothing Nothing
+
+
+--------------------------------------------------------------------------------
+defaultPresentationSettings :: PresentationSettings
+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)
+
+
+--------------------------------------------------------------------------------
+instance A.FromJSON ExtensionList where
+ parseJSON = A.withArray "FromJSON ExtensionList" $
+ fmap (ExtensionList . mconcat) . mapM parseExt . Foldable.toList
+ where
+ parseExt = A.withText "FromJSON ExtensionList" $ \txt -> case txt of
+ -- Our default extensions
+ "patat_extensions" -> return (unExtensionList defaultExtensionList)
+
+ -- Individuals
+ _ -> case readMaybe ("Ext_" ++ T.unpack txt) of
+ Just e -> return $ Pandoc.extensionsFromList [e]
+ Nothing -> fail $
+ "Unknown extension: " ++ show txt ++
+ ", known extensions are: " ++
+ intercalate ", "
+ [ show (drop 4 (show e))
+ | e <- [minBound .. maxBound] :: [Pandoc.Extension]
+ ]
+
+
+--------------------------------------------------------------------------------
+defaultExtensionList :: ExtensionList
+defaultExtensionList = ExtensionList $
+ Pandoc.readerExtensions Pandoc.def `mappend` Pandoc.extensionsFromList
+ [ Pandoc.Ext_yaml_metadata_block
+ , Pandoc.Ext_table_captions
+ , Pandoc.Ext_simple_tables
+ , Pandoc.Ext_multiline_tables
+ , Pandoc.Ext_grid_tables
+ , Pandoc.Ext_pipe_tables
+ , Pandoc.Ext_raw_html
+ , Pandoc.Ext_tex_math_dollars
+ , Pandoc.Ext_fenced_code_blocks
+ , Pandoc.Ext_fenced_code_attributes
+ , Pandoc.Ext_backtick_code_blocks
+ , Pandoc.Ext_inline_code_attributes
+ , Pandoc.Ext_fancy_lists
+ , Pandoc.Ext_four_space_rule
+ , Pandoc.Ext_definition_lists
+ , Pandoc.Ext_compact_definition_lists
+ , Pandoc.Ext_example_lists
+ , Pandoc.Ext_strikeout
+ , Pandoc.Ext_superscript
+ , Pandoc.Ext_subscript
+ ]
+
+
+--------------------------------------------------------------------------------
+data ImageSettings = ImageSettings
+ { isBackend :: !T.Text
+ , isParams :: !A.Object
+ } deriving (Show)
+
+
+--------------------------------------------------------------------------------
+instance A.FromJSON ImageSettings where
+ parseJSON = A.withObject "FromJSON ImageSettings" $ \o -> do
+ t <- o A..: "backend"
+ return ImageSettings {isBackend = t, isParams = o}
+
+
+--------------------------------------------------------------------------------
+data Slide
+ = ContentSlide [Fragment]
+ | TitleSlide Pandoc.Block
+ deriving (Show)
+
+
+--------------------------------------------------------------------------------
+newtype Fragment = Fragment {unFragment :: [Pandoc.Block]}
+ deriving (Monoid, Semigroup, Show)
+
+
+--------------------------------------------------------------------------------
+-- | Active slide, active fragment.
+type Index = (Int, Int)
+
+
+--------------------------------------------------------------------------------
+getSlide :: Int -> Presentation -> Maybe Slide
+getSlide sidx = listToMaybe . drop sidx . pSlides
+
+
+--------------------------------------------------------------------------------
+numFragments :: Slide -> Int
+numFragments (ContentSlide fragments) = length fragments
+numFragments (TitleSlide _) = 1
+
+
+--------------------------------------------------------------------------------
+data ActiveFragment = ActiveContent Fragment | ActiveTitle Pandoc.Block
+ deriving (Show)
+
+
+--------------------------------------------------------------------------------
+getActiveFragment :: Presentation -> Maybe ActiveFragment
+getActiveFragment presentation = do
+ let (sidx, fidx) = pActiveFragment presentation
+ slide <- getSlide sidx presentation
+ case slide of
+ TitleSlide block -> return (ActiveTitle block)
+ ContentSlide fragments ->
+ fmap ActiveContent . listToMaybe $ drop fidx fragments
+
+
+--------------------------------------------------------------------------------
+$(A.deriveFromJSON A.dropPrefixOptions ''PresentationSettings)
+$(A.deriveFromJSON A.dropPrefixOptions ''Margins)
diff --git a/lib/Patat/Presentation/Read.hs b/lib/Patat/Presentation/Read.hs
new file mode 100644
index 0000000..581c31d
--- /dev/null
+++ b/lib/Patat/Presentation/Read.hs
@@ -0,0 +1,205 @@
+-- | Read a presentation from disk.
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+module Patat.Presentation.Read
+ ( readPresentation
+ ) where
+
+
+--------------------------------------------------------------------------------
+import Control.Monad.Except (ExceptT (..), runExceptT,
+ throwError)
+import Control.Monad.Trans (liftIO)
+import qualified Data.Aeson as A
+import qualified Data.HashMap.Strict as HMS
+import Data.Maybe (fromMaybe)
+import Data.Monoid (mempty, (<>))
+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.Presentation.Fragment
+import Patat.Presentation.Internal
+import Prelude
+import System.Directory (doesFileExist, getHomeDirectory)
+import System.FilePath (takeExtension, (</>))
+import qualified Text.Pandoc.Error as Pandoc
+import qualified Text.Pandoc.Extended as Pandoc
+
+
+--------------------------------------------------------------------------------
+readPresentation :: FilePath -> IO (Either String Presentation)
+readPresentation filePath = runExceptT $ do
+ -- We need to read the settings first.
+ src <- liftIO $ T.readFile filePath
+ homeSettings <- ExceptT readHomeSettings
+ metaSettings <- ExceptT $ return $ readMetaSettings src
+ let settings = metaSettings <> homeSettings <> defaultPresentationSettings
+
+ let pexts = fromMaybe defaultExtensionList (psPandocExtensions settings)
+ reader <- case readExtension pexts ext of
+ Nothing -> throwError $ "Unknown file extension: " ++ show ext
+ Just x -> return x
+ doc <- case reader src of
+ Left e -> throwError $ "Could not parse document: " ++ show e
+ Right x -> return x
+
+ ExceptT $ return $ pandocToPresentation filePath settings doc
+ where
+ ext = takeExtension filePath
+
+
+--------------------------------------------------------------------------------
+readExtension
+ :: ExtensionList -> String
+ -> Maybe (T.Text -> Either Pandoc.PandocError Pandoc.Pandoc)
+readExtension (ExtensionList extensions) fileExt = case fileExt of
+ ".md" -> 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
+
+ where
+ readerOpts = Pandoc.def
+ { Pandoc.readerExtensions =
+ extensions <> absolutelyRequiredExtensions
+ }
+
+ lhsOpts = readerOpts
+ { Pandoc.readerExtensions =
+ Pandoc.readerExtensions readerOpts <>
+ Pandoc.extensionsFromList [Pandoc.Ext_literate_haskell]
+ }
+
+ absolutelyRequiredExtensions =
+ Pandoc.extensionsFromList [Pandoc.Ext_yaml_metadata_block]
+
+
+--------------------------------------------------------------------------------
+pandocToPresentation
+ :: FilePath -> PresentationSettings -> Pandoc.Pandoc
+ -> Either String Presentation
+pandocToPresentation pFilePath pSettings pandoc@(Pandoc.Pandoc meta _) = do
+ let !pTitle = Pandoc.docTitle meta
+ !pSlides = pandocToSlides pSettings pandoc
+ !pActiveFragment = (0, 0)
+ !pAuthor = concat (Pandoc.docAuthors meta)
+ return Presentation {..}
+
+
+--------------------------------------------------------------------------------
+-- | This re-parses the pandoc metadata block using the YAML library. This
+-- avoids the problems caused by pandoc involving rendering Markdown. This
+-- should only be used for settings though, not things like title / authors
+-- since those /can/ contain markdown.
+parseMetadataBlock :: T.Text -> Maybe A.Value
+parseMetadataBlock src = do
+ block <- T.encodeUtf8 <$> mbBlock
+ either (const Nothing) Just (Yaml.decodeEither' block)
+ where
+ mbBlock :: Maybe T.Text
+ mbBlock = case T.lines src of
+ ("---" : ls) -> case break (`elem` ["---", "..."]) ls of
+ (_, []) -> Nothing
+ (block, (_ : _)) -> Just (T.unlines block)
+ _ -> Nothing
+
+
+--------------------------------------------------------------------------------
+-- | Read settings from the metadata block in the Pandoc document.
+readMetaSettings :: T.Text -> Either String PresentationSettings
+readMetaSettings src = fromMaybe (Right mempty) $ do
+ A.Object obj <- parseMetadataBlock src
+ val <- HMS.lookup "patat" obj
+ return $! resultToEither $! A.fromJSON val
+ where
+ resultToEither :: A.Result a -> Either String a
+ resultToEither (A.Success x) = Right x
+ resultToEither (A.Error e) = Left $!
+ "Error parsing patat settings from metadata: " ++ e
+
+
+--------------------------------------------------------------------------------
+-- | Read settings from "$HOME/.patat.yaml".
+readHomeSettings :: IO (Either String PresentationSettings)
+readHomeSettings = do
+ home <- getHomeDirectory
+ let path = home </> ".patat.yaml"
+ exists <- doesFileExist path
+ if not exists
+ then return (Right mempty)
+ else do
+ errOrPs <- Yaml.decodeFileEither path
+ return $! case errOrPs of
+ Left err -> Left (show err)
+ Right ps -> Right ps
+
+
+--------------------------------------------------------------------------------
+pandocToSlides :: PresentationSettings -> Pandoc.Pandoc -> [Slide]
+pandocToSlides settings pandoc =
+ let slideLevel = fromMaybe (detectSlideLevel pandoc) (psSlideLevel settings)
+ unfragmented = splitSlides slideLevel pandoc
+ fragmented =
+ [ case slide of
+ TitleSlide _ -> slide
+ ContentSlide fragments0 ->
+ let blocks = concatMap unFragment fragments0
+ blockss = fragmentBlocks fragmentSettings blocks in
+ ContentSlide (map Fragment blockss)
+ | slide <- unfragmented
+ ] in
+ fragmented
+ where
+ fragmentSettings = FragmentSettings
+ { fsIncrementalLists = fromMaybe False (psIncrementalLists settings)
+ }
+
+
+--------------------------------------------------------------------------------
+-- | Find level of header that starts slides. This is defined as the least
+-- header that occurs before a non-header in the blocks.
+detectSlideLevel :: Pandoc.Pandoc -> Int
+detectSlideLevel (Pandoc.Pandoc _meta blocks0) =
+ go 6 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
+
+ nonHeader (Pandoc.Header _ _ _) = False
+ nonHeader _ = True
+
+
+--------------------------------------------------------------------------------
+-- | Split a pandoc document into slides. If the document contains horizonal
+-- rules, we use those as slide delimiters. If there are no horizontal rules,
+-- we split using headers, determined by the slide level (see
+-- 'detectSlideLevel').
+splitSlides :: Int -> Pandoc.Pandoc -> [Slide]
+splitSlides slideLevel (Pandoc.Pandoc _meta blocks0)
+ | any (== Pandoc.HorizontalRule) blocks0 = splitAtRules blocks0
+ | otherwise = splitAtHeaders [] blocks0
+ where
+ mkContentSlide :: [Pandoc.Block] -> [Slide]
+ mkContentSlide [] = [] -- Never create empty slides
+ mkContentSlide bs = [ContentSlide [Fragment bs]]
+
+ splitAtRules blocks = case break (== Pandoc.HorizontalRule) blocks of
+ (xs, []) -> mkContentSlide xs
+ (xs, (_rule : ys)) -> mkContentSlide xs ++ splitAtRules ys
+
+ splitAtHeaders acc [] =
+ mkContentSlide (reverse acc)
+ splitAtHeaders acc (b@(Pandoc.Header i _ _) : bs)
+ | i > slideLevel = splitAtHeaders (b : acc) bs
+ | i == slideLevel =
+ mkContentSlide (reverse acc) ++ splitAtHeaders [b] bs
+ | otherwise =
+ mkContentSlide (reverse acc) ++ [TitleSlide b] ++ splitAtHeaders [] bs
+ splitAtHeaders acc (b : bs) =
+ splitAtHeaders (b : acc) bs
diff --git a/lib/Patat/PrettyPrint.hs b/lib/Patat/PrettyPrint.hs
new file mode 100644
index 0000000..bffa274
--- /dev/null
+++ b/lib/Patat/PrettyPrint.hs
@@ -0,0 +1,411 @@
+--------------------------------------------------------------------------------
+-- | This is a small pretty-printing library.
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE RecordWildCards #-}
+module Patat.PrettyPrint
+ ( Doc
+ , toString
+ , dimensions
+ , null
+
+ , hPutDoc
+ , putDoc
+
+ , string
+ , text
+ , space
+ , spaces
+ , softline
+ , hardline
+
+ , wrapAt
+
+ , Trimmable (..)
+ , indent
+
+ , ansi
+
+ , (<+>)
+ , (<$$>)
+ , vcat
+
+ -- * Exotic combinators
+ , Alignment (..)
+ , align
+ , paste
+ ) where
+
+
+--------------------------------------------------------------------------------
+import Control.Monad.Reader (asks, local)
+import Control.Monad.RWS (RWS, runRWS)
+import Control.Monad.State (get, gets, modify)
+import Control.Monad.Writer (tell)
+import Data.Foldable (Foldable)
+import qualified Data.List as L
+import Data.Monoid (Monoid, mconcat, mempty)
+import Data.Semigroup (Semigroup (..))
+import Data.String (IsString (..))
+import qualified Data.Text as T
+import Data.Traversable (Traversable, traverse)
+import Prelude hiding (null)
+import qualified System.Console.ANSI as Ansi
+import qualified System.IO as IO
+
+
+--------------------------------------------------------------------------------
+-- | A simple chunk of text. All ANSI codes are "reset" after printing.
+data Chunk
+ = StringChunk [Ansi.SGR] String
+ | NewlineChunk
+ deriving (Eq)
+
+
+--------------------------------------------------------------------------------
+type Chunks = [Chunk]
+
+
+--------------------------------------------------------------------------------
+hPutChunk :: IO.Handle -> Chunk -> IO ()
+hPutChunk h NewlineChunk = IO.hPutStrLn h ""
+hPutChunk h (StringChunk codes str) = do
+ Ansi.hSetSGR h (reverse codes)
+ IO.hPutStr h str
+ Ansi.hSetSGR h [Ansi.Reset]
+
+
+--------------------------------------------------------------------------------
+chunkToString :: Chunk -> String
+chunkToString NewlineChunk = "\n"
+chunkToString (StringChunk _ str) = str
+
+
+--------------------------------------------------------------------------------
+-- | If two neighboring chunks have the same set of ANSI codes, we can group
+-- them together.
+optimizeChunks :: Chunks -> Chunks
+optimizeChunks (StringChunk c1 s1 : StringChunk c2 s2 : chunks)
+ | c1 == c2 = optimizeChunks (StringChunk c1 (s1 <> s2) : chunks)
+ | otherwise =
+ StringChunk c1 s1 : optimizeChunks (StringChunk c2 s2 : chunks)
+optimizeChunks (x : chunks) = x : optimizeChunks chunks
+optimizeChunks [] = []
+
+
+--------------------------------------------------------------------------------
+chunkLines :: Chunks -> [Chunks]
+chunkLines chunks = case break (== NewlineChunk) chunks of
+ (xs, _newline : ys) -> xs : chunkLines ys
+ (xs, []) -> [xs]
+
+
+--------------------------------------------------------------------------------
+data DocE
+ = String String
+ | Softspace
+ | Hardspace
+ | Softline
+ | Hardline
+ | WrapAt
+ { wrapAtCol :: Maybe Int
+ , wrapDoc :: Doc
+ }
+ | Ansi
+ { ansiCode :: [Ansi.SGR] -> [Ansi.SGR] -- ^ Modifies current codes.
+ , ansiDoc :: Doc
+ }
+ | Indent
+ { indentFirstLine :: LineBuffer
+ , indentOtherLines :: LineBuffer
+ , indentDoc :: Doc
+ }
+
+
+--------------------------------------------------------------------------------
+chunkToDocE :: Chunk -> DocE
+chunkToDocE NewlineChunk = Hardline
+chunkToDocE (StringChunk codes str) = Ansi (\_ -> codes) (Doc [String str])
+
+
+--------------------------------------------------------------------------------
+newtype Doc = Doc {unDoc :: [DocE]}
+ deriving (Monoid, Semigroup)
+
+
+--------------------------------------------------------------------------------
+instance IsString Doc where
+ fromString = string
+
+
+--------------------------------------------------------------------------------
+instance Show Doc where
+ show = toString
+
+
+--------------------------------------------------------------------------------
+data DocEnv = DocEnv
+ { deCodes :: [Ansi.SGR] -- ^ Most recent ones first in the list
+ , deIndent :: LineBuffer -- ^ Don't need to store first-line indent
+ , deWrap :: Maybe Int -- ^ Wrap at columns
+ }
+
+
+--------------------------------------------------------------------------------
+type DocM = RWS DocEnv Chunks LineBuffer
+
+
+--------------------------------------------------------------------------------
+data Trimmable a
+ = NotTrimmable !a
+ | Trimmable !a
+ deriving (Foldable, Functor, Traversable)
+
+
+--------------------------------------------------------------------------------
+-- | Note that this is reversed so we have fast append
+type LineBuffer = [Trimmable Chunk]
+
+
+--------------------------------------------------------------------------------
+bufferToChunks :: LineBuffer -> Chunks
+bufferToChunks = map trimmableToChunk . reverse . dropWhile isTrimmable
+ where
+ isTrimmable (NotTrimmable _) = False
+ isTrimmable (Trimmable _) = True
+
+ trimmableToChunk (NotTrimmable c) = c
+ trimmableToChunk (Trimmable c) = c
+
+
+--------------------------------------------------------------------------------
+docToChunks :: Doc -> Chunks
+docToChunks doc0 =
+ let env0 = DocEnv [] [] Nothing
+ ((), b, cs) = runRWS (go $ unDoc doc0) env0 mempty in
+ optimizeChunks (cs <> bufferToChunks b)
+ where
+ go :: [DocE] -> DocM ()
+
+ go [] = return ()
+
+ go (String str : docs) = do
+ chunk <- makeChunk str
+ modify (NotTrimmable chunk :)
+ go docs
+
+ go (Softspace : docs) = do
+ hard <- softConversion Softspace docs
+ go (hard : docs)
+
+ go (Hardspace : docs) = do
+ chunk <- makeChunk " "
+ modify (NotTrimmable chunk :)
+ go docs
+
+ go (Softline : docs) = do
+ hard <- softConversion Softline docs
+ go (hard : docs)
+
+ go (Hardline : docs) = do
+ buffer <- get
+ tell $ bufferToChunks buffer <> [NewlineChunk]
+ indentation <- asks deIndent
+ modify $ \_ -> if L.null docs then [] else indentation
+ go docs
+
+ go (WrapAt {..} : docs) = do
+ local (\env -> env {deWrap = wrapAtCol}) $ go (unDoc wrapDoc)
+ go docs
+
+ go (Ansi {..} : docs) = do
+ local (\env -> env {deCodes = ansiCode (deCodes env)}) $
+ go (unDoc ansiDoc)
+ go docs
+
+ go (Indent {..} : docs) = do
+ local (\env -> env {deIndent = indentOtherLines ++ deIndent env}) $ do
+ modify (indentFirstLine ++)
+ go (unDoc indentDoc)
+ go docs
+
+ makeChunk :: String -> DocM Chunk
+ makeChunk str = do
+ codes <- asks deCodes
+ return $ StringChunk codes str
+
+ -- Convert 'Softspace' or 'Softline' to 'Hardspace' or 'Hardline'
+ softConversion :: DocE -> [DocE] -> DocM DocE
+ softConversion soft docs = do
+ mbWrapCol <- asks deWrap
+ case mbWrapCol of
+ Nothing -> return hard
+ Just maxCol -> do
+ -- Slow.
+ currentLine <- gets (concatMap chunkToString . bufferToChunks)
+ let currentCol = length currentLine
+ case nextWordLength docs of
+ Nothing -> return hard
+ Just l
+ | currentCol + 1 + l <= maxCol -> return Hardspace
+ | otherwise -> return Hardline
+ where
+ hard = case soft of
+ Softspace -> Hardspace
+ Softline -> Hardline
+ _ -> soft
+
+ nextWordLength :: [DocE] -> Maybe Int
+ nextWordLength [] = Nothing
+ nextWordLength (String x : xs)
+ | L.null x = nextWordLength xs
+ | otherwise = Just (length x)
+ nextWordLength (Softspace : xs) = nextWordLength xs
+ nextWordLength (Hardspace : xs) = nextWordLength xs
+ nextWordLength (Softline : xs) = nextWordLength xs
+ nextWordLength (Hardline : _) = Nothing
+ nextWordLength (WrapAt {..} : xs) = nextWordLength (unDoc wrapDoc ++ xs)
+ nextWordLength (Ansi {..} : xs) = nextWordLength (unDoc ansiDoc ++ xs)
+ nextWordLength (Indent {..} : xs) = nextWordLength (unDoc indentDoc ++ xs)
+
+
+--------------------------------------------------------------------------------
+toString :: Doc -> String
+toString = concat . map chunkToString . docToChunks
+
+
+--------------------------------------------------------------------------------
+-- | Returns the rows and columns necessary to render this document
+dimensions :: Doc -> (Int, Int)
+dimensions doc =
+ let ls = lines (toString doc) in
+ (length ls, foldr max 0 (map length ls))
+
+
+--------------------------------------------------------------------------------
+null :: Doc -> Bool
+null doc = case unDoc doc of [] -> True; _ -> False
+
+
+--------------------------------------------------------------------------------
+hPutDoc :: IO.Handle -> Doc -> IO ()
+hPutDoc h = mapM_ (hPutChunk h) . docToChunks
+
+
+--------------------------------------------------------------------------------
+putDoc :: Doc -> IO ()
+putDoc = hPutDoc IO.stdout
+
+
+--------------------------------------------------------------------------------
+mkDoc :: DocE -> Doc
+mkDoc e = Doc [e]
+
+
+--------------------------------------------------------------------------------
+string :: String -> Doc
+string = mkDoc . String -- TODO (jaspervdj): Newline conversion
+
+
+--------------------------------------------------------------------------------
+text :: T.Text -> Doc
+text = string . T.unpack
+
+
+--------------------------------------------------------------------------------
+space :: Doc
+space = mkDoc Softspace
+
+
+--------------------------------------------------------------------------------
+spaces :: Int -> Doc
+spaces n = mconcat $ replicate n space
+
+
+--------------------------------------------------------------------------------
+softline :: Doc
+softline = mkDoc Softline
+
+
+--------------------------------------------------------------------------------
+hardline :: Doc
+hardline = mkDoc Hardline
+
+
+--------------------------------------------------------------------------------
+wrapAt :: Maybe Int -> Doc -> Doc
+wrapAt wrapAtCol wrapDoc = mkDoc WrapAt {..}
+
+
+--------------------------------------------------------------------------------
+indent :: Trimmable Doc -> Trimmable Doc -> Doc -> Doc
+indent firstLineDoc otherLinesDoc doc = mkDoc $ Indent
+ { indentFirstLine = traverse docToChunks firstLineDoc
+ , indentOtherLines = traverse docToChunks otherLinesDoc
+ , indentDoc = doc
+ }
+
+
+--------------------------------------------------------------------------------
+ansi :: [Ansi.SGR] -> Doc -> Doc
+ansi codes = mkDoc . Ansi (codes ++)
+
+
+--------------------------------------------------------------------------------
+(<+>) :: Doc -> Doc -> Doc
+x <+> y = x <> space <> y
+infixr 6 <+>
+
+
+--------------------------------------------------------------------------------
+(<$$>) :: Doc -> Doc -> Doc
+x <$$> y = x <> hardline <> y
+infixr 5 <$$>
+
+
+--------------------------------------------------------------------------------
+vcat :: [Doc] -> Doc
+vcat = mconcat . L.intersperse hardline
+
+
+--------------------------------------------------------------------------------
+data Alignment = AlignLeft | AlignCenter | AlignRight deriving (Eq, Ord, Show)
+
+
+--------------------------------------------------------------------------------
+align :: Int -> Alignment -> Doc -> Doc
+align width alignment doc0 =
+ let chunks0 = docToChunks doc0
+ lines_ = chunkLines chunks0 in
+ vcat
+ [ Doc (map chunkToDocE (alignLine line))
+ | line <- lines_
+ ]
+ where
+ lineWidth :: [Chunk] -> Int
+ lineWidth = sum . map (length . chunkToString)
+
+ alignLine :: [Chunk] -> [Chunk]
+ alignLine line =
+ let actual = lineWidth line
+ chunkSpaces n = [StringChunk [] (replicate n ' ')] in
+ case alignment of
+ AlignLeft -> line <> chunkSpaces (width - actual)
+ AlignRight -> chunkSpaces (width - actual) <> line
+ AlignCenter ->
+ let r = (width - actual) `div` 2
+ l = (width - actual) - r in
+ chunkSpaces l <> line <> chunkSpaces r
+
+
+--------------------------------------------------------------------------------
+-- | Like the unix program 'paste'.
+paste :: [Doc] -> Doc
+paste docs0 =
+ let chunkss = map docToChunks docs0 :: [Chunks]
+ cols = map chunkLines chunkss :: [[Chunks]]
+ rows0 = L.transpose cols :: [[Chunks]]
+ rows1 = map (map (Doc . map chunkToDocE)) rows0 :: [[Doc]] in
+ vcat $ map mconcat rows1
diff --git a/lib/Patat/Theme.hs b/lib/Patat/Theme.hs
new file mode 100644
index 0000000..952a521
--- /dev/null
+++ b/lib/Patat/Theme.hs
@@ -0,0 +1,324 @@
+--------------------------------------------------------------------------------
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
+module Patat.Theme
+ ( Theme (..)
+ , defaultTheme
+
+ , Style (..)
+
+ , SyntaxHighlighting (..)
+ , defaultSyntaxHighlighting
+ , syntaxHighlight
+ ) where
+
+
+--------------------------------------------------------------------------------
+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)
+
+
+--------------------------------------------------------------------------------
+data Theme = Theme
+ { themeBorders :: !(Maybe Style)
+ , themeHeader :: !(Maybe Style)
+ , themeCodeBlock :: !(Maybe Style)
+ , themeBulletList :: !(Maybe Style)
+ , themeBulletListMarkers :: !(Maybe T.Text)
+ , themeOrderedList :: !(Maybe Style)
+ , themeBlockQuote :: !(Maybe Style)
+ , themeDefinitionTerm :: !(Maybe Style)
+ , themeDefinitionList :: !(Maybe Style)
+ , themeTableHeader :: !(Maybe Style)
+ , themeTableSeparator :: !(Maybe Style)
+ , themeLineBlock :: !(Maybe Style)
+ , themeEmph :: !(Maybe Style)
+ , themeStrong :: !(Maybe Style)
+ , themeCode :: !(Maybe Style)
+ , themeLinkText :: !(Maybe Style)
+ , themeLinkTarget :: !(Maybe Style)
+ , themeStrikeout :: !(Maybe Style)
+ , themeQuoted :: !(Maybe Style)
+ , themeMath :: !(Maybe Style)
+ , themeImageText :: !(Maybe Style)
+ , themeImageTarget :: !(Maybe Style)
+ , themeSyntaxHighlighting :: !(Maybe SyntaxHighlighting)
+ } deriving (Show)
+
+
+--------------------------------------------------------------------------------
+instance Semigroup Theme where
+ l <> r = Theme
+ { themeBorders = mplusOn themeBorders
+ , themeHeader = mplusOn themeHeader
+ , themeCodeBlock = mplusOn themeCodeBlock
+ , themeBulletList = mplusOn themeBulletList
+ , themeBulletListMarkers = mplusOn themeBulletListMarkers
+ , themeOrderedList = mplusOn themeOrderedList
+ , themeBlockQuote = mplusOn themeBlockQuote
+ , themeDefinitionTerm = mplusOn themeDefinitionTerm
+ , themeDefinitionList = mplusOn themeDefinitionList
+ , themeTableHeader = mplusOn themeTableHeader
+ , themeTableSeparator = mplusOn themeTableSeparator
+ , themeLineBlock = mplusOn themeLineBlock
+ , themeEmph = mplusOn themeEmph
+ , themeStrong = mplusOn themeStrong
+ , themeCode = mplusOn themeCode
+ , themeLinkText = mplusOn themeLinkText
+ , themeLinkTarget = mplusOn themeLinkTarget
+ , themeStrikeout = mplusOn themeStrikeout
+ , themeQuoted = mplusOn themeQuoted
+ , themeMath = mplusOn themeMath
+ , themeImageText = mplusOn themeImageText
+ , themeImageTarget = mplusOn themeImageTarget
+ , themeSyntaxHighlighting = mappendOn themeSyntaxHighlighting
+ }
+ where
+ mplusOn f = f l `mplus` f r
+ mappendOn f = f l `mappend` f r
+
+
+--------------------------------------------------------------------------------
+instance Monoid Theme where
+ mappend = (<>)
+ mempty = Theme
+ Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
+ Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
+ Nothing Nothing Nothing Nothing Nothing
+
+--------------------------------------------------------------------------------
+defaultTheme :: Theme
+defaultTheme = Theme
+ { themeBorders = dull Ansi.Yellow
+ , themeHeader = dull Ansi.Blue
+ , themeCodeBlock = dull Ansi.White `mappend` ondull Ansi.Black
+ , themeBulletList = dull Ansi.Magenta
+ , themeBulletListMarkers = Just "-*"
+ , themeOrderedList = dull Ansi.Magenta
+ , themeBlockQuote = dull Ansi.Green
+ , themeDefinitionTerm = dull Ansi.Blue
+ , themeDefinitionList = dull Ansi.Magenta
+ , themeTableHeader = dull Ansi.Blue
+ , themeTableSeparator = dull Ansi.Magenta
+ , themeLineBlock = dull Ansi.Magenta
+ , themeEmph = dull Ansi.Green
+ , themeStrong = dull Ansi.Red `mappend` bold
+ , themeCode = dull Ansi.White `mappend` ondull Ansi.Black
+ , themeLinkText = dull Ansi.Green
+ , themeLinkTarget = dull Ansi.Cyan `mappend` underline
+ , themeStrikeout = ondull Ansi.Red
+ , themeQuoted = dull Ansi.Green
+ , themeMath = dull Ansi.Green
+ , themeImageText = dull Ansi.Green
+ , themeImageTarget = dull Ansi.Cyan `mappend` underline
+ , themeSyntaxHighlighting = Just defaultSyntaxHighlighting
+ }
+ where
+ dull c = Just $ Style [Ansi.SetColor Ansi.Foreground Ansi.Dull c]
+ ondull c = Just $ Style [Ansi.SetColor Ansi.Background Ansi.Dull c]
+ bold = Just $ Style [Ansi.SetConsoleIntensity Ansi.BoldIntensity]
+ underline = Just $ Style [Ansi.SetUnderlining Ansi.SingleUnderline]
+
+
+--------------------------------------------------------------------------------
+newtype Style = Style {unStyle :: [Ansi.SGR]}
+ deriving (Monoid, Semigroup, Show)
+
+
+--------------------------------------------------------------------------------
+instance A.ToJSON Style where
+ toJSON = A.toJSON . mapMaybe sgrToString . unStyle
+
+
+--------------------------------------------------------------------------------
+instance A.FromJSON Style where
+ parseJSON val = do
+ names <- A.parseJSON val
+ sgrs <- mapM toSgr names
+ return $! Style sgrs
+ where
+ toSgr name = case stringToSgr name of
+ Just sgr -> return sgr
+ Nothing -> fail $!
+ "Unknown style: " ++ show name ++ ". Known styles are: " ++
+ intercalate ", " (map show $ M.keys namedSgrs) ++
+ ", or \"rgb#RrGgBb\" and \"onRgb#RrGgBb\" where 'Rr', " ++
+ "'Gg' and 'Bb' are hexadecimal bytes (e.g. \"rgb#f08000\")."
+
+
+--------------------------------------------------------------------------------
+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) $
+ (case intensity of
+ Ansi.Dull -> "dull"
+ Ansi.Vivid -> "vivid") ++
+ (case color of
+ Ansi.Black -> "Black"
+ Ansi.Red -> "Red"
+ Ansi.Green -> "Green"
+ Ansi.Yellow -> "Yellow"
+ Ansi.Blue -> "Blue"
+ Ansi.Magenta -> "Magenta"
+ Ansi.Cyan -> "Cyan"
+ Ansi.White -> "White")
+
+sgrToString (Ansi.SetUnderlining Ansi.SingleUnderline) = Just "underline"
+
+sgrToString (Ansi.SetConsoleIntensity Ansi.BoldIntensity) = Just "bold"
+
+sgrToString (Ansi.SetItalicized True) = Just "italic"
+
+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
+
+
+--------------------------------------------------------------------------------
+namedSgrs :: M.Map String Ansi.SGR
+namedSgrs = M.fromList
+ [ (name, sgr)
+ | sgr <- knownSgrs
+ , name <- maybeToList (sgrToString sgr)
+ ]
+ where
+ -- | It doesn't really matter if we generate "too much" SGRs here since
+ -- 'sgrToString' will only pick the ones we support.
+ knownSgrs =
+ [ Ansi.SetColor l i c
+ | l <- [minBound .. maxBound]
+ , i <- [minBound .. maxBound]
+ , c <- [minBound .. maxBound]
+ ] ++
+ [Ansi.SetUnderlining u | u <- [minBound .. maxBound]] ++
+ [Ansi.SetConsoleIntensity c | c <- [minBound .. maxBound]] ++
+ [Ansi.SetItalicized i | i <- [minBound .. maxBound]]
+
+
+--------------------------------------------------------------------------------
+newtype SyntaxHighlighting = SyntaxHighlighting
+ { unSyntaxHighlighting :: M.Map String Style
+ } deriving (Monoid, Semigroup, Show, A.ToJSON)
+
+
+--------------------------------------------------------------------------------
+instance A.FromJSON SyntaxHighlighting where
+ parseJSON val = do
+ styleMap <- A.parseJSON val
+ forM_ (M.keys styleMap) $ \k -> case nameToTokenType k of
+ Just _ -> return ()
+ Nothing -> fail $ "Unknown token type: " ++ show k
+ return (SyntaxHighlighting styleMap)
+
+
+--------------------------------------------------------------------------------
+defaultSyntaxHighlighting :: SyntaxHighlighting
+defaultSyntaxHighlighting = mkSyntaxHighlighting
+ [ (Skylighting.KeywordTok, dull Ansi.Yellow)
+ , (Skylighting.ControlFlowTok, dull Ansi.Yellow)
+
+ , (Skylighting.DataTypeTok, dull Ansi.Green)
+
+ , (Skylighting.DecValTok, dull Ansi.Red)
+ , (Skylighting.BaseNTok, dull Ansi.Red)
+ , (Skylighting.FloatTok, dull Ansi.Red)
+ , (Skylighting.ConstantTok, dull Ansi.Red)
+ , (Skylighting.CharTok, dull Ansi.Red)
+ , (Skylighting.SpecialCharTok, dull Ansi.Red)
+ , (Skylighting.StringTok, dull Ansi.Red)
+ , (Skylighting.VerbatimStringTok, dull Ansi.Red)
+ , (Skylighting.SpecialStringTok, dull Ansi.Red)
+
+ , (Skylighting.CommentTok, dull Ansi.Blue)
+ , (Skylighting.DocumentationTok, dull Ansi.Blue)
+ , (Skylighting.AnnotationTok, dull Ansi.Blue)
+ , (Skylighting.CommentVarTok, dull Ansi.Blue)
+
+ , (Skylighting.ImportTok, dull Ansi.Cyan)
+ , (Skylighting.OperatorTok, dull Ansi.Cyan)
+ , (Skylighting.FunctionTok, dull Ansi.Cyan)
+ , (Skylighting.PreprocessorTok, dull Ansi.Cyan)
+ ]
+ where
+ dull c = Style [Ansi.SetColor Ansi.Foreground Ansi.Dull c]
+
+ mkSyntaxHighlighting ls = SyntaxHighlighting $
+ M.fromList [(nameForTokenType tt, s) | (tt, s) <- ls]
+
+
+--------------------------------------------------------------------------------
+nameForTokenType :: Skylighting.TokenType -> String
+nameForTokenType =
+ unCapitalize . dropTok . show
+ where
+ unCapitalize (x : xs) = toLower x : xs
+ unCapitalize xs = xs
+
+ dropTok :: String -> String
+ dropTok str
+ | "Tok" `isSuffixOf` str = take (length str - 3) str
+ | otherwise = str
+
+
+--------------------------------------------------------------------------------
+nameToTokenType :: String -> Maybe Skylighting.TokenType
+nameToTokenType = readMaybe . capitalize . (++ "Tok")
+
+
+--------------------------------------------------------------------------------
+capitalize :: String -> String
+capitalize "" = ""
+capitalize (x : xs) = toUpper x : xs
+
+
+--------------------------------------------------------------------------------
+syntaxHighlight :: Theme -> Skylighting.TokenType -> Maybe Style
+syntaxHighlight theme tokenType = do
+ sh <- themeSyntaxHighlighting theme
+ M.lookup (nameForTokenType tokenType) (unSyntaxHighlighting sh)
+
+
+--------------------------------------------------------------------------------
+$(A.deriveJSON A.dropPrefixOptions ''Theme)
diff --git a/lib/Text/Pandoc/Extended.hs b/lib/Text/Pandoc/Extended.hs
new file mode 100644
index 0000000..941d716
--- /dev/null
+++ b/lib/Text/Pandoc/Extended.hs
@@ -0,0 +1,30 @@
+--------------------------------------------------------------------------------
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE LambdaCase #-}
+module Text.Pandoc.Extended
+ ( module Text.Pandoc
+
+ , plainToPara
+ , newlineToSpace
+ ) where
+
+
+--------------------------------------------------------------------------------
+import Data.Data.Extended (grecT)
+import Text.Pandoc
+import Prelude
+
+
+--------------------------------------------------------------------------------
+plainToPara :: [Block] -> [Block]
+plainToPara = map $ \case
+ Plain inlines -> Para inlines
+ block -> block
+
+
+--------------------------------------------------------------------------------
+newlineToSpace :: [Inline] -> [Inline]
+newlineToSpace = grecT $ \case
+ SoftBreak -> Space
+ LineBreak -> Space
+ inline -> inline