test: refactor, document, organise easytests, port amountp tests (#812)

hledger-lib/Hledger.hs

@@ -1,14 +1,20 @@
+{-# LANGUAGE OverloadedStrings #-}
+
 module Hledger (
   module X
  ,tests_Hledger
+ ,Hledger.easytests
 )
 where
 import           Test.HUnit
+import           EasyTest
 
-import           Hledger.Data    as X
+import           Hledger.Data    as X hiding (easytests)
-import           Hledger.Query   as X
+import qualified Hledger.Data    (easytests)
-import           Hledger.Read    as X hiding (samplejournal)
+import           Hledger.Read    as X hiding (samplejournal, easytests)
+import qualified Hledger.Read    (easytests)
 import           Hledger.Reports as X
+import           Hledger.Query   as X
 import           Hledger.Utils   as X
 
 tests_Hledger = TestList
@@ -19,3 +25,8 @@ tests_Hledger = TestList
     ,tests_Hledger_Reports
     ,tests_Hledger_Utils
     ]
+
+easytests = scope "Hledger" $ tests [
+   Hledger.Data.easytests
+  ,Hledger.Read.easytests
+  ]

hledger-lib/Hledger/Data/Journal.hs

@@ -69,6 +69,7 @@ module Hledger.Data.Journal (
   -- * Tests
   samplejournal,
   tests_Hledger_Data_Journal,
+  easytests,
 )
 where
 import Control.Applicative (Const(..))
@@ -91,6 +92,7 @@ import Data.Ord
 import qualified Data.Semigroup as Sem
 import Data.Text (Text)
 import qualified Data.Text as T
+import EasyTest
 import Safe (headMay, headDef)
 import Data.Time.Calendar
 import Data.Tree
@@ -1085,3 +1087,24 @@ tests_Hledger_Data_Journal = TestList $
   --   journalBalanceSheetAccountNames j `is` ["assets","assets:a","equity","equity:q","equity:q:qq","liabilities","liabilities:l"]
   --   journalProfitAndLossAccountNames j `is` ["expenses","expenses:e","income","income:i"]
  ]
+
+easytests = scope "Journal" $ tests [
+  scope "standard account types" $ do
+    let
+      j = samplejournal
+      journalAccountNamesMatching :: Query -> Journal -> [AccountName]
+      journalAccountNamesMatching q = filter (q `matchesAccount`) . journalAccountNames
+      namesfrom qfunc = journalAccountNamesMatching (qfunc j) j
+    tests
+      [ scope "assets" $
+        expectEq (namesfrom journalAssetAccountQuery)     ["assets","assets:bank","assets:bank:checking","assets:bank:saving","assets:cash"]
+      , scope "liabilities" $
+        expectEq (namesfrom journalLiabilityAccountQuery) ["liabilities","liabilities:debts"]
+      , scope "equity" $
+        expectEq (namesfrom journalEquityAccountQuery)    []
+      , scope "income" $
+        expectEq (namesfrom journalIncomeAccountQuery)    ["income","income:gifts","income:salary"]
+      , scope "expenses" $
+        expectEq (namesfrom journalExpenseAccountQuery)   ["expenses","expenses:food","expenses:supplies"]
+      ]
+  ]

hledger-lib/Hledger/Read.hs

@@ -31,6 +31,7 @@ module Hledger.Read (
   -- * Tests
   samplejournal,
   tests_Hledger_Read,
+  easytests,
 
 ) where
 
@@ -44,6 +45,7 @@ import Data.Ord
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Time (Day)
+import EasyTest
 import Safe
 import System.Directory (doesFileExist, getHomeDirectory)
 import System.Environment (getEnv)
@@ -55,7 +57,8 @@ import Text.Printf
 
 import Hledger.Data.Dates (getCurrentDay, parsedate, showDate)
 import Hledger.Data.Types
-import Hledger.Read.Common
+import Hledger.Read.Common hiding (easytests)
+import qualified Hledger.Read.Common (easytests)
 import qualified Hledger.Read.JournalReader   as JournalReader
 -- import qualified Hledger.Read.LedgerReader    as LedgerReader
 import qualified Hledger.Read.TimedotReader   as TimedotReader
@@ -360,3 +363,7 @@ tests_Hledger_Read = TestList $
     either error' (assertBool "journalp parsing an empty file should give an empty journal" . null . jtxns) jE
 
   ]
+
+easytests = scope "Read" $ tests [
+  Hledger.Read.Common.easytests
+  ]

hledger-lib/Hledger/Read/Common.hs

@@ -92,7 +92,8 @@ module Hledger.Read.Common (
   singlespacep,
 
   -- * tests
-  tests_Hledger_Read_Common
+  tests_Hledger_Read_Common,
+  Hledger.Read.Common.easytests
 )
 where
 --- * imports
@@ -118,12 +119,13 @@ import Data.Time.Calendar
 import Data.Time.LocalTime
 import System.Time (getClockTime)
 import Test.HUnit
+import EasyTest hiding (char, char')
 import Text.Megaparsec
 import Text.Megaparsec.Char
 import Text.Megaparsec.Char.Lexer (decimal)
 import Text.Megaparsec.Custom
 
-import Hledger.Data
+import Hledger.Data hiding (easytests)
 import Hledger.Utils
 
 -- $setup
@@ -589,18 +591,6 @@ amountwithoutpricep = do
           Left errMsg -> uncurry parseErrorAtRegion posRegion errMsg
           Right res -> pure res
 
-
-test_amountp = TestCase $ do
-    assertParseEqual' (parseWithState mempty amountp "$47.18") (usd 47.18)
-    assertParseEqual' (parseWithState mempty amountp "$1.") (usd 1 `withPrecision` 0)
--- TODO
---    assertParseEqual'' "amount with unit price"
---      (parseWithState mempty amountp "$10 @ €0.5")
---      (usd 10 `withPrecision` 0 `at` (eur 0.5 `withPrecision` 1))
---    assertParseEqual'' "amount with total price"
---     (parseWithState mempty amountp "$10 @@ €5")
---     (usd 10 `withPrecision` 0 @@ (eur 5 `withPrecision` 0))
-
 -- | Parse an amount from a string, or get an error.
 amountp' :: String -> Amount
 amountp' s =
@@ -1250,4 +1240,15 @@ match' p = do
   (!txt, p) <- match p
   pure (txt, p)
 
-tests_Hledger_Read_Common = TestList [test_spaceandamountormissingp, test_amountp]
+tests_Hledger_Read_Common = TestList [
+  test_spaceandamountormissingp
+  ]
+
+easytests = scope "Common" $ tests [
+  scope "amountp" $ tests [
+    scope "basic"                  $ expectParseEq amountp "$47.18"     (usd 47.18)
+   ,scope "ends with decimal mark" $ expectParseEq amountp "$1."        (usd 1  `withPrecision` 0)
+--   ,scope "with unit price"        $ expectParseEq amountp "$10 @ €0.5" (usd 10 `withPrecision` 0 `at` (eur 0.5 `withPrecision` 1)) 
+--   ,scope "with total price"       $ expectParseEq amountp "$10 @@ €5"  (usd 10 `withPrecision` 0 @@ (eur 5 `withPrecision` 0))
+    ]
+  ]

hledger-lib/Hledger/Utils/Test.hs

@@ -1,23 +1,37 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
 module Hledger.Utils.Test where
 
+import Control.Exception
+import Control.Monad
 import Data.Functor.Identity
-import Test.HUnit
+import Data.List
+import qualified Data.Text as T
+import EasyTest
+import Safe 
+import System.Exit
+import System.IO
+import Test.HUnit as HUnit
 import Text.Megaparsec
+
 import Hledger.Utils.Debug (pshow)
+import Hledger.Utils.Parse (parseWithState)
+import Hledger.Utils.UTF8IOCompat (error')
 
 -- | Get a Test's label, or the empty string.
-testName :: Test -> String
+testName :: HUnit.Test -> String
 testName (TestLabel n _) = n
 testName _ = ""
 
 -- | Flatten a Test containing TestLists into a list of single tests.
-flattenTests :: Test -> [Test]
+flattenTests :: HUnit.Test -> [HUnit.Test]
 flattenTests (TestLabel _ t@(TestList _)) = flattenTests t
 flattenTests (TestList ts) = concatMap flattenTests ts
 flattenTests t = [t]
 
 -- | Filter TestLists in a Test, recursively, preserving the structure.
-filterTests :: (Test -> Bool) -> Test -> Test
+filterTests :: (HUnit.Test -> Bool) -> HUnit.Test -> HUnit.Test
 filterTests p (TestLabel l ts) = TestLabel l (filterTests p ts)
 filterTests p (TestList ts) = TestList $ filter (any p . flattenTests) $ map (filterTests p) ts
 filterTests _ t = t
@@ -58,3 +72,100 @@ assertParseEqual'' label parse expected =
 printParseError :: (Show a) => a -> IO ()
 printParseError e = do putStr "parse error at "; print e
 
+-- | Run some easytests, returning True if there was a problem. Catches ExitCode.
+-- With arguments, runs only tests in the scope named by the first argument
+-- (case sensitive). 
+-- If there is a second argument, it should be an integer and will be used
+-- as the seed for randomness. 
+runEasyTests :: [String] -> EasyTest.Test () -> IO Bool
+runEasyTests args easytests = (do
+  case args of
+    []    -> EasyTest.run easytests
+    [a]   -> EasyTest.runOnly (T.pack a) easytests
+    a:b:_ -> do
+      case readMay b :: Maybe Int of
+        Nothing   -> error' "the second argument should be an integer (a seed for easytest)"
+        Just seed -> EasyTest.rerunOnly seed (T.pack a) easytests
+  return False
+  )
+  `catch` (\(_::ExitCode) -> return True)
+
+expectParseEq parser input expected = do
+  let ep = runIdentity $ parseWithState mempty parser input
+  scope "parse succeeded" $ expectRight ep
+  let Right p = ep
+  scope "parse result" $ expectEq p expected
+
+-- | Run some hunit tests, returning True if there was a problem.
+-- With arguments, runs only tests whose names contain the first argument
+-- (case sensitive). 
+runHunitTests :: [String] -> HUnit.Test -> IO Bool
+runHunitTests args hunittests = do
+  let ts = 
+        (case args of
+          a:_ -> filterTests ((a `isInfixOf`) . testName)
+          _   -> id
+        ) hunittests
+  results <- liftM (fst . flip (,) 0) $ runTestTTStdout ts
+  return $ errors results > 0 || failures results > 0
+  where
+    -- | Like runTestTT but prints to stdout.
+    runTestTTStdout t = do
+      (counts, 0) <- HUnit.runTestText (putTextToHandle stdout True) t
+      return counts
+
+--    matchedTests opts ts 
+--      | tree_ $ reportopts_ opts = 
+--        -- Tests, filtered by any arguments, in a flat list with simple names.
+--        TestList $
+--          filter (matchesAccount (queryFromOpts nulldate $ reportopts_ opts) . T.pack . testName) $ 
+--          flattenTests ts
+--      | otherwise = 
+--        -- Tests, filtered by any arguments, in the original suites with hierarchical names.
+--        filterTests (matchesAccount (queryFromOpts nulldate $ reportopts_ opts) . T.pack . testName) 
+--        ts
+
+-- -- | Like runTestTT but can optionally not erase progress output.
+-- runTestTT' verbose t = do
+--   (counts, 0) <- runTestText' (f stderr True) t
+--   return counts
+--   where f | verbose   = putTextToHandle'
+--           | otherwise = putTextToHandle
+
+-- -- | Like runTestText but also prints test names if any.
+-- runTestText' :: PutText st -> Test -> IO (Counts, st)
+-- runTestText' _pt _t@(TestLabel _label _) = error "HERE"  -- hPutStrLn stderr label >> runTestText pt t
+-- runTestText' pt t = runTestText pt t
+
+-- -- runTestText' (PutText put us0) t = do
+-- --   (counts', us1) <- trace "XXX" $ performTest reportStart reportError reportFailure us0 t
+-- --   us2 <- put (showCounts counts' ++ " :::: " ++ testName t) True us1
+-- --   return (counts', us2)
+-- --  where
+-- --   reportStart ss us = put (showCounts (counts ss)) False us
+-- --   reportError   = reportProblem "Error:"   "Error in:   "
+-- --   reportFailure = reportProblem "Failure:" "Failure in: "
+-- --   reportProblem p0 p1 loc msg ss us = put line True us
+-- --    where line  = "### " ++ kind ++ path' ++ "\n" ++ formatLocation loc ++ msg
+-- --          kind  = if null path' then p0 else p1
+-- --          path' = showPath (path ss)
+
+-- -- formatLocation :: Maybe SrcLoc -> String
+-- -- formatLocation Nothing = ""
+-- -- formatLocation (Just loc) = srcLocFile loc ++ ":" ++ show (srcLocStartLine loc) ++ "\n"
+
+-- -- | Like putTextToHandle but does not erase progress lines.
+-- putTextToHandle'
+--     :: Handle
+--     -> Bool -- ^ Write progress lines to handle?
+--     -> PutText Int
+-- putTextToHandle' handle showProgress = PutText put initCnt
+--  where
+--   initCnt = if showProgress then 0 else -1
+--   put line pers (-1) = do when pers (hPutStrLn handle line); return (-1)
+--   put line True  cnt = do hPutStrLn handle (erase cnt ++ line); return 0
+--   put line False _   = do hPutStr handle ('\n' : line); return (length line)
+--     -- The "erasing" strategy with a single '\r' relies on the fact that the
+--     -- lengths of successive summary lines are monotonically nondecreasing.
+--   erase cnt = if cnt == 0 then "" else "\r" ++ replicate cnt ' ' ++ "\r"
+

hledger-lib/hledger-lib.cabal

@@ -2,7 +2,7 @@
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: afb7a8b69691588056deb8465bec29cc05326218651e83f7f47d169e4c46aa95
+-- hash: b52d450888004e007b3689cfe42d916ab8e8af3bc91a6a374ff022a719e86611
 
 name:           hledger-lib
 version:        1.10.99
@@ -117,6 +117,7 @@ library
     , data-default >=0.5
     , deepseq
     , directory
+    , easytest
     , extra
     , filepath
     , hashtables >=1.2.3.1
@@ -215,6 +216,7 @@ test-suite doctests
     , deepseq
     , directory
     , doctest >=0.8
+    , easytest
     , extra
     , filepath
     , hashtables >=1.2.3.1
@@ -411,6 +413,7 @@ test-suite hunittests
     , data-default >=0.5
     , deepseq
     , directory
+    , easytest
     , extra
     , filepath
     , hashtables >=1.2.3.1

hledger-lib/package.yaml

@@ -52,6 +52,7 @@ dependencies:
 - Decimal
 - deepseq
 - directory
+- easytest
 - filepath
 - hashtables >=1.2.3.1
 - megaparsec >=6.4.1
@@ -177,4 +178,3 @@ tests:
     source-dirs: tests
     dependencies:
     - hledger-lib
-    - easytest

hledger/Hledger/Cli/Commands.hs

@@ -3,7 +3,6 @@ hledger's built-in commands, and helpers for printing the commands list.
 -}
 
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE CPP #-}
 
@@ -38,7 +37,6 @@ module Hledger.Cli.Commands (
 where
 
 -- import Control.Concurrent
-import Control.Exception
 import Control.Monad
 import Data.Default
 -- import Data.CallStack
@@ -53,9 +51,7 @@ import qualified Data.Text as T
 import Data.Time.Calendar
 import System.Console.CmdArgs.Explicit as C
 import System.Exit
-import System.IO (stdout)
+import Test.HUnit as HUnit
-import EasyTest
-import Test.HUnit
 
 import Hledger
 import Hledger.Cli.CliOptions
@@ -219,141 +215,46 @@ commandsFromCommandsList s =
   concatMap (splitOn "|") [w | ' ':l <- lines s, let w:_ = words l]
 
 
+-- The test command, defined here for easy access to other modules' tests.
 
--- The test command, defined here so it can access other commands' tests.
+testmode = hledgerCommandMode
+  [here| test
+Run the unit tests built in to hledger-lib and hledger, 
+printing results on stdout and exiting with success or failure.
 
-testmode = (defCommandMode ["test"]) {
+Tests are run in two batches: easytest-based and hunit-based tests.
-  modeHelp = "run built-in self-tests"
+If any test fails or gives an error, the exit code will be non-zero.
- ,modeArgs = ([], Just $ argsFlag "[REGEXPS]")
- ,modeGroupFlags = Group {
-     groupUnnamed = []
-    ,groupHidden = [
-        flagNone ["tree"] (\opts -> setboolopt "tree" opts) "show tests hierarchically"
-       ,flagNone ["flat"] (\opts -> setboolopt "flat" opts) "show tests as a flat list"
-      ]
-    ,groupNamed = [generalflagsgroup3]
-    }
- }
 
--- | Run some or all hledger-lib and hledger unit tests, and exit with success or failure.
+If a pattern argument (case sensitive) is provided, only easytests 
+in that scope and only hunit tests whose name contains it are run.
+
+If a numeric second argument is provided, it will set the randomness
+seed for easytests. 
+
+FLAGS
+  |]
+  []
+  [generalflagsgroup3]
+  []
+  ([], Just $ argsFlag "[TESTPATTERN] [SEED]")
+
+-- | See testmode.
 --
 -- Unlike other hledger commands, this one does not operate on the user's Journal.
--- For ease of implementation the Journal parameter remains in the type signature, 
+-- For ease of implementation the Journal parameter remains in the type signature. 
--- but it will raise an error if used.
 testcmd :: CliOpts -> Journal -> IO ()
-testcmd opts _donotuse = do
+testcmd opts _undefined = do 
+  let args = words' $ query_ $ reportopts_ opts
   putStrLn "\n=== easytest tests: ===\n"
-  runEasyTests opts
+  e1 <- runEasyTests args easytests
-
+  when (not e1) $ putStr "\n"
-  putStrLn "\n\n=== hunit tests: ===\n"
+  putStrLn "=== hunit tests: ===\n"
-  runHunitTests opts
+  e2 <- runHunitTests args tests_Hledger_Cli_Commands
-    -- hide exit exception output when running tests from ghci/ghcid
-    `catch` (\(_::ExitCode) -> return ())
-
-  -- whitespace to separate test results from ghcid status
   putStrLn ""
+  if or [e1, e2] then exitFailure else exitSuccess
 
--- | Run some easytests.
+-- collected hledger-lib + hledger hunit tests
--- XXX Just duplicates the ones in hledger-lib/tests/easytest.hs for now.
-runEasyTests _opts = do
-  run
-  -- rerun "journal.standard account types.queries.assets"
-  -- rerunOnly 2686786430487349354 "journal.standard account types.queries.assets"
-    $ tests [
 
-      scope "journal.standard account types.queries" $
-        let
-          j = samplejournal
-          journalAccountNamesMatching :: Query -> Journal -> [AccountName]
-          journalAccountNamesMatching q = filter (q `matchesAccount`) . journalAccountNames
-          namesfrom qfunc = journalAccountNamesMatching (qfunc j) j
-        in
-          tests
-            [ scope "assets" $
-              expectEq (namesfrom journalAssetAccountQuery)     ["assets","assets:bank","assets:bank:checking","assets:bank:saving","assets:cash"]
-            , scope "liabilities" $
-              expectEq (namesfrom journalLiabilityAccountQuery) ["liabilities","liabilities:debts"]
-            , scope "equity" $
-              expectEq (namesfrom journalEquityAccountQuery)    []
-            , scope "income" $
-              expectEq (namesfrom journalIncomeAccountQuery)    ["income","income:gifts","income:salary"]
-            , scope "expenses" $
-              expectEq (namesfrom journalExpenseAccountQuery)   ["expenses","expenses:food","expenses:supplies"]
-            ]
-
-    ]
-
-runHunitTests opts = do
-  let ts = 
-        (if tree_ $ reportopts_ opts then matchedTestsTree else matchedTestsFlat) 
-          opts tests_Hledger_Cli_Commands
-  results <- liftM (fst . flip (,) 0) $ runTestTTStdout ts
-  if errors results > 0 || failures results > 0
-    then exitFailure
-    else exitWith ExitSuccess
-
--- | Like runTestTT but prints to stdout.
-runTestTTStdout t = do
-  (counts, 0) <- runTestText (putTextToHandle stdout True) t
-  return counts
-
--- -- | Like runTestTT but can optionally not erase progress output.
--- runTestTT' verbose t = do
---   (counts, 0) <- runTestText' (f stderr True) t
---   return counts
---   where f | verbose   = putTextToHandle'
---           | otherwise = putTextToHandle
-
--- -- | Like runTestText but also prints test names if any.
--- runTestText' :: PutText st -> Test -> IO (Counts, st)
--- runTestText' _pt _t@(TestLabel _label _) = error "HERE"  -- hPutStrLn stderr label >> runTestText pt t
--- runTestText' pt t = runTestText pt t
-
--- -- runTestText' (PutText put us0) t = do
--- --   (counts', us1) <- trace "XXX" $ performTest reportStart reportError reportFailure us0 t
--- --   us2 <- put (showCounts counts' ++ " :::: " ++ testName t) True us1
--- --   return (counts', us2)
--- --  where
--- --   reportStart ss us = put (showCounts (counts ss)) False us
--- --   reportError   = reportProblem "Error:"   "Error in:   "
--- --   reportFailure = reportProblem "Failure:" "Failure in: "
--- --   reportProblem p0 p1 loc msg ss us = put line True us
--- --    where line  = "### " ++ kind ++ path' ++ "\n" ++ formatLocation loc ++ msg
--- --          kind  = if null path' then p0 else p1
--- --          path' = showPath (path ss)
-
--- -- formatLocation :: Maybe SrcLoc -> String
--- -- formatLocation Nothing = ""
--- -- formatLocation (Just loc) = srcLocFile loc ++ ":" ++ show (srcLocStartLine loc) ++ "\n"
-
--- -- | Like putTextToHandle but does not erase progress lines.
--- putTextToHandle'
---     :: Handle
---     -> Bool -- ^ Write progress lines to handle?
---     -> PutText Int
--- putTextToHandle' handle showProgress = PutText put initCnt
---  where
---   initCnt = if showProgress then 0 else -1
---   put line pers (-1) = do when pers (hPutStrLn handle line); return (-1)
---   put line True  cnt = do hPutStrLn handle (erase cnt ++ line); return 0
---   put line False _   = do hPutStr handle ('\n' : line); return (length line)
---     -- The "erasing" strategy with a single '\r' relies on the fact that the
---     -- lengths of successive summary lines are monotonically nondecreasing.
---   erase cnt = if cnt == 0 then "" else "\r" ++ replicate cnt ' ' ++ "\r"
-
--- | All or pattern-matched tests, as a flat list to show simple names.
-matchedTestsFlat opts = TestList . 
-  filter (matchesAccount (queryFromOpts nulldate $ reportopts_ opts) . T.pack . testName) . 
-  flattenTests
-
--- | All or pattern-matched tests, in the original suites to show hierarchical names.
-matchedTestsTree opts = 
-  filterTests (matchesAccount (queryFromOpts nulldate $ reportopts_ opts) . T.pack . testName) 
-
-
--- collected hledger-lib + hledger unit tests
-
-tests_Hledger_Cli_Commands :: Test.HUnit.Test
 tests_Hledger_Cli_Commands = TestList [
    tests_Hledger
   ,tests_Hledger_Cli_CliOptions

hledger/hledger_commands.m4.md

@@ -787,14 +787,20 @@ With additional QUERY arguments, only transactions matching the query are consid
 ## test
 Run built-in unit tests.
 
-```shell
-$ hledger test
-Cases: 74  Tried: 74  Errors: 0  Failures: 0
-```
-
 This command runs hledger's built-in unit tests and displays a quick report.
-With a regular expression argument, it selects only tests with matching names.
+It's mainly used during development, but it's also nice to be able to
-It's mainly used in development, but it's also nice to be able to
+sanity-check your installed hledger executable at any time.
-check your hledger executable for smoke at any time.
+
+It runs the unit tests built in to hledger-lib and hledger, 
+printing results on stdout and exiting with success or failure.
+
+Tests are run in two batches: easytest-based and hunit-based tests.
+If any test fails or gives an error, the exit code will be non-zero.
+
+If a pattern argument (case sensitive) is provided, only easytests 
+in that scope and only hunit tests whose name contains it are run.
+
+If a numeric second argument is provided, it will set the randomness
+seed for easytests. 
 
 _include_(hledger_addons.m4.md)