hledger-lib 1.43.2 → 1.50

raw patch · 35 files changed

+2233/−1280 lines, 35 filesdep +thesedep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: these

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• CHANGES.md +31/−3
• Hledger/Data.hs +8/−1
• Hledger/Data/Account.hs +168/−85
• Hledger/Data/Amount.hs +81/−6
• Hledger/Data/BalanceData.hs +59/−0
• Hledger/Data/Balancing.hs +29/−17
• Hledger/Data/Dates.hs +120/−34
• Hledger/Data/Journal.hs +59/−79
• Hledger/Data/Json.hs +24/−10
• Hledger/Data/Ledger.hs +7/−5
• Hledger/Data/PeriodData.hs +127/−0
• Hledger/Data/PeriodicTransaction.hs +1/−1
• Hledger/Data/Posting.hs +1/−1
• Hledger/Data/Timeclock.hs +167/−134
• Hledger/Data/Transaction.hs +31/−1
• Hledger/Data/TransactionModifier.hs +5/−0
• Hledger/Data/Types.hs +33/−13
• Hledger/Query.hs +42/−22
• Hledger/Read.hs +7/−9
• Hledger/Read/Common.hs +80/−50
• Hledger/Read/CsvReader.hs +9/−6
• Hledger/Read/JournalReader.hs +216/−104
• Hledger/Read/RulesReader.hs +280/−56
• Hledger/Read/TimeclockReader.hs +151/−38
• Hledger/Read/TimedotReader.hs +4/−4
• Hledger/Reports/AccountTransactionsReport.hs +7/−9
• Hledger/Reports/BudgetReport.hs +59/−97
• Hledger/Reports/MultiBalanceReport.hs +288/−365
• Hledger/Reports/PostingsReport.hs +2/−2
• Hledger/Reports/ReportOptions.hs +57/−38
• Hledger/Utils.hs +7/−0
• Hledger/Utils/IO.hs +32/−21
• Hledger/Utils/Parse.hs +27/−59
• Hledger/Utils/Regex.hs +3/−4
• hledger-lib.cabal +11/−6

@@ -11,16 +11,44 @@  Improvements +--> +Internal/api/developer-ish changes in the hledger-lib (and hledger) packages.+For user-visible changes, see the hledger package changelog.  +# 1.50 2025-09-03 +Breaking changes +- hledger now requires at least GHC 9.6 (and base 4.18), to ease maintenance. --->-Internal/api/developer-ish changes in the hledger-lib (and hledger) packages.-For user-visible changes, see the hledger package changelog.+Fixes +- Fix liftA2 build error with ghc <9.6 (broken since 1.43.1).++Improvements++- Account now stores balances, one per date period. This enables it do+  the hard work in MultiBalanceReport.+  Some new types are created to enable convenient operation of accounts:+  - `BalanceData` is a type which stores an exclusive balance, inclusive+    balance, and number of postings. This was previously directly stored+    in Account, but is now factored into a separate data type.+  - `PeriodData` is a container which stores date-indexed data, as well as+    pre-period data. In post cases, this represents the report spans,+    along with the historical data.+  - Account becomes polymorphic, allowing customisation of the type of+    data it stores. This will usually be `BalanceData`, but in+    `BudgetReport` it can use `These BalanceData BalanceData` to store+    both actuals and budgets in the same structure. The data structure+    changes to contain a `PeriodData`, allowing multiperiod accounts.+  (Stephen Morgan)+- Hledger.Read: make LatestDatesForFile showable+- Hledger.Read.Common: accountnamep and modifiedaccountnamep now take a flag to allow semicolons or not+- Hledger.Utils.IO: getFlag, warnIO, rename exitOnError -> handleExit, improve doc+- Hledger.Query: matchesCommodity handles all query types, not just cur:, and doesn't match by default+- Hledger.Data.Amount: move commodityStylesFromAmounts here, drop canonicalStyleFrom  # 1.43.2 2025-06-13 

@@ -10,6 +10,8 @@  module Hledger.Data (                module Hledger.Data.Account,+               module Hledger.Data.BalanceData,+               module Hledger.Data.PeriodData,                module Hledger.Data.AccountName,                module Hledger.Data.Amount,                module Hledger.Data.Balancing,@@ -36,6 +38,8 @@  import Test.Tasty (testGroup) import Hledger.Data.Account+import Hledger.Data.BalanceData+import Hledger.Data.PeriodData import Hledger.Data.AccountName import Hledger.Data.Amount import Hledger.Data.Balancing@@ -58,7 +62,10 @@ import Hledger.Data.Valuation  tests_Data = testGroup "Data" [-   tests_AccountName+   tests_Account+  ,tests_AccountName+  ,tests_BalanceData+  ,tests_PeriodData   ,tests_Amount   ,tests_Balancing   -- ,tests_Currency

@@ -1,6 +1,7 @@-{-# LANGUAGE CPP               #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards   #-}+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE RecordWildCards     #-}+{-# LANGUAGE ScopedTypeVariables #-} {-|  @@ -11,8 +12,11 @@  module Hledger.Data.Account ( nullacct+, accountFromBalances+, accountFromPostings , accountsFromPostings , accountTree+, accountTreeFromBalanceAndNames , showAccounts , showAccountsBoringFlag , printAccounts@@ -20,6 +24,7 @@ , parentAccounts , accountsLevels , mapAccounts+, mapPeriodData , anyAccounts , filterAccounts , sumAccounts@@ -27,38 +32,53 @@ , clipAccountsAndAggregate , pruneAccounts , flattenAccounts+, mergeAccounts , accountSetDeclarationInfo , sortAccountNamesByDeclaration-, sortAccountTreeByAmount+, sortAccountTreeByDeclaration+, sortAccountTreeOn+-- -- * Tests+, tests_Account ) where +import Control.Applicative ((<|>)) import qualified Data.HashSet as HS import qualified Data.HashMap.Strict as HM+import qualified Data.IntMap as IM import Data.List (find, sortOn) #if !MIN_VERSION_base(4,20,0) import Data.List (foldl') #endif-import Data.List.Extra (groupOn)+import Data.List.NonEmpty (NonEmpty(..), groupWith) import qualified Data.Map as M-import Data.Ord (Down(..))+import Data.Maybe (fromMaybe)+import qualified Data.Text as T+import Data.These (These(..))+import Data.Time (Day(..), fromGregorian) import Safe (headMay) import Text.Printf (printf) -import Hledger.Data.AccountName (expandAccountName, clipOrEllipsifyAccountName)+import Hledger.Data.BalanceData ()+import Hledger.Data.PeriodData+import Hledger.Data.AccountName import Hledger.Data.Amount import Hledger.Data.Types+import Hledger.Utils   -- deriving instance Show Account-instance Show Account where-    show Account{..} = printf "Account %s (boring:%s, postings:%d, ebalance:%s, ibalance:%s)"-                       aname-                       (if aboring then "y" else "n" :: String)-                       anumpostings-                       (wbUnpack $ showMixedAmountB defaultFmt aebalance)-                       (wbUnpack $ showMixedAmountB defaultFmt aibalance)+instance Show a => Show (Account a) where+  showsPrec d acct =+    showParen (d > 10) $+       showString "Account "+      . showString (T.unpack $ aname acct)+      . showString " (boring:"+      . showString (if aboring acct then "y" else "n")+      . showString ", adata:"+      . shows (adata acct)+      . showChar ')' -instance Eq Account where+instance Eq (Account a) where   (==) a b = aname a == aname b -- quick equality test for speed              -- and              -- [ aname a == aname b@@ -68,50 +88,73 @@              -- , aibalance a == aibalance b              -- ] -nullacct = Account-  { aname            = ""+nullacct :: Account BalanceData+nullacct = accountFromBalances "" mempty++-- | Construct an 'Account" from an account name and balances. Other fields are+-- left blank.+accountFromBalances :: AccountName -> PeriodData a -> Account a+accountFromBalances name bal = Account+  { aname            = name   , adeclarationinfo = Nothing   , asubs            = []   , aparent          = Nothing   , aboring          = False-  , anumpostings     = 0-  , aebalance        = nullmixedamt-  , aibalance        = nullmixedamt+  , adata            = bal   } --- | Derive 1. an account tree and 2. each account's total exclusive--- and inclusive changes from a list of postings.+-- | Derive 1. an account tree and 2. each account's total exclusive and+-- inclusive changes associated with dates from a list of postings and a+-- function for associating a date to each posting (usually representing the+-- start dates of report subperiods). -- This is the core of the balance command (and of *ledger). -- The accounts are returned as a list in flattened tree order, -- and also reference each other as a tree. -- (The first account is the root of the tree.)-accountsFromPostings :: [Posting] -> [Account]-accountsFromPostings ps =-  let-    summed = foldr (\p -> HM.insertWith addAndIncrement (paccount p) (1, pamount p)) mempty ps-      where addAndIncrement (n, a) (m, b) = (n + m, a `maPlus` b)-    acctstree      = accountTree "root" $ HM.keys summed-    acctswithebals = mapAccounts setnumpsebalance acctstree-      where setnumpsebalance a = a{anumpostings=numps, aebalance=total}-              where (numps, total) = HM.lookupDefault (0, nullmixedamt) (aname a) summed-    acctswithibals = sumAccounts acctswithebals-    acctswithparents = tieAccountParents acctswithibals-    acctsflattened = flattenAccounts acctswithparents-  in-    acctsflattened+accountsFromPostings :: (Posting -> Maybe Day) -> [Posting] -> [Account BalanceData]+accountsFromPostings getPostingDate = flattenAccounts . accountFromPostings getPostingDate +-- | Derive 1. an account tree and 2. each account's total exclusive+-- and inclusive changes associated with dates from a list of postings and a+-- function for associating a date to each posting (usually representing the+-- start dates of report subperiods).+-- This is the core of the balance command (and of *ledger).+-- The accounts are returned as a tree.+accountFromPostings :: (Posting -> Maybe Day) -> [Posting] -> Account BalanceData+accountFromPostings getPostingDate ps =+    tieAccountParents . sumAccounts $ mapAccounts setBalance acctTree+  where+    -- The special name "..." is stored in the root of the tree+    acctTree     = accountTree "root" . HM.keys $ HM.delete "..." accountMap+    setBalance a = a{adata = HM.lookupDefault mempty name accountMap}+      where name = if aname a == "root" then "..." else aname a+    accountMap   = processPostings ps++    processPostings :: [Posting] -> HM.HashMap AccountName (PeriodData BalanceData)+    processPostings = foldl' (flip processAccountName) mempty+      where+        processAccountName p = HM.alter (updateBalanceData p) (paccount p)+        updateBalanceData p = Just+                            . insertPeriodData (getPostingDate p) (BalanceData (pamount p) nullmixedamt 1)+                            . fromMaybe mempty+ -- | Convert a list of account names to a tree of Account objects,--- with just the account names filled in.+-- with just the account names filled in and an empty balance. -- A single root account with the given name is added.-accountTree :: AccountName -> [AccountName] -> Account-accountTree rootname as = nullacct{aname=rootname, asubs=map (uncurry accountTree') $ M.assocs m }+accountTree :: Monoid a => AccountName -> [AccountName] -> Account a+accountTree rootname = accountTreeFromBalanceAndNames rootname mempty++-- | Convert a list of account names to a tree of Account objects,+-- with just the account names filled in. Each account is given the same+-- supplied balance.+-- A single root account with the given name is added.+accountTreeFromBalanceAndNames :: AccountName -> PeriodData a -> [AccountName] -> Account a+accountTreeFromBalanceAndNames rootname bals as =+    (accountFromBalances rootname bals){ asubs=map (uncurry accountTree') $ M.assocs m }   where     T m = treeFromPaths $ map expandAccountName as :: FastTree AccountName     accountTree' a (T m') =-      nullacct{-        aname=a-       ,asubs=map (uncurry accountTree') $ M.assocs m'-       }+      (accountFromBalances a bals){ asubs=map (uncurry accountTree') $ M.assocs m' }  -- | An efficient-to-build tree suggested by Cale Gibbard, probably -- better than accountNameTreeFrom.@@ -130,7 +173,7 @@   -- | Tie the knot so all subaccounts' parents are set correctly.-tieAccountParents :: Account -> Account+tieAccountParents :: Account a -> Account a tieAccountParents = tie Nothing   where     tie parent a@Account{..} = a'@@ -138,35 +181,50 @@         a' = a{aparent=parent, asubs=map (tie (Just a')) asubs}  -- | Get this account's parent accounts, from the nearest up to the root.-parentAccounts :: Account -> [Account]+parentAccounts :: Account a -> [Account a] parentAccounts Account{aparent=Nothing} = [] parentAccounts Account{aparent=Just a} = a:parentAccounts a  -- | List the accounts at each level of the account tree.-accountsLevels :: Account -> [[Account]]+accountsLevels :: Account a -> [[Account a]] accountsLevels = takeWhile (not . null) . iterate (concatMap asubs) . (:[])  -- | Map a (non-tree-structure-modifying) function over this and sub accounts.-mapAccounts :: (Account -> Account) -> Account -> Account+mapAccounts :: (Account a -> Account a) -> Account a -> Account a mapAccounts f a = f a{asubs = map (mapAccounts f) $ asubs a} +-- | Apply a function to all 'PeriodData' within this and sub accounts.+mapPeriodData :: (PeriodData a -> PeriodData a) -> Account a -> Account a+mapPeriodData f = mapAccounts (\a -> a{adata = f $ adata a})+ -- | Is the predicate true on any of this account or its subaccounts ?-anyAccounts :: (Account -> Bool) -> Account -> Bool+anyAccounts :: (Account a -> Bool) -> Account a -> Bool anyAccounts p a     | p a = True     | otherwise = any (anyAccounts p) $ asubs a --- | Add subaccount-inclusive balances to an account tree.-sumAccounts :: Account -> Account-sumAccounts a-  | null $ asubs a = a{aibalance=aebalance a}-  | otherwise      = a{aibalance=ibal, asubs=subs}+-- | Is the predicate true on all of this account and its subaccounts ?+allAccounts :: (Account a -> Bool) -> Account a -> Bool+allAccounts p a+    | not (p a) = False+    | otherwise = all (allAccounts p) $ asubs a++-- | Recalculate all the subaccount-inclusive balances in this tree.+sumAccounts :: Account BalanceData -> Account BalanceData+sumAccounts a = a{asubs = subs, adata = setInclusiveBalances $ adata a}   where     subs = map sumAccounts $ asubs a-    ibal = maSum $ aebalance a : map aibalance subs+    subtotals = foldMap adata subs +    setInclusiveBalances :: PeriodData BalanceData -> PeriodData BalanceData+    setInclusiveBalances = mergePeriodData onlyChildren noChildren combineChildren subtotals++    combineChildren children this = this  {bdincludingsubs = bdexcludingsubs this <> bdincludingsubs children}+    onlyChildren    children      = mempty{bdincludingsubs = bdincludingsubs children}+    noChildren               this = this  {bdincludingsubs = bdexcludingsubs this}+ -- | Remove all subaccounts below a certain depth.-clipAccounts :: Int -> Account -> Account+clipAccounts :: Int -> Account a -> Account a clipAccounts 0 a = a{asubs=[]} clipAccounts d a = a{asubs=subs}     where@@ -175,13 +233,14 @@ -- | Remove subaccounts below the specified depth, aggregating their balance at the depth limit -- (accounts at the depth limit will have any sub-balances merged into their exclusive balance). -- If the depth is Nothing, return the original accounts-clipAccountsAndAggregate :: DepthSpec -> [Account] -> [Account]+clipAccountsAndAggregate :: Monoid a => DepthSpec -> [Account a] -> [Account a] clipAccountsAndAggregate (DepthSpec Nothing []) as = as-clipAccountsAndAggregate d                      as = combined+clipAccountsAndAggregate depthSpec              as = combined     where-      clipped  = [a{aname=clipOrEllipsifyAccountName d $ aname a} | a <- as]-      combined = [a{aebalance=maSum $ map aebalance same}-                 | same@(a:_) <- groupOn aname clipped]+      clipped  = [a{aname=clipOrEllipsifyAccountName depthSpec $ aname a} | a <- as]+      combined = [a{adata=foldMap adata same}+                 | same@(a:|_) <- groupWith aname clipped]+ {- test cases, assuming d=1: @@ -211,7 +270,7 @@ -}  -- | Remove all leaf accounts and subtrees matching a predicate.-pruneAccounts :: (Account -> Bool) -> Account -> Maybe Account+pruneAccounts :: (Account a -> Bool) -> Account a -> Maybe (Account a) pruneAccounts p = headMay . prune   where     prune a@@ -224,33 +283,47 @@ -- | Flatten an account tree into a list, which is sometimes -- convenient. Note since accounts link to their parents/subs, the -- tree's structure remains intact and can still be used. It's a tree/list!-flattenAccounts :: Account -> [Account]+flattenAccounts :: Account a -> [Account a] flattenAccounts a = squish a []   where squish a' as = a' : Prelude.foldr squish as (asubs a')  -- | Filter an account tree (to a list).-filterAccounts :: (Account -> Bool) -> Account -> [Account]+filterAccounts :: (Account a -> Bool) -> Account a -> [Account a] filterAccounts p a     | p a       = a : concatMap (filterAccounts p) (asubs a)     | otherwise = concatMap (filterAccounts p) (asubs a) --- | Sort each group of siblings in an account tree by inclusive amount,--- so that the accounts with largest normal balances are listed first.--- The provided normal balance sign determines whether normal balances--- are negative or positive, affecting the sort order. Ie,--- if balances are normally negative, then the most negative balances--- sort first, and vice versa.-sortAccountTreeByAmount :: NormalSign -> Account -> Account-sortAccountTreeByAmount normalsign = mapAccounts $ \a -> a{asubs=sortSubs $ asubs a}+-- | Merge two account trees and their subaccounts.+--+-- This assumes that the top-level 'Account's have the same name.+mergeAccounts :: Account a -> Account b -> Account (These a b)+mergeAccounts a = tieAccountParents . merge a   where-    sortSubs = case normalsign of-        NormallyPositive -> sortOn (\a -> (Down $ amt a, aname a))-        NormallyNegative -> sortOn (\a -> (amt a, aname a))-    amt = mixedAmountStripCosts . aibalance+    merge acct1 acct2 = acct1+       { adeclarationinfo = adeclarationinfo acct1 <|> adeclarationinfo acct2+       , aparent = Nothing+       , aboring = aboring acct1 && aboring acct2+       , adata = mergeBalances (adata acct1) (adata acct2)+       , asubs = mergeSubs (sortOn aname $ asubs acct1) (sortOn aname $ asubs acct2)+       } +    mergeSubs (x:xs) (y:ys) = case compare (aname x) (aname y) of+      EQ -> merge x y : mergeSubs xs ys+      LT -> fmap This x : mergeSubs xs (y:ys)+      GT -> fmap That y : mergeSubs (x:xs) ys+    mergeSubs xs [] = map (fmap This) xs+    mergeSubs [] ys = map (fmap That) ys++    mergeBalances = mergePeriodData This That These++-- | Sort each group of siblings in an account tree by projecting through+-- a provided function.+sortAccountTreeOn :: Ord b => (Account a -> b) -> Account a -> Account a+sortAccountTreeOn f = mapAccounts $ \a -> a{asubs=sortOn f $ asubs a}+ -- | Add extra info for this account derived from the Journal's -- account directives, if any (comment, tags, declaration order..).-accountSetDeclarationInfo :: Journal -> Account -> Account+accountSetDeclarationInfo :: Journal -> Account a -> Account a accountSetDeclarationInfo j a@Account{..} =   a{ adeclarationinfo=lookup aname $ jdeclaredaccounts j } @@ -271,14 +344,13 @@     flattenAccounts $                                   -- convert to an account list     sortAccountTreeByDeclaration $                      -- sort by declaration order (and name)     mapAccounts (accountSetDeclarationInfo j) $         -- add declaration order info-    accountTree "root"                                  -- convert to an account tree-    as+    (accountTree "root" as :: Account ())               -- convert to an account tree  -- | Sort each group of siblings in an account tree by declaration order, then account name. -- So each group will contain first the declared accounts, -- in the same order as their account directives were parsed, -- and then the undeclared accounts, sorted by account name.-sortAccountTreeByDeclaration :: Account -> Account+sortAccountTreeByDeclaration :: Account a -> Account a sortAccountTreeByDeclaration a   | null $ asubs a = a   | otherwise      = a{asubs=@@ -286,26 +358,37 @@       map sortAccountTreeByDeclaration $ asubs a       } -accountDeclarationOrderAndName :: Account -> (Int, AccountName)+accountDeclarationOrderAndName :: Account a -> (Int, AccountName) accountDeclarationOrderAndName a = (adeclarationorder', aname a)   where     adeclarationorder' = maybe maxBound adideclarationorder $ adeclarationinfo a  -- | Search an account list by name.-lookupAccount :: AccountName -> [Account] -> Maybe Account+lookupAccount :: AccountName -> [Account a] -> Maybe (Account a) lookupAccount a = find ((==a).aname)  -- debug helpers -printAccounts :: Account -> IO ()+printAccounts :: Show a => Account a -> IO () printAccounts = putStrLn . showAccounts +showAccounts :: Show a => Account a -> String showAccounts = unlines . map showAccountDebug . flattenAccounts  showAccountsBoringFlag = unlines . map (show . aboring) . flattenAccounts -showAccountDebug a = printf "%-25s %4s %4s %s"+showAccountDebug a = printf "%-25s %s %4s"                      (aname a)-                     (wbUnpack . showMixedAmountB defaultFmt $ aebalance a)-                     (wbUnpack . showMixedAmountB defaultFmt $ aibalance a)                      (if aboring a then "b" else " " :: String)+                     (show $ adata a)+++tests_Account = testGroup "Account" [+    testGroup "accountFromPostings" [+      testCase "no postings, no days" $+        accountFromPostings undefined [] @?= accountTree "root" []+     ,testCase "no postings, only 2000-01-01" $+         allAccounts (all (\d -> (ModifiedJulianDay $ toInteger d) == fromGregorian 2000 01 01) . IM.keys . pdperiods . adata)+                     (accountFromPostings undefined []) @? "Not all adata have exactly 2000-01-01"+    ]+  ]

@@ -77,6 +77,10 @@   amountStyleSetRounding,   amountStylesSetRounding,   amountUnstyled,+  commodityStylesFromAmounts,+  -- canonicalStyleFrom,+  getAmounts,+   -- ** rendering   AmountFormat(..),   defaultFmt,@@ -135,6 +139,7 @@   divideMixedAmount,   multiplyMixedAmount,   averageMixedAmounts,+  sumAndAverageMixedAmounts,   isNegativeAmount,   isNegativeMixedAmount,   mixedAmountIsZero,@@ -171,7 +176,7 @@ ) where  import Prelude hiding (Applicative(..))-import Control.Applicative (Applicative(..))+import Control.Applicative (Applicative(..), (<|>)) import Control.Monad (foldM) import Data.Char (isDigit) import Data.Decimal (DecimalRaw(..), decimalPlaces, normalizeDecimal, roundTo)@@ -562,6 +567,13 @@                 olds)           Nothing -> olds +-- | Get an amount and its attached cost amount if any. Returns one or two amounts.+getAmounts :: Amount -> [Amount]+getAmounts a@Amount{acost} = a : case acost of+  Nothing            -> []+  Just (UnitCost  c) -> [c]+  Just (TotalCost c) -> [c]+ -- AmountStyle helpers  -- | Replace one AmountStyle with another, but don't just replace the display precision;@@ -631,6 +643,52 @@ amountUnstyled :: Amount -> Amount amountUnstyled a = a{astyle=amountstyle} +-- | Given a list of amounts, in parse order (roughly speaking; see journalStyleInfluencingAmounts),+-- build a map from their commodity names to standard commodity+-- display formats. Can return an error message eg if inconsistent+-- number formats are found.+--+-- Though, these amounts may have come from multiple files, so we+-- shouldn't assume they use consistent number formats.+-- Currently we don't enforce that even within a single file,+-- and this function never reports an error.+commodityStylesFromAmounts :: [Amount] -> Either String (M.Map CommoditySymbol AmountStyle)+commodityStylesFromAmounts =+  Right . foldr (\a -> M.insertWith canonicalStyle (acommodity a) (astyle a)) mempty++-- -- | 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 = 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.++-- | Given a pair of AmountStyles, choose a canonical style.+-- This is:+-- the general style of the first amount,+-- with the first digit group style seen,+-- with the maximum precision of all.+canonicalStyle :: AmountStyle -> AmountStyle -> AmountStyle+canonicalStyle a b = a{asprecision = prec, asdecimalmark = decmark, asdigitgroups = mgrps}+ where+  -- precision is maximum of all precisions+  prec = max (asprecision a) (asprecision b)+  -- identify the digit group mark (& group sizes)+  mgrps = asdigitgroups a <|> asdigitgroups b+  -- if a digit group mark was identified above, we can rely on that;+  -- make sure the decimal mark is different. If not, default to period.+  defdecmark = case mgrps of+    Just (DigitGroups '.' _) -> ','+    _ -> '.'+  -- identify the decimal mark: the first one used, or the above default,+  -- but never the same character as the digit group mark.+  -- urgh.. refactor..+  decmark = case mgrps of+    Just _ -> Just defdecmark+    Nothing -> asdecimalmark a <|> asdecimalmark b <|> Just defdecmark++ -- | Set (or clear) an amount's display decimal point. setAmountDecimalPoint :: Maybe Char -> Amount -> Amount setAmountDecimalPoint mc a@Amount{ astyle=s } = a{ astyle=s{asdecimalmark=mc} }@@ -851,9 +909,15 @@ transformMixedAmount f = mapMixedAmountUnsafe (transformAmount f)  -- | Calculate the average of some mixed amounts.-averageMixedAmounts :: [MixedAmount] -> MixedAmount-averageMixedAmounts as = fromIntegral (length as) `divideMixedAmount` maSum as+averageMixedAmounts :: Foldable f => f MixedAmount -> MixedAmount+averageMixedAmounts = snd . sumAndAverageMixedAmounts +-- | Calculate the sum and average of some mixed amounts.+sumAndAverageMixedAmounts :: Foldable f => f MixedAmount -> (MixedAmount, MixedAmount)+sumAndAverageMixedAmounts amts = (total, fromIntegral nAmts `divideMixedAmount` total)+  where+    (nAmts, total) = foldl' (\(n, a) b -> (n + 1, maPlus a b)) (0 :: Int, nullmixedamt) amts+ -- | Is this mixed amount negative, if we can tell that unambiguously? -- Ie when normalised, are all individual commodity amounts negative ? isNegativeMixedAmount :: MixedAmount -> Maybe Bool@@ -1038,10 +1102,21 @@ -- v4 instance HasAmounts MixedAmount where   styleAmounts styles = mapMixedAmountUnsafe (styleAmounts styles)+  -- getAmounts = concatMap getAmounts . amounts -instance HasAmounts Account where-  styleAmounts styles acct@Account{aebalance,aibalance} =-    acct{aebalance=styleAmounts styles aebalance, aibalance=styleAmounts styles aibalance}+instance HasAmounts BalanceData where+  styleAmounts styles balance@BalanceData{bdexcludingsubs,bdincludingsubs} =+    balance{bdexcludingsubs=styleAmounts styles bdexcludingsubs, bdincludingsubs=styleAmounts styles bdincludingsubs}+  -- getAmounts BalanceData{bdexcludingsubs, bdincludingsubs} =+  --   getAmounts bdexcludingsubs <> getAmounts bdincludingsubs++instance HasAmounts a => HasAmounts (PeriodData a) where+  styleAmounts styles = fmap (styleAmounts styles)+  -- getAmounts ++instance HasAmounts a => HasAmounts (Account a) where+  styleAmounts styles acct@Account{adata} =+    acct{adata = styleAmounts styles <$> adata}  -- | Reset each individual amount's display style to the default. mixedAmountUnstyled :: MixedAmount -> MixedAmount

@@ -0,0 +1,59 @@+{-# LANGUAGE CPP #-}+{-|+++A 'BalanceData is a data type tracking a number of postings, exclusive, and inclusive balance+for given date ranges.++-}+module Hledger.Data.BalanceData+( mapBalanceData+, opBalanceData++, tests_BalanceData+) where+++import Test.Tasty (testGroup)+import Test.Tasty.HUnit ((@?=), testCase)++import Hledger.Data.Amount+import Hledger.Data.Types+++instance Show BalanceData where+  showsPrec d (BalanceData e i n) =+    showParen (d > 10) $+        showString "BalanceData"+      . showString "{ bdexcludingsubs = " . showString (wbUnpack (showMixedAmountB defaultFmt e))+      . showString ", bdincludingsubs = " . showString (wbUnpack (showMixedAmountB defaultFmt i))+      . showString ", bdnumpostings = " . shows n+      . showChar '}'++instance Semigroup BalanceData where+  BalanceData e i n <> BalanceData e' i' n' = BalanceData (maPlus e e') (maPlus i i') (n + n')++instance Monoid BalanceData where+  mempty = BalanceData nullmixedamt nullmixedamt 0++-- | Apply an operation to both 'MixedAmount' in an 'BalanceData'.+mapBalanceData :: (MixedAmount -> MixedAmount) -> BalanceData -> BalanceData+mapBalanceData f a = a{bdexcludingsubs = f $ bdexcludingsubs a, bdincludingsubs = f $ bdincludingsubs a}++-- | Merge two 'BalanceData', using the given operation to combine their amounts.+opBalanceData :: (MixedAmount -> MixedAmount -> MixedAmount) -> BalanceData -> BalanceData -> BalanceData+opBalanceData f a b = a{bdexcludingsubs = f (bdexcludingsubs a) (bdexcludingsubs b), bdincludingsubs = f (bdincludingsubs a) (bdincludingsubs b)}+++-- tests++tests_BalanceData = testGroup "BalanceData" [++  testCase "opBalanceData maPlus" $ do+    opBalanceData maPlus (BalanceData (mixed [usd 1]) (mixed [usd 2]) 5) (BalanceData (mixed [usd 3]) (mixed [usd 4]) 0)+      @?= BalanceData (mixed [usd 4]) (mixed [usd 6]) 5,++  testCase "opBalanceData maMinus" $ do+    opBalanceData maMinus (BalanceData (mixed [usd 1]) (mixed [usd 2]) 5) (BalanceData (mixed [usd 3]) (mixed [usd 4]) 0)+      @?= BalanceData (mixed [usd (-2)]) (mixed [usd (-2)]) 5+  ]

@@ -34,6 +34,7 @@ import Control.Monad.ST (ST, runST) import Control.Monad.Trans.Class (lift) import Data.Array.ST (STArray, getElems, newListArray, writeArray)+import Data.Bifunctor (second) import Data.Foldable (asum) import Data.Function ((&)) import Data.Functor ((<&>), void)@@ -49,7 +50,6 @@ import Safe (headErr) import Text.Printf (printf) -import Hledger.Utils import Hledger.Data.Types import Hledger.Data.AccountName (isAccountNamePrefixOf) import Hledger.Data.Amount@@ -57,7 +57,7 @@ import Hledger.Data.Posting import Hledger.Data.Transaction import Hledger.Data.Errors-import Data.Bifunctor (second)+import Hledger.Utils   data BalancingOpts = BalancingOpts@@ -65,6 +65,7 @@   , infer_balancing_costs_ :: Bool  -- ^ Are we permitted to infer missing costs to balance transactions ?                                     --   Distinct from InputOpts{infer_costs_}.   , commodity_styles_      :: Maybe (M.Map CommoditySymbol AmountStyle)  -- ^ commodity display styles+  , txn_balancing_         :: TransactionBalancingPrecision   } deriving (Eq, Ord, Show)  defbalancingopts :: BalancingOpts@@ -72,6 +73,7 @@   { ignore_assertions_     = False   , infer_balancing_costs_ = True   , commodity_styles_      = Nothing+  , txn_balancing_         = TBPExact   }  -- | Check that this transaction would appear balanced to a human when displayed.@@ -92,7 +94,7 @@ --    (using the given display styles if provided) -- transactionCheckBalanced :: BalancingOpts -> Transaction -> [String]-transactionCheckBalanced BalancingOpts{commodity_styles_} t = errs+transactionCheckBalanced BalancingOpts{commodity_styles_=_mglobalstyles, txn_balancing_} t = errs   where     -- get real and balanced virtual postings, to be checked separately     (rps, bvps) = foldr partitionPosting ([], []) $ tpostings t@@ -102,30 +104,33 @@             BalancedVirtualPosting -> (l, p:r)             VirtualPosting         -> (l, r) -    -- convert this posting's amount to cost,+    -- convert a posting's amount to cost,     -- unless it has been marked as a redundant cost (equivalent to some nearby equity conversion postings),     -- in which case ignore it.     postingBalancingAmount p       | costPostingTagName `elem` map fst (ptags p) = mixedAmountStripCosts $ pamount p       | otherwise                                   = mixedAmountCost $ pamount p -    -- transaction balancedness is checked at each commodity's display precision-    lookszero = mixedAmountLooksZero . atdisplayprecision-      where-        atdisplayprecision = maybe id styleAmounts $ commodity_styles_+    lookszero = case txn_balancing_ of+      TBPOld    -> lookszeroatglobaldisplayprecision+      TBPExact  -> lookszeroatlocaltransactionprecision +    lookszeroatlocaltransactionprecision = mixedAmountLooksZero . styleAmounts (transactionCommodityStylesWith HardRounding t)+    lookszeroatglobaldisplayprecision    = mixedAmountLooksZero . maybe id styleAmounts _mglobalstyles++    -- check that the sum looks like zero+    (rsumcost,  bvsumcost)  = (foldMap postingBalancingAmount rps, foldMap postingBalancingAmount bvps)+    (rsumok,    bvsumok)    = (lookszero rsumcost, lookszero bvsumcost)+    (rsumokold, bvsumokold) = (lookszeroatglobaldisplayprecision rsumcost, lookszeroatglobaldisplayprecision bvsumcost)+     -- when there's multiple non-zeros, check they do not all have the same sign-    (rsignsok, bvsignsok) = (signsOk rps, signsOk bvps)+    (rsignsok, bvsignsok)   = (signsOk rps, signsOk bvps)       where         signsOk ps = length nonzeros < 2 || length nonzerosigns > 1           where             nonzeros = filter (not.lookszero) $ map postingBalancingAmount ps             nonzerosigns = nubSort $ mapMaybe isNegativeMixedAmount nonzeros -    -- check that the sum looks like zero-    (rsumcost, bvsumcost) = (foldMap postingBalancingAmount rps, foldMap postingBalancingAmount bvps)-    (rsumok, bvsumok) = (lookszero rsumcost, lookszero bvsumcost)-     -- Generate error messages if any. Show amounts with their original precisions.     errs = filter (not.null) [rmsg, bvmsg]       where@@ -136,6 +141,7 @@               (showMixedAmountWith oneLineNoCostFmt{displayCost=True, displayZeroCommodity=True} $               mixedAmountSetFullPrecisionUpTo Nothing $ mixedAmountSetFullPrecision               rsumcost)+              ++ if rsumokold then oldbalancingmsg else ""         bvmsg           | bvsumok       = ""           | not bvsignsok = "The balanced virtual postings all have the same sign. Consider negating some of them."@@ -143,6 +149,14 @@               (showMixedAmountWith oneLineNoCostFmt{displayCost=True, displayZeroCommodity=True} $               mixedAmountSetFullPrecisionUpTo Nothing $ mixedAmountSetFullPrecision               bvsumcost)+              ++ if bvsumokold then oldbalancingmsg else ""+        oldbalancingmsg = unlines [+          -- -------------------------------------------------------------------------------+           "\nNote, hledger <1.50 accepted this entry because of the global display precision,"+          ,"but hledger 1.50+ checks more strictly, using the entry's local precision."+          ,"You can use --txn-balancing=old to keep it working, or fix it (recommended);"+          ,"see 'Transaction balancing' in the hledger manual."+          ]  -- | Legacy form of transactionCheckBalanced. isTransactionBalanced :: BalancingOpts -> Transaction -> Bool@@ -207,9 +221,7 @@           [ "Consider adjusting this entry's amounts, adding missing postings,"           , "or recording conversion price(s) with @, @@ or equity postings."            ]-          else-          [ "Consider adjusting this entry's amounts, or adding missing postings."-          ]+          else []  transactionCommodities :: Transaction -> S.Set CommoditySymbol transactionCommodities t = mconcat $ map (maCommodities . pamount) $ tpostings t@@ -289,7 +301,7 @@                 & mixedAmountCost                 -- & dbg9With (lbl "balancing amount converted to cost".showMixedAmountOneLine)                 & styleAmounts (styles-                                -- Needed until we switch to locally-inferred balancing precisions:+                                -- Needed until we switch to locally-inferred balancing precisions: XXX #2402                                 -- these had hard rounding set to help with balanced-checking;                                 -- set no rounding now to avoid excessive display precision in output                                 & amountStylesSetRounding NoRounding

@@ -63,6 +63,7 @@   spanIntersect,   spansIntersect,   spanDefaultsFrom,+  spanValidDefaultsFrom,   spanExtend,   spanUnion,   spansUnion,@@ -88,7 +89,7 @@ import Control.Applicative.Permutations import Control.Monad (guard, unless) import qualified Control.Monad.Fail as Fail (MonadFail, fail)-import Data.Char (digitToInt, isDigit, ord)+import Data.Char (digitToInt, isDigit) import Data.Default (def) import Data.Foldable (asum) import Data.Function (on)@@ -348,10 +349,43 @@  -- | Fill any unspecified dates in the first span with the dates from -- the second one (if specified there). Sort of a one-way spanIntersect.+-- This one can create an invalid span that'll always be empty.+--+-- >>> :{+--  DateSpan (Just $ Exact $ fromGregorian 2024 1 1) Nothing+--  `spanDefaultsFrom`+--  DateSpan (Just $ Exact $ fromGregorian 2024 1 1) (Just $ Exact $ fromGregorian 2024 1 2)+-- :}+-- DateSpan 2024-01-01+--+-- >>> :{+--  DateSpan (Just $ Exact $ fromGregorian 2025 1 1) Nothing+--  `spanDefaultsFrom`+--  DateSpan (Just $ Exact $ fromGregorian 2024 1 1) (Just $ Exact $ fromGregorian 2024 1 2)+-- :}+-- DateSpan 2025-01-01..2024-01-01+--+spanDefaultsFrom :: DateSpan -> DateSpan -> DateSpan spanDefaultsFrom (DateSpan a1 b1) (DateSpan a2 b2) = DateSpan a b     where a = if isJust a1 then a1 else a2           b = if isJust b1 then b1 else b2 +-- | A smarter version of spanDefaultsFrom that avoids creating invalid+-- spans ending before they begin. Kept separate for now to reduce risk.+--+-- >>> :{+--  DateSpan (Just $ Exact $ fromGregorian 2025 1 1) Nothing+--  `spanValidDefaultsFrom`+--  DateSpan (Just $ Exact $ fromGregorian 2024 1 1) (Just $ Exact $ fromGregorian 2024 1 2)+-- :}+-- DateSpan 2025-01-01..+--+spanValidDefaultsFrom :: DateSpan -> DateSpan -> DateSpan+spanValidDefaultsFrom s1 s2 =+  case s1 `spanDefaultsFrom` s2 of+    DateSpan b e | b >= e -> s1+    s -> s+ -- | Calculate the union of two datespans. -- If either span is open-ended, the union will be too. --@@ -365,9 +399,11 @@ -- DateSpan ..2024-12-31 spanUnion (DateSpan b1 e1) (DateSpan b2 e2) = DateSpan (earlier b1 b2) (later e1 e2) --- | Extend the first span to include any definite end dates of the second.--- Unlike spanUnion, open ends in the second are ignored.--- If the first span was open-ended, it still will be after being extended.+-- | Extend the definite start/end dates of the first span, if needed,+-- to include the definite start/end dates of the second span.+-- And/or, replace open start/end dates in the first span with+-- definite start/end dates from the second.+-- Unlike spanUnion, open start/end dates in the second are ignored. -- -- >>> ys2024 = fromGregorian 2024 01 01 -- >>> ys2025 = fromGregorian 2025 01 01@@ -876,7 +912,8 @@ smartdate = choice'   -- XXX maybe obscures date errors ? see ledgerdate     [ relativeP-    , yyyymmdd, ymd+    , yyyymmdd+    , ymd     , (\(m,d) -> SmartFromReference (Just m) d) <$> md     , failIfInvalidDate . SmartFromReference Nothing =<< decimal     , SmartMonth <$> (month <|> mon)@@ -1107,12 +1144,11 @@         ]  periodexprdatespanp :: Day -> TextParser m DateSpan-periodexprdatespanp rdate = choice $ map try [+periodexprdatespanp rdate = choice' [                             doubledatespanp rdate,-                            quarterdatespanp rdate,                             fromdatespanp rdate,                             todatespanp rdate,-                            justdatespanp rdate+                            indatespanp rdate                            ]  -- |@@ -1128,45 +1164,95 @@ -- Right DateSpan 2017 doubledatespanp :: Day -> TextParser m DateSpan doubledatespanp rdate = liftA2 fromToSpan-    (optional ((string' "from" <|> string' "since") *> skipNonNewlineSpaces) *> smartdate)+    (optional ((string' "from" <|> string' "since") *> skipNonNewlineSpaces) *> smartdateorquarterstartp rdate)     (skipNonNewlineSpaces *> choice [string' "to", string "..", string "-"]-    *> skipNonNewlineSpaces *> smartdate)+    *> skipNonNewlineSpaces *> smartdateorquarterstartp rdate)   where     fromToSpan = DateSpan `on` (Just . fixSmartDate rdate)  -- |--- >>> parsewith (quarterdatespanp (fromGregorian 2018 01 01) <* eof) "q1"--- Right DateSpan 2018Q1--- >>> parsewith (quarterdatespanp (fromGregorian 2018 01 01) <* eof) "Q1"--- Right DateSpan 2018Q1--- >>> parsewith (quarterdatespanp (fromGregorian 2018 01 01) <* eof) "2020q4"--- Right DateSpan 2020Q4-quarterdatespanp :: Day -> TextParser m DateSpan-quarterdatespanp rdate = do-    y <- yearp <|> pure (first3 $ toGregorian rdate)-    q <- char' 'q' *> satisfy is4Digit-    return . periodAsDateSpan $ QuarterPeriod y (digitToInt q)-  where-    is4Digit c = (fromIntegral (ord c - ord '1') :: Word) <= 3-+-- >>> let p = parsewith (fromdatespanp (fromGregorian 2024 02 02) <* eof)+-- >>> p "2025-01-01.."+-- Right DateSpan 2025-01-01..+-- >>> p "2025Q1.."+-- Right DateSpan 2025-01-01..+-- >>> p "from q2"+-- Right DateSpan 2024-04-01.. fromdatespanp :: Day -> TextParser m DateSpan fromdatespanp rdate = fromSpan <$> choice-    [ (string' "from" <|> string' "since") *> skipNonNewlineSpaces *> smartdate-    , smartdate <* choice [string "..", string "-"]-    ]+  [ (string' "from" <|> string' "since") *> skipNonNewlineSpaces *> smartdateorquarterstartp rdate+  , smartdateorquarterstartp rdate <* choice [string "..", string "-"]+  ]   where     fromSpan b = DateSpan (Just $ fixSmartDate rdate b) Nothing +-- |+-- >>> let p = parsewith (todatespanp (fromGregorian 2024 02 02) <* eof)+-- >>> p "..2025-01-01"+-- Right DateSpan ..2024-12-31+-- >>> p "..2025Q1"+-- Right DateSpan ..2024-12-31+-- >>> p "to q2"+-- Right DateSpan ..2024-03-31 todatespanp :: Day -> TextParser m DateSpan todatespanp rdate =-    choice [string' "to", string' "until", string "..", string "-"]-    *> skipNonNewlineSpaces-    *> (DateSpan Nothing . Just . fixSmartDate rdate <$> smartdate)+  choice [string' "to", string' "until", string "..", string "-"]+  *> skipNonNewlineSpaces+  *> (DateSpan Nothing . Just . fixSmartDate rdate <$> smartdateorquarterstartp rdate) -justdatespanp :: Day -> TextParser m DateSpan-justdatespanp rdate =-    optional (string' "in" *> skipNonNewlineSpaces)-    *> (spanFromSmartDate rdate <$> smartdate)+-- |j+-- >>> let p = parsewith (indatespanp (fromGregorian 2024 02 02) <* eof)+-- >>> p "2025-01-01"+-- Right DateSpan 2025-01-01+-- >>> p "2025q1"+-- Right DateSpan 2025Q1+-- >>> p "in Q2"+-- Right DateSpan 2024Q2+indatespanp :: Day -> TextParser m DateSpan+indatespanp rdate =+  optional (string' "in" *> skipNonNewlineSpaces)+  *> choice' [+    quarterspanp rdate,+    spanFromSmartDate rdate <$> smartdate+  ]++-- Helper: parse a quarter number, optionally preceded by a year.+quarterp :: Day -> TextParser m (Year, Int)+quarterp rdate = do+  y <- yearp <|> pure (first3 $ toGregorian rdate)+  n <- char' 'q' *> satisfy (`elem` ['1' .. '4']) >>= return . digitToInt+  return (y, n)++-- | Parse a single quarter (YYYYqN or qN, case insensitive q) as a date span.+--+-- >>> parsewith (quarterspanp (fromGregorian 2018 01 01) <* eof) "q1"+-- Right DateSpan 2018Q1+-- >>> parsewith (quarterspanp (fromGregorian 2018 01 01) <* eof) "Q1"+-- Right DateSpan 2018Q1+-- >>> parsewith (quarterspanp (fromGregorian 2018 01 01) <* eof) "2020q4"+-- Right DateSpan 2020Q4+quarterspanp :: Day -> TextParser m DateSpan+quarterspanp rdate = do+  (y,q) <- quarterp rdate+  return . periodAsDateSpan $ QuarterPeriod y q++-- | Parse a quarter (YYYYqN or qN, case insensitive q) as its start date.+--+-- >>> parsewith (quarterstartp (fromGregorian 2025 02 02) <* eof) "q1"+-- Right 2025-01-01+-- >>> parsewith (quarterstartp (fromGregorian 2025 02 02) <* eof) "Q2"+-- Right 2025-04-01+-- >>> parsewith (quarterstartp (fromGregorian 2025 02 02) <* eof) "2025q4"+-- Right 2025-10-01+quarterstartp :: Day -> TextParser m Day+quarterstartp rdate = do+  (y,q) <- quarterp rdate+  return $+    fromMaybe (error' "Hledger.Data.Dates.quarterstartp: invalid date found") $  -- PARTIAL, shouldn't happen+    periodStart $ QuarterPeriod y q++smartdateorquarterstartp :: Day -> TextParser m SmartDate+smartdateorquarterstartp rdate = choice' [SmartCompleteDate <$> quarterstartp rdate, smartdate]  nulldatespan :: DateSpan nulldatespan = DateSpan Nothing Nothing

@@ -26,7 +26,6 @@   journalInferMarketPricesFromTransactions,   journalInferCommodityStyles,   journalStyleAmounts,-  commodityStylesFromAmounts,   journalCommodityStyles,   journalCommodityStylesWith,   journalToCost,@@ -56,7 +55,6 @@   journalAccountNamesDeclared,   journalAccountNamesDeclaredOrUsed,   journalAccountNamesDeclaredOrImplied,-  journalLeafAccountNamesDeclared,   journalAccountNames,   journalLeafAccountNames,   journalAccountNameTree,@@ -73,9 +71,14 @@   journalTagsDeclared,   journalTagsUsed,   journalTagsDeclaredOrUsed,+  journalAmounts,+  journalPostingAmounts,+  journalPostingAndCostAmounts,   journalCommoditiesDeclared,   journalCommoditiesUsed,   journalCommodities,+  journalCommoditiesFromPriceDirectives,+  journalCommoditiesFromTransactions,   journalDateSpan,   journalDateSpanBothDates,   journalStartDate,@@ -88,21 +91,19 @@   journalNextTransaction,   journalPrevTransaction,   journalPostings,-  journalPostingAmounts,-  showJournalAmountsDebug,+  showJournalPostingAmountsDebug,   journalTransactionsSimilarTo,   -- * Account types   journalAccountType,   journalAccountTypes,   journalAddAccountTypes,   journalPostingsAddAccountTags,+  journalPostingsKeepAccountTagsOnly,   defaultBaseConversionAccount,   -- journalPrices,   journalBaseConversionAccount,   journalConversionAccounts,   -- * Misc-  canonicalStyleFrom,-   nulljournal,   journalConcat,   journalNumberTransactions,@@ -114,7 +115,7 @@   -- * Tests   samplejournal,   samplejournalMaybeExplicit,-  tests_Journal+  tests_Journal,   -- ) where@@ -308,10 +309,10 @@     -- it seems unneeded except perhaps for debugging  -- | Debug log the ordering of a journal's account declarations--- (at debug level 5+).+-- (at debug level 7+). dbgJournalAcctDeclOrder :: String -> Journal -> Journal dbgJournalAcctDeclOrder prefix =-  dbg5With ((prefix++) . showAcctDeclsSummary . jdeclaredaccounts)+  dbg7With ((prefix++) . showAcctDeclsSummary . jdeclaredaccounts)   where     showAcctDeclsSummary :: [(AccountName,AccountDeclarationInfo)] -> String     showAcctDeclsSummary adis@@ -399,26 +400,48 @@ journalPostingAmounts :: Journal -> [MixedAmount] journalPostingAmounts = map pamount . journalPostings --- | Show the journal amounts rendered, suitable for debug logging.-showJournalAmountsDebug :: Journal -> String-showJournalAmountsDebug = show.map showMixedAmountOneLine.journalPostingAmounts+-- | Show the journal posting amounts rendered, suitable for debug logging.+showJournalPostingAmountsDebug :: Journal -> String+showJournalPostingAmountsDebug = show . map showMixedAmountOneLine . journalPostingAmounts +-- | All raw amounts used in this journal's postings and costs,+-- with MixedAmounts flattened, in parse order.+journalPostingAndCostAmounts :: Journal -> [Amount]+journalPostingAndCostAmounts = concatMap getAmounts . concatMap (amountsRaw . pamount) . journalPostings++-- | All raw amounts appearing in this journal, with MixedAmounts flattened, in no particular order.+-- (Including from posting amounts, cost amounts, P directives, and the last D directive.)+journalAmounts :: Journal -> S.Set Amount+journalAmounts = S.fromList . journalStyleInfluencingAmounts True+ -- | Sorted unique commodity symbols declared by commodity directives in this journal. journalCommoditiesDeclared :: Journal -> [CommoditySymbol] journalCommoditiesDeclared = M.keys . jdeclaredcommodities --- | Sorted unique commodity symbols used in this journal.+-- | Sorted unique commodity symbols used anywhere in this journal, including+-- commodity directives, P directives, the last D directive, posting amounts and cost amounts. journalCommoditiesUsed :: Journal -> [CommoditySymbol]-journalCommoditiesUsed = S.elems . S.fromList . concatMap (map acommodity . amounts) . journalPostingAmounts+journalCommoditiesUsed j = S.elems $+  journalCommoditiesFromPriceDirectives j <>+  (S.fromList $ map acommodity $ journalStyleInfluencingAmounts True j) --- | Sorted unique commodity symbols mentioned in this journal.+-- | Sorted unique commodity symbols mentioned anywhere in this journal.+-- (Including commodity directives, P directives, the last D directive, posting amounts and cost amounts.) journalCommodities :: Journal -> S.Set CommoditySymbol journalCommodities j =      M.keysSet (jdeclaredcommodities j)-  <> M.keysSet (jinferredcommoditystyles j)-  <> S.fromList (concatMap pdcommodities $ jpricedirectives j)-      where pdcommodities pd = [pdcommodity pd, acommodity $ pdamount pd]+  <> journalCommoditiesFromPriceDirectives j+  <> S.fromList (map acommodity $ journalStyleInfluencingAmounts True j) +-- | Sorted unique commodity symbols mentioned in this journal's P directives.+journalCommoditiesFromPriceDirectives :: Journal -> S.Set CommoditySymbol+journalCommoditiesFromPriceDirectives = S.fromList . concatMap pdcomms . jpricedirectives+  where pdcomms pd = [pdcommodity pd, acommodity $ pdamount pd]++-- | Sorted unique commodity symbols used in transactions, in either posting or cost amounts.+journalCommoditiesFromTransactions :: Journal -> S.Set CommoditySymbol+journalCommoditiesFromTransactions j = S.fromList $ map acommodity $ journalPostingAndCostAmounts j+ -- | Unique transaction descriptions used in this journal. journalDescriptions :: Journal -> [Text] journalDescriptions = nubSort . map tdescription . jtxns@@ -463,11 +486,6 @@ journalAccountNamesDeclared :: Journal -> [AccountName] journalAccountNamesDeclared = nubSort . map fst . jdeclaredaccounts --- | Sorted unique account names declared by account directives in this journal,--- which have no children.-journalLeafAccountNamesDeclared :: Journal -> [AccountName]-journalLeafAccountNamesDeclared = treeLeaves . accountNameTreeFrom . journalAccountNamesDeclared- -- | Sorted unique account names declared by account directives or posted to -- by transactions in this journal. journalAccountNamesDeclaredOrUsed :: Journal -> [AccountName]@@ -625,6 +643,13 @@ journalPostingsAddAccountTags j = journalMapPostings addtags j   where addtags p = p `postingAddTags` (journalInheritedAccountTags j $ paccount p) +-- | Remove all tags from the journal's postings except those provided by their account.+-- This is useful for the accounts report.+-- It does not remove tag declarations from the posting comments.+journalPostingsKeepAccountTagsOnly :: Journal -> Journal+journalPostingsKeepAccountTagsOnly j = journalMapPostings keepaccounttags j+  where keepaccounttags p = p{ptags=[]} `postingAddTags` (journalInheritedAccountTags j $ paccount p)+ -- | The account name to use for conversion postings generated by --infer-equity. -- This is the first account declared with type V/Conversion, -- or otherwise the defaultBaseConversionAccount (equity:conversion).@@ -910,59 +935,14 @@ journalCommodityStylesWith r = amountStylesSetRounding r . journalCommodityStyles  -- | Collect and save inferred amount styles for each commodity based on--- the posting amounts in that commodity (excluding price amounts).+-- P directive amounts, posting amounts but not cost amounts, and maybe the last D amount, in that commodity. -- Can return an error message eg if inconsistent number formats are found. journalInferCommodityStyles :: Journal -> Either String Journal journalInferCommodityStyles j =-  case commodityStylesFromAmounts $ journalStyleInfluencingAmounts j of+  case commodityStylesFromAmounts $ journalStyleInfluencingAmounts False j of     Left e   -> Left e     Right cs -> Right j{jinferredcommoditystyles = dbg7 "journalInferCommodityStyles" cs} --- | Given a list of amounts, in parse order (roughly speaking; see journalStyleInfluencingAmounts),--- build a map from their commodity names to standard commodity--- display formats. Can return an error message eg if inconsistent--- number formats are found.------ Though, these amounts may have come from multiple files, so we--- shouldn't assume they use consistent number formats.--- Currently we don't enforce that even within a single file,--- and this function never reports an error.----commodityStylesFromAmounts :: [Amount] -> Either String (M.Map CommoditySymbol AmountStyle)-commodityStylesFromAmounts =-    Right . foldr (\a -> M.insertWith canonicalStyle (acommodity a) (astyle a)) mempty---- | 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 = 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.--- | Given a pair of AmountStyles, choose a canonical style.--- This is:--- the general style of the first amount,--- with the first digit group style seen,--- with the maximum precision of all.-canonicalStyle :: AmountStyle -> AmountStyle -> AmountStyle-canonicalStyle a b = a{asprecision=prec, asdecimalmark=decmark, asdigitgroups=mgrps}-  where-    -- precision is maximum of all precisions-    prec = max (asprecision a) (asprecision b)-    -- identify the digit group mark (& group sizes)-    mgrps = asdigitgroups a <|> asdigitgroups b-    -- if a digit group mark was identified above, we can rely on that;-    -- make sure the decimal mark is different. If not, default to period.-    defdecmark = case mgrps of-        Just (DigitGroups '.' _) -> ','-        _                        -> '.'-    -- identify the decimal mark: the first one used, or the above default,-    -- but never the same character as the digit group mark.-    -- urgh.. refactor..-    decmark = case mgrps of-        Just _  -> Just defdecmark-        Nothing -> asdecimalmark a <|> asdecimalmark b <|> Just defdecmark- -- -- | Apply this journal's historical price records to unpriced amounts where possible. -- journalApplyPriceDirectives :: Journal -> Journal -- journalApplyPriceDirectives j@Journal{jtxns=ts} = j{jtxns=map fixtransaction ts}@@ -1036,23 +1016,23 @@ --               Just (UnitCost ma)  -> c:(concatMap amountCommodities $ amounts ma) --               Just (TotalCost ma) -> c:(concatMap amountCommodities $ amounts ma) --- | Get an ordered list of amounts in this journal which can--- influence canonical amount display styles. Those amounts are, in--- the following order:+-- | Get an ordered list of amounts in this journal which can influence+-- canonical amount display styles (excluding the ones in commodity directives). +-- They are, in the following order: -- -- * amounts in market price (P) directives (in parse order)--- * posting amounts in transactions (in parse order)+-- * posting amounts and optionally cost amounts (in parse order) -- * the amount in the final default commodity (D) directive ----- Transaction price amounts (posting amounts' acost field) are not included.----journalStyleInfluencingAmounts :: Journal -> [Amount]-journalStyleInfluencingAmounts j =+journalStyleInfluencingAmounts :: Bool -> Journal -> [Amount]+journalStyleInfluencingAmounts includecost j =   dbg7 "journalStyleInfluencingAmounts" $   catMaybes $ concat [    [mdefaultcommodityamt]   ,map (Just . pdamount) $ jpricedirectives j-  ,map Just . concatMap (amountsRaw . pamount) $ journalPostings j+  ,map Just $ if includecost+    then journalPostingAndCostAmounts j+    else concatMap amountsRaw $ journalPostingAmounts j   ]   where     -- D's amount style isn't actually stored as an amount, make it into one

@@ -22,9 +22,11 @@ --import           Data.Aeson.TH import qualified Data.ByteString.Lazy as BL import           Data.Decimal (DecimalRaw(..), roundTo)+import qualified Data.IntMap as IM import           Data.Maybe (fromMaybe) import qualified Data.Text.Lazy    as TL import qualified Data.Text.Lazy.Builder as TB+import           Data.Time (Day(..)) import           Text.Megaparsec (Pos, SourcePos, mkPos, unPos)  import           Hledger.Data.Types@@ -155,24 +157,27 @@ instance ToJSON TimeclockEntry instance ToJSON Journal -instance ToJSON Account where+instance ToJSON BalanceData+instance ToJSON a => ToJSON (PeriodData a) where+  toJSON a = object+    [ "pdpre" .= pdpre a+    , "pdperiods" .= map (\(d, x) -> (ModifiedJulianDay (toInteger d), x)) (IM.toList $ pdperiods a)+    ]++instance ToJSON a => ToJSON (Account a) where   toJSON = object . accountKV   toEncoding = pairs . mconcat . accountKV  accountKV :: #if MIN_VERSION_aeson(2,2,0)-  KeyValue e kv+  (KeyValue e kv, ToJSON a) #else-  KeyValue kv+  (KeyValue kv, ToJSON a) #endif-  => Account -> [kv]+  => Account a -> [kv] accountKV a =     [ "aname"            .= aname a     , "adeclarationinfo" .= adeclarationinfo a-    , "aebalance"        .= aebalance a-    , "aibalance"        .= aibalance a-    , "anumpostings"     .= anumpostings a-    , "aboring"          .= aboring a     -- To avoid a cycle, show just the parent account's name     -- in a dummy field. When re-parsed, there will be no parent.     , "aparent_"         .= maybe "" aname (aparent a)@@ -181,7 +186,9 @@     -- The actual subaccounts (and their subs..), making a (probably highly redundant) tree     -- ,"asubs"        .= asubs a     -- Omit the actual subaccounts-    , "asubs"            .= ([]::[Account])+    , "asubs"            .= ([]::[Account BalanceData])+    , "aboring"          .= aboring a+    , "adata"            .= adata a     ]  instance ToJSON Ledger@@ -215,10 +222,17 @@ instance FromJSON Posting instance FromJSON Transaction instance FromJSON AccountDeclarationInfo++instance FromJSON BalanceData+instance FromJSON a => FromJSON (PeriodData a) where+  parseJSON = withObject "PeriodData" $ \v -> PeriodData+    <$> v .: "pdpre"+    <*> (IM.fromList . map (\(d, x) -> (fromInteger $ toModifiedJulianDay d, x)) <$> v .: "pdperiods")+ -- XXX The ToJSON instance replaces subaccounts with just names. -- Here we should try to make use of those to reconstruct the -- parent-child relationships.-instance FromJSON Account+instance FromJSON a => FromJSON (Account a)  -- Decimal, various attempts --

@@ -32,6 +32,7 @@ import Test.Tasty.HUnit ((@?=), testCase) import Hledger.Data.Types import Hledger.Data.Account+import Hledger.Data.Dates (nulldate) import Hledger.Data.Journal import Hledger.Query @@ -61,7 +62,8 @@     (q',depthq)  = (filterQuery (not . queryIsDepth) q, filterQuery queryIsDepth q)     j'  = filterJournalAmounts (filterQuery queryIsSym q) $ -- remove amount parts which the query's sym: terms would exclude           filterJournalPostings q' j-    as  = accountsFromPostings $ journalPostings j'+    -- Ledger does not use date-separated balances, so dates are left empty+    as  = accountsFromPostings (const $ Just nulldate) $ journalPostings j'     j'' = filterJournalPostings depthq j'  -- | List a ledger's account names.@@ -69,21 +71,21 @@ ledgerAccountNames = drop 1 . map aname . laccounts  -- | Get the named account from a ledger.-ledgerAccount :: Ledger -> AccountName -> Maybe Account+ledgerAccount :: Ledger -> AccountName -> Maybe (Account BalanceData) ledgerAccount l a = lookupAccount a $ laccounts l  -- | Get this ledger's root account, which is a dummy "root" account -- above all others. This should always be first in the account list, -- if somehow not this returns a null account.-ledgerRootAccount :: Ledger -> Account+ledgerRootAccount :: Ledger -> Account BalanceData ledgerRootAccount = headDef nullacct . laccounts  -- | List a ledger's top-level accounts (the ones below the root), in tree order.-ledgerTopAccounts :: Ledger -> [Account]+ledgerTopAccounts :: Ledger -> [Account BalanceData] ledgerTopAccounts = asubs . headDef nullacct . laccounts  -- | List a ledger's bottom-level (subaccount-less) accounts, in tree order.-ledgerLeafAccounts :: Ledger -> [Account]+ledgerLeafAccounts :: Ledger -> [Account BalanceData] ledgerLeafAccounts = filter (null.asubs) . laccounts  -- | List a ledger's postings, in the order parsed.

@@ -0,0 +1,127 @@+{-# LANGUAGE CPP #-}+{-|+++Data values for zero or more report periods, and for the pre-report period.+Report periods are assumed to be contiguous, and represented only by start dates+(as keys of an IntMap).++-}+module Hledger.Data.PeriodData+( periodDataFromList++, lookupPeriodData+, insertPeriodData+, opPeriodData+, mergePeriodData+, padPeriodData++, tests_PeriodData+) where++#if MIN_VERSION_base(4,18,0)+import Data.Foldable1 (Foldable1(..))+#else+import Control.Applicative (liftA2)+#endif+import qualified Data.IntMap.Strict as IM+import qualified Data.IntSet as IS+#if !MIN_VERSION_base(4,20,0)+import Data.List (foldl')+#endif+import Data.Time (Day(..), fromGregorian)++import Test.Tasty (testGroup)+import Test.Tasty.HUnit ((@?=), testCase)++import Hledger.Data.Amount+import Hledger.Data.Types+++instance Show a => Show (PeriodData a) where+  showsPrec d (PeriodData h ds) =+    showParen (d > 10) $+        showString "PeriodData"+      . showString "{ pdpre = " . shows h+      . showString ", pdperiods = "+      . showString "fromList " . shows (map (\(day, x) -> (ModifiedJulianDay $ toInteger day, x)) $ IM.toList ds)+      . showChar '}'++instance Foldable PeriodData where+  foldr f z (PeriodData h as) = foldr f (f h z) as+  foldl f z (PeriodData h as) = foldl f (f z h) as+  foldl' f z (PeriodData h as) = let fzh = f z h in fzh `seq` foldl' f fzh as++#if MIN_VERSION_base(4,18,0)+instance Foldable1 PeriodData where+  foldrMap1 f g (PeriodData h as) = foldr g (f h) as+  foldlMap1 f g (PeriodData h as) = foldl g (f h) as+  foldlMap1' f g (PeriodData h as) = let fh = f h in fh `seq` foldl' g fh as+#endif++instance Traversable PeriodData where+  traverse f (PeriodData h as) = liftA2 PeriodData (f h) $ traverse f as++-- | The Semigroup instance for 'AccountBalance' will simply take the union of+-- keys in the date map section. This may not be the result you want if the+-- keys are not identical.+instance Semigroup a => Semigroup (PeriodData a) where+  PeriodData h1 as1 <> PeriodData h2 as2 = PeriodData (h1 <> h2) $ IM.unionWith (<>) as1 as2++instance Monoid a => Monoid (PeriodData a) where+  mempty = PeriodData mempty mempty++-- | Construct an 'PeriodData' from a list.+periodDataFromList :: a -> [(Day, a)] -> PeriodData a+periodDataFromList h = PeriodData h . IM.fromList . map (\(d, a) -> (fromInteger $ toModifiedJulianDay d, a))++-- | Get account balance information to the period containing a given 'Day'.+lookupPeriodData :: Day -> PeriodData a -> a+lookupPeriodData d (PeriodData h as) =+    maybe h snd $ IM.lookupLE (fromInteger $ toModifiedJulianDay d) as++-- | Add account balance information to the appropriate location in 'PeriodData'.+insertPeriodData :: Semigroup a => Maybe Day -> a -> PeriodData a -> PeriodData a+insertPeriodData mday b balances = case mday of+    Nothing  -> balances{pdpre = pdpre balances <> b}+    Just day -> balances{pdperiods = IM.insertWith (<>) (fromInteger $ toModifiedJulianDay day) b $ pdperiods balances}++-- | Merges two 'PeriodData', using the given operation to combine their balance information.+--+-- This will drop keys if they are not present in both 'PeriodData'.+opPeriodData :: (a -> b -> c) -> PeriodData a -> PeriodData b -> PeriodData c+opPeriodData f (PeriodData h1 as1) (PeriodData h2 as2) =+    PeriodData (f h1 h2) $ IM.intersectionWith f as1 as2++-- | Merges two 'PeriodData', using the given operations for balance+-- information only in the first, only in the second, or in both+-- 'PeriodData', respectively.+mergePeriodData :: (a -> c) -> (b -> c) -> (a -> b -> c)+                -> PeriodData a -> PeriodData b -> PeriodData c+mergePeriodData only1 only2 f = \(PeriodData h1 as1) (PeriodData h2 as2) ->+    PeriodData (f h1 h2) $ merge as1 as2+  where+    merge = IM.mergeWithKey (\_ x y -> Just $ f x y) (fmap only1) (fmap only2)++-- | Pad out the datemap of an 'PeriodData' so that every key from a set is present.+padPeriodData :: Monoid a => IS.IntSet -> PeriodData a -> PeriodData a+padPeriodData keys bal = bal{pdperiods = pdperiods bal <> IM.fromSet (const mempty) keys}+++-- tests++tests_PeriodData =+  let+    dayMap  = periodDataFromList (mixed [usd 1]) [(fromGregorian 2000 01 01, mixed [usd 2]), (fromGregorian 2004 02 28, mixed [usd 3])]+    dayMap2 = periodDataFromList (mixed [usd 2]) [(fromGregorian 2000 01 01, mixed [usd 4]), (fromGregorian 2004 02 28, mixed [usd 6])]+  in testGroup "PeriodData" [++  testCase "periodDataFromList" $ do+    length dayMap @?= 3,++  testCase "Semigroup instance" $ do+    dayMap <> dayMap @?= dayMap2,++  testCase "Monoid instance" $ do+    dayMap <> mempty @?= dayMap+  ]

@@ -215,7 +215,7 @@     alltxnspans = splitSpan adjust ptinterval span'       where         -- If the PT does not specify  start or end dates, we take them from the requestedspan.-        span' = ptspan `spanDefaultsFrom` requestedspan+        span' = ptspan `spanValidDefaultsFrom` requestedspan         -- Unless the PT specified a start date explicitly, we will adjust the start date to the previous interval boundary.         adjust = isNothing $ spanStart span' 

@@ -435,7 +435,7 @@ postingAllTags :: Posting -> [Tag] postingAllTags p = ptags p ++ maybe [] ttags (ptransaction p) --- | Tags for this transaction including any from its postings.+-- | Tags for this transaction including any from its postings (which includes any from the postings' accounts). transactionAllTags :: Transaction -> [Tag] transactionAllTags t = ttags t ++ concatMap ptags (tpostings t) 

@@ -7,10 +7,11 @@ -}  {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StandaloneDeriving #-}  module Hledger.Data.Timeclock (-   timeclockEntriesToTransactions-  ,timeclockEntriesToTransactionsSingle+   timeclockToTransactions+  ,timeclockToTransactionsOld   ,tests_Timeclock ) where@@ -31,141 +32,158 @@ import Hledger.Data.Amount import Hledger.Data.Posting +-- detailed output for debugging+-- deriving instance Show TimeclockEntry++-- compact output instance Show TimeclockEntry where-    show t = printf "%s %s %s  %s" (show $ tlcode t) (show $ tldatetime t) (tlaccount t) (tldescription t)+  show t = printf "%s %s %s  %s" (show $ tlcode t) (show $ tldatetime t) (tlaccount t) (tldescription t)  instance Show TimeclockCode where-    show SetBalance = "b"-    show SetRequiredHours = "h"-    show In = "i"-    show Out = "o"-    show FinalOut = "O"+  show SetBalance = "b"+  show SetRequiredHours = "h"+  show In = "i"+  show Out = "o"+  show FinalOut = "O"  instance Read TimeclockCode where-    readsPrec _ ('b' : xs) = [(SetBalance, xs)]-    readsPrec _ ('h' : xs) = [(SetRequiredHours, xs)]-    readsPrec _ ('i' : xs) = [(In, xs)]-    readsPrec _ ('o' : xs) = [(Out, xs)]-    readsPrec _ ('O' : xs) = [(FinalOut, xs)]-    readsPrec _ _ = []--data Session = Session-    { in' :: TimeclockEntry,-      out :: TimeclockEntry-    }+  readsPrec _ ('b':xs) = [(SetBalance, xs)]+  readsPrec _ ('h':xs) = [(SetRequiredHours, xs)]+  readsPrec _ ('i':xs) = [(In, xs)]+  readsPrec _ ('o':xs) = [(Out, xs)]+  readsPrec _ ('O':xs) = [(FinalOut, xs)]+  readsPrec _ _ = [] -data Sessions = Sessions-    { completed :: [Session],-      active :: [TimeclockEntry]-    }+data Session = Session {+  in' :: TimeclockEntry,+  out :: TimeclockEntry+} deriving Show --- Find the relevant clockin in the actives list that should be paired with this clockout.--- If there is a session that has the same account name, then use that.--- Otherwise, if there is an active anonymous session, use that.--- Otherwise, raise an error.-findInForOut :: TimeclockEntry -> ([TimeclockEntry], [TimeclockEntry]) -> (TimeclockEntry, [TimeclockEntry])-findInForOut _ (matchingout : othermatches, rest) = (matchingout, othermatches <> rest)-findInForOut o ([], activeins) =-    if emptyname then (first, rest) else error' errmsg-    where-        l = show $ unPos $ sourceLine $ tlsourcepos o-        c = unPos $ sourceColumn $ tlsourcepos o-        emptyname = tlaccount o == ""-        (first, rest) = case uncons activeins of-            Just (hd, tl) -> (hd, tl)-            Nothing -> error' errmsg-        errmsg =-            printf-              "%s:\n%s\n%s\n\nCould not find previous clockin to match this clockout."-              (sourcePosPretty $ tlsourcepos o)-              (l ++ " | " ++ show o)-              (replicate (length l) ' ' ++ " |" ++ replicate c ' ' ++ "^")+data Sessions = Sessions {+  completed :: [Session],+  active :: [TimeclockEntry]+} deriving Show --- Assuming that entries has been sorted, we go through each time log entry.--- We collect all of the "i" in the list "actives," and each time we encounter--- an "o," we look for the corresponding "i" in actives.--- If we cannot find it, then it is an error (since the list is sorted).--- If the "o" is recorded on a different day than the "i," then we close the--- active entry at the end of its day, replace it in the active list--- with a start at midnight on the next day, and try again.--- This raises an error if any outs cannot be paired with an in.-pairClockEntries :: [TimeclockEntry] -> [TimeclockEntry] -> [Session] -> Sessions-pairClockEntries [] actives sessions = Sessions {completed = sessions, active = actives}-pairClockEntries (entry : rest) actives sessions-    | tlcode entry == In = pairClockEntries rest inentries sessions-    | tlcode entry == Out = pairClockEntries rest' actives' sessions'-    | otherwise = pairClockEntries rest actives sessions-    where-        (inentry, newactive) = findInForOut entry (partition (\e -> tlaccount e == tlaccount entry) actives)-        (itime, otime) = (tldatetime inentry, tldatetime entry)-        (idate, odate) = (localDay itime, localDay otime)-        omidnight = entry {tldatetime = itime {localDay = idate, localTimeOfDay = TimeOfDay 23 59 59}}-        imidnight = inentry {tldatetime = itime {localDay = addDays 1 idate, localTimeOfDay = midnight}}-        (sessions', actives', rest') = if odate > idate then-              (Session {in' = inentry, out = omidnight} : sessions, imidnight : newactive, entry : rest)-            else-              (Session {in' = inentry, out = entry} : sessions, newactive, rest)-        l = show $ unPos $ sourceLine $ tlsourcepos entry-        c = unPos $ sourceColumn $ tlsourcepos entry-        inentries =-          if any (\e -> tlaccount e == tlaccount entry) actives-            then error' $-                printf-                  "%s:\n%s\n%s\n\nEncountered clockin entry for session \"%s\" that is already active."-                  (sourcePosPretty $ tlsourcepos entry)-                  (l ++ " | " ++ show entry)-                  (replicate (length l) ' ' ++ " |" ++ replicate c ' ' ++ "^")-                  (tlaccount entry)-            else entry : actives+-- | Convert timeclock entries to journal transactions.+-- This is the old version from hledger <1.43, now enabled by --old-timeclock.+-- It requires strictly alternating clock-in and clock-entries.+-- It was documented as allowing only one clocked-in session at a time,+-- but in fact it allows concurrent sessions, even with the same account name.+--+-- Entries must be a strict alternation of in and out, beginning with in.+-- When there is no clockout, one is added with the provided current time. +-- Sessions crossing midnight are split into days to give accurate per-day totals.+-- If entries are not in the expected in/out order, an error is raised.+--+timeclockToTransactionsOld :: LocalTime -> [TimeclockEntry] -> [Transaction]+timeclockToTransactionsOld _ [] = []+timeclockToTransactionsOld now [i]+  | tlcode i /= In = errorExpectedCodeButGot In i+  | odate > idate = entryFromTimeclockInOut True i o' : timeclockToTransactionsOld now [i',o]+  | otherwise = [entryFromTimeclockInOut True i o]+  where+    o = TimeclockEntry (tlsourcepos i) Out end "" "" "" []+    end = if itime > now then itime else now+    (itime,otime) = (tldatetime i,tldatetime o)+    (idate,odate) = (localDay itime,localDay otime)+    o' = o{tldatetime=itime{localDay=idate, localTimeOfDay=TimeOfDay 23 59 59}}+    i' = i{tldatetime=itime{localDay=addDays 1 idate, localTimeOfDay=midnight}}+timeclockToTransactionsOld now (i:o:rest)+  | tlcode i /= In  = errorExpectedCodeButGot In i+  | tlcode o /= Out = errorExpectedCodeButGot Out o+  | odate > idate   = entryFromTimeclockInOut True i o' : timeclockToTransactionsOld now (i':o:rest)+  | otherwise       = entryFromTimeclockInOut True i o : timeclockToTransactionsOld now rest+  where+    (itime,otime) = (tldatetime i,tldatetime o)+    (idate,odate) = (localDay itime,localDay otime)+    o' = o{tldatetime=itime{localDay=idate, localTimeOfDay=TimeOfDay 23 59 59}}+    i' = i{tldatetime=itime{localDay=addDays 1 idate, localTimeOfDay=midnight}}+{- HLINT ignore timeclockToTransactionsOld -} --- | Convert time log entries to journal transactions. When there is no--- clockout, add one with the provided current time. Sessions crossing--- midnight are split into days to give accurate per-day totals.--- If any entries cannot be paired as expected, then an error is raised.-timeclockEntriesToTransactions :: LocalTime -> [TimeclockEntry] -> [Transaction]-timeclockEntriesToTransactions now entries = transactions+-- | Convert timeclock entries to journal transactions.+-- This is the new, default version added in hledger 1.43 and improved in 1.50.+-- It allows concurrent clocked-in sessions (though not with the same account name),+-- and clock-in/clock-out entries in any order.+--+-- Entries are processed in parse order.+-- Sessions crossing midnight are split into days to give accurate per-day totals.+-- At the end, any sessions with no clockout get an implicit clockout with the provided "now" time.+-- If any entries cannot be paired as expected, an error is raised.+--+timeclockToTransactions :: LocalTime -> [TimeclockEntry] -> [Transaction]+timeclockToTransactions now entries0 = transactions   where-    sessions = pairClockEntries (sortBy (\e1 e2 -> compare (tldatetime e1) (tldatetime e2)) entries) [] []-    transactionsFromSession s = entryFromTimeclockInOut (in' s) (out s)+    -- don't sort by time, it messes things up; just reverse to get the parsed order+    entries = dbg7 "timeclock entries" $ reverse entries0+    sessions = dbg6 "sessions" $ pairClockEntries entries [] []+    transactionsFromSession s = entryFromTimeclockInOut False (in' s) (out s)     -- If any "in" sessions are in the future, then set their out time to the initial time     outtime te = max now (tldatetime te)     createout te = TimeclockEntry (tlsourcepos te) Out (outtime te) (tlaccount te) "" "" []     outs = map createout (active sessions)-    stillopen = pairClockEntries ((active sessions) <> outs) [] []+    stillopen = dbg6 "stillopen" $ pairClockEntries ((active sessions) <> outs) [] []     transactions = map transactionsFromSession $ sortBy (\s1 s2 -> compare (in' s1) (in' s2)) (completed sessions ++ completed stillopen) --- | Convert time log entries to journal transactions, expecting the entries to be--- a strict in/out cycle. When there is no clockout, add one with the provided current time. --- Sessions crossing midnight are split into days to give accurate per-day totals.-timeclockEntriesToTransactionsSingle :: LocalTime -> [TimeclockEntry] -> [Transaction]-timeclockEntriesToTransactionsSingle _ [] = []-timeclockEntriesToTransactionsSingle now [i]-    | tlcode i /= In = errorExpectedCodeButGot In i-    | odate > idate = entryFromTimeclockInOut i o' : timeclockEntriesToTransactions now [i',o]-    | otherwise = [entryFromTimeclockInOut i o]-    where-      o = TimeclockEntry (tlsourcepos i) Out end "" "" "" []-      end = if itime > now then itime else now-      (itime,otime) = (tldatetime i,tldatetime o)-      (idate,odate) = (localDay itime,localDay otime)-      o' = o{tldatetime=itime{localDay=idate, localTimeOfDay=TimeOfDay 23 59 59}}-      i' = i{tldatetime=itime{localDay=addDays 1 idate, localTimeOfDay=midnight}}-timeclockEntriesToTransactionsSingle now (i:o:rest)-    | tlcode i /= In  = errorExpectedCodeButGot In i-    | tlcode o /= Out = errorExpectedCodeButGot Out o-    | odate > idate   = entryFromTimeclockInOut i o' : timeclockEntriesToTransactions now (i':o:rest)-    | otherwise       = entryFromTimeclockInOut i o : timeclockEntriesToTransactions now rest-    where-      (itime,otime) = (tldatetime i,tldatetime o)-      (idate,odate) = (localDay itime,localDay otime)-      o' = o{tldatetime=itime{localDay=idate, localTimeOfDay=TimeOfDay 23 59 59}}-      i' = i{tldatetime=itime{localDay=addDays 1 idate, localTimeOfDay=midnight}}-{- HLINT ignore timeclockEntriesToTransactions -}+    -- | Assuming that entries have been sorted, we go through each time log entry.+    -- We collect all of the "i" in the list "actives," and each time we encounter+    -- an "o," we look for the corresponding "i" in actives.+    -- If we cannot find it, then it is an error (since the list is sorted).+    -- If the "o" is recorded on a different day than the "i" then we close the+    -- active entry at the end of its day, replace it in the active list+    -- with a start at midnight on the next day, and try again.+    -- This raises an error if any outs cannot be paired with an in.+    pairClockEntries :: [TimeclockEntry] -> [TimeclockEntry] -> [Session] -> Sessions+    pairClockEntries [] actives sessions1 = Sessions {completed = sessions1, active = actives}+    pairClockEntries (entry:es) actives sessions1+      | tlcode entry == In  = pairClockEntries es inentries sessions1+      | tlcode entry == Out = pairClockEntries es' actives' sessions2+      | otherwise = pairClockEntries es actives sessions1+      where+        (inentry, newactive) = findInForOut entry (partition (\e -> tlaccount e == tlaccount entry) actives)+        (itime, otime) = (tldatetime inentry, tldatetime entry)+        (idate, odate) = (localDay itime, localDay otime)+        omidnight = entry {tldatetime = itime {localDay = idate, localTimeOfDay = TimeOfDay 23 59 59}}+        imidnight = inentry {tldatetime = itime {localDay = addDays 1 idate, localTimeOfDay = midnight}}+        (sessions2, actives', es')+          | odate > idate = (Session {in' = inentry, out = omidnight} : sessions1, imidnight:newactive, entry:es)+          | otherwise     = (Session {in' = inentry, out = entry} : sessions1, newactive, es)+        inentries = case filter ((== tlaccount entry) . tlaccount) actives of+          []                -> entry:actives+          activesinthisacct -> error' $ T.unpack $ makeTimeClockErrorExcerpt entry $ T.unlines $ [+            ""+            ,"overlaps with session beginning at:"+            ,""+            ]+            <> map (flip makeTimeClockErrorExcerpt "") activesinthisacct+            <> [ "Overlapping sessions with the same account name are not supported." ]+            -- XXX better to show full session(s)+            -- <> map (T.pack . show) (filter ((`elem` activesinthisacct).in') sessions) +        -- | Find the relevant clockin in the actives list that should be paired with this clockout.+        -- If there is a session that has the same account name, then use that.+        -- Otherwise, if there is an active anonymous session, use that.+        -- Otherwise, raise an error.+        findInForOut :: TimeclockEntry -> ([TimeclockEntry], [TimeclockEntry]) -> (TimeclockEntry, [TimeclockEntry])+        findInForOut _ (matchingout:othermatches, rest) = (matchingout, othermatches <> rest)+        findInForOut o ([], activeins) =+            if emptyname then (first, rest) else error' errmsg+            where+                l = show $ unPos $ sourceLine $ tlsourcepos o+                c = unPos $ sourceColumn $ tlsourcepos o+                emptyname = tlaccount o == ""+                (first, rest) = case uncons activeins of+                    Just (hd, tl) -> (hd, tl)+                    Nothing -> error' errmsg+                errmsg =+                    printf+                      "%s:\n%s\n%s\n\nCould not find previous clockin to match this clockout."+                      (sourcePosPretty $ tlsourcepos o)+                      (l ++ " | " ++ show o)+                      (replicate (length l) ' ' ++ " |" ++ replicate c ' ' ++ "^")+ errorExpectedCodeButGot :: TimeclockCode -> TimeclockEntry -> a errorExpectedCodeButGot expected actual = error' $ printf   ("%s:\n%s\n%s\n\nExpected a timeclock %s entry but got %s.\n"-  ++"Only one session may be clocked in at a time.\n"   ++"Please alternate i and o, beginning with i.")   (sourcePosPretty $ tlsourcepos actual)   (l ++ " | " ++ show actual)@@ -176,12 +194,22 @@     l = show $ unPos $ sourceLine $ tlsourcepos actual     c = unPos $ sourceColumn $ tlsourcepos actual +makeTimeClockErrorExcerpt :: TimeclockEntry -> T.Text -> T.Text+makeTimeClockErrorExcerpt e@TimeclockEntry{tlsourcepos=pos} msg = T.unlines [+  T.pack (sourcePosPretty pos) <> ":"+  ,l <> " | " <> T.pack (show e)+  -- ,T.replicate (T.length l) " " <> " |" -- <> T.replicate c " " <> "^")+  ] <> msg+  where+    l = T.pack $ show $ unPos $ sourceLine $ tlsourcepos e+    -- c = unPos $ sourceColumn $ tlsourcepos e+ -- | Convert a timeclock clockin and clockout entry to an equivalent journal -- transaction, representing the time expenditure. Note this entry is  not balanced, -- since we omit the \"assets:time\" transaction for simpler output.-entryFromTimeclockInOut :: TimeclockEntry -> TimeclockEntry -> Transaction-entryFromTimeclockInOut i o-    | otime >= itime = t+entryFromTimeclockInOut :: Bool -> TimeclockEntry -> TimeclockEntry -> Transaction+entryFromTimeclockInOut requiretimeordered i o+    | not requiretimeordered || otime >= itime = t     | otherwise =       -- Clockout time earlier than clockin is an error.       -- (Clockin earlier than preceding clockin/clockout is allowed.)@@ -209,8 +237,8 @@             tstatus      = Cleared,             tcode        = "",             tdescription = desc,-            tcomment     = tlcomment i,-            ttags        = tltags i,+            tcomment     = tlcomment i <> tlcomment o,+            ttags        = tltags i ++ tltags o,             tpostings    = ps,             tprecedingcomment=""           }@@ -228,14 +256,19 @@       -- since otherwise it will often have large recurring decimal parts which (since 1.21)       -- print would display all 255 digits of. timeclock amounts have one second resolution,       -- so two decimal places is precise enough (#1527).-      amt   = mixedAmount $ setAmountInternalPrecision 2 $ hrs hours-      ps       = [posting{paccount=acctname, pamount=amt, ptype=VirtualPosting, ptransaction=Just t}]+      amt = case mixedAmount $ setAmountInternalPrecision 2 $ hrs hours of+        a | not $ a < 0 -> a+        _ -> error' $ printf+          "%s%s:\nThis clockout is earlier than the clockin."+          (makeTimeClockErrorExcerpt i "")+          (makeTimeClockErrorExcerpt o "")+      ps = [posting{paccount=acctname, pamount=amt, ptype=VirtualPosting, ptransaction=Just t}]   -- tests  tests_Timeclock = testGroup "Timeclock" [-  testCaseSteps "timeclockEntriesToTransactions tests" $ \step -> do+  testCaseSteps "timeclockToTransactions tests" $ \step -> do       step "gathering data"       today <- getCurrentDay       now' <- getCurrentTime@@ -248,7 +281,7 @@           mktime d = LocalTime d . fromMaybe midnight .                      parseTimeM True defaultTimeLocale "%H:%M:%S"           showtime = formatTime defaultTimeLocale "%H:%M"-          txndescs = map (T.unpack . tdescription) . timeclockEntriesToTransactions now+          txndescs = map (T.unpack . tdescription) . timeclockToTransactions now           future = utcToLocalTime tz $ addUTCTime 100 now'           futurestr = showtime future       step "started yesterday, split session at midnight"@@ -260,13 +293,13 @@       step "use the clockin time for auto-clockout if it's in the future"       txndescs [clockin future "" "" "" []] @?= [printf "%s-%s" futurestr futurestr]       step "multiple open sessions"-      txndescs-        [ clockin (mktime today "00:00:00") "a" "" "" [],-          clockin (mktime today "01:00:00") "b" "" "" [],-          clockin (mktime today "02:00:00") "c" "" "" [],-          clockout (mktime today "03:00:00") "b" "" "" [],-          clockout (mktime today "04:00:00") "a" "" "" [],-          clockout (mktime today "05:00:00") "c" "" "" []-        ]+      txndescs (reverse [+        clockin (mktime today "00:00:00") "a" "" "" [],+        clockin (mktime today "01:00:00") "b" "" "" [],+        clockin (mktime today "02:00:00") "c" "" "" [],+        clockout (mktime today "03:00:00") "b" "" "" [],+        clockout (mktime today "04:00:00") "a" "" "" [],+        clockout (mktime today "05:00:00") "c" "" "" []+        ])         @?= ["00:00-04:00", "01:00-03:00", "02:00-05:00"]  ]

@@ -33,11 +33,14 @@ , transactionMapPostings , transactionMapPostingAmounts , transactionAmounts+, transactionCommodityStyles+, transactionCommodityStylesWith , transactionNegate , partitionAndCheckConversionPostings , transactionAddTags , transactionAddHiddenAndMaybeVisibleTag   -- * helpers+, TransactionBalancingPrecision(..) , payeeAndNoteFromDescription , payeeAndNoteFromDescription'   -- nonzerobalanceerror@@ -83,6 +86,22 @@ import Data.List (union)  +-- | How to determine the precision used for checking that transactions are balanced. See #2402.+data TransactionBalancingPrecision =+    TBPOld+    -- ^ Legacy behaviour, as in hledger <1.50, included to ease upgrades.+    -- use precision inferred from the whole journal, overridable by commodity directive or -c.+    -- Display precision is also transaction balancing precision; increasing it can break journal reading.+    -- Some valid journals are rejected until commodity directives are added.+    -- Small unbalanced remainders can be hidden, and in accounts that are never reconciled, can accumulate over time.+  | TBPExact+    -- ^ Simpler, more robust behaviour, as in Ledger: use precision inferred from the transaction.+    -- Display precision and transaction balancing precision are independent; display precision never affects journal reading.+    -- Valid journals from ledger or beancount are accepted without needing commodity directives.+    -- Every imbalance in a transaction is visibly accounted for in that transaction's journal entry.++  deriving (Bounded, Enum, Eq, Ord, Read, Show)+ instance HasAmounts Transaction where   styleAmounts styles t = t{tpostings=styleAmounts styles $ tpostings t} @@ -264,7 +283,7 @@ -- If the transaction already has these tags (with any value), do nothing. transactionAddHiddenAndMaybeVisibleTag :: Bool -> HiddenTag -> Transaction -> Transaction transactionAddHiddenAndMaybeVisibleTag verbosetags ht t@Transaction{tcomment=c, ttags} =-  (t `transactionAddTags` ([ht] <> [vt|verbosetags]))+  (t `transactionAddTags` ([ht] <> [ vt|verbosetags]))   {tcomment=if verbosetags && not hadtag then c `commentAddTagNextLine` vt else c}   where     vt@(vname,_) = toVisibleTag ht@@ -482,6 +501,17 @@ -- | All posting amounts from this transaction, in order. transactionAmounts :: Transaction -> [MixedAmount] transactionAmounts = map pamount . tpostings++-- | Get the canonical amount styles inferred from this transaction's amounts.+transactionCommodityStyles :: Transaction -> M.Map CommoditySymbol AmountStyle+transactionCommodityStyles =+  either (const mempty) id .  -- ignore style problems, commodityStylesFromAmounts doesn't report them currently+  commodityStylesFromAmounts . concatMap (amountsRaw . pamount) . tpostings++-- | Like transactionCommodityStyles, but attach a particular rounding strategy to the styles,+-- affecting how they will affect display precisions when applied.+transactionCommodityStylesWith :: Rounding -> Transaction -> M.Map CommoditySymbol AmountStyle+transactionCommodityStylesWith r = amountStylesSetRounding r . transactionCommodityStyles  -- | Flip the sign of this transaction's posting amounts (and balance assertion amounts). transactionNegate :: Transaction -> Transaction

@@ -109,6 +109,7 @@   \p -> styleAmounts styles . renderPostingCommentDates $ pr       { pdate    = pdate  pr <|> pdate  p       , pdate2   = pdate2 pr <|> pdate2 p+      , paccount = account' p       , pamount  = amount' p       , pcomment = pcomment pr & (if verbosetags then (`commentAddTag` ("generated-posting",qry)) else id)       , ptags    = ptags pr@@ -119,6 +120,10 @@     pr = tmprPosting tmpr     qry = "= " <> querytxt     symq = filterQuery (liftA2 (||) queryIsSym queryIsAmt) query+    account' = if accountTemplate `T.isInfixOf` paccount pr+                 then \p -> T.replace accountTemplate (paccount p) $ paccount pr+                 else const $ paccount pr+      where accountTemplate = "%account"     amount' = case postingRuleMultiplier tmpr of         Nothing -> const $ pamount pr         Just n  -> \p ->

@@ -18,6 +18,7 @@  -- {-# LANGUAGE DeriveAnyClass #-}  -- https://hackage.haskell.org/package/deepseq-1.4.4.0/docs/Control-DeepSeq.html#v:rnf {-# LANGUAGE CPP        #-}+{-# LANGUAGE DeriveFunctor        #-} {-# LANGUAGE DeriveGeneric        #-} {-# LANGUAGE FlexibleInstances    #-} {-# LANGUAGE OverloadedStrings    #-}@@ -39,6 +40,7 @@ import Data.Decimal (Decimal, DecimalRaw(..)) import Data.Default (Default(..)) import Data.Functor (($>))+import qualified Data.IntMap.Strict as IM import Data.List (intercalate, sortBy) --XXX https://hackage.haskell.org/package/containers/docs/Data-Map.html --Note: You should use Data.Map.Strict instead of this module if:@@ -670,6 +672,8 @@   | Ssv  -- semicolon-separated   deriving (Eq, Ord) +-- XXX A little confusion, this is also used to name readers in splitReaderPrefix.+-- readers, input formats, and output formats overlap but are distinct concepts. -- | The id of a data format understood by hledger, eg @journal@ or @csv@. -- The --output-format option selects one of these for output. data StorageFormat @@ -733,21 +737,37 @@   ,adisourcepos        = SourcePos "" (mkPos 1) (mkPos 1) } --- | An account, with its balances, parent/subaccount relationships, etc.--- Only the name is required; the other fields are added when needed.-data Account = Account {-   aname                     :: AccountName    -- ^ this account's full name+-- | An account within a hierarchy, with references to its parent+-- and subaccounts if any, and with per-report-period data of type 'a'.+-- Only the name is required; the other fields may or may not be present.+data Account a = Account {+   aname                     :: AccountName        -- ^ full name   ,adeclarationinfo          :: Maybe AccountDeclarationInfo  -- ^ optional extra info from account directives   -- relationships in the tree-  ,asubs                     :: [Account]      -- ^ this account's sub-accounts-  ,aparent                   :: Maybe Account  -- ^ parent account-  ,aboring                   :: Bool           -- ^ used in the accounts report to label elidable parents-  -- balance information-  ,anumpostings              :: Int            -- ^ the number of postings to this account-  ,aebalance                 :: MixedAmount    -- ^ this account's balance, excluding subaccounts-  ,aibalance                 :: MixedAmount    -- ^ this account's balance, including subaccounts-  } deriving (Generic)+  ,asubs                     :: [Account a]        -- ^ subaccounts+  ,aparent                   :: Maybe (Account a)  -- ^ parent account+  ,aboring                   :: Bool               -- ^ used in some reports to indicate elidable accounts+  ,adata                     :: PeriodData a       -- ^ associated data per report period+  } deriving (Generic, Functor) +-- | Data values for zero or more report periods, and for the pre-report period.+-- Report periods are assumed to be contiguous, and represented only by start dates+-- (as keys of an IntMap). XXX how does that work, again ?+data PeriodData a = PeriodData {+   pdpre     :: a            -- ^ data from the pre-report period (e.g. historical balances)+  ,pdperiods :: IM.IntMap a  -- ^ data for the periods+  } deriving (Eq, Functor, Generic)++-- | Data that's useful in "balance" reports:+-- subaccount-exclusive and -inclusive amounts,+-- typically representing either a balance change or an end balance;+-- and a count of postings.+data BalanceData = BalanceData {+   bdexcludingsubs :: MixedAmount  -- ^ balance data excluding subaccounts+  ,bdincludingsubs :: MixedAmount  -- ^ balance data including subaccounts+  ,bdnumpostings :: Int            -- ^ the number of postings+  } deriving (Eq, Generic)+ -- | Whether an account's balance is normally a positive number (in -- accounting terms, a debit balance) or a negative number (credit balance). -- Assets and expenses are normally positive (debit), while liabilities, equity@@ -761,7 +781,7 @@ -- account is the root of the tree and always exists. data Ledger = Ledger {    ljournal  :: Journal-  ,laccounts :: [Account]+  ,laccounts :: [Account BalanceData]   } deriving (Generic)  instance NFData AccountAlias

@@ -67,7 +67,8 @@   matchesMixedAmount,   matchesAmount,   matchesCommodity,-  matchesTags,+  matchesTag,+  -- patternsMatchTags,   matchesPriceDirective,   words'',   queryprefixes,@@ -76,7 +77,7 @@ ) where -import Control.Applicative ((<|>), many, optional)+import Control.Applicative import Data.Default (Default(..)) import Data.Either (partitionEithers) import Data.List (partition, intercalate)@@ -126,7 +127,7 @@   -- compound queries for transactions (any:, all:)   -- If used in a non transaction-matching context, these are equivalent to And.   | AnyPosting  [Query]       -- ^ match if any one posting is matched by all of these-  | AllPostings [Query]       -- ^ match if all postings are matched by all of these+  | AllPostings [Query]       -- ^ match if all of one or more postings are matched by all of these   deriving (Eq,Show)  instance Default Query where def = Any@@ -510,7 +511,7 @@     ([],[])   -> Left help     ([],ts)   -> Right $ Type ts   where-    help = "type:'s argument should be one or more of " ++ accountTypeChoices False ++ " (case insensitive)."+    help = "type:'s argument should be one or more of " ++ accountTypeChoices False  accountTypeChoices :: Bool -> String accountTypeChoices allowlongform = @@ -813,8 +814,14 @@ -- matching things with queries  matchesCommodity :: Query -> CommoditySymbol -> Bool-matchesCommodity (Sym r) = regexMatchText r-matchesCommodity _ = const True+matchesCommodity (Sym r)          s = regexMatchText r s+matchesCommodity (Any)            _ = True+matchesCommodity (None)           _ = False+matchesCommodity (Or qs)          s = any (`matchesCommodity` s) qs+matchesCommodity (And qs)         s = all (`matchesCommodity` s) qs+matchesCommodity (AnyPosting qs)  s = all (`matchesCommodity` s) qs+matchesCommodity (AllPostings qs) s = all1 (`matchesCommodity` s) qs+matchesCommodity _                _ = False  -- | Does the match expression match this (simple) amount ? matchesAmount :: Query -> Amount -> Bool@@ -824,7 +831,7 @@ matchesAmount (Or qs) a = any (`matchesAmount` a) qs matchesAmount (And qs) a = all (`matchesAmount` a) qs matchesAmount (AnyPosting  qs) a = all (`matchesAmount` a) qs-matchesAmount (AllPostings qs) a = all (`matchesAmount` a) qs+matchesAmount (AllPostings qs) a = all1 (`matchesAmount` a) qs matchesAmount (Amt ord n) a = compareAmount ord n a matchesAmount (Sym r) a = matchesCommodity (Sym r) (acommodity a) matchesAmount _ _ = True@@ -855,7 +862,7 @@ matchesAccount (Or ms) a = any (`matchesAccount` a) ms matchesAccount (And ms) a = all (`matchesAccount` a) ms matchesAccount (AnyPosting  qs) a = all (`matchesAccount` a) qs-matchesAccount (AllPostings qs) a = all (`matchesAccount` a) qs+matchesAccount (AllPostings qs) a = all1 (`matchesAccount` a) qs matchesAccount (Acct r) a = regexMatchText r a matchesAccount (Depth d) a = accountNameLevel a <= d matchesAccount (DepthAcct r d) a = accountNameLevel a <= d || not (regexMatchText r a)@@ -875,9 +882,9 @@ matchesAccountExtra atypes atags (Or  qs ) a = any (\q -> matchesAccountExtra atypes atags q a) qs matchesAccountExtra atypes atags (And qs ) a = all (\q -> matchesAccountExtra atypes atags q a) qs matchesAccountExtra atypes atags (AnyPosting  qs ) a = all (\q -> matchesAccountExtra atypes atags q a) qs-matchesAccountExtra atypes atags (AllPostings qs ) a = all (\q -> matchesAccountExtra atypes atags q a) qs+matchesAccountExtra atypes atags (AllPostings qs ) a = all1 (\q -> matchesAccountExtra atypes atags q a) qs matchesAccountExtra atypes _     (Type ts) a = maybe False (\t -> any (t `isAccountSubtypeOf`) ts) $ atypes a-matchesAccountExtra _      atags (Tag npat vpat) a = matchesTags npat vpat $ atags a+matchesAccountExtra _      atags (Tag npat vpat) a = patternsMatchTags npat vpat $ atags a matchesAccountExtra _      _     q         a = matchesAccount q a  -- | Does the match expression match this posting ?@@ -890,7 +897,7 @@ matchesPosting (Or qs) p = any (`matchesPosting` p) qs matchesPosting (And qs) p = all (`matchesPosting` p) qs matchesPosting (AnyPosting  qs) p = all (`matchesPosting` p) qs-matchesPosting (AllPostings qs) p = all (`matchesPosting` p) qs+matchesPosting (AllPostings qs) p = all1 (`matchesPosting` p) qs matchesPosting (Code r) p = maybe False (regexMatchText r . tcode) $ ptransaction p matchesPosting (Desc r) p = maybe False (regexMatchText r . tdescription) $ ptransaction p matchesPosting (Acct r) p = matches p || maybe False matches (poriginal p) where matches = regexMatchText r . paccount@@ -905,7 +912,7 @@ 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-  (_, mv) -> matchesTags n mv $ postingAllTags p+  (_, mv) -> patternsMatchTags n mv $ postingAllTags p matchesPosting (Type _) _ = False  -- | Like matchesPosting, but if the posting's account's type is provided,@@ -916,7 +923,7 @@ matchesPostingExtra atype (Or  qs)  p = any (\q -> matchesPostingExtra atype q p) qs matchesPostingExtra atype (And qs)  p = all (\q -> matchesPostingExtra atype q p) qs matchesPostingExtra atype (AnyPosting  qs)  p = all (\q -> matchesPostingExtra atype q p) qs-matchesPostingExtra atype (AllPostings qs)  p = all (\q -> matchesPostingExtra atype q p) qs+matchesPostingExtra atype (AllPostings qs)  p = all1 (\q -> matchesPostingExtra atype q p) qs matchesPostingExtra atype (Type ts) p =   -- does posting's account's type, if we can detect it, match any of the given types ?   (maybe False (\t -> any (t `isAccountSubtypeOf`) ts) . atype $ paccount p)@@ -937,7 +944,7 @@ matchesTransaction (Or qs) t = any (`matchesTransaction` t) qs matchesTransaction (And qs) t = all (`matchesTransaction` t) qs matchesTransaction (AnyPosting  qs) t = any (\p -> all (`matchesPosting` p) qs) $ tpostings t-matchesTransaction (AllPostings qs) t = all (\p -> all (`matchesPosting` p) qs) $ tpostings t+matchesTransaction (AllPostings qs) t = all1 (\p -> all (`matchesPosting` p) qs) $ tpostings t matchesTransaction (Code r) t = regexMatchText r $ tcode t matchesTransaction (Desc r) t = regexMatchText r $ tdescription t matchesTransaction q@(Acct _) t = any (q `matchesPosting`) $ tpostings t@@ -952,7 +959,7 @@ matchesTransaction (Tag n v) t = case (reString n, v) of   ("payee", Just v') -> regexMatchText v' $ transactionPayee t   ("note", Just v') -> regexMatchText v' $ transactionNote t-  (_, v') -> matchesTags n v' $ transactionAllTags t+  (_, v') -> patternsMatchTags n v' $ transactionAllTags t matchesTransaction (Type _) _ = False  -- | Like matchesTransaction, but if the journal's account types are provided,@@ -963,12 +970,12 @@ matchesTransactionExtra atype (Or  qs) t = any (\q -> matchesTransactionExtra atype q t) qs matchesTransactionExtra atype (And qs) t = all (\q -> matchesTransactionExtra atype q t) qs matchesTransactionExtra atype (AnyPosting  qs) t = any (\p -> all (\q -> matchesPostingExtra atype q p) qs) $ tpostings t-matchesTransactionExtra atype (AllPostings qs) t = all (\p -> all (\q -> matchesPostingExtra atype q p) qs) $ tpostings t+matchesTransactionExtra atype (AllPostings qs) t = all1 (\p -> all (\q -> matchesPostingExtra atype q p) qs) $ tpostings t matchesTransactionExtra atype q@(Type _) t = any (matchesPostingExtra atype q) $ tpostings t matchesTransactionExtra _ q t = matchesTransaction q t  -- | Does the query match this transaction description ?--- Tests desc: terms, any other terms are ignored.+-- Non-desc: query terms are ignored (this might disrupt some boolean queries). matchesDescription :: Query -> Text -> Bool matchesDescription (Not q) d          = not $ q `matchesDescription` d matchesDescription (Any) _            = True@@ -976,7 +983,7 @@ matchesDescription (Or qs) d          = any (`matchesDescription` d) $ filter queryIsDesc qs matchesDescription (And qs) d         = all (`matchesDescription` d) $ filter queryIsDesc qs matchesDescription (AnyPosting  qs) d = all (`matchesDescription` d) $ filter queryIsDesc qs-matchesDescription (AllPostings qs) d = all (`matchesDescription` d) $ filter queryIsDesc qs+matchesDescription (AllPostings qs) d = all1 (`matchesDescription` d) $ filter queryIsDesc qs matchesDescription (Code _) _         = False matchesDescription (Desc r) d         = regexMatchText r d matchesDescription _ _                = False@@ -988,12 +995,25 @@ matchesPayeeWIP :: Query -> Payee -> Bool 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 = any (matches namepat valuepat)+-- | Do this name regex and optional value regex match the name and value of any of these tags ?+patternsMatchTags :: Regexp -> Maybe Regexp -> [Tag] -> Bool+patternsMatchTags namepat valuepat = any (matches namepat valuepat)   where     matches npat vpat (n,v) = regexMatchText npat n && maybe (const True) regexMatchText vpat v +-- | Does the query match the name and optionally the value of this tag ?+-- Non-tag: query terms are ignored (this might disrupt some boolean queries).+matchesTag :: Query -> Tag -> Bool+matchesTag (Not q)          t = not $ q `matchesTag` t+matchesTag (Any)            _ = True+matchesTag (None)           _ = False+matchesTag (Or qs)          t = any (`matchesTag` t) $ filter queryIsTag qs+matchesTag (And qs)         t = all (`matchesTag` t) $ filter queryIsTag qs+matchesTag (AnyPosting qs)  t = all (`matchesTag` t) $ filter queryIsTag qs+matchesTag (AllPostings qs) t = all1 (`matchesTag` t) $ filter queryIsTag qs+matchesTag (Tag npat mvpat) t = patternsMatchTags npat mvpat [t]+matchesTag _                _ = False+ -- | Does the query match this market price ? matchesPriceDirective :: Query -> PriceDirective -> Bool matchesPriceDirective (None) _           = False@@ -1001,7 +1021,7 @@ matchesPriceDirective (Or qs) p          = any (`matchesPriceDirective` p) qs matchesPriceDirective (And qs) p         = all (`matchesPriceDirective` p) qs matchesPriceDirective (AnyPosting  qs) p = all (`matchesPriceDirective` p) qs-matchesPriceDirective (AllPostings qs) p = all (`matchesPriceDirective` p) qs+matchesPriceDirective (AllPostings qs) p = all1 (`matchesPriceDirective` p) qs matchesPriceDirective q@(Amt _ _) p      = matchesAmount q (pdamount p) matchesPriceDirective q@(Sym _) p        = matchesCommodity q (pdcommodity p) matchesPriceDirective (Date spn) p       = spanContainsDate spn (pddate p)

@@ -87,7 +87,6 @@ module Hledger.Read (    -- * Journal files-  PrefixedFilePath,   defaultJournal,   defaultJournalWith,   defaultJournalSafely,@@ -227,10 +226,6 @@         home <- fromMaybe "" <$> getHomeSafe         return $ home </> journalDefaultFilename --- | A file path optionally prefixed by a reader name and colon--- (journal:, csv:, timedot:, etc.).-type PrefixedFilePath = FilePath- -- | @readJournal iopts mfile txt@ -- -- Read a Journal from some handle, with strict checks if enabled,@@ -337,9 +332,9 @@   when (new_ && new_save_) $ liftIO $ saveLatestDatesForFiles latestdatesforfiles   return j --- The implementation of readJournalFiles, but with --new, --- also returns the latest transaction date(s) read in each file.--- Used by the import command, to save those at the end.+-- The implementation of readJournalFiles.+-- With --new, it also returns the latest transaction date(s) read in each file+-- (used by the import command). readJournalFilesAndLatestDates :: InputOpts -> [PrefixedFilePath] -> ExceptT String IO (Journal, [LatestDatesForFile]) readJournalFilesAndLatestDates iopts pfs = do   (js, lastdates) <- unzip <$> mapM (readJournalFileAndLatestDates iopts) pfs@@ -413,6 +408,7 @@  -- The path of an input file, and its current "LatestDates". data LatestDatesForFile = LatestDatesForFile FilePath LatestDates+  deriving Show  -- | Get all instances of the latest date in an unsorted list of dates. -- Ie, if the latest date appears once, return it in a one-element list,@@ -423,8 +419,10 @@  -- | Save the given latest date(s) seen in the given data FILE, -- in a hidden file named .latest.FILE, creating it if needed.+-- Unless no latest dates are provided, in which case do nothing. saveLatestDates :: LatestDates -> FilePath -> IO ()-saveLatestDates dates f = T.writeFile (latestDatesFileFor f) $ T.unlines $ map showDate dates+saveLatestDates dates f = when (not $ null dates) $+  T.writeFile (latestDatesFileFor f) $ T.unlines $ map showDate dates  -- | Save each file's latest dates. saveLatestDatesForFiles :: [LatestDatesForFile] -> IO ()

@@ -30,6 +30,8 @@ --- ** exports module Hledger.Read.Common (   Reader (..),+  PrefixedFilePath,+  isStdin,   InputOpts(..),   HasInputOpts(..),   definputopts,@@ -72,6 +74,7 @@   -- ** account names   modifiedaccountnamep,   accountnamep,+  accountnamenosemicolonp,    -- ** account aliases   accountaliasp,@@ -160,6 +163,7 @@ import Hledger.Utils import Hledger.Read.InputOptions + --- ** doctest setup -- $setup -- >>> :set -XOverloadedStrings@@ -168,29 +172,38 @@  -- main types; a few more below --- | A hledger journal reader is a triple of storage format name, a--- detector of that format, and a parser from that format to Journal.--- The type variable m appears here so that rParserr can hold a--- journal parser, which depends on it.+-- | A hledger journal reader is a storage format name,+-- a list of file extensions assumed to be in this format,+-- and an IO action that reads data in this format, returning a Journal.+--+-- The journal parser used by the latter is also stored separately for direct use+-- by the journal reader's includedirectivep to parse included files.+-- The type variable m is needed for this parser.+-- Lately it requires an InputOpts, basically to support --old-timeclock. data Reader m = Reader {--     -- The canonical name of the format handled by this reader-     rFormat   :: StorageFormat--     -- The file extensions recognised as containing this format-    ,rExtensions :: [String]+    -- The canonical name of the format handled by this reader. "journal", "timedot", "csv" etc.+   rFormat :: StorageFormat+    -- The file extensions recognised as containing this format.+  ,rExtensions :: [String]+    -- An IO action for reading this format, producing a journal or an error message.+    -- It accepts input options, a file path to show in error messages, and a handle to read data from.+  ,rReadFn :: InputOpts -> FilePath -> Handle -> ExceptT String IO Journal+    -- The megaparsec parser called by the above, provided separately for parsing included files.+  ,rParser :: MonadIO m => InputOpts -> ErroringJournalParser m ParsedJournal+  } -     -- The entry point for reading this format, accepting input options, file-     -- path for error messages and file contents via the handle, producing an exception-raising IO-     -- action that produces a journal or error message.-    ,rReadFn   :: InputOpts -> FilePath -> Handle -> ExceptT String IO Journal+instance Show (Reader m) where show r = show (rFormat r) ++ " reader" -     -- The actual megaparsec parser called by the above, in case-     -- another parser (includedirectivep) wants to use it directly.-    ,rParser :: MonadIO m => ErroringJournalParser m ParsedJournal-    }+-- | A file path optionally prefixed by a reader name and colon (journal:, csv:, timedot:, etc.).+-- The file path part can also be - meaning standard input.+type PrefixedFilePath = FilePath -instance Show (Reader m) where show r = show (rFormat r) ++ " reader"+-- | Is this the special file path meaning standard input ? (-, possibly prefixed)+isStdin :: PrefixedFilePath -> Bool+isStdin f = case splitAtElement ':' f of+  [_,"-"] -> True+  ["-"] -> True+  _ -> False  -- | 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.@@ -214,8 +227,11 @@         argsquery = map fst . rights . map (parseQueryTerm day) $ querystring_ ropts         datequery = simplifyQuery . filterQuery queryIsDate . And $ queryFromFlags ropts : argsquery +        txnbalancingprecision = either err id $ transactionBalancingPrecisionFromOpts rawopts+          where err e = error' $ "could not parse --txn-balancing: '" ++ e ++ "'"  -- PARTIAL:+         styles = either err id $ commodityStyleFromRawOpts rawopts-          where err e = error' $ "could not parse commodity-style: '" ++ e ++ "'"  -- PARTIAL:+          where err e = error' $ "could not parse --commodity-style: '" ++ e ++ "'"  -- PARTIAL:      in definputopts{        -- files_             = listofstringopt "file" rawopts@@ -236,6 +252,7 @@       ,balancingopts_     = defbalancingopts{                                  ignore_assertions_     = boolopt "ignore-assertions" rawopts                                , infer_balancing_costs_ = not noinferbalancingcosts+                               , txn_balancing_         = txnbalancingprecision                                , commodity_styles_      = Just styles                                }       ,strict_            = boolopt "strict" rawopts@@ -262,18 +279,26 @@         _          -> 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+-- | Given the raw options, return either+-- * if all options were successfully parsed: a map of successfully parsed commodity styles,+-- * if one or more options failed to parse: the first option which 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+  foldM (\r -> fmap (\(c,a) -> M.insert c a r) . parseCommodity) mempty optList   where     optList = listofstringopt "commodity-style" rawOpts     parseCommodity optStr = case parseamount optStr of-        Left _ -> Left optStr-        Right (Amount acommodity _ astyle _) -> Right (acommodity, astyle)+      Left _ -> Left optStr+      Right (Amount acommodity _ astyle _) -> Right (acommodity, astyle) +transactionBalancingPrecisionFromOpts :: RawOpts -> Either String TransactionBalancingPrecision+transactionBalancingPrecisionFromOpts rawopts =+  case maybestringopt "txn-balancing" rawopts of+    Nothing      -> Right TBPExact+    Just "old"   -> Right TBPOld+    Just "exact" -> Right TBPExact+    Just s       -> Left $ s<>", should be one of: old, exact"+ -- | 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.@@ -285,7 +310,7 @@ -- | Given a parser to ParsedJournal, input options, file path and -- content: run the parser on the content. This is all steps of -- 'parseAndFinaliseJournal' without the finalisation step, and is used when--- you need to perform other actions before finalisation, as in parsing+-- you need to perform other actions before finalisatison, as in parsing -- Timeclock and Timedot files. initialiseAndParseJournal :: ErroringJournalParser IO ParsedJournal -> InputOpts                           -> FilePath -> Text -> ExceptT String IO Journal@@ -375,16 +400,16 @@       -- XXX how to force debug output here ?        -- >>= Right . dbg0With (concatMap (T.unpack.showTransaction).jtxns)        -- >>= \j -> deepseq (concatMap (T.unpack.showTransaction).jtxns $ j) (return j)-      <&> dbg9With (lbl "amounts after styling, forecasting, auto-posting".showJournalAmountsDebug)+      <&> dbg9With (lbl "amounts after styling, forecasting, auto-posting".showJournalPostingAmountsDebug)       >>= (\j -> if checkordereddates then journalCheckOrdereddates j $> j else Right j)  -- check ordereddates before assertions. The outer parentheses are needed.       >>= journalBalanceTransactions balancingopts_{ignore_assertions_=not checkassertions}  -- infer balance assignments and missing amounts, and maybe check balance assertions.-      <&> dbg9With (lbl "amounts after transaction-balancing".showJournalAmountsDebug)-      -- <&> dbg9With (("journalFinalise amounts after styling, forecasting, auto postings, transaction balancing"<>).showJournalAmountsDebug)+      <&> dbg9With (lbl "amounts after transaction-balancing".showJournalPostingAmountsDebug)+      -- <&> dbg9With (("journalFinalise amounts after styling, forecasting, auto postings, transaction balancing"<>).showJournalPostingAmountsDebug)       >>= journalInferCommodityStyles                    -- infer commodity styles once more now that all posting amounts are present       -- >>= Right . dbg0With (pshow.journalCommodityStyles)       >>= (if infer_costs_  then journalTagCostsAndEquityAndMaybeInferCosts verbose_tags_ True else pure)  -- With --infer-costs, infer costs from equity postings where possible       <&> (if infer_equity_ then journalInferEquityFromCosts verbose_tags_ else id)          -- With --infer-equity, infer equity postings from costs where possible-      <&> dbg9With (lbl "amounts after equity-inferring".showJournalAmountsDebug)+      <&> dbg9With (lbl "amounts after equity-inferring".showJournalPostingAmountsDebug)       <&> journalInferMarketPricesFromTransactions       -- infer market prices from commodity-exchanging transactions       -- <&> dbg6Msg fname  -- debug logging       <&> dbgJournalAcctDeclOrder (fname <> ": acct decls           : ")@@ -665,16 +690,18 @@  --- *** account names --- | Parse an account name (plus one following space if present),+-- | Parse an account name plus one following space if present (see accountnamep); -- then apply any parent account prefix and/or account aliases currently in effect,--- in that order. (Ie first add the parent account prefix, then rewrite with aliases).+-- in that order. Ie first add the parent account prefix, then rewrite with aliases. -- This calls error if any account alias with an invalid regular expression exists.-modifiedaccountnamep :: JournalParser m AccountName-modifiedaccountnamep = do+-- The flag says whether account names may include semicolons; currently account names+-- in journal format may, but account names in timeclock/timedot formats may not.+modifiedaccountnamep :: Bool -> JournalParser m AccountName+modifiedaccountnamep allowsemicolon = do   parent  <- getParentAccount   als     <- getAccountAliases   -- off1    <- getOffset-  a       <- lift accountnamep+  a       <- lift $ if allowsemicolon then accountnamep else accountnamenosemicolonp   -- off2    <- getOffset   -- XXX or accountNameApplyAliasesMemo ? doesn't seem to make a difference (retest that function)   case accountNameApplyAliases als $ joinAccountNames parent a of@@ -689,15 +716,17 @@ -- | Parse an account name, plus one following space if present. -- Account names have one or more parts separated by the account separator character, -- and are terminated by two or more spaces (or end of input).--- Each part is at least one character long, may have single spaces inside it,--- and starts with a non-whitespace.--- Note, this means "{account}", "%^!" and ";comment" are all accepted--- (parent parsers usually prevent/consume the last).--- It should have required parts to start with an alphanumeric;--- for now it remains as-is for backwards compatibility.+-- Each part is at least one character long, may have single spaces inside it, and starts with a non-whitespace.+-- (We should have required them to start with an alphanumeric, but didn't.)+-- Note, this means account names can contain all kinds of punctuation, including ; which usually starts a following comment.+-- Parent parsers usually remove the following comment before using this parser. accountnamep :: TextParser m AccountName accountnamep = singlespacedtext1p +-- Like accountnamep, but stops parsing if it reaches a semicolon.+accountnamenosemicolonp :: TextParser m AccountName+accountnamenosemicolonp = singlespacednoncommenttext1p+ -- | Parse a single line of possibly empty text enclosed in double quotes. doublequotedtextp :: TextParser m Text doublequotedtextp = between (char '"') (char '"') $@@ -1348,10 +1377,10 @@ -- using the provided line parser to parse each line. -- This returns the comment text, and the combined results from the line parser. ----- Following comments begin with a semicolon and extend to the end of the line.--- They can optionally be continued on the next lines,--- where each next line begins with an indent and another semicolon.--- (This parser expects to see these semicolons and indents.)+-- Following comments are a 1-or-more-lines comment,+-- beginning with a semicolon possibly preceded by whitespace on the current line,+-- or with an indented semicolon on the next line.+-- Additional lines also must begin with an indented semicolon. -- -- Like Ledger, we sometimes allow data to be embedded in comments. -- account directive comments and transaction comments can contain tags,@@ -1415,10 +1444,11 @@  -- | Parse a transaction comment and extract its tags. ----- The first line of a transaction may be followed by comments, which--- begin with semicolons and extend to the end of the line. Transaction--- comments may span multiple lines, but comment lines below the--- transaction must be preceded by leading whitespace.+-- The first line of a transaction may be followed a 1-or-more-lines comment,+-- beginning with a semicolon possibly preceded by whitespace on the current line,+-- or with an indented semicolon on the next line. Additional lines also must+-- begin with an indented semicolon.+-- See also followingcommentpWith. -- -- 2000/1/1 ; a transaction comment starting on the same line ... --   ; extending to the next line

@@ -46,13 +46,17 @@   {rFormat     = Sep sep   ,rExtensions = [show sep]   ,rReadFn     = parse sep-  ,rParser     = error' "sorry, CSV files can't be included yet"  -- PARTIAL:+  ,rParser     = const $ fail "sorry, CSV files can't be included yet"+    -- This unnecessarily shows the CSV file's first line in the error message,+    -- but gives a more useful message than just calling error'.+    -- XXX Note every call to error' in Hledger.Read.* is potentially a similar problem -+    -- the error message is good enough when the file was specified directly by the user,+    -- but not good if it was loaded by a possibly long chain of include directives.   } --- | Parse and post-process a "Journal" from CSV data, or give an error.--- This currently ignores the provided data, and reads it from the file path instead.--- This file path is normally the CSV(/SSV/TSV) data file, and a corresponding rules file is inferred.--- But it can also be the rules file, in which case the corresponding data file is inferred.+-- | Parse and post-process a "Journal" from a CSV(/SSV/TSV/*SV) data file, or give an error.+-- This currently ignores the provided input file handle, and reads from the data file itself,+-- inferring a corresponding rules file to help convert it. -- This does not check balance assertions. parse :: SepFormat -> InputOpts -> FilePath -> Handle -> ExceptT String IO Journal parse sep iopts f h = do@@ -71,4 +75,3 @@  tests_CsvReader = testGroup "CsvReader" [   ]-

@@ -71,9 +71,8 @@ where  --- ** imports-import qualified Control.Monad.Fail as Fail (fail) import qualified Control.Exception as C-import Control.Monad (forM_, when, void, unless)+import Control.Monad (forM_, when, void, unless, filterM) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Except (ExceptT(..), runExceptT) import Control.Monad.State.Strict (evalStateT,get,modify',put)@@ -94,6 +93,7 @@ import Text.Printf import System.FilePath import "Glob" System.FilePath.Glob hiding (match)+-- import "filepattern" System.FilePattern.Directory  import Hledger.Data import Hledger.Read.Common@@ -103,7 +103,8 @@ import qualified Hledger.Read.RulesReader as RulesReader (reader) import qualified Hledger.Read.TimeclockReader as TimeclockReader (reader) import qualified Hledger.Read.TimedotReader as TimedotReader (reader)-import System.Directory (canonicalizePath)+import System.Directory (canonicalizePath, doesFileExist)+import Data.Functor ((<&>))  --- ** doctest setup -- $setup@@ -166,28 +167,40 @@     (prefix,path') = splitReaderPrefix path     ext            = map toLower $ drop 1 $ takeExtension path' --- | A file path optionally prefixed by a reader name and colon--- (journal:, csv:, timedot:, etc.).-type PrefixedFilePath = FilePath---- | If a filepath is prefixed by one of the reader names and a colon,--- split that off. Eg "csv:-" -> (Just "csv", "-").--- These reader prefixes can be used to force a specific reader,--- overriding the file extension. +-- | Separate a file path and its reader prefix, if any.+--+-- >>> splitReaderPrefix "csv:-"+-- (Just csv,"-") splitReaderPrefix :: PrefixedFilePath -> (Maybe StorageFormat, FilePath) splitReaderPrefix f =   let -  candidates = [(Just r, drop (length r + 1) f) | r <- readerNames ++ ["ssv","tsv"], (r++":") `isPrefixOf` f]-  (strPrefix, newF) = headDef (Nothing, f) candidates+    candidates = [(Just r, drop (length r + 1) f) | r <- readerNames ++ ["ssv","tsv"], (r++":") `isPrefixOf` f]+    (strPrefix, newF) = headDef (Nothing, f) candidates   in case strPrefix of-  Just "csv" -> (Just (Sep Csv), newF)-  Just "tsv" -> (Just (Sep Tsv), newF)-  Just "ssv" -> (Just (Sep Ssv), newF)-  Just "journal" -> (Just Journal', newF)-  Just "timeclock" -> (Just Timeclock, newF)-  Just "timedot" -> (Just Timedot, newF)-  _ -> (Nothing, f)+    Just "csv" -> (Just (Sep Csv), newF)+    Just "tsv" -> (Just (Sep Tsv), newF)+    Just "ssv" -> (Just (Sep Ssv), newF)+    Just "journal" -> (Just Journal', newF)+    Just "timeclock" -> (Just Timeclock, newF)+    Just "timedot" -> (Just Timedot, newF)+    _ -> (Nothing, f) +-- -- | Does this file path have a reader prefix ?+-- hasReaderPrefix :: PrefixedFilePath -> Bool+-- hasReaderPrefix = isJust . fst. splitReaderPrefix++-- -- | Add a reader prefix to a file path, unless it already has one.+-- -- The argument should be a valid reader name.+-- --+-- -- >>> addReaderPrefix "csv" "a.txt"+-- -- >>> "csv:a.txt"+-- -- >>> addReaderPrefix "csv" "timedot:a.txt"+-- -- >>> "timedot:a.txt"+-- addReaderPrefix :: ReaderPrefix -> FilePath -> PrefixedFilePath+-- addReaderPrefix readername f+--   | hasReaderPrefix f = f+--   | otherwise = readername <> ":" <> f+ --- ** reader  reader :: MonadIO m => Reader m@@ -207,7 +220,7 @@     journalp' = do       -- reverse parsed aliases to ensure that they are applied in order given on commandline       mapM_ addAccountAlias (reverse $ aliasesFromOpts iopts)-      journalp+      journalp iopts  --- ** parsers --- *** journal@@ -215,23 +228,23 @@ -- | A journal parser. Accumulates and returns a "ParsedJournal", -- which should be finalised/validated before use. ----- >>> rejp (journalp <* eof) "2015/1/1\n a  0\n"+-- >>> rejp (journalp definputopts <* eof) "2015/1/1\n a  0\n" -- Right (Right Journal (unknown) with 1 transactions, 1 accounts) ---journalp :: MonadIO m => ErroringJournalParser m ParsedJournal-journalp = do-  many addJournalItemP+journalp :: MonadIO m => InputOpts -> ErroringJournalParser m ParsedJournal+journalp iopts = do+  many $ addJournalItemP iopts   eof   get  -- | A side-effecting parser; parses any kind of journal item -- and updates the parse state accordingly.-addJournalItemP :: MonadIO m => ErroringJournalParser m ()-addJournalItemP =+addJournalItemP :: MonadIO m => InputOpts -> ErroringJournalParser m ()+addJournalItemP iopts =   -- all journal line types can be distinguished by the first   -- character, can use choice without backtracking   choice [-      directivep+      directivep iopts     , transactionp          >>= modify' . addTransaction     , transactionmodifierp  >>= modify' . addTransactionModifier     , periodictransactionp  >>= modify' . addPeriodicTransaction@@ -245,11 +258,11 @@ -- | Parse any journal directive and update the parse state accordingly. -- Cf http://hledger.org/hledger.html#directives, -- http://ledger-cli.org/3.0/doc/ledger3.html#Command-Directives-directivep :: MonadIO m => ErroringJournalParser m ()-directivep = (do+directivep :: MonadIO m => InputOpts -> ErroringJournalParser m ()+directivep iopts = (do   optional $ oneOf ['!','@']   choice [-    includedirectivep+    includedirectivep iopts    ,aliasdirectivep    ,endaliasesdirectivep    ,accountdirectivep@@ -283,82 +296,174 @@   ) <?> "directive"  -- | Parse an include directive, and the file(s) it refers to, possibly recursively.--- include's argument is a file path or glob pattern, optionally with a file type prefix.--- ~ at the start is expanded to the user's home directory.--- Relative paths are relative to the current file.--- Examples: foo.j, ../foo/bar.j, timedot:/foo/2020*, *.journal-includedirectivep :: MonadIO m => ErroringJournalParser m ()-includedirectivep = do-  -- parse+-- Input options are required since they may affect parsing (of timeclock files, specifically).+-- include's argument is a file path or glob pattern (see findMatchedFiles for details),+-- optionally with a file type prefix. Relative paths are relative to the current file.+includedirectivep :: MonadIO m => InputOpts -> ErroringJournalParser m ()+includedirectivep iopts = do+  -- save the position at start of include directive, for error messages+  eoff <- getOffset+  -- and the parent file's path, for error messages and debug output+  parentf <- getSourcePos >>= sourcePosFilePath++  -- parse the directive   string "include"   lift skipNonNewlineSpaces1   prefixedglob <- rstrip . T.unpack <$> takeWhileP Nothing (`notElem` [';','\n'])   lift followingcommentp-  -- save the position (does sequencing wrt newline matter ? seems not)-  parentoff <- getOffset-  parentpos <- getSourcePos-  -- find file(s)   let (mprefix,glb) = splitReaderPrefix prefixedglob-  paths <- getFilePaths parentoff parentpos glb+  when (null $ dbg6 (parentf <> " include: glob pattern") glb) $+    customFailure $ parseErrorAt eoff $ "include needs a file path or glob pattern argument"++  -- Find the file or glob-matched files (just the ones from this include directive), with some IO error checking.+  -- Also report whether a glob pattern was used, and not just a literal file path.+  -- (paths, isglob) <- findMatchedFiles off pos glb+  paths <- findMatchedFiles eoff parentf glb++  -- XXX worth the trouble ? no+  -- Comprehensively exclude files already processed. Some complexities here:+  -- If this include directive uses a glob pattern, remove duplicates. +  -- Ie if this glob pattern matches any files we have already processed (or the current file),+  -- due to multiple includes in sequence or in a cycle, exclude those files so they're not processed again.+  -- If this include directive uses a literal file path, don't remove duplicates.+  -- Multiple includes in sequence will cause the included file to be processed multiple times.+  -- Multiple includes forming a cycle will be detected and reported as an error in parseIncludedFile.+  -- let paths' = if isglob then filter (...) paths else paths++  -- if there was a reader prefix, apply it to all the file paths   let prefixedpaths = case mprefix of         Nothing  -> paths         Just fmt -> map ((show fmt++":")++) paths-  -- parse them inline-  forM_ prefixedpaths $ parseChild parentpos +  -- Parse each one, as if inlined here.+  forM_ prefixedpaths $ parseIncludedFile iopts eoff+   where-    getFilePaths-      :: MonadIO m => Int -> SourcePos -> FilePath -> JournalParser m [FilePath]-    getFilePaths parseroff parserpos fileglobpattern = do-        -- Expand a ~ at the start of the glob pattern, if any.-        fileglobpattern' <- lift $ expandHomePath fileglobpattern-                         `orRethrowIOError` (show parserpos ++ " locating " ++ fileglobpattern)-        -- Compile the glob pattern.-        fileglob <- case tryCompileWith compDefault{errorRecovery=False} fileglobpattern' of-            Right x -> pure x-            Left e -> customFailure $ parseErrorAt parseroff $ "Invalid glob pattern: " ++ e-        -- Get the directory of the including file. This will be used to resolve relative paths.-        let parentfilepath = sourceName parserpos-        realparentfilepath <- liftIO $ canonicalizePath parentfilepath   -- Follow a symlink. If the path is already absolute, the operation never fails. -        let curdir = takeDirectory realparentfilepath-        -- Find all matched files, in lexicographic order mimicking the output of 'ls'.-        filepaths <- liftIO $ sort <$> globDir1 fileglob curdir-        if (not . null) filepaths-            then pure filepaths-            else customFailure $ parseErrorAt parseroff $-                   "No existing files match pattern: " ++ fileglobpattern -    parseChild :: MonadIO m => SourcePos -> PrefixedFilePath -> ErroringJournalParser m ()-    parseChild parentpos prefixedpath = do+    -- | Find the files matched by a literal path or a glob pattern.+    -- Examples: foo.j, ../foo/bar.j, timedot:/foo/2020*, *.journal, **.journal.+    --+    -- Uses the current parse context for detecting the current directory and for error messages.+    -- Expands a leading tilde to the user's home directory.+    -- Converts ** without a slash to **/*, like zsh's GLOB_STAR_SHORT, so ** also matches file name parts.+    -- Checks if any matched paths are directories and excludes those.+    -- Converts all matched paths to their canonical form.+    --+    -- Glob patterns never match dot files or files under dot directories,+    -- even if it seems like they should; this is a workaround for Glob bug #49.+    -- This workaround is disabled if the --old-glob flag is present in the command line+    -- (detected with unsafePerformIO; it's not worth a ton of boilerplate).+    -- In that case, be aware ** recursive globs will search intermediate dot directories.++    findMatchedFiles :: (MonadIO m) => Int -> FilePath -> FilePath -> JournalParser m [FilePath]+    findMatchedFiles off parentf globpattern = do++      -- Some notes about the Glob library that we use (related: https://github.com/Deewiant/glob/issues/49):+      -- It does not expand tilde.+      -- It does not canonicalise paths.+      -- The results are not in any particular order.+      -- The results can include directories.+      -- DIRPAT/ is equivalent to DIRPAT, except results will end with // (double slash).+      -- A . or .. path component can match the current or parent directories (including them in the results).+      -- * matches zero or more characters in a file or directory name.+      -- * at the start of a file name ignores dot-named files and directories, by default.+      -- ** (or zero or more consecutive *'s) not followed by slash is equivalent to *.+      -- A **/ component matches any number of directory parts.+      -- A **/ ignores dot-named directories in its starting and ending directories, by default.+      -- But **/ does search intermediate dot-named directories. Eg it can find a/.b/c.++      -- expand a tilde at the start of the glob pattern, or throw an error+      expandedglob <- lift $ expandHomePath globpattern `orRethrowIOError` "failed to expand ~"++      -- get the directory of the including file+      let cwd = takeDirectory parentf++      -- Don't allow 3 or more stars.+      when ("***" `isInfixOf` expandedglob) $+        customFailure $ parseErrorAt off $ "Invalid glob pattern: too many stars, use * or **"++      -- Make ** also match file name parts like zsh's GLOB_STAR_SHORT.+      let+        expandedglob' =+          -- ** without a slash is equivalent to **/*+          case regexReplace (toRegex' $ T.pack "\\*\\*([^/\\])") "**/*\\1" expandedglob of+            Right s -> s+            Left  _ -> expandedglob   -- ignore any error, there should be none++      -- Compile as a Pattern. Can throw an error.+      g <- case tryCompileWith compDefault{errorRecovery=False} expandedglob' of+        Left e  -> customFailure $ parseErrorAt off $ "Invalid glob pattern: " ++ e+        Right x -> pure x+      let isglob = not $ isLiteral g++      -- Find all matched paths. These might include directories or the current file.+      paths <- liftIO $ globDir1 g cwd++      -- Exclude any directories or symlinks to directories, and canonicalise, and sort.+      files <- liftIO $+        filterM doesFileExist paths+        >>= mapM canonicalizePath+        <&> sort++      -- Work around a Glob bug with dot dirs: while **/ ignores dot dirs in the starting and ending dirs,+      -- it does search dot dirs in between those two (Glob #49).+      -- This could be inconvenient, eg making it hard to avoid VCS directories in a source tree.+      -- We work around as follows: when any glob was used, paths involving dot dirs are excluded in post processing.+      -- Unfortunately this means valid globs like .dotdir/* can't be used; only literal paths can match+      -- things in dot dirs. An --old-glob command line flag disables this workaround, for backward compatibility.+      oldglobflag <- liftIO $ getFlag ["old-glob"]+      let+        files2 = (if isglob && not oldglobflag then filter (not.hasdotdir) else id) files+          where+            hasdotdir p = any isdotdir $ splitPath p+              where+                isdotdir c = "." `isPrefixOf` c && "/" `isSuffixOf` c++      -- Throw an error if no files were matched.+      when (null files2) $+        customFailure $ parseErrorAt off $ "No files were matched by glob pattern: " ++ globpattern++      -- If a glob was used, exclude the current file, for convenience.+      let+        files3 =+          dbg6 (parentf <> " include: matched files" <> if isglob then " (excluding current file)" else "") $+          (if isglob then filter (/= parentf) else id) files2++      return files3++    -- Parse the given included file (and any deeper includes, recursively) as if it was inlined in the current (parent) file.+    -- The offset of the start of the include directive in the parent file is provided for error messages.+    parseIncludedFile :: MonadIO m => InputOpts -> Int -> PrefixedFilePath -> ErroringJournalParser m ()+    parseIncludedFile iopts1 eoff prefixedpath = do       let (_mprefix,filepath) = splitReaderPrefix prefixedpath +      -- Throw an error if a cycle is detected       parentj <- get       let parentfilestack = jincludefilestack parentj-      when (filepath `elem` parentfilestack) $-        Fail.fail ("Cyclic include: " ++ filepath)+      when (dbg7 "parseIncludedFile: reading" filepath `elem` parentfilestack) $+        customFailure $ parseErrorAt eoff $ "This included file forms a cycle: " ++ filepath -      childInput <--        dbg6Msg ("parseChild: "++takeFileName filepath) $-        lift $ readFilePortably filepath-          `orRethrowIOError` (show parentpos ++ " reading " ++ filepath)+      -- Read the file's content, or throw an error+      childInput <- lift $ readFilePortably filepath `orRethrowIOError` "failed to read a file"       let initChildj = newJournalWithParseStateFrom filepath parentj -      -- Choose a reader/parser based on the file path prefix or file extension,+      -- Choose a reader based on the file path prefix or file extension,       -- defaulting to JournalReader. Duplicating readJournal a bit here.       let r = fromMaybe reader $ findReader Nothing (Just prefixedpath)-          parser = rParser r-      dbg6IO "parseChild: trying reader" (rFormat r)+          parser = (rParser r) iopts1+      dbg7IO "parseIncludedFile: trying reader" (rFormat r) -      -- Parse the file (of whichever format) to a Journal, with file path and source text attached.+      -- Parse the file (and its own includes, if any) to a Journal+      -- with file path and source text attached. Or throw an error.       updatedChildj <- journalAddFile (filepath, childInput) <$>                         parseIncludeFile parser initChildj filepath childInput -      -- Merge this child journal into the parent journal-      -- (with debug logging for troubleshooting account display order).+      -- Child journal was parsed successfully; now merge it into the parent journal.+      -- Debug logging is provided for troubleshooting account display order (eg).       -- The parent journal is the second argument to journalConcat; this means       -- its parse state is kept, and its lists are appended to child's (which       -- ultimately produces the right list order, because parent's and child's-      -- lists are in reverse order at this stage. Cf #1909).+      -- lists are in reverse order at this stage. Cf #1909)       let         parentj' =           dbgJournalAcctDeclOrder ("parseChild: child " <> childfilename <> " acct decls: ") updatedChildj@@ -369,22 +474,29 @@             childfilename = takeFileName filepath             parentfilename = maybe "(unknown)" takeFileName $ headMay $ jincludefilestack parentj  -- XXX more accurate than journalFilePath for some reason -      -- Update the parse state.+      -- And update the current parse state.       put parentj' -    newJournalWithParseStateFrom :: FilePath -> Journal -> Journal-    newJournalWithParseStateFrom filepath j = nulljournal{-      jparsedefaultyear      = jparsedefaultyear j-      ,jparsedefaultcommodity = jparsedefaultcommodity j-      ,jparseparentaccounts   = jparseparentaccounts j-      ,jparsedecimalmark      = jparsedecimalmark j-      ,jparsealiases          = jparsealiases j-      ,jdeclaredcommodities           = jdeclaredcommodities j-      -- ,jparsetransactioncount = jparsetransactioncount j-      ,jparsetimeclockentries = jparsetimeclockentries j-      ,jincludefilestack      = filepath : jincludefilestack j-      }+      where+        newJournalWithParseStateFrom :: FilePath -> Journal -> Journal+        newJournalWithParseStateFrom filepath j = nulljournal{+          jparsedefaultyear      = jparsedefaultyear j+          ,jparsedefaultcommodity = jparsedefaultcommodity j+          ,jparseparentaccounts   = jparseparentaccounts j+          ,jparsedecimalmark      = jparsedecimalmark j+          ,jparsealiases          = jparsealiases j+          ,jdeclaredcommodities           = jdeclaredcommodities j+          -- ,jparsetransactioncount = jparsetransactioncount j+          ,jparsetimeclockentries = jparsetimeclockentries j+          ,jincludefilestack      = filepath : jincludefilestack j+          } +-- Get the canonical path of the file referenced by this parse position.+-- Symbolic links will be dereferenced. This probably will always succeed+-- (since the parse file's path is probably always absolute).+sourcePosFilePath :: (MonadIO m) => SourcePos -> m FilePath+sourcePosFilePath = liftIO . canonicalizePath . sourceName+ -- | Lift an IO action into the exception monad, rethrowing any IO -- error with the given message prepended. orRethrowIOError :: MonadIO m => IO a -> String -> TextParser m a@@ -392,7 +504,7 @@   eResult <- liftIO $ (Right <$> io) `C.catch` \(e::C.IOException) -> pure $ Left $ printf "%s:\n%s" msg (show e)   case eResult of     Right res -> pure res-    Left errMsg -> Fail.fail errMsg+    Left errMsg -> fail errMsg  -- Parse an account directive, adding its info to the journal's -- list of account declarations.@@ -406,7 +518,7 @@    -- the account name, possibly modified by preceding alias or apply account directives   acct <- (notFollowedBy (char '(' <|> char '[') <?> "account name without brackets") >>-          modifiedaccountnamep+          modifiedaccountnamep True    -- maybe a comment, on this and/or following lines   (cmt, tags) <- lift transactioncommentp@@ -511,7 +623,7 @@     pure $ (off, amt)   lift skipNonNewlineSpaces   _ <- lift followingcommentp-  let comm = Commodity{csymbol=acommodity, cformat=Just $ dbg6 "style from commodity directive" astyle}+  let comm = Commodity{csymbol=acommodity, cformat=Just $ dbg7 "style from commodity directive" astyle}   if isNothing $ asdecimalmark astyle   then customFailure $ parseErrorAt off pleaseincludedecimalpoint   else modify' (\j -> j{jdeclaredcommodities=M.insert acommodity comm $ jdeclaredcommodities j})@@ -557,7 +669,7 @@     then       if isNothing $ asdecimalmark astyle       then customFailure $ parseErrorAt off pleaseincludedecimalpoint-      else return $ dbg6 "style from format subdirective" astyle+      else return $ dbg7 "style from format subdirective" astyle     else customFailure $ parseErrorAt off $          printf "commodity directive symbol \"%s\" and format directive symbol \"%s\" should be the same" expectedsym acommodity @@ -848,7 +960,7 @@       lift skipNonNewlineSpaces1       status <- lift statusp       lift skipNonNewlineSpaces-      account <- modifiedaccountnamep+      account <- modifiedaccountnamep True       return (status, account)     let (ptype, account') = (accountNamePostingType account, textUnbracket account)     lift skipNonNewlineSpaces@@ -1109,8 +1221,8 @@    ,testGroup "directivep" [     testCase "supports !" $ do-        assertParseE directivep "!account a\n"-        assertParseE directivep "!D 1.0\n"+        assertParseE (directivep definputopts) "!account a\n"+        assertParseE (directivep definputopts) "!D 1.0\n"      ]    ,testGroup "accountdirectivep" [@@ -1144,8 +1256,8 @@      assertParse ignoredpricecommoditydirectivep "N $\n"    ,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*"+      testCase "include" $ assertParseErrorE (includedirectivep definputopts) "include nosuchfile\n" "No files were matched by glob pattern: nosuchfile"+     ,testCase "glob" $ assertParseErrorE (includedirectivep definputopts) "include nosuchfile*\n" "No files were matched by glob pattern: nosuchfile*"      ]    ,testCase "marketpricedirectivep" $ assertParseEq marketpricedirectivep@@ -1172,12 +1284,12 @@       assertParse endtagdirectivep "end apply tag \n"    ,testGroup "journalp" [-    testCase "empty file" $ assertParseEqE journalp "" nulljournal+    testCase "empty file" $ assertParseEqE (journalp definputopts) "" nulljournal     ]     -- these are defined here rather than in Common so they can use journalp   ,testCase "parseAndFinaliseJournal" $ do-      ej <- runExceptT $ parseAndFinaliseJournal journalp definputopts "" "2019-1-1\n"+      ej <- runExceptT $ parseAndFinaliseJournal (journalp definputopts) definputopts "" "2019-1-1\n"       let Right j = ej       assertEqual "" [""] $ journalFilePaths j 

@@ -22,6 +22,7 @@ {-# LANGUAGE ViewPatterns         #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TupleSections #-}  --- ** exports module Hledger.Read.RulesReader (@@ -44,7 +45,9 @@ --- ** imports import Prelude hiding (Applicative(..)) import Control.Applicative (Applicative(..))-import Control.Monad              (unless, when, void)+import Control.Concurrent (forkIO)+import Control.DeepSeq (deepseq)+import Control.Monad (unless, void, when) import Control.Monad.Except       (ExceptT(..), liftEither, throwError) import qualified Control.Monad.Fail as Fail import Control.Monad.IO.Class     (MonadIO, liftIO)@@ -52,9 +55,16 @@ import Control.Monad.Trans.Class  (lift) import Data.Char                  (toLower, isDigit, isSpace, isAlphaNum, ord) import Data.Bifunctor             (first)-import Data.Encoding              (encodingFromStringExplicit)-import Data.Functor               ((<&>))+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import qualified Data.Csv as Cassava+import qualified Data.Csv.Parser.Megaparsec as CassavaMegaparsec+import Data.Encoding (encodingFromStringExplicit)+import Data.Either (fromRight)+import Data.Functor ((<&>)) import Data.List (elemIndex, mapAccumL, nub, sortOn)+-- import Data.List (elemIndex, mapAccumL, nub, sortOn, isPrefixOf, sortBy)+-- import Data.Ord (Down(..), comparing) #if !MIN_VERSION_base(4,20,0) import Data.List (foldl') #endif@@ -67,14 +77,14 @@ import qualified Data.Text.Encoding as T import qualified Data.Text.IO as T import Data.Time ( Day, TimeZone, UTCTime, LocalTime, ZonedTime(ZonedTime),-  defaultTimeLocale, getCurrentTimeZone, localDay, parseTimeM, utcToLocalTime, localTimeToUTC, zonedTimeToUTC)+  defaultTimeLocale, getCurrentTimeZone, localDay, parseTimeM, utcToLocalTime, localTimeToUTC, zonedTimeToUTC, utctDay) import Safe (atMay, headMay, lastMay, readMay)-import System.FilePath ((</>), takeDirectory, takeExtension, stripExtension, takeFileName)-import System.IO       (Handle, hClose)-import qualified Data.Csv as Cassava-import qualified Data.Csv.Parser.Megaparsec as CassavaMegaparsec-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as BL+import System.Directory (createDirectoryIfMissing, doesFileExist, getHomeDirectory, getModificationTime, removeFile)+-- import System.Directory (createDirectoryIfMissing, doesFileExist, getHomeDirectory, getModificationTime, listDirectory, renameFile, doesDirectoryExist)+import System.Exit      (ExitCode(..))+import System.FilePath (stripExtension, takeBaseName, takeDirectory, takeExtension, takeFileName, (<.>), (</>))+import System.IO       (Handle, hClose, hPutStrLn, stderr, hGetContents')+import System.Process  (CreateProcess(..), StdStream(CreatePipe), shell, waitForProcess, withCreateProcess) import Data.Foldable (asum, toList) import Text.Megaparsec hiding (match, parse) import Text.Megaparsec.Char (char, newline, string, digitChar)@@ -84,9 +94,6 @@ import Hledger.Utils import Hledger.Read.Common (aliasesFromOpts, Reader(..), InputOpts(..), amountp, statusp, journalFinalise, accountnamep, transactioncommentp, postingcommentp ) import Hledger.Write.Csv-import System.Directory (doesFileExist, getHomeDirectory)-import Data.Either (fromRight)-import Control.DeepSeq (deepseq)  --- ** doctest setup -- $setup@@ -101,7 +108,7 @@   {rFormat     = Rules   ,rExtensions = ["rules"]   ,rReadFn     = parse-  ,rParser     = error' "sorry, rules files can't be included"  -- PARTIAL:+  ,rParser     = const $ fail "sorry, rules files can't be included yet"   }  isFileName f = takeFileName f == f@@ -110,50 +117,264 @@   home <- getHomeDirectory   return $ home </> "Downloads"  -- XXX --- | Parse and post-process a "Journal" from the given rules file path, or give an error.--- A data file is inferred from the @source@ rule, otherwise from a similarly-named file--- in the same directory.--- The source rule can specify a glob pattern and supports ~ for home directory.--- If it is a bare filename it will be relative to the defaut download directory--- on this system. If is a relative file path it will be relative to the rules--- file's directory. When a glob pattern matches multiple files, the alphabetically--- last is used. (Eg in case of multiple numbered downloads, the highest-numbered--- will be used.)--- The provided handle, or a --rules option, are ignored by this reader.--- Balance assertions are not checked.+-- | Read, parse and post-process a "Journal" from the given rules file, or give an error.+-- This particular reader also provides some extra features like data cleaning/generating commands and data archiving.+--+-- The provided input file handle, and the --rules option, are ignored by this reader.+-- Instead, a data file (or data-generating command) is usually specified by the @source@ rule.+-- If there's no source rule, the data file is assumed to be named like the rules file without .rules, in the same directory.+--+-- The source rule supports ~ for home directory: @source ~/Downloads/foo.csv@.+-- If the argument is a bare filename, its directory is assumed to be ~/Downloads: @source foo.csv@.+-- Otherwise if it is a relative path, it is assumed to be relative to the rules file's directory: @source new/foo.csv@.+--+-- The source rule can specify a glob pattern: @source foo*.csv@.+-- If the glob pattern matches multiple files, the newest (last modified) file is used (with one exception, described below).+--+-- The source rule can specify a data-cleaning command, after a @|@ separator: @source foo*.csv | sed -e 's/USD/$/g'@.+-- This command is executed by the user's default shell, receives the data file's content on stdin,+-- and should output CSV data suitable for the conversion rules.+-- A # character can be used to comment out the data-cleaning command: @source foo*.csv  # | ...@.+--+-- Or the source rule can specify just a data-generating command, with no file pattern: @source | foo-csv.sh@.+-- In this case the command receives no input; it should output CSV data suitable for the conversion rules.+--+-- If the archive rule is present:+-- After successfully reading the data file or data command and converting to a journal, while doing a non-dry-run import:+-- the data will be archived in an auto-created data/ directory next to the rules file,+-- with a name based on the rules file and the data file's modification date and extension+-- (or for a data-generating command, the current date and the ".csv" extension).+-- And import will prefer the oldest file matched by a glob pattern (not the newest).+--+-- Balance assertions are not checked by this reader.+-- parse :: InputOpts -> FilePath -> Handle -> ExceptT String IO Journal-parse iopts f h = do-  lift $ hClose h -- We don't need it-  rules <- readRulesFile $ dbg4 "reading rules file" f-  -- XXX higher-than usual debug level for file reading to bypass excessive noise from elsewhere, normally 6 or 7-  mdatafile <- liftIO $ do-    dldir <- getDownloadDir-    let rulesdir = takeDirectory f-    let msource = T.unpack <$> getDirective "source" rules-    fs <- case msource of-            Just src -> expandGlob dir (dbg4 "source" src) >>= sortByModTime <&> dbg4 ("matched files"<>desc<>", newest first")-              where (dir,desc) = if isFileName src then (dldir," in download directory") else (rulesdir,"")-            Nothing  -> return [maybe err (dbg4 "inferred source") $ dataFileFor f]  -- shouldn't fail, f has .rules extension-              where err = error' $ "could not infer a data file for " <> f-    return $ dbg4 "data file" $ headMay fs+parse iopts rulesfile h = do+  lift $ hClose h -- We don't need it (XXX why ?)++  -- The rules reader does a lot; we must be organised.++  -- 1. gather contextual info+  --  gives: import flag, dryrun flag, rulesdir++  let+    args     = progArgs+    import_  = dbg2 "import" $ any (`elem` args) ["import", "imp"]+    dryrun   = dbg2 "dryrun" $ any (`elem` args) ["--dry-run", "--dry"]+    rulesdir = takeDirectory rulesfile++  -- 2. parse the source and archive rules+  --  needs: rules file+  --  gives: file pattern, data cleaning/generating command, archive flag++  -- XXX higher-than usual logging priority for file reading (normally 6 or 7), to bypass excessive noise from elsewhere+  rules <- readRulesFile $ dbg1 "reading rules file" rulesfile+  let+    msourcearg = getDirective "source" rules+      -- Nothing -> error' $ rulesfile ++ " source rule must specify a file pattern or a command"+    -- Surrounding whitespace is removed from the whole source argument and from each part of it.+    -- A # before | makes the rest of line a comment.+    -- A # after | is left for the shell to interpret; it could be part of the command or the start of a comment.+    stripspaces = T.strip+    stripcommentandspaces = stripspaces . T.takeWhile (/= '#')+    mpatandcmd = T.breakOn "|" . stripspaces <$> msourcearg+    mpat = dbg2 "file pattern" $  -- a non-empty file pattern, or nothing+      case T.unpack . stripcommentandspaces . fst <$> mpatandcmd of+        Just s | not $ null s -> Just s+        _ -> Nothing+    mcmd = dbg2 "data command" $  -- a non-empty command, or nothing+      mpatandcmd >>= \sc ->+        let c = T.unpack . stripspaces . T.drop 1 . snd $ sc+        in if null c then Nothing else Just c++    archive = isJust (getDirective "archive" rules)++  -- 3. find the file to be read, if any+  --  needs: file pattern, data command, import flag, archive flag, downloads dir+  --  gives: data file, data file description++  (mdatafile, datafiledesc) <- dbg2 "data file found ?" <$> case (mpat, mcmd) of+    (Nothing, Nothing) -> error' $ "to make " ++ rulesfile ++ " readable,\n please add a 'source' rule with a non-empty file pattern or command"+    (Nothing, Just _) -> return (Nothing, "")+    (Just pat, _) -> do+      dldir <- liftIO getDownloadDir  -- look here for the data file if it's specified without a directory+      let+        (startdir, dirdesc)+          | isFileName pat = (dldir,    " in download directory")+          | otherwise      = (rulesdir, "")+      fs <- liftIO $+        expandGlob startdir pat+        >>= sortByModTime+        <&> dbg2 ("matched files"<>dirdesc<>", oldest first")+      return $+        if import_ && archive+        then (headMay fs, " oldest file")+        else (lastMay fs, " newest file")+    +  -- 4. log which file we are reading/importing/cleaning/generating+  --  needs: data file, data file description, import flag++  case (mdatafile, datafiledesc) of+    (Just f, desc) -> dbg1IO ("trying to " ++ (if import_ then "import" else "read") ++ desc) f+    (Nothing, _)   -> return ()++  -- 5. read raw, cleaned or generated data+  --  needs: file pattern, data file, data command+  --  gives: clean data (possibly empty)++  mexistingdatafile <- maybe (return Nothing) (\f -> liftIO $ do+    exists <- doesFileExist f+    return $ if exists then Just f else Nothing+    ) $ mdatafile+  cleandata <- dbg1With (\t -> "read "++(show $ length $ T.lines t)++" lines") <$> case (mpat, mexistingdatafile, mcmd) of++    -- file pattern, but no file found+    (Just _, Nothing, _) -> -- trace "file pattern, but no file found" $+      return ""++    -- file found, and maybe a data cleaning command+    (_, Just f,  mc) ->  -- trace "file found" $ +      liftIO $ do+        raw <- openFileOrStdin f >>= readHandlePortably+        maybe (return raw) (\c -> runCommandAsFilter rulesfile (dbg0Msg ("running: "++c) c) raw) mc++    -- no file pattern, but a data generating command+    (Nothing, _, Just cmd) -> -- trace "data generating command" $+      liftIO $ runCommand rulesfile $ dbg0Msg ("running: " ++ cmd) cmd++    -- neither a file pattern nor a data generating command+    (Nothing, _, Nothing) -> -- trace "no file pattern or data generating command" $+      error' $ rulesfile ++ " source rule must specify a file pattern or a command"++  -- 6. convert the clean data to a (possibly empty) journal+  --  needs: clean data, rules, rules file, data file if any+  --  gives: journal++  j <- do+    cleandatah <- liftIO $ inputToHandle cleandata+    readJournalFromCsv (Just $ Left rules) (fromMaybe "(cmd)" mdatafile) cleandatah Nothing+    -- apply any command line account aliases. Can fail with a bad replacement pattern.+    >>= liftEither . journalApplyAliases (aliasesFromOpts iopts)+        -- journalFinalise assumes the journal's items are+        -- reversed, as produced by JournalReader's parser.+        -- But here they are already properly ordered. So we'd+        -- better preemptively reverse them once more. XXX inefficient+        . journalReverse+    >>= journalFinalise iopts{balancingopts_=(balancingopts_ iopts){ignore_assertions_=True}} rulesfile ""++  -- 7. if non-empty, successfully read and converted, and we're doing a non-dry-run archiving import: archive the data+  --  needs: import/archive/dryrun flags, rules directory, rules file, data file if any, clean data++  when (not (T.null cleandata) && import_ && archive && not dryrun) $+    liftIO $ saveToArchive (rulesdir </> "data") rulesfile mdatafile cleandata++  return j++-- | For the given rules file, run the given shell command, in the rules file's directory.+-- If the command fails, raise an error and show its error output;+-- otherwise return its output, and show any error output as a warning.+runCommand :: FilePath -> String -> IO Text+runCommand rulesfile cmd = do+  let process = (shell cmd) { cwd = Just $ takeDirectory rulesfile, std_out = CreatePipe, std_err = CreatePipe }+  withCreateProcess process $ \_ mhout mherr phandle -> do+    case (mhout, mherr) of+      (Just hout, Just herr) -> do+        out <- T.hGetContents hout+        err <- hGetContents' herr+        exitCode <- waitForProcess phandle+        case exitCode of+          ExitSuccess -> do+            unless (null err) $ warnIO err+            return out+          ExitFailure code ->+            error' $ "in " ++ rulesfile ++ ": command \"" ++ cmd ++ "\" failed with exit code " ++ show code+              ++ (if null err then "" else ":\n" ++ err)+      _ -> error' $ "in " ++ rulesfile ++ ": failed to create pipes for command execution"++-- | For the given rules file, run the given shell command, in the rules file's directory, passing the given text as input.+-- Return the output, or if the command fails, raise an informative error.+runCommandAsFilter :: FilePath -> String -> Text -> IO Text+runCommandAsFilter rulesfile cmd input = do+  let process = (shell cmd) { cwd = Just $ takeDirectory rulesfile, std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe }+  withCreateProcess process $ \mhin mhout mherr phandle -> do+    case (mhin, mhout, mherr) of+      (Just hin, Just hout, Just herr) -> do+        forkIO $ T.hPutStr hin input >> hClose hin+        out <- T.hGetContents hout+        err <- hGetContents' herr+        exitCode <- waitForProcess phandle+        case exitCode of+          ExitSuccess -> return out+          ExitFailure code ->+            error' $ "in " ++ rulesfile ++ ": command \"" ++ cmd ++ "\" failed with exit code " ++ show code+              ++ (if null err then "" else ":\n" ++ err)+      _ -> error' $ "in " ++ rulesfile ++ ": failed to create pipes for command execution"++type DirPath = FilePath++-- | Save some successfully imported data+-- (more precisely: data that was successfully read and maybe cleaned, or that was generated, during an import)+-- to the given archive directory, autocreating that if needed, and show informational output on stderr.+-- The arguments are:+-- the archive directory,+-- the rules file (for naming),+-- the data file name, if any,+-- the data that was read, cleaned, or generated.+-- The archive file name will be RULESFILEBASENAME.DATAFILEMODDATEORCURRENTDATE.DATAFILEEXTORCSV.+-- Note for a data generating command, where there's no data file, we use the current date+-- and a .csv file extension (meaning "character-separated values" in this case).+saveToArchive :: DirPath -> FilePath -> Maybe FilePath -> Text -> IO ()+saveToArchive archivedir rulesfile mdatafile cleandata = do+  createDirectoryIfMissing True archivedir+  (_, cleanname) <- archiveFileName rulesfile mdatafile+  let cleanarchive = archivedir </> cleanname+  hPutStrLn stderr $ "archiving " <> cleanarchive+  T.writeFile cleanarchive cleandata+  maybe (return ()) removeFile mdatafile++-- | Figure out the file names to use when archiving, for the given rules file and the given data file if any.+-- The second name is for the final (possibly cleaned) data; the first name has ".orig" added,+-- and is used if both original and cleaned data are being archived. They will be like this:+-- ("RULESFILEBASENAME.orig.DATAFILEMODDATE.DATAFILEEXT", "RULESFILEBASENAME.DATAFILEMODDATE.DATAFILEEXT")+archiveFileName :: FilePath -> Maybe FilePath -> IO (String, String)+archiveFileName rulesfile mdatafile = do+  let base = takeBaseName rulesfile   case mdatafile of-    Nothing -> return nulljournal  -- data file specified by source rule was not found-    Just dat -> do-      exists <- liftIO $ doesFileExist dat-      if not (dat=="-" || exists)-      then return nulljournal      -- data file inferred from rules file name was not found-      else do-        dath <- liftIO $ openFileOrStdin dat-        readJournalFromCsv (Just $ Left rules) dat dath Nothing-        -- apply any command line account aliases. Can fail with a bad replacement pattern.-        >>= liftEither . journalApplyAliases (aliasesFromOpts iopts)-            -- journalFinalise assumes the journal's items are-            -- reversed, as produced by JournalReader's parser.-            -- But here they are already properly ordered. So we'd-            -- better preemptively reverse them once more. XXX inefficient-            . journalReverse-        >>= journalFinalise iopts{balancingopts_=(balancingopts_ iopts){ignore_assertions_=True}} f ""+    Just datafile -> do+      moddate <- (show . utctDay) <$> getModificationTime datafile+      let ext = takeExtension datafile+      return (+         base <.> "orig" <.> moddate <.> ext+        ,base            <.> moddate <.> ext+        )+    Nothing -> do+      let ext = "csv"+      curdate <- show <$> getCurrentDay+      return (+         base <.> "orig" <.> curdate <.> ext+        ,base            <.> curdate <.> ext+        ) +-- -- | In the given archive directory, if it exists, find the paths of data files saved for the given rules file.+-- -- They will be reverse sorted by name, ie newest first, assuming normal archive file names.+-- --+-- -- We don't know which extension the data files use, but we look for file names beginning with+-- -- the rules file's base name followed by .YYYY-MM-DD, which will normally be good enough.+-- --+-- archivesFor :: FilePath -> FilePath -> IO [FilePath]+-- archivesFor archivedir rulesfile = do+--   exists <- doesDirectoryExist archivedir+--   if not exists then return []+--   else do+--     let prefix = takeBaseName rulesfile <> "."+--     fs <- listDirectory archivedir+--     return $ map (archivedir </>) $ sortBy (comparing Down)+--       [f | f <- fs,+--         prefix `isPrefixOf` f,+--         let nextpart = takeWhile (/= '.') $ drop (length prefix) f,+--         isJust $ parsedate nextpart+--         ]+ --- ** reading rules files --- *** rules utilities _RULES_READING__________________________________________ = undefined@@ -392,10 +613,12 @@  RULES: RULE* -RULE: ( SOURCE | FIELD-LIST | FIELD-ASSIGNMENT | CONDITIONAL-BLOCK | SKIP | TIMEZONE | NEWEST-FIRST | INTRA-DAY-REVERSED | DATE-FORMAT | DECIMAL-MARK | COMMENT | BLANK ) NEWLINE+RULE: ( SOURCE | ARCHIVE | FIELD-LIST | FIELD-ASSIGNMENT | CONDITIONAL-BLOCK | SKIP | TIMEZONE | NEWEST-FIRST | INTRA-DAY-REVERSED | DATE-FORMAT | DECIMAL-MARK | COMMENT | BLANK ) NEWLINE  SOURCE: source SPACE FILEPATH +ARCHIVE: archive+ FIELD-LIST: fields SPACE FIELD-NAME ( SPACE? , SPACE? FIELD-NAME )*  FIELD-NAME: QUOTED-FIELD-NAME | BARE-FIELD-NAME@@ -518,6 +741,7 @@ directives :: [Text] directives =   ["source"+  ,"archive"   ,"encoding"   ,"date-format"   ,"decimal-mark"

@@ -1,17 +1,14 @@ --- * -*- outline-regexp:"--- \\*"; -*- --- ** doc -- In Emacs, use TAB on lines beginning with "-- *" to collapse/expand sections.-{-| -A reader for the timeclock file format generated by timeclock.el-(<http://www.emacswiki.org/emacs/TimeClock>). Example:+-- Keep relevant parts synced with manual:+{-| -@-i 2007\/03\/10 12:26:00 hledger-o 2007\/03\/10 17:26:02-@+A reader for the timeclock file format. -From timeclock.el 2.6:+What exactly is this format ? It was introduced in timeclock.el (<http://www.emacswiki.org/emacs/TimeClock>).+The old specification in timeclock.el 2.6 was:  @ A timeclock contains data in the form of a single entry per line.@@ -41,6 +38,92 @@      now finished.  Useful for creating summary reports. @ +Ledger's timeclock format is different, and hledger's timeclock format is different again.+For example: in a clock-in entry, after the time,++- timeclock.el's timeclock has 0-1 fields: [COMMENT]+- Ledger's timeclock has 0-2 fields:       [ACCOUNT[  PAYEE]]+- hledger's timeclock has 1-3 fields:      ACCOUNT[  DESCRIPTION[;COMMENT]]++hledger's timeclock format is:++@+# Comment lines like these, and blank lines, are ignored:+# comment line+; comment line+* comment line++# Lines beginning with b, h, or capital O are also ignored, for compatibility:+b SIMPLEDATE HH:MM[:SS][+-ZZZZ][ TEXT]+h SIMPLEDATE HH:MM[:SS][+-ZZZZ][ TEXT]+O SIMPLEDATE HH:MM[:SS][+-ZZZZ][ TEXT]++# Lines beginning with i or o are are clock-in / clock-out entries:+i SIMPLEDATE HH:MM[:SS][+-ZZZZ] ACCOUNT[  DESCRIPTION][;COMMENT]]+o SIMPLEDATE HH:MM[:SS][+-ZZZZ][ ACCOUNT][;COMMENT]+@++The date is a hledger [simple date](#simple-dates) (YYYY-MM-DD or similar).+The time parts must use two digits.+The seconds are optional.+A + or - four-digit time zone is accepted for compatibility, but currently ignored; times are always interpreted as a local time.++In clock-in entries (`i`), the account name is required.+A transaction description, separated from the account name by 2+ spaces, is optional.+A transaction comment, beginning with `;`, is also optional.++In clock-out entries (`o`) have no description, but can have a comment if you wish.+A clock-in and clock-out pair form a "transaction" posting some number of hours to an account - also known as a session.+Eg:++```timeclock+i 2015/03/30 09:00:00 session1+o 2015/03/30 10:00:00+```++```cli+$ hledger -f a.timeclock print+2015-03-30 * 09:00-10:00+    (session1)           1.00h+```++Clock-ins and clock-outs are matched by their account/session name.+If a clock-outs does not specify a name, the most recent unclosed clock-in is closed.+Also, sessions spanning more than one day are automatically split at day boundaries.+Eg, the following time log:++```timeclock+i 2015/03/30 09:00:00 some account  optional description after 2 spaces ; optional comment, tags:+o 2015/03/30 09:20:00+i 2015/03/31 22:21:45 another:account+o 2015/04/01 02:00:34+i 2015/04/02 12:00:00 another:account  ; this demonstrates multple sessions being clocked in+i 2015/04/02 13:00:00 some account+o 2015/04/02 14:00:00+o 2015/04/02 15:00:00 another:account+```++generates these transactions:++```cli+$ hledger -f t.timeclock print+2015-03-30 * optional description after 2 spaces   ; optional comment, tags:+    (some account)           0.33h++2015-03-31 * 22:21-23:59+    (another:account)           1.64h++2015-04-01 * 00:00-02:00+    (another:account)           2.01h++2015-04-02 * 12:00-15:00  ; this demonstrates multiple sessions being clocked in+    (another:account)           3.00h++2015-04-02 * 13:00-14:00+    (some account)           1.00h++```+ -}  --- ** language@@ -68,6 +151,7 @@ import           Hledger.Read.Common import           Hledger.Utils import Data.Text as T (strip)+import Data.Functor ((<&>))  --- ** doctest setup -- $setup@@ -80,7 +164,7 @@   {rFormat     = Timeclock   ,rExtensions = ["timeclock"]   ,rReadFn     = handleReadFnToTextReadFn parse-  ,rParser     = timeclockfilep definputopts+  ,rParser     = timeclockfilep   }  -- | Parse and post-process a "Journal" from timeclock.el's timeclock@@ -98,40 +182,69 @@ -- timeclockfilep args  timeclockfilep :: MonadIO m => InputOpts -> JournalParser m ParsedJournal-timeclockfilep iopts = do many timeclockitemp-                          eof-                          j@Journal{jparsetimeclockentries=es} <- get-                          -- Convert timeclock entries in this journal to transactions, closing any unfinished sessions.-                          -- Doing this here rather than in journalFinalise means timeclock sessions can't span file boundaries,-                          -- but it simplifies code above.-                          now <- liftIO getCurrentLocalTime-                          -- journalFinalise expects the transactions in reverse order, so reverse the output in either case-                          let j' = if (_oldtimeclock iopts) then -                                -- timeclockEntriesToTransactionsSingle expects the entries to be in normal order, -                                -- but they have been parsed in reverse order, so reverse them before calling-                                j{jtxns = reverse $ timeclockEntriesToTransactionsSingle now $ reverse es, jparsetimeclockentries = []}-                              else -                                -- We don't need to reverse these transactions -                                -- since they are sorted inside of timeclockEntiresToTransactions-                                j{jtxns = reverse $ timeclockEntriesToTransactions now es, jparsetimeclockentries = []}-                          return j'-    where-      -- As all ledger line types can be distinguished by the first-      -- character, excepting transactions versus empty (blank or-      -- comment-only) lines, can use choice w/o try-      timeclockitemp = choice [-                            void (lift emptyorcommentlinep)-                          , timeclockentryp >>= \e -> modify' (\j -> j{jparsetimeclockentries = e : jparsetimeclockentries j})-                          ] <?> "timeclock entry, comment line, or empty line"+timeclockfilep iopts = do+  many timeclockitemp+  eof+  j@Journal{jparsetimeclockentries=es} <- get+  -- Convert timeclock entries in this journal to transactions, closing any unfinished sessions.+  -- Doing this here rather than in journalFinalise means timeclock sessions can't span file boundaries,+  -- but it simplifies code above.+  now <- liftIO getCurrentLocalTime+  -- journalFinalise expects the transactions in reverse order, so reverse the output in either case+  let+    j' = if _oldtimeclock iopts+      then+        -- timeclockToTransactionsOld expects the entries to be in normal order, +        -- but they have been parsed in reverse order, so reverse them before calling+        j{jtxns = reverse $ timeclockToTransactionsOld now $ reverse es, jparsetimeclockentries = []}+      else+        -- We don't need to reverse these transactions +        -- since they are sorted inside of timeclockToTransactions+        j{jtxns = reverse $ timeclockToTransactions now es, jparsetimeclockentries = []}+  return j'+  where+    -- As all ledger line types can be distinguished by the first+    -- character, excepting transactions versus empty (blank or+    -- comment-only) lines, can use choice w/o try+    timeclockitemp = choice [+       void (lift emptyorcommentlinep)+      ,entryp >>= \e -> modify' (\j -> j{jparsetimeclockentries = e : jparsetimeclockentries j})+      ] <?> "timeclock entry, comment line, or empty line"+      where entryp = if _oldtimeclock iopts then oldtimeclockentryp else timeclockentryp --- | Parse a timeclock entry.-timeclockentryp :: JournalParser m TimeclockEntry-timeclockentryp = do+-- | Parse a timeclock entry (loose pre-1.50 format).+oldtimeclockentryp :: JournalParser m TimeclockEntry+oldtimeclockentryp = do   pos <- getSourcePos   code <- oneOf ("bhioO" :: [Char])   lift skipNonNewlineSpaces1   datetime <- datetimep-  account     <- fmap (fromMaybe "") $ optional $ lift skipNonNewlineSpaces1 >> modifiedaccountnamep+  account     <- fmap (fromMaybe "") $ optional $ lift skipNonNewlineSpaces1 >> modifiedaccountnamep True   description <- fmap (maybe "" T.strip) $ optional $ lift $ skipNonNewlineSpaces1 >> descriptionp   (comment, tags) <- lift transactioncommentp+  return $ TimeclockEntry pos (read [code]) datetime account description comment tags++-- | Parse a timeclock entry (more robust post-1.50 format).+timeclockentryp :: JournalParser m TimeclockEntry+timeclockentryp = do+  pos <- getSourcePos+  code <- oneOf ("iobhO" :: [Char])+  lift skipNonNewlineSpaces1+  datetime <- datetimep+  (account, description) <- case code of+    'i' -> do+      lift skipNonNewlineSpaces1+      a <- modifiedaccountnamep False+      d <- optional (lift $ skipNonNewlineSpaces1 >> descriptionp) <&> maybe "" T.strip+      return (a, d)+    'o' -> do+      -- Notice the try needed here to avoid a parse error if there's trailing spaces.+      -- Unlike descriptionp above, modifiedaccountnamep requires nonempty text.+      -- And when a parser in an optional fails after consuming input, optional doesn't backtrack,+      -- it propagates the failure.+      a <- optional (try $ lift skipNonNewlineSpaces1 >> modifiedaccountnamep False) <&> fromMaybe ""+      return (a, "")+    _ -> return ("", "")+  lift skipNonNewlineSpaces+  (comment, tags) <- lift $ optional transactioncommentp <&> fromMaybe ("",[])   return $ TimeclockEntry pos (read [code]) datetime account description comment tags

@@ -74,7 +74,7 @@  -- | Parse and post-process a "Journal" from the timedot format, or give an error. parse :: InputOpts -> FilePath -> Text -> ExceptT String IO Journal-parse iopts fp t = initialiseAndParseJournal timedotp iopts fp t+parse iopts fp t = initialiseAndParseJournal (timedotp iopts) iopts fp t                    >>= liftEither . journalApplyAliases (aliasesFromOpts iopts)                    >>= journalFinalise iopts fp t @@ -106,8 +106,8 @@  timedotfilep = timedotp -- XXX rename export above -timedotp :: JournalParser m ParsedJournal-timedotp = preamblep >> many dayp >> eof >> get+timedotp :: InputOpts -> JournalParser m ParsedJournal+timedotp _ = preamblep >> many dayp >> eof >> get  preamblep :: JournalParser m () preamblep = do@@ -176,7 +176,7 @@   dp "timedotentryp"   notFollowedBy datelinep   lift $ optional $ choice [orgheadingprefixp, skipNonNewlineSpaces1]-  a <- modifiedaccountnamep+  a <- modifiedaccountnamep False   lift skipNonNewlineSpaces   taggedhours <- lift durationsp   (comment0, tags0) <-

@@ -27,7 +27,6 @@ import Data.List.Extra (nubSort) import Data.Maybe (catMaybes) import Data.Ord (Down(..), comparing)-import Data.Text (Text) import qualified Data.Text as T import Data.Time.Calendar (Day) @@ -80,7 +79,7 @@    Transaction -- the transaction, unmodified   ,Transaction -- the transaction, as seen from the current account   ,Bool        -- is this a split (more than one posting to other accounts) ?-  ,Text        -- a display string describing the other account(s), if any+  ,[AccountName] -- the other account(s), if any   ,MixedAmount -- the amount posted to the current account(s) (or total amount posted)   ,MixedAmount -- the register's running total or the current account(s)'s historical balance, after this transaction   )@@ -188,14 +187,14 @@     -- 201407: I've lost my grip on this, let's just hope for the best     -- 201606: we now calculate change and balance from filtered postings, check this still works well for all callers XXX     | null reportps = (bal, Nothing)  -- no matched postings in this transaction, skip it-    | otherwise     = (bal', Just (t, tacct{tdate=d}, numotheraccts > 1, otheracctstr, amt, bal'))+    | otherwise     = (bal', Just (t, tacct{tdate=d}, numotheraccts > 1, otheraccts, amt, bal'))     where       tacct@Transaction{tpostings=reportps} = filterTransactionPostingsExtra accttypefn reportq t  -- TODO needs to consider --date2, #1731       (thisacctps, otheracctps) = partition (matchesPosting thisacctq) reportps       numotheraccts = length $ nub $ map paccount otheracctps-      otheracctstr | thisacctq == None  = summarisePostingAccounts reportps     -- no current account ? summarise all matched postings-                   | numotheraccts == 0 = summarisePostingAccounts thisacctps   -- only postings to current account ? summarise those-                   | otherwise          = summarisePostingAccounts otheracctps  -- summarise matched postings to other account(s)+      otheraccts | thisacctq == None  = summarisePostingAccounts reportps     -- no current account ? summarise all matched postings+                 | numotheraccts == 0 = summarisePostingAccounts thisacctps   -- only postings to current account ? summarise those+                 | otherwise          = summarisePostingAccounts otheracctps  -- summarise matched postings to other account(s)       -- 202302: Impact of t on thisacct - normally the sum of thisacctps,       -- but if they are null it probably means reportq is an account filter       -- and we should sum otheracctps instead.@@ -236,9 +235,8 @@  -- | Generate a simplified summary of some postings' accounts. -- To reduce noise, if there are both real and virtual postings, show only the real ones.-summarisePostingAccounts :: [Posting] -> Text-summarisePostingAccounts ps =-    T.intercalate ", " . map accountSummarisedName . nub $ map paccount displayps+summarisePostingAccounts :: [Posting] -> [AccountName]+summarisePostingAccounts ps = map paccount displayps   where     realps = filter isReal ps     displayps | null realps = ps

@@ -9,23 +9,22 @@   BudgetReportRow,   BudgetReport,   budgetReport,-  -- * Helpers-  combineBudgetAndActual,   -- * Tests   tests_BudgetReport ) where  import Control.Applicative ((<|>))-import Data.HashMap.Strict (HashMap)-import qualified Data.HashMap.Strict as HM-import Data.List (find, partition, maximumBy, intercalate)+import Control.Monad ((>=>))+import Data.Bifunctor (bimap)+import Data.Foldable (toList)+import Data.List (find, maximumBy, intercalate) import Data.List.Extra (nubSort)-import Data.Maybe (fromMaybe, isJust)-import Data.Map (Map)-import qualified Data.Map as Map+import Data.Maybe (catMaybes, fromMaybe, isJust)+import Data.Ord (comparing) import qualified Data.Set as S import qualified Data.Text as T+import Data.These (These(..), these) import Safe (minimumDef)  import Hledger.Data@@ -33,8 +32,6 @@ import Hledger.Reports.ReportOptions import Hledger.Reports.ReportTypes import Hledger.Reports.MultiBalanceReport-import Data.Ord (comparing)-import Control.Monad ((>=>))  -- All MixedAmounts: type BudgetGoal    = Change@@ -69,7 +66,9 @@     -- 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 = (_rsReportOpts rspec){ accountlistmode_ = ALTree }+    -- ropts = _rsReportOpts rspec     showunbudgeted = empty_ ropts+     budgetedaccts =       dbg3 "budgetedacctsinperiod" $       S.fromList $@@ -78,22 +77,60 @@       concatMap tpostings $       concatMap (\pt -> runPeriodicTransaction False pt reportspan) $       jperiodictxns j+     actualj = journalWithBudgetAccountNames budgetedaccts showunbudgeted j     budgetj = journalAddBudgetGoalTransactions bopts ropts reportspan j     priceoracle = journalPriceOracle (infer_prices_ ropts) j-    budgetgoalreport@(PeriodicReport _ budgetgoalitems budgetgoaltotals) =-        dbg5 "budgetgoalreport" $ multiBalanceReportWith rspec{_rsReportOpts=ropts{empty_=True}} budgetj priceoracle mempty-    budgetedacctsseen = S.fromList $ map prrFullName budgetgoalitems-    actualreport@(PeriodicReport actualspans _ _) =-        dbg5 "actualreport"     $ multiBalanceReportWith rspec{_rsReportOpts=ropts{empty_=True}} actualj priceoracle budgetedacctsseen-    budgetgoalreport'-      -- If no interval is specified:-      -- budgetgoalreport's span might be shorter actualreport's due to periodic txns;-      -- it should be safe to replace it with the latter, so they combine well.-      | interval_ ropts == NoInterval = PeriodicReport actualspans budgetgoalitems budgetgoaltotals-      | otherwise = budgetgoalreport-    budgetreport = combineBudgetAndActual ropts j budgetgoalreport' actualreport +    (_, actualspans) = dbg5 "actualspans" $ reportSpan actualj rspec+    (_, budgetspans) = dbg5 "budgetspans" $ reportSpan budgetj rspec+    allspans = case interval_ ropts of+        -- If no interval is specified:+        -- budgetgoalreport's span might be shorter actualreport's due to periodic txns;+        -- it should be safe to replace it with the latter, so they combine well.+        NoInterval -> actualspans+        _          -> nubSort . filter (/= nulldatespan) $ actualspans ++ budgetspans++    actualps = dbg5 "actualps" $ getPostings rspec actualj priceoracle reportspan+    budgetps = dbg5 "budgetps" $ getPostings rspec budgetj priceoracle reportspan++    actualAcct = dbg5 "actualAcct" $ generateMultiBalanceAccount rspec actualj priceoracle actualspans actualps+    budgetAcct = dbg5 "budgetAcct" $ generateMultiBalanceAccount rspec budgetj priceoracle budgetspans budgetps++    combinedAcct = dbg5 "combinedAcct" $ if null budgetps+        -- If no budget postings, just use actual account, to avoid unnecssary budget zeros+        then This <$> actualAcct+        else mergeAccounts actualAcct budgetAcct++    budgetreport = generateBudgetReport ropts allspans combinedAcct++-- | 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.+generateBudgetReport :: ReportOpts -> [DateSpan] -> Account (These BalanceData BalanceData) -> BudgetReport+generateBudgetReport = generatePeriodicReport makeBudgetReportRow treeActualBalance flatActualBalance+  where+    treeActualBalance = these bdincludingsubs (const nullmixedamt) (const . bdincludingsubs)+    flatActualBalance = fromMaybe nullmixedamt . fst++-- | Build a report row.+--+-- Calculate the column totals. These are always the sum of column amounts.+makeBudgetReportRow :: ReportOpts -> (BalanceData -> MixedAmount)+                    -> a -> Account (These BalanceData BalanceData) -> PeriodicReportRow a BudgetCell+makeBudgetReportRow ropts balance =+    makePeriodicReportRow (Just nullmixedamt, Nothing) avg ropts (theseToMaybe . bimap balance balance)+  where+    avg xs = ((actualtotal, budgettotal), (actualavg, budgetavg))+      where+        (actuals, budgets) = unzip $ toList xs+        (actualtotal, actualavg) = bimap Just Just . sumAndAverageMixedAmounts $ catMaybes actuals+        (budgettotal, budgetavg) = bimap Just Just . sumAndAverageMixedAmounts $ catMaybes budgets++    theseToMaybe (This a) = (Just a, Nothing)+    theseToMaybe (That b) = (Just nullmixedamt, Just b)+    theseToMaybe (These a b) = (Just a, Just b)+ -- | Use all (or all matched by --budget's argument) periodic transactions in the journal  -- to generate budget goal transactions in the specified date span (and before, to support -- --historical. The precise start date is the natural start date of the largest interval@@ -179,81 +216,6 @@         budgetedparent = find (`S.member` budgetedaccts) $ parentAccountNames a         u = unbudgetedAccountName --- | Combine a per-account-and-subperiod report of budget goals, and one--- of actual change amounts, into a budget performance report.--- The two reports should have the same report interval, but need not--- have exactly the same account rows or date columns.--- (Cells in the combined budget report can be missing a budget goal,--- an actual amount, or both.) The combined report will include:------ - consecutive subperiods at the same interval as the two reports,---   spanning the period of both reports------ - all accounts mentioned in either report, sorted by account code or---   account name or amount as appropriate.----combineBudgetAndActual :: ReportOpts -> Journal -> MultiBalanceReport -> MultiBalanceReport -> BudgetReport-combineBudgetAndActual ropts j-      (PeriodicReport budgetperiods budgetrows (PeriodicReportRow _ budgettots budgetgrandtot budgetgrandavg))-      (PeriodicReport actualperiods actualrows (PeriodicReportRow _ actualtots actualgrandtot actualgrandavg)) =-    PeriodicReport periods combinedrows totalrow-  where-    periods = nubSort . filter (/= nulldatespan) $ budgetperiods ++ actualperiods--    -- first, combine any corresponding budget goals with actual changes-    actualsplusgoals = [-        -- dbg0With (("actualsplusgoals: "<>)._brrShowDebug) $-        PeriodicReportRow acct amtandgoals totamtandgoal avgamtandgoal-      | PeriodicReportRow acct actualamts actualtot actualavg <- actualrows--      , let mbudgetgoals       = HM.lookup (displayFull acct) budgetGoalsByAcct :: Maybe ([BudgetGoal], BudgetTotal, BudgetAverage)-      , let budgetmamts        = maybe (Nothing <$ periods) (map Just . first3) mbudgetgoals :: [Maybe BudgetGoal]-      , let mbudgettot         = second3 <$> mbudgetgoals :: Maybe BudgetTotal-      , let mbudgetavg         = third3 <$> mbudgetgoals  :: Maybe BudgetAverage-      , let acctGoalByPeriod   = Map.fromList [ (p,budgetamt) | (p, Just budgetamt) <- zip budgetperiods budgetmamts ] :: Map DateSpan BudgetGoal-      , let acctActualByPeriod = Map.fromList [ (p,actualamt) | (p, Just actualamt) <- zip actualperiods (map Just actualamts) ] :: Map DateSpan Change-      , let amtandgoals        = [ (Map.lookup p acctActualByPeriod, Map.lookup p acctGoalByPeriod) | p <- periods ] :: [BudgetCell]-      , let totamtandgoal      = (Just actualtot, mbudgettot)-      , let avgamtandgoal      = (Just actualavg, mbudgetavg)-      ]-      where-        budgetGoalsByAcct :: HashMap AccountName ([BudgetGoal], BudgetTotal, BudgetAverage) =-          HM.fromList [ (displayFull acct, (amts, tot, avg))-                      | PeriodicReportRow acct amts tot avg <--                          -- dbg0With (unlines.map (("budgetgoals: "<>).prrShowDebug)) $-                          budgetrows-                      ]--    -- next, make rows for budget goals with no actual changes-    othergoals = [-        -- dbg0With (("othergoals: "<>)._brrShowDebug) $-        PeriodicReportRow acct amtandgoals totamtandgoal avgamtandgoal-      | PeriodicReportRow acct budgetgoals budgettot budgetavg <- budgetrows-      , displayFull acct `notElem` map prrFullName actualsplusgoals-      , let acctGoalByPeriod   = Map.fromList $ zip budgetperiods budgetgoals :: Map DateSpan BudgetGoal-      , let amtandgoals        = [ (Just 0, Map.lookup p acctGoalByPeriod) | p <- periods ] :: [BudgetCell]-      , let totamtandgoal      = (Just 0, Just budgettot)-      , let avgamtandgoal      = (Just 0, Just budgetavg)-      ]--    -- combine and re-sort rows-    -- TODO: add --sort-budget to sort by budget goal amount-    combinedrows :: [BudgetReportRow] =-      -- map (dbg0With (("combinedrows: "<>)._brrShowDebug)) $-      sortRowsLike (mbrsorted unbudgetedrows ++ mbrsorted rows') rows-      where-        (unbudgetedrows, rows') = partition ((==unbudgetedAccountName) . prrFullName) rows-        mbrsorted = map prrFullName . sortRows ropts j . map (fmap $ fromMaybe nullmixedamt . fst)-        rows = actualsplusgoals ++ othergoals--    totalrow = PeriodicReportRow ()-        [ (Map.lookup p totActualByPeriod, Map.lookup p totGoalByPeriod) | p <- periods ]-        ( Just actualgrandtot, budget budgetgrandtot )-        ( Just actualgrandavg, budget budgetgrandavg )-      where-        totGoalByPeriod = 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  -- tests 

@@ -1,8 +1,11 @@+{-# LANGUAGE CPP                 #-} {-# LANGUAGE FlexibleInstances   #-} {-# LANGUAGE OverloadedStrings   #-}-{-# LANGUAGE NamedFieldPuns   #-}+{-# LANGUAGE NamedFieldPuns      #-}+{-# LANGUAGE RankNTypes          #-} {-# LANGUAGE RecordWildCards     #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections       #-} {-|  Multi-column balance reports, used by the balance command.@@ -19,52 +22,42 @@   compoundBalanceReport,   compoundBalanceReportWith, -  sortRows,-  sortRowsLike,-   -- * Helper functions   makeReportQuery,-  getPostingsByColumn,   getPostings,-  startingPostings,-  generateMultiBalanceReport,+  generateMultiBalanceAccount,+  generatePeriodicReport,+  makePeriodicReportRow,    -- -- * Tests   tests_MultiBalanceReport ) where +#if !MIN_VERSION_base(4,18,0)+import Control.Applicative (liftA2)+#endif import Control.Monad (guard)-import Data.Bifunctor (second) import Data.Foldable (toList)-import Data.List (sortOn, transpose)+import Data.List (sortOn) import Data.List.NonEmpty (NonEmpty((:|)))-import Data.HashMap.Strict (HashMap)-import qualified Data.HashMap.Strict as HM-import Data.Map (Map)-import qualified Data.Map as M+import qualified Data.HashSet as HS+import qualified Data.IntMap.Strict as IM+import qualified Data.IntSet as IS import Data.Maybe (fromMaybe, isJust, mapMaybe) import Data.Ord (Down(..)) import Data.Semigroup (sconcat)-import Data.Set (Set)-import qualified Data.Set as Set-import Data.Time.Calendar (fromGregorian)-import Safe (lastDef, minimumMay)+import Data.These (these)+import Data.Time.Calendar (Day(..), addDays, fromGregorian)+import Data.Traversable (mapAccumL)  import Hledger.Data import Hledger.Query-import Hledger.Utils hiding (dbg3,dbg4,dbg5)-import qualified Hledger.Utils+import Hledger.Utils import Hledger.Reports.ReportOptions import Hledger.Reports.ReportTypes  --- add a prefix to this function's debug output-dbg3 s = let p = "multiBalanceReport" in Hledger.Utils.dbg3 (p++" "++s)-dbg4 s = let p = "multiBalanceReport" in Hledger.Utils.dbg4 (p++" "++s)-dbg5 s = let p = "multiBalanceReport" in Hledger.Utils.dbg5 (p++" "++s)-- -- | A multi balance report is a kind of periodic report, where the amounts -- correspond to balance changes or ending balances in a given period. It has: --@@ -86,10 +79,7 @@ type MultiBalanceReport    = PeriodicReport    DisplayName MixedAmount type MultiBalanceReportRow = PeriodicReportRow DisplayName MixedAmount --- type alias just to remind us which AccountNames might be depth-clipped, below.-type ClippedAccountName = AccountName - -- | Generate a multicolumn balance report for the matched accounts, -- showing the change of balance, accumulated balance, or historical balance -- in each of the specified periods. If the normalbalance_ option is set, it@@ -98,7 +88,7 @@ -- by the balance command (in multiperiod mode) and (via compoundBalanceReport) -- by the bs/cf/is commands. multiBalanceReport :: ReportSpec -> Journal -> MultiBalanceReport-multiBalanceReport rspec j = multiBalanceReportWith rspec j (journalPriceOracle infer j) mempty+multiBalanceReport rspec j = multiBalanceReportWith rspec j (journalPriceOracle infer j)   where infer = infer_prices_ $ _rsReportOpts rspec  -- | A helper for multiBalanceReport. This one takes some extra arguments,@@ -106,26 +96,23 @@ -- 'AccountName's which should not be elided. Commands which run multiple -- reports (bs etc.) can generate the price oracle just once for efficiency, -- passing it to each report by calling this function directly.-multiBalanceReportWith :: ReportSpec -> Journal -> PriceOracle -> Set AccountName -> MultiBalanceReport-multiBalanceReportWith rspec' j priceoracle unelidableaccts = report+multiBalanceReportWith :: ReportSpec -> Journal -> PriceOracle -> MultiBalanceReport+multiBalanceReportWith rspec' j priceoracle = report   where     -- Queries, report/column dates.-    (reportspan, colspans) = reportSpan j rspec'-    rspec = dbg3 "reportopts" $ makeReportQuery rspec' reportspan+    (reportspan, colspans) = dbg5 "multiBalanceReportWith reportSpan" $ reportSpan j rspec'+    rspec = dbg3 "multiBalanceReportWith rspec" $ makeReportQuery rspec' reportspan     -- force evaluation order to show price lookup after date spans in debug output (XXX not working)     -- priceoracle = reportspan `seq` priceoracle0 -    -- Group postings into their columns.-    colps = dbg5 "colps" $ getPostingsByColumn rspec j priceoracle colspans+    -- Get postings+    ps = dbg5 "multiBalanceReportWith ps" $ getPostings rspec j priceoracle reportspan -    -- 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 $ startingPostings rspec j priceoracle reportspan+    -- Process changes into normal, cumulative, or historical amounts, plus value them and mark which are uninteresting+    acct = dbg5 "multiBalanceReportWith acct" $ generateMultiBalanceAccount rspec j priceoracle colspans ps      -- Generate and postprocess the report, negating balances and taking percentages if needed-    report = dbg4 "multiBalanceReportWith" $-      generateMultiBalanceReport rspec j priceoracle unelidableaccts colps startbals+    report = dbg4 "multiBalanceReportWith report" $ generateMultiBalanceReport (_rsReportOpts rspec) colspans acct  -- | Generate a compound balance report from a list of CBCSubreportSpec. This -- shares postings between the subreports.@@ -141,23 +128,18 @@ compoundBalanceReportWith rspec' j priceoracle subreportspecs = cbr   where     -- Queries, report/column dates.-    (reportspan, colspans) = reportSpan j rspec'-    rspec = dbg3 "reportopts" $ makeReportQuery rspec' reportspan--    -- Group postings into their columns.-    colps = dbg5 "colps" $ getPostingsByColumn rspec j priceoracle colspans+    (reportspan, colspans) = dbg5 "compoundBalanceReportWith reportSpan" $ reportSpan j rspec'+    rspec = dbg3 "compoundBalanceReportWith rspec" $ makeReportQuery rspec' reportspan -    -- 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.-    startps = dbg5 "startps" $ startingPostings rspec j priceoracle reportspan+    -- Get postings+    ps = dbg5 "compoundBalanceReportWith ps" $ getPostings rspec j priceoracle reportspan      subreports = map generateSubreport subreportspecs       where         generateSubreport CBCSubreportSpec{..} =             ( cbcsubreporttitle             -- Postprocess the report, negating balances and taking percentages if needed-            , cbcsubreporttransform $-                generateMultiBalanceReport rspecsub j priceoracle mempty colps' startbals'+            , cbcsubreporttransform $ generateMultiBalanceReport ropts colspans acct             , cbcsubreportincreasestotal             )           where@@ -165,10 +147,10 @@             -- Add a restriction to this subreport to the report query.             -- XXX in non-thorough way, consider updateReportSpec ?             rspecsub = rspec{_rsReportOpts=ropts, _rsQuery=And [cbcsubreportquery, _rsQuery rspec]}-            -- Starting balances and column postings specific to this subreport.-            startbals' = startingBalances rspecsub j priceoracle $-              filter (matchesPostingExtra (journalAccountType j) cbcsubreportquery) startps-            colps' = map (second $ filter (matchesPostingExtra (journalAccountType j) cbcsubreportquery)) colps+            -- Match and postings for the subreport+            subreportps = filter (matchesPostingExtra (journalAccountType j) cbcsubreportquery) ps+            -- Account representing this subreport+            acct = generateMultiBalanceAccount rspecsub j priceoracle colspans subreportps      -- Sum the subreport totals by column. Handle these cases:     -- - no subreports@@ -181,48 +163,9 @@         subreportTotal (_, sr, increasestotal) =             (if increasestotal then id else fmap maNegate) $ prTotals sr -    cbr = CompoundPeriodicReport "" (map fst colps) subreports overalltotals+    cbr = CompoundPeriodicReport "" colspans subreports overalltotals --- XXX seems refactorable--- | Calculate accounts' balances on the report start date, from these postings--- which should be all postings before that date, and possibly also from account declarations.-startingBalances :: ReportSpec -> Journal -> PriceOracle -> [Posting]-                             -> HashMap AccountName Account-startingBalances rspec j priceoracle ps =-    M.findWithDefault nullacct emptydatespan-      <$> calculateReportMatrix rspec j priceoracle mempty [(emptydatespan, ps)] --- | 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.-startingPostings :: ReportSpec -> Journal -> PriceOracle -> DateSpan -> [Posting]-startingPostings rspec@ReportSpec{_rsQuery=query,_rsReportOpts=ropts} j priceoracle reportspan =-    getPostings rspec' j priceoracle-  where-    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{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),-    -- we use emptydatespan to make sure they aren't counted as starting balance.-    startbalq = dbg3 "startbalq" $ And [datelessq, precedingspanq]-    datelessq = dbg3 "datelessq" $ filterQuery (not . queryIsDateOrDate2) query--    precedingperiod = dateSpanAsPeriod . spanIntersect precedingspan .-                         periodAsDateSpan $ period_ ropts-    precedingspan = DateSpan Nothing (Exact <$> spanStart reportspan)-    precedingspanq = (if date2_ ropts then Date2 else Date) $ case precedingspan of-        DateSpan Nothing Nothing -> emptydatespan-        a -> a- -- | Remove any date queries and insert queries from the report span. -- The user's query expanded to the report span -- if there is one (otherwise any date queries are left as-is, which@@ -233,86 +176,102 @@     | otherwise = rspec{_rsQuery=query}   where     query            = simplifyQuery $ And [dateless $ _rsQuery rspec, reportspandatesq]-    reportspandatesq = dbg3 "reportspandatesq" $ dateqcons reportspan-    dateless         = dbg3 "dateless" . filterQuery (not . queryIsDateOrDate2)+    reportspandatesq = dbg3 "makeReportQuery reportspandatesq" $ dateqcons reportspan+    dateless         = dbg3 "makeReportQuery dateless" . filterQuery (not . queryIsDateOrDate2)     dateqcons        = if date2_ (_rsReportOpts rspec) then Date2 else Date --- | Group postings, grouped by their column-getPostingsByColumn :: ReportSpec -> Journal -> PriceOracle -> [DateSpan] -> [(DateSpan, [Posting])]-getPostingsByColumn rspec j priceoracle colspans =-    groupByDateSpan True getDate colspans ps-  where-    -- Postings matching the query within the report period.-    ps = dbg5 "getPostingsByColumn" $ getPostings rspec j priceoracle-    -- The date spans to be included as report columns.-    getDate = postingDateOrDate2 (whichDate (_rsReportOpts rspec))- -- | Gather postings matching the query within the report period.-getPostings :: ReportSpec -> Journal -> PriceOracle -> [Posting]-getPostings rspec@ReportSpec{_rsQuery=query, _rsReportOpts=ropts} j priceoracle =-    journalPostings $ journalValueAndFilterPostingsWith rspec' j priceoracle+getPostings :: ReportSpec -> Journal -> PriceOracle -> DateSpan -> [Posting]+getPostings rspec@ReportSpec{_rsQuery=query, _rsReportOpts=ropts} j priceoracle reportspan =+    setPostingsCount+    . journalPostings+    $ journalValueAndFilterPostingsWith rspec' j priceoracle   where-    rspec' = rspec{_rsQuery=depthless, _rsReportOpts = ropts'}+    -- If doing --count, set all posting amounts to "1".+    setPostingsCount = case balancecalc_ ropts of+        CalcPostingsCount -> map (postingTransformAmount (const $ mixed [num 1]))+        _                 -> id++    rspec' = rspec{_rsQuery=fullreportq,_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' = if isJust (valuationAfterSum ropts)-        then ropts{value_=Nothing, conversionop_=Just NoConversionOp}  -- If we're valuing after the sum, don't do it now-        else ropts+        then ropts{period_=dateSpanAsPeriod fullreportspan, value_=Nothing, conversionop_=Just NoConversionOp}  -- If we're valuing after the sum, don't do it now+        else ropts{period_=dateSpanAsPeriod fullreportspan} +    -- 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),+    -- we use emptydatespan to make sure they aren't counted as starting balance.+    fullreportq = dbg3 "getPostings fullreportq" $ And [datelessq, fullreportspanq]+    datelessq   = dbg3 "getPostings datelessq" $ filterQuery (not . queryIsDateOrDate2) depthlessq+     -- The user's query with no depth limit, and expanded to the report span     -- if there is one (otherwise any date queries are left as-is, which     -- handles the hledger-ui+future txns case above).-    depthless = dbg3 "depthless" $ filterQuery (not . queryIsDepth) query+    depthlessq = dbg3 "getPostings depthlessq" $ filterQuery (not . queryIsDepth) query --- | From set of postings, eg for a single report column, calculate the balance change in each account. --- Accounts and amounts will be depth-clipped appropriately if a depth limit is in effect.------ When --declared is used, accounts which have been declared with an account directive--- are also included, with a 0 balance change. But only leaf accounts, since non-leaf--- empty declared accounts are less useful in reports. This is primarily for hledger-ui.-acctChanges :: ReportSpec -> Journal -> [Posting] -> HashMap ClippedAccountName Account-acctChanges ReportSpec{_rsQuery=query,_rsReportOpts=ReportOpts{accountlistmode_, declared_}} j ps =-  HM.fromList [(aname a, a) | a <- accts]+    fullreportspan  = if requiresHistorical ropts then DateSpan Nothing (Exact <$> spanEnd reportspan) else reportspan+    fullreportspanq = (if date2_ ropts then Date2 else Date) $ case fullreportspan of+        DateSpan Nothing Nothing -> emptydatespan+        a -> a++-- | Generate the 'Account' for the requested multi-balance report from a list+-- of 'Posting's.+generateMultiBalanceAccount :: ReportSpec -> Journal -> PriceOracle -> [DateSpan] -> [Posting] -> Account BalanceData+generateMultiBalanceAccount rspec@ReportSpec{_rsReportOpts=ropts} j priceoracle colspans =+    -- Add declared accounts if called with --declared and --empty+    (if (declared_ ropts && empty_ ropts) then addDeclaredAccounts rspec j else id)+    -- Negate amounts if applicable+    . (if invert_ ropts then fmap (mapBalanceData maNegate) else id)+    -- Mark which accounts are boring and which are interesting+    . markAccountBoring rspec+    -- Set account declaration info (for sorting purposes)+    . mapAccounts (accountSetDeclarationInfo j)+    -- Process changes into normal, cumulative, or historical amounts, plus value them+    . calculateReportAccount rspec j priceoracle colspans+    -- Clip account names+    . map clipPosting   where-    -- With --declared, add the query-matching declared accounts-    -- (as dummy postings so they are processed like the rest).-    -- This function is used for calculating both pre-start changes and column changes,-    -- and the declared accounts are really only needed for the former, -    -- but it's harmless to have them in the column changes as well.-    ps' = ps ++ if declared_ then declaredacctps else []-      where-        declaredacctps =-          [nullposting{paccount=a}-          | a <- journalLeafAccountNamesDeclared j-          , matchesAccountExtra (journalAccountType j) (journalAccountTags j) accttypetagsq a-          ]-          where-            accttypetagsq  = dbg3 "accttypetagsq" $-              filterQueryOrNotQuery (\q -> queryIsAcct q || queryIsType q || queryIsTag q) query+    -- Clip postings to the requested depth according to the query+    clipPosting p = p{paccount = clipOrEllipsifyAccountName depthSpec $ paccount p}+    depthSpec = dbg3 "generateMultiBalanceAccount depthSpec"+              . queryDepth . filterQuery queryIsDepth $ _rsQuery rspec -    filterbydepth = case accountlistmode_ of-        ALTree -> filter (depthMatches . aname)       -- a tree - just exclude deeper accounts-        ALFlat -> clipAccountsAndAggregate depthSpec  -- a list - aggregate deeper accounts at the depth limit-                  . filter ((0<) . anumpostings)      -- and exclude empty parent accounts-      where-        depthSpec = dbg3 "depthq" . queryDepth $ filterQuery queryIsDepth query-        depthMatches name = maybe True (accountNameLevel name <=) $ getAccountNameClippedDepth depthSpec name+-- | Add declared accounts to the account tree.+addDeclaredAccounts :: Monoid a => ReportSpec -> Journal -> Account a -> Account a+addDeclaredAccounts rspec j acct =+    these id id const <$> mergeAccounts acct declaredTree+  where+    declaredTree =+        mapAccounts (\a -> a{aboring = not $ aname a `HS.member` HS.fromList declaredAccounts}) $+          accountTreeFromBalanceAndNames "root" (mempty <$ adata acct) declaredAccounts -    accts = filterbydepth $ drop 1 $ accountsFromPostings ps'+    -- With --declared, add the query-matching declared accounts (as dummy postings+    -- so they are processed like the rest).+    declaredAccounts =+      map (clipOrEllipsifyAccountName depthSpec) .+      filter (matchesAccountExtra (journalAccountType j) (journalAccountTags j) accttypetagsq) $+      journalAccountNamesDeclared j +    accttypetagsq  = dbg3 "addDeclaredAccounts accttypetagsq" .+      filterQueryOrNotQuery (\q -> queryIsAcct q || queryIsType q || queryIsTag q) $+      _rsQuery rspec++    depthSpec = queryDepth . filterQuery queryIsDepth $ _rsQuery rspec++ -- | Gather the account balance changes into a regular matrix, then -- accumulate and value amounts, as specified by the report options. -- Makes sure all report columns have an entry.-calculateReportMatrix :: ReportSpec -> Journal -> PriceOracle-                      -> HashMap ClippedAccountName Account-                      -> [(DateSpan, [Posting])]-                      -> HashMap ClippedAccountName (Map DateSpan Account)-calculateReportMatrix rspec@ReportSpec{_rsReportOpts=ropts} j priceoracle startbals colps =  -- PARTIAL:-    -- Ensure all columns have entries, including those with starting balances-    HM.mapWithKey rowbals allchanges+calculateReportAccount :: ReportSpec -> Journal -> PriceOracle -> [DateSpan] -> [Posting] -> Account BalanceData+calculateReportAccount rspec@ReportSpec{_rsReportOpts=ropts} j priceoracle colspans ps =  -- PARTIAL:+    mapPeriodData rowbals changesAcct   where     -- The valued row amounts to be displayed: per-period changes,     -- zero-based cumulative totals, or     -- starting-balance-based historical balances.-    rowbals name unvaluedChanges = dbg5 "rowbals" $ case balanceaccum_ ropts of+    rowbals :: PeriodData BalanceData -> PeriodData BalanceData+    rowbals unvaluedChanges = case balanceaccum_ ropts of         PerPeriod  -> changes         Cumulative -> cumulative         Historical -> historical@@ -320,207 +279,209 @@         -- changes to report on: usually just the valued changes themselves, but use the         -- differences in the valued historical amount for CalcValueChange and CalcGain.         changes = case balancecalc_ ropts of-            CalcChange        -> M.mapWithKey avalue unvaluedChanges-            CalcBudget        -> M.mapWithKey avalue unvaluedChanges-            CalcValueChange   -> periodChanges valuedStart historical-            CalcGain          -> periodChanges valuedStart historical-            CalcPostingsCount -> M.mapWithKey avalue unvaluedChanges+            CalcChange        -> avalue unvaluedChanges+            CalcBudget        -> avalue unvaluedChanges+            CalcValueChange   -> periodChanges historical+            CalcGain          -> periodChanges historical+            CalcPostingsCount -> avalue unvaluedChanges         -- the historical balance is the valued cumulative sum of all unvalued changes-        historical = M.mapWithKey avalue $ cumulativeSum startingBalance unvaluedChanges+        historical = avalue $ cumulativeSum unvaluedChanges         -- since this is a cumulative sum of valued amounts, it should not be valued again-        cumulative = cumulativeSum nullacct changes-        startingBalance = HM.lookupDefault nullacct name startbals-        valuedStart = avalue (DateSpan Nothing (Exact <$> historicalDate)) startingBalance+        cumulative = cumulativeSum changes{pdpre = mempty}+        avalue = periodDataValuation ropts j priceoracle colspans -    -- In each column, get each account's balance changes-    colacctchanges = dbg5 "colacctchanges" $ map (second $ acctChanges rspec j) colps :: [(DateSpan, HashMap ClippedAccountName Account)]-    -- Transpose it to get each account's balance changes across all columns-    acctchanges = dbg5 "acctchanges" $ transposeMap colacctchanges :: HashMap AccountName (Map DateSpan Account)-    -- Fill out the matrix with zeros in empty cells-    allchanges = ((<>zeros) <$> acctchanges) <> (zeros <$ startbals)+    changesAcct = dbg5With (\x -> "calculateReportAccount changesAcct\n" ++ showAccounts x) .+        mapPeriodData (padPeriodData intervalStarts) $+        accountFromPostings getIntervalStartDate ps -    avalue = acctApplyBoth . mixedAmountApplyValuationAfterSumFromOptsWith ropts j priceoracle-    acctApplyBoth f a = a{aibalance = f $ aibalance a, aebalance = f $ aebalance a}-    historicalDate = minimumMay $ mapMaybe spanStart colspans-    zeros = M.fromList [(spn, nullacct) | spn <- colspans]-    colspans = map fst colps+    getIntervalStartDate p = intToDay <$> IS.lookupLE (dayToInt $ getPostingDate p) intervalStarts+    getPostingDate = postingDateOrDate2 (whichDate (_rsReportOpts rspec)) +    intervalStarts = IS.fromList . map dayToInt $ case mapMaybe spanStart colspans of+      [] -> [nulldate]  -- Deal with the case of the empty journal+      xs -> xs+    dayToInt = fromInteger . toModifiedJulianDay+    intToDay = ModifiedJulianDay . toInteger --- | 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 -> Set AccountName-                           -> [(DateSpan, [Posting])] -> HashMap AccountName Account-                           -> MultiBalanceReport-generateMultiBalanceReport rspec@ReportSpec{_rsReportOpts=ropts} j priceoracle unelidableaccts colps0 startbals =-    report+-- | The valuation function to use for the chosen report options.+-- This can call error in various situations.+periodDataValuation :: ReportOpts -> Journal -> PriceOracle -> [DateSpan]+                    -> PeriodData BalanceData -> PeriodData BalanceData+periodDataValuation ropts j priceoracle colspans =+    opPeriodData valueBalanceData balanceDataPeriodEnds   where-    -- If doing --count, set all posting amounts to "1".-    colps =-      if balancecalc_ ropts == CalcPostingsCount-      then map (second (map (postingTransformAmount (const $ mixed [num 1])))) colps0-      else colps0--    -- Process changes into normal, cumulative, or historical amounts, plus value them-    matrix = calculateReportMatrix rspec j priceoracle startbals colps--    -- All account names that will be displayed, possibly depth-clipped.-    displaynames = dbg5 "displaynames" $ displayedAccounts rspec unelidableaccts matrix--    -- All the rows of the report.-    rows = dbg5 "rows" . (if invert_ ropts then map (fmap maNegate) else id)  -- Negate amounts if applicable-             $ buildReportRows ropts displaynames matrix--    -- Calculate column totals-    totalsrow = dbg5 "totalsrow" $ calculateTotalsRow ropts rows $ length colps--    -- Sorted report rows.-    sortedrows = dbg5 "sortedrows" $ sortRows ropts j rows+    valueBalanceData :: Day -> BalanceData -> BalanceData+    valueBalanceData d = mapBalanceData (valueMixedAmount d) -    -- Take percentages if needed-    report = reportPercent ropts $ PeriodicReport (map fst colps) sortedrows totalsrow+    valueMixedAmount :: Day -> MixedAmount -> MixedAmount+    valueMixedAmount = mixedAmountApplyValuationAfterSumFromOptsWith ropts j priceoracle --- | Build the report rows.--- One row per account, with account name info, row amounts, row total and row average.--- Rows are unsorted.-buildReportRows :: ReportOpts-                -> HashMap AccountName DisplayName-                -> HashMap AccountName (Map DateSpan Account)-                -> [MultiBalanceReportRow]-buildReportRows ropts displaynames =-  toList . HM.mapMaybeWithKey mkRow  -- toList of HashMap's Foldable instance - does not sort consistently-  where-    mkRow name accts = do-        displayname <- HM.lookup name displaynames-        return $ PeriodicReportRow displayname rowbals rowtot rowavg+    balanceDataPeriodEnds :: PeriodData Day+    balanceDataPeriodEnds = dbg5 "balanceDataPeriodEnds" $ case colspans of  -- FIXME: Change colspans to nonempty list+        [DateSpan Nothing Nothing] -> periodDataFromList nulldate [(nulldate, nulldate)]  -- Empty journal+        h:ds                       -> periodDataFromList (makeJustFst $ boundaries h) $ map (makeJust . boundaries) (h:ds)+        []                         -> error' "balanceDataPeriodEnds: Shouldn't have empty colspans"  -- PARTIAL: Shouldn't occur       where-        rowbals = map balance $ toList accts  -- toList of Map's Foldable instance - does sort by key-        -- 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 balanceaccum_ ropts of-            PerPeriod -> maSum rowbals-            _         -> lastDef nullmixedamt rowbals-        rowavg = averageMixedAmounts rowbals-    balance = case accountlistmode_ ropts of ALTree -> aibalance; ALFlat -> aebalance+        boundaries spn = (spanStart spn, spanEnd spn) --- | Calculate accounts which are to be displayed in the report,--- and their name and their indent level if displayed in tree mode.-displayedAccounts :: ReportSpec-                  -> Set AccountName-                  -> HashMap AccountName (Map DateSpan Account)-                  -> HashMap AccountName DisplayName-displayedAccounts ReportSpec{_rsQuery=query,_rsReportOpts=ropts} unelidableaccts valuedaccts-    | qdepthIsZero = HM.singleton "..." $ DisplayName "..." "..." 0-    | otherwise    = HM.mapWithKey (\a _ -> displayedName a) displayedAccts+        makeJust (Just x, Just y) = (x, addDays (-1) y)+        makeJust _    = error' "balanceDataPeriodEnds: expected all non-initial spans to have start and end dates"+        makeJustFst (Just x, _) = addDays (-1) x+        makeJustFst _ = error' "balanceDataPeriodEnds: expected initial span to have an end date"++-- | Mark which nodes of an 'Account' are boring, and so should be omitted from reports.+markAccountBoring :: ReportSpec -> Account BalanceData -> Account BalanceData+markAccountBoring ReportSpec{_rsQuery=query,_rsReportOpts=ropts}+    -- If depth 0, all accounts except the top-level account are boring+    | qdepthIsZero = markBoring False . mapAccounts (markBoring True)+    -- Otherwise the top level account is boring, and subaccounts are boring if+    -- they are both boring in and of themselves and are boring parents+    | otherwise    = markBoring True . mapAccounts (markBoringBy (liftA2 (&&) isBoring isBoringParent))   where-    displayedName name = case accountlistmode_ ropts of-        ALTree -> DisplayName name leaf (max 0 $ level - 1 - boringParents)-        ALFlat -> DisplayName name droppedName 0+    -- Accounts boring on their own+    isBoring :: Account BalanceData -> Bool+    isBoring acct = tooDeep || allZeros       where-        droppedName   = accountNameDrop (drop_ ropts) name-        leaf          = accountNameFromComponents . reverse . map accountLeafName $-                          droppedName : takeWhile notDisplayed parents-        level         = max 0 $ (accountNameLevel name) - drop_ ropts-        parents       = take (level - 1) $ parentAccountNames name-        boringParents = if no_elide_ ropts then 0 else length $ filter notDisplayed parents-        notDisplayed  = not . (`HM.member` displayedAccts)+        tooDeep = d > qdepth                                       -- Throw out anything too deep+        allZeros = isZeroRow balance amts && not keepEmptyAccount  -- Throw away everything with a zero balance in the row, unless..+        keepEmptyAccount = empty_ ropts && keepWhenEmpty acct      -- We are keeping empty rows and this row meets the criteria -    -- Accounts which are to be displayed-    displayedAccts = (if qdepthIsZero then id else HM.filterWithKey keep) valuedaccts-      where-        keep name amts = isInteresting name amts || name `HM.member` interestingParents+        amts = pdperiods $ adata acct+        d = accountNameLevel $ aname acct -    -- Accounts interesting for their own sake-    isInteresting name amts =-        d <= qdepth                                -- Throw out anything too deep-        && ( name `Set.member` unelidableaccts     -- Unelidable accounts should be kept unless 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-        qdepth = fromMaybe maxBound $ getAccountNameClippedDepth depthspec name-        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+        qdepth = fromMaybe maxBound . getAccountNameClippedDepth depthspec $ aname acct         balance = maybeStripPrices . case accountlistmode_ ropts of-            ALTree | d == qdepth -> aibalance-            _                    -> aebalance-          where maybeStripPrices = if conversionop_ ropts == Just NoConversionOp then id else mixedAmountStripCosts+            ALTree | d == qdepth -> bdincludingsubs+            _                    -> bdexcludingsubs -    -- Accounts interesting because they are a fork for interesting subaccounts-    interestingParents = dbg5 "interestingParents" $ case accountlistmode_ ropts of-        ALTree -> HM.filterWithKey hasEnoughSubs numSubs-        ALFlat -> mempty+    -- Accounts which don't have enough interesting subaccounts+    isBoringParent :: Account a -> Bool+    isBoringParent acct = case accountlistmode_ ropts of+        ALTree -> notEnoughSubs || droppedAccount+        ALFlat -> True       where-        hasEnoughSubs name nsubs = nsubs >= minSubs && accountNameLevel name > drop_ ropts-        minSubs = if no_elide_ ropts then 1 else 2+        notEnoughSubs = length interestingSubs < minimumSubs+        droppedAccount = accountNameLevel (aname acct) <= drop_ ropts+        interestingSubs = filter (anyAccounts (not . aboring)) $ asubs acct+        minimumSubs = if no_elide_ ropts then 1 else 2      isZeroRow balance = all (mixedAmountLooksZero . balance)-    depthspec = queryDepth query+    keepWhenEmpty = case accountlistmode_ ropts of+        ALFlat -> any ((0<) . bdnumpostings) . pdperiods . adata  -- Keep all accounts that have postings in flat mode+        ALTree -> null . asubs                                    -- Keep only empty leaves in tree mode+    maybeStripPrices = if conversionop_ ropts == Just NoConversionOp then id else mixedAmountStripCosts+     qdepthIsZero = depthspec == DepthSpec (Just 0) []-    numSubs = subaccountTallies . HM.keys $ HM.filterWithKey isInteresting valuedaccts+    depthspec = queryDepth query --- | Sort the rows by amount or by account declaration order.-sortRows :: ReportOpts -> Journal -> [MultiBalanceReportRow] -> [MultiBalanceReportRow]-sortRows ropts j-    | sort_amount_ ropts, ALTree <- accountlistmode_ ropts = sortTreeMBRByAmount-    | sort_amount_ ropts, ALFlat <- accountlistmode_ ropts = sortFlatMBRByAmount-    | otherwise                                            = sortMBRByAccountDeclaration+    markBoring   v a = a{aboring = v}+    markBoringBy f a = a{aboring = f a}+++-- | Build a report row.+--+-- Calculate the column totals. These are always the sum of column amounts.+generateMultiBalanceReport :: ReportOpts -> [DateSpan] -> Account BalanceData -> MultiBalanceReport+generateMultiBalanceReport ropts colspans =+    reportPercent ropts . generatePeriodicReport makeMultiBalanceReportRow bdincludingsubs id ropts colspans++-- | 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.+generatePeriodicReport :: Show c =>+    (forall a. ReportOpts -> (BalanceData -> MixedAmount) -> a -> Account b -> PeriodicReportRow a c)+    -> (b -> MixedAmount) -> (c -> MixedAmount)+    -> ReportOpts -> [DateSpan] -> Account b -> PeriodicReport DisplayName c+generatePeriodicReport makeRow treeAmt flatAmt ropts colspans acct =+    PeriodicReport colspans (buildAndSort acct) totalsrow   where-    -- Sort the report rows, representing a tree of accounts, by row total at each level.-    -- Similar to sortMBRByAccountDeclaration/sortAccountNamesByDeclaration.-    sortTreeMBRByAmount :: [MultiBalanceReportRow] -> [MultiBalanceReportRow]-    sortTreeMBRByAmount rows = mapMaybe (`HM.lookup` rowMap) sortedanames+    -- Build report rows and sort them+    buildAndSort = dbg5 "generatePeriodicReport buildAndSort" . case accountlistmode_ ropts of+        ALTree | sort_amount_ ropts -> buildRows . sortTreeByAmount+        ALFlat | sort_amount_ ropts -> sortFlatByAmount . buildRows+        _                           -> buildRows . sortAccountTreeByDeclaration++    buildRows = buildReportRows makeRow ropts++    -- Calculate column totals from the inclusive balances of the root account+    totalsrow = dbg5 "generatePeriodicReport totalsrow" $ makeRow ropts bdincludingsubs () acct++    sortTreeByAmount = case fromMaybe NormallyPositive $ normalbalance_ ropts of+        NormallyPositive -> sortAccountTreeOn (\r -> (Down $ amt r, aname r))+        NormallyNegative -> sortAccountTreeOn (\r -> (amt r, aname r))       where-        accounttree = accountTree "root" $ map prrFullName rows-        rowMap = HM.fromList $ map (\row -> (prrFullName row, row)) rows-        -- Set the inclusive balance of an account from the rows, or sum the-        -- subaccounts if it's not present-        accounttreewithbals = mapAccounts setibalance accounttree-        setibalance a = a{aibalance = maybe (maSum . map aibalance $ asubs a) prrTotal $-                                          HM.lookup (aname a) rowMap}-        sortedaccounttree = sortAccountTreeByAmount (fromMaybe NormallyPositive $ normalbalance_ ropts) accounttreewithbals-        sortedanames = map aname $ drop 1 $ flattenAccounts sortedaccounttree+        amt = mixedAmountStripCosts . sortKey . fmap treeAmt . pdperiods . adata+        sortKey = case balanceaccum_ ropts of+          PerPeriod -> maSum+          _         -> maybe nullmixedamt snd . IM.lookupMax -    -- Sort the report rows, representing a flat account list, by row total (and then account name).-    sortFlatMBRByAmount :: [MultiBalanceReportRow] -> [MultiBalanceReportRow]-    sortFlatMBRByAmount = case fromMaybe NormallyPositive $ normalbalance_ ropts of+    sortFlatByAmount = case fromMaybe NormallyPositive $ normalbalance_ ropts of         NormallyPositive -> sortOn (\r -> (Down $ amt r, prrFullName r))         NormallyNegative -> sortOn (\r -> (amt r, prrFullName r))-      where amt = mixedAmountStripCosts . prrTotal+      where amt = mixedAmountStripCosts . flatAmt . prrTotal -    -- Sort the report rows by account declaration order then account name.-    sortMBRByAccountDeclaration :: [MultiBalanceReportRow] -> [MultiBalanceReportRow]-    sortMBRByAccountDeclaration rows = sortRowsLike sortedanames rows+-- | Build the report rows.+-- One row per account, with account name info, row amounts, row total and row average.+-- Rows are sorted according to the order in the 'Account' tree.+buildReportRows :: forall b c.+                (ReportOpts -> (BalanceData -> MixedAmount) -> DisplayName -> Account b -> PeriodicReportRow DisplayName c)+                -> ReportOpts -> Account b -> [PeriodicReportRow DisplayName c]+buildReportRows makeRow ropts = mkRows True (-drop_ ropts) 0+  where+    -- Build the row for an account at a given depth with some number of boring parents+    mkRows :: Bool -> Int -> Int -> Account b -> [PeriodicReportRow DisplayName c]+    mkRows isRoot d boringParents acct+        -- Account is a boring root account, and should be bypassed entirely+        | aboring acct && isRoot         = buildSubrows d 0+        -- Account is boring and has been dropped, so should be skipped and move up the hierarchy+        | aboring acct && d < 0          = buildSubrows (d + 1) 0+        -- Account is boring, and we can omit boring parents, so we should omit but keep track+        | aboring acct && canOmitParents = buildSubrows d (boringParents + 1)+        -- Account is not boring or otherwise should be displayed.+        | otherwise = makeRow ropts balance displayname acct : buildSubrows (d + 1) 0       where-        sortedanames = sortAccountNamesByDeclaration j (tree_ ropts) $ map prrFullName rows+        displayname = displayedName d boringParents $ aname acct+        buildSubrows i b = concatMap (mkRows False i b) $ asubs acct --- | Build the report totals row.------ Calculate the column totals. These are always the sum of column amounts.-calculateTotalsRow :: ReportOpts -> [MultiBalanceReportRow] -> Int -> PeriodicReportRow () MixedAmount-calculateTotalsRow ropts rows colcount =-    PeriodicReportRow () coltotals grandtotal grandaverage-  where-    isTopRow row = flat_ ropts || not (any (`HM.member` rowMap) parents)-      where parents = init . expandAccountName $ prrFullName row-    rowMap = HM.fromList $ map (\row -> (prrFullName row, row)) rows+    canOmitParents = flat_ ropts || not (no_elide_ ropts)+    balance = case accountlistmode_ ropts of+        ALTree -> bdincludingsubs+        ALFlat -> bdexcludingsubs -    colamts = transpose . map prrAmounts $ filter isTopRow rows+    displayedName d boringParents name+        | d == 0 && name == "root" = DisplayName "..." "..." 0+        | otherwise = case accountlistmode_ ropts of+            ALTree -> DisplayName name leaf $ max 0 d+            ALFlat -> DisplayName name droppedName 0+      where+        leaf = accountNameFromComponents+               . reverse . take (boringParents + 1) . reverse+               $ accountNameComponents droppedName+        droppedName = accountNameDrop (drop_ ropts) name -    coltotals :: [MixedAmount] = dbg5 "coltotals" $ case colamts of-      [] -> replicate colcount nullmixedamt-      _ -> map maSum colamts -    -- Calculate the grand total and average. These are always the sum/average-    -- of the column totals.+-- | Build a report row.+--+-- Calculate the column totals. These are always the sum of column amounts.+makeMultiBalanceReportRow :: ReportOpts -> (BalanceData -> MixedAmount)+                          -> a -> Account BalanceData -> PeriodicReportRow a MixedAmount+makeMultiBalanceReportRow = makePeriodicReportRow nullmixedamt sumAndAverageMixedAmounts++-- | Build a report row.+--+-- Calculate the column totals. These are always the sum of column amounts.+makePeriodicReportRow :: c -> (IM.IntMap c -> (c, c))+                      -> ReportOpts -> (b -> c)+                      -> a -> Account b -> PeriodicReportRow a c+makePeriodicReportRow nullEntry totalAndAverage ropts balance name acct =+    PeriodicReportRow name (toList rowbals) rowtotal avg+  where+    rowbals = fmap balance . pdperiods $ adata acct+    (total, avg) = totalAndAverage rowbals     -- Total for a cumulative/historical report is always the last column.-    grandtotal = case balanceaccum_ ropts of-        PerPeriod -> maSum coltotals-        _         -> lastDef nullmixedamt coltotals-    grandaverage = averageMixedAmounts coltotals+    rowtotal = case balanceaccum_ ropts of+        PerPeriod -> total+        _         -> maybe nullEntry snd $ IM.lookupMax rowbals  -- | Map the report rows to percentages if needed reportPercent :: ReportOpts -> MultiBalanceReport -> MultiBalanceReport@@ -534,31 +495,6 @@         (perdivide rowtotal $ prrTotal totalrow)         (perdivide rowavg $ prrAverage totalrow) ---- | Transpose a Map of HashMaps to a HashMap of Maps.------ Makes sure that all DateSpans are present in all rows.-transposeMap :: [(DateSpan, HashMap AccountName a)]-             -> HashMap AccountName (Map DateSpan a)-transposeMap = foldr (uncurry addSpan) mempty-  where-    addSpan spn acctmap seen = HM.foldrWithKey (addAcctSpan spn) seen acctmap--    addAcctSpan spn acct a = HM.alter f acct-      where f = Just . M.insert spn a . fromMaybe mempty---- | A sorting helper: sort a list of things (eg report rows) keyed by account name--- to match the provided ordering of those same account names.-sortRowsLike :: [AccountName] -> [PeriodicReportRow DisplayName b] -> [PeriodicReportRow DisplayName b]-sortRowsLike sortedas rows = mapMaybe (`HM.lookup` rowMap) sortedas-  where rowMap = HM.fromList $ map (\row -> (prrFullName row, row)) rows---- | Given a list of account names, find all forking parent accounts, i.e.--- those which fork between different branches-subaccountTallies :: [AccountName] -> HashMap AccountName Int-subaccountTallies = foldr incrementParent mempty . expandAccountNames-  where incrementParent a = HM.insertWith (+) (parentAccountName a) 1- -- | A helper: what percentage is the second mixed amount of the first ? -- Keeps the sign of the first amount. -- Uses unifyMixedAmount to unify each argument and then divides them.@@ -572,26 +508,13 @@     return $ mixed [per $ if aquantity b' == 0 then 0 else aquantity a' / abs (aquantity b') * 100]   where errmsg = "Cannot calculate percentages if accounts have different commodities (Hint: Try --cost, -V or similar flags.)" --- Add the values of two accounts. Should be right-biased, since it's used--- in scanl, so other properties (such as anumpostings) stay in the right place-sumAcct :: Account -> Account -> Account-sumAcct Account{aibalance=i1,aebalance=e1} a@Account{aibalance=i2,aebalance=e2} =-    a{aibalance = i1 `maPlus` i2, aebalance = e1 `maPlus` e2}---- Subtract the values in one account from another. Should be left-biased.-subtractAcct :: Account -> Account -> Account-subtractAcct a@Account{aibalance=i1,aebalance=e1} Account{aibalance=i2,aebalance=e2} =-    a{aibalance = i1 `maMinus` i2, aebalance = e1 `maMinus` e2}---- | Extract period changes from a cumulative list-periodChanges :: Account -> Map k Account -> Map k Account-periodChanges start amtmap =-    M.fromDistinctAscList . zip dates $ zipWith subtractAcct amts (start:amts)-  where (dates, amts) = unzip $ M.toAscList amtmap- -- | Calculate a cumulative sum from a list of period changes.-cumulativeSum :: Account -> Map DateSpan Account -> Map DateSpan Account-cumulativeSum start = snd . M.mapAccum (\a b -> let s = sumAcct a b in (s, s)) start+cumulativeSum :: Traversable t => t BalanceData -> t BalanceData+cumulativeSum = snd . mapAccumL (\prev new -> let z = prev <> new in (z, z)) mempty++-- | Extract period changes from a cumulative list.+periodChanges :: Traversable t => t BalanceData -> t BalanceData+periodChanges = snd . mapAccumL (\prev new -> (new, opBalanceData maMinus new prev)) mempty  -- tests 

@@ -243,10 +243,10 @@     summarypes = map (, dateSpanAsPeriod spn) $ (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+    accts = accountsFromPostings (const Nothing) ps     balance a = maybe nullmixedamt bal $ lookupAccount a accts       where-        bal = if isclipped a then aibalance else aebalance+        bal = (if isclipped a then bdincludingsubs else bdexcludingsubs) . pdpre . adata         isclipped a' = maybe False (accountNameLevel a' >=) mdepth  

@@ -52,6 +52,7 @@   journalApplyValuationFromOptsWith,   mixedAmountApplyValuationAfterSumFromOptsWith,   valuationAfterSum,+  requiresHistorical,   intervalFromRawOpts,   queryFromFlags,   transactionDateFn,@@ -664,11 +665,17 @@       CalcGain -> id       _        -> journalToCost costop where costop = fromMaybe NoConversionOp $ conversionop_ ropts -    -- Find the end of the period containing this posting+    -- Find the "end" valuation date for this posting.+    -- With a report interval, this is the last day of the report subperiod containing this posting;+    -- with no interval it's the last date of the overall report period+    -- (which for an end value report may have been extended to include the latest non-future P directive).+    -- To get the period's last day, we subtract one from the (exclusive) period end date.     postingperiodend  = addDays (-1) . fromMaybe err . mPeriodEnd . postingDateOrDate2 (whichDate ropts)-    mPeriodEnd = case interval_ ropts of-        NoInterval -> const . spanEnd . fst $ reportSpan j rspec-        _          -> spanEnd <=< latestSpanContaining (historical : spans)+      where+        mPeriodEnd = case interval_ ropts of+          NoInterval -> const . spanEnd . fst $ reportSpan j rspec+          _          -> spanEnd <=< latestSpanContaining (historical : spans)+     historical = DateSpan Nothing $ (fmap Exact . spanStart) =<< headMay spans     spans = snd $ reportSpanBothDates j rspec     styles = journalCommodityStyles j@@ -677,21 +684,20 @@ -- | Select the Account valuation functions required for performing valuation after summing -- amounts. Used in MultiBalanceReport to value historical and similar reports. mixedAmountApplyValuationAfterSumFromOptsWith :: ReportOpts -> Journal -> PriceOracle-                                              -> (DateSpan -> MixedAmount -> MixedAmount)+                                              -> (Day -> MixedAmount -> MixedAmount) mixedAmountApplyValuationAfterSumFromOptsWith ropts j priceoracle =     case valuationAfterSum ropts of         Just mc -> case balancecalc_ ropts of             CalcGain -> gain mc-            _        -> \spn -> valuation mc spn . costing+            _        -> \d -> valuation mc d . costing         Nothing      -> const id   where-    valuation mc spn = mixedAmountValueAtDate priceoracle styles mc (maybe err (addDays (-1)) $ spanEnd spn)-    gain mc spn = mixedAmountGainAtDate priceoracle styles mc (maybe err (addDays (-1)) $ spanEnd spn)+    valuation mc d = mixedAmountValueAtDate priceoracle styles mc d+    gain mc d = mixedAmountGainAtDate priceoracle styles mc d     costing = case fromMaybe NoConversionOp $ conversionop_ ropts of         NoConversionOp -> id         ToCost         -> styleAmounts styles . mixedAmountCost     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 of the commodity symbol we're converting to, Just Nothing for the default,@@ -699,12 +705,15 @@ -- 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 = balancecalc_  ropts == CalcValueChange-                     || balancecalc_  ropts == CalcGain-                     || balanceaccum_ ropts /= PerPeriod+    Just (AtEnd mc) | requiresHistorical ropts -> Just mc+    _                                          -> Nothing +-- | If the ReportOpts specify that we will need to consider historical+-- postings, either because this is a historical report, or because the+-- valuation strategy requires historical amounts.+requiresHistorical :: ReportOpts -> Bool+requiresHistorical ReportOpts{balanceaccum_ = accum, balancecalc_ = calc} =+    accum == Historical || calc == CalcValueChange || calc == CalcGain  -- | Convert report options to a query, ignoring any non-flag command line arguments. queryFromFlags :: ReportOpts -> Query@@ -763,49 +772,59 @@  -- Report dates. --- | The effective report span is the start and end dates specified by--- options or queries, or otherwise the earliest and latest transaction or--- posting dates in the journal. If no dates are specified by options/queries--- and the journal is empty, returns the null date span.--- Also return the intervals if they are requested.+-- | The effective report span is the start and end dates requested by options or queries.+-- If the start date is unspecified, the earliest transaction or posting date is used.+-- If the end date is unspecified, the latest transaction or posting date+-- (or non-future market price date, when doing an end value report) is used.+-- If none of these things are present, the null date span is returned.+-- The report sub-periods caused by a report interval, if any, are also returned. reportSpan :: Journal -> ReportSpec -> (DateSpan, [DateSpan]) reportSpan = reportSpanHelper False+-- Note: In end value reports, the report end date and valuation date are the same.+-- If valuation date ever needs to be different, journalApplyValuationFromOptsWith is the place. --- | Like reportSpan, but uses both primary and secondary dates when calculating--- the span.+-- | Like reportSpan, but considers both primary and secondary dates, not just one or the other. reportSpanBothDates :: Journal -> ReportSpec -> (DateSpan, [DateSpan]) reportSpanBothDates = reportSpanHelper True --- | A helper for reportSpan, which takes a Bool indicating whether to use both--- primary and secondary dates. reportSpanHelper :: Bool -> Journal -> ReportSpec -> (DateSpan, [DateSpan])-reportSpanHelper bothdates j ReportSpec{_rsQuery=query, _rsReportOpts=ropts} =-    (reportspan, intervalspans)+reportSpanHelper bothdates j ReportSpec{_rsQuery=query, _rsReportOpts=ropts, _rsDay=today} =+  (enlargedreportspan, if not (null intervalspans) then intervalspans else [enlargedreportspan])   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-    -- If we are requesting period-end valuation, the journal date span should-    -- include price directives after the last transaction-    journalspan = dbg3 "journalspan" $ if bothdates then journalDateSpanBothDates j else journalDateSpan (date2_ ropts) j-    pricespan = dbg3 "pricespan" . DateSpan Nothing $ case value_ ropts of-        Just (AtEnd _) -> fmap (Exact . addDays 1) . maximumMay . map pddate $ jpricedirectives j-        _              -> Nothing-    -- If the requested span is open-ended, close it using the journal's start and end dates.-    -- This can still be the null (open) span if the journal is empty.-    requestedspan' = dbg3 "requestedspan'" $ requestedspan `spanDefaultsFrom` (journalspan `spanExtend` pricespan)+    requestedspan = dbg3 "requestedspan" $+      if bothdates then queryDateSpan' query else queryDateSpan (date2_ ropts) query++    -- If the requested span has open ends, fill them with defaults.+    reportspan = dbg3 "reportspan" $ requestedspan `spanValidDefaultsFrom` txnsorpricespan+      where+        txnsorpricespan = dbg3 "txnsorpricespan" $ DateSpan mfirsttxn mlatesttxnorprice+          where+            DateSpan mfirsttxn mlasttxn = dbg3 "txnsspan" $+              if bothdates then journalDateSpanBothDates j else journalDateSpan (date2_ ropts) j+            mlatesttxnorprice =+              case value_ ropts of+                Just (AtEnd _) -> mlasttxn `max` mlatestnonfutureprice+                _              -> mlasttxn+              where+                mlatestnonfutureprice = dbg3 "latestnonfutureprice" $ -- #2445+                  fmap (Exact . addDays 1) . maximumMay . filter (not . (> today)) . map pddate $ jpricedirectives j+     -- The list of interval spans enclosing the requested span.     -- This list can be empty if the journal was empty,     -- or if hledger-ui has added its special date:-tomorrow to the query     -- and all txns are in the future.-    intervalspans  = dbg3 "intervalspans" $ splitSpan adjust (interval_ ropts) requestedspan'+    intervalspans = dbg3 "intervalspans" $ splitSpan adjust (interval_ ropts) reportspan       where         -- When calculating report periods, we will adjust the start date back to the nearest interval boundary         -- unless a start date was specified explicitly.         adjust = isNothing $ spanStart requestedspan+     -- The requested span enlarged to enclose a whole number of intervals.     -- This can be the null span if there were no intervals.-    reportspan = dbg3 "reportspan" $ DateSpan (fmap Exact . spanStart =<< headMay intervalspans)-                                              (fmap Exact . spanEnd =<< lastMay intervalspans)+    enlargedreportspan = dbg3 "enlargedreportspan" $+      DateSpan (fmap Exact . spanStart =<< headMay intervalspans)+               (fmap Exact . spanEnd =<< lastMay intervalspans)  reportStartDate :: Journal -> ReportSpec -> Maybe Day reportStartDate j = spanStart . fst . reportSpan j

@@ -24,6 +24,7 @@   minimumStrict,   splitAtElement,   sumStrict,+  all1,    -- * Trees   treeLeaves,@@ -173,6 +174,12 @@ {-# INLINABLE sumStrict #-} sumStrict :: Num a => [a] -> a sumStrict = foldl' (+) 0++-- | Version of all that fails on an empty list.+{-# INLINABLE all1 #-}+all1 :: (a -> Bool) -> [a] -> Bool+all1 _ [] = False+all1 p as = all p as  -- Trees 

@@ -23,6 +23,7 @@   error',   usageError,   warn,+  warnIO,   ansiFormatError,   ansiFormatWarning,   printError,@@ -52,6 +53,7 @@    -- * Command line parsing   progArgs,+  getFlag,   getOpt,   parseYN,   parseYNA,@@ -130,7 +132,6 @@ import           Data.Functor ((<&>)) import           Data.List hiding (uncons) import           Data.Maybe (isJust, catMaybes)-import           Data.Ord (comparing, Down (Down)) import qualified Data.Text as T import           Data.Text.Encoding.Error (UnicodeException) import qualified Data.Text.IO as T@@ -160,6 +161,7 @@ import           Text.Pretty.Simple (CheckColorTty(..), OutputOptions(..), defaultOutputOptionsDarkBg, defaultOutputOptionsNoColor, pShowOpt, pPrintOpt)  import Hledger.Utils.Text (WideBuilder(WideBuilder))+import Control.Monad.IO.Class (MonadIO, liftIO)   -- Pretty showing/printing@@ -217,17 +219,21 @@ ansiFormatError :: String -> String ansiFormatError = (<> sgrresetall) . ((sgrbrightred <> sgrbold) <>) --- | Show a message, with "Warning:" label, on stderr before returning the given value.--- Also do some ANSI styling of the first line when allowed (using unsafe IO).--- Currently we use this very sparingly in hledger; we prefer to either quietly work,--- or loudly raise an error. (Varying output can make scripting harder.)+-- | Show a warning message on stderr before returning the given value.+-- Like trace, but prepends a "Warning:" label, and does some ANSI styling of the first line when allowed (using unsafe IO).+-- Currently we use this very sparingly in hledger; we prefer to either quietly work, or loudly raise an error.+-- Varying output can make scripting harder. But on stderr, it shouldn't cause much hassle. warn :: String -> a -> a-warn msg = trace msg'-  where-    msg' =-      (if useColorOnStderrUnsafe then modifyFirstLine ansiFormatWarning else id) $-      "Warning: "<> msg+warn = trace . formatWarning +-- | Like warn, but take extra care to sequence properly in IO.+warnIO :: MonadIO m => String -> m ()+warnIO = liftIO . traceIO . formatWarning++formatWarning =+  (if useColorOnStderrUnsafe then modifyFirstLine ansiFormatWarning else id) .+  ("Warning: " <>)+ -- | Apply standard ANSI SGR formatting (yellow, bold) suitable for console warning text. ansiFormatWarning :: String -> String ansiFormatWarning = (<> sgrresetall) . ((sgrbrightyellow <> sgrbold) <>)@@ -238,9 +244,8 @@ modifyFirstLine :: (String -> String) -> String -> String modifyFirstLine f s = intercalate "\n" $ map f l <> ls where (l,ls) = splitAt 1 $ lines s  -- total -{- | Print an error message to stderr, with a consistent "programname: " prefix,-and applying ANSI styling (bold bright red) to the first line if that is supported and allowed.--}+-- | Print an error message to stderr, with a consistent "programname: " prefix,+-- and applying ANSI styling (bold bright red) to the first line if that is supported and allowed. printError :: String -> IO () printError msg = do   progname <- getProgName@@ -256,9 +261,8 @@         <> (if "Error:" `isPrefixOf` msg then "" else "Error: ")   hPutStrLn stderr $ style $ prefix <> msg -{- | Print an error message with printError,-then exit the program with a non-zero exit code.--}+-- | Print an error message with printError,+-- then exit the program with a non-zero exit code. exitWithErrorMessage :: String -> IO () exitWithErrorMessage msg = printError msg >> exitFailure @@ -415,11 +419,11 @@ expandGlob :: FilePath -> FilePath -> IO [FilePath] expandGlob curdir p = expandPath curdir p >>= glob <&> sort  -- PARTIAL: --- | Given a list of existing file paths, sort them by modification time, most recent first.+-- | Given a list of existing file paths, sort them by modification time (from oldest to newest). sortByModTime :: [FilePath] -> IO [FilePath] sortByModTime fs = do   ftimes <- forM fs $ \f -> do {t <- getModificationTime f; return (t,f)}-  return $ map snd $ sortBy (comparing Data.Ord.Down) ftimes+  return $ map snd $ sort ftimes  -- | Like readFilePortably, but read all of the file before proceeding. readFileStrictly :: FilePath -> IO T.Text@@ -502,6 +506,15 @@ --  a few cases involving --color (see useColorOnStdoutUnsafe) --  --debug +-- | Given one or more long or short flag names,+-- report whether this flag is present in the command line.+-- Concatenated short flags (-a -b written as -ab) are not supported.+getFlag :: [String] -> IO Bool+getFlag names = do+  let flags = map toFlag names+  args <- getArgs+  return $ any (`elem` args) flags+ -- | Given one or more long or short option names, read the rightmost value of this option from the command line arguments. -- If the value is missing raise an error. -- Concatenated short flags (-a -b written as -ab) are not supported.@@ -614,7 +627,6 @@ --   --chop-long-lines --   --hilite-unread --   --ignore-case---   --mouse --   --no-init --   --quit-at-eof --   --quit-if-one-screen@@ -636,7 +648,6 @@        "--chop-long-lines"       ,"--hilite-unread"       ,"--ignore-case"-      ,"--mouse"       ,"--no-init"       ,"--quit-at-eof"       ,"--quit-if-one-screen"@@ -765,7 +776,7 @@  -- | Detect whether ANSI should be used on stdout using useColorOnStdoutUnsafe, -- and if so prepend and append the given SGR codes to a string.--- Currently used in a few places (the commands list, the demo command, the recentassertions error message);+-- Currently used in a few places (the commands list, the recentassertions error message, add, demo); -- see useColorOnStdoutUnsafe's limitations. ansiWrapUnsafe :: SGRString -> SGRString -> String -> String ansiWrapUnsafe pre post s = if useColorOnStdoutUnsafe then pre<>s<>post else s

@@ -101,10 +101,9 @@ import Data.List import Data.Text (Text) import Text.Megaparsec.Char--- import Text.Megaparsec.Debug (dbg)  -- from megaparsec 9.3++-- import Text.Megaparsec.Debug (dbg)  import Control.Monad.Except (ExceptT, MonadError, catchError, throwError)--- import Control.Monad.State.Strict (StateT, evalStateT) import Control.Monad.Trans.Class (lift) import qualified Data.List.NonEmpty as NE import Data.Monoid (Alt(..))@@ -165,13 +164,11 @@ parsewith p = runParser p ""  -- | Run a text parser in the identity monad. See also: parseWithState.-runTextParser, rtp-  :: TextParser Identity a -> Text -> Either HledgerParseErrors a+runTextParser, rtp :: TextParser Identity a -> Text -> Either HledgerParseErrors a runTextParser = parsewith rtp = runTextParser -parsewithString-  :: Parsec e String a -> String -> Either (ParseErrorBundle String e) a+parsewithString :: Parsec e String a -> String -> Either (ParseErrorBundle String e) a parsewithString p = runParser p ""  -- | Run a stateful parser with some initial state on a text.@@ -192,20 +189,16 @@   -> (Either (ParseErrorBundle s e) a) parseWithState' ctx p = runParser (evalStateT p ctx) "" -fromparse-  :: (Show t, Show (Token t), Show e) => Either (ParseErrorBundle t e) a -> a+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 = errorWithoutStackTrace $ showParseError e  -- PARTIAL: -showParseError-  :: (Show t, Show (Token t), Show e)-  => ParseErrorBundle t e -> String+showParseError :: (Show t, Show (Token t), Show e) => ParseErrorBundle t e -> String showParseError e = "parse error at " ++ show e -showDateParseError-  :: (Show t, Show (Token t), Show e) => ParseErrorBundle t e -> String+showDateParseError :: (Show t, Show (Token t), Show e) => ParseErrorBundle t e -> String showDateParseError e = printf "date parse error (%s)" (intercalate ", " $ tailErr $ lines $ show e)  -- PARTIAL tailError won't be null because showing a parse error  isNewline :: Char -> Bool @@ -295,7 +288,6 @@ -- | Fail at a specific source position, given by the raw offset from the -- start of the input stream (the number of tokens processed at that -- point).- parseErrorAt :: Int -> String -> HledgerParseErrorData parseErrorAt offset = ErrorFailAt offset (offset+1) @@ -305,7 +297,6 @@ -- -- Note that care must be taken to ensure that the specified interval does -- not span multiple lines of the input source. This will not be checked.- parseErrorAtRegion   :: Int    -- ^ Start offset   -> Int    -- ^ End end offset@@ -325,12 +316,10 @@ -- data type is to preserve the content and source position of the excerpt -- so that parse errors raised during "re-parsing" may properly reference -- the original source.- data SourceExcerpt = SourceExcerpt Int  -- Offset of beginning of excerpt                                    Text -- Fragment of source file  -- | Get the raw text of a source excerpt.- getExcerptText :: SourceExcerpt -> Text getExcerptText (SourceExcerpt _ txt) = txt @@ -454,22 +443,17 @@ -- (1) it should be possible to convert any parse error into a "final" -- parse error, -- (2) it should be possible to take a parse error thrown from an include--- file and re-throw it in the parent file, and+-- file and re-throw it in the context of the parent file, and -- (3) the pretty-printing of "final" parse errors should be consistent--- with that of ordinary parse errors, but should also report a stack of--- files for errors thrown from include files.+-- with that of ordinary parse errors, but should also report the stack of+-- parent files when errors are thrown from included files. -- -- In order to pretty-print a "final" parse error (goal 3), it must be -- bundled with include filepaths and its full source text. When a "final" -- parse error is thrown from within a parser, we do not have access to--- the full source, so we must hold the parse error until it can be joined--- with its source (and include filepaths, if it was thrown from an--- include file) by the parser's caller.------ A parse error with include filepaths and its full source text is--- represented by the 'FinalParseErrorBundle' type, while a parse error in--- need of either include filepaths, full source text, or both is--- represented by the 'FinalParseError' type.+-- the full source, so we must hold the parse error ('FinalParseError') +-- until it can be combined with the full source (and any parent file paths)+-- by the parser's caller ('FinalParseErrorBundle').  data FinalParseError' e   -- a parse error thrown as a "final" parse error@@ -502,7 +486,6 @@ -- Megaparsec's 'ParseErrorBundle' type already bundles a parse error with -- its full source text and filepath, so we just add a stack of include -- files.- data FinalParseErrorBundle' e = FinalParseErrorBundle'   { finalErrorBundle :: ParseErrorBundle Text e   , includeFileStack :: [FilePath]@@ -514,12 +497,10 @@ --- * Constructing and throwing final parse errors  -- | Convert a "regular" parse error into a "final" parse error.- finalError :: ParseError Text e -> FinalParseError' e finalError = FinalError  -- | Like megaparsec's 'fancyFailure', but as a "final" parse error.- finalFancyFailure   :: (MonadParsec e s m, MonadError (FinalParseError' e) m)   => S.Set (ErrorFancy e) -> m a@@ -528,25 +509,19 @@   throwError $ FinalError $ FancyError offset errSet  -- | Like 'fail', but as a "final" parse error.--finalFail-  :: (MonadParsec e s m, MonadError (FinalParseError' e) m) => String -> m a+finalFail :: (MonadParsec e s m, MonadError (FinalParseError' e) m) => String -> m a finalFail = finalFancyFailure . S.singleton . ErrorFail  -- | Like megaparsec's 'customFailure', but as a "final" parse error.--finalCustomFailure-  :: (MonadParsec e s m, MonadError (FinalParseError' e) m) => e -> m a+finalCustomFailure :: (MonadParsec e s m, MonadError (FinalParseError' e) m) => e -> m a finalCustomFailure = finalFancyFailure . S.singleton . ErrorCustom   --- * Pretty-printing "final" parse errors  -- | Pretty-print a "final" parse error: print the stack of include files,--- then apply the pretty-printer for parse error bundles. Note that--- 'attachSource' must be used on a "final" parse error before it can be--- pretty-printed.-+-- then apply the pretty-printer for parse error bundles.+-- Note that 'attachSource' must be used on a "final" parse error before it can be pretty-printed. finalErrorBundlePretty :: FinalParseErrorBundle' HledgerParseErrorData -> String finalErrorBundlePretty bundle =      concatMap showIncludeFilepath (includeFileStack bundle)@@ -554,12 +529,9 @@   where     showIncludeFilepath path = "in file included from " <> path <> ",\n" --- | Supply a filepath and source text to a "final" parse error so that it--- can be pretty-printed. You must ensure that you provide the appropriate--- source text and filepath.--attachSource-  :: FilePath -> Text -> FinalParseError' e -> FinalParseErrorBundle' e+-- | Attach a filepath and source text to a "final" parse error so that it can be pretty-printed.+-- You must ensure that you provide the appropriate source text and filepath.+attachSource :: FilePath -> Text -> FinalParseError' e -> FinalParseErrorBundle' e attachSource filePath sourceText finalParseError = case finalParseError of    -- A parse error thrown directly with the 'FinalError' constructor@@ -586,9 +558,9 @@  --- * Handling parse errors from include files with "final" parse errors --- | Parse a file with the given parser and initial state, discarding the--- final state and re-throwing any parse errors as "final" parse errors.-+-- | Parse an include file with the given parser and initial state,+-- discarding the resulting state,+-- and re-throwing any parse errors as final parse errors with the file's info attached. parseIncludeFile   :: Monad m   => StateT st (ParsecT HledgerParseErrorData Text (ExceptT FinalParseError m)) a@@ -596,26 +568,22 @@   -> FilePath   -> Text   -> StateT st (ParsecT HledgerParseErrorData Text (ExceptT FinalParseError m)) a-parseIncludeFile parser initialState filepath text =-  catchError parser' handler+parseIncludeFile parser initialState filepath text = catchError parser' handler   where     parser' = do-      eResult <- lift $ lift $-                  runParserT (evalStateT parser initialState) filepath text+      eResult <- lift $ lift $ runParserT (evalStateT parser initialState) filepath text       case eResult of         Left parseErrorBundle -> throwError $ FinalBundle parseErrorBundle         Right result -> pure result-     -- Attach source and filepath of the include file to its parse errors     handler e = throwError $ FinalBundleWithStack $ attachSource filepath text e   --- * Helpers --- Like megaparsec's 'initialState', but instead for 'PosState'. Used when--- constructing 'ParseErrorBundle's. The values for "tab width" and "line--- prefix" are taken from 'initialState'.-+-- | Like megaparsec's 'initialState', but instead for 'PosState'.+-- Used when constructing 'ParseErrorBundle's.+-- The values for "tab width" and "line prefix" are taken from 'initialState'. initialPosState :: FilePath -> Text -> PosState Text initialPosState filePath sourceText = PosState   { pstateInput      = sourceText

@@ -78,8 +78,7 @@ import Text.Regex.TDFA (   Regex, CompOption(..), defaultCompOpt, defaultExecOpt,   makeRegexOptsM, AllMatches(getAllMatches), match, MatchText,-  RegexLike(..), RegexMaker(..), RegexOptions(..), RegexContext(..),-  (=~)+  RegexLike(..), RegexMaker(..), RegexOptions(..), RegexContext(..)   )  @@ -179,8 +178,8 @@ -- Regex to a Text. regexMatchTextGroups :: Regexp -> Text -> [Text] regexMatchTextGroups r txt = let-    pat = reString r-    (_,_,_,matches) = txt =~ pat :: (Text,Text,Text,[Text])+    pat = reCompiled r+    (_,_,_,matches) = match pat txt :: (Text,Text,Text,[Text])     in matches  --------------------------------------------------------------------------------

@@ -1,11 +1,11 @@ cabal-version: 2.2 --- This file has been generated from package.yaml by hpack version 0.38.0.+-- This file has been generated from package.yaml by hpack version 0.38.2. -- -- see: https://github.com/sol/hpack  name:           hledger-lib-version:        1.43.2+version:        1.50 synopsis:       A library providing the core functionality of hledger description:    This library contains hledger's core functionality.                 It is used by most hledger* packages so that they support the same@@ -34,7 +34,7 @@ license-file:   LICENSE build-type:     Simple tested-with:-    ghc==8.10.7, ghc==9.0.2, ghc==9.2.8, ghc==9.4.8, ghc==9.6.7, ghc==9.8.4, ghc==9.10.2, ghc==9.12.1+    ghc==9.6.7, ghc==9.8.4, ghc==9.10.2, ghc==9.12.2 extra-source-files:     CHANGES.md     README.md@@ -115,6 +115,8 @@       Text.Tabular.AsciiWide       Text.WideString   other-modules:+      Hledger.Data.BalanceData+      Hledger.Data.PeriodData       Paths_hledger_lib   autogen-modules:       Paths_hledger_lib@@ -128,7 +130,7 @@     , aeson-pretty     , ansi-terminal >=0.9     , array-    , base >=4.14 && <4.22+    , base >=4.18 && <4.22     , blaze-html     , blaze-markup >=0.5.1     , bytestring@@ -163,6 +165,7 @@     , template-haskell     , terminal-size >=0.3.3     , text >=1.2.4.1+    , these >=1.0.0     , time >=1.5     , timeit     , transformers >=0.2@@ -186,7 +189,7 @@     , aeson-pretty     , ansi-terminal >=0.9     , array-    , base >=4.14 && <4.22+    , base >=4.18 && <4.22     , blaze-html     , blaze-markup >=0.5.1     , bytestring@@ -222,6 +225,7 @@     , template-haskell     , terminal-size >=0.3.3     , text >=1.2.4.1+    , these >=1.0.0     , time >=1.5     , timeit     , transformers >=0.2@@ -247,7 +251,7 @@     , aeson-pretty     , ansi-terminal >=0.9     , array-    , base >=4.14 && <4.22+    , base >=4.18 && <4.22     , blaze-html     , blaze-markup >=0.5.1     , bytestring@@ -283,6 +287,7 @@     , template-haskell     , terminal-size >=0.3.3     , text >=1.2.4.1+    , these >=1.0.0     , time >=1.5     , timeit     , transformers >=0.2