test: run some easytests as well; print test output on stdout

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

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

hledger/package.yaml

@@ -89,6 +89,7 @@ dependencies:
 - data-default >=0.5
 - Decimal
 - directory
+- easytest
 - file-embed >=0.0.10
 - filepath
 - haskeline >=0.6