module Hledger.Reports (
ReportOpts(..),
DisplayExp,
FormatStr,
defreportopts,
dateSpanFromOpts,
intervalFromOpts,
clearedValueFromOpts,
whichDateFromOpts,
journalSelectingDateFromOpts,
journalSelectingAmountFromOpts,
queryFromOpts,
queryOptsFromOpts,
EntriesReport,
EntriesReportItem,
entriesReport,
PostingsReport,
PostingsReportItem,
postingsReport,
mkpostingsReportItem,
TransactionsReport,
TransactionsReportItem,
triDate,
triBalance,
journalTransactionsReport,
accountTransactionsReport,
AccountsReport,
AccountsReportItem,
accountsReport,
isInteresting,
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 System.Time (ClockTime(TOD))
import Test.HUnit
import Text.ParserCombinators.Parsec
import Text.Printf
import Hledger.Data
import Hledger.Read (amount')
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
,effective_ :: 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
,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
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 effective_ then EffectiveDate else ActualDate
transactionDateFn :: ReportOpts -> (Transaction -> Day)
transactionDateFn ReportOpts{..} = if effective_ then transactionEffectiveDate else transactionActualDate
journalSelectingDateFromOpts :: ReportOpts -> Journal -> Journal
journalSelectingDateFromOpts opts = journalSelectingDate (whichDateFromOpts opts)
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 $
[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 "" (EDate $ 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, String)
,Posting
,MixedAmount
)
postingsReport :: ReportOpts -> Query -> Journal -> PostingsReport
postingsReport opts q j = (totallabel, postingsReportItems ps nullposting depth startbal (+))
where
ps | interval == NoInterval = displayableps
| otherwise = summarisePostingsByInterval interval depth empty reportspan displayableps
j' = journalSelectingDateFromOpts opts $ journalSelectingAmountFromOpts opts j
(depth, q') = (queryDepth q, filterQuery (not . queryIsDepth) q)
(precedingps, displayableps, _) = dbg "ps3" $ postingsMatchingDisplayExpr (display_ opts)
$ 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 effectivedate q
effectivedate = whichDateFromOpts opts == EffectiveDate
displayspan = postingsDateSpan ps
where (_,ps,_) = postingsMatchingDisplayExpr displayexpr $ journalPostings j'
matchedspan = postingsDateSpan displayableps
reportspan | empty = requestedspan `orDatesFrom` journalspan
| otherwise = requestedspan `spanIntersect` matchedspan
startbal = sumPostings precedingps
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
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)
]
totallabel = "Total"
balancelabel = "Balance"
postingsReportItems :: [Posting] -> Posting -> Int -> MixedAmount -> (MixedAmount -> MixedAmount -> MixedAmount) -> [PostingsReportItem]
postingsReportItems [] _ _ _ _ = []
postingsReportItems (p:ps) pprev d b sumfn = i:(postingsReportItems ps p d b' sumfn)
where
i = mkpostingsReportItem isfirst p' b'
p' = p{paccount=clipAccountName d $ paccount p}
isfirst = ptransaction p /= ptransaction pprev
b' = b `sumfn` pamount p
mkpostingsReportItem :: Bool -> Posting -> MixedAmount -> PostingsReportItem
mkpostingsReportItem False p b = (Nothing, p, b)
mkpostingsReportItem True p b = (ds, p, b)
where ds = case ptransaction p of Just (Transaction{tdate=da,tdescription=de}) -> Just (da,de)
Nothing -> Just (nulldate,"")
postingsMatchingDisplayExpr :: Maybe String -> [Posting] -> ([Posting],[Posting],[Posting])
postingsMatchingDisplayExpr d ps = (before, matched, after)
where
sorted = sortBy (comparing postingDate) 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=balancetoshowfor a} | a <- clippedanames]
anames = sort $ nub $ map paccount ps
(_,_,exclbalof,inclbalof) = groupPostings ps
clippedanames = nub $ map (clipAccountName depth) anames
isclipped a = accountNameLevel a >= depth
balancetoshowfor a =
(if isclipped a then inclbalof else exclbalof) (if null a then "top" else a)
type TransactionsReport = (String
,[TransactionsReportItem]
)
type TransactionsReportItem = (Transaction
,Transaction
,Bool
,String
,MixedAmount
,MixedAmount
)
triDate (t,_,_,_,_,_) = tdate t
triBalance (_,_,_,_,_,Mixed a) = case a of [] -> "0"
(Amount{quantity=q}):_ -> show q
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 $
journalSelectingDateFromOpts opts $ journalSelectingAmountFromOpts opts j
(startbal,label) | queryIsNull m = (nullmixedamt, balancelabel)
| queryIsStartDateOnly (effective_ opts) m = (sumPostings priorps, balancelabel)
| otherwise = (nullmixedamt, totallabel)
where
priorps =
filter (matchesPosting
(
And [thisacctquery, tostartdatequery]))
$ transactionsPostings ts
tostartdatequery = Date (DateSpan Nothing startdate)
startdate = queryStartDate (effective_ 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 query j = (items, total)
where
q' = filterQuery (not . queryIsDepth) query
l = journalToLedger q' $ journalSelectingDateFromOpts opts $ journalSelectingAmountFromOpts opts j
acctnames = filter (query `matchesAccount`) $ journalAccountNames j
interestingaccts | no_elide_ opts = acctnames
| otherwise = filter (isInteresting opts l) acctnames
items = map mkitem interestingaccts
total = sum $ map abalance $ ledgerTopAccounts l
mkitem :: AccountName -> AccountsReportItem
mkitem a = (a, adisplay, indent, abal)
where
adisplay | flat_ opts = a
| otherwise = accountNameFromComponents $ reverse (map accountLeafName ps) ++ [accountLeafName a]
where ps = takeWhile boring parents where boring = not . (`elem` interestingparents)
indent | flat_ opts = 0
| otherwise = length interestingparents
interestingparents = filter (`elem` interestingaccts) parents
parents = parentAccountNames a
abal | flat_ opts = exclusiveBalance acct
| otherwise = abalance acct
where acct = ledgerAccount l a
tests_accountsReport = [
"accountsReport" ~: do
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
(defreportopts, nulljournal) `gives` ([], Mixed [nullamt])
(defreportopts, samplejournal) `gives`
([
("assets","assets",0, amount' "$-1.00")
,("assets:bank:saving","bank:saving",1, amount' "$1.00")
,("assets:cash","cash",1, amount' "$-2.00")
,("expenses","expenses",0, amount' "$2.00")
,("expenses:food","food",1, amount' "$1.00")
,("expenses:supplies","supplies",1, amount' "$1.00")
,("income","income",0, amount' "$-2.00")
,("income:gifts","gifts",1, amount' "$-1.00")
,("income:salary","salary",1, amount' "$-1.00")
,("liabilities:debts","liabilities:debts",0, amount' "$1.00")
],
Mixed [nullamt])
(defreportopts{depth_=Just 1}, samplejournal) `gives`
([
("assets", "assets", 0, amount' "$-1.00")
,("expenses", "expenses", 0, amount' "$2.00")
,("income", "income", 0, amount' "$-2.00")
,("liabilities", "liabilities", 0, amount' "$1.00")
],
Mixed [nullamt])
(defreportopts{query_="depth:1"}, samplejournal) `gives`
([
("assets", "assets", 0, amount' "$-1.00")
,("expenses", "expenses", 0, amount' "$2.00")
,("income", "income", 0, amount' "$-2.00")
,("liabilities", "liabilities", 0, amount' "$1.00")
],
Mixed [nullamt])
(defreportopts{query_="date:'in 2009'"}, samplejournal2) `gives`
([],
Mixed [nullamt])
(defreportopts{query_="edate:'in 2009'"}, samplejournal2) `gives`
([
("assets:bank:checking","assets:bank:checking",0,amount' "$1.00")
,("income:salary","income:salary",0,amount' "$-1.00")
],
Mixed [nullamt])
]
Right samplejournal2 = journalBalanceTransactions $ Journal
[]
[]
[
txnTieKnot $ Transaction {
tdate=parsedate "2008/01/01",
teffectivedate=Just $ parsedate "2009/01/01",
tstatus=False,
tcode="",
tdescription="income",
tcomment="",
ttags=[],
tpostings=[
Posting {
pstatus=False,
paccount="assets:bank:checking",
pamount=(Mixed [dollars 1]),
pcomment="",
ptype=RegularPosting,
ptags=[],
ptransaction=Nothing
},
Posting {
pstatus=False,
paccount="income:salary",
pamount=(missingmixedamt),
pcomment="",
ptype=RegularPosting,
ptags=[],
ptransaction=Nothing
}
],
tpreceding_comment_lines=""
}
]
[]
[]
""
nullctx
[]
(TOD 0 0)
exclusiveBalance :: Account -> MixedAmount
exclusiveBalance = sumPostings . apostings
isInteresting :: ReportOpts -> Ledger -> AccountName -> Bool
isInteresting opts l a | flat_ opts = isInterestingFlat opts l a
| otherwise = isInterestingIndented opts l a
isInterestingFlat :: ReportOpts -> Ledger -> AccountName -> Bool
isInterestingFlat opts l a = notempty || emptyflag
where
acct = ledgerAccount l a
notempty = not $ isZeroMixedAmount $ exclusiveBalance acct
emptyflag = empty_ opts
isInterestingIndented :: ReportOpts -> Ledger -> AccountName -> Bool
isInterestingIndented opts l a
| numinterestingsubs == 1 && samebalanceassub && not atmaxdepth = False
| numinterestingsubs < 2 && zerobalance && not emptyflag = False
| otherwise = True
where
atmaxdepth = accountNameLevel a == depthFromOpts opts
emptyflag = empty_ opts
acct = ledgerAccount l a
zerobalance = isZeroMixedAmount inclbalance where inclbalance = abalance acct
samebalanceassub = isZeroMixedAmount exclbalance where exclbalance = sumPostings $ apostings acct
numinterestingsubs = length $ filter isInterestingTree subtrees
where
isInterestingTree = treeany (isInteresting opts l . aname)
subtrees = map (fromJust . ledgerAccountTreeAt l) $ ledgerSubAccounts l $ ledgerAccount l a
tests_isInterestingIndented = [
"isInterestingIndented" ~: do
let (opts, journal, acctname) `gives` r = isInterestingIndented opts l acctname `is` r
where l = journalToLedger (queryFromOpts nulldate opts) journal
(defreportopts, samplejournal, "expenses") `gives` True
]
depthFromOpts :: ReportOpts -> Int
depthFromOpts opts = min (fromMaybe 99999 $ depth_ opts) (queryDepth $ queryFromOpts nulldate opts)
tests_Hledger_Reports :: Test
tests_Hledger_Reports = TestList $
tests_queryFromOpts
++ tests_queryOptsFromOpts
++ tests_entriesReport
++ tests_summarisePostingsByInterval
++ tests_postingsReport
++ tests_isInterestingIndented
++ tests_accountsReport
++ [
]