module Hledger.Reports (
ReportOpts(..),
DisplayExp,
FormatStr,
defreportopts,
dateSpanFromOpts,
intervalFromOpts,
clearedValueFromOpts,
whichDateFromOpts,
journalSelectingAmountFromOpts,
queryFromOpts,
queryOptsFromOpts,
EntriesReport,
EntriesReportItem,
entriesReport,
PostingsReport,
PostingsReportItem,
postingsReport,
mkpostingsReportItem,
TransactionsReport,
TransactionsReportItem,
triDate,
triBalance,
triSimpleBalance,
transactionsReportByCommodity,
journalTransactionsReport,
accountTransactionsReport,
AccountsReport,
AccountsReportItem,
accountsReport,
accountBalanceHistory,
tests_Hledger_Reports
)
where
import Control.Monad
import Data.List
import Data.Maybe
import Data.Ord
import Data.Time.Calendar
import Safe (headMay, lastMay)
import System.Console.CmdArgs
import Test.HUnit
import Text.ParserCombinators.Parsec
import Text.Printf
import Hledger.Data
import Hledger.Read (mamountp')
import Hledger.Query
import Hledger.Utils
data ReportOpts = ReportOpts {
begin_ :: Maybe Day
,end_ :: Maybe Day
,period_ :: Maybe (Interval,DateSpan)
,cleared_ :: Bool
,uncleared_ :: Bool
,cost_ :: Bool
,depth_ :: Maybe Int
,display_ :: Maybe DisplayExp
,date2_ :: Bool
,empty_ :: Bool
,no_elide_ :: Bool
,real_ :: Bool
,flat_ :: Bool
,drop_ :: Int
,no_total_ :: Bool
,daily_ :: Bool
,weekly_ :: Bool
,monthly_ :: Bool
,quarterly_ :: Bool
,yearly_ :: Bool
,format_ :: Maybe FormatStr
,related_ :: Bool
,query_ :: String
} deriving (Show)
type DisplayExp = String
type FormatStr = String
defreportopts = ReportOpts
def
def
def
def
def
def
def
def
def
def
def
def
def
def
def
def
def
def
def
def
def
def
def
instance Default ReportOpts where def = defreportopts
dateSpanFromOpts :: Day -> ReportOpts -> DateSpan
dateSpanFromOpts _ ReportOpts{..} =
case period_ of Just (_,span) -> span
Nothing -> DateSpan begin_ end_
intervalFromOpts :: ReportOpts -> Interval
intervalFromOpts ReportOpts{..} =
case period_ of
Just (interval,_) -> interval
Nothing -> i
where i | daily_ = Days 1
| weekly_ = Weeks 1
| monthly_ = Months 1
| quarterly_ = Quarters 1
| yearly_ = Years 1
| otherwise = NoInterval
clearedValueFromOpts :: ReportOpts -> Maybe Bool
clearedValueFromOpts ReportOpts{..} | cleared_ = Just True
| uncleared_ = Just False
| otherwise = Nothing
whichDateFromOpts :: ReportOpts -> WhichDate
whichDateFromOpts ReportOpts{..} = if date2_ then SecondaryDate else PrimaryDate
transactionDateFn :: ReportOpts -> (Transaction -> Day)
transactionDateFn ReportOpts{..} = if date2_ then transactionDate2 else tdate
postingDateFn :: ReportOpts -> (Posting -> Day)
postingDateFn ReportOpts{..} = if date2_ then postingDate2 else postingDate
journalSelectingAmountFromOpts :: ReportOpts -> Journal -> Journal
journalSelectingAmountFromOpts opts
| cost_ opts = journalConvertAmountsToCost
| otherwise = id
queryFromOpts :: Day -> ReportOpts -> Query
queryFromOpts d opts@ReportOpts{..} = simplifyQuery $ And $ [flagsq, argsq]
where
flagsq = And $
[(if date2_ then Date2 else Date) $ dateSpanFromOpts d opts]
++ (if real_ then [Real True] else [])
++ (if empty_ then [Empty True] else [])
++ (maybe [] ((:[]) . Status) (clearedValueFromOpts opts))
++ (maybe [] ((:[]) . Depth) depth_)
argsq = fst $ parseQuery d query_
tests_queryFromOpts = [
"queryFromOpts" ~: do
assertEqual "" Any (queryFromOpts nulldate defreportopts)
assertEqual "" (Acct "a") (queryFromOpts nulldate defreportopts{query_="a"})
assertEqual "" (Desc "a a") (queryFromOpts nulldate defreportopts{query_="desc:'a a'"})
assertEqual "" (Date $ mkdatespan "2012/01/01" "2013/01/01")
(queryFromOpts nulldate defreportopts{begin_=Just (parsedate "2012/01/01")
,query_="date:'to 2013'"
})
assertEqual "" (Date2 $ mkdatespan "2012/01/01" "2013/01/01")
(queryFromOpts nulldate defreportopts{query_="edate:'in 2012'"})
assertEqual "" (Or [Acct "a a", Acct "'b"])
(queryFromOpts nulldate defreportopts{query_="'a a' 'b"})
]
queryOptsFromOpts :: Day -> ReportOpts -> [QueryOpt]
queryOptsFromOpts d ReportOpts{..} = flagsqopts ++ argsqopts
where
flagsqopts = []
argsqopts = snd $ parseQuery d query_
tests_queryOptsFromOpts = [
"queryOptsFromOpts" ~: do
assertEqual "" [] (queryOptsFromOpts nulldate defreportopts)
assertEqual "" [] (queryOptsFromOpts nulldate defreportopts{query_="a"})
assertEqual "" [] (queryOptsFromOpts nulldate defreportopts{begin_=Just (parsedate "2012/01/01")
,query_="date:'to 2013'"
})
]
type EntriesReport = [EntriesReportItem]
type EntriesReportItem = Transaction
entriesReport :: ReportOpts -> Query -> Journal -> EntriesReport
entriesReport opts q j =
sortBy (comparing date) $ filter (q `matchesTransaction`) ts
where
date = transactionDateFn opts
ts = jtxns $ journalSelectingAmountFromOpts opts j
tests_entriesReport = [
"entriesReport" ~: do
assertEqual "not acct" 1 (length $ entriesReport defreportopts (Not $ Acct "bank") samplejournal)
let span = mkdatespan "2008/06/01" "2008/07/01"
assertEqual "date" 3 (length $ entriesReport defreportopts (Date $ span) samplejournal)
]
type PostingsReport = (String
,[PostingsReportItem]
)
type PostingsReportItem = (Maybe Day
,Maybe String
,Posting
,MixedAmount
)
postingsReport :: ReportOpts -> Query -> Journal -> PostingsReport
postingsReport opts q j =
(totallabel, postingsReportItems ps nullposting wd depth startbal (+))
where
ps | interval == NoInterval = displayableps
| otherwise = summarisePostingsByInterval interval depth empty reportspan displayableps
j' = journalSelectingAmountFromOpts opts j
wd = whichDateFromOpts opts
(depth, q') = (queryDepth q, filterQuery (not . queryIsDepth) q)
(precedingps, displayableps, _) = dbg "ps4" $ postingsMatchingDisplayExpr displayexpr opts
$ dbg "ps3" $ (if related_ opts then concatMap relatedPostings else id)
$ dbg "ps2" $ filter (q' `matchesPosting`)
$ dbg "ps1" $ journalPostings j'
dbg :: Show a => String -> a -> a
dbg = flip const
empty = queryEmpty q
displayexpr = display_ opts
interval = intervalFromOpts opts
journalspan = journalDateSpan j'
requestedspan = periodspan `spanIntersect` displayspan
periodspan = queryDateSpan secondarydate q
secondarydate = whichDateFromOpts opts == SecondaryDate
displayspan = postingsDateSpan ps
where (_,ps,_) = postingsMatchingDisplayExpr displayexpr opts $ journalPostings j'
matchedspan = postingsDateSpan displayableps
reportspan | empty = requestedspan `orDatesFrom` journalspan
| otherwise = requestedspan `spanIntersect` matchedspan
startbal = sumPostings precedingps
totallabel = "Total"
balancelabel = "Balance"
postingsReportItems :: [Posting] -> Posting -> WhichDate -> Int -> MixedAmount -> (MixedAmount -> MixedAmount -> MixedAmount) -> [PostingsReportItem]
postingsReportItems [] _ _ _ _ _ = []
postingsReportItems (p:ps) pprev wd d b sumfn = i:(postingsReportItems ps p wd d b' sumfn)
where
i = mkpostingsReportItem showdate showdesc wd p' b'
showdate = isfirstintxn || isdifferentdate
showdesc = isfirstintxn
isfirstintxn = ptransaction p /= ptransaction pprev
isdifferentdate = case wd of PrimaryDate -> postingDate p /= postingDate pprev
SecondaryDate -> postingDate2 p /= postingDate2 pprev
p' = p{paccount=clipAccountName d $ paccount p}
b' = b `sumfn` pamount p
mkpostingsReportItem :: Bool -> Bool -> WhichDate -> Posting -> MixedAmount -> PostingsReportItem
mkpostingsReportItem showdate showdesc wd p b = (if showdate then Just date else Nothing, if showdesc then Just desc else Nothing, p, b)
where
date = case wd of PrimaryDate -> postingDate p
SecondaryDate -> postingDate2 p
desc = maybe "" tdescription $ ptransaction p
postingsMatchingDisplayExpr :: Maybe String -> ReportOpts -> [Posting] -> ([Posting],[Posting],[Posting])
postingsMatchingDisplayExpr d opts ps = (before, matched, after)
where
sorted = sortBy (comparing (postingDateFn opts)) ps
(before, rest) = break (displayExprMatches d) sorted
(matched, after) = span (displayExprMatches d) rest
displayExprMatches :: Maybe String -> Posting -> Bool
displayExprMatches Nothing _ = True
displayExprMatches (Just d) p = (fromparse $ parsewith datedisplayexpr d) p
datedisplayexpr :: GenParser Char st (Posting -> Bool)
datedisplayexpr = do
char 'd'
op <- compareop
char '['
(y,m,d) <- smartdate
char ']'
let date = parsedate $ printf "%04s/%02s/%02s" y m d
test op = return $ (`op` date) . postingDate
case op of
"<" -> test (<)
"<=" -> test (<=)
"=" -> test (==)
"==" -> test (==)
">=" -> test (>=)
">" -> test (>)
_ -> mzero
where
compareop = choice $ map (try . string) ["<=",">=","==","<","=",">"]
summarisePostingsByInterval :: Interval -> Int -> Bool -> DateSpan -> [Posting] -> [Posting]
summarisePostingsByInterval interval depth empty reportspan ps = concatMap summarisespan $ splitSpan interval reportspan
where
summarisespan s = summarisePostingsInDateSpan s depth empty (postingsinspan s)
postingsinspan s = filter (isPostingInDateSpan s) ps
tests_summarisePostingsByInterval = [
"summarisePostingsByInterval" ~: do
summarisePostingsByInterval (Quarters 1) 99999 False (DateSpan Nothing Nothing) [] ~?= []
]
summarisePostingsInDateSpan :: DateSpan -> Int -> Bool -> [Posting] -> [Posting]
summarisePostingsInDateSpan (DateSpan b e) depth showempty ps
| null ps && (isNothing b || isNothing e) = []
| null ps && showempty = [summaryp]
| otherwise = summaryps'
where
summaryp = summaryPosting b' ("- "++ showDate (addDays (1) e'))
b' = fromMaybe (maybe nulldate postingDate $ headMay ps) b
e' = fromMaybe (maybe (addDays 1 nulldate) postingDate $ lastMay ps) e
summaryPosting date desc = nullposting{ptransaction=Just nulltransaction{tdate=date,tdescription=desc}}
summaryps' = (if showempty then id else filter (not . isZeroMixedAmount . pamount)) summaryps
summaryps = [summaryp{paccount=a,pamount=balance a} | a <- clippedanames]
clippedanames = nub $ map (clipAccountName depth) anames
anames = sort $ nub $ map paccount ps
accts = accountsFromPostings ps
balance a = maybe nullmixedamt bal $ lookupAccount a accts
where
bal = if isclipped a then aibalance else aebalance
isclipped a = accountNameLevel a >= depth
type TransactionsReport = (String
,[TransactionsReportItem]
)
type TransactionsReportItem = (Transaction
,Transaction
,Bool
,String
,MixedAmount
,MixedAmount
)
triDate (t,_,_,_,_,_) = tdate t
triAmount (_,_,_,_,a,_) = a
triBalance (_,_,_,_,_,a) = a
triSimpleBalance (_,_,_,_,_,Mixed a) = case a of [] -> "0"
(Amount{aquantity=q}):_ -> show q
transactionsReportByCommodity :: TransactionsReport -> [TransactionsReport]
transactionsReportByCommodity tr =
[filterTransactionsReportByCommodity c tr | c <- transactionsReportCommodities tr]
where
transactionsReportCommodities (_,items) =
nub $ sort $ map acommodity $ concatMap (amounts . triAmount) items
filterTransactionsReportByCommodity :: Commodity -> TransactionsReport -> TransactionsReport
filterTransactionsReportByCommodity c (label,items) =
(label, fixTransactionsReportItemBalances $ concat [filterTransactionsReportItemByCommodity c i | i <- items])
where
filterTransactionsReportItemByCommodity c (t,t2,s,o,a,bal)
| c `elem` cs = [item']
| otherwise = []
where
cs = map acommodity $ amounts a
item' = (t,t2,s,o,a',bal)
a' = filterMixedAmountByCommodity c a
fixTransactionsReportItemBalances [] = []
fixTransactionsReportItemBalances [i] = [i]
fixTransactionsReportItemBalances items = reverse $ i:(go startbal is)
where
i:is = reverse items
startbal = filterMixedAmountByCommodity c $ triBalance i
go _ [] = []
go bal ((t,t2,s,o,amt,_):is) = (t,t2,s,o,amt,bal'):go bal' is
where bal' = bal + amt
filterMixedAmountByCommodity :: Commodity -> MixedAmount -> MixedAmount
filterMixedAmountByCommodity c (Mixed as) = Mixed $ filter ((==c). acommodity) as
journalTransactionsReport :: ReportOpts -> Journal -> Query -> TransactionsReport
journalTransactionsReport _ Journal{jtxns=ts} m = (totallabel, items)
where
ts' = sortBy (comparing tdate) $ filter (not . null . tpostings) $ map (filterTransactionPostings m) ts
items = reverse $ accountTransactionsReportItems m Nothing nullmixedamt id ts'
accountTransactionsReport :: ReportOpts -> Journal -> Query -> Query -> TransactionsReport
accountTransactionsReport opts j m thisacctquery = (label, items)
where
ts = sortBy (comparing tdate) $ filter (matchesTransaction thisacctquery) $ jtxns $
journalSelectingAmountFromOpts opts j
(startbal,label) | queryIsNull m = (nullmixedamt, balancelabel)
| queryIsStartDateOnly (date2_ opts) m = (sumPostings priorps, balancelabel)
| otherwise = (nullmixedamt, totallabel)
where
priorps =
filter (matchesPosting
(
And [thisacctquery, tostartdatequery]))
$ transactionsPostings ts
tostartdatequery = Date (DateSpan Nothing startdate)
startdate = queryStartDate (date2_ opts) m
items = reverse $ accountTransactionsReportItems m (Just thisacctquery) startbal negate ts
accountTransactionsReportItems :: Query -> Maybe Query -> MixedAmount -> (MixedAmount -> MixedAmount) -> [Transaction] -> [TransactionsReportItem]
accountTransactionsReportItems _ _ _ _ [] = []
accountTransactionsReportItems query thisacctquery bal signfn (t:ts) =
case i of Just i' -> i':is
Nothing -> is
where
tmatched@Transaction{tpostings=psmatched} = filterTransactionPostings query t
(psthisacct,psotheracct) = case thisacctquery of Just m -> partition (matchesPosting m) psmatched
Nothing -> ([],psmatched)
numotheraccts = length $ nub $ map paccount psotheracct
amt = negate $ sum $ map pamount psthisacct
acct | isNothing thisacctquery = summarisePostings psmatched
| numotheraccts == 0 = "transfer between " ++ summarisePostingAccounts psthisacct
| otherwise = prefix ++ summarisePostingAccounts psotheracct
where prefix = maybe "" (\b -> if b then "from " else "to ") $ isNegativeMixedAmount amt
(i,bal') = case psmatched of
[] -> (Nothing,bal)
_ -> (Just (t, tmatched, numotheraccts > 1, acct, a, b), b)
where
a = signfn amt
b = bal + a
is = accountTransactionsReportItems query thisacctquery bal' signfn ts
summarisePostings :: [Posting] -> String
summarisePostings ps =
case (summarisePostingAccounts froms, summarisePostingAccounts tos) of
("",t) -> "to "++t
(f,"") -> "from "++f
(f,t) -> "from "++f++" to "++t
where
(froms,tos) = partition (fromMaybe False . isNegativeMixedAmount . pamount) ps
summarisePostingAccounts :: [Posting] -> String
summarisePostingAccounts = intercalate ", " . map accountLeafName . nub . map paccount
filterTransactionPostings :: Query -> Transaction -> Transaction
filterTransactionPostings m t@Transaction{tpostings=ps} = t{tpostings=filter (m `matchesPosting`) ps}
type AccountsReport = ([AccountsReportItem]
,MixedAmount
)
type AccountsReportItem = (AccountName
,AccountName
,Int
,MixedAmount)
accountsReport :: ReportOpts -> Query -> Journal -> AccountsReport
accountsReport opts q j = (items, total)
where
l = ledgerFromJournal q $ journalSelectingAmountFromOpts opts j
accts = clipAccounts (queryDepth q) $ ledgerRootAccount l
accts'
| flat_ opts = filterzeros $ tail $ flattenAccounts accts
| otherwise = filter (not.aboring) $ tail $ flattenAccounts $ markboring $ prunezeros accts
where
filterzeros | empty_ opts = id
| otherwise = filter (not . isZeroMixedAmount . aebalance)
prunezeros | empty_ opts = id
| otherwise = fromMaybe nullacct . pruneAccounts (isZeroMixedAmount.aibalance)
markboring | no_elide_ opts = id
| otherwise = markBoringParentAccounts
items = map (accountsReportItem opts) accts'
total = sum [amt | (a,_,indent,amt) <- items, if flat_ opts then accountNameLevel a == 1 else indent == 0]
markBoringParentAccounts :: Account -> Account
markBoringParentAccounts = tieAccountParents . mapAccounts mark
where
mark a | length (asubs a) == 1 && isZeroMixedAmount (aebalance a) = a{aboring=True}
| otherwise = a
accountsReportItem :: ReportOpts -> Account -> AccountsReportItem
accountsReportItem opts a@Account{aname=name, aibalance=ibal}
| flat_ opts = (name, name, 0, ibal)
| otherwise = (name, elidedname, indent, ibal)
where
elidedname = accountNameFromComponents (adjacentboringparentnames ++ [accountLeafName name])
adjacentboringparentnames = reverse $ map (accountLeafName.aname) $ takeWhile aboring $ parents
indent = length $ filter (not.aboring) parents
parents = init $ parentAccounts a
accountBalanceHistory :: ReportOpts -> Journal -> Account -> [(Day, MixedAmount)]
accountBalanceHistory ropts j a = [(getdate t, bal) | (t,_,_,_,_,bal) <- items]
where
(_,items) = journalTransactionsReport ropts j acctquery
inclusivebal = True
acctquery = Acct $ (if inclusivebal then accountNameToAccountRegex else accountNameToAccountOnlyRegex) $ aname a
getdate = if date2_ ropts then transactionDate2 else tdate
tests_postingsReport = [
"postingsReport" ~: do
let (query, journal) `gives` n = (length $ snd $ postingsReport defreportopts query journal) `is` n
(Any, nulljournal) `gives` 0
(Any, samplejournal) `gives` 11
(Depth 2, samplejournal) `gives` 11
(And [Depth 1, Status True, Acct "expenses"], samplejournal) `gives` 2
(And [And [Depth 1, Status True], Acct "expenses"], samplejournal) `gives` 2
assertEqual "" 11 (length $ snd $ postingsReport defreportopts Any samplejournal)
assertEqual "" 9 (length $ snd $ postingsReport defreportopts{monthly_=True} Any samplejournal)
assertEqual "" 19 (length $ snd $ postingsReport defreportopts{monthly_=True} (Empty True) samplejournal)
assertEqual "" 4 (length $ snd $ postingsReport defreportopts (Acct "assets:bank:checking") samplejournal)
]
tests_accountsReport =
let (opts,journal) `gives` r = do
let (eitems, etotal) = r
(aitems, atotal) = accountsReport opts (queryFromOpts nulldate opts) journal
assertEqual "items" eitems aitems
assertEqual "total" etotal atotal
in [
"accountsReport with no args on null journal" ~: do
(defreportopts, nulljournal) `gives` ([], Mixed [nullamt])
,"accountsReport with no args on sample journal" ~: do
(defreportopts, samplejournal) `gives`
([
("assets","assets",0, mamountp' "$-1.00")
,("assets:bank:saving","bank:saving",1, mamountp' "$1.00")
,("assets:cash","cash",1, mamountp' "$-2.00")
,("expenses","expenses",0, mamountp' "$2.00")
,("expenses:food","food",1, mamountp' "$1.00")
,("expenses:supplies","supplies",1, mamountp' "$1.00")
,("income","income",0, mamountp' "$-2.00")
,("income:gifts","gifts",1, mamountp' "$-1.00")
,("income:salary","salary",1, mamountp' "$-1.00")
,("liabilities:debts","liabilities:debts",0, mamountp' "$1.00")
],
Mixed [nullamt])
,"accountsReport with --depth=N" ~: do
(defreportopts{depth_=Just 1}, samplejournal) `gives`
([
("assets", "assets", 0, mamountp' "$-1.00")
,("expenses", "expenses", 0, mamountp' "$2.00")
,("income", "income", 0, mamountp' "$-2.00")
,("liabilities", "liabilities", 0, mamountp' "$1.00")
],
Mixed [nullamt])
,"accountsReport with depth:N" ~: do
(defreportopts{query_="depth:1"}, samplejournal) `gives`
([
("assets", "assets", 0, mamountp' "$-1.00")
,("expenses", "expenses", 0, mamountp' "$2.00")
,("income", "income", 0, mamountp' "$-2.00")
,("liabilities", "liabilities", 0, mamountp' "$1.00")
],
Mixed [nullamt])
,"accountsReport with a date or secondary date span" ~: do
(defreportopts{query_="date:'in 2009'"}, samplejournal2) `gives`
([],
Mixed [nullamt])
(defreportopts{query_="edate:'in 2009'"}, samplejournal2) `gives`
([
("assets:bank:checking","assets:bank:checking",0,mamountp' "$1.00")
,("income:salary","income:salary",0,mamountp' "$-1.00")
],
Mixed [nullamt])
,"accountsReport with desc:" ~: do
(defreportopts{query_="desc:income"}, samplejournal) `gives`
([
("assets:bank:checking","assets:bank:checking",0,mamountp' "$1.00")
,("income:salary","income:salary",0, mamountp' "$-1.00")
],
Mixed [nullamt])
,"accountsReport with not:desc:" ~: do
(defreportopts{query_="not:desc:income"}, samplejournal) `gives`
([
("assets","assets",0, mamountp' "$-2.00")
,("assets:bank","bank",1, Mixed [nullamt])
,("assets:bank:checking","checking",2,mamountp' "$-1.00")
,("assets:bank:saving","saving",2, mamountp' "$1.00")
,("assets:cash","cash",1, mamountp' "$-2.00")
,("expenses","expenses",0, mamountp' "$2.00")
,("expenses:food","food",1, mamountp' "$1.00")
,("expenses:supplies","supplies",1, mamountp' "$1.00")
,("income:gifts","income:gifts",0, mamountp' "$-1.00")
,("liabilities:debts","liabilities:debts",0, mamountp' "$1.00")
],
Mixed [nullamt])
]
Right samplejournal2 = journalBalanceTransactions $
nulljournal
{jtxns = [
txnTieKnot $ Transaction {
tdate=parsedate "2008/01/01",
tdate2=Just $ parsedate "2009/01/01",
tstatus=False,
tcode="",
tdescription="income",
tcomment="",
ttags=[],
tpostings=
[posting {paccount="assets:bank:checking", pamount=Mixed [usd 1]}
,posting {paccount="income:salary", pamount=missingmixedamt}
],
tpreceding_comment_lines=""
}
]
}
tests_Hledger_Reports :: Test
tests_Hledger_Reports = TestList $
tests_queryFromOpts
++ tests_queryOptsFromOpts
++ tests_entriesReport
++ tests_summarisePostingsByInterval
++ tests_postingsReport
++ tests_accountsReport
++ [
]