Add a Haskell test suite

.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 }}'

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

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]

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

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

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

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
+    ]

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