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

@@ -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
+    ]

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) [] ~?= []
+
+        ]

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

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

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 = TestList $ filter matchname $ tflatten tests  -- show flat test names
-      --ts = tfilter matchname $ TestList tests -- unflattened
+      -- ts = tfilter matchname $ TestList tests -- show hierarchical test names
       matchname = matchpats args . tname
 
--- | Get a Test's label, or the empty string.
+-- | hledger's unit tests, defined here and also (new) in the respective modules.
-tname :: Test -> String
+-- The latter is probably the way forward.
-tname (TestLabel n _) = n
+tests :: Test
-tname _ = ""
+tests = TestList [
 
--- | Flatten a Test containing TestLists into a list of single tests.
+   tests_Register,
-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.
+   "account directive" ~:
-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" ~: 
    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]
+    assertParse (parseWithCtx emptyCtx postingamount " $47.18") (Mixed [dollars 47.18])
-    parseWithCtx emptyCtx postingamount " $1." `parseis` 
+    assertParse (parseWithCtx emptyCtx postingamount " $1.")
-     Mixed [Amount Commodity {symbol="$",side=L,spaced=False,comma=False,precision=0} 1 Nothing]
+                (Mixed [Amount Commodity {symbol="$",side=L,spaced=False,comma=False,precision=0} 1 Nothing])
 
   ]
 
   
-------------------------------------------------------------------------------
+-- fixtures/test data
--- test data
 
 date1 = parsedate "2008/11/26"
 t1 = LocalTime date1 midday