From a407b065b8b0cfbbc1b0516cc98dfa6da06563c5 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Mon, 7 Oct 2019 13:26:22 +0200 Subject: [PATCH] Add a Haskell test suite --- .circleci/config.yml | 4 +- {src => lib}/Data/Aeson/Extended.hs | 0 {src => lib}/Data/Aeson/TH/Extended.hs | 0 {src => lib}/Data/Data/Extended.hs | 0 {src => lib}/Patat/AutoAdvance.hs | 0 {src => lib}/Patat/Cleanup.hs | 0 {src => lib}/Patat/Images.hs | 0 {src => lib}/Patat/Images/ITerm2.hs | 0 {src => lib}/Patat/Images/Internal.hs | 0 {src => lib}/Patat/Images/W3m.hs | 0 lib/Patat/Main.hs | 196 ++++++++++++++++++ {src => lib}/Patat/Presentation.hs | 0 {src => lib}/Patat/Presentation/Display.hs | 0 .../Patat/Presentation/Display/CodeBlock.hs | 0 .../Patat/Presentation/Display/Table.hs | 0 {src => lib}/Patat/Presentation/Fragment.hs | 0 .../Patat/Presentation/Interactive.hs | 12 +- {src => lib}/Patat/Presentation/Internal.hs | 0 {src => lib}/Patat/Presentation/Read.hs | 0 {src => lib}/Patat/PrettyPrint.hs | 0 {src => lib}/Patat/Theme.hs | 0 {src => lib}/Text/Pandoc/Extended.hs | 0 patat.cabal | 44 +++- src/Main.hs | 194 +---------------- test.sh | 2 +- tests/{ => golden}/01.md | 0 tests/{ => golden}/01.md.dump | 0 tests/{ => golden}/02.lhs | 0 tests/{ => golden}/02.lhs.dump | 0 tests/{ => golden}/03.md | 0 tests/{ => golden}/03.md.dump | 0 tests/{ => golden}/bolditalic.md | 0 tests/{ => golden}/bolditalic.md.dump | 0 tests/{ => golden}/comments.lhs | 0 tests/{ => golden}/comments.lhs.dump | 0 tests/{ => golden}/comments.md | 0 tests/{ => golden}/comments.md.dump | 0 tests/{ => golden}/deflist.md | 0 tests/{ => golden}/deflist.md.dump | 0 tests/{ => golden}/extentions0.md | 0 tests/{ => golden}/extentions0.md.dump | 0 tests/{ => golden}/extentions1.md | 0 tests/{ => golden}/extentions1.md.dump | 0 tests/{ => golden}/fragments.md | 0 tests/{ => golden}/fragments.md.dump | 0 tests/{ => golden}/headers.md | 0 tests/{ => golden}/headers.md.dump | 0 tests/{ => golden}/links.md | 0 tests/{ => golden}/links.md.dump | 0 tests/{ => golden}/lists.md | 0 tests/{ => golden}/lists.md.dump | 0 tests/{ => golden}/margins.md | 0 tests/{ => golden}/margins.md.dump | 0 tests/{ => golden}/meta.md | 0 tests/{ => golden}/meta.md.dump | 0 tests/{ => golden}/slidelevel0.md | 0 tests/{ => golden}/slidelevel0.md.dump | 0 tests/{ => golden}/slidelevel1.md | 0 tests/{ => golden}/slidelevel1.md.dump | 0 tests/{ => golden}/slidelevel2.md | 0 tests/{ => golden}/slidelevel2.md.dump | 0 tests/{ => golden}/syntax.md | 0 tests/{ => golden}/syntax.md.dump | 0 tests/{ => golden}/tables.md | 0 tests/{ => golden}/tables.md.dump | 0 tests/{ => golden}/themes.md | 0 tests/{ => golden}/themes.md.dump | 0 tests/{ => golden}/wrapping.md | 0 tests/{ => golden}/wrapping.md.dump | 0 tests/haskell/Main.hs | 9 + .../Patat/Presentation/Interactive/Tests.hs | 55 +++++ 71 files changed, 308 insertions(+), 208 deletions(-) rename {src => lib}/Data/Aeson/Extended.hs (100%) rename {src => lib}/Data/Aeson/TH/Extended.hs (100%) rename {src => lib}/Data/Data/Extended.hs (100%) rename {src => lib}/Patat/AutoAdvance.hs (100%) rename {src => lib}/Patat/Cleanup.hs (100%) rename {src => lib}/Patat/Images.hs (100%) rename {src => lib}/Patat/Images/ITerm2.hs (100%) rename {src => lib}/Patat/Images/Internal.hs (100%) rename {src => lib}/Patat/Images/W3m.hs (100%) create mode 100644 lib/Patat/Main.hs rename {src => lib}/Patat/Presentation.hs (100%) rename {src => lib}/Patat/Presentation/Display.hs (100%) rename {src => lib}/Patat/Presentation/Display/CodeBlock.hs (100%) rename {src => lib}/Patat/Presentation/Display/Table.hs (100%) rename {src => lib}/Patat/Presentation/Fragment.hs (100%) rename {src => lib}/Patat/Presentation/Interactive.hs (93%) rename {src => lib}/Patat/Presentation/Internal.hs (100%) rename {src => lib}/Patat/Presentation/Read.hs (100%) rename {src => lib}/Patat/PrettyPrint.hs (100%) rename {src => lib}/Patat/Theme.hs (100%) rename {src => lib}/Text/Pandoc/Extended.hs (100%) rename tests/{ => golden}/01.md (100%) rename tests/{ => golden}/01.md.dump (100%) rename tests/{ => golden}/02.lhs (100%) rename tests/{ => golden}/02.lhs.dump (100%) rename tests/{ => golden}/03.md (100%) rename tests/{ => golden}/03.md.dump (100%) rename tests/{ => golden}/bolditalic.md (100%) rename tests/{ => golden}/bolditalic.md.dump (100%) rename tests/{ => golden}/comments.lhs (100%) rename tests/{ => golden}/comments.lhs.dump (100%) rename tests/{ => golden}/comments.md (100%) rename tests/{ => golden}/comments.md.dump (100%) rename tests/{ => golden}/deflist.md (100%) rename tests/{ => golden}/deflist.md.dump (100%) rename tests/{ => golden}/extentions0.md (100%) rename tests/{ => golden}/extentions0.md.dump (100%) rename tests/{ => golden}/extentions1.md (100%) rename tests/{ => golden}/extentions1.md.dump (100%) rename tests/{ => golden}/fragments.md (100%) rename tests/{ => golden}/fragments.md.dump (100%) rename tests/{ => golden}/headers.md (100%) rename tests/{ => golden}/headers.md.dump (100%) rename tests/{ => golden}/links.md (100%) rename tests/{ => golden}/links.md.dump (100%) rename tests/{ => golden}/lists.md (100%) rename tests/{ => golden}/lists.md.dump (100%) rename tests/{ => golden}/margins.md (100%) rename tests/{ => golden}/margins.md.dump (100%) rename tests/{ => golden}/meta.md (100%) rename tests/{ => golden}/meta.md.dump (100%) rename tests/{ => golden}/slidelevel0.md (100%) rename tests/{ => golden}/slidelevel0.md.dump (100%) rename tests/{ => golden}/slidelevel1.md (100%) rename tests/{ => golden}/slidelevel1.md.dump (100%) rename tests/{ => golden}/slidelevel2.md (100%) rename tests/{ => golden}/slidelevel2.md.dump (100%) rename tests/{ => golden}/syntax.md (100%) rename tests/{ => golden}/syntax.md.dump (100%) rename tests/{ => golden}/tables.md (100%) rename tests/{ => golden}/tables.md.dump (100%) rename tests/{ => golden}/themes.md (100%) rename tests/{ => golden}/themes.md.dump (100%) rename tests/{ => golden}/wrapping.md (100%) rename tests/{ => golden}/wrapping.md.dump (100%) create mode 100644 tests/haskell/Main.hs create mode 100644 tests/haskell/Patat/Presentation/Interactive/Tests.hs diff --git a/.circleci/config.yml b/.circleci/config.yml index 4d7780d..bc2e92b 100644 --- a/.circleci/config.yml +++ b/.circleci/config.yml @@ -23,9 +23,9 @@ jobs: # We set jobs to 1 here because that prevents Out-Of-Memory exceptions # while compiling dependencies. name: 'Install' - command: '.circleci/tickle.sh stack build --pedantic --copy-bins --jobs=1 --no-terminal' + command: '.circleci/tickle.sh stack build --pedantic --copy-bins --jobs=1 --no-terminal --test' - run: - name: 'Run tests' + name: 'Run golden tests' command: 'make test' - save_cache: key: 'v4-patat-{{ arch }}-{{ .Branch }}-{{ .Revision }}' diff --git a/src/Data/Aeson/Extended.hs b/lib/Data/Aeson/Extended.hs similarity index 100% rename from src/Data/Aeson/Extended.hs rename to lib/Data/Aeson/Extended.hs diff --git a/src/Data/Aeson/TH/Extended.hs b/lib/Data/Aeson/TH/Extended.hs similarity index 100% rename from src/Data/Aeson/TH/Extended.hs rename to lib/Data/Aeson/TH/Extended.hs diff --git a/src/Data/Data/Extended.hs b/lib/Data/Data/Extended.hs similarity index 100% rename from src/Data/Data/Extended.hs rename to lib/Data/Data/Extended.hs diff --git a/src/Patat/AutoAdvance.hs b/lib/Patat/AutoAdvance.hs similarity index 100% rename from src/Patat/AutoAdvance.hs rename to lib/Patat/AutoAdvance.hs diff --git a/src/Patat/Cleanup.hs b/lib/Patat/Cleanup.hs similarity index 100% rename from src/Patat/Cleanup.hs rename to lib/Patat/Cleanup.hs diff --git a/src/Patat/Images.hs b/lib/Patat/Images.hs similarity index 100% rename from src/Patat/Images.hs rename to lib/Patat/Images.hs diff --git a/src/Patat/Images/ITerm2.hs b/lib/Patat/Images/ITerm2.hs similarity index 100% rename from src/Patat/Images/ITerm2.hs rename to lib/Patat/Images/ITerm2.hs diff --git a/src/Patat/Images/Internal.hs b/lib/Patat/Images/Internal.hs similarity index 100% rename from src/Patat/Images/Internal.hs rename to lib/Patat/Images/Internal.hs diff --git a/src/Patat/Images/W3m.hs b/lib/Patat/Images/W3m.hs similarity index 100% rename from src/Patat/Images/W3m.hs rename to lib/Patat/Images/W3m.hs diff --git a/lib/Patat/Main.hs b/lib/Patat/Main.hs new file mode 100644 index 0000000..a9abc86 --- /dev/null +++ b/lib/Patat/Main.hs @@ -0,0 +1,196 @@ +-------------------------------------------------------------------------------- +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +module Patat.Main + ( 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`." + ] + + +-------------------------------------------------------------------------------- +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` cleanall) $ 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 IO.stdin >>= 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 + 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 + + cleanall :: IO () + cleanall = 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 diff --git a/src/Patat/Presentation.hs b/lib/Patat/Presentation.hs similarity index 100% rename from src/Patat/Presentation.hs rename to lib/Patat/Presentation.hs diff --git a/src/Patat/Presentation/Display.hs b/lib/Patat/Presentation/Display.hs similarity index 100% rename from src/Patat/Presentation/Display.hs rename to lib/Patat/Presentation/Display.hs diff --git a/src/Patat/Presentation/Display/CodeBlock.hs b/lib/Patat/Presentation/Display/CodeBlock.hs similarity index 100% rename from src/Patat/Presentation/Display/CodeBlock.hs rename to lib/Patat/Presentation/Display/CodeBlock.hs diff --git a/src/Patat/Presentation/Display/Table.hs b/lib/Patat/Presentation/Display/Table.hs similarity index 100% rename from src/Patat/Presentation/Display/Table.hs rename to lib/Patat/Presentation/Display/Table.hs diff --git a/src/Patat/Presentation/Fragment.hs b/lib/Patat/Presentation/Fragment.hs similarity index 100% rename from src/Patat/Presentation/Fragment.hs rename to lib/Patat/Presentation/Fragment.hs diff --git a/src/Patat/Presentation/Interactive.hs b/lib/Patat/Presentation/Interactive.hs similarity index 93% rename from src/Patat/Presentation/Interactive.hs rename to lib/Patat/Presentation/Interactive.hs index d3977e3..9374433 100644 --- a/src/Patat/Presentation/Interactive.hs +++ b/lib/Patat/Presentation/Interactive.hs @@ -15,6 +15,7 @@ module Patat.Presentation.Interactive -------------------------------------------------------------------------------- import Patat.Presentation.Internal import Patat.Presentation.Read +import qualified System.IO as IO -------------------------------------------------------------------------------- @@ -28,11 +29,12 @@ data PresentationCommand | Last | Reload | UnknownCommand String + deriving (Eq, Show) -------------------------------------------------------------------------------- -readPresentationCommand :: IO PresentationCommand -readPresentationCommand = do +readPresentationCommand :: IO.Handle -> IO PresentationCommand +readPresentationCommand h = do k <- readKey case k of "q" -> return Exit @@ -57,13 +59,13 @@ readPresentationCommand = do where readKey :: IO String readKey = do - c0 <- getChar + 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] _ -> return [c0] diff --git a/src/Patat/Presentation/Internal.hs b/lib/Patat/Presentation/Internal.hs similarity index 100% rename from src/Patat/Presentation/Internal.hs rename to lib/Patat/Presentation/Internal.hs diff --git a/src/Patat/Presentation/Read.hs b/lib/Patat/Presentation/Read.hs similarity index 100% rename from src/Patat/Presentation/Read.hs rename to lib/Patat/Presentation/Read.hs diff --git a/src/Patat/PrettyPrint.hs b/lib/Patat/PrettyPrint.hs similarity index 100% rename from src/Patat/PrettyPrint.hs rename to lib/Patat/PrettyPrint.hs diff --git a/src/Patat/Theme.hs b/lib/Patat/Theme.hs similarity index 100% rename from src/Patat/Theme.hs rename to lib/Patat/Theme.hs diff --git a/src/Text/Pandoc/Extended.hs b/lib/Text/Pandoc/Extended.hs similarity index 100% rename from src/Text/Pandoc/Extended.hs rename to lib/Text/Pandoc/Extended.hs diff --git a/patat.cabal b/patat.cabal index dff5f26..8586af8 100644 --- a/patat.cabal +++ b/patat.cabal @@ -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,16 +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 @@ -81,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 @@ -101,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 bffd6e4..b7736dd 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,194 +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` cleanall) $ 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 - 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 - - cleanall :: IO () - cleanall = 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/test.sh b/test.sh index bbe7c5a..050c641 100755 --- a/test.sh +++ b/test.sh @@ -1,7 +1,7 @@ #!/bin/bash set -o nounset -o errexit -o pipefail -srcs=$(find tests -type f ! -name '*.dump') +srcs=$(find tests/golden -type f ! -name '*.dump') stuff_went_wrong=false for src in $srcs; do diff --git a/tests/01.md b/tests/golden/01.md similarity index 100% rename from tests/01.md rename to tests/golden/01.md diff --git a/tests/01.md.dump b/tests/golden/01.md.dump similarity index 100% rename from tests/01.md.dump rename to tests/golden/01.md.dump diff --git a/tests/02.lhs b/tests/golden/02.lhs similarity index 100% rename from tests/02.lhs rename to tests/golden/02.lhs diff --git a/tests/02.lhs.dump b/tests/golden/02.lhs.dump similarity index 100% rename from tests/02.lhs.dump rename to tests/golden/02.lhs.dump diff --git a/tests/03.md b/tests/golden/03.md similarity index 100% rename from tests/03.md rename to tests/golden/03.md diff --git a/tests/03.md.dump b/tests/golden/03.md.dump similarity index 100% rename from tests/03.md.dump rename to tests/golden/03.md.dump diff --git a/tests/bolditalic.md b/tests/golden/bolditalic.md similarity index 100% rename from tests/bolditalic.md rename to tests/golden/bolditalic.md diff --git a/tests/bolditalic.md.dump b/tests/golden/bolditalic.md.dump similarity index 100% rename from tests/bolditalic.md.dump rename to tests/golden/bolditalic.md.dump diff --git a/tests/comments.lhs b/tests/golden/comments.lhs similarity index 100% rename from tests/comments.lhs rename to tests/golden/comments.lhs diff --git a/tests/comments.lhs.dump b/tests/golden/comments.lhs.dump similarity index 100% rename from tests/comments.lhs.dump rename to tests/golden/comments.lhs.dump diff --git a/tests/comments.md b/tests/golden/comments.md similarity index 100% rename from tests/comments.md rename to tests/golden/comments.md diff --git a/tests/comments.md.dump b/tests/golden/comments.md.dump similarity index 100% rename from tests/comments.md.dump rename to tests/golden/comments.md.dump diff --git a/tests/deflist.md b/tests/golden/deflist.md similarity index 100% rename from tests/deflist.md rename to tests/golden/deflist.md diff --git a/tests/deflist.md.dump b/tests/golden/deflist.md.dump similarity index 100% rename from tests/deflist.md.dump rename to tests/golden/deflist.md.dump diff --git a/tests/extentions0.md b/tests/golden/extentions0.md similarity index 100% rename from tests/extentions0.md rename to tests/golden/extentions0.md diff --git a/tests/extentions0.md.dump b/tests/golden/extentions0.md.dump similarity index 100% rename from tests/extentions0.md.dump rename to tests/golden/extentions0.md.dump diff --git a/tests/extentions1.md b/tests/golden/extentions1.md similarity index 100% rename from tests/extentions1.md rename to tests/golden/extentions1.md diff --git a/tests/extentions1.md.dump b/tests/golden/extentions1.md.dump similarity index 100% rename from tests/extentions1.md.dump rename to tests/golden/extentions1.md.dump diff --git a/tests/fragments.md b/tests/golden/fragments.md similarity index 100% rename from tests/fragments.md rename to tests/golden/fragments.md diff --git a/tests/fragments.md.dump b/tests/golden/fragments.md.dump similarity index 100% rename from tests/fragments.md.dump rename to tests/golden/fragments.md.dump diff --git a/tests/headers.md b/tests/golden/headers.md similarity index 100% rename from tests/headers.md rename to tests/golden/headers.md diff --git a/tests/headers.md.dump b/tests/golden/headers.md.dump similarity index 100% rename from tests/headers.md.dump rename to tests/golden/headers.md.dump diff --git a/tests/links.md b/tests/golden/links.md similarity index 100% rename from tests/links.md rename to tests/golden/links.md diff --git a/tests/links.md.dump b/tests/golden/links.md.dump similarity index 100% rename from tests/links.md.dump rename to tests/golden/links.md.dump diff --git a/tests/lists.md b/tests/golden/lists.md similarity index 100% rename from tests/lists.md rename to tests/golden/lists.md diff --git a/tests/lists.md.dump b/tests/golden/lists.md.dump similarity index 100% rename from tests/lists.md.dump rename to tests/golden/lists.md.dump diff --git a/tests/margins.md b/tests/golden/margins.md similarity index 100% rename from tests/margins.md rename to tests/golden/margins.md diff --git a/tests/margins.md.dump b/tests/golden/margins.md.dump similarity index 100% rename from tests/margins.md.dump rename to tests/golden/margins.md.dump diff --git a/tests/meta.md b/tests/golden/meta.md similarity index 100% rename from tests/meta.md rename to tests/golden/meta.md diff --git a/tests/meta.md.dump b/tests/golden/meta.md.dump similarity index 100% rename from tests/meta.md.dump rename to tests/golden/meta.md.dump diff --git a/tests/slidelevel0.md b/tests/golden/slidelevel0.md similarity index 100% rename from tests/slidelevel0.md rename to tests/golden/slidelevel0.md diff --git a/tests/slidelevel0.md.dump b/tests/golden/slidelevel0.md.dump similarity index 100% rename from tests/slidelevel0.md.dump rename to tests/golden/slidelevel0.md.dump diff --git a/tests/slidelevel1.md b/tests/golden/slidelevel1.md similarity index 100% rename from tests/slidelevel1.md rename to tests/golden/slidelevel1.md diff --git a/tests/slidelevel1.md.dump b/tests/golden/slidelevel1.md.dump similarity index 100% rename from tests/slidelevel1.md.dump rename to tests/golden/slidelevel1.md.dump diff --git a/tests/slidelevel2.md b/tests/golden/slidelevel2.md similarity index 100% rename from tests/slidelevel2.md rename to tests/golden/slidelevel2.md diff --git a/tests/slidelevel2.md.dump b/tests/golden/slidelevel2.md.dump similarity index 100% rename from tests/slidelevel2.md.dump rename to tests/golden/slidelevel2.md.dump diff --git a/tests/syntax.md b/tests/golden/syntax.md similarity index 100% rename from tests/syntax.md rename to tests/golden/syntax.md diff --git a/tests/syntax.md.dump b/tests/golden/syntax.md.dump similarity index 100% rename from tests/syntax.md.dump rename to tests/golden/syntax.md.dump diff --git a/tests/tables.md b/tests/golden/tables.md similarity index 100% rename from tests/tables.md rename to tests/golden/tables.md diff --git a/tests/tables.md.dump b/tests/golden/tables.md.dump similarity index 100% rename from tests/tables.md.dump rename to tests/golden/tables.md.dump diff --git a/tests/themes.md b/tests/golden/themes.md similarity index 100% rename from tests/themes.md rename to tests/golden/themes.md diff --git a/tests/themes.md.dump b/tests/golden/themes.md.dump similarity index 100% rename from tests/themes.md.dump rename to tests/golden/themes.md.dump diff --git a/tests/wrapping.md b/tests/golden/wrapping.md similarity index 100% rename from tests/wrapping.md rename to tests/golden/wrapping.md diff --git a/tests/wrapping.md.dump b/tests/golden/wrapping.md.dump similarity index 100% rename from tests/wrapping.md.dump rename to tests/golden/wrapping.md.dump 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..2fa6d93 --- /dev/null +++ b/tests/haskell/Patat/Presentation/Interactive/Tests.hs @@ -0,0 +1,55 @@ +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.elements $ + [ ArbitraryCommand "q" Exit + , ArbitraryCommand "\n" Forward + , ArbitraryCommand "\DEL" Backward + , ArbitraryCommand "h" Backward + , ArbitraryCommand "j" SkipForward + , ArbitraryCommand "k" SkipBackward + , ArbitraryCommand "l" Forward + , ArbitraryCommand "\ESC[C" Forward + , ArbitraryCommand "\ESC[D" Backward + , ArbitraryCommand "\ESC[B" SkipForward + , ArbitraryCommand "\ESC[A" SkipBackward + , ArbitraryCommand "\ESC[6" Forward + , ArbitraryCommand "\ESC[5" Backward + , ArbitraryCommand "0" First + , ArbitraryCommand "G" Last + , ArbitraryCommand "r" Reload + ] + +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