From a50d3e2b71d7ed5963486ddc182b7878df7c8251 Mon Sep 17 00:00:00 2001 From: Simon Michael Date: Mon, 8 Mar 2010 21:47:36 +0000 Subject: [PATCH] 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. --- Commands/All.hs | 25 +++++++++++++++++- Commands/Register.hs | 8 ++++++ Ledger/Parse.hs | 3 --- Ledger/Utils.hs | 33 ++++++++++++++++++++++- Tests.hs | 62 +++++++++++++------------------------------- 5 files changed, 82 insertions(+), 49 deletions(-) diff --git a/Commands/All.hs b/Commands/All.hs index 423399c74..ca09a1f43 100644 --- a/Commands/All.hs +++ b/Commands/All.hs @@ -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 + ] diff --git a/Commands/Register.hs b/Commands/Register.hs index b50f44101..f968b5209 100644 --- a/Commands/Register.hs +++ b/Commands/Register.hs @@ -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) [] ~?= [] + + ] diff --git a/Ledger/Parse.hs b/Ledger/Parse.hs index 3ae2717c9..6c576865f 100644 --- a/Ledger/Parse.hs +++ b/Ledger/Parse.hs @@ -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 diff --git a/Ledger/Utils.hs b/Ledger/Utils.hs index 42f456815..2727b13f0 100644 --- a/Ledger/Utils.hs +++ b/Ledger/Utils.hs @@ -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 diff --git a/Tests.hs b/Tests.hs index d83d50f7c..b757d52ca 100644 --- a/Tests.hs +++ b/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