module Hledger.Reports (
ReportOpts(..),
DisplayExp,
FormatStr,
defreportopts,
dateSpanFromOpts,
intervalFromOpts,
clearedValueFromOpts,
whichDateFromOpts,
journalSelectingDateFromOpts,
journalSelectingAmountFromOpts,
optsToFilterSpec,
EntriesReport,
EntriesReportItem,
entriesReport,
PostingsReport,
PostingsReportItem,
postingsReport,
mkpostingsReportItem,
TransactionsReport,
TransactionsReportItem,
triDate,
triBalance,
journalTransactionsReport,
accountTransactionsReport,
AccountsReport,
AccountsReportItem,
accountsReport,
accountsReport2,
isInteresting,
tests_Hledger_Reports
)
where
import Control.Monad
import Data.List
import Data.Maybe
import Data.Ord
import Data.Time.Calendar
import Data.Tree
import Safe (headMay, lastMay)
import System.Console.CmdArgs
import Test.HUnit
import Text.ParserCombinators.Parsec
import Text.Printf
import Hledger.Data
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
,patterns_ :: [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
journalSelectingDateFromOpts :: ReportOpts -> Journal -> Journal
journalSelectingDateFromOpts opts = journalSelectingDate (whichDateFromOpts opts)
journalSelectingAmountFromOpts :: ReportOpts -> Journal -> Journal
journalSelectingAmountFromOpts opts
| cost_ opts = journalConvertAmountsToCost
| otherwise = id
optsToFilterSpec :: ReportOpts -> Day -> FilterSpec
optsToFilterSpec opts@ReportOpts{..} d = FilterSpec {
datespan=dateSpanFromOpts d opts
,cleared= clearedValueFromOpts opts
,real=real_
,empty=empty_
,acctpats=apats
,descpats=dpats
,depth = depth_
}
where (apats,dpats) = parsePatternArgs patterns_
parsePatternArgs :: [String] -> ([String],[String])
parsePatternArgs args = (as, ds')
where
descprefix = "desc:"
(ds, as) = partition (descprefix `isPrefixOf`) args
ds' = map (drop (length descprefix)) ds
type EntriesReport = [EntriesReportItem]
type EntriesReportItem = Transaction
entriesReport :: ReportOpts -> FilterSpec -> Journal -> EntriesReport
entriesReport opts fspec j = sortBy (comparing tdate) $ jtxns $ filterJournalTransactions fspec j'
where
j' = journalSelectingDateFromOpts opts $ journalSelectingAmountFromOpts opts j
type PostingsReport = (String
,[PostingsReportItem]
)
type PostingsReportItem = (Maybe (Day, String)
,Posting
,MixedAmount
)
postingsReport :: ReportOpts -> FilterSpec -> Journal -> PostingsReport
postingsReport opts fspec j = (totallabel, postingsReportItems ps nullposting startbal (+))
where
ps | interval == NoInterval = displayableps
| otherwise = summarisePostingsByInterval interval depth empty filterspan displayableps
(precedingps, displayableps, _) = postingsMatchingDisplayExpr (display_ opts)
$ depthClipPostings depth
$ journalPostings
$ filterJournalPostings fspec{depth=Nothing}
$ journalSelectingDateFromOpts opts
$ journalSelectingAmountFromOpts opts
j
startbal = sumPostings precedingps
filterspan = datespan fspec
(interval, depth, empty) = (intervalFromOpts opts, depth_ opts, empty_ opts)
totallabel = "Total"
balancelabel = "Balance"
postingsReportItems :: [Posting] -> Posting -> MixedAmount -> (MixedAmount -> MixedAmount -> MixedAmount) -> [PostingsReportItem]
postingsReportItems [] _ _ _ = []
postingsReportItems (p:ps) pprev b sumfn = i:(postingsReportItems ps p b' sumfn)
where
i = mkpostingsReportItem isfirst p b'
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) ["<=",">=","==","<","=",">"]
depthClipPostings :: Maybe Int -> [Posting] -> [Posting]
depthClipPostings depth = map (depthClipPosting depth)
depthClipPosting :: Maybe Int -> Posting -> Posting
depthClipPosting Nothing p = p
depthClipPosting (Just d) p@Posting{paccount=a} = p{paccount=clipAccountName d a}
summarisePostingsByInterval :: Interval -> Maybe Int -> Bool -> DateSpan -> [Posting] -> [Posting]
summarisePostingsByInterval interval depth empty filterspan ps = concatMap summarisespan $ splitSpan interval reportspan
where
summarisespan s = summarisePostingsInDateSpan s depth empty (postingsinspan s)
postingsinspan s = filter (isPostingInDateSpan s) ps
dataspan = postingsDateSpan ps
reportspan | empty = filterspan `orDatesFrom` dataspan
| otherwise = dataspan
summarisePostingsInDateSpan :: DateSpan -> Maybe 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 d) anames
isclipped a = accountNameLevel a >= d
d = fromMaybe 99999 $ 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 -> Matcher -> 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 -> Matcher -> Matcher -> TransactionsReport
accountTransactionsReport opts j m thisacctmatcher = (label, items)
where
ts = sortBy (comparing tdate) $ filter (matchesTransaction thisacctmatcher) $ jtxns $
journalSelectingDateFromOpts opts $ journalSelectingAmountFromOpts opts j
(startbal,label) | matcherIsNull m = (nullmixedamt, balancelabel)
| matcherIsStartDateOnly (effective_ opts) m = (sumPostings priorps, balancelabel)
| otherwise = (nullmixedamt, totallabel)
where
priorps =
filter (matchesPosting
(
MatchAnd [thisacctmatcher, tostartdatematcher]))
$ transactionsPostings ts
tostartdatematcher = MatchDate (DateSpan Nothing startdate)
startdate = matcherStartDate (effective_ opts) m
items = reverse $ accountTransactionsReportItems m (Just thisacctmatcher) startbal negate ts
accountTransactionsReportItems :: Matcher -> Maybe Matcher -> MixedAmount -> (MixedAmount -> MixedAmount) -> [Transaction] -> [TransactionsReportItem]
accountTransactionsReportItems _ _ _ _ [] = []
accountTransactionsReportItems matcher thisacctmatcher bal signfn (t:ts) =
case i of Just i' -> i':is
Nothing -> is
where
tmatched@Transaction{tpostings=psmatched} = filterTransactionPostings matcher t
(psthisacct,psotheracct) = case thisacctmatcher of Just m -> partition (matchesPosting m) psmatched
Nothing -> ([],psmatched)
numotheraccts = length $ nub $ map paccount psotheracct
amt = sum $ map pamount psotheracct
acct | isNothing thisacctmatcher = 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 matcher thisacctmatcher 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 :: Matcher -> 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 -> FilterSpec -> Journal -> AccountsReport
accountsReport opts filterspec j = accountsReport' opts j (journalToLedger filterspec)
accountsReport2 :: ReportOpts -> Matcher -> Journal -> AccountsReport
accountsReport2 opts matcher j = accountsReport' opts j (journalToLedger2 matcher)
accountsReport' :: ReportOpts -> Journal -> (Journal -> Ledger) -> AccountsReport
accountsReport' opts j jtol = (items, total)
where
items = map mkitem interestingaccts
interestingaccts | no_elide_ opts = acctnames
| otherwise = filter (isInteresting opts l) acctnames
acctnames = sort $ tail $ flatten $ treemap aname accttree
accttree = ledgerAccountTree (fromMaybe 99999 $ depth_ opts) l
total = sum $ map abalance $ ledgerTopAccounts l
l = jtol $ journalSelectingDateFromOpts opts $ journalSelectingAmountFromOpts opts j
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
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 && not atmaxdepth = notlikesub
| otherwise = notzero || emptyflag
where
atmaxdepth = isJust d && Just (accountNameLevel a) == d where d = depth_ opts
emptyflag = empty_ opts
acct = ledgerAccount l a
notzero = not $ isZeroMixedAmount inclbalance where inclbalance = abalance acct
notlikesub = not $ 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_Hledger_Reports :: Test
tests_Hledger_Reports = TestList
[
"summarisePostingsByInterval" ~: do
summarisePostingsByInterval (Quarters 1) Nothing False (DateSpan Nothing Nothing) [] ~?= []
]