diff --git a/hledger/Hledger/Cli/Commands.hs b/hledger/Hledger/Cli/Commands.hs index fabb7f670..0184928af 100644 --- a/hledger/Hledger/Cli/Commands.hs +++ b/hledger/Hledger/Cli/Commands.hs @@ -3,6 +3,7 @@ hledger's built-in commands, and helpers for printing the commands list. -} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE CPP #-} @@ -36,8 +37,11 @@ module Hledger.Cli.Commands ( ) where +-- import Control.Concurrent +import Control.Exception import Control.Monad import Data.Default +-- import Data.CallStack import Data.List import Data.List.Split (splitOn) #if !(MIN_VERSION_base(4,11,0)) @@ -49,6 +53,8 @@ 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 Hledger @@ -233,17 +239,108 @@ testmode = (defCommandMode ["test"]) { -- -- 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 not be valid and should not be used. +-- but it will raise an error if used. testcmd :: CliOpts -> Journal -> IO () testcmd opts _donotuse = do + 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 + putStrLn "" + +-- | 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 [ + + 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) $ runTestTT ts + 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) . @@ -256,7 +353,7 @@ matchedTestsTree opts = -- collected hledger-lib + hledger unit tests -tests_Hledger_Cli_Commands :: Test +tests_Hledger_Cli_Commands :: Test.HUnit.Test tests_Hledger_Cli_Commands = TestList [ tests_Hledger ,tests_Hledger_Cli_CliOptions diff --git a/hledger/hledger.cabal b/hledger/hledger.cabal index e0b376804..e6f887671 100644 --- a/hledger/hledger.cabal +++ b/hledger/hledger.cabal @@ -2,7 +2,7 @@ -- -- see: https://github.com/sol/hpack -- --- hash: fc9d50bfd8e455c344f6ba60fd05358537cb2f3a6bc968eca7e554364f4cc1fe +-- hash: 3be7e8745a826dbfc9d0007b9b37c3962486573614267365e6dafb8f7079ece6 name: hledger version: 1.10.99 @@ -123,6 +123,7 @@ library , csv , data-default >=0.5 , directory + , easytest , file-embed >=0.0.10 , filepath , hashable >=1.2.4 @@ -175,6 +176,7 @@ executable hledger , csv , data-default >=0.5 , directory + , easytest , file-embed >=0.0.10 , filepath , haskeline >=0.6 @@ -229,6 +231,7 @@ test-suite test , csv , data-default >=0.5 , directory + , easytest , file-embed >=0.0.10 , filepath , haskeline >=0.6 @@ -283,6 +286,7 @@ benchmark bench , csv , data-default >=0.5 , directory + , easytest , file-embed >=0.0.10 , filepath , haskeline >=0.6 diff --git a/hledger/package.yaml b/hledger/package.yaml index a69078cab..5f3f99d57 100644 --- a/hledger/package.yaml +++ b/hledger/package.yaml @@ -89,6 +89,7 @@ dependencies: - data-default >=0.5 - Decimal - directory +- easytest - file-embed >=0.0.10 - filepath - haskeline >=0.6