register report now has layout, auto-fills missing transaction amounts and shows the running balance

Makefile

@@ -1,5 +1,5 @@
 build:
-	ghc --make hledger.hs
+	ghc --make -O2 hledger.hs
 
 Tags:
 	hasktags *hs

Parse.hs

@@ -179,7 +179,8 @@ ledgerentry = do
   description <- anyChar `manyTill` ledgereol
   transactions <- ledgertransactions
   ledgernondatalines
-  return (Entry date status code description transactions)
+  let entry = Entry date status code description transactions
+  return $ autofill entry
 
 ledgerdate :: Parser String
 ledgerdate = do date <- many1 (digit <|> char '/'); many1 spacenonewline; return date
@@ -212,10 +213,12 @@ ledgeramount :: Parser Amount
 ledgeramount = try (do
                       many1 spacenonewline
                       currency <- many (noneOf "-.0123456789\n") <?> "currency"
-                      quantity <- many1 (oneOf "-.0123456789") <?> "quantity"
-                      return (Amount currency (read quantity))
+                      quantity <- many1 (oneOf "-.,0123456789") <?> "quantity"
+                      return (Amount currency (read $ stripcommas quantity))
                    ) <|> 
-                    return (Amount "" 0)
+                    return (Amount "AUTO" 0)
+
+stripcommas = filter (',' /=)
 
 ledgereol :: Parser String
 ledgereol = ledgercomment <|> do {newline; return []}

Tests.hs

@@ -125,6 +125,22 @@ parse' p ts = parse p "" ts
     
 -- hunit tests
 
+--   parseTest ledgertransaction sample_transaction2
+--   parseTest ledgerentry sample_entry2
+--   parseTest ledgerentry sample_entry3
+--   parseTest ledgerperiodicentry sample_periodic_entry
+--   parseTest ledgerperiodicentry sample_periodic_entry2
+--   parseTest ledgerperiodicentry sample_periodic_entry3
+--   parseTest ledger sample_ledger
+--   parseTest ledger sample_ledger2
+--   parseTest ledger sample_ledger3
+--   parseTest ledger sample_ledger4
+--   parseTest ledger sample_ledger5
+--   parseTest ledger sample_ledger6
+--   parseTest ledger sample_periodic_entry
+--   parseTest ledger sample_periodic_entry2
+--   parseLedgerFile ledgerFilePath >>= printParseResult
+
 test_parse_ledgertransaction :: Assertion
 test_parse_ledgertransaction =
     assertParseEqual
@@ -134,21 +150,20 @@ test_parse_ledgertransaction =
 entry2 =
     (Entry "2007/01/28" False "" "coopportunity" 
                [Transaction "expenses:food:groceries" (Amount "$" 47.18), 
-                Transaction "assets:checking" (Amount "" 0)])
+                Transaction "assets:checking" (Amount "$" (-47.18))])
 
 test_parse_ledgerentry =
-  assertParseEqual entry2 (parse' ledgerentry sample_entry2)
-
-test_show_entry =
-  assertEqual'
-    "2007/01/28 coopportunity\n    expenses:food:groceries                                 $47.18\n    assets:checking                                            0.0\n"
-    (show entry2)
+    assertParseEqual entry2 (parse' ledgerentry sample_entry2)
 
+test_autofill_entry = 
+    assertEqual'
+      (Amount "$" (-47.18))
+      (amount $ last $ transactions $ autofill entry2)
 
 hunittests = TestList [
                        test "test_parse_ledgertransaction" test_parse_ledgertransaction
                       , test "test_parse_ledgerentry" test_parse_ledgerentry
---                      , test "test_show_entry" test_show_entry
+                      , test "test_autofill_entry" test_autofill_entry
                       ] 
     where test label fn = TestLabel label $ TestCase fn
 
@@ -170,20 +185,6 @@ prop1 = 1 == 1
 test :: IO ()      
 test = do
   runTestTT hunittests
-  runTestTT hunittests2
-  quickCheck prop1
-  parseTest ledgertransaction sample_transaction2
-  parseTest ledgerentry sample_entry2
---   parseTest ledgerentry sample_entry3
---   parseTest ledgerperiodicentry sample_periodic_entry
---   parseTest ledgerperiodicentry sample_periodic_entry2
---   parseTest ledgerperiodicentry sample_periodic_entry3
---   parseTest ledger sample_ledger
---   parseTest ledger sample_ledger2
---   parseTest ledger sample_ledger3
---   parseTest ledger sample_ledger4
---   parseTest ledger sample_ledger5
---   parseTest ledger sample_ledger6
---   parseTest ledger sample_periodic_entry
---   parseTest ledger sample_periodic_entry2
---   parseLedgerFile ledgerFilePath >>= printParseResult
+--  runTestTT hunittests2
+--  quickCheck prop1
+  return ()

Types.hs

@@ -29,12 +29,25 @@ data Transaction = Transaction {
                                } deriving (Eq)
 data Amount = Amount {
                       currency :: String,
-                      quantity :: Float
+                      quantity :: Double
                      } deriving (Eq)
 type Date = String
 type Account = String
 
--- show methods
+-- Amount arithmetic
+-- ignores currency conversion
+instance Num Amount where
+    abs (Amount c q) = Amount c (abs q)
+    signum (Amount c q) = Amount c (signum q)
+    fromInteger i = Amount "$" (fromInteger i)
+    (+) = amountAdd
+    (-) = amountSub
+    (*) = amountMult
+Amount ca qa `amountAdd` Amount cb qb = Amount ca (qa + qb)
+Amount ca qa `amountSub` Amount cb qb = Amount ca (qa - qb)
+Amount ca qa `amountMult` Amount cb qb = Amount ca (qa * qb)
+
+-- show & display methods
 
 instance Show Ledger where
     show l = "Ledger with " ++ m ++ " modifier, " ++ p ++ " periodic, " ++ e ++ " normal entries:\n"
@@ -52,32 +65,98 @@ instance Show ModifierEntry where
 instance Show PeriodicEntry where 
     show e = "~ " ++ (periodexpr e) ++ "\n" ++ unlines (map show (p_transactions e))
 
-instance Show Entry where show = showEntry2
+instance Show Entry where show = showEntry
 
-showEntry1 e = date e ++ " " ++ s ++ c ++ d ++ "\n" ++ unlines (map show (transactions e))
+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 -> ""}
 
-dateWidth = 10
-descWidth = 20
-acctWidth = 25
-amtWidth = 11
+-- a register entry is displayed as two or more lines like this:
+-- date       description          account                    amount     balance
 
-showEntry2 e = 
-    unlines (
-             [printf "%-10s %-20s " (date e) (take 20 $ description e)
-                         ++ (show $ head $ transactions e)]
-             ++ map ((printf (take 32 (repeat ' ')) ++) . show) (tail $ transactions e))
+-- DDDDDDDDDD dddddddddddddddddddd aaaaaaaaaaaaaaaaaaaaaaaaa  AAAAAAAAAA AAAAAAAAAA
+--                                 aaaaaaaaaaaaaaaaaaaaaaaaa  AAAAAAAAAA AAAAAAAAAA
+--                                 ...                        ...        ...
+-- dateWidth = 10
+-- descWidth = 20
+-- acctWidth = 25
+-- amtWidth  = 10
+-- balWidth  = 10
+
+-- convert an Entry to entry lines (string, amount pairs)
+entryLines :: Entry -> [(String,Amount)]
+entryLines e =
+    [(entrydesc ++ (show t), amount t)]
+    ++ 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 ' ')) ++)
 
 instance Show Transaction where 
-    show t = printf "%-25s  %8.2s %8.2s" (take 25 $ account t) (show $ amount t) (show 0)
+    show t = printf "%-25s  %10s " (take 25 $ account t) (show $ amount t)
 
-instance Show Amount where show a = (currency a) ++ (show $ quantity a)
+instance Show Amount where
+    show (Amount cur qty) = 
+        let roundedqty = printf "%.2f" qty in
+        case roundedqty of
+          "0.00" -> "0"
+          otherwise -> cur ++ roundedqty
 
--- more display methods
+showEntry :: Entry -> String
+showEntry e = unlines $ map fst (entryLines e)
+
+-- 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'))
+
+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))
 
 printRegister :: Ledger -> IO ()
-printRegister l = do
-    putStr $ concat $ map show $ entries l
+printRegister l = putStr $ showRegisterEntries (entries l) 0
+
+-- misc
+
+transactionsFrom :: [Entry] -> [Transaction]
+transactionsFrom es = concat $ map transactions es
+
+-- fill in missing amounts etc., as far as possible
+autofill :: Entry -> Entry
+autofill e = Entry (date e) (status e) (code e) (description e)
+             (autofillTransactions (transactions e))
+
+autofillTransactions :: [Transaction] -> [Transaction]
+autofillTransactions ts =
+    let (ns,as) = normalAndAutoTransactions ts in
+    case (length as) of
+      0 -> ns
+      1 -> let t = head as 
+               newamt = -(sumTransactions ns)
+           in 
+             ns ++ [Transaction (account t) newamt]
+      otherwise -> error "too many blank transactions in this entry"
+
+normalAndAutoTransactions :: [Transaction] -> ([Transaction], [Transaction])
+normalAndAutoTransactions ts =
+    ([t | t <- ts, (currency $ amount t) /= "AUTO"],
+     [t | t <- ts, (currency $ amount t) == "AUTO"])
+
+sumTransactions :: [Transaction] -> Amount
+sumTransactions ts = sum [amount t | t <- ts]

hledger.hs

@@ -13,10 +13,11 @@ import Tests
 main :: IO ()
 main = do
   (opts, args) <- getArgs >>= getOptions
+  test
   if "reg" `elem` args
     then register
-    else if "test" `elem` args 
-         then test
+--     else if "test" `elem` args 
+--          then test
          else return ()
 
 -- commands