patat 0.8.3.0 → 0.8.4.0

raw patch · 46 files changed

+2872/−2701 lines, 46 filesdep +QuickCheckdep +patatdep +tastydep ~basedep ~pandocdep ~time

Dependencies added: QuickCheck, patat, tasty, tasty-hunit, tasty-quickcheck

Dependency ranges changed: base, pandoc, time

Files

• CHANGELOG.md +5/−0
• README.md +1/−0
• lib/Data/Aeson/Extended.hs +22/−0
• lib/Data/Aeson/TH/Extended.hs +21/−0
• lib/Data/Data/Extended.hs +23/−0
• lib/Patat/AutoAdvance.hs +52/−0
• lib/Patat/Cleanup.hs +10/−0
• lib/Patat/Images.hs +61/−0
• lib/Patat/Images/ITerm2.hs +58/−0
• lib/Patat/Images/Internal.hs +40/−0
• lib/Patat/Images/W3m.hs +151/−0
• lib/Patat/Main.hs +219/−0
• lib/Patat/Presentation.hs +20/−0
• lib/Patat/Presentation/Display.hs +380/−0
• lib/Patat/Presentation/Display/CodeBlock.hs +83/−0
• lib/Patat/Presentation/Display/Table.hs +107/−0
• lib/Patat/Presentation/Fragment.hs +134/−0
• lib/Patat/Presentation/Interactive.hs +142/−0
• lib/Patat/Presentation/Internal.hs +266/−0
• lib/Patat/Presentation/Read.hs +205/−0
• lib/Patat/PrettyPrint.hs +411/−0
• lib/Patat/Theme.hs +324/−0
• lib/Text/Pandoc/Extended.hs +30/−0
• patat.cabal +38/−9
• src/Data/Aeson/Extended.hs +0/−22
• src/Data/Aeson/TH/Extended.hs +0/−21
• src/Data/Data/Extended.hs +0/−23
• src/Main.hs +2/−191
• src/Patat/AutoAdvance.hs +0/−52
• src/Patat/Images.hs +0/−60
• src/Patat/Images/ITerm2.hs +0/−56
• src/Patat/Images/Internal.hs +0/−39
• src/Patat/Images/W3m.hs +0/−145
• src/Patat/Presentation.hs +0/−20
• src/Patat/Presentation/Display.hs +0/−377
• src/Patat/Presentation/Display/CodeBlock.hs +0/−83
• src/Patat/Presentation/Display/Table.hs +0/−107
• src/Patat/Presentation/Fragment.hs +0/−134
• src/Patat/Presentation/Interactive.hs +0/−126
• src/Patat/Presentation/Internal.hs +0/−266
• src/Patat/Presentation/Read.hs +0/−205
• src/Patat/PrettyPrint.hs +0/−411
• src/Patat/Theme.hs +0/−324
• src/Text/Pandoc/Extended.hs +0/−30
• tests/haskell/Main.hs +9/−0
• tests/haskell/Patat/Presentation/Interactive/Tests.hs +58/−0

@@ -1,5 +1,10 @@ # Changelog +- 0.8.4.0 (2019-10-09)+    * Add slide seeking (enter slide number + `enter`)+    * Fix turning tty echo off/on during presentation+    * Run `w3mimgdisplay` cleanup action, fixing image issues on some terminals+ - 0.8.3.0 (2019-09-07)     * Fix test failure again, and ensure that it works for multiple pandoc       versions by slightly modifying test input

@@ -128,6 +128,7 @@ - **Go backward 10 slides**: `k`, `↑` - **First slide**: `0` - **Last slide**: `G`+- **Jump to slide N**: `N` followed by `enter` - **Reload file**: `r` - **Quit**: `q` 

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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 ()

@@ -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

@@ -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"

@@ -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+    }

@@ -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)

@@ -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

@@ -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

@@ -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

@@ -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) ' ') <> " "

@@ -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

@@ -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

@@ -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+                }

@@ -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)

@@ -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

@@ -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

@@ -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)

@@ -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

@@ -1,5 +1,5 @@ Name:                patat-Version:             0.8.3.0+Version:             0.8.4.0 Synopsis:            Terminal-based presentations using Pandoc Description:         Terminal-based presentations using Pandoc. License:             GPL-2@@ -25,10 +25,9 @@   Default:     False   Manual:      True -Executable patat-  Main-is:           Main.hs-  Ghc-options:       -Wall -threaded -rtsopts "-with-rtsopts=-N"-  Hs-source-dirs:    src+Library+  Ghc-options:       -Wall+  Hs-source-dirs:    lib   Default-language:  Haskell2010    Build-depends:@@ -61,15 +60,14 @@     Build-depends:       semigroups >= 0.16 && < 0.19 -  Other-modules:-    Data.Aeson.Extended-    Data.Aeson.TH.Extended-    Data.Data.Extended+  Exposed-modules:     Patat.AutoAdvance+    Patat.Cleanup     Patat.Images     Patat.Images.Internal     Patat.Images.W3m     Patat.Images.ITerm2+    Patat.Main     Patat.Presentation     Patat.Presentation.Display     Patat.Presentation.Display.CodeBlock@@ -80,9 +78,21 @@     Patat.Presentation.Read     Patat.PrettyPrint     Patat.Theme++  Other-modules:+    Data.Aeson.Extended+    Data.Aeson.TH.Extended+    Data.Data.Extended     Paths_patat     Text.Pandoc.Extended +Executable patat+  Main-is:          Main.hs+  Ghc-options:      -Wall -threaded -rtsopts "-with-rtsopts=-N"+  Hs-source-dirs:   src+  Default-language: Haskell2010+  Build-depends:    base, patat+ Executable patat-make-man   Main-is:          make-man.hs   Ghc-options:      -Wall@@ -100,3 +110,22 @@     pandoc >= 2.0  && < 2.8,     text   >= 1.2  && < 1.3,     time   >= 1.6  && < 1.10++Test-suite patat-tests+  Main-is:          Main.hs+  Ghc-options:      -Wall+  Hs-source-dirs:   tests/haskell+  Type:             exitcode-stdio-1.0+  Default-language: Haskell2010++  Other-modules:+    Patat.Presentation.Interactive.Tests++  Build-depends:+    patat,+    base                 >= 4.8  && < 5,+    directory            >= 1.2  && < 1.4,+    tasty                >= 1.2  && < 1.3,+    tasty-hunit          >= 0.10 && < 0.11,+    tasty-quickcheck     >= 0.10 && < 0.11,+    QuickCheck           >= 2.8  && < 2.14

@@ -1,22 +0,0 @@-{-# 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

@@ -1,21 +0,0 @@----------------------------------------------------------------------------------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

@@ -1,23 +0,0 @@-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

@@ -1,193 +1,4 @@----------------------------------------------------------------------------------{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings          #-}-{-# LANGUAGE RecordWildCards            #-}-module Main where------------------------------------------------------------------------------------import           Control.Applicative          ((<$>), (<*>))-import           Control.Concurrent           (forkIO, threadDelay)-import qualified Control.Concurrent.Chan      as Chan-import           Control.Exception            (finally)-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`."-        ]-+import qualified Patat.Main --------------------------------------------------------------------------------- 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 = (`finally` cleanup) $ do-        IO.hSetBuffering IO.stdin IO.NoBuffering-        Ansi.hideCursor--        -- Spawn the initial channel that gives us commands based on user input.-        commandChan0 <- Chan.newChan-        _            <- forkIO $ forever $-            readPresentationCommand >>= Chan.writeChan commandChan0--        -- If an auto delay is set, use 'autoAdvance' to create a new one.-        commandChan <- case psAutoAdvanceDelay (pSettings pres0) of-            Nothing                    -> return commandChan0-            Just (A.FlexibleNum delay) -> autoAdvance delay commandChan0--        -- 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-                case mbError of-                    Nothing  -> displayPresentation images pres-                    Just err -> displayPresentationError pres err--                c      <- Chan.readChan commandChan-                update <- updatePresentation c pres-                case update of-                    ExitedPresentation        -> return ()-                    UpdatedPresentation pres' -> loop pres' Nothing-                    ErroredPresentation err   -> loop pres (Just err)--        loop pres0 Nothing--    cleanup :: IO ()-    cleanup = do-        Ansi.showCursor-        Ansi.clearScreen-        Ansi.setCursorPosition 0 0------------------------------------------------------------------------------------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+main = Patat.Main.main

@@ -1,52 +0,0 @@----------------------------------------------------------------------------------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

@@ -1,60 +0,0 @@----------------------------------------------------------------------------------{-# LANGUAGE OverloadedStrings #-}-module Patat.Images-    ( Backend-    , Handle-    , new-    , drawImage-    ) where------------------------------------------------------------------------------------import           Control.Exception           (catch)-import qualified Data.Aeson                  as A-import qualified Data.Text                   as T-import           Patat.Images.Internal-import qualified Patat.Images.ITerm2         as ITerm2-import qualified Patat.Images.W3m            as W3m-import           Patat.Presentation.Internal------------------------------------------------------------------------------------new :: ImageSettings -> IO Handle-new is-    | isBackend is == "auto" = auto-    | Just (Backend b) <- lookup (isBackend is) backends =-        case A.fromJSON (A.Object $ isParams is) of-            A.Success c -> b (Explicit c)-            A.Error err -> fail $-                "Patat.Images.new: Error parsing config for " ++-                show (isBackend is) ++ " image backend: " ++ err-new is = fail $-    "Patat.Images.new: Could not find " ++ show (isBackend is) ++-    " image backend."------------------------------------------------------------------------------------auto :: IO Handle-auto = go [] backends-  where-    go names ((name, Backend b) : bs) = catch-        (b Auto)-        (\(BackendNotSupported _) -> go (name : names) bs)-    go names [] = fail $-        "Could not find a supported backend, tried: " ++-        T.unpack (T.intercalate ", " (reverse names))-------------------------------------------------------------------------------------- | All supported backends.  We can use CPP to include or exclude some--- depending on platform availability.-backends :: [(T.Text, Backend)]-backends =-    [ ("iterm2", ITerm2.backend)-    , ("w3m",    W3m.backend)-    ]------------------------------------------------------------------------------------drawImage :: Handle -> FilePath -> IO ()-drawImage = hDrawImage

@@ -1,56 +0,0 @@----------------------------------------------------------------------------------{-# LANGUAGE TemplateHaskell #-}-module Patat.Images.ITerm2-    ( backend-    ) where------------------------------------------------------------------------------------import           Control.Exception           (throwIO)-import           Control.Monad               (unless, when)-import qualified Data.Aeson                  as A-import qualified Data.ByteString.Base64.Lazy as B64-import qualified Data.ByteString.Lazy        as BL-import qualified Data.List                   as L-import qualified Patat.Images.Internal       as Internal-import           System.Environment          (lookupEnv)------------------------------------------------------------------------------------backend :: Internal.Backend-backend = Internal.Backend new------------------------------------------------------------------------------------data Config = Config deriving (Eq)-instance A.FromJSON Config where parseJSON _ = return Config------------------------------------------------------------------------------------new :: Internal.Config Config -> IO Internal.Handle-new config = do-    when (config == Internal.Auto) $ do-        termProgram <- lookupEnv "TERM_PROGRAM"-        unless (termProgram == Just "iTerm.app") $ throwIO $-            Internal.BackendNotSupported "TERM_PROGRAM not iTerm.app"--    return Internal.Handle {Internal.hDrawImage = drawImage}------------------------------------------------------------------------------------drawImage :: FilePath -> IO ()-drawImage path = do-    content <- BL.readFile path-    withEscapeSequence $ do-        putStr "1337;File=inline=1;width=100%;height=100%:"-        BL.putStr (B64.encode content)------------------------------------------------------------------------------------withEscapeSequence :: IO () -> IO ()-withEscapeSequence f = do-    term <- lookupEnv "TERM"-    let inScreen = maybe False ("screen" `L.isPrefixOf`) term-    putStr $ if inScreen then "\ESCPtmux;\ESC\ESC]" else "\ESC]"-    f-    putStrLn $ if inScreen then "\a\ESC\\" else "\a"

@@ -1,39 +0,0 @@----------------------------------------------------------------------------------{-# 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)------------------------------------------------------------------------------------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 ()-    }

@@ -1,145 +0,0 @@----------------------------------------------------------------------------------{-# LANGUAGE TemplateHaskell #-}-module Patat.Images.W3m-    ( backend-    ) where------------------------------------------------------------------------------------import           Control.Exception      (throwIO)-import           Control.Monad          (unless)-import qualified Data.Aeson.TH.Extended as A-import qualified Patat.Images.Internal  as Internal-import qualified System.Directory       as Directory-import qualified System.Process         as Process-import           Text.Read              (readMaybe)------------------------------------------------------------------------------------backend :: Internal.Backend-backend = Internal.Backend new------------------------------------------------------------------------------------data Config = Config-    { cPath :: Maybe FilePath-    } deriving (Show)------------------------------------------------------------------------------------new :: Internal.Config Config -> IO Internal.Handle-new config = do-    w3m <- findW3m $ case config of-        Internal.Explicit c -> cPath c-        _                   -> Nothing--    return Internal.Handle {Internal.hDrawImage = drawImage w3m}------------------------------------------------------------------------------------newtype W3m = W3m FilePath deriving (Show)------------------------------------------------------------------------------------findW3m :: Maybe FilePath -> IO W3m-findW3m mbPath-    | Just path <- mbPath = do-        exe <- isExecutable path-        if exe-            then return (W3m path)-            else throwIO $-                    Internal.BackendNotSupported $ path ++ " is not executable"-    | otherwise = W3m <$> find paths-  where-    find []       = throwIO $ Internal.BackendNotSupported-        "w3mimgdisplay executable not found"-    find (p : ps) = do-        exe <- isExecutable p-        if exe then return p else find ps--    paths =-        [ "/usr/lib/w3m/w3mimgdisplay"-        , "/usr/libexec/w3m/w3mimgdisplay"-        , "/usr/lib64/w3m/w3mimgdisplay"-        , "/usr/libexec64/w3m/w3mimgdisplay"-        , "/usr/local/libexec/w3m/w3mimgdisplay"-        ]--    isExecutable path = do-        exists <- Directory.doesFileExist path-        if exists then do-            perms <- Directory.getPermissions path-            return (Directory.executable perms)-        else-            return False-------------------------------------------------------------------------------------- | Parses something of the form "<width> <height>\n".-parseWidthHeight :: String -> Maybe (Int, Int)-parseWidthHeight output = case words output of-    [ws, hs] | Just w <- readMaybe ws, Just h <- readMaybe hs ->-        return (w, h)-    _  -> Nothing------------------------------------------------------------------------------------getTerminalSize :: W3m -> IO (Int, Int)-getTerminalSize (W3m w3mPath) = do-    output <- Process.readProcess w3mPath ["-test"] ""-    case parseWidthHeight output of-        Just wh -> return wh-        _       -> fail $-            "Patat.Images.W3m.getTerminalSize: " ++-            "Could not parse `w3mimgdisplay -test` output"------------------------------------------------------------------------------------getImageSize :: W3m -> FilePath -> IO (Int, Int)-getImageSize (W3m w3mPath) path = do-    output <- Process.readProcess w3mPath [] ("5;" ++ path ++ "\n")-    case parseWidthHeight output of-        Just wh -> return wh-        _       -> fail $-            "Patat.Images.W3m.getImageSize: " ++-            "Could not parse image size using `w3mimgdisplay` for " ++-            path------------------------------------------------------------------------------------drawImage :: W3m -> FilePath -> IO ()-drawImage w3m@(W3m w3mPath) path = do-    exists <- Directory.doesFileExist path-    unless exists $ fail $-        "Patat.Images.W3m.drawImage: file does not exist: " ++ path--    tsize <- getTerminalSize w3m-    isize <- getImageSize w3m path-    let (x, y, w, h) = fit tsize isize-        command =-            "0;1;" ++-            show x ++ ";" ++ show y ++ ";" ++ show w ++ ";" ++ show h ++-            ";;;;;" ++ path ++ "\n4;\n3;\n"--    _ <- Process.readProcess w3mPath [] command-    return ()-  where-    fit :: (Int, Int) -> (Int, Int) -> (Int, Int, Int, Int)-    fit (tw, th) (iw0, ih0) =-        -- Scale down to width-        let iw1 = if iw0 > tw then tw else iw0-            ih1 = if iw0 > tw then ((ih0 * tw) `div` iw0) else ih0--        -- Scale down to height-            iw2 = if ih1 > th then ((iw1 * th) `div` ih1) else iw1-            ih2 = if ih1 > th then th else ih1--        -- Find position-            x = (tw - iw2) `div` 2-            y = (th - ih2) `div` 2 in--         (x, y, iw2, ih2)------------------------------------------------------------------------------------$(A.deriveFromJSON A.dropPrefixOptions ''Config)

@@ -1,20 +0,0 @@-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

@@ -1,377 +0,0 @@----------------------------------------------------------------------------------{-# 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 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 ()-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------------------------------------------------------------------------------------displayImage :: Images.Handle -> FilePath -> IO ()-displayImage images path = do-    Ansi.clearScreen-    Ansi.setCursorPosition 0 0-    putStrLn ""-    IO.hFlush IO.stdout-    Images.drawImage images path------------------------------------------------------------------------------------displayPresentation :: Maybe Images.Handle -> Presentation -> IO ()-displayPresentation mbImages pres@Presentation {..} =-     case getActiveFragment pres of-        Nothing                       -> displayWithBorders pres mempty-        Just (ActiveContent fragment)-                | Just images <- mbImages-                , Just image <- onlyImage fragment ->-            displayImage images image-        Just (ActiveContent fragment) ->-            displayWithBorders pres $ \_canvasSize theme ->-            prettyFragment theme fragment-        Just (ActiveTitle   block)    ->-            displayWithBorders pres $ \canvasSize theme ->-            let pblock          = prettyBlock theme block-                (prows, pcols)  = PP.dimensions pblock-                (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 ()-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

@@ -1,83 +0,0 @@------------------------------------------------------------------------------------ | 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) ' ') <> " "

@@ -1,107 +0,0 @@----------------------------------------------------------------------------------{-# 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

@@ -1,134 +0,0 @@--- | 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

@@ -1,126 +0,0 @@------------------------------------------------------------------------------------ | 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           Patat.Presentation.Internal-import           Patat.Presentation.Read------------------------------------------------------------------------------------data PresentationCommand-    = Exit-    | Forward-    | Backward-    | SkipForward-    | SkipBackward-    | First-    | Last-    | Reload-    | UnknownCommand String------------------------------------------------------------------------------------readPresentationCommand :: IO PresentationCommand-readPresentationCommand = do-    k <- readKey-    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-        _        -> return (UnknownCommand k)-  where-    readKey :: IO String-    readKey = do-        c0 <- getChar-        case c0 of-            '\ESC' -> do-                c1 <- getChar-                case c1 of-                    '[' -> do-                        c2 <- getChar-                        return [c0, c1, c2]-                    _ -> return [c0, c1]-            _ -> return [c0]------------------------------------------------------------------------------------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)-    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-                }

@@ -1,266 +0,0 @@----------------------------------------------------------------------------------{-# 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)

@@ -1,205 +0,0 @@--- | 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

@@ -1,411 +0,0 @@------------------------------------------------------------------------------------ | 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

@@ -1,324 +0,0 @@----------------------------------------------------------------------------------{-# 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)

@@ -1,30 +0,0 @@----------------------------------------------------------------------------------{-# 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

@@ -0,0 +1,9 @@+module Main where++import qualified Patat.Presentation.Interactive.Tests+import qualified Test.Tasty                           as Tasty++main :: IO ()+main = Tasty.defaultMain $ Tasty.testGroup "patat"+    [ Patat.Presentation.Interactive.Tests.tests+    ]

@@ -0,0 +1,58 @@+module Patat.Presentation.Interactive.Tests+    ( tests+    ) where++import           Control.Monad                  (forM_, replicateM)+import           Patat.Presentation.Interactive+import           System.Directory               (getTemporaryDirectory,+                                                 removeFile)+import qualified System.IO                      as IO+import qualified Test.QuickCheck                as QC+import qualified Test.QuickCheck.Monadic        as QC+import qualified Test.Tasty                     as Tasty+import qualified Test.Tasty.QuickCheck                     as Tasty++tests :: Tasty.TestTree+tests = Tasty.testGroup "Patat.Presentation.Interactive.Tests"+    [ Tasty.testProperty "testReadPresentationCommands" $+        QC.monadicIO . QC.run . testReadPresentationCommands+    ]++-- | A raw input string followed by the expected command.+data ArbitraryCommand = ArbitraryCommand String PresentationCommand+    deriving (Show)++instance QC.Arbitrary ArbitraryCommand where+    arbitrary = QC.oneof $+        [ return $ ArbitraryCommand "q"      Exit+        , return $ ArbitraryCommand "\n"     Forward+        , return $ ArbitraryCommand "\DEL"   Backward+        , return $ ArbitraryCommand "h"      Backward+        , return $ ArbitraryCommand "j"      SkipForward+        , return $ ArbitraryCommand "k"      SkipBackward+        , return $ ArbitraryCommand "l"      Forward+        , return $ ArbitraryCommand "\ESC[C" Forward+        , return $ ArbitraryCommand "\ESC[D" Backward+        , return $ ArbitraryCommand "\ESC[B" SkipForward+        , return $ ArbitraryCommand "\ESC[A" SkipBackward+        , return $ ArbitraryCommand "\ESC[6" Forward+        , return $ ArbitraryCommand "\ESC[5" Backward+        , return $ ArbitraryCommand "0"      First+        , return $ ArbitraryCommand "G"      Last+        , return $ ArbitraryCommand "r"      Reload+        , do+            n <- QC.choose (1, 1000)+            return $ ArbitraryCommand (show n <> "\n") (Seek n)+        ]++testReadPresentationCommands :: [ArbitraryCommand] -> IO Bool+testReadPresentationCommands commands = do+    tmpdir        <- getTemporaryDirectory+    (tmppath, h)  <- IO.openBinaryTempFile tmpdir "patat.input"+    IO.hSetBuffering h IO.NoBuffering+    forM_ commands $ \(ArbitraryCommand s _) -> IO.hPutStr h s+    IO.hSeek h IO.AbsoluteSeek 0+    parsed <- replicateM (length commands) (readPresentationCommand h)+    IO.hClose h+    removeFile tmppath+    return $ [expect | ArbitraryCommand _ expect <- commands] == parsed