diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -9,6 +9,38 @@ Internal/api/developer-ish changes in the hledger-lib (and hledger) packages. For user-visible changes, see the hledger package changelog. +# 1.24 2021-12-01 + +Improvements + +- The Semigroup instance of PeriodicReportRow and PeriodicReport now + preserves the first prrName, rather than the second. + (Stephen Morgan) + +- PeriodicReport and PeriodicReportRow now have Bifunctor instances. + (Stephen Morgan) + +- Move posting rendering functions into Hledger.Data.Posting. + This produces slightly different output for showPosting, in particular + it no longer displays the transaction date. However, this has been + marked as ‘for debugging only’ for a while. + (Stephen Morgan) + +- Drop postingDateOrDate2, transactionDateOrDate2; rename + whichDateFromOpts to whichDate. (#1731) + +- Added new helper functions journalValueAndFilterPostings(With) to make + valuation and filtration less error prone. + (Stephen Morgan) + +- Avoid deprecation warnings with safe 0.3.18+. + (Stephen Morgan) + +- Drop base-compat-batteries dependency. + (Stephen Morgan) + +- Allow megaparsec 9.2. + # 1.23 2021-09-21 - Require base >=4.11, prevent red squares on Hackage's build matrix. diff --git a/Hledger/Data/AccountName.hs b/Hledger/Data/AccountName.hs --- a/Hledger/Data/AccountName.hs +++ b/Hledger/Data/AccountName.hs @@ -46,6 +46,7 @@ import Data.Text (Text) import qualified Data.Text as T import Data.Tree (Tree(..)) +import Text.DocLayout (realLength) import Hledger.Data.Types import Hledger.Utils @@ -186,7 +187,7 @@ where elideparts :: Int -> [Text] -> [Text] -> [Text] elideparts width done ss - | textWidth (accountNameFromComponents $ done++ss) <= width = done++ss + | realLength (accountNameFromComponents $ done++ss) <= width = done++ss | length ss > 1 = elideparts width (done++[textTakeWidth 2 $ head ss]) (tail ss) | otherwise = done++ss diff --git a/Hledger/Data/Amount.hs b/Hledger/Data/Amount.hs --- a/Hledger/Data/Amount.hs +++ b/Hledger/Data/Amount.hs @@ -171,7 +171,7 @@ import Hledger.Data.Types import Hledger.Utils (colorB) import Hledger.Utils.Text (textQuoteIfNeeded) -import Text.WideString (WideBuilder(..), textWidth, wbToText, wbUnpack) +import Text.WideString (WideBuilder(..), wbFromText, wbToText, wbUnpack) -- A 'Commodity' is a symbol representing a currency or some other kind of @@ -244,7 +244,7 @@ abs a@Amount{aquantity=q} = a{aquantity=abs q} signum a@Amount{aquantity=q} = a{aquantity=signum q} fromInteger i = nullamt{aquantity=fromInteger i} - negate a = transformAmount negate a + negate = transformAmount negate (+) = similarAmountsOp (+) (-) = similarAmountsOp (-) (*) = similarAmountsOp (*) @@ -469,14 +469,13 @@ showAmountB _ Amount{acommodity="AUTO"} = mempty showAmountB opts a@Amount{astyle=style} = color $ case ascommodityside style of - L -> showC c' space <> quantity' <> price - R -> quantity' <> showC space c' <> price + L -> showC (wbFromText c) space <> quantity' <> price + R -> quantity' <> showC space (wbFromText c) <> price where quantity = showamountquantity a (quantity',c) | amountLooksZero a && not (displayZeroCommodity opts) = (WideBuilder (TB.singleton '0') 1,"") | otherwise = (quantity, quoteCommoditySymbolIfNeeded $ acommodity a) space = if not (T.null c) && ascommodityspaced style then WideBuilder (TB.singleton ' ') 1 else mempty - c' = WideBuilder (TB.fromText c) (textWidth c) showC l r = if isJust (displayOrder opts) then mempty else l <> r price = if displayPrice opts then showAmountPrice a else mempty color = if displayColour opts && isNegativeAmount a then colorB Dull Red else id @@ -914,12 +913,9 @@ withElided = zipWith (\num amt -> (amt, elisionDisplay Nothing (wbWidth sep) num amt)) [n-1,n-2..0] orderedAmounts :: AmountDisplayOpts -> MixedAmount -> [Amount] -orderedAmounts AmountDisplayOpts{displayOrder=ord} ma - | Just cs <- ord = fmap pad cs - | otherwise = as +orderedAmounts dopts = maybe id (mapM pad) (displayOrder dopts) . amounts where - as = amounts ma - pad c = fromMaybe (amountWithCommodity c nullamt) . find ((==) c . acommodity) $ as + pad c = fromMaybe (amountWithCommodity c nullamt) . find ((c==) . acommodity) data AmountDisplay = AmountDisplay diff --git a/Hledger/Data/Balancing.hs b/Hledger/Data/Balancing.hs --- a/Hledger/Data/Balancing.hs +++ b/Hledger/Data/Balancing.hs @@ -508,7 +508,7 @@ oldbalothercommodities <- filterMixedAmount ((acommodity baamount /=) . acommodity) <$> getRunningBalanceB acc return $ maAddAmount oldbalothercommodities baamount diff <- (if bainclusive then setInclusiveRunningBalanceB else setRunningBalanceB) acc newbal - let p' = p{pamount=diff, poriginal=Just $ originalPosting p} + let p' = p{pamount=filterMixedAmount (not . amountIsZero) diff, poriginal=Just $ originalPosting p} whenM (R.reader bsAssrt) $ checkBalanceAssertionB p' newbal return p' diff --git a/Hledger/Data/Dates.hs b/Hledger/Data/Dates.hs --- a/Hledger/Data/Dates.hs +++ b/Hledger/Data/Dates.hs @@ -79,18 +79,16 @@ ) where -import Prelude () -import "base-compat-batteries" Prelude.Compat hiding (fail) -import qualified "base-compat-batteries" Control.Monad.Fail.Compat as Fail (MonadFail, fail) +import qualified Control.Monad.Fail as Fail (MonadFail, fail) import Control.Applicative (liftA2) import Control.Applicative.Permutations import Control.Monad (guard, unless) -import "base-compat-batteries" Data.List.Compat import Data.Char (digitToInt, isDigit, ord) import Data.Default (def) import Data.Foldable (asum) import Data.Function (on) import Data.Functor (($>)) +import Data.List (elemIndex, group, sort, sortBy) import Data.Maybe (catMaybes, fromMaybe, isJust, mapMaybe) import Data.Ord (comparing) import qualified Data.Set as Set diff --git a/Hledger/Data/Journal.hs b/Hledger/Data/Journal.hs --- a/Hledger/Data/Journal.hs +++ b/Hledger/Data/Journal.hs @@ -92,7 +92,7 @@ samplejournal, samplejournalMaybeExplicit, tests_Journal -) +,journalLeafAccountNamesDeclared) where import Control.Applicative ((<|>)) @@ -313,6 +313,11 @@ journalAccountNamesDeclared :: Journal -> [AccountName] journalAccountNamesDeclared = nubSort . map fst . jdeclaredaccounts +-- | Sorted unique account names declared by account directives in this journal, +-- which have no children. +journalLeafAccountNamesDeclared :: Journal -> [AccountName] +journalLeafAccountNamesDeclared = treeLeaves . accountNameTreeFrom . journalAccountNamesDeclared + -- | Sorted unique account names declared by account directives or posted to -- by transactions in this journal. journalAccountNamesDeclaredOrUsed :: Journal -> [AccountName] @@ -521,19 +526,26 @@ filterJournalRelatedPostings :: Query -> Journal -> Journal filterJournalRelatedPostings q j@Journal{jtxns=ts} = j{jtxns=map (filterTransactionRelatedPostings q) ts} --- | Within each posting's amount, keep only the parts matching the query. +-- | Within each posting's amount, keep only the parts matching the query, and +-- remove any postings with all amounts removed. -- This can leave unbalanced transactions. filterJournalAmounts :: Query -> Journal -> Journal filterJournalAmounts q j@Journal{jtxns=ts} = j{jtxns=map (filterTransactionAmounts q) ts} --- | Filter out all parts of this transaction's amounts which do not match the query. +-- | Filter out all parts of this transaction's amounts which do not match the +-- query, and remove any postings with all amounts removed. -- This can leave the transaction unbalanced. filterTransactionAmounts :: Query -> Transaction -> Transaction -filterTransactionAmounts q t@Transaction{tpostings=ps} = t{tpostings=map (filterPostingAmount q) ps} +filterTransactionAmounts q t@Transaction{tpostings=ps} = t{tpostings=mapMaybe (filterPostingAmount q) ps} --- | Filter out all parts of this posting's amount which do not match the query. -filterPostingAmount :: Query -> Posting -> Posting -filterPostingAmount q p@Posting{pamount=as} = p{pamount=filterMixedAmount (q `matchesAmount`) as} +-- | Filter out all parts of this posting's amount which do not match the query, and remove the posting +-- if this removes all amounts. +filterPostingAmount :: Query -> Posting -> Maybe Posting +filterPostingAmount q p@Posting{pamount=as} + | null newamt = Nothing + | otherwise = Just p{pamount=Mixed newamt} + where + Mixed newamt = filterMixedAmount (q `matchesAmount`) as filterTransactionPostings :: Query -> Transaction -> Transaction filterTransactionPostings q t@Transaction{tpostings=ps} = t{tpostings=filter (q `matchesPosting`) ps} diff --git a/Hledger/Data/Posting.hs b/Hledger/Data/Posting.hs --- a/Hledger/Data/Posting.hs +++ b/Hledger/Data/Posting.hs @@ -42,6 +42,7 @@ -- * date operations postingDate, postingDate2, + postingDateOrDate2, isPostingInDateSpan, isPostingInDateSpan', -- * account name operations @@ -61,8 +62,12 @@ sumPostings, -- * rendering showPosting, + showPostingLines, + postingAsLines, + postingsAsLines, + showAccountName, + renderCommentLines, -- * misc. - showComment, postingTransformAmount, postingApplyValuation, postingToCost, @@ -71,6 +76,7 @@ where import Control.Monad (foldM) +import Data.Default (def) import Data.Foldable (asum) import qualified Data.Map as M import Data.Maybe (fromMaybe, isJust) @@ -79,14 +85,19 @@ import qualified Data.Set as S import Data.Text (Text) import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Builder as TB import Data.Time.Calendar (Day) -import Safe (headDef) +import Safe (headDef, maximumBound) +import Text.DocLayout (realLength) +import Text.Tabular.AsciiWide + import Hledger.Utils import Hledger.Data.Types import Hledger.Data.Amount import Hledger.Data.AccountName -import Hledger.Data.Dates (nulldate, showDate, spanContainsDate) +import Hledger.Data.Dates (nulldate, spanContainsDate) import Hledger.Data.Valuation @@ -152,28 +163,150 @@ balassertTotInc :: Amount -> Maybe BalanceAssertion balassertTotInc amt = Just $ nullassertion{baamount=amt, batotal=True, bainclusive=True} +-- | Render a balance assertion, as the =[=][*] symbol and expected amount. +showBalanceAssertion :: BalanceAssertion -> WideBuilder +showBalanceAssertion ba = + singleton '=' <> eq <> ast <> singleton ' ' <> showAmountB def{displayZeroCommodity=True} (baamount ba) + where + eq = if batotal ba then singleton '=' else mempty + ast = if bainclusive ba then singleton '*' else mempty + singleton c = WideBuilder (TB.singleton c) 1 + -- Get the original posting, if any. originalPosting :: Posting -> Posting originalPosting p = fromMaybe p $ poriginal p --- XXX once rendered user output, but just for debugging now; clean up showPosting :: Posting -> String -showPosting p@Posting{paccount=a,pamount=amt,ptype=t} = - T.unpack $ textConcatTopPadded [showDate (postingDate p) <> " ", showaccountname a <> " ", showamt, showComment $ pcomment p] +showPosting p = T.unpack . T.unlines $ postingsAsLines False [p] + +-- | Render a posting, at the appropriate width for aligning with +-- its siblings if any. Used by the rewrite command. +showPostingLines :: Posting -> [Text] +showPostingLines p = first3 $ postingAsLines False False maxacctwidth maxamtwidth p where - ledger3ishlayout = False - acctnamewidth = if ledger3ishlayout then 25 else 22 - showaccountname = fitText (Just acctnamewidth) Nothing False False . bracket . elideAccountName width - (bracket,width) = case t of - BalancedVirtualPosting -> (wrap "[" "]", acctnamewidth-2) - VirtualPosting -> (wrap "(" ")", acctnamewidth-2) - _ -> (id,acctnamewidth) - showamt = wbToText $ showMixedAmountB noColour{displayMinWidth=Just 12} amt + linesWithWidths = map (postingAsLines False False maxacctwidth maxamtwidth) . maybe [p] tpostings $ ptransaction p + maxacctwidth = maximumBound 0 $ map second3 linesWithWidths + maxamtwidth = maximumBound 0 $ map third3 linesWithWidths +-- | Given a transaction and its postings, render the postings, suitable +-- for `print` output. Normally this output will be valid journal syntax which +-- hledger can reparse (though it may include no-longer-valid balance assertions). +-- +-- Explicit amounts are shown, any implicit amounts are not. +-- +-- Postings with multicommodity explicit amounts are handled as follows: +-- if onelineamounts is true, these amounts are shown on one line, +-- comma-separated, and the output will not be valid journal syntax. +-- Otherwise, they are shown as several similar postings, one per commodity. +-- +-- The output will appear to be a balanced transaction. +-- Amounts' display precisions, which may have been limited by commodity +-- directives, will be increased if necessary to ensure this. +-- +-- Posting amounts will be aligned with each other, starting about 4 columns +-- beyond the widest account name (see postingAsLines for details). +postingsAsLines :: Bool -> [Posting] -> [Text] +postingsAsLines onelineamounts ps = concatMap first3 linesWithWidths + where + linesWithWidths = map (postingAsLines False onelineamounts maxacctwidth maxamtwidth) ps + maxacctwidth = maximumBound 0 $ map second3 linesWithWidths + maxamtwidth = maximumBound 0 $ map third3 linesWithWidths -showComment :: Text -> Text -showComment t = if T.null t then "" else " ;" <> t +-- | Render one posting, on one or more lines, suitable for `print` output. +-- There will be an indented account name, plus one or more of status flag, +-- posting amount, balance assertion, same-line comment, next-line comments. +-- +-- If the posting's amount is implicit or if elideamount is true, no amount is shown. +-- +-- If the posting's amount is explicit and multi-commodity, multiple similar +-- postings are shown, one for each commodity, to help produce parseable journal syntax. +-- Or if onelineamounts is true, such amounts are shown on one line, comma-separated +-- (and the output will not be valid journal syntax). +-- +-- By default, 4 spaces (2 if there's a status flag) are shown between +-- account name and start of amount area, which is typically 12 chars wide +-- and contains a right-aligned amount (so 10-12 visible spaces between +-- account name and amount is typical). +-- When given a list of postings to be aligned with, the whitespace will be +-- increased if needed to match the posting with the longest account name. +-- This is used to align the amounts of a transaction's postings. +-- +-- Also returns the account width and amount width used. +postingAsLines :: Bool -> Bool -> Int -> Int -> Posting -> ([Text], Int, Int) +postingAsLines elideamount onelineamounts acctwidth amtwidth p = + (concatMap (++ newlinecomments) postingblocks, thisacctwidth, thisamtwidth) + where + -- This needs to be converted to strict Text in order to strip trailing + -- spaces. This adds a small amount of inefficiency, and the only difference + -- is whether there are trailing spaces in print (and related) reports. This + -- could be removed and we could just keep everything as a Text Builder, but + -- would require adding trailing spaces to 42 failing tests. + postingblocks = [map T.stripEnd . T.lines . TL.toStrict $ + render [ textCell BottomLeft statusandaccount + , textCell BottomLeft " " + , Cell BottomLeft [pad amt] + , Cell BottomLeft [assertion] + , textCell BottomLeft samelinecomment + ] + | amt <- shownAmounts] + render = renderRow def{tableBorders=False, borderSpaces=False} . Group NoLine . map Header + pad amt = WideBuilder (TB.fromText $ T.replicate w " ") w <> amt + where w = max 12 amtwidth - wbWidth amt -- min. 12 for backwards compatibility + assertion = maybe mempty ((WideBuilder (TB.singleton ' ') 1 <>).showBalanceAssertion) $ pbalanceassertion p + -- pad to the maximum account name width, plus 2 to leave room for status flags, to keep amounts aligned + statusandaccount = lineIndent . fitText (Just $ 2 + acctwidth) Nothing False True $ pstatusandacct p + thisacctwidth = realLength $ pacctstr p + + pacctstr p' = showAccountName Nothing (ptype p') (paccount p') + pstatusandacct p' = pstatusprefix p' <> pacctstr p' + pstatusprefix p' = case pstatus p' of + Unmarked -> "" + s -> T.pack (show s) <> " " + + -- currently prices are considered part of the amount string when right-aligning amounts + -- Since we will usually be calling this function with the knot tied between + -- amtwidth and thisamtwidth, make sure thisamtwidth does not depend on + -- amtwidth at all. + shownAmounts + | elideamount = [mempty] + | otherwise = showMixedAmountLinesB noColour{displayOneLine=onelineamounts} $ pamount p + thisamtwidth = maximumBound 0 $ map wbWidth shownAmounts + + (samelinecomment, newlinecomments) = + case renderCommentLines (pcomment p) of [] -> ("",[]) + c:cs -> (c,cs) + +-- | Show an account name, clipped to the given width if any, and +-- appropriately bracketed/parenthesised for the given posting type. +showAccountName :: Maybe Int -> PostingType -> AccountName -> Text +showAccountName w = fmt + where + fmt RegularPosting = maybe id T.take w + fmt VirtualPosting = wrap "(" ")" . maybe id (T.takeEnd . subtract 2) w + fmt BalancedVirtualPosting = wrap "[" "]" . maybe id (T.takeEnd . subtract 2) w + +-- | Render a transaction or posting's comment as indented, semicolon-prefixed comment lines. +-- The first line (unless empty) will have leading space, subsequent lines will have a larger indent. +renderCommentLines :: Text -> [Text] +renderCommentLines t = + case T.lines t of + [] -> [] + [l] -> [commentSpace $ comment l] -- single-line comment + ("":ls) -> "" : map (lineIndent . comment) ls -- multi-line comment with empty first line + (l:ls) -> commentSpace (comment l) : map (lineIndent . comment) ls + where + comment = ("; "<>) + +-- | Prepend a suitable indent for a posting (or transaction/posting comment) line. +lineIndent :: Text -> Text +lineIndent = (" "<>) + +-- | Prepend the space required before a same-line comment. +commentSpace :: Text -> Text +commentSpace = (" "<>) + + isReal :: Posting -> Bool isReal p = ptype p == RegularPosting @@ -219,6 +352,11 @@ , pdate p , tdate <$> ptransaction p ] + +-- | Get a posting's primary or secondary date, as specified. +postingDateOrDate2 :: WhichDate -> Posting -> Day +postingDateOrDate2 PrimaryDate = postingDate +postingDateOrDate2 SecondaryDate = postingDate2 -- | Get a posting's status. This is cleared or pending if those are -- explicitly set on the posting, otherwise the status of its parent diff --git a/Hledger/Data/StringFormat.hs b/Hledger/Data/StringFormat.hs --- a/Hledger/Data/StringFormat.hs +++ b/Hledger/Data/StringFormat.hs @@ -17,8 +17,6 @@ , tests_StringFormat ) where -import Prelude () -import "base-compat-batteries" Prelude.Compat import Numeric (readDec) import Data.Char (isPrint) import Data.Default (Default(..)) diff --git a/Hledger/Data/Transaction.hs b/Hledger/Data/Transaction.hs --- a/Hledger/Data/Transaction.hs +++ b/Hledger/Data/Transaction.hs @@ -18,7 +18,6 @@ , txnTieKnot , txnUntieKnot -- * operations -, showAccountName , hasRealPostings , realPostings , assignmentPostings @@ -34,6 +33,7 @@ -- nonzerobalanceerror -- * date operations , transactionDate2 +, transactionDateOrDate2 -- * transaction description parts , transactionPayee , transactionNote @@ -41,14 +41,11 @@ -- * rendering , showTransaction , showTransactionOneLineAmounts - -- showPostingLine -, showPostingLines , transactionFile -- * tests , tests_Transaction ) where -import Data.Default (Default(..)) import Data.Maybe (fromMaybe) import Data.Text (Text) import qualified Data.Text as T @@ -56,7 +53,6 @@ import qualified Data.Text.Lazy.Builder as TB import Data.Time.Calendar (Day, fromGregorian) import qualified Data.Map as M -import Safe (maximumDef) import Hledger.Utils import Hledger.Data.Types @@ -64,7 +60,6 @@ import Hledger.Data.Posting import Hledger.Data.Amount import Hledger.Data.Valuation -import Text.Tabular.AsciiWide nulltransaction :: Transaction @@ -154,154 +149,6 @@ c:cs -> (c,cs) newline = TB.singleton '\n' --- | Render a transaction or posting's comment as indented, semicolon-prefixed comment lines. --- The first line (unless empty) will have leading space, subsequent lines will have a larger indent. -renderCommentLines :: Text -> [Text] -renderCommentLines t = - case T.lines t of - [] -> [] - [l] -> [commentSpace $ comment l] -- single-line comment - ("":ls) -> "" : map (lineIndent . comment) ls -- multi-line comment with empty first line - (l:ls) -> commentSpace (comment l) : map (lineIndent . comment) ls - where - comment = ("; "<>) - --- | Given a transaction and its postings, render the postings, suitable --- for `print` output. Normally this output will be valid journal syntax which --- hledger can reparse (though it may include no-longer-valid balance assertions). --- --- Explicit amounts are shown, any implicit amounts are not. --- --- Postings with multicommodity explicit amounts are handled as follows: --- if onelineamounts is true, these amounts are shown on one line, --- comma-separated, and the output will not be valid journal syntax. --- Otherwise, they are shown as several similar postings, one per commodity. --- --- The output will appear to be a balanced transaction. --- Amounts' display precisions, which may have been limited by commodity --- directives, will be increased if necessary to ensure this. --- --- Posting amounts will be aligned with each other, starting about 4 columns --- beyond the widest account name (see postingAsLines for details). -postingsAsLines :: Bool -> [Posting] -> [Text] -postingsAsLines onelineamounts ps = concatMap first3 linesWithWidths - where - linesWithWidths = map (postingAsLines False onelineamounts maxacctwidth maxamtwidth) ps - maxacctwidth = maximumDef 0 $ map second3 linesWithWidths - maxamtwidth = maximumDef 0 $ map third3 linesWithWidths - --- | Render one posting, on one or more lines, suitable for `print` output. --- There will be an indented account name, plus one or more of status flag, --- posting amount, balance assertion, same-line comment, next-line comments. --- --- If the posting's amount is implicit or if elideamount is true, no amount is shown. --- --- If the posting's amount is explicit and multi-commodity, multiple similar --- postings are shown, one for each commodity, to help produce parseable journal syntax. --- Or if onelineamounts is true, such amounts are shown on one line, comma-separated --- (and the output will not be valid journal syntax). --- --- By default, 4 spaces (2 if there's a status flag) are shown between --- account name and start of amount area, which is typically 12 chars wide --- and contains a right-aligned amount (so 10-12 visible spaces between --- account name and amount is typical). --- When given a list of postings to be aligned with, the whitespace will be --- increased if needed to match the posting with the longest account name. --- This is used to align the amounts of a transaction's postings. --- --- Also returns the account width and amount width used. -postingAsLines :: Bool -> Bool -> Int -> Int -> Posting -> ([Text], Int, Int) -postingAsLines elideamount onelineamounts acctwidth amtwidth p = - (concatMap (++ newlinecomments) postingblocks, thisacctwidth, thisamtwidth) - where - -- This needs to be converted to strict Text in order to strip trailing - -- spaces. This adds a small amount of inefficiency, and the only difference - -- is whether there are trailing spaces in print (and related) reports. This - -- could be removed and we could just keep everything as a Text Builder, but - -- would require adding trailing spaces to 42 failing tests. - postingblocks = [map T.stripEnd . T.lines . TL.toStrict $ - render [ textCell BottomLeft statusandaccount - , textCell BottomLeft " " - , Cell BottomLeft [pad amt] - , Cell BottomLeft [assertion] - , textCell BottomLeft samelinecomment - ] - | amt <- shownAmounts] - render = renderRow def{tableBorders=False, borderSpaces=False} . Group NoLine . map Header - pad amt = WideBuilder (TB.fromText $ T.replicate w " ") w <> amt - where w = max 12 amtwidth - wbWidth amt -- min. 12 for backwards compatibility - - assertion = maybe mempty ((WideBuilder (TB.singleton ' ') 1 <>).showBalanceAssertion) $ pbalanceassertion p - -- pad to the maximum account name width, plus 2 to leave room for status flags, to keep amounts aligned - statusandaccount = lineIndent . fitText (Just $ 2 + acctwidth) Nothing False True $ pstatusandacct p - thisacctwidth = textWidth $ pacctstr p - - pacctstr p' = showAccountName Nothing (ptype p') (paccount p') - pstatusandacct p' = pstatusprefix p' <> pacctstr p' - pstatusprefix p' = case pstatus p' of - Unmarked -> "" - s -> T.pack (show s) <> " " - - -- currently prices are considered part of the amount string when right-aligning amounts - -- Since we will usually be calling this function with the knot tied between - -- amtwidth and thisamtwidth, make sure thisamtwidth does not depend on - -- amtwidth at all. - shownAmounts - | elideamount = [mempty] - | otherwise = showMixedAmountLinesB noColour{displayOneLine=onelineamounts} $ pamount p - thisamtwidth = maximumDef 0 $ map wbWidth shownAmounts - - (samelinecomment, newlinecomments) = - case renderCommentLines (pcomment p) of [] -> ("",[]) - c:cs -> (c,cs) - --- | Render a balance assertion, as the =[=][*] symbol and expected amount. -showBalanceAssertion :: BalanceAssertion -> WideBuilder -showBalanceAssertion BalanceAssertion{..} = - singleton '=' <> eq <> ast <> singleton ' ' <> showAmountB def{displayZeroCommodity=True} baamount - where - eq = if batotal then singleton '=' else mempty - ast = if bainclusive then singleton '*' else mempty - singleton c = WideBuilder (TB.singleton c) 1 - --- | Render a posting, simply. Used in balance assertion errors. --- showPostingLine p = --- lineIndent $ --- if pstatus p == Cleared then "* " else "" ++ -- XXX show ! --- showAccountName Nothing (ptype p) (paccount p) ++ --- " " ++ --- showMixedAmountOneLine (pamount p) ++ --- assertion --- where --- -- XXX extract, handle == --- assertion = maybe "" ((" = " ++) . showAmountWithZeroCommodity . baamount) $ pbalanceassertion p - --- | Render a posting, at the appropriate width for aligning with --- its siblings if any. Used by the rewrite command. -showPostingLines :: Posting -> [Text] -showPostingLines p = first3 $ postingAsLines False False maxacctwidth maxamtwidth p - where - linesWithWidths = map (postingAsLines False False maxacctwidth maxamtwidth) . maybe [p] tpostings $ ptransaction p - maxacctwidth = maximumDef 0 $ map second3 linesWithWidths - maxamtwidth = maximumDef 0 $ map third3 linesWithWidths - --- | Prepend a suitable indent for a posting (or transaction/posting comment) line. -lineIndent :: Text -> Text -lineIndent = (" "<>) - --- | Prepend the space required before a same-line comment. -commentSpace :: Text -> Text -commentSpace = (" "<>) - --- | Show an account name, clipped to the given width if any, and --- appropriately bracketed/parenthesised for the given posting type. -showAccountName :: Maybe Int -> PostingType -> AccountName -> Text -showAccountName w = fmt - where - fmt RegularPosting = maybe id T.take w - fmt VirtualPosting = wrap "(" ")" . maybe id (T.takeEnd . subtract 2) w - fmt BalancedVirtualPosting = wrap "[" "]" . maybe id (T.takeEnd . subtract 2) w - hasRealPostings :: Transaction -> Bool hasRealPostings = not . null . realPostings @@ -320,9 +167,14 @@ transactionsPostings :: [Transaction] -> [Posting] transactionsPostings = concatMap tpostings --- Get a transaction's secondary date, defaulting to the primary date. +-- Get a transaction's secondary date, or the primary date if there is none. transactionDate2 :: Transaction -> Day transactionDate2 t = fromMaybe (tdate t) $ tdate2 t + +-- Get a transaction's primary or secondary date, as specified. +transactionDateOrDate2 :: WhichDate -> Transaction -> Day +transactionDateOrDate2 PrimaryDate = tdate +transactionDateOrDate2 SecondaryDate = transactionDate2 -- | Ensure a transaction's postings refer back to it, so that eg -- relatedPostings works right. diff --git a/Hledger/Query.hs b/Hledger/Query.hs --- a/Hledger/Query.hs +++ b/Hledger/Query.hs @@ -479,7 +479,7 @@ queryDateSpan :: Bool -> Query -> DateSpan queryDateSpan secondary (Or qs) = spansUnion $ map (queryDateSpan secondary) qs queryDateSpan secondary (And qs) = spansIntersect $ map (queryDateSpan secondary) qs -queryDateSpan False (Date span) = span +queryDateSpan _ (Date span) = span queryDateSpan True (Date2 span) = span queryDateSpan _ _ = nulldatespan diff --git a/Hledger/Read/Common.hs b/Hledger/Read/Common.hs --- a/Hledger/Read/Common.hs +++ b/Hledger/Read/Common.hs @@ -119,10 +119,8 @@ where --- ** imports -import Prelude () -import "base-compat-batteries" Prelude.Compat hiding (fail, readFile) import Control.Applicative.Permutations (runPermutation, toPermutationWithDefault) -import qualified "base-compat-batteries" Control.Monad.Fail.Compat as Fail (fail) +import qualified Control.Monad.Fail as Fail (fail) import Control.Monad.Except (ExceptT(..), liftEither, runExceptT, throwError) import Control.Monad.State.Strict hiding (fail) import Data.Bifunctor (bimap, second) @@ -130,8 +128,8 @@ import Data.Decimal (DecimalRaw (Decimal), Decimal) import Data.Either (lefts, rights) import Data.Function ((&)) -import Data.Functor ((<&>)) -import "base-compat-batteries" Data.List.Compat +import Data.Functor ((<&>), ($>)) +import Data.List (find, genericReplicate) import Data.List.NonEmpty (NonEmpty(..)) import Data.Maybe (catMaybes, fromMaybe, isJust, listToMaybe) import qualified Data.Map as M @@ -357,7 +355,7 @@ -- | Check that all the journal's transactions have payees declared with -- payee directives, returning an error message otherwise. journalCheckPayeesDeclared :: Journal -> Either String () -journalCheckPayeesDeclared j = sequence_ $ map checkpayee $ jtxns j +journalCheckPayeesDeclared j = mapM_ checkpayee (jtxns j) where checkpayee t | p `elem` ps = Right () @@ -373,7 +371,7 @@ -- | Check that all the journal's postings are to accounts declared with -- account directives, returning an error message otherwise. journalCheckAccountsDeclared :: Journal -> Either String () -journalCheckAccountsDeclared j = sequence_ $ map checkacct $ journalPostings j +journalCheckAccountsDeclared j = mapM_ checkacct (journalPostings j) where checkacct Posting{paccount,ptransaction} | paccount `elem` as = Right () @@ -391,7 +389,7 @@ -- by commodity directives, returning an error message otherwise. journalCheckCommoditiesDeclared :: Journal -> Either String () journalCheckCommoditiesDeclared j = - sequence_ $ map checkcommodities $ journalPostings j + mapM_ checkcommodities (journalPostings j) where checkcommodities Posting{..} = case mfirstundeclaredcomm of @@ -421,7 +419,7 @@ getDecimalMarkStyle :: JournalParser m (Maybe AmountStyle) getDecimalMarkStyle = do Journal{jparsedecimalmark} <- get - let mdecmarkStyle = maybe Nothing (\c -> Just $ amountstyle{asdecimalpoint=Just c}) jparsedecimalmark + let mdecmarkStyle = (\c -> Just $ amountstyle{asdecimalpoint=Just c}) =<< jparsedecimalmark return mdecmarkStyle setDefaultCommodityAndStyle :: (CommoditySymbol,AmountStyle) -> JournalParser m () @@ -861,7 +859,7 @@ -- | Parse a minus or plus sign followed by zero or more spaces, -- or nothing, returning a function that negates or does nothing. signp :: Num a => TextParser m (a -> a) -signp = ((char '-' *> pure negate <|> char '+' *> pure id) <* skipNonNewlineSpaces) <|> pure id +signp = ((char '-' $> negate <|> char '+' $> id) <* skipNonNewlineSpaces) <|> pure id commoditysymbolp :: TextParser m CommoditySymbol commoditysymbolp = @@ -880,7 +878,7 @@ -- https://www.ledger-cli.org/3.0/doc/ledger3.html#Virtual-posting-costs parenthesised <- option False $ char '(' >> pure True char '@' - totalPrice <- char '@' *> pure True <|> pure False + totalPrice <- char '@' $> True <|> pure False when parenthesised $ void $ char ')' lift skipNonNewlineSpaces @@ -1289,8 +1287,7 @@ commenttagsp :: TextParser m [Tag] commenttagsp = do - tagName <- fmap (last . T.split isSpace) - $ takeWhileP Nothing (\c -> c /= ':' && c /= '\n') + tagName <- (last . T.split isSpace) <$> takeWhileP Nothing (\c -> c /= ':' && c /= '\n') atColon tagName <|> pure [] -- if not ':', then either '\n' or EOF where @@ -1366,8 +1363,8 @@ postingcommentp mYear = do (commentText, (tags, dateTags)) <- followingcommentp' (commenttagsanddatesp mYear) - let mdate = fmap snd $ find ((=="date") .fst) dateTags - mdate2 = fmap snd $ find ((=="date2").fst) dateTags + let mdate = snd <$> find ((=="date") .fst) dateTags + mdate2 = snd <$> find ((=="date2").fst) dateTags pure (commentText, tags, mdate, mdate2) {-# INLINABLE postingcommentp #-} diff --git a/Hledger/Read/CsvReader.hs b/Hledger/Read/CsvReader.hs --- a/Hledger/Read/CsvReader.hs +++ b/Hledger/Read/CsvReader.hs @@ -37,8 +37,6 @@ where --- ** imports -import Prelude () -import "base-compat-batteries" Prelude.Compat hiding (fail) import Control.Applicative (liftA2) import Control.Exception (IOException, handle, throw) import Control.Monad (unless, when) @@ -49,7 +47,7 @@ import Control.Monad.Trans.Class (lift) import Data.Char (toLower, isDigit, isSpace, isAlphaNum, isAscii, ord) import Data.Bifunctor (first) -import "base-compat-batteries" Data.List.Compat +import Data.List (elemIndex, foldl', intersperse, mapAccumL, nub, sortBy) import Data.Maybe (catMaybes, fromMaybe, isJust) import Data.MemoUgly (memo) import Data.Ord (comparing) @@ -788,7 +786,7 @@ parseCsv separator filePath csvdata = case filePath of "-" -> parseCassava separator "(stdin)" <$> T.getContents - _ -> return $ parseCassava separator filePath csvdata + _ -> return $ if T.null csvdata then Right mempty else parseCassava separator filePath csvdata parseCassava :: Char -> FilePath -> Text -> Either String CSV parseCassava separator path content = @@ -998,33 +996,31 @@ ] -- if any of the numbered field names are present, discard all the unnumbered ones - assignments' | any isnumbered assignments = filter isnumbered assignments - | otherwise = assignments + discardUnnumbered xs = if null numbered then xs else numbered where - isnumbered (f,_) = T.any isDigit f + numbered = filter (T.any isDigit . fst) xs - -- if there's more than one value and only some are zeros, discard the zeros - assignments'' - | length assignments' > 1 && not (null nonzeros) = nonzeros - | otherwise = assignments' - where nonzeros = filter (not . mixedAmountLooksZero . snd) assignments' + -- discard all zero amounts, unless all amounts are zero, in which case discard all but the first + discardExcessZeros xs = if null nonzeros then take 1 xs else nonzeros + where + nonzeros = filter (not . mixedAmountLooksZero . snd) xs - in case -- dbg0 ("amounts for posting "++show n) - assignments'' of - [] -> Nothing - [(f,a)] | "-out" `T.isSuffixOf` f -> Just (maNegate a) -- for -out fields, flip the sign - -- XXX unless it's already negative ? back compat issues / too confusing ? - [(_,a)] -> Just a - fs -> error' . T.unpack . T.unlines $ [ -- PARTIAL: - "multiple non-zero amounts or multiple zero amounts assigned," + -- for -out fields, flip the sign XXX unless it's already negative ? back compat issues / too confusing ? + negateIfOut f = if "-out" `T.isSuffixOf` f then maNegate else id + + in case discardExcessZeros $ discardUnnumbered assignments of + [] -> Nothing + [(f,a)] -> Just $ negateIfOut f a + fs -> error' . T.unpack . T.unlines $ -- PARTIAL: + ["multiple non-zero amounts assigned," ,"please ensure just one. (https://hledger.org/csv.html#amount)" ," " <> showRecord record ," for posting: " <> T.pack (show n) - ] - ++ [" assignment: " <> f <> " " <> - fromMaybe "" (hledgerField rules record f) <> - "\t=> value: " <> wbToText (showMixedAmountB noColour a) -- XXX not sure this is showing all the right info - | (f,a) <- fs] + ] ++ + [" assignment: " <> f <> " " <> + fromMaybe "" (hledgerField rules record f) <> + "\t=> value: " <> wbToText (showMixedAmountB noColour a) -- XXX not sure this is showing all the right info + | (f,a) <- fs] -- | Figure out the expected balance (assertion or assignment) specified for posting N, -- if any (and its parse position). diff --git a/Hledger/Read/JournalReader.hs b/Hledger/Read/JournalReader.hs --- a/Hledger/Read/JournalReader.hs +++ b/Hledger/Read/JournalReader.hs @@ -71,9 +71,7 @@ where --- ** imports --- import qualified Prelude (fail) --- import "base-compat-batteries" Prelude.Compat hiding (fail, readFile) -import qualified "base-compat-batteries" Control.Monad.Fail.Compat as Fail (fail) +import qualified Control.Monad.Fail as Fail (fail) import qualified Control.Exception as C import Control.Monad (forM_, when, void) import Control.Monad.IO.Class (MonadIO, liftIO) @@ -248,6 +246,7 @@ ,defaultcommoditydirectivep ,commodityconversiondirectivep ,ignoredpricecommoditydirectivep + ,decimalmarkdirectivep ] ) "directive" @@ -319,6 +318,7 @@ jparsedefaultyear = jparsedefaultyear j ,jparsedefaultcommodity = jparsedefaultcommodity j ,jparseparentaccounts = jparseparentaccounts j + ,jparsedecimalmark = jparsedecimalmark j ,jparsealiases = jparsealiases j ,jcommodities = jcommodities j -- ,jparsetransactioncount = jparsetransactioncount j @@ -598,6 +598,18 @@ char '=' lift skipNonNewlineSpaces amountp + lift restofline + return () + +-- | Read a valid decimal mark from the decimal-mark directive e.g +-- +-- decimal-mark , +decimalmarkdirectivep :: JournalParser m () +decimalmarkdirectivep = do + string "decimal-mark" "decimal mark" + lift skipNonNewlineSpaces1 + mark <- satisfy isDecimalMark + modify' $ \j -> j{jparsedecimalmark=Just mark} lift restofline return () diff --git a/Hledger/Read/TimeclockReader.hs b/Hledger/Read/TimeclockReader.hs --- a/Hledger/Read/TimeclockReader.hs +++ b/Hledger/Read/TimeclockReader.hs @@ -57,8 +57,6 @@ where --- ** imports -import Prelude () -import "base-compat-batteries" Prelude.Compat import Control.Monad import Control.Monad.Except (ExceptT) import Control.Monad.State.Strict diff --git a/Hledger/Read/TimedotReader.hs b/Hledger/Read/TimedotReader.hs --- a/Hledger/Read/TimedotReader.hs +++ b/Hledger/Read/TimedotReader.hs @@ -40,8 +40,6 @@ where --- ** imports -import Prelude () -import "base-compat-batteries" Prelude.Compat import Control.Monad import Control.Monad.Except (ExceptT) import Control.Monad.State.Strict @@ -173,21 +171,26 @@ lift $ optional $ choice [orgheadingprefixp, skipNonNewlineSpaces1] a <- modifiedaccountnamep lift skipNonNewlineSpaces - hours <- + hrs <- try (lift followingcommentp >> return 0) <|> (durationp <* (try (lift followingcommentp) <|> (newline >> return ""))) - let t = nulltransaction{ - tsourcepos = (pos, pos), - tstatus = Cleared, - tpostings = [ - nullposting{paccount=a - ,pamount=mixedAmount . amountSetPrecision (Precision 2) $ num hours -- don't assume hours; do set precision to 2 - ,ptype=VirtualPosting - ,ptransaction=Just t - } - ] - } + mcs <- getDefaultCommodityAndStyle + let + (c,s) = case mcs of + Just (defc,defs) -> (defc, defs{asprecision=max (asprecision defs) (Precision 2)}) + _ -> ("", amountstyle{asprecision=Precision 2}) + t = nulltransaction{ + tsourcepos = (pos, pos), + tstatus = Cleared, + tpostings = [ + nullposting{paccount=a + ,pamount=mixedAmount $ nullamt{acommodity=c, aquantity=hrs, astyle=s} + ,ptype=VirtualPosting + ,ptransaction=Just t + } + ] + } lift $ traceparse' "entryp" return t diff --git a/Hledger/Reports/AccountTransactionsReport.hs b/Hledger/Reports/AccountTransactionsReport.hs --- a/Hledger/Reports/AccountTransactionsReport.hs +++ b/Hledger/Reports/AccountTransactionsReport.hs @@ -103,8 +103,9 @@ periodq = Date . periodAsDateSpan $ period_ ropts amtq = filterQuery queryIsCurOrAmt $ _rsQuery rspec queryIsCurOrAmt q = queryIsSym q || queryIsAmt q + wd = whichDate ropts - -- Note that within this functions, we are only allowed limited + -- Note that within this function, we are only allowed limited -- transformation of the transaction postings: this is due to the need to -- pass the original transactions into accountTransactionsReportItem. -- Generally, we either include a transaction in full, or not at all. @@ -112,6 +113,8 @@ -- - filter them by the account query if any, -- - discard amounts not matched by the currency and amount query if any, -- - then apply valuation if any. + -- Additional reportq filtering, such as date filtering, happens down in + -- accountTransactionsReportItem, which discards transactions with no matched postings. acctJournal = ptraceAtWith 5 (("ts3:\n"++).pshowTransactions.jtxns) -- maybe convert these transactions to cost or value @@ -149,7 +152,7 @@ -- sort by the transaction's register date, then index, for accurate starting balance . ptraceAtWith 5 (("ts4:\n"++).pshowTransactions.map snd) . sortBy (comparing (Down . fst) <> comparing (Down . tindex . snd)) - . map (\t -> (transactionRegisterDate reportq thisacctq t, t)) + . map (\t -> (transactionRegisterDate wd reportq thisacctq t, t)) $ jtxns acctJournal pshowTransactions :: [Transaction] -> String @@ -160,9 +163,8 @@ -- which account to use as the focus, a starting balance, and a sign-setting -- function. -- Each transaction is accompanied by the date that should be shown for it --- in the report, which is not necessarily the transaction date; it is --- the earliest of the posting dates which match both thisacctq and reportq, --- otherwise the transaction's date if there are no matching postings. +-- in the report. This is not necessarily the transaction date - see +-- transactionRegisterDate. accountTransactionsReportItems :: Query -> Query -> MixedAmount -> (MixedAmount -> MixedAmount) -> [(Day, Transaction)] -> [AccountTransactionsReportItem] accountTransactionsReportItems reportq thisacctq bal signfn = @@ -176,7 +178,7 @@ | null reportps = (bal, Nothing) -- no matched postings in this transaction, skip it | otherwise = (b, Just (torig, tacct{tdate=d}, numotheraccts > 1, otheracctstr, a, b)) where - tacct@Transaction{tpostings=reportps} = filterTransactionPostings reportq torig + tacct@Transaction{tpostings=reportps} = filterTransactionPostings reportq torig -- TODO needs to consider --date2, #1731 (thisacctps, otheracctps) = partition (matchesPosting thisacctq) reportps numotheraccts = length $ nub $ map paccount otheracctps otheracctstr | thisacctq == None = summarisePostingAccounts reportps -- no current account ? summarise all matched postings @@ -185,16 +187,20 @@ a = signfn . maNegate $ sumPostings thisacctps b = bal `maPlus` a --- | What is the transaction's date in the context of a particular account --- (specified with a query) and report query, as in an account register ? --- It's normally the transaction's general date, but if any posting(s) --- matched by the report query and affecting the matched account(s) have --- their own earlier dates, it's the earliest of these dates. --- Secondary transaction/posting dates are ignored. -transactionRegisterDate :: Query -> Query -> Transaction -> Day -transactionRegisterDate reportq thisacctq t - | null thisacctps = tdate t - | otherwise = minimum $ map postingDate thisacctps +-- TODO needs checking, cf #1731 +-- | What date should be shown for a transaction in an account register report ? +-- This will be in context of a particular account (the "this account" query) +-- and any additional report query. It could be: +-- +-- - if postings are matched by both thisacctq and reportq, the earliest of those +-- matched postings' dates (or their secondary dates if --date2 was used) +-- +-- - the transaction date, or its secondary date if --date2 was used. +-- +transactionRegisterDate :: WhichDate -> Query -> Query -> Transaction -> Day +transactionRegisterDate wd reportq thisacctq t + | not $ null thisacctps = minimum $ map (postingDateOrDate2 wd) thisacctps + | otherwise = transactionDateOrDate2 wd t where reportps = tpostings $ filterTransactionPostings reportq t thisacctps = filter (matchesPosting thisacctq) reportps diff --git a/Hledger/Reports/BudgetReport.hs b/Hledger/Reports/BudgetReport.hs --- a/Hledger/Reports/BudgetReport.hs +++ b/Hledger/Reports/BudgetReport.hs @@ -38,7 +38,7 @@ import qualified Data.Text.Lazy.Builder as TB --import System.Console.CmdArgs.Explicit as C --import Lucid as L -import Text.Tabular.AsciiWide as Tab +import qualified Text.Tabular.AsciiWide as Tab import Hledger.Data import Hledger.Utils @@ -230,18 +230,18 @@ <> ":" -- | Build a 'Table' from a multi-column balance report. -budgetReportAsTable :: ReportOpts -> BudgetReport -> Table Text Text WideBuilder +budgetReportAsTable :: ReportOpts -> BudgetReport -> Tab.Table Text Text WideBuilder budgetReportAsTable ReportOpts{..} (PeriodicReport spans items tr) = maybetransposetable $ addtotalrow $ - Table - (Tab.Group NoLine $ map Header accts) - (Tab.Group NoLine $ map Header colheadings) + Tab.Table + (Tab.Group Tab.NoLine $ map Tab.Header accts) + (Tab.Group Tab.NoLine $ map Tab.Header colheadings) rows where - colheadings = ["Commodity" | commodity_column_] + colheadings = ["Commodity" | commodity_layout_ == CommodityBare] ++ map (reportPeriodName balanceaccum_ spans) spans ++ [" Total" | row_total_] ++ ["Average" | average_] @@ -255,16 +255,16 @@ addtotalrow | no_total_ = id - | otherwise = let rh = Tab.Group NoLine . replicate (length totalrows) $ Header "" - ch = Header [] -- ignored - in (flip (concatTables SingleLine) $ Table rh ch totalrows) + | otherwise = let rh = Tab.Group Tab.NoLine . replicate (length totalrows) $ Tab.Header "" + ch = Tab.Header [] -- ignored + in (flip (Tab.concatTables Tab.SingleLine) $ Tab.Table rh ch totalrows) maybetranspose | transpose_ = transpose | otherwise = id maybetransposetable - | transpose_ = \(Table rh ch vals) -> Table ch rh (transpose vals) + | transpose_ = \(Tab.Table rh ch vals) -> Tab.Table ch rh (transpose vals) | otherwise = id (accts, rows, totalrows) = (accts, prependcs itemscs (padcells texts), prependcs trcs (padtr trtexts)) @@ -283,24 +283,23 @@ padcells = maybetranspose . fmap (fmap (uncurry paddisplaycell) . zip widths) . maybetranspose padtr = maybetranspose . fmap (fmap (uncurry paddisplaycell) . zip trwidths) . maybetranspose - -- commodities are shown with the amounts without `commodity-column` + -- commodities are shown with the amounts without `commodity_layout_ == CommodityBare` prependcs cs - | commodity_column_ = zipWith (:) cs - | otherwise = id + | commodity_layout_ /= CommodityBare = id + | otherwise = zipWith (:) cs rowToBudgetCells (PeriodicReportRow _ as rowtot rowavg) = as ++ [rowtot | row_total_ && not (null as)] ++ [rowavg | average_ && not (null as)] - -- functions for displaying budget cells depending on `commodity-column` flag + -- functions for displaying budget cells depending on `commodity-layout_` option rowfuncs :: [CommoditySymbol] -> (BudgetShowMixed, BudgetPercBudget) - rowfuncs cs - | not commodity_column_ = - ( pure . showMixedAmountB oneLine{displayColour=color_, displayMaxWidth=Just 32} - , \a -> pure . percentage a) - | otherwise = - ( showMixedAmountLinesB noPrice{displayOrder=Just cs, displayMinWidth=Nothing, displayColour=color_} - , \a b -> fmap (percentage' a b) cs) + rowfuncs cs = case commodity_layout_ of + CommodityWide width -> + ( pure . showMixedAmountB oneLine{displayColour=color_, displayMaxWidth=width} + , \a -> pure . percentage a) + _ -> ( showMixedAmountLinesB noPrice{displayOrder=Just cs, displayMinWidth=Nothing, displayColour=color_} + , \a b -> fmap (percentage' a b) cs) showrow :: [BudgetCell] -> [(WideBuilder, BudgetDisplayRow)] showrow row = @@ -408,7 +407,7 @@ -- heading row ("Account" : - ["Commodity" | commodity_column_ ] + ["Commodity" | commodity_layout_ == CommodityBare ] ++ concatMap (\span -> [showDateSpan span, "budget"]) colspans ++ concat [["Total" ,"budget"] | row_total_] ++ concat [["Average","budget"] | average_] @@ -428,7 +427,7 @@ -> PeriodicReportRow a BudgetCell -> [[Text]] rowAsTexts render row@(PeriodicReportRow _ as (rowtot,budgettot) (rowavg, budgetavg)) - | not commodity_column_ = [render row : fmap showNorm all] + | commodity_layout_ /= CommodityBare = [render row : fmap showNorm all] | otherwise = joinNames . zipWith (:) cs -- add symbols and names . transpose -- each row becomes a list of Text quantities diff --git a/Hledger/Reports/MultiBalanceReport.hs b/Hledger/Reports/MultiBalanceReport.hs --- a/Hledger/Reports/MultiBalanceReport.hs +++ b/Hledger/Reports/MultiBalanceReport.hs @@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-| @@ -26,7 +27,6 @@ getPostingsByColumn, getPostings, startingPostings, - startingBalancesFromPostings, generateMultiBalanceReport, balanceReportTableAsText, @@ -122,8 +122,8 @@ -- The matched accounts with a starting balance. All of these should appear -- in the report, even if they have no postings during the report period. - startbals = dbg5 "startbals" . startingBalancesFromPostings rspec j priceoracle - $ startingPostings rspec j priceoracle reportspan + startbals = dbg5 "startbals" $ + startingBalances rspec j priceoracle $ startingPostings rspec j priceoracle reportspan -- Generate and postprocess the report, negating balances and taking percentages if needed report = dbg4 "multiBalanceReportWith" $ @@ -159,16 +159,18 @@ ( cbcsubreporttitle -- Postprocess the report, negating balances and taking percentages if needed , cbcsubreporttransform $ - generateMultiBalanceReport rspec{_rsReportOpts=ropts} j priceoracle colps' startbals' + generateMultiBalanceReport rspecsub j priceoracle colps' startbals' , cbcsubreportincreasestotal ) where - -- Filter the column postings according to each subreport + -- Add a restriction to this subreport to the report query. + -- XXX in non-thorough way, consider updateReportSpec ? + q = cbcsubreportquery j + ropts = cbcsubreportoptions $ _rsReportOpts rspec + rspecsub = rspec{_rsReportOpts=ropts, _rsQuery=And [q, _rsQuery rspec]} + -- Starting balances and column postings specific to this subreport. + startbals' = startingBalances rspecsub j priceoracle $ filter (matchesPosting q) startps colps' = map (second $ filter (matchesPosting q)) colps - -- We need to filter historical postings directly, rather than their accumulated balances. (#1698) - startbals' = startingBalancesFromPostings rspec j priceoracle $ filter (matchesPosting q) startps - ropts = cbcsubreportoptions $ _rsReportOpts rspec - q = cbcsubreportquery j -- Sum the subreport totals by column. Handle these cases: -- - no subreports @@ -183,10 +185,12 @@ cbr = CompoundPeriodicReport "" (map fst colps) subreports overalltotals --- | Calculate starting balances from postings, if needed for -H. -startingBalancesFromPostings :: ReportSpec -> Journal -> PriceOracle -> [Posting] +-- XXX seems refactorable +-- | Calculate accounts' balances on the report start date, from these postings +-- which should be all postings before that date, and possibly also from account declarations. +startingBalances :: ReportSpec -> Journal -> PriceOracle -> [Posting] -> HashMap AccountName Account -startingBalancesFromPostings rspec j priceoracle ps = +startingBalances rspec j priceoracle ps = M.findWithDefault nullacct emptydatespan <$> calculateReportMatrix rspec j priceoracle mempty [(emptydatespan, ps)] @@ -244,46 +248,55 @@ ps = dbg5 "getPostingsByColumn" $ getPostings rspec j priceoracle -- The date spans to be included as report columns. colspans = dbg3 "colspans" $ splitSpan (interval_ $ _rsReportOpts rspec) reportspan - getDate = case whichDateFromOpts (_rsReportOpts rspec) of - PrimaryDate -> postingDate - SecondaryDate -> postingDate2 + getDate = postingDateOrDate2 (whichDate (_rsReportOpts rspec)) -- | Gather postings matching the query within the report period. getPostings :: ReportSpec -> Journal -> PriceOracle -> [Posting] -getPostings rspec@ReportSpec{_rsQuery=query,_rsReportOpts=ropts} j priceoracle = - journalPostings . - valueJournal . - filterJournalAmounts symq $ -- remove amount parts excluded by cur: - filterJournalPostings reportq j -- remove postings not matched by (adjusted) query +getPostings rspec@ReportSpec{_rsQuery=query, _rsReportOpts=ropts} j priceoracle = + journalPostings $ journalValueAndFilterPostingsWith rspec' j priceoracle where - symq = dbg3 "symq" . filterQuery queryIsSym $ dbg3 "requested q" query + rspec' = rspec{_rsQuery=depthless, _rsReportOpts = ropts'} + ropts' = if isJust (valuationAfterSum ropts) + then ropts{value_=Nothing, cost_=NoCost} -- If we're valuing after the sum, don't do it now + else ropts + -- The user's query with no depth limit, and expanded to the report span -- if there is one (otherwise any date queries are left as-is, which -- handles the hledger-ui+future txns case above). - reportq = dbg3 "reportq" $ depthless query - depthless = dbg3 "depthless" . filterQuery (not . queryIsDepth) - valueJournal j' | isJust (valuationAfterSum ropts) = j' - | otherwise = journalApplyValuationFromOptsWith rspec j' priceoracle - + depthless = dbg3 "depthless" $ filterQuery (not . queryIsDepth) query --- | Given a set of postings, eg for a single report column, gather --- the accounts that have postings and calculate the change amount for --- each. Accounts and amounts will be depth-clipped appropriately if --- a depth limit is in effect. -acctChangesFromPostings :: ReportSpec -> [Posting] -> HashMap ClippedAccountName Account -acctChangesFromPostings ReportSpec{_rsQuery=query,_rsReportOpts=ropts} ps = - HM.fromList [(aname a, a) | a <- as] +-- | From set of postings, eg for a single report column, calculate the balance change in each account. +-- Accounts and amounts will be depth-clipped appropriately if a depth limit is in effect. +-- +-- When --declared is used, accounts which have been declared with an account directive +-- are also included, with a 0 balance change. But only leaf accounts, since non-leaf +-- empty declared accounts are less useful in reports. This is primarily for hledger-ui. +acctChanges :: ReportSpec -> Journal -> [Posting] -> HashMap ClippedAccountName Account +acctChanges ReportSpec{_rsQuery=query,_rsReportOpts=ReportOpts{accountlistmode_, declared_}} j ps = + HM.fromList [(aname a, a) | a <- accts] where - as = filterAccounts . drop 1 $ accountsFromPostings ps - filterAccounts = case accountlistmode_ ropts of - ALTree -> filter ((depthq `matchesAccount`) . aname) -- exclude deeper balances - ALFlat -> clipAccountsAndAggregate (queryDepth depthq) . -- aggregate deeper balances at the depth limit. - filter ((0<) . anumpostings) - depthq = dbg3 "depthq" $ filterQuery queryIsDepth query + -- With --declared, add the query-matching declared accounts + -- (as dummy postings so they are processed like the rest). + -- This function is used for calculating both pre-start changes and column changes, + -- and the declared accounts are really only needed for the former, + -- but it's harmless to have them in the column changes as well. + ps' = ps ++ if declared_ then declaredacctps else [] + where + declaredacctps = + [nullposting{paccount=n} | n <- journalLeafAccountNamesDeclared j + , acctq `matchesAccount` n] + where acctq = dbg3 "acctq" $ filterQuery queryIsAcct query + filterbydepth = case accountlistmode_ of + ALTree -> filter ((depthq `matchesAccount`) . aname) -- a tree - just exclude deeper accounts + ALFlat -> clipAccountsAndAggregate (queryDepth depthq) -- a list - aggregate deeper accounts at the depth limit + . filter ((0<) . anumpostings) -- and exclude empty parent accounts + where depthq = dbg3 "depthq" $ filterQuery queryIsDepth query + + accts = filterbydepth $ drop 1 $ accountsFromPostings ps' + -- | Gather the account balance changes into a regular matrix, then -- accumulate and value amounts, as specified by the report options. --- -- Makes sure all report columns have an entry. calculateReportMatrix :: ReportSpec -> Journal -> PriceOracle -> HashMap ClippedAccountName Account @@ -313,15 +326,15 @@ startingBalance = HM.lookupDefault nullacct name startbals valuedStart = avalue (DateSpan Nothing historicalDate) startingBalance - -- Transpose to get each account's balance changes across all columns, then - -- pad with zeros - allchanges = ((<>zeros) <$> acctchanges) <> (zeros <$ startbals) - acctchanges = dbg5 "acctchanges" . addElided $ transposeMap colacctchanges - colacctchanges = dbg5 "colacctchanges" $ map (second $ acctChangesFromPostings rspec) colps + -- In each column, get each account's balance changes + colacctchanges = dbg5 "colacctchanges" $ map (second $ acctChanges rspec j) colps :: [(DateSpan, HashMap ClippedAccountName Account)] + -- Transpose it to get each account's balance changes across all columns + acctchanges = dbg5 "acctchanges" $ transposeMap colacctchanges :: HashMap AccountName (Map DateSpan Account) + -- Fill out the matrix with zeros in empty cells + allchanges = ((<>zeros) <$> acctchanges) <> (zeros <$ startbals) avalue = acctApplyBoth . mixedAmountApplyValuationAfterSumFromOptsWith ropts j priceoracle acctApplyBoth f a = a{aibalance = f $ aibalance a, aebalance = f $ aebalance a} - addElided = if queryDepth (_rsQuery rspec) == Just 0 then HM.insert "..." zeros else id historicalDate = minimumMay $ mapMaybe spanStart colspans zeros = M.fromList [(span, nullacct) | span <- colspans] colspans = map fst colps @@ -573,14 +586,15 @@ Tab.renderTableByRowsB def{Tab.tableBorders=False, Tab.prettyTable=pretty_} renderCh renderRow where renderCh - | not commodity_column_ || transpose_ = fmap (Tab.textCell Tab.TopRight) + | commodity_layout_ /= CommodityBare || transpose_ = fmap (Tab.textCell Tab.TopRight) | otherwise = zipWith ($) (Tab.textCell Tab.TopLeft : repeat (Tab.textCell Tab.TopRight)) renderRow (rh, row) - | not commodity_column_ || transpose_ = + | commodity_layout_ /= CommodityBare || transpose_ = (Tab.textCell Tab.TopLeft rh, fmap (Tab.Cell Tab.TopRight . pure) row) | otherwise = (Tab.textCell Tab.TopLeft rh, zipWith ($) (Tab.Cell Tab.TopLeft : repeat (Tab.Cell Tab.TopRight)) (fmap pure row)) + -- tests diff --git a/Hledger/Reports/PostingsReport.hs b/Hledger/Reports/PostingsReport.hs --- a/Hledger/Reports/PostingsReport.hs +++ b/Hledger/Reports/PostingsReport.hs @@ -64,7 +64,7 @@ postingsReport rspec@ReportSpec{_rsReportOpts=ropts@ReportOpts{..}} j = items where reportspan = reportSpanBothDates j rspec - whichdate = whichDateFromOpts ropts + whichdate = whichDate ropts mdepth = queryDepth $ _rsQuery rspec multiperiod = interval_ /= NoInterval @@ -113,29 +113,23 @@ -- A helper for the postings report. matchedPostingsBeforeAndDuring :: ReportSpec -> Journal -> DateSpan -> ([Posting],[Posting]) matchedPostingsBeforeAndDuring rspec@ReportSpec{_rsReportOpts=ropts,_rsQuery=q} j reportspan = - dbg5 "beforeps, duringps" $ span (beforestartq `matchesPosting`) beforeandduringps + dbg5 "beforeps, duringps" $ span (beforestartq `matchesPosting`) beforeandduringps where beforestartq = dbg3 "beforestartq" $ dateqtype $ DateSpan Nothing $ spanStart reportspan - beforeandduringps = - dbg5 "ps4" $ sortOn sortdate $ -- sort postings by date or date2 - dbg5 "ps3" $ (if invert_ ropts then map negatePostingAmount else id) $ -- with --invert, invert amounts - journalPostings $ - journalApplyValuationFromOpts rspec $ -- convert to cost and apply valuation - dbg5 "ps2" $ filterJournalAmounts symq $ -- remove amount parts which the query's cur: terms would exclude - dbg5 "ps1" $ filterJournal beforeandduringq j -- filter postings by the query, with no start date or depth limit + beforeandduringps = + sortOn (postingDateOrDate2 (whichDate ropts)) -- sort postings by date or date2 + . (if invert_ ropts then map negatePostingAmount else id) -- with --invert, invert amounts + . journalPostings + $ journalValueAndFilterPostings rspec{_rsQuery=beforeandduringq} j + -- filter postings by the query, with no start date or depth limit beforeandduringq = dbg4 "beforeandduringq" $ And [depthless $ dateless q, beforeendq] where depthless = filterQuery (not . queryIsDepth) dateless = filterQuery (not . queryIsDateOrDate2) beforeendq = dateqtype $ DateSpan Nothing $ spanEnd reportspan - sortdate = if date2_ ropts then postingDate2 else postingDate - filterJournal = if related_ ropts then filterJournalRelatedPostings else filterJournalPostings -- with -r, replace each posting with its sibling postings - symq = dbg4 "symq" $ filterQuery queryIsSym q - dateqtype - | queryIsDate2 dateq || (queryIsDate dateq && date2_ ropts) = Date2 - | otherwise = Date + dateqtype = if queryIsDate2 dateq || (queryIsDate dateq && date2_ ropts) then Date2 else Date where dateq = dbg4 "dateq" $ filterQuery queryIsDateOrDate2 $ dbg4 "q" q -- XXX confused by multiple date:/date2: ? @@ -160,15 +154,12 @@ -- the transaction description. mkpostingsReportItem :: Bool -> Bool -> WhichDate -> Maybe Period -> Posting -> MixedAmount -> PostingsReportItem mkpostingsReportItem showdate showdesc wd mperiod p b = - (if showdate then Just date else Nothing + (if showdate then Just $ postingDateOrDate2 wd p else Nothing ,mperiod ,if showdesc then tdescription <$> ptransaction p else Nothing ,p ,b ) - where - date = case wd of PrimaryDate -> postingDate p - SecondaryDate -> postingDate2 p -- | Convert a list of postings into summary postings, one per interval, -- aggregated to the specified depth if any. @@ -178,13 +169,10 @@ concatMap (\(s,ps) -> summarisePostingsInDateSpan s wd mdepth showempty ps) -- Group postings into their columns. We try to be efficient, since -- there can possibly be a very large number of intervals (cf #1683) - . groupByDateSpan showempty getDate colspans + . groupByDateSpan showempty (postingDateOrDate2 wd) colspans where -- The date spans to be included as report columns. colspans = splitSpan interval reportspan - getDate = case wd of - PrimaryDate -> postingDate - SecondaryDate -> postingDate2 -- | Given a date span (representing a report interval) and a list of -- postings within it, aggregate the postings into one summary posting per diff --git a/Hledger/Reports/ReportOptions.hs b/Hledger/Reports/ReportOptions.hs --- a/Hledger/Reports/ReportOptions.hs +++ b/Hledger/Reports/ReportOptions.hs @@ -26,6 +26,7 @@ BalanceAccumulation(..), AccountListMode(..), ValuationType(..), + CommodityLayout(..), defreportopts, rawOptsToReportOpts, defreportspec, @@ -38,7 +39,9 @@ tree_, reportOptsToggleStatus, simplifyStatuses, - whichDateFromOpts, + whichDate, + journalValueAndFilterPostings, + journalValueAndFilterPostingsWith, journalApplyValuationFromOpts, journalApplyValuationFromOptsWith, mixedAmountApplyValuationAfterSumFromOptsWith, @@ -59,17 +62,18 @@ ) where -import Control.Applicative (Const(..), (<|>)) -import Control.Monad ((<=<), join) +import Control.Applicative (Const(..), (<|>), liftA2) +import Control.Monad ((<=<), guard, join) +import Data.Char (toLower) import Data.Either (fromRight) import Data.Either.Extra (eitherToMaybe) import Data.Functor.Identity (Identity(..)) -import Data.List.Extra (nubSort) +import Data.List.Extra (find, isPrefixOf, nubSort) import Data.Maybe (fromMaybe, mapMaybe) import qualified Data.Text as T import Data.Time.Calendar (Day, addDays) import Data.Default (Default(..)) -import Safe (headMay, lastDef, lastMay, maximumMay) +import Safe (headMay, lastDef, lastMay, maximumMay, readMay) import Text.Megaparsec.Custom @@ -105,47 +109,53 @@ instance Default AccountListMode where def = ALFlat +data CommodityLayout = CommodityWide (Maybe Int) + | CommodityTall + | CommodityBare + deriving (Eq, Show) + -- | Standard options for customising report filtering and output. -- Most of these correspond to standard hledger command-line options -- or query arguments, but not all. Some are used only by certain -- commands, as noted below. data ReportOpts = ReportOpts { -- for most reports: - period_ :: Period - ,interval_ :: Interval - ,statuses_ :: [Status] -- ^ Zero, one, or two statuses to be matched - ,cost_ :: Costing -- ^ Should we convert amounts to cost, when present? - ,value_ :: Maybe ValuationType -- ^ What value should amounts be converted to ? - ,infer_prices_ :: Bool -- ^ Infer market prices from transactions ? - ,depth_ :: Maybe Int - ,date2_ :: Bool - ,empty_ :: Bool - ,no_elide_ :: Bool - ,real_ :: Bool - ,format_ :: StringFormat - ,pretty_ :: Bool - ,querystring_ :: [T.Text] + period_ :: Period + ,interval_ :: Interval + ,statuses_ :: [Status] -- ^ Zero, one, or two statuses to be matched + ,cost_ :: Costing -- ^ Should we convert amounts to cost, when present? + ,value_ :: Maybe ValuationType -- ^ What value should amounts be converted to ? + ,infer_prices_ :: Bool -- ^ Infer market prices from transactions ? + ,depth_ :: Maybe Int + ,date2_ :: Bool + ,empty_ :: Bool + ,no_elide_ :: Bool + ,real_ :: Bool + ,format_ :: StringFormat + ,pretty_ :: Bool + ,querystring_ :: [T.Text] -- - ,average_ :: Bool + ,average_ :: Bool -- for posting reports (register) - ,related_ :: Bool + ,related_ :: Bool -- for account transactions reports (aregister) - ,txn_dates_ :: Bool + ,txn_dates_ :: Bool -- for balance reports (bal, bs, cf, is) - ,balancecalc_ :: BalanceCalculation -- ^ What to calculate in balance report cells - ,balanceaccum_ :: BalanceAccumulation -- ^ How to accumulate balance report values over time - ,budgetpat_ :: Maybe T.Text -- ^ A case-insensitive description substring - -- to select periodic transactions for budget reports. - -- (Not a regexp, nor a full hledger query, for now.) - ,accountlistmode_ :: AccountListMode - ,drop_ :: Int - ,row_total_ :: Bool - ,no_total_ :: Bool - ,show_costs_ :: Bool -- ^ Whether to show costs for reports which normally don't show them - ,sort_amount_ :: Bool - ,percent_ :: Bool - ,invert_ :: Bool -- ^ if true, flip all amount signs in reports - ,normalbalance_ :: Maybe NormalSign + ,balancecalc_ :: BalanceCalculation -- ^ What to calculate in balance report cells + ,balanceaccum_ :: BalanceAccumulation -- ^ How to accumulate balance report values over time + ,budgetpat_ :: Maybe T.Text -- ^ A case-insensitive description substring + -- to select periodic transactions for budget reports. + -- (Not a regexp, nor a full hledger query, for now.) + ,accountlistmode_ :: AccountListMode + ,drop_ :: Int + ,declared_ :: Bool -- ^ Include accounts declared but not yet posted to ? + ,row_total_ :: Bool + ,no_total_ :: Bool + ,show_costs_ :: Bool -- ^ Show costs for reports which normally don't show them ? + ,sort_amount_ :: Bool + ,percent_ :: Bool + ,invert_ :: Bool -- ^ Flip all amount signs in reports ? + ,normalbalance_ :: Maybe NormalSign -- ^ This can be set when running balance reports on a set of accounts -- with the same normal balance type (eg all assets, or all incomes). -- - It helps --sort-amount know how to sort negative numbers @@ -153,51 +163,52 @@ -- - It helps compound balance report commands (is, bs etc.) do -- sign normalisation, converting normally negative subreports to -- normally positive for a more conventional display. - ,color_ :: Bool + ,color_ :: Bool -- ^ Whether to use ANSI color codes in text output. -- Influenced by the --color/colour flag (cf CliOptions), -- whether stdout is an interactive terminal, and the value of -- TERM and existence of NO_COLOR environment variables. - ,transpose_ :: Bool - ,commodity_column_:: Bool + ,transpose_ :: Bool + ,commodity_layout_ :: CommodityLayout } deriving (Show) instance Default ReportOpts where def = defreportopts defreportopts :: ReportOpts defreportopts = ReportOpts - { period_ = PeriodAll - , interval_ = NoInterval - , statuses_ = [] - , cost_ = NoCost - , value_ = Nothing - , infer_prices_ = False - , depth_ = Nothing - , date2_ = False - , empty_ = False - , no_elide_ = False - , real_ = False - , format_ = def - , pretty_ = False - , querystring_ = [] - , average_ = False - , related_ = False - , txn_dates_ = False - , balancecalc_ = def - , balanceaccum_ = def - , budgetpat_ = Nothing - , accountlistmode_ = ALFlat - , drop_ = 0 - , row_total_ = False - , no_total_ = False - , show_costs_ = False - , sort_amount_ = False - , percent_ = False - , invert_ = False - , normalbalance_ = Nothing - , color_ = False - , transpose_ = False - , commodity_column_ = False + { period_ = PeriodAll + , interval_ = NoInterval + , statuses_ = [] + , cost_ = NoCost + , value_ = Nothing + , infer_prices_ = False + , depth_ = Nothing + , date2_ = False + , empty_ = False + , no_elide_ = False + , real_ = False + , format_ = def + , pretty_ = False + , querystring_ = [] + , average_ = False + , related_ = False + , txn_dates_ = False + , balancecalc_ = def + , balanceaccum_ = def + , budgetpat_ = Nothing + , accountlistmode_ = ALFlat + , drop_ = 0 + , declared_ = False + , row_total_ = False + , no_total_ = False + , show_costs_ = False + , sort_amount_ = False + , percent_ = False + , invert_ = False + , normalbalance_ = Nothing + , color_ = False + , transpose_ = False + , commodity_layout_ = CommodityWide Nothing } -- | Generate a ReportOpts from raw command-line input, given a day. @@ -220,37 +231,38 @@ Just (Left err) -> usageError $ "could not parse format option: " ++ err in defreportopts - {period_ = periodFromRawOpts d rawopts - ,interval_ = intervalFromRawOpts rawopts - ,statuses_ = statusesFromRawOpts rawopts - ,cost_ = costing - ,value_ = valuation - ,infer_prices_ = boolopt "infer-market-prices" rawopts - ,depth_ = maybeposintopt "depth" rawopts - ,date2_ = boolopt "date2" rawopts - ,empty_ = boolopt "empty" rawopts - ,no_elide_ = boolopt "no-elide" rawopts - ,real_ = boolopt "real" rawopts - ,format_ = format - ,querystring_ = querystring - ,average_ = boolopt "average" rawopts - ,related_ = boolopt "related" rawopts - ,txn_dates_ = boolopt "txn-dates" rawopts - ,balancecalc_ = balancecalcopt rawopts - ,balanceaccum_ = balanceaccumopt rawopts - ,budgetpat_ = maybebudgetpatternopt rawopts - ,accountlistmode_ = accountlistmodeopt rawopts - ,drop_ = posintopt "drop" rawopts - ,row_total_ = boolopt "row-total" rawopts - ,no_total_ = boolopt "no-total" rawopts - ,show_costs_ = boolopt "show-costs" rawopts - ,sort_amount_ = boolopt "sort-amount" rawopts - ,percent_ = boolopt "percent" rawopts - ,invert_ = boolopt "invert" rawopts - ,pretty_ = pretty - ,color_ = useColorOnStdout -- a lower-level helper - ,transpose_ = boolopt "transpose" rawopts - ,commodity_column_= boolopt "commodity-column" rawopts + {period_ = periodFromRawOpts d rawopts + ,interval_ = intervalFromRawOpts rawopts + ,statuses_ = statusesFromRawOpts rawopts + ,cost_ = costing + ,value_ = valuation + ,infer_prices_ = boolopt "infer-market-prices" rawopts + ,depth_ = maybeposintopt "depth" rawopts + ,date2_ = boolopt "date2" rawopts + ,empty_ = boolopt "empty" rawopts + ,no_elide_ = boolopt "no-elide" rawopts + ,real_ = boolopt "real" rawopts + ,format_ = format + ,querystring_ = querystring + ,average_ = boolopt "average" rawopts + ,related_ = boolopt "related" rawopts + ,txn_dates_ = boolopt "txn-dates" rawopts + ,balancecalc_ = balancecalcopt rawopts + ,balanceaccum_ = balanceaccumopt rawopts + ,budgetpat_ = maybebudgetpatternopt rawopts + ,accountlistmode_ = accountlistmodeopt rawopts + ,drop_ = posintopt "drop" rawopts + ,declared_ = boolopt "declared" rawopts + ,row_total_ = boolopt "row-total" rawopts + ,no_total_ = boolopt "no-total" rawopts + ,show_costs_ = boolopt "show-costs" rawopts + ,sort_amount_ = boolopt "sort-amount" rawopts + ,percent_ = boolopt "percent" rawopts + ,invert_ = boolopt "invert" rawopts + ,pretty_ = pretty + ,color_ = useColorOnStdout -- a lower-level helper + ,transpose_ = boolopt "transpose" rawopts + ,commodity_layout_ = commoditylayoutopt rawopts } -- | The result of successfully parsing a ReportOpts on a particular @@ -325,6 +337,27 @@ CalcValueChange -> Just PerPeriod _ -> Nothing +commoditylayoutopt :: RawOpts -> CommodityLayout +commoditylayoutopt rawopts = fromMaybe (CommodityWide Nothing) $ layout <|> column + where + layout = parse <$> maybestringopt "layout" rawopts + column = CommodityBare <$ guard (boolopt "commodity-column" rawopts) + + parse opt = maybe err snd $ guard (not $ null s) *> find (isPrefixOf s . fst) checkNames + where + checkNames = [ ("wide", CommodityWide w) + , ("tall", CommodityTall) + , ("bare", CommodityBare) + ] + -- For `--layout=elided,n`, elide to the given width + (s,n) = break (==',') $ map toLower opt + w = case drop 1 n of + "" -> Nothing + c | Just w <- readMay c -> Just w + _ -> usageError "width in --layout=wide,WIDTH must be an integer" + + err = usageError "--layout's argument should be \"wide[,WIDTH]\", \"tall\", or \"bare\"" + -- Get the period specified by any -b/--begin, -e/--end and/or -p/--period -- options appearing in the command line. -- Its bounds are the rightmost begin date specified by a -b or -p, and @@ -484,8 +517,8 @@ postingDateFn ReportOpts{..} = if date2_ then postingDate2 else postingDate -- | Report which date we will report on based on --date2. -whichDateFromOpts :: ReportOpts -> WhichDate -whichDateFromOpts ReportOpts{..} = if date2_ then SecondaryDate else PrimaryDate +whichDate :: ReportOpts -> WhichDate +whichDate ReportOpts{..} = if date2_ then SecondaryDate else PrimaryDate -- | Legacy-compatible convenience aliases for accountlistmode_. tree_ :: ReportOpts -> Bool @@ -498,6 +531,31 @@ -- depthFromOpts :: ReportOpts -> Int -- depthFromOpts opts = min (fromMaybe 99999 $ depth_ opts) (queryDepth $ queryFromOpts nulldate opts) +-- | Convert a 'Journal''s amounts to cost and/or to value (see +-- 'journalApplyValuationFromOpts'), and filter by the 'ReportSpec' 'Query'. +-- +-- We make sure to first filter by amt: and cur: terms, then value the +-- 'Journal', then filter by the remaining terms. +journalValueAndFilterPostings :: ReportSpec -> Journal -> Journal +journalValueAndFilterPostings rspec j = journalValueAndFilterPostingsWith rspec j priceoracle + where priceoracle = journalPriceOracle (infer_prices_ $ _rsReportOpts rspec) j + +-- | Like 'journalValueAndFilterPostings', but takes a 'PriceOracle' as an argument. +journalValueAndFilterPostingsWith :: ReportSpec -> Journal -> PriceOracle -> Journal +journalValueAndFilterPostingsWith rspec@ReportSpec{_rsQuery=q, _rsReportOpts=ropts} j = + -- Filter by the remainder of the query + filterJournal reportq + -- Apply valuation and costing + . journalApplyValuationFromOptsWith rspec + -- Filter by amount and currency, so it matches pre-valuation/costing + (if queryIsNull amtsymq then j else filterJournalAmounts amtsymq j) + where + -- with -r, replace each posting with its sibling postings + filterJournal = if related_ ropts then filterJournalRelatedPostings else filterJournalPostings + amtsymq = dbg3 "amtsymq" $ filterQuery queryIsAmtOrSym q + reportq = dbg3 "reportq" $ filterQuery (not . queryIsAmtOrSym) q + queryIsAmtOrSym = liftA2 (||) queryIsAmt queryIsSym + -- | Convert this journal's postings' amounts to cost and/or to value, if specified -- by options (-B/--cost/-V/-X/--value etc.). Strip prices if not needed. This -- should be the main stop for performing costing and valuation. The exception is @@ -524,7 +582,9 @@ -- Find the end of the period containing this posting periodEnd = addDays (-1) . fromMaybe err . mPeriodEnd . postingDate - mPeriodEnd = spanEnd <=< latestSpanContaining (historical : spans) + mPeriodEnd = case interval_ ropts of + NoInterval -> const . spanEnd $ reportSpan j rspec + _ -> spanEnd <=< latestSpanContaining (historical : spans) historical = DateSpan Nothing $ spanStart =<< headMay spans spans = splitSpan (interval_ ropts) $ reportSpanBothDates j rspec styles = journalCommodityStyles j diff --git a/Hledger/Reports/ReportTypes.hs b/Hledger/Reports/ReportTypes.hs --- a/Hledger/Reports/ReportTypes.hs +++ b/Hledger/Reports/ReportTypes.hs @@ -29,9 +29,11 @@ , prrFullName , prrDisplayName , prrDepth +, prrAdd ) where import Data.Aeson (ToJSON(..)) +import Data.Bifunctor (Bifunctor(..)) import Data.Decimal (Decimal) import Data.Maybe (mapMaybe) import Data.Text (Text) @@ -86,6 +88,9 @@ , prTotals :: PeriodicReportRow () b -- The grand totals row. } deriving (Show, Functor, Generic, ToJSON) +instance Bifunctor PeriodicReport where + bimap f g pr = pr{prRows = map (bimap f g) $ prRows pr, prTotals = fmap g $ prTotals pr} + data PeriodicReportRow a b = PeriodicReportRow { prrName :: a -- An account name. @@ -94,13 +99,23 @@ , prrAverage :: b -- The average of this row's values. } deriving (Show, Functor, Generic, ToJSON) +instance Bifunctor PeriodicReportRow where + first f prr = prr{prrName = f $ prrName prr} + second = fmap + instance Semigroup b => Semigroup (PeriodicReportRow a b) where - (PeriodicReportRow _ amts1 t1 a1) <> (PeriodicReportRow n2 amts2 t2 a2) = - PeriodicReportRow n2 (sumPadded amts1 amts2) (t1 <> t2) (a1 <> a2) - where - sumPadded (a:as) (b:bs) = (a <> b) : sumPadded as bs - sumPadded as [] = as - sumPadded [] bs = bs + (<>) = prrAdd + +-- | Add two 'PeriodicReportRows', preserving the name of the first. +prrAdd :: Semigroup b => PeriodicReportRow a b -> PeriodicReportRow a b -> PeriodicReportRow a b +prrAdd (PeriodicReportRow n1 amts1 t1 a1) (PeriodicReportRow _ amts2 t2 a2) = + PeriodicReportRow n1 (zipWithPadded (<>) amts1 amts2) (t1 <> t2) (a1 <> a2) + +-- | Version of 'zipWith' which will not end on the shortest list, but will copy the rest of the longer list. +zipWithPadded :: (a -> a -> a) -> [a] -> [a] -> [a] +zipWithPadded f (a:as) (b:bs) = f a b : zipWithPadded f as bs +zipWithPadded _ as [] = as +zipWithPadded _ [] bs = bs -- | Figure out the overall date span of a PeriodicReport periodicReportSpan :: PeriodicReport a b -> DateSpan diff --git a/Hledger/Utils.hs b/Hledger/Utils.hs --- a/Hledger/Utils.hs +++ b/Hledger/Utils.hs @@ -59,6 +59,7 @@ import Hledger.Utils.String import Hledger.Utils.Text import Hledger.Utils.Test +import Data.Tree (foldTree, Tree) -- tuples @@ -116,6 +117,11 @@ where split es = let (first,rest) = break (x==) es in first : splitAtElement x rest + +-- trees + +treeLeaves :: Tree a -> [a] +treeLeaves = foldTree (\a bs -> (if null bs then (a:) else id) $ concat bs) -- text diff --git a/Hledger/Utils/Debug.hs b/Hledger/Utils/Debug.hs --- a/Hledger/Utils/Debug.hs +++ b/Hledger/Utils/Debug.hs @@ -93,7 +93,7 @@ ,module Debug.Trace ,useColorOnStdout ,useColorOnStderr - ) + ,dlog) where import Control.Monad (when) @@ -304,6 +304,10 @@ -- | otherwise = ls -- in trace (s++":"++nlorspace++intercalate "\n" ls') a in trace p a + +-- | Log a pretty-printed showable value to "./debug.log". Uses unsafePerformIO. +dlog :: Show a => a -> a +dlog x = unsafePerformIO $ appendFile "debug.log" (pshow x ++ "\n") >> return x -- "dbg" would clash with megaparsec. -- | Pretty-print a label and the showable value to the console, then return it. diff --git a/Hledger/Utils/String.hs b/Hledger/Utils/String.hs --- a/Hledger/Utils/String.hs +++ b/Hledger/Utils/String.hs @@ -42,7 +42,7 @@ import Hledger.Utils.Parse import Hledger.Utils.Regex (toRegex', regexReplace) -import Text.WideString (charWidth, strWidth) +import Text.DocLayout (charWidth, realLength) -- | Take elements from the end of a list. @@ -173,6 +173,10 @@ -- adding ANSI escape sequences, but is being kept around for now. strWidthAnsi :: String -> Int strWidthAnsi = strWidth . stripAnsi + +-- | Alias for 'realLength'. +strWidth :: String -> Int +strWidth = realLength -- | Strip ANSI escape sequences from a string. -- diff --git a/Hledger/Utils/Text.hs b/Hledger/Utils/Text.hs --- a/Hledger/Utils/Text.hs +++ b/Hledger/Utils/Text.hs @@ -43,7 +43,6 @@ wbToText, wbFromText, wbUnpack, - textWidth, textTakeWidth, -- * Reading readDecimal, @@ -58,12 +57,13 @@ import qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Builder as TB +import Text.DocLayout (charWidth, realLength) import Test.Tasty (testGroup) import Test.Tasty.HUnit ((@?=), testCase) import Text.Tabular.AsciiWide (Align(..), Header(..), Properties(..), TableOpts(..), renderRow, textCell) -import Text.WideString (WideBuilder(..), wbToText, wbFromText, wbUnpack, charWidth, textWidth) +import Text.WideString (WideBuilder(..), wbToText, wbFromText, wbUnpack) -- lowercase, uppercase :: String -> String @@ -206,7 +206,7 @@ clip s = case mmaxwidth of Just w - | textWidth s > w -> + | realLength s > w -> if rightside then textTakeWidth (w - T.length ellipsis) s <> ellipsis else ellipsis <> T.reverse (textTakeWidth (w - T.length ellipsis) $ T.reverse s) @@ -224,7 +224,7 @@ else T.replicate (w - sw) " " <> s | otherwise -> s Nothing -> s - where sw = textWidth s + where sw = realLength s -- | Double-width-character-aware string truncation. Take as many -- characters as possible from a string without exceeding the diff --git a/Text/Megaparsec/Custom.hs b/Text/Megaparsec/Custom.hs --- a/Text/Megaparsec/Custom.hs +++ b/Text/Megaparsec/Custom.hs @@ -47,9 +47,6 @@ ) where -import Prelude () -import "base-compat-batteries" Prelude.Compat hiding (readFile) - import Control.Monad.Except import Control.Monad.State.Strict (StateT, evalStateT) import qualified Data.List.NonEmpty as NE diff --git a/Text/Tabular/AsciiWide.hs b/Text/Tabular/AsciiWide.hs --- a/Text/Tabular/AsciiWide.hs +++ b/Text/Tabular/AsciiWide.hs @@ -35,7 +35,7 @@ import Data.Text.Lazy.Builder (Builder, fromString, fromText, singleton, toLazyText) import Safe (maximumMay) import Text.Tabular -import Text.WideString (WideBuilder(..), wbFromText, textWidth) +import Text.WideString (WideBuilder(..), wbFromText) -- | The options to use for rendering a table. @@ -63,7 +63,7 @@ -- | Create a single-line cell from the given contents with its natural width. textCell :: Align -> Text -> Cell -textCell a x = Cell a . map (\x -> WideBuilder (fromText x) (textWidth x)) $ if T.null x then [""] else T.lines x +textCell a x = Cell a . map wbFromText $ if T.null x then [""] else T.lines x -- | Create a multi-line cell from the given contents with its natural width. textsCell :: Align -> [Text] -> Cell diff --git a/Text/WideString.hs b/Text/WideString.hs --- a/Text/WideString.hs +++ b/Text/WideString.hs @@ -1,10 +1,6 @@ -- | Calculate the width of String and Text, being aware of wide characters. module Text.WideString ( - -- * wide-character-aware layout - strWidth, - textWidth, - charWidth, -- * Text Builders which keep track of length WideBuilder(..), wbUnpack, @@ -13,9 +9,9 @@ ) where import Data.Text (Text) -import qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Builder as TB +import Text.DocLayout (realLength) -- | Helper for constructing Builders while keeping track of text width. @@ -36,68 +32,8 @@ -- | Convert a strict Text to a WideBuilder. wbFromText :: Text -> WideBuilder -wbFromText t = WideBuilder (TB.fromText t) (textWidth t) +wbFromText t = WideBuilder (TB.fromText t) (realLength t) -- | Convert a WideBuilder to a String. wbUnpack :: WideBuilder -> String wbUnpack = TL.unpack . TB.toLazyText . wbBuilder - - --- | Calculate the render width of a string, considering --- wide characters (counted as double width) -strWidth :: String -> Int -strWidth = foldr (\a b -> charWidth a + b) 0 - --- | Calculate the render width of a string, considering --- wide characters (counted as double width) -textWidth :: Text -> Int -textWidth = T.foldr (\a b -> charWidth a + b) 0 - --- from Pandoc (copyright John MacFarlane, GPL) --- see also http://unicode.org/reports/tr11/#Description - --- | Get the designated render width of a character: 0 for a combining --- character, 1 for a regular character, 2 for a wide character. --- (Wide characters are rendered as exactly double width in apps and --- fonts that support it.) (From Pandoc.) -charWidth :: Char -> Int -charWidth c - | c < '\x0300' = 1 - | c >= '\x0300' && c <= '\x036F' = 0 -- combining - | c >= '\x0370' && c <= '\x10FC' = 1 - | c >= '\x1100' && c <= '\x115F' = 2 - | c >= '\x1160' && c <= '\x11A2' = 1 - | c >= '\x11A3' && c <= '\x11A7' = 2 - | c >= '\x11A8' && c <= '\x11F9' = 1 - | c >= '\x11FA' && c <= '\x11FF' = 2 - | c >= '\x1200' && c <= '\x2328' = 1 - | c >= '\x2329' && c <= '\x232A' = 2 - | c >= '\x232B' && c <= '\x2E31' = 1 - | c >= '\x2E80' && c <= '\x303E' = 2 - | c == '\x303F' = 1 - | c >= '\x3041' && c <= '\x3247' = 2 - | c >= '\x3248' && c <= '\x324F' = 1 -- ambiguous - | c >= '\x3250' && c <= '\x4DBF' = 2 - | c >= '\x4DC0' && c <= '\x4DFF' = 1 - | c >= '\x4E00' && c <= '\xA4C6' = 2 - | c >= '\xA4D0' && c <= '\xA95F' = 1 - | c >= '\xA960' && c <= '\xA97C' = 2 - | c >= '\xA980' && c <= '\xABF9' = 1 - | c >= '\xAC00' && c <= '\xD7FB' = 2 - | c >= '\xD800' && c <= '\xDFFF' = 1 - | c >= '\xE000' && c <= '\xF8FF' = 1 -- ambiguous - | c >= '\xF900' && c <= '\xFAFF' = 2 - | c >= '\xFB00' && c <= '\xFDFD' = 1 - | c >= '\xFE00' && c <= '\xFE0F' = 1 -- ambiguous - | c >= '\xFE10' && c <= '\xFE19' = 2 - | c >= '\xFE20' && c <= '\xFE26' = 1 - | c >= '\xFE30' && c <= '\xFE6B' = 2 - | c >= '\xFE70' && c <= '\xFEFF' = 1 - | c >= '\xFF01' && c <= '\xFF60' = 2 - | c >= '\xFF61' && c <= '\x16A38' = 1 - | c >= '\x1B000' && c <= '\x1B001' = 2 - | c >= '\x1D000' && c <= '\x1F1FF' = 1 - | c >= '\x1F200' && c <= '\x1F251' = 2 - | c >= '\x1F300' && c <= '\x1F773' = 1 - | c >= '\x20000' && c <= '\x3FFFD' = 2 - | otherwise = 1 diff --git a/hledger-lib.cabal b/hledger-lib.cabal --- a/hledger-lib.cabal +++ b/hledger-lib.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: hledger-lib -version: 1.23 +version: 1.24 synopsis: A reusable library providing the core functionality of hledger description: A reusable library containing hledger's core functionality. This is used by most hledger* packages so that they support the same @@ -100,7 +100,6 @@ , ansi-terminal >=0.9 , array , base >=4.11 && <4.16 - , base-compat-batteries >=0.10.1 && <0.12 , blaze-markup >=0.5.1 , bytestring , call-stack @@ -110,18 +109,19 @@ , containers >=0.5.9 , data-default >=0.5 , directory + , doclayout ==0.3.* , extra >=1.6.3 , file-embed >=0.0.10 , filepath , hashtables >=1.2.3.1 - , megaparsec >=7.0.0 && <9.2 + , megaparsec >=7.0.0 && <9.3 , microlens >=0.4 , microlens-th >=0.4 , mtl >=2.2.1 , parser-combinators >=0.4.0 , pretty-simple >4 && <5 , regex-tdfa - , safe >=0.2 + , safe >=0.3.18 , tabular >=0.2 , tasty >=1.2.3 , tasty-hunit >=0.10.0.2 @@ -150,7 +150,6 @@ , ansi-terminal >=0.9 , array , base >=4.11 && <4.16 - , base-compat-batteries >=0.10.1 && <0.12 , blaze-markup >=0.5.1 , bytestring , call-stack @@ -160,19 +159,20 @@ , containers >=0.5.9 , data-default >=0.5 , directory + , doclayout ==0.3.* , doctest >=0.18.1 , extra >=1.6.3 , file-embed >=0.0.10 , filepath , hashtables >=1.2.3.1 - , megaparsec >=7.0.0 && <9.2 + , megaparsec >=7.0.0 && <9.3 , microlens >=0.4 , microlens-th >=0.4 , mtl >=2.2.1 , parser-combinators >=0.4.0 , pretty-simple >4 && <5 , regex-tdfa - , safe >=0.2 + , safe >=0.3.18 , tabular >=0.2 , tasty >=1.2.3 , tasty-hunit >=0.10.0.2 @@ -203,7 +203,6 @@ , ansi-terminal >=0.9 , array , base >=4.11 && <4.16 - , base-compat-batteries >=0.10.1 && <0.12 , blaze-markup >=0.5.1 , bytestring , call-stack @@ -213,19 +212,20 @@ , containers >=0.5.9 , data-default >=0.5 , directory + , doclayout ==0.3.* , extra >=1.6.3 , file-embed >=0.0.10 , filepath , hashtables >=1.2.3.1 , hledger-lib - , megaparsec >=7.0.0 && <9.2 + , megaparsec >=7.0.0 && <9.3 , microlens >=0.4 , microlens-th >=0.4 , mtl >=2.2.1 , parser-combinators >=0.4.0 , pretty-simple >4 && <5 , regex-tdfa - , safe >=0.2 + , safe >=0.3.18 , tabular >=0.2 , tasty >=1.2.3 , tasty-hunit >=0.10.0.2