diff --git a/Makefile b/Makefile index bd2b03cfa..ef8fa72f3 100644 --- a/Makefile +++ b/Makefile @@ -1,5 +1,5 @@ build: - ghc --make hledger.hs + ghc --make -O2 hledger.hs Tags: hasktags *hs diff --git a/Parse.hs b/Parse.hs index e7f800d4e..1a1b75044 100644 --- a/Parse.hs +++ b/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 []} diff --git a/Tests.hs b/Tests.hs index 9146f29c7..87c15a9e9 100644 --- a/Tests.hs +++ b/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 () diff --git a/Types.hs b/Types.hs index b1f2a55d5..03f635920 100644 --- a/Types.hs +++ b/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] \ No newline at end of file diff --git a/hledger.hs b/hledger.hs index 52a7a2c40..d830f2371 100644 --- a/hledger.hs +++ b/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