266 lines
13 KiB
Haskell
266 lines
13 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# LANGUAGE MultiWayIf #-}
|
|
|
|
module Hledger.Cli.Commands.Close (
|
|
closemode
|
|
,close
|
|
)
|
|
where
|
|
|
|
import Data.Function (on)
|
|
import Data.List (groupBy)
|
|
import Data.Maybe (fromMaybe)
|
|
import qualified Data.Text as T
|
|
import qualified Data.Text.IO as T
|
|
import Data.Time.Calendar (addDays)
|
|
import System.Console.CmdArgs.Explicit as C
|
|
|
|
import Hledger
|
|
import Hledger.Cli.CliOptions
|
|
import Safe (lastDef, readMay, readDef)
|
|
import System.FilePath (takeFileName)
|
|
import Data.Char (isDigit)
|
|
import Hledger.Read.RulesReader (parseBalanceAssertionType)
|
|
import Hledger.Cli.Commands.Print (roundFlag, amountStylesSetRoundingFromRawOpts)
|
|
|
|
defclosedesc = "closing balances"
|
|
defopendesc = "opening balances"
|
|
defretaindesc = "retain earnings"
|
|
|
|
defcloseacct = "equity:opening/closing balances"
|
|
defretainacct = "equity:retained earnings"
|
|
|
|
closemode = hledgerCommandMode
|
|
$(embedFileRelative "Hledger/Cli/Commands/Close.txt")
|
|
[flagOpt "" ["migrate"] (\s opts -> Right $ setopt "migrate" s opts) "NEW" ("show closing and opening transactions,"
|
|
<> " for Asset and Liability accounts by default, tagged for easy matching."
|
|
<> " The tag's default value can be overridden by providing NEW."
|
|
)
|
|
,flagOpt "" ["close"] (\s opts -> Right $ setopt "close" s opts) "NEW" "(default) show a closing transaction"
|
|
,flagOpt "" ["open"] (\s opts -> Right $ setopt "open" s opts) "NEW" "show an opening transaction"
|
|
,flagOpt "" ["assign"] (\s opts -> Right $ setopt "assign" s opts) "NEW" "show opening balance assignments"
|
|
,flagOpt "" ["assert"] (\s opts -> Right $ setopt "assert" s opts) "NEW" "show closing balance assertions"
|
|
,flagOpt "" ["retain"] (\s opts -> Right $ setopt "retain" s opts) "NEW" "show a retain earnings transaction, for Revenue and Expense accounts by default"
|
|
,flagNone ["explicit","x"] (setboolopt "explicit") "show all amounts explicitly"
|
|
,flagNone ["show-costs"] (setboolopt "show-costs") "show amounts with different costs separately"
|
|
,flagNone ["interleaved"] (setboolopt "interleaved") "show source and destination postings together"
|
|
,flagReq ["assertion-type"] (\s opts -> Right $ setopt "assertion-type" s opts) "TYPE" "=, ==, =* or ==*"
|
|
,flagReq ["close-desc"] (\s opts -> Right $ setopt "close-desc" s opts) "DESC" "set closing transaction's description"
|
|
,flagReq ["close-acct"] (\s opts -> Right $ setopt "close-acct" s opts) "ACCT" "set closing transaction's destination account"
|
|
,flagReq ["open-desc"] (\s opts -> Right $ setopt "open-desc" s opts) "DESC" "set opening transaction's description"
|
|
,flagReq ["open-acct"] (\s opts -> Right $ setopt "open-acct" s opts) "ACCT" "set opening transaction's source account"
|
|
,roundFlag
|
|
]
|
|
cligeneralflagsgroups1
|
|
(hiddenflags
|
|
++ -- keep supporting old flag names for compatibility
|
|
[flagNone ["closing"] (setboolopt "close") "old spelling of --close"
|
|
,flagNone ["opening"] (setboolopt "open") "old spelling of --open"
|
|
,flagReq ["close-to"] (\s opts -> Right $ setopt "close-acct" s opts) "ACCT" "old spelling of --close-acct"
|
|
,flagReq ["open-from"] (\s opts -> Right $ setopt "open-acct" s opts) "ACCT" "old spelling of --open-acct"
|
|
]
|
|
)
|
|
([], Just $ argsFlag "[--migrate|--close|--open|--assign|--assert|--retain] [ACCTQUERY]")
|
|
|
|
-- | The close command's mode (subcommand).
|
|
-- The code depends on these spellings.
|
|
data CloseMode = Migrate | Close | Open | Assign | Assert | Retain deriving (Eq,Show,Read)
|
|
|
|
-- | Pick the rightmost flag spelled like a CloseMode (--migrate, --close, --open, etc), or default to Close.
|
|
closeModeFromRawOpts :: RawOpts -> CloseMode
|
|
closeModeFromRawOpts rawopts = lastDef Close $ collectopts (\(name,_) -> readMay (capitalise name)) rawopts
|
|
|
|
-- Debugger, beware: close is incredibly devious; simple rules combine to make a horrid maze.
|
|
-- Tests are in hledger/test/close.test.
|
|
close CliOpts{rawopts_=rawopts, reportspec_=rspec0} j = do
|
|
let
|
|
mode_ = closeModeFromRawOpts rawopts
|
|
defacctsq_ = if mode_ == Retain then Type [Revenue, Expense] else Type [Asset, Liability]
|
|
defcloseacct_ = if mode_ == Retain then defretainacct else defcloseacct
|
|
closeacct = T.pack $ fromMaybe defcloseacct_ $ maybestringopt "close-acct" rawopts
|
|
openacct = maybe closeacct T.pack $ maybestringopt "open-acct" rawopts
|
|
|
|
-- For easy matching and exclusion, a recognisable tag is added to all generated transactions
|
|
tagval = fromMaybe "" $ maybestringopt modeflag rawopts where modeflag = lowercase $ show mode_
|
|
comment = T.pack $ if
|
|
| mode_ == Assert -> "assert:" <> tagval
|
|
| mode_ == Assign -> "assign:" <> tagval
|
|
| mode_ == Retain -> "retain:" <> tagval
|
|
| otherwise -> "clopen:" <> if null tagval then inferredval else tagval
|
|
where
|
|
inferredval = newfilename
|
|
where
|
|
oldfilename = takeFileName $ journalFilePath j
|
|
(nonnum, rest) = break isDigit $ reverse oldfilename
|
|
(oldnum, rest2) = span isDigit rest
|
|
newfilename = case oldnum of
|
|
[] -> ""
|
|
_ -> reverse rest2 <> newnum <> reverse nonnum
|
|
where
|
|
newnum = show $ 1 + readDef err (reverse oldnum) -- PARTIAL: should not fail
|
|
where err = error' $ "could not read " <> show oldnum <> " as a number in Hledger.Cli.Commands.Close.close"
|
|
|
|
ropts = (_rsReportOpts rspec0){balanceaccum_=Historical, accountlistmode_=ALFlat}
|
|
rspec1 = setDefaultConversionOp NoConversionOp rspec0{_rsReportOpts=ropts}
|
|
|
|
-- Dates of the closing and opening transactions.
|
|
-- "The default closing date is yesterday, or the journal's end date, whichever is later.
|
|
-- You can change this by specifying a [report end date](#report-start--end-date) with `-e`.
|
|
-- The last day of the report period will be the closing date, eg `-e 2024` means "close on 2023-12-31".
|
|
-- The opening date is always the day after the closing date."
|
|
argsq = _rsQuery rspec1
|
|
yesterday = addDays (-1) $ _rsDay rspec1
|
|
yesterdayorjournalend = case journalLastDay False j of
|
|
Just journalend -> max yesterday journalend
|
|
Nothing -> yesterday
|
|
mreportlastday = addDays (-1) <$> queryEndDate False argsq
|
|
closedate = fromMaybe yesterdayorjournalend mreportlastday
|
|
opendate = addDays 1 closedate
|
|
|
|
-- should we show the amount(s) on the equity posting(s) ?
|
|
explicit = boolopt "explicit" rawopts
|
|
|
|
-- the accounts to close
|
|
argsacctq = filterQuery (\q -> queryIsAcct q || queryIsType q) argsq
|
|
q2 = if queryIsNull argsacctq then And [argsq, defacctsq_] else argsq
|
|
-- always exclude the balancing equity account
|
|
q3 = And [q2, Not $ Acct $ accountNameToAccountOnlyRegex closeacct]
|
|
-- the balances to close
|
|
rspec3 = rspec1{_rsQuery=q3}
|
|
(acctbals',_) = balanceReport rspec3 j
|
|
acctbals = map (\(a,_,_,b) -> (a, if show_costs_ ropts then b else mixedAmountStripCosts b)) acctbals'
|
|
totalamt = maSum $ map snd acctbals
|
|
|
|
-- since balance assertion amounts are required to be exact, the
|
|
-- amounts in opening/closing transactions should be too (#941, #1137)
|
|
precise = amountSetFullPrecision
|
|
|
|
-- interleave equity postings next to the corresponding closing posting, or put them all at the end ?
|
|
interleaved = boolopt "interleaved" rawopts
|
|
|
|
-- a balance assertion template of the right type
|
|
assertion =
|
|
case maybestringopt "assertion-type" rawopts >>= parseBalanceAssertionType of
|
|
Nothing -> nullassertion
|
|
Just (total, inclusive) -> nullassertion{batotal=total, bainclusive=inclusive}
|
|
|
|
-- the closing (balance-asserting or balance-zeroing) transaction
|
|
mclosetxn
|
|
| mode_ `notElem` [Migrate, Close, Assert, Retain] = Nothing
|
|
| otherwise = Just nulltransaction{
|
|
tdate=closedate, tdescription=closedesc, tcomment=comment, tpostings=closeps
|
|
}
|
|
where
|
|
closedesc = T.pack $ fromMaybe defclosedesc_ $ maybestringopt "close-desc" rawopts
|
|
where
|
|
defclosedesc_
|
|
| mode_ == Retain = defretaindesc
|
|
| mode_ == Assert = "assert balances"
|
|
| otherwise = defclosedesc
|
|
closeps
|
|
-- XXX some duplication
|
|
| mode_ == Assert =
|
|
[ posting{
|
|
paccount = a
|
|
,pamount = mixedAmount $ precise b{aquantity=0, acost=Nothing}
|
|
-- after each commodity's last posting, assert 0 balance (#1035)
|
|
-- balance assertion amounts are unpriced (#824)
|
|
,pbalanceassertion =
|
|
if islast
|
|
then Just assertion{baamount=precise b}
|
|
else Nothing
|
|
}
|
|
| -- get the balances for each commodity and transaction price
|
|
(a,mb) <- acctbals
|
|
, let bs0 = amounts mb
|
|
-- mark the last balance in each commodity with True
|
|
, let bs2 = concat [reverse $ zip (reverse bs1) (True : repeat False)
|
|
| bs1 <- groupBy ((==) `on` acommodity) bs0]
|
|
, (b, islast) <- bs2
|
|
]
|
|
|
|
| otherwise =
|
|
concat [
|
|
posting{paccount = a
|
|
,pamount = mixedAmount . precise $ negate b
|
|
-- after each commodity's last posting, assert 0 balance (#1035)
|
|
-- balance assertion amounts are unpriced (#824)
|
|
,pbalanceassertion =
|
|
if islast
|
|
then Just assertion{baamount=precise b{aquantity=0, acost=Nothing}}
|
|
else Nothing
|
|
}
|
|
|
|
-- maybe an interleaved posting transferring this balance to equity
|
|
: [posting{paccount=closeacct, pamount=mixedAmount $ precise b} | interleaved]
|
|
|
|
| -- get the balances for each commodity and transaction price
|
|
(a,mb) <- acctbals
|
|
, let bs0 = amounts mb
|
|
-- mark the last balance in each commodity with True
|
|
, let bs2 = concat [reverse $ zip (reverse bs1) (True : repeat False)
|
|
| bs1 <- groupBy ((==) `on` acommodity) bs0]
|
|
, (b, islast) <- bs2
|
|
]
|
|
|
|
-- or a final multicommodity posting transferring all balances to equity
|
|
-- (print will show this as multiple single-commodity postings)
|
|
++ [posting{paccount=closeacct, pamount=if explicit then mixedAmountSetFullPrecision totalamt else missingmixedamt} | not interleaved]
|
|
|
|
-- the opening (balance-assigning or balance-unzeroing) transaction
|
|
mopentxn
|
|
| mode_ `notElem` [Migrate, Open, Assign] = Nothing
|
|
| otherwise = Just nulltransaction{
|
|
tdate=opendate, tdescription=opendesc, tcomment=comment, tpostings=openps
|
|
}
|
|
where
|
|
opendesc = T.pack $ fromMaybe defopendesc $ maybestringopt "open-desc" rawopts
|
|
openps
|
|
| mode_ == Assign =
|
|
[ posting{paccount = a
|
|
,pamount = missingmixedamt
|
|
,pbalanceassertion = Just assertion{baamount=b}
|
|
-- case mcommoditysum of
|
|
-- Just s -> Just nullassertion{baamount=precise s}
|
|
-- Nothing -> Nothing
|
|
}
|
|
|
|
| (a,mb) <- acctbals
|
|
, let bs0 = amounts mb
|
|
-- mark the last balance in each commodity with the unpriced sum in that commodity (for a balance assertion)
|
|
, let bs2 = concat [reverse $ zip (reverse bs1) (Just commoditysum : repeat Nothing)
|
|
| bs1 <- groupBy ((==) `on` acommodity) bs0
|
|
, let commoditysum = (sum bs1)]
|
|
, (b, _mcommoditysum) <- bs2
|
|
]
|
|
++ [posting{paccount=openacct, pamount=if explicit then mixedAmountSetFullPrecision (maNegate totalamt) else missingmixedamt} | not interleaved]
|
|
|
|
| otherwise =
|
|
concat [
|
|
posting{paccount = a
|
|
,pamount = mixedAmount $ precise b
|
|
,pbalanceassertion =
|
|
case mcommoditysum of
|
|
Just s -> Just assertion{baamount=precise s{acost=Nothing}}
|
|
Nothing -> Nothing
|
|
}
|
|
: [posting{paccount=openacct, pamount=mixedAmount . precise $ negate b} | interleaved]
|
|
|
|
| (a,mb) <- acctbals
|
|
, let bs0 = amounts mb
|
|
-- mark the last balance in each commodity with the unpriced sum in that commodity (for a balance assertion)
|
|
, let bs2 = concat [reverse $ zip (reverse bs1) (Just commoditysum : repeat Nothing)
|
|
| bs1 <- groupBy ((==) `on` acommodity) bs0
|
|
, let commoditysum = (sum bs1)]
|
|
, (b, mcommoditysum) <- bs2
|
|
]
|
|
++ [posting{paccount=openacct, pamount=if explicit then mixedAmountSetFullPrecision (maNegate totalamt) else missingmixedamt} | not interleaved]
|
|
|
|
-- print them
|
|
-- allow user-specified rounding with --round, like print
|
|
let styles = amountStylesSetRoundingFromRawOpts rawopts $ journalCommodityStyles j
|
|
maybe (pure ()) (T.putStr . showTransaction . styleAmounts styles) mclosetxn
|
|
maybe (pure ()) (T.putStr . showTransaction . styleAmounts styles) mopentxn
|
|
|