summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJasperVanDerJeugt <>2019-10-09 15:10:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2019-10-09 15:10:00 (GMT)
commit843663f9e31b1dac40b3090f848715b2fd334587 (patch)
tree61f6553efd128a85282c70d179fb005ef3d52eb4
parentc78dda812788f59bdff0a50281abee00039bc333 (diff)
version 0.8.4.0HEAD0.8.4.0master
-rw-r--r--CHANGELOG.md5
-rw-r--r--README.md1
-rw-r--r--lib/Data/Aeson/Extended.hs (renamed from src/Data/Aeson/Extended.hs)0
-rw-r--r--lib/Data/Aeson/TH/Extended.hs (renamed from src/Data/Aeson/TH/Extended.hs)0
-rw-r--r--lib/Data/Data/Extended.hs (renamed from src/Data/Data/Extended.hs)0
-rw-r--r--lib/Patat/AutoAdvance.hs (renamed from src/Patat/AutoAdvance.hs)0
-rw-r--r--lib/Patat/Cleanup.hs10
-rw-r--r--lib/Patat/Images.hs (renamed from src/Patat/Images.hs)3
-rw-r--r--lib/Patat/Images/ITerm2.hs (renamed from src/Patat/Images/ITerm2.hs)4
-rw-r--r--lib/Patat/Images/Internal.hs (renamed from src/Patat/Images/Internal.hs)3
-rw-r--r--lib/Patat/Images/W3m.hs (renamed from src/Patat/Images/W3m.hs)12
-rw-r--r--lib/Patat/Main.hs219
-rw-r--r--lib/Patat/Presentation.hs (renamed from src/Patat/Presentation.hs)0
-rw-r--r--lib/Patat/Presentation/Display.hs (renamed from src/Patat/Presentation/Display.hs)11
-rw-r--r--lib/Patat/Presentation/Display/CodeBlock.hs (renamed from src/Patat/Presentation/Display/CodeBlock.hs)0
-rw-r--r--lib/Patat/Presentation/Display/Table.hs (renamed from src/Patat/Presentation/Display/Table.hs)0
-rw-r--r--lib/Patat/Presentation/Fragment.hs (renamed from src/Patat/Presentation/Fragment.hs)0
-rw-r--r--lib/Patat/Presentation/Interactive.hs (renamed from src/Patat/Presentation/Interactive.hs)66
-rw-r--r--lib/Patat/Presentation/Internal.hs (renamed from src/Patat/Presentation/Internal.hs)0
-rw-r--r--lib/Patat/Presentation/Read.hs (renamed from src/Patat/Presentation/Read.hs)0
-rw-r--r--lib/Patat/PrettyPrint.hs (renamed from src/Patat/PrettyPrint.hs)0
-rw-r--r--lib/Patat/Theme.hs (renamed from src/Patat/Theme.hs)0
-rw-r--r--lib/Text/Pandoc/Extended.hs (renamed from src/Text/Pandoc/Extended.hs)0
-rw-r--r--patat.cabal47
-rw-r--r--src/Main.hs193
-rw-r--r--tests/haskell/Main.hs9
-rw-r--r--tests/haskell/Patat/Presentation/Interactive/Tests.hs58
27 files changed, 406 insertions, 235 deletions
diff --git a/CHANGELOG.md b/CHANGELOG.md
index 8a5eb9a..8fd3057 100644
--- 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
index 2162870..ceb7656 100644
--- a/README.md
+++ b/README.md
@@ -128,6 +128,7 @@ Controls
- **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/src/Data/Aeson/Extended.hs b/lib/Data/Aeson/Extended.hs
index 9b95cec..9b95cec 100644
--- a/src/Data/Aeson/Extended.hs
+++ b/lib/Data/Aeson/Extended.hs
diff --git a/src/Data/Aeson/TH/Extended.hs b/lib/Data/Aeson/TH/Extended.hs
index 0fa5487..0fa5487 100644
--- a/src/Data/Aeson/TH/Extended.hs
+++ b/lib/Data/Aeson/TH/Extended.hs
diff --git a/src/Data/Data/Extended.hs b/lib/Data/Data/Extended.hs
index 636591e..636591e 100644
--- a/src/Data/Data/Extended.hs
+++ b/lib/Data/Data/Extended.hs
diff --git a/src/Patat/AutoAdvance.hs b/lib/Patat/AutoAdvance.hs
index 236e0cb..236e0cb 100644
--- a/src/Patat/AutoAdvance.hs
+++ b/lib/Patat/AutoAdvance.hs
diff --git a/lib/Patat/Cleanup.hs b/lib/Patat/Cleanup.hs
new file mode 100644
index 0000000..2519681
--- /dev/null
+++ b/lib/Patat/Cleanup.hs
@@ -0,0 +1,10 @@
+--------------------------------------------------------------------------------
+-- | Defines a cleanup action that needs to be run after we're done with a slide
+-- or image.
+module Patat.Cleanup
+ ( Cleanup
+ ) where
+
+
+--------------------------------------------------------------------------------
+type Cleanup = IO ()
diff --git a/src/Patat/Images.hs b/lib/Patat/Images.hs
index 0d048d0..3ea7e0f 100644
--- a/src/Patat/Images.hs
+++ b/lib/Patat/Images.hs
@@ -12,6 +12,7 @@ module Patat.Images
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
@@ -56,5 +57,5 @@ backends =
--------------------------------------------------------------------------------
-drawImage :: Handle -> FilePath -> IO ()
+drawImage :: Handle -> FilePath -> IO Cleanup
drawImage = hDrawImage
diff --git a/src/Patat/Images/ITerm2.hs b/lib/Patat/Images/ITerm2.hs
index 2584aed..a6e7ad4 100644
--- a/src/Patat/Images/ITerm2.hs
+++ b/lib/Patat/Images/ITerm2.hs
@@ -12,6 +12,7 @@ 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)
@@ -38,12 +39,13 @@ new config = do
--------------------------------------------------------------------------------
-drawImage :: FilePath -> IO ()
+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
--------------------------------------------------------------------------------
diff --git a/src/Patat/Images/Internal.hs b/lib/Patat/Images/Internal.hs
index 939f962..246fb44 100644
--- a/src/Patat/Images/Internal.hs
+++ b/lib/Patat/Images/Internal.hs
@@ -14,6 +14,7 @@ import Control.Exception (Exception)
import qualified Data.Aeson as A
import Data.Data (Data)
import Data.Typeable (Typeable)
+import Patat.Cleanup
--------------------------------------------------------------------------------
@@ -35,5 +36,5 @@ instance Exception BackendNotSupported
--------------------------------------------------------------------------------
data Handle = Handle
- { hDrawImage :: FilePath -> IO ()
+ { hDrawImage :: FilePath -> IO Cleanup
}
diff --git a/src/Patat/Images/W3m.hs b/lib/Patat/Images/W3m.hs
index d2ae171..60795a4 100644
--- a/src/Patat/Images/W3m.hs
+++ b/lib/Patat/Images/W3m.hs
@@ -7,8 +7,10 @@ module Patat.Images.W3m
--------------------------------------------------------------------------------
import Control.Exception (throwIO)
-import Control.Monad (unless)
+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
@@ -107,7 +109,7 @@ getImageSize (W3m w3mPath) path = do
--------------------------------------------------------------------------------
-drawImage :: W3m -> FilePath -> IO ()
+drawImage :: W3m -> FilePath -> IO Cleanup
drawImage w3m@(W3m w3mPath) path = do
exists <- Directory.doesFileExist path
unless exists $ fail $
@@ -121,8 +123,12 @@ drawImage w3m@(W3m w3mPath) path = do
show x ++ ";" ++ show y ++ ";" ++ show w ++ ";" ++ show h ++
";;;;;" ++ path ++ "\n4;\n3;\n"
+ -- Draw image.
_ <- Process.readProcess w3mPath [] command
- return ()
+
+ -- 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) =
diff --git a/lib/Patat/Main.hs b/lib/Patat/Main.hs
new file mode 100644
index 0000000..e844ce5
--- /dev/null
+++ b/lib/Patat/Main.hs
@@ -0,0 +1,219 @@
+--------------------------------------------------------------------------------
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+module Patat.Main
+ ( main
+ ) where
+
+
+--------------------------------------------------------------------------------
+import Control.Applicative ((<$>), (<*>))
+import Control.Concurrent (forkIO, killThread, threadDelay)
+import Control.Concurrent.Chan (Chan)
+import qualified Control.Concurrent.Chan as Chan
+import Control.Exception (bracket)
+import Control.Monad (forever, unless, when)
+import qualified Data.Aeson.Extended as A
+import Data.Monoid (mempty, (<>))
+import Data.Time (UTCTime)
+import Data.Version (showVersion)
+import qualified Options.Applicative as OA
+import Patat.AutoAdvance
+import qualified Patat.Images as Images
+import Patat.Presentation
+import qualified Paths_patat
+import Prelude
+import qualified System.Console.ANSI as Ansi
+import System.Directory (doesFileExist,
+ getModificationTime)
+import System.Exit (exitFailure, exitSuccess)
+import qualified System.IO as IO
+import qualified Text.Pandoc as Pandoc
+import qualified Text.PrettyPrint.ANSI.Leijen as PP
+
+
+--------------------------------------------------------------------------------
+data Options = Options
+ { oFilePath :: !(Maybe FilePath)
+ , oForce :: !Bool
+ , oDump :: !Bool
+ , oWatch :: !Bool
+ , oVersion :: !Bool
+ } deriving (Show)
+
+
+--------------------------------------------------------------------------------
+parseOptions :: OA.Parser Options
+parseOptions = Options
+ <$> (OA.optional $ OA.strArgument $
+ OA.metavar "FILENAME" <>
+ OA.help "Input file")
+ <*> (OA.switch $
+ OA.long "force" <>
+ OA.short 'f' <>
+ OA.help "Force ANSI terminal" <>
+ OA.hidden)
+ <*> (OA.switch $
+ OA.long "dump" <>
+ OA.short 'd' <>
+ OA.help "Just dump all slides and exit" <>
+ OA.hidden)
+ <*> (OA.switch $
+ OA.long "watch" <>
+ OA.short 'w' <>
+ OA.help "Watch file for changes")
+ <*> (OA.switch $
+ OA.long "version" <>
+ OA.help "Display version info and exit" <>
+ OA.hidden)
+
+
+--------------------------------------------------------------------------------
+parserInfo :: OA.ParserInfo Options
+parserInfo = OA.info (OA.helper <*> parseOptions) $
+ OA.fullDesc <>
+ OA.header ("patat v" <> showVersion Paths_patat.version) <>
+ OA.progDescDoc (Just desc)
+ where
+ desc = PP.vcat
+ [ "Terminal-based presentations using Pandoc"
+ , ""
+ , "Controls:"
+ , "- Next slide: space, enter, l, right, pagedown"
+ , "- Previous slide: backspace, h, left, pageup"
+ , "- Go forward 10 slides: j, down"
+ , "- Go backward 10 slides: k, up"
+ , "- First slide: 0"
+ , "- Last slide: G"
+ , "- Reload file: r"
+ , "- Quit: q"
+ ]
+
+
+--------------------------------------------------------------------------------
+parserPrefs :: OA.ParserPrefs
+parserPrefs = OA.prefs OA.showHelpOnError
+
+
+--------------------------------------------------------------------------------
+errorAndExit :: [String] -> IO a
+errorAndExit msg = do
+ mapM_ (IO.hPutStrLn IO.stderr) msg
+ exitFailure
+
+
+--------------------------------------------------------------------------------
+assertAnsiFeatures :: IO ()
+assertAnsiFeatures = do
+ supports <- Ansi.hSupportsANSI IO.stdout
+ unless supports $ errorAndExit
+ [ "It looks like your terminal does not support ANSI codes."
+ , "If you still want to run the presentation, use `--force`."
+ ]
+
+
+--------------------------------------------------------------------------------
+main :: IO ()
+main = do
+ options <- OA.customExecParser parserPrefs parserInfo
+
+ when (oVersion options) $ do
+ putStrLn (showVersion Paths_patat.version)
+ putStrLn $ "Using pandoc: " ++ Pandoc.pandocVersion
+ exitSuccess
+
+ filePath <- case oFilePath options of
+ Just fp -> return fp
+ Nothing -> OA.handleParseResult $ OA.Failure $
+ OA.parserFailure parserPrefs parserInfo OA.ShowHelpText mempty
+
+ errOrPres <- readPresentation filePath
+ pres <- either (errorAndExit . return) return errOrPres
+
+ unless (oForce options) assertAnsiFeatures
+
+ -- (Maybe) initialize images backend.
+ images <- traverse Images.new (psImages $ pSettings pres)
+
+ if oDump options
+ then dumpPresentation pres
+ else interactiveLoop options images pres
+ where
+ interactiveLoop :: Options -> Maybe Images.Handle -> Presentation -> IO ()
+ interactiveLoop options images pres0 =
+ interactively readPresentationCommand $ \commandChan0 -> do
+
+ -- If an auto delay is set, use 'autoAdvance' to create a new one.
+ commandChan <- case psAutoAdvanceDelay (pSettings pres0) of
+ Nothing -> return commandChan0
+ Just (A.FlexibleNum delay) -> autoAdvance delay commandChan0
+
+ -- Spawn a thread that adds 'Reload' commands based on the file time.
+ mtime0 <- getModificationTime (pFilePath pres0)
+ when (oWatch options) $ do
+ _ <- forkIO $ watcher commandChan (pFilePath pres0) mtime0
+ return ()
+
+ let loop :: Presentation -> Maybe String -> IO ()
+ loop pres mbError = do
+ cleanup <- case mbError of
+ Nothing -> displayPresentation images pres
+ Just err -> displayPresentationError pres err
+
+ c <- Chan.readChan commandChan
+ update <- updatePresentation c pres
+ cleanup
+ case update of
+ ExitedPresentation -> return ()
+ UpdatedPresentation pres' -> loop pres' Nothing
+ ErroredPresentation err -> loop pres (Just err)
+
+ loop pres0 Nothing
+
+
+--------------------------------------------------------------------------------
+-- | Utility for dealing with pecularities of stdin & interactive applications
+-- on the terminal. Tries to restore the original state of the terminal as much
+-- as possible.
+interactively
+ -- | Reads a command from stdin (or from some other IO). This will be
+ -- interrupted by 'killThread' when the application finishes.
+ :: (IO.Handle -> IO a)
+ -- | Application to run.
+ -> (Chan a -> IO ())
+ -- | Returns when application finishes.
+ -> IO ()
+interactively reader app = bracket setup teardown $ \(_, _, _, chan) -> app chan
+ where
+ setup = do
+ chan <- Chan.newChan
+ echo <- IO.hGetEcho IO.stdin
+ buff <- IO.hGetBuffering IO.stdin
+ IO.hSetEcho IO.stdin False
+ IO.hSetBuffering IO.stdin IO.NoBuffering
+ Ansi.hideCursor
+ readerThreadId <- forkIO $ forever $
+ reader IO.stdin >>= Chan.writeChan chan
+ return (echo, buff, readerThreadId, chan)
+
+ teardown (echo, buff, readerThreadId, _chan) = do
+ Ansi.showCursor
+ Ansi.clearScreen
+ Ansi.setCursorPosition 0 0
+ killThread readerThreadId
+ IO.hSetEcho IO.stdin echo
+ IO.hSetBuffering IO.stdin buff
+
+
+--------------------------------------------------------------------------------
+watcher :: Chan.Chan PresentationCommand -> FilePath -> UTCTime -> IO a
+watcher chan filePath mtime0 = do
+ -- The extra exists check helps because some editors temporarily make the
+ -- file disappear while writing.
+ exists <- doesFileExist filePath
+ mtime1 <- if exists then getModificationTime filePath else return mtime0
+
+ when (mtime1 > mtime0) $ Chan.writeChan chan Reload
+ threadDelay (200 * 1000)
+ watcher chan filePath mtime1
diff --git a/src/Patat/Presentation.hs b/lib/Patat/Presentation.hs
index 8da5a30..8da5a30 100644
--- a/src/Patat/Presentation.hs
+++ b/lib/Patat/Presentation.hs
diff --git a/src/Patat/Presentation/Display.hs b/lib/Patat/Presentation/Display.hs
index 4e42c70..876311d 100644
--- a/src/Patat/Presentation/Display.hs
+++ b/lib/Patat/Presentation/Display.hs
@@ -19,6 +19,7 @@ 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
@@ -42,7 +43,7 @@ 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 ()
+ :: Presentation -> (CanvasSize -> Theme -> PP.Doc) -> IO Cleanup
displayWithBorders Presentation {..} f = do
Ansi.clearScreen
Ansi.setCursorPosition 0 0
@@ -85,9 +86,11 @@ displayWithBorders Presentation {..} f = do
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 ()
+displayImage :: Images.Handle -> FilePath -> IO Cleanup
displayImage images path = do
Ansi.clearScreen
Ansi.setCursorPosition 0 0
@@ -97,7 +100,7 @@ displayImage images path = do
--------------------------------------------------------------------------------
-displayPresentation :: Maybe Images.Handle -> Presentation -> IO ()
+displayPresentation :: Maybe Images.Handle -> Presentation -> IO Cleanup
displayPresentation mbImages pres@Presentation {..} =
case getActiveFragment pres of
Nothing -> displayWithBorders pres mempty
@@ -136,7 +139,7 @@ displayPresentation mbImages pres@Presentation {..} =
--------------------------------------------------------------------------------
-- | 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 :: Presentation -> String -> IO Cleanup
displayPresentationError pres err = displayWithBorders pres $ \_ Theme {..} ->
themed themeStrong "Error occurred in the presentation:" <$$>
"" <$$>
diff --git a/src/Patat/Presentation/Display/CodeBlock.hs b/lib/Patat/Presentation/Display/CodeBlock.hs
index 149bc68..149bc68 100644
--- a/src/Patat/Presentation/Display/CodeBlock.hs
+++ b/lib/Patat/Presentation/Display/CodeBlock.hs
diff --git a/src/Patat/Presentation/Display/Table.hs b/lib/Patat/Presentation/Display/Table.hs
index fee68c9..fee68c9 100644
--- a/src/Patat/Presentation/Display/Table.hs
+++ b/lib/Patat/Presentation/Display/Table.hs
diff --git a/src/Patat/Presentation/Fragment.hs b/lib/Patat/Presentation/Fragment.hs
index 0908381..0908381 100644
--- a/src/Patat/Presentation/Fragment.hs
+++ b/lib/Patat/Presentation/Fragment.hs
diff --git a/src/Patat/Presentation/Interactive.hs b/lib/Patat/Presentation/Interactive.hs
index d3977e3..6707e09 100644
--- a/src/Patat/Presentation/Interactive.hs
+++ b/lib/Patat/Presentation/Interactive.hs
@@ -13,8 +13,11 @@ module Patat.Presentation.Interactive
--------------------------------------------------------------------------------
+import Data.Char (isDigit)
import Patat.Presentation.Internal
import Patat.Presentation.Read
+import qualified System.IO as IO
+import Text.Read (readMaybe)
--------------------------------------------------------------------------------
@@ -27,47 +30,59 @@ data PresentationCommand
| First
| Last
| Reload
+ | Seek Int
| UnknownCommand String
+ deriving (Eq, Show)
--------------------------------------------------------------------------------
-readPresentationCommand :: IO PresentationCommand
-readPresentationCommand = do
- k <- readKey
+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
+ "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
+ "\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)
+ "\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
- readKey :: IO String
- readKey = do
- c0 <- getChar
+ readKeys :: IO String
+ readKeys = do
+ c0 <- IO.hGetChar h
case c0 of
'\ESC' -> do
- c1 <- getChar
+ c1 <- IO.hGetChar h
case c1 of
'[' -> do
- c2 <- getChar
+ 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
@@ -89,6 +104,7 @@ updatePresentation cmd presentation = case cmd of
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
diff --git a/src/Patat/Presentation/Internal.hs b/lib/Patat/Presentation/Internal.hs
index db8d16b..db8d16b 100644
--- a/src/Patat/Presentation/Internal.hs
+++ b/lib/Patat/Presentation/Internal.hs
diff --git a/src/Patat/Presentation/Read.hs b/lib/Patat/Presentation/Read.hs
index 581c31d..581c31d 100644
--- a/src/Patat/Presentation/Read.hs
+++ b/lib/Patat/Presentation/Read.hs
diff --git a/src/Patat/PrettyPrint.hs b/lib/Patat/PrettyPrint.hs
index bffa274..bffa274 100644
--- a/src/Patat/PrettyPrint.hs
+++ b/lib/Patat/PrettyPrint.hs
diff --git a/src/Patat/Theme.hs b/lib/Patat/Theme.hs
index 952a521..952a521 100644
--- a/src/Patat/Theme.hs
+++ b/lib/Patat/Theme.hs
diff --git a/src/Text/Pandoc/Extended.hs b/lib/Text/Pandoc/Extended.hs
index 941d716..941d716 100644
--- a/src/Text/Pandoc/Extended.hs
+++ b/lib/Text/Pandoc/Extended.hs
diff --git a/patat.cabal b/patat.cabal
index 2f70a36..4bffa75 100644
--- 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 @@ Flag patat-make-man
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 @@ Executable patat
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 @@ Executable patat
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 @@ Executable patat-make-man
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/Main.hs b/src/Main.hs
index b7dfa27..b7736dd 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -1,193 +1,4 @@
---------------------------------------------------------------------------------
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards #-}
-module Main where
+import qualified Patat.Main
-
---------------------------------------------------------------------------------
-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`."
- ]
-
-
---------------------------------------------------------------------------------
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/tests/haskell/Main.hs b/tests/haskell/Main.hs
new file mode 100644
index 0000000..82e9f2b
--- /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
index 0000000..d3c958c
--- /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