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