module Hledger.Cli.Commands.Register (
RegisterReport
,RegisterReportItem
,register
,registerReport
,registerReportAsText
,showPostingWithBalanceForVty
,tests_Register
) where
import Safe (headMay, lastMay)
import Hledger.Data
import Hledger.Cli.Options
#if __GLASGOW_HASKELL__ <= 610
import Prelude hiding ( putStr )
import System.IO.UTF8
#endif
import Text.ParserCombinators.Parsec
type RegisterReport = [RegisterReportItem]
type RegisterReportItem = (Maybe (Day, String)
,Posting
,MixedAmount
)
register :: [Opt] -> [String] -> Journal -> IO ()
register opts args j = do
t <- getCurrentLocalTime
putStr $ registerReportAsText opts $ registerReport opts (optsToFilterSpec opts args t) j
registerReportAsText :: [Opt] -> RegisterReport -> String
registerReportAsText opts = unlines . map (registerReportItemAsText opts)
registerReportItemAsText :: [Opt] -> RegisterReportItem -> String
registerReportItemAsText _ (dd, p, b) = concatTopPadded [datedesc, pstr, " ", bal]
where
datedesc = case dd of Nothing -> replicate datedescwidth ' '
Just (da, de) -> printf "%s %s " date desc
where
date = showDate da
desc = printf ("%-"++(show descwidth)++"s") $ elideRight descwidth de :: String
where
descwidth = datedescwidth datewidth 2
datedescwidth = 32
datewidth = 10
pstr = showPostingForRegister p
bal = padleft 12 (showMixedAmountOrZeroWithoutPrice b)
showPostingWithBalanceForVty showtxninfo p b = registerReportItemAsText [] $ mkitem showtxninfo p b
registerReport :: [Opt] -> FilterSpec -> Journal -> RegisterReport
registerReport opts fspec j = getitems ps nullposting startbal
where
ps | interval == NoInterval = displayableps
| otherwise = summarisePostingsByInterval interval depth empty filterspan displayableps
(precedingps, displayableps, _) = postingsMatchingDisplayExpr (displayExprFromOpts opts)
$ depthClipPostings depth
$ journalPostings
$ filterJournalPostings fspec{depth=Nothing} j
startbal = sumPostings precedingps
filterspan = datespan fspec
(interval, depth, empty) = (intervalFromOpts opts, depthFromOpts opts, Empty `elem` opts)
getitems :: [Posting] -> Posting -> MixedAmount -> [RegisterReportItem]
getitems [] _ _ = []
getitems (p:ps) pprev b = i:(getitems ps p b')
where
i = mkitem isfirst p b'
isfirst = ptransaction p /= ptransaction pprev
b' = b + pamount p
mkitem :: Bool -> Posting -> MixedAmount -> RegisterReportItem
mkitem False p b = (Nothing, p, b)
mkitem 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 -> 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)
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}
tests_Register :: Test
tests_Register = TestList [
"summarisePostingsByInterval" ~: do
summarisePostingsByInterval Quarterly Nothing False (DateSpan Nothing Nothing) [] ~?= []
]