mirror of
https://github.com/simonmichael/hledger.git
synced 2024-09-20 02:37:12 +03:00
refactor, allow in-module unit tests
Until now, all unit tests were defined in Tests.hs. Pro: simple, makes code/test line counting easy. Con: tests are far from code, Tests.hs turns into a big wall of test code. Now, unit tests can also be defined in modules. To avoid name clashes and template haskell complexity, a dumb manual naming scheme is used: any module may export a hunit Test(List) named tests_ModuleName. These are manually aggregated and re-exported when appropriate, eg in Commands.All and finally in Tests.hs.
This commit is contained in:
parent
3969dff3fc
commit
a50d3e2b71
@ -22,8 +22,9 @@ module Commands.All (
|
||||
module Commands.Web,
|
||||
#endif
|
||||
#ifdef CHART
|
||||
module Commands.Chart
|
||||
module Commands.Chart,
|
||||
#endif
|
||||
tests_Commands
|
||||
)
|
||||
where
|
||||
import Commands.Add
|
||||
@ -42,3 +43,25 @@ import Commands.Web
|
||||
#ifdef CHART
|
||||
import Commands.Chart
|
||||
#endif
|
||||
import Test.HUnit (Test(TestList))
|
||||
|
||||
|
||||
tests_Commands = TestList
|
||||
[
|
||||
-- Commands.Add.tests_Add
|
||||
-- ,Commands.Balance.tests_Balance
|
||||
-- ,Commands.Convert.tests_Convert
|
||||
-- ,Commands.Histogram.tests_Histogram
|
||||
-- ,Commands.Print.tests_Print
|
||||
Commands.Register.tests_Register
|
||||
-- ,Commands.Stats.tests_Stats
|
||||
-- #ifdef VTY
|
||||
-- ,Commands.UI.tests_UI
|
||||
-- #endif
|
||||
-- #if defined(WEB) || defined(WEBHAPPSTACK)
|
||||
-- ,Commands.Web.tests_Web
|
||||
-- #endif
|
||||
-- #ifdef CHART
|
||||
-- ,Commands.Chart.tests_Chart
|
||||
-- #endif
|
||||
]
|
||||
|
@ -8,6 +8,7 @@ A ledger-compatible @register@ command.
|
||||
module Commands.Register (
|
||||
register
|
||||
,showRegisterReport
|
||||
,tests_Register
|
||||
) where
|
||||
|
||||
import Safe (headMay, lastMay)
|
||||
@ -133,3 +134,10 @@ showposting withtxninfo p b = concatBottomPadded [txninfo ++ pstr ++ " ", bal] +
|
||||
(da,de) = case ptransaction p of Just (Transaction{tdate=da',tdescription=de'}) -> (da',de')
|
||||
Nothing -> (nulldate,"")
|
||||
|
||||
tests_Register :: Test
|
||||
tests_Register = TestList [
|
||||
|
||||
"summarisePostings" ~: do
|
||||
summarisePostings Quarterly Nothing False (DateSpan Nothing Nothing) [] ~?= []
|
||||
|
||||
]
|
||||
|
@ -61,9 +61,6 @@ setYear y = updateState (\ctx -> ctx{ctxYear=Just y})
|
||||
getYear :: GenParser tok LedgerFileCtx (Maybe Integer)
|
||||
getYear = liftM ctxYear getState
|
||||
|
||||
printParseError :: (Show a) => a -> IO ()
|
||||
printParseError e = do putStr "ledger parse error at "; print e
|
||||
|
||||
-- let's get to it
|
||||
|
||||
parseLedgerFile :: LocalTime -> FilePath -> ErrorT String IO Journal
|
||||
|
@ -37,7 +37,7 @@ import Data.Time.Calendar
|
||||
import Data.Time.LocalTime
|
||||
import Debug.Trace
|
||||
#if __GLASGOW_HASKELL__ <= 610
|
||||
import Prelude hiding (readFile)
|
||||
import Prelude hiding (readFile,putStr,print)
|
||||
import System.IO.UTF8
|
||||
#endif
|
||||
import Test.HUnit
|
||||
@ -267,6 +267,37 @@ getCurrentLocalTime = do
|
||||
tz <- getCurrentTimeZone
|
||||
return $ utcToLocalTime tz t
|
||||
|
||||
-- testing
|
||||
|
||||
-- | Get a Test's label, or the empty string.
|
||||
tname :: Test -> String
|
||||
tname (TestLabel n _) = n
|
||||
tname _ = ""
|
||||
|
||||
-- | Flatten a Test containing TestLists into a list of single tests.
|
||||
tflatten :: Test -> [Test]
|
||||
tflatten (TestLabel _ t@(TestList _)) = tflatten t
|
||||
tflatten (TestList ts) = concatMap tflatten ts
|
||||
tflatten t = [t]
|
||||
|
||||
-- | Filter TestLists in a Test, recursively, preserving the structure.
|
||||
tfilter :: (Test -> Bool) -> Test -> Test
|
||||
tfilter p (TestLabel l ts) = TestLabel l (tfilter p ts)
|
||||
tfilter p (TestList ts) = TestList $ filter (any p . tflatten) $ map (tfilter p) ts
|
||||
tfilter _ t = t
|
||||
|
||||
-- | Simple way to assert something is some expected value, with no label.
|
||||
is :: (Eq a, Show a) => a -> a -> Assertion
|
||||
a `is` e = assertEqual "" e a
|
||||
|
||||
-- | Assert a parse result is some expected value, or print a parse error.
|
||||
assertParse :: (Show a, Eq a) => (Either ParseError a) -> a -> Assertion
|
||||
assertParse parse expected = either printParseError (`is` expected) parse
|
||||
|
||||
printParseError :: (Show a) => a -> IO ()
|
||||
printParseError e = do putStr "parse error at "; print e
|
||||
|
||||
|
||||
-- misc
|
||||
|
||||
isLeft :: Either a b -> Bool
|
||||
|
62
Tests.hs
62
Tests.hs
@ -31,17 +31,18 @@ where
|
||||
import qualified Data.Map as Map
|
||||
import Data.Time.Format
|
||||
import Locale (defaultTimeLocale)
|
||||
import Text.ParserCombinators.Parsec
|
||||
import Test.HUnit.Tools (runVerboseTests)
|
||||
import System.Exit (exitFailure, exitWith, ExitCode(ExitSuccess)) -- base 3 compatible
|
||||
import System.Time (ClockTime(TOD))
|
||||
|
||||
import Commands.All
|
||||
import Ledger
|
||||
import Ledger -- including testing utils in Ledger.Utils
|
||||
import Options
|
||||
import Utils
|
||||
|
||||
|
||||
-- | Run unit tests.
|
||||
runtests :: [Opt] -> [String] -> IO ()
|
||||
runtests opts args = do
|
||||
(counts,_) <- runner ts
|
||||
if errors counts > 0 || (failures counts > 0)
|
||||
@ -50,44 +51,18 @@ runtests opts args = do
|
||||
where
|
||||
runner | Verbose `elem` opts = runVerboseTests
|
||||
| otherwise = liftM (flip (,) 0) . runTestTT
|
||||
ts = TestList $ filter matchname $ concatMap tflatten tests
|
||||
--ts = tfilter matchname $ TestList tests -- unflattened
|
||||
ts = TestList $ filter matchname $ tflatten tests -- show flat test names
|
||||
-- ts = tfilter matchname $ TestList tests -- show hierarchical test names
|
||||
matchname = matchpats args . tname
|
||||
|
||||
-- | Get a Test's label, or the empty string.
|
||||
tname :: Test -> String
|
||||
tname (TestLabel n _) = n
|
||||
tname _ = ""
|
||||
-- | hledger's unit tests, defined here and also (new) in the respective modules.
|
||||
-- The latter is probably the way forward.
|
||||
tests :: Test
|
||||
tests = TestList [
|
||||
|
||||
-- | Flatten a Test containing TestLists into a list of single tests.
|
||||
tflatten :: Test -> [Test]
|
||||
tflatten (TestLabel _ t@(TestList _)) = tflatten t
|
||||
tflatten (TestList ts) = concatMap tflatten ts
|
||||
tflatten t = [t]
|
||||
tests_Register,
|
||||
|
||||
-- | Filter TestLists in a Test, recursively, preserving the structure.
|
||||
tfilter :: (Test -> Bool) -> Test -> Test
|
||||
tfilter p (TestLabel l ts) = TestLabel l (tfilter p ts)
|
||||
tfilter p (TestList ts) = TestList $ filter (any p . tflatten) $ map (tfilter p) ts
|
||||
tfilter _ t = t
|
||||
|
||||
-- | Simple way to assert something is some expected value, with no label.
|
||||
is :: (Eq a, Show a) => a -> a -> Assertion
|
||||
a `is` e = assertEqual "" e a
|
||||
|
||||
-- | Assert a parse result is some expected value, or print a parse error.
|
||||
parseis :: (Show a, Eq a) => (Either ParseError a) -> a -> Assertion
|
||||
parse `parseis` expected = either printParseError (`is` expected) parse
|
||||
|
||||
assertParse :: (Show a, Eq a) => (Either ParseError a) -> a -> Assertion
|
||||
assertParse = parseis
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Tests for any function or topic. Mostly ordered by test name.
|
||||
tests :: [Test]
|
||||
tests = [
|
||||
|
||||
"account directive" ~:
|
||||
"account directive" ~:
|
||||
let sameParse str1 str2 = do l1 <- journalFromString str1
|
||||
l2 <- journalFromString str2
|
||||
l1 `is` l2
|
||||
@ -462,10 +437,10 @@ tests = [
|
||||
assertBool "ledgerFile parsing an empty file should give an empty ledger" $ null $ jtxns r
|
||||
|
||||
,"ledgerHistoricalPrice" ~:
|
||||
parseWithCtx emptyCtx ledgerHistoricalPrice price1_str `parseis` price1
|
||||
assertParse (parseWithCtx emptyCtx ledgerHistoricalPrice price1_str) price1
|
||||
|
||||
,"ledgerTransaction" ~: do
|
||||
parseWithCtx emptyCtx ledgerTransaction entry1_str `parseis` entry1
|
||||
assertParse (parseWithCtx emptyCtx ledgerTransaction entry1_str) entry1
|
||||
assertBool "ledgerTransaction should not parse just a date"
|
||||
$ isLeft $ parseWithCtx emptyCtx ledgerTransaction "2009/1/1\n"
|
||||
assertBool "ledgerTransaction should require some postings"
|
||||
@ -481,7 +456,7 @@ tests = [
|
||||
assertBool "ledgeraccountname rejects an empty trailing component" (isLeft $ parsewith ledgeraccountname "a:b:")
|
||||
|
||||
,"ledgerposting" ~:
|
||||
parseWithCtx emptyCtx ledgerposting rawposting1_str `parseis` rawposting1
|
||||
assertParse (parseWithCtx emptyCtx ledgerposting rawposting1_str) rawposting1
|
||||
|
||||
,"normaliseMixedAmount" ~: do
|
||||
normaliseMixedAmount (Mixed []) ~?= Mixed [nullamt]
|
||||
@ -867,15 +842,14 @@ tests = [
|
||||
-- ]
|
||||
|
||||
,"postingamount" ~: do
|
||||
parseWithCtx emptyCtx postingamount " $47.18" `parseis` Mixed [dollars 47.18]
|
||||
parseWithCtx emptyCtx postingamount " $1." `parseis`
|
||||
Mixed [Amount Commodity {symbol="$",side=L,spaced=False,comma=False,precision=0} 1 Nothing]
|
||||
assertParse (parseWithCtx emptyCtx postingamount " $47.18") (Mixed [dollars 47.18])
|
||||
assertParse (parseWithCtx emptyCtx postingamount " $1.")
|
||||
(Mixed [Amount Commodity {symbol="$",side=L,spaced=False,comma=False,precision=0} 1 Nothing])
|
||||
|
||||
]
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- test data
|
||||
-- fixtures/test data
|
||||
|
||||
date1 = parsedate "2008/11/26"
|
||||
t1 = LocalTime date1 midday
|
||||
|
Loading…
Reference in New Issue
Block a user