diff --git a/hledger-lib/Hledger.hs b/hledger-lib/Hledger.hs index 8ff39b5f9..832f3d081 100644 --- a/hledger-lib/Hledger.hs +++ b/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.Query as X -import Hledger.Read as X hiding (samplejournal) +import Hledger.Data as X hiding (easytests) +import qualified Hledger.Data (easytests) +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 + ] diff --git a/hledger-lib/Hledger/Data/Journal.hs b/hledger-lib/Hledger/Data/Journal.hs index ed4d2aa9c..98f3f144d 100644 --- a/hledger-lib/Hledger/Data/Journal.hs +++ b/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"] + ] + ] diff --git a/hledger-lib/Hledger/Read.hs b/hledger-lib/Hledger/Read.hs index c3b78d214..e508bc492 100644 --- a/hledger-lib/Hledger/Read.hs +++ b/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 + ] diff --git a/hledger-lib/Hledger/Read/Common.hs b/hledger-lib/Hledger/Read/Common.hs index 36a37697d..49ff70668 100644 --- a/hledger-lib/Hledger/Read/Common.hs +++ b/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)) + ] + ] diff --git a/hledger-lib/Hledger/Utils/Test.hs b/hledger-lib/Hledger/Utils/Test.hs index 1afdefe7f..b63362688 100644 --- a/hledger-lib/Hledger/Utils/Test.hs +++ b/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" + diff --git a/hledger-lib/hledger-lib.cabal b/hledger-lib/hledger-lib.cabal index d500a5e23..d825a2a40 100644 --- a/hledger-lib/hledger-lib.cabal +++ b/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 diff --git a/hledger-lib/package.yaml b/hledger-lib/package.yaml index 6f89f0e1d..8ebd84751 100644 --- a/hledger-lib/package.yaml +++ b/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 diff --git a/hledger/Hledger/Cli/Commands.hs b/hledger/Hledger/Cli/Commands.hs index 0184928af..855ab3cfa 100644 --- a/hledger/Hledger/Cli/Commands.hs +++ b/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 EasyTest -import Test.HUnit +import Test.HUnit as 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"]) { - modeHelp = "run built-in self-tests" - ,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] - } - } +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. --- | 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, --- but it will raise an error if used. +-- For ease of implementation the Journal parameter remains in the type signature. 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 - - putStrLn "\n\n=== hunit tests: ===\n" - runHunitTests opts - -- hide exit exception output when running tests from ghci/ghcid - `catch` (\(_::ExitCode) -> return ()) - - -- whitespace to separate test results from ghcid status + e1 <- runEasyTests args easytests + when (not e1) $ putStr "\n" + putStrLn "=== hunit tests: ===\n" + e2 <- runHunitTests args tests_Hledger_Cli_Commands putStrLn "" + if or [e1, e2] then exitFailure else exitSuccess --- | Run some easytests. --- 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 [ +-- collected hledger-lib + hledger hunit 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 diff --git a/hledger/hledger_commands.m4.md b/hledger/hledger_commands.m4.md index 5f9a2a0b0..1f6ac008e 100644 --- a/hledger/hledger_commands.m4.md +++ b/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 in development, but it's also nice to be able to -check your hledger executable for smoke at any time. +It's mainly used during development, but it's also nice to be able to +sanity-check your installed hledger executable 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)