much refactoring, get quickcheck working, beginnings of account matching

Models.hs

@@ -3,7 +3,9 @@ module Models  -- data types & behaviours
 where
 
 import Text.Printf
-import List
+import Data.List
+
+-- types
 
 data Ledger = Ledger {
                       modifier_entries :: [ModifierEntry],
@@ -36,8 +38,8 @@ data Amount = Amount {
 type Date = String
 type Account = String
 
--- Amount arithmetic
+-- Amount arithmetic - ignores currency conversion
--- ignores currency conversion
+
 instance Num Amount where
     abs (Amount c q) = Amount c (abs q)
     signum (Amount c q) = Amount c (signum q)
@@ -69,16 +71,8 @@ instance Show PeriodicEntry where
 
 instance Show Entry where show = showEntry
 
-showEntryOld :: Entry -> String
-showEntryOld e = date e ++ " " ++ s ++ c ++ d ++ "\n" ++ unlines (map show (transactions e))
-        where 
-          d = description e
-          s = case (status e) of {True -> "* "; False -> ""}
-          c = case (length(code e) > 0) of {True -> (code e ++ " "); False -> ""}
-
 -- a register entry is displayed as two or more lines like this:
 -- date       description          account                    amount     balance
-
 -- DDDDDDDDDD dddddddddddddddddddd aaaaaaaaaaaaaaaaaaaaaaaaa  AAAAAAAAAA AAAAAAAAAA
 --                                 aaaaaaaaaaaaaaaaaaaaaaaaa  AAAAAAAAAA AAAAAAAAAA
 --                                 ...                        ...        ...
@@ -88,18 +82,22 @@ showEntryOld e = date e ++ " " ++ s ++ c ++ d ++ "\n" ++ unlines (map show (tran
 -- amtWidth  = 10
 -- balWidth  = 10
 
+showEntry :: Entry -> String
+showEntry e = unlines $ map fst (entryLines e)
+
 -- convert an Entry to entry lines (string, amount pairs)
 entryLines :: Entry -> [(String,Amount)]
 entryLines e =
-    [(entrydesc ++ (show t), amount t)]
+    [firstline] ++ otherlines
-    ++ map (\t -> (prependSpace $ show t, amount t)) ts
         where 
           t:ts = transactions e
           entrydesc = printf "%-10s %-20s " (date e) (take 20 $ description e)
-          prependSpace = (printf (take 32 (repeat ' ')) ++)
+          firstline = (entrydesc ++ (show t), amount t)
+          otherlines = map (\t -> (prependSpace $ show t, amount t)) ts
+          prependSpace = (replicate 32 ' ' ++)
 
 instance Show Transaction where 
-    show t = printf "%-25s  %10s " (take 25 $ account t) (show $ amount t)
+    show t = printf "%-25s  %10s" (take 25 $ account t) (show $ amount t)
 
 instance Show Amount where
     show (Amount cur qty) = 
@@ -108,58 +106,87 @@ instance Show Amount where
           "0.00" -> "0"
           otherwise -> cur ++ roundedqty
 
-showEntry :: Entry -> String
+-- in the register report we show entries plus a running balance
-showEntry e = unlines $ map fst (entryLines e)
+
+showEntriesWithBalances :: [Entry] -> Amount -> String
+showEntriesWithBalances [] _ = ""
+showEntriesWithBalances (e:es) b =
+    showEntryWithBalances e b ++ (showEntriesWithBalances es b')
+        where b' = b + (entryBalance e)
+
+entryBalance :: Entry -> Amount
+entryBalance = sumTransactions . transactions
+
+showEntryWithBalances :: Entry -> Amount -> String
+showEntryWithBalances e b =
+    unlines [s | (s,a,b) <- entryLinesWithBalances (entryLines e) b]
 
--- add balances to entry lines, given a starting balance
 entryLinesWithBalances :: [(String,Amount)] -> Amount -> [(String,Amount,Amount)]
 entryLinesWithBalances [] _ = []
 entryLinesWithBalances ((str,amt):els) bal = 
     [(str',amt,bal')] ++ entryLinesWithBalances els bal'
         where
           bal' = bal + amt
-          str' = str ++ (printf "%10.2s" (show bal'))
+          str' = str ++ (printf " %10.2s" (show bal'))
-
-showEntryWithBalances :: Entry -> Amount -> String
-showEntryWithBalances e b = unlines $ 
-  [s | (s,a,b) <- entryLinesWithBalances (entryLines e) b]
-
--- show register entries, keeping a running balance
-showRegisterEntries :: [Entry] -> Amount -> String
-showRegisterEntries [] _ = ""
-showRegisterEntries (e:es) b =
-    showEntryWithBalances e b ++ (showRegisterEntries es b')
-        where b' = b + (sumTransactions (transactions e))
 
 -- misc
 
--- fill in missing amounts etc., as far as possible
+autofillEntry :: Entry -> Entry
-autofill :: Entry -> Entry
+autofillEntry e = 
-autofill e = Entry (date e) (status e) (code e) (description e)
+    Entry (date e) (status e) (code e) (description e)
               (autofillTransactions (transactions e))
 
 autofillTransactions :: [Transaction] -> [Transaction]
 autofillTransactions ts =
-    let (ns,as) = normalAndAutoTransactions ts in
+    let (ns, as) = normalAndAutoTransactions ts in
     case (length as) of
       0 -> ns
-      1 -> ns ++ [Transaction (account (head as)) (-(sumTransactions ns))]
+      1 -> ns ++ [balanceTransaction $ head as]
+          where balanceTransaction t = t{amount = -(sumTransactions ns)}
       otherwise -> error "too many blank transactions in this entry"
 
 normalAndAutoTransactions :: [Transaction] -> ([Transaction], [Transaction])
 normalAndAutoTransactions ts = 
-    ([t | t <- ts, (currency $ amount t) /= "AUTO"],
+    partition isNormal ts
-     [t | t <- ts, (currency $ amount t) == "AUTO"])
+        where isNormal t = (currency $ amount t) /= "AUTO"
 
 sumTransactions :: [Transaction] -> Amount
 sumTransactions ts = sum [amount t | t <- ts]
 
-transactionsFrom :: [Entry] -> [Transaction]
+transactionsFromEntries :: [Entry] -> [Transaction]
-transactionsFrom es = concat $ map transactions es
+transactionsFromEntries es = concat $ map transactions es
 
-accountsFrom :: [Transaction] -> [Account]
+accountsFromTransactions :: [Transaction] -> [Account]
-accountsFrom ts = nub $ map account ts
+accountsFromTransactions ts = nub $ map account ts
 
 accountsUsed :: Ledger -> [Account]
-accountsUsed l = accountsFrom $ transactionsFrom $ entries l
+accountsUsed l = accountsFromTransactions $ transactionsFromEntries $ entries l
 
+-- ["a:b:c","d:e"] -> ["a","a:b","a:b:c","d","d:e"]
+expandAccounts :: [Account] -> [Account]
+expandAccounts l = nub $ concat $ map expand l
+                where
+                  expand l' = map (concat . intersperse ":") (tail $ inits $ splitAtElement ':' l')
+
+splitAtElement :: Eq a => a -> [a] -> [[a]]
+splitAtElement e l = 
+    case dropWhile (e==) l of
+      [] -> []
+      l' -> first : splitAtElement e rest
+        where
+          (first,rest) = break (e==) l'
+
+accountTree :: Ledger -> [Account]
+accountTree = sort . expandAccounts . accountsUsed
+
+entriesMatching :: String -> Ledger -> [Entry]
+entriesMatching s l = filterEntriesByAccount s (entries l)
+
+filterEntriesByAccount :: String -> [Entry] -> [Entry]
+filterEntriesByAccount s es = filter (matchEntryAccount s) es
+
+matchEntryAccount :: String -> Entry -> Bool
+matchEntryAccount s e = any (matchTransactionAccount s) (transactions e)
+
+matchTransactionAccount :: String -> Transaction -> Bool
+matchTransactionAccount s t = s `isInfixOf` (account t)

Options.hs

@@ -31,6 +31,6 @@ get_content (File s) = Just s
 --defaultLedgerFile = tildeExpand "~/ledger.dat"
 defaultLedgerFile = "ledger.dat"
 
-ledgerFilePath :: IO String
+getLedgerFilePath :: IO String
-ledgerFilePath = do
+getLedgerFilePath = do
   getEnv "LEDGER" `catch` \_ -> return defaultLedgerFile >>= return

Parse.hs

@@ -182,7 +182,7 @@ ledgerentry = do
   transactions <- ledgertransactions
   ledgernondatalines
   let entry = Entry date status code description transactions
-  return $ autofill entry
+  return $ autofillEntry entry
 
 ledgerdate :: Parser String
 ledgerdate = do date <- many1 (digit <|> char '/'); many1 spacenonewline; return date
@@ -235,11 +235,15 @@ whiteSpace1 :: Parser ()
 whiteSpace1 = do space; whiteSpace
 
 
--- ok, what can we do with it ?
+-- utils
-
-printParseResult r = case r of
-                       Left e -> parseError e
-                       Right v  -> print v
 
+parseError :: (Show a) => a -> IO ()
 parseError e = do putStr "ledger parse error at "; print e
 
+printParseResult :: Show v => Either ParseError v -> IO ()
+printParseResult r = case r of Left e -> parseError e
+                               Right v -> print v
+
+parseLedgerFile :: String -> IO (Either ParseError Ledger)
+parseLedgerFile f = parseFromFile ledger f
+

TODO

@@ -1,9 +1,24 @@
 features
+ register
+  account matching
+   match transactions, not entries
+
+$ ledger reg equi
+2007/01/01 opening balance      equity:opening balan..       $-4.82       $-4.82
+2007/01/25 balance adjustment   equity                       $91.15       $86.33
+$ hledger reg equi
+2007/01/01 opening balance      assets:cash                     $4.82      $4.82
+                                equity:opening balances        $-4.82          0
+2007/01/25 balance adjustment   equity                         $91.15     $91.15
+                                assets:cash                   $-91.15          0
+  description matching
+  regexp matching
+
  balance
-  show top-level acct balance
+  show top-level acct balances
-  show per-account balances
+  show all account balances
+
  print
- matching by account/description regexp
  more directives, eg include
  read timelog files
  -p period expressions
@@ -14,13 +29,11 @@ features
  read gnucash files
 
 testing
- get quickcheck working
- consider hunit dsl
  ledger regression/compatibility tests
 
 environment
  cleaner option processing
- smart ledger file finding
+ robust ledger file finding
 
 documentation
  literate docs

Tests.hs

@@ -202,15 +202,21 @@ ledger7 = Ledger [] []
 
 -- utils
 
+assertEqual' e a = assertEqual "" e a
+
+parse' p ts = parse p "" ts
+
 assertParseEqual :: (Show a, Eq a) => a -> (Either ParseError a) -> Assertion
 assertParseEqual expected parsed =
     case parsed of
       Left e -> parseError e
       Right v -> assertEqual " " expected v
 
-assertEqual' e a = assertEqual "" e a
+parseEquals :: Eq a => (Either ParseError a) -> a -> Bool
-
+parseEquals parsed other =
-parse' p ts = parse p "" ts
+    case parsed of
+      Left e -> False
+      Right v -> v == other
 
 -- hunit tests
 
@@ -229,36 +235,49 @@ parse' p ts = parse p "" ts
 --   parseTest ledger periodic_entry2_str
 --   parseLedgerFile ledgerFilePath >>= printParseResult
 
-test_parse_ledgertransaction :: Assertion
+test_ledgertransaction :: Assertion
-test_parse_ledgertransaction =
+test_ledgertransaction =
     assertParseEqual transaction1 (parse' ledgertransaction transaction1_str)      
 
-test_parse_ledgerentry =
+test_ledgerentry =
     assertParseEqual entry1 (parse' ledgerentry entry1_str)
 
-test_autofill_entry = 
+test_autofillEntry = 
     assertEqual'
     (Amount "$" (-47.18))
-      (amount $ last $ transactions $ autofill entry1)
+    (amount $ last $ transactions $ autofillEntry entry1)
 
-tests = TestList [
+test_expandAccounts =
-                   t "test_parse_ledgertransaction" test_parse_ledgertransaction
+    assertEqual'
-                 , t "test_parse_ledgerentry" test_parse_ledgerentry
+    ["assets","assets:cash","assets:checking","expenses","expenses:vacation"]
-                 , t "test_autofill_entry" test_autofill_entry
+    (expandAccounts ["assets:cash","assets:checking","expenses:vacation"])
+
+test_accountTree =
+    assertEqual'
+    ["assets","assets:cash","assets:checking","equity","equity:opening balances","expenses","expenses:vacation"]
+    (accountTree ledger7)
+
+tests = let t l f = TestLabel l $ TestCase f in TestList
+        [
+          t "test_ledgertransaction" test_ledgertransaction
+        , t "test_ledgerentry" test_ledgerentry
+        , t "test_autofillEntry" test_autofillEntry
+        , t "test_expandAccounts" test_expandAccounts
+        , t "test_accountTree" test_accountTree
         ]
-    where t label fn = TestLabel label $ TestCase fn
 
-tests2 = Test.HUnit.test [
+tests2 = Test.HUnit.test 
+         [
           "test1" ~: assertEqual "2 equals 2" 2 2
          ]
 
 -- quickcheck properties
 
-prop1 = 1 == 1
+props =
---prop_test_parse_ledgertransaction =
+    [
---     (Transaction "expenses:food:dining" (Amount "$" 10)) == 
+     (parse' ledgertransaction transaction1_str) `parseEquals`
---     (parse' ledgertransaction transaction_str))
+     (Transaction "expenses:food:dining" (Amount "$" 10))
-
+    ,
-props = [
+     (accountTree ledger7) == 
-         prop1
+     ["assets","assets:cash","assets:checking","equity","equity:opening balances","expenses","expenses:vacation"]
     ]

hledger.hs

@@ -6,8 +6,8 @@
 module Main -- almost all IO is handled here
 where
 
-import System (getArgs)
+import System
-import Data.List (isPrefixOf)
+import Data.List
 import Test.HUnit (runTestTT)
 import Test.QuickCheck (quickCheck)
 import Text.ParserCombinators.Parsec (parseFromFile, ParseError)
@@ -33,32 +33,32 @@ main = do
 
 test :: IO ()      
 test = do
-  putStrLn "hunit "
+  hcounts <- runTestTT tests
-  runTestTT tests
+  qcounts <- mapM quickCheck props
-  putStr "quickcheck "
+  --print $ "hunit: " ++ (showHunitCounts hcounts)
-  mapM quickCheck props
+  --print $ "quickcheck: " ++ (concat $ intersperse " " $ map show qcounts)
   return ()
+    where showHunitCounts c =
+              reverse $ tail $ reverse ("passed " ++ (unwords $ drop 5 $ words (show c)))
 
 register :: [String] -> IO ()
 register args = do 
-  p <- parseLedgerFile ledgerFilePath
+  getLedgerFilePath >>= parseLedgerFile >>= doWithParsed (printRegister args)
-  case p of Left e -> parseError e
-            Right l -> printRegister l
 
 balance :: [String] -> IO ()
-balance args = do 
+balance args = 
-  p <- parseLedgerFile ledgerFilePath
+    return ()
-  case p of Left e -> parseError e
-            Right l -> printBalances l
 
 -- utils
 
-parseLedgerFile :: IO String -> IO (Either ParseError Ledger)
+-- doWithLedgerFile =
-parseLedgerFile f = f >>= parseFromFile ledger
+--     getLedgerFilePath >>= parseLedgerFile >>= doWithParsed
 
-printRegister :: Ledger -> IO ()
+doWithParsed :: (a -> IO ()) -> (Either ParseError a) -> IO ()
-printRegister l = putStr $ showRegisterEntries (entries l) 0
+doWithParsed a p = 
-
+  case p of Left e -> parseError e
-printBalances :: Ledger -> IO ()
+            Right v -> a v
-printBalances l = putStr $ showRegisterEntries (entries l) 0
 
+printRegister :: [String] -> Ledger -> IO ()
+printRegister args ledger =
+    putStr $ showEntriesWithBalances (entriesMatching (head (args ++ [""])) ledger) 0