2021-01-12 21:55:00 +03:00
|
|
|
#!/usr/bin/env stack
|
|
|
|
-- stack runghc --verbosity info --package hledger
|
bin: switch scripts to "stack ghc" and "env -S" (#1453)
Using stack's script command meant that the scripts needed to be
compatible, and regularly tested, with a hledger release in stackage,
rather than the latest hledger source. This created hassles for
maintainers, contributors and sometimes for users.
To simplify things overall, we now require script users to check out
the hledger source tree and run the scripts (or, bin/compile.sh) from
there once so they compile themselves. Some notes on alternative
setups are included (in one of the scripts, and referenced by the
others). This ensures that users and our CI tests are building scripts
the same way.
Current stack does not allow a stack options line to be used with the
"stack ghc" command, unfortunately, so instead we are using env's -S
flag, which hopefully has sufficiently wide support by now, and
putting all arguments in the shebang line.
This method will probably require complete explicit --package options,
unlike "stack script", so more testing and tweaking is expected.
Probably we're going to end up with some long shebang lines.
This isn't pretty but seems like a possible way to keep things
manageable.
2021-01-12 04:42:13 +03:00
|
|
|
-- See hledger-check-fancyassertions.hs
|
|
|
|
--package string-qq
|
2020-08-15 19:59:59 +03:00
|
|
|
|
2021-01-12 21:55:00 +03:00
|
|
|
|
2020-01-23 23:53:43 +03:00
|
|
|
-- This is an unfinished prototype, see https://github.com/simonmichael/hledger/issues/1171
|
2020-01-23 23:40:25 +03:00
|
|
|
-- Requires a contemporaneous version of the hledger package.
|
|
|
|
-- Requires journal entries to be sorted by date.
|
2018-07-17 01:36:06 +03:00
|
|
|
-- Run it inside an up to date hledger source tree, eg: bin/hledger-smooth.hs ACCT
|
|
|
|
-- Or add bin/ to $PATH and [stack ghc bin/hledger-smooth;] hledger smooth ACCT
|
|
|
|
|
|
|
|
{-# LANGUAGE QuasiQuotes #-}
|
|
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
2020-01-23 23:03:52 +03:00
|
|
|
{-# OPTIONS_GHC -Wall -Wno-missing-signatures -Wno-name-shadowing #-}
|
2018-07-17 01:36:06 +03:00
|
|
|
|
|
|
|
import Data.List
|
|
|
|
import Data.Maybe
|
2020-01-23 23:02:55 +03:00
|
|
|
import Data.String.QQ (s)
|
2018-07-17 01:36:06 +03:00
|
|
|
import qualified Data.Text as T
|
|
|
|
import Data.Time.Calendar
|
|
|
|
import Safe
|
2020-01-23 23:03:52 +03:00
|
|
|
-- import Hledger
|
2018-07-17 01:36:06 +03:00
|
|
|
import Hledger.Cli
|
|
|
|
|
|
|
|
------------------------------------------------------------------------------
|
|
|
|
cmdmode = hledgerCommandMode
|
2020-01-23 23:02:55 +03:00
|
|
|
[s| smooth
|
2018-07-17 01:36:06 +03:00
|
|
|
Like the print command, but splits any posting to ACCT (a full account name)
|
|
|
|
into multiple daily postings having a similar overall effect.
|
|
|
|
|
|
|
|
Each posting is smoothed across the period until the next ACCT posting, and
|
|
|
|
the last one is smoothed until the report end date, or today.
|
|
|
|
Eg: $30 on 1/1 and $50 on 1/4, if smoothed on 1/6 with no end date specified,
|
|
|
|
becomes $10 on 1/1, $10 on 1/2, $10 on 1/3, $25 on 1/4, $25 on 1/5.
|
|
|
|
|
|
|
|
The last new posting's amount is left blank to ensure a balanced transaction.
|
|
|
|
It can differ from the others.
|
|
|
|
|
|
|
|
Useful for preprocessing a journal to smooth out irregular revenues or
|
|
|
|
expenses in daily/weekly/monthly reports, eg:
|
|
|
|
hledger smooth revenues:consulting | hledger -f- incomestatement -W
|
|
|
|
|
2020-08-15 21:29:35 +03:00
|
|
|
_FLAGS
|
2018-07-17 01:36:06 +03:00
|
|
|
|]
|
2019-07-15 13:28:52 +03:00
|
|
|
[]
|
2018-07-17 01:36:06 +03:00
|
|
|
[generalflagsgroup1]
|
|
|
|
[]
|
|
|
|
([], Just $ argsFlag "ACCT")
|
|
|
|
------------------------------------------------------------------------------
|
|
|
|
-- we could smooth postings across the journal period, or within standard intervals: --smooth-interval=posting|journal|weekly|monthly|...
|
|
|
|
-- we could perhaps split transactions instead: --smooth-split=postings|transactions
|
|
|
|
|
|
|
|
main :: IO ()
|
|
|
|
main = do
|
2020-12-30 09:59:12 +03:00
|
|
|
copts@CliOpts{reportspec_=rspec, rawopts_} <- getHledgerCliOpts cmdmode
|
|
|
|
let ropts = rsOpts rspec
|
|
|
|
copts' = copts{
|
2019-07-17 01:36:37 +03:00
|
|
|
-- One of our postings will probably have a missing amount; this ensures it's
|
|
|
|
-- explicit on all the others.
|
2020-12-30 09:59:12 +03:00
|
|
|
rawopts_ = setboolopt "explicit" rawopts_
|
2019-07-17 01:36:37 +03:00
|
|
|
-- Don't let our ACCT argument be interpreted as a query by print
|
2020-12-30 09:59:12 +03:00
|
|
|
,reportspec_ = rspec{rsOpts=ropts{querystring_=[]}}
|
2019-07-17 01:36:37 +03:00
|
|
|
}
|
|
|
|
withJournalDo copts' $ \j -> do
|
2018-07-17 01:36:06 +03:00
|
|
|
today <- getCurrentDay
|
|
|
|
let
|
2020-12-30 09:59:12 +03:00
|
|
|
menddate = reportPeriodLastDay rspec
|
|
|
|
q = rsQuery rspec
|
|
|
|
acct = headDef (error' "Please provide an account name argument") $ querystring_ ropts
|
|
|
|
pr = postingsReport rspec{rsQuery = And [Acct $ accountNameToAccountRegexCI acct, q]} j
|
2019-07-15 13:28:52 +03:00
|
|
|
|
2018-07-17 01:36:06 +03:00
|
|
|
-- dates of postings to acct (in report)
|
2021-01-01 01:43:00 +03:00
|
|
|
pdates = map (postingDate . fourth5) pr
|
2018-07-17 01:36:06 +03:00
|
|
|
-- the specified report end date or today's date
|
|
|
|
enddate = fromMaybe today menddate
|
|
|
|
dates = pdates ++ [enddate]
|
|
|
|
(_,ts') = mapAccumL (splitTransactionPostings q acct) dates $ jtxns j
|
|
|
|
j' = j{jtxns=ts'}
|
|
|
|
print' copts' j'
|
|
|
|
|
|
|
|
-- | Split a transaction's postings to acct, if the transaction is matched by q,
|
|
|
|
-- into equivalent daily postings up to the next given end date,
|
|
|
|
-- keeping track of remaining end dates.
|
|
|
|
splitTransactionPostings :: Query -> AccountName -> [Day] -> Transaction -> ([Day], Transaction)
|
2019-07-17 01:58:50 +03:00
|
|
|
splitTransactionPostings _q acct dates t
|
2018-07-17 01:36:06 +03:00
|
|
|
-- | q `matchesTransaction` t = (dates', t')
|
|
|
|
-- | otherwise = (dates, t)
|
|
|
|
| otherwise = (dates', t')
|
|
|
|
where
|
|
|
|
(dates', pss') = mapAccumL (splitPosting acct) dates $ tpostings t
|
|
|
|
t' = txnTieKnot t{tpostings=concat pss'}
|
|
|
|
|
|
|
|
-- | Split a posting to acct into equivalent daily postings
|
|
|
|
-- up to the next given end date, keeping track of remaining end dates.
|
|
|
|
-- We assume we will see postings in number and order corresponding the given end dates.
|
|
|
|
splitPosting :: AccountName -> [Day] -> Posting -> ([Day], [Posting])
|
|
|
|
splitPosting acct dates p@Posting{paccount,pamount}
|
|
|
|
| paccount == acct = (dates', ps')
|
|
|
|
| otherwise = (dates, [p])
|
|
|
|
where
|
|
|
|
start = dbg4 "start" $ postingDate p
|
|
|
|
(end, dates') =
|
|
|
|
case dbg4 "dates" dates of
|
2020-01-23 23:40:25 +03:00
|
|
|
-- XXX fragile, breaks if transactions are not date-ordered
|
|
|
|
(d1:d2:ds) -> if d1==start then (d2, d2:ds) else error' "splitPosting got wrong date, should not happen (maybe sort your transactions by date)"
|
2018-07-17 01:36:06 +03:00
|
|
|
[d] -> (d, [])
|
2020-01-23 23:40:25 +03:00
|
|
|
[] -> error' "splitPosting ran out of dates, should not happen (maybe sort your transactions by date)"
|
2018-07-17 01:36:06 +03:00
|
|
|
days = initSafe [start..end]
|
2020-08-10 04:09:40 +03:00
|
|
|
amt = (genericLength days) `divideMixedAmount` pamount
|
2018-07-17 01:36:06 +03:00
|
|
|
-- give one of the postings an exact balancing amount to ensure the transaction is balanced
|
|
|
|
-- lastamt = pamount - ptrace (amt `multiplyMixedAmount` (fromIntegral $ length days))
|
|
|
|
lastamt = missingmixedamt
|
|
|
|
daysamts = zip days (take (length days - 1) (repeat amt) ++ [lastamt])
|
|
|
|
ps' = [postingSetDate (Just d) p{pamount=a} | (d,a) <- daysamts ]
|
|
|
|
|
|
|
|
-- | Set a posting's (primary) date, as if it had been parsed from the journal entry:
|
|
|
|
-- Updates the date field,
|
|
|
|
-- adds a "date" tag to the parsed tag list (replacing any existing "date" tags there),
|
|
|
|
-- and adds the "date" tag to the unparsed comment field as well, for display purposes.
|
|
|
|
-- If the date is Nothing, unsets the date and removes it from the tags list.
|
|
|
|
-- Does not remove existing date tags from the comment field.
|
|
|
|
postingSetDate :: Maybe Day -> Posting -> Posting
|
|
|
|
postingSetDate md p@Posting{ptags,pcomment} = p{pdate=md, ptags=ptags'', pcomment=pcomment'}
|
|
|
|
where
|
|
|
|
ptags'' = case md of
|
|
|
|
Nothing -> ptags'
|
|
|
|
Just d -> ptags'++[("date", T.pack $ show d)]
|
|
|
|
where
|
|
|
|
ptags' = filter (not.(=="date").fst) ptags
|
|
|
|
|
|
|
|
pcomment' = case md of
|
|
|
|
Nothing -> pcomment
|
2020-01-23 23:22:24 +03:00
|
|
|
Just d -> commentAddTag pcomment ("date:", T.pack $ show d)
|