diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -9,6 +9,151 @@ Internal/api/developer-ish changes in the hledger-lib (and hledger) packages. For user-visible changes, see the hledger package changelog. +# 1.23 2021-09-21 + +- Require base >=4.11, prevent red squares on Hackage's build matrix. + +Much code cleanup and reorganisation, such as: + +- Introduce lenses for many types. (Stephen Morgan) + +- The now-obsolete normaliseMixedAmount and + normaliseMixedAmountSquashPricesForDisplay functions have been + dropped. (Stephen Morgan) + +- GenericSourcePos has been dropped, replaced by either SourcePos or + (SourcePos, SourcePos), simplifying module structure. (Stephen Morgan) + +- Functions related to balancing (both transaction balancing and journal balancing) + have been moved to Hledger.Data.Balancing, reducing module size and reducing the risk + of import cycles. + (Stephen Morgan) + +- `ReportOptions{infer_value_}` has been renamed to `infer_prices_`, + for more consistency with the corresponding CLI flag. + And `BalancingOpts{infer_prices_}` is now `infer_transaction_prices_`. + +- JournalParser and ErroringJournalParser have moved to + Hledger.Data.Journal. (Stephen Morgan) + +- MixedAmounts now have a more predictable Ord instance / sort order. + They are compared in each commodity in turn, with + alphabetically-first commodity symbols being most significant. + Missing commodities are assumed to be zero. + As a consequence, all the ways of representing zero with a MixedAmount ([], + [A 0], [A 0, B 0, ...]) are now Eq-ual (==), whereas before they were + not. We have not been able to find anything broken by this change. + ([#1563](https://github.com/simonmichael/hledger/issues/1563), + [#1564](https://github.com/simonmichael/hledger/issues/1564), + Stephen Morgan) + +- HUnit's testCase and testGroup are now used directly instead of + having test and tests aliases. (Stephen Morgan) + +- The codebase now passes many hlint checks + +- Dropped modules: + Hledger.Utils.Color, + Hledger.Data.Commodity, + Hledger.Utils.UTF8IOCompat, + Hledger.Utils.Tree module. + (Stephen Morgan) + +- Drop the deprecated old-time lib. + A small number type signatures have changed: + journalSetLastReadTime, maybeFileModificationTime and Journal + now use POSIXTime instead of ClockTime. + Hledger.Cli.Utils.utcTimeToClockTime has been removed, + as it is now equivalent to utcTimeToPOSIXSeconds from Data.Time.Clock.POSIX. + To get the current system time, you should now use getPOSIXTime + from Data.Time.Clock.POSIX instead of getClockTime. + ([#1650](https://github.com/simonmichael/hledger/issues/1650), Stephen Morgan) + +- modifyTransactions now takes a Map of commodity styles, and will style amounts according to that argument. journalAddForecast and journalTransform now return an Either String Journal. (Stephen Morgan) + This improves efficiency, as we no longer have to restyle all amounts in + the journal after generating auto postings or periodic transactions. + Changing the return type of journalAddForecast and journalTransform + reduces partiality. + To get the previous behaviour for modifyTransaction, use modifyTransaction mempty. + +- Refactor journalFinalise to clarify flow. (Stephen Morgan) + The only semantic difference is that we now apply + journalApplyCommodityStyles before running journalCheckAccountsDeclared + and journalCheckCommoditiesDeclared. + +- Introduce lenses for ReportOpts and ReportSpec. (Stephen Morgan) + +- Rename the fields of ReportSpec. (Stephen Morgan) + + This is done to be more consistent with future field naming conventions, + and to make automatic generation of lenses simpler. See discussion in + [#1545](https://github.com/simonmichael/hledger/issues/1545). + + rsOpts -> _rsReportOpts + rsToday -> _rsDay + rsQuery -> _rsQuery + rsQueryOpts -> _rsQueryOpts + +- Remove aismultiplier from Amount. (Stephen Morgan) + + In Amount, aismultiplier is a boolean flag that will always be False, + except for in TMPostingRules, where it indicates whether the posting + rule is a multiplier. It is therefore unnecessary in the vast majority + of cases. This posting pulls this flag out of Amount and puts it into + TMPostingRule, so it is only kept around when necessary. + + This changes the parsing of journals somewhat. Previously you could + include an * before an amount anywhere in a Journal, and it would + happily parse and set the aismultiplier flag true. This will now fail + with a parse error: * is now only acceptable before an amount within an + auto posting rule. + + Any usage of the library in which the aismultiplier field is read or set + should be removed. If you truly need its functionality, you should + switch to using TMPostingRule. + + This changes the JSON output of Amount, as it will no longer include + aismultiplier. + +- For accountTransactionsReport, generate the overall reportq from the ReportSpec, rather than being supplied as a separate option. (Stephen Morgan) + + This is the same approach used by the other reports, e.g. EntryReport, + PostingReport, MultiBalanceReport. This reduces code duplication, as + previously the reportq had to be separately tweaked in each of 5 + different places. + + If you call accountTransactionreport, there is no need to separately + derive the report query. + +- Remove unused TransactionReport. Move the useful utility functions to AccountTransactionsReport. (Stephen Morgan) + + If you use transactionsReport, you should either use entryReport if you + don't require a running total, or using accountTransactionsReport with + thisacctq as Any or None (depending on what you want included in the + running total). + +- Some balance report types have been renamed for clarity and to sync with docs: + + ReportType -> BalanceCalculation + ChangeReport -> CalcChange + BudgetReport -> CalcBudget + ValueChangeReport -> CalcValueChange + + BalanceType -> BalanceAccumulation + PeriodChange -> PerPeriod + CumulativeChange -> Cumulative + HistoricalBalance -> Historical + + ReportOpts: + reporttype_ -> balancecalc_ + balancetype_ -> balanceaccum_ + + CompoundBalanceCommandSpec: + cbctype -> cbcaccum + + Hledger.Reports.ReportOptions: + balanceTypeOverride -> balanceAccumulationOverride + # 1.22.2 2021-08-07 - forecast_ has moved from ReportOpts to InputOpts. (Stephen Morgan) diff --git a/Hledger.hs b/Hledger.hs --- a/Hledger.hs +++ b/Hledger.hs @@ -12,7 +12,7 @@ import Hledger.Query as X import Hledger.Utils as X -tests_Hledger = tests "Hledger" [ +tests_Hledger = testGroup "Hledger" [ tests_Data ,tests_Query ,tests_Read diff --git a/Hledger/Data.hs b/Hledger/Data.hs --- a/Hledger/Data.hs +++ b/Hledger/Data.hs @@ -12,7 +12,7 @@ module Hledger.Data.Account, module Hledger.Data.AccountName, module Hledger.Data.Amount, - module Hledger.Data.Commodity, + module Hledger.Data.Balancing, module Hledger.Data.Dates, module Hledger.Data.Journal, module Hledger.Data.Json, @@ -31,10 +31,11 @@ ) where +import Test.Tasty (testGroup) import Hledger.Data.Account import Hledger.Data.AccountName import Hledger.Data.Amount -import Hledger.Data.Commodity +import Hledger.Data.Balancing import Hledger.Data.Dates import Hledger.Data.Journal import Hledger.Data.Json @@ -49,11 +50,12 @@ import Hledger.Data.TransactionModifier import Hledger.Data.Types hiding (MixedAmountKey, Mixed) import Hledger.Data.Valuation -import Hledger.Utils.Test -tests_Data = tests "Data" [ +tests_Data = testGroup "Data" [ tests_AccountName ,tests_Amount + ,tests_Dates + ,tests_Balancing ,tests_Journal ,tests_Ledger ,tests_Posting diff --git a/Hledger/Data/Account.hs b/Hledger/Data/Account.hs --- a/Hledger/Data/Account.hs +++ b/Hledger/Data/Account.hs @@ -10,21 +10,40 @@ -} module Hledger.Data.Account -where +( nullacct +, accountsFromPostings +, accountTree +, showAccounts +, showAccountsBoringFlag +, printAccounts +, lookupAccount +, parentAccounts +, accountsLevels +, mapAccounts +, anyAccounts +, filterAccounts +, sumAccounts +, clipAccounts +, clipAccountsAndAggregate +, pruneAccounts +, flattenAccounts +, accountSetDeclarationInfo +, sortAccountNamesByDeclaration +, sortAccountTreeByAmount +) where + import qualified Data.HashSet as HS import qualified Data.HashMap.Strict as HM -import Data.List (find, sortOn) +import Data.List (find, foldl', sortOn) import Data.List.Extra (groupOn) import qualified Data.Map as M import Data.Ord (Down(..)) import Safe (headMay) -import Text.Printf +import Text.Printf (printf) -import Hledger.Data.AccountName +import Hledger.Data.AccountName (expandAccountName, clipOrEllipsifyAccountName) import Hledger.Data.Amount -import Hledger.Data.Posting () import Hledger.Data.Types -import Hledger.Utils -- deriving instance Show Account @@ -90,6 +109,22 @@ aname=a ,asubs=map (uncurry accountTree') $ M.assocs m } + +-- | An efficient-to-build tree suggested by Cale Gibbard, probably +-- better than accountNameTreeFrom. +newtype FastTree a = T (M.Map a (FastTree a)) + deriving (Show, Eq, Ord) + +mergeTrees :: (Ord a) => FastTree a -> FastTree a -> FastTree a +mergeTrees (T m) (T m') = T (M.unionWith mergeTrees m m') + +treeFromPath :: [a] -> FastTree a +treeFromPath [] = T M.empty +treeFromPath (x:xs) = T (M.singleton x (treeFromPath xs)) + +treeFromPaths :: (Ord a) => [[a]] -> FastTree a +treeFromPaths = foldl' mergeTrees (T M.empty) . map treeFromPath + -- | Tie the knot so all subaccounts' parents are set correctly. tieAccountParents :: Account -> Account diff --git a/Hledger/Data/AccountName.hs b/Hledger/Data/AccountName.hs --- a/Hledger/Data/AccountName.hs +++ b/Hledger/Data/AccountName.hs @@ -235,21 +235,21 @@ --isAccountRegex :: String -> Bool --isAccountRegex s = take 1 s == "^" && take 5 (reverse s) == ")$|:(" -tests_AccountName = tests "AccountName" [ - test "accountNameTreeFrom" $ do +tests_AccountName = testGroup "AccountName" [ + testCase "accountNameTreeFrom" $ do accountNameTreeFrom ["a"] @?= Node "root" [Node "a" []] accountNameTreeFrom ["a","b"] @?= Node "root" [Node "a" [], Node "b" []] accountNameTreeFrom ["a","a:b"] @?= Node "root" [Node "a" [Node "a:b" []]] accountNameTreeFrom ["a:b:c"] @?= Node "root" [Node "a" [Node "a:b" [Node "a:b:c" []]]] - ,test "expandAccountNames" $ do + ,testCase "expandAccountNames" $ do expandAccountNames ["assets:cash","assets:checking","expenses:vacation"] @?= ["assets","assets:cash","assets:checking","expenses","expenses:vacation"] - ,test "isAccountNamePrefixOf" $ do + ,testCase "isAccountNamePrefixOf" $ do "assets" `isAccountNamePrefixOf` "assets" @?= False "assets" `isAccountNamePrefixOf` "assets:bank" @?= True "assets" `isAccountNamePrefixOf` "assets:bank:checking" @?= True "my assets" `isAccountNamePrefixOf` "assets:bank" @?= False - ,test "isSubAccountNameOf" $ do + ,testCase "isSubAccountNameOf" $ do "assets" `isSubAccountNameOf` "assets" @?= False "assets:bank" `isSubAccountNameOf` "assets" @?= True "assets:bank:checking" `isSubAccountNameOf` "assets" @?= False diff --git a/Hledger/Data/Amount.hs b/Hledger/Data/Amount.hs --- a/Hledger/Data/Amount.hs +++ b/Hledger/Data/Amount.hs @@ -30,9 +30,9 @@ 16h + $13.55 + AAPL 500 + 6 oranges @ -When a mixed amount has been \"normalised\", it has no more than one amount -in each commodity and no zero amounts; or it has just a single zero amount -and no others. +A mixed amount is always \"normalised\", it has no more than one amount +in each commodity and price. When calling 'amounts' it will have no zero +amounts, or just a single zero amount and no other amounts. Limited arithmetic with simple and mixed amounts is supported, best used with similar amounts since it mostly ignores assigned prices and commodity @@ -40,12 +40,14 @@ -} -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE StandaloneDeriving #-} module Hledger.Data.Amount ( + -- * Commodity + showCommoditySymbol, + isNonsimpleCommodityChar, + quoteCommoditySymbolIfNeeded, -- * Amount amount, nullamt, @@ -93,17 +95,17 @@ -- * MixedAmount nullmixedamt, missingmixedamt, + isMissingMixedAmount, mixed, mixedAmount, maAddAmount, maAddAmounts, amounts, amountsRaw, + maCommodities, filterMixedAmount, filterMixedAmountByCommodity, mapMixedAmount, - normaliseMixedAmountSquashPricesForDisplay, - normaliseMixedAmount, unifyMixedAmount, mixedAmountStripPrices, -- ** arithmetic @@ -144,28 +146,56 @@ tests_Amount ) where +import Control.Applicative (liftA2) import Control.Monad (foldM) +import Data.Char (isDigit) import Data.Decimal (DecimalRaw(..), decimalPlaces, normalizeDecimal, roundTo) import Data.Default (Default(..)) import Data.Foldable (toList) import Data.List (find, foldl', intercalate, intersperse, mapAccumL, partition) import Data.List.NonEmpty (NonEmpty(..), nonEmpty) import qualified Data.Map.Strict as M -import Data.Maybe (fromMaybe, isNothing) +import qualified Data.Set as S +import Data.Maybe (fromMaybe, isNothing, isJust) import Data.Semigroup (Semigroup(..)) import qualified Data.Text as T import qualified Data.Text.Lazy.Builder as TB import Data.Word (Word8) import Safe (headDef, lastDef, lastMay) -import Text.Printf (printf) +import System.Console.ANSI (Color(..),ColorIntensity(..)) +import Debug.Trace (trace) +import Test.Tasty (testGroup) +import Test.Tasty.HUnit ((@?=), assertBool, testCase) + import Hledger.Data.Types -import Hledger.Data.Commodity -import Hledger.Utils +import Hledger.Utils (colorB) +import Hledger.Utils.Text (textQuoteIfNeeded) +import Text.WideString (WideBuilder(..), textWidth, wbToText, wbUnpack) -deriving instance Show MarketPrice +-- A 'Commodity' is a symbol representing a currency or some other kind of +-- thing we are tracking, and some display preferences that tell how to +-- display 'Amount's of the commodity - is the symbol on the left or right, +-- are thousands separated by comma, significant decimal places and so on. +-- | Show space-containing commodity symbols quoted, as they are in a journal. +showCommoditySymbol :: T.Text -> T.Text +showCommoditySymbol = textQuoteIfNeeded + +-- characters that may not be used in a non-quoted commodity symbol +isNonsimpleCommodityChar :: Char -> Bool +isNonsimpleCommodityChar = liftA2 (||) isDigit isOther + where + otherChars = "-+.@*;\t\n \"{}=" :: T.Text + isOther c = T.any (==c) otherChars + +quoteCommoditySymbolIfNeeded :: T.Text -> T.Text +quoteCommoditySymbolIfNeeded s + | T.any isNonsimpleCommodityChar s = "\"" <> s <> "\"" + | otherwise = s + + -- | Options for the display of Amount and MixedAmount. data AmountDisplayOpts = AmountDisplayOpts { displayPrice :: Bool -- ^ Whether to display the Price of an Amount. @@ -174,6 +204,9 @@ , displayOneLine :: Bool -- ^ Whether to display on one line. , displayMinWidth :: Maybe Int -- ^ Minimum width to pad to , displayMaxWidth :: Maybe Int -- ^ Maximum width to clip to + -- | Display amounts in this order (without the commodity symbol) and display + -- a 0 in case a corresponding commodity does not exist + , displayOrder :: Maybe [CommoditySymbol] } deriving (Show) -- | Display Amount and MixedAmount with no colour. @@ -185,8 +218,9 @@ , displayColour = False , displayZeroCommodity = False , displayOneLine = False - , displayMinWidth = Nothing + , displayMinWidth = Just 0 , displayMaxWidth = Nothing + , displayOrder = Nothing } -- | Display Amount and MixedAmount with no prices. @@ -217,7 +251,7 @@ -- | The empty simple amount. amount, nullamt :: Amount -amount = Amount{acommodity="", aquantity=0, aprice=Nothing, astyle=amountstyle, aismultiplier=False} +amount = Amount{acommodity="", aquantity=0, aprice=Nothing, astyle=amountstyle} nullamt = amount -- | A temporary value for parsed transactions which had no amount specified. @@ -243,8 +277,8 @@ -- Prices are ignored and discarded. -- Remember: the caller is responsible for ensuring both amounts have the same commodity. similarAmountsOp :: (Quantity -> Quantity -> Quantity) -> Amount -> Amount -> Amount -similarAmountsOp op !Amount{acommodity=_, aquantity=q1, astyle=AmountStyle{asprecision=p1}} - !Amount{acommodity=c2, aquantity=q2, astyle=s2@AmountStyle{asprecision=p2}} = +similarAmountsOp op Amount{acommodity=_, aquantity=q1, astyle=AmountStyle{asprecision=p1}} + Amount{acommodity=c2, aquantity=q2, astyle=s2@AmountStyle{asprecision=p2}} = -- trace ("a1:"++showAmountDebug a1) $ trace ("a2:"++showAmountDebug a2) $ traceWith (("= :"++).showAmountDebug) amount{acommodity=c2, aquantity=q1 `op` q2, astyle=s2{asprecision=max p1 p2}} -- c1==c2 || q1==0 || q2==0 = @@ -393,12 +427,19 @@ -- | Given a map of standard commodity display styles, apply the -- appropriate one to this amount. If there's no standard style for -- this amount's commodity, return the amount unchanged. +-- Also apply the style to the price (except for precision) styleAmount :: M.Map CommoditySymbol AmountStyle -> Amount -> Amount -styleAmount styles a = - case M.lookup (acommodity a) styles of - Just s -> a{astyle=s} - Nothing -> a +styleAmount styles a = styledAmount{aprice = stylePrice styles (aprice styledAmount)} + where + styledAmount = case M.lookup (acommodity a) styles of + Just s -> a{astyle=s} + Nothing -> a +stylePrice :: M.Map CommoditySymbol AmountStyle -> Maybe AmountPrice -> Maybe AmountPrice +stylePrice styles (Just (UnitPrice a)) = Just (UnitPrice $ styleAmountExceptPrecision styles a) +stylePrice styles (Just (TotalPrice a)) = Just (TotalPrice $ styleAmountExceptPrecision styles a) +stylePrice _ _ = Nothing + -- | Like styleAmount, but keep the number of decimal places unchanged. styleAmountExceptPrecision :: M.Map CommoditySymbol AmountStyle -> Amount -> Amount styleAmountExceptPrecision styles a@Amount{astyle=AmountStyle{asprecision=origp}} = @@ -428,14 +469,15 @@ showAmountB _ Amount{acommodity="AUTO"} = mempty showAmountB opts a@Amount{astyle=style} = color $ case ascommodityside style of - L -> c' <> space <> quantity' <> price - R -> quantity' <> space <> c' <> price + L -> showC c' space <> quantity' <> price + R -> quantity' <> showC space 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 @@ -462,7 +504,9 @@ -- appropriate to the current debug level. 9 shows maximum detail. showAmountDebug :: Amount -> String showAmountDebug Amount{acommodity="AUTO"} = "(missing)" -showAmountDebug Amount{..} = printf "Amount {acommodity=%s, aquantity=%s, aprice=%s, astyle=%s}" (show acommodity) (show aquantity) (showAmountPriceDebug aprice) (show astyle) +showAmountDebug Amount{..} = + "Amount {acommodity=" ++ show acommodity ++ ", aquantity=" ++ show aquantity + ++ ", aprice=" ++ showAmountPriceDebug aprice ++ ", astyle=" ++ show astyle ++ "}" -- | Get a Text Builder for the string representation of the number part of of an amount, -- using the display settings from its commodity. Also returns the width of the @@ -521,9 +565,9 @@ fromInteger = mixedAmount . fromInteger negate = maNegate (+) = maPlus - (*) = error' "error, mixed amounts do not support multiplication" -- PARTIAL: - abs = error' "error, mixed amounts do not support abs" - signum = error' "error, mixed amounts do not support signum" + (*) = error "error, mixed amounts do not support multiplication" -- PARTIAL: + abs = error "error, mixed amounts do not support abs" + signum = error "error, mixed amounts do not support signum" -- | Calculate the key used to store an Amount within a MixedAmount. amountKey :: Amount -> MixedAmountKey @@ -540,6 +584,10 @@ missingmixedamt :: MixedAmount missingmixedamt = mixedAmount missingamt +-- | Whether a MixedAmount has a missing amount +isMissingMixedAmount :: MixedAmount -> Bool +isMissingMixedAmount (Mixed ma) = amountKey missingamt `M.member` ma + -- | Convert amounts in various commodities into a mixed amount. mixed :: Foldable t => t Amount -> MixedAmount mixed = maAddAmounts nullmixedamt @@ -592,7 +640,7 @@ -- Ie when normalised, are all individual commodity amounts negative ? isNegativeMixedAmount :: MixedAmount -> Maybe Bool isNegativeMixedAmount m = - case amounts $ normaliseMixedAmountSquashPricesForDisplay m of + case amounts $ mixedAmountStripPrices m of [] -> Just False [a] -> Just $ isNegativeAmount a as | all isNegativeAmount as -> Just True @@ -603,13 +651,13 @@ -- i.e. does it have zero quantity with no price, zero quantity with a total price (which is also zero), -- and zero quantity for each unit price? mixedAmountLooksZero :: MixedAmount -> Bool -mixedAmountLooksZero = all amountLooksZero . amounts . normaliseMixedAmount +mixedAmountLooksZero (Mixed ma) = all amountLooksZero ma -- | Is this mixed amount exactly zero, ignoring its display precision? -- i.e. does it have zero quantity with no price, zero quantity with a total price (which is also zero), -- and zero quantity for each unit price? mixedAmountIsZero :: MixedAmount -> Bool -mixedAmountIsZero = all amountIsZero . amounts . normaliseMixedAmount +mixedAmountIsZero (Mixed ma) = all amountIsZero ma -- | Is this mixed amount exactly zero, ignoring its display precision? -- @@ -637,13 +685,12 @@ -- amounts :: MixedAmount -> [Amount] amounts (Mixed ma) - | missingkey `M.member` ma = [missingamt] -- missingamt should always be alone, but detect it even if not - | M.null nonzeros = [newzero] - | otherwise = toList nonzeros + | isMissingMixedAmount (Mixed ma) = [missingamt] -- missingamt should always be alone, but detect it even if not + | M.null nonzeros = [newzero] + | otherwise = toList nonzeros where newzero = fromMaybe nullamt $ find (not . T.null . acommodity) zeros (zeros, nonzeros) = M.partition amountIsZero ma - missingkey = amountKey missingamt -- | Get a mixed amount's component amounts without normalising zero and missing -- amounts. This is used for JSON serialisation, so the order is important. In @@ -653,12 +700,11 @@ amountsRaw :: MixedAmount -> [Amount] amountsRaw (Mixed ma) = toList ma -normaliseMixedAmount :: MixedAmount -> MixedAmount -normaliseMixedAmount = id -- XXX Remove - --- | Strip prices from a MixedAmount. -normaliseMixedAmountSquashPricesForDisplay :: MixedAmount -> MixedAmount -normaliseMixedAmountSquashPricesForDisplay = mixedAmountStripPrices -- XXX Remove +-- | Get this mixed amount's commodities as a set. +-- Returns an empty set if there are no amounts. +maCommodities :: MixedAmount -> S.Set CommoditySymbol +maCommodities = S.fromList . fmap acommodity . amounts' + where amounts' ma@(Mixed m) = if M.null m then [] else amounts ma -- | Unify a MixedAmount to a single commodity value if possible. -- This consolidates amounts of the same commodity and discards zero @@ -718,7 +764,9 @@ -- | Convert all component amounts to cost/selling price where -- possible (see amountCost). mixedAmountCost :: MixedAmount -> MixedAmount -mixedAmountCost = mapMixedAmount amountCost +mixedAmountCost (Mixed ma) = + foldl' (\m a -> maAddAmount m (amountCost a)) (Mixed noPrices) withPrices + where (noPrices, withPrices) = M.partition (isNothing . aprice) ma -- -- | MixedAmount derived Eq instance in Types.hs doesn't know that we -- -- want $0 = EUR0 = 0. Yet we don't want to drag all this code over there. @@ -784,7 +832,7 @@ -- | Get an unambiguous string representation of a mixed amount for debugging. showMixedAmountDebug :: MixedAmount -> String showMixedAmountDebug m | m == missingmixedamt = "(missing)" - | otherwise = printf "Mixed [%s]" as + | otherwise = "Mixed [" ++ as ++ "]" where as = intercalate "\n " $ map showAmountDebug $ amounts m -- | General function to generate a WideBuilder for a MixedAmount, according to the @@ -816,13 +864,16 @@ showMixedAmountLinesB opts@AmountDisplayOpts{displayMaxWidth=mmax,displayMinWidth=mmin} ma = map (adBuilder . pad) elided where - astrs = amtDisplayList (wbWidth sep) (showAmountB opts) . amounts $ + astrs = amtDisplayList (wbWidth sep) (showAmountB opts) . orderedAmounts opts $ if displayPrice opts then ma else mixedAmountStripPrices ma sep = WideBuilder (TB.singleton '\n') 0 - width = maximum $ fromMaybe 0 mmin : map (wbWidth . adBuilder) elided + width = maximum $ map (wbWidth . adBuilder) elided - pad amt = amt{ adBuilder = WideBuilder (TB.fromText $ T.replicate w " ") w <> adBuilder amt } - where w = width - wbWidth (adBuilder amt) + pad amt + | Just mw <- mmin = + let w = (max width mw) - wbWidth (adBuilder amt) + in amt{ adBuilder = WideBuilder (TB.fromText $ T.replicate w " ") w <> adBuilder amt } + | otherwise = amt elided = maybe id elideTo mmax astrs elideTo m xs = maybeAppend elisionStr short @@ -839,7 +890,7 @@ . max width $ fromMaybe 0 mmin where width = maybe 0 adTotal $ lastMay elided - astrs = amtDisplayList (wbWidth sep) (showAmountB opts) . amounts $ + astrs = amtDisplayList (wbWidth sep) (showAmountB opts) . orderedAmounts opts $ if displayPrice opts then ma else mixedAmountStripPrices ma sep = WideBuilder (TB.fromString ", ") 2 n = length astrs @@ -862,6 +913,15 @@ -- Add the elision strings (if any) to each amount 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 + where + as = amounts ma + pad c = fromMaybe (amountWithCommodity c nullamt) . find ((==) c . acommodity) $ as + + data AmountDisplay = AmountDisplay { adBuilder :: !WideBuilder -- ^ String representation of the Amount , adTotal :: !Int -- ^ Cumulative length of MixedAmount this Amount is part of, @@ -900,7 +960,7 @@ -- | Compact labelled trace of a mixed amount, for debugging. ltraceamount :: String -> MixedAmount -> MixedAmount -ltraceamount s = traceWith (((s ++ ": ") ++).showMixedAmount) +ltraceamount s a = trace (s ++ ": " ++ showMixedAmount a) a -- | Set the display precision in the amount's commodities. mixedAmountSetPrecision :: AmountPrecision -> MixedAmount -> MixedAmount @@ -931,24 +991,24 @@ ------------------------------------------------------------------------------- -- tests -tests_Amount = tests "Amount" [ - tests "Amount" [ +tests_Amount = testGroup "Amount" [ + testGroup "Amount" [ - test "amountCost" $ do + testCase "amountCost" $ do amountCost (eur 1) @?= eur 1 amountCost (eur 2){aprice=Just $ UnitPrice $ usd 2} @?= usd 4 amountCost (eur 1){aprice=Just $ TotalPrice $ usd 2} @?= usd 2 amountCost (eur (-1)){aprice=Just $ TotalPrice $ usd (-2)} @?= usd (-2) - ,test "amountLooksZero" $ do + ,testCase "amountLooksZero" $ do assertBool "" $ amountLooksZero amount assertBool "" $ amountLooksZero $ usd 0 - ,test "negating amounts" $ do + ,testCase "negating amounts" $ do negate (usd 1) @?= (usd 1){aquantity= -1} let b = (usd 1){aprice=Just $ UnitPrice $ eur 2} in negate b @?= b{aquantity= -1} - ,test "adding amounts without prices" $ do + ,testCase "adding amounts without prices" $ do (usd 1.23 + usd (-1.23)) @?= usd 0 (usd 1.23 + usd (-1.23)) @?= usd 0 (usd (-1.23) + usd (-1.23)) @?= usd (-2.46) @@ -959,14 +1019,21 @@ -- adding different commodities assumes conversion rate 1 assertBool "" $ amountLooksZero (usd 1.23 - eur 1.23) - ,test "showAmount" $ do + ,testCase "showAmount" $ do showAmount (usd 0 + gbp 0) @?= "0" ] - ,tests "MixedAmount" [ + ,testGroup "MixedAmount" [ - test "adding mixed amounts to zero, the commodity and amount style are preserved" $ + testCase "comparing mixed amounts compares based on quantities" $ do + let usdpos = mixed [usd 1] + usdneg = mixed [usd (-1)] + eurneg = mixed [eur (-12)] + compare usdneg usdpos @?= LT + compare eurneg usdpos @?= LT + + ,testCase "adding mixed amounts to zero, the commodity and amount style are preserved" $ maSum (map mixedAmount [usd 1.25 ,usd (-1) `withPrecision` Precision 3 @@ -974,39 +1041,39 @@ ]) @?= mixedAmount (usd 0 `withPrecision` Precision 3) - ,test "adding mixed amounts with total prices" $ do + ,testCase "adding mixed amounts with total prices" $ do maSum (map mixedAmount [usd 1 @@ eur 1 ,usd (-2) @@ eur 1 ]) @?= mixedAmount (usd (-1) @@ eur 2) - ,test "showMixedAmount" $ do + ,testCase "showMixedAmount" $ do showMixedAmount (mixedAmount (usd 1)) @?= "$1.00" showMixedAmount (mixedAmount (usd 1 `at` eur 2)) @?= "$1.00 @ €2.00" showMixedAmount (mixedAmount (usd 0)) @?= "0" showMixedAmount nullmixedamt @?= "0" showMixedAmount missingmixedamt @?= "" - ,test "showMixedAmountWithoutPrice" $ do + ,testCase "showMixedAmountWithoutPrice" $ do let a = usd 1 `at` eur 2 showMixedAmountWithoutPrice False (mixedAmount (a)) @?= "$1.00" showMixedAmountWithoutPrice False (mixed [a, -a]) @?= "0" - ,tests "amounts" [ - test "a missing amount overrides any other amounts" $ + ,testGroup "amounts" [ + testCase "a missing amount overrides any other amounts" $ amounts (mixed [usd 1, missingamt]) @?= [missingamt] - ,test "unpriced same-commodity amounts are combined" $ + ,testCase "unpriced same-commodity amounts are combined" $ amounts (mixed [usd 0, usd 2]) @?= [usd 2] - ,test "amounts with same unit price are combined" $ + ,testCase "amounts with same unit price are combined" $ amounts (mixed [usd 1 `at` eur 1, usd 1 `at` eur 1]) @?= [usd 2 `at` eur 1] - ,test "amounts with different unit prices are not combined" $ + ,testCase "amounts with different unit prices are not combined" $ amounts (mixed [usd 1 `at` eur 1, usd 1 `at` eur 2]) @?= [usd 1 `at` eur 1, usd 1 `at` eur 2] - ,test "amounts with total prices are combined" $ + ,testCase "amounts with total prices are combined" $ amounts (mixed [usd 1 @@ eur 1, usd 1 @@ eur 1]) @?= [usd 2 @@ eur 2] ] - ,test "mixedAmountStripPrices" $ do + ,testCase "mixedAmountStripPrices" $ do amounts (mixedAmountStripPrices nullmixedamt) @?= [nullamt] assertBool "" $ mixedAmountLooksZero $ mixedAmountStripPrices (mixed [usd 10 diff --git a/Hledger/Data/Balancing.hs b/Hledger/Data/Balancing.hs new file mode 100644 --- /dev/null +++ b/Hledger/Data/Balancing.hs @@ -0,0 +1,986 @@ +{-| +Functions for ensuring transactions and journals are balanced. +-} + +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +module Hledger.Data.Balancing +( -- * BalancingOpts + BalancingOpts(..) +, HasBalancingOpts(..) +, defbalancingopts + -- * transaction balancing +, isTransactionBalanced +, balanceTransaction +, balanceTransactionHelper +, annotateErrorWithTransaction + -- * journal balancing +, journalBalanceTransactions +, journalCheckBalanceAssertions + -- * tests +, tests_Balancing +) +where + +import Control.Monad.Except (ExceptT(..), runExceptT, throwError) +import "extra" Control.Monad.Extra (whenM) +import Control.Monad.Reader as R +import Control.Monad.ST (ST, runST) +import Data.Array.ST (STArray, getElems, newListArray, writeArray) +import Data.Foldable (asum) +import Data.Function ((&)) +import qualified Data.HashTable.Class as H (toList) +import qualified Data.HashTable.ST.Cuckoo as H +import Data.List (intercalate, partition, sortOn) +import Data.List.Extra (nubSort) +import Data.Maybe (fromJust, fromMaybe, isJust, isNothing, mapMaybe) +import qualified Data.Set as S +import qualified Data.Text as T +import Data.Time.Calendar (fromGregorian) +import qualified Data.Map as M +import Safe (headDef) +import Text.Printf (printf) + +import Hledger.Utils +import Hledger.Data.Types +import Hledger.Data.AccountName (isAccountNamePrefixOf) +import Hledger.Data.Amount +import Hledger.Data.Dates (showDate) +import Hledger.Data.Journal +import Hledger.Data.Posting +import Hledger.Data.Transaction + + +data BalancingOpts = BalancingOpts + { ignore_assertions_ :: Bool -- ^ Ignore balance assertions + , infer_transaction_prices_ :: Bool -- ^ Infer prices in unbalanced multicommodity amounts + , commodity_styles_ :: Maybe (M.Map CommoditySymbol AmountStyle) -- ^ commodity display styles + } deriving (Show) + +defbalancingopts :: BalancingOpts +defbalancingopts = BalancingOpts + { ignore_assertions_ = False + , infer_transaction_prices_ = True + , commodity_styles_ = Nothing + } + +-- | Check that this transaction would appear balanced to a human when displayed. +-- On success, returns the empty list, otherwise one or more error messages. +-- +-- In more detail: +-- For the real postings, and separately for the balanced virtual postings: +-- +-- 1. Convert amounts to cost where possible +-- +-- 2. When there are two or more non-zero amounts +-- (appearing non-zero when displayed, using the given display styles if provided), +-- are they a mix of positives and negatives ? +-- This is checked separately to give a clearer error message. +-- (Best effort; could be confused by postings with multicommodity amounts.) +-- +-- 3. Does the amounts' sum appear non-zero when displayed ? +-- (using the given display styles if provided) +-- +transactionCheckBalanced :: BalancingOpts -> Transaction -> [String] +transactionCheckBalanced BalancingOpts{commodity_styles_} t = errs + where + (rps, bvps) = foldr partitionPosting ([], []) $ tpostings t + where + partitionPosting p ~(l, r) = case ptype p of + RegularPosting -> (p:l, r) + BalancedVirtualPosting -> (l, p:r) + VirtualPosting -> (l, r) + + -- check for mixed signs, detecting nonzeros at display precision + canonicalise = maybe id canonicaliseMixedAmount commodity_styles_ + signsOk ps = + case filter (not.mixedAmountLooksZero) $ map (canonicalise.mixedAmountCost.pamount) ps of + nonzeros | length nonzeros >= 2 + -> length (nubSort $ mapMaybe isNegativeMixedAmount nonzeros) > 1 + _ -> True + (rsignsok, bvsignsok) = (signsOk rps, signsOk bvps) + + -- check for zero sum, at display precision + (rsum, bvsum) = (sumPostings rps, sumPostings bvps) + (rsumcost, bvsumcost) = (mixedAmountCost rsum, mixedAmountCost bvsum) + (rsumdisplay, bvsumdisplay) = (canonicalise rsumcost, canonicalise bvsumcost) + (rsumok, bvsumok) = (mixedAmountLooksZero rsumdisplay, mixedAmountLooksZero bvsumdisplay) + + -- generate error messages, showing amounts with their original precision + errs = filter (not.null) [rmsg, bvmsg] + where + rmsg + | rsumok = "" + | not rsignsok = "real postings all have the same sign" + | otherwise = "real postings' sum should be 0 but is: " ++ showMixedAmount rsumcost + bvmsg + | bvsumok = "" + | not bvsignsok = "balanced virtual postings all have the same sign" + | otherwise = "balanced virtual postings' sum should be 0 but is: " ++ showMixedAmount bvsumcost + +-- | Legacy form of transactionCheckBalanced. +isTransactionBalanced :: BalancingOpts -> Transaction -> Bool +isTransactionBalanced bopts = null . transactionCheckBalanced bopts + +-- | Balance this transaction, ensuring that its postings +-- (and its balanced virtual postings) sum to 0, +-- by inferring a missing amount or conversion price(s) if needed. +-- Or if balancing is not possible, because the amounts don't sum to 0 or +-- because there's more than one missing amount, return an error message. +-- +-- Transactions with balance assignments can have more than one +-- missing amount; to balance those you should use the more powerful +-- journalBalanceTransactions. +-- +-- The "sum to 0" test is done using commodity display precisions, +-- if provided, so that the result agrees with the numbers users can see. +-- +balanceTransaction :: + BalancingOpts + -> Transaction + -> Either String Transaction +balanceTransaction bopts = fmap fst . balanceTransactionHelper bopts + +-- | Helper used by balanceTransaction and balanceTransactionWithBalanceAssignmentAndCheckAssertionsB; +-- use one of those instead. It also returns a list of accounts +-- and amounts that were inferred. +balanceTransactionHelper :: + BalancingOpts + -> Transaction + -> Either String (Transaction, [(AccountName, MixedAmount)]) +balanceTransactionHelper bopts t = do + (t', inferredamtsandaccts) <- inferBalancingAmount (fromMaybe M.empty $ commodity_styles_ bopts) $ + if infer_transaction_prices_ bopts then inferBalancingPrices t else t + case transactionCheckBalanced bopts t' of + [] -> Right (txnTieKnot t', inferredamtsandaccts) + errs -> Left $ transactionBalanceError t' errs + +-- | Generate a transaction balancing error message, given the transaction +-- and one or more suberror messages. +transactionBalanceError :: Transaction -> [String] -> String +transactionBalanceError t errs = + annotateErrorWithTransaction t $ + intercalate "\n" $ "could not balance this transaction:" : errs + +annotateErrorWithTransaction :: Transaction -> String -> String +annotateErrorWithTransaction t s = + unlines [ showSourcePosPair $ tsourcepos t, s + , T.unpack . T.stripEnd $ showTransaction t + ] + +-- | Infer up to one missing amount for this transactions's real postings, and +-- likewise for its balanced virtual postings, if needed; or return an error +-- message if we can't. Returns the updated transaction and any inferred posting amounts, +-- with the corresponding accounts, in order). +-- +-- We can infer a missing amount when there are multiple postings and exactly +-- one of them is amountless. If the amounts had price(s) the inferred amount +-- have the same price(s), and will be converted to the price commodity. +inferBalancingAmount :: + M.Map CommoditySymbol AmountStyle -- ^ commodity display styles + -> Transaction + -> Either String (Transaction, [(AccountName, MixedAmount)]) +inferBalancingAmount styles t@Transaction{tpostings=ps} + | length amountlessrealps > 1 + = Left $ transactionBalanceError t + ["can't have more than one real posting with no amount" + ,"(remember to put two or more spaces between account and amount)"] + | length amountlessbvps > 1 + = Left $ transactionBalanceError t + ["can't have more than one balanced virtual posting with no amount" + ,"(remember to put two or more spaces between account and amount)"] + | otherwise + = let psandinferredamts = map inferamount ps + inferredacctsandamts = [(paccount p, amt) | (p, Just amt) <- psandinferredamts] + in Right (t{tpostings=map fst psandinferredamts}, inferredacctsandamts) + where + (amountfulrealps, amountlessrealps) = partition hasAmount (realPostings t) + realsum = sumPostings amountfulrealps + (amountfulbvps, amountlessbvps) = partition hasAmount (balancedVirtualPostings t) + bvsum = sumPostings amountfulbvps + + inferamount :: Posting -> (Posting, Maybe MixedAmount) + inferamount p = + let + minferredamt = case ptype p of + RegularPosting | not (hasAmount p) -> Just realsum + BalancedVirtualPosting | not (hasAmount p) -> Just bvsum + _ -> Nothing + in + case minferredamt of + Nothing -> (p, Nothing) + Just a -> (p{pamount=a', poriginal=Just $ originalPosting p}, Just a') + where + -- Inferred amounts are converted to cost. + -- Also ensure the new amount has the standard style for its commodity + -- (since the main amount styling pass happened before this balancing pass); + a' = styleMixedAmount styles . mixedAmountCost $ maNegate a + +-- | Infer prices for this transaction's posting amounts, if needed to make +-- the postings balance, and if possible. This is done once for the real +-- postings and again (separately) for the balanced virtual postings. When +-- it's not possible, the transaction is left unchanged. +-- +-- The simplest example is a transaction with two postings, each in a +-- different commodity, with no prices specified. In this case we'll add a +-- price to the first posting such that it can be converted to the commodity +-- of the second posting (with -B), and such that the postings balance. +-- +-- In general, we can infer a conversion price when the sum of posting amounts +-- contains exactly two different commodities and no explicit prices. Also +-- all postings are expected to contain an explicit amount (no missing +-- amounts) in a single commodity. Otherwise no price inferring is attempted. +-- +-- The transaction itself could contain more than two commodities, and/or +-- prices, if they cancel out; what matters is that the sum of posting amounts +-- contains exactly two commodities and zero prices. +-- +-- There can also be more than two postings in either of the commodities. +-- +-- We want to avoid excessive display of digits when the calculated price is +-- an irrational number, while hopefully also ensuring the displayed numbers +-- make sense if the user does a manual calculation. This is (mostly) achieved +-- in two ways: +-- +-- - when there is only one posting in the "from" commodity, a total price +-- (@@) is used, and all available decimal digits are shown +-- +-- - otherwise, a suitable averaged unit price (@) is applied to the relevant +-- postings, with display precision equal to the summed display precisions +-- of the two commodities being converted between, or 2, whichever is larger. +-- +-- (We don't always calculate a good-looking display precision for unit prices +-- when the commodity display precisions are low, eg when a journal doesn't +-- use any decimal places. The minimum of 2 helps make the prices shown by the +-- print command a bit less surprising in this case. Could do better.) +-- +inferBalancingPrices :: Transaction -> Transaction +inferBalancingPrices t@Transaction{tpostings=ps} = t{tpostings=ps'} + where + ps' = map (priceInferrerFor t BalancedVirtualPosting . priceInferrerFor t RegularPosting) ps + +-- | Generate a posting update function which assigns a suitable balancing +-- price to the posting, if and as appropriate for the given transaction and +-- posting type (real or balanced virtual). If we cannot or should not infer +-- prices, just act as the identity on postings. +priceInferrerFor :: Transaction -> PostingType -> (Posting -> Posting) +priceInferrerFor t pt = maybe id inferprice inferFromAndTo + where + postings = filter ((==pt).ptype) $ tpostings t + pcommodities = map acommodity $ concatMap (amounts . pamount) postings + sumamounts = amounts $ sumPostings postings -- amounts normalises to one amount per commodity & price + + -- We can infer prices if there are no prices given, exactly two commodities in the normalised + -- sum of postings in this transaction, and these two have opposite signs. The amount we are + -- converting from is the first commodity to appear in the ordered list of postings, and the + -- commodity we are converting to is the other. If we cannot infer prices, return Nothing. + inferFromAndTo = case sumamounts of + [a,b] | noprices, oppositesigns -> asum $ map orderIfMatches pcommodities + where + noprices = all (isNothing . aprice) sumamounts + oppositesigns = signum (aquantity a) /= signum (aquantity b) + orderIfMatches x | x == acommodity a = Just (a,b) + | x == acommodity b = Just (b,a) + | otherwise = Nothing + _ -> Nothing + + -- For each posting, if the posting type matches, there is only a single amount in the posting, + -- and the commodity of the amount matches the amount we're converting from, + -- then set its price based on the ratio between fromamount and toamount. + inferprice (fromamount, toamount) posting + | [a] <- amounts (pamount posting), ptype posting == pt, acommodity a == acommodity fromamount + = posting{ pamount = mixedAmount a{aprice=Just conversionprice} + , poriginal = Just $ originalPosting posting } + | otherwise = posting + where + -- If only one Amount in the posting list matches fromamount we can use TotalPrice. + -- Otherwise divide the conversion equally among the Amounts by using a unit price. + conversionprice = case filter (== acommodity fromamount) pcommodities of + [_] -> TotalPrice $ negate toamount + _ -> UnitPrice $ negate unitprice `withPrecision` unitprecision + + unitprice = aquantity fromamount `divideAmount` toamount + unitprecision = case (asprecision $ astyle fromamount, asprecision $ astyle toamount) of + (Precision a, Precision b) -> Precision . max 2 $ saturatedAdd a b + _ -> NaturalPrecision + saturatedAdd a b = if maxBound - a < b then maxBound else a + b + + +-- | Check any balance assertions in the journal and return an error message +-- if any of them fail (or if the transaction balancing they require fails). +journalCheckBalanceAssertions :: Journal -> Maybe String +journalCheckBalanceAssertions = either Just (const Nothing) . journalBalanceTransactions defbalancingopts + +-- "Transaction balancing", including: inferring missing amounts, +-- applying balance assignments, checking transaction balancedness, +-- checking balance assertions, respecting posting dates. These things +-- are all interdependent. +-- WARN tricky algorithm and code ahead. +-- +-- Code overview as of 20190219, this could/should be simplified/documented more: +-- parseAndFinaliseJournal['] (Cli/Utils.hs), journalAddForecast (Common.hs), journalAddBudgetGoalTransactions (BudgetReport.hs), tests (BalanceReport.hs) +-- journalBalanceTransactions +-- runST +-- runExceptT +-- balanceTransaction (Transaction.hs) +-- balanceTransactionHelper +-- runReaderT +-- balanceTransactionAndCheckAssertionsB +-- addAmountAndCheckAssertionB +-- addOrAssignAmountAndCheckAssertionB +-- balanceTransactionHelper (Transaction.hs) +-- uiCheckBalanceAssertions d ui@UIState{aopts=UIOpts{cliopts_=copts}, ajournal=j} (ErrorScreen.hs) +-- journalCheckBalanceAssertions +-- journalBalanceTransactions +-- transactionWizard, postingsBalanced (Add.hs), tests (Transaction.hs) +-- balanceTransaction (Transaction.hs) XXX hledger add won't allow balance assignments + missing amount ? + +-- | Monad used for statefully balancing/amount-inferring/assertion-checking +-- a sequence of transactions. +-- Perhaps can be simplified, or would a different ordering of layers make sense ? +-- If you see a way, let us know. +type Balancing s = ReaderT (BalancingState s) (ExceptT String (ST s)) + +-- | The state used while balancing a sequence of transactions. +data BalancingState s = BalancingState { + -- read only + bsStyles :: Maybe (M.Map CommoditySymbol AmountStyle) -- ^ commodity display styles + ,bsUnassignable :: S.Set AccountName -- ^ accounts in which balance assignments may not be used + ,bsAssrt :: Bool -- ^ whether to check balance assertions + -- mutable + ,bsBalances :: H.HashTable s AccountName MixedAmount -- ^ running account balances, initially empty + ,bsTransactions :: STArray s Integer Transaction -- ^ a mutable array of the transactions being balanced + -- (for efficiency ? journalBalanceTransactions says: not strictly necessary but avoids a sort at the end I think) + } + +-- | Access the current balancing state, and possibly modify the mutable bits, +-- lifting through the Except and Reader layers into the Balancing monad. +withRunningBalance :: (BalancingState s -> ST s a) -> Balancing s a +withRunningBalance f = ask >>= lift . lift . f + +-- | Get this account's current exclusive running balance. +getRunningBalanceB :: AccountName -> Balancing s MixedAmount +getRunningBalanceB acc = withRunningBalance $ \BalancingState{bsBalances} -> do + fromMaybe nullmixedamt <$> H.lookup bsBalances acc + +-- | Add this amount to this account's exclusive running balance. +-- Returns the new running balance. +addToRunningBalanceB :: AccountName -> MixedAmount -> Balancing s MixedAmount +addToRunningBalanceB acc amt = withRunningBalance $ \BalancingState{bsBalances} -> do + old <- fromMaybe nullmixedamt <$> H.lookup bsBalances acc + let new = maPlus old amt + H.insert bsBalances acc new + return new + +-- | Set this account's exclusive running balance to this amount. +-- Returns the change in exclusive running balance. +setRunningBalanceB :: AccountName -> MixedAmount -> Balancing s MixedAmount +setRunningBalanceB acc amt = withRunningBalance $ \BalancingState{bsBalances} -> do + old <- fromMaybe nullmixedamt <$> H.lookup bsBalances acc + H.insert bsBalances acc amt + return $ maMinus amt old + +-- | Set this account's exclusive running balance to whatever amount +-- makes its *inclusive* running balance (the sum of exclusive running +-- balances of this account and any subaccounts) be the given amount. +-- Returns the change in exclusive running balance. +setInclusiveRunningBalanceB :: AccountName -> MixedAmount -> Balancing s MixedAmount +setInclusiveRunningBalanceB acc newibal = withRunningBalance $ \BalancingState{bsBalances} -> do + oldebal <- fromMaybe nullmixedamt <$> H.lookup bsBalances acc + allebals <- H.toList bsBalances + let subsibal = -- sum of any subaccounts' running balances + maSum . map snd $ filter ((acc `isAccountNamePrefixOf`).fst) allebals + let newebal = maMinus newibal subsibal + H.insert bsBalances acc newebal + return $ maMinus newebal oldebal + +-- | Update (overwrite) this transaction in the balancing state. +updateTransactionB :: Transaction -> Balancing s () +updateTransactionB t = withRunningBalance $ \BalancingState{bsTransactions} -> + void $ writeArray bsTransactions (tindex t) t + +-- | Infer any missing amounts (to satisfy balance assignments and +-- to balance transactions) and check that all transactions balance +-- and (optional) all balance assertions pass. Or return an error message +-- (just the first error encountered). +-- +-- Assumes journalInferCommodityStyles has been called, since those +-- affect transaction balancing. +-- +-- This does multiple things at once because amount inferring, balance +-- assignments, balance assertions and posting dates are interdependent. +journalBalanceTransactions :: BalancingOpts -> Journal -> Either String Journal +journalBalanceTransactions bopts' j' = + let + -- ensure transactions are numbered, so we can store them by number + j@Journal{jtxns=ts} = journalNumberTransactions j' + -- display precisions used in balanced checking + styles = Just $ journalCommodityStyles j + bopts = bopts'{commodity_styles_=styles} + -- balance assignments will not be allowed on these + txnmodifieraccts = S.fromList . map (paccount . tmprPosting) . concatMap tmpostingrules $ jtxnmodifiers j + in + runST $ do + -- We'll update a mutable array of transactions as we balance them, + -- not strictly necessary but avoids a sort at the end I think. + balancedtxns <- newListArray (1, toInteger $ length ts) ts + + -- Infer missing posting amounts, check transactions are balanced, + -- and check balance assertions. This is done in two passes: + runExceptT $ do + + -- 1. Step through the transactions, balancing the ones which don't have balance assignments + -- and leaving the others for later. The balanced ones are split into their postings. + -- The postings and not-yet-balanced transactions remain in the same relative order. + psandts :: [Either Posting Transaction] <- fmap concat $ forM ts $ \case + t | null $ assignmentPostings t -> case balanceTransaction bopts t of + Left e -> throwError e + Right t' -> do + lift $ writeArray balancedtxns (tindex t') t' + return $ map Left $ tpostings t' + t -> return [Right t] + + -- 2. Sort these items by date, preserving the order of same-day items, + -- and step through them while keeping running account balances, + runningbals <- lift $ H.newSized (length $ journalAccountNamesUsed j) + flip runReaderT (BalancingState styles txnmodifieraccts (not $ ignore_assertions_ bopts) runningbals balancedtxns) $ do + -- performing balance assignments in, and balancing, the remaining transactions, + -- and checking balance assertions as each posting is processed. + void $ mapM' balanceTransactionAndCheckAssertionsB $ sortOn (either postingDate tdate) psandts + + ts' <- lift $ getElems balancedtxns + return j{jtxns=ts'} + +-- | This function is called statefully on each of a date-ordered sequence of +-- 1. fully explicit postings from already-balanced transactions and +-- 2. not-yet-balanced transactions containing balance assignments. +-- It executes balance assignments and finishes balancing the transactions, +-- and checks balance assertions on each posting as it goes. +-- An error will be thrown if a transaction can't be balanced +-- or if an illegal balance assignment is found (cf checkIllegalBalanceAssignment). +-- Transaction prices are removed, which helps eg balance-assertions.test: 15. Mix different commodities and assignments. +-- This stores the balanced transactions in case 2 but not in case 1. +balanceTransactionAndCheckAssertionsB :: Either Posting Transaction -> Balancing s () +balanceTransactionAndCheckAssertionsB (Left p@Posting{}) = + -- update the account's running balance and check the balance assertion if any + void . addAmountAndCheckAssertionB $ postingStripPrices p +balanceTransactionAndCheckAssertionsB (Right t@Transaction{tpostings=ps}) = do + -- make sure we can handle the balance assignments + mapM_ checkIllegalBalanceAssignmentB ps + -- for each posting, infer its amount from the balance assignment if applicable, + -- update the account's running balance and check the balance assertion if any + ps' <- mapM (addOrAssignAmountAndCheckAssertionB . postingStripPrices) ps + -- infer any remaining missing amounts, and make sure the transaction is now fully balanced + styles <- R.reader bsStyles + case balanceTransactionHelper defbalancingopts{commodity_styles_=styles} t{tpostings=ps'} of + Left err -> throwError err + Right (t', inferredacctsandamts) -> do + -- for each amount just inferred, update the running balance + mapM_ (uncurry addToRunningBalanceB) inferredacctsandamts + -- and save the balanced transaction. + updateTransactionB t' + +-- | If this posting has an explicit amount, add it to the account's running balance. +-- If it has a missing amount and a balance assignment, infer the amount from, and +-- reset the running balance to, the assigned balance. +-- If it has a missing amount and no balance assignment, leave it for later. +-- Then test the balance assertion if any. +addOrAssignAmountAndCheckAssertionB :: Posting -> Balancing s Posting +addOrAssignAmountAndCheckAssertionB p@Posting{paccount=acc, pamount=amt, pbalanceassertion=mba} + -- an explicit posting amount + | hasAmount p = do + newbal <- addToRunningBalanceB acc amt + whenM (R.reader bsAssrt) $ checkBalanceAssertionB p newbal + return p + + -- no explicit posting amount, but there is a balance assignment + | Just BalanceAssertion{baamount,batotal,bainclusive} <- mba = do + newbal <- if batotal + -- a total balance assignment (==, all commodities) + then return $ mixedAmount baamount + -- a partial balance assignment (=, one commodity) + else do + 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} + whenM (R.reader bsAssrt) $ checkBalanceAssertionB p' newbal + return p' + + -- no explicit posting amount, no balance assignment + | otherwise = return p + +-- | Add the posting's amount to its account's running balance, and +-- optionally check the posting's balance assertion if any. +-- The posting is expected to have an explicit amount (otherwise this does nothing). +-- Adding and checking balance assertions are tightly paired because we +-- need to see the balance as it stands after each individual posting. +addAmountAndCheckAssertionB :: Posting -> Balancing s Posting +addAmountAndCheckAssertionB p | hasAmount p = do + newbal <- addToRunningBalanceB (paccount p) $ pamount p + whenM (R.reader bsAssrt) $ checkBalanceAssertionB p newbal + return p +addAmountAndCheckAssertionB p = return p + +-- | Check a posting's balance assertion against the given actual balance, and +-- return an error if the assertion is not satisfied. +-- If the assertion is partial, unasserted commodities in the actual balance +-- are ignored; if it is total, they will cause the assertion to fail. +checkBalanceAssertionB :: Posting -> MixedAmount -> Balancing s () +checkBalanceAssertionB p@Posting{pbalanceassertion=Just (BalanceAssertion{baamount,batotal})} actualbal = + forM_ (baamount : otheramts) $ \amt -> checkBalanceAssertionOneCommodityB p amt actualbal + where + assertedcomm = acommodity baamount + otheramts | batotal = map (\a -> a{aquantity=0}) . amountsRaw + $ filterMixedAmount ((/=assertedcomm).acommodity) actualbal + | otherwise = [] +checkBalanceAssertionB _ _ = return () + +-- | Does this (single commodity) expected balance match the amount of that +-- commodity in the given (multicommodity) actual balance ? If not, returns a +-- balance assertion failure message based on the provided posting. To match, +-- the amounts must be exactly equal (display precision is ignored here). +-- If the assertion is inclusive, the expected amount is compared with the account's +-- subaccount-inclusive balance; otherwise, with the subaccount-exclusive balance. +checkBalanceAssertionOneCommodityB :: Posting -> Amount -> MixedAmount -> Balancing s () +checkBalanceAssertionOneCommodityB p@Posting{paccount=assertedacct} assertedamt actualbal = do + let isinclusive = maybe False bainclusive $ pbalanceassertion p + actualbal' <- + if isinclusive + then + -- sum the running balances of this account and any of its subaccounts seen so far + withRunningBalance $ \BalancingState{bsBalances} -> + H.foldM + (\ibal (acc, amt) -> return $ + if assertedacct==acc || assertedacct `isAccountNamePrefixOf` acc then maPlus ibal amt else ibal) + nullmixedamt + bsBalances + else return actualbal + let + assertedcomm = acommodity assertedamt + actualbalincomm = headDef nullamt . amountsRaw . filterMixedAmountByCommodity assertedcomm $ actualbal' + pass = + aquantity + -- traceWith (("asserted:"++).showAmountDebug) + assertedamt == + aquantity + -- traceWith (("actual:"++).showAmountDebug) + actualbalincomm + + errmsg = printf (unlines + [ "balance assertion: %s", + "\nassertion details:", + "date: %s", + "account: %s%s", + "commodity: %s", + -- "display precision: %d", + "calculated: %s", -- (at display precision: %s)", + "asserted: %s", -- (at display precision: %s)", + "difference: %s" + ]) + (case ptransaction p of + Nothing -> "?" -- shouldn't happen + Just t -> printf "%s\ntransaction:\n%s" + (showSourcePos pos) + (textChomp $ showTransaction t) + :: String + where + pos = baposition $ fromJust $ pbalanceassertion p + ) + (showDate $ postingDate p) + (T.unpack $ paccount p) -- XXX pack + (if isinclusive then " (and subs)" else "" :: String) + assertedcomm + -- (asprecision $ astyle actualbalincommodity) -- should be the standard display precision I think + (show $ aquantity actualbalincomm) + -- (showAmount actualbalincommodity) + (show $ aquantity assertedamt) + -- (showAmount assertedamt) + (show $ aquantity assertedamt - aquantity actualbalincomm) + + unless pass $ throwError errmsg + +-- | Throw an error if this posting is trying to do an illegal balance assignment. +checkIllegalBalanceAssignmentB :: Posting -> Balancing s () +checkIllegalBalanceAssignmentB p = do + checkBalanceAssignmentPostingDateB p + checkBalanceAssignmentUnassignableAccountB p + +-- XXX these should show position. annotateErrorWithTransaction t ? + +-- | Throw an error if this posting is trying to do a balance assignment and +-- has a custom posting date (which makes amount inference too hard/impossible). +checkBalanceAssignmentPostingDateB :: Posting -> Balancing s () +checkBalanceAssignmentPostingDateB p = + when (hasBalanceAssignment p && isJust (pdate p)) $ + throwError . T.unpack $ T.unlines + ["postings which are balance assignments may not have a custom date." + ,"Please write the posting amount explicitly, or remove the posting date:" + ,"" + ,maybe (T.unlines $ showPostingLines p) showTransaction $ ptransaction p + ] + +-- | Throw an error if this posting is trying to do a balance assignment and +-- the account does not allow balance assignments (eg because it is referenced +-- by a transaction modifier, which might generate additional postings to it). +checkBalanceAssignmentUnassignableAccountB :: Posting -> Balancing s () +checkBalanceAssignmentUnassignableAccountB p = do + unassignable <- R.asks bsUnassignable + when (hasBalanceAssignment p && paccount p `S.member` unassignable) $ + throwError . T.unpack $ T.unlines + ["balance assignments cannot be used with accounts which are" + ,"posted to by transaction modifier rules (auto postings)." + ,"Please write the posting amount explicitly, or remove the rule." + ,"" + ,"account: " <> paccount p + ,"" + ,"transaction:" + ,"" + ,maybe (T.unlines $ showPostingLines p) showTransaction $ ptransaction p + ] + +-- lenses + +makeHledgerClassyLenses ''BalancingOpts + +-- tests + +tests_Balancing :: TestTree +tests_Balancing = + testGroup "Balancing" [ + + testCase "inferBalancingAmount" $ do + (fst <$> inferBalancingAmount M.empty nulltransaction) @?= Right nulltransaction + (fst <$> inferBalancingAmount M.empty nulltransaction{tpostings = ["a" `post` usd (-5), "b" `post` missingamt]}) @?= + Right nulltransaction{tpostings = ["a" `post` usd (-5), "b" `post` usd 5]} + (fst <$> inferBalancingAmount M.empty nulltransaction{tpostings = ["a" `post` usd (-5), "b" `post` (eur 3 @@ usd 4), "c" `post` missingamt]}) @?= + Right nulltransaction{tpostings = ["a" `post` usd (-5), "b" `post` (eur 3 @@ usd 4), "c" `post` usd 1]} + + , testGroup "balanceTransaction" [ + testCase "detect unbalanced entry, sign error" $ + assertLeft + (balanceTransaction defbalancingopts + (Transaction + 0 + "" + nullsourcepos + (fromGregorian 2007 01 28) + Nothing + Unmarked + "" + "test" + "" + [] + [posting {paccount = "a", pamount = mixedAmount (usd 1)}, posting {paccount = "b", pamount = mixedAmount (usd 1)}])) + ,testCase "detect unbalanced entry, multiple missing amounts" $ + assertLeft $ + balanceTransaction defbalancingopts + (Transaction + 0 + "" + nullsourcepos + (fromGregorian 2007 01 28) + Nothing + Unmarked + "" + "test" + "" + [] + [ posting {paccount = "a", pamount = missingmixedamt} + , posting {paccount = "b", pamount = missingmixedamt} + ]) + ,testCase "one missing amount is inferred" $ + (pamount . last . tpostings <$> + balanceTransaction defbalancingopts + (Transaction + 0 + "" + nullsourcepos + (fromGregorian 2007 01 28) + Nothing + Unmarked + "" + "" + "" + [] + [posting {paccount = "a", pamount = mixedAmount (usd 1)}, posting {paccount = "b", pamount = missingmixedamt}])) @?= + Right (mixedAmount $ usd (-1)) + ,testCase "conversion price is inferred" $ + (pamount . head . tpostings <$> + balanceTransaction defbalancingopts + (Transaction + 0 + "" + nullsourcepos + (fromGregorian 2007 01 28) + Nothing + Unmarked + "" + "" + "" + [] + [ posting {paccount = "a", pamount = mixedAmount (usd 1.35)} + , posting {paccount = "b", pamount = mixedAmount (eur (-1))} + ])) @?= + Right (mixedAmount $ usd 1.35 @@ eur 1) + ,testCase "balanceTransaction balances based on cost if there are unit prices" $ + assertRight $ + balanceTransaction defbalancingopts + (Transaction + 0 + "" + nullsourcepos + (fromGregorian 2011 01 01) + Nothing + Unmarked + "" + "" + "" + [] + [ posting {paccount = "a", pamount = mixedAmount $ usd 1 `at` eur 2} + , posting {paccount = "a", pamount = mixedAmount $ usd (-2) `at` eur 1} + ]) + ,testCase "balanceTransaction balances based on cost if there are total prices" $ + assertRight $ + balanceTransaction defbalancingopts + (Transaction + 0 + "" + nullsourcepos + (fromGregorian 2011 01 01) + Nothing + Unmarked + "" + "" + "" + [] + [ posting {paccount = "a", pamount = mixedAmount $ usd 1 @@ eur 1} + , posting {paccount = "a", pamount = mixedAmount $ usd (-2) @@ eur (-1)} + ]) + ] + , testGroup "isTransactionBalanced" [ + testCase "detect balanced" $ + assertBool "" $ + isTransactionBalanced defbalancingopts $ + Transaction + 0 + "" + nullsourcepos + (fromGregorian 2009 01 01) + Nothing + Unmarked + "" + "a" + "" + [] + [ posting {paccount = "b", pamount = mixedAmount (usd 1.00)} + , posting {paccount = "c", pamount = mixedAmount (usd (-1.00))} + ] + ,testCase "detect unbalanced" $ + assertBool "" $ + not $ + isTransactionBalanced defbalancingopts $ + Transaction + 0 + "" + nullsourcepos + (fromGregorian 2009 01 01) + Nothing + Unmarked + "" + "a" + "" + [] + [ posting {paccount = "b", pamount = mixedAmount (usd 1.00)} + , posting {paccount = "c", pamount = mixedAmount (usd (-1.01))} + ] + ,testCase "detect unbalanced, one posting" $ + assertBool "" $ + not $ + isTransactionBalanced defbalancingopts $ + Transaction + 0 + "" + nullsourcepos + (fromGregorian 2009 01 01) + Nothing + Unmarked + "" + "a" + "" + [] + [posting {paccount = "b", pamount = mixedAmount (usd 1.00)}] + ,testCase "one zero posting is considered balanced for now" $ + assertBool "" $ + isTransactionBalanced defbalancingopts $ + Transaction + 0 + "" + nullsourcepos + (fromGregorian 2009 01 01) + Nothing + Unmarked + "" + "a" + "" + [] + [posting {paccount = "b", pamount = mixedAmount (usd 0)}] + ,testCase "virtual postings don't need to balance" $ + assertBool "" $ + isTransactionBalanced defbalancingopts $ + Transaction + 0 + "" + nullsourcepos + (fromGregorian 2009 01 01) + Nothing + Unmarked + "" + "a" + "" + [] + [ posting {paccount = "b", pamount = mixedAmount (usd 1.00)} + , posting {paccount = "c", pamount = mixedAmount (usd (-1.00))} + , posting {paccount = "d", pamount = mixedAmount (usd 100), ptype = VirtualPosting} + ] + ,testCase "balanced virtual postings need to balance among themselves" $ + assertBool "" $ + not $ + isTransactionBalanced defbalancingopts $ + Transaction + 0 + "" + nullsourcepos + (fromGregorian 2009 01 01) + Nothing + Unmarked + "" + "a" + "" + [] + [ posting {paccount = "b", pamount = mixedAmount (usd 1.00)} + , posting {paccount = "c", pamount = mixedAmount (usd (-1.00))} + , posting {paccount = "d", pamount = mixedAmount (usd 100), ptype = BalancedVirtualPosting} + ] + ,testCase "balanced virtual postings need to balance among themselves (2)" $ + assertBool "" $ + isTransactionBalanced defbalancingopts $ + Transaction + 0 + "" + nullsourcepos + (fromGregorian 2009 01 01) + Nothing + Unmarked + "" + "a" + "" + [] + [ posting {paccount = "b", pamount = mixedAmount (usd 1.00)} + , posting {paccount = "c", pamount = mixedAmount (usd (-1.00))} + , posting {paccount = "d", pamount = mixedAmount (usd 100), ptype = BalancedVirtualPosting} + , posting {paccount = "3", pamount = mixedAmount (usd (-100)), ptype = BalancedVirtualPosting} + ] + ] + + ,testGroup "journalBalanceTransactions" [ + + testCase "missing-amounts" $ do + let ej = journalBalanceTransactions defbalancingopts $ samplejournalMaybeExplicit False + assertRight ej + journalPostings <$> ej @?= Right (journalPostings samplejournal) + + ,testCase "balance-assignment" $ do + let ej = journalBalanceTransactions defbalancingopts $ + --2019/01/01 + -- (a) = 1 + nulljournal{ jtxns = [ + transaction (fromGregorian 2019 01 01) [ vpost' "a" missingamt (balassert (num 1)) ] + ]} + assertRight ej + let Right j = ej + (jtxns j & head & tpostings & head & pamount & amountsRaw) @?= [num 1] + + ,testCase "same-day-1" $ do + assertRight $ journalBalanceTransactions defbalancingopts $ + --2019/01/01 + -- (a) = 1 + --2019/01/01 + -- (a) 1 = 2 + nulljournal{ jtxns = [ + transaction (fromGregorian 2019 01 01) [ vpost' "a" missingamt (balassert (num 1)) ] + ,transaction (fromGregorian 2019 01 01) [ vpost' "a" (num 1) (balassert (num 2)) ] + ]} + + ,testCase "same-day-2" $ do + assertRight $ journalBalanceTransactions defbalancingopts $ + --2019/01/01 + -- (a) 2 = 2 + --2019/01/01 + -- b 1 + -- a + --2019/01/01 + -- a 0 = 1 + nulljournal{ jtxns = [ + transaction (fromGregorian 2019 01 01) [ vpost' "a" (num 2) (balassert (num 2)) ] + ,transaction (fromGregorian 2019 01 01) [ + post' "b" (num 1) Nothing + ,post' "a" missingamt Nothing + ] + ,transaction (fromGregorian 2019 01 01) [ post' "a" (num 0) (balassert (num 1)) ] + ]} + + ,testCase "out-of-order" $ do + assertRight $ journalBalanceTransactions defbalancingopts $ + --2019/1/2 + -- (a) 1 = 2 + --2019/1/1 + -- (a) 1 = 1 + nulljournal{ jtxns = [ + transaction (fromGregorian 2019 01 02) [ vpost' "a" (num 1) (balassert (num 2)) ] + ,transaction (fromGregorian 2019 01 01) [ vpost' "a" (num 1) (balassert (num 1)) ] + ]} + + ] + + ,testGroup "commodityStylesFromAmounts" $ [ + + -- Journal similar to the one on #1091: + -- 2019/09/24 + -- (a) 1,000.00 + -- + -- 2019/09/26 + -- (a) 1000,000 + -- + testCase "1091a" $ do + commodityStylesFromAmounts [ + nullamt{aquantity=1000, astyle=AmountStyle L False (Precision 3) (Just ',') Nothing} + ,nullamt{aquantity=1000, astyle=AmountStyle L False (Precision 2) (Just '.') (Just (DigitGroups ',' [3]))} + ] + @?= + -- The commodity style should have period as decimal mark + -- and comma as digit group mark. + Right (M.fromList [ + ("", AmountStyle L False (Precision 3) (Just '.') (Just (DigitGroups ',' [3]))) + ]) + -- same journal, entries in reverse order + ,testCase "1091b" $ do + commodityStylesFromAmounts [ + nullamt{aquantity=1000, astyle=AmountStyle L False (Precision 2) (Just '.') (Just (DigitGroups ',' [3]))} + ,nullamt{aquantity=1000, astyle=AmountStyle L False (Precision 3) (Just ',') Nothing} + ] + @?= + -- The commodity style should have period as decimal mark + -- and comma as digit group mark. + Right (M.fromList [ + ("", AmountStyle L False (Precision 3) (Just '.') (Just (DigitGroups ',' [3]))) + ]) + + ] + + ] diff --git a/Hledger/Data/Commodity.hs b/Hledger/Data/Commodity.hs deleted file mode 100644 --- a/Hledger/Data/Commodity.hs +++ /dev/null @@ -1,80 +0,0 @@ -{-| - -A 'Commodity' is a symbol representing a currency or some other kind of -thing we are tracking, and some display preferences that tell how to -display 'Amount's of the commodity - is the symbol on the left or right, -are thousands separated by comma, significant decimal places and so on. - --} - -{-# LANGUAGE OverloadedStrings #-} - -module Hledger.Data.Commodity -where -import Control.Applicative (liftA2) -import Data.Char (isDigit) -import Data.List -import Data.Maybe (fromMaybe) -import qualified Data.Text as T --- import qualified Data.Map as M - -import Hledger.Data.Types -import Hledger.Utils - --- Show space-containing commodity symbols quoted, as they are in a journal. -showCommoditySymbol = textQuoteIfNeeded - --- characters that may not be used in a non-quoted commodity symbol -isNonsimpleCommodityChar :: Char -> Bool -isNonsimpleCommodityChar = liftA2 (||) isDigit isOther - where - otherChars = "-+.@*;\t\n \"{}=" :: T.Text - isOther c = T.any (==c) otherChars - -quoteCommoditySymbolIfNeeded :: T.Text -> T.Text -quoteCommoditySymbolIfNeeded s - | T.any isNonsimpleCommodityChar s = "\"" <> s <> "\"" - | otherwise = s - -commodity = "" - --- handy constructors for tests --- unknown = commodity --- usd = "$" --- eur = "€" --- gbp = "£" --- hour = "h" - --- Some sample commodity' names and symbols, for use in tests.. -commoditysymbols = - [("unknown","") - ,("usd","$") - ,("eur","€") - ,("gbp","£") - ,("hour","h") - ] - --- | Look up one of the sample commodities' symbol by name. -comm :: String -> CommoditySymbol -comm name = snd $ fromMaybe - (error' "commodity lookup failed") -- PARTIAL: - (find (\n -> fst n == name) commoditysymbols) - --- | Find the conversion rate between two commodities. Currently returns 1. -conversionRate :: CommoditySymbol -> CommoditySymbol -> Double -conversionRate _ _ = 1 - --- -- | Convert a list of commodities to a map from commodity symbols to --- -- unique, display-preference-canonicalised commodities. --- canonicaliseCommodities :: [CommoditySymbol] -> Map.Map String CommoditySymbol --- canonicaliseCommodities cs = --- Map.fromList [(s,firstc{precision=maxp}) | s <- symbols, --- let cs = commoditymap ! s, --- let firstc = head cs, --- let maxp = maximum $ map precision cs --- ] --- where --- commoditymap = Map.fromList [(s, commoditieswithsymbol s) | s <- symbols] --- commoditieswithsymbol s = filter ((s==) . symbol) cs --- symbols = nub $ map symbol cs - diff --git a/Hledger/Data/Dates.hs b/Hledger/Data/Dates.hs --- a/Hledger/Data/Dates.hs +++ b/Hledger/Data/Dates.hs @@ -66,6 +66,7 @@ latestSpanContaining, smartdate, splitSpan, + groupByDateSpan, fixSmartDate, fixSmartDateStr, fixSmartDateStrEither, @@ -73,6 +74,8 @@ yearp, daysInSpan, maybePeriod, + + tests_Dates ) where @@ -84,24 +87,28 @@ import Control.Monad (guard, unless) import "base-compat-batteries" Data.List.Compat import Data.Char (digitToInt, isDigit, ord) -import Data.Default +import Data.Default (def) import Data.Foldable (asum) import Data.Function (on) -import Data.Maybe +import Data.Functor (($>)) +import Data.Maybe (catMaybes, fromMaybe, isJust, mapMaybe) +import Data.Ord (comparing) import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as T import Data.Time.Format hiding (months) import Data.Time.Calendar -import Data.Time.Calendar.OrdinalDate -import Data.Time.Clock -import Data.Time.LocalTime + (Day, addDays, addGregorianYearsClip, addGregorianMonthsClip, diffDays, + fromGregorian, fromGregorianValid, toGregorian) +import Data.Time.Calendar.OrdinalDate (fromMondayStartWeek, mondayStartWeek) +import Data.Time.Clock (UTCTime, diffUTCTime) +import Data.Time.LocalTime (getZonedTime, localDay, zonedTimeToLocalTime) import Safe (headMay, lastMay, maximumMay, minimumMay) import Text.Megaparsec -import Text.Megaparsec.Char +import Text.Megaparsec.Char (char, char', digitChar, string, string') import Text.Megaparsec.Char.Lexer (decimal) -import Text.Megaparsec.Custom -import Text.Printf +import Text.Megaparsec.Custom (customErrorBundlePretty) +import Text.Printf (printf) import Hledger.Data.Types import Hledger.Data.Period @@ -160,7 +167,7 @@ -- | Get overall span enclosing multiple sequentially ordered spans. spansSpan :: [DateSpan] -> DateSpan -spansSpan spans = DateSpan (maybe Nothing spanStart $ headMay spans) (maybe Nothing spanEnd $ lastMay spans) +spansSpan spans = DateSpan (spanStart =<< headMay spans) (spanEnd =<< lastMay spans) -- | Split a DateSpan into consecutive whole spans of the specified interval -- which fully encompass the original span (and a little more when necessary). @@ -193,7 +200,7 @@ -- [DateSpan 2007-12-02..2008-01-01,DateSpan 2008-01-02..2008-02-01,DateSpan 2008-02-02..2008-03-01,DateSpan 2008-03-02..2008-04-01] -- >>> t (WeekdayOfMonth 2 4) 2011 01 01 2011 02 15 -- [DateSpan 2010-12-09..2011-01-12,DateSpan 2011-01-13..2011-02-09,DateSpan 2011-02-10..2011-03-09] --- >>> t (DayOfWeek 2) 2011 01 01 2011 01 15 +-- >>> t (DaysOfWeek [2]) 2011 01 01 2011 01 15 -- [DateSpan 2010-12-28..2011-01-03,DateSpan 2011-01-04..2011-01-10,DateSpan 2011-01-11..2011-01-17] -- >>> t (DayOfYear 11 29) 2011 10 01 2011 10 15 -- [DateSpan 2010-11-29..2011-11-28] @@ -211,7 +218,19 @@ splitSpan (Years n) s = splitspan startofyear (applyN n nextyear) s splitSpan (DayOfMonth n) s = splitspan (nthdayofmonthcontaining n) (nthdayofmonth n . nextmonth) s splitSpan (WeekdayOfMonth n wd) s = splitspan (nthweekdayofmonthcontaining n wd) (advancetonthweekday n wd . nextmonth) s -splitSpan (DayOfWeek n) s = splitspan (nthdayofweekcontaining n) (applyN (n-1) nextday . nextweek) s +splitSpan (DaysOfWeek []) s = [s] -- shouldn't happen in parser but for completeness +splitSpan (DaysOfWeek days@(n:_)) ds + | DateSpan Nothing (Just e) <- ds = split (DateSpan (Just $ start e) (Just $ nextday $ start e)) + | DateSpan (Just s) Nothing <- ds = split (DateSpan (Just $ start s) (Just $ nextday $ start s)) + | DateSpan (Just s) (Just e) <- ds = + if s == e then [ds] else split (DateSpan (Just $ start s) (Just e)) + where + start = nthdayofweekcontaining n + + wheel = (\x -> zipWith (-) (tail x) x) . concat . zipWith fmap (fmap (+) [0,7..]) . repeat $ days + + split = splitspan' (repeat startofday) (fmap (`applyN` nextday) wheel) + splitSpan (DayOfYear m n) s = splitspan (nthdayofyearcontaining m n) (applyN (n-1) nextday . applyN (m-1) nextmonth . nextyear) s -- splitSpan (WeekOfYear n) s = splitspan startofweek (applyN n nextweek) s -- splitSpan (MonthOfYear n) s = splitspan startofmonth (applyN n nextmonth) s @@ -226,15 +245,16 @@ splitspan start next (DateSpan (Just s) Nothing) = splitspan start next (DateSpan (Just $ start s) (Just $ next $ start s)) splitspan start next span@(DateSpan (Just s) (Just e)) | s == e = [span] - | otherwise = splitspan' start next span - where - splitspan' start next (DateSpan (Just s) (Just e)) - | s >= e = [] - | otherwise = DateSpan (Just subs) (Just sube) : splitspan' start next (DateSpan (Just sube) (Just e)) - where subs = start s - sube = next subs - splitspan' _ _ _ = error' "won't happen, avoids warnings" -- PARTIAL: + | otherwise = splitspan' (repeat start) (repeat next) span +splitspan' :: [Day -> Day] -> [Day -> Day] -> DateSpan -> [DateSpan] +splitspan' (start:ss) (next:ns) (DateSpan (Just s) (Just e)) + | s >= e = [] + | otherwise = DateSpan (Just subs) (Just sube) : splitspan' ss ns (DateSpan (Just sube) (Just e)) + where subs = start s + sube = next subs +splitspan' _ _ _ = error' "won't happen, avoids warnings" -- PARTIAL: + -- | Count the days in a DateSpan, or if it is open-ended return Nothing. daysInSpan :: DateSpan -> Maybe Integer daysInSpan (DateSpan (Just d1) (Just d2)) = Just $ diffDays d2 d1 @@ -257,6 +277,22 @@ periodContainsDate :: Period -> Day -> Bool periodContainsDate p = spanContainsDate (periodAsDateSpan p) +-- | Group elements based on where they fall in a list of 'DateSpan's without +-- gaps. The precondition is not checked. +groupByDateSpan :: Bool -> (a -> Day) -> [DateSpan] -> [a] -> [(DateSpan, [a])] +groupByDateSpan showempty date colspans = + groupByCols colspans + . dropWhile (beforeStart . fst) + . sortBy (comparing fst) + . map (\x -> (date x, x)) + where + groupByCols [] _ = [] + groupByCols (c:cs) [] = if showempty then (c, []) : groupByCols cs [] else [] + groupByCols (c:cs) ps = (c, map snd matches) : groupByCols cs later + where (matches, later) = span ((spanEnd c >) . Just . fst) ps + + beforeStart = maybe (const True) (>) $ spanStart =<< headMay colspans + -- | Calculate the intersection of a number of datespans. spansIntersect [] = nulldatespan spansIntersect [d] = d @@ -731,7 +767,7 @@ -- XXX maybe obscures date errors ? see ledgerdate [ yyyymmdd, ymd , (\(m,d) -> SmartFromReference (Just m) d) <$> md - , (SmartFromReference Nothing <$> decimal) >>= failIfInvalidDate + , failIfInvalidDate . SmartFromReference Nothing =<< decimal , SmartMonth <$> (month <|> mon) , SmartRelative This Day <$ string' "today" , SmartRelative Last Day <$ string' "yesterday" @@ -761,7 +797,7 @@ validDay n = n >= 1 && n <= 31 failIfInvalidDate :: Fail.MonadFail m => SmartDate -> m SmartDate -failIfInvalidDate s = unless isValid (Fail.fail $ "bad smart date: " ++ show s) *> return s +failIfInvalidDate s = unless isValid (Fail.fail $ "bad smart date: " ++ show s) $> s where isValid = case s of SmartAssumeStart y (Just (m, md)) -> isJust $ fromGregorianValid y m (fromMaybe 1 md) SmartFromReference mm d -> isJust $ fromGregorianValid 2004 (fromMaybe 1 mm) d @@ -824,6 +860,9 @@ [] -> Fail.fail $ "weekday: should not happen: attempted to find " <> show wday <> " in " <> show (weekdays ++ weekdayabbrevs) +weekdaysp :: TextParser m [Int] +weekdaysp = fmap head . group . sort <$> sepBy1 weekday (string' ",") + -- | Parse a period expression, specifying a date span and optionally -- a reporting interval. Requires a reference "today" date for -- resolving any relative start/end dates (only; it is not needed for @@ -867,9 +906,9 @@ -- >>> p "every 1st monday of month to 2009" -- Right (WeekdayOfMonth 1 1,DateSpan ..2008-12-31) -- >>> p "every tue" --- Right (DayOfWeek 2,DateSpan ..) +-- Right (DaysOfWeek [2],DateSpan ..) -- >>> p "every 2nd day of week" --- Right (DayOfWeek 2,DateSpan ..) +-- Right (DaysOfWeek [2],DateSpan ..) -- >>> p "every 2nd day of month" -- Right (DayOfMonth 2,DateSpan ..) -- >>> p "every 2nd day" @@ -898,7 +937,6 @@ reportingintervalp :: TextParser m Interval reportingintervalp = choice' [ tryinterval "day" "daily" Days - , tryinterval "week" "weekly" Weeks , tryinterval "month" "monthly" Months , tryinterval "quarter" "quarterly" Quarters , tryinterval "year" "yearly" Years @@ -906,13 +944,20 @@ , Weeks 2 <$ string' "fortnightly" , Months 2 <$ string' "bimonthly" , string' "every" *> skipNonNewlineSpaces *> choice' - [ DayOfWeek <$> (nth <* skipNonNewlineSpaces <* string' "day" <* of_ "week") + [ DaysOfWeek . pure <$> (nth <* skipNonNewlineSpaces <* string' "day" <* of_ "week") , DayOfMonth <$> (nth <* skipNonNewlineSpaces <* string' "day" <* optOf_ "month") , liftA2 WeekdayOfMonth nth $ skipNonNewlineSpaces *> weekday <* optOf_ "month" , uncurry DayOfYear <$> (md <* optOf_ "year") - , DayOfWeek <$> weekday + , DaysOfWeek <$> weekdaysp + , DaysOfWeek [1..5] <$ string' "weekday" + , DaysOfWeek [6..7] <$ string' "weekendday" , d_o_y <* optOf_ "year" ] + -- NB: the ordering is important here since the parse for `every weekday` + -- would match the `tryinterval` first and then error on `d`. Perhaps it + -- would be clearer to factor some of this into the `every` choice or other + -- left-factorings. + , tryinterval "week" "weekly" Weeks ] where of_ period = @@ -1009,3 +1054,45 @@ nulldate :: Day nulldate = fromGregorian 0 1 1 + + +-- tests + +tests_Dates = testGroup "Dates" + [ testCase "weekday" $ do + splitSpan (DaysOfWeek [1..5]) (DateSpan (Just $ fromGregorian 2021 07 01) (Just $ fromGregorian 2021 07 08)) + @?= [ (DateSpan (Just $ fromGregorian 2021 06 28) (Just $ fromGregorian 2021 06 29)) + , (DateSpan (Just $ fromGregorian 2021 06 29) (Just $ fromGregorian 2021 06 30)) + , (DateSpan (Just $ fromGregorian 2021 06 30) (Just $ fromGregorian 2021 07 01)) + , (DateSpan (Just $ fromGregorian 2021 07 01) (Just $ fromGregorian 2021 07 02)) + , (DateSpan (Just $ fromGregorian 2021 07 02) (Just $ fromGregorian 2021 07 05)) + -- next week + , (DateSpan (Just $ fromGregorian 2021 07 05) (Just $ fromGregorian 2021 07 06)) + , (DateSpan (Just $ fromGregorian 2021 07 06) (Just $ fromGregorian 2021 07 07)) + , (DateSpan (Just $ fromGregorian 2021 07 07) (Just $ fromGregorian 2021 07 08)) + ] + + splitSpan (DaysOfWeek [1, 5]) (DateSpan (Just $ fromGregorian 2021 07 01) (Just $ fromGregorian 2021 07 08)) + @?= [ (DateSpan (Just $ fromGregorian 2021 06 28) (Just $ fromGregorian 2021 07 02)) + , (DateSpan (Just $ fromGregorian 2021 07 02) (Just $ fromGregorian 2021 07 05)) + -- next week + , (DateSpan (Just $ fromGregorian 2021 07 05) (Just $ fromGregorian 2021 07 09)) + ] + + , testCase "match dayOfWeek" $ do + let dayofweek n s = splitspan (nthdayofweekcontaining n) (applyN (n-1) nextday . nextweek) s + match ds day = dayofweek day ds == splitSpan (DaysOfWeek [day]) ds @?= True + ys2021 = fromGregorian 2021 01 01 + ye2021 = fromGregorian 2021 12 31 + ys2022 = fromGregorian 2022 01 01 + mapM_ (match (DateSpan (Just ys2021) (Just ye2021))) [1..7] + mapM_ (match (DateSpan (Just ys2021) (Just ys2022))) [1..7] + mapM_ (match (DateSpan (Just ye2021) (Just ys2022))) [1..7] + + mapM_ (match (DateSpan (Just ye2021) Nothing)) [1..7] + mapM_ (match (DateSpan (Just ys2022) Nothing)) [1..7] + + mapM_ (match (DateSpan Nothing (Just ye2021))) [1..7] + mapM_ (match (DateSpan Nothing (Just ys2022))) [1..7] + + ] diff --git a/Hledger/Data/Journal.hs b/Hledger/Data/Journal.hs --- a/Hledger/Data/Journal.hs +++ b/Hledger/Data/Journal.hs @@ -1,7 +1,5 @@ -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PackageImports #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -15,11 +13,12 @@ module Hledger.Data.Journal ( -- * Parsing helpers + JournalParser, + ErroringJournalParser, addPriceDirective, addTransactionModifier, addPeriodicTransaction, addTransaction, - journalBalanceTransactions, journalInferMarketPricesFromTransactions, journalApplyCommodityStyles, commodityStylesFromAmounts, @@ -84,59 +83,59 @@ -- * Misc canonicalStyleFrom, nulljournal, - journalCheckBalanceAssertions, + journalNumberTransactions, journalNumberAndTieTransactions, journalUntieTransactions, journalModifyTransactions, journalApplyAliases, -- * Tests samplejournal, - tests_Journal, + samplejournalMaybeExplicit, + tests_Journal ) where import Control.Applicative ((<|>)) -import Control.Monad.Except (ExceptT(..), runExceptT, throwError) -import "extra" Control.Monad.Extra (whenM) -import Control.Monad.Reader as R -import Control.Monad.ST (ST, runST) -import Data.Array.ST (STArray, getElems, newListArray, writeArray) +import Control.Monad.Except (ExceptT(..)) +import Control.Monad.State.Strict (StateT) import Data.Char (toUpper, isDigit) import Data.Default (Default(..)) import Data.Foldable (toList) -import Data.Function ((&)) -import qualified Data.HashTable.Class as H (toList) -import qualified Data.HashTable.ST.Cuckoo as H -import Data.List ((\\), find, foldl', sortOn) +import Data.List ((\\), find, foldl', sortBy) import Data.List.Extra (nubSort) import qualified Data.Map.Strict as M -import Data.Maybe (catMaybes, fromJust, fromMaybe, isJust, mapMaybe, maybeToList) +import Data.Maybe (catMaybes, fromMaybe, mapMaybe, maybeToList) import qualified Data.Set as S import Data.Text (Text) import qualified Data.Text as T import Safe (headMay, headDef, maximumMay, minimumMay) import Data.Time.Calendar (Day, addDays, fromGregorian) +import Data.Time.Clock.POSIX (POSIXTime) import Data.Tree (Tree, flatten) -import System.Time (ClockTime(TOD)) import Text.Printf (printf) +import Text.Megaparsec (ParsecT) +import Text.Megaparsec.Custom (FinalParseError) import Hledger.Utils import Hledger.Data.Types import Hledger.Data.AccountName import Hledger.Data.Amount -import Hledger.Data.Dates import Hledger.Data.Transaction import Hledger.Data.TransactionModifier import Hledger.Data.Posting import Hledger.Query -import Data.List (sortBy) --- try to make Journal ppShow-compatible --- instance Show ClockTime where --- show t = "" --- deriving instance Show Journal +-- | A parser of text that runs in some monad, keeping a Journal as state. +type JournalParser m a = StateT Journal (ParsecT CustomErr Text m) a +-- | A parser of text that runs in some monad, keeping a Journal as +-- state, that can throw an exception to end parsing, preventing +-- further parser backtracking. +type ErroringJournalParser m a = + StateT Journal (ParsecT CustomErr Text (ExceptT FinalParseError m)) a + +-- deriving instance Show Journal instance Show Journal where show j | debugLevel < 3 = printf "Journal %s with %d transactions, %d accounts" @@ -234,7 +233,7 @@ ,jtxns = [] ,jfinalcommentlines = "" ,jfiles = [] - ,jlastreadtime = TOD 0 0 + ,jlastreadtime = 0 } journalFilePath :: Journal -> FilePath @@ -405,8 +404,7 @@ concat $ mapMaybe (`M.lookup` jdeclaredaccounttypes) atypes in case declaredacctsoftype of [] -> Acct fallbackregex - as -> And $ [ Or acctnameRegexes ] - ++ if null differentlyTypedRegexes then [] else [ Not $ Or differentlyTypedRegexes ] + as -> And $ Or acctnameRegexes : if null differentlyTypedRegexes then [] else [ Not $ Or differentlyTypedRegexes ] where -- XXX Query isn't able to match account type since that requires extra info from the journal. -- So we do a hacky search by name instead. @@ -415,7 +413,7 @@ differentlytypedsubs = concat [subs | (t,bs) <- M.toList jdeclaredaccounttypes - , not $ t `elem` atypes + , t `notElem` atypes , let subs = [b | b <- bs, any (`isAccountNamePrefixOf` b) as] ] @@ -435,8 +433,7 @@ -- or otherwise for accounts with names matched by the case-insensitive -- regular expression @^assets?(:|$)@. journalAssetNonCashAccountQuery :: Journal -> Query -journalAssetNonCashAccountQuery j = - journalAccountTypeQuery [Asset] (toRegexCI' "^assets?(:|$)") j +journalAssetNonCashAccountQuery = journalAccountTypeQuery [Asset] (toRegexCI' "^assets?(:|$)") -- | A query for Cash (liquid asset) accounts in this journal, ie accounts -- declared as Cash by account directives, or otherwise Asset accounts whose @@ -697,7 +694,7 @@ } -- | Set this journal's last read time, ie when its files were last read. -journalSetLastReadTime :: ClockTime -> Journal -> Journal +journalSetLastReadTime :: POSIXTime -> Journal -> Journal journalSetLastReadTime t j = j{ jlastreadtime = t } @@ -705,7 +702,7 @@ -- | Number (set the tindex field) this journal's transactions, counting upward from 1. journalNumberTransactions :: Journal -> Journal -journalNumberTransactions j@Journal{jtxns=ts} = j{jtxns=map (\(i,t) -> t{tindex=i}) $ zip [1..] ts} +journalNumberTransactions j@Journal{jtxns=ts} = j{jtxns=zipWith (\i t -> t{tindex=i}) [1..] ts} -- | Tie the knot in all of this journal's transactions, ensuring their postings -- refer to them. This should be done last, after any other transaction-modifying operations. @@ -723,342 +720,9 @@ -- relative dates in transaction modifier queries. journalModifyTransactions :: Day -> Journal -> Either String Journal journalModifyTransactions d j = - case modifyTransactions d (jtxnmodifiers j) (jtxns j) of - Right ts -> Right j{jtxns=ts} - Left err -> Left err - --- | Check any balance assertions in the journal and return an error message --- if any of them fail (or if the transaction balancing they require fails). -journalCheckBalanceAssertions :: Journal -> Maybe String -journalCheckBalanceAssertions = either Just (const Nothing) . journalBalanceTransactions def - --- "Transaction balancing", including: inferring missing amounts, --- applying balance assignments, checking transaction balancedness, --- checking balance assertions, respecting posting dates. These things --- are all interdependent. --- WARN tricky algorithm and code ahead. --- --- Code overview as of 20190219, this could/should be simplified/documented more: --- parseAndFinaliseJournal['] (Cli/Utils.hs), journalAddForecast (Common.hs), journalAddBudgetGoalTransactions (BudgetReport.hs), tests (BalanceReport.hs) --- journalBalanceTransactions --- runST --- runExceptT --- balanceTransaction (Transaction.hs) --- balanceTransactionHelper --- runReaderT --- balanceTransactionAndCheckAssertionsB --- addAmountAndCheckAssertionB --- addOrAssignAmountAndCheckAssertionB --- balanceTransactionHelper (Transaction.hs) --- uiCheckBalanceAssertions d ui@UIState{aopts=UIOpts{cliopts_=copts}, ajournal=j} (ErrorScreen.hs) --- journalCheckBalanceAssertions --- journalBalanceTransactions --- transactionWizard, postingsBalanced (Add.hs), tests (Transaction.hs) --- balanceTransaction (Transaction.hs) XXX hledger add won't allow balance assignments + missing amount ? - --- | Monad used for statefully balancing/amount-inferring/assertion-checking --- a sequence of transactions. --- Perhaps can be simplified, or would a different ordering of layers make sense ? --- If you see a way, let us know. -type Balancing s = ReaderT (BalancingState s) (ExceptT String (ST s)) - --- | The state used while balancing a sequence of transactions. -data BalancingState s = BalancingState { - -- read only - bsStyles :: Maybe (M.Map CommoditySymbol AmountStyle) -- ^ commodity display styles - ,bsUnassignable :: S.Set AccountName -- ^ accounts in which balance assignments may not be used - ,bsAssrt :: Bool -- ^ whether to check balance assertions - -- mutable - ,bsBalances :: H.HashTable s AccountName MixedAmount -- ^ running account balances, initially empty - ,bsTransactions :: STArray s Integer Transaction -- ^ a mutable array of the transactions being balanced - -- (for efficiency ? journalBalanceTransactions says: not strictly necessary but avoids a sort at the end I think) - } - --- | Access the current balancing state, and possibly modify the mutable bits, --- lifting through the Except and Reader layers into the Balancing monad. -withRunningBalance :: (BalancingState s -> ST s a) -> Balancing s a -withRunningBalance f = ask >>= lift . lift . f - --- | Get this account's current exclusive running balance. -getRunningBalanceB :: AccountName -> Balancing s MixedAmount -getRunningBalanceB acc = withRunningBalance $ \BalancingState{bsBalances} -> do - fromMaybe nullmixedamt <$> H.lookup bsBalances acc - --- | Add this amount to this account's exclusive running balance. --- Returns the new running balance. -addToRunningBalanceB :: AccountName -> MixedAmount -> Balancing s MixedAmount -addToRunningBalanceB acc amt = withRunningBalance $ \BalancingState{bsBalances} -> do - old <- fromMaybe nullmixedamt <$> H.lookup bsBalances acc - let new = maPlus old amt - H.insert bsBalances acc new - return new - --- | Set this account's exclusive running balance to this amount. --- Returns the change in exclusive running balance. -setRunningBalanceB :: AccountName -> MixedAmount -> Balancing s MixedAmount -setRunningBalanceB acc amt = withRunningBalance $ \BalancingState{bsBalances} -> do - old <- fromMaybe nullmixedamt <$> H.lookup bsBalances acc - H.insert bsBalances acc amt - return $ maMinus amt old - --- | Set this account's exclusive running balance to whatever amount --- makes its *inclusive* running balance (the sum of exclusive running --- balances of this account and any subaccounts) be the given amount. --- Returns the change in exclusive running balance. -setInclusiveRunningBalanceB :: AccountName -> MixedAmount -> Balancing s MixedAmount -setInclusiveRunningBalanceB acc newibal = withRunningBalance $ \BalancingState{bsBalances} -> do - oldebal <- fromMaybe nullmixedamt <$> H.lookup bsBalances acc - allebals <- H.toList bsBalances - let subsibal = -- sum of any subaccounts' running balances - maSum . map snd $ filter ((acc `isAccountNamePrefixOf`).fst) allebals - let newebal = maMinus newibal subsibal - H.insert bsBalances acc newebal - return $ maMinus newebal oldebal - --- | Update (overwrite) this transaction in the balancing state. -updateTransactionB :: Transaction -> Balancing s () -updateTransactionB t = withRunningBalance $ \BalancingState{bsTransactions} -> - void $ writeArray bsTransactions (tindex t) t - --- | Infer any missing amounts (to satisfy balance assignments and --- to balance transactions) and check that all transactions balance --- and (optional) all balance assertions pass. Or return an error message --- (just the first error encountered). --- --- Assumes journalInferCommodityStyles has been called, since those --- affect transaction balancing. --- --- This does multiple things at once because amount inferring, balance --- assignments, balance assertions and posting dates are interdependent. -journalBalanceTransactions :: BalancingOpts -> Journal -> Either String Journal -journalBalanceTransactions bopts' j' = - let - -- ensure transactions are numbered, so we can store them by number - j@Journal{jtxns=ts} = journalNumberTransactions j' - -- display precisions used in balanced checking - styles = Just $ journalCommodityStyles j - bopts = bopts'{commodity_styles_=styles} - -- balance assignments will not be allowed on these - txnmodifieraccts = S.fromList $ map paccount $ concatMap tmpostingrules $ jtxnmodifiers j - in - runST $ do - -- We'll update a mutable array of transactions as we balance them, - -- not strictly necessary but avoids a sort at the end I think. - balancedtxns <- newListArray (1, toInteger $ length ts) ts - - -- Infer missing posting amounts, check transactions are balanced, - -- and check balance assertions. This is done in two passes: - runExceptT $ do - - -- 1. Step through the transactions, balancing the ones which don't have balance assignments - -- and leaving the others for later. The balanced ones are split into their postings. - -- The postings and not-yet-balanced transactions remain in the same relative order. - psandts :: [Either Posting Transaction] <- fmap concat $ forM ts $ \case - t | null $ assignmentPostings t -> case balanceTransaction bopts t of - Left e -> throwError e - Right t' -> do - lift $ writeArray balancedtxns (tindex t') t' - return $ map Left $ tpostings t' - t -> return [Right t] - - -- 2. Sort these items by date, preserving the order of same-day items, - -- and step through them while keeping running account balances, - runningbals <- lift $ H.newSized (length $ journalAccountNamesUsed j) - flip runReaderT (BalancingState styles txnmodifieraccts (not $ ignore_assertions_ bopts) runningbals balancedtxns) $ do - -- performing balance assignments in, and balancing, the remaining transactions, - -- and checking balance assertions as each posting is processed. - void $ mapM' balanceTransactionAndCheckAssertionsB $ sortOn (either postingDate tdate) psandts - - ts' <- lift $ getElems balancedtxns - return j{jtxns=ts'} - --- | This function is called statefully on each of a date-ordered sequence of --- 1. fully explicit postings from already-balanced transactions and --- 2. not-yet-balanced transactions containing balance assignments. --- It executes balance assignments and finishes balancing the transactions, --- and checks balance assertions on each posting as it goes. --- An error will be thrown if a transaction can't be balanced --- or if an illegal balance assignment is found (cf checkIllegalBalanceAssignment). --- Transaction prices are removed, which helps eg balance-assertions.test: 15. Mix different commodities and assignments. --- This stores the balanced transactions in case 2 but not in case 1. -balanceTransactionAndCheckAssertionsB :: Either Posting Transaction -> Balancing s () -balanceTransactionAndCheckAssertionsB (Left p@Posting{}) = - -- update the account's running balance and check the balance assertion if any - void . addAmountAndCheckAssertionB $ postingStripPrices p -balanceTransactionAndCheckAssertionsB (Right t@Transaction{tpostings=ps}) = do - -- make sure we can handle the balance assignments - mapM_ checkIllegalBalanceAssignmentB ps - -- for each posting, infer its amount from the balance assignment if applicable, - -- update the account's running balance and check the balance assertion if any - ps' <- mapM (addOrAssignAmountAndCheckAssertionB . postingStripPrices) ps - -- infer any remaining missing amounts, and make sure the transaction is now fully balanced - styles <- R.reader bsStyles - case balanceTransactionHelper balancingOpts{commodity_styles_=styles} t{tpostings=ps'} of - Left err -> throwError err - Right (t', inferredacctsandamts) -> do - -- for each amount just inferred, update the running balance - mapM_ (uncurry addToRunningBalanceB) inferredacctsandamts - -- and save the balanced transaction. - updateTransactionB t' - --- | If this posting has an explicit amount, add it to the account's running balance. --- If it has a missing amount and a balance assignment, infer the amount from, and --- reset the running balance to, the assigned balance. --- If it has a missing amount and no balance assignment, leave it for later. --- Then test the balance assertion if any. -addOrAssignAmountAndCheckAssertionB :: Posting -> Balancing s Posting -addOrAssignAmountAndCheckAssertionB p@Posting{paccount=acc, pamount=amt, pbalanceassertion=mba} - -- an explicit posting amount - | hasAmount p = do - newbal <- addToRunningBalanceB acc amt - whenM (R.reader bsAssrt) $ checkBalanceAssertionB p newbal - return p - - -- no explicit posting amount, but there is a balance assignment - | Just BalanceAssertion{baamount,batotal,bainclusive} <- mba = do - newbal <- if batotal - -- a total balance assignment (==, all commodities) - then return $ mixedAmount baamount - -- a partial balance assignment (=, one commodity) - else do - 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} - whenM (R.reader bsAssrt) $ checkBalanceAssertionB p' newbal - return p' - - -- no explicit posting amount, no balance assignment - | otherwise = return p - --- | Add the posting's amount to its account's running balance, and --- optionally check the posting's balance assertion if any. --- The posting is expected to have an explicit amount (otherwise this does nothing). --- Adding and checking balance assertions are tightly paired because we --- need to see the balance as it stands after each individual posting. -addAmountAndCheckAssertionB :: Posting -> Balancing s Posting -addAmountAndCheckAssertionB p | hasAmount p = do - newbal <- addToRunningBalanceB (paccount p) $ pamount p - whenM (R.reader bsAssrt) $ checkBalanceAssertionB p newbal - return p -addAmountAndCheckAssertionB p = return p - --- | Check a posting's balance assertion against the given actual balance, and --- return an error if the assertion is not satisfied. --- If the assertion is partial, unasserted commodities in the actual balance --- are ignored; if it is total, they will cause the assertion to fail. -checkBalanceAssertionB :: Posting -> MixedAmount -> Balancing s () -checkBalanceAssertionB p@Posting{pbalanceassertion=Just (BalanceAssertion{baamount,batotal})} actualbal = - forM_ (baamount : otheramts) $ \amt -> checkBalanceAssertionOneCommodityB p amt actualbal - where - assertedcomm = acommodity baamount - otheramts | batotal = map (\a -> a{aquantity=0}) . amountsRaw - $ filterMixedAmount ((/=assertedcomm).acommodity) actualbal - | otherwise = [] -checkBalanceAssertionB _ _ = return () - --- | Does this (single commodity) expected balance match the amount of that --- commodity in the given (multicommodity) actual balance ? If not, returns a --- balance assertion failure message based on the provided posting. To match, --- the amounts must be exactly equal (display precision is ignored here). --- If the assertion is inclusive, the expected amount is compared with the account's --- subaccount-inclusive balance; otherwise, with the subaccount-exclusive balance. -checkBalanceAssertionOneCommodityB :: Posting -> Amount -> MixedAmount -> Balancing s () -checkBalanceAssertionOneCommodityB p@Posting{paccount=assertedacct} assertedamt actualbal = do - let isinclusive = maybe False bainclusive $ pbalanceassertion p - actualbal' <- - if isinclusive - then - -- sum the running balances of this account and any of its subaccounts seen so far - withRunningBalance $ \BalancingState{bsBalances} -> - H.foldM - (\ibal (acc, amt) -> return $ - if assertedacct==acc || assertedacct `isAccountNamePrefixOf` acc then maPlus ibal amt else ibal) - nullmixedamt - bsBalances - else return actualbal - let - assertedcomm = acommodity assertedamt - actualbalincomm = headDef nullamt . amountsRaw . filterMixedAmountByCommodity assertedcomm $ actualbal' - pass = - aquantity - -- traceWith (("asserted:"++).showAmountDebug) - assertedamt == - aquantity - -- traceWith (("actual:"++).showAmountDebug) - actualbalincomm - - errmsg = printf (unlines - [ "balance assertion: %s", - "\nassertion details:", - "date: %s", - "account: %s%s", - "commodity: %s", - -- "display precision: %d", - "calculated: %s", -- (at display precision: %s)", - "asserted: %s", -- (at display precision: %s)", - "difference: %s" - ]) - (case ptransaction p of - Nothing -> "?" -- shouldn't happen - Just t -> printf "%s\ntransaction:\n%s" - (showGenericSourcePos pos) - (textChomp $ showTransaction t) - :: String - where - pos = baposition $ fromJust $ pbalanceassertion p - ) - (showDate $ postingDate p) - (T.unpack $ paccount p) -- XXX pack - (if isinclusive then " (and subs)" else "" :: String) - assertedcomm - -- (asprecision $ astyle actualbalincommodity) -- should be the standard display precision I think - (show $ aquantity actualbalincomm) - -- (showAmount actualbalincommodity) - (show $ aquantity assertedamt) - -- (showAmount assertedamt) - (show $ aquantity assertedamt - aquantity actualbalincomm) - - when (not pass) $ throwError errmsg - --- | Throw an error if this posting is trying to do an illegal balance assignment. -checkIllegalBalanceAssignmentB :: Posting -> Balancing s () -checkIllegalBalanceAssignmentB p = do - checkBalanceAssignmentPostingDateB p - checkBalanceAssignmentUnassignableAccountB p - --- XXX these should show position. annotateErrorWithTransaction t ? - --- | Throw an error if this posting is trying to do a balance assignment and --- has a custom posting date (which makes amount inference too hard/impossible). -checkBalanceAssignmentPostingDateB :: Posting -> Balancing s () -checkBalanceAssignmentPostingDateB p = - when (hasBalanceAssignment p && isJust (pdate p)) $ - throwError . T.unpack $ T.unlines - ["postings which are balance assignments may not have a custom date." - ,"Please write the posting amount explicitly, or remove the posting date:" - ,"" - ,maybe (T.unlines $ showPostingLines p) showTransaction $ ptransaction p - ] - --- | Throw an error if this posting is trying to do a balance assignment and --- the account does not allow balance assignments (eg because it is referenced --- by a transaction modifier, which might generate additional postings to it). -checkBalanceAssignmentUnassignableAccountB :: Posting -> Balancing s () -checkBalanceAssignmentUnassignableAccountB p = do - unassignable <- R.asks bsUnassignable - when (hasBalanceAssignment p && paccount p `S.member` unassignable) $ - throwError . T.unpack $ T.unlines - ["balance assignments cannot be used with accounts which are" - ,"posted to by transaction modifier rules (auto postings)." - ,"Please write the posting amount explicitly, or remove the rule." - ,"" - ,"account: " <> paccount p - ,"" - ,"transaction:" - ,"" - ,maybe (T.unlines $ showPostingLines p) showTransaction $ ptransaction p - ] + case modifyTransactions (journalCommodityStyles j) d (jtxnmodifiers j) (jtxns j) of + Right ts -> Right j{jtxns=ts} + Left err -> Left err -- @@ -1066,20 +730,12 @@ -- amounts in each commodity (see journalCommodityStyles). -- Can return an error message eg if inconsistent number formats are found. journalApplyCommodityStyles :: Journal -> Either String Journal -journalApplyCommodityStyles j@Journal{jtxns=ts, jpricedirectives=pds} = - case journalInferCommodityStyles j of - Left e -> Left e - Right j' -> Right j'' +journalApplyCommodityStyles = fmap fixjournal . journalInferCommodityStyles + where + fixjournal j@Journal{jpricedirectives=pds} = + journalMapPostings (postingApplyCommodityStyles styles) j{jpricedirectives=map fixpricedirective pds} where - styles = journalCommodityStyles j' - j'' = j'{jtxns=map fixtransaction ts - ,jpricedirectives=map fixpricedirective pds - } - fixtransaction t@Transaction{tpostings=ps} = t{tpostings=map fixposting ps} - fixposting p = p{pamount=styleMixedAmount styles $ pamount p - ,pbalanceassertion=fixbalanceassertion <$> pbalanceassertion p} - -- balance assertion amounts are always displayed (by print) at full precision, per docs - fixbalanceassertion ba = ba{baamount=styleAmountExceptPrecision styles $ baamount ba} + styles = journalCommodityStyles j fixpricedirective pd@PriceDirective{pdamount=a} = pd{pdamount=styleAmountExceptPrecision styles a} -- | Get the canonical amount styles for this journal, whether (in order of precedence): @@ -1126,7 +782,7 @@ -- | Given a list of amount styles (assumed to be from parsed amounts -- in a single commodity), in parse order, choose a canonical style. canonicalStyleFrom :: [AmountStyle] -> AmountStyle -canonicalStyleFrom ss = foldl' canonicalStyle amountstyle ss +canonicalStyleFrom = foldl' canonicalStyle amountstyle -- TODO: should probably detect and report inconsistencies here. -- Though, we don't have the info for a good error message, so maybe elsewhere. @@ -1395,9 +1051,10 @@ -- tracePostingsCommodities ps = trace (show $ map ((map (precision . acommodity) . amounts) . pamount) ps) ps -- tests - --- A sample journal for testing, similar to examples/sample.journal: -- +-- A sample journal for testing, similar to examples/sample.journal. +-- Provide an option to either use explicit amounts or missing amounts, for testing purposes. +-- -- 2008/01/01 income -- assets:bank:checking $1 -- income:salary @@ -1422,9 +1079,11 @@ -- 2008/12/31 * pay off -- liabilities:debts $1 -- assets:bank:checking --- -Right samplejournal = journalBalanceTransactions def $ - nulljournal + +samplejournal = samplejournalMaybeExplicit True + +samplejournalMaybeExplicit :: Bool -> Journal +samplejournalMaybeExplicit explicit = nulljournal {jtxns = [ txnTieKnot $ Transaction { tindex=0, @@ -1438,7 +1097,7 @@ ttags=[], tpostings= ["assets:bank:checking" `post` usd 1 - ,"income:salary" `post` missingamt + ,"income:salary" `post` if explicit then usd (-1) else missingamt ], tprecedingcomment="" } @@ -1455,7 +1114,7 @@ ttags=[], tpostings= ["assets:bank:checking" `post` usd 1 - ,"income:gifts" `post` missingamt + ,"income:gifts" `post` if explicit then usd (-1) else missingamt ], tprecedingcomment="" } @@ -1472,7 +1131,7 @@ ttags=[], tpostings= ["assets:bank:saving" `post` usd 1 - ,"assets:bank:checking" `post` usd (-1) + ,"assets:bank:checking" `post` if explicit then usd (-1) else missingamt ], tprecedingcomment="" } @@ -1489,7 +1148,7 @@ ttags=[], tpostings=["expenses:food" `post` usd 1 ,"expenses:supplies" `post` usd 1 - ,"assets:cash" `post` missingamt + ,"assets:cash" `post` if explicit then usd (-2) else missingamt ], tprecedingcomment="" } @@ -1521,16 +1180,16 @@ tcomment="", ttags=[], tpostings=["liabilities:debts" `post` usd 1 - ,"assets:bank:checking" `post` usd (-1) + ,"assets:bank:checking" `post` if explicit then usd (-1) else missingamt ], tprecedingcomment="" } ] } -tests_Journal = tests "Journal" [ +tests_Journal = testGroup "Journal" [ - test "journalDateSpan" $ + testCase "journalDateSpan" $ journalDateSpan True nulljournal{ jtxns = [nulltransaction{tdate = fromGregorian 2014 02 01 ,tpostings = [posting{pdate=Just (fromGregorian 2014 01 10)}] @@ -1542,115 +1201,23 @@ } @?= (DateSpan (Just $ fromGregorian 2014 1 10) (Just $ fromGregorian 2014 10 11)) - ,tests "standard account type queries" $ + ,testGroup "standard account type queries" $ let j = samplejournal journalAccountNamesMatching :: Query -> Journal -> [AccountName] journalAccountNamesMatching q = filter (q `matchesAccount`) . journalAccountNames namesfrom qfunc = journalAccountNamesMatching (qfunc j) j - in [ - test "assets" $ assertEqual "" ["assets","assets:bank","assets:bank:checking","assets:bank:saving","assets:cash"] + in [testCase "assets" $ assertEqual "" ["assets","assets:bank","assets:bank:checking","assets:bank:saving","assets:cash"] (namesfrom journalAssetAccountQuery) - ,test "cash" $ assertEqual "" ["assets","assets:bank","assets:bank:checking","assets:bank:saving","assets:cash"] - (namesfrom journalCashAccountQuery) - ,test "liabilities" $ assertEqual "" ["liabilities","liabilities:debts"] - (namesfrom journalLiabilityAccountQuery) - ,test "equity" $ assertEqual "" [] - (namesfrom journalEquityAccountQuery) - ,test "income" $ assertEqual "" ["income","income:gifts","income:salary"] - (namesfrom journalRevenueAccountQuery) - ,test "expenses" $ assertEqual "" ["expenses","expenses:food","expenses:supplies"] - (namesfrom journalExpenseAccountQuery) - ] - - ,tests "journalBalanceTransactions" [ - - test "balance-assignment" $ do - let ej = journalBalanceTransactions def $ - --2019/01/01 - -- (a) = 1 - nulljournal{ jtxns = [ - transaction (fromGregorian 2019 01 01) [ vpost' "a" missingamt (balassert (num 1)) ] - ]} - assertRight ej - let Right j = ej - (jtxns j & head & tpostings & head & pamount & amountsRaw) @?= [num 1] - - ,test "same-day-1" $ do - assertRight $ journalBalanceTransactions def $ - --2019/01/01 - -- (a) = 1 - --2019/01/01 - -- (a) 1 = 2 - nulljournal{ jtxns = [ - transaction (fromGregorian 2019 01 01) [ vpost' "a" missingamt (balassert (num 1)) ] - ,transaction (fromGregorian 2019 01 01) [ vpost' "a" (num 1) (balassert (num 2)) ] - ]} - - ,test "same-day-2" $ do - assertRight $ journalBalanceTransactions def $ - --2019/01/01 - -- (a) 2 = 2 - --2019/01/01 - -- b 1 - -- a - --2019/01/01 - -- a 0 = 1 - nulljournal{ jtxns = [ - transaction (fromGregorian 2019 01 01) [ vpost' "a" (num 2) (balassert (num 2)) ] - ,transaction (fromGregorian 2019 01 01) [ - post' "b" (num 1) Nothing - ,post' "a" missingamt Nothing - ] - ,transaction (fromGregorian 2019 01 01) [ post' "a" (num 0) (balassert (num 1)) ] - ]} - - ,test "out-of-order" $ do - assertRight $ journalBalanceTransactions def $ - --2019/1/2 - -- (a) 1 = 2 - --2019/1/1 - -- (a) 1 = 1 - nulljournal{ jtxns = [ - transaction (fromGregorian 2019 01 02) [ vpost' "a" (num 1) (balassert (num 2)) ] - ,transaction (fromGregorian 2019 01 01) [ vpost' "a" (num 1) (balassert (num 1)) ] - ]} - - ] - - ,tests "commodityStylesFromAmounts" $ [ - - -- Journal similar to the one on #1091: - -- 2019/09/24 - -- (a) 1,000.00 - -- - -- 2019/09/26 - -- (a) 1000,000 - -- - test "1091a" $ do - commodityStylesFromAmounts [ - nullamt{aquantity=1000, astyle=AmountStyle L False (Precision 3) (Just ',') Nothing} - ,nullamt{aquantity=1000, astyle=AmountStyle L False (Precision 2) (Just '.') (Just (DigitGroups ',' [3]))} - ] - @?= - -- The commodity style should have period as decimal mark - -- and comma as digit group mark. - Right (M.fromList [ - ("", AmountStyle L False (Precision 3) (Just '.') (Just (DigitGroups ',' [3]))) - ]) - -- same journal, entries in reverse order - ,test "1091b" $ do - commodityStylesFromAmounts [ - nullamt{aquantity=1000, astyle=AmountStyle L False (Precision 2) (Just '.') (Just (DigitGroups ',' [3]))} - ,nullamt{aquantity=1000, astyle=AmountStyle L False (Precision 3) (Just ',') Nothing} - ] - @?= - -- The commodity style should have period as decimal mark - -- and comma as digit group mark. - Right (M.fromList [ - ("", AmountStyle L False (Precision 3) (Just '.') (Just (DigitGroups ',' [3]))) - ]) - - ] - + ,testCase "cash" $ assertEqual "" ["assets","assets:bank","assets:bank:checking","assets:bank:saving","assets:cash"] + (namesfrom journalCashAccountQuery) + ,testCase "liabilities" $ assertEqual "" ["liabilities","liabilities:debts"] + (namesfrom journalLiabilityAccountQuery) + ,testCase "equity" $ assertEqual "" [] + (namesfrom journalEquityAccountQuery) + ,testCase "income" $ assertEqual "" ["income","income:gifts","income:salary"] + (namesfrom journalRevenueAccountQuery) + ,testCase "expenses" $ assertEqual "" ["expenses","expenses:food","expenses:supplies"] + (namesfrom journalExpenseAccountQuery) + ] ] diff --git a/Hledger/Data/Json.hs b/Hledger/Data/Json.hs --- a/Hledger/Data/Json.hs +++ b/Hledger/Data/Json.hs @@ -2,28 +2,10 @@ JSON instances. Should they be in Types.hs ? -} -{-# OPTIONS_GHC -fno-warn-orphans #-} - ---{-# LANGUAGE DataKinds #-} ---{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} ---{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} ---{-# LANGUAGE NamedFieldPuns #-} ---{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} ---{-# LANGUAGE PolyKinds #-} ---{-# LANGUAGE QuasiQuotes #-} ---{-# LANGUAGE QuasiQuotes #-} ---{-# LANGUAGE Rank2Types #-} ---{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} ---{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} ---{-# LANGUAGE TemplateHaskell #-} ---{-# LANGUAGE TypeFamilies #-} ---{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE RecordWildCards #-} module Hledger.Data.Json ( -- * Instances @@ -34,16 +16,15 @@ ) where import Data.Aeson -import Data.Aeson.Encode.Pretty (encodePrettyToTextBuilder) +import Data.Aeson.Encode.Pretty (Config(..), Indent(..), NumberFormat(..), + encodePretty', encodePrettyToTextBuilder') --import Data.Aeson.TH import qualified Data.ByteString.Lazy as BL import Data.Decimal (DecimalRaw(..), roundTo) import Data.Maybe (fromMaybe) import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.IO as TL import qualified Data.Text.Lazy.Builder as TB -import GHC.Generics (Generic) -import System.Time (ClockTime) +import Text.Megaparsec (Pos, SourcePos, mkPos, unPos) import Hledger.Data.Types import Hledger.Data.Amount (amountsRaw, mixed) @@ -51,8 +32,13 @@ -- To JSON instance ToJSON Status -instance ToJSON GenericSourcePos +instance ToJSON SourcePos +-- Use the same encoding as the underlying Int +instance ToJSON Pos where + toJSON = toJSON . unPos + toEncoding = toEncoding . unPos + -- https://github.com/simonmichael/hledger/issues/1195 -- The default JSON output for Decimal can contain 255-digit integers @@ -136,10 +122,12 @@ instance ToJSON Transaction instance ToJSON TransactionModifier +instance ToJSON TMPostingRule instance ToJSON PeriodicTransaction instance ToJSON PriceDirective instance ToJSON DateSpan instance ToJSON Interval +instance ToJSON Period instance ToJSON AccountAlias instance ToJSON AccountType instance ToJSONKey AccountType @@ -148,7 +136,6 @@ instance ToJSON Commodity instance ToJSON TimeclockCode instance ToJSON TimeclockEntry -instance ToJSON ClockTime instance ToJSON Journal instance ToJSON Account where @@ -173,13 +160,16 @@ , "asubs" .= ([]::[Account]) ] -deriving instance Generic (Ledger) instance ToJSON Ledger -- From JSON instance FromJSON Status -instance FromJSON GenericSourcePos +instance FromJSON SourcePos +-- Use the same encoding as the underlying Int +instance FromJSON Pos where + parseJSON = fmap mkPos . parseJSON + instance FromJSON Amount instance FromJSON AmountStyle @@ -217,9 +207,6 @@ -- $(deriveFromJSON defaultOptions ''DecimalRaw) -- works; requires TH, but gives better parse error messages -- -- https://github.com/PaulJohnson/Haskell-Decimal/issues/6 ---deriving instance Generic Decimal ---instance FromJSON Decimal -deriving instance Generic (DecimalRaw a) instance FromJSON (DecimalRaw Integer) -- -- @simonmichael, I think the code in your first comment should work if it compiles—though “work” doesn’t mean you can parse a JSON number directly into a `Decimal` using the generic instance, as you’ve discovered. @@ -249,6 +236,7 @@ -- instance FromJSON Commodity -- instance FromJSON DateSpan -- instance FromJSON Interval +-- instance FromJSON Period -- instance FromJSON PeriodicTransaction -- instance FromJSON PriceDirective -- instance FromJSON TimeclockCode @@ -259,15 +247,18 @@ -- Utilities +-- | Config for pretty printing JSON output. +jsonConf :: Config +jsonConf = Config{confIndent=Spaces 2, confCompare=compare, confNumFormat=Generic, confTrailingNewline=True} + -- | Show a JSON-convertible haskell value as pretty-printed JSON text. toJsonText :: ToJSON a => a -> TL.Text -toJsonText = TB.toLazyText . (<> TB.fromText "\n") . encodePrettyToTextBuilder +toJsonText = TB.toLazyText . encodePrettyToTextBuilder' jsonConf -- | Write a JSON-convertible haskell value to a pretty-printed JSON file. -- Eg: writeJsonFile "a.json" nulltransaction writeJsonFile :: ToJSON a => FilePath -> a -> IO () -writeJsonFile f = TL.writeFile f . toJsonText --- we write with Text and read with ByteString, is that fine ? +writeJsonFile f = BL.writeFile f . encodePretty' jsonConf -- | Read a JSON file and decode it to the target type, or raise an error if we can't. -- Eg: readJsonFile "a.json" :: IO Transaction @@ -280,4 +271,3 @@ case fromJSON v :: FromJSON a => Result a of Error e -> error e Success t -> return t - diff --git a/Hledger/Data/Ledger.hs b/Hledger/Data/Ledger.hs --- a/Hledger/Data/Ledger.hs +++ b/Hledger/Data/Ledger.hs @@ -28,7 +28,8 @@ import Safe (headDef) import Text.Printf -import Hledger.Utils.Test +import Test.Tasty (testGroup) +import Test.Tasty.HUnit ((@?=), testCase) import Hledger.Data.Types import Hledger.Data.Account import Hledger.Data.Journal @@ -101,8 +102,8 @@ -- tests tests_Ledger = - tests "Ledger" [ - test "ledgerFromJournal" $ do + testGroup "Ledger" [ + testCase "ledgerFromJournal" $ do length (ledgerPostings $ ledgerFromJournal Any nulljournal) @?= 0 length (ledgerPostings $ ledgerFromJournal Any samplejournal) @?= 13 length (ledgerPostings $ ledgerFromJournal (Depth 2) samplejournal) @?= 7 diff --git a/Hledger/Data/Period.hs b/Hledger/Data/Period.hs --- a/Hledger/Data/Period.hs +++ b/Hledger/Data/Period.hs @@ -13,6 +13,7 @@ ,simplifyPeriod ,isLastDayOfMonth ,isStandardPeriod + ,periodTextWidth ,showPeriod ,showPeriodMonthAbbrev ,periodStart @@ -154,6 +155,20 @@ isStandardPeriod' (QuarterPeriod _ _) = True isStandardPeriod' (YearPeriod _) = True isStandardPeriod' _ = False + +-- | The width of a period of this type when displayed. +periodTextWidth :: Period -> Int +periodTextWidth = periodTextWidth' . simplifyPeriod + where + periodTextWidth' DayPeriod{} = 10 -- 2021-01-01 + periodTextWidth' WeekPeriod{} = 13 -- 2021-01-01W52 + periodTextWidth' MonthPeriod{} = 7 -- 2021-01 + periodTextWidth' QuarterPeriod{} = 6 -- 2021Q1 + periodTextWidth' YearPeriod{} = 4 -- 2021 + periodTextWidth' PeriodBetween{} = 22 -- 2021-01-01..2021-01-07 + periodTextWidth' PeriodFrom{} = 12 -- 2021-01-01.. + periodTextWidth' PeriodTo{} = 12 -- ..2021-01-01 + periodTextWidth' PeriodAll = 2 -- .. -- | Render a period as a compact display string suitable for user output. -- diff --git a/Hledger/Data/PeriodicTransaction.hs b/Hledger/Data/PeriodicTransaction.hs --- a/Hledger/Data/PeriodicTransaction.hs +++ b/Hledger/Data/PeriodicTransaction.hs @@ -20,8 +20,7 @@ import Hledger.Data.Amount import Hledger.Data.Posting (post, commentAddTagNextLine) import Hledger.Data.Transaction -import Hledger.Utils.UTF8IOCompat (error') -import Hledger.Utils.Debug +import Hledger.Utils -- $setup -- >>> :set -XOverloadedStrings diff --git a/Hledger/Data/Posting.hs b/Hledger/Data/Posting.hs --- a/Hledger/Data/Posting.hs +++ b/Hledger/Data/Posting.hs @@ -72,11 +72,11 @@ import Control.Monad (foldM) import Data.Foldable (asum) -import Data.List.Extra (nubSort) import qualified Data.Map as M import Data.Maybe (fromMaybe, isJust) import Data.MemoUgly (memo) import Data.List (foldl') +import qualified Data.Set as S import Data.Text (Text) import qualified Data.Text as T import Data.Time.Calendar (Day) @@ -125,15 +125,15 @@ vpost' :: AccountName -> Amount -> Maybe BalanceAssertion -> Posting vpost' acc amt ass = (post' acc amt ass){ptype=VirtualPosting, pbalanceassertion=ass} -nullsourcepos :: GenericSourcePos -nullsourcepos = JournalSourcePos "" (1,1) +nullsourcepos :: (SourcePos, SourcePos) +nullsourcepos = (SourcePos "" (mkPos 1) (mkPos 1), SourcePos "" (mkPos 2) (mkPos 1)) nullassertion :: BalanceAssertion nullassertion = BalanceAssertion {baamount=nullamt ,batotal=False ,bainclusive=False - ,baposition=nullsourcepos + ,baposition=initialPos "" } -- | Make a partial, exclusive balance assertion. @@ -184,14 +184,14 @@ isBalancedVirtual p = ptype p == BalancedVirtualPosting hasAmount :: Posting -> Bool -hasAmount = (/= missingmixedamt) . pamount +hasAmount = not . isMissingMixedAmount . pamount hasBalanceAssignment :: Posting -> Bool hasBalanceAssignment p = not (hasAmount p) && isJust (pbalanceassertion p) -- | Sorted unique account names referenced by these postings. accountNamesFromPostings :: [Posting] -> [AccountName] -accountNamesFromPostings = nubSort . map paccount +accountNamesFromPostings = S.toList . S.fromList . map paccount -- | Sum all amounts from a list of postings. sumPostings :: [Posting] -> MixedAmount @@ -226,10 +226,9 @@ -- the ambiguity, unmarked can mean "posting and transaction are both -- unmarked" or "posting is unmarked and don't know about the transaction". postingStatus :: Posting -> Status -postingStatus Posting{pstatus=s, ptransaction=mt} - | s == Unmarked = case mt of Just t -> tstatus t - Nothing -> Unmarked - | otherwise = s +postingStatus Posting{pstatus=s, ptransaction=mt} = case s of + Unmarked -> maybe Unmarked tstatus mt + _ -> s -- | Tags for this posting including any inherited from its parent transaction. postingAllTags :: Posting -> [Tag] @@ -379,34 +378,34 @@ -- tests -tests_Posting = tests "Posting" [ +tests_Posting = testGroup "Posting" [ - test "accountNamePostingType" $ do + testCase "accountNamePostingType" $ do accountNamePostingType "a" @?= RegularPosting accountNamePostingType "(a)" @?= VirtualPosting accountNamePostingType "[a]" @?= BalancedVirtualPosting - ,test "accountNameWithoutPostingType" $ do + ,testCase "accountNameWithoutPostingType" $ do accountNameWithoutPostingType "(a)" @?= "a" - ,test "accountNameWithPostingType" $ do + ,testCase "accountNameWithPostingType" $ do accountNameWithPostingType VirtualPosting "[a]" @?= "(a)" - ,test "joinAccountNames" $ do + ,testCase "joinAccountNames" $ do "a" `joinAccountNames` "b:c" @?= "a:b:c" "a" `joinAccountNames` "(b:c)" @?= "(a:b:c)" "[a]" `joinAccountNames` "(b:c)" @?= "[a:b:c]" "" `joinAccountNames` "a" @?= "a" - ,test "concatAccountNames" $ do + ,testCase "concatAccountNames" $ do concatAccountNames [] @?= "" concatAccountNames ["a","(b)","[c:d]"] @?= "(a:b:c:d)" - ,test "commentAddTag" $ do + ,testCase "commentAddTag" $ do commentAddTag "" ("a","") @?= "a: " commentAddTag "[1/2]" ("a","") @?= "[1/2], a: " - ,test "commentAddTagNextLine" $ do + ,testCase "commentAddTagNextLine" $ do commentAddTagNextLine "" ("a","") @?= "\na: " commentAddTagNextLine "[1/2]" ("a","") @?= "[1/2]\na: " diff --git a/Hledger/Data/RawOptions.hs b/Hledger/Data/RawOptions.hs --- a/Hledger/Data/RawOptions.hs +++ b/Hledger/Data/RawOptions.hs @@ -50,7 +50,7 @@ setboolopt name = overRawOpts (++ [(name,"")]) appendopts :: [(String,String)] -> RawOpts -> RawOpts -appendopts new = overRawOpts $ \old -> concat [old,new] +appendopts new = overRawOpts (++new) -- | Is the named option present ? inRawOpts :: String -> RawOpts -> Bool diff --git a/Hledger/Data/StringFormat.hs b/Hledger/Data/StringFormat.hs --- a/Hledger/Data/StringFormat.hs +++ b/Hledger/Data/StringFormat.hs @@ -136,7 +136,7 @@ char '(' f <- fieldp char ')' - return $ FormatField (isJust leftJustified) (parseDec minWidth) (parseDec maxWidth) f + return $ FormatField (isJust leftJustified) (parseDec minWidth <|> Just 0) (parseDec maxWidth) f where parseDec s = case s of Just text -> Just m where ((m,_):_) = readDec text @@ -159,9 +159,9 @@ FormatLiteral l -> formatText False Nothing Nothing l FormatField leftJustify min max _ -> formatText leftJustify min max value -tests_StringFormat = tests "StringFormat" [ +tests_StringFormat = testGroup "StringFormat" [ - test "formatStringHelper" $ do + testCase "formatStringHelper" $ do formatStringTester (FormatLiteral " ") "" " " formatStringTester (FormatField False Nothing Nothing DescriptionField) "description" "description" formatStringTester (FormatField False (Just 20) Nothing DescriptionField) "description" " description" @@ -171,25 +171,25 @@ formatStringTester (FormatField True (Just 20) (Just 20) DescriptionField) "description" "description " formatStringTester (FormatField True Nothing (Just 3) DescriptionField) "description" "des" - ,let s `gives` expected = test s $ parseStringFormat (T.pack s) @?= Right expected - in tests "parseStringFormat" [ + ,let s `gives` expected = testCase s $ parseStringFormat (T.pack s) @?= Right expected + in testGroup "parseStringFormat" [ "" `gives` (defaultStringFormatStyle []) , "D" `gives` (defaultStringFormatStyle [FormatLiteral "D"]) - , "%(date)" `gives` (defaultStringFormatStyle [FormatField False Nothing Nothing DescriptionField]) - , "%(total)" `gives` (defaultStringFormatStyle [FormatField False Nothing Nothing TotalField]) + , "%(date)" `gives` (defaultStringFormatStyle [FormatField False (Just 0) Nothing DescriptionField]) + , "%(total)" `gives` (defaultStringFormatStyle [FormatField False (Just 0) Nothing TotalField]) -- TODO -- , "^%(total)" `gives` (TopAligned [FormatField False Nothing Nothing TotalField]) -- , "_%(total)" `gives` (BottomAligned [FormatField False Nothing Nothing TotalField]) -- , ",%(total)" `gives` (OneLine [FormatField False Nothing Nothing TotalField]) - , "Hello %(date)!" `gives` (defaultStringFormatStyle [FormatLiteral "Hello ", FormatField False Nothing Nothing DescriptionField, FormatLiteral "!"]) - , "%-(date)" `gives` (defaultStringFormatStyle [FormatField True Nothing Nothing DescriptionField]) + , "Hello %(date)!" `gives` (defaultStringFormatStyle [FormatLiteral "Hello ", FormatField False (Just 0) Nothing DescriptionField, FormatLiteral "!"]) + , "%-(date)" `gives` (defaultStringFormatStyle [FormatField True (Just 0) Nothing DescriptionField]) , "%20(date)" `gives` (defaultStringFormatStyle [FormatField False (Just 20) Nothing DescriptionField]) - , "%.10(date)" `gives` (defaultStringFormatStyle [FormatField False Nothing (Just 10) DescriptionField]) + , "%.10(date)" `gives` (defaultStringFormatStyle [FormatField False (Just 0) (Just 10) DescriptionField]) , "%20.10(date)" `gives` (defaultStringFormatStyle [FormatField False (Just 20) (Just 10) DescriptionField]) , "%20(account) %.10(total)" `gives` (defaultStringFormatStyle [FormatField False (Just 20) Nothing AccountField ,FormatLiteral " " - ,FormatField False Nothing (Just 10) TotalField + ,FormatField False (Just 0) (Just 10) TotalField ]) - , test "newline not parsed" $ assertLeft $ parseStringFormat "\n" + , testCase "newline not parsed" $ assertLeft $ parseStringFormat "\n" ] ] diff --git a/Hledger/Data/Timeclock.hs b/Hledger/Data/Timeclock.hs --- a/Hledger/Data/Timeclock.hs +++ b/Hledger/Data/Timeclock.hs @@ -77,10 +77,7 @@ {- HLINT ignore timeclockEntriesToTransactions -} errorExpectedCodeButGot expected actual = errorWithSourceLine line $ "expected timeclock code " ++ (show expected) ++ " but got " ++ show (tlcode actual) - where - line = case tlsourcepos actual of - GenericSourcePos _ l _ -> l - JournalSourcePos _ (l, _) -> l + where line = unPos . sourceLine $ tlsourcepos actual errorWithSourceLine line msg = error $ "line " ++ show line ++ ": " ++ msg @@ -95,7 +92,7 @@ where t = Transaction { tindex = 0, - tsourcepos = tlsourcepos i, + tsourcepos = (tlsourcepos i, tlsourcepos i), tdate = idate, tdate2 = Nothing, tstatus = Cleared, @@ -126,7 +123,7 @@ -- tests -tests_Timeclock = tests "Timeclock" [ +tests_Timeclock = testGroup "Timeclock" [ testCaseSteps "timeclockEntriesToTransactions tests" $ \step -> do step "gathering data" today <- getCurrentDay @@ -135,7 +132,7 @@ let now = utcToLocalTime tz now' nowstr = showtime now yesterday = prevday today - clockin = TimeclockEntry nullsourcepos In + clockin = TimeclockEntry (initialPos "") In mktime d = LocalTime d . fromMaybe midnight . parseTimeM True defaultTimeLocale "%H:%M:%S" showtime = formatTime defaultTimeLocale "%H:%M" diff --git a/Hledger/Data/Transaction.hs b/Hledger/Data/Transaction.hs --- a/Hledger/Data/Transaction.hs +++ b/Hledger/Data/Transaction.hs @@ -7,67 +7,49 @@ -} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE Rank2Types #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE NamedFieldPuns #-} -module Hledger.Data.Transaction ( - -- * Transaction - nulltransaction, - transaction, - txnTieKnot, - txnUntieKnot, - transactionCheckBalanced, +module Hledger.Data.Transaction +( -- * Transaction + nulltransaction +, transaction +, txnTieKnot +, txnUntieKnot -- * operations - showAccountName, - hasRealPostings, - realPostings, - assignmentPostings, - virtualPostings, - balancedVirtualPostings, - transactionsPostings, - BalancingOpts(..), - balancingOpts, - isTransactionBalanced, - balanceTransaction, - balanceTransactionHelper, - transactionTransformPostings, - transactionApplyValuation, - transactionToCost, - transactionApplyAliases, - transactionMapPostings, - transactionMapPostingAmounts, - -- nonzerobalanceerror, +, showAccountName +, hasRealPostings +, realPostings +, assignmentPostings +, virtualPostings +, balancedVirtualPostings +, transactionsPostings +, transactionTransformPostings +, transactionApplyValuation +, transactionToCost +, transactionApplyAliases +, transactionMapPostings +, transactionMapPostingAmounts + -- nonzerobalanceerror -- * date operations - transactionDate2, +, transactionDate2 -- * transaction description parts - transactionPayee, - transactionNote, - -- payeeAndNoteFromDescription, +, transactionPayee +, transactionNote + -- payeeAndNoteFromDescription -- * rendering - showTransaction, - showTransactionOneLineAmounts, - -- showPostingLine, - showPostingLines, - -- * GenericSourcePos - sourceFilePath, - sourceFirstLine, - showGenericSourcePos, - annotateErrorWithTransaction, - transactionFile, +, showTransaction +, showTransactionOneLineAmounts + -- showPostingLine +, showPostingLines +, transactionFile -- * tests - tests_Transaction -) -where +, tests_Transaction +) where import Data.Default (Default(..)) -import Data.Foldable (asum) -import Data.List (intercalate, partition) -import Data.List.Extra (nubSort) -import Data.Maybe (fromMaybe, isNothing, mapMaybe) +import Data.Maybe (fromMaybe) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Lazy as TL @@ -84,23 +66,7 @@ import Hledger.Data.Valuation import Text.Tabular.AsciiWide -sourceFilePath :: GenericSourcePos -> FilePath -sourceFilePath = \case - GenericSourcePos fp _ _ -> fp - JournalSourcePos fp _ -> fp -sourceFirstLine :: GenericSourcePos -> Int -sourceFirstLine = \case - GenericSourcePos _ line _ -> line - JournalSourcePos _ (line, _) -> line - --- | Render source position in human-readable form. --- Keep in sync with Hledger.UI.ErrorScreen.hledgerparseerrorpositionp (temporary). XXX -showGenericSourcePos :: GenericSourcePos -> String -showGenericSourcePos = \case - GenericSourcePos fp line column -> show fp ++ " (line " ++ show line ++ ", column " ++ show column ++ ")" - JournalSourcePos fp (line, line') -> show fp ++ " (lines " ++ show line ++ "-" ++ show line' ++ ")" - nulltransaction :: Transaction nulltransaction = Transaction { tindex=0, @@ -354,257 +320,6 @@ transactionsPostings :: [Transaction] -> [Posting] transactionsPostings = concatMap tpostings -data BalancingOpts = BalancingOpts - { ignore_assertions_ :: Bool -- ^ Ignore balance assertions - , infer_prices_ :: Bool -- ^ Infer prices in unbalanced multicommodity amounts - , commodity_styles_ :: Maybe (M.Map CommoditySymbol AmountStyle) -- ^ commodity display styles - } deriving (Show) - -instance Default BalancingOpts where def = balancingOpts - -balancingOpts :: BalancingOpts -balancingOpts = BalancingOpts - { ignore_assertions_ = False - , infer_prices_ = True - , commodity_styles_ = Nothing - } - --- | Check that this transaction would appear balanced to a human when displayed. --- On success, returns the empty list, otherwise one or more error messages. --- --- In more detail: --- For the real postings, and separately for the balanced virtual postings: --- --- 1. Convert amounts to cost where possible --- --- 2. When there are two or more non-zero amounts --- (appearing non-zero when displayed, using the given display styles if provided), --- are they a mix of positives and negatives ? --- This is checked separately to give a clearer error message. --- (Best effort; could be confused by postings with multicommodity amounts.) --- --- 3. Does the amounts' sum appear non-zero when displayed ? --- (using the given display styles if provided) --- -transactionCheckBalanced :: BalancingOpts -> Transaction -> [String] -transactionCheckBalanced BalancingOpts{commodity_styles_} t = errs - where - (rps, bvps) = (realPostings t, balancedVirtualPostings t) - - -- check for mixed signs, detecting nonzeros at display precision - canonicalise = maybe id canonicaliseMixedAmount commodity_styles_ - signsOk ps = - case filter (not.mixedAmountLooksZero) $ map (canonicalise.mixedAmountCost.pamount) ps of - nonzeros | length nonzeros >= 2 - -> length (nubSort $ mapMaybe isNegativeMixedAmount nonzeros) > 1 - _ -> True - (rsignsok, bvsignsok) = (signsOk rps, signsOk bvps) - - -- check for zero sum, at display precision - (rsum, bvsum) = (sumPostings rps, sumPostings bvps) - (rsumcost, bvsumcost) = (mixedAmountCost rsum, mixedAmountCost bvsum) - (rsumdisplay, bvsumdisplay) = (canonicalise rsumcost, canonicalise bvsumcost) - (rsumok, bvsumok) = (mixedAmountLooksZero rsumdisplay, mixedAmountLooksZero bvsumdisplay) - - -- generate error messages, showing amounts with their original precision - errs = filter (not.null) [rmsg, bvmsg] - where - rmsg - | not rsignsok = "real postings all have the same sign" - | not rsumok = "real postings' sum should be 0 but is: " ++ showMixedAmount rsumcost - | otherwise = "" - bvmsg - | not bvsignsok = "balanced virtual postings all have the same sign" - | not bvsumok = "balanced virtual postings' sum should be 0 but is: " ++ showMixedAmount bvsumcost - | otherwise = "" - --- | Legacy form of transactionCheckBalanced. -isTransactionBalanced :: BalancingOpts -> Transaction -> Bool -isTransactionBalanced bopts = null . transactionCheckBalanced bopts - --- | Balance this transaction, ensuring that its postings --- (and its balanced virtual postings) sum to 0, --- by inferring a missing amount or conversion price(s) if needed. --- Or if balancing is not possible, because the amounts don't sum to 0 or --- because there's more than one missing amount, return an error message. --- --- Transactions with balance assignments can have more than one --- missing amount; to balance those you should use the more powerful --- journalBalanceTransactions. --- --- The "sum to 0" test is done using commodity display precisions, --- if provided, so that the result agrees with the numbers users can see. --- -balanceTransaction :: - BalancingOpts - -> Transaction - -> Either String Transaction -balanceTransaction bopts = fmap fst . balanceTransactionHelper bopts - --- | Helper used by balanceTransaction and balanceTransactionWithBalanceAssignmentAndCheckAssertionsB; --- use one of those instead. It also returns a list of accounts --- and amounts that were inferred. -balanceTransactionHelper :: - BalancingOpts - -> Transaction - -> Either String (Transaction, [(AccountName, MixedAmount)]) -balanceTransactionHelper bopts t = do - (t', inferredamtsandaccts) <- inferBalancingAmount (fromMaybe M.empty $ commodity_styles_ bopts) $ - if infer_prices_ bopts then inferBalancingPrices t else t - case transactionCheckBalanced bopts t' of - [] -> Right (txnTieKnot t', inferredamtsandaccts) - errs -> Left $ transactionBalanceError t' errs - --- | Generate a transaction balancing error message, given the transaction --- and one or more suberror messages. -transactionBalanceError :: Transaction -> [String] -> String -transactionBalanceError t errs = - annotateErrorWithTransaction t $ - intercalate "\n" $ "could not balance this transaction:" : errs - -annotateErrorWithTransaction :: Transaction -> String -> String -annotateErrorWithTransaction t s = - unlines [ showGenericSourcePos $ tsourcepos t, s - , T.unpack . T.stripEnd $ showTransaction t - ] - --- | Infer up to one missing amount for this transactions's real postings, and --- likewise for its balanced virtual postings, if needed; or return an error --- message if we can't. Returns the updated transaction and any inferred posting amounts, --- with the corresponding accounts, in order). --- --- We can infer a missing amount when there are multiple postings and exactly --- one of them is amountless. If the amounts had price(s) the inferred amount --- have the same price(s), and will be converted to the price commodity. -inferBalancingAmount :: - M.Map CommoditySymbol AmountStyle -- ^ commodity display styles - -> Transaction - -> Either String (Transaction, [(AccountName, MixedAmount)]) -inferBalancingAmount styles t@Transaction{tpostings=ps} - | length amountlessrealps > 1 - = Left $ transactionBalanceError t - ["can't have more than one real posting with no amount" - ,"(remember to put two or more spaces between account and amount)"] - | length amountlessbvps > 1 - = Left $ transactionBalanceError t - ["can't have more than one balanced virtual posting with no amount" - ,"(remember to put two or more spaces between account and amount)"] - | otherwise - = let psandinferredamts = map inferamount ps - inferredacctsandamts = [(paccount p, amt) | (p, Just amt) <- psandinferredamts] - in Right (t{tpostings=map fst psandinferredamts}, inferredacctsandamts) - where - (amountfulrealps, amountlessrealps) = partition hasAmount (realPostings t) - realsum = sumPostings amountfulrealps - (amountfulbvps, amountlessbvps) = partition hasAmount (balancedVirtualPostings t) - bvsum = sumPostings amountfulbvps - - inferamount :: Posting -> (Posting, Maybe MixedAmount) - inferamount p = - let - minferredamt = case ptype p of - RegularPosting | not (hasAmount p) -> Just realsum - BalancedVirtualPosting | not (hasAmount p) -> Just bvsum - _ -> Nothing - in - case minferredamt of - Nothing -> (p, Nothing) - Just a -> (p{pamount=a', poriginal=Just $ originalPosting p}, Just a') - where - -- Inferred amounts are converted to cost. - -- Also ensure the new amount has the standard style for its commodity - -- (since the main amount styling pass happened before this balancing pass); - a' = styleMixedAmount styles . mixedAmountCost $ maNegate a - --- | Infer prices for this transaction's posting amounts, if needed to make --- the postings balance, and if possible. This is done once for the real --- postings and again (separately) for the balanced virtual postings. When --- it's not possible, the transaction is left unchanged. --- --- The simplest example is a transaction with two postings, each in a --- different commodity, with no prices specified. In this case we'll add a --- price to the first posting such that it can be converted to the commodity --- of the second posting (with -B), and such that the postings balance. --- --- In general, we can infer a conversion price when the sum of posting amounts --- contains exactly two different commodities and no explicit prices. Also --- all postings are expected to contain an explicit amount (no missing --- amounts) in a single commodity. Otherwise no price inferring is attempted. --- --- The transaction itself could contain more than two commodities, and/or --- prices, if they cancel out; what matters is that the sum of posting amounts --- contains exactly two commodities and zero prices. --- --- There can also be more than two postings in either of the commodities. --- --- We want to avoid excessive display of digits when the calculated price is --- an irrational number, while hopefully also ensuring the displayed numbers --- make sense if the user does a manual calculation. This is (mostly) achieved --- in two ways: --- --- - when there is only one posting in the "from" commodity, a total price --- (@@) is used, and all available decimal digits are shown --- --- - otherwise, a suitable averaged unit price (@) is applied to the relevant --- postings, with display precision equal to the summed display precisions --- of the two commodities being converted between, or 2, whichever is larger. --- --- (We don't always calculate a good-looking display precision for unit prices --- when the commodity display precisions are low, eg when a journal doesn't --- use any decimal places. The minimum of 2 helps make the prices shown by the --- print command a bit less surprising in this case. Could do better.) --- -inferBalancingPrices :: Transaction -> Transaction -inferBalancingPrices t@Transaction{tpostings=ps} = t{tpostings=ps'} - where - ps' = map (priceInferrerFor t BalancedVirtualPosting . priceInferrerFor t RegularPosting) ps - --- | Generate a posting update function which assigns a suitable balancing --- price to the posting, if and as appropriate for the given transaction and --- posting type (real or balanced virtual). If we cannot or should not infer --- prices, just act as the identity on postings. -priceInferrerFor :: Transaction -> PostingType -> (Posting -> Posting) -priceInferrerFor t pt = maybe id inferprice inferFromAndTo - where - postings = filter ((==pt).ptype) $ tpostings t - pcommodities = map acommodity $ concatMap (amounts . pamount) postings - sumamounts = amounts $ sumPostings postings -- amounts normalises to one amount per commodity & price - - -- We can infer prices if there are no prices given, exactly two commodities in the normalised - -- sum of postings in this transaction, and these two have opposite signs. The amount we are - -- converting from is the first commodity to appear in the ordered list of postings, and the - -- commodity we are converting to is the other. If we cannot infer prices, return Nothing. - inferFromAndTo = case sumamounts of - [a,b] | noprices, oppositesigns -> asum $ map orderIfMatches pcommodities - where - noprices = all (isNothing . aprice) sumamounts - oppositesigns = signum (aquantity a) /= signum (aquantity b) - orderIfMatches x | x == acommodity a = Just (a,b) - | x == acommodity b = Just (b,a) - | otherwise = Nothing - _ -> Nothing - - -- For each posting, if the posting type matches, there is only a single amount in the posting, - -- and the commodity of the amount matches the amount we're converting from, - -- then set its price based on the ratio between fromamount and toamount. - inferprice (fromamount, toamount) posting - | [a] <- amounts (pamount posting), ptype posting == pt, acommodity a == acommodity fromamount - = posting{ pamount = mixedAmount a{aprice=Just conversionprice} - , poriginal = Just $ originalPosting posting } - | otherwise = posting - where - -- If only one Amount in the posting list matches fromamount we can use TotalPrice. - -- Otherwise divide the conversion equally among the Amounts by using a unit price. - conversionprice = case filter (== acommodity fromamount) pcommodities of - [_] -> TotalPrice $ negate toamount - _ -> UnitPrice $ negate unitprice `withPrecision` unitprecision - - unitprice = aquantity fromamount `divideAmount` toamount - unitprecision = case (asprecision $ astyle fromamount, asprecision $ astyle toamount) of - (Precision a, Precision b) -> Precision . max 2 $ saturatedAdd a b - _ -> NaturalPrecision - saturatedAdd a b = if maxBound - a < b then maxBound else a + b - -- Get a transaction's secondary date, defaulting to the primary date. transactionDate2 :: Transaction -> Day transactionDate2 t = fromMaybe (tdate t) $ tdate2 t @@ -657,20 +372,17 @@ -- | The file path from which this transaction was parsed. transactionFile :: Transaction -> FilePath -transactionFile Transaction{tsourcepos} = - case tsourcepos of - GenericSourcePos f _ _ -> f - JournalSourcePos f _ -> f +transactionFile Transaction{tsourcepos} = sourceName $ fst tsourcepos -- tests tests_Transaction :: TestTree tests_Transaction = - tests "Transaction" [ + testGroup "Transaction" [ - tests "showPostingLines" [ - test "null posting" $ showPostingLines nullposting @?= [" 0"] - , test "non-null posting" $ + testGroup "showPostingLines" [ + testCase "null posting" $ showPostingLines nullposting @?= [" 0"] + , testCase "non-null posting" $ let p = posting { pstatus = Cleared @@ -705,45 +417,38 @@ t3 = nulltransaction {tpostings = ["a" `post` usd 1, "b" `post` missingamt, "c" `post` usd (-1)]} -- unbalanced amounts when precision is limited (#931) -- t4 = nulltransaction {tpostings = ["a" `post` usd (-0.01), "b" `post` usd (0.005), "c" `post` usd (0.005)]} - in tests "postingsAsLines" [ - test "null-transaction" $ postingsAsLines False (tpostings nulltransaction) @?= [] - , test "implicit-amount" $ postingsAsLines False (tpostings timp) @?= + in testGroup "postingsAsLines" [ + testCase "null-transaction" $ postingsAsLines False (tpostings nulltransaction) @?= [] + , testCase "implicit-amount" $ postingsAsLines False (tpostings timp) @?= [ " a $1.00" , " b" -- implicit amount remains implicit ] - , test "explicit-amounts" $ postingsAsLines False (tpostings texp) @?= + , testCase "explicit-amounts" $ postingsAsLines False (tpostings texp) @?= [ " a $1.00" , " b $-1.00" ] - , test "one-explicit-amount" $ postingsAsLines False (tpostings texp1) @?= + , testCase "one-explicit-amount" $ postingsAsLines False (tpostings texp1) @?= [ " (a) $1.00" ] - , test "explicit-amounts-two-commodities" $ postingsAsLines False (tpostings texp2) @?= + , testCase "explicit-amounts-two-commodities" $ postingsAsLines False (tpostings texp2) @?= [ " a $1.00" , " b -1.00h @ $1.00" ] - , test "explicit-amounts-not-explicitly-balanced" $ postingsAsLines False (tpostings texp2b) @?= + , testCase "explicit-amounts-not-explicitly-balanced" $ postingsAsLines False (tpostings texp2b) @?= [ " a $1.00" , " b -1.00h" ] - , test "implicit-amount-not-last" $ postingsAsLines False (tpostings t3) @?= + , testCase "implicit-amount-not-last" $ postingsAsLines False (tpostings t3) @?= [" a $1.00", " b", " c $-1.00"] - -- , test "ensure-visibly-balanced" $ + -- , testCase "ensure-visibly-balanced" $ -- in postingsAsLines False (tpostings t4) @?= -- [" a $-0.01", " b $0.005", " c $0.005"] ] - , test "inferBalancingAmount" $ do - (fst <$> inferBalancingAmount M.empty nulltransaction) @?= Right nulltransaction - (fst <$> inferBalancingAmount M.empty nulltransaction{tpostings = ["a" `post` usd (-5), "b" `post` missingamt]}) @?= - Right nulltransaction{tpostings = ["a" `post` usd (-5), "b" `post` usd 5]} - (fst <$> inferBalancingAmount M.empty nulltransaction{tpostings = ["a" `post` usd (-5), "b" `post` (eur 3 @@ usd 4), "c" `post` missingamt]}) @?= - Right nulltransaction{tpostings = ["a" `post` usd (-5), "b" `post` (eur 3 @@ usd 4), "c" `post` usd 1]} - - , tests "showTransaction" [ - test "null transaction" $ showTransaction nulltransaction @?= "0000-01-01\n\n" - , test "non-null transaction" $ showTransaction + , testGroup "showTransaction" [ + testCase "null transaction" $ showTransaction nulltransaction @?= "0000-01-01\n\n" + , testCase "non-null transaction" $ showTransaction nulltransaction { tdate = fromGregorian 2012 05 14 , tdate2 = Just $ fromGregorian 2012 05 15 @@ -772,7 +477,7 @@ , " ; pcomment2" , "" ] - , test "show a balanced transaction" $ + , testCase "show a balanced transaction" $ (let t = Transaction 0 @@ -795,7 +500,7 @@ , " assets:checking $-47.18" , "" ]) - , test "show an unbalanced transaction, should not elide" $ + , testCase "show an unbalanced transaction, should not elide" $ (showTransaction (txnTieKnot $ Transaction @@ -818,7 +523,7 @@ , " assets:checking $-47.19" , "" ]) - , test "show a transaction with one posting and a missing amount" $ + , testCase "show a transaction with one posting and a missing amount" $ (showTransaction (txnTieKnot $ Transaction @@ -834,7 +539,7 @@ [] [posting {paccount = "expenses:food:groceries", pamount = missingmixedamt}])) @?= (T.unlines ["2007-01-28 coopportunity", " expenses:food:groceries", ""]) - , test "show a transaction with a priced commodityless amount" $ + , testCase "show a transaction with a priced commodityless amount" $ (showTransaction (txnTieKnot $ Transaction @@ -852,231 +557,5 @@ , posting {paccount = "b", pamount = missingmixedamt} ])) @?= (T.unlines ["2010-01-01 x", " a 1 @ $2", " b", ""]) - ] - , tests "balanceTransaction" [ - test "detect unbalanced entry, sign error" $ - assertLeft - (balanceTransaction def - (Transaction - 0 - "" - nullsourcepos - (fromGregorian 2007 01 28) - Nothing - Unmarked - "" - "test" - "" - [] - [posting {paccount = "a", pamount = mixedAmount (usd 1)}, posting {paccount = "b", pamount = mixedAmount (usd 1)}])) - ,test "detect unbalanced entry, multiple missing amounts" $ - assertLeft $ - balanceTransaction def - (Transaction - 0 - "" - nullsourcepos - (fromGregorian 2007 01 28) - Nothing - Unmarked - "" - "test" - "" - [] - [ posting {paccount = "a", pamount = missingmixedamt} - , posting {paccount = "b", pamount = missingmixedamt} - ]) - ,test "one missing amount is inferred" $ - (pamount . last . tpostings <$> - balanceTransaction def - (Transaction - 0 - "" - nullsourcepos - (fromGregorian 2007 01 28) - Nothing - Unmarked - "" - "" - "" - [] - [posting {paccount = "a", pamount = mixedAmount (usd 1)}, posting {paccount = "b", pamount = missingmixedamt}])) @?= - Right (mixedAmount $ usd (-1)) - ,test "conversion price is inferred" $ - (pamount . head . tpostings <$> - balanceTransaction def - (Transaction - 0 - "" - nullsourcepos - (fromGregorian 2007 01 28) - Nothing - Unmarked - "" - "" - "" - [] - [ posting {paccount = "a", pamount = mixedAmount (usd 1.35)} - , posting {paccount = "b", pamount = mixedAmount (eur (-1))} - ])) @?= - Right (mixedAmount $ usd 1.35 @@ eur 1) - ,test "balanceTransaction balances based on cost if there are unit prices" $ - assertRight $ - balanceTransaction def - (Transaction - 0 - "" - nullsourcepos - (fromGregorian 2011 01 01) - Nothing - Unmarked - "" - "" - "" - [] - [ posting {paccount = "a", pamount = mixedAmount $ usd 1 `at` eur 2} - , posting {paccount = "a", pamount = mixedAmount $ usd (-2) `at` eur 1} - ]) - ,test "balanceTransaction balances based on cost if there are total prices" $ - assertRight $ - balanceTransaction def - (Transaction - 0 - "" - nullsourcepos - (fromGregorian 2011 01 01) - Nothing - Unmarked - "" - "" - "" - [] - [ posting {paccount = "a", pamount = mixedAmount $ usd 1 @@ eur 1} - , posting {paccount = "a", pamount = mixedAmount $ usd (-2) @@ eur (-1)} - ]) - ] - , tests "isTransactionBalanced" [ - test "detect balanced" $ - assertBool "" $ - isTransactionBalanced def $ - Transaction - 0 - "" - nullsourcepos - (fromGregorian 2009 01 01) - Nothing - Unmarked - "" - "a" - "" - [] - [ posting {paccount = "b", pamount = mixedAmount (usd 1.00)} - , posting {paccount = "c", pamount = mixedAmount (usd (-1.00))} - ] - ,test "detect unbalanced" $ - assertBool "" $ - not $ - isTransactionBalanced def $ - Transaction - 0 - "" - nullsourcepos - (fromGregorian 2009 01 01) - Nothing - Unmarked - "" - "a" - "" - [] - [ posting {paccount = "b", pamount = mixedAmount (usd 1.00)} - , posting {paccount = "c", pamount = mixedAmount (usd (-1.01))} - ] - ,test "detect unbalanced, one posting" $ - assertBool "" $ - not $ - isTransactionBalanced def $ - Transaction - 0 - "" - nullsourcepos - (fromGregorian 2009 01 01) - Nothing - Unmarked - "" - "a" - "" - [] - [posting {paccount = "b", pamount = mixedAmount (usd 1.00)}] - ,test "one zero posting is considered balanced for now" $ - assertBool "" $ - isTransactionBalanced def $ - Transaction - 0 - "" - nullsourcepos - (fromGregorian 2009 01 01) - Nothing - Unmarked - "" - "a" - "" - [] - [posting {paccount = "b", pamount = mixedAmount (usd 0)}] - ,test "virtual postings don't need to balance" $ - assertBool "" $ - isTransactionBalanced def $ - Transaction - 0 - "" - nullsourcepos - (fromGregorian 2009 01 01) - Nothing - Unmarked - "" - "a" - "" - [] - [ posting {paccount = "b", pamount = mixedAmount (usd 1.00)} - , posting {paccount = "c", pamount = mixedAmount (usd (-1.00))} - , posting {paccount = "d", pamount = mixedAmount (usd 100), ptype = VirtualPosting} - ] - ,test "balanced virtual postings need to balance among themselves" $ - assertBool "" $ - not $ - isTransactionBalanced def $ - Transaction - 0 - "" - nullsourcepos - (fromGregorian 2009 01 01) - Nothing - Unmarked - "" - "a" - "" - [] - [ posting {paccount = "b", pamount = mixedAmount (usd 1.00)} - , posting {paccount = "c", pamount = mixedAmount (usd (-1.00))} - , posting {paccount = "d", pamount = mixedAmount (usd 100), ptype = BalancedVirtualPosting} - ] - ,test "balanced virtual postings need to balance among themselves (2)" $ - assertBool "" $ - isTransactionBalanced def $ - Transaction - 0 - "" - nullsourcepos - (fromGregorian 2009 01 01) - Nothing - Unmarked - "" - "a" - "" - [] - [ posting {paccount = "b", pamount = mixedAmount (usd 1.00)} - , posting {paccount = "c", pamount = mixedAmount (usd (-1.00))} - , posting {paccount = "d", pamount = mixedAmount (usd 100), ptype = BalancedVirtualPosting} - , posting {paccount = "3", pamount = mixedAmount (usd (-100)), ptype = BalancedVirtualPosting} - ] ] ] diff --git a/Hledger/Data/TransactionModifier.hs b/Hledger/Data/TransactionModifier.hs --- a/Hledger/Data/TransactionModifier.hs +++ b/Hledger/Data/TransactionModifier.hs @@ -13,6 +13,7 @@ where import Control.Applicative ((<|>), liftA2) +import qualified Data.Map as M import Data.Maybe (catMaybes) import qualified Data.Text as T import Data.Time.Calendar (Day) @@ -22,7 +23,7 @@ import Hledger.Data.Transaction (txnTieKnot) import Hledger.Query (Query, filterQuery, matchesAmount, matchesPosting, parseQuery, queryIsAmt, queryIsSym, simplifyQuery) -import Hledger.Data.Posting (commentJoin, commentAddTag) +import Hledger.Data.Posting (commentJoin, commentAddTag, postingApplyCommodityStyles) import Hledger.Utils (dbg6, wrap) -- $setup @@ -35,9 +36,9 @@ -- Or if any of them fails to be parsed, return the first error. A reference -- date is provided to help interpret relative dates in transaction modifier -- queries. -modifyTransactions :: Day -> [TransactionModifier] -> [Transaction] -> Either String [Transaction] -modifyTransactions d tmods ts = do - fs <- mapM (transactionModifierToFunction d) tmods -- convert modifiers to functions, or return a parse error +modifyTransactions :: M.Map CommoditySymbol AmountStyle -> Day -> [TransactionModifier] -> [Transaction] -> Either String [Transaction] +modifyTransactions styles d tmods ts = do + fs <- mapM (transactionModifierToFunction styles d) tmods -- convert modifiers to functions, or return a parse error let modifytxn t = t'' where @@ -60,27 +61,28 @@ -- -- >>> import qualified Data.Text.IO as T -- >>> t = nulltransaction{tpostings=["ping" `post` usd 1]} --- >>> test = either putStr (T.putStr.showTransaction) . fmap ($ t) . transactionModifierToFunction nulldate --- >>> test $ TransactionModifier "" ["pong" `post` usd 2] +-- >>> tmpost acc amt = TMPostingRule (acc `post` amt) False +-- >>> test = either putStr (T.putStr.showTransaction) . fmap ($ t) . transactionModifierToFunction mempty nulldate +-- >>> test $ TransactionModifier "" ["pong" `tmpost` usd 2] -- 0000-01-01 -- ping $1.00 -- pong $2.00 ; generated-posting: = -- --- >>> test $ TransactionModifier "miss" ["pong" `post` usd 2] +-- >>> test $ TransactionModifier "miss" ["pong" `tmpost` usd 2] -- 0000-01-01 -- ping $1.00 -- --- >>> test $ TransactionModifier "ping" ["pong" `post` amount{aismultiplier=True, aquantity=3}] +-- >>> test $ TransactionModifier "ping" [("pong" `tmpost` amount{aquantity=3}){tmprIsMultiplier=True}] -- 0000-01-01 -- ping $1.00 -- pong $3.00 ; generated-posting: = ping -- -- -transactionModifierToFunction :: Day -> TransactionModifier -> Either String (Transaction -> Transaction) -transactionModifierToFunction refdate TransactionModifier{tmquerytxt, tmpostingrules} = do +transactionModifierToFunction :: M.Map CommoditySymbol AmountStyle -> Day -> TransactionModifier -> Either String (Transaction -> Transaction) +transactionModifierToFunction styles refdate TransactionModifier{tmquerytxt, tmpostingrules} = do q <- simplifyQuery . fst <$> parseQuery refdate tmquerytxt let - fs = map (tmPostingRuleToFunction q tmquerytxt) tmpostingrules + fs = map (tmPostingRuleToFunction styles q tmquerytxt) tmpostingrules generatePostings ps = concatMap (\p -> p : map ($p) (if q `matchesPosting` p then fs else [])) ps Right $ \t@(tpostings -> ps) -> txnTieKnot t{tpostings=generatePostings ps} @@ -92,9 +94,9 @@ -- and a hidden _generated-posting: tag which does not. -- The TransactionModifier's query text is also provided, and saved -- as the tags' value. -tmPostingRuleToFunction :: Query -> T.Text -> TMPostingRule -> (Posting -> Posting) -tmPostingRuleToFunction query querytxt pr = - \p -> renderPostingCommentDates $ pr +tmPostingRuleToFunction :: M.Map CommoditySymbol AmountStyle -> Query -> T.Text -> TMPostingRule -> (Posting -> Posting) +tmPostingRuleToFunction styles query querytxt tmpr = + \p -> postingApplyCommodityStyles styles . renderPostingCommentDates $ pr { pdate = pdate pr <|> pdate p , pdate2 = pdate2 pr <|> pdate2 p , pamount = amount' p @@ -104,9 +106,10 @@ ptags pr } where + pr = tmprPosting tmpr qry = "= " <> querytxt symq = filterQuery (liftA2 (||) queryIsSym queryIsAmt) query - amount' = case postingRuleMultiplier pr of + amount' = case postingRuleMultiplier tmpr of Nothing -> const $ pamount pr Just n -> \p -> -- Multiply the old posting's amount by the posting rule's multiplier. @@ -127,9 +130,9 @@ c -> mapMixedAmount (\a -> a{acommodity = c, astyle = astyle pramount, aprice = aprice pramount}) as postingRuleMultiplier :: TMPostingRule -> Maybe Quantity -postingRuleMultiplier p = case amountsRaw $ pamount p of - [a] | aismultiplier a -> Just $ aquantity a - _ -> Nothing +postingRuleMultiplier tmpr = case amountsRaw . pamount $ tmprPosting tmpr of + [a] | tmprIsMultiplier tmpr -> Just $ aquantity a + _ -> Nothing renderPostingCommentDates :: Posting -> Posting renderPostingCommentDates p = p { pcomment = comment' } diff --git a/Hledger/Data/Types.hs b/Hledger/Data/Types.hs --- a/Hledger/Data/Types.hs +++ b/Hledger/Data/Types.hs @@ -27,11 +27,10 @@ where import GHC.Generics (Generic) -import Data.Decimal -import Data.Default +import Data.Decimal (Decimal, DecimalRaw(..)) +import Data.Default (Default(..)) import Data.Functor (($>)) import Data.List (intercalate) -import Text.Blaze (ToMarkup(..)) --XXX https://hackage.haskell.org/package/containers/docs/Data-Map.html --Note: You should use Data.Map.Strict instead of this module if: --You will eventually need all the values stored. @@ -39,10 +38,12 @@ import qualified Data.Map as M import Data.Ord (comparing) import Data.Text (Text) -import Data.Time.Calendar -import Data.Time.LocalTime +import Data.Time.Calendar (Day) +import Data.Time.Clock.POSIX (POSIXTime) +import Data.Time.LocalTime (LocalTime) import Data.Word (Word8) -import System.Time (ClockTime(..)) +import Text.Blaze (ToMarkup(..)) +import Text.Megaparsec (SourcePos) import Hledger.Utils.Regex @@ -121,7 +122,7 @@ | Years Int | DayOfMonth Int | WeekdayOfMonth Int Int - | DayOfWeek Int + | DaysOfWeek [Int] | DayOfYear Int Int -- Month, Day -- WeekOfYear Int -- MonthOfYear Int @@ -172,6 +173,7 @@ instance ToMarkup Quantity where toMarkup = toMarkup . show +deriving instance Generic (DecimalRaw a) -- | An amount's per-unit or total cost/selling price in another -- commodity, as recorded in the journal entry eg with @ or @@. @@ -224,14 +226,32 @@ data Amount = Amount { acommodity :: !CommoditySymbol, -- commodity symbol, or special value "AUTO" aquantity :: !Quantity, -- numeric quantity, or zero in case of "AUTO" - aismultiplier :: !Bool, -- ^ kludge: a flag marking this amount and posting as a multiplier - -- in a TMPostingRule. In a regular Posting, should always be false. astyle :: !AmountStyle, aprice :: !(Maybe AmountPrice) -- ^ the (fixed, transaction-specific) price for this amount, if any } deriving (Eq,Ord,Generic,Show) -newtype MixedAmount = Mixed (M.Map MixedAmountKey Amount) deriving (Eq,Ord,Generic,Show) +newtype MixedAmount = Mixed (M.Map MixedAmountKey Amount) deriving (Generic,Show) +instance Eq MixedAmount where a == b = maCompare a b == EQ +instance Ord MixedAmount where compare = maCompare + +-- | Compare two MixedAmounts, substituting 0 for the quantity of any missing +-- commodities in either. +maCompare :: MixedAmount -> MixedAmount -> Ordering +maCompare (Mixed a) (Mixed b) = go (M.toList a) (M.toList b) + where + go xss@((kx,x):xs) yss@((ky,y):ys) = case compare kx ky of + EQ -> compareQuantities (Just x) (Just y) <> go xs ys + LT -> compareQuantities (Just x) Nothing <> go xs yss + GT -> compareQuantities Nothing (Just y) <> go xss ys + go ((_,x):xs) [] = compareQuantities (Just x) Nothing <> go xs [] + go [] ((_,y):ys) = compareQuantities Nothing (Just y) <> go [] ys + go [] [] = EQ + compareQuantities = comparing (maybe 0 aquantity) <> comparing (maybe 0 totalprice) + totalprice x = case aprice x of + Just (TotalPrice p) -> aquantity p + _ -> 0 + -- | Stores the CommoditySymbol of the Amount, along with the CommoditySymbol of -- the price, and its unit price if being used. data MixedAmountKey @@ -319,10 +339,10 @@ -- at once. Not implemented, requires #934. -- data BalanceAssertion = BalanceAssertion { - baamount :: Amount, -- ^ the expected balance in a particular commodity - batotal :: Bool, -- ^ disallow additional non-asserted commodities ? - bainclusive :: Bool, -- ^ include subaccounts when calculating the actual balance ? - baposition :: GenericSourcePos -- ^ the assertion's file position, for error reporting + baamount :: Amount, -- ^ the expected balance in a particular commodity + batotal :: Bool, -- ^ disallow additional non-asserted commodities ? + bainclusive :: Bool, -- ^ include subaccounts when calculating the actual balance ? + baposition :: SourcePos -- ^ the assertion's file position, for error reporting } deriving (Eq,Generic,Show) data Posting = Posting { @@ -366,20 +386,10 @@ ,"poriginal=" ++ show poriginal ] ++ "}" --- TODO: needs renaming, or removal if no longer needed. See also TextPosition in Hledger.UI.Editor --- | The position of parse errors (eg), like parsec's SourcePos but generic. -data GenericSourcePos = GenericSourcePos FilePath Int Int -- ^ file path, 1-based line number and 1-based column number. - | JournalSourcePos FilePath (Int, Int) -- ^ file path, inclusive range of 1-based line numbers (first, last). - deriving (Eq, Read, Show, Ord, Generic) - ---{-# ANN Transaction "HLint: ignore" #-} --- Ambiguous type variable ‘p0’ arising from an annotation --- prevents the constraint ‘(Data p0)’ from being solved. --- Probable fix: use a type annotation to specify what ‘p0’ should be. data Transaction = Transaction { tindex :: Integer, -- ^ this transaction's 1-based position in the transaction stream, or 0 when not available tprecedingcomment :: Text, -- ^ any comment lines immediately preceding this transaction - tsourcepos :: GenericSourcePos, -- ^ the file position where the date starts + tsourcepos :: (SourcePos, SourcePos), -- ^ the file position where the date starts, and where the last posting ends tdate :: Day, tdate2 :: Maybe Day, tstatus :: Status, @@ -407,9 +417,12 @@ -- | A transaction modifier transformation, which adds an extra posting -- to the matched posting's transaction. --- Can be like a regular posting, or the amount can have the aismultiplier flag set, +-- Can be like a regular posting, or can have the tmprIsMultiplier flag set, -- indicating that it's a multiplier for the matched posting's amount. -type TMPostingRule = Posting +data TMPostingRule = TMPostingRule + { tmprPosting :: Posting + , tmprIsMultiplier :: Bool + } deriving (Eq,Generic,Show) -- | A periodic transaction rule, describing a transaction that recurs. data PeriodicTransaction = PeriodicTransaction { @@ -440,7 +453,7 @@ data TimeclockCode = SetBalance | SetRequiredHours | In | Out | FinalOut deriving (Eq,Ord,Generic) data TimeclockEntry = TimeclockEntry { - tlsourcepos :: GenericSourcePos, + tlsourcepos :: SourcePos, tlcode :: TimeclockCode, tldatetime :: LocalTime, tlaccount :: AccountName, @@ -455,7 +468,6 @@ ,pdcommodity :: CommoditySymbol ,pdamount :: Amount } deriving (Eq,Ord,Generic,Show) - -- Show instance derived in Amount.hs (XXX why ?) -- | A historical market price (exchange rate) from one commodity to another. -- A more concise form of a PriceDirective, without the amount display info. @@ -464,8 +476,7 @@ ,mpfrom :: CommoditySymbol -- ^ The commodity being converted from. ,mpto :: CommoditySymbol -- ^ The commodity being converted to. ,mprate :: Quantity -- ^ One unit of the "from" commodity is worth this quantity of the "to" commodity. - } deriving (Eq,Ord,Generic) - -- Show instance derived in Amount.hs (XXX why ?) + } deriving (Eq,Ord,Generic, Show) -- additional valuation-related types in Valuation.hs @@ -507,11 +518,9 @@ -- followed by any included files in the order encountered. -- TODO: FilePath is a sloppy type here, don't assume it's a -- real file; values like "", "-", "(string)" can be seen - ,jlastreadtime :: ClockTime -- ^ when this journal was last read from its file(s) + ,jlastreadtime :: POSIXTime -- ^ when this journal was last read from its file(s) } deriving (Eq, Generic) -deriving instance Generic ClockTime - -- | A journal in the process of being parsed, not yet finalised. -- The data is partial, and list fields are in reverse order. type ParsedJournal = Journal @@ -573,7 +582,6 @@ -- tree-wise, since each one knows its parent and subs; the first -- account is the root of the tree and always exists. data Ledger = Ledger { - ljournal :: Journal, - laccounts :: [Account] -} - + ljournal :: Journal + ,laccounts :: [Account] + } deriving (Generic) diff --git a/Hledger/Data/Valuation.hs b/Hledger/Data/Valuation.hs --- a/Hledger/Data/Valuation.hs +++ b/Hledger/Data/Valuation.hs @@ -20,6 +20,8 @@ ,mixedAmountToCost ,mixedAmountApplyValuation ,mixedAmountValueAtDate + ,mixedAmountApplyGain + ,mixedAmountGainAtDate ,marketPriceReverse ,priceDirectiveToMarketPrice -- ,priceLookup @@ -43,8 +45,6 @@ import Hledger.Data.Types import Hledger.Data.Amount import Hledger.Data.Dates (nulldate) -import Hledger.Data.Commodity (showCommoditySymbol) -import Data.Maybe (fromMaybe) import Text.Printf (printf) @@ -114,28 +114,24 @@ amountToCost Cost styles = styleAmount styles . amountCost -- | Apply a specified valuation to this amount, using the provided --- price oracle, reference dates, and whether this is for a --- multiperiod report or not. Also fix up its display style using the --- provided commodity styles. +-- price oracle, and reference dates. Also fix up its display style +-- using the provided commodity styles. -- -- When the valuation requires converting to another commodity, a --- valuation (conversion) date is chosen based on the valuation type, --- the provided reference dates, and whether this is for a --- single-period or multi-period report. It will be one of: +-- valuation (conversion) date is chosen based on the valuation type +-- and the provided reference dates. It will be one of: -- --- - a fixed date specified by the ValuationType itself --- (--value=DATE). +-- - the date of the posting itself (--value=then) -- -- - the provided "period end" date - this is typically the last day -- of a subperiod (--value=end with a multi-period report), or of -- the specified report period or the journal (--value=end with a -- single-period report). -- --- - the provided "report end" date - the last day of the specified --- report period, if any (-V/-X with a report end date). +-- - the provided "today" date (--value=now). -- --- - the provided "today" date - (--value=now, or -V/X with no report --- end date). +-- - a fixed date specified by the ValuationType itself +-- (--value=DATE). -- -- This is all a bit complicated. See the reference doc at -- https://hledger.org/hledger.html#effect-of-valuation-on-reports @@ -180,6 +176,29 @@ styleAmount styles amount{acommodity=comm, aquantity=rate * aquantity a} +-- | Calculate the gain of each component amount, that is the difference +-- between the valued amount and the value of the cost basis (see +-- mixedAmountApplyValuation). +-- +-- If the commodity we are valuing in is not the same as the commodity of the +-- cost, this will value the cost at the same date as the primary amount. This +-- may not be what you want; for example you may want the cost valued at the +-- posting date. If so, let us know and we can change this behaviour. +mixedAmountApplyGain :: PriceOracle -> M.Map CommoditySymbol AmountStyle -> Day -> Day -> Day -> ValuationType -> MixedAmount -> MixedAmount +mixedAmountApplyGain priceoracle styles periodlast today postingdate v ma = + mixedAmountApplyValuation priceoracle styles periodlast today postingdate v $ ma `maMinus` mixedAmountCost ma + +-- | Calculate the gain of each component amount, that is the +-- difference between the valued amount and the value of the cost basis. +-- +-- If the commodity we are valuing in is not the same as the commodity of the +-- cost, this will value the cost at the same date as the primary amount. This +-- may not be what you want; for example you may want the cost valued at the +-- posting date. If so, let us know and we can change this behaviour. +mixedAmountGainAtDate :: PriceOracle -> M.Map CommoditySymbol AmountStyle -> Maybe CommoditySymbol -> Day -> MixedAmount -> MixedAmount +mixedAmountGainAtDate priceoracle styles mto d ma = + mixedAmountValueAtDate priceoracle styles mto d $ ma `maMinus` mixedAmountCost ma + ------------------------------------------------------------------------------ -- Market price lookup @@ -241,7 +260,7 @@ ,p 2001 01 01 "A" 11 "B" ] makepricegraph = makePriceGraph ps1 [] - in test "priceLookup" $ do + in testCase "priceLookup" $ do priceLookup makepricegraph (fromGregorian 1999 01 01) "A" Nothing @?= Nothing priceLookup makepricegraph (fromGregorian 2000 01 01) "A" Nothing @?= Just ("B",10) priceLookup makepricegraph (fromGregorian 2000 01 01) "B" (Just "A") @?= Just ("A",0.1) @@ -314,14 +333,14 @@ extend (path,unusededges) = let pathnodes = start : map mpto path - pathend = fromMaybe start $ mpto <$> lastMay path + pathend = maybe start mpto $ lastMay path (nextedges,remainingedges) = partition ((==pathend).mpfrom) unusededges in [ (path', remainingedges') | e <- nextedges , let path' = dbgpath "trying" $ path ++ [e] -- PERF prepend ? , let pathnodes' = mpto e : pathnodes - , let remainingedges' = [r | r <- remainingedges, not $ mpto r `elem` pathnodes' ] + , let remainingedges' = [r | r <- remainingedges, mpto r `notElem` pathnodes' ] ] -- debug helpers @@ -359,7 +378,7 @@ -- -- 1. A *declared market price* or *inferred market price*: -- A's latest market price in B on or before the valuation date --- as declared by a P directive, or (with the `--infer-market-price` flag) +-- as declared by a P directive, or (with the `--infer-market-prices` flag) -- inferred from transaction prices. -- -- 2. A *reverse market price*: @@ -384,7 +403,7 @@ -- prices before the valuation date.) -- -- 3. If there are no P directives at all (any commodity or date), and --- the `--infer-market-price` flag is used, then the price commodity from +-- the `--infer-market-prices` flag is used, then the price commodity from -- the latest transaction price for A on or before valuation date." -- makePriceGraph :: [MarketPrice] -> [MarketPrice] -> Day -> PriceGraph @@ -423,7 +442,7 @@ where ps | not $ null visibledeclaredprices = visibledeclaredprices | not $ null alldeclaredprices = alldeclaredprices - | otherwise = visibleinferredprices -- will be null without --infer-market-price + | otherwise = visibleinferredprices -- will be null without --infer-market-prices -- | Given a list of P-declared market prices in parse order and a -- list of transaction-inferred market prices in parse order, select @@ -462,9 +481,9 @@ ------------------------------------------------------------------------------ -tests_Valuation = tests "Valuation" [ +tests_Valuation = testGroup "Valuation" [ tests_priceLookup - ,test "marketPriceReverse" $ do + ,testCase "marketPriceReverse" $ do marketPriceReverse nullmarketprice{mprate=2} @?= nullmarketprice{mprate=0.5} marketPriceReverse nullmarketprice @?= nullmarketprice -- the reverse of a 0 price is a 0 price diff --git a/Hledger/Query.hs b/Hledger/Query.hs --- a/Hledger/Query.hs +++ b/Hledger/Query.hs @@ -62,7 +62,7 @@ import Control.Applicative ((<|>), many, optional) import Data.Default (Default(..)) -import Data.Either (partitionEithers) +import Data.Either (fromLeft, partitionEithers) import Data.List (partition) import Data.Maybe (fromMaybe, isJust, mapMaybe) import Data.Text (Text) @@ -183,7 +183,7 @@ -- 4. then all terms are AND'd together parseQueryList :: Day -> [T.Text] -> Either String (Query, [QueryOpt]) parseQueryList d termstrs = do - eterms <- sequence $ map (parseQueryTerm d) termstrs + eterms <- mapM (parseQueryTerm d) termstrs let (pats, opts) = partitionEithers eterms (descpats, pats') = partition queryIsDesc pats (acctpats, pats'') = partition queryIsAcct pats' @@ -199,7 +199,7 @@ words'' prefixes = fromparse . parsewith maybeprefixedquotedphrases -- XXX where maybeprefixedquotedphrases :: SimpleTextParser [T.Text] - maybeprefixedquotedphrases = choice' [prefixedQuotedPattern, singleQuotedPattern, doubleQuotedPattern, pattern] `sepBy` skipNonNewlineSpaces1 + maybeprefixedquotedphrases = choice' [prefixedQuotedPattern, singleQuotedPattern, doubleQuotedPattern, patterns] `sepBy` skipNonNewlineSpaces1 prefixedQuotedPattern :: SimpleTextParser T.Text prefixedQuotedPattern = do not' <- fromMaybe "" `fmap` (optional $ string "not:") @@ -211,11 +211,11 @@ p <- singleQuotedPattern <|> doubleQuotedPattern return $ prefix <> stripquotes p singleQuotedPattern :: SimpleTextParser T.Text - singleQuotedPattern = between (char '\'') (char '\'') (many $ noneOf ("'" :: [Char])) >>= return . stripquotes . T.pack + singleQuotedPattern = stripquotes . T.pack <$> between (char '\'') (char '\'') (many $ noneOf ("'" :: [Char])) doubleQuotedPattern :: SimpleTextParser T.Text - doubleQuotedPattern = between (char '"') (char '"') (many $ noneOf ("\"" :: [Char])) >>= return . stripquotes . T.pack - pattern :: SimpleTextParser T.Text - pattern = fmap T.pack $ many (noneOf (" \n\r" :: [Char])) + doubleQuotedPattern = stripquotes . T.pack <$> between (char '"') (char '"') (many $ noneOf ("\"" :: [Char])) + patterns :: SimpleTextParser T.Text + patterns = T.pack <$> many (noneOf (" \n\r" :: [Char])) -- XXX -- keep synced with patterns below, excluding "not" @@ -341,8 +341,8 @@ -- | Parse the value part of a "status:" query, or return an error. parseStatus :: T.Text -> Either String Status parseStatus s | s `elem` ["*","1"] = Right Cleared - | s `elem` ["!"] = Right Pending | s `elem` ["","0"] = Right Unmarked + | s == "!" = Right Pending | otherwise = Left $ "could not parse "++show s++" as a status (should be *, ! or empty)" -- | Parse the boolean value part of a "status:" query. "1" means true, @@ -361,14 +361,14 @@ simplify (And []) = Any simplify (And [q]) = simplify q simplify (And qs) | same qs = simplify $ head qs - | any (==None) qs = None + | None `elem` qs = None | all queryIsDate qs = Date $ spansIntersect $ mapMaybe queryTermDateSpan qs - | otherwise = And $ concat $ [map simplify dateqs, map simplify otherqs] + | otherwise = And $ map simplify dateqs ++ map simplify otherqs where (dateqs, otherqs) = partition queryIsDate $ filter (/=Any) qs simplify (Or []) = Any simplify (Or [q]) = simplifyQuery q simplify (Or qs) | same qs = simplify $ head qs - | any (==Any) qs = Any + | Any `elem` qs = Any -- all queryIsDate qs = Date $ spansUnion $ mapMaybe queryTermDateSpan qs ? | otherwise = Or $ map simplify $ filter (/=None) qs simplify (Date (DateSpan Nothing Nothing)) = Any @@ -445,8 +445,8 @@ queryIsStartDateOnly :: Bool -> Query -> Bool queryIsStartDateOnly _ Any = False queryIsStartDateOnly _ None = False -queryIsStartDateOnly secondary (Or ms) = and $ map (queryIsStartDateOnly secondary) ms -queryIsStartDateOnly secondary (And ms) = and $ map (queryIsStartDateOnly secondary) ms +queryIsStartDateOnly secondary (Or ms) = all (queryIsStartDateOnly secondary) ms +queryIsStartDateOnly secondary (And ms) = all (queryIsStartDateOnly secondary) ms queryIsStartDateOnly False (Date (DateSpan (Just _) _)) = True queryIsStartDateOnly True (Date2 (DateSpan (Just _) _)) = True queryIsStartDateOnly _ _ = False @@ -613,7 +613,7 @@ matchesPosting (Real v) p = v == isReal p matchesPosting q@(Depth _) Posting{paccount=a} = q `matchesAccount` a matchesPosting q@(Amt _ _) Posting{pamount=as} = q `matchesMixedAmount` as -matchesPosting (Sym r) Posting{pamount=as} = any (matchesCommodity (Sym r)) . map acommodity $ amountsRaw as +matchesPosting (Sym r) Posting{pamount=as} = any (matchesCommodity (Sym r) . acommodity) $ amountsRaw as matchesPosting (Tag n v) p = case (reString n, v) of ("payee", Just v) -> maybe False (regexMatchText v . transactionPayee) $ ptransaction p ("note", Just v) -> maybe False (regexMatchText v . transactionNote) $ ptransaction p @@ -666,11 +666,11 @@ -- XXX Currently an alias for matchDescription. I'm not sure if more is needed, -- There's some shenanigan with payee: and "payeeTag" to figure out. matchesPayeeWIP :: Query -> Payee -> Bool -matchesPayeeWIP q p = matchesDescription q p +matchesPayeeWIP = matchesDescription -- | Does the query match the name and optionally the value of any of these tags ? matchesTags :: Regexp -> Maybe Regexp -> [Tag] -> Bool -matchesTags namepat valuepat = not . null . filter (matches namepat valuepat) +matchesTags namepat valuepat = any (matches namepat valuepat) where matches npat vpat (n,v) = regexMatchText npat n && maybe (const True) regexMatchText vpat v @@ -688,8 +688,8 @@ -- tests -tests_Query = tests "Query" [ - test "simplifyQuery" $ do +tests_Query = testGroup "Query" [ + testCase "simplifyQuery" $ do (simplifyQuery $ Or [Acct $ toRegex' "a"]) @?= (Acct $ toRegex' "a") (simplifyQuery $ Or [Any,None]) @?= (Any) (simplifyQuery $ And [Any,None]) @?= (None) @@ -700,7 +700,7 @@ @?= (Date (DateSpan (Just $ fromGregorian 2012 01 01) (Just $ fromGregorian 2013 01 01))) (simplifyQuery $ And [Or [],Or [Desc $ toRegex' "b b"]]) @?= (Desc $ toRegex' "b b") - ,test "parseQuery" $ do + ,testCase "parseQuery" $ do (parseQuery nulldate "acct:'expenses:autres d\233penses' desc:b") @?= Right (And [Acct $ toRegexCI' "expenses:autres d\233penses", Desc $ toRegexCI' "b"], []) parseQuery nulldate "inacct:a desc:\"b b\"" @?= Right (Desc $ toRegexCI' "b b", [QueryOptInAcct "a"]) parseQuery nulldate "inacct:a inacct:b" @?= Right (Any, [QueryOptInAcct "a", QueryOptInAcct "b"]) @@ -708,7 +708,7 @@ parseQuery nulldate "'a a' 'b" @?= Right (Or [Acct $ toRegexCI' "a a",Acct $ toRegexCI' "'b"], []) parseQuery nulldate "\"" @?= Right (Acct $ toRegexCI' "\"", []) - ,test "words''" $ do + ,testCase "words''" $ do (words'' [] "a b") @?= ["a","b"] (words'' [] "'a b'") @?= ["a b"] (words'' [] "not:a b") @?= ["not:a","b"] @@ -718,13 +718,13 @@ (words'' prefixes "\"acct:expenses:autres d\233penses\"") @?= ["acct:expenses:autres d\233penses"] (words'' prefixes "\"") @?= ["\""] - ,test "filterQuery" $ do + ,testCase "filterQuery" $ do filterQuery queryIsDepth Any @?= Any filterQuery queryIsDepth (Depth 1) @?= Depth 1 filterQuery (not.queryIsDepth) (And [And [StatusQ Cleared,Depth 1]]) @?= StatusQ Cleared filterQuery queryIsDepth (And [Date nulldatespan, Not (Or [Any, Depth 1])]) @?= Any -- XXX unclear - ,test "parseQueryTerm" $ do + ,testCase "parseQueryTerm" $ do parseQueryTerm nulldate "a" @?= Right (Left $ Acct $ toRegexCI' "a") parseQueryTerm nulldate "acct:expenses:autres d\233penses" @?= Right (Left $ Acct $ toRegexCI' "expenses:autres d\233penses") parseQueryTerm nulldate "not:desc:a b" @?= Right (Left $ Not $ Desc $ toRegexCI' "a b") @@ -745,7 +745,7 @@ parseQueryTerm nulldate "amt:<0" @?= Right (Left $ Amt Lt 0) parseQueryTerm nulldate "amt:>10000.10" @?= Right (Left $ Amt AbsGt 10000.1) - ,test "parseAmountQueryTerm" $ do + ,testCase "parseAmountQueryTerm" $ do parseAmountQueryTerm "<0" @?= Right (Lt,0) -- special case for convenience, since AbsLt 0 would be always false parseAmountQueryTerm ">0" @?= Right (Gt,0) -- special case for convenience and consistency with above parseAmountQueryTerm " > - 0 " @?= Right (Gt,0) -- accept whitespace around the argument parts @@ -757,7 +757,7 @@ assertLeft $ parseAmountQueryTerm "-0,23" assertLeft $ parseAmountQueryTerm "=.23" - ,test "queryStartDate" $ do + ,testCase "queryStartDate" $ do let small = Just $ fromGregorian 2000 01 01 big = Just $ fromGregorian 2000 01 02 queryStartDate False (And [Date $ DateSpan small Nothing, Date $ DateSpan big Nothing]) @?= big @@ -765,7 +765,7 @@ queryStartDate False (Or [Date $ DateSpan small Nothing, Date $ DateSpan big Nothing]) @?= small queryStartDate False (Or [Date $ DateSpan small Nothing, Date $ DateSpan Nothing Nothing]) @?= Nothing - ,test "queryEndDate" $ do + ,testCase "queryEndDate" $ do let small = Just $ fromGregorian 2000 01 01 big = Just $ fromGregorian 2000 01 02 queryEndDate False (And [Date $ DateSpan Nothing small, Date $ DateSpan Nothing big]) @?= small @@ -773,7 +773,7 @@ queryEndDate False (Or [Date $ DateSpan Nothing small, Date $ DateSpan Nothing big]) @?= big queryEndDate False (Or [Date $ DateSpan Nothing small, Date $ DateSpan Nothing Nothing]) @?= Nothing - ,test "matchesAccount" $ do + ,testCase "matchesAccount" $ do assertBool "" $ (Acct $ toRegex' "b:c") `matchesAccount` "a:bb:c:d" assertBool "" $ not $ (Acct $ toRegex' "^a:b") `matchesAccount` "c:a:b" assertBool "" $ Depth 2 `matchesAccount` "a" @@ -783,22 +783,22 @@ assertBool "" $ Date2 nulldatespan `matchesAccount` "a" assertBool "" $ not $ Tag (toRegex' "a") Nothing `matchesAccount` "a" - ,tests "matchesPosting" [ - test "positive match on cleared posting status" $ + ,testGroup "matchesPosting" [ + testCase "positive match on cleared posting status" $ assertBool "" $ (StatusQ Cleared) `matchesPosting` nullposting{pstatus=Cleared} - ,test "negative match on cleared posting status" $ + ,testCase "negative match on cleared posting status" $ assertBool "" $ not $ (Not $ StatusQ Cleared) `matchesPosting` nullposting{pstatus=Cleared} - ,test "positive match on unmarked posting status" $ + ,testCase "positive match on unmarked posting status" $ assertBool "" $ (StatusQ Unmarked) `matchesPosting` nullposting{pstatus=Unmarked} - ,test "negative match on unmarked posting status" $ + ,testCase "negative match on unmarked posting status" $ assertBool "" $ not $ (Not $ StatusQ Unmarked) `matchesPosting` nullposting{pstatus=Unmarked} - ,test "positive match on true posting status acquired from transaction" $ + ,testCase "positive match on true posting status acquired from transaction" $ assertBool "" $ (StatusQ Cleared) `matchesPosting` nullposting{pstatus=Unmarked,ptransaction=Just nulltransaction{tstatus=Cleared}} - ,test "real:1 on real posting" $ assertBool "" $ (Real True) `matchesPosting` nullposting{ptype=RegularPosting} - ,test "real:1 on virtual posting fails" $ assertBool "" $ not $ (Real True) `matchesPosting` nullposting{ptype=VirtualPosting} - ,test "real:1 on balanced virtual posting fails" $ assertBool "" $ not $ (Real True) `matchesPosting` nullposting{ptype=BalancedVirtualPosting} - ,test "acct:" $ assertBool "" $ (Acct $ toRegex' "'b") `matchesPosting` nullposting{paccount="'b"} - ,test "tag:" $ do + ,testCase "real:1 on real posting" $ assertBool "" $ (Real True) `matchesPosting` nullposting{ptype=RegularPosting} + ,testCase "real:1 on virtual posting fails" $ assertBool "" $ not $ (Real True) `matchesPosting` nullposting{ptype=VirtualPosting} + ,testCase "real:1 on balanced virtual posting fails" $ assertBool "" $ not $ (Real True) `matchesPosting` nullposting{ptype=BalancedVirtualPosting} + ,testCase "acct:" $ assertBool "" $ (Acct $ toRegex' "'b") `matchesPosting` nullposting{paccount="'b"} + ,testCase "tag:" $ do assertBool "" $ not $ (Tag (toRegex' "a") (Just $ toRegex' "r$")) `matchesPosting` nullposting assertBool "" $ (Tag (toRegex' "foo") Nothing) `matchesPosting` nullposting{ptags=[("foo","")]} assertBool "" $ (Tag (toRegex' "foo") Nothing) `matchesPosting` nullposting{ptags=[("foo","baz")]} @@ -806,16 +806,16 @@ assertBool "" $ not $ (Tag (toRegex' "foo") (Just $ toRegex' "a$")) `matchesPosting` nullposting{ptags=[("foo","bar")]} assertBool "" $ not $ (Tag (toRegex' " foo ") (Just $ toRegex' "a")) `matchesPosting` nullposting{ptags=[("foo","bar")]} assertBool "" $ not $ (Tag (toRegex' "foo foo") (Just $ toRegex' " ar ba ")) `matchesPosting` nullposting{ptags=[("foo foo","bar bar")]} - ,test "a tag match on a posting also sees inherited tags" $ assertBool "" $ (Tag (toRegex' "txntag") Nothing) `matchesPosting` nullposting{ptransaction=Just nulltransaction{ttags=[("txntag","")]}} - ,test "cur:" $ do - let toSym = either id (const $ error' "No query opts") . either error' id . parseQueryTerm (fromGregorian 2000 01 01) . ("cur:"<>) + ,testCase "a tag match on a posting also sees inherited tags" $ assertBool "" $ (Tag (toRegex' "txntag") Nothing) `matchesPosting` nullposting{ptransaction=Just nulltransaction{ttags=[("txntag","")]}} + ,testCase "cur:" $ do + let toSym = fromLeft (error' "No query opts") . either error' id . parseQueryTerm (fromGregorian 2000 01 01) . ("cur:"<>) assertBool "" $ not $ toSym "$" `matchesPosting` nullposting{pamount=mixedAmount $ usd 1} -- becomes "^$$", ie testing for null symbol assertBool "" $ (toSym "\\$") `matchesPosting` nullposting{pamount=mixedAmount $ usd 1} -- have to quote $ for regexpr assertBool "" $ (toSym "shekels") `matchesPosting` nullposting{pamount=mixedAmount nullamt{acommodity="shekels"}} assertBool "" $ not $ (toSym "shek") `matchesPosting` nullposting{pamount=mixedAmount nullamt{acommodity="shekels"}} ] - ,test "matchesTransaction" $ do + ,testCase "matchesTransaction" $ do assertBool "" $ Any `matchesTransaction` nulltransaction assertBool "" $ not $ (Desc $ toRegex' "x x") `matchesTransaction` nulltransaction{tdescription="x"} assertBool "" $ (Desc $ toRegex' "x x") `matchesTransaction` nulltransaction{tdescription="x x"} diff --git a/Hledger/Read.hs b/Hledger/Read.hs --- a/Hledger/Read.hs +++ b/Hledger/Read.hs @@ -32,10 +32,12 @@ readJournal', -- * Re-exported - JournalReader.postingp, + JournalReader.tmpostingrulep, findReader, splitReaderPrefix, + runJournalParser, module Hledger.Read.Common, + module Hledger.Read.InputOptions, -- * Tests tests_Read, @@ -45,7 +47,7 @@ --- ** imports import Control.Arrow (right) import qualified Control.Exception as C -import Control.Monad (when) +import Control.Monad (unless, when) import "mtl" Control.Monad.Except (runExceptT) import Data.Default (def) import Data.Foldable (asum) @@ -69,6 +71,7 @@ import Hledger.Data.Dates (getCurrentDay, parsedateM, showDate) import Hledger.Data.Types import Hledger.Read.Common +import Hledger.Read.InputOptions import Hledger.Read.JournalReader as JournalReader import Hledger.Read.CsvReader (tests_CsvReader) -- import Hledger.Read.TimedotReader (tests_TimedotReader) @@ -89,7 +92,7 @@ -- | Read a Journal from the given text, assuming journal format; or -- throw an error. readJournal' :: Text -> IO Journal -readJournal' t = readJournal def Nothing t >>= either error' return -- PARTIAL: +readJournal' t = readJournal definputopts Nothing t >>= either error' return -- PARTIAL: -- | @readJournal iopts mfile txt@ -- @@ -115,7 +118,7 @@ -- | Read the default journal file specified by the environment, or raise an error. defaultJournal :: IO Journal -defaultJournal = defaultJournalPath >>= readJournalFile def >>= either error' return -- PARTIAL: +defaultJournal = defaultJournalPath >>= readJournalFile definputopts >>= either error' return -- PARTIAL: -- | Get the default journal file path specified by the environment. -- Like ledger, we look first for the LEDGER_FILE environment @@ -190,7 +193,7 @@ requireJournalFileExists "-" = return () requireJournalFileExists f = do exists <- doesFileExist f - when (not exists) $ do -- XXX might not be a journal file + unless exists $ do -- XXX might not be a journal file hPutStr stderr $ "The hledger journal file \"" <> f <> "\" was not found.\n" hPutStr stderr "Please create it first, eg with \"hledger add\" or a text editor.\n" hPutStr stderr "Or, specify an existing journal file with -f or LEDGER_FILE.\n" @@ -205,7 +208,7 @@ hPutStr stderr $ "Part of file path \"" <> show f <> "\"\n ends with a dot, which is unsafe on Windows; please use a different path.\n" exitFailure exists <- doesFileExist f - when (not exists) $ do + unless exists $ do hPutStr stderr $ "Creating hledger journal file " <> show f <> ".\n" -- note Hledger.Utils.UTF8.* do no line ending conversion on windows, -- we currently require unix line endings on all platforms. @@ -214,11 +217,7 @@ -- | Does any part of this path contain non-. characters and end with a . ? -- Such paths are not safe to use on Windows (cf #1056). isWindowsUnsafeDotPath :: FilePath -> Bool -isWindowsUnsafeDotPath = - not . null . - filter (not . all (=='.')) . - filter ((=='.').last) . - splitDirectories +isWindowsUnsafeDotPath = any (\x -> last x == '.' && any (/='.') x) . splitDirectories -- | Give the content for a new auto-created journal file. newJournalContent :: IO Text @@ -285,7 +284,7 @@ --- ** tests -tests_Read = tests "Read" [ +tests_Read = testGroup "Read" [ tests_Common ,tests_CsvReader ,tests_JournalReader diff --git a/Hledger/Read/Common.hs b/Hledger/Read/Common.hs --- a/Hledger/Read/Common.hs +++ b/Hledger/Read/Common.hs @@ -29,20 +29,12 @@ --- ** exports module Hledger.Read.Common ( Reader (..), - InputOpts (..), + InputOpts(..), + HasInputOpts(..), definputopts, rawOptsToInputOpts, - forecastPeriodFromRawOpts, -- * parsing utilities - runTextParser, - rtp, - runJournalParser, - rjp, - runErroringJournalParser, - rejp, - genericSourcePos, - journalSourcePos, parseAndFinaliseJournal, parseAndFinaliseJournal', journalFinalise, @@ -89,6 +81,7 @@ amountp, amountp', mamountp', + amountpwithmultiplier, commoditysymbolp, priceamountp, balanceassertionp, @@ -135,11 +128,9 @@ import Data.Bifunctor (bimap, second) import Data.Char (digitToInt, isDigit, isSpace) import Data.Decimal (DecimalRaw (Decimal), Decimal) -import Data.Default (Default(..)) import Data.Either (lefts, rights) import Data.Function ((&)) import Data.Functor ((<&>)) -import Data.Functor.Identity (Identity) import "base-compat-batteries" Data.List.Compat import Data.List.NonEmpty (NonEmpty(..)) import Data.Maybe (catMaybes, fromMaybe, isJust, listToMaybe) @@ -147,22 +138,22 @@ import qualified Data.Semigroup as Sem import Data.Text (Text) import qualified Data.Text as T -import Data.Time.Calendar (Day, addDays, fromGregorianValid, toGregorian) +import Data.Time.Calendar (Day, fromGregorianValid, toGregorian) +import Data.Time.Clock.POSIX (getPOSIXTime) import Data.Time.LocalTime (LocalTime(..), TimeOfDay(..)) import Data.Word (Word8) -import System.Time (getClockTime) import Text.Megaparsec import Text.Megaparsec.Char (char, char', digitChar, newline, string) import Text.Megaparsec.Char.Lexer (decimal) import Text.Megaparsec.Custom - (FinalParseError, attachSource, customErrorBundlePretty, - finalErrorBundlePretty, parseErrorAt, parseErrorAtRegion) + (attachSource, customErrorBundlePretty, finalErrorBundlePretty, parseErrorAt, parseErrorAtRegion) import Hledger.Data -import Hledger.Query (Query(..), filterQuery, parseQueryTerm, queryEndDate, queryIsDate, simplifyQuery) +import Hledger.Query (Query(..), filterQuery, parseQueryTerm, queryEndDate, queryStartDate, queryIsDate, simplifyQuery) import Hledger.Reports.ReportOptions (ReportOpts(..), queryFromFlags, rawOptsToReportOpts) import Hledger.Utils import Text.Printf (printf) +import Hledger.Read.InputOptions --- ** doctest setup -- $setup @@ -196,50 +187,23 @@ instance Show (Reader m) where show r = rFormat r ++ " reader" --- $setup - --- | Various options to use when reading journal files. --- Similar to CliOptions.inputflags, simplifies the journal-reading functions. -data InputOpts = InputOpts { - -- files_ :: [FilePath] - mformat_ :: Maybe StorageFormat -- ^ a file/storage format to try, unless overridden - -- by a filename prefix. Nothing means try all. - ,mrules_file_ :: Maybe FilePath -- ^ a conversion rules file to use (when reading CSV) - ,aliases_ :: [String] -- ^ account name aliases to apply - ,anon_ :: Bool -- ^ do light anonymisation/obfuscation of the data - ,new_ :: Bool -- ^ read only new transactions since this file was last read - ,new_save_ :: Bool -- ^ save latest new transactions state for next time - ,pivot_ :: String -- ^ use the given field's value as the account name - ,forecast_ :: Maybe DateSpan -- ^ span in which to generate forecast transactions - ,auto_ :: Bool -- ^ generate automatic postings when journal is parsed - ,balancingopts_ :: BalancingOpts -- ^ options for balancing transactions - ,strict_ :: Bool -- ^ do extra error checking (eg, all posted accounts are declared, no prices are inferred) - } deriving (Show) +-- | Parse an InputOpts from a RawOpts and a provided date. +-- This will fail with a usage error if the forecast period expression cannot be parsed. +rawOptsToInputOpts :: Day -> RawOpts -> InputOpts +rawOptsToInputOpts day rawopts = -instance Default InputOpts where def = definputopts + let noinferprice = boolopt "strict" rawopts || stringopt "args" rawopts == "balancednoautoconversion" -definputopts :: InputOpts -definputopts = InputOpts - { mformat_ = Nothing - , mrules_file_ = Nothing - , aliases_ = [] - , anon_ = False - , new_ = False - , new_save_ = True - , pivot_ = "" - , forecast_ = Nothing - , auto_ = False - , balancingopts_ = def - , strict_ = False - } + -- Do we really need to do all this work just to get the requested end date? This is duplicating + -- much of reportOptsToSpec. + ropts = rawOptsToReportOpts day rawopts + argsquery = lefts . rights . map (parseQueryTerm day) $ querystring_ ropts + datequery = simplifyQuery . filterQuery queryIsDate . And $ queryFromFlags ropts : argsquery --- | Parse an InputOpts from a RawOpts and the current date. --- This will fail with a usage error if the forecast period expression cannot be parsed. -rawOptsToInputOpts :: RawOpts -> IO InputOpts -rawOptsToInputOpts rawopts = do - d <- getCurrentDay + commodity_styles = either err id $ commodityStyleFromRawOpts rawopts + where err e = error' $ "could not parse commodity-style: '" ++ e ++ "'" -- PARTIAL: - return InputOpts{ + in InputOpts{ -- files_ = listofstringopt "file" rawopts mformat_ = Nothing ,mrules_file_ = maybestringopt "rules-file" rawopts @@ -248,77 +212,52 @@ ,new_ = boolopt "new" rawopts ,new_save_ = True ,pivot_ = stringopt "pivot" rawopts - ,forecast_ = forecastPeriodFromRawOpts d rawopts + ,forecast_ = forecastPeriodFromRawOpts day rawopts + ,reportspan_ = DateSpan (queryStartDate False datequery) (queryEndDate False datequery) ,auto_ = boolopt "auto" rawopts - ,balancingopts_ = def{ ignore_assertions_ = boolopt "ignore-assertions" rawopts - , infer_prices_ = not noinferprice + ,balancingopts_ = defbalancingopts{ + ignore_assertions_ = boolopt "ignore-assertions" rawopts + , infer_transaction_prices_ = not noinferprice + , commodity_styles_ = Just commodity_styles } ,strict_ = boolopt "strict" rawopts + ,_ioDay = day } - where noinferprice = boolopt "strict" rawopts || stringopt "args" rawopts == "balancednoautoconversion" --- | Get period expression from --forecast option. --- This will fail with a usage error if the forecast period expression cannot be parsed. +-- | Get the date span from --forecast's PERIODEXPR argument, if any. +-- This will fail with a usage error if the period expression cannot be parsed, +-- or if it contains a report interval. forecastPeriodFromRawOpts :: Day -> RawOpts -> Maybe DateSpan -forecastPeriodFromRawOpts d rawopts = case maybestringopt "forecast" rawopts of - Nothing -> Nothing - Just "" -> Just forecastspanDefault - Just str -> either (\e -> usageError $ "could not parse forecast period : "++customErrorBundlePretty e) - (\(_,requestedspan) -> Just $ requestedspan `spanDefaultsFrom` forecastspanDefault) $ - parsePeriodExpr d $ stripquotes $ T.pack str +forecastPeriodFromRawOpts d rawopts = do + arg <- maybestringopt "forecast" rawopts + let period = parsePeriodExpr d . stripquotes $ T.pack arg + return $ if null arg then nulldatespan else either badParse (getSpan arg) period where - -- "They end on or before the specified report end date, or 180 days from today if unspecified." - mspecifiedend = dbg2 "specifieddates" $ queryEndDate False datequery - forecastendDefault = dbg2 "forecastendDefault" $ addDays 180 d - forecastspanDefault = DateSpan Nothing $ mspecifiedend <|> Just forecastendDefault - -- Do we really need to do all this work just to get the requested end date? This is duplicating - -- much of reportOptsToSpec. - ropts = rawOptsToReportOpts d rawopts - argsquery = lefts . rights . map (parseQueryTerm d) $ querystring_ ropts - datequery = simplifyQuery . filterQuery queryIsDate . And $ queryFromFlags ropts : argsquery - ---- ** parsing utilities - --- | Run a text parser in the identity monad. See also: parseWithState. -runTextParser, rtp - :: TextParser Identity a -> Text -> Either (ParseErrorBundle Text CustomErr) a -runTextParser p t = runParser p "" t -rtp = runTextParser - --- | Run a journal parser in some monad. See also: parseWithState. -runJournalParser, rjp - :: Monad m - => JournalParser m a -> Text -> m (Either (ParseErrorBundle Text CustomErr) a) -runJournalParser p t = runParserT (evalStateT p nulljournal) "" t -rjp = runJournalParser - --- | Run an erroring journal parser in some monad. See also: parseWithState. -runErroringJournalParser, rejp - :: Monad m - => ErroringJournalParser m a - -> Text - -> m (Either FinalParseError (Either (ParseErrorBundle Text CustomErr) a)) -runErroringJournalParser p t = - runExceptT $ runParserT (evalStateT p nulljournal) "" t -rejp = runErroringJournalParser - -genericSourcePos :: SourcePos -> GenericSourcePos -genericSourcePos p = GenericSourcePos (sourceName p) (unPos $ sourceLine p) (unPos $ sourceColumn p) - --- | Construct a generic start & end line parse position from start and end megaparsec SourcePos's. -journalSourcePos :: SourcePos -> SourcePos -> GenericSourcePos -journalSourcePos p p' = JournalSourcePos (sourceName p) (unPos $ sourceLine p, line') - where line' | (unPos $ sourceColumn p') == 1 = unPos (sourceLine p') - 1 - | otherwise = unPos $ sourceLine p' -- might be at end of file withat last new-line + badParse e = usageError $ "could not parse forecast period : "++customErrorBundlePretty e + getSpan arg (interval, requestedspan) = case interval of + NoInterval -> requestedspan + _ -> usageError $ "--forecast's argument should not contain a report interval (" + ++ show interval ++ " in \"" ++ arg ++ "\")" +-- | Given the name of the option and the raw options, returns either +-- | * a map of successfully parsed commodity styles, if all options where successfully parsed +-- | * the first option which failed to parse, if one or more options failed to parse +commodityStyleFromRawOpts :: RawOpts -> Either String (M.Map CommoditySymbol AmountStyle) +commodityStyleFromRawOpts rawOpts = + foldM (\r -> fmap (\(c,a) -> M.insert c a r) . parseCommodity) mempty optList + where + optList = listofstringopt "commodity-style" rawOpts + parseCommodity optStr = case amountp'' optStr of + Left _ -> Left optStr + Right (Amount acommodity _ astyle _) -> Right (acommodity, astyle) -- | Given a parser to ParsedJournal, input options, file path and -- content: run the parser on the content, and finalise the result to -- get a Journal; or throw an error. parseAndFinaliseJournal :: ErroringJournalParser IO ParsedJournal -> InputOpts -> FilePath -> Text -> ExceptT String IO Journal parseAndFinaliseJournal parser iopts f txt = do - y <- liftIO getCurrentYear - let initJournal = nulljournal{ jparsedefaultyear = Just y, jincludefilestack = [f] } + let y = first3 . toGregorian $ _ioDay iopts + initJournal = nulljournal{ jparsedefaultyear = Just y, jincludefilestack = [f] } eep <- liftIO $ runExceptT $ runParserT (evalStateT parser initJournal) f txt -- TODO: urgh.. clean this up somehow case eep of @@ -334,15 +273,15 @@ parseAndFinaliseJournal' :: JournalParser IO ParsedJournal -> InputOpts -> FilePath -> Text -> ExceptT String IO Journal parseAndFinaliseJournal' parser iopts f txt = do - y <- liftIO getCurrentYear - let initJournal = nulljournal + let y = first3 . toGregorian $ _ioDay iopts + initJournal = nulljournal { jparsedefaultyear = Just y , jincludefilestack = [f] } ep <- liftIO $ runParserT (evalStateT parser initJournal) f txt -- see notes above case ep of Left e -> throwError $ customErrorBundlePretty e - Right pj -> + Right pj -> -- apply any command line account aliases. Can fail with a bad replacement pattern. case journalApplyAliases (aliasesFromOpts iopts) pj of Left e -> throwError e @@ -365,12 +304,11 @@ -- - infer transaction-implied market prices from transaction prices -- journalFinalise :: InputOpts -> FilePath -> Text -> ParsedJournal -> ExceptT String IO Journal -journalFinalise InputOpts{forecast_,auto_,balancingopts_,strict_} f txt pj = do - t <- liftIO getClockTime - d <- liftIO getCurrentDay +journalFinalise iopts@InputOpts{auto_,balancingopts_,strict_} f txt pj = do + t <- liftIO getPOSIXTime -- Infer and apply canonical styles for each commodity (or throw an error). -- This affects transaction balancing/assertions/assignments, so needs to be done early. - liftEither $ checkAddAndBalance d <=< journalApplyCommodityStyles $ + liftEither $ checkAddAndBalance (_ioDay iopts) <=< journalApplyCommodityStyles $ pj{jglobalcommoditystyles=fromMaybe mempty $ commodity_styles_ balancingopts_} -- save any global commodity styles & journalAddFile (f, txt) -- save the main file's info & journalSetLastReadTime t -- save the last read time @@ -384,7 +322,7 @@ journalCheckCommoditiesDeclared j -- Add forecast transactions if enabled - journalAddForecast d forecast_ j + journalAddForecast (forecastPeriod iopts j) j -- Add auto postings if enabled & (if auto_ && not (null $ jtxnmodifiers j) then journalAddAutoPostings d balancingopts_ else pure) -- Balance all transactions and maybe check balance assertions. @@ -400,16 +338,15 @@ -- (Note adding auto postings after balancing means #893b fails; -- adding them before balancing probably means #893a, #928, #938 fail.) >=> journalModifyTransactions d - >=> journalApplyCommodityStyles -- | Generate periodic transactions from all periodic transaction rules in the journal. -- These transactions are added to the in-memory Journal (but not the on-disk file). -- -- The start & end date for generated periodic transactions are determined in -- a somewhat complicated way; see the hledger manual -> Periodic transactions. -journalAddForecast :: Day -> Maybe DateSpan -> Journal -> Journal -journalAddForecast _ Nothing j = j -journalAddForecast d (Just requestedspan) j = j{jtxns = jtxns j ++ forecasttxns} +journalAddForecast :: Maybe DateSpan -> Journal -> Journal +journalAddForecast Nothing j = j +journalAddForecast (Just forecastspan) j = j{jtxns = jtxns j ++ forecasttxns} where forecasttxns = map (txnTieKnot . transactionTransformPostings (postingApplyCommodityStyles $ journalCommodityStyles j)) @@ -417,14 +354,6 @@ . concatMap (`runPeriodicTransaction` forecastspan) $ jperiodictxns j - -- "They can start no earlier than: the day following the latest normal transaction in the journal (or today if there are none)." - mjournalend = dbg2 "journalEndDate" $ journalEndDate False j -- ignore secondary dates - forecastbeginDefault = dbg2 "forecastbeginDefault" $ mjournalend <|> Just d - - -- "They end on or before the specified report end date, or 180 days from today if unspecified." - forecastspan = dbg2 "forecastspan" $ dbg2 "forecastspan flag" requestedspan - `spanDefaultsFrom` DateSpan forecastbeginDefault (Just $ addDays 180 d) - -- | Check that all the journal's transactions have payees declared with -- payee directives, returning an error message otherwise. journalCheckPayeesDeclared :: Journal -> Either String () @@ -435,7 +364,7 @@ | otherwise = Left $ printf "undeclared payee \"%s\"\nat: %s\n\n%s" (T.unpack p) - (showGenericSourcePos $ tsourcepos t) + (showSourcePosPair $ tsourcepos t) (linesPrepend2 "> " " " . (<>"\n") . textChomp $ showTransaction t) where p = transactionPayee t @@ -453,7 +382,7 @@ ++ case ptransaction of Nothing -> "" Just t -> printf "in transaction at: %s\n\n%s" - (showGenericSourcePos $ tsourcepos t) + (showSourcePosPair $ tsourcepos t) (linesPrepend " " . (<>"\n") . textChomp $ showTransaction t) where as = journalAccountNamesDeclared j @@ -472,7 +401,7 @@ ++ case ptransaction of Nothing -> "" Just t -> printf "in transaction at: %s\n\n%s" - (showGenericSourcePos $ tsourcepos t) + (showSourcePosPair $ tsourcepos t) (linesPrepend " " . (<>"\n") . textChomp $ showTransaction t) where mfirstundeclaredcomm = @@ -818,10 +747,12 @@ -- files with any supported decimal mark, but it also allows different decimal marks -- in different amounts, which is a bit too loose. There's an open issue. amountp :: JournalParser m Amount -amountp = label "amount" $ do - let - spaces = lift $ skipNonNewlineSpaces - amount <- amountwithoutpricep <* spaces +amountp = amountpwithmultiplier False + +amountpwithmultiplier :: Bool -> JournalParser m Amount +amountpwithmultiplier mult = label "amount" $ do + let spaces = lift $ skipNonNewlineSpaces + amount <- amountwithoutpricep mult <* spaces (mprice, _elotprice, _elotdate) <- runPermutation $ (,,) <$> toPermutationWithDefault Nothing (Just <$> priceamountp amount <* spaces) <*> toPermutationWithDefault Nothing (Just <$> lotpricep <* spaces) @@ -831,20 +762,20 @@ amountpnolotpricesp :: JournalParser m Amount amountpnolotpricesp = label "amount" $ do let spaces = lift $ skipNonNewlineSpaces - amount <- amountwithoutpricep + amount <- amountwithoutpricep False spaces mprice <- optional $ priceamountp amount <* spaces pure $ amount { aprice = mprice } -amountwithoutpricep :: JournalParser m Amount -amountwithoutpricep = do - (mult, sign) <- lift $ (,) <$> multiplierp <*> signp - leftsymbolamountp mult sign <|> rightornosymbolamountp mult sign +amountwithoutpricep :: Bool -> JournalParser m Amount +amountwithoutpricep mult = do + sign <- lift signp + leftsymbolamountp sign <|> rightornosymbolamountp sign where - leftsymbolamountp :: Bool -> (Decimal -> Decimal) -> JournalParser m Amount - leftsymbolamountp mult sign = label "amount" $ do + leftsymbolamountp :: (Decimal -> Decimal) -> JournalParser m Amount + leftsymbolamountp sign = label "amount" $ do c <- lift commoditysymbolp mdecmarkStyle <- getDecimalMarkStyle mcommodityStyle <- getAmountStyle c @@ -859,10 +790,10 @@ let numRegion = (offBeforeNum, offAfterNum) (q,prec,mdec,mgrps) <- lift $ interpretNumber numRegion suggestedStyle ambiguousRawNum mExponent let s = amountstyle{ascommodityside=L, ascommodityspaced=commodityspaced, asprecision=prec, asdecimalpoint=mdec, asdigitgroups=mgrps} - return $ nullamt{acommodity=c, aquantity=sign (sign2 q), aismultiplier=mult, astyle=s, aprice=Nothing} + return nullamt{acommodity=c, aquantity=sign (sign2 q), astyle=s, aprice=Nothing} - rightornosymbolamountp :: Bool -> (Decimal -> Decimal) -> JournalParser m Amount - rightornosymbolamountp mult sign = label "amount" $ do + rightornosymbolamountp :: (Decimal -> Decimal) -> JournalParser m Amount + rightornosymbolamountp sign = label "amount" $ do offBeforeNum <- getOffset ambiguousRawNum <- lift rawnumberp mExponent <- lift $ optional $ try exponentp @@ -878,7 +809,7 @@ let msuggestedStyle = mdecmarkStyle <|> mcommodityStyle (q,prec,mdec,mgrps) <- lift $ interpretNumber numRegion msuggestedStyle ambiguousRawNum mExponent let s = amountstyle{ascommodityside=R, ascommodityspaced=commodityspaced, asprecision=prec, asdecimalpoint=mdec, asdigitgroups=mgrps} - return $ nullamt{acommodity=c, aquantity=sign q, aismultiplier=mult, astyle=s, aprice=Nothing} + return nullamt{acommodity=c, aquantity=sign q, astyle=s, aprice=Nothing} -- no symbol amount Nothing -> do -- look for a number style to use when parsing, based on @@ -895,7 +826,7 @@ let (c,s) = case (mult, defcs) of (False, Just (defc,defs)) -> (defc, defs{asprecision=max (asprecision defs) prec}) _ -> ("", amountstyle{asprecision=prec, asdecimalpoint=mdec, asdigitgroups=mgrps}) - return $ nullamt{acommodity=c, aquantity=sign q, aismultiplier=mult, astyle=s, aprice=Nothing} + return nullamt{acommodity=c, aquantity=sign q, astyle=s, aprice=Nothing} -- For reducing code duplication. Doesn't parse anything. Has the type -- of a parser only in order to throw parse errors (for convenience). @@ -912,10 +843,14 @@ uncurry parseErrorAtRegion posRegion errMsg Right (q,p,d,g) -> pure (q, Precision p, d, g) +-- | Try to parse an amount from a string +amountp'' :: String -> Either (ParseErrorBundle Text CustomErr) Amount +amountp'' s = runParser (evalStateT (amountp <* eof) nulljournal) "" (T.pack s) + -- | Parse an amount from a string, or get an error. amountp' :: String -> Amount amountp' s = - case runParser (evalStateT (amountp <* eof) nulljournal) "" (T.pack s) of + case amountp'' s of Right amt -> amt Left err -> error' $ show err -- PARTIAL: XXX should throwError @@ -928,9 +863,6 @@ signp :: Num a => TextParser m (a -> a) signp = ((char '-' *> pure negate <|> char '+' *> pure id) <* skipNonNewlineSpaces) <|> pure id -multiplierp :: TextParser m Bool -multiplierp = option False $ char '*' *> pure True - commoditysymbolp :: TextParser m CommoditySymbol commoditysymbolp = quotedcommoditysymbolp <|> simplecommoditysymbolp "commodity symbol" @@ -952,7 +884,7 @@ when parenthesised $ void $ char ')' lift skipNonNewlineSpaces - priceAmount <- amountwithoutpricep -- "unpriced amount (specifying a price)" + priceAmount <- amountwithoutpricep False -- "unpriced amount (specifying a price)" let amtsign' = signum $ aquantity baseAmt amtsign = if amtsign' == 0 then 1 else amtsign' @@ -964,7 +896,7 @@ balanceassertionp :: JournalParser m BalanceAssertion balanceassertionp = do - sourcepos <- genericSourcePos <$> lift getSourcePos + sourcepos <- getSourcePos char '=' istotal <- fmap isJust $ optional $ try $ char '=' isinclusive <- fmap isJust $ optional $ try $ char '*' @@ -989,11 +921,10 @@ doublebrace <- option False $ char '{' >> pure True _fixed <- fmap isJust $ optional $ lift skipNonNewlineSpaces >> char '=' lift skipNonNewlineSpaces - _a <- amountwithoutpricep + _a <- amountwithoutpricep False lift skipNonNewlineSpaces char '}' when (doublebrace) $ void $ char '}' - return () -- Parse a Ledger-style lot date [DATE], and ignore it. -- https://www.ledger-cli.org/3.0/doc/ledger3.html#Fixing-Lot-Prices . @@ -1048,7 +979,7 @@ -> Maybe Integer -> Either String (Quantity, Word8, Maybe Char, Maybe DigitGroupStyle) -fromRawNumber (WithSeparators _ _ _) (Just _) = +fromRawNumber (WithSeparators{}) (Just _) = Left "invalid number: digit separators and exponents may not be used together" fromRawNumber raw mExp = do (quantity, precision) <- toQuantity (fromMaybe 0 mExp) (digitGroup raw) (decimalGroup raw) @@ -1234,7 +1165,7 @@ endComment = eof <|> string "end comment" *> trailingSpaces trailingSpaces = skipNonNewlineSpaces <* newline - anyLine = void $ takeWhileP Nothing (\c -> c /= '\n') *> newline + anyLine = void $ takeWhileP Nothing (/='\n') *> newline {-# INLINABLE multilinecommentp #-} @@ -1581,12 +1512,12 @@ --- ** tests -tests_Common = tests "Common" [ +tests_Common = testGroup "Common" [ - tests "amountp" [ - test "basic" $ assertParseEq amountp "$47.18" (usd 47.18) - ,test "ends with decimal mark" $ assertParseEq amountp "$1." (usd 1 `withPrecision` Precision 0) - ,test "unit price" $ assertParseEq amountp "$10 @ €0.5" + testGroup "amountp" [ + testCase "basic" $ assertParseEq amountp "$47.18" (usd 47.18) + ,testCase "ends with decimal mark" $ assertParseEq amountp "$1." (usd 1 `withPrecision` Precision 0) + ,testCase "unit price" $ assertParseEq amountp "$10 @ €0.5" -- not precise enough: -- (usd 10 `withPrecision` 0 `at` (eur 0.5 `withPrecision` 1)) -- `withStyle` asdecimalpoint=Just '.' amount{ @@ -1600,7 +1531,7 @@ ,astyle=amountstyle{asprecision=Precision 1, asdecimalpoint=Just '.'} } } - ,test "total price" $ assertParseEq amountp "$10 @@ €5" + ,testCase "total price" $ assertParseEq amountp "$10 @@ €5" amount{ acommodity="$" ,aquantity=10 @@ -1612,12 +1543,12 @@ ,astyle=amountstyle{asprecision=Precision 0, asdecimalpoint=Nothing} } } - ,test "unit price, parenthesised" $ assertParse amountp "$10 (@) €0.5" - ,test "total price, parenthesised" $ assertParse amountp "$10 (@@) €0.5" + ,testCase "unit price, parenthesised" $ assertParse amountp "$10 (@) €0.5" + ,testCase "total price, parenthesised" $ assertParse amountp "$10 (@@) €0.5" ] ,let p = lift (numberp Nothing) :: JournalParser IO (Quantity, Word8, Maybe Char, Maybe DigitGroupStyle) in - test "numberp" $ do + testCase "numberp" $ do assertParseEq p "0" (0, 0, Nothing, Nothing) assertParseEq p "1" (1, 0, Nothing, Nothing) assertParseEq p "1.1" (1.1, 1, Just '.', Nothing) @@ -1639,11 +1570,11 @@ assertParseEq p "1.555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555" (1.555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555, 255, Just '.', Nothing) assertParseError p "1.5555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555" "" - ,tests "spaceandamountormissingp" [ - test "space and amount" $ assertParseEq spaceandamountormissingp " $47.18" (mixedAmount $ usd 47.18) - ,test "empty string" $ assertParseEq spaceandamountormissingp "" missingmixedamt - -- ,test "just space" $ assertParseEq spaceandamountormissingp " " missingmixedamt -- XXX should it ? - -- ,test "just amount" $ assertParseError spaceandamountormissingp "$47.18" "" -- succeeds, consuming nothing + ,testGroup "spaceandamountormissingp" [ + testCase "space and amount" $ assertParseEq spaceandamountormissingp " $47.18" (mixedAmount $ usd 47.18) + ,testCase "empty string" $ assertParseEq spaceandamountormissingp "" missingmixedamt + -- ,testCase "just space" $ assertParseEq spaceandamountormissingp " " missingmixedamt -- XXX should it ? + -- ,testCase "just amount" $ assertParseError spaceandamountormissingp "$47.18" "" -- succeeds, consuming nothing ] ] diff --git a/Hledger/Read/CsvReader.hs b/Hledger/Read/CsvReader.hs --- a/Hledger/Read/CsvReader.hs +++ b/Hledger/Read/CsvReader.hs @@ -41,7 +41,7 @@ import "base-compat-batteries" Prelude.Compat hiding (fail) import Control.Applicative (liftA2) import Control.Exception (IOException, handle, throw) -import Control.Monad (liftM, unless, when) +import Control.Monad (unless, when) import Control.Monad.Except (ExceptT, throwError) import qualified Control.Monad.Fail as Fail import Control.Monad.IO.Class (MonadIO, liftIO) @@ -77,7 +77,7 @@ import Hledger.Data import Hledger.Utils -import Hledger.Read.Common (aliasesFromOpts, Reader(..),InputOpts(..), amountp, statusp, genericSourcePos, journalFinalise ) +import Hledger.Read.Common (aliasesFromOpts, Reader(..), InputOpts(..), amountp, statusp, journalFinalise ) --- ** doctest setup -- $setup @@ -170,7 +170,7 @@ addAssignment a r = r{rassignments=a:rassignments r} setIndexesAndAssignmentsFromList :: [CsvFieldName] -> CsvRulesParsed -> CsvRulesParsed -setIndexesAndAssignmentsFromList fs r = addAssignmentsFromList fs . setCsvFieldIndexesFromList fs $ r +setIndexesAndAssignmentsFromList fs = addAssignmentsFromList fs . setCsvFieldIndexesFromList fs setCsvFieldIndexesFromList :: [CsvFieldName] -> CsvRulesParsed -> CsvRulesParsed setCsvFieldIndexesFromList fs r = r{rcsvfieldindexes=zip fs [1..]} @@ -223,8 +223,7 @@ -- | Parse this text as CSV conversion rules. The file path is for error messages. parseCsvRules :: FilePath -> T.Text -> Either (ParseErrorBundle T.Text CustomErr) CsvRules -- parseCsvRules rulesfile s = runParser csvrulesfile nullrules{baseAccount=takeBaseName rulesfile} rulesfile s -parseCsvRules rulesfile s = - runParser (evalStateT rulesp defrules) rulesfile s +parseCsvRules = runParser (evalStateT rulesp defrules) -- | Return the validated rules, or an error. validateRules :: CsvRules -> Either String CsvRules @@ -437,8 +436,7 @@ ,(conditionaltablep >>= modify' . addConditionalBlocks . reverse) "conditional table" ] eof - r <- get - return $ mkrules r + mkrules <$> get blankorcommentlinep :: CsvRulesParser () blankorcommentlinep = lift (dbgparse 8 "trying blankorcommentlinep") >> choiceInState [blanklinep, commentlinep] @@ -742,7 +740,7 @@ -- mfieldnames = lastMay headerlines let - -- convert CSV records to transactions + -- convert CSV records to transactions, saving the CSV line numbers for error positions txns = dbg7 "csv txns" $ snd $ mapAccumL (\pos r -> let @@ -750,7 +748,7 @@ line' = (mkPos . (+1) . unPos) line pos' = SourcePos name line' col in - (pos, transactionFromCsvRecord pos' rules r) + (pos', transactionFromCsvRecord pos rules r) ) (initialPos parsecfilename) records @@ -789,7 +787,7 @@ parseCsv :: Char -> FilePath -> Text -> IO (Either String CSV) parseCsv separator filePath csvdata = case filePath of - "-" -> liftM (parseCassava separator "(stdin)") T.getContents + "-" -> parseCassava separator "(stdin)" <$> T.getContents _ -> return $ parseCassava separator filePath csvdata parseCassava :: Char -> FilePath -> Text -> Either String CSV @@ -922,10 +920,11 @@ ] code = maybe "" singleline $ fieldval "code" description = maybe "" singleline $ fieldval "description" - comment = maybe "" singleline $ fieldval "comment" - precomment = maybe "" singleline $ fieldval "precomment" + comment = maybe "" unescapeNewlines $ fieldval "comment" + precomment = maybe "" unescapeNewlines $ fieldval "precomment" singleline = T.unwords . filter (not . T.null) . map T.strip . T.lines + unescapeNewlines = T.intercalate "\n" . T.splitOn "\\n" ---------------------------------------------------------------------- -- 3. Generate the postings for which an account has been assigned @@ -933,7 +932,7 @@ p1IsVirtual = (accountNamePostingType <$> fieldval "account1") == Just VirtualPosting ps = [p | n <- [1..maxpostings] - ,let comment = fromMaybe "" $ fieldval ("comment"<> T.pack (show n)) + ,let comment = maybe "" unescapeNewlines $ fieldval ("comment"<> T.pack (show n)) ,let currency = fromMaybe "" (fieldval ("currency"<> T.pack (show n)) <|> fieldval "currency") ,let mamount = getAmount rules record currency p1IsVirtual n ,let mbalance = getBalance rules record currency n @@ -954,7 +953,7 @@ -- 4. Build the transaction (and name it, so the postings can reference it). t = nulltransaction{ - tsourcepos = genericSourcePos sourcepos -- the CSV line number + tsourcepos = (sourcepos, sourcepos) -- the CSV line number ,tdate = date' ,tdate2 = mdate2' ,tstatus = status @@ -963,7 +962,7 @@ ,tcomment = comment ,tprecedingcomment = precomment ,tpostings = ps - } + } -- | Figure out the amount specified for posting N, if any. -- A currency symbol to prepend to the amount, if any, is provided, @@ -1002,7 +1001,7 @@ assignments' | any isnumbered assignments = filter isnumbered assignments | otherwise = assignments where - isnumbered (f,_) = T.any (flip elem ['0'..'9']) f + isnumbered (f,_) = T.any isDigit f -- if there's more than one value and only some are zeros, discard the zeros assignments'' @@ -1029,7 +1028,7 @@ -- | Figure out the expected balance (assertion or assignment) specified for posting N, -- if any (and its parse position). -getBalance :: CsvRules -> CsvRecord -> Text -> Int -> Maybe (Amount, GenericSourcePos) +getBalance :: CsvRules -> CsvRecord -> Text -> Int -> Maybe (Amount, SourcePos) getBalance rules record currency n = do v <- (fieldval ("balance"<> T.pack (show n)) -- for posting 1, also recognise the old field name @@ -1038,7 +1037,7 @@ "" -> Nothing s -> Just ( parseBalanceAmount rules record currency n s - ,nullsourcepos -- parse position to show when assertion fails, + ,initialPos "" -- parse position to show when assertion fails, ) -- XXX the csv record's line number would be good where fieldval = fmap T.strip . hledgerFieldValue rules record :: HledgerFieldName -> Maybe Text @@ -1102,7 +1101,7 @@ -- possibly set by a balance-type rule. -- The CSV rules and current record are also provided, to be shown in case -- balance-type's argument is bad (XXX refactor). -mkBalanceAssertion :: CsvRules -> CsvRecord -> (Amount, GenericSourcePos) -> BalanceAssertion +mkBalanceAssertion :: CsvRules -> CsvRecord -> (Amount, SourcePos) -> BalanceAssertion mkBalanceAssertion rules record (amt, pos) = assrt{baamount=amt, baposition=pos} where assrt = @@ -1121,7 +1120,7 @@ -- | Figure out the account name specified for posting N, if any. -- And whether it is the default unknown account (which may be -- improved later) or an explicitly set account (which may not). -getAccount :: CsvRules -> CsvRecord -> Maybe MixedAmount -> Maybe (Amount, GenericSourcePos) -> Int -> Maybe (AccountName, Bool) +getAccount :: CsvRules -> CsvRecord -> Maybe MixedAmount -> Maybe (Amount, SourcePos) -> Int -> Maybe (AccountName, Bool) getAccount rules record mamount mbalance n = let fieldval = hledgerFieldValue rules record :: HledgerFieldName -> Maybe Text @@ -1266,8 +1265,7 @@ csvFieldValue rules record fieldname = do fieldindex <- if | T.all isDigit fieldname -> readMay $ T.unpack fieldname | otherwise -> lookup (T.toLower fieldname) $ rcsvfieldindexes rules - fieldvalue <- T.strip <$> atMay record (fieldindex-1) - return fieldvalue + T.strip <$> atMay record (fieldindex-1) -- | Parse the date string using the specified date-format, or if unspecified -- the "simple date" formats (YYYY/MM/DD, YYYY-MM-DD, YYYY.MM.DD, leading @@ -1291,77 +1289,77 @@ --- ** tests -tests_CsvReader = tests "CsvReader" [ - tests "parseCsvRules" [ - test "empty file" $ +tests_CsvReader = testGroup "CsvReader" [ + testGroup "parseCsvRules" [ + testCase "empty file" $ parseCsvRules "unknown" "" @?= Right (mkrules defrules) ] - ,tests "rulesp" [ - test "trailing comments" $ + ,testGroup "rulesp" [ + testCase "trailing comments" $ parseWithState' defrules rulesp "skip\n# \n#\n" @?= Right (mkrules $ defrules{rdirectives = [("skip","")]}) - ,test "trailing blank lines" $ + ,testCase "trailing blank lines" $ parseWithState' defrules rulesp "skip\n\n \n" @?= (Right (mkrules $ defrules{rdirectives = [("skip","")]})) - ,test "no final newline" $ + ,testCase "no final newline" $ parseWithState' defrules rulesp "skip" @?= (Right (mkrules $ defrules{rdirectives=[("skip","")]})) - ,test "assignment with empty value" $ + ,testCase "assignment with empty value" $ parseWithState' defrules rulesp "account1 \nif foo\n account2 foo\n" @?= (Right (mkrules $ defrules{rassignments = [("account1","")], rconditionalblocks = [CB{cbMatchers=[RecordMatcher None (toRegex' "foo")],cbAssignments=[("account2","foo")]}]})) ] - ,tests "conditionalblockp" [ - test "space after conditional" $ -- #1120 + ,testGroup "conditionalblockp" [ + testCase "space after conditional" $ -- #1120 parseWithState' defrules conditionalblockp "if a\n account2 b\n \n" @?= (Right $ CB{cbMatchers=[RecordMatcher None $ toRegexCI' "a"],cbAssignments=[("account2","b")]}) - ,tests "csvfieldreferencep" [ - test "number" $ parseWithState' defrules csvfieldreferencep "%1" @?= (Right "%1") - ,test "name" $ parseWithState' defrules csvfieldreferencep "%date" @?= (Right "%date") - ,test "quoted name" $ parseWithState' defrules csvfieldreferencep "%\"csv date\"" @?= (Right "%\"csv date\"") + ,testGroup "csvfieldreferencep" [ + testCase "number" $ parseWithState' defrules csvfieldreferencep "%1" @?= (Right "%1") + ,testCase "name" $ parseWithState' defrules csvfieldreferencep "%date" @?= (Right "%date") + ,testCase "quoted name" $ parseWithState' defrules csvfieldreferencep "%\"csv date\"" @?= (Right "%\"csv date\"") ] - ,tests "matcherp" [ + ,testGroup "matcherp" [ - test "recordmatcherp" $ + testCase "recordmatcherp" $ parseWithState' defrules matcherp "A A\n" @?= (Right $ RecordMatcher None $ toRegexCI' "A A") - ,test "recordmatcherp.starts-with-&" $ + ,testCase "recordmatcherp.starts-with-&" $ parseWithState' defrules matcherp "& A A\n" @?= (Right $ RecordMatcher And $ toRegexCI' "A A") - ,test "fieldmatcherp.starts-with-%" $ + ,testCase "fieldmatcherp.starts-with-%" $ parseWithState' defrules matcherp "description A A\n" @?= (Right $ RecordMatcher None $ toRegexCI' "description A A") - ,test "fieldmatcherp" $ + ,testCase "fieldmatcherp" $ parseWithState' defrules matcherp "%description A A\n" @?= (Right $ FieldMatcher None "%description" $ toRegexCI' "A A") - ,test "fieldmatcherp.starts-with-&" $ + ,testCase "fieldmatcherp.starts-with-&" $ parseWithState' defrules matcherp "& %description A A\n" @?= (Right $ FieldMatcher And "%description" $ toRegexCI' "A A") - -- ,test "fieldmatcherp with operator" $ + -- ,testCase "fieldmatcherp with operator" $ -- parseWithState' defrules matcherp "%description ~ A A\n" @?= (Right $ FieldMatcher "%description" "A A") ] - ,tests "getEffectiveAssignment" [ + ,testGroup "getEffectiveAssignment" [ let rules = mkrules $ defrules {rcsvfieldindexes=[("csvdate",1)],rassignments=[("date","%csvdate")]} - in test "toplevel" $ getEffectiveAssignment rules ["a","b"] "date" @?= (Just "%csvdate") + in testCase "toplevel" $ getEffectiveAssignment rules ["a","b"] "date" @?= (Just "%csvdate") ,let rules = mkrules $ defrules{rcsvfieldindexes=[("csvdate",1)], rconditionalblocks=[CB [FieldMatcher None "%csvdate" $ toRegex' "a"] [("date","%csvdate")]]} - in test "conditional" $ getEffectiveAssignment rules ["a","b"] "date" @?= (Just "%csvdate") + in testCase "conditional" $ getEffectiveAssignment rules ["a","b"] "date" @?= (Just "%csvdate") ,let rules = mkrules $ defrules{rcsvfieldindexes=[("csvdate",1),("description",2)], rconditionalblocks=[CB [FieldMatcher None "%csvdate" $ toRegex' "a", FieldMatcher None "%description" $ toRegex' "b"] [("date","%csvdate")]]} - in test "conditional-with-or-a" $ getEffectiveAssignment rules ["a"] "date" @?= (Just "%csvdate") + in testCase "conditional-with-or-a" $ getEffectiveAssignment rules ["a"] "date" @?= (Just "%csvdate") ,let rules = mkrules $ defrules{rcsvfieldindexes=[("csvdate",1),("description",2)], rconditionalblocks=[CB [FieldMatcher None "%csvdate" $ toRegex' "a", FieldMatcher None "%description" $ toRegex' "b"] [("date","%csvdate")]]} - in test "conditional-with-or-b" $ getEffectiveAssignment rules ["_", "b"] "date" @?= (Just "%csvdate") + in testCase "conditional-with-or-b" $ getEffectiveAssignment rules ["_", "b"] "date" @?= (Just "%csvdate") ,let rules = mkrules $ defrules{rcsvfieldindexes=[("csvdate",1),("description",2)], rconditionalblocks=[CB [FieldMatcher None "%csvdate" $ toRegex' "a", FieldMatcher And "%description" $ toRegex' "b"] [("date","%csvdate")]]} - in test "conditional.with-and" $ getEffectiveAssignment rules ["a", "b"] "date" @?= (Just "%csvdate") + in testCase "conditional.with-and" $ getEffectiveAssignment rules ["a", "b"] "date" @?= (Just "%csvdate") ,let rules = mkrules $ defrules{rcsvfieldindexes=[("csvdate",1),("description",2)], rconditionalblocks=[CB [FieldMatcher None "%csvdate" $ toRegex' "a", FieldMatcher And "%description" $ toRegex' "b", FieldMatcher None "%description" $ toRegex' "c"] [("date","%csvdate")]]} - in test "conditional.with-and-or" $ getEffectiveAssignment rules ["_", "c"] "date" @?= (Just "%csvdate") + in testCase "conditional.with-and-or" $ getEffectiveAssignment rules ["_", "c"] "date" @?= (Just "%csvdate") ] diff --git a/Hledger/Read/InputOptions.hs b/Hledger/Read/InputOptions.hs new file mode 100644 --- /dev/null +++ b/Hledger/Read/InputOptions.hs @@ -0,0 +1,86 @@ +{-| + +Various options to use when reading journal files. +Similar to CliOptions.inputflags, simplifies the journal-reading functions. + +-} +{-# LANGUAGE TemplateHaskell #-} + +module Hledger.Read.InputOptions ( +-- * Types and helpers for input options + InputOpts(..) +, HasInputOpts(..) +, definputopts +, forecastPeriod +) where + +import Control.Applicative ((<|>)) +import Data.Time (Day, addDays) + +import Hledger.Data.Types +import Hledger.Data.Journal (journalEndDate) +import Hledger.Data.Dates (nulldate, nulldatespan) +import Hledger.Data.Balancing (BalancingOpts(..), HasBalancingOpts(..), defbalancingopts) +import Hledger.Utils (dbg2, makeHledgerClassyLenses) + +data InputOpts = InputOpts { + -- files_ :: [FilePath] + mformat_ :: Maybe StorageFormat -- ^ a file/storage format to try, unless overridden + -- by a filename prefix. Nothing means try all. + ,mrules_file_ :: Maybe FilePath -- ^ a conversion rules file to use (when reading CSV) + ,aliases_ :: [String] -- ^ account name aliases to apply + ,anon_ :: Bool -- ^ do light anonymisation/obfuscation of the data + ,new_ :: Bool -- ^ read only new transactions since this file was last read + ,new_save_ :: Bool -- ^ save latest new transactions state for next time + ,pivot_ :: String -- ^ use the given field's value as the account name + ,forecast_ :: Maybe DateSpan -- ^ span in which to generate forecast transactions + ,reportspan_ :: DateSpan -- ^ a dirty hack keeping the query dates in InputOpts. This rightfully lives in ReportSpec, but is duplicated here. + ,auto_ :: Bool -- ^ generate automatic postings when journal is parsed + ,balancingopts_ :: BalancingOpts -- ^ options for balancing transactions + ,strict_ :: Bool -- ^ do extra error checking (eg, all posted accounts are declared, no prices are inferred) + ,_ioDay :: Day -- ^ today's date, for use with forecast transactions XXX this duplicates _rsDay, and should eventually be removed when it's not needed anymore. + } deriving (Show) + +definputopts :: InputOpts +definputopts = InputOpts + { mformat_ = Nothing + , mrules_file_ = Nothing + , aliases_ = [] + , anon_ = False + , new_ = False + , new_save_ = True + , pivot_ = "" + , forecast_ = Nothing + , reportspan_ = nulldatespan + , auto_ = False + , balancingopts_ = defbalancingopts + , strict_ = False + , _ioDay = nulldate + } + +-- | Get the Maybe the DateSpan to generate forecast options from. +-- This begins on: +-- - the start date supplied to the `--forecast` argument, if present +-- - otherwise, the later of +-- - the report start date if specified with -b/-p/date: +-- - the day after the latest normal (non-periodic) transaction in the journal, if any +-- - otherwise today. +-- It ends on: +-- - the end date supplied to the `--forecast` argument, if present +-- - otherwise the report end date if specified with -e/-p/date: +-- - otherwise 180 days (6 months) from today. +forecastPeriod :: InputOpts -> Journal -> Maybe DateSpan +forecastPeriod iopts j = do + DateSpan requestedStart requestedEnd <- forecast_ iopts + let forecastStart = requestedStart <|> max mjournalend reportStart <|> Just (_ioDay iopts) + forecastEnd = requestedEnd <|> reportEnd <|> Just (addDays 180 $ _ioDay iopts) + mjournalend = dbg2 "journalEndDate" $ journalEndDate False j -- ignore secondary dates + DateSpan reportStart reportEnd = reportspan_ iopts + return . dbg2 "forecastspan" $ DateSpan forecastStart forecastEnd + +-- ** Lenses + +makeHledgerClassyLenses ''InputOpts + +instance HasBalancingOpts InputOpts where + balancingOpts = balancingopts diff --git a/Hledger/Read/JournalReader.hs b/Hledger/Read/JournalReader.hs --- a/Hledger/Read/JournalReader.hs +++ b/Hledger/Read/JournalReader.hs @@ -44,10 +44,11 @@ reader, -- * Parsing utils - genericSourcePos, parseAndFinaliseJournal, runJournalParser, rjp, + runErroringJournalParser, + rejp, -- * Parsers used elsewhere getParentAccount, @@ -58,7 +59,7 @@ datetimep, datep, modifiedaccountnamep, - postingp, + tmpostingrulep, statusp, emptyorcommentlinep, followingcommentp, @@ -77,7 +78,7 @@ import Control.Monad (forM_, when, void) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Except (ExceptT(..), runExceptT) -import Control.Monad.State.Strict (get,modify',put) +import Control.Monad.State.Strict (evalStateT,get,modify',put) import Control.Monad.Trans.Class (lift) import Data.Char (toLower) import Data.Either (isRight) @@ -108,7 +109,27 @@ --- ** doctest setup -- $setup -- >>> :set -XOverloadedStrings +-- +--- ** parsing utilities +-- | Run a journal parser in some monad. See also: parseWithState. +runJournalParser, rjp + :: Monad m + => JournalParser m a -> Text -> m (Either (ParseErrorBundle Text CustomErr) a) +runJournalParser p = runParserT (evalStateT p nulljournal) "" +rjp = runJournalParser + +-- | Run an erroring journal parser in some monad. See also: parseWithState. +runErroringJournalParser, rejp + :: Monad m + => ErroringJournalParser m a + -> Text + -> m (Either FinalParseError (Either (ParseErrorBundle Text CustomErr) a)) +runErroringJournalParser p t = + runExceptT $ runParserT (evalStateT p nulljournal) "" t +rejp = runErroringJournalParser + + --- ** reader finding utilities -- Defined here rather than Hledger.Read so that we can use them in includedirectivep below. @@ -341,10 +362,7 @@ -- an account type may have been set by account type code or a tag; -- the latter takes precedence let - mtypecode' :: Maybe Text = maybe - (T.singleton <$> mtypecode) - Just - $ lookup accountTypeTagName tags + mtypecode' :: Maybe Text = lookup accountTypeTagName tags <|> (T.singleton <$> mtypecode) metype = parseAccountTypeCode <$> mtypecode' -- update the journal @@ -429,7 +447,7 @@ lift skipNonNewlineSpaces _ <- lift followingcommentp let comm = Commodity{csymbol=acommodity, cformat=Just $ dbg6 "style from commodity directive" astyle} - if asdecimalpoint astyle == Nothing + if isNothing $ asdecimalpoint astyle then customFailure $ parseErrorAt off pleaseincludedecimalpoint else modify' (\j -> j{jcommodities=M.insert acommodity comm $ jcommodities j}) @@ -470,7 +488,7 @@ _ <- lift followingcommentp if acommodity==expectedsym then - if asdecimalpoint astyle == Nothing + if isNothing $ asdecimalpoint astyle then customFailure $ parseErrorAt off pleaseincludedecimalpoint else return $ dbg6 "style from format subdirective" astyle else customFailure $ parseErrorAt off $ @@ -547,7 +565,7 @@ off <- getOffset Amount{acommodity,astyle} <- amountp lift restofline - if asdecimalpoint astyle == Nothing + if isNothing $ asdecimalpoint astyle then customFailure $ parseErrorAt off pleaseincludedecimalpoint else setDefaultCommodityAndStyle (acommodity, astyle) @@ -592,8 +610,8 @@ lift skipNonNewlineSpaces querytxt <- lift $ T.strip <$> descriptionp (_comment, _tags) <- lift transactioncommentp -- TODO apply these to modified txns ? - postings <- postingsp Nothing - return $ TransactionModifier querytxt postings + postingrules <- tmpostingrulesp Nothing + return $ TransactionModifier querytxt postingrules -- | Parse a periodic transaction rule. -- @@ -677,7 +695,7 @@ let year = first3 $ toGregorian date postings <- postingsp (Just year) endpos <- getSourcePos - let sourcepos = journalSourcePos startpos endpos + let sourcepos = (startpos, endpos) return $ txnTieKnot $ Transaction 0 "" sourcepos date edate status code description comment tags postings --- *** postings @@ -695,61 +713,78 @@ -- return $ sp ++ (c:cs) ++ "\n" postingp :: Maybe Year -> JournalParser m Posting -postingp mTransactionYear = do - -- lift $ dbgparse 0 "postingp" - (status, account) <- try $ do - lift skipNonNewlineSpaces1 - status <- lift statusp +postingp = fmap fst . postingphelper False + +-- Parse the following whitespace-beginning lines as transaction posting rules, posting +-- tags, and/or comments (inferring year, if needed, from the given date). +tmpostingrulesp :: Maybe Year -> JournalParser m [TMPostingRule] +tmpostingrulesp mTransactionYear = many (tmpostingrulep mTransactionYear) "posting rules" + +tmpostingrulep :: Maybe Year -> JournalParser m TMPostingRule +tmpostingrulep = fmap (uncurry TMPostingRule) . postingphelper True + +-- Parse a Posting, and return a flag with whether a multiplier has been detected. +-- The multiplier is used in TMPostingRules. +postingphelper :: Bool -> Maybe Year -> JournalParser m (Posting, Bool) +postingphelper isPostingRule mTransactionYear = do + -- lift $ dbgparse 0 "postingp" + (status, account) <- try $ do + lift skipNonNewlineSpaces1 + status <- lift statusp + lift skipNonNewlineSpaces + account <- modifiedaccountnamep + return (status, account) + let (ptype, account') = (accountNamePostingType account, textUnbracket account) lift skipNonNewlineSpaces - account <- modifiedaccountnamep - return (status, account) - let (ptype, account') = (accountNamePostingType account, textUnbracket account) - lift skipNonNewlineSpaces - amount <- optional amountp - lift skipNonNewlineSpaces - massertion <- optional balanceassertionp - lift skipNonNewlineSpaces - (comment,tags,mdate,mdate2) <- lift $ postingcommentp mTransactionYear - return posting - { pdate=mdate - , pdate2=mdate2 - , pstatus=status - , paccount=account' - , pamount=maybe missingmixedamt mixedAmount amount - , pcomment=comment - , ptype=ptype - , ptags=tags - , pbalanceassertion=massertion - } + mult <- if isPostingRule then multiplierp else pure False + amount <- optional $ amountpwithmultiplier mult + lift skipNonNewlineSpaces + massertion <- optional balanceassertionp + lift skipNonNewlineSpaces + (comment,tags,mdate,mdate2) <- lift $ postingcommentp mTransactionYear + let p = posting + { pdate=mdate + , pdate2=mdate2 + , pstatus=status + , paccount=account' + , pamount=maybe missingmixedamt mixedAmount amount + , pcomment=comment + , ptype=ptype + , ptags=tags + , pbalanceassertion=massertion + } + return (p, mult) + where + multiplierp = option False $ True <$ char '*' --- ** tests -tests_JournalReader = tests "JournalReader" [ +tests_JournalReader = testGroup "JournalReader" [ let p = lift accountnamep :: JournalParser IO AccountName in - tests "accountnamep" [ - test "basic" $ assertParse p "a:b:c" - -- ,test "empty inner component" $ assertParseError p "a::c" "" -- TODO - -- ,test "empty leading component" $ assertParseError p ":b:c" "x" - -- ,test "empty trailing component" $ assertParseError p "a:b:" "x" + testGroup "accountnamep" [ + testCase "basic" $ assertParse p "a:b:c" + -- ,testCase "empty inner component" $ assertParseError p "a::c" "" -- TODO + -- ,testCase "empty leading component" $ assertParseError p ":b:c" "x" + -- ,testCase "empty trailing component" $ assertParseError p "a:b:" "x" ] -- "Parse a date in YYYY/MM/DD format. -- Hyphen (-) and period (.) are also allowed as separators. -- The year may be omitted if a default year has been set. -- Leading zeroes may be omitted." - ,tests "datep" [ - test "YYYY/MM/DD" $ assertParseEq datep "2018/01/01" (fromGregorian 2018 1 1) - ,test "YYYY-MM-DD" $ assertParse datep "2018-01-01" - ,test "YYYY.MM.DD" $ assertParse datep "2018.01.01" - ,test "yearless date with no default year" $ assertParseError datep "1/1" "current year is unknown" - ,test "yearless date with default year" $ do + ,testGroup "datep" [ + testCase "YYYY/MM/DD" $ assertParseEq datep "2018/01/01" (fromGregorian 2018 1 1) + ,testCase "YYYY-MM-DD" $ assertParse datep "2018-01-01" + ,testCase "YYYY.MM.DD" $ assertParse datep "2018.01.01" + ,testCase "yearless date with no default year" $ assertParseError datep "1/1" "current year is unknown" + ,testCase "yearless date with default year" $ do let s = "1/1" ep <- parseWithState nulljournal{jparsedefaultyear=Just 2018} datep s either (assertFailure . ("parse error at "++) . customErrorBundlePretty) (const $ return ()) ep - ,test "no leading zero" $ assertParse datep "2018/1/1" + ,testCase "no leading zero" $ assertParse datep "2018/1/1" ] - ,test "datetimep" $ do + ,testCase "datetimep" $ do let good = assertParse datetimep bad = (\t -> assertParseError datetimep t "") @@ -765,9 +800,9 @@ assertParseEq datetimep "2018/1/1 00:00-0800" t assertParseEq datetimep "2018/1/1 00:00+1234" t - ,tests "periodictransactionp" [ + ,testGroup "periodictransactionp" [ - test "more period text in comment after one space" $ assertParseEq periodictransactionp + testCase "more period text in comment after one space" $ assertParseEq periodictransactionp "~ monthly from 2018/6 ;In 2019 we will change this\n" nullperiodictransaction { ptperiodexpr = "monthly from 2018/6" @@ -777,7 +812,7 @@ ,ptcomment = "In 2019 we will change this\n" } - ,test "more period text in description after two spaces" $ assertParseEq periodictransactionp + ,testCase "more period text in description after two spaces" $ assertParseEq periodictransactionp "~ monthly from 2018/6 In 2019 we will change this\n" nullperiodictransaction { ptperiodexpr = "monthly from 2018/6" @@ -787,7 +822,7 @@ ,ptcomment = "" } - ,test "Next year in description" $ assertParseEq periodictransactionp + ,testCase "Next year in description" $ assertParseEq periodictransactionp "~ monthly Next year blah blah\n" nullperiodictransaction { ptperiodexpr = "monthly" @@ -797,7 +832,7 @@ ,ptcomment = "" } - ,test "Just date, no description" $ assertParseEq periodictransactionp + ,testCase "Just date, no description" $ assertParseEq periodictransactionp "~ 2019-01-04\n" nullperiodictransaction { ptperiodexpr = "2019-01-04" @@ -807,13 +842,13 @@ ,ptcomment = "" } - ,test "Just date, no description + empty transaction comment" $ assertParse periodictransactionp + ,testCase "Just date, no description + empty transaction comment" $ assertParse periodictransactionp "~ 2019-01-04\n ;\n a 1\n b\n" ] - ,tests "postingp" [ - test "basic" $ assertParseEq (postingp Nothing) + ,testGroup "postingp" [ + testCase "basic" $ assertParseEq (postingp Nothing) " expenses:food:dining $10.00 ; a: a a \n ; b: b b \n" posting{ paccount="expenses:food:dining", @@ -822,7 +857,7 @@ ptags=[("a","a a"), ("b","b b")] } - ,test "posting dates" $ assertParseEq (postingp Nothing) + ,testCase "posting dates" $ assertParseEq (postingp Nothing) " a 1. ; date:2012/11/28, date2=2012/11/29,b:b\n" nullposting{ paccount="a" @@ -833,7 +868,7 @@ ,pdate2=Nothing -- Just $ fromGregorian 2012 11 29 } - ,test "posting dates bracket syntax" $ assertParseEq (postingp Nothing) + ,testCase "posting dates bracket syntax" $ assertParseEq (postingp Nothing) " a 1. ; [2012/11/28=2012/11/29]\n" nullposting{ paccount="a" @@ -844,37 +879,37 @@ ,pdate2=Just $ fromGregorian 2012 11 29 } - ,test "quoted commodity symbol with digits" $ assertParse (postingp Nothing) " a 1 \"DE123\"\n" + ,testCase "quoted commodity symbol with digits" $ assertParse (postingp Nothing) " a 1 \"DE123\"\n" - ,test "only lot price" $ assertParse (postingp Nothing) " a 1A {1B}\n" - ,test "fixed lot price" $ assertParse (postingp Nothing) " a 1A {=1B}\n" - ,test "total lot price" $ assertParse (postingp Nothing) " a 1A {{1B}}\n" - ,test "fixed total lot price, and spaces" $ assertParse (postingp Nothing) " a 1A {{ = 1B }}\n" - ,test "lot price before transaction price" $ assertParse (postingp Nothing) " a 1A {1B} @ 1B\n" - ,test "lot price after transaction price" $ assertParse (postingp Nothing) " a 1A @ 1B {1B}\n" - ,test "lot price after balance assertion not allowed" $ assertParseError (postingp Nothing) " a 1A @ 1B = 1A {1B}\n" "unexpected '{'" - ,test "only lot date" $ assertParse (postingp Nothing) " a 1A [2000-01-01]\n" - ,test "transaction price, lot price, lot date" $ assertParse (postingp Nothing) " a 1A @ 1B {1B} [2000-01-01]\n" - ,test "lot date, lot price, transaction price" $ assertParse (postingp Nothing) " a 1A [2000-01-01] {1B} @ 1B\n" + ,testCase "only lot price" $ assertParse (postingp Nothing) " a 1A {1B}\n" + ,testCase "fixed lot price" $ assertParse (postingp Nothing) " a 1A {=1B}\n" + ,testCase "total lot price" $ assertParse (postingp Nothing) " a 1A {{1B}}\n" + ,testCase "fixed total lot price, and spaces" $ assertParse (postingp Nothing) " a 1A {{ = 1B }}\n" + ,testCase "lot price before transaction price" $ assertParse (postingp Nothing) " a 1A {1B} @ 1B\n" + ,testCase "lot price after transaction price" $ assertParse (postingp Nothing) " a 1A @ 1B {1B}\n" + ,testCase "lot price after balance assertion not allowed" $ assertParseError (postingp Nothing) " a 1A @ 1B = 1A {1B}\n" "unexpected '{'" + ,testCase "only lot date" $ assertParse (postingp Nothing) " a 1A [2000-01-01]\n" + ,testCase "transaction price, lot price, lot date" $ assertParse (postingp Nothing) " a 1A @ 1B {1B} [2000-01-01]\n" + ,testCase "lot date, lot price, transaction price" $ assertParse (postingp Nothing) " a 1A [2000-01-01] {1B} @ 1B\n" - ,test "balance assertion over entire contents of account" $ assertParse (postingp Nothing) " a $1 == $1\n" + ,testCase "balance assertion over entire contents of account" $ assertParse (postingp Nothing) " a $1 == $1\n" ] - ,tests "transactionmodifierp" [ + ,testGroup "transactionmodifierp" [ - test "basic" $ assertParseEq transactionmodifierp + testCase "basic" $ assertParseEq transactionmodifierp "= (some value expr)\n some:postings 1.\n" nulltransactionmodifier { tmquerytxt = "(some value expr)" - ,tmpostingrules = [nullposting{paccount="some:postings", pamount=mixedAmount (num 1)}] + ,tmpostingrules = [TMPostingRule nullposting{paccount="some:postings", pamount=mixedAmount (num 1)} False] } ] - ,tests "transactionp" [ + ,testGroup "transactionp" [ - test "just a date" $ assertParseEq transactionp "2015/1/1\n" nulltransaction{tdate=fromGregorian 2015 1 1} + testCase "just a date" $ assertParseEq transactionp "2015/1/1\n" nulltransaction{tdate=fromGregorian 2015 1 1} - ,test "more complex" $ assertParseEq transactionp + ,testCase "more complex" $ assertParseEq transactionp (T.unlines [ "2012/05/14=2012/05/15 (code) desc ; tcomment1", " ; tcomment2", @@ -885,7 +920,7 @@ " ; ptag2: val2" ]) nulltransaction{ - tsourcepos=JournalSourcePos "" (1,7), -- XXX why 7 here ? + tsourcepos=(SourcePos "" (mkPos 1) (mkPos 1), SourcePos "" (mkPos 8) (mkPos 1)), -- 8 because there are 7 lines tprecedingcomment="", tdate=fromGregorian 2012 5 14, tdate2=Just $ fromGregorian 2012 5 15, @@ -908,7 +943,7 @@ ] } - ,test "parses a well-formed transaction" $ + ,testCase "parses a well-formed transaction" $ assertBool "" $ isRight $ rjp transactionp $ T.unlines ["2007/01/28 coopportunity" ," expenses:food:groceries $47.18" @@ -916,10 +951,10 @@ ,"" ] - ,test "does not parse a following comment as part of the description" $ + ,testCase "does not parse a following comment as part of the description" $ assertParseEqOn transactionp "2009/1/1 a ;comment\n b 1\n" tdescription "a" - ,test "parses a following whitespace line" $ + ,testCase "parses a following whitespace line" $ assertBool "" $ isRight $ rjp transactionp $ T.unlines ["2012/1/1" ," a 1" @@ -927,7 +962,7 @@ ," " ] - ,test "parses an empty transaction comment following whitespace line" $ + ,testCase "parses an empty transaction comment following whitespace line" $ assertBool "" $ isRight $ rjp transactionp $ T.unlines ["2012/1/1" ," ;" @@ -936,7 +971,7 @@ ," " ] - ,test "comments everywhere, two postings parsed" $ + ,testCase "comments everywhere, two postings parsed" $ assertParseEqOn transactionp (T.unlines ["2009/1/1 x ; transaction comment" @@ -952,17 +987,17 @@ -- directives - ,tests "directivep" [ - test "supports !" $ do + ,testGroup "directivep" [ + testCase "supports !" $ do assertParseE directivep "!account a\n" assertParseE directivep "!D 1.0\n" ] - ,tests "accountdirectivep" [ - test "with-comment" $ assertParse accountdirectivep "account a:b ; a comment\n" - ,test "does-not-support-!" $ assertParseError accountdirectivep "!account a:b\n" "" - ,test "account-type-code" $ assertParse accountdirectivep "account a:b A\n" - ,test "account-type-tag" $ assertParseStateOn accountdirectivep "account a:b ; type:asset\n" + ,testGroup "accountdirectivep" [ + testCase "with-comment" $ assertParse accountdirectivep "account a:b ; a comment\n" + ,testCase "does-not-support-!" $ assertParseError accountdirectivep "!account a:b\n" "" + ,testCase "account-type-code" $ assertParse accountdirectivep "account a:b A\n" + ,testCase "account-type-tag" $ assertParseStateOn accountdirectivep "account a:b ; type:asset\n" jdeclaredaccounts [("a:b", AccountDeclarationInfo{adicomment = "type:asset\n" ,aditags = [("type","asset")] @@ -971,28 +1006,28 @@ ] ] - ,test "commodityconversiondirectivep" $ do + ,testCase "commodityconversiondirectivep" $ do assertParse commodityconversiondirectivep "C 1h = $50.00\n" - ,test "defaultcommoditydirectivep" $ do + ,testCase "defaultcommoditydirectivep" $ do assertParse defaultcommoditydirectivep "D $1,000.0\n" assertParseError defaultcommoditydirectivep "D $1000\n" "Please include a decimal point or decimal comma" - ,tests "defaultyeardirectivep" [ - test "1000" $ assertParse defaultyeardirectivep "Y 1000" -- XXX no \n like the others - -- ,test "999" $ assertParseError defaultyeardirectivep "Y 999" "bad year number" - ,test "12345" $ assertParse defaultyeardirectivep "Y 12345" + ,testGroup "defaultyeardirectivep" [ + testCase "1000" $ assertParse defaultyeardirectivep "Y 1000" -- XXX no \n like the others + -- ,testCase "999" $ assertParseError defaultyeardirectivep "Y 999" "bad year number" + ,testCase "12345" $ assertParse defaultyeardirectivep "Y 12345" ] - ,test "ignoredpricecommoditydirectivep" $ do + ,testCase "ignoredpricecommoditydirectivep" $ do assertParse ignoredpricecommoditydirectivep "N $\n" - ,tests "includedirectivep" [ - test "include" $ assertParseErrorE includedirectivep "include nosuchfile\n" "No existing files match pattern: nosuchfile" - ,test "glob" $ assertParseErrorE includedirectivep "include nosuchfile*\n" "No existing files match pattern: nosuchfile*" + ,testGroup "includedirectivep" [ + testCase "include" $ assertParseErrorE includedirectivep "include nosuchfile\n" "No existing files match pattern: nosuchfile" + ,testCase "glob" $ assertParseErrorE includedirectivep "include nosuchfile*\n" "No existing files match pattern: nosuchfile*" ] - ,test "marketpricedirectivep" $ assertParseEq marketpricedirectivep + ,testCase "marketpricedirectivep" $ assertParseEq marketpricedirectivep "P 2017/01/30 BTC $922.83\n" PriceDirective{ pddate = fromGregorian 2017 1 30, @@ -1000,24 +1035,24 @@ pdamount = usd 922.83 } - ,tests "payeedirectivep" [ - test "simple" $ assertParse payeedirectivep "payee foo\n" - ,test "with-comment" $ assertParse payeedirectivep "payee foo ; comment\n" + ,testGroup "payeedirectivep" [ + testCase "simple" $ assertParse payeedirectivep "payee foo\n" + ,testCase "with-comment" $ assertParse payeedirectivep "payee foo ; comment\n" ] - ,test "tagdirectivep" $ do + ,testCase "tagdirectivep" $ do assertParse tagdirectivep "tag foo \n" - ,test "endtagdirectivep" $ do + ,testCase "endtagdirectivep" $ do assertParse endtagdirectivep "end tag \n" assertParse endtagdirectivep "pop \n" - ,tests "journalp" [ - test "empty file" $ assertParseEqE journalp "" nulljournal + ,testGroup "journalp" [ + testCase "empty file" $ assertParseEqE journalp "" nulljournal ] -- these are defined here rather than in Common so they can use journalp - ,test "parseAndFinaliseJournal" $ do + ,testCase "parseAndFinaliseJournal" $ do ej <- runExceptT $ parseAndFinaliseJournal journalp definputopts "" "2019-1-1\n" let Right j = ej assertEqual "" [""] $ journalFilePaths j diff --git a/Hledger/Read/TimeclockReader.hs b/Hledger/Read/TimeclockReader.hs --- a/Hledger/Read/TimeclockReader.hs +++ b/Hledger/Read/TimeclockReader.hs @@ -119,7 +119,7 @@ -- | Parse a timeclock entry. timeclockentryp :: JournalParser m TimeclockEntry timeclockentryp = do - sourcepos <- genericSourcePos <$> lift getSourcePos + sourcepos <- getSourcePos code <- oneOf ("bhioO" :: [Char]) lift skipNonNewlineSpaces1 datetime <- datetimep diff --git a/Hledger/Read/TimedotReader.hs b/Hledger/Read/TimedotReader.hs --- a/Hledger/Read/TimedotReader.hs +++ b/Hledger/Read/TimedotReader.hs @@ -7,12 +7,12 @@ Example: @ -#DATE -#ACCT DOTS # Each dot represents 15m, spaces are ignored -#ACCT 8 # numbers with or without a following h represent hours -#ACCT 5m # numbers followed by m represent minutes +;DATE +;ACCT DOTS # Each dot represents 15m, spaces are ignored +;ACCT 8 # numbers with or without a following h represent hours +;ACCT 5m # numbers followed by m represent minutes -# on 2/1, 1h was spent on FOSS haskell work, 0.25h on research, etc. +; on 2/1, 1h was spent on FOSS haskell work, 0.25h on research, etc. 2/1 fos.haskell .... .. biz.research . @@ -168,7 +168,7 @@ entryp :: JournalParser m Transaction entryp = do lift $ traceparse "entryp" - pos <- genericSourcePos <$> getSourcePos + pos <- getSourcePos notFollowedBy datelinep lift $ optional $ choice [orgheadingprefixp, skipNonNewlineSpaces1] a <- modifiedaccountnamep @@ -178,7 +178,7 @@ <|> (durationp <* (try (lift followingcommentp) <|> (newline >> return ""))) let t = nulltransaction{ - tsourcepos = pos, + tsourcepos = (pos, pos), tstatus = Cleared, tpostings = [ nullposting{paccount=a diff --git a/Hledger/Reports.hs b/Hledger/Reports.hs --- a/Hledger/Reports.hs +++ b/Hledger/Reports.hs @@ -15,7 +15,6 @@ module Hledger.Reports.ReportTypes, module Hledger.Reports.EntriesReport, module Hledger.Reports.PostingsReport, - module Hledger.Reports.TransactionsReport, module Hledger.Reports.AccountTransactionsReport, module Hledger.Reports.BalanceReport, module Hledger.Reports.MultiBalanceReport, @@ -25,18 +24,17 @@ ) where +import Test.Tasty (testGroup) import Hledger.Reports.ReportOptions import Hledger.Reports.ReportTypes import Hledger.Reports.AccountTransactionsReport import Hledger.Reports.EntriesReport import Hledger.Reports.PostingsReport -import Hledger.Reports.TransactionsReport import Hledger.Reports.BalanceReport import Hledger.Reports.MultiBalanceReport import Hledger.Reports.BudgetReport -import Hledger.Utils.Test -tests_Reports = tests "Reports" [ +tests_Reports = testGroup "Reports" [ tests_BalanceReport ,tests_BudgetReport ,tests_AccountTransactionsReport diff --git a/Hledger/Reports/AccountTransactionsReport.hs b/Hledger/Reports/AccountTransactionsReport.hs --- a/Hledger/Reports/AccountTransactionsReport.hs +++ b/Hledger/Reports/AccountTransactionsReport.hs @@ -12,11 +12,19 @@ accountTransactionsReport, accountTransactionsReportItems, transactionRegisterDate, + triOrigTransaction, + triDate, + triAmount, + triBalance, + triCommodityAmount, + triCommodityBalance, + accountTransactionsReportByCommodity, tests_AccountTransactionsReport ) where import Data.List (mapAccumR, nub, partition, sortBy) +import Data.List.Extra (nubSort) import Data.Maybe (catMaybes) import Data.Ord (Down(..), comparing) import Data.Text (Text) @@ -41,10 +49,9 @@ -- - the transaction as seen in the context of the current account and query, -- which means: -- --- - the transaction date is set to the "transaction context date", --- which can be different from the transaction's general date: --- if postings to the current account (and matched by the report query) --- have their own dates, it's the earliest of these dates. +-- - the transaction date is set to the "transaction context date": +-- the earliest of the transaction date and any other posting dates +-- of postings to the current account (matched by the report query). -- -- - the transaction's postings are filtered, excluding any which are not -- matched by the report query @@ -78,16 +85,23 @@ ,MixedAmount -- the register's running total or the current account(s)'s historical balance, after this transaction ) -accountTransactionsReport :: ReportSpec -> Journal -> Query -> Query -> AccountTransactionsReport -accountTransactionsReport rspec@ReportSpec{rsOpts=ropts} j reportq' thisacctq = items +triOrigTransaction (torig,_,_,_,_,_) = torig +triDate (_,tacct,_,_,_,_) = tdate tacct +triAmount (_,_,_,_,a,_) = a +triBalance (_,_,_,_,_,a) = a +triCommodityAmount c = filterMixedAmountByCommodity c . triAmount +triCommodityBalance c = filterMixedAmountByCommodity c . triBalance + +accountTransactionsReport :: ReportSpec -> Journal -> Query -> AccountTransactionsReport +accountTransactionsReport rspec@ReportSpec{_rsReportOpts=ropts} j thisacctq = items where -- A depth limit should not affect the account transactions report; it should show all transactions in/below this account. -- Queries on currency or amount are also ignored at this stage; they are handled earlier, before valuation. reportq = simplifyQuery $ And [aregisterq, periodq] where - aregisterq = filterQuery (not . queryIsCurOrAmt) $ filterQuery (not . queryIsDepth) reportq' + aregisterq = filterQuery (not . queryIsCurOrAmt) . filterQuery (not . queryIsDepth) $ _rsQuery rspec periodq = Date . periodAsDateSpan $ period_ ropts - amtq = filterQuery queryIsCurOrAmt $ rsQuery rspec + amtq = filterQuery queryIsCurOrAmt $ _rsQuery rspec queryIsCurOrAmt q = queryIsSym q || queryIsAmt q -- Note that within this functions, we are only allowed limited @@ -118,8 +132,8 @@ statusq = filterQuery queryIsStatus reportq startbal - | balancetype_ ropts == HistoricalBalance = sumPostings priorps - | otherwise = nullmixedamt + | balanceaccum_ ropts == Historical = sumPostings priorps + | otherwise = nullmixedamt where priorps = dbg5 "priorps" . journalPostings $ filterJournalPostings priorq acctJournal priorq = dbg5 "priorq" $ And [thisacctq, tostartdateq, datelessreportq] @@ -206,7 +220,40 @@ displayps | null realps = ps | otherwise = realps +-- | Split an account transactions report whose items may involve several commodities, +-- into one or more single-commodity account transactions reports. +accountTransactionsReportByCommodity :: AccountTransactionsReport -> [(CommoditySymbol, AccountTransactionsReport)] +accountTransactionsReportByCommodity tr = + [(c, filterAccountTransactionsReportByCommodity c tr) | c <- commodities tr] + where + commodities = nubSort . map acommodity . concatMap (amounts . triAmount) + +-- | Remove account transaction report items and item amount (and running +-- balance amount) components that don't involve the specified +-- commodity. Other item fields such as the transaction are left unchanged. +filterAccountTransactionsReportByCommodity :: CommoditySymbol -> AccountTransactionsReport -> AccountTransactionsReport +filterAccountTransactionsReportByCommodity c = + fixTransactionsReportItemBalances . concatMap (filterTransactionsReportItemByCommodity c) + where + filterTransactionsReportItemByCommodity c (t,t2,s,o,a,bal) + | c `elem` cs = [item'] + | otherwise = [] + where + cs = map acommodity $ amounts a + item' = (t,t2,s,o,a',bal) + a' = filterMixedAmountByCommodity c a + + fixTransactionsReportItemBalances [] = [] + fixTransactionsReportItemBalances [i] = [i] + fixTransactionsReportItemBalances items = reverse $ i:(go startbal is) + where + i:is = reverse items + startbal = filterMixedAmountByCommodity c $ triBalance i + go _ [] = [] + go bal ((t,t2,s,o,amt,_):is) = (t,t2,s,o,amt,bal'):go bal' is + where bal' = bal `maPlus` amt + -- tests -tests_AccountTransactionsReport = tests "AccountTransactionsReport" [ +tests_AccountTransactionsReport = testGroup "AccountTransactionsReport" [ ] diff --git a/Hledger/Reports/BalanceReport.hs b/Hledger/Reports/BalanceReport.hs --- a/Hledger/Reports/BalanceReport.hs +++ b/Hledger/Reports/BalanceReport.hs @@ -22,7 +22,6 @@ import Data.Time.Calendar import Hledger.Data -import Hledger.Read (mamountp') import Hledger.Query import Hledger.Utils import Hledger.Reports.MultiBalanceReport (multiBalanceReport) @@ -78,7 +77,7 @@ -- tests Right samplejournal2 = - journalBalanceTransactions balancingOpts + journalBalanceTransactions defbalancingopts nulljournal{ jtxns = [ txnTieKnot Transaction{ @@ -100,116 +99,116 @@ ] } -tests_BalanceReport = tests "BalanceReport" [ +tests_BalanceReport = testGroup "BalanceReport" [ let (rspec,journal) `gives` r = do - let opts' = rspec{rsQuery=And [queryFromFlags $ rsOpts rspec, rsQuery rspec]} + let opts' = rspec{_rsQuery=And [queryFromFlags $ _rsReportOpts rspec, _rsQuery rspec]} (eitems, etotal) = r (aitems, atotal) = balanceReport opts' journal showw (acct,acct',indent,amt) = (acct, acct', indent, showMixedAmountDebug amt) (map showw aitems) @?= (map showw eitems) (showMixedAmountDebug atotal) @?= (showMixedAmountDebug etotal) in - tests "balanceReport" [ + testGroup "balanceReport" [ - test "no args, null journal" $ + testCase "no args, null journal" $ (defreportspec, nulljournal) `gives` ([], nullmixedamt) - ,test "no args, sample journal" $ + ,testCase "no args, sample journal" $ (defreportspec, samplejournal) `gives` ([ - ("assets:bank:checking","assets:bank:checking",0, mamountp' "$1.00") - ,("assets:bank:saving","assets:bank:saving",0, mamountp' "$1.00") - ,("assets:cash","assets:cash",0, mamountp' "$-2.00") - ,("expenses:food","expenses:food",0, mamountp' "$1.00") - ,("expenses:supplies","expenses:supplies",0, mamountp' "$1.00") - ,("income:gifts","income:gifts",0, mamountp' "$-1.00") - ,("income:salary","income:salary",0, mamountp' "$-1.00") + ("assets:bank:checking","assets:bank:checking",0, mixedAmount (usd 1)) + ,("assets:bank:saving","assets:bank:saving",0, mixedAmount (usd 1)) + ,("assets:cash","assets:cash",0, mixedAmount (usd (-2))) + ,("expenses:food","expenses:food",0, mixedAmount (usd 1)) + ,("expenses:supplies","expenses:supplies",0, mixedAmount (usd 1)) + ,("income:gifts","income:gifts",0, mixedAmount (usd (-1))) + ,("income:salary","income:salary",0, mixedAmount (usd (-1))) ], mixedAmount (usd 0)) - ,test "with --tree" $ - (defreportspec{rsOpts=defreportopts{accountlistmode_=ALTree}}, samplejournal) `gives` + ,testCase "with --tree" $ + (defreportspec{_rsReportOpts=defreportopts{accountlistmode_=ALTree}}, samplejournal) `gives` ([ - ("assets","assets",0, mamountp' "$0.00") - ,("assets:bank","bank",1, mamountp' "$2.00") - ,("assets:bank:checking","checking",2, mamountp' "$1.00") - ,("assets:bank:saving","saving",2, mamountp' "$1.00") - ,("assets:cash","cash",1, mamountp' "$-2.00") - ,("expenses","expenses",0, mamountp' "$2.00") - ,("expenses:food","food",1, mamountp' "$1.00") - ,("expenses:supplies","supplies",1, mamountp' "$1.00") - ,("income","income",0, mamountp' "$-2.00") - ,("income:gifts","gifts",1, mamountp' "$-1.00") - ,("income:salary","salary",1, mamountp' "$-1.00") + ("assets","assets",0, mixedAmount (usd 0)) + ,("assets:bank","bank",1, mixedAmount (usd 2)) + ,("assets:bank:checking","checking",2, mixedAmount (usd 1)) + ,("assets:bank:saving","saving",2, mixedAmount (usd 1)) + ,("assets:cash","cash",1, mixedAmount (usd (-2))) + ,("expenses","expenses",0, mixedAmount (usd 2)) + ,("expenses:food","food",1, mixedAmount (usd 1)) + ,("expenses:supplies","supplies",1, mixedAmount (usd 1)) + ,("income","income",0, mixedAmount (usd (-2))) + ,("income:gifts","gifts",1, mixedAmount (usd (-1))) + ,("income:salary","salary",1, mixedAmount (usd (-1))) ], mixedAmount (usd 0)) - ,test "with --depth=N" $ - (defreportspec{rsOpts=defreportopts{depth_=Just 1}}, samplejournal) `gives` + ,testCase "with --depth=N" $ + (defreportspec{_rsReportOpts=defreportopts{depth_=Just 1}}, samplejournal) `gives` ([ - ("expenses", "expenses", 0, mamountp' "$2.00") - ,("income", "income", 0, mamountp' "$-2.00") + ("expenses", "expenses", 0, mixedAmount (usd 2)) + ,("income", "income", 0, mixedAmount (usd (-2))) ], mixedAmount (usd 0)) - ,test "with depth:N" $ - (defreportspec{rsQuery=Depth 1}, samplejournal) `gives` + ,testCase "with depth:N" $ + (defreportspec{_rsQuery=Depth 1}, samplejournal) `gives` ([ - ("expenses", "expenses", 0, mamountp' "$2.00") - ,("income", "income", 0, mamountp' "$-2.00") + ("expenses", "expenses", 0, mixedAmount (usd 2)) + ,("income", "income", 0, mixedAmount (usd (-2))) ], mixedAmount (usd 0)) - ,test "with date:" $ - (defreportspec{rsQuery=Date $ DateSpan (Just $ fromGregorian 2009 01 01) (Just $ fromGregorian 2010 01 01)}, samplejournal2) `gives` + ,testCase "with date:" $ + (defreportspec{_rsQuery=Date $ DateSpan (Just $ fromGregorian 2009 01 01) (Just $ fromGregorian 2010 01 01)}, samplejournal2) `gives` ([], nullmixedamt) - ,test "with date2:" $ - (defreportspec{rsQuery=Date2 $ DateSpan (Just $ fromGregorian 2009 01 01) (Just $ fromGregorian 2010 01 01)}, samplejournal2) `gives` + ,testCase "with date2:" $ + (defreportspec{_rsQuery=Date2 $ DateSpan (Just $ fromGregorian 2009 01 01) (Just $ fromGregorian 2010 01 01)}, samplejournal2) `gives` ([ - ("assets:bank:checking","assets:bank:checking",0,mamountp' "$1.00") - ,("income:salary","income:salary",0,mamountp' "$-1.00") + ("assets:bank:checking","assets:bank:checking",0,mixedAmount (usd 1)) + ,("income:salary","income:salary",0,mixedAmount (usd (-1))) ], mixedAmount (usd 0)) - ,test "with desc:" $ - (defreportspec{rsQuery=Desc $ toRegexCI' "income"}, samplejournal) `gives` + ,testCase "with desc:" $ + (defreportspec{_rsQuery=Desc $ toRegexCI' "income"}, samplejournal) `gives` ([ - ("assets:bank:checking","assets:bank:checking",0,mamountp' "$1.00") - ,("income:salary","income:salary",0, mamountp' "$-1.00") + ("assets:bank:checking","assets:bank:checking",0,mixedAmount (usd 1)) + ,("income:salary","income:salary",0, mixedAmount (usd (-1))) ], mixedAmount (usd 0)) - ,test "with not:desc:" $ - (defreportspec{rsQuery=Not . Desc $ toRegexCI' "income"}, samplejournal) `gives` + ,testCase "with not:desc:" $ + (defreportspec{_rsQuery=Not . Desc $ toRegexCI' "income"}, samplejournal) `gives` ([ - ("assets:bank:saving","assets:bank:saving",0, mamountp' "$1.00") - ,("assets:cash","assets:cash",0, mamountp' "$-2.00") - ,("expenses:food","expenses:food",0, mamountp' "$1.00") - ,("expenses:supplies","expenses:supplies",0, mamountp' "$1.00") - ,("income:gifts","income:gifts",0, mamountp' "$-1.00") + ("assets:bank:saving","assets:bank:saving",0, mixedAmount (usd 1)) + ,("assets:cash","assets:cash",0, mixedAmount (usd (-2))) + ,("expenses:food","expenses:food",0, mixedAmount (usd 1)) + ,("expenses:supplies","expenses:supplies",0, mixedAmount (usd 1)) + ,("income:gifts","income:gifts",0, mixedAmount (usd (-1))) ], mixedAmount (usd 0)) - ,test "with period on a populated period" $ - (defreportspec{rsOpts=defreportopts{period_= PeriodBetween (fromGregorian 2008 1 1) (fromGregorian 2008 1 2)}}, samplejournal) `gives` + ,testCase "with period on a populated period" $ + (defreportspec{_rsReportOpts=defreportopts{period_= PeriodBetween (fromGregorian 2008 1 1) (fromGregorian 2008 1 2)}}, samplejournal) `gives` ( [ - ("assets:bank:checking","assets:bank:checking",0, mamountp' "$1.00") - ,("income:salary","income:salary",0, mamountp' "$-1.00") + ("assets:bank:checking","assets:bank:checking",0, mixedAmount (usd 1)) + ,("income:salary","income:salary",0, mixedAmount (usd (-1))) ], mixedAmount (usd 0)) - ,test "with period on an unpopulated period" $ - (defreportspec{rsOpts=defreportopts{period_= PeriodBetween (fromGregorian 2008 1 2) (fromGregorian 2008 1 3)}}, samplejournal) `gives` + ,testCase "with period on an unpopulated period" $ + (defreportspec{_rsReportOpts=defreportopts{period_= PeriodBetween (fromGregorian 2008 1 2) (fromGregorian 2008 1 3)}}, samplejournal) `gives` ([], nullmixedamt) {- - ,test "accounts report with account pattern o" ~: + ,testCase "accounts report with account pattern o" ~: defreportopts{patterns_=["o"]} `gives` [" $1 expenses:food" ," $-2 income" @@ -219,7 +218,7 @@ ," $-1" ] - ,test "accounts report with account pattern o and --depth 1" ~: + ,testCase "accounts report with account pattern o and --depth 1" ~: defreportopts{patterns_=["o"],depth_=Just 1} `gives` [" $1 expenses" ," $-2 income" @@ -227,7 +226,7 @@ ," $-1" ] - ,test "accounts report with account pattern a" ~: + ,testCase "accounts report with account pattern a" ~: defreportopts{patterns_=["a"]} `gives` [" $-1 assets" ," $1 bank:saving" @@ -238,7 +237,7 @@ ," $-1" ] - ,test "accounts report with account pattern e" ~: + ,testCase "accounts report with account pattern e" ~: defreportopts{patterns_=["e"]} `gives` [" $-1 assets" ," $1 bank:saving" @@ -254,7 +253,7 @@ ," 0" ] - ,test "accounts report with unmatched parent of two matched subaccounts" ~: + ,testCase "accounts report with unmatched parent of two matched subaccounts" ~: defreportopts{patterns_=["cash","saving"]} `gives` [" $-1 assets" ," $1 bank:saving" @@ -263,14 +262,14 @@ ," $-1" ] - ,test "accounts report with multi-part account name" ~: + ,testCase "accounts report with multi-part account name" ~: defreportopts{patterns_=["expenses:food"]} `gives` [" $1 expenses:food" ,"--------------------" ," $1" ] - ,test "accounts report with negative account pattern" ~: + ,testCase "accounts report with negative account pattern" ~: defreportopts{patterns_=["not:assets"]} `gives` [" $2 expenses" ," $1 food" @@ -283,20 +282,20 @@ ," $1" ] - ,test "accounts report negative account pattern always matches full name" ~: + ,testCase "accounts report negative account pattern always matches full name" ~: defreportopts{patterns_=["not:e"]} `gives` ["--------------------" ," 0" ] - ,test "accounts report negative patterns affect totals" ~: + ,testCase "accounts report negative patterns affect totals" ~: defreportopts{patterns_=["expenses","not:food"]} `gives` [" $1 expenses:supplies" ,"--------------------" ," $1" ] - ,test "accounts report with -E shows zero-balance accounts" ~: + ,testCase "accounts report with -E shows zero-balance accounts" ~: defreportopts{patterns_=["assets"],empty_=True} `gives` [" $-1 assets" ," $1 bank" @@ -307,7 +306,7 @@ ," $-1" ] - ,test "accounts report with cost basis" $ + ,testCase "accounts report with cost basis" $ j <- (readJournal def Nothing $ unlines ["" ,"2008/1/1 test " diff --git a/Hledger/Reports/BudgetReport.hs b/Hledger/Reports/BudgetReport.hs --- a/Hledger/Reports/BudgetReport.hs +++ b/Hledger/Reports/BudgetReport.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -22,13 +21,14 @@ where import Control.Applicative ((<|>)) +import Control.Arrow ((***)) import Data.Decimal (roundTo) -import Data.Default (def) +import Data.Function (on) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HM -import Data.List (find, partition, transpose) +import Data.List (find, partition, transpose, foldl') import Data.List.Extra (nubSort) -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, catMaybes) import Data.Map (Map) import qualified Data.Map as Map import qualified Data.Set as S @@ -42,7 +42,6 @@ import Hledger.Data import Hledger.Utils -import Hledger.Read.CsvReader (CSV) import Hledger.Reports.ReportOptions import Hledger.Reports.ReportTypes import Hledger.Reports.MultiBalanceReport @@ -57,10 +56,13 @@ type BudgetReportRow = PeriodicReportRow DisplayName BudgetCell type BudgetReport = PeriodicReport DisplayName BudgetCell -type BudgetDisplayCell = ((Text, Int), Maybe ((Text, Int), Maybe (Text, Int))) +type BudgetDisplayCell = (WideBuilder, Maybe (WideBuilder, Maybe WideBuilder)) +type BudgetDisplayRow = [BudgetDisplayCell] +type BudgetShowMixed = MixedAmount -> [WideBuilder] +type BudgetPercBudget = Change -> BudgetGoal -> [Maybe Percentage] -- | Calculate per-account, per-period budget (balance change) goals --- from all periodic transactions, calculate actual balance changes +-- from all periodic transactions, calculate actual balance changes -- from the regular transactions, and compare these to get a 'BudgetReport'. -- Unbudgeted accounts may be hidden or renamed (see journalWithBudgetAccountNames). budgetReport :: ReportSpec -> BalancingOpts -> DateSpan -> Journal -> BudgetReport @@ -68,7 +70,7 @@ where -- Budget report demands ALTree mode to ensure subaccounts and subaccount budgets are properly handled -- and that reports with and without --empty make sense when compared side by side - ropts = (rsOpts rspec){ accountlistmode_ = ALTree } + ropts = (_rsReportOpts rspec){ accountlistmode_ = ALTree } showunbudgeted = empty_ ropts budgetedaccts = dbg3 "budgetedacctsinperiod" $ @@ -81,9 +83,9 @@ actualj = journalWithBudgetAccountNames budgetedaccts showunbudgeted j budgetj = journalAddBudgetGoalTransactions bopts ropts reportspan j actualreport@(PeriodicReport actualspans _ _) = - dbg5 "actualreport" $ multiBalanceReport rspec{rsOpts=ropts{empty_=True}} actualj + dbg5 "actualreport" $ multiBalanceReport rspec{_rsReportOpts=ropts{empty_=True}} actualj budgetgoalreport@(PeriodicReport _ budgetgoalitems budgetgoaltotals) = - dbg5 "budgetgoalreport" $ multiBalanceReport rspec{rsOpts=ropts{empty_=True}} budgetj + dbg5 "budgetgoalreport" $ multiBalanceReport rspec{_rsReportOpts=ropts{empty_=True}} budgetj budgetgoalreport' -- If no interval is specified: -- budgetgoalreport's span might be shorter actualreport's due to periodic txns; @@ -98,14 +100,21 @@ -- their purpose and effect is to define balance change goals, per account and period, -- for BudgetReport. journalAddBudgetGoalTransactions :: BalancingOpts -> ReportOpts -> DateSpan -> Journal -> Journal -journalAddBudgetGoalTransactions bopts _ropts reportspan j = +journalAddBudgetGoalTransactions bopts ropts reportspan j = either error' id $ journalBalanceTransactions bopts j{ jtxns = budgetts } -- PARTIAL: where budgetspan = dbg3 "budget span" $ reportspan + pat = fromMaybe "" $ dbg3 "budget pattern" $ T.toLower <$> budgetpat_ ropts + -- select periodic transactions matching a pattern + -- (the argument of the (final) --budget option). + -- XXX two limitations/wishes, requiring more extensive type changes: + -- - give an error if pat is non-null and matches no periodic txns + -- - allow a regexp or a full hledger query, not just a substring budgetts = dbg5 "budget goal txns" $ [makeBudgetTxn t | pt <- jperiodictxns j + , pat `T.isInfixOf` T.toLower (ptdescription pt) , t <- runPeriodicTransaction pt budgetspan ] makeBudgetTxn t = txnTieKnot $ t { tdescription = T.pack "Budget transaction" } @@ -193,21 +202,20 @@ mbrsorted = map prrFullName . sortRows ropts j . map (fmap $ fromMaybe nullmixedamt . fst) rows = rows1 ++ rows2 - -- TODO: grand total & average shows 0% when there are no actual amounts, inconsistent with other cells totalrow = PeriodicReportRow () [ (Map.lookup p totActualByPeriod, Map.lookup p totBudgetByPeriod) | p <- periods ] - ( Just actualgrandtot, Just budgetgrandtot ) - ( Just actualgrandavg, Just budgetgrandavg ) + ( Just actualgrandtot, budget budgetgrandtot ) + ( Just actualgrandavg, budget budgetgrandavg ) where totBudgetByPeriod = Map.fromList $ zip budgetperiods budgettots :: Map DateSpan BudgetTotal totActualByPeriod = Map.fromList $ zip actualperiods actualtots :: Map DateSpan Change + budget b = if mixedAmountLooksZero b then Nothing else Just b -- | Render a budget report as plain text suitable for console output. budgetReportAsText :: ReportOpts -> BudgetReport -> TL.Text budgetReportAsText ropts@ReportOpts{..} budgetr = TB.toLazyText $ TB.fromText title <> TB.fromText "\n\n" <> - renderTableB def{tableBorders=False,prettyTable=pretty_tables_} - (textCell TopLeft) (textCell TopRight) (uncurry showcell) displayTableWithWidths + balanceReportTableAsText ropts (budgetReportAsTable ropts budgetr) where title = "Budget performance in " <> showDateSpan (periodicReportSpan budgetr) <> (case cost_ of @@ -221,42 +229,151 @@ Nothing -> "") <> ":" - displayTableWithWidths :: Table Text Text ((Int, Int, Int), BudgetDisplayCell) - displayTableWithWidths = Table rh ch $ map (zipWith (,) widths) displaycells - Table rh ch displaycells = case budgetReportAsTable ropts budgetr of - Table rh' ch' vals -> maybetranspose . Table rh' ch' $ map (map displayCell) vals +-- | Build a 'Table' from a multi-column balance report. +budgetReportAsTable :: ReportOpts -> BudgetReport -> 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) + rows + where + colheadings = ["Commodity" | commodity_column_] + ++ map (reportPeriodName balanceaccum_ spans) spans + ++ [" Total" | row_total_] + ++ ["Average" | average_] - displayCell (actual, budget) = (showamt actual', budgetAndPerc <$> budget) + -- FIXME. Have to check explicitly for which to render here, since + -- budgetReport sets accountlistmode to ALTree. Find a principled way to do + -- this. + renderacct row = case accountlistmode_ of + ALTree -> T.replicate ((prrDepth row - 1)*2) " " <> prrDisplayName row + ALFlat -> accountNameDrop (drop_) $ prrFullName row + + 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) + + maybetranspose + | transpose_ = transpose + | otherwise = id + + maybetransposetable + | transpose_ = \(Table rh ch vals) -> Table ch rh (transpose vals) + | otherwise = id + + (accts, rows, totalrows) = (accts, prependcs itemscs (padcells texts), prependcs trcs (padtr trtexts)) where - actual' = fromMaybe nullmixedamt actual - budgetAndPerc b = (showamt b, showper <$> percentage actual' b) - showamt = (\(WideBuilder b w) -> (TL.toStrict $ TB.toLazyText b, w)) . showMixedAmountB oneLine{displayColour=color_, displayMaxWidth=Just 32} - showper p = let str = T.pack (show $ roundTo 0 p) in (str, T.length str) - cellWidth ((_,wa), Nothing) = (wa, 0, 0) - cellWidth ((_,wa), Just ((_,wb), Nothing)) = (wa, wb, 0) - cellWidth ((_,wa), Just ((_,wb), Just (_,wp))) = (wa, wb, wp) + shownitems :: [[(AccountName, WideBuilder, BudgetDisplayRow)]] + shownitems = (fmap (\i -> fmap (\(cs, cvals) -> (renderacct i, cs, cvals)) . showrow $ rowToBudgetCells i) items) + (accts, itemscs, texts) = unzip3 $ concat shownitems + showntr :: [[(WideBuilder, BudgetDisplayRow)]] + showntr = [showrow $ rowToBudgetCells tr] + (trcs, trtexts) = unzip $ concat showntr + trwidths + | transpose_ = drop (length texts) widths + | otherwise = widths + + 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` + prependcs cs + | commodity_column_ = zipWith (:) cs + | otherwise = id + + 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 + 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) + + showrow :: [BudgetCell] -> [(WideBuilder, BudgetDisplayRow)] + showrow row = + let cs = budgetCellsCommodities row + (showmixed, percbudget) = rowfuncs cs + in zip (fmap wbFromText cs) + . transpose + . fmap (showcell showmixed percbudget) + $ row + + budgetCellsCommodities = S.toList . foldl' S.union mempty . fmap budgetCellCommodities + budgetCellCommodities :: BudgetCell -> S.Set CommoditySymbol + budgetCellCommodities (am, bm) = f am `S.union` f bm + where f = maybe mempty maCommodities + + cellswidth :: [BudgetCell] -> [[(Int, Int, Int)]] + cellswidth row = + let cs = budgetCellsCommodities row + (showmixed, percbudget) = rowfuncs cs + disp = showcell showmixed percbudget + budgetpercwidth = wbWidth *** maybe 0 wbWidth + cellwidth (am, bm) = let (bw, pw) = maybe (0, 0) budgetpercwidth bm in (wbWidth am, bw, pw) + in fmap (fmap cellwidth . disp) row + + -- build a list of widths for each column. In the case of transposed budget + -- reports, the total 'row' must be included in this list widths = zip3 actualwidths budgetwidths percentwidths - actualwidths = map (maximum' . map (first3 . cellWidth)) cols - budgetwidths = map (maximum' . map (second3 . cellWidth)) cols - percentwidths = map (maximum' . map (third3 . cellWidth)) cols - cols = transpose displaycells + where + actualwidths = map (maximum' . map first3 ) $ cols + budgetwidths = map (maximum' . map second3) $ cols + percentwidths = map (maximum' . map third3 ) $ cols + catcolumnwidths = foldl' (zipWith (++)) $ repeat [] + cols = maybetranspose $ catcolumnwidths $ map (cellswidth . rowToBudgetCells) items ++ [cellswidth $ rowToBudgetCells tr] - -- XXX lay out actual, percentage and/or goal in the single table cell for now, should probably use separate cells - showcell :: (Int, Int, Int) -> BudgetDisplayCell -> Cell - showcell (actualwidth, budgetwidth, percentwidth) ((actual,wa), mbudget) = - Cell TopRight [WideBuilder ( TB.fromText (T.replicate (actualwidth - wa) " ") - <> TB.fromText actual - <> budgetstr - ) (actualwidth + totalbudgetwidth)] + -- split a BudgetCell into BudgetDisplayCell's (one per commodity when applicable) + showcell :: BudgetShowMixed -> BudgetPercBudget -> BudgetCell -> BudgetDisplayRow + showcell showmixed percbudget (actual, mbudget) = zip (showmixed actual') full where - totalpercentwidth = if percentwidth == 0 then 0 else percentwidth + 5 - totalbudgetwidth = if budgetwidth == 0 then 0 else budgetwidth + totalpercentwidth + 3 - budgetstr = TB.fromText $ case mbudget of - Nothing -> T.replicate totalbudgetwidth " " - Just ((budget, wb), Nothing) -> " [" <> T.replicate totalpercentwidth " " <> T.replicate (budgetwidth - wb) " " <> budget <> "]" - Just ((budget, wb), Just (pct, wp)) -> " [" <> T.replicate (percentwidth - wp) " " <> pct <> "% of " <> T.replicate (budgetwidth - wb) " " <> budget <> "]" + actual' = fromMaybe nullmixedamt actual + budgetAndPerc b = uncurry zip + ( showmixed b + , fmap (wbFromText . T.pack . show . roundTo 0) <$> percbudget actual' b + ) + + full + | Just b <- mbudget = Just <$> budgetAndPerc b + | otherwise = repeat Nothing + + paddisplaycell :: (Int, Int, Int) -> BudgetDisplayCell -> WideBuilder + paddisplaycell (actualwidth, budgetwidth, percentwidth) (actual, mbudget) = full + where + toPadded (WideBuilder b w) = + (TB.fromText . flip T.replicate " " $ actualwidth - w) <> b + + (totalpercentwidth, totalbudgetwidth) = + let totalpercentwidth = if percentwidth == 0 then 0 else percentwidth + 5 + in ( totalpercentwidth + , if budgetwidth == 0 then 0 else budgetwidth + totalpercentwidth + 3 + ) + + -- | Display a padded budget string + budgetb (budget, perc) = + let perct = case perc of + Nothing -> T.replicate totalpercentwidth " " + Just pct -> T.replicate (percentwidth - wbWidth pct) " " <> wbToText pct <> "% of " + in TB.fromText $ " [" <> perct <> T.replicate (budgetwidth - wbWidth budget) " " <> wbToText budget <> "]" + + emptyBudget = TB.fromText $ T.replicate totalbudgetwidth " " + + full = flip WideBuilder (actualwidth + totalbudgetwidth) $ + toPadded actual <> maybe emptyBudget budgetb mbudget + -- | Calculate the percentage of actual change to budget goal to show, if any. -- If valuing at cost, both amounts are converted to cost before comparing. -- A percentage will not be shown if: @@ -274,80 +391,59 @@ Cost -> amounts . mixedAmountCost NoCost -> amounts - maybetranspose | transpose_ = \(Table rh ch vals) -> Table ch rh (transpose vals) - | otherwise = id - --- | Build a 'Table' from a multi-column balance report. -budgetReportAsTable :: ReportOpts -> BudgetReport -> Table Text Text (Maybe MixedAmount, Maybe MixedAmount) -budgetReportAsTable - ropts@ReportOpts{balancetype_} - (PeriodicReport spans rows (PeriodicReportRow _ coltots grandtot grandavg)) = - addtotalrow $ - Table - (Tab.Group NoLine $ map Header accts) - (Tab.Group NoLine $ map Header colheadings) - (map rowvals rows) - where - colheadings = map (reportPeriodName balancetype_ spans) spans - ++ [" Total" | row_total_ ropts] - ++ ["Average" | average_ ropts] - - accts = map renderacct rows - -- FIXME. Have to check explicitly for which to render here, since - -- budgetReport sets accountlistmode to ALTree. Find a principled way to do - -- this. - renderacct row = case accountlistmode_ ropts of - ALTree -> T.replicate ((prrDepth row - 1)*2) " " <> prrDisplayName row - ALFlat -> accountNameDrop (drop_ ropts) $ prrFullName row - rowvals (PeriodicReportRow _ as rowtot rowavg) = - as ++ [rowtot | row_total_ ropts] ++ [rowavg | average_ ropts] - addtotalrow - | no_total_ ropts = id - | otherwise = (+----+ (row "" $ - coltots ++ [grandtot | row_total_ ropts && not (null coltots)] - ++ [grandavg | average_ ropts && not (null coltots)] - )) + -- | Calculate the percentage of actual change to budget goal for a particular commodity + percentage' :: Change -> BudgetGoal -> CommoditySymbol -> Maybe Percentage + percentage' am bm c = case ((,) `on` find ((==) c . acommodity) . amounts) am bm of + (Just a, Just b) -> percentage (mixedAmount a) (mixedAmount b) + _ -> Nothing -- XXX generalise this with multiBalanceReportAsCsv ? -- | Render a budget report as CSV. Like multiBalanceReportAsCsv, -- but includes alternating actual and budget amount columns. -budgetReportAsCsv :: ReportOpts -> BudgetReport -> CSV +budgetReportAsCsv :: ReportOpts -> BudgetReport -> [[Text]] budgetReportAsCsv - ReportOpts{average_, row_total_, no_total_, transpose_} - (PeriodicReport colspans items (PeriodicReportRow _ abtotals (magrandtot,mbgrandtot) (magrandavg,mbgrandavg))) + ReportOpts{..} + (PeriodicReport colspans items tr) = (if transpose_ then transpose else id) $ -- heading row ("Account" : - concatMap (\span -> [showDateSpan span, "budget"]) colspans + ["Commodity" | commodity_column_ ] + ++ concatMap (\span -> [showDateSpan span, "budget"]) colspans ++ concat [["Total" ,"budget"] | row_total_] ++ concat [["Average","budget"] | average_] ) : -- account rows - [displayFull a : - map showmamt (flattentuples abamts) - ++ concat [[showmamt mactualrowtot, showmamt mbudgetrowtot] | row_total_] - ++ concat [[showmamt mactualrowavg, showmamt mbudgetrowavg] | average_] - | PeriodicReportRow a abamts (mactualrowtot,mbudgetrowtot) (mactualrowavg,mbudgetrowavg) <- items - ] + concatMap (rowAsTexts prrFullName) items -- totals row - ++ concat [ - [ - "Total:" : - map showmamt (flattentuples abtotals) - ++ concat [[showmamt magrandtot,showmamt mbgrandtot] | row_total_] - ++ concat [[showmamt magrandavg,showmamt mbgrandavg] | average_] - ] - | not no_total_ - ] + ++ concat [ rowAsTexts (const "Total:") tr | not no_total_ ] where flattentuples abs = concat [[a,b] | (a,b) <- abs] - showmamt = maybe "" (wbToText . showMixedAmountB oneLine) + showNorm = maybe "" (wbToText . showMixedAmountB oneLine) + rowAsTexts :: (PeriodicReportRow a BudgetCell -> Text) + -> PeriodicReportRow a BudgetCell + -> [[Text]] + rowAsTexts render row@(PeriodicReportRow _ as (rowtot,budgettot) (rowavg, budgetavg)) + | not commodity_column_ = [render row : fmap showNorm all] + | otherwise = + joinNames . zipWith (:) cs -- add symbols and names + . transpose -- each row becomes a list of Text quantities + . fmap (fmap wbToText . showMixedAmountLinesB oneLine{displayOrder=Just cs, displayMinWidth=Nothing} + .fromMaybe nullmixedamt) + $ all + where + cs = S.toList . foldl' S.union mempty . fmap maCommodities $ catMaybes all + all = flattentuples as + ++ concat [[rowtot, budgettot] | row_total_] + ++ concat [[rowavg, budgetavg] | average_] + + joinNames = fmap (render row :) + -- tests -tests_BudgetReport = tests "BudgetReport" [ +tests_BudgetReport = testGroup "BudgetReport" [ ] diff --git a/Hledger/Reports/EntriesReport.hs b/Hledger/Reports/EntriesReport.hs --- a/Hledger/Reports/EntriesReport.hs +++ b/Hledger/Reports/EntriesReport.hs @@ -34,15 +34,15 @@ -- | Select transactions for an entries report. entriesReport :: ReportSpec -> Journal -> EntriesReport -entriesReport rspec@ReportSpec{rsOpts=ropts} = +entriesReport rspec@ReportSpec{_rsReportOpts=ropts} = sortBy (comparing $ transactionDateFn ropts) . jtxns - . journalApplyValuationFromOpts rspec{rsOpts=ropts{show_costs_=True}} - . filterJournalTransactions (rsQuery rspec) + . journalApplyValuationFromOpts rspec{_rsReportOpts=ropts{show_costs_=True}} + . filterJournalTransactions (_rsQuery rspec) -tests_EntriesReport = tests "EntriesReport" [ - tests "entriesReport" [ - test "not acct" $ (length $ entriesReport defreportspec{rsQuery=Not . Acct $ toRegex' "bank"} samplejournal) @?= 1 - ,test "date" $ (length $ entriesReport defreportspec{rsQuery=Date $ DateSpan (Just $ fromGregorian 2008 06 01) (Just $ fromGregorian 2008 07 01)} samplejournal) @?= 3 +tests_EntriesReport = testGroup "EntriesReport" [ + testGroup "entriesReport" [ + testCase "not acct" $ (length $ entriesReport defreportspec{_rsQuery=Not . Acct $ toRegex' "bank"} samplejournal) @?= 1 + ,testCase "date" $ (length $ entriesReport defreportspec{_rsQuery=Date $ DateSpan (Just $ fromGregorian 2008 06 01) (Just $ fromGregorian 2008 07 01)} samplejournal) @?= 3 ] ] diff --git a/Hledger/Reports/MultiBalanceReport.hs b/Hledger/Reports/MultiBalanceReport.hs --- a/Hledger/Reports/MultiBalanceReport.hs +++ b/Hledger/Reports/MultiBalanceReport.hs @@ -25,8 +25,10 @@ makeReportQuery, getPostingsByColumn, getPostings, - startingBalances, + startingPostings, + startingBalancesFromPostings, generateMultiBalanceReport, + balanceReportTableAsText, -- -- * Tests tests_MultiBalanceReport @@ -34,6 +36,7 @@ where import Control.Monad (guard) +import Data.Bifunctor (second) import Data.Foldable (toList) import Data.List (sortOn, transpose) import Data.List.NonEmpty (NonEmpty(..)) @@ -44,14 +47,18 @@ import Data.Maybe (fromMaybe, isJust, mapMaybe) import Data.Ord (Down(..)) import Data.Semigroup (sconcat) -import Data.Time.Calendar (Day, fromGregorian) +import Data.Time.Calendar (fromGregorian) import Safe (lastDef, minimumMay) +import Data.Default (def) +import qualified Data.Text as T +import qualified Data.Text.Lazy.Builder as TB +import qualified Text.Tabular.AsciiWide as Tab + import Hledger.Data import Hledger.Query import Hledger.Utils hiding (dbg3,dbg4,dbg5) import qualified Hledger.Utils -import Hledger.Read (mamountp') import Hledger.Reports.ReportOptions import Hledger.Reports.ReportTypes @@ -96,7 +103,7 @@ -- by the bs/cf/is commands. multiBalanceReport :: ReportSpec -> Journal -> MultiBalanceReport multiBalanceReport rspec j = multiBalanceReportWith rspec j (journalPriceOracle infer j) - where infer = infer_value_ $ rsOpts rspec + where infer = infer_prices_ $ _rsReportOpts rspec -- | A helper for multiBalanceReport. This one takes an extra argument, -- a PriceOracle to be used for looking up market prices. Commands which @@ -115,7 +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" $ startingBalances rspec j priceoracle reportspan + startbals = dbg5 "startbals" . startingBalancesFromPostings rspec j priceoracle + $ startingPostings rspec j priceoracle reportspan -- Generate and postprocess the report, negating balances and taking percentages if needed report = dbg4 "multiBalanceReportWith" $ @@ -126,7 +134,7 @@ compoundBalanceReport :: ReportSpec -> Journal -> [CBCSubreportSpec a] -> CompoundPeriodicReport a MixedAmount compoundBalanceReport rspec j = compoundBalanceReportWith rspec j (journalPriceOracle infer j) - where infer = infer_value_ $ rsOpts rspec + where infer = infer_prices_ $ _rsReportOpts rspec -- | A helper for compoundBalanceReport, similar to multiBalanceReportWith. compoundBalanceReportWith :: ReportSpec -> Journal -> PriceOracle @@ -141,9 +149,9 @@ -- Group postings into their columns. colps = dbg5 "colps" $ getPostingsByColumn rspec j priceoracle reportspan - -- The matched accounts with a starting balance. All of these should appear + -- The matched postings 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" $ startingBalances rspec j priceoracle reportspan + startps = dbg5 "startps" $ startingPostings rspec j priceoracle reportspan subreports = map generateSubreport subreportspecs where @@ -151,14 +159,15 @@ ( cbcsubreporttitle -- Postprocess the report, negating balances and taking percentages if needed , cbcsubreporttransform $ - generateMultiBalanceReport rspec{rsOpts=ropts} j priceoracle colps' startbals' + generateMultiBalanceReport rspec{_rsReportOpts=ropts} j priceoracle colps' startbals' , cbcsubreportincreasestotal ) where -- Filter the column postings according to each subreport - colps' = filter (matchesPosting q) <$> colps - startbals' = HM.filterWithKey (\k _ -> matchesAccount q k) startbals - ropts = cbcsubreportoptions $ rsOpts rspec + 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: @@ -172,30 +181,32 @@ subreportTotal (_, sr, increasestotal) = (if increasestotal then id else fmap maNegate) $ prTotals sr - cbr = CompoundPeriodicReport "" (M.keys colps) subreports overalltotals + cbr = CompoundPeriodicReport "" (map fst colps) subreports overalltotals +-- | Calculate starting balances from postings, if needed for -H. +startingBalancesFromPostings :: ReportSpec -> Journal -> PriceOracle -> [Posting] + -> HashMap AccountName Account +startingBalancesFromPostings rspec j priceoracle ps = + M.findWithDefault nullacct emptydatespan + <$> calculateReportMatrix rspec j priceoracle mempty [(emptydatespan, ps)] --- | Calculate starting balances, if needed for -H +-- | Postings needed to calculate starting balances. -- -- Balances at report start date, from all earlier postings which otherwise match the query. -- These balances are unvalued. -- TODO: Do we want to check whether to bother calculating these? isHistorical -- and startDate is not nothing, otherwise mempty? This currently gives a -- failure with some totals which are supposed to be 0 being blank. -startingBalances :: ReportSpec -> Journal -> PriceOracle -> DateSpan -> HashMap AccountName Account -startingBalances rspec@ReportSpec{rsQuery=query,rsOpts=ropts} j priceoracle reportspan = - fmap (M.findWithDefault nullacct precedingspan) acctmap +startingPostings :: ReportSpec -> Journal -> PriceOracle -> DateSpan -> [Posting] +startingPostings rspec@ReportSpec{_rsQuery=query,_rsReportOpts=ropts} j priceoracle reportspan = + getPostings rspec' j priceoracle where - acctmap = calculateReportMatrix rspec' j priceoracle mempty - . M.singleton precedingspan . map fst $ getPostings rspec' j priceoracle - - rspec' = rspec{rsQuery=startbalq,rsOpts=ropts'} + rspec' = rspec{_rsQuery=startbalq,_rsReportOpts=ropts'} -- If we're re-valuing every period, we need to have the unvalued start -- balance, so we can do it ourselves later. ropts' = case value_ ropts of - Just (AtEnd _) -> ropts''{value_=Nothing} - _ -> ropts'' - where ropts'' = ropts{period_=precedingperiod, no_elide_=accountlistmode_ ropts == ALTree} + Just (AtEnd _) -> ropts{period_=precedingperiod, value_=Nothing} + _ -> ropts{period_=precedingperiod} -- q projected back before the report start date. -- When there's no report start date, in case there are future txns (the hledger-ui case above), @@ -217,32 +228,29 @@ makeReportQuery :: ReportSpec -> DateSpan -> ReportSpec makeReportQuery rspec reportspan | reportspan == nulldatespan = rspec - | otherwise = rspec{rsQuery=query} + | otherwise = rspec{_rsQuery=query} where - query = simplifyQuery $ And [dateless $ rsQuery rspec, reportspandatesq] + query = simplifyQuery $ And [dateless $ _rsQuery rspec, reportspandatesq] reportspandatesq = dbg3 "reportspandatesq" $ dateqcons reportspan dateless = dbg3 "dateless" . filterQuery (not . queryIsDateOrDate2) - dateqcons = if date2_ (rsOpts rspec) then Date2 else Date + dateqcons = if date2_ (_rsReportOpts rspec) then Date2 else Date -- | Group postings, grouped by their column -getPostingsByColumn :: ReportSpec -> Journal -> PriceOracle -> DateSpan -> Map DateSpan [Posting] -getPostingsByColumn rspec j priceoracle reportspan = columns +getPostingsByColumn :: ReportSpec -> Journal -> PriceOracle -> DateSpan -> [(DateSpan, [Posting])] +getPostingsByColumn rspec j priceoracle reportspan = + groupByDateSpan True getDate colspans ps where -- Postings matching the query within the report period. - ps :: [(Posting, Day)] = dbg5 "getPostingsByColumn" $ getPostings rspec j priceoracle - + ps = dbg5 "getPostingsByColumn" $ getPostings rspec j priceoracle -- The date spans to be included as report columns. - colspans = dbg3 "colspans" $ splitSpan (interval_ $ rsOpts rspec) reportspan - addPosting (p, d) = maybe id (M.adjust (p:)) $ latestSpanContaining colspans d - emptyMap = M.fromList . zip colspans $ repeat [] - - -- Group postings into their columns - columns = foldr addPosting emptyMap ps + colspans = dbg3 "colspans" $ splitSpan (interval_ $ _rsReportOpts rspec) reportspan + getDate = case whichDateFromOpts (_rsReportOpts rspec) of + PrimaryDate -> postingDate + SecondaryDate -> postingDate2 -- | Gather postings matching the query within the report period. -getPostings :: ReportSpec -> Journal -> PriceOracle -> [(Posting, Day)] -getPostings rspec@ReportSpec{rsQuery=query,rsOpts=ropts} j priceoracle = - map (\p -> (p, date p)) . +getPostings :: ReportSpec -> Journal -> PriceOracle -> [Posting] +getPostings rspec@ReportSpec{_rsQuery=query,_rsReportOpts=ropts} j priceoracle = journalPostings . valueJournal . filterJournalAmounts symq $ -- remove amount parts excluded by cur: @@ -257,17 +265,13 @@ valueJournal j' | isJust (valuationAfterSum ropts) = j' | otherwise = journalApplyValuationFromOptsWith rspec j' priceoracle - date = case whichDateFromOpts ropts of - PrimaryDate -> postingDate - SecondaryDate -> postingDate2 - -- | 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,rsOpts=ropts} ps = +acctChangesFromPostings ReportSpec{_rsQuery=query,_rsReportOpts=ropts} ps = HM.fromList [(aname a, a) | a <- as] where as = filterAccounts . drop 1 $ accountsFromPostings ps @@ -283,26 +287,27 @@ -- Makes sure all report columns have an entry. calculateReportMatrix :: ReportSpec -> Journal -> PriceOracle -> HashMap ClippedAccountName Account - -> Map DateSpan [Posting] + -> [(DateSpan, [Posting])] -> HashMap ClippedAccountName (Map DateSpan Account) -calculateReportMatrix rspec@ReportSpec{rsOpts=ropts} j priceoracle startbals colps = -- PARTIAL: +calculateReportMatrix rspec@ReportSpec{_rsReportOpts=ropts} j priceoracle startbals colps = -- PARTIAL: -- Ensure all columns have entries, including those with starting balances HM.mapWithKey rowbals allchanges where -- The valued row amounts to be displayed: per-period changes, -- zero-based cumulative totals, or -- starting-balance-based historical balances. - rowbals name changes = dbg5 "rowbals" $ case balancetype_ ropts of - PeriodChange -> changeamts - CumulativeChange -> cumulative - HistoricalBalance -> historical + rowbals name changes = dbg5 "rowbals" $ case balanceaccum_ ropts of + PerPeriod -> changeamts + Cumulative -> cumulative + Historical -> historical where -- changes to report on: usually just the changes itself, but use the -- differences in the historical amount for ValueChangeReports. - changeamts = case reporttype_ ropts of - ChangeReport -> M.mapWithKey avalue changes - BudgetReport -> M.mapWithKey avalue changes - ValueChangeReport -> periodChanges valuedStart historical + changeamts = case balancecalc_ ropts of + CalcChange -> M.mapWithKey avalue changes + CalcBudget -> M.mapWithKey avalue changes + CalcValueChange -> periodChanges valuedStart historical + CalcGain -> periodChanges valuedStart historical cumulative = cumulativeSum avalue nullacct changeamts historical = cumulativeSum avalue startingBalance changes startingBalance = HM.lookupDefault nullacct name startbals @@ -312,23 +317,23 @@ -- pad with zeros allchanges = ((<>zeros) <$> acctchanges) <> (zeros <$ startbals) acctchanges = dbg5 "acctchanges" . addElided $ transposeMap colacctchanges - colacctchanges = dbg5 "colacctchanges" $ fmap (acctChangesFromPostings rspec) colps + colacctchanges = dbg5 "colacctchanges" $ map (second $ acctChangesFromPostings rspec) colps 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 + 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 = M.keys colps + colspans = map fst colps -- | Lay out a set of postings grouped by date span into a regular matrix with rows -- given by AccountName and columns by DateSpan, then generate a MultiBalanceReport -- from the columns. generateMultiBalanceReport :: ReportSpec -> Journal -> PriceOracle - -> Map DateSpan [Posting] -> HashMap AccountName Account + -> [(DateSpan, [Posting])] -> HashMap AccountName Account -> MultiBalanceReport -generateMultiBalanceReport rspec@ReportSpec{rsOpts=ropts} j priceoracle colps startbals = +generateMultiBalanceReport rspec@ReportSpec{_rsReportOpts=ropts} j priceoracle colps startbals = report where -- Process changes into normal, cumulative, or historical amounts, plus value them @@ -348,7 +353,7 @@ sortedrows = dbg5 "sortedrows" $ sortRows ropts j rows -- Take percentages if needed - report = reportPercent ropts $ PeriodicReport (M.keys colps) sortedrows totalsrow + report = reportPercent ropts $ PeriodicReport (map fst colps) sortedrows totalsrow -- | Build the report rows. -- One row per account, with account name info, row amounts, row total and row average. @@ -368,9 +373,9 @@ -- The total and average for the row. -- These are always simply the sum/average of the displayed row amounts. -- Total for a cumulative/historical report is always the last column. - rowtot = case balancetype_ ropts of - PeriodChange -> maSum rowbals - _ -> lastDef nullmixedamt rowbals + rowtot = case balanceaccum_ ropts of + PerPeriod -> maSum rowbals + _ -> lastDef nullmixedamt rowbals rowavg = averageMixedAmounts rowbals balance = case accountlistmode_ ropts of ALTree -> aibalance; ALFlat -> aebalance @@ -378,7 +383,7 @@ -- their name and depth displayedAccounts :: ReportSpec -> HashMap AccountName (Map DateSpan Account) -> HashMap AccountName DisplayName -displayedAccounts ReportSpec{rsQuery=query,rsOpts=ropts} valuedaccts +displayedAccounts ReportSpec{_rsQuery=query,_rsReportOpts=ropts} valuedaccts | depth == 0 = HM.singleton "..." $ DisplayName "..." "..." 1 | otherwise = HM.mapWithKey (\a _ -> displayedName a) displayedAccts where @@ -402,13 +407,18 @@ -- Accounts interesting for their own sake isInteresting name amts = - d <= depth -- Throw out anything too deep - && ((empty_ ropts && all (null . asubs) amts) -- Keep all leaves when using empty_ - || not (isZeroRow balance amts)) -- Throw out anything with zero balance + d <= depth -- Throw out anything too deep + && ( (empty_ ropts && keepWhenEmpty amts) -- Keep empty accounts when called with --empty + || not (isZeroRow balance amts) -- Keep everything with a non-zero balance in the row + ) where d = accountNameLevel name - balance | ALTree <- accountlistmode_ ropts, d == depth = maybeStripPrices . aibalance - | otherwise = maybeStripPrices . aebalance + keepWhenEmpty = case accountlistmode_ ropts of + ALFlat -> const True -- Keep all empty accounts in flat mode + ALTree -> all (null . asubs) -- Keep only empty leaves in tree mode + balance = maybeStripPrices . case accountlistmode_ ropts of + ALTree | d == depth -> aibalance + _ -> aebalance where maybeStripPrices = if show_costs_ ropts then id else mixedAmountStripPrices -- Accounts interesting because they are a fork for interesting subaccounts @@ -476,9 +486,9 @@ -- Calculate the grand total and average. These are always the sum/average -- of the column totals. -- Total for a cumulative/historical report is always the last column. - grandtotal = case balancetype_ ropts of - PeriodChange -> maSum coltotals - _ -> lastDef nullmixedamt coltotals + grandtotal = case balanceaccum_ ropts of + PerPeriod -> maSum coltotals + _ -> lastDef nullmixedamt coltotals grandaverage = averageMixedAmounts coltotals -- | Map the report rows to percentages if needed @@ -497,9 +507,9 @@ -- | Transpose a Map of HashMaps to a HashMap of Maps. -- -- Makes sure that all DateSpans are present in all rows. -transposeMap :: Map DateSpan (HashMap AccountName a) +transposeMap :: [(DateSpan, HashMap AccountName a)] -> HashMap AccountName (Map DateSpan a) -transposeMap = M.foldrWithKey addSpan mempty +transposeMap = foldr (uncurry addSpan) mempty where addSpan span acctmap seen = HM.foldrWithKey (addAcctSpan span) seen acctmap @@ -554,14 +564,33 @@ cumulativeSum value start = snd . M.mapAccumWithKey accumValued start where accumValued startAmt date newAmt = let s = sumAcct startAmt newAmt in (s, value date s) +-- | Given a table representing a multi-column balance report (for example, +-- made using 'balanceReportAsTable'), render it in a format suitable for +-- console output. Amounts with more than two commodities will be elided +-- unless --no-elide is used. +balanceReportTableAsText :: ReportOpts -> Tab.Table T.Text T.Text WideBuilder -> TB.Builder +balanceReportTableAsText ReportOpts{..} = + Tab.renderTableByRowsB def{Tab.tableBorders=False, Tab.prettyTable=pretty_} renderCh renderRow + where + renderCh + | not commodity_column_ || transpose_ = fmap (Tab.textCell Tab.TopRight) + | otherwise = zipWith ($) (Tab.textCell Tab.TopLeft : repeat (Tab.textCell Tab.TopRight)) + + renderRow (rh, row) + | not commodity_column_ || 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 -tests_MultiBalanceReport = tests "MultiBalanceReport" [ +tests_MultiBalanceReport = testGroup "MultiBalanceReport" [ let - amt0 = Amount {acommodity="$", aquantity=0, aprice=Nothing, astyle=AmountStyle {ascommodityside = L, ascommodityspaced = False, asprecision = Precision 2, asdecimalpoint = Just '.', asdigitgroups = Nothing}, aismultiplier=False} + amt0 = Amount {acommodity="$", aquantity=0, aprice=Nothing, astyle=AmountStyle {ascommodityside = L, ascommodityspaced = False, asprecision = Precision 2, asdecimalpoint = Just '.', asdigitgroups = Nothing}} (rspec,journal) `gives` r = do - let rspec' = rspec{rsQuery=And [queryFromFlags $ rsOpts rspec, rsQuery rspec]} + let rspec' = rspec{_rsQuery=And [queryFromFlags $ _rsReportOpts rspec, _rsQuery rspec]} (eitems, etotal) = r (PeriodicReport _ aitems atotal) = multiBalanceReport rspec' journal showw (PeriodicReportRow a lAmt amt amt') @@ -569,20 +598,20 @@ (map showw aitems) @?= (map showw eitems) showMixedAmountDebug (prrTotal atotal) @?= showMixedAmountDebug etotal -- we only check the sum of the totals in - tests "multiBalanceReport" [ - test "null journal" $ + testGroup "multiBalanceReport" [ + testCase "null journal" $ (defreportspec, nulljournal) `gives` ([], nullmixedamt) - ,test "with -H on a populated period" $ - (defreportspec{rsOpts=defreportopts{period_= PeriodBetween (fromGregorian 2008 1 1) (fromGregorian 2008 1 2), balancetype_=HistoricalBalance}}, samplejournal) `gives` + ,testCase "with -H on a populated period" $ + (defreportspec{_rsReportOpts=defreportopts{period_= PeriodBetween (fromGregorian 2008 1 1) (fromGregorian 2008 1 2), balanceaccum_=Historical}}, samplejournal) `gives` ( - [ PeriodicReportRow (flatDisplayName "assets:bank:checking") [mamountp' "$1.00"] (mamountp' "$1.00") (mixedAmount amt0{aquantity=1}) - , PeriodicReportRow (flatDisplayName "income:salary") [mamountp' "$-1.00"] (mamountp' "$-1.00") (mixedAmount amt0{aquantity=(-1)}) + [ PeriodicReportRow (flatDisplayName "assets:bank:checking") [mixedAmount $ usd 1] (mixedAmount $ usd 1) (mixedAmount amt0{aquantity=1}) + , PeriodicReportRow (flatDisplayName "income:salary") [mixedAmount $ usd (-1)] (mixedAmount $ usd (-1)) (mixedAmount amt0{aquantity=(-1)}) ], - mamountp' "$0.00") + mixedAmount $ usd 0) - -- ,test "a valid history on an empty period" $ - -- (defreportopts{period_= PeriodBetween (fromGregorian 2008 1 2) (fromGregorian 2008 1 3), balancetype_=HistoricalBalance}, samplejournal) `gives` + -- ,testCase "a valid history on an empty period" $ + -- (defreportopts{period_= PeriodBetween (fromGregorian 2008 1 2) (fromGregorian 2008 1 3), balanceaccum_=Historical}, samplejournal) `gives` -- ( -- [ -- ("assets:bank:checking","checking",3, [mamountp' "$1.00"], mamountp' "$1.00",mixedAmount amt0 {aquantity=1}) @@ -590,8 +619,8 @@ -- ], -- mixedAmount usd0) - -- ,test "a valid history on an empty period (more complex)" $ - -- (defreportopts{period_= PeriodBetween (fromGregorian 2009 1 1) (fromGregorian 2009 1 2), balancetype_=HistoricalBalance}, samplejournal) `gives` + -- ,testCase "a valid history on an empty period (more complex)" $ + -- (defreportopts{period_= PeriodBetween (fromGregorian 2009 1 1) (fromGregorian 2009 1 2), balanceaccum_=Historical}, samplejournal) `gives` -- ( -- [ -- ("assets:bank:checking","checking",3, [mamountp' "$1.00"], mamountp' "$1.00",mixedAmount amt0 {aquantity=1}) diff --git a/Hledger/Reports/PostingsReport.hs b/Hledger/Reports/PostingsReport.hs --- a/Hledger/Reports/PostingsReport.hs +++ b/Hledger/Reports/PostingsReport.hs @@ -25,8 +25,8 @@ import Data.List.Extra (nubSort) import Data.Maybe (fromMaybe, isJust, isNothing) import Data.Text (Text) -import Data.Time.Calendar (Day, addDays) -import Safe (headMay, lastMay) +import Data.Time.Calendar (Day) +import Safe (headMay) import Hledger.Data import Hledger.Query @@ -38,44 +38,42 @@ -- transaction info to help with rendering. -- This is used eg for the register command. type PostingsReport = [PostingsReportItem] -- line items, one per posting -type PostingsReportItem = (Maybe Day -- The posting date, if this is the first posting in a - -- transaction or if it's different from the previous - -- posting's date. Or if this a summary posting, the - -- report interval's start date if this is the first - -- summary posting in the interval. - ,Maybe Day -- If this is a summary posting, the report interval's - -- end date if this is the first summary posting in - -- the interval. - ,Maybe Text -- The posting's transaction's description, if this is the first posting in the transaction. - ,Posting -- The posting, possibly with the account name depth-clipped. - ,MixedAmount -- The running total after this posting, or with --average, - -- the running average posting amount. With --historical, - -- postings before the report start date are included in - -- the running total/average. +type PostingsReportItem = (Maybe Day -- The posting date, if this is the first posting in a + -- transaction or if it's different from the previous + -- posting's date. Or if this a summary posting, the + -- report interval's start date if this is the first + -- summary posting in the interval. + ,Maybe Period -- If this is a summary posting, the report interval's period. + ,Maybe Text -- The posting's transaction's description, if this is the first posting in the transaction. + ,Posting -- The posting, possibly with the account name depth-clipped. + ,MixedAmount -- The running total after this posting, or with --average, + -- the running average posting amount. With --historical, + -- postings before the report start date are included in + -- the running total/average. ) -- | A summary posting summarises the activity in one account within a report --- interval. It is kludgily represented by a regular Posting with no description, --- the interval's start date stored as the posting date, and the interval's end --- date attached with a tuple. -type SummaryPosting = (Posting, Day) +-- interval. It is by a regular Posting with no description, the interval's +-- start date stored as the posting date, and the interval's Period attached +-- with a tuple. +type SummaryPosting = (Posting, Period) -- | Select postings from the journal and add running balance and other -- information to make a postings report. Used by eg hledger's register command. postingsReport :: ReportSpec -> Journal -> PostingsReport -postingsReport rspec@ReportSpec{rsOpts=ropts@ReportOpts{..}} j = items +postingsReport rspec@ReportSpec{_rsReportOpts=ropts@ReportOpts{..}} j = items where reportspan = reportSpanBothDates j rspec whichdate = whichDateFromOpts ropts - mdepth = queryDepth $ rsQuery rspec + mdepth = queryDepth $ _rsQuery rspec multiperiod = interval_ /= NoInterval -- postings to be included in the report, and similarly-matched postings before the report start date (precedingps, reportps) = matchedPostingsBeforeAndDuring rspec j reportspan -- Postings, or summary postings with their subperiod's end date, to be displayed. - displayps :: [(Posting, Maybe Day)] - | multiperiod = [(p, Just periodend) | (p, periodend) <- summariseps reportps] + displayps :: [(Posting, Maybe Period)] + | multiperiod = [(p, Just period) | (p, period) <- summariseps reportps] | otherwise = [(p, Nothing) | p <- reportps] where summariseps = summarisePostingsByInterval interval_ whichdate mdepth showempty reportspan @@ -90,7 +88,7 @@ -- may be converting to value per hledger_options.m4.md "Effect -- of --value on reports". -- XXX balance report doesn't value starting balance.. should this ? - historical = balancetype_ == HistoricalBalance + historical = balanceaccum_ == Historical startbal | average_ = if historical then precedingavg else nullmixedamt | otherwise = if historical then precedingsum else nullmixedamt where @@ -114,13 +112,13 @@ -- Date restrictions and depth restrictions in the query are ignored. -- A helper for the postings report. matchedPostingsBeforeAndDuring :: ReportSpec -> Journal -> DateSpan -> ([Posting],[Posting]) -matchedPostingsBeforeAndDuring rspec@ReportSpec{rsOpts=ropts,rsQuery=q} j reportspan = +matchedPostingsBeforeAndDuring rspec@ReportSpec{_rsReportOpts=ropts,_rsQuery=q} j reportspan = dbg5 "beforeps, duringps" $ span (beforestartq `matchesPosting`) beforeandduringps where beforestartq = dbg3 "beforestartq" $ dateqtype $ DateSpan Nothing $ spanStart reportspan beforeandduringps = - dbg5 "ps5" $ sortOn sortdate $ -- sort postings by date or date2 - dbg5 "ps4" $ (if invert_ ropts then map negatePostingAmount else id) $ -- with --invert, invert amounts + 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 @@ -142,15 +140,15 @@ dateq = dbg4 "dateq" $ filterQuery queryIsDateOrDate2 $ dbg4 "q" q -- XXX confused by multiple date:/date2: ? -- | Generate postings report line items from a list of postings or (with --- non-Nothing dates attached) summary postings. -postingsReportItems :: [(Posting,Maybe Day)] -> (Posting,Maybe Day) -> WhichDate -> Maybe Int -> MixedAmount -> (Int -> MixedAmount -> MixedAmount -> MixedAmount) -> Int -> [PostingsReportItem] +-- non-Nothing periods attached) summary postings. +postingsReportItems :: [(Posting,Maybe Period)] -> (Posting,Maybe Period) -> WhichDate -> Maybe Int -> MixedAmount -> (Int -> MixedAmount -> MixedAmount -> MixedAmount) -> Int -> [PostingsReportItem] postingsReportItems [] _ _ _ _ _ _ = [] -postingsReportItems ((p,menddate):ps) (pprev,menddateprev) wd d b runningcalcfn itemnum = - i:(postingsReportItems ps (p,menddate) wd d b' runningcalcfn (itemnum+1)) +postingsReportItems ((p,mperiod):ps) (pprev,mperiodprev) wd d b runningcalcfn itemnum = + i:(postingsReportItems ps (p,mperiod) wd d b' runningcalcfn (itemnum+1)) where - i = mkpostingsReportItem showdate showdesc wd menddate p' b' - (showdate, showdesc) | isJust menddate = (menddate /= menddateprev, False) - | otherwise = (isfirstintxn || isdifferentdate, isfirstintxn) + i = mkpostingsReportItem showdate showdesc wd mperiod p' b' + (showdate, showdesc) | isJust mperiod = (mperiod /= mperiodprev, False) + | otherwise = (isfirstintxn || isdifferentdate, isfirstintxn) isfirstintxn = ptransaction p /= ptransaction pprev isdifferentdate = case wd of PrimaryDate -> postingDate p /= postingDate pprev SecondaryDate -> postingDate2 p /= postingDate2 pprev @@ -160,10 +158,10 @@ -- | Generate one postings report line item, containing the posting, -- the current running balance, and optionally the posting date and/or -- the transaction description. -mkpostingsReportItem :: Bool -> Bool -> WhichDate -> Maybe Day -> Posting -> MixedAmount -> PostingsReportItem -mkpostingsReportItem showdate showdesc wd menddate p b = +mkpostingsReportItem :: Bool -> Bool -> WhichDate -> Maybe Period -> Posting -> MixedAmount -> PostingsReportItem +mkpostingsReportItem showdate showdesc wd mperiod p b = (if showdate then Just date else Nothing - ,menddate + ,mperiod ,if showdesc then tdescription <$> ptransaction p else Nothing ,p ,b @@ -176,10 +174,17 @@ -- aggregated to the specified depth if any. -- Each summary posting will have a non-Nothing interval end date. summarisePostingsByInterval :: Interval -> WhichDate -> Maybe Int -> Bool -> DateSpan -> [Posting] -> [SummaryPosting] -summarisePostingsByInterval interval wd mdepth showempty reportspan ps = concatMap summarisespan $ splitSpan interval reportspan +summarisePostingsByInterval interval wd mdepth showempty reportspan = + 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 where - summarisespan s = summarisePostingsInDateSpan s wd mdepth showempty (postingsinspan s) - postingsinspan s = filter (isPostingInDateSpan' wd s) ps + -- 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 @@ -194,19 +199,18 @@ -- with 0 amount. -- summarisePostingsInDateSpan :: DateSpan -> WhichDate -> Maybe Int -> Bool -> [Posting] -> [SummaryPosting] -summarisePostingsInDateSpan (DateSpan b e) wd mdepth showempty ps +summarisePostingsInDateSpan span@(DateSpan b e) wd mdepth showempty ps | null ps && (isNothing b || isNothing e) = [] - | null ps && showempty = [(summaryp, e')] + | null ps && showempty = [(summaryp, dateSpanAsPeriod span)] | otherwise = summarypes where postingdate = if wd == PrimaryDate then postingDate else postingDate2 b' = fromMaybe (maybe nulldate postingdate $ headMay ps) b - e' = fromMaybe (maybe (addDays 1 nulldate) postingdate $ lastMay ps) e summaryp = nullposting{pdate=Just b'} clippedanames = nub $ map (clipAccountName mdepth) anames summaryps | mdepth == Just 0 = [summaryp{paccount="...",pamount=sumPostings ps}] | otherwise = [summaryp{paccount=a,pamount=balance a} | a <- clippedanames] - summarypes = map (, e') $ (if showempty then id else filter (not . mixedAmountLooksZero . pamount)) summaryps + summarypes = map (, dateSpanAsPeriod span) $ (if showempty then id else filter (not . mixedAmountLooksZero . pamount)) summaryps anames = nubSort $ map paccount ps -- aggregate balances by account, like ledgerFromJournal, then do depth-clipping accts = accountsFromPostings ps @@ -221,10 +225,10 @@ -- tests -tests_PostingsReport = tests "PostingsReport" [ +tests_PostingsReport = testGroup "PostingsReport" [ - test "postingsReport" $ do - let (query, journal) `gives` n = (length $ postingsReport defreportspec{rsQuery=query} journal) @?= n + testCase "postingsReport" $ do + let (query, journal) `gives` n = (length $ postingsReport defreportspec{_rsQuery=query} journal) @?= n -- with the query specified explicitly (Any, nulljournal) `gives` 0 (Any, samplejournal) `gives` 13 @@ -234,9 +238,9 @@ (And [And [Depth 1, StatusQ Cleared], Acct (toRegex' "expenses")], samplejournal) `gives` 2 -- with query and/or command-line options (length $ postingsReport defreportspec samplejournal) @?= 13 - (length $ postingsReport defreportspec{rsOpts=defreportopts{interval_=Months 1}} samplejournal) @?= 11 - (length $ postingsReport defreportspec{rsOpts=defreportopts{interval_=Months 1, empty_=True}} samplejournal) @?= 20 - (length $ postingsReport defreportspec{rsQuery=Acct $ toRegex' "assets:bank:checking"} samplejournal) @?= 5 + (length $ postingsReport defreportspec{_rsReportOpts=defreportopts{interval_=Months 1}} samplejournal) @?= 11 + (length $ postingsReport defreportspec{_rsReportOpts=defreportopts{interval_=Months 1, empty_=True}} samplejournal) @?= 20 + (length $ postingsReport defreportspec{_rsQuery=Acct $ toRegex' "assets:bank:checking"} samplejournal) @?= 5 -- (defreportopts, And [Acct "a a", Acct "'b"], samplejournal2) `gives` 0 -- [(Just (fromGregorian 2008 01 01,"income"),assets:bank:checking $1,$1) @@ -384,7 +388,7 @@ -} - ,test "summarisePostingsByInterval" $ + ,testCase "summarisePostingsByInterval" $ summarisePostingsByInterval (Quarters 1) PrimaryDate Nothing False (DateSpan Nothing Nothing) [] @?= [] -- ,tests_summarisePostingsInDateSpan = [ diff --git a/Hledger/Reports/ReportOptions.hs b/Hledger/Reports/ReportOptions.hs --- a/Hledger/Reports/ReportOptions.hs +++ b/Hledger/Reports/ReportOptions.hs @@ -4,15 +4,26 @@ -} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} module Hledger.Reports.ReportOptions ( ReportOpts(..), + HasReportOptsNoUpdate(..), + HasReportOpts(..), ReportSpec(..), - ReportType(..), - BalanceType(..), + HasReportSpec(..), + overEither, + setEither, + BalanceCalculation(..), + BalanceAccumulation(..), AccountListMode(..), ValuationType(..), defreportopts, @@ -22,7 +33,7 @@ updateReportSpec, updateReportSpecWith, rawOptsToReportSpec, - balanceTypeOverride, + balanceAccumulationOverride, flat_, tree_, reportOptsToggleStatus, @@ -48,8 +59,11 @@ ) where -import Control.Applicative ((<|>)) -import Control.Monad ((<=<)) +import Control.Applicative (Const(..), (<|>)) +import Control.Monad ((<=<), join) +import Data.Either (fromRight) +import Data.Either.Extra (eitherToMaybe) +import Data.Functor.Identity (Identity(..)) import Data.List.Extra (nubSort) import Data.Maybe (fromMaybe, mapMaybe) import qualified Data.Text as T @@ -64,23 +78,27 @@ import Hledger.Utils --- | What is calculated and shown in each cell in a balance report. -data ReportType = ChangeReport -- ^ The sum of posting amounts. - | BudgetReport -- ^ The sum of posting amounts and the goal. - | ValueChangeReport -- ^ The change of value of period-end historical values. +-- | What to calculate for each cell in a balance report. +-- "Balance report types -> Calculation type" in the hledger manual. +data BalanceCalculation = + CalcChange -- ^ Sum of posting amounts in the period. + | CalcBudget -- ^ Sum of posting amounts and the goal for the period. + | CalcValueChange -- ^ Change from previous period's historical end value to this period's historical end value. + | CalcGain -- ^ Change from previous period's gain, i.e. valuation minus cost basis. deriving (Eq, Show) -instance Default ReportType where def = ChangeReport +instance Default BalanceCalculation where def = CalcChange --- | Which "accumulation method" is being shown in a balance report. -data BalanceType = PeriodChange -- ^ The accumulate change over a single period. - | CumulativeChange -- ^ The accumulated change across multiple periods. - | HistoricalBalance -- ^ The historical ending balance, including the effect of - -- all postings before the report period. Unless altered by, - -- a query, this is what you would see on a bank statement. +-- | How to accumulate calculated values across periods (columns) in a balance report. +-- "Balance report types -> Accumulation type" in the hledger manual. +data BalanceAccumulation = + PerPeriod -- ^ No accumulation. Eg, shows the change of balance in each period. + | Cumulative -- ^ Accumulate changes across periods, starting from zero at report start. + | Historical -- ^ Accumulate changes across periods, including any from before report start. + -- Eg, shows the historical end balance of each period. deriving (Eq,Show) -instance Default BalanceType where def = PeriodChange +instance Default BalanceAccumulation where def = PerPeriod -- | Should accounts be displayed: in the command's default style, hierarchically, or as a flat list ? data AccountListMode = ALFlat | ALTree deriving (Eq, Show) @@ -98,13 +116,14 @@ ,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_value_ :: Bool -- ^ Infer market prices from transactions ? + ,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 @@ -113,14 +132,16 @@ -- for account transactions reports (aregister) ,txn_dates_ :: Bool -- for balance reports (bal, bs, cf, is) - ,reporttype_ :: ReportType - ,balancetype_ :: BalanceType + ,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 - ,pretty_tables_ :: Bool ,sort_amount_ :: Bool ,percent_ :: Bool ,invert_ :: Bool -- ^ if true, flip all amount signs in reports @@ -138,6 +159,7 @@ -- whether stdout is an interactive terminal, and the value of -- TERM and existence of NO_COLOR environment variables. ,transpose_ :: Bool + ,commodity_column_:: Bool } deriving (Show) instance Default ReportOpts where def = defreportopts @@ -149,31 +171,33 @@ , statuses_ = [] , cost_ = NoCost , value_ = Nothing - , infer_value_ = False + , 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 - , reporttype_ = def - , balancetype_ = def + , balancecalc_ = def + , balanceaccum_ = def + , budgetpat_ = Nothing , accountlistmode_ = ALFlat , drop_ = 0 , row_total_ = False , no_total_ = False , show_costs_ = False - , pretty_tables_ = False , sort_amount_ = False , percent_ = False , invert_ = False , normalbalance_ = Nothing , color_ = False , transpose_ = False + , commodity_column_ = False } -- | Generate a ReportOpts from raw command-line input, given a day. @@ -181,12 +205,14 @@ -- - an invalid --format argument, -- - an invalid --value argument, -- - if --valuechange is called with a valuation type other than -V/--value=end. +-- - an invalid --pretty argument, rawOptsToReportOpts :: Day -> RawOpts -> ReportOpts rawOptsToReportOpts d rawopts = let formatstring = T.pack <$> maybestringopt "format" rawopts querystring = map T.pack $ listofstringopt "args" rawopts -- doesn't handle an arg like "" right (costing, valuation) = valuationTypeFromRawOpts rawopts + pretty = fromMaybe False $ alwaysneveropt "pretty" rawopts format = case parseStringFormat <$> formatstring of Nothing -> defaultBalanceLineFormat @@ -199,7 +225,7 @@ ,statuses_ = statusesFromRawOpts rawopts ,cost_ = costing ,value_ = valuation - ,infer_value_ = boolopt "infer-market-price" rawopts + ,infer_prices_ = boolopt "infer-market-prices" rawopts ,depth_ = maybeposintopt "depth" rawopts ,date2_ = boolopt "date2" rawopts ,empty_ = boolopt "empty" rawopts @@ -210,8 +236,9 @@ ,average_ = boolopt "average" rawopts ,related_ = boolopt "related" rawopts ,txn_dates_ = boolopt "txn-dates" rawopts - ,reporttype_ = reporttypeopt rawopts - ,balancetype_ = balancetypeopt rawopts + ,balancecalc_ = balancecalcopt rawopts + ,balanceaccum_ = balanceaccumopt rawopts + ,budgetpat_ = maybebudgetpatternopt rawopts ,accountlistmode_ = accountlistmodeopt rawopts ,drop_ = posintopt "drop" rawopts ,row_total_ = boolopt "row-total" rawopts @@ -220,9 +247,10 @@ ,sort_amount_ = boolopt "sort-amount" rawopts ,percent_ = boolopt "percent" rawopts ,invert_ = boolopt "invert" rawopts - ,pretty_tables_ = boolopt "pretty-tables" rawopts + ,pretty_ = pretty ,color_ = useColorOnStdout -- a lower-level helper ,transpose_ = boolopt "transpose" rawopts + ,commodity_column_= boolopt "commodity-column" rawopts } -- | The result of successfully parsing a ReportOpts on a particular @@ -233,51 +261,22 @@ -- `reportOptsToSpec` to regenerate the ReportSpec with the new -- Query. data ReportSpec = ReportSpec - { rsOpts :: ReportOpts -- ^ The underlying ReportOpts used to generate this ReportSpec - , rsToday :: Day -- ^ The Day this ReportSpec is generated for - , rsQuery :: Query -- ^ The generated Query for the given day - , rsQueryOpts :: [QueryOpt] -- ^ A list of QueryOpts for the given day + { _rsReportOpts :: ReportOpts -- ^ The underlying ReportOpts used to generate this ReportSpec + , _rsDay :: Day -- ^ The Day this ReportSpec is generated for + , _rsQuery :: Query -- ^ The generated Query for the given day + , _rsQueryOpts :: [QueryOpt] -- ^ A list of QueryOpts for the given day } deriving (Show) instance Default ReportSpec where def = defreportspec defreportspec :: ReportSpec defreportspec = ReportSpec - { rsOpts = def - , rsToday = nulldate - , rsQuery = Any - , rsQueryOpts = [] + { _rsReportOpts = def + , _rsDay = nulldate + , _rsQuery = Any + , _rsQueryOpts = [] } --- | Generate a ReportSpec from a set of ReportOpts on a given day. -reportOptsToSpec :: Day -> ReportOpts -> Either String ReportSpec -reportOptsToSpec day ropts = do - (argsquery, queryopts) <- parseQueryList day $ querystring_ ropts - return ReportSpec - { rsOpts = ropts - , rsToday = day - , rsQuery = simplifyQuery $ And [queryFromFlags ropts, argsquery] - , rsQueryOpts = queryopts - } - --- | Update the ReportOpts and the fields derived from it in a ReportSpec, --- or return an error message if there is a problem such as missing or --- unparseable options data. This is the safe way to change a ReportSpec, --- ensuring that all fields (rsQuery, rsOpts, querystring_, etc.) are in sync. -updateReportSpec :: ReportOpts -> ReportSpec -> Either String ReportSpec -updateReportSpec ropts rspec = reportOptsToSpec (rsToday rspec) ropts - --- | Like updateReportSpec, but takes a ReportOpts-modifying function. -updateReportSpecWith :: (ReportOpts -> ReportOpts) -> ReportSpec -> Either String ReportSpec -updateReportSpecWith f rspec = reportOptsToSpec (rsToday rspec) . f $ rsOpts rspec - --- | Generate a ReportSpec from RawOpts and the current date. -rawOptsToReportSpec :: RawOpts -> IO ReportSpec -rawOptsToReportSpec rawopts = do - d <- getCurrentDay - let ropts = rawOptsToReportOpts d rawopts - either fail return $ reportOptsToSpec d ropts - accountlistmodeopt :: RawOpts -> AccountListMode accountlistmodeopt = fromMaybe ALFlat . choiceopt parse where @@ -286,29 +285,45 @@ "flat" -> Just ALFlat _ -> Nothing -reporttypeopt :: RawOpts -> ReportType -reporttypeopt = - fromMaybe ChangeReport . choiceopt parse where +-- Get the argument of the --budget option if any, or the empty string. +maybebudgetpatternopt :: RawOpts -> Maybe T.Text +maybebudgetpatternopt = fmap T.pack . maybestringopt "budget" + +balancecalcopt :: RawOpts -> BalanceCalculation +balancecalcopt = + fromMaybe CalcChange . choiceopt parse where parse = \case - "sum" -> Just ChangeReport - "valuechange" -> Just ValueChangeReport - "budget" -> Just BudgetReport + "sum" -> Just CalcChange + "valuechange" -> Just CalcValueChange + "gain" -> Just CalcGain + "budget" -> Just CalcBudget _ -> Nothing -balancetypeopt :: RawOpts -> BalanceType -balancetypeopt = fromMaybe PeriodChange . balanceTypeOverride +balanceaccumopt :: RawOpts -> BalanceAccumulation +balanceaccumopt = fromMaybe PerPeriod . balanceAccumulationOverride -balanceTypeOverride :: RawOpts -> Maybe BalanceType -balanceTypeOverride rawopts = choiceopt parse rawopts <|> reportbal +alwaysneveropt :: String -> RawOpts -> Maybe Bool +alwaysneveropt opt rawopts = case maybestringopt opt rawopts of + Just "always" -> Just True + Just "yes" -> Just True + Just "y" -> Just True + Just "never" -> Just False + Just "no" -> Just False + Just "n" -> Just False + Just _ -> usageError "--pretty's argument should be \"yes\" or \"no\" (or y, n, always, never)" + _ -> Nothing + +balanceAccumulationOverride :: RawOpts -> Maybe BalanceAccumulation +balanceAccumulationOverride rawopts = choiceopt parse rawopts <|> reportbal where parse = \case - "historical" -> Just HistoricalBalance - "cumulative" -> Just CumulativeChange - "change" -> Just PeriodChange + "historical" -> Just Historical + "cumulative" -> Just Cumulative + "change" -> Just PerPeriod _ -> Nothing - reportbal = case reporttypeopt rawopts of - ValueChangeReport -> Just PeriodChange - _ -> Nothing + reportbal = case balancecalcopt rawopts of + CalcValueChange -> Just PerPeriod + _ -> Nothing -- Get the period specified by any -b/--begin, -e/--end and/or -p/--period -- options appearing in the command line. @@ -321,8 +336,7 @@ (Nothing, Nothing) -> PeriodAll (Just b, Nothing) -> PeriodFrom b (Nothing, Just e) -> PeriodTo e - (Just b, Just e) -> simplifyPeriod $ - PeriodBetween b e + (Just b, Just e) -> simplifyPeriod $ PeriodBetween b e where mlastb = case beginDatesFromRawOpts d rawopts of [] -> Nothing @@ -428,16 +442,16 @@ -- to --value, or if --valuechange is called with a valuation type -- other than -V/--value=end. valuationTypeFromRawOpts :: RawOpts -> (Costing, Maybe ValuationType) -valuationTypeFromRawOpts rawopts = (costing, valuation) +valuationTypeFromRawOpts rawopts = case (balancecalcopt rawopts, directcost, directval) of + (CalcValueChange, _, Nothing ) -> (directcost, Just $ AtEnd Nothing) -- If no valuation requested for valuechange, use AtEnd + (CalcValueChange, _, Just (AtEnd _)) -> (directcost, directval) -- If AtEnd valuation requested, use it + (CalcValueChange, _, _ ) -> usageError "--valuechange only produces sensible results with --value=end" + (CalcGain, Cost, _ ) -> usageError "--gain cannot be combined with --cost" + (CalcGain, NoCost, Nothing ) -> (directcost, Just $ AtEnd Nothing) -- If no valuation requested for gain, use AtEnd + (_, _, _ ) -> (directcost, directval) -- Otherwise, use requested valuation where - costing = if (any ((Cost==) . fst) valuationopts) then Cost else NoCost - valuation = case reporttypeopt rawopts of - ValueChangeReport -> case directval of - Nothing -> Just $ AtEnd Nothing -- If no valuation requested for valuechange, use AtEnd - Just (AtEnd _) -> directval -- If AtEnd valuation requested, use it - Just _ -> usageError "--valuechange only produces sensible results with --value=end" - _ -> directval -- Otherwise, use requested valuation - where directval = lastMay $ mapMaybe snd valuationopts + directcost = if Cost `elem` map fst valuationopts then Cost else NoCost + directval = lastMay $ mapMaybe snd valuationopts valuationopts = collectopts valuationfromrawopt rawopts valuationfromrawopt (n,v) -- option name, value @@ -493,14 +507,17 @@ journalApplyValuationFromOpts :: ReportSpec -> Journal -> Journal journalApplyValuationFromOpts rspec j = journalApplyValuationFromOptsWith rspec j priceoracle - where priceoracle = journalPriceOracle (infer_value_ $ rsOpts rspec) j + where priceoracle = journalPriceOracle (infer_prices_ $ _rsReportOpts rspec) j -- | Like journalApplyValuationFromOpts, but takes PriceOracle as an argument. journalApplyValuationFromOptsWith :: ReportSpec -> Journal -> PriceOracle -> Journal -journalApplyValuationFromOptsWith rspec@ReportSpec{rsOpts=ropts} j priceoracle = - journalMapPostings valuation $ costing j +journalApplyValuationFromOptsWith rspec@ReportSpec{_rsReportOpts=ropts} j priceoracle = + case balancecalc_ ropts of + CalcGain -> journalMapPostings (\p -> postingTransformAmount (gain p) p) j + _ -> journalMapPostings (\p -> postingTransformAmount (valuation p) p) $ costing j where - valuation p = maybe id (postingApplyValuation priceoracle styles (periodEnd p) (rsToday rspec)) (value_ ropts) p + valuation p = maybe id (mixedAmountApplyValuation priceoracle styles (periodEnd p) (_rsDay rspec) (postingDate p)) (value_ ropts) + gain p = maybe id (mixedAmountApplyGain priceoracle styles (periodEnd p) (_rsDay rspec) (postingDate p)) (value_ ropts) costing = case cost_ ropts of Cost -> journalToCost NoCost -> id @@ -519,25 +536,30 @@ -> (DateSpan -> MixedAmount -> MixedAmount) mixedAmountApplyValuationAfterSumFromOptsWith ropts j priceoracle = case valuationAfterSum ropts of - Just mc -> \span -> valuation mc span . costing - Nothing -> const id + Just mc -> case balancecalc_ ropts of + CalcGain -> gain mc + _ -> \span -> valuation mc span . costing + Nothing -> const id where valuation mc span = mixedAmountValueAtDate priceoracle styles mc (maybe err (addDays (-1)) $ spanEnd span) - where err = error "mixedAmountApplyValuationAfterSumFromOptsWith: expected all spans to have an end date" + gain mc span = mixedAmountGainAtDate priceoracle styles mc (maybe err (addDays (-1)) $ spanEnd span) costing = case cost_ ropts of Cost -> styleMixedAmount styles . mixedAmountCost NoCost -> id styles = journalCommodityStyles j + err = error "mixedAmountApplyValuationAfterSumFromOptsWith: expected all spans to have an end date" -- | If the ReportOpts specify that we are performing valuation after summing amounts, --- return Just the commodity symbol we're converting to, otherwise return Nothing. +-- return Just of the commodity symbol we're converting to, Just Nothing for the default, +-- and otherwise return Nothing. -- Used for example with historical reports with --value=end. valuationAfterSum :: ReportOpts -> Maybe (Maybe CommoditySymbol) valuationAfterSum ropts = case value_ ropts of Just (AtEnd mc) | valueAfterSum -> Just mc _ -> Nothing - where valueAfterSum = reporttype_ ropts == ValueChangeReport - || balancetype_ ropts /= PeriodChange + where valueAfterSum = balancecalc_ ropts == CalcValueChange + || balancecalc_ ropts == CalcGain + || balanceaccum_ ropts /= PerPeriod -- | Convert report options to a query, ignoring any non-flag command line arguments. @@ -569,7 +591,7 @@ -- | A helper for reportSpan, which takes a Bool indicating whether to use both -- primary and secondary dates. reportSpanHelper :: Bool -> Journal -> ReportSpec -> DateSpan -reportSpanHelper bothdates j ReportSpec{rsQuery=query, rsOpts=ropts} = reportspan +reportSpanHelper bothdates j ReportSpec{_rsQuery=query, _rsReportOpts=ropts} = reportspan where -- The date span specified by -b/-e/-p options and query args if any. requestedspan = dbg3 "requestedspan" $ if bothdates then queryDateSpan' query else queryDateSpan (date2_ ropts) query @@ -603,7 +625,7 @@ -- Get the report's start date. -- If no report period is specified, will be Nothing. reportPeriodStart :: ReportSpec -> Maybe Day -reportPeriodStart = queryStartDate False . rsQuery +reportPeriodStart = queryStartDate False . _rsQuery -- Get the report's start date, or if no report period is specified, -- the journal's start date (the earliest posting date). If there's no @@ -617,7 +639,7 @@ -- more commonly used, exclusive, report end date). -- If no report period is specified, will be Nothing. reportPeriodLastDay :: ReportSpec -> Maybe Day -reportPeriodLastDay = fmap (addDays (-1)) . queryEndDate False . rsQuery +reportPeriodLastDay = fmap (addDays (-1)) . queryEndDate False . _rsQuery -- Get the last day of the overall report period, or if no report -- period is specified, the last day of the journal (ie the latest @@ -627,7 +649,7 @@ reportPeriodOrJournalLastDay :: ReportSpec -> Journal -> Maybe Day reportPeriodOrJournalLastDay rspec j = reportPeriodLastDay rspec <|> journalOrPriceEnd where - journalOrPriceEnd = case value_ $ rsOpts rspec of + journalOrPriceEnd = case value_ $ _rsReportOpts rspec of Just (AtEnd _) -> max (journalLastDay False j) lastPriceDirective _ -> journalLastDay False j lastPriceDirective = fmap (addDays 1) . maximumMay . map pddate $ jpricedirectives j @@ -644,10 +666,131 @@ -- -- - all other balance change reports: a description of the datespan, -- abbreviated to compact form if possible (see showDateSpan). -reportPeriodName :: BalanceType -> [DateSpan] -> DateSpan -> T.Text -reportPeriodName balancetype spans = - case balancetype of - PeriodChange -> if multiyear then showDateSpan else showDateSpanMonthAbbrev +reportPeriodName :: BalanceAccumulation -> [DateSpan] -> DateSpan -> T.Text +reportPeriodName balanceaccumulation spans = + case balanceaccumulation of + PerPeriod -> if multiyear then showDateSpan else showDateSpanMonthAbbrev where multiyear = (>1) $ length $ nubSort $ map spanStartYear spans _ -> maybe "" (showDate . prevday) . spanEnd + +-- lenses + +-- Reportable functors are so that we can create special lenses which can fail +-- and report on their failure. +class Functor f => Reportable f e where + report :: a -> f (Either e a) -> f a + +instance Reportable (Const r) e where + report _ (Const x) = Const x + +instance Reportable Identity e where + report a (Identity i) = Identity $ fromRight a i + +instance Reportable Maybe e where + report _ = (eitherToMaybe =<<) + +instance (e ~ a) => Reportable (Either a) e where + report _ = join + +-- | Apply a function over a lens, but report on failure. +overEither :: ((a -> Either e b) -> s -> Either e t) -> (a -> b) -> s -> Either e t +overEither l f = l (pure . f) + +-- | Set a field using a lens, but report on failure. +setEither :: ((a -> Either e b) -> s -> Either e t) -> b -> s -> Either e t +setEither l = overEither l . const + +type ReportableLens' s a = forall f. Reportable f String => (a -> f a) -> s -> f s + +-- | Lenses for ReportOpts. + +-- Implement HasReportOptsNoUpdate, the basic lenses for ReportOpts. +makeHledgerClassyLenses ''ReportOpts +makeHledgerClassyLenses ''ReportSpec + +-- | Special lenses for ReportOpts which also update the Query and QueryOpts in ReportSpec. +-- Note that these are not true lenses, as they have a further restriction on +-- the functor. This will work as a normal lens for all common uses, but since they +-- don't obey the lens laws for some fancy cases, they may fail in some exotic circumstances. +-- +-- Note that setEither/overEither should only be necessary with +-- querystring and reportOpts: the other lenses should never fail. +-- +-- === Examples: +-- >>> import Lens.Micro (set) +-- >>> _rsQuery <$> setEither querystring ["assets"] defreportspec +-- Right (Acct (RegexpCI "assets")) +-- >>> _rsQuery <$> setEither querystring ["(assets"] defreportspec +-- Left "this regular expression could not be compiled: (assets" +-- >>> _rsQuery $ set querystring ["assets"] defreportspec +-- Acct (RegexpCI "assets") +-- >>> _rsQuery $ set querystring ["(assets"] defreportspec +-- *** Exception: Updating ReportSpec failed: try using overEither instead of over or setEither instead of set +-- >>> _rsQuery $ set period (MonthPeriod 2021 08) defreportspec +-- Date DateSpan 2021-08 +class HasReportOptsNoUpdate a => HasReportOpts a where + reportOpts :: ReportableLens' a ReportOpts + reportOpts = reportOptsNoUpdate + {-# INLINE reportOpts #-} + + period :: ReportableLens' a Period + period = reportOpts.periodNoUpdate + {-# INLINE period #-} + + statuses :: ReportableLens' a [Status] + statuses = reportOpts.statusesNoUpdate + {-# INLINE statuses #-} + + depth :: ReportableLens' a (Maybe Int) + depth = reportOpts.depthNoUpdate + {-# INLINE depth #-} + + date2 :: ReportableLens' a Bool + date2 = reportOpts.date2NoUpdate + {-# INLINE date2 #-} + + real :: ReportableLens' a Bool + real = reportOpts.realNoUpdate + {-# INLINE real #-} + + querystring :: ReportableLens' a [T.Text] + querystring = reportOpts.querystringNoUpdate + {-# INLINE querystring #-} + +instance HasReportOpts ReportOpts + +instance HasReportOptsNoUpdate ReportSpec where + reportOptsNoUpdate = rsReportOpts + +instance HasReportOpts ReportSpec where + reportOpts f rspec = report (error' "Updating ReportSpec failed: try using overEither instead of over or setEither instead of set") $ -- PARTIAL: + reportOptsToSpec (_rsDay rspec) <$> f (_rsReportOpts rspec) + {-# INLINE reportOpts #-} + +-- | Generate a ReportSpec from a set of ReportOpts on a given day. +reportOptsToSpec :: Day -> ReportOpts -> Either String ReportSpec +reportOptsToSpec day ropts = do + (argsquery, queryopts) <- parseQueryList day $ querystring_ ropts + return ReportSpec + { _rsReportOpts = ropts + , _rsDay = day + , _rsQuery = simplifyQuery $ And [queryFromFlags ropts, argsquery] + , _rsQueryOpts = queryopts + } + +-- | Update the ReportOpts and the fields derived from it in a ReportSpec, +-- or return an error message if there is a problem such as missing or +-- unparseable options data. This is the safe way to change a ReportSpec, +-- ensuring that all fields (_rsQuery, _rsReportOpts, querystring_, etc.) are in sync. +updateReportSpec :: ReportOpts -> ReportSpec -> Either String ReportSpec +updateReportSpec = setEither reportOpts + +-- | Like updateReportSpec, but takes a ReportOpts-modifying function. +updateReportSpecWith :: (ReportOpts -> ReportOpts) -> ReportSpec -> Either String ReportSpec +updateReportSpecWith = overEither reportOpts + +-- | Generate a ReportSpec from RawOpts and a provided day, or return an error +-- string if there are regular expression errors. +rawOptsToReportSpec :: Day -> RawOpts -> Either String ReportSpec +rawOptsToReportSpec day = reportOptsToSpec day . rawOptsToReportOpts day diff --git a/Hledger/Reports/ReportTypes.hs b/Hledger/Reports/ReportTypes.hs --- a/Hledger/Reports/ReportTypes.hs +++ b/Hledger/Reports/ReportTypes.hs @@ -64,7 +64,7 @@ -- -- * A list of amounts, one for each column. Depending on the value type, -- these can represent balance changes, ending balances, budget --- performance, etc. (for example, see 'BalanceType' and +-- performance, etc. (for example, see 'BalanceAccumulation' and -- "Hledger.Cli.Commands.Balance"). -- -- * the total of the row's amounts for a periodic report, diff --git a/Hledger/Reports/TransactionsReport.hs b/Hledger/Reports/TransactionsReport.hs deleted file mode 100644 --- a/Hledger/Reports/TransactionsReport.hs +++ /dev/null @@ -1,108 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-| - -A transactions report. Like an EntriesReport, but with more -information such as a running balance. - --} - -module Hledger.Reports.TransactionsReport ( - TransactionsReport, - TransactionsReportItem, - transactionsReport, - transactionsReportByCommodity, - triOrigTransaction, - triDate, - triAmount, - triBalance, - triCommodityAmount, - triCommodityBalance, - tests_TransactionsReport -) -where - -import Data.List (sortBy) -import Data.List.Extra (nubSort) -import Data.Ord (comparing) -import Data.Text (Text) - -import Hledger.Data -import Hledger.Query -import Hledger.Reports.ReportOptions -import Hledger.Reports.AccountTransactionsReport -import Hledger.Utils - - --- | A transactions report includes a list of transactions touching multiple accounts --- (posting-filtered and unfiltered variants), a running balance, and some --- other information helpful for rendering a register view with or without a notion --- of current account(s). Two kinds of report use this data structure, see transactionsReport --- and accountTransactionsReport below for details. -type TransactionsReport = [TransactionsReportItem] -- line items, one per transaction -type TransactionsReportItem = (Transaction -- the original journal transaction, unmodified - ,Transaction -- the transaction as seen from a particular account, with postings maybe filtered - ,Bool -- is this a split, ie more than one other account posting - ,Text -- a display string describing the other account(s), if any - ,MixedAmount -- the amount posted to the current account(s) by the filtered postings (or total amount posted) - ,MixedAmount -- the running total of item amounts, starting from zero; - -- or with --historical, the running total including items - -- (matched by the report query) preceding the report period - ) - -triOrigTransaction (torig,_,_,_,_,_) = torig -triDate (_,tacct,_,_,_,_) = tdate tacct -triAmount (_,_,_,_,a,_) = a -triBalance (_,_,_,_,_,a) = a -triCommodityAmount c = filterMixedAmountByCommodity c . triAmount -triCommodityBalance c = filterMixedAmountByCommodity c . triBalance - --- | Select transactions from the whole journal. This is similar to a --- "postingsReport" except with transaction-based report items which --- are ordered most recent first. XXX Or an EntriesReport - use that instead ? --- This is used by hledger-web's journal view. -transactionsReport :: ReportSpec -> Journal -> Query -> TransactionsReport -transactionsReport rspec j q = items - where - -- XXX items' first element should be the full transaction with all postings - items = reverse $ accountTransactionsReportItems q None nullmixedamt id ts - ts = sortBy (comparing fst) $ map (\t -> (date t, t)) $ filter (q `matchesTransaction`) $ jtxns $ journalApplyValuationFromOpts rspec j - date = transactionDateFn $ rsOpts rspec - --- | Split a transactions report whose items may involve several commodities, --- into one or more single-commodity transactions reports. -transactionsReportByCommodity :: TransactionsReport -> [(CommoditySymbol, TransactionsReport)] -transactionsReportByCommodity tr = - [(c, filterTransactionsReportByCommodity c tr) | c <- transactionsReportCommodities tr] - where - transactionsReportCommodities = nubSort . map acommodity . concatMap (amounts . triAmount) - --- Remove transaction report items and item amount (and running --- balance amount) components that don't involve the specified --- commodity. Other item fields such as the transaction are left unchanged. -filterTransactionsReportByCommodity :: CommoditySymbol -> TransactionsReport -> TransactionsReport -filterTransactionsReportByCommodity c = - fixTransactionsReportItemBalances . concatMap (filterTransactionsReportItemByCommodity c) - where - filterTransactionsReportItemByCommodity c (t,t2,s,o,a,bal) - | c `elem` cs = [item'] - | otherwise = [] - where - cs = map acommodity $ amounts a - item' = (t,t2,s,o,a',bal) - a' = filterMixedAmountByCommodity c a - - fixTransactionsReportItemBalances [] = [] - fixTransactionsReportItemBalances [i] = [i] - fixTransactionsReportItemBalances items = reverse $ i:(go startbal is) - where - i:is = reverse items - startbal = filterMixedAmountByCommodity c $ triBalance i - go _ [] = [] - go bal ((t,t2,s,o,amt,_):is) = (t,t2,s,o,amt,bal'):go bal' is - where bal' = bal `maPlus` amt - --- tests - -tests_TransactionsReport = tests "TransactionsReport" [ - ] diff --git a/Hledger/Utils.hs b/Hledger/Utils.hs --- a/Hledger/Utils.hs +++ b/Hledger/Utils.hs @@ -4,9 +4,7 @@ in the module hierarchy. This is the bottom of hledger's module graph. -} -{-# LANGUAGE CPP #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} module Hledger.Utils (---- provide these frequently used modules - or not, for clearer api: -- module Control.Monad, @@ -26,27 +24,29 @@ module Hledger.Utils.String, module Hledger.Utils.Text, module Hledger.Utils.Test, - module Hledger.Utils.Color, - module Hledger.Utils.Tree, -- Debug.Trace.trace, -- module Data.PPrint, - -- module Hledger.Utils.UTF8IOCompat - error',userError',usageError, -- the rest need to be done in each module I think ) where -import Control.Monad (liftM, when) +import Control.Monad (when) +import Data.Char (toLower) import Data.FileEmbed (makeRelativeToProject, embedStringFile) -import Data.List (foldl', foldl1') --- import Data.String.Here (hereFile) +import Data.List.Extra (foldl', foldl1', uncons, unsnoc) +import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text.IO as T +import qualified Data.Text.Lazy.Builder as TB import Data.Time.Clock (getCurrentTime) import Data.Time.LocalTime (LocalTime, ZonedTime, getCurrentTimeZone, utcToLocalTime, utcToZonedTime) +import Language.Haskell.TH (DecsQ, Name, mkName, nameBase) -- import Language.Haskell.TH.Quote (QuasiQuoter(..)) import Language.Haskell.TH.Syntax (Q, Exp) +import Lens.Micro ((&), (.~)) +import Lens.Micro.TH (DefName(TopName), lensClass, lensField, makeLensesWith, classyRules) +import System.Console.ANSI (Color,ColorIntensity,ConsoleLayer(..), SGR(..), setSGRCode) import System.Directory (getHomeDirectory) import System.FilePath (isRelative, ()) import System.IO @@ -59,11 +59,6 @@ import Hledger.Utils.String import Hledger.Utils.Text import Hledger.Utils.Test -import Hledger.Utils.Color -import Hledger.Utils.Tree --- import Prelude hiding (readFile,writeFile,appendFile,getContents,putStr,putStrLn) --- import Hledger.Utils.UTF8IOCompat (readFile,writeFile,appendFile,getContents,putStr,putStrLn) -import Hledger.Utils.UTF8IOCompat (error',userError',usageError) -- tuples @@ -92,7 +87,6 @@ -- currying - curry2 :: ((a, b) -> c) -> a -> b -> c curry2 f x y = f (x, y) @@ -156,7 +150,7 @@ -- Can raise an error. expandPath :: FilePath -> FilePath -> IO FilePath -- general type sig for use in reader parsers expandPath _ "-" = return "-" -expandPath curdir p = (if isRelative p then (curdir ) else id) `liftM` expandHomePath p +expandPath curdir p = (if isRelative p then (curdir ) else id) <$> expandHomePath p -- PARTIAL: -- | Expand user home path indicated by tilde prefix @@ -231,6 +225,14 @@ mapM' :: Monad f => (a -> f b) -> [a] -> f [b] mapM' f = sequence' . map f +-- | Simpler alias for errorWithoutStackTrace +error' :: String -> a +error' = errorWithoutStackTrace + +-- | A version of errorWithoutStackTrace that adds a usage hint. +usageError :: String -> a +usageError = error' . (++ " (use -h to see usage)") + -- | Like embedFile, but takes a path relative to the package directory. -- Similar to embedFileRelative ? embedFileRelative :: FilePath -> Q Exp @@ -243,6 +245,81 @@ -- where -- QuasiQuoter{quoteExp=hereFileExp} = hereFile -tests_Utils = tests "Utils" [ +-- | Wrap a string in ANSI codes to set and reset foreground colour. +color :: ColorIntensity -> Color -> String -> String +color int col s = setSGRCode [SetColor Foreground int col] ++ s ++ setSGRCode [] + +-- | Wrap a string in ANSI codes to set and reset background colour. +bgColor :: ColorIntensity -> Color -> String -> String +bgColor int col s = setSGRCode [SetColor Background int col] ++ s ++ setSGRCode [] + +-- | Wrap a WideBuilder in ANSI codes to set and reset foreground colour. +colorB :: ColorIntensity -> Color -> WideBuilder -> WideBuilder +colorB int col (WideBuilder s w) = + WideBuilder (TB.fromString (setSGRCode [SetColor Foreground int col]) <> s <> TB.fromString (setSGRCode [])) w + +-- | Wrap a WideBuilder in ANSI codes to set and reset background colour. +bgColorB :: ColorIntensity -> Color -> WideBuilder -> WideBuilder +bgColorB int col (WideBuilder s w) = + WideBuilder (TB.fromString (setSGRCode [SetColor Background int col]) <> s <> TB.fromString (setSGRCode [])) w + + +-- | Make classy lenses for Hledger options fields. +-- This is intended to be used with BalancingOpts, InputOpt, ReportOpts, +-- ReportSpec, and CliOpts. +-- When run on X, it will create a typeclass named HasX (except for ReportOpts, +-- which will be named HasReportOptsNoUpdate) containing all the lenses for that type. +-- If the field name starts with an underscore, the lens name will be created +-- by stripping the underscore from the front on the name. If the field name ends with +-- an underscore, the field name ends with an underscore, the lens name will be +-- mostly created by stripping the underscore, but a few names for which this +-- would create too many conflicts instead have a second underscore appended. +-- ReportOpts fields for which updating them requires updating the query in +-- ReportSpec are instead names by dropping the trailing underscore and +-- appending NoUpdate to the name, e.g. querystring_ -> querystringNoUpdate. +-- +-- There are a few reasons for the complicated rules. +-- - We have some legacy field names ending in an underscore (e.g. value_) +-- which we want to temporarily accommodate, before eventually switching to +-- a more modern style (e.g. _rsReportOpts) +-- - Certain fields in ReportOpts need to update the enclosing ReportSpec when +-- they are updated, and it is a common programming error to forget to do +-- this. We append NoUpdate to those lenses which will not update the +-- enclosing field, and reserve the shorter name for manually define lenses +-- (or at least something lens-like) which will update the ReportSpec. +-- cf. the lengthy discussion here and in surrounding comments: +-- https://github.com/simonmichael/hledger/pull/1545#issuecomment-881974554 +makeHledgerClassyLenses :: Name -> DecsQ +makeHledgerClassyLenses x = flip makeLensesWith x $ classyRules + & lensField .~ (\_ _ n -> fieldName $ nameBase n) + & lensClass .~ (className . nameBase) + where + fieldName n | Just ('_', name) <- uncons n = [TopName (mkName name)] + | Just (name, '_') <- unsnoc n, + name `Set.member` queryFields = [TopName (mkName $ name ++ "NoUpdate")] + | Just (name, '_') <- unsnoc n, + name `Set.member` commonFields = [TopName (mkName $ name ++ "__")] + | Just (name, '_') <- unsnoc n = [TopName (mkName name)] + | otherwise = [] + + -- Fields which would cause too many conflicts if we exposed lenses with these names. + commonFields = Set.fromList + [ "empty", "drop", "color", "transpose" -- ReportOpts + , "anon", "new", "auto" -- InputOpts + , "rawopts", "file", "debug", "width" -- CliOpts + ] + + -- When updating some fields of ReportOpts within a ReportSpec, we need to + -- update the rsQuery term as well. To do this we implement a special + -- HasReportOpts class with some special behaviour. We therefore give the + -- basic lenses a special NoUpdate name to avoid conflicts. + className "ReportOpts" = Just (mkName "HasReportOptsNoUpdate", mkName "reportOptsNoUpdate") + className (x:xs) = Just (mkName ("Has" ++ x:xs), mkName (toLower x : xs)) + className [] = Nothing + + -- Fields of ReportOpts which need to update the Query when they are updated. + queryFields = Set.fromList ["period", "statuses", "depth", "date2", "real", "querystring"] + +tests_Utils = testGroup "Utils" [ tests_Text ] diff --git a/Hledger/Utils/Color.hs b/Hledger/Utils/Color.hs deleted file mode 100644 --- a/Hledger/Utils/Color.hs +++ /dev/null @@ -1,35 +0,0 @@ --- | Basic color helpers for prettifying console output. - -module Hledger.Utils.Color -( - color, - bgColor, - colorB, - bgColorB, - Color(..), - ColorIntensity(..) -) -where - -import qualified Data.Text.Lazy.Builder as TB -import System.Console.ANSI -import Hledger.Utils.Text (WideBuilder(..)) - - --- | Wrap a string in ANSI codes to set and reset foreground colour. -color :: ColorIntensity -> Color -> String -> String -color int col s = setSGRCode [SetColor Foreground int col] ++ s ++ setSGRCode [] - --- | Wrap a string in ANSI codes to set and reset background colour. -bgColor :: ColorIntensity -> Color -> String -> String -bgColor int col s = setSGRCode [SetColor Background int col] ++ s ++ setSGRCode [] - --- | Wrap a WideBuilder in ANSI codes to set and reset foreground colour. -colorB :: ColorIntensity -> Color -> WideBuilder -> WideBuilder -colorB int col (WideBuilder s w) = - WideBuilder (TB.fromString (setSGRCode [SetColor Foreground int col]) <> s <> TB.fromString (setSGRCode [])) w - --- | Wrap a WideBuilder in ANSI codes to set and reset background colour. -bgColorB :: ColorIntensity -> Color -> WideBuilder -> WideBuilder -bgColorB int col (WideBuilder s w) = - WideBuilder (TB.fromString (setSGRCode [SetColor Background int col]) <> s <> TB.fromString (setSGRCode [])) w diff --git a/Hledger/Utils/Debug.hs b/Hledger/Utils/Debug.hs --- a/Hledger/Utils/Debug.hs +++ b/Hledger/Utils/Debug.hs @@ -151,11 +151,11 @@ -- command-line processing. When running with :main in GHCI, you must -- touch and reload this module to see the effect of a new --debug option. -- {-# OPTIONS_GHC -fno-cse #-} --- {-# NOINLINE debugLevel #-} +{-# NOINLINE debugLevel #-} -- Avoid using dbg* in this function (infinite loop). debugLevel :: Int -debugLevel = case snd $ break (=="--debug") args of - "--debug":[] -> 1 +debugLevel = case dropWhile (/="--debug") args of + ["--debug"] -> 1 "--debug":n:_ -> readDef 1 n _ -> case take 1 $ filter ("--debug" `isPrefixOf`) args of @@ -167,14 +167,14 @@ -- Avoid using dbg*, pshow etc. in this function (infinite loop). -- | Check the IO environment to see if ANSI colour codes should be used on stdout. --- This is done using unsafePerformIO so it can be used anywhere, eg in +-- This is done using unsafePerformIO so it can be used anywhere, eg in -- low-level debug utilities, which should be ok since we are just reading. --- The logic is: use color if --- a NO_COLOR environment variable is not defined --- and the program was not started with --color=no|never --- and ( --- the program was started with --color=yes|always --- or stdout supports ANSI color and -o/--output-file was not used or is "-" +-- The logic is: use color if +-- the program was started with --color=yes|always +-- or ( +-- the program was not started with --color=no|never +-- and a NO_COLOR environment variable is not defined +-- and stdout supports ANSI color and -o/--output-file was not used or is "-" -- ). -- Caveats: -- When running code in GHCI, this module must be reloaded to see a change. @@ -200,11 +200,8 @@ no_color <- isJust <$> lookupEnv "NO_COLOR" supports_color <- hSupportsANSIColor h let coloroption = colorOption - return $ and [ - not no_color - ,not $ coloroption `elem` ["never","no"] - ,coloroption `elem` ["always","yes"] || supports_color - ] + return $ coloroption `elem` ["always","yes"] + || (coloroption `notElem` ["never","no"] && not no_color && supports_color) -- Keep synced with color/colour flag definition in hledger:CliOptions. -- Avoid using dbg*, pshow etc. in this function (infinite loop). @@ -217,7 +214,7 @@ colorOption = -- similar to debugLevel let args = unsafePerformIO getArgs in - case snd $ break (=="--color") args of + case dropWhile (/="--color") args of -- --color ARG "--color":v:_ -> v _ -> @@ -225,7 +222,7 @@ -- --color=ARG ['-':'-':'c':'o':'l':'o':'r':'=':v] -> v _ -> - case snd $ break (=="--colour") args of + case dropWhile (/="--colour") args of -- --colour ARG "--colour":v:_ -> v _ -> @@ -240,7 +237,7 @@ -- {-# OPTIONS_GHC -fno-cse #-} -- {-# NOINLINE hasOutputFile #-} hasOutputFile :: Bool -hasOutputFile = not $ outputFileOption `elem` [Nothing, Just "-"] +hasOutputFile = outputFileOption `notElem` [Nothing, Just "-"] -- Keep synced with output-file flag definition in hledger:CliOptions. -- Avoid using dbg*, pshow etc. in this function (infinite loop). @@ -252,13 +249,13 @@ outputFileOption :: Maybe String outputFileOption = let args = unsafePerformIO getArgs in - case snd $ break ("-o" `isPrefixOf`) args of + case dropWhile (not . ("-o" `isPrefixOf`)) args of -- -oARG ('-':'o':v@(_:_)):_ -> Just v -- -o ARG "-o":v:_ -> Just v _ -> - case snd $ break (=="--output-file") args of + case dropWhile (/="--output-file") args of -- --output-file ARG "--output-file":v:_ -> Just v _ -> @@ -272,7 +269,7 @@ -- uses unsafePerformIO. traceAt :: Int -> String -> a -> a traceAt level - | level > 0 && debugLevel < level = flip const + | level > 0 && debugLevel < level = const id | otherwise = trace -- | Trace (print to stderr) a showable value using a custom show function, @@ -286,12 +283,12 @@ -- At level 0, always prints. Otherwise, uses unsafePerformIO. ptraceAt :: Show a => Int -> String -> a -> a ptraceAt level - | level > 0 && debugLevel < level = flip const + | level > 0 && debugLevel < level = const id | otherwise = \s a -> let p = pshow a ls = lines p nlorspace | length ls > 1 = "\n" - | otherwise = " " ++ take (10 - length s) (repeat ' ') - ls' | length ls > 1 = map (" "++) ls + | otherwise = replicate (11 - length s) ' ' + ls' | length ls > 1 = map (' ':) ls | otherwise = ls in trace (s++":"++nlorspace++intercalate "\n" ls') a @@ -441,5 +438,5 @@ -- | Convenience alias for traceParseAt dbgparse :: Int -> String -> TextParser m () -dbgparse level msg = traceParseAt level msg +dbgparse = traceParseAt diff --git a/Hledger/Utils/Parse.hs b/Hledger/Utils/Parse.hs --- a/Hledger/Utils/Parse.hs +++ b/Hledger/Utils/Parse.hs @@ -5,13 +5,22 @@ SimpleStringParser, SimpleTextParser, TextParser, - JournalParser, - ErroringJournalParser, + SourcePos(..), + mkPos, + unPos, + initialPos, + + -- * SourcePos + showSourcePosPair, + showSourcePos, + choice', choiceInState, surroundedBy, parsewith, + runTextParser, + rtp, parsewithString, parseWithState, parseWithState', @@ -34,9 +43,9 @@ ) where -import Control.Monad.Except (ExceptT) import Control.Monad.State.Strict (StateT, evalStateT) import Data.Char +import Data.Functor (void) import Data.Functor.Identity (Identity(..)) import Data.List import Data.Text (Text) @@ -45,9 +54,6 @@ import Text.Megaparsec.Custom import Text.Printf -import Hledger.Data.Types -import Hledger.Utils.UTF8IOCompat (error') - -- | A parser of string to some type. type SimpleStringParser a = Parsec CustomErr String a @@ -57,14 +63,16 @@ -- | A parser of text that runs in some monad. type TextParser m a = ParsecT CustomErr Text m a --- | A parser of text that runs in some monad, keeping a Journal as state. -type JournalParser m a = StateT Journal (ParsecT CustomErr Text m) a +-- | Render source position in human-readable form. +showSourcePos :: SourcePos -> String +showSourcePos (SourcePos fp l c) = + show fp ++ " (line " ++ show (unPos l) ++ ", column " ++ show (unPos c) ++ ")" --- | A parser of text that runs in some monad, keeping a Journal as --- state, that can throw an exception to end parsing, preventing --- further parser backtracking. -type ErroringJournalParser m a = - StateT Journal (ParsecT CustomErr Text (ExceptT FinalParseError m)) a +-- | Render a pair of source position in human-readable form. +showSourcePosPair :: (SourcePos, SourcePos) -> String +showSourcePosPair (SourcePos fp l1 _, SourcePos _ l2 c2) = + show fp ++ " (lines " ++ show (unPos l1) ++ "-" ++ show l2' ++ ")" + where l2' = if unPos c2 == 1 then unPos l2 - 1 else unPos l2 -- might be at end of file withat last new-line -- | Backtracking choice, use this when alternatives share a prefix. -- Consumes no input if all choices fail. @@ -82,6 +90,12 @@ parsewith :: Parsec e Text a -> Text -> Either (ParseErrorBundle Text e) a parsewith p = runParser p "" +-- | Run a text parser in the identity monad. See also: parseWithState. +runTextParser, rtp + :: TextParser Identity a -> Text -> Either (ParseErrorBundle Text CustomErr) a +runTextParser = parsewith +rtp = runTextParser + parsewithString :: Parsec e String a -> String -> Either (ParseErrorBundle String e) a parsewithString p = runParser p "" @@ -94,7 +108,7 @@ -> StateT st (ParsecT CustomErr Text m) a -> Text -> m (Either (ParseErrorBundle Text CustomErr) a) -parseWithState ctx p s = runParserT (evalStateT p ctx) "" s +parseWithState ctx p = runParserT (evalStateT p ctx) "" parseWithState' :: (Stream s) @@ -102,14 +116,14 @@ -> StateT st (ParsecT e s Identity) a -> s -> (Either (ParseErrorBundle s e) a) -parseWithState' ctx p s = runParser (evalStateT p ctx) "" s +parseWithState' ctx p = runParser (evalStateT p ctx) "" fromparse :: (Show t, Show (Token t), Show e) => Either (ParseErrorBundle t e) a -> a fromparse = either parseerror id parseerror :: (Show t, Show (Token t), Show e) => ParseErrorBundle t e -> a -parseerror e = error' $ showParseError e -- PARTIAL: +parseerror e = errorWithoutStackTrace $ showParseError e -- PARTIAL: showParseError :: (Show t, Show (Token t), Show e) @@ -154,4 +168,4 @@ eolof :: TextParser m () -eolof = (newline >> return ()) <|> eof +eolof = void newline <|> eof diff --git a/Hledger/Utils/Regex.hs b/Hledger/Utils/Regex.hs --- a/Hledger/Utils/Regex.hs +++ b/Hledger/Utils/Regex.hs @@ -75,9 +75,7 @@ RegexLike(..), RegexMaker(..), RegexOptions(..), RegexContext(..) ) -import Hledger.Utils.UTF8IOCompat (error') - -- | Regular expression. Extended regular expression-ish syntax ? But does not support eg (?i) syntax. data Regexp = Regexp { reString :: Text, reCompiled :: Regex } @@ -140,11 +138,11 @@ -- Convert a Regexp string to a compiled Regex, throw an error toRegex' :: Text -> Regexp -toRegex' = either error' id . toRegex +toRegex' = either errorWithoutStackTrace id . toRegex -- Like toRegex', but make a case-insensitive Regex. toRegexCI' :: Text -> Regexp -toRegexCI' = either error' id . toRegexCI +toRegexCI' = either errorWithoutStackTrace id . toRegexCI -- | A replacement pattern. May include numeric backreferences (\N). type Replacement = String diff --git a/Hledger/Utils/String.hs b/Hledger/Utils/String.hs --- a/Hledger/Utils/String.hs +++ b/Hledger/Utils/String.hs @@ -134,10 +134,9 @@ words' "" = [] words' s = map stripquotes $ fromparse $ parsewithString p s where - p = do ss <- (singleQuotedPattern <|> doubleQuotedPattern <|> pattern) `sepBy` skipNonNewlineSpaces1 - -- eof - return ss - pattern = many (noneOf whitespacechars) + p = (singleQuotedPattern <|> doubleQuotedPattern <|> patterns) `sepBy` skipNonNewlineSpaces1 + -- eof + patterns = many (noneOf whitespacechars) singleQuotedPattern = between (char '\'') (char '\'') (many $ noneOf "'") doubleQuotedPattern = between (char '"') (char '"') (many $ noneOf "\"") diff --git a/Hledger/Utils/Test.hs b/Hledger/Utils/Test.hs --- a/Hledger/Utils/Test.hs +++ b/Hledger/Utils/Test.hs @@ -7,8 +7,6 @@ ,module Test.Tasty.HUnit -- ,module QC -- ,module SC - ,tests - ,test ,assertLeft ,assertRight ,assertParse @@ -41,21 +39,11 @@ ) import Hledger.Utils.Debug (pshow) --- import Hledger.Utils.UTF8IOCompat (error') -- * tasty helpers -- TODO: pretty-print values in failure messages - --- | Name and group a list of tests. Shorter alias for Test.Tasty.HUnit.testGroup. -tests :: String -> [TestTree] -> TestTree -tests = testGroup - --- | Name an assertion or sequence of assertions. Shorter alias for Test.Tasty.HUnit.testCase. -test :: String -> Assertion -> TestTree -test = testCase - -- | Assert any Left value. assertLeft :: (HasCallStack, Eq b, Show b) => Either a b -> Assertion assertLeft (Left _) = return () @@ -80,7 +68,7 @@ -- | Assert a parser produces an expected value. assertParseEq :: (HasCallStack, Eq a, Show a, Default st) => StateT st (ParsecT CustomErr T.Text IO) a -> T.Text -> a -> Assertion -assertParseEq parser input expected = assertParseEqOn parser input id expected +assertParseEq parser input = assertParseEqOn parser input id -- | Like assertParseEq, but transform the parse result with the given function -- before comparing it. @@ -146,7 +134,7 @@ -> T.Text -> a -> Assertion -assertParseEqE parser input expected = assertParseEqOnE parser input id expected +assertParseEqE parser input = assertParseEqOnE parser input id assertParseEqOnE :: (HasCallStack, Eq b, Show b, Default st) diff --git a/Hledger/Utils/Text.hs b/Hledger/Utils/Text.hs --- a/Hledger/Utils/Text.hs +++ b/Hledger/Utils/Text.hs @@ -41,6 +41,7 @@ -- * wide-character-aware layout WideBuilder(..), wbToText, + wbFromText, wbUnpack, textWidth, textTakeWidth, @@ -58,10 +59,11 @@ import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Builder as TB -import Hledger.Utils.Test ((@?=), test, tests) +import Test.Tasty (testGroup) +import Test.Tasty.HUnit ((@?=), testCase) import Text.Tabular.AsciiWide (Align(..), Header(..), Properties(..), TableOpts(..), renderRow, textCell) -import Text.WideString (WideBuilder(..), wbToText, wbUnpack, charWidth, textWidth) +import Text.WideString (WideBuilder(..), wbToText, wbFromText, wbUnpack, charWidth, textWidth) -- lowercase, uppercase :: String -> String @@ -205,9 +207,9 @@ case mmaxwidth of Just w | textWidth s > w -> - case rightside of - True -> textTakeWidth (w - T.length ellipsis) s <> ellipsis - False -> ellipsis <> T.reverse (textTakeWidth (w - T.length ellipsis) $ T.reverse s) + if rightside + then textTakeWidth (w - T.length ellipsis) s <> ellipsis + else ellipsis <> T.reverse (textTakeWidth (w - T.length ellipsis) $ T.reverse s) | otherwise -> s where ellipsis = if ellipsify then ".." else "" @@ -217,9 +219,9 @@ case mminwidth of Just w | sw < w -> - case rightside of - True -> s <> T.replicate (w - sw) " " - False -> T.replicate (w - sw) " " <> s + if rightside + then s <> T.replicate (w - sw) " " + else T.replicate (w - sw) " " <> s | otherwise -> s Nothing -> s where sw = textWidth s @@ -259,8 +261,8 @@ where step a c = a * 10 + toInteger (digitToInt c) -tests_Text = tests "Text" [ - test "quoteIfSpaced" $ do +tests_Text = testGroup "Text" [ + testCase "quoteIfSpaced" $ do quoteIfSpaced "a'a" @?= "a'a" quoteIfSpaced "a\"a" @?= "a\"a" quoteIfSpaced "a a" @?= "\"a a\"" diff --git a/Hledger/Utils/Tree.hs b/Hledger/Utils/Tree.hs deleted file mode 100644 --- a/Hledger/Utils/Tree.hs +++ /dev/null @@ -1,26 +0,0 @@ -module Hledger.Utils.Tree -( FastTree(..) -, treeFromPaths -) where - --- import Data.Char -import Data.List (foldl') -import qualified Data.Map as M - --- | An efficient-to-build tree suggested by Cale Gibbard, probably --- better than accountNameTreeFrom. -newtype FastTree a = T (M.Map a (FastTree a)) - deriving (Show, Eq, Ord) - -emptyTree :: FastTree a -emptyTree = T M.empty - -mergeTrees :: (Ord a) => FastTree a -> FastTree a -> FastTree a -mergeTrees (T m) (T m') = T (M.unionWith mergeTrees m m') - -treeFromPath :: [a] -> FastTree a -treeFromPath [] = T M.empty -treeFromPath (x:xs) = T (M.singleton x (treeFromPath xs)) - -treeFromPaths :: (Ord a) => [[a]] -> FastTree a -treeFromPaths = foldl' mergeTrees emptyTree . map treeFromPath diff --git a/Hledger/Utils/UTF8IOCompat.hs b/Hledger/Utils/UTF8IOCompat.hs deleted file mode 100644 --- a/Hledger/Utils/UTF8IOCompat.hs +++ /dev/null @@ -1,105 +0,0 @@ -{-# LANGUAGE CPP #-} -{- | - -UTF-8 aware string IO functions that will work across multiple platforms -and GHC versions. Includes code from Text.Pandoc.UTF8 ((C) 2010 John -MacFarlane). - -Example usage: - - import Prelude hiding (readFile,writeFile,appendFile,getContents,putStr,putStrLn) - import UTF8IOCompat (readFile,writeFile,appendFile,getContents,putStr,putStrLn) - import UTF8IOCompat (SystemString,fromSystemString,toSystemString,error',userError') - -2013/4/10 update: we now trust that current GHC versions & platforms -do the right thing, so this file is a no-op and on its way to being removed. -Not carefully tested. - -2019/10/20 update: all packages have base>=4.9 which corresponds to GHC v8.0.1 -and higher. Tear this file apart! - --} --- TODO obsolete ? - -module Hledger.Utils.UTF8IOCompat ( - readFile, - writeFile, - appendFile, - getContents, - hGetContents, - putStr, - putStrLn, - hPutStr, - hPutStrLn, - -- - error', - userError', - usageError, -) -where - --- import Control.Monad (liftM) --- import qualified Data.ByteString.Lazy as B --- import qualified Data.ByteString.Lazy.Char8 as B8 --- import qualified Data.ByteString.Lazy.UTF8 as U8 (toString, fromString) -import Prelude hiding (readFile, writeFile, appendFile, getContents, putStr, putStrLn) -import System.IO -- (Handle) - --- bom :: B.ByteString --- bom = B.pack [0xEF, 0xBB, 0xBF] - --- stripBOM :: B.ByteString -> B.ByteString --- stripBOM s | bom `B.isPrefixOf` s = B.drop 3 s --- stripBOM s = s - --- readFile :: FilePath -> IO String --- readFile = liftM (U8.toString . stripBOM) . B.readFile - --- writeFile :: FilePath -> String -> IO () --- writeFile f = B.writeFile f . U8.fromString - --- appendFile :: FilePath -> String -> IO () --- appendFile f = B.appendFile f . U8.fromString - --- getContents :: IO String --- getContents = liftM (U8.toString . stripBOM) B.getContents - --- hGetContents :: Handle -> IO String --- hGetContents h = liftM (U8.toString . stripBOM) (B.hGetContents h) - --- putStr :: String -> IO () --- putStr = bs_putStr . U8.fromString - --- putStrLn :: String -> IO () --- putStrLn = bs_putStrLn . U8.fromString - --- hPutStr :: Handle -> String -> IO () --- hPutStr h = bs_hPutStr h . U8.fromString - --- hPutStrLn :: Handle -> String -> IO () --- hPutStrLn h = bs_hPutStrLn h . U8.fromString - --- -- span GHC versions including 6.12.3 - 7.4.1: --- bs_putStr = B8.putStr --- bs_putStrLn = B8.putStrLn --- bs_hPutStr = B8.hPut --- bs_hPutStrLn h bs = B8.hPut h bs >> B8.hPut h (B.singleton 0x0a) - --- | A SystemString-aware version of error. -error' :: String -> a -error' = -#if __GLASGOW_HASKELL__ < 800 --- (easier than if base < 4.9) - error -#else - errorWithoutStackTrace -#endif - --- | A SystemString-aware version of userError. -userError' :: String -> IOError -userError' = userError - --- | A SystemString-aware version of error that adds a usage hint. -usageError :: String -> a -usageError = error' . (++ " (use -h to see usage)") - diff --git a/Text/Megaparsec/Custom.hs b/Text/Megaparsec/Custom.hs --- a/Text/Megaparsec/Custom.hs +++ b/Text/Megaparsec/Custom.hs @@ -103,7 +103,7 @@ -- point). parseErrorAt :: Int -> String -> CustomErr -parseErrorAt offset msg = ErrorFailAt offset (offset+1) msg +parseErrorAt offset = ErrorFailAt offset (offset+1) -- | Fail at a specific source interval, given by the raw offsets of its -- endpoints from the start of the input stream (the numbers of tokens diff --git a/Text/Tabular/AsciiWide.hs b/Text/Tabular/AsciiWide.hs --- a/Text/Tabular/AsciiWide.hs +++ b/Text/Tabular/AsciiWide.hs @@ -10,19 +10,24 @@ , render , renderTable , renderTableB +, renderTableByRowsB , renderRow , renderRowB +, renderColumns , Cell(..) , Align(..) , emptyCell , textCell +, textsCell , cellWidth +, concatTables ) where +import Data.Bifunctor (bimap) import Data.Maybe (fromMaybe) import Data.Default (Default(..)) -import Data.List (intersperse, transpose) +import Data.List (intercalate, intersperse, transpose) import Data.Semigroup (stimesMonoid) import Data.Text (Text) import qualified Data.Text as T @@ -30,7 +35,7 @@ import Data.Text.Lazy.Builder (Builder, fromString, fromText, singleton, toLazyText) import Safe (maximumMay) import Text.Tabular -import Text.WideString (WideBuilder(..), textWidth) +import Text.WideString (WideBuilder(..), wbFromText, textWidth) -- | The options to use for rendering a table. @@ -60,6 +65,10 @@ 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 +-- | Create a multi-line cell from the given contents with its natural width. +textsCell :: Align -> [Text] -> Cell +textsCell a = Cell a . fmap wbFromText + -- | Return the width of a Cell. cellWidth :: Cell -> Int cellWidth (Cell _ xs) = fromMaybe 0 . maximumMay $ map wbWidth xs @@ -86,20 +95,31 @@ -> (a -> Cell) -- ^ Function determining the string and width of a cell -> Table rh ch a -> Builder -renderTableB topts@TableOpts{prettyTable=pretty, tableBorders=borders} fr fc f (Table rh ch cells) = +renderTableB topts fr fc f = renderTableByRowsB topts (fmap fc) $ bimap fr (fmap f) + +-- | A version of renderTable that operates on rows (including the 'row' of +-- column headers) and returns the underlying Builder. +renderTableByRowsB :: TableOpts -- ^ Options controlling Table rendering + -> ([ch] -> [Cell]) -- ^ Rendering function for column headers + -> ((rh, [a]) -> (Cell, [Cell])) -- ^ Rendering function for row and row header + -> Table rh ch a + -> Builder +renderTableByRowsB topts@TableOpts{prettyTable=pretty, tableBorders=borders} fc f (Table rh ch cells) = unlinesB . addBorders $ renderColumns topts sizes ch2 : bar VM DoubleLine -- +======================================+ - : renderRs (fmap renderR $ zipHeader [] cellContents rowHeaders) + : renderRs (renderR <$> zipHeader [] cellContents rowHeaders) where + renderR :: ([Cell], Cell) -> Builder renderR (cs,h) = renderColumns topts sizes $ Group DoubleLine [ Header h - , fmap fst $ zipHeader emptyCell cs colHeaders + , fst <$> zipHeader emptyCell cs colHeaders ] - rowHeaders = fmap fr rh - colHeaders = fmap fc ch - cellContents = map (map f) cells + rows = unzip . fmap f $ zip (headerContents rh) cells + rowHeaders = fst <$> zipHeader emptyCell (fst rows) rh + colHeaders = fst <$> zipHeader emptyCell (fc $ headerContents ch) ch + cellContents = snd rows -- ch2 and cell2 include the row and column labels ch2 = Group DoubleLine [Header emptyCell, colHeaders] @@ -108,7 +128,7 @@ -- maximum width for each column sizes = map (fromMaybe 0 . maximumMay . map cellWidth) $ transpose cells2 renderRs (Header s) = [s] - renderRs (Group p hs) = concat . intersperse sep $ map renderRs hs + renderRs (Group p hs) = intercalate sep $ map renderRs hs where sep = renderHLine VM borders pretty sizes ch2 p -- borders and bars @@ -162,6 +182,7 @@ padCell (w, Cell TopRight ls) = map (\x -> fromText (T.replicate (w - wbWidth x) " ") <> wbBuilder x) ls padCell (w, Cell BottomRight ls) = map (\x -> fromText (T.replicate (w - wbWidth x) " ") <> wbBuilder x) ls + -- Pad each cell to have the same number of lines padRow (Cell TopLeft ls) = Cell TopLeft $ ls ++ replicate (nLines - length ls) mempty padRow (Cell TopRight ls) = Cell TopRight $ ls ++ replicate (nLines - length ls) mempty @@ -276,3 +297,9 @@ lineart DoubleLine DoubleLine SingleLine SingleLine = pick "╫" "++" lineart _ _ _ _ = const mempty + + +-- | Add the second table below the first, discarding its column headings. +concatTables :: Properties -> Table rh ch a -> Table rh ch2 a -> Table rh ch a +concatTables prop (Table hLeft hTop dat) (Table hLeft' _ dat') = + Table (Group prop [hLeft, hLeft']) hTop (dat ++ dat') diff --git a/Text/WideString.hs b/Text/WideString.hs --- a/Text/WideString.hs +++ b/Text/WideString.hs @@ -8,7 +8,8 @@ -- * Text Builders which keep track of length WideBuilder(..), wbUnpack, - wbToText + wbToText, + wbFromText ) where import Data.Text (Text) @@ -32,6 +33,10 @@ -- | Convert a WideBuilder to a strict Text. wbToText :: WideBuilder -> Text wbToText = TL.toStrict . TB.toLazyText . wbBuilder + +-- | Convert a strict Text to a WideBuilder. +wbFromText :: Text -> WideBuilder +wbFromText t = WideBuilder (TB.fromText t) (textWidth t) -- | Convert a WideBuilder to a String. wbUnpack :: WideBuilder -> String 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.22.2 +version: 1.23 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 @@ -27,7 +27,7 @@ license-file: LICENSE build-type: Simple tested-with: - GHC==8.6.5, GHC==8.8.4, GHC==8.10.4 + GHC==8.6.5, GHC==8.8.4, GHC==8.10.4, GHC==9.0.1 extra-source-files: CHANGES.md README.md @@ -45,8 +45,9 @@ Hledger.Data.Account Hledger.Data.AccountName Hledger.Data.Amount - Hledger.Data.Commodity + Hledger.Data.Balancing Hledger.Data.Dates + Hledger.Read.InputOptions Hledger.Data.Journal Hledger.Data.Json Hledger.Data.Ledger @@ -76,17 +77,13 @@ Hledger.Reports.EntriesReport Hledger.Reports.MultiBalanceReport Hledger.Reports.PostingsReport - Hledger.Reports.TransactionsReport Hledger.Utils - Hledger.Utils.Color Hledger.Utils.Debug Hledger.Utils.Parse Hledger.Utils.Regex Hledger.Utils.String Hledger.Utils.Test Hledger.Utils.Text - Hledger.Utils.Tree - Hledger.Utils.UTF8IOCompat Text.Tabular.AsciiWide other-modules: Text.Megaparsec.Custom @@ -102,7 +99,7 @@ , aeson-pretty , ansi-terminal >=0.9 , array - , base >=4.10.1.0 && <4.16 + , base >=4.11 && <4.16 , base-compat-batteries >=0.10.1 && <0.12 , blaze-markup >=0.5.1 , bytestring @@ -118,8 +115,9 @@ , filepath , hashtables >=1.2.3.1 , megaparsec >=7.0.0 && <9.2 + , microlens >=0.4 + , microlens-th >=0.4 , mtl >=2.2.1 - , old-time , parser-combinators >=0.4.0 , pretty-simple >4 && <5 , regex-tdfa @@ -151,7 +149,7 @@ , aeson-pretty , ansi-terminal >=0.9 , array - , base >=4.10.1.0 && <4.16 + , base >=4.11 && <4.16 , base-compat-batteries >=0.10.1 && <0.12 , blaze-markup >=0.5.1 , bytestring @@ -162,14 +160,15 @@ , containers >=0.5.9 , data-default >=0.5 , directory - , doctest >=0.16.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 + , microlens >=0.4 + , microlens-th >=0.4 , mtl >=2.2.1 - , old-time , parser-combinators >=0.4.0 , pretty-simple >4 && <5 , regex-tdfa @@ -185,7 +184,7 @@ , uglymemo , unordered-containers >=0.2 , utf8-string >=0.3.5 - if (impl(ghc < 8.2)) + if impl(ghc >= 9.0) buildable: False default-language: Haskell2010 @@ -203,7 +202,7 @@ , aeson-pretty , ansi-terminal >=0.9 , array - , base >=4.10.1.0 && <4.16 + , base >=4.11 && <4.16 , base-compat-batteries >=0.10.1 && <0.12 , blaze-markup >=0.5.1 , bytestring @@ -220,8 +219,9 @@ , hashtables >=1.2.3.1 , hledger-lib , megaparsec >=7.0.0 && <9.2 + , microlens >=0.4 + , microlens-th >=0.4 , mtl >=2.2.1 - , old-time , parser-combinators >=0.4.0 , pretty-simple >4 && <5 , regex-tdfa diff --git a/test/doctests.hs b/test/doctests.hs --- a/test/doctests.hs +++ b/test/doctests.hs @@ -2,6 +2,8 @@ Run doctests in Hledger source files under the current directory (./Hledger.hs, ./Hledger/**, ./Text/**) using the doctest runner. +https://github.com/sol/doctest#readme + Arguments are case-insensitive file path substrings, to limit the files searched. --verbose shows files being searched for doctests and progress while running. --slow reloads ghci between each test (https://github.com/sol/doctest#a-note-on-performance). @@ -12,7 +14,7 @@ or: -$ stack test hledger-lib:test:doctests [--test-arguments '[--verbose] [--slow] [CIFILEPATHSUBSTRINGS]'] +$ stack test hledger-lib:test:doctest --test-arguments="--verbose --slow [CIFILEPATHSUBSTRINGS]" -} -- This file can't be called doctest.hs ("File name does not match module name")