slaesvuo/hledger
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

much refactoring, get quickcheck working, beginnings of account matching

Browse Source
This commit is contained in:
Simon Michael 2007-02-10 23:24:33 +00:00
parent 080d567f15
commit 6bf13fb262
6 changed files with 168 additions and 105 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

111
Models.hs
View File

@ -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
-- ignores currency conversion
-- 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)
@ -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)]
++ map (\t -> (prependSpace $ show t, amount t)) ts
[firstline] ++ otherlines
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
showEntry e = unlines $ map fst (entryLines e)
-- in the register report we show entries plus a running balance
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'))
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))
str' = str ++ (printf " %10.2s" (show bal'))
-- misc
-- fill in missing amounts etc., as far as possible
autofill :: Entry -> Entry
autofill e = Entry (date e) (status e) (code e) (description e)
autofillEntry :: Entry -> Entry
autofillEntry 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"],
[t | t <- ts, (currency $ amount t) == "AUTO"])
partition isNormal ts
where isNormal t = (currency $ amount t) /= "AUTO"
sumTransactions :: [Transaction] -> Amount
sumTransactions ts = sum [amount t | t <- ts]
transactionsFrom :: [Entry] -> [Transaction]
transactionsFrom es = concat $ map transactions es
transactionsFromEntries :: [Entry] -> [Transaction]
transactionsFromEntries es = concat $ map transactions es
accountsFrom :: [Transaction] -> [Account]
accountsFrom ts = nub $ map account ts
accountsFromTransactions :: [Transaction] -> [Account]
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)

4
Options.hs
View File

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

16
Parse.hs
View File

@ -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 ?
printParseResult r = case r of
Left e -> parseError e
Right v -> print v
-- utils
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

25
TODO
View File

@ -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 per-account balances
show top-level acct 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

61
Tests.hs
View File

@ -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
parse' p ts = parse p "" ts
parseEquals :: Eq a => (Either ParseError a) -> a -> Bool
parseEquals parsed other =
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_parse_ledgertransaction =
test_ledgertransaction :: Assertion
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 [
t "test_parse_ledgertransaction" test_parse_ledgertransaction
, t "test_parse_ledgerentry" test_parse_ledgerentry
, t "test_autofill_entry" test_autofill_entry
test_expandAccounts =
assertEqual'
["assets","assets:cash","assets:checking","expenses","expenses:vacation"]
(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
--prop_test_parse_ledgertransaction =
-- (Transaction "expenses:food:dining" (Amount "$" 10)) ==
-- (parse' ledgertransaction transaction_str))
props = [
prop1
props =
[
(parse' ledgertransaction transaction1_str) `parseEquals`
(Transaction "expenses:food:dining" (Amount "$" 10))
,
(accountTree ledger7) ==
["assets","assets:cash","assets:checking","equity","equity:opening balances","expenses","expenses:vacation"]
]

40
hledger.hs
View File

@ -6,8 +6,8 @@
module Main -- almost all IO is handled here
where
import System (getArgs)
import Data.List (isPrefixOf)
import System
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 "
runTestTT tests
putStr "quickcheck "
mapM quickCheck props
hcounts <- runTestTT tests
qcounts <- mapM quickCheck props
--print $ "hunit: " ++ (showHunitCounts hcounts)
--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
case p of Left e -> parseError e
Right l -> printRegister l
getLedgerFilePath >>= parseLedgerFile >>= doWithParsed (printRegister args)
balance :: [String] -> IO ()
balance args = do
p <- parseLedgerFile ledgerFilePath
case p of Left e -> parseError e
Right l -> printBalances l
balance args =
return ()
-- utils
parseLedgerFile :: IO String -> IO (Either ParseError Ledger)
parseLedgerFile f = f >>= parseFromFile ledger
-- doWithLedgerFile =
-- getLedgerFilePath >>= parseLedgerFile >>= doWithParsed
printRegister :: Ledger -> IO ()
printRegister l = putStr $ showRegisterEntries (entries l) 0
printBalances :: Ledger -> IO ()
printBalances l = putStr $ showRegisterEntries (entries l) 0
doWithParsed :: (a -> IO ()) -> (Either ParseError a) -> IO ()
doWithParsed a p =
case p of Left e -> parseError e
Right v -> a v
printRegister :: [String] -> Ledger -> IO ()
printRegister args ledger =
putStr $ showEntriesWithBalances (entriesMatching (head (args ++ [""])) ledger) 0