hledger 0.1 → 0.2
raw patch · 24 files changed
+1568/−750 lines, 24 filesdep −QuickCheck
Dependencies removed: QuickCheck
Files
- BalanceCommand.hs +55/−52
- Ledger/Account.hs +7/−4
- Ledger/AccountName.hs +75/−0
- Ledger/Amount.hs +110/−38
- Ledger/Commodity.hs +18/−20
- Ledger/Dates.hs +83/−0
- Ledger/Entry.hs +42/−49
- Ledger/Ledger.hs +27/−49
- Ledger/Parse.hs +146/−27
- Ledger/RawLedger.hs +71/−59
- Ledger/RawTransaction.hs +16/−17
- Ledger/TimeLog.hs +8/−9
- Ledger/Transaction.hs +7/−5
- Ledger/Types.hs +16/−14
- Ledger/Utils.hs +68/−26
- Options.hs +52/−21
- PrintCommand.hs +4/−1
- README +153/−20
- RegisterCommand.hs +35/−29
- Tests.hs +502/−280
- Utils.hs +28/−12
- hledger.cabal +27/−7
- hledger.hs +15/−11
- sample.ledger +3/−0
BalanceCommand.hs view
@@ -29,7 +29,7 @@ $1 liabilities @ -With -s (--showsubs), also show the subaccounts:+With -s (--subtotal), also show the subaccounts: @ $-1 assets@@ -88,7 +88,7 @@ - with an account pattern, it shows accounts whose leafname matches, plus their parents -- with the showsubs option, it also shows all subaccounts of the above+- with the subtotal option, it also shows all subaccounts of the above - zero-balance leaf accounts are removed @@ -117,68 +117,71 @@ balance :: [Opt] -> [String] -> Ledger -> IO () balance opts args l = putStr $ showBalanceReport opts args l --- | Generate balance report output for a ledger, based on options.+-- | Generate balance report output for a ledger. showBalanceReport :: [Opt] -> [String] -> Ledger -> String-showBalanceReport opts args l = acctsstr ++ totalstr+showBalanceReport opts args l = acctsstr ++ (if collapse then "" else totalstr) where - acctsstr = concatMap (showAccountTreeWithBalances acctnamestoshow) $ subs treetoshow- totalstr = if isZeroAmount total + acctsstr = concatMap showatree $ subs t+ showatree t = showAccountTreeWithBalances matchedacctnames t+ matchedacctnames = balancereportacctnames l sub apats t+ t = (if empty then id else pruneZeroBalanceLeaves) $ ledgerAccountTree maxdepth l+ apats = fst $ parseAccountDescriptionArgs args+ maxdepth = fromMaybe 9999 $ depthFromOpts opts+ sub = SubTotal `elem` opts || (isJust $ depthFromOpts opts)+ empty = Empty `elem` opts+ collapse = Collapse `elem` opts+ totalstr = if isZeroMixedAmount total then "" - else printf "--------------------\n%20s\n" $ showAmount total- showingsubs = ShowSubs `elem` opts- pats@(apats,dpats) = parseAccountDescriptionArgs args- maxdepth = if null args && not showingsubs then 1 else 9999- acctstoshow = balancereportaccts showingsubs apats l- acctnamestoshow = map aname acctstoshow- treetoshow = pruneZeroBalanceLeaves $ pruneUnmatchedAccounts $ treeprune maxdepth $ ledgerAccountTree 9999 l- total = sumAmounts $ map abalance $ nonredundantaccts- nonredundantaccts = filter (not . hasparentshowing) acctstoshow- hasparentshowing a = (parentAccountName $ aname a) `elem` acctnamestoshow-- -- select accounts for which we should show balances, based on the options- balancereportaccts :: Bool -> [String] -> Ledger -> [Account]- balancereportaccts False [] l = topAccounts l- balancereportaccts False pats l = accountsMatching pats l- balancereportaccts True pats l = addsubaccts l $ balancereportaccts False pats l+ else printf "--------------------\n%s\n" $ padleft 20 $ showMixedAmount total+ total = sum $ map (abalance . ledgerAccount l) $ nonredundantaccts+ nonredundantaccts = filter (not . hasparentshowing) matchedacctnames+ hasparentshowing aname = (parentAccountName $ aname) `elem` matchedacctnames - -- add (in tree order) any missing subacccounts to a list of accounts+-- | Identify the accounts we are interested in seeing balances for in the+-- balance report, based on the -s flag and account patterns. See Tests.hs.+balancereportacctnames :: Ledger -> Bool -> [String] -> Tree Account -> [AccountName]+balancereportacctnames l False [] t = filter (/= "top") $ map aname $ flatten $ treeprune 1 t+balancereportacctnames l False pats t = filter (/= "top") $ ns+ where + ns = filter (matchpats_balance pats) $ map aname $ flatten t'+ t' | null $ positivepats pats = treeprune 1 t+ | otherwise = t+balancereportacctnames l True pats t = nub $ map aname $ addsubaccts l $ as+ where + as = map (ledgerAccount l) ns+ ns = balancereportacctnames l False pats t+ -- add (in tree order) any missing subaccounts to a list of accounts addsubaccts :: Ledger -> [Account] -> [Account] addsubaccts l as = concatMap addsubs as where addsubs = maybe [] flatten . ledgerAccountTreeAt l - -- remove any accounts from the tree which are not one of the acctstoshow, - -- or one of their parents, or one of their subaccounts when doing --showsubs- pruneUnmatchedAccounts :: Tree Account -> Tree Account- pruneUnmatchedAccounts = treefilter matched- where - matched (Account name _ _)- | name `elem` acctnamestoshow = True- | any (name `isAccountNamePrefixOf`) acctnamestoshow = True- | showingsubs && any (`isAccountNamePrefixOf` name) acctnamestoshow = True- | otherwise = False-- -- remove zero-balance leaf accounts (recursively)- pruneZeroBalanceLeaves :: Tree Account -> Tree Account- pruneZeroBalanceLeaves = treefilter (not . isZeroAmount . abalance)+-- | Remove all sub-trees whose accounts have a zero balance.+pruneZeroBalanceLeaves :: Tree Account -> Tree Account+pruneZeroBalanceLeaves = treefilter (not . isZeroMixedAmount . abalance) --- | Show a tree of accounts with balances, for the balance report,--- eliding boring parent accounts. Requires a list of the account names we--- are interested in to help with that.+-- | Show this tree of accounts with balances, eliding boring parent+-- accounts and omitting uninteresting subaccounts based on the provided+-- list of account names we want to see balances for. showAccountTreeWithBalances :: [AccountName] -> Tree Account -> String-showAccountTreeWithBalances matchedacctnames = - showAccountTreeWithBalances' matchedacctnames 0 ""+showAccountTreeWithBalances matchednames t = showAccountTreeWithBalances' matchednames 0 "" t where showAccountTreeWithBalances' :: [AccountName] -> Int -> String -> Tree Account -> String- showAccountTreeWithBalances' matchedacctnames indentlevel prefix (Node (Account fullname _ bal) subs) =- if isboringparent then showsubswithprefix else showacct ++ showsubswithindent+ showAccountTreeWithBalances' matchednames indent prefix (Node (Account fullname _ bal) subs)+ | isboringparent && hasmatchedsubs = subsprefixed+ | ismatched = this ++ subsindented+ | otherwise = subsnoindent where- showsubswithprefix = showsubs indentlevel (fullname++":")- showsubswithindent = showsubs (indentlevel+1) ""- showsubs i p = concatMap (showAccountTreeWithBalances' matchedacctnames i p) subs- showacct = showbal ++ " " ++ indent ++ prefix ++ leafname ++ "\n"- showbal = printf "%20s" $ show bal- indent = replicate (indentlevel * 2) ' '+ subsprefixed = showsubs indent (prefix++leafname++":")+ subsnoindent = showsubs indent ""+ subsindented = showsubs (indent+1) ""+ showsubs i p = concatMap (showAccountTreeWithBalances' matchednames i p) subs+ hasmatchedsubs = any ((`elem` matchednames) . aname) $ concatMap flatten subs+ amt = padleft 20 $ showMixedAmount bal+ this = concatTopPadded [amt, spaces ++ prefix ++ leafname] ++ "\n"+ spaces = " " ++ replicate (indent * 2) ' ' leafname = accountLeafName fullname+ ismatched = fullname `elem` matchednames+ isboringparent = numsubs >= 1 && (bal == subbal || not matched) numsubs = length subs subbal = abalance $ root $ head subs- matched = fullname `elem` matchedacctnames- isboringparent = numsubs >= 1 && (bal == subbal || not matched)+ matched = fullname `elem` matchednames+
Ledger/Account.hs view
@@ -1,7 +1,7 @@ {-| -An 'Account' stores an account name, all transactions in the account-(excluding any subaccounts), and the total balance (including any+An 'Account' stores, for efficiency: an 'AccountName', all transactions in+the account (excluding subaccounts), and the account balance (including subaccounts). -}@@ -14,7 +14,10 @@ instance Show Account where- show (Account a ts b) = printf "Account %s with %d txns and %s balance" a (length ts) (show b)+ show (Account a ts b) = printf "Account %s with %d txns and %s balance" a (length ts) (showMixedAmount b) -nullacct = Account "" [] nullamt+instance Eq Account where+ (==) (Account n1 t1 b1) (Account n2 t2 b2) = n1 == n2 && t1 == t2 && b1 == b2++nullacct = Account "" [] nullmixedamt
Ledger/AccountName.hs view
@@ -99,3 +99,78 @@ | (length $ accountNameFromComponents $ done++ss) <= width = done++ss | length ss > 1 = elideparts width (done++[take 2 $ head ss]) (tail ss) | otherwise = done++ss+++-- -- | Check if a set of ledger account/description patterns matches the+-- -- given account name or entry description. Patterns are case-insensitive+-- -- regular expression strings; those beginning with - are anti-patterns.+-- -- +-- -- Call with forbalancereport=True to mimic ledger's balance report+-- -- matching. Account patterns usually match the full account name, but in+-- -- balance reports when the pattern does not contain : and is not an+-- -- anti-pattern, it matches only the leaf name.+-- matchpats :: Bool -> [String] -> String -> Bool+-- matchpats forbalancereport pats str =+-- (null positives || any ismatch positives) && (null negatives || not (any ismatch negatives))+-- where +-- isnegative = (== negativepatternchar) . head+-- (negatives,positives) = partition isnegative pats+-- ismatch pat = containsRegex (mkRegexWithOpts pat' True True) matchee+-- where +-- pat' = if isnegative pat then drop 1 pat else pat+-- matchee = if forbalancereport && not (':' `elem` pat) && not (isnegative pat)+-- then accountLeafName str+-- else str++-- | Check if a set of ledger account/description patterns matches the+-- given account name or entry description. Patterns are case-insensitive+-- regular expression strings; those beginning with - are anti-patterns.+matchpats :: [String] -> String -> Bool+matchpats pats str =+ (null positives || any match positives) && (null negatives || not (any match negatives))+ where+ (negatives,positives) = partition isnegativepat pats+ match "" = True+ match pat = matchregex (abspat pat) str++-- | Similar to matchpats, but follows the special behaviour of ledger+-- 2.6's balance command: positive patterns which do not contain : match+-- the account leaf name, other patterns match the full account name.+matchpats_balance :: [String] -> String -> Bool+matchpats_balance pats str = match_positive_pats pats str && (not $ match_negative_pats pats str)+-- (null positives || any match positives) && (null negatives || not (any match negatives))+-- where+-- (negatives,positives) = partition isnegativepat pats+-- match "" = True+-- match pat = matchregex (abspat pat) matchee+-- where +-- matchee = if not (':' `elem` pat) && not (isnegativepat pat)+-- then accountLeafName str+-- else str++-- | Do the positives in these patterns permit a match for this string ?+match_positive_pats :: [String] -> String -> Bool+match_positive_pats pats str = (null ps) || (any match ps)+ where+ ps = positivepats pats+ match "" = True+ match p = matchregex (abspat p) matchee+ where + matchee | ':' `elem` p = str+ | otherwise = accountLeafName str++-- | Do the negatives in these patterns prevent a match for this string ?+match_negative_pats :: [String] -> String -> Bool+match_negative_pats pats str = (not $ null ns) && (any match ns)+ where+ ns = map abspat $ negativepats pats+ match "" = True+ match p = matchregex (abspat p) str++negativepatternchar = '-'+isnegativepat pat = (== [negativepatternchar]) $ take 1 pat+abspat pat = if isnegativepat pat then drop 1 pat else pat+positivepats = filter (not . isnegativepat)+negativepats = filter isnegativepat+matchregex pat str = containsRegex (mkRegexWithOpts pat True True) str+
Ledger/Amount.hs view
@@ -1,7 +1,7 @@ {-| An 'Amount' is some quantity of money, shares, or anything else. -A simple amount is a commodity, quantity pair (where commodity can be anything):+A simple amount is a 'Commodity', quantity pair: @ $1 @@ -13,13 +13,14 @@ 0 @ -A mixed amount (not yet implemented) is one or more simple amounts:+A 'MixedAmount' is zero or more simple amounts: @ $50, EUR 3, AAPL 500 16h, $13.55, oranges 6 @ +Not implemented: Commodities may be convertible or not. A mixed amount containing only convertible commodities can be converted to a simple amount. Arithmetic examples:@@ -38,23 +39,73 @@ module Ledger.Amount where+import qualified Data.Map as Map import Ledger.Utils import Ledger.Types import Ledger.Commodity instance Show Amount where show = showAmount+instance Show MixedAmount where show = showMixedAmount +instance Num Amount where+ abs (Amount c q p) = Amount c (abs q) p+ signum (Amount c q p) = Amount c (signum q) p+ fromInteger i = Amount (comm "") (fromInteger i) Nothing+ (+) = amountop (+)+ (-) = amountop (-)+ (*) = amountop (*)++instance Ord Amount where+ compare (Amount ac aq ap) (Amount bc bq bp) = compare (ac,aq,ap) (bc,bq,bp)++instance Num MixedAmount where+ fromInteger i = Mixed [Amount (comm "") (fromInteger i) Nothing]+ negate (Mixed as) = Mixed $ map negateAmountPreservingPrice as+ (+) (Mixed as) (Mixed bs) = normaliseMixedAmount $ Mixed $ filter (not . isZeroAmount) $ as ++ bs+ (*) = error "programming error, mixed amounts do not support multiplication"+ abs = error "programming error, mixed amounts do not support abs"+ signum = error "programming error, mixed amounts do not support signum"++instance Ord MixedAmount where+ compare (Mixed as) (Mixed bs) = compare as bs++negateAmountPreservingPrice a = (-a){price=price a}++-- | Apply a binary arithmetic operator to two amounts - converting to the+-- second one's commodity, adopting the lowest precision, and discarding+-- any price information. (Using the second commodity is best since sum+-- and other folds start with a no-commodity amount.)+amountop :: (Double -> Double -> Double) -> Amount -> Amount -> Amount+amountop op a@(Amount ac aq ap) b@(Amount bc bq bp) = + Amount bc ((quantity $ convertAmountTo bc a) `op` bq) Nothing++-- | Convert an amount to the commodity of its saved price, if any.+costOfAmount :: Amount -> Amount+costOfAmount a@(Amount _ _ Nothing) = a+costOfAmount a@(Amount _ q (Just price))+ | isZeroMixedAmount price = nullamt+ | otherwise = Amount pc (pq*q) Nothing+ where (Amount pc pq _) = head $ amounts price++-- | Convert an amount to the specified commodity using the appropriate+-- exchange rate (which is currently always 1).+convertAmountTo :: Commodity -> Amount -> Amount+convertAmountTo c2 (Amount c1 q p) = Amount c2 (q * conversionRate c1 c2) Nothing+ -- | Get the string representation of an amount, based on its commodity's -- display settings. showAmount :: Amount -> String-showAmount (Amount (Commodity {symbol=sym,side=side,spaced=spaced,comma=comma,precision=p}) q)- | side==L = printf "%s%s%s" sym space quantity- | side==R = printf "%s%s%s" quantity space sym+showAmount (Amount (Commodity {symbol=sym,side=side,spaced=spaced,comma=comma,precision=p}) q pri)+ | sym=="AUTO" = "" -- can display one of these in an error message+ | side==L = printf "%s%s%s%s" sym space quantity price+ | side==R = printf "%s%s%s%s" quantity space sym price where space = if spaced then " " else "" quantity = commad $ printf ("%."++show p++"f") q commad = if comma then punctuatethousands else id+ price = case pri of (Just pamt) -> " @ " ++ showMixedAmount pamt+ Nothing -> "" -- | Add thousands-separating commas to a decimal number string punctuatethousands :: String -> String@@ -67,44 +118,65 @@ triples [] = [] triples l = [take 3 l] ++ (triples $ drop 3 l) --- | Get the string representation of an amount, rounded, or showing just "0" if it's zero.-showAmountOrZero :: Amount -> String-showAmountOrZero a- | isZeroAmount a = "0"- | otherwise = showAmount a---- | is this amount zero, when displayed with its given precision ?+-- | Does this amount appear to be zero when displayed with its given precision ? isZeroAmount :: Amount -> Bool-isZeroAmount a@(Amount c _ ) = nonzerodigits == ""+isZeroAmount a = nonzerodigits == "" where nonzerodigits = filter (`elem` "123456789") $ showAmount a -instance Num Amount where- abs (Amount c q) = Amount c (abs q)- signum (Amount c q) = Amount c (signum q)- fromInteger i = Amount (comm "") (fromInteger i)- (+) = amountop (+)- (-) = amountop (-)- (*) = amountop (*)+-- | Access a mixed amount's components.+amounts :: MixedAmount -> [Amount]+amounts (Mixed as) = as --- | Apply a binary arithmetic operator to two amounts, converting to the--- second one's commodity and adopting the lowest precision. (Using the--- second commodity means that folds (like sum [Amount]) will preserve the--- commodity.)-amountop :: (Double -> Double -> Double) -> Amount -> Amount -> Amount-amountop op a@(Amount ac aq) b@(Amount bc bq) = - Amount bc ((quantity $ convertAmountTo bc a) `op` bq)+-- | Does this mixed amount appear to be zero - empty, or+-- containing only simple amounts which appear to be zero ?+isZeroMixedAmount :: MixedAmount -> Bool+isZeroMixedAmount = all isZeroAmount . amounts . normaliseMixedAmount --- | Convert an amount to the specified commodity using the appropriate--- exchange rate.-convertAmountTo :: Commodity -> Amount -> Amount-convertAmountTo c2 (Amount c1 q) = Amount c2 (q * conversionRate c1 c2)+-- | Get the string representation of a mixed amount, showing each of+-- its component amounts.+showMixedAmount :: MixedAmount -> String+showMixedAmount m = concat $ intersperse "\n" $ map showfixedwidth as+ where + (Mixed as) = normaliseMixedAmount m+ width = maximum $ map (length . show) $ as+ showfixedwidth = printf (printf "%%%ds" width) . show --- | Sum a list of amounts. This is still needed because a final zero--- amount will discard the sum's commodity.-sumAmounts :: [Amount] -> Amount-sumAmounts = sum . filter (not . isZeroAmount)+-- | Get the string representation of a mixed amount, and if it+-- appears to be all zero just show a bare 0, ledger-style.+showMixedAmountOrZero :: MixedAmount -> String+showMixedAmountOrZero a+ | isZeroMixedAmount a = "0"+ | otherwise = showMixedAmount a -nullamt = Amount (comm "") 0+-- | Simplify a mixed amount by combining any component amounts which have+-- the same commodity and the same price.+normaliseMixedAmount :: MixedAmount -> MixedAmount+normaliseMixedAmount (Mixed as) = Mixed as'+ where + as' = map sumAmountsPreservingPrice $ group $ sort as+ sort = sortBy cmpsymbolandprice+ cmpsymbolandprice a1 a2 = compare (sym a1,price a1) (sym a2,price a2)+ group = groupBy samesymbolandprice + samesymbolandprice a1 a2 = (sym a1 == sym a2) && (price a1 == price a2)+ sym = symbol . commodity --- temporary value for partial entries-autoamt = Amount (Commodity {symbol="AUTO",side=L,spaced=False,comma=False,precision=0,rate=1}) 0+sumAmountsPreservingPrice [] = nullamt+sumAmountsPreservingPrice as = (sum as){price=price $ head as}++-- | Convert a mixed amount's component amounts to the commodity of their+-- saved price, if any.+costOfMixedAmount :: MixedAmount -> MixedAmount+costOfMixedAmount (Mixed as) = Mixed $ map costOfAmount as++-- | The empty simple amount.+nullamt :: Amount+nullamt = Amount unknown 0 Nothing++-- | The empty mixed amount.+nullmixedamt :: MixedAmount+nullmixedamt = Mixed []++-- | A temporary value for parsed transactions which had no amount specified.+missingamt :: MixedAmount+missingamt = Mixed [Amount (Commodity {symbol="AUTO",side=L,spaced=False,comma=False,precision=0}) 0 Nothing]+
Ledger/Commodity.hs view
@@ -1,9 +1,9 @@ {-| A 'Commodity' is a symbol representing a currency or some other kind of-thing we are tracking, and some settings that tell how to display amounts-of the commodity. For the moment, commodities also include a hard-coded-conversion rate relative to the dollar.+thing we are tracking, and some display preferences that tell how to+display 'Amount's of the commodity - is the symbol on the left or right,+are thousands separated by comma, significant decimal places and so on. -} module Ledger.Commodity@@ -13,30 +13,28 @@ import Ledger.Types --- for nullamt, autoamt, etc.-unknown = Commodity {symbol="",side=L,spaced=False,comma=False,precision=0,rate=1}- -- convenient amount and commodity constructors, for tests etc. -dollar = Commodity {symbol="$",side=L,spaced=False,comma=False,precision=2,rate=1}-euro = Commodity {symbol="EUR",side=L,spaced=False,comma=False,precision=2,rate=0.760383}-pound = Commodity {symbol="£",side=L,spaced=False,comma=False,precision=2,rate=0.512527}-hour = Commodity {symbol="h",side=R,spaced=False,comma=False,precision=1,rate=100}+unknown = Commodity {symbol="", side=L,spaced=False,comma=False,precision=0}+dollar = Commodity {symbol="$", side=L,spaced=False,comma=False,precision=2}+euro = Commodity {symbol="EUR",side=L,spaced=False,comma=False,precision=2}+pound = Commodity {symbol="£", side=L,spaced=False,comma=False,precision=2}+hour = Commodity {symbol="h", side=R,spaced=False,comma=False,precision=1} -dollars = Amount dollar-euros = Amount euro-pounds = Amount pound-hours = Amount hour+dollars n = Amount dollar n Nothing+euros n = Amount euro n Nothing+pounds n = Amount pound n Nothing+hours n = Amount hour n Nothing defaultcommodities = [dollar, euro, pound, hour, unknown] -defaultcommoditiesmap :: Map.Map String Commodity-defaultcommoditiesmap = Map.fromList [(symbol c :: String, c :: Commodity) | c <- defaultcommodities]-+-- | Look up one of the hard-coded default commodities. For use in tests. comm :: String -> Commodity-comm symbol = Map.findWithDefault (error "commodity lookup failed") symbol defaultcommoditiesmap+comm sym = fromMaybe + (error "commodity lookup failed") + $ find (\(Commodity{symbol=s}) -> s==sym) defaultcommodities --- | Find the conversion rate between two commodities.+-- | Find the conversion rate between two commodities. Currently returns 1. conversionRate :: Commodity -> Commodity -> Double-conversionRate oldc newc = (rate newc) / (rate oldc)+conversionRate oldc newc = 1
+ Ledger/Dates.hs view
@@ -0,0 +1,83 @@+{-|++Types for Dates and DateTimes, implemented in terms of UTCTime++-}++module Ledger.Dates+--(+-- Date, +-- DateTime,+-- mkDate,+-- mkDateTime,+-- parsedatetime,+-- parsedate,+-- datetimeToDate,+-- elapsedSeconds,+-- today+-- ) +where++import Data.Time.Clock+import Data.Time.Format+import Data.Time.Calendar+import Data.Time.LocalTime+import System.Locale (defaultTimeLocale)+import Text.Printf+import Data.Maybe++newtype Date = Date UTCTime+ deriving (Ord, Eq)++newtype DateTime = DateTime UTCTime+ deriving (Ord, Eq)++instance Show Date where+ show (Date t) = formatTime defaultTimeLocale "%Y/%m/%d" t++instance Show DateTime where + show (DateTime t) = formatTime defaultTimeLocale "%Y/%m/%d %H:%M:%S" t++mkDate :: Day -> Date+mkDate day = Date (localTimeToUTC utc (LocalTime day midnight))++mkDateTime :: Day -> TimeOfDay -> DateTime+mkDateTime day tod = DateTime (localTimeToUTC utc (LocalTime day tod))++-- | Parse a date-time string to a time type, or raise an error.+parsedatetime :: String -> DateTime+parsedatetime s = DateTime $+ parsetimewith "%Y/%m/%d %H:%M:%S" s $+ error $ printf "could not parse timestamp \"%s\"" s++-- | Parse a date string to a time type, or raise an error.+parsedate :: String -> Date+parsedate s = Date $+ parsetimewith "%Y/%m/%d" s $+ error $ printf "could not parse date \"%s\"" s++-- | Parse a time string to a time type using the provided pattern, or+-- return the default.+parsetimewith :: ParseTime t => String -> String -> t -> t+parsetimewith pat s def = fromMaybe def $ parseTime defaultTimeLocale pat s++datetimeToDate :: DateTime -> Date+datetimeToDate (DateTime (UTCTime{utctDay=day})) = Date (UTCTime day 0)++elapsedSeconds :: Fractional a => DateTime -> DateTime -> a+elapsedSeconds (DateTime dt1) (DateTime dt2) = realToFrac $ diffUTCTime dt1 dt2++today :: IO Date+today = getCurrentTime >>= return . Date++dateToUTC :: Date -> UTCTime+dateToUTC (Date u) = u++dateComponents :: Date -> (Integer,Int,Int)+dateComponents = toGregorian . utctDay . dateToUTC++-- dateDay :: Date -> Day+dateDay date = d where (_,_,d) = dateComponents date++-- dateMonth :: Date -> Day+dateMonth date = m where (_,m,_) = dateComponents date
Ledger/Entry.hs view
@@ -1,7 +1,7 @@ {-| -An 'Entry' represents a regular entry in the ledger file. It contains two-or more 'RawTransaction's whose sum must be zero.+An 'Entry' represents a regular entry in the ledger file. It normally+contains two or more balanced 'RawTransaction's. -} @@ -15,62 +15,41 @@ instance Show Entry where show = showEntry -{--Helpers for the register report. A register entry is displayed as two-or more lines like this:--@-date description account amount balance-DDDDDDDDDD dddddddddddddddddddd aaaaaaaaaaaaaaaaaaaaaa AAAAAAAAAAA AAAAAAAAAAAA- aaaaaaaaaaaaaaaaaaaaaa AAAAAAAAAAA AAAAAAAAAAAA- ... ... ...--datewidth = 10-descwidth = 20-acctwidth = 22-amtwidth = 11-balwidth = 12-@--}--showEntryDescription e = - (showDate $ edate e) ++ " " ++ (showDescription $ edescription e) ++ " "-showDate d = printf "%-10s" d-showDescription s = printf "%-20s" (elideRight 20 s)--isEntryBalanced :: Entry -> Bool-isEntryBalanced (Entry {etransactions=ts}) = isZeroAmount sum && numcommodities==1- where- sum = sumLedgerTransactions ts- numcommodities = length $ nub $ map (symbol . commodity . tamount) ts+instance Show ModifierEntry where + show e = "= " ++ (valueexpr e) ++ "\n" ++ unlines (map show (m_transactions e)) -autofillEntry :: Entry -> Entry-autofillEntry e@(Entry {etransactions=ts}) = e{etransactions=autofillTransactions ts}+instance Show PeriodicEntry where + show e = "~ " ++ (periodexpr e) ++ "\n" ++ unlines (map show (p_transactions e)) -assertBalancedEntry :: Entry -> Entry-assertBalancedEntry e- | isEntryBalanced e = e- | otherwise = error $ "transactions don't balance in:\n" ++ show e+nullentry = Entry {+ edate=parsedate "1900/1/1", + estatus=False, + ecode="", + edescription="", + ecomment="",+ etransactions=[],+ epreceding_comment_lines=""+ } {-|-Helper for the print command which shows cleaned up ledger file-entries, something like:+Show a ledger entry, formatted for the print command. ledger 2.x's+standard format looks like this: @ yyyy/mm/dd[ *][ CODE] description......... [ ; comment...............] account name 1..................... ...$amount1[ ; comment...............] account name 2..................... ..$-amount1[ ; comment...............] -pcodewidth = no limit -- 10-pdescwidth = no limit -- 20-pacctwidth = 35 minimum, no maximum+pcodewidth = no limit -- 10 -- mimicking ledger layout.+pdescwidth = no limit -- 20 -- I don't remember what these mean,+pacctwidth = 35 minimum, no maximum -- they were important at the time. pamtwidth = 11 pcommentwidth = no limit -- 22 @ -} showEntry :: Entry -> String showEntry e = - unlines $ [precedingcomment ++ description] ++ (showtxns $ etransactions e) ++ [""]+ unlines $ [{-precedingcomment ++ -}description] ++ (showtxns $ etransactions e) ++ [""] where precedingcomment = epreceding_comment_lines e description = concat [date, status, code, desc] -- , comment]@@ -84,15 +63,29 @@ showtxn t = showacct t ++ " " ++ (showamount $ tamount t) ++ (showcomment $ tcomment t) showtxnnoamt t = showacct t ++ " " ++ (showcomment $ tcomment t) showacct t = " " ++ (showaccountname $ taccount t)- showamount = printf "%12s" . showAmount+ showamount = printf "%12s" . showMixedAmount showaccountname s = printf "%-34s" s showcomment s = if (length s) > 0 then " ; "++s else "" --- modifier & periodic entries--instance Show ModifierEntry where - show e = "= " ++ (valueexpr e) ++ "\n" ++ unlines (map show (m_transactions e))+showDate d = printf "%-10s" (show d) -instance Show PeriodicEntry where - show e = "~ " ++ (periodexpr e) ++ "\n" ++ unlines (map show (p_transactions e))+isEntryBalanced :: Entry -> Bool+isEntryBalanced (Entry {etransactions=ts}) = + isZeroMixedAmount $ sum $ map tamount $ filter isReal ts +-- | Fill in a missing balance in this entry, if we have enough+-- information to do that. Excluding virtual transactions, there should be+-- at most one missing balance. Otherwise, raise an error.+-- The new balance will be converted to cost basis if possible.+balanceEntry :: Entry -> Entry+balanceEntry e@Entry{etransactions=ts} = e{etransactions=ts'}+ where + (withamounts, missingamounts) = partition hasAmount $ filter isReal ts+ ts' = case (length missingamounts) of+ 0 -> ts+ 1 -> map balance ts+ otherwise -> error $ "could not balance this entry, too many missing amounts:\n" ++ show e+ otherstotal = sum $ map tamount withamounts+ balance t+ | isReal t && not (hasAmount t) = t{tamount = costOfMixedAmount (-otherstotal)}+ | otherwise = t
Ledger/Ledger.hs view
@@ -1,8 +1,8 @@ {-| A 'Ledger' stores, for efficiency, a 'RawLedger' plus its tree of account-names, a map from account names to 'Account's, and the display precision.-Typically it has also has had the uninteresting 'Entry's filtered out.+names, and a map from account names to 'Account's. It may also have had+uninteresting 'Entry's and 'Transaction's filtered out. -} @@ -14,6 +14,7 @@ import Ledger.Types import Ledger.Amount import Ledger.AccountName+import Ledger.Account import Ledger.Transaction import Ledger.RawLedger import Ledger.Entry@@ -28,28 +29,29 @@ (showtree $ accountnametree l) -- | Convert a raw ledger to a more efficient cached type, described above. -cacheLedger :: RawLedger -> Ledger-cacheLedger l = - let - ant = rawLedgerAccountNameTree l- anames = flatten ant- ts = rawLedgerTransactions l- sortedts = sortBy (comparing account) ts- groupedts = groupBy (\t1 t2 -> account t1 == account t2) sortedts- txnmap = Map.union +cacheLedger :: [String] -> RawLedger -> Ledger+cacheLedger apats l = Ledger l ant amap+ where+ ant = rawLedgerAccountNameTree l+ anames = flatten ant+ ts = filtertxns apats $ rawLedgerTransactions l+ sortedts = sortBy (comparing account) ts+ groupedts = groupBy (\t1 t2 -> account t1 == account t2) sortedts+ txnmap = Map.union (Map.fromList [(account $ head g, g) | g <- groupedts]) (Map.fromList [(a,[]) | a <- anames])- txnsof = (txnmap !)- subacctsof a = filter (isAccountNamePrefixOf a) anames- subtxnsof a = concat [txnsof a | a <- [a] ++ subacctsof a]- balmap = Map.union - (Map.fromList [(a, (sumTransactions $ subtxnsof a)) | a <- anames])- (Map.fromList [(a,nullamt) | a <- anames])- amap = Map.fromList [(a, Account a (txnmap ! a) (balmap ! a)) | a <- anames]- in- Ledger l ant amap+ txnsof = (txnmap !)+ subacctsof a = filter (a `isAccountNamePrefixOf`) anames+ subtxnsof a = concat [txnsof a | a <- [a] ++ subacctsof a]+ balmap = Map.union + (Map.fromList [(a,(sumTransactions $ subtxnsof a)) | a <- anames])+ (Map.fromList [(a,Mixed []) | a <- anames])+ amap = Map.fromList [(a, Account a (txnmap ! a) (balmap ! a)) | a <- anames] --- | List a 'Ledger' 's account names.+filtertxns :: [String] -> [Transaction] -> [Transaction]+filtertxns apats ts = filter (matchpats apats . account) ts++-- | List a ledger's account names. accountnames :: Ledger -> [AccountName] accountnames l = drop 1 $ flatten $ accountnametree l @@ -66,46 +68,22 @@ topAccounts l = map root $ branches $ ledgerAccountTree 9999 l -- | Accounts in ledger whose name matches the pattern, in tree order.--- We apply ledger's special rules for balance report account matching--- (see 'matchLedgerPatterns'). accountsMatching :: [String] -> Ledger -> [Account]-accountsMatching pats l = filter (matchLedgerPatterns True pats . aname) $ accounts l+accountsMatching pats l = filter (matchpats pats . aname) $ accounts l -- | List a ledger account's immediate subaccounts subAccounts :: Ledger -> Account -> [Account]-subAccounts l a = map (ledgerAccount l) subacctnames- where- allnames = accountnames l- name = aname a- subacctnames = filter (name `isAccountNamePrefixOf`) allnames+subAccounts l Account{aname=a} = + map (ledgerAccount l) $ filter (a `isAccountNamePrefixOf`) $ accountnames l -- | List a ledger's transactions.------ NB this sets the amount precisions to that of the highest-precision--- amount, to help with report output. It should perhaps be done in the--- display functions, but those are far removed from the ledger. Keep in--- mind if doing more arithmetic with these. ledgerTransactions :: Ledger -> [Transaction] ledgerTransactions l = rawLedgerTransactions $ rawledger l -- | Get a ledger's tree of accounts to the specified depth. ledgerAccountTree :: Int -> Ledger -> Tree Account-ledgerAccountTree depth l = - addDataToAccountNameTree l depthpruned- where- nametree = accountnametree l- depthpruned = treeprune depth nametree---- that's weird.. why can't this be in Account.hs ?-instance Eq Account where- (==) (Account n1 t1 b1) (Account n2 t2 b2) = n1 == n2 && t1 == t2 && b1 == b2+ledgerAccountTree depth l = treemap (ledgerAccount l) $ treeprune depth $ accountnametree l -- | Get a ledger's tree of accounts rooted at the specified account. ledgerAccountTreeAt :: Ledger -> Account -> Maybe (Tree Account) ledgerAccountTreeAt l acct = subtreeat acct $ ledgerAccountTree 9999 l---- | Convert a tree of account names into a tree of accounts, using their--- parent ledger.-addDataToAccountNameTree :: Ledger -> Tree AccountName -> Tree Account-addDataToAccountNameTree = treemap . ledgerAccount-
Ledger/Parse.hs view
@@ -19,6 +19,8 @@ import Ledger.Entry import Ledger.Commodity import Ledger.TimeLog+import Data.Time.LocalTime+import Data.Time.Calendar -- utils@@ -169,14 +171,14 @@ modifier_entries <- many ledgermodifierentry periodic_entries <- many ledgerperiodicentry - entries <- (many ledgerentry) <?> "entry"+ entries <- (many $ try ledgerentry) <?> "entry" final_comment_lines <- ledgernondatalines eof return $ RawLedger modifier_entries periodic_entries entries (unlines final_comment_lines) ledgernondatalines :: Parser [String]-ledgernondatalines = many (ledgerdirective <|> -- treat as comments- commentline <|> +ledgernondatalines = many (try ledgerdirective <|> -- treat as comments+ try commentline <|> blankline) ledgerdirective :: Parser String@@ -189,6 +191,7 @@ commentline :: Parser String commentline = do+ many spacenonewline char ';' <?> "comment line" l <- restofline return $ ";" ++ l@@ -231,18 +234,34 @@ comment <- ledgercomment restofline transactions <- ledgertransactions- return $ assertBalancedEntry $ autofillEntry $ Entry date status code description comment transactions (unlines preceding)+ return $ balanceEntry $ Entry date status code description comment transactions (unlines preceding) -ledgerdate :: Parser String-ledgerdate = do +ledgerday :: Parser Day+ledgerday = do y <- many1 digit char '/' m <- many1 digit char '/' d <- many1 digit- many1 spacenonewline- return $ printf "%04s/%02s/%02s" y m d+ many spacenonewline+ return (fromGregorian (read y) (read m) (read d)) +ledgerdate :: Parser Date+ledgerdate = fmap mkDate ledgerday++ledgerdatetime :: Parser DateTime+ledgerdatetime = do + day <- ledgerday+ h <- many1 digit+ char ':'+ m <- many1 digit+ s <- optionMaybe $ do+ char ':'+ many1 digit+ many spacenonewline+ return (mkDateTime day (TimeOfDay (read h) (read m) (maybe 0 (fromIntegral.read) s)))++ ledgerstatus :: Parser Bool ledgerstatus = try (do { char '*'; many1 spacenonewline; return True } ) <|> return False @@ -250,7 +269,9 @@ ledgercode = try (do { char '('; code <- anyChar `manyTill` char ')'; many1 spacenonewline; return code } ) <|> return "" ledgertransactions :: Parser [RawTransaction]-ledgertransactions = (ledgertransaction <?> "transaction") `manyTill` (do {newline <?> "blank line"; return ()} <|> eof)+ledgertransactions = + ((try virtualtransaction <|> try balancedvirtualtransaction <|> ledgertransaction) <?> "transaction") + `manyTill` (do {newline <?> "blank line"; return ()} <|> eof) ledgertransaction :: Parser RawTransaction ledgertransaction = do@@ -260,55 +281,96 @@ many spacenonewline comment <- ledgercomment restofline- return (RawTransaction account amount comment)+ return (RawTransaction account amount comment RegularTransaction) +virtualtransaction :: Parser RawTransaction+virtualtransaction = do+ many1 spacenonewline+ char '('+ account <- ledgeraccountname+ char ')'+ amount <- transactionamount+ many spacenonewline+ comment <- ledgercomment+ restofline+ return (RawTransaction account amount comment VirtualTransaction)++balancedvirtualtransaction :: Parser RawTransaction+balancedvirtualtransaction = do+ many1 spacenonewline+ char '['+ account <- ledgeraccountname+ char ']'+ amount <- transactionamount+ many spacenonewline+ comment <- ledgercomment+ restofline+ return (RawTransaction account amount comment BalancedVirtualTransaction)+ -- | account names may have single spaces inside them, and are terminated by two or more spaces ledgeraccountname :: Parser String ledgeraccountname = do accountname <- many1 (accountnamechar <|> singlespace) return $ striptrailingspace accountname where - accountnamechar = alphaNum <|> oneOf ":/_" <?> "account name character" singlespace = try (do {spacenonewline; do {notFollowedBy spacenonewline; return ' '}}) -- couldn't avoid consuming a final space sometimes, harmless striptrailingspace s = if last s == ' ' then init s else s -transactionamount :: Parser Amount+accountnamechar = notFollowedBy (oneOf "()[]") >> nonspace+ <?> "account name character (non-bracket, non-parenthesis, non-whitespace)"++transactionamount :: Parser MixedAmount transactionamount = try (do many1 spacenonewline- a <- try leftsymbolamount <|> try rightsymbolamount <|> nosymbolamount <|> return autoamt+ a <- someamount <|> return missingamt return a- ) <|> return autoamt+ ) <|> return missingamt -leftsymbolamount :: Parser Amount+someamount = try leftsymbolamount <|> try rightsymbolamount <|> nosymbolamount ++leftsymbolamount :: Parser MixedAmount leftsymbolamount = do sym <- commoditysymbol sp <- many spacenonewline (q,p,comma) <- amountquantity- let c = Commodity {symbol=sym,side=L,spaced=not $ null sp,comma=comma,precision=p,rate=1}- return $ Amount c q+ pri <- priceamount+ let c = Commodity {symbol=sym,side=L,spaced=not $ null sp,comma=comma,precision=p}+ return $ Mixed [Amount c q pri] <?> "left-symbol amount" -rightsymbolamount :: Parser Amount+rightsymbolamount :: Parser MixedAmount rightsymbolamount = do (q,p,comma) <- amountquantity sp <- many spacenonewline sym <- commoditysymbol- let c = Commodity {symbol=sym,side=R,spaced=not $ null sp,comma=comma,precision=p,rate=1}- return $ Amount c q+ pri <- priceamount+ let c = Commodity {symbol=sym,side=R,spaced=not $ null sp,comma=comma,precision=p}+ return $ Mixed [Amount c q pri] <?> "right-symbol amount" -nosymbolamount :: Parser Amount+nosymbolamount :: Parser MixedAmount nosymbolamount = do (q,p,comma) <- amountquantity- let c = Commodity {symbol="",side=L,spaced=False,comma=comma,precision=p,rate=1}- return $ Amount c q+ pri <- priceamount+ let c = Commodity {symbol="",side=L,spaced=False,comma=comma,precision=p}+ return $ Mixed [Amount c q pri] <?> "no-symbol amount" commoditysymbol :: Parser String commoditysymbol = many1 (noneOf "-.0123456789;\n ") <?> "commodity symbol" +priceamount :: Parser (Maybe MixedAmount)+priceamount =+ try (do+ many spacenonewline+ char '@'+ many spacenonewline+ a <- someamount+ return $ Just a+ ) <|> return Nothing+ -- gawd.. trying to parse a ledger number without error: -- | parse a ledger-style numeric quantity and also return the number of@@ -359,7 +421,9 @@ whiteSpace1 :: Parser () whiteSpace1 = do space; whiteSpace +nonspace = satisfy (not . isSpace) + {-| Parse a timelog file. Here is the timelog grammar, from timeclock.el 2.6: @@@ -407,10 +471,7 @@ many (commentline <|> blankline) code <- oneOf "bhioO" many1 spacenonewline- date <- ledgerdate- time <- many $ oneOf "0123456789:"- let datetime = date ++ " " ++ time- many spacenonewline+ datetime <- ledgerdatetime comment <- restofline return $ TimeLogEntry code datetime comment @@ -419,3 +480,61 @@ tl <- timelog return $ ledgerFromTimeLog tl ++-- misc parsing+{-| +Parse a date in any of the formats allowed in ledger's period expressions:++> 2004+> 2004/10+> 2004/10/1+> 10/1+> october+> oct+> this week # or day, month, quarter, year+> next week+> last week+-}+smartdate :: Parser (String,String,String)+smartdate = do+ (y,m,d) <- (+ try ymd + <|> try ym + <|> try y+-- <|> try md+-- <|> try month+-- <|> try mon+-- <|> try thiswhatever+-- <|> try nextwhatever+-- <|> try lastwhatever+ )+ return $ (y,m,d)++datesep = oneOf "/-."++ymd :: Parser (String,String,String)+ymd = do+ y <- many digit+ datesep+ m <- many digit+ datesep+ d <- many digit+ return (y,m,d)++ym :: Parser (String,String,String)+ym = do+ y <- many digit+ datesep+ m <- many digit+ return (y,m,"1")++y :: Parser (String,String,String)+y = do+ y <- many digit+ return (y,"1","1")++-- | Parse a flexible date string, with awareness of the current time,+-- | and return a Date or raise an error.+smartparsedate :: String -> Date+smartparsedate s = parsedate $ printf "%04s/%02s/%02s" y m d+ where (y,m,d) = fromparse $ parsewith smartdate s
Ledger/RawLedger.hs view
@@ -11,12 +11,12 @@ import Ledger.Utils import Ledger.Types import Ledger.AccountName+import Ledger.Amount import Ledger.Entry import Ledger.Transaction+import Ledger.RawTransaction -negativepatternchar = '-'- instance Show RawLedger where show l = printf "RawLedger with %d entries, %d accounts: %s" ((length $ entries l) +@@ -28,10 +28,8 @@ where accounts = flatten $ rawLedgerAccountNameTree l rawLedgerTransactions :: RawLedger -> [Transaction]-rawLedgerTransactions = txns . entries- where- txns :: [Entry] -> [Transaction]- txns es = concat $ map flattenEntry $ zip es (iterate (+1) 1)+rawLedgerTransactions = txnsof . entries+ where txnsof es = concat $ map flattenEntry $ zip es [1..] rawLedgerAccountNamesUsed :: RawLedger -> [AccountName] rawLedgerAccountNamesUsed = accountNamesFromTransactions . rawLedgerTransactions@@ -44,72 +42,86 @@ -- | Remove ledger entries we are not interested in. -- Keep only those which fall between the begin and end dates, and match--- the description pattern.-filterRawLedger :: String -> String -> [String] -> RawLedger -> RawLedger-filterRawLedger begin end pats = +-- the description pattern, and are cleared or real if those options are active.+filterRawLedger :: Maybe Date -> Maybe Date -> [String] -> Bool -> Bool -> RawLedger -> RawLedger+filterRawLedger begin end pats clearedonly realonly = + filterRawLedgerTransactionsByRealness realonly .+ filterRawLedgerEntriesByClearedStatus clearedonly . filterRawLedgerEntriesByDate begin end . filterRawLedgerEntriesByDescription pats --- | Keep only entries whose description matches the description pattern.+-- | Keep only entries whose description matches the description patterns. filterRawLedgerEntriesByDescription :: [String] -> RawLedger -> RawLedger filterRawLedgerEntriesByDescription pats (RawLedger ms ps es f) = RawLedger ms ps (filter matchdesc es) f- where- matchdesc :: Entry -> Bool- matchdesc = matchLedgerPatterns False pats . edescription+ where matchdesc = matchpats pats . edescription -- | Keep only entries which fall between begin and end dates. -- We include entries on the begin date and exclude entries on the end -- date, like ledger. An empty date string means no restriction.-filterRawLedgerEntriesByDate :: String -> String -> RawLedger -> RawLedger+filterRawLedgerEntriesByDate :: Maybe Date -> Maybe Date -> RawLedger -> RawLedger filterRawLedgerEntriesByDate begin end (RawLedger ms ps es f) = RawLedger ms ps (filter matchdate es) f- where- matchdate :: Entry -> Bool- matchdate e = (begin == "" || entrydate >= begindate) && - (end == "" || entrydate < enddate)- where - begindate = parsedate begin :: UTCTime- enddate = parsedate end- entrydate = parsedate $ edate e+ where + matchdate e = (maybe True (edate e>=) begin) && (maybe True (edate e<) end) +-- | Keep only entries with cleared status, if the flag is true, otherwise+-- do no filtering.+filterRawLedgerEntriesByClearedStatus :: Bool -> RawLedger -> RawLedger+filterRawLedgerEntriesByClearedStatus False l = l+filterRawLedgerEntriesByClearedStatus True (RawLedger ms ps es f) =+ RawLedger ms ps (filter estatus es) f --- | Check if a set of ledger account/description patterns matches the--- given account name or entry description, applying ledger's special--- cases. --- --- Patterns are case-insensitive regular expression strings, and those--- beginning with - are negative patterns. The special case is that--- account patterns match the full account name except in balance reports--- when the pattern does not contain : and is a positive pattern, where it--- matches only the leaf name.-matchLedgerPatterns :: Bool -> [String] -> String -> Bool-matchLedgerPatterns forbalancereport pats str =- (null positives || any ismatch positives) && (null negatives || (not $ any ismatch negatives))- where - isnegative = (== negativepatternchar) . head- (negatives,positives) = partition isnegative pats- ismatch pat = containsRegex (mkRegexWithOpts pat' True True) matchee- where - pat' = if isnegative pat then drop 1 pat else pat- matchee = if forbalancereport && (not $ ':' `elem` pat) && (not $ isnegative pat)- then accountLeafName str- else str+-- | Strip out any virtual transactions, if the flag is true, otherwise do+-- no filtering.+filterRawLedgerTransactionsByRealness :: Bool -> RawLedger -> RawLedger+filterRawLedgerTransactionsByRealness False l = l+filterRawLedgerTransactionsByRealness True (RawLedger ms ps es f) =+ RawLedger ms ps (map filtertxns es) f+ where filtertxns e@Entry{etransactions=ts} = e{etransactions=filter isReal ts} --- | Give amounts the display settings of the first one detected in each commodity.-normaliseRawLedgerAmounts :: RawLedger -> RawLedger-normaliseRawLedgerAmounts l@(RawLedger ms ps es f) = RawLedger ms ps es' f+-- | Keep only entries which affect accounts matched by the account patterns.+filterRawLedgerEntriesByAccount :: [String] -> RawLedger -> RawLedger+filterRawLedgerEntriesByAccount apats (RawLedger ms ps es f) =+ RawLedger ms ps (filter (any (matchpats apats . taccount) . etransactions) es) f++-- | Give all a ledger's amounts their canonical display settings. That+-- is, in each commodity, amounts will use the display settings of the+-- first amount detected, and the greatest precision of the amounts+-- detected. Also, amounts are converted to cost basis if that flag is+-- active.+canonicaliseAmounts :: Bool -> RawLedger -> RawLedger+canonicaliseAmounts costbasis l@(RawLedger ms ps es f) = RawLedger ms ps (map fixEntryAmounts es) f where - es' = map normaliseEntryAmounts es- normaliseEntryAmounts (Entry d s c desc comm ts pre) = Entry d s c desc comm ts' pre- where ts' = map normaliseRawTransactionAmounts ts- normaliseRawTransactionAmounts (RawTransaction acct a c) = RawTransaction acct a' c- where a' = normaliseAmount a- normaliseAmount (Amount c q) = Amount (firstoccurrenceof c) q- firstcommodities = nubBy samesymbol $ allcommodities- allcommodities = map (commodity . amount) $ rawLedgerTransactions l- samesymbol (Commodity {symbol=s1}) (Commodity {symbol=s2}) = s1==s2- firstoccurrenceof c@(Commodity {symbol=s}) = - fromMaybe- (error "failed to normalise commodity") -- shouldn't happen- (find (\(Commodity {symbol=sym}) -> sym==s) firstcommodities)+ fixEntryAmounts (Entry d s c de co ts pr) = Entry d s c de co (map fixRawTransactionAmounts ts) pr+ fixRawTransactionAmounts (RawTransaction ac a c t) = RawTransaction ac (fixMixedAmount a) c t+ fixMixedAmount (Mixed as) = Mixed $ map fixAmount as+ fixAmount | costbasis = fixcommodity . costOfAmount+ | otherwise = fixcommodity+ fixcommodity a = a{commodity=canonicalcommodity $ commodity a}+ canonicalcommodity c = (firstoccurrenceof c){precision=maxprecision c}+ where+ firstoccurrenceof c = head $ rawLedgerCommoditiesWithSymbol l (symbol c)+ maxprecision c = maximum $ map precision $ rawLedgerCommoditiesWithSymbol l (symbol c)++-- | Get all amount commodities with a given symbol, in the order parsed.+-- Must be called with a good symbol or it will fail.+rawLedgerCommoditiesWithSymbol :: RawLedger -> String -> [Commodity]+rawLedgerCommoditiesWithSymbol l s = + fromMaybe (error $ "no such commodity "++s) (Map.lookup s map)+ where+ map = Map.fromList [(symbol $ head cs,cs) | cs <- groupBy same $ rawLedgerCommodities l]+ same c1 c2 = symbol c1 == symbol c2++-- | Get just the ammount commodities from a ledger, in the order parsed.+rawLedgerCommodities :: RawLedger -> [Commodity]+rawLedgerCommodities = map commodity . concatMap amounts . rawLedgerAmounts++-- | Get just the amounts from a ledger, in the order parsed.+rawLedgerAmounts :: RawLedger -> [MixedAmount]+rawLedgerAmounts = map amount . rawLedgerTransactions++-- | Get just the amount precisions from a ledger, in the order parsed.+rawLedgerPrecisions :: RawLedger -> [Int]+rawLedgerPrecisions = map precision . rawLedgerCommodities+
Ledger/RawTransaction.hs view
@@ -13,24 +13,23 @@ import Ledger.AccountName -instance Show RawTransaction where show = showLedgerTransaction+instance Show RawTransaction where show = showRawTransaction -showLedgerTransaction :: RawTransaction -> String-showLedgerTransaction t = (showaccountname $ taccount t) ++ " " ++ (showamount $ tamount t) +nullrawtxn = RawTransaction "" nullmixedamt "" RegularTransaction++showRawTransaction :: RawTransaction -> String+showRawTransaction (RawTransaction a amt _ ttype) = + concatTopPadded [showaccountname a ++ " ", showamount amt] where- showaccountname = printf "%-22s" . elideAccountName 22- showamount = printf "%12s" . showAmountOrZero+ showaccountname = printf "%-22s" . bracket . elideAccountName width+ (bracket,width) = case ttype of+ BalancedVirtualTransaction -> (\s -> "["++s++"]", 20)+ VirtualTransaction -> (\s -> "("++s++")", 20)+ otherwise -> (id,22)+ showamount = padleft 12 . showMixedAmountOrZero -autofillTransactions :: [RawTransaction] -> [RawTransaction]-autofillTransactions ts =- case (length blanks) of- 0 -> ts- 1 -> map balance ts- otherwise -> error "too many blank transactions in this entry"- where - (normals, blanks) = partition isnormal ts- isnormal t = (symbol $ commodity $ tamount t) /= "AUTO"- balance t = if isnormal t then t else t{tamount = -(sumLedgerTransactions normals)}+isReal :: RawTransaction -> Bool+isReal t = rttype t == RegularTransaction -sumLedgerTransactions :: [RawTransaction] -> Amount-sumLedgerTransactions = sumAmounts . map tamount+hasAmount :: RawTransaction -> Bool+hasAmount = (/= missingamt) . tamount
Ledger/TimeLog.hs view
@@ -15,7 +15,7 @@ instance Show TimeLogEntry where - show t = printf "%s %s %s" (show $ tlcode t) (tldatetime t) (tlcomment t)+ show t = printf "%s %s %s" (show $ tlcode t) (show $ tldatetime t) (tlcomment t) instance Show TimeLog where show tl = printf "TimeLog with %d entries" $ length $ timelog_entries tl@@ -52,12 +52,11 @@ } where acctname = tlcomment i- indate = showdate intime- outdate = showdate outtime- showdate = formatTime defaultTimeLocale "%Y/%m/%d"- intime = parsedatetime $ tldatetime i- outtime = parsedatetime $ tldatetime o- amount = hours $ realToFrac (diffUTCTime outtime intime) / 3600- txns = [RawTransaction acctname amount ""- --,RawTransaction "assets:time" (-amount) ""+ indate = datetimeToDate intime+ outdate = datetimeToDate outtime+ intime = tldatetime i+ outtime = tldatetime o+ amount = Mixed [hours $ elapsedSeconds outtime intime / 3600]+ txns = [RawTransaction acctname amount "" RegularTransaction+ --,RawTransaction "assets:time" (-amount) "" RegularTransaction ]
Ledger/Transaction.hs view
@@ -14,20 +14,22 @@ import Ledger.Amount -instance Show Transaction where - show (Transaction eno d desc a amt) = unwords [d,desc,a,show amt]+instance Show Transaction where show=showTransaction +showTransaction :: Transaction -> String+showTransaction (Transaction eno d desc a amt ttype) = unwords [show d,desc,a,show amt,show ttype]+ -- | Convert a 'Entry' to two or more 'Transaction's. An id number -- is attached to the transactions to preserve their grouping - it should -- be unique per entry. flattenEntry :: (Entry, Int) -> [Transaction] flattenEntry (Entry d _ _ desc _ ts _, e) = - [Transaction e d desc (taccount t) (tamount t) | t <- ts]+ [Transaction e d desc (taccount t) (tamount t) (rttype t) | t <- ts] accountNamesFromTransactions :: [Transaction] -> [AccountName] accountNamesFromTransactions ts = nub $ map account ts -sumTransactions :: [Transaction] -> Amount+sumTransactions :: [Transaction] -> MixedAmount sumTransactions = sum . map amount -nulltxn = Transaction 0 "" "" "" nullamt+nulltxn = Transaction 0 (parsedate "1900/1/1") "" "" nullmixedamt RegularTransaction
Ledger/Types.hs view
@@ -11,11 +11,9 @@ import qualified Data.Map as Map -type Date = String--type DateTime = String+type AccountName = String -data Side = L | R deriving (Eq,Show) +data Side = L | R deriving (Eq,Show,Ord) data Commodity = Commodity { symbol :: String, -- ^ the commodity's symbol@@ -24,22 +22,25 @@ side :: Side, -- ^ should the symbol appear on the left or the right spaced :: Bool, -- ^ should there be a space between symbol and quantity comma :: Bool, -- ^ should thousands be comma-separated- precision :: Int, -- ^ number of decimal places to display-- rate :: Double -- ^ the current (hard-coded) conversion rate against the dollar- } deriving (Eq,Show)+ precision :: Int -- ^ number of decimal places to display+ } deriving (Eq,Show,Ord) data Amount = Amount { commodity :: Commodity,- quantity :: Double+ quantity :: Double,+ price :: Maybe MixedAmount -- ^ optional per-unit price for this amount at the time of entry } deriving (Eq) -type AccountName = String+newtype MixedAmount = Mixed [Amount] deriving (Eq) +data TransactionType = RegularTransaction | VirtualTransaction | BalancedVirtualTransaction+ deriving (Eq,Show)+ data RawTransaction = RawTransaction { taccount :: AccountName,- tamount :: Amount,- tcomment :: String+ tamount :: MixedAmount,+ tcomment :: String,+ rttype :: TransactionType } deriving (Eq) -- | a ledger "modifier" entry. Currently ignored.@@ -86,13 +87,14 @@ date :: Date, description :: String, account :: AccountName,- amount :: Amount+ amount :: MixedAmount,+ ttype :: TransactionType } deriving (Eq) data Account = Account { aname :: AccountName, atransactions :: [Transaction],- abalance :: Amount+ abalance :: MixedAmount } data Ledger = Ledger {
Ledger/Utils.hs view
@@ -11,15 +11,15 @@ --module Data.Map, module Data.Maybe, module Data.Ord,-module Data.Time.Clock,-module Data.Time.Format, module Data.Tree,+module Data.Time.Clock,+module Data.Time.Calendar, module Debug.Trace, module Ledger.Utils,-module System.Locale, module Text.Printf, module Text.Regex, module Test.HUnit,+module Ledger.Dates, ) where import Char@@ -28,18 +28,20 @@ --import qualified Data.Map as Map import Data.Maybe import Data.Ord-import Data.Time.Clock (UTCTime, diffUTCTime)-import Data.Time.Format (ParseTime, parseTime, formatTime) import Data.Tree+import Data.Time.Clock+import Data.Time.Calendar import Debug.Trace-import System.Locale (defaultTimeLocale) import Test.HUnit-import Test.QuickCheck hiding (test, Testable)+-- import Test.QuickCheck hiding (test, Testable) import Text.Printf import Text.Regex import Text.ParserCombinators.Parsec (parse)+import Ledger.Dates +-- strings+ elideLeft width s = case length s > width of True -> ".." ++ (reverse $ take (width - 2) $ reverse s)@@ -50,6 +52,65 @@ True -> take (width - 2) s ++ ".." False -> s +-- | Join multi-line strings as side-by-side rectangular strings of the same height, top-padded.+concatTopPadded :: [String] -> String+concatTopPadded strs = intercalate "\n" $ map concat $ transpose padded+ where+ lss = map lines strs+ h = maximum $ map length lss+ ypad ls = replicate (difforzero h (length ls)) "" ++ ls+ xpad ls = map (padleft w) ls where w | null ls = 0+ | otherwise = maximum $ map length ls+ padded = map (xpad . ypad) lss++-- | Join multi-line strings as side-by-side rectangular strings of the same height, bottom-padded.+concatBottomPadded :: [String] -> String+concatBottomPadded strs = intercalate "\n" $ map concat $ transpose padded+ where+ lss = map lines strs+ h = maximum $ map length lss+ ypad ls = ls ++ replicate (difforzero h (length ls)) ""+ xpad ls = map (padleft w) ls where w | null ls = 0+ | otherwise = maximum $ map length ls+ padded = map (xpad . ypad) lss++-- | Convert a multi-line string to a rectangular string top-padded to the specified height.+padtop :: Int -> String -> String+padtop h s = intercalate "\n" xpadded+ where+ ls = lines s+ sh = length ls+ sw | null ls = 0+ | otherwise = maximum $ map length ls+ ypadded = replicate (difforzero h sh) "" ++ ls+ xpadded = map (padleft sw) ypadded++-- | Convert a multi-line string to a rectangular string bottom-padded to the specified height.+padbottom :: Int -> String -> String+padbottom h s = intercalate "\n" xpadded+ where+ ls = lines s+ sh = length ls+ sw | null ls = 0+ | otherwise = maximum $ map length ls+ ypadded = ls ++ replicate (difforzero h sh) ""+ xpadded = map (padleft sw) ypadded++-- | Convert a multi-line string to a rectangular string left-padded to the specified width.+padleft :: Int -> String -> String+padleft w "" = concat $ replicate w " "+padleft w s = intercalate "\n" $ map (printf (printf "%%%ds" w)) $ lines s++-- | Convert a multi-line string to a rectangular string right-padded to the specified width.+padright :: Int -> String -> String+padright w "" = concat $ replicate w " "+padright w s = intercalate "\n" $ map (printf (printf "%%-%ds" w)) $ lines s++-- math++difforzero :: (Num a, Ord a) => a -> a -> a+difforzero a b = maximum [(a - b), 0]+ -- regexps instance Show Regex where show r = "a Regex"@@ -58,25 +119,6 @@ containsRegex r s = case matchRegex r s of Just _ -> True otherwise -> False---- time---- | Parse a date-time string to a time type, or raise an error.-parsedatetime :: ParseTime t => String -> t-parsedatetime s =- parsetimewith "%Y/%m/%d %H:%M:%S" s $- error $ printf "could not parse timestamp \"%s\"" s---- | Parse a date string to a time type, or raise an error.-parsedate :: ParseTime t => String -> t-parsedate s = - parsetimewith "%Y/%m/%d" s $- error $ printf "could not parse date \"%s\"" s---- | Parse a time string to a time type using the provided pattern, or--- return the default.-parsetimewith :: ParseTime t => String -> String -> t -> t-parsetimewith pat s def = fromMaybe def $ parseTime defaultTimeLocale pat s -- lists
Options.hs view
@@ -3,18 +3,23 @@ import System import System.Console.GetOpt import System.Directory-import Ledger.RawLedger (negativepatternchar)+import Text.Printf+import Ledger.AccountName (negativepatternchar)+import Ledger.Parse (smartparsedate)+import Ledger.Dates usagehdr = "Usage: hledger [OPTS] balance|print|register [ACCTPATS] [-- DESCPATS]\n\nOptions"++warning++":" warning = if negativepatternchar=='-' then " (must appear before command)" else " (can appear anywhere)"-usageftr = "\n\- \Commands (may be abbreviated):\n\- \balance - show account balances\n\- \print - show parsed and reformatted ledger entries\n\- \register - show register transactions\n\- \\n\- \Account and description patterns are regular expressions, optionally prefixed\n\- \with " ++ [negativepatternchar] ++ " to make them negative.\n"+usageftr = "\n" +++ "Commands (may be abbreviated):\n" +++ "balance - show account balances\n" +++ "print - show formatted ledger entries\n" +++ "register - show register transactions\n" +++ "\n" +++ "Account and description patterns are regular expressions, optionally prefixed\n" +++ "with " ++ [negativepatternchar] ++ " to make them negative.\n" +++ "\n" +++ "Also: hledger [-v] test [TESTPATS] to run some or all self-tests.\n" defaultfile = "~/.ledger" fileenvvar = "LEDGER" optionorder = if negativepatternchar=='-' then RequireOrder else Permute@@ -25,8 +30,15 @@ Option ['f'] ["file"] (ReqArg File "FILE") "ledger file; - means use standard input", Option ['b'] ["begin"] (ReqArg Begin "YYYY/MM/DD") "report on entries on or after this date", Option ['e'] ["end"] (ReqArg End "YYYY/MM/DD") "report on entries prior to this date",- Option ['s'] ["showsubs"] (NoArg ShowSubs) "in the balance report, include subaccounts",- Option ['h'] ["help","usage"] (NoArg Help) "show this help",+ Option ['C'] ["cleared"] (NoArg Cleared) "report only on cleared entries",+ Option ['B'] ["cost","basis"] (NoArg CostBasis) "report cost basis of commodities",+ Option [] ["depth"] (ReqArg Depth "N") "balance report: maximum account depth to show",+ Option ['E'] ["empty"] (NoArg Empty) "balance report: show accounts with zero balance",+ Option ['R'] ["real"] (NoArg Real) "report only on real (non-virtual) transactions",+ Option ['n'] ["collapse"] (NoArg Collapse) "balance report: no grand total",+ Option ['s'] ["subtotal"] (NoArg SubTotal) "balance report: show subaccounts",+ Option ['h'] ["help"] (NoArg Help) "show this help",+ Option ['v'] ["verbose"] (NoArg Verbose) "verbose test output", Option ['V'] ["version"] (NoArg Version) "show version" ] @@ -35,14 +47,22 @@ File String | Begin String | End String | - ShowSubs |+ Cleared | + CostBasis | + Depth String | + Empty | + Real | + Collapse |+ SubTotal | Help |+ Verbose | Version deriving (Show,Eq) usage = usageInfo usagehdr options ++ usageftr -version = "hledger version 0.1 alpha\n"+versionno = "0.2"+version = printf "hledger version %s \n" versionno :: String -- | Parse the command-line arguments into ledger options, ledger command -- name, and ledger command arguments@@ -75,29 +95,40 @@ -- return (homeDirectory pw ++ path) tildeExpand xs = return xs --- | get the value of the begin date option, or a default-beginDateFromOpts :: [Opt] -> String+-- | Get the value of the begin date option, if any.+beginDateFromOpts :: [Opt] -> Maybe Date beginDateFromOpts opts = case beginopts of- (x:_) -> last beginopts- _ -> defaultdate+ (x:_) -> Just $ smartparsedate $ last beginopts+ _ -> Nothing where beginopts = concatMap getbegindate opts getbegindate (Begin s) = [s] getbegindate _ = [] defaultdate = "" --- | get the value of the end date option, or a default-endDateFromOpts :: [Opt] -> String+-- | Get the value of the end date option, if any.+endDateFromOpts :: [Opt] -> Maybe Date endDateFromOpts opts = case endopts of- (x:_) -> last endopts- _ -> defaultdate+ (x:_) -> Just $ smartparsedate $ last endopts+ _ -> Nothing where endopts = concatMap getenddate opts getenddate (End s) = [s] getenddate _ = [] defaultdate = ""++-- | Get the value of the depth option, if any.+depthFromOpts :: [Opt] -> Maybe Int+depthFromOpts opts =+ case depthopts of+ (x:_) -> Just $ read x+ _ -> Nothing+ where+ depthopts = concatMap getdepth opts+ getdepth (Depth s) = [s]+ getdepth _ = [] -- | Gather any ledger-style account/description pattern arguments into -- two lists. These are 0 or more account patterns optionally followed by
PrintCommand.hs view
@@ -15,4 +15,7 @@ print' opts args l = putStr $ showEntries opts args l showEntries :: [Opt] -> [String] -> Ledger -> String-showEntries opts args l = concatMap showEntry $ entries $ rawledger l+showEntries opts args l = concatMap showEntry $ filteredentries+ where + filteredentries = entries $ filterRawLedgerEntriesByAccount apats $ rawledger l+ (apats,_) = parseAccountDescriptionArgs args
README view
@@ -1,29 +1,162 @@-hledger - a ledger-compatible text-based accounting tool.+hledger - a ledger-compatible text-based accounting tool+======================================================== +Welcome to hledger! ++hledger is a minimal haskell clone of John Wiegley's "ledger" text-based+accounting tool (http://newartisans.com/software/ledger.html). hledger+generates ledger-compatible register & balance reports from a plain text+ledger file, and demonstrates a functional implementation of ledger. For+more information, see the hledger home page: http://joyful.com/hledger+ Copyright (c) 2007-2008 Simon Michael <simon@joyful.com> Released under GPL version 3 or later. -This is a minimal haskell clone of John Wiegley's ledger-<http://newartisans.com/software/ledger.html>. hledger does basic-register & balance reports, and demonstrates a functional implementation-of ledger. -Installation:+INSTALLATION+------------+In the hledger directory, do:: -runhaskell Setup.hs configure-runhaskell Setup.hs build-sudo runhaskell Setup.hs install - (or symlink dist/build/hledger/hledger into your path)+ cabal install -Examples:+or:: -hledger -f sample.ledger balance-export LEDGER=sample.ledger-hledger -s balance-hledger register-hledger reg cash-hledger reg -- shop+ runhaskell Setup.hs configure+ runhaskell Setup.hs build+ sudo runhaskell Setup.hs install -This version of hledger mimics ledger 2.5 closely, -see the ledger manual for more info:-<http://joyful.com/repos/hledger/doc/ledger.html>.++EXAMPLES+--------+Here are some commands to try::++ hledger --help+ hledger -f sample.ledger balance+ export LEDGER=sample.ledger+ hledger -s balance+ hledger register+ hledger reg cash+ hledger reg -- shop+++FEATURES+--------+This version of hledger mimics a subset of ledger 2.6.1:++- regular ledger entries+- multiple commodities+- virtual transactions+- balance, print, register commands+- positive and negative account & description patterns+- LEDGER environment variable+- and::++ Basic options:+ -h, --help display summarized help text+ -v, --version show version information+ -f, --file FILE read ledger data from FILE+ + Report filtering:+ -b, --begin DATE set report begin date+ -e, --end DATE set report end date+ -C, --cleared consider only cleared transactions+ -R, --real consider only real (non-virtual) transactions+ + Output customization:+ -s, --subtotal balance report: show sub-accounts+ -E, --empty balance report: show accounts with zero balance+ -n, --collapse balance report: no grand total+ + Commodity reporting:+ -B, --basis, --cost report cost basis of commodities++ Commands:+ balance [REGEXP]... show balance totals for matching accounts+ register [REGEXP]... show register of matching transactions+ print [REGEXP]... print all matching entries++hledger-specific features:++ --depth=N balance report: maximum account depth to show+ --cost alias for basis++ledger features not supported:++- !include+- modifier entries+- periodic entries+- commodity pricing+- counting an unfinished timelog session+- parsing gnucash files+- and::++ Basic options:+ -o, --output FILE write output to FILE+ -i, --init-file FILE initialize ledger using FILE (default: ~/.ledgerrc)+ --cache FILE use FILE as a binary cache when --file is not used+ --no-cache don't use a cache, even if it would be appropriate+ -a, --account NAME use NAME for the default account (useful with QIF)+ + Report filtering:+ -c, --current show only current and past entries (not future)+ -p, --period STR report using the given period+ --period-sort EXPR sort each report period's entries by EXPR+ -U, --uncleared consider only uncleared transactions+ -L, --actual consider only actual (non-automated) transactions+ -r, --related calculate report using related transactions+ --budget generate budget entries based on periodic entries+ --add-budget show all transactions plus the budget+ --unbudgeted show only unbudgeted transactions+ --forecast EXPR generate forecast entries while EXPR is true+ -l, --limit EXPR calculate only transactions matching EXPR+ -t, --amount EXPR use EXPR to calculate the displayed amount+ -T, --total EXPR use EXPR to calculate the displayed total+ + Output customization:+ -n, --collapse register: collapse entries+ -s, --subtotal other: show subtotals+ -P, --by-payee show summarized totals by payee+ -x, --comm-as-payee set commodity name as the payee, for reporting+ -W, --weekly show weekly sub-totals+ -M, --monthly show monthly sub-totals+ -Y, --yearly show yearly sub-totals+ --dow show a days-of-the-week report+ -S, --sort EXPR sort report according to the value expression EXPR+ -w, --wide for the default register report, use 132 columns+ --head COUNT show only the first COUNT entries (negative inverts)+ --tail COUNT show only the last COUNT entries (negative inverts)+ --pager PAGER send all output through the given PAGER program+ -A, --average report average transaction amount+ -D, --deviation report deviation from the average+ -%, --percentage report balance totals as a percentile of the parent+ --totals in the "xml" report, include running total+ -j, --amount-data print only raw amount data (useful for scripting)+ -J, --total-data print only raw total data+ -d, --display EXPR display only transactions matching EXPR+ -y, --date-format STR use STR as the date format (default: %Y/%m/%d)+ -F, --format STR use STR as the format; for each report type, use:+ --balance-format --register-format --print-format+ --plot-amount-format --plot-total-format --equity-format+ --prices-format --wide-register-format+ + Commodity reporting:+ --price-db FILE sets the price database to FILE (def: ~/.pricedb)+ -L, --price-exp MINS download quotes only if newer than MINS (def: 1440)+ -Q, --download download price information when needed+ -O, --quantity report commodity totals (this is the default)+ -V, --market report last known market value+ -g, --performance report gain/loss for each displayed transaction+ -G, --gain report net gain/loss+ + Commands:+ xml [REGEXP]... print matching entries in XML format+ equity [REGEXP]... output equity entries for matching accounts+ prices [REGEXP]... display price history for matching commodities+ entry DATE PAYEE AMT output a derived entry, based on the arguments++Some other differences:++- hledger talks about the entry and transaction "description", which ledger calls "note"+- hledger always shows timelog balances in hours+- hledger doesn't require a space after flags like -f+- hledger keeps differently-priced amounts of the same commodity separate, at the moment
RegisterCommand.hs view
@@ -12,36 +12,42 @@ -- | Print a register report. register :: [Opt] -> [String] -> Ledger -> IO ()-register opts args l = putStr $ showTransactionsWithBalances opts args l--showTransactionsWithBalances :: [Opt] -> [String] -> Ledger -> String-showTransactionsWithBalances opts args l =- unlines $ showTransactionsWithBalances' ts nulltxn startingbalance- where- ts = filter matchtxn $ ledgerTransactions l- matchtxn (Transaction _ _ desc acct _) = matchLedgerPatterns False apats acct- apats = fst $ parseAccountDescriptionArgs args- startingbalance = nullamt- showTransactionsWithBalances' :: [Transaction] -> Transaction -> Amount -> [String]- showTransactionsWithBalances' [] _ _ = []- showTransactionsWithBalances' (t:ts) tprev b =- (if sameentry t tprev- then [showTransactionAndBalance t b']- else [showTransactionDescriptionAndBalance t b'])- ++ (showTransactionsWithBalances' ts t b')- where - b' = b + (amount t)- sameentry (Transaction e1 _ _ _ _) (Transaction e2 _ _ _ _) = e1 == e2+register opts args l = putStr $ showRegisterReport opts args l -showTransactionDescriptionAndBalance :: Transaction -> Amount -> String-showTransactionDescriptionAndBalance t b =- (showEntryDescription $ Entry (date t) False "" (description t) "" [] "") - ++ (showLedgerTransaction $ RawTransaction (account t) (amount t) "") ++ (showBalance b)+{- |+Generate the register report. Each ledger entry is displayed as two or+more lines like this: -showTransactionAndBalance :: Transaction -> Amount -> String-showTransactionAndBalance t b =- (replicate 32 ' ') ++ (showLedgerTransaction $ RawTransaction (account t) (amount t) "") ++ (showBalance b)+@+date (10) description (20) account (22) amount (11) balance (12)+DDDDDDDDDD dddddddddddddddddddd aaaaaaaaaaaaaaaaaaaaaa AAAAAAAAAAA AAAAAAAAAAAA+ aaaaaaaaaaaaaaaaaaaaaa AAAAAAAAAAA AAAAAAAAAAAA+ ... ... ...+@+-}+showRegisterReport :: [Opt] -> [String] -> Ledger -> String+showRegisterReport opts args l = showtxns ts nulltxn nullmixedamt+ where+ ts = filter matchtxn $ ledgerTransactions l+ matchtxn Transaction{account=a} = matchpats apats a+ apats = fst $ parseAccountDescriptionArgs args -showBalance :: Amount -> String-showBalance b = printf " %12s" (showAmountOrZero b)+ -- show transactions, one per line, with a running balance+ showtxns [] _ _ = ""+ showtxns (t@Transaction{amount=a}:ts) tprev bal =+ (if isZeroMixedAmount a then "" else this) ++ showtxns ts t bal'+ where+ this = showtxn (t `issame` tprev) t bal'+ issame t1 t2 = entryno t1 == entryno t2+ bal' = bal + amount t + -- show one transaction line, with or without the entry details+ showtxn :: Bool -> Transaction -> MixedAmount -> String+ showtxn omitdesc t b = concatBottomPadded [entrydesc ++ txn ++ " ", bal] ++ "\n"+ where+ entrydesc = if omitdesc then replicate 32 ' ' else printf "%s %s " date desc+ date = show $ da+ desc = printf "%-20s" $ elideRight 20 de :: String+ txn = showRawTransaction $ RawTransaction a amt "" tt+ bal = padleft 12 (showMixedAmountOrZero b)+ Transaction{date=da,description=de,account=a,amount=amt,ttype=tt} = t
Tests.hs view
@@ -11,30 +11,48 @@ import RegisterCommand -runtests = do {putStrLn "Running tests.."; runTestTT $ tconcat [unittests, functests]}--tconcat :: [Test] -> Test-tconcat = foldr (\(TestList as) (TestList bs) -> TestList (as ++ bs)) (TestList []) +runtests opts args = do+ when (Verbose `elem` opts)+ (do+ putStrLn $ printf "Running %d tests%s:" n s+ sequence $ map (putStrLn . tname) $ tflatten flattests; putStrLn "Results:")+ runTestTT flattests+ where+ deeptests = tfilter matchname $ TestList tests+ flattests = TestList $ filter matchname $ concatMap tflatten tests+ matchname = matchpats args . tname+ n = length ts where (TestList ts) = flattests+ s | null args = ""+ | otherwise = printf " matching %s " + (intercalate ", " $ map (printf "\"%s\"") args) ------------------------------------------------------------------------------+-- tests -unittests = TestList [- -- remember to indent assertequal arguments, contrary to haskell-mode auto-indent+tests = [TestList []+ ,misc_tests+ ,balancereportacctnames_tests+ ,balancecommand_tests+ ,printcommand_tests+ ,registercommand_tests+ ]++misc_tests = TestList [ "show dollars" ~: show (dollars 1) ~?= "$1.00" , "show hours" ~: show (hours 1) ~?= "1.0h" , "amount arithmetic" ~: do let a1 = dollars 1.23- let a2 = Amount (comm "$") (-1.23)- let a3 = Amount (comm "$") (-1.23)- assertequal (Amount (comm "$") 0) (a1 + a2)- assertequal (Amount (comm "$") 0) (a1 + a3)- assertequal (Amount (comm "$") (-2.46)) (a2 + a3)- assertequal (Amount (comm "$") (-2.46)) (a3 + a3)- assertequal (Amount (comm "$") (-2.46)) (sum [a2,a3])- assertequal (Amount (comm "$") (-2.46)) (sum [a3,a3])- assertequal (Amount (comm "$") 0) (sum [a1,a2,a3,-a3])+ let a2 = Amount (comm "$") (-1.23) Nothing+ let a3 = Amount (comm "$") (-1.23) Nothing+ assertequal (Amount (comm "$") 0 Nothing) (a1 + a2)+ assertequal (Amount (comm "$") 0 Nothing) (a1 + a3)+ assertequal (Amount (comm "$") (-2.46) Nothing) (a2 + a3)+ assertequal (Amount (comm "$") (-2.46) Nothing) (a3 + a3)+ assertequal (Amount (comm "$") (-2.46) Nothing) (sum [a2,a3])+ assertequal (Amount (comm "$") (-2.46) Nothing) (sum [a3,a3])+ assertequal (Amount (comm "$") 0 Nothing) (sum [a1,a2,a3,-a3]) , "ledgertransaction" ~: do assertparseequal rawtransaction1 (parsewith ledgertransaction rawtransaction1_str)@@ -42,10 +60,10 @@ "ledgerentry" ~: do assertparseequal entry1 (parsewith ledgerentry entry1_str) ,- "autofillEntry" ~: do+ "balanceEntry" ~: do assertequal- (dollars (-47.18))- (tamount $ last $ etransactions $ autofillEntry entry1)+ (Mixed [dollars (-47.18)])+ (tamount $ last $ etransactions $ balanceEntry entry1) , "punctuatethousands" ~: punctuatethousands "" @?= "" ,@@ -66,284 +84,384 @@ (accountnames ledger7) , "cacheLedger" ~: do- assertequal 15 (length $ Map.keys $ accountmap $ cacheLedger rawledger7)+ assertequal 15 (length $ Map.keys $ accountmap $ cacheLedger [] rawledger7) , "transactionamount" ~: do- assertparseequal (dollars 47.18) (parsewith transactionamount " $47.18")- assertparseequal (Amount (Commodity {symbol="$",side=L,spaced=False,comma=False,precision=0,rate=1}) 1) (parsewith transactionamount " $1.")+ assertparseequal (Mixed [dollars 47.18]) (parsewith transactionamount " $47.18")+ assertparseequal (Mixed [Amount (Commodity {symbol="$",side=L,spaced=False,comma=False,precision=0}) 1 Nothing]) (parsewith transactionamount " $1.")+ ,+ "canonicaliseAmounts" ~: do+ -- all amounts use the greatest precision+ assertequal [2,2] (rawLedgerPrecisions $ canonicaliseAmounts False $ rawLedgerWithAmounts ["1","2.00"])+ ,+ "timeLog" ~: do+ assertparseequal timelog1 (parsewith timelog timelog1_str)+ , + "smartparsedate" ~: do+ assertequal (1999,12,13) (dateComponents $ smartparsedate "1999/12/13")+ assertequal (2008,2,1) (dateComponents $ smartparsedate "2008-2")+ assertequal (2008,1,1) (dateComponents $ smartparsedate "2008") ] ---------------------------------------------------------------------------------functests = TestList [- balancecommandtests- ,registercommandtests- ]+balancereportacctnames_tests = TestList + [+ "balancereportacctnames0" ~: ("-s",[]) `gives` ["assets","assets:cash","assets:checking","assets:saving",+ "expenses","expenses:food","expenses:supplies","income",+ "income:gifts","income:salary","liabilities","liabilities:debts"]+ ,"balancereportacctnames1" ~: ("", []) `gives` ["assets","expenses","income","liabilities"]+ ,"balancereportacctnames2" ~: ("", ["assets"]) `gives` ["assets"]+ ,"balancereportacctnames3" ~: ("", ["as"]) `gives` ["assets","assets:cash"]+ ,"balancereportacctnames4" ~: ("", ["assets:cash"]) `gives` ["assets:cash"]+ ,"balancereportacctnames5" ~: ("", ["-assets"]) `gives` ["expenses","income","liabilities"]+ ,"balancereportacctnames6" ~: ("", ["-e"]) `gives` []+ ,"balancereportacctnames7" ~: ("-s",["assets"]) `gives` ["assets","assets:cash","assets:checking","assets:saving"]+ ,"balancereportacctnames8" ~: ("-s",["-e"]) `gives` []+ ] where+ gives (opt,pats) e = do + l <- ledgerfromfile pats "sample.ledger"+ let t = pruneZeroBalanceLeaves $ ledgerAccountTree 999 l+ assertequal e (balancereportacctnames l (opt=="-s") pats t) -balancecommandtests = TestList [- "simple balance report" ~: do- l <- ledgerfromfile "sample.ledger"- assertequal- " $-1 assets\n\- \ $2 expenses\n\- \ $-2 income\n\- \ $1 liabilities\n\- \" --"- (showBalanceReport [] [] l)+balancecommand_tests = TestList [+ "simple balance report" ~:+ ([], []) `gives`+ (" $-1 assets\n" +++ " $2 expenses\n" +++ " $-2 income\n" +++ " $1 liabilities\n" +++ "") ,- "balance report with showsubs" ~: do- l <- ledgerfromfile "sample.ledger"- assertequal- " $-1 assets\n\- \ $-2 cash\n\- \ $1 saving\n\- \ $2 expenses\n\- \ $1 food\n\- \ $1 supplies\n\- \ $-2 income\n\- \ $-1 gifts\n\- \ $-1 salary\n\- \ $1 liabilities:debts\n\- \" --"- (showBalanceReport [ShowSubs] [] l)+ "balance report with -s" ~:+ ([SubTotal], []) `gives`+ (" $-1 assets\n" +++ " $-2 cash\n" +++ " $1 saving\n" +++ " $2 expenses\n" +++ " $1 food\n" +++ " $1 supplies\n" +++ " $-2 income\n" +++ " $-1 gifts\n" +++ " $-1 salary\n" +++ " $1 liabilities:debts\n" +++ "") ,- "balance report with account pattern o" ~: do- l <- ledgerfromfile "sample.ledger"- assertequal- " $1 expenses:food\n\- \ $-2 income\n\- \--------------------\n\- \ $-1\n\- \" --"- (showBalanceReport [] ["o"] l)+ "balance report --depth limits -s" ~:+ ([SubTotal,Depth "1"], []) `gives`+ (" $-1 assets\n" +++ " $2 expenses\n" +++ " $-2 income\n" +++ " $1 liabilities\n" +++ "") ,- "balance report with account pattern o and showsubs" ~: do- l <- ledgerfromfile "sample.ledger"- assertequal- " $1 expenses:food\n\- \ $-2 income\n\- \ $-1 gifts\n\- \ $-1 salary\n\- \--------------------\n\- \ $-1\n\- \" --"- (showBalanceReport [ShowSubs] ["o"] l)+ "balance report --depth activates -s" ~:+ ([Depth "2"], []) `gives`+ (" $-1 assets\n" +++ " $-2 cash\n" +++ " $1 saving\n" +++ " $2 expenses\n" +++ " $1 food\n" +++ " $1 supplies\n" +++ " $-2 income\n" +++ " $-1 gifts\n" +++ " $-1 salary\n" +++ " $1 liabilities:debts\n" +++ "") ,- "balance report with account pattern a" ~: do- l <- ledgerfromfile "sample.ledger"- assertequal- " $-1 assets\n\- \ $-2 cash\n\- \ $1 saving\n\- \ $-1 income:salary\n\- \ $1 liabilities\n\- \--------------------\n\- \ $-1\n\- \" --"- (showBalanceReport [] ["a"] l)+ "balance report with account pattern o" ~:+ ([], ["o"]) `gives`+ (" $1 expenses:food\n" +++ " $-2 income\n" +++ "--------------------\n" +++ " $-1\n" +++ "") ,- "balance report with account pattern e" ~: do- l <- ledgerfromfile "sample.ledger"- assertequal- " $-1 assets\n\- \ $2 expenses\n\- \ $1 supplies\n\- \ $-2 income\n\- \ $1 liabilities:debts\n\- \" --"- (showBalanceReport [] ["e"] l)+ "balance report with account pattern o and -s" ~:+ ([SubTotal], ["o"]) `gives`+ (" $1 expenses:food\n" +++ " $-2 income\n" +++ " $-1 gifts\n" +++ " $-1 salary\n" +++ "--------------------\n" +++ " $-1\n" +++ "") ,+ "balance report with account pattern a" ~:+ ([], ["a"]) `gives`+ (" $-1 assets\n" +++ " $-2 cash\n" +++ " $1 saving\n" +++ " $-1 income:salary\n" +++ " $1 liabilities\n" +++ "--------------------\n" +++ " $-1\n" +++ "")+ ,+ "balance report with account pattern e" ~:+ ([], ["e"]) `gives`+ (" $-1 assets\n" +++ " $2 expenses\n" +++ " $1 supplies\n" +++ " $-2 income\n" +++ " $1 liabilities:debts\n" +++ "")+ , "balance report with unmatched parent of two matched subaccounts" ~: - do- l <- ledgerfromfile "sample.ledger"- assertequal- " $-2 assets:cash\n\- \ $1 assets:saving\n\- \--------------------\n\- \ $-1\n\- \" --"- (showBalanceReport [] ["cash","saving"] l)+ ([], ["cash","saving"]) `gives`+ (" $-2 assets:cash\n" +++ " $1 assets:saving\n" +++ "--------------------\n" +++ " $-1\n" +++ "") , "balance report with multi-part account name" ~: - do - l <- ledgerfromfile "sample.ledger"- assertequal- " $1 expenses:food\n\- \--------------------\n\- \ $1\n\- \" --"- $ showBalanceReport [] ["expenses:food"] l+ ([], ["expenses:food"]) `gives`+ (" $1 expenses:food\n" +++ "--------------------\n" +++ " $1\n" +++ "") ,+ "balance report with negative account pattern" ~:+ ([], ["-assets"]) `gives`+ (" $2 expenses\n" +++ " $-2 income\n" +++ " $1 liabilities\n" +++ "--------------------\n" +++ " $1\n" +++ "")+ , "balance report negative account pattern always matches full name" ~: + ([], ["-e"]) `gives` ""+ ,+ "balance report negative patterns affect totals" ~: + ([], ["expenses","-food"]) `gives`+ (" $1 expenses\n" +++ "--------------------\n" +++ " $1\n" +++ "")+ ,+ "balance report with -E shows zero-balance accounts" ~:+ ([SubTotal,Empty], ["assets"]) `gives`+ (" $-1 assets\n" +++ " $-2 cash\n" +++ " $0 checking\n" +++ " $1 saving\n" +++ "--------------------\n" +++ " $-1\n" +++ "")+ ,+ "balance report with -n omits the total" ~:+ ([Collapse], ["cash"]) `gives`+ (" $-2 assets:cash\n" +++ "")+ ,+ "balance report with cost basis" ~: do+ let l = cacheLedger [] $ + filterRawLedger Nothing Nothing [] False False $ + canonicaliseAmounts True $ -- enable cost basis adjustment+ rawledgerfromstring+ ("" +++ "2008/1/1 test \n" +++ " a:b 10h @ $50\n" +++ " c:d \n" +++ "\n")+ assertequal + (" $500 a\n" +++ " $-500 c\n" +++ ""+ )+ (showBalanceReport [] [] l)+ ] where+ gives (opts,pats) e = do + l <- ledgerfromfile pats "sample.ledger"+ assertequal e (showBalanceReport opts pats l)++printcommand_tests = TestList [+ "print with account patterns" ~: do - l <- ledgerfromfile "sample.ledger"- assertequal "" $ showBalanceReport [] ["-e"] l- ]+ let pats = ["expenses"]+ l <- ledgerfromfile pats "sample.ledger"+ assertequal (+ "2007/01/01 * eat & shop\n" +++ " expenses:food $1\n" +++ " expenses:supplies $1\n" +++ " assets:cash $-2\n" +++ "\n")+ $ showEntries [] pats l+ ] -registercommandtests = TestList [- "register does something" ~:+registercommand_tests = TestList [+ "register report" ~: do - l <- ledgerfromfile "sample.ledger"- assertnotequal "" $ showTransactionsWithBalances [] [] l+ l <- ledgerfromfile [] "sample.ledger"+ assertequal (+ "2007/01/01 income assets:checking $1 $1\n" +++ " income:salary $-1 0\n" +++ "2007/01/01 gift assets:checking $1 $1\n" +++ " income:gifts $-1 0\n" +++ "2007/01/01 save assets:saving $1 $1\n" +++ " assets:checking $-1 0\n" +++ "2007/01/01 eat & shop expenses:food $1 $1\n" +++ " expenses:supplies $1 $2\n" +++ " assets:cash $-2 0\n" +++ "2008/01/01 pay off liabilities:debts $1 $1\n" +++ " assets:checking $-1 0\n" +++ "")+ $ showRegisterReport [] [] l ] --- | Assert a parsed thing equals some expected thing, or print a parse error.-assertparseequal :: (Show a, Eq a) => a -> (Either ParseError a) -> Assertion-assertparseequal expected parsed = either printParseError (assertequal expected) parsed- --------------------------------------------------------------------------------- data+-- test data rawtransaction1_str = " expenses:food:dining $10.00\n" -rawtransaction1 = RawTransaction "expenses:food:dining" (dollars 10) ""+rawtransaction1 = RawTransaction "expenses:food:dining"(Mixed [dollars 10]) "" RegularTransaction -entry1_str = "\-\2007/01/28 coopportunity\n\-\ expenses:food:groceries $47.18\n\-\ assets:checking\n\-\\n" --"+entry1_str = "" +++ "2007/01/28 coopportunity\n" +++ " expenses:food:groceries $47.18\n" +++ " assets:checking\n" +++ "\n" entry1 =- (Entry "2007/01/28" False "" "coopportunity" ""- [RawTransaction "expenses:food:groceries" (dollars 47.18) "", - RawTransaction "assets:checking" (dollars (-47.18)) ""] "")+ (Entry (parsedate "2007/01/28") False "" "coopportunity" ""+ [RawTransaction "expenses:food:groceries" (Mixed [dollars 47.18]) "" RegularTransaction, + RawTransaction "assets:checking" (Mixed [dollars (-47.18)]) "" RegularTransaction] "") -entry2_str = "\-\2007/01/27 * joes diner\n\-\ expenses:food:dining $10.00\n\-\ expenses:gifts $10.00\n\-\ assets:checking $-20.00\n\-\\n" --"+entry2_str = "" +++ "2007/01/27 * joes diner\n" +++ " expenses:food:dining $10.00\n" +++ " expenses:gifts $10.00\n" +++ " assets:checking $-20.00\n" +++ "\n" -entry3_str = "\-\2007/01/01 * opening balance\n\-\ assets:cash $4.82\n\-\ equity:opening balances\n\-\\n\-\2007/01/01 * opening balance\n\-\ assets:cash $4.82\n\-\ equity:opening balances\n\-\\n\-\2007/01/28 coopportunity\n\-\ expenses:food:groceries $47.18\n\-\ assets:checking\n\-\\n" --"+entry3_str = "" +++ "2007/01/01 * opening balance\n" +++ " assets:cash $4.82\n" +++ " equity:opening balances\n" +++ "\n" +++ "2007/01/01 * opening balance\n" +++ " assets:cash $4.82\n" +++ " equity:opening balances\n" +++ "\n" +++ "2007/01/28 coopportunity\n" +++ " expenses:food:groceries $47.18\n" +++ " assets:checking\n" +++ "\n" -periodic_entry1_str = "\-\~ monthly from 2007/2/2\n\-\ assets:saving $200.00\n\-\ assets:checking\n\-\\n" --"+periodic_entry1_str = "" +++ "~ monthly from 2007/2/2\n" +++ " assets:saving $200.00\n" +++ " assets:checking\n" +++ "\n" -periodic_entry2_str = "\-\~ monthly from 2007/2/2\n\-\ assets:saving $200.00 ;auto savings\n\-\ assets:checking\n\-\\n" --"+periodic_entry2_str = "" +++ "~ monthly from 2007/2/2\n" +++ " assets:saving $200.00 ;auto savings\n" +++ " assets:checking\n" +++ "\n" -periodic_entry3_str = "\-\~ monthly from 2007/01/01\n\-\ assets:cash $4.82\n\-\ equity:opening balances\n\-\\n\-\~ monthly from 2007/01/01\n\-\ assets:cash $4.82\n\-\ equity:opening balances\n\-\\n" --"+periodic_entry3_str = "" +++ "~ monthly from 2007/01/01\n" +++ " assets:cash $4.82\n" +++ " equity:opening balances\n" +++ "\n" +++ "~ monthly from 2007/01/01\n" +++ " assets:cash $4.82\n" +++ " equity:opening balances\n" +++ "\n" -ledger1_str = "\-\\n\-\2007/01/27 * joes diner\n\-\ expenses:food:dining $10.00\n\-\ expenses:gifts $10.00\n\-\ assets:checking $-20.00\n\-\\n\-\\n\-\2007/01/28 coopportunity\n\-\ expenses:food:groceries $47.18\n\-\ assets:checking $-47.18\n\-\\n\-\" --"+ledger1_str = "" +++ "\n" +++ "2007/01/27 * joes diner\n" +++ " expenses:food:dining $10.00\n" +++ " expenses:gifts $10.00\n" +++ " assets:checking $-20.00\n" +++ "\n" +++ "\n" +++ "2007/01/28 coopportunity\n" +++ " expenses:food:groceries $47.18\n" +++ " assets:checking $-47.18\n" +++ "\n" +++ "" -ledger2_str = "\-\;comment\n\-\2007/01/27 * joes diner\n\-\ expenses:food:dining $10.00\n\-\ assets:checking $-47.18\n\-\\n" --"+ledger2_str = "" +++ ";comment\n" +++ "2007/01/27 * joes diner\n" +++ " expenses:food:dining $10.00\n" +++ " assets:checking $-47.18\n" +++ "\n" -ledger3_str = "\-\2007/01/27 * joes diner\n\-\ expenses:food:dining $10.00\n\-\;intra-entry comment\n\-\ assets:checking $-47.18\n\-\\n" --"+ledger3_str = "" +++ "2007/01/27 * joes diner\n" +++ " expenses:food:dining $10.00\n" +++ ";intra-entry comment\n" +++ " assets:checking $-47.18\n" +++ "\n" -ledger4_str = "\-\!include \"somefile\"\n\-\2007/01/27 * joes diner\n\-\ expenses:food:dining $10.00\n\-\ assets:checking $-47.18\n\-\\n" --"+ledger4_str = "" +++ "!include \"somefile\"\n" +++ "2007/01/27 * joes diner\n" +++ " expenses:food:dining $10.00\n" +++ " assets:checking $-47.18\n" +++ "\n" ledger5_str = "" -ledger6_str = "\-\~ monthly from 2007/1/21\n\-\ expenses:entertainment $16.23 ;netflix\n\-\ assets:checking\n\-\\n\-\; 2007/01/01 * opening balance\n\-\; assets:saving $200.04\n\-\; equity:opening balances \n\-\\n" --"+ledger6_str = "" +++ "~ monthly from 2007/1/21\n" +++ " expenses:entertainment $16.23 ;netflix\n" +++ " assets:checking\n" +++ "\n" +++ "; 2007/01/01 * opening balance\n" +++ "; assets:saving $200.04\n" +++ "; equity:opening balances \n" +++ "\n" -ledger7_str = "\-\2007/01/01 * opening balance\n\-\ assets:cash $4.82\n\-\ equity:opening balances \n\-\\n\-\2007/01/01 * opening balance\n\-\ income:interest $-4.82\n\-\ equity:opening balances \n\-\\n\-\2007/01/02 * ayres suites\n\-\ expenses:vacation $179.92\n\-\ assets:checking \n\-\\n\-\2007/01/02 * auto transfer to savings\n\-\ assets:saving $200.00\n\-\ assets:checking \n\-\\n\-\2007/01/03 * poquito mas\n\-\ expenses:food:dining $4.82\n\-\ assets:cash \n\-\\n\-\2007/01/03 * verizon\n\-\ expenses:phone $95.11\n\-\ assets:checking \n\-\\n\-\2007/01/03 * discover\n\-\ liabilities:credit cards:discover $80.00\n\-\ assets:checking \n\-\\n\-\2007/01/04 * blue cross\n\-\ expenses:health:insurance $90.00\n\-\ assets:checking \n\-\\n\-\2007/01/05 * village market liquor\n\-\ expenses:food:dining $6.48\n\-\ assets:checking \n\-\\n" --"+ledger7_str = "" +++ "2007/01/01 * opening balance\n" +++ " assets:cash $4.82\n" +++ " equity:opening balances \n" +++ "\n" +++ "2007/01/01 * opening balance\n" +++ " income:interest $-4.82\n" +++ " equity:opening balances \n" +++ "\n" +++ "2007/01/02 * ayres suites\n" +++ " expenses:vacation $179.92\n" +++ " assets:checking \n" +++ "\n" +++ "2007/01/02 * auto transfer to savings\n" +++ " assets:saving $200.00\n" +++ " assets:checking \n" +++ "\n" +++ "2007/01/03 * poquito mas\n" +++ " expenses:food:dining $4.82\n" +++ " assets:cash \n" +++ "\n" +++ "2007/01/03 * verizon\n" +++ " expenses:phone $95.11\n" +++ " assets:checking \n" +++ "\n" +++ "2007/01/03 * discover\n" +++ " liabilities:credit cards:discover $80.00\n" +++ " assets:checking \n" +++ "\n" +++ "2007/01/04 * blue cross\n" +++ " expenses:health:insurance $90.00\n" +++ " assets:checking \n" +++ "\n" +++ "2007/01/05 * village market liquor\n" +++ " expenses:food:dining $6.48\n" +++ " assets:checking \n" +++ "\n" rawledger7 = RawLedger [] [] [ Entry {- edate="2007/01/01", + edate= parsedate "2007/01/01", estatus=False, ecode="*", edescription="opening balance", @@ -351,20 +469,22 @@ etransactions=[ RawTransaction { taccount="assets:cash", - tamount=dollars 4.82,- tcomment=""+ tamount=(Mixed [dollars 4.82]),+ tcomment="",+ rttype=RegularTransaction }, RawTransaction { taccount="equity:opening balances", - tamount=dollars (-4.82),- tcomment=""+ tamount=(Mixed [dollars (-4.82)]),+ tcomment="",+ rttype=RegularTransaction } ], epreceding_comment_lines="" } , Entry {- edate="2007/02/01", + edate= parsedate "2007/02/01", estatus=False, ecode="*", edescription="ayres suites", @@ -372,20 +492,22 @@ etransactions=[ RawTransaction { taccount="expenses:vacation", - tamount=dollars 179.92,- tcomment=""+ tamount=(Mixed [dollars 179.92]),+ tcomment="",+ rttype=RegularTransaction }, RawTransaction { taccount="assets:checking", - tamount=dollars (-179.92),- tcomment=""+ tamount=(Mixed [dollars (-179.92)]),+ tcomment="",+ rttype=RegularTransaction } ], epreceding_comment_lines="" } , Entry {- edate="2007/01/02", + edate=parsedate "2007/01/02", estatus=False, ecode="*", edescription="auto transfer to savings", @@ -393,20 +515,22 @@ etransactions=[ RawTransaction { taccount="assets:saving", - tamount=dollars 200,- tcomment=""+ tamount=(Mixed [dollars 200]),+ tcomment="",+ rttype=RegularTransaction }, RawTransaction { taccount="assets:checking", - tamount=dollars (-200),- tcomment=""+ tamount=(Mixed [dollars (-200)]),+ tcomment="",+ rttype=RegularTransaction } ], epreceding_comment_lines="" } , Entry {- edate="2007/01/03", + edate=parsedate "2007/01/03", estatus=False, ecode="*", edescription="poquito mas", @@ -414,20 +538,22 @@ etransactions=[ RawTransaction { taccount="expenses:food:dining", - tamount=dollars 4.82,- tcomment=""+ tamount=(Mixed [dollars 4.82]),+ tcomment="",+ rttype=RegularTransaction }, RawTransaction { taccount="assets:cash", - tamount=dollars (-4.82),- tcomment=""+ tamount=(Mixed [dollars (-4.82)]),+ tcomment="",+ rttype=RegularTransaction } ], epreceding_comment_lines="" } , Entry {- edate="2007/01/03", + edate=parsedate "2007/01/03", estatus=False, ecode="*", edescription="verizon", @@ -435,20 +561,22 @@ etransactions=[ RawTransaction { taccount="expenses:phone", - tamount=dollars 95.11,- tcomment=""+ tamount=(Mixed [dollars 95.11]),+ tcomment="",+ rttype=RegularTransaction }, RawTransaction { taccount="assets:checking", - tamount=dollars (-95.11),- tcomment=""+ tamount=(Mixed [dollars (-95.11)]),+ tcomment="",+ rttype=RegularTransaction } ], epreceding_comment_lines="" } , Entry {- edate="2007/01/03", + edate=parsedate "2007/01/03", estatus=False, ecode="*", edescription="discover", @@ -456,13 +584,15 @@ etransactions=[ RawTransaction { taccount="liabilities:credit cards:discover", - tamount=dollars 80,- tcomment=""+ tamount=(Mixed [dollars 80]),+ tcomment="",+ rttype=RegularTransaction }, RawTransaction { taccount="assets:checking", - tamount=dollars (-80),- tcomment=""+ tamount=(Mixed [dollars (-80)]),+ tcomment="",+ rttype=RegularTransaction } ], epreceding_comment_lines=""@@ -470,13 +600,65 @@ ] "" -ledger7 = cacheLedger rawledger7 +ledger7 = cacheLedger [] rawledger7 +ledger8_str = "" +++ "2008/1/1 test \n" +++ " a:b 10h @ $40\n" +++ " c:d \n" +++ "\n"++sample_ledger_str = (+ "; A sample ledger file.\n" +++ ";\n" +++ "; Sets up this account tree:\n" +++ "; assets\n" +++ "; cash\n" +++ "; checking\n" +++ "; saving\n" +++ "; expenses\n" +++ "; food\n" +++ "; supplies\n" +++ "; income\n" +++ "; gifts\n" +++ "; salary\n" +++ "; liabilities\n" +++ "; debts\n" +++ "\n" +++ "2007/01/01 income\n" +++ " assets:checking $1\n" +++ " income:salary\n" +++ "\n" +++ "2007/01/01 gift\n" +++ " assets:checking $1\n" +++ " income:gifts\n" +++ "\n" +++ "2007/01/01 save\n" +++ " assets:saving $1\n" +++ " assets:checking\n" +++ "\n" +++ "2007/01/01 * eat & shop\n" +++ " expenses:food $1\n" +++ " expenses:supplies $1\n" +++ " assets:cash\n" +++ "\n" +++ "2008/1/1 * pay off\n" +++ " liabilities:debts $1\n" +++ " assets:checking\n" +++ "\n" +++ "\n" +++ ";final comment\n" +++ "")++write_sample_ledger = writeFile "sample.ledger" sample_ledger_str++read_sample_ledger = readFile "sample.ledger"+ timelogentry1_str = "i 2007/03/11 16:19:00 hledger\n"-timelogentry1 = TimeLogEntry 'i' "2007/03/11 16:19:00" "hledger"+timelogentry1 = TimeLogEntry 'i' (parsedatetime "2007/03/11 16:19:00") "hledger" timelogentry2_str = "o 2007/03/11 16:30:00\n"-timelogentry2 = TimeLogEntry 'o' "2007/03/11 16:30:00" ""+timelogentry2 = TimeLogEntry 'o' (parsedatetime "2007/03/11 16:30:00") "" timelog1_str = concat [ timelogentry1_str,@@ -486,4 +668,44 @@ timelogentry1, timelogentry2 ]++a1 = Mixed [(hours 1){price=Just $ Mixed [Amount (comm "$") 10 Nothing]}]+a2 = Mixed [(hours 2){price=Just $ Mixed [Amount (comm "EUR") 10 Nothing]}]+a3 = Mixed $ (amounts a1) ++ (amounts a2)++------------------------------------------------------------------------------+-- test utils++-- | 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++-- | Combine a list of TestLists into one.+tlistconcat :: [Test] -> Test+tlistconcat = foldr (\(TestList as) (TestList bs) -> TestList (as ++ bs)) (TestList []) ++-- | Assert a parsed thing equals some expected thing, or print a parse error.+assertparseequal :: (Show a, Eq a) => a -> (Either ParseError a) -> Assertion+assertparseequal expected parsed = either printParseError (assertequal expected) parsed++rawLedgerWithAmounts as = + RawLedger + [] + [] + [nullentry{edescription=a,etransactions=[nullrawtxn{tamount=parse a}]} | a <- as]+ ""+ where parse = fromparse . parsewith transactionamount . (" "++)
Utils.hs view
@@ -7,37 +7,53 @@ module Utils where import qualified Data.Map as Map (lookup)+import Text.ParserCombinators.Parsec import Options import Ledger --- | get a RawLedger from the given file path+-- | Get a RawLedger from the given string, or raise an error.+rawledgerfromstring :: String -> RawLedger+rawledgerfromstring = fromparse . parsewith ledgerfile++-- | Get a filtered and cached Ledger from the given string, or raise an error.+ledgerfromstring :: [String] -> String -> Ledger+ledgerfromstring args s =+ cacheLedger apats $ filterRawLedger Nothing Nothing dpats False False l+ where+ (apats,dpats) = parseAccountDescriptionArgs args+ l = rawledgerfromstring s+ +-- | Get a RawLedger from the given file path, or a dummy one if there was an error. rawledgerfromfile :: FilePath -> IO RawLedger rawledgerfromfile f = do parsed <- parseLedgerFile f return $ either (\_ -> RawLedger [] [] [] "") id parsed --- | get a cached Ledger from the given file path-ledgerfromfile :: FilePath -> IO Ledger-ledgerfromfile f = do+-- | Get a filtered and cached Ledger from the given file path, or a dummy+-- one if there was an error.+ledgerfromfile :: [String] -> FilePath -> IO Ledger+ledgerfromfile args f = do l <- rawledgerfromfile f- return $ cacheLedger $ filterRawLedger "" "" [] l---- | get a RawLedger from the file your LEDGER environment variable--- variable points to or (WARNING) an empty one if there was a problem.+ return $ cacheLedger apats $ filterRawLedger Nothing Nothing dpats False False l+ where+ (apats,dpats) = parseAccountDescriptionArgs args+ +-- | Get a RawLedger from the file your LEDGER environment variable+-- variable points to, or a dummy one if there was a problem. myrawledger :: IO RawLedger myrawledger = do parsed <- ledgerFilePathFromOpts [] >>= parseLedgerFile return $ either (\_ -> RawLedger [] [] [] "") id parsed --- | get a cached Ledger from the file your LEDGER environment variable--- variable points to or (WARNING) an empty one if there was a problem.+-- | Get a cached Ledger from the file your LEDGER environment variable+-- variable points to, or a dummy one if there was a problem. myledger :: IO Ledger myledger = do l <- myrawledger- return $ cacheLedger $ filterRawLedger "" "" [] l+ return $ cacheLedger [] $ filterRawLedger Nothing Nothing [] False False l --- | get a named account from your ledger file+-- | Get a named account from your ledger file. myaccount :: AccountName -> IO Account myaccount a = myledger >>= (return . fromMaybe nullacct . Map.lookup a . accountmap)
hledger.cabal view
@@ -1,16 +1,16 @@ Name: hledger-Version: 0.1+Version: 0.2 Category: Finance Synopsis: A ledger-compatible text-based accounting tool.-Description: This is a minimal haskell clone of John Wiegley's ledger- <http://newartisans.com/software/ledger.html>. hledger does basic- register & balance reporting from a plain text ledger file, and - demonstrates a functional implementation of ledger.+Description: hledger is a minimal haskell clone of John Wiegley's "ledger" text-based+ accounting tool (http://newartisans.com/software/ledger.html). hledger+ generates ledger-compatible register & balance reports from a plain text+ ledger file, and demonstrates a functional implementation of ledger. License: GPL Stability: alpha Author: Simon Michael <simon@joyful.com> Maintainer: Simon Michael <simon@joyful.com>-Homepage: http://joyful.com/Ledger#hledger+Homepage: http://joyful.com/hledger Tested-With: GHC Build-Type: Simple License-File: LICENSE@@ -20,7 +20,7 @@ Executable hledger Build-Depends: base, containers, haskell98, directory, parsec, regex-compat,- old-locale, time, HUnit, QuickCheck >= 1 && < 2+ old-locale, time, HUnit Main-Is: hledger.hs Other-Modules: BalanceCommand@@ -35,6 +35,7 @@ Ledger.AccountName Ledger.Amount Ledger.Commodity+ Ledger.Dates Ledger.Entry Ledger.RawLedger Ledger.Ledger@@ -45,3 +46,22 @@ Ledger.Types Ledger.Utils +library+ Build-Depends: base, containers, haskell98, directory, parsec, regex-compat,+ old-locale, time, HUnit+ Exposed-modules:+ Ledger+ Ledger.Account+ Ledger.AccountName+ Ledger.Amount+ Ledger.Commodity+ Ledger.Dates+ Ledger.Entry+ Ledger.RawLedger+ Ledger.Ledger+ Ledger.RawTransaction+ Ledger.Parse+ Ledger.TimeLog+ Ledger.Transaction+ Ledger.Types+ Ledger.Utils
hledger.hs view
@@ -5,10 +5,11 @@ Copyright (c) 2007-2008 Simon Michael <simon@joyful.com> Released under GPL version 3 or later. -This is a minimal haskell clone of John Wiegley's ledger-<http://newartisans.com/software/ledger.html>. hledger generates-simple ledger-compatible register & balance reports from a plain text-ledger file, and demonstrates a functional implementation of ledger.+hledger is a minimal haskell clone of John Wiegley's "ledger" text-based+accounting tool (http://newartisans.com/software/ledger.html). hledger+generates ledger-compatible register & balance reports from a plain text+ledger file, and demonstrates a functional implementation of ledger. For+more information, see the hledger home page: http://joyful.com/hledger You can use the command line: @@ -17,7 +18,7 @@ or ghci: > $ ghci hledger-> > l <- ledgerfromfile "sample.ledger"+> > l <- ledgerfromfile [] "sample.ledger" > > balance [] [] l > $-1 assets > $2 expenses@@ -61,17 +62,20 @@ | cmd `isPrefixOf` "balance" = parseLedgerAndDo opts args balance | cmd `isPrefixOf` "print" = parseLedgerAndDo opts args print' | cmd `isPrefixOf` "register" = parseLedgerAndDo opts args register- | cmd `isPrefixOf` "test" = runtests >> return ()+ | cmd `isPrefixOf` "test" = runtests opts args >> return () | otherwise = putStr usage -- | parse the user's specified ledger file and do some action with it -- (or report a parse error). This function makes the whole thing go. parseLedgerAndDo :: [Opt] -> [String] -> ([Opt] -> [String] -> Ledger -> IO ()) -> IO () parseLedgerAndDo opts args cmd = - ledgerFilePathFromOpts opts >>= parseLedgerFile >>= either printParseError runthecommand+ ledgerFilePathFromOpts opts >>= parseLedgerFile >>= either printParseError runcmd where- runthecommand = cmd opts args . cacheLedger . normaliseRawLedgerAmounts . filterRawLedger begin end descpats- begin = beginDateFromOpts opts- end = endDateFromOpts opts- descpats = snd $ parseAccountDescriptionArgs args+ runcmd = cmd opts args . cacheLedger apats . filterRawLedger b e dpats c r . canonicaliseAmounts costbasis+ b = beginDateFromOpts opts+ e = endDateFromOpts opts+ (apats,dpats) = parseAccountDescriptionArgs args+ c = Cleared `elem` opts+ r = Real `elem` opts+ costbasis = CostBasis `elem` opts
sample.ledger view
@@ -34,3 +34,6 @@ 2008/1/1 * pay off liabilities:debts $1 assets:checking+++;final comment