hledger-lib 1.26.1 → 1.27

raw patch · 41 files changed

+1337/−686 lines, 41 filesdep +breakpointdep +deepseqdep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: breakpoint, deepseq

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• CHANGES.md +49/−0
• Hledger/Data/Account.hs +3/−3
• Hledger/Data/AccountName.hs +7/−7
• Hledger/Data/Amount.hs +30/−31
• Hledger/Data/Balancing.hs +85/−59
• Hledger/Data/Dates.hs +45/−38
• Hledger/Data/Errors.hs +44/−0
• Hledger/Data/Journal.hs +60/−142
• Hledger/Data/JournalChecks.hs +156/−26
• Hledger/Data/JournalChecks/Ordereddates.hs +19/−17
• Hledger/Data/JournalChecks/Uniqueleafnames.hs +28/−26
• Hledger/Data/Period.hs +1/−1
• Hledger/Data/PeriodicTransaction.hs +5/−3
• Hledger/Data/Posting.hs +19/−12
• Hledger/Data/StringFormat.hs +2/−3
• Hledger/Data/Timeclock.hs +35/−13
• Hledger/Data/Transaction.hs +133/−3
• Hledger/Data/TransactionModifier.hs +1/−1
• Hledger/Data/Types.hs +3/−1
• Hledger/Data/Valuation.hs +1/−1
• Hledger/Query.hs +27/−27
• Hledger/Read.hs +10/−9
• Hledger/Read/Common.hs +54/−43
• Hledger/Read/CsvReader.hs +145/−47
• Hledger/Read/InputOptions.hs +2/−0
• Hledger/Read/JournalReader.hs +51/−28
• Hledger/Read/TimedotReader.hs +2/−3
• Hledger/Reports/AccountTransactionsReport.hs +14/−12
• Hledger/Reports/BudgetReport.hs +70/−27
• Hledger/Reports/MultiBalanceReport.hs +28/−29
• Hledger/Reports/PostingsReport.hs +6/−6
• Hledger/Reports/ReportOptions.hs +18/−16
• Hledger/Reports/ReportTypes.hs +1/−1
• Hledger/Utils.hs +4/−4
• Hledger/Utils/Debug.hs +108/−15
• Hledger/Utils/Parse.hs +1/−0
• Hledger/Utils/Regex.hs +14/−14
• Hledger/Utils/String.hs +33/−3
• Text/Megaparsec/Custom.hs +6/−4
• Text/Tabular/AsciiWide.hs +2/−2
• hledger-lib.cabal +15/−9

@@ -9,6 +9,55 @@ Internal/api/developer-ish changes in the hledger-lib (and hledger) packages. For user-visible changes, see the hledger package changelog. +# 1.27 2022-09-01++Breaking changes++- Support for GHC 8.6 and 8.8 has been dropped.+  hledger now requires GHC 8.10 or newer.++- Hledger.Data.Amount: `amount` has been dropped; use `nullamt` instead.++- journal*AccountQuery functions have been dropped; use a type: query instead.+  cbcsubreportquery no longer takes Journal as an argument.+  (#1921)++Misc. changes++- Hledger.Utils.Debug now re-exports Debug.Breakpoint from the+  breakpoint library, so that breakpoint's helpers can be used easily+  during development.++- Hledger.Utils.Debug:+  dlog has been replaced by more reliable functions for debug-logging+  to a file (useful for debugging TUI apps like hledger-ui):++  dlogTrace+  dlogTraceAt+  dlogAt+  dlog0+  dlog1+  dlog2+  dlog3+  dlog4+  dlog5+  dlog6+  dlog7+  dlog8+  dlog9++- Hledger.Utils.Debug: pprint' and pshow' have been added,+  forcing monochrome output.++- Hledger.Utils.String: add quoteForCommandLine++- Hledger.Data.Errors: export makeBalanceAssertionErrorExcerpt++- Hledger.Utils.Parse: export HledgerParseErrors++- Debug logging from journalFilePath and the include directive will+  now show "(unknown)" instead of an empty string.+ # 1.26.1 2022-07-11  - require safe 0.3.19+ to avoid deprecation warning

@@ -104,10 +104,10 @@ accountTree rootname as = nullacct{aname=rootname, asubs=map (uncurry accountTree') $ M.assocs m }   where     T m = treeFromPaths $ map expandAccountName as :: FastTree AccountName-    accountTree' a (T m) =+    accountTree' a (T m') =       nullacct{         aname=a-       ,asubs=map (uncurry accountTree') $ M.assocs m+       ,asubs=map (uncurry accountTree') $ M.assocs m'        }  -- | An efficient-to-build tree suggested by Cale Gibbard, probably@@ -223,7 +223,7 @@ -- tree's structure remains intact and can still be used. It's a tree/list! flattenAccounts :: Account -> [Account] flattenAccounts a = squish a []-  where squish a as = a : Prelude.foldr squish as (asubs a)+  where squish a' as = a' : Prelude.foldr squish as (asubs a')  -- | Filter an account tree (to a list). filterAccounts :: (Account -> Bool) -> Account -> [Account]

@@ -177,12 +177,12 @@ -- Or, return any error arising from a bad regular expression in the aliases. accountNameApplyAliases :: [AccountAlias] -> AccountName -> Either RegexError AccountName accountNameApplyAliases aliases a =-  let (aname,atype) = (accountNameWithoutPostingType a, accountNamePostingType a)+  let (name,typ) = (accountNameWithoutPostingType a, accountNamePostingType a)   in foldM      (\acct alias -> dbg6 "result" $ aliasReplace (dbg6 "alias" alias) (dbg6 "account" acct))-     aname+     name      aliases-     >>= Right . accountNameWithPostingType atype+     >>= Right . accountNameWithPostingType typ  -- | Memoising version of accountNameApplyAliases, maybe overkill. accountNameApplyAliasesMemo :: [AccountAlias] -> AccountName -> Either RegexError AccountName@@ -238,7 +238,7 @@ parentAccountNames a = parentAccountNames' $ parentAccountName a     where       parentAccountNames' "" = []-      parentAccountNames' a = a : parentAccountNames' (parentAccountName a)+      parentAccountNames' a2 = a2 : parentAccountNames' (parentAccountName a2)  -- | Is the first account a parent or other ancestor of (and not the same as) the second ? isAccountNamePrefixOf :: AccountName -> AccountName -> Bool@@ -296,9 +296,9 @@     fitText Nothing (Just width) True False $ accountNameFromComponents $ elideparts width [] $ accountNameComponents s       where         elideparts :: Int -> [Text] -> [Text] -> [Text]-        elideparts width done ss-          | realLength (accountNameFromComponents $ done++ss) <= width = done++ss-          | length ss > 1 = elideparts width (done++[textTakeWidth 2 $ head ss]) (tail ss)+        elideparts w done ss+          | realLength (accountNameFromComponents $ done++ss) <= w = done++ss+          | length ss > 1 = elideparts w (done++[textTakeWidth 2 $ head ss]) (tail ss)           | otherwise = done++ss  -- | Keep only the first n components of an account name, where n

@@ -49,7 +49,6 @@   isNonsimpleCommodityChar,   quoteCommoditySymbolIfNeeded,   -- * Amount-  amount,   nullamt,   missingamt,   num,@@ -256,22 +255,22 @@     (*)                          = similarAmountsOp (*)  -- | The empty simple amount.-amount, nullamt :: Amount-amount = Amount{acommodity="", aquantity=0, aprice=Nothing, astyle=amountstyle}-nullamt = amount+nullamt :: Amount+nullamt = Amount{acommodity="", aquantity=0, aprice=Nothing, astyle=amountstyle}  -- | A temporary value for parsed transactions which had no amount specified. missingamt :: Amount-missingamt = amount{acommodity="AUTO"}+missingamt = nullamt{acommodity="AUTO"}  -- Handy amount constructors for tests. -- usd/eur/gbp round their argument to a whole number of pennies/cents.-num n = amount{acommodity="",  aquantity=n}-hrs n = amount{acommodity="h", aquantity=n,           astyle=amountstyle{asprecision=Precision 2, ascommodityside=R}}-usd n = amount{acommodity="$", aquantity=roundTo 2 n, astyle=amountstyle{asprecision=Precision 2}}-eur n = amount{acommodity="€", aquantity=roundTo 2 n, astyle=amountstyle{asprecision=Precision 2}}-gbp n = amount{acommodity="£", aquantity=roundTo 2 n, astyle=amountstyle{asprecision=Precision 2}}-per n = amount{acommodity="%", aquantity=n,           astyle=amountstyle{asprecision=Precision 1, ascommodityside=R, ascommodityspaced=True}}+-- XXX these are a bit clashy+num n = nullamt{acommodity="",  aquantity=n}+hrs n = nullamt{acommodity="h", aquantity=n,           astyle=amountstyle{asprecision=Precision 2, ascommodityside=R}}+usd n = nullamt{acommodity="$", aquantity=roundTo 2 n, astyle=amountstyle{asprecision=Precision 2}}+eur n = nullamt{acommodity="€", aquantity=roundTo 2 n, astyle=amountstyle{asprecision=Precision 2}}+gbp n = nullamt{acommodity="£", aquantity=roundTo 2 n, astyle=amountstyle{asprecision=Precision 2}}+per n = nullamt{acommodity="%", aquantity=n,           astyle=amountstyle{asprecision=Precision 1, ascommodityside=R, ascommodityspaced=True}} amt `at` priceamt = amt{aprice=Just $ UnitPrice priceamt} amt @@ priceamt = amt{aprice=Just $ TotalPrice priceamt} @@ -286,7 +285,7 @@ similarAmountsOp op Amount{acommodity=_,  aquantity=q1, astyle=AmountStyle{asprecision=p1}}                     Amount{acommodity=c2, aquantity=q2, astyle=s2@AmountStyle{asprecision=p2}} =    -- trace ("a1:"++showAmountDebug a1) $ trace ("a2:"++showAmountDebug a2) $ traceWith (("= :"++).showAmountDebug)-   amount{acommodity=c2, aquantity=q1 `op` q2, astyle=s2{asprecision=max p1 p2}}+   nullamt{acommodity=c2, aquantity=q1 `op` q2, astyle=s2{asprecision=max p1 p2}}   --  c1==c2 || q1==0 || q2==0 =   --  otherwise = error "tried to do simple arithmetic with amounts in different commodities" @@ -314,8 +313,8 @@ transformAmount :: (Quantity -> Quantity) -> Amount -> Amount transformAmount f a@Amount{aquantity=q,aprice=p} = a{aquantity=f q, aprice=f' <$> p}   where-    f' (TotalPrice a@Amount{aquantity=pq}) = TotalPrice a{aquantity = f pq}-    f' p = p+    f' (TotalPrice a1@Amount{aquantity=pq}) = TotalPrice a1{aquantity = f pq}+    f' p' = p'  -- | Divide an amount's quantity (and its total price, if it has one) by a constant. divideAmount :: Quantity -> Amount -> Amount@@ -522,15 +521,15 @@ applyDigitGroupStyle :: Maybe DigitGroupStyle -> Int -> T.Text -> WideBuilder applyDigitGroupStyle Nothing                       l s = WideBuilder (TB.fromText s) l applyDigitGroupStyle (Just (DigitGroups _ []))     l s = WideBuilder (TB.fromText s) l-applyDigitGroupStyle (Just (DigitGroups c (g:gs))) l s = addseps (g:|gs) (toInteger l) s+applyDigitGroupStyle (Just (DigitGroups c (g0:gs0))) l0 s0 = addseps (g0:|gs0) (toInteger l0) s0   where-    addseps (g:|gs) l s-        | l' > 0    = addseps gs' l' rest <> WideBuilder (TB.singleton c <> TB.fromText part) (fromIntegral g + 1)-        | otherwise = WideBuilder (TB.fromText s) (fromInteger l)+    addseps (g1:|gs1) l1 s1+        | l2 > 0    = addseps gs2 l2 rest <> WideBuilder (TB.singleton c <> TB.fromText part) (fromIntegral g1 + 1)+        | otherwise = WideBuilder (TB.fromText s1) (fromInteger l1)       where-        (rest, part) = T.splitAt (fromInteger l') s-        gs' = fromMaybe (g:|[]) $ nonEmpty gs-        l' = l - toInteger g+        (rest, part) = T.splitAt (fromInteger l2) s1+        gs2 = fromMaybe (g1:|[]) $ nonEmpty gs1+        l2 = l1 - toInteger g1  -- like journalCanonicaliseAmounts -- | Canonicalise an amount's display style using the provided commodity style map.@@ -702,11 +701,11 @@ unifyMixedAmount :: MixedAmount -> Maybe Amount unifyMixedAmount = foldM combine 0 . amounts   where-    combine amount result-      | amountIsZero amount                    = Just result-      | amountIsZero result                    = Just amount-      | acommodity amount == acommodity result = Just $ amount + result-      | otherwise                              = Nothing+    combine amt result+      | amountIsZero amt                    = Just result+      | amountIsZero result                 = Just amt+      | acommodity amt == acommodity result = Just $ amt + result+      | otherwise                           = Nothing  -- | Sum same-commodity amounts in a lossy way, applying the first -- price to the result and discarding any other prices. Only used as a@@ -839,10 +838,10 @@ showMixedAmountB :: AmountDisplayOpts -> MixedAmount -> WideBuilder showMixedAmountB opts ma     | displayOneLine opts = showMixedAmountOneLineB opts ma-    | otherwise           = WideBuilder (wbBuilder . mconcat $ intersperse sep lines) width+    | otherwise           = WideBuilder (wbBuilder . mconcat $ intersperse sep ls) width   where-    lines = showMixedAmountLinesB opts ma-    width = headDef 0 $ map wbWidth lines+    ls = showMixedAmountLinesB opts ma+    width = headDef 0 $ map wbWidth ls     sep = WideBuilder (TB.singleton '\n') 0  -- | Helper for showMixedAmountB to show a list of Amounts on multiple lines. This returns@@ -900,7 +899,7 @@     dropWhileRev p = foldr (\x xs -> if null xs && p x then [] else x:xs) []      -- Add the elision strings (if any) to each amount-    withElided = zipWith (\num amt -> (amt, elisionDisplay Nothing (wbWidth sep) num amt)) [n-1,n-2..0]+    withElided = zipWith (\n2 amt -> (amt, elisionDisplay Nothing (wbWidth sep) n2 amt)) [n-1,n-2..0]  orderedAmounts :: AmountDisplayOpts -> MixedAmount -> [Amount] orderedAmounts dopts = maybe id (mapM pad) (displayOrder dopts) . amounts@@ -981,7 +980,7 @@        amountCost (eur (-1)){aprice=Just $ TotalPrice $ usd (-2)} @?= usd (-2)      ,testCase "amountLooksZero" $ do-       assertBool "" $ amountLooksZero amount+       assertBool "" $ amountLooksZero nullamt        assertBool "" $ amountLooksZero $ usd 0      ,testCase "negating amounts" $ do

@@ -18,7 +18,6 @@ , isTransactionBalanced , balanceTransaction , balanceTransactionHelper-, annotateErrorWithTransaction   -- * journal balancing , journalBalanceTransactions , journalCheckBalanceAssertions@@ -36,7 +35,7 @@ import Data.Function ((&)) import qualified Data.HashTable.Class as H (toList) import qualified Data.HashTable.ST.Cuckoo as H-import Data.List (intercalate, partition, sortOn)+import Data.List (partition, sortOn) import Data.List.Extra (nubSort) import Data.Maybe (fromJust, fromMaybe, isJust, isNothing, mapMaybe) import qualified Data.Set as S@@ -50,10 +49,10 @@ import Hledger.Data.Types import Hledger.Data.AccountName (isAccountNamePrefixOf) import Hledger.Data.Amount-import Hledger.Data.Dates (showDate) import Hledger.Data.Journal import Hledger.Data.Posting import Hledger.Data.Transaction+import Hledger.Data.Errors   data BalancingOpts = BalancingOpts@@ -98,16 +97,18 @@      -- check for mixed signs, detecting nonzeros at display precision     canonicalise = maybe id canonicaliseMixedAmount commodity_styles_+    postingBalancingAmount p+      | "_price-matched" `elem` map fst (ptags p) = mixedAmountStripPrices $ pamount p+      | otherwise                                 = mixedAmountCost $ pamount p     signsOk ps =-      case filter (not.mixedAmountLooksZero) $ map (canonicalise.mixedAmountCost.pamount) ps of+      case filter (not.mixedAmountLooksZero) $ map (canonicalise.postingBalancingAmount) ps of         nonzeros | length nonzeros >= 2                    -> length (nubSort $ mapMaybe isNegativeMixedAmount nonzeros) > 1         _          -> True     (rsignsok, bvsignsok)       = (signsOk rps, signsOk bvps)      -- check for zero sum, at display precision-    (rsum, bvsum)               = (sumPostings rps, sumPostings bvps)-    (rsumcost, bvsumcost)       = (mixedAmountCost rsum, mixedAmountCost bvsum)+    (rsumcost, bvsumcost)       = (foldMap postingBalancingAmount rps, foldMap postingBalancingAmount bvps)     (rsumdisplay, bvsumdisplay) = (canonicalise rsumcost, canonicalise bvsumcost)     (rsumok, bvsumok)           = (mixedAmountLooksZero rsumdisplay, mixedAmountLooksZero bvsumdisplay) @@ -116,12 +117,12 @@       where         rmsg           | rsumok        = ""-          | not rsignsok  = "real postings all have the same sign"-          | otherwise     = "real postings' sum should be 0 but is: " ++ showMixedAmount rsumcost+          | not rsignsok  = "The real postings all have the same sign. Consider negating some of them."+          | otherwise     = "The real postings' sum should be 0 but is: " ++ showMixedAmountOneLine rsumcost         bvmsg           | bvsumok       = ""-          | not bvsignsok = "balanced virtual postings all have the same sign"-          | otherwise     = "balanced virtual postings' sum should be 0 but is: " ++ showMixedAmount bvsumcost+          | not bvsignsok = "The balanced virtual postings all have the same sign. Consider negating some of them."+          | otherwise     = "The balanced virtual postings' sum should be 0 but is: " ++ showMixedAmountOneLine bvsumcost  -- | Legacy form of transactionCheckBalanced. isTransactionBalanced :: BalancingOpts -> Transaction -> Bool@@ -158,20 +159,42 @@     if infer_transaction_prices_ bopts then inferBalancingPrices t else t   case transactionCheckBalanced bopts t' of     []   -> Right (txnTieKnot t', inferredamtsandaccts)-    errs -> Left $ transactionBalanceError t' errs+    errs -> Left $ transactionBalanceError t' errs'+      where+        ismulticommodity = (length $ transactionCommodities t') > 1+        errs' =+          [ "Automatic commodity conversion is not enabled."+          | ismulticommodity && not (infer_transaction_prices_ bopts)+          ] +++          errs +++          if ismulticommodity+          then+          [ "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."+          ] +transactionCommodities :: Transaction -> S.Set CommoditySymbol+transactionCommodities t = mconcat $ map (maCommodities . pamount) $ tpostings t+ -- | Generate a transaction balancing error message, given the transaction -- and one or more suberror messages. transactionBalanceError :: Transaction -> [String] -> String-transactionBalanceError t errs =-  annotateErrorWithTransaction t $-  intercalate "\n" $ "could not balance this transaction:" : errs--annotateErrorWithTransaction :: Transaction -> String -> String-annotateErrorWithTransaction t s =-  unlines [ sourcePosPairPretty $ tsourcepos t, s-          , T.unpack . T.stripEnd $ showTransaction t-          ]+transactionBalanceError t errs = printf "%s:\n%s\n\nThis %stransaction is unbalanced.\n%s"+  (sourcePosPairPretty $ tsourcepos t)+  (textChomp ex)+  (if ismulticommodity then "multi-commodity " else "" :: String)+  (chomp $ unlines errs)+  where+    ismulticommodity = (length $ transactionCommodities t) > 1+    (_f,_l,_mcols,ex) = makeTransactionErrorExcerpt t finderrcols+      where+        finderrcols _ = Nothing+        -- finderrcols t = Just (1, Just w)+        --   where+        --     w = maximumDef 1 $ map T.length $ T.lines $ showTransaction t  -- | Infer up to one missing amount for this transactions's real postings, and -- likewise for its balanced virtual postings, if needed; or return an error@@ -188,12 +211,12 @@ inferBalancingAmount styles t@Transaction{tpostings=ps}   | length amountlessrealps > 1       = Left $ transactionBalanceError t-        ["can't have more than one real posting with no amount"-        ,"(remember to put two or more spaces between account and amount)"]+        ["There can't be more than one real posting with no amount."+        ,"(Remember to put two or more spaces between account and amount.)"]   | length amountlessbvps > 1       = Left $ transactionBalanceError t-        ["can't have more than one balanced virtual posting with no amount"-        ,"(remember to put two or more spaces between account and amount)"]+        ["There can't be more than one balanced virtual posting with no amount."+        ,"(Remember to put two or more spaces between account and amount.)"]   | otherwise       = let psandinferredamts = map inferamount ps             inferredacctsandamts = [(paccount p, amt) | (p, Just amt) <- psandinferredamts]@@ -292,11 +315,11 @@     -- For each posting, if the posting type matches, there is only a single amount in the posting,     -- and the commodity of the amount matches the amount we're converting from,     -- then set its price based on the ratio between fromamount and toamount.-    inferprice (fromamount, toamount) posting-        | [a] <- amounts (pamount posting), ptype posting == pt, acommodity a == acommodity fromamount-            = posting{ pamount   = mixedAmount a{aprice=Just conversionprice}-                     , poriginal = Just $ originalPosting posting }-        | otherwise = posting+    inferprice (fromamount, toamount) p+        | [a] <- amounts (pamount p), ptype p == pt, acommodity a == acommodity fromamount+            = p{ pamount   = mixedAmount a{aprice=Just conversionprice}+                     , poriginal = Just $ originalPosting p }+        | otherwise = p       where         -- If only one Amount in the posting list matches fromamount we can use TotalPrice.         -- Otherwise divide the conversion equally among the Amounts by using a unit price.@@ -550,6 +573,7 @@ checkBalanceAssertionOneCommodityB :: Posting -> Amount -> MixedAmount -> Balancing s () checkBalanceAssertionOneCommodityB p@Posting{paccount=assertedacct} assertedamt actualbal = do   let isinclusive = maybe False bainclusive $ pbalanceassertion p+  let istotal     = maybe False batotal     $ pbalanceassertion p   actualbal' <-     if isinclusive     then@@ -571,38 +595,40 @@       aquantity         -- traceWith (("actual:"++).showAmountDebug)         actualbalincomm--    errmsg = printf (unlines-                  [ "balance assertion: %s",-                    "\nassertion details:",-                    "date:       %s",-                    "account:    %s%s",-                    "commodity:  %s",-                    -- "display precision:  %d",-                    "calculated: %s", -- (at display precision: %s)",-                    "asserted:   %s", -- (at display precision: %s)",-                    "difference: %s"-                  ])-      (case ptransaction p of-         Nothing -> "?" -- shouldn't happen-         Just t ->  printf "%s\ntransaction:\n%s"-                      (sourcePosPretty pos)-                      (textChomp $ showTransaction t)-                      :: String-                      where-                        pos = baposition $ fromJust $ pbalanceassertion p-      )-      (showDate $ postingDate p)-      (T.unpack $ paccount p) -- XXX pack-      (if isinclusive then " (and subs)" else "" :: String)-      assertedcomm+    errmsg = chomp $ printf (unlines+      [ "%s:",+        "%s\n",+        "This balance assertion failed.",+        -- "date:       %s",+        "In account:    %s",+        "and commodity: %s",+        -- "display precision:  %d",+        "this balance was asserted:     %s", -- (at display precision: %s)",+        "but the calculated balance is: %s", -- (at display precision: %s)",+        "a difference of:               %s",+        "",+        "Consider viewing this account's calculated balances to troubleshoot. Eg:",+        "",+        "hledger reg '%s'%s -I  # -f FILE"+      ])+      (sourcePosPretty pos)+      (textChomp ex)+      -- (showDate $ postingDate p)+      (if isinclusive then printf "%-30s  (including subaccounts)" acct else acct)+      (if istotal     then printf "%-30s  (no other commodities allowed)" (T.unpack assertedcomm) else (T.unpack assertedcomm))       -- (asprecision $ astyle actualbalincommodity)  -- should be the standard display precision I think-      (show $ aquantity actualbalincomm)-      -- (showAmount actualbalincommodity)       (show $ aquantity assertedamt)       -- (showAmount assertedamt)+      (show $ aquantity actualbalincomm)+      -- (showAmount actualbalincommodity)       (show $ aquantity assertedamt - aquantity actualbalincomm)-+      (acct ++ if isinclusive then "" else "$")+      (if istotal then "" else (" cur:" ++ quoteForCommandLine (T.unpack assertedcomm)))+      where+        acct = T.unpack $ paccount p+        ass = fromJust $ pbalanceassertion p  -- PARTIAL: fromJust won't fail, there is a balance assertion+        pos = baposition ass+        (_,_,_,ex) = makeBalanceAssertionErrorExcerpt p   unless pass $ throwError errmsg  -- | Throw an error if this posting is trying to do an illegal balance assignment.@@ -619,7 +645,7 @@ checkBalanceAssignmentPostingDateB p =   when (hasBalanceAssignment p && isJust (pdate p)) $     throwError $ chomp $ unlines [-       "can't use balance assignment with custom posting date"+       "Balance assignments and custom posting dates may not be combined."       ,""       ,chomp1 $ T.unpack $ maybe (T.unlines $ showPostingLines p) showTransaction $ ptransaction p       ,"Balance assignments may not be used on postings with a custom posting date"@@ -635,7 +661,7 @@   unassignable <- R.asks bsUnassignable   when (hasBalanceAssignment p && paccount p `S.member` unassignable) $     throwError $ chomp $ unlines [-       "can't use balance assignment with auto postings"+       "Balance assignments and auto postings may not be combined."       ,""       ,chomp1 $ T.unpack $ maybe (T.unlines $ showPostingLines p) (showTransaction) $ ptransaction p       ,"Balance assignments may not be used on accounts affected by auto posting rules"

@@ -2,7 +2,6 @@ {-# LANGUAGE NoMonoLocalBinds    #-} {-# LANGUAGE OverloadedStrings   #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TupleSections       #-} {-# LANGUAGE TypeFamilies        #-} {-| @@ -76,7 +75,7 @@   daysInSpan,    tests_Dates-)+, intervalStartBefore) where  import qualified Control.Monad.Fail as Fail (MonadFail, fail)@@ -105,7 +104,7 @@ import Text.Megaparsec import Text.Megaparsec.Char (char, char', digitChar, string, string') import Text.Megaparsec.Char.Lexer (decimal, signed)-import Text.Megaparsec.Custom (customErrorBundlePretty, HledgerParseErrors)+import Text.Megaparsec.Custom (customErrorBundlePretty) import Text.Printf (printf)  import Hledger.Data.Types@@ -348,9 +347,9 @@ latestSpanContaining datespans = go   where     go day = do-        span <- Set.lookupLT supSpan spanSet-        guard $ spanContainsDate span day-        return span+        spn <- Set.lookupLT supSpan spanSet+        guard $ spanContainsDate spn day+        return spn       where         -- The smallest DateSpan larger than any DateSpan containing day.         supSpan = DateSpan (Just $ addDays 1 day) Nothing@@ -387,18 +386,19 @@ spanFromSmartDate refdate sdate = DateSpan (Just b) (Just e)     where       (ry,rm,_) = toGregorian refdate-      (b,e) = span sdate-      span :: SmartDate -> (Day,Day)-      span (SmartCompleteDate day)       = (day, nextday day)-      span (SmartAssumeStart y Nothing)  = (startofyear day, nextyear day) where day = fromGregorian y 1 1-      span (SmartAssumeStart y (Just m)) = (startofmonth day, nextmonth day) where day = fromGregorian y m 1-      span (SmartFromReference m d)      = (day, nextday day) where day = fromGregorian ry (fromMaybe rm m) d-      span (SmartMonth m)                = (startofmonth day, nextmonth day) where day = fromGregorian ry m 1-      span (SmartRelative n Day)         = (addDays n refdate, addDays (n+1) refdate)-      span (SmartRelative n Week)        = (addDays (7*n) d, addDays (7*n+7) d) where d = thisweek refdate-      span (SmartRelative n Month)       = (addGregorianMonthsClip n d, addGregorianMonthsClip (n+1) d) where d = thismonth refdate-      span (SmartRelative n Quarter)     = (addGregorianMonthsClip (3*n) d, addGregorianMonthsClip (3*n+3) d) where d = thisquarter refdate-      span (SmartRelative n Year)        = (addGregorianYearsClip n d, addGregorianYearsClip (n+1) d) where d = thisyear refdate+      (b,e) = span' sdate+        where+          span' :: SmartDate -> (Day,Day)+          span' (SmartCompleteDate day)       = (day, nextday day)+          span' (SmartAssumeStart y Nothing)  = (startofyear day, nextyear day) where day = fromGregorian y 1 1+          span' (SmartAssumeStart y (Just m)) = (startofmonth day, nextmonth day) where day = fromGregorian y m 1+          span' (SmartFromReference m d)      = (day, nextday day) where day = fromGregorian ry (fromMaybe rm m) d+          span' (SmartMonth m)                = (startofmonth day, nextmonth day) where day = fromGregorian ry m 1+          span' (SmartRelative n Day)         = (addDays n refdate, addDays (n+1) refdate)+          span' (SmartRelative n Week)        = (addDays (7*n) d, addDays (7*n+7) d) where d = thisweek refdate+          span' (SmartRelative n Month)       = (addGregorianMonthsClip n d, addGregorianMonthsClip (n+1) d) where d = thismonth refdate+          span' (SmartRelative n Quarter)     = (addGregorianMonthsClip (3*n) d, addGregorianMonthsClip (3*n+3) d) where d = thisquarter refdate+          span' (SmartRelative n Year)        = (addGregorianYearsClip n d, addGregorianYearsClip (n+1) d) where d = thisyear refdate  -- showDay :: Day -> String -- showDay day = printf "%04d/%02d/%02d" y m d where (y,m,d) = toGregorian day@@ -541,13 +541,20 @@ startofquarter day = fromGregorian y (firstmonthofquarter m) 1     where       (y,m,_) = toGregorian day-      firstmonthofquarter m = ((m-1) `div` 3) * 3 + 1+      firstmonthofquarter m2 = ((m2-1) `div` 3) * 3 + 1  thisyear = startofyear prevyear = startofyear . addGregorianYearsClip (-1) nextyear = startofyear . addGregorianYearsClip 1 startofyear day = fromGregorian y 1 1 where (y,_,_) = toGregorian day +-- Get the natural start for the given interval that falls on or before the given day.+intervalStartBefore :: Interval -> Day -> Day+intervalStartBefore int d =+  case splitSpan int (DateSpan (Just d) (Just $ addDays 1 d)) of+    (DateSpan (Just start) _:_) -> start+    _ -> d+ -- | For given date d find year-long interval that starts on given -- MM/DD of year and covers it. -- The given MM and DD should be basically valid (1-12 & 1-31),@@ -570,14 +577,14 @@ -- >>> nthdayofyearcontaining 1 1 wed22nd -- 2017-01-01 nthdayofyearcontaining :: Month -> MonthDay -> Day -> Day-nthdayofyearcontaining m md date+nthdayofyearcontaining m mdy date   -- PARTIAL:   | not (validMonth m)  = error' $ "nthdayofyearcontaining: invalid month "++show m-  | not (validDay   md) = error' $ "nthdayofyearcontaining: invalid day "  ++show md+  | not (validDay   mdy) = error' $ "nthdayofyearcontaining: invalid day "  ++show mdy   | mmddOfSameYear <= date = mmddOfSameYear   | otherwise = mmddOfPrevYear-  where mmddOfSameYear = addDays (toInteger md-1) $ applyN (m-1) nextmonth s-        mmddOfPrevYear = addDays (toInteger md-1) $ applyN (m-1) nextmonth $ prevyear s+  where mmddOfSameYear = addDays (toInteger mdy-1) $ applyN (m-1) nextmonth s+        mmddOfPrevYear = addDays (toInteger mdy-1) $ applyN (m-1) nextmonth $ prevyear s         s = startofyear date  -- | For given date d find month-long interval that starts on nth day of month@@ -599,13 +606,13 @@ -- >>> nthdayofmonthcontaining 30 wed22nd -- 2017-10-30 nthdayofmonthcontaining :: MonthDay -> Day -> Day-nthdayofmonthcontaining md date+nthdayofmonthcontaining mdy date   -- PARTIAL:-  | not (validDay md) = error' $ "nthdayofmonthcontaining: invalid day "  ++show md+  | not (validDay mdy) = error' $ "nthdayofmonthcontaining: invalid day "  ++show mdy   | nthOfSameMonth <= date = nthOfSameMonth   | otherwise = nthOfPrevMonth-  where nthOfSameMonth = nthdayofmonth md s-        nthOfPrevMonth = nthdayofmonth md $ prevmonth s+  where nthOfSameMonth = nthdayofmonth mdy s+        nthOfPrevMonth = nthdayofmonth mdy $ prevmonth s         s = startofmonth date  -- | For given date d find week-long interval that starts on nth day of week@@ -800,8 +807,8 @@ yyyymmdd = do   y <- read <$> count 4 digitChar   m <- read <$> count 2 digitChar-  md <- optional $ read <$> count 2 digitChar-  case md of+  mdy <- optional $ read <$> count 2 digitChar+  case mdy of       Nothing -> failIfInvalidDate $ SmartAssumeStart y (Just m)       Just d  -> maybe (Fail.fail $ showBadDate y m d) (return . SmartCompleteDate) $                    fromGregorianValid y m d@@ -1073,19 +1080,19 @@             ]    , testCase "match dayOfWeek" $ do-      let dayofweek n s = splitspan (nthdayofweekcontaining n) (\w -> (if w == 0 then id else applyN (n-1) nextday . applyN (fromInteger w) nextweek)) 1 s-          match ds day = splitSpan (DaysOfWeek [day]) ds @?= dayofweek day ds+      let dayofweek n = splitspan (nthdayofweekcontaining n) (\w -> (if w == 0 then id else applyN (n-1) nextday . applyN (fromInteger w) nextweek)) 1+          matchdow ds day = splitSpan (DaysOfWeek [day]) ds @?= dayofweek day ds           ys2021 = fromGregorian 2021 01 01           ye2021 = fromGregorian 2021 12 31           ys2022 = fromGregorian 2022 01 01-      mapM_ (match (DateSpan (Just ys2021) (Just ye2021))) [1..7]-      mapM_ (match (DateSpan (Just ys2021) (Just ys2022))) [1..7]-      mapM_ (match (DateSpan (Just ye2021) (Just ys2022))) [1..7]+      mapM_ (matchdow (DateSpan (Just ys2021) (Just ye2021))) [1..7]+      mapM_ (matchdow (DateSpan (Just ys2021) (Just ys2022))) [1..7]+      mapM_ (matchdow (DateSpan (Just ye2021) (Just ys2022))) [1..7] -      mapM_ (match (DateSpan (Just ye2021) Nothing)) [1..7]-      mapM_ (match (DateSpan (Just ys2022) Nothing)) [1..7]+      mapM_ (matchdow (DateSpan (Just ye2021) Nothing)) [1..7]+      mapM_ (matchdow (DateSpan (Just ys2022) Nothing)) [1..7] -      mapM_ (match (DateSpan Nothing (Just ye2021))) [1..7]-      mapM_ (match (DateSpan Nothing (Just ys2022))) [1..7]+      mapM_ (matchdow (DateSpan Nothing (Just ye2021))) [1..7]+      mapM_ (matchdow (DateSpan Nothing (Just ys2022))) [1..7]    ]

@@ -7,6 +7,8 @@ module Hledger.Data.Errors (   makeTransactionErrorExcerpt,   makePostingErrorExcerpt,+  makePostingAccountErrorExcerpt,+  makeBalanceAssertionErrorExcerpt,   transactionFindPostingIndex, ) where@@ -19,6 +21,9 @@ import Hledger.Data.Transaction (showTransaction) import Hledger.Data.Types import Hledger.Utils+import Data.Maybe+import Safe (headMay)+import Hledger.Data.Posting (isVirtual)  -- | Given a problem transaction and a function calculating the best -- column(s) for marking the error region:@@ -26,6 +31,7 @@ -- on the transaction line, and a column(s) marker. -- Returns the file path, line number, column(s) if known, -- and the rendered excerpt, or as much of these as is possible.+-- A limitation: columns will be accurate for the rendered error message but not for the original journal data. makeTransactionErrorExcerpt :: Transaction -> (Transaction -> Maybe (Int, Maybe Int)) -> (FilePath, Int, Maybe (Int, Maybe Int), Text) makeTransactionErrorExcerpt t findtxnerrorcolumns = (f, tl, merrcols, ex)   -- XXX findtxnerrorcolumns is awkward, I don't think this is the final form@@ -58,6 +64,7 @@ -- on the problem posting's line, and a column indicator. -- Returns the file path, line number, column(s) if known, -- and the rendered excerpt, or as much of these as is possible.+-- A limitation: columns will be accurate for the rendered error message but not for the original journal data. makePostingErrorExcerpt :: Posting -> (Posting -> Transaction -> Text -> Maybe (Int, Maybe Int)) -> (FilePath, Int, Maybe (Int, Maybe Int), Text) makePostingErrorExcerpt p findpostingerrorcolumns =   case ptransaction p of@@ -97,4 +104,41 @@ transactionFindPostingIndex :: (Posting -> Bool) -> Transaction -> Maybe Int transactionFindPostingIndex ppredicate =    fmap fst . find (ppredicate.snd) . zip [1..] . tpostings++-- | From the given posting, make an error excerpt showing the transaction with+-- this posting's account part highlighted.+makePostingAccountErrorExcerpt :: Posting -> (FilePath, Int, Maybe (Int, Maybe Int), Text)+makePostingAccountErrorExcerpt p = makePostingErrorExcerpt p finderrcols+  where+    -- Calculate columns suitable for highlighting the synthetic excerpt.+    finderrcols p' _ _ = Just (col, Just col2)+      where+        col = 5 + if isVirtual p' then 1 else 0+        col2 = col + T.length (paccount p') - 1++-- | From the given posting, make an error excerpt showing the transaction with+-- the balance assertion highlighted.+makeBalanceAssertionErrorExcerpt :: Posting -> (FilePath, Int, Maybe (Int, Maybe Int), Text)+makeBalanceAssertionErrorExcerpt p = makePostingErrorExcerpt p finderrcols+  where+    finderrcols p' t trendered = Just (col, Just col2)+      where+        -- Analyse the rendering to find the columns to highlight.+        tlines = dbg5 "tlines" $ max 1 $ length $ T.lines $ tcomment t  -- transaction comment can generate extra lines+        (col, col2) =+          let def = (5, maximum (map T.length $ T.lines trendered))  -- fallback: underline whole posting. Shouldn't happen.+          in+            case transactionFindPostingIndex (==p') t of+              Nothing  -> def+              Just idx -> fromMaybe def $ do+                let+                  beforeps = take (idx-1) $ tpostings t+                  beforepslines = dbg5 "beforepslines" $ sum $ map (max 1 . length . T.lines . pcomment) beforeps   -- posting comment can generate extra lines (assume only one commodity shown)+                assertionline <- dbg5 "assertionline" $ headMay $ drop (tlines + beforepslines) $ T.lines trendered+                let+                  col2' = T.length assertionline+                  l = dropWhile (/= '=') $ reverse $ T.unpack assertionline+                  l' = dropWhile (`elem` ['=','*']) l+                  col' = length l' + 1+                return (col', col2') 

@@ -26,8 +26,10 @@   journalCommodityStyles,   journalToCost,   journalAddInferredEquityPostings,+  journalAddPricesFromEquity,   journalReverse,   journalSetLastReadTime,+  journalRenumberAccountDeclarations,   journalPivot,   -- * Filtering   filterJournalTransactions,@@ -36,6 +38,7 @@   filterJournalAmounts,   filterTransactionAmounts,   filterTransactionPostings,+  filterTransactionPostingsExtra,   filterTransactionRelatedPostings,   filterPostingAmount,   -- * Mapping@@ -83,24 +86,17 @@   journalAddAccountTypes,   journalPostingsAddAccountTags,   -- journalPrices,-  -- * Standard account types-  journalBalanceSheetAccountQuery,-  journalProfitAndLossAccountQuery,-  journalRevenueAccountQuery,-  journalExpenseAccountQuery,-  journalAssetAccountQuery,-  journalLiabilityAccountQuery,-  journalEquityAccountQuery,-  journalCashAccountQuery,   journalConversionAccount,   -- * Misc   canonicalStyleFrom,   nulljournal,+  journalConcat,   journalNumberTransactions,   journalNumberAndTieTransactions,   journalUntieTransactions,   journalModifyTransactions,   journalApplyAliases,+  dbgJournalAcctDeclOrder,   -- * Tests   samplejournal,   samplejournalMaybeExplicit,@@ -115,7 +111,7 @@ import Data.Char (toUpper, isDigit) import Data.Default (Default(..)) import Data.Foldable (toList)-import Data.List ((\\), find, foldl', sortBy, union)+import Data.List ((\\), find, foldl', sortBy, union, intercalate) import Data.List.Extra (nubSort) import qualified Data.Map.Strict as M import Data.Maybe (catMaybes, fromMaybe, mapMaybe, maybeToList)@@ -139,6 +135,7 @@ import Hledger.Data.TransactionModifier import Hledger.Data.Valuation import Hledger.Query+import System.FilePath (takeFileName)   -- | A parser of text that runs in some monad, keeping a Journal as state.@@ -186,9 +183,7 @@ -- The semigroup instance for Journal is useful for two situations. -- -- 1. concatenating finalised journals, eg with multiple -f options:--- FIRST <> SECOND. The second's list fields are appended to the--- first's, map fields are combined, transaction counts are summed,--- the parse state of the second is kept.+-- FIRST <> SECOND. -- -- 2. merging a child parsed journal, eg with the include directive: -- CHILD <> PARENT. A parsed journal's data is in reverse order, so@@ -196,8 +191,22 @@ -- -- Note that (<>) is right-biased, so nulljournal is only a left identity. -- In particular, this prevents Journal from being a monoid.-instance Semigroup Journal where-  j1 <> j2 = Journal {+instance Semigroup Journal where j1 <> j2 = j1 `journalConcat` j2++-- | Merge two journals into one.+-- Transaction counts are summed, map fields are combined,+-- the second's list fields are appended to the first's,+-- the second's parse state is kept.+journalConcat :: Journal -> Journal -> Journal+journalConcat j1 j2 =+  let+    f1 = takeFileName $ journalFilePath j1+    f2 = maybe "(unknown)" takeFileName $ headMay $ jincludefilestack j2  -- XXX more accurate than journalFilePath for some reason+  in+    dbgJournalAcctDeclOrder ("journalConcat: " <> f1 <> " <> " <> f2 <> ", acct decls renumbered: ") $+    journalRenumberAccountDeclarations $+    dbgJournalAcctDeclOrder ("journalConcat: " <> f1 <> " <> " <> f2 <> ", acct decls           : ") $+    Journal {      jparsedefaultyear          = jparsedefaultyear          j2     ,jparsedefaultcommodity     = jparsedefaultcommodity     j2     ,jparsedecimalmark          = jparsedecimalmark          j2@@ -224,6 +233,34 @@     ,jlastreadtime              = max (jlastreadtime j1) (jlastreadtime j2)     } +-- | Renumber all the account declarations. This is useful to call when+-- finalising or concatenating Journals, to give account declarations+-- a total order across files.+journalRenumberAccountDeclarations :: Journal -> Journal+journalRenumberAccountDeclarations j = j{jdeclaredaccounts=jdas'}+  where+    jdas' = [(a, adi{adideclarationorder=n}) | (n, (a,adi)) <- zip [1..] $ jdeclaredaccounts j]+    -- the per-file declaration order saved during parsing is discarded,+    -- it seems unneeded except perhaps for debugging++-- | Debug log the ordering of a journal's account declarations+-- (at debug level 5+).+dbgJournalAcctDeclOrder :: String -> Journal -> Journal+dbgJournalAcctDeclOrder prefix+  | debugLevel >= 5 = traceWith ((prefix++) . showAcctDeclsSummary . jdeclaredaccounts)+  | otherwise       = id+  where+    showAcctDeclsSummary :: [(AccountName,AccountDeclarationInfo)] -> String+    showAcctDeclsSummary adis+      | length adis < (2*n+2) = "[" <> showadis adis <> "]"+      | otherwise =+          "[" <> showadis (take n adis) <> " ... " <> showadis (takelast n adis) <> "]"+      where+        n = 3+        showadis = intercalate ", " . map showadi+        showadi (a,adi) = "("<>show (adideclarationorder adi)<>","<>T.unpack a<>")"+        takelast n' = reverse . take n' . reverse+ instance Default Journal where   def = nulljournal @@ -262,7 +299,7 @@ journalFilePaths = map fst . jfiles  mainfile :: Journal -> (FilePath, Text)-mainfile = headDef ("", "") . jfiles+mainfile = headDef ("(unknown)", "") . jfiles  addTransaction :: Transaction -> Journal -> Journal addTransaction t j = j { jtxns = t : jtxns j }@@ -368,7 +405,7 @@ -- | Which tags are in effect for this account, including tags inherited from parent accounts ? journalInheritedAccountTags :: Journal -> AccountName -> [Tag] journalInheritedAccountTags j a =-  foldl' (\ts a -> ts `union` journalAccountTags j a) [] as+  foldl' (\ts a' -> ts `union` journalAccountTags j a') [] as   where     as = a : parentAccountNames a -- PERF: cache in journal ?@@ -428,111 +465,6 @@ letterPairs (a:b:rest) = [a,b] : letterPairs (b:rest) letterPairs _ = [] --- Older account type code---- queries for standard account types---- | Get a query for accounts of the specified types in this journal. --- Account types include:--- Asset, Liability, Equity, Revenue, Expense, Cash, Conversion.--- For each type, if no accounts were declared with this type, the query --- will instead match accounts with names matched by the case-insensitive --- regular expression provided as a fallback.--- The query will match all accounts which were declared as one of--- these types (by account directives with the type: tag), plus all their --- subaccounts which have not been declared as some other type.------ This is older code pre-dating 2022's expansion of account types.-journalAccountTypeQuery :: [AccountType] -> Regexp -> Journal -> Query-journalAccountTypeQuery atypes fallbackregex Journal{jdeclaredaccounttypes} =-  let-    declaredacctsoftype :: [AccountName] =-      concat $ mapMaybe (`M.lookup` jdeclaredaccounttypes) atypes-  in case declaredacctsoftype of-    [] -> Acct fallbackregex-    as -> And $ Or acctnameRegexes : if null differentlyTypedRegexes then [] else [ Not $ Or differentlyTypedRegexes ]-      where-        -- XXX Query isn't able to match account type since that requires extra info from the journal.-        -- So we do a hacky search by name instead.-        acctnameRegexes = map (Acct . accountNameToAccountRegex) as-        differentlyTypedRegexes = map (Acct . accountNameToAccountRegex) differentlytypedsubs--        differentlytypedsubs = concat-          [subs | (t,bs) <- M.toList jdeclaredaccounttypes-              , t `notElem` atypes-              , let subs = [b | b <- bs, any (`isAccountNamePrefixOf` b) as]-          ]---- | A query for accounts in this journal which have been--- declared as Asset (or Cash, a subtype of Asset) by account directives, --- or otherwise for accounts with names matched by the case-insensitive --- regular expression @^assets?(:|$)@.-journalAssetAccountQuery :: Journal -> Query-journalAssetAccountQuery j =-  Or [-     journalAccountTypeQuery [Asset] assetAccountRegex j-    ,journalCashAccountOnlyQuery j-  ]---- | A query for Cash (liquid asset) accounts in this journal, ie accounts--- declared as Cash by account directives, or otherwise accounts whose--- names match the case-insensitive regular expression--- @(^assets:(.+:)?(cash|bank)(:|$)@.-journalCashAccountQuery :: Journal -> Query-journalCashAccountQuery = journalAccountTypeQuery [Cash] cashAccountRegex---- | A query for accounts in this journal specifically declared as Cash by --- account directives, or otherwise the None query.-journalCashAccountOnlyQuery :: Journal -> Query-journalCashAccountOnlyQuery j-  -- Cash accounts are declared; get a query for them (the fallback regex won't be used)-  | Cash `M.member` jdeclaredaccounttypes j = journalAccountTypeQuery [Cash] notused j-  | otherwise = None-  where notused = error' "journalCashAccountOnlyQuery: this should not have happened!"  -- PARTIAL:---- | A query for accounts in this journal which have been--- declared as Liability by account directives, or otherwise for--- accounts with names matched by the case-insensitive regular expression--- @^(debts?|liabilit(y|ies))(:|$)@.-journalLiabilityAccountQuery :: Journal -> Query-journalLiabilityAccountQuery = journalAccountTypeQuery [Liability] liabilityAccountRegex---- | A query for accounts in this journal which have been--- declared as Equity by account directives, or otherwise for--- accounts with names matched by the case-insensitive regular expression--- @^equity(:|$)@.-journalEquityAccountQuery :: Journal -> Query-journalEquityAccountQuery = journalAccountTypeQuery [Equity] equityAccountRegex---- | A query for accounts in this journal which have been--- declared as Revenue by account directives, or otherwise for--- accounts with names matched by the case-insensitive regular expression--- @^(income|revenue)s?(:|$)@.-journalRevenueAccountQuery :: Journal -> Query-journalRevenueAccountQuery = journalAccountTypeQuery [Revenue] revenueAccountRegex---- | A query for accounts in this journal which have been--- declared as Expense by account directives, or otherwise for--- accounts with names matched by the case-insensitive regular expression--- @^expenses?(:|$)@.-journalExpenseAccountQuery  :: Journal -> Query-journalExpenseAccountQuery = journalAccountTypeQuery [Expense] expenseAccountRegex---- | A query for Asset, Liability & Equity accounts in this journal.--- Cf <http://en.wikipedia.org/wiki/Chart_of_accounts#Balance_Sheet_Accounts>.-journalBalanceSheetAccountQuery :: Journal -> Query-journalBalanceSheetAccountQuery j = Or [journalAssetAccountQuery j-                                       ,journalLiabilityAccountQuery j-                                       ,journalEquityAccountQuery j-                                       ]---- | A query for Profit & Loss accounts in this journal.--- Cf <http://en.wikipedia.org/wiki/Chart_of_accounts#Profit_.26_Loss_accounts>.-journalProfitAndLossAccountQuery  :: Journal -> Query-journalProfitAndLossAccountQuery j = Or [journalRevenueAccountQuery j-                                        ,journalExpenseAccountQuery j-                                        ]- -- | The 'AccountName' to use for automatically generated conversion postings. journalConversionAccount :: Journal -> AccountName journalConversionAccount =@@ -949,6 +881,12 @@   where     equityAcct = journalConversionAccount j +-- | Add inferred transaction prices from equity postings.+journalAddPricesFromEquity :: Journal -> Either String Journal+journalAddPricesFromEquity j = do+    ts <- mapM (transactionAddPricesFromEquity $ jaccounttypes j) $ jtxns j+    return j{jtxns=ts}+ -- -- | Get this journal's unique, display-preference-canonicalised commodities, by symbol. -- journalCanonicalCommodities :: Journal -> M.Map String CommoditySymbol -- journalCanonicalCommodities j = canonicaliseCommodities $ journalAmountCommodities j@@ -1287,24 +1225,4 @@               ]       }     @?= (DateSpan (Just $ fromGregorian 2014 1 10) (Just $ fromGregorian 2014 10 11))--  ,testGroup "standard account type queries" $-    let-      j = samplejournal-      journalAccountNamesMatching :: Query -> Journal -> [AccountName]-      journalAccountNamesMatching q = filter (q `matchesAccount`) . journalAccountNames-      namesfrom qfunc = journalAccountNamesMatching (qfunc j) j-    in [testCase "assets"      $ assertEqual "" ["assets","assets:bank","assets:bank:checking","assets:bank:saving","assets:cash"]-         (namesfrom journalAssetAccountQuery)-       ,testCase "cash"        $ assertEqual "" ["assets:bank","assets:bank:checking","assets:bank:saving","assets:cash"]-         (namesfrom journalCashAccountQuery)-       ,testCase "liabilities" $ assertEqual "" ["liabilities","liabilities:debts"]-         (namesfrom journalLiabilityAccountQuery)-       ,testCase "equity"      $ assertEqual "" []-         (namesfrom journalEquityAccountQuery)-       ,testCase "income"      $ assertEqual "" ["income","income:gifts","income:salary"]-         (namesfrom journalRevenueAccountQuery)-       ,testCase "expenses"    $ assertEqual "" ["expenses","expenses:food","expenses:supplies"]-         (namesfrom journalExpenseAccountQuery)-       ]   ]

@@ -6,32 +6,36 @@  {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards #-}  module Hledger.Data.JournalChecks (   journalCheckAccounts,   journalCheckCommodities,   journalCheckPayees,+  journalCheckRecentAssertions,   module Hledger.Data.JournalChecks.Ordereddates,   module Hledger.Data.JournalChecks.Uniqueleafnames, ) where  import Data.Char (isSpace)-import Data.List (find) import Data.Maybe import qualified Data.Map.Strict as M import qualified Data.Text as T-import Safe (atMay)+import Safe (atMay, lastMay) import Text.Printf (printf)  import Hledger.Data.Errors import Hledger.Data.Journal import Hledger.Data.JournalChecks.Ordereddates import Hledger.Data.JournalChecks.Uniqueleafnames-import Hledger.Data.Posting (isVirtual)+import Hledger.Data.Posting (isVirtual, postingDate, postingStatus) import Hledger.Data.Types import Hledger.Data.Amount (amountIsZero, amountsRaw, missingamt) import Hledger.Data.Transaction (transactionPayee, showTransactionLineFirstPart)+import Data.Time (Day, diffDays)+import Data.List.Extra+import Hledger.Utils (chomp, textChomp, sourcePosPretty)  -- | Check that all the journal's postings are to accounts  with -- account directives, returning an error message otherwise.@@ -40,16 +44,18 @@   where     checkacct p@Posting{paccount=a}       | a `elem` journalAccountNamesDeclared j = Right ()-      | otherwise = Left $ -        printf "%s:%d:%d-%d:\n%sundeclared account \"%s\"\n" f l col col2 ex a+      | otherwise = Left $ printf (unlines [+           "%s:%d:"+          ,"%s"+          ,"Strict account checking is enabled, and"+          ,"account %s has not been declared."+          ,"Consider adding an account directive. Examples:"+          ,""+          ,"account %s"+          ,"account %s    ; type:A  ; (L,E,R,X,C,V)"+          ]) f l ex (show a) a a         where-          (f,l,mcols,ex) = makePostingErrorExcerpt p finderrcols-          col  = maybe 0 fst mcols-          col2 = maybe 0 (fromMaybe 0 . snd) mcols-          finderrcols p _ _ = Just (col, Just col2)-            where-              col = 5 + if isVirtual p then 1 else 0-              col2 = col + T.length a - 1+          (f,l,_mcols,ex) = makePostingAccountErrorExcerpt p  -- | Check that all the commodities used in this journal's postings have been declared -- by commodity directives, returning an error message otherwise.@@ -60,11 +66,18 @@       case findundeclaredcomm p of         Nothing -> Right ()         Just (comm, _) ->-          Left $ printf "%s:%d:%d-%d:\n%sundeclared commodity \"%s\"\n" f l col col2 ex comm+          Left $ printf (unlines [+           "%s:%d:"+          ,"%s"+          ,"Strict commodity checking is enabled, and"+          ,"commodity %s has not been declared."+          ,"Consider adding a commodity directive. Examples:"+          ,""+          ,"commodity %s1000.00"+          ,"commodity 1.000,00 %s"+          ]) f l ex (show comm) comm comm           where-            (f,l,mcols,ex) = makePostingErrorExcerpt p finderrcols-            col  = maybe 0 fst mcols-            col2 = maybe 0 (fromMaybe 0 . snd) mcols+            (f,l,_mcols,ex) = makePostingErrorExcerpt p finderrcols       where         -- Find the first undeclared commodity symbol in this posting's amount         -- or balance assertion amount, if any. The boolean will be true if@@ -83,6 +96,10 @@             assertioncomms = [acommodity a | Just a <- [baamount <$> pbalanceassertion]]             findundeclared = find (`M.notMember` jcommodities j) +        -- Calculate columns suitable for highlighting the excerpt.+        -- We won't show these in the main error line as they aren't+        -- accurate for the actual data.+         -- Find the best position for an error column marker when this posting         -- is rendered by showTransaction.         -- Reliably locating a problem commodity symbol in showTransaction output@@ -99,15 +116,15 @@         --     assets      "C $" -1 @ $ 2         --                 ^^^^^^^^^^^^^^         -- XXX refine this region when it's easy-        finderrcols p t txntxt =-          case transactionFindPostingIndex (==p) t of+        finderrcols p' t txntxt =+          case transactionFindPostingIndex (==p') t of             Nothing     -> Nothing             Just pindex -> Just (amtstart, Just amtend)               where                 tcommentlines = max 0 (length (T.lines $ tcomment t) - 1)                 errrelline = 1 + tcommentlines + pindex   -- XXX doesn't count posting coment lines                 errline = fromMaybe "" (T.lines txntxt `atMay` (errrelline-1))-                acctend = 4 + T.length (paccount p) + if isVirtual p then 2 else 0+                acctend = 4 + T.length (paccount p') + if isVirtual p' then 2 else 0                 amtstart = acctend + (T.length $ T.takeWhile isSpace $ T.drop acctend errline) + 1                 amtend = amtstart + (T.length $ T.stripEnd $ T.takeWhile (/=';') $ T.drop amtstart errline) @@ -119,13 +136,126 @@     checkpayee t       | payee `elem` journalPayeesDeclared j = Right ()       | otherwise = Left $-        printf "%s:%d:%d-%d:\n%sundeclared payee \"%s\"\n" f l col col2 ex payee+        printf (unlines [+           "%s:%d:"+          ,"%s"+          ,"Strict payee checking is enabled, and"+          ,"payee %s has not been declared."+          ,"Consider adding a payee directive. Examples:"+          ,""+          ,"payee %s"+          ]) f l ex (show payee) payee       where         payee = transactionPayee t-        (f,l,mcols,ex) = makeTransactionErrorExcerpt t finderrcols-        col  = maybe 0 fst mcols-        col2 = maybe 0 (fromMaybe 0 . snd) mcols-        finderrcols t = Just (col, Just col2)+        (f,l,_mcols,ex) = makeTransactionErrorExcerpt t finderrcols+        -- Calculate columns suitable for highlighting the excerpt.+        -- We won't show these in the main error line as they aren't+        -- accurate for the actual data.+        finderrcols t' = Just (col, Just col2)           where-            col = T.length (showTransactionLineFirstPart t) + 2-            col2 = col + T.length (transactionPayee t) - 1+            col  = T.length (showTransactionLineFirstPart t') + 2+            col2 = col + T.length (transactionPayee t') - 1++----------++-- | Information useful for checking the age and lag of an account's latest balance assertion.+data BalanceAssertionInfo = BAI {+    baiAccount                :: AccountName -- ^ the account+  , baiLatestAssertionPosting :: Posting     -- ^ the account's latest posting with a balance assertion+  , baiLatestAssertionDate    :: Day         -- ^ the posting date+  , baiLatestAssertionStatus  :: Status      -- ^ the posting status+  , baiLatestPostingDate      :: Day         -- ^ the date of this account's latest posting with or without a balance assertion+}++-- | Given a list of postings to the same account,+-- if any of them contain a balance assertion,+-- calculate the last asserted and posted dates.+balanceAssertionInfo :: [Posting] -> Maybe BalanceAssertionInfo+balanceAssertionInfo ps =+  case (mlatestp, mlatestassertp) of+    (Just latestp, Just latestassertp) -> Just $+      BAI{baiAccount                 = paccount latestassertp+          ,baiLatestAssertionDate    = postingDate latestassertp+          ,baiLatestAssertionPosting = latestassertp+          ,baiLatestAssertionStatus  = postingStatus latestassertp+          ,baiLatestPostingDate      = postingDate latestp+          }+    _ -> Nothing+  where+    ps' = sortOn postingDate ps+    mlatestp = lastMay ps'+    mlatestassertp = lastMay [p | p@Posting{pbalanceassertion=Just _} <- ps']++-- | The number of days allowed between an account's latest balance assertion +-- and latest posting.+maxlag = 7++-- | The number of days between this balance assertion and the latest posting in its account.+baiLag BAI{..} = diffDays baiLatestPostingDate baiLatestAssertionDate++-- -- | The earliest balance assertion date which would satisfy the recentassertions check.+-- baiLagOkDate :: BalanceAssertionInfo -> Day+-- baiLagOkDate BAI{..} = addDays (-7) baiLatestPostingDate++-- | Check that this latest assertion is close enough to the account's latest posting.+checkRecentAssertion :: BalanceAssertionInfo -> Either (BalanceAssertionInfo, String) ()+checkRecentAssertion bai@BAI{..}+  | lag > maxlag =+    Left (bai, printf (chomp $ unlines [+       "the last balance assertion (%s) was %d days before"+      ,"the latest posting (%s)."+      ])+      (show baiLatestAssertionDate) lag (show baiLatestPostingDate)+      )+  | otherwise = Right ()+  where +    lag = baiLag bai++-- | Check that all the journal's accounts with balance assertions have+-- an assertion no more than 7 days before their latest posting.+-- Today's date is provided for error messages.+journalCheckRecentAssertions :: Day -> Journal -> Either String ()+journalCheckRecentAssertions today j =+  let+    acctps = groupOn paccount $ sortOn paccount $ journalPostings j+    acctassertioninfos = mapMaybe balanceAssertionInfo acctps+  in+    case mapM_ checkRecentAssertion acctassertioninfos of+      Right () -> Right ()+      Left (BAI{..}, msg) -> Left errmsg+        where+          errmsg = chomp $ printf +            (unlines [+              "%s:",+              "%s\n",+              "The recentassertions check is enabled, so accounts with balance assertions must",+              "have a balance assertion no more than %d days before their latest posting date.",+              "In account %s,",+              "%s",+              "",+              "%s"+              ])+            (maybe "(no position)"  -- shouldn't happen+              (sourcePosPretty . baposition) $ pbalanceassertion baiLatestAssertionPosting)+            (textChomp excerpt)+            maxlag+            baiAccount+            msg+            recommendation+            where+              (_,_,_,excerpt) = makeBalanceAssertionErrorExcerpt baiLatestAssertionPosting+              recommendation = unlines [+                "Consider adding a more recent balance assertion for this account. Eg:",+                "",+                printf "%s *\n    %s    $0 = $0  ; <- adjust" (show today) baiAccount+                ]++-- -- | Print the last balance assertion date & status of all accounts with balance assertions.+-- printAccountLastAssertions :: Day -> [BalanceAssertionInfo] -> IO ()+-- printAccountLastAssertions today acctassertioninfos = do+--   forM_ acctassertioninfos $ \BAI{..} -> do+--     putStr $ printf "%-30s  %s %s, %d days ago\n"+--       baiAccount+--       (if baiLatestClearedAssertionStatus==Unmarked then " " else show baiLatestClearedAssertionStatus)+--       (show baiLatestClearedAssertionDate)+--       (diffDays today baiLatestClearedAssertionDate)

@@ -6,35 +6,37 @@ import Control.Monad (forM) import Data.List (groupBy) import Text.Printf (printf)-import Data.Maybe (fromMaybe)+import qualified Data.Text as T (pack, unlines)  import Hledger.Data.Errors (makeTransactionErrorExcerpt) import Hledger.Data.Transaction (transactionFile, transactionDateOrDate2) import Hledger.Data.Types+import Hledger.Utils (textChomp)  journalCheckOrdereddates :: WhichDate -> Journal -> Either String () journalCheckOrdereddates whichdate j = do-  let +  let     -- we check date ordering within each file, not across files     -- note, relying on txns always being sorted by file here     txnsbyfile = groupBy (\t1 t2 -> transactionFile t1 == transactionFile t2) $ jtxns j     getdate = transactionDateOrDate2 whichdate-    compare a b = getdate a <= getdate b-  either Left (const $ Right ()) $ -   forM txnsbyfile $ \ts ->-    case checkTransactions compare ts of+    compare' a b = getdate a <= getdate b+  (const $ Right ()) =<< (forM txnsbyfile $ \ts ->+    case checkTransactions compare' ts of       FoldAcc{fa_previous=Nothing} -> Right ()       FoldAcc{fa_error=Nothing}    -> Right ()       FoldAcc{fa_error=Just t, fa_previous=Just tprev} -> Left $ printf-        "%s:%d:%d-%d:\n%stransaction date%s is out of order with previous transaction date %s" -        f l col col2 ex datenum tprevdate+        ("%s:%d:\n%s\nOrdered dates checking is enabled, and this transaction's\n"+          ++ "date%s (%s) is out of order with the previous transaction.\n"+          ++ "Consider moving this entry into date order, or adjusting its date.")+        f l ex datenum (show $ getdate t)         where-          (f,l,mcols,ex) = makeTransactionErrorExcerpt t finderrcols-          col  = maybe 0 fst mcols-          col2 = maybe 0 (fromMaybe 0 . snd) mcols+          (_,_,_,ex1) = makeTransactionErrorExcerpt tprev (const Nothing)+          (f,l,_,ex2) = makeTransactionErrorExcerpt t finderrcols+          -- separate the two excerpts by a space-beginning line to help flycheck-hledger parse them+          ex = T.unlines [textChomp ex1, T.pack " ", textChomp ex2]           finderrcols _t = Just (1, Just 10)-          datenum   = if whichdate==SecondaryDate then "2" else ""-          tprevdate = show $ getdate tprev+          datenum   = if whichdate==SecondaryDate then "2" else "")  data FoldAcc a b = FoldAcc  { fa_error    :: Maybe a@@ -43,11 +45,11 @@  checkTransactions :: (Transaction -> Transaction -> Bool)   -> [Transaction] -> FoldAcc Transaction Transaction-checkTransactions compare = foldWhile f FoldAcc{fa_error=Nothing, fa_previous=Nothing}+checkTransactions compare' = foldWhile f FoldAcc{fa_error=Nothing, fa_previous=Nothing}   where     f current acc@FoldAcc{fa_previous=Nothing} = acc{fa_previous=Just current}     f current acc@FoldAcc{fa_previous=Just previous} =-      if compare previous current+      if compare' previous current       then acc{fa_previous=Just current}       else acc{fa_error=Just current} @@ -55,5 +57,5 @@ foldWhile _ acc [] = acc foldWhile fold acc (a:as) =   case fold a acc of-   acc@FoldAcc{fa_error=Just _} -> acc-   acc -> foldWhile fold acc as+   acc'@FoldAcc{fa_error=Just _} -> acc'+   acc' -> foldWhile fold acc' as

@@ -1,4 +1,3 @@-{-# LANGUAGE NamedFieldPuns    #-} {-# LANGUAGE OverloadedStrings #-}  module Hledger.Data.JournalChecks.Uniqueleafnames (@@ -11,13 +10,13 @@ import Data.Text (Text) import qualified Data.Text as T import Text.Printf (printf)-import Data.Maybe (fromMaybe)  import Hledger.Data.AccountName (accountLeafName) import Hledger.Data.Errors (makePostingErrorExcerpt) import Hledger.Data.Journal (journalPostings, journalAccountNamesUsed) import Hledger.Data.Posting (isVirtual) import Hledger.Data.Types+import Hledger.Utils (chomp, textChomp)  -- | Check that all the journal's postings are to accounts with a unique leaf name. -- Otherwise, return an error message for the first offending posting.@@ -26,10 +25,34 @@   -- find all duplicate leafnames, and the full account names they appear in   case finddupes $ journalLeafAndFullAccountNames j of     [] -> Right ()-    dupes ->-      -- report the first posting that references one of them (and its position), for now-      mapM_ (checkposting dupes) $ journalPostings j+    -- pick the first duplicated leafname and show the transactions of+    -- the first two postings using it, highlighting the second as the error.+    (leaf,fulls):_ ->+      case filter ((`elem` fulls).paccount) $ journalPostings j of+        ps@(p:p2:_) -> Left $ chomp $ printf+          ("%s:%d:\n%s\nChecking for unique account leaf names is enabled, and\n"+          ++"account leaf name %s is not unique.\n"+          ++"It appears in these account names, which are used in %d places:\n%s"+          ++"\nConsider changing these account names so their last parts are different."+          )+          f l ex (show leaf) (length ps) accts+          where+            -- t = fromMaybe nulltransaction ptransaction  -- XXX sloppy+            (_,_,_,ex1) = makePostingErrorExcerpt p (\_ _ _ -> Nothing)+            (f,l,_,ex2) = makePostingErrorExcerpt p2 finderrcols+            -- separate the two excerpts by a space-beginning line to help flycheck-hledger parse them+            ex = T.unlines [textChomp ex1, T.pack " ...", textChomp ex2]+            finderrcols p' _ _ = Just (col, Just col2)+              where+                a = paccount p'+                alen = T.length a+                llen = T.length $ accountLeafName a+                col = 5 + (if isVirtual p' then 1 else 0) + alen - llen+                col2 = col + llen - 1+            accts = T.unlines fulls +        _ -> Right ()  -- shouldn't happen+ finddupes :: (Ord leaf, Eq full) => [(leaf, full)] -> [(leaf, [full])] finddupes leafandfullnames = zip dupLeafs dupAccountNames   where dupLeafs = map (fst . head) d@@ -42,24 +65,3 @@ journalLeafAndFullAccountNames :: Journal -> [(Text, AccountName)] journalLeafAndFullAccountNames = map leafAndAccountName . journalAccountNamesUsed   where leafAndAccountName a = (accountLeafName a, a)--checkposting :: [(Text,[AccountName])] -> Posting -> Either String ()-checkposting leafandfullnames p@Posting{paccount=a} =-  case [lf | lf@(_,fs) <- leafandfullnames, a `elem` fs] of-    []             -> Right ()-    (leaf,fulls):_ -> Left $ printf-      "%s:%d:%d-%d:\n%saccount leaf name \"%s\" is not unique\nit is used in account names: %s" -      f l col col2 ex leaf accts-      where-        -- t = fromMaybe nulltransaction ptransaction  -- XXX sloppy-        col  = maybe 0 fst mcols-        col2 = maybe 0 (fromMaybe 0 . snd) mcols-        (f,l,mcols,ex) = makePostingErrorExcerpt p finderrcols-          where-            finderrcols p _ _ = Just (col, Just col2)-              where-                alen = T.length $ paccount p-                llen = T.length $ accountLeafName a-                col = 5 + (if isVirtual p then 1 else 0) + alen - llen-                col2 = col + llen - 1-        accts = T.intercalate ", " $ map (("\""<>).(<>"\"")) fulls

@@ -59,7 +59,7 @@   where     (y', q') | q==4      = (y+1,1)              | otherwise = (y,q+1)-    quarterAsMonth q = (q-1) * 3 + 1+    quarterAsMonth q2 = (q2-1) * 3 + 1     m  = quarterAsMonth q     m' = quarterAsMonth q' periodAsDateSpan (YearPeriod y) = DateSpan (Just $ fromGregorian y 1 1) (Just $ fromGregorian (y+1) 1 1)

@@ -41,7 +41,7 @@           nullperiodictransaction{ ptperiodexpr=t , ptspan=s, ptinterval=i, ptpostings=["a" `post` usd 1] }           nulldatespan -_ptgenspan str span = do+_ptgenspan str spn = do   let     t = T.pack str     (i,s) = parsePeriodExpr' nulldate t@@ -51,7 +51,7 @@       mapM_ (T.putStr . showTransaction) $         runPeriodicTransaction           nullperiodictransaction{ ptperiodexpr=t , ptspan=s, ptinterval=i, ptpostings=["a" `post` usd 1] }-          span+          spn  --deriving instance Show PeriodicTransaction -- for better pretty-printing:@@ -73,7 +73,9 @@  --nullperiodictransaction is defined in Types.hs --- | Generate transactions from 'PeriodicTransaction' within a 'DateSpan'+-- | Generate transactions from 'PeriodicTransaction' within a 'DateSpan'.+-- This should be a closed span with both start and end dates specified;+-- an open ended span will generate no transactions. -- -- Note that new transactions require 'txnTieKnot' post-processing. -- The new transactions will have three tags added: 

@@ -61,6 +61,7 @@   postingsAsLines,   showAccountName,   renderCommentLines,+  showBalanceAssertion,   -- * misc.   postingTransformAmount,   postingApplyValuation,@@ -85,7 +86,7 @@ import Safe (maximumBound) import Text.DocLayout (realLength) -import Text.Tabular.AsciiWide+import Text.Tabular.AsciiWide hiding (render)  import Hledger.Utils import Hledger.Data.Types@@ -395,7 +396,7 @@     Right a -> Right p{paccount=a}     Left e  -> Left err       where-        err = "problem while applying account aliases:\n" ++ pshow aliases +        err = "problem while applying account aliases:\n" ++ pshow aliases           ++ "\n to account name: "++T.unpack paccount++"\n "++e  -- | Choose and apply a consistent display style to the posting@@ -419,19 +420,26 @@  -- | Maybe convert this 'Posting's amount to cost, and apply apply appropriate -- amount styles.-postingToCost :: M.Map CommoditySymbol AmountStyle -> ConversionOp -> Posting -> Posting-postingToCost _      NoConversionOp p = p-postingToCost styles ToCost         p = postingTransformAmount (styleMixedAmount styles . mixedAmountCost) p+postingToCost :: M.Map CommoditySymbol AmountStyle -> ConversionOp -> Posting -> Maybe Posting+postingToCost _      NoConversionOp p = Just p+postingToCost styles ToCost         p+    -- If this is a conversion posting with a matched transaction price posting, ignore it+    | "_conversion-matched" `elem` map fst (ptags p) && noCost = Nothing+    | otherwise = Just $ postingTransformAmount (styleMixedAmount styles . mixedAmountCost) p+  where+    noCost = (not . any (isJust . aprice) . amountsRaw) $ pamount p  -- | Generate inferred equity postings from a 'Posting' using transaction prices.+-- Make sure not to generate equity postings when there are already matched+-- conversion postings. postingAddInferredEquityPostings :: Text -> Posting -> [Posting]-postingAddInferredEquityPostings equityAcct p = taggedPosting : concatMap conversionPostings priceAmounts+postingAddInferredEquityPostings equityAcct p+    | "_price-matched" `elem` map fst (ptags p) = [p]+    | otherwise = taggedPosting : concatMap conversionPostings priceAmounts   where     taggedPosting       | null priceAmounts = p-      | otherwise         = p{ pcomment = pcomment p `commentAddTag` priceTag-                             , ptags = priceTag : ptags p-                             }+      | otherwise         = p{ ptags = ("_price-matched","") : ptags p }     conversionPostings amt = case aprice amt of         Nothing -> []         Just _  -> [ cp{ paccount = accountPrefix <> amtCommodity@@ -446,7 +454,7 @@         amtCommodity  = commodity amt         costCommodity = commodity cost         cp = p{ pcomment = pcomment p `commentAddTag` ("generated-posting","")-              , ptags = [("generated-posting", ""), ("_generated-posting", "")]+              , ptags = [("_conversion-matched", ""), ("generated-posting", ""), ("_generated-posting", "")]               , pbalanceassertion = Nothing               , poriginal = Nothing               }@@ -454,7 +462,6 @@         -- Take the commodity of an amount and collapse consecutive spaces to a single space         commodity = T.unwords . filter (not . T.null) . T.words . acommodity -    priceTag = ("cost", T.strip . wbToText $ foldMap showAmountPrice priceAmounts)     priceAmounts = filter (isJust . aprice) . amountsRaw $ pamount p  -- | Make a market price equivalent to this posting's amount's unit@@ -490,7 +497,7 @@ -- A space is inserted following the colon, before the value. commentAddTagNextLine :: Text -> Tag -> Text commentAddTagNextLine cmt (t,v) =-  cmt <> (if "\n" `T.isSuffixOf` cmt then "" else "\n") <> t <> ": " <> v +  cmt <> (if "\n" `T.isSuffixOf` cmt then "" else "\n") <> t <> ": " <> v   -- tests

@@ -4,7 +4,6 @@  {-# LANGUAGE FlexibleContexts  #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PackageImports    #-} {-# LANGUAGE TypeFamilies      #-}  module Hledger.Data.StringFormat (@@ -154,8 +153,8 @@ formatStringTester fs value expected = actual @?= expected   where     actual = case fs of-      FormatLiteral l                   -> formatText False Nothing Nothing l-      FormatField leftJustify min max _ -> formatText leftJustify min max value+      FormatLiteral l                 -> formatText False Nothing Nothing l+      FormatField leftJustify mn mx _ -> formatText leftJustify mn mx value  tests_StringFormat = testGroup "StringFormat" [ 

@@ -28,7 +28,6 @@ import Hledger.Data.Dates import Hledger.Data.Amount import Hledger.Data.Posting-import Hledger.Data.Transaction  instance Show TimeclockEntry where     show t = printf "%s %s %s  %s" (show $ tlcode t) (show $ tldatetime t) (tlaccount t) (tldescription t)@@ -65,10 +64,10 @@       o' = o{tldatetime=itime{localDay=idate, localTimeOfDay=TimeOfDay 23 59 59}}       i' = i{tldatetime=itime{localDay=addDays 1 idate, localTimeOfDay=midnight}} timeclockEntriesToTransactions 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+    | 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)@@ -76,10 +75,19 @@       i' = i{tldatetime=itime{localDay=addDays 1 idate, localTimeOfDay=midnight}} {- HLINT ignore timeclockEntriesToTransactions -} -errorExpectedCodeButGot expected actual = errorWithSourceLine line $ "expected timeclock code " ++ (show expected) ++ " but got " ++ show (tlcode actual)-    where line = unPos . sourceLine $ tlsourcepos actual--errorWithSourceLine line msg = error $ "line " ++ show line ++ ": " ++ msg+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)+  (replicate (length l) ' ' ++ " |" ++ replicate c ' ' ++ "^")+  (show expected)+  (show $ tlcode actual)+  where+    l = show $ unPos $ sourceLine $ tlsourcepos actual+    c = unPos $ sourceColumn $ tlsourcepos actual  -- | Convert a timeclock clockin and clockout entry to an equivalent journal -- transaction, representing the time expenditure. Note this entry is  not balanced,@@ -87,9 +95,23 @@ entryFromTimeclockInOut :: TimeclockEntry -> TimeclockEntry -> Transaction entryFromTimeclockInOut i o     | otime >= itime = t-    | otherwise = error' . T.unpack $-        "clock-out time less than clock-in time in:\n" <> showTransaction t  -- PARTIAL:+    | otherwise =+      -- Clockout time earlier than clockin is an error.+      -- (Clockin earlier than preceding clockin/clockout is allowed.)+      error' $ printf+        ("%s:\n%s\nThis clockout time (%s) is earlier than the previous clockin.\n"+        ++"Please adjust it to be later than %s.")+        (sourcePosPretty $ tlsourcepos o)+        (unlines [+          replicate (length l) ' '++ " | " ++ show i,+          l ++ " | " ++ show o,+          (replicate (length l) ' ' ++ " |" ++ replicate c ' ' ++ replicate 19 '^')+          ])+        (show $ tldatetime o)+        (show $ tldatetime i)     where+      l = show $ unPos $ sourceLine $ tlsourcepos o+      c = (unPos $ sourceColumn $ tlsourcepos o) + 2       t = Transaction {             tindex       = 0,             tsourcepos   = (tlsourcepos i, tlsourcepos i),@@ -117,8 +139,8 @@       -- 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).-      amount   = mixedAmount $ setAmountInternalPrecision 2 $ hrs hours-      ps       = [posting{paccount=acctname, pamount=amount, ptype=VirtualPosting, ptransaction=Just t}]+      amt   = mixedAmount $ setAmountInternalPrecision 2 $ hrs hours+      ps       = [posting{paccount=acctname, pamount=amt, ptype=VirtualPosting, ptransaction=Just t}]   -- tests

@@ -7,6 +7,7 @@  -} +{-# LANGUAGE MultiWayIf        #-} {-# LANGUAGE NamedFieldPuns    #-} {-# LANGUAGE OverloadedStrings #-} @@ -27,6 +28,7 @@ , transactionApplyValuation , transactionToCost , transactionAddInferredEquityPostings+, transactionAddPricesFromEquity , transactionApplyAliases , transactionMapPostings , transactionMapPostingAmounts@@ -43,17 +45,23 @@ , showTransactionOneLineAmounts , showTransactionLineFirstPart , transactionFile+  -- * transaction errors+, annotateErrorWithTransaction   -- * tests , tests_Transaction ) where -import Data.Maybe (fromMaybe)+import Control.Monad.Trans.State (StateT(..), evalStateT)+import Data.Bifunctor (first)+import Data.Foldable (foldrM)+import Data.Maybe (fromMaybe, isJust, mapMaybe)+import Data.Semigroup (Endo(..)) import Data.Text (Text)+import qualified Data.Map as M import qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Builder as TB import Data.Time.Calendar (Day, fromGregorian)-import qualified Data.Map as M  import Hledger.Utils import Hledger.Data.Types@@ -210,13 +218,128 @@ -- | Maybe convert this 'Transaction's amounts to cost and apply the -- appropriate amount styles. transactionToCost :: M.Map CommoditySymbol AmountStyle -> ConversionOp -> Transaction -> Transaction-transactionToCost styles cost = transactionMapPostings (postingToCost styles cost)+transactionToCost styles cost t = t{tpostings = mapMaybe (postingToCost styles cost) $ tpostings t}  -- | Add inferred equity postings to a 'Transaction' using transaction prices. transactionAddInferredEquityPostings :: AccountName -> Transaction -> Transaction transactionAddInferredEquityPostings equityAcct t =     t{tpostings=concatMap (postingAddInferredEquityPostings equityAcct) $ tpostings t} +-- | Add inferred transaction prices from equity postings. For every adjacent+-- pair of conversion postings, it will first search the postings with+-- transaction prices to see if any match. If so, it will tag it as matched.+-- If no postings with transaction prices match, it will then search the+-- postings without transaction prices, and will match the first such posting+-- which matches one of the conversion amounts. If it finds a match, it will+-- add a transaction price and then tag it.+type IdxPosting = (Int, Posting)+transactionAddPricesFromEquity :: M.Map AccountName AccountType -> Transaction -> Either String Transaction+transactionAddPricesFromEquity acctTypes t = first (annotateErrorWithTransaction t . T.unpack) $ do+    (conversionPairs, stateps) <- partitionPs npostings+    f <- transformIndexedPostingsF addPricesToPostings conversionPairs stateps+    return t{tpostings = map (snd . f) npostings}+  where+    -- Include indices for postings+    npostings = zip [0..] $ tpostings t+    transformIndexedPostingsF f = evalStateT . fmap (appEndo . foldMap Endo) . traverse f++    -- Sort postings into pairs of conversion postings, transaction price postings, and other postings+    partitionPs = fmap fst . foldrM select (([], ([], [])), Nothing)+    select np@(_, p) ((cs, others@(ps, os)), Nothing)+      | isConversion p = Right ((cs, others),      Just np)+      | hasPrice p     = Right ((cs, (np:ps, os)), Nothing)+      | otherwise      = Right ((cs, (ps, np:os)), Nothing)+    select np@(_, p) ((cs, others), Just lst)+      | isConversion p = Right (((lst, np):cs, others), Nothing)+      | otherwise      = Left "Conversion postings must occur in adjacent pairs"++    -- Given a pair of indexed conversion postings, and a state consisting of lists of+    -- priced and unpriced non-conversion postings, create a function which adds transaction+    -- prices to the posting which matches the conversion postings if necessary, and tags+    -- the conversion and matched postings. Then update the state by removing the matched+    -- postings. If there are no matching postings or too much ambiguity, return an error+    -- string annotated with the conversion postings.+    addPricesToPostings :: (IdxPosting, IdxPosting)+                        -> StateT ([IdxPosting], [IdxPosting]) (Either Text) (IdxPosting -> IdxPosting)+    addPricesToPostings ((n1, cp1), (n2, cp2)) = StateT $ \(priceps, otherps) -> do+        -- Get the two conversion posting amounts, if possible+        ca1 <- postingAmountNoPrice cp1+        ca2 <- postingAmountNoPrice cp2+        let -- The function to add transaction prices and tag postings in the indexed list of postings+            transformPostingF np pricep (n,p) =+              (n, if | n == np            -> pricep `postingAddTags` [("_price-matched","")]+                     | n == n1 || n == n2 -> p      `postingAddTags` [("_conversion-matched","")]+                     | otherwise          -> p)+            -- All priced postings which match the conversion posting pair+            matchingPricePs = mapMaybe (mapM $ pricedPostingIfMatchesBothAmounts ca1 ca2) priceps+            -- All other postings which match at least one of the conversion posting pair+            matchingOtherPs = mapMaybe (mapM $ addPriceIfMatchesOneAmount ca1 ca2) otherps++        -- Annotate any errors with the conversion posting pair+        first (annotateWithPostings [cp1, cp2]) $+            if -- If a single transaction price posting matches the conversion postings,+               -- delete it from the list of priced postings in the state, delete the+               -- first matching unpriced posting from the list of non-priced postings+               -- in the state, and return the transformation function with the new state.+               | [(np, (pricep, _))] <- matchingPricePs+               , Just newpriceps <- deleteIdx np priceps+                   -> Right (transformPostingF np pricep, (newpriceps, otherps))+               -- If no transaction price postings match the conversion postings, but some+               -- of the unpriced postings match, check that the first such posting has a+               -- different amount from all the others, and if so add a transaction price to+               -- it, then delete it from the list of non-priced postings in the state, and+               -- return the transformation function with the new state.+               | [] <- matchingPricePs+               , (np, (pricep, amt)):nps <- matchingOtherPs+               , not $ any (amountMatches amt . snd . snd) nps+               , Just newotherps <- deleteIdx np otherps+                   -> Right (transformPostingF np pricep, (priceps, newotherps))+               -- Otherwise it's too ambiguous to make a guess, so return an error.+               | otherwise -> Left "There is not a unique posting which matches the conversion posting pair:"++    -- If a posting with transaction price matches both the conversion amounts, return it along+    -- with the matching amount which must be present in another non-conversion posting.+    pricedPostingIfMatchesBothAmounts :: Amount -> Amount -> Posting -> Maybe (Posting, Amount)+    pricedPostingIfMatchesBothAmounts a1 a2 p = do+        a@Amount{aprice=Just _} <- postingSingleAmount p+        if | amountMatches (-a1) a && amountMatches a2 (amountCost a) -> Just (p, -a2)+           | amountMatches (-a2) a && amountMatches a1 (amountCost a) -> Just (p, -a1)+           | otherwise -> Nothing++    -- Add a transaction price to a posting if it matches (negative) one of the+    -- supplied conversion amounts, adding the other amount as the price+    addPriceIfMatchesOneAmount :: Amount -> Amount -> Posting -> Maybe (Posting, Amount)+    addPriceIfMatchesOneAmount a1 a2 p = do+        a <- postingSingleAmount p+        let newp price = p{pamount = mixedAmount a{aprice = Just $ TotalPrice price}}+        if | amountMatches (-a1) a -> Just (newp a2, a2)+           | amountMatches (-a2) a -> Just (newp a1, a1)+           | otherwise             -> Nothing++    hasPrice p = isJust $ aprice =<< postingSingleAmount p+    postingAmountNoPrice p = case postingSingleAmount p of+        Just a@Amount{aprice=Nothing} -> Right a+        _ -> Left $ annotateWithPostings [p] "The posting must only have a single amount with no transaction price"+    postingSingleAmount p = case amountsRaw (pamount p) of+        [a] -> Just a+        _   -> Nothing++    amountMatches a b = acommodity a == acommodity b && aquantity a == aquantity b+    isConversion p = M.lookup (paccount p) acctTypes == Just Conversion++    -- Delete a posting from the indexed list of postings based on either its+    -- index or its posting amount.+    -- Note: traversing the whole list to delete a single match is generally not efficient,+    -- but given that a transaction probably doesn't have more than four postings, it should+    -- still be more efficient than using a Map or another data structure. Even monster+    -- transactions with up to 10 postings, which are generally not a good+    -- idea, are still too small for there to be an advantage.+    deleteIdx n = deleteUniqueMatch ((n==) . fst)+    deleteUniqueMatch p (x:xs) | p x       = if any p xs then Nothing else Just xs+                               | otherwise = (x:) <$> deleteUniqueMatch p xs+    deleteUniqueMatch _ []                 = Nothing+    annotateWithPostings xs str = T.unlines $ str : postingsAsLines False xs+ -- | Apply some account aliases to all posting account names in the transaction, as described by accountNameApplyAliases. -- This can fail due to a bad replacement pattern in a regular expression alias. transactionApplyAliases :: [AccountAlias] -> Transaction -> Either RegexError Transaction@@ -236,6 +359,13 @@ -- | The file path from which this transaction was parsed. transactionFile :: Transaction -> FilePath transactionFile Transaction{tsourcepos} = sourceName $ fst tsourcepos++-- Add transaction information to an error message.+annotateErrorWithTransaction :: Transaction -> String -> String+annotateErrorWithTransaction t s =+  unlines [ sourcePosPairPretty $ tsourcepos t, s+          , T.unpack . T.stripEnd $ showTransaction t+          ]  -- tests 

@@ -76,7 +76,7 @@ -- 0000-01-01 --     ping           $1.00 -- <BLANKLINE>--- >>> test $ TransactionModifier "ping" [("pong" `tmpost` amount{aquantity=3}){tmprIsMultiplier=True}]+-- >>> test $ TransactionModifier "ping" [("pong" `tmpost` nullamt{aquantity=3}){tmprIsMultiplier=True}] -- 0000-01-01 --     ping           $1.00 --     pong           $3.00  ; generated-posting: = ping

@@ -49,7 +49,7 @@ import Data.Time.LocalTime (LocalTime) import Data.Word (Word8) import Text.Blaze (ToMarkup(..))-import Text.Megaparsec (SourcePos)+import Text.Megaparsec (SourcePos(SourcePos), mkPos)  import Hledger.Utils.Regex @@ -585,12 +585,14 @@   ,aditags             :: [Tag]  -- ^ tags extracted from the account comment, if any   ,adideclarationorder :: Int    -- ^ the order in which this account was declared,                                  --   relative to other account declarations, during parsing (1..)+  ,adisourcepos        :: SourcePos  -- ^ source file and position } deriving (Eq,Show,Generic)  nullaccountdeclarationinfo = AccountDeclarationInfo {    adicomment          = ""   ,aditags             = []   ,adideclarationorder = 0+  ,adisourcepos        = SourcePos "" (mkPos 1) (mkPos 1) }  -- | An account, with its balances, parent/subaccount relationships, etc.

@@ -193,7 +193,7 @@                                       -- Make default display style use precision 2 instead of 0 ?                                       -- Leave as is for now; mentioned in manual.       styleAmount styles-      amount{acommodity=comm, aquantity=rate * aquantity a}+      nullamt{acommodity=comm, aquantity=rate * aquantity a}  -- | Calculate the gain of each component amount, that is the difference -- between the valued amount and the value of the cost basis (see

@@ -67,7 +67,7 @@   matchesTags,   matchesPriceDirective,   words'',-  prefixes,+  queryprefixes,   -- * tests   tests_Query )@@ -167,7 +167,7 @@ -- >>> parseQuery nulldate "\"expenses:dining out\"" -- Right (Acct (RegexpCI "expenses:dining out"),[]) parseQuery :: Day -> T.Text -> Either String (Query,[QueryOpt])-parseQuery d = parseQueryList d . words'' prefixes+parseQuery d = parseQueryList d . words'' queryprefixes  -- | Convert a list of query expression containing to a query and zero -- or more query options; or return an error message if query parsing fails.@@ -234,8 +234,8 @@  -- XXX -- keep synced with patterns below, excluding "not"-prefixes :: [T.Text]-prefixes = map (<>":") [+queryprefixes :: [T.Text]+queryprefixes = map (<>":") [      "inacctonly"     ,"inacct"     ,"amt"@@ -285,10 +285,10 @@ parseQueryTerm _ (T.stripPrefix "acct:" -> Just s) = Left . Acct <$> toRegexCI s parseQueryTerm d (T.stripPrefix "date2:" -> Just s) =         case parsePeriodExpr d s of Left e         -> Left $ "\"date2:"++T.unpack s++"\" gave a "++showDateParseError e-                                    Right (_,span) -> Right $ Left $ Date2 span+                                    Right (_,spn) -> Right $ Left $ Date2 spn parseQueryTerm d (T.stripPrefix "date:" -> Just s) =         case parsePeriodExpr d s of Left e         -> Left $ "\"date:"++T.unpack s++"\" gave a "++showDateParseError e-                                    Right (_,span) -> Right $ Left $ Date span+                                    Right (_,spn) -> Right $ Left $ Date spn parseQueryTerm _ (T.stripPrefix "status:" -> Just s) =         case parseStatus s of Left e   -> Left $ "\"status:"++T.unpack s++"\" gave a parse error: " ++ e                               Right st -> Right $ Left $ StatusQ st@@ -412,9 +412,9 @@ -- * modifying  simplifyQuery :: Query -> Query-simplifyQuery q =-  let q' = simplify q-  in if q' == q then q else simplifyQuery q'+simplifyQuery q0 =+  let q1 = simplify q0+  in if q1 == q0 then q0 else simplifyQuery q1   where     simplify (And []) = Any     simplify (And [q]) = simplify q@@ -455,7 +455,7 @@ -- (Since 1.24.1, might be merged into filterQuery in future.) -- XXX Semantics not completely clear. filterQueryOrNotQuery :: (Query -> Bool) -> Query -> Query-filterQueryOrNotQuery p = simplifyQuery . filterQueryOrNotQuery' p+filterQueryOrNotQuery p0 = simplifyQuery . filterQueryOrNotQuery' p0   where     filterQueryOrNotQuery' :: (Query -> Bool) -> Query -> Query     filterQueryOrNotQuery' p (And qs)      = And $ map (filterQueryOrNotQuery p) qs@@ -584,7 +584,7 @@ queryEndDate True (Date2 (DateSpan _ (Just d))) = Just d queryEndDate _ _ = Nothing -queryTermDateSpan (Date span) = Just span+queryTermDateSpan (Date spn) = Just spn queryTermDateSpan _ = Nothing  -- | What date span (or with a true argument, what secondary date span) does this query specify ?@@ -594,8 +594,8 @@ queryDateSpan :: Bool -> Query -> DateSpan queryDateSpan secondary (Or qs)  = spansUnion     $ map (queryDateSpan secondary) qs queryDateSpan secondary (And qs) = spansIntersect $ map (queryDateSpan secondary) qs-queryDateSpan _     (Date span)  = span-queryDateSpan True (Date2 span)  = span+queryDateSpan _     (Date spn)  = spn+queryDateSpan True (Date2 spn)  = spn queryDateSpan _ _                = nulldatespan  -- | What date span does this query specify, treating primary and secondary dates as equivalent ?@@ -605,8 +605,8 @@ queryDateSpan' :: Query -> DateSpan queryDateSpan' (Or qs)      = spansUnion     $ map queryDateSpan' qs queryDateSpan' (And qs)     = spansIntersect $ map queryDateSpan' qs-queryDateSpan' (Date span)  = span-queryDateSpan' (Date2 span) = span+queryDateSpan' (Date spn)  = spn+queryDateSpan' (Date2 spn) = spn queryDateSpan' _            = nulldatespan  -- | What is the earliest of these dates, where Nothing is earliest ?@@ -732,16 +732,16 @@ 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-matchesPosting (Date span) p = span `spanContainsDate` postingDate p-matchesPosting (Date2 span) p = span `spanContainsDate` postingDate2 p+matchesPosting (Date spn) p = spn `spanContainsDate` postingDate p+matchesPosting (Date2 spn) p = spn `spanContainsDate` postingDate2 p matchesPosting (StatusQ s) p = postingStatus p == s matchesPosting (Real v) p = v == isReal p matchesPosting q@(Depth _) Posting{paccount=a} = q `matchesAccount` a matchesPosting q@(Amt _ _) Posting{pamount=as} = q `matchesMixedAmount` as matchesPosting (Sym r) Posting{pamount=as} = any (matchesCommodity (Sym r) . acommodity) $ amountsRaw as matchesPosting (Tag n v) p = case (reString n, v) of-  ("payee", Just v) -> maybe False (regexMatchText v . transactionPayee) $ ptransaction p-  ("note", Just v) -> maybe False (regexMatchText v . transactionNote) $ ptransaction p+  ("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 matchesPosting (Type _) _ = False @@ -765,17 +765,17 @@ 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-matchesTransaction (Date span) t = spanContainsDate span $ tdate t-matchesTransaction (Date2 span) t = spanContainsDate span $ transactionDate2 t+matchesTransaction (Date spn) t = spanContainsDate spn $ tdate t+matchesTransaction (Date2 spn) t = spanContainsDate spn $ transactionDate2 t matchesTransaction (StatusQ s) t = tstatus t == s matchesTransaction (Real v) t = v == hasRealPostings t matchesTransaction q@(Amt _ _) t = any (q `matchesPosting`) $ tpostings t matchesTransaction (Depth d) t = any (Depth d `matchesPosting`) $ tpostings t matchesTransaction q@(Sym _) t = any (q `matchesPosting`) $ tpostings t 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+  ("payee", Just v') -> regexMatchText v' $ transactionPayee t+  ("note", Just v') -> regexMatchText v' $ transactionNote t+  (_, v') -> matchesTags n v' $ transactionAllTags t matchesTransaction (Type _) _ = False  -- | Like matchesTransaction, but if the journal's account types are provided,@@ -821,7 +821,7 @@ matchesPriceDirective (And qs) p    = all (`matchesPriceDirective` p) qs matchesPriceDirective q@(Amt _ _) p = matchesAmount q (pdamount p) matchesPriceDirective q@(Sym _) p   = matchesCommodity q (pdcommodity p)-matchesPriceDirective (Date span) p = spanContainsDate span (pddate p)+matchesPriceDirective (Date spn) p = spanContainsDate spn (pddate p) matchesPriceDirective _ _           = True  @@ -854,8 +854,8 @@       (words'' [] "not:'a b'")             @?= ["not:a b"]       (words'' [] "'not:a b'")             @?= ["not:a b"]       (words'' ["desc:"] "not:desc:'a b'") @?= ["not:desc:a b"]-      (words'' prefixes "\"acct:expenses:autres d\233penses\"") @?= ["acct:expenses:autres d\233penses"]-      (words'' prefixes "\"")              @?= ["\""]+      (words'' queryprefixes "\"acct:expenses:autres d\233penses\"") @?= ["acct:expenses:autres d\233penses"]+      (words'' queryprefixes "\"")              @?= ["\""]    ,testCase "filterQuery" $ do      filterQuery queryIsDepth Any       @?= Any

@@ -69,7 +69,7 @@ import System.Directory (doesFileExist, getHomeDirectory) import System.Environment (getEnv) import System.Exit (exitFailure)-import System.FilePath ((<.>), (</>), splitDirectories, splitFileName)+import System.FilePath ((<.>), (</>), splitDirectories, splitFileName, takeFileName) import System.Info (os) import System.IO (hPutStr, stderr) @@ -108,15 +108,15 @@ defaultJournalPath :: IO String defaultJournalPath = do   s <- envJournalPath-  if null s then defaultJournalPath else return s+  if null s then defpath else return s     where       envJournalPath =         getEnv journalEnvVar          `C.catch` (\(_::C.IOException) -> getEnv journalEnvVar2                                             `C.catch` (\(_::C.IOException) -> return ""))-      defaultJournalPath = do-                  home <- getHomeDirectory `C.catch` (\(_::C.IOException) -> return "")-                  return $ home </> journalDefaultFilename+      defpath = do+        home <- getHomeDirectory `C.catch` (\(_::C.IOException) -> return "")+        return $ home </> journalDefaultFilename  -- | A file path optionally prefixed by a reader name and colon -- (journal:, csv:, timedot:, etc.).@@ -139,9 +139,8 @@ -- since hledger 1.17, we prefer predictability.) readJournal :: InputOpts -> Maybe FilePath -> Text -> ExceptT String IO Journal readJournal iopts mpath txt = do-  let r :: Reader IO =-        fromMaybe JournalReader.reader $ findReader (mformat_ iopts) mpath-  dbg6IO "trying reader" (rFormat r)+  let r :: Reader IO = fromMaybe JournalReader.reader $ findReader (mformat_ iopts) mpath+  dbg6IO "readJournal: trying reader" (rFormat r)   rReadFn r iopts (fromMaybe "(string)" mpath) txt  -- | Read a Journal from this file, or from stdin if the file path is -,@@ -161,7 +160,9 @@     (mfmt, f) = splitReaderPrefix prefixedfile     iopts' = iopts{mformat_=asum [mfmt, mformat_ iopts]}   liftIO $ requireJournalFileExists f-  t <- liftIO $ readFileOrStdinPortably f+  t <-+    traceAt 6 ("readJournalFile: "++takeFileName f) $+    liftIO $ readFileOrStdinPortably f     -- <- T.readFile f  -- or without line ending translation, for testing   j <- readJournal iopts' (Just f) t   if new_ iopts

@@ -141,13 +141,14 @@ import Text.Megaparsec.Char (char, char', digitChar, newline, string) import Text.Megaparsec.Char.Lexer (decimal) import Text.Megaparsec.Custom-  (FinalParseError, attachSource, customErrorBundlePretty, finalErrorBundlePretty, parseErrorAt, parseErrorAtRegion, HledgerParseErrors)+  (FinalParseError, attachSource, customErrorBundlePretty, finalErrorBundlePretty, parseErrorAt, parseErrorAtRegion)  import Hledger.Data import Hledger.Query (Query(..), filterQuery, parseQueryTerm, queryEndDate, queryStartDate, queryIsDate, simplifyQuery) import Hledger.Reports.ReportOptions (ReportOpts(..), queryFromFlags, rawOptsToReportOpts) import Hledger.Utils import Hledger.Read.InputOptions+import System.FilePath (takeFileName)  --- ** doctest setup -- $setup@@ -194,10 +195,10 @@         argsquery = lefts . rights . map (parseQueryTerm day) $ querystring_ ropts         datequery = simplifyQuery . filterQuery queryIsDate . And $ queryFromFlags ropts : argsquery -        commodity_styles = either err id $ commodityStyleFromRawOpts rawopts+        styles = either err id $ commodityStyleFromRawOpts rawopts           where err e = error' $ "could not parse commodity-style: '" ++ e ++ "'"  -- PARTIAL: -    in InputOpts{+    in definputopts{        -- files_             = listofstringopt "file" rawopts        mformat_           = Nothing       ,mrules_file_       = maybestringopt "rules-file" rawopts@@ -210,10 +211,11 @@       ,reportspan_        = DateSpan (queryStartDate False datequery) (queryEndDate False datequery)       ,auto_              = boolopt "auto" rawopts       ,infer_equity_      = boolopt "infer-equity" rawopts && conversionop_ ropts /= Just ToCost+      ,infer_costs_       = boolopt "infer-costs" rawopts       ,balancingopts_     = defbalancingopts{                                  ignore_assertions_ = boolopt "ignore-assertions" rawopts                                , infer_transaction_prices_ = not noinferprice-                               , commodity_styles_  = Just commodity_styles+                               , commodity_styles_  = Just styles                                }       ,strict_            = boolopt "strict" rawopts       ,_ioDay             = day@@ -305,7 +307,7 @@ -- - check all commodities have been declared if in strict mode -- journalFinalise :: InputOpts -> FilePath -> Text -> ParsedJournal -> ExceptT String IO Journal-journalFinalise iopts@InputOpts{auto_,infer_equity_,balancingopts_,strict_,_ioDay} f txt pj = do+journalFinalise iopts@InputOpts{..} f txt pj = do   t <- liftIO getPOSIXTime   liftEither $ do     j <- pj{jglobalcommoditystyles=fromMaybe mempty $ commodity_styles_ balancingopts_}@@ -319,9 +321,14 @@       >>= (if auto_ && not (null $ jtxnmodifiers pj)               then journalAddAutoPostings _ioDay balancingopts_  -- Add auto postings if enabled, and account tags if needed               else pure)-      >>= journalBalanceTransactions balancingopts_      -- Balance all transactions and maybe check balance assertions.-      <&> (if infer_equity_ then journalAddInferredEquityPostings else id)  -- Add inferred equity postings, after balancing transactions and generating auto postings+      >>= (if infer_costs_  then journalAddPricesFromEquity else pure)      -- Add inferred transaction prices from equity postings, if present+      >>= journalBalanceTransactions balancingopts_                         -- Balance all transactions and maybe check balance assertions.+      <&> (if infer_equity_ then journalAddInferredEquityPostings else id)  -- Add inferred equity postings, after balancing and generating auto postings       <&> journalInferMarketPricesFromTransactions       -- infer market prices from commodity-exchanging transactions+      <&> traceAt 6 ("journalFinalise: " <> takeFileName f)  -- debug logging+      <&> dbgJournalAcctDeclOrder ("journalFinalise: " <> takeFileName f <> "   acct decls           : ")+      <&> journalRenumberAccountDeclarations+      <&> dbgJournalAcctDeclOrder ("journalFinalise: " <> takeFileName f <> "   acct decls renumbered: ")     when strict_ $ do       journalCheckAccounts j                     -- If in strict mode, check all postings are to declared accounts       journalCheckCommodities j                  -- and using declared commodities@@ -439,8 +446,8 @@ -- A version of `match` that is strict in the returned text match' :: TextParser m a -> TextParser m (Text, a) match' p = do-  (!txt, p) <- match p-  pure (txt, p)+  (!txt, p') <- match p+  pure (txt, p')  --- ** parsers --- *** transaction bits@@ -498,26 +505,28 @@       let dateStr = show year ++ [sep1] ++ show month ++ [sep2] ++ show day        when (sep1 /= sep2) $ customFailure $ parseErrorAtRegion startOffset endOffset $-        "invalid date: separators are different, should be the same"+        "This date is malformed because the separators are different.\n"+        ++"Please use consistent separators."        case fromGregorianValid year month day of         Nothing -> customFailure $ parseErrorAtRegion startOffset endOffset $-                     "well-formed but invalid date: " ++ dateStr+                     "This date is invalid, please correct it: " ++ dateStr         Just date -> pure $! date      partialDate :: Int -> Maybe Year -> Month -> Char -> MonthDay -> TextParser m Day-    partialDate startOffset mYear month sep day = do+    partialDate startOffset myr month sep day = do       endOffset <- getOffset-      case mYear of+      case myr of         Just year ->           case fromGregorianValid year month day of             Nothing -> customFailure $ parseErrorAtRegion startOffset endOffset $-                        "well-formed but invalid date: " ++ dateStr+                        "This date is invalid, please correct it: " ++ dateStr             Just date -> pure $! date           where dateStr = show year ++ [sep] ++ show month ++ [sep] ++ show day          Nothing -> customFailure $ parseErrorAtRegion startOffset endOffset $-          "partial date "++dateStr++" found, but the current year is unknown"+          "The partial date "++dateStr++" can not be parsed because the current year is unknown.\n"+          ++"Consider making it a full date, or add a default year directive.\n"           where dateStr = show month ++ [sep] ++ show day  {-# INLINABLE datep' #-}@@ -602,12 +611,12 @@ modifiedaccountnamep :: JournalParser m AccountName modifiedaccountnamep = do   parent  <- getParentAccount-  aliases <- getAccountAliases+  als     <- getAccountAliases   -- off1    <- getOffset   a       <- lift accountnamep   -- off2    <- getOffset   -- XXX or accountNameApplyAliasesMemo ? doesn't seem to make a difference (retest that function)-  case accountNameApplyAliases aliases $ joinAccountNames parent a of+  case accountNameApplyAliases als $ joinAccountNames parent a of     Right a' -> return $! a'     -- should not happen, regexaliasp will have displayed a better error already:     -- (XXX why does customFailure cause error to be displayed there, but not here ?)@@ -651,12 +660,12 @@ -- | Parse non-empty, single-spaced text starting and ending with non-whitespace, -- where all characters satisfy the given predicate. singlespacedtextsatisfying1p :: (Char -> Bool) -> TextParser m T.Text-singlespacedtextsatisfying1p pred = do+singlespacedtextsatisfying1p f = do   firstPart <- partp   otherParts <- many $ try $ singlespacep *> partp   pure $! T.unwords $ firstPart : otherParts   where-    partp = takeWhile1P Nothing (\c -> pred c && not (isSpace c))+    partp = takeWhile1P Nothing (\c -> f c && not (isSpace c))  -- | Parse one non-newline whitespace character that is not followed by another one. singlespacep :: TextParser m ()@@ -699,20 +708,20 @@ amountpwithmultiplier :: Bool -> JournalParser m Amount amountpwithmultiplier mult = label "amount" $ do   let spaces = lift $ skipNonNewlineSpaces-  amount <- amountwithoutpricep mult <* spaces+  amt <- amountwithoutpricep mult <* spaces   (mprice, _elotprice, _elotdate) <- runPermutation $-    (,,) <$> toPermutationWithDefault Nothing (Just <$> priceamountp amount <* spaces)+    (,,) <$> toPermutationWithDefault Nothing (Just <$> priceamountp amt <* spaces)          <*> toPermutationWithDefault Nothing (Just <$> lotpricep <* spaces)          <*> toPermutationWithDefault Nothing (Just <$> lotdatep <* spaces)-  pure $ amount { aprice = mprice }+  pure $ amt { aprice = mprice }  amountpnolotpricesp :: JournalParser m Amount amountpnolotpricesp = label "amount" $ do   let spaces = lift $ skipNonNewlineSpaces-  amount <- amountwithoutpricep False+  amt <- amountwithoutpricep False   spaces-  mprice <- optional $ priceamountp amount <* spaces-  pure $ amount { aprice = mprice }+  mprice <- optional $ priceamountp amt <* spaces+  pure $ amt { aprice = mprice }  amountwithoutpricep :: Bool -> JournalParser m Amount amountwithoutpricep mult = do@@ -1085,8 +1094,8 @@  -- | A custom show instance, showing digit groups as the parser saw them. instance Show DigitGrp where-  show (DigitGrp len num) = "\"" ++ padding ++ numStr ++ "\""-    where numStr = show num+  show (DigitGrp len n) = "\"" ++ padding ++ numStr ++ "\""+    where numStr = show n           padding = genericReplicate (toInteger len - toInteger (length numStr)) '0'  instance Sem.Semigroup DigitGrp where@@ -1147,18 +1156,20 @@ isSameLineCommentStart ';' = True isSameLineCommentStart _   = False --- A parser combinator for parsing (possibly multiline) comments--- following journal items.+-- A parser for (possibly multiline) comments following a journal item. ----- Several journal items may be followed by comments, which begin with--- semicolons and extend to the end of the line. Such comments may span--- multiple lines, but comment lines below the journal item must be--- preceded by leading whitespace.+-- Comments following a journal item begin with a semicolon and extend to+-- the end of the line. They may span multiple lines; any comment lines +-- not on the same line as the journal item must be indented (preceded by+-- leading whitespace). ----- This parser combinator accepts a parser that consumes all input up--- until the next newline. This parser should extract the "content" from--- comments. The resulting parser returns this content plus the raw text--- of the comment itself.+-- Like Ledger, we sometimes allow data to be embedded in comments. Eg,+-- comments on the account directive and on transactions can contain tags,+-- and comments on postings can contain tags and/or bracketed posting dates.+-- To handle these variations, this parser takes as parameter a subparser,+-- which should consume all input up until the next newline, and which can+-- optionally extract some kind of data from it.+-- followingcommentp' returns this data along with the full text of the comment. -- -- See followingcommentp for tests. --@@ -1389,10 +1400,10 @@ -- Left ...not a bracketed date... -- -- >>> either (Left . customErrorBundlePretty) Right $ rtp (bracketeddatetagsp Nothing) "[2016/1/32]"--- Left ...1:2:...well-formed but invalid date: 2016/1/32...+-- Left ...1:2:...This date is invalid... -- -- >>> either (Left . customErrorBundlePretty) Right $ rtp (bracketeddatetagsp Nothing) "[1/31]"--- Left ...1:2:...partial date 1/31 found, but the current year is unknown...+-- Left ...1:2:...The partial date 1/31 can not be parsed... -- -- >>> either (Left . customErrorBundlePretty) Right $ rtp (bracketeddatetagsp Nothing) "[0123456789/-.=/-.=]" -- Left ...1:13:...expecting month or day...@@ -1469,24 +1480,24 @@    ,testCase "unit price"             $ assertParseEq amountp "$10 @ €0.5"       -- not precise enough:       -- (usd 10 `withPrecision` 0 `at` (eur 0.5 `withPrecision` 1)) -- `withStyle` asdecimalpoint=Just '.'-      amount{+      nullamt{          acommodity="$"         ,aquantity=10 -- need to test internal precision with roundTo ? I think not         ,astyle=amountstyle{asprecision=Precision 0, asdecimalpoint=Nothing}         ,aprice=Just $ UnitPrice $-          amount{+          nullamt{              acommodity="€"             ,aquantity=0.5             ,astyle=amountstyle{asprecision=Precision 1, asdecimalpoint=Just '.'}             }         }    ,testCase "total price"            $ assertParseEq amountp "$10 @@ €5"-      amount{+      nullamt{          acommodity="$"         ,aquantity=10         ,astyle=amountstyle{asprecision=Precision 0, asdecimalpoint=Nothing}         ,aprice=Just $ TotalPrice $-          amount{+          nullamt{              acommodity="€"             ,aquantity=5             ,astyle=amountstyle{asprecision=Precision 0, asdecimalpoint=Nothing}

@@ -13,9 +13,7 @@ --- ** language {-# LANGUAGE FlexibleContexts     #-} {-# LANGUAGE FlexibleInstances    #-}-{-# LANGUAGE MultiWayIf           #-} {-# LANGUAGE OverloadedStrings    #-}-{-# LANGUAGE PackageImports       #-} {-# LANGUAGE RecordWildCards      #-} {-# LANGUAGE ScopedTypeVariables  #-} {-# LANGUAGE TypeFamilies         #-}@@ -38,7 +36,7 @@  --- ** imports import Control.Applicative        (liftA2)-import Control.Monad              (unless, when)+import Control.Monad              (unless, when, void) import Control.Monad.Except       (ExceptT(..), liftEither, throwError) import qualified Control.Monad.Fail as Fail import Control.Monad.IO.Class     (MonadIO, liftIO)@@ -104,13 +102,13 @@ parse iopts f t = do   let rulesfile = mrules_file_ iopts   readJournalFromCsv rulesfile f t-  -- 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   -- 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 t  --- ** reading rules files@@ -193,14 +191,14 @@ -- Included file paths may be relative to the directory of the provided file path. -- This is done as a pre-parse step to simplify the CSV rules parser. expandIncludes :: FilePath -> Text -> IO Text-expandIncludes dir content = mapM (expandLine dir) (T.lines content) >>= return . T.unlines+expandIncludes dir0 content = mapM (expandLine dir0) (T.lines content) <&> T.unlines   where-    expandLine dir line =+    expandLine dir1 line =       case line of-        (T.stripPrefix "include " -> Just f) -> expandIncludes dir' =<< T.readFile f'+        (T.stripPrefix "include " -> Just f) -> expandIncludes dir2 =<< T.readFile f'           where-            f' = dir </> T.unpack (T.dropWhile isSpace f)-            dir' = takeDirectory f'+            f' = dir1 </> T.unpack (T.dropWhile isSpace f)+            dir2 = takeDirectory f'         _ -> return line  -- | An error-throwing IO action that parses this text as CSV conversion rules@@ -257,7 +255,7 @@  instance Eq CsvRules where   r1 == r2 = (rdirectives r1, rcsvfieldindexes r1, rassignments r1) ==-             (rdirectives r2, rcsvfieldindexes r2, rassignments r2) +             (rdirectives r2, rcsvfieldindexes r2, rassignments r2)  -- Custom Show instance used for debug output: omit the rblocksassigning field, which isn't showable. instance Show CsvRules where@@ -582,7 +580,7 @@   newline   body <- flip manyTill (lift eolof) $ do     off <- getOffset-    m <- matcherp' (char sep >> return ())+    m <- matcherp' $ void $ char sep     vs <- T.split (==sep) . T.pack <$> lift restofline     if (length vs /= length fields)       then customFailure $ parseErrorAt off $ ((printf "line of conditional table should have %d values, but this one has only %d" (length fields) (length vs)) :: String)@@ -745,8 +743,8 @@       -- than one date and the first date is more recent than the last):       -- reverse them to get same-date transactions ordered chronologically.       txns' =-        (if newestfirst || mdataseemsnewestfirst == Just True -          then dbg7 "reversed csv txns" . reverse else id) +        (if newestfirst || mdataseemsnewestfirst == Just True+          then dbg7 "reversed csv txns" . reverse else id)           txns         where           newestfirst = dbg6 "newestfirst" $ isJust $ getDirective "newest-first" rules@@ -757,7 +755,7 @@       -- Second, sort by date.       txns'' = dbg7 "date-sorted csv txns" $ sortBy (comparing tdate) txns' -    liftIO $ when (not rulesfileexists) $ do+    liftIO $ unless rulesfileexists $ do       dbg1IO "creating conversion rules file" rulesfile       T.writeFile rulesfile rulestext @@ -804,7 +802,7 @@ validateCsv rules numhdrlines = validate . applyConditionalSkips . drop numhdrlines . filternulls   where     filternulls = filter (/=[""])-    skipCount r =+    skipnum r =       case (getEffectiveAssignment rules r "end", getEffectiveAssignment rules r "skip") of         (Nothing, Nothing) -> Nothing         (Just _, _) -> Just maxBound@@ -812,7 +810,7 @@         (Nothing, Just x) -> Just (read $ T.unpack x)     applyConditionalSkips [] = []     applyConditionalSkips (r:rest) =-      case skipCount r of+      case skipnum r of         Nothing -> r:(applyConditionalSkips rest)         Just cnt -> applyConditionalSkips (drop (cnt-1) rest)     validate [] = Right []@@ -869,15 +867,15 @@     field    = hledgerField      rules record :: HledgerFieldName -> Maybe FieldTemplate     fieldval = hledgerFieldValue rules record :: HledgerFieldName -> Maybe Text     parsedate = parseDateWithCustomOrDefaultFormats (rule "date-format")-    mkdateerror datefield datevalue mdateformat = T.unpack $ T.unlines+    mkdateerror datefield datevalue mdateformat' = T.unpack $ T.unlines       ["error: could not parse \""<>datevalue<>"\" as a date using date format "-        <>maybe "\"YYYY/M/D\", \"YYYY-M-D\" or \"YYYY.M.D\"" (T.pack . show) mdateformat+        <>maybe "\"YYYY/M/D\", \"YYYY-M-D\" or \"YYYY.M.D\"" (T.pack . show) mdateformat'       ,showRecord record       ,"the "<>datefield<>" rule is:   "<>(fromMaybe "required, but missing" $ field datefield)-      ,"the date-format is: "<>fromMaybe "unspecified" mdateformat+      ,"the date-format is: "<>fromMaybe "unspecified" mdateformat'       ,"you may need to "         <>"change your "<>datefield<>" rule, "-        <>maybe "add a" (const "change your") mdateformat<>" date-format rule, "+        <>maybe "add a" (const "change your") mdateformat'<>" date-format rule, "         <>"or "<>maybe "add a" (const "change your") mskip<>" skip rule"       ,"for m/d/y or d/m/y dates, use date-format %-m/%-d/%Y or date-format %-d/%-m/%Y"       ]@@ -894,7 +892,7 @@     -- PARTIAL:     date'       = fromMaybe (error' $ mkdateerror "date" date mdateformat) $ parsedate date     mdate2      = fieldval "date2"-    mdate2'     = maybe Nothing (maybe (error' $ mkdateerror "date2" (fromMaybe "" mdate2) mdateformat) Just . parsedate) mdate2+    mdate2'     = (maybe (error' $ mkdateerror "date2" (fromMaybe "" mdate2) mdateformat) Just . parsedate) =<< mdate2     status      =       case fieldval "status" of         Nothing -> Unmarked@@ -904,12 +902,12 @@               ["error: could not parse \""<>s<>"\" as a cleared status (should be *, ! or empty)"               ,"the parse error is:      "<>T.pack (customErrorBundlePretty err)               ]-    code        = maybe "" singleline $ fieldval "code"-    description = maybe "" singleline $ fieldval "description"+    code        = maybe "" singleline' $ fieldval "code"+    description = maybe "" singleline' $ fieldval "description"     comment     = maybe "" unescapeNewlines $ fieldval "comment"     precomment  = maybe "" unescapeNewlines $ fieldval "precomment" -    singleline = T.unwords . filter (not . T.null) . map T.strip . T.lines+    singleline' = T.unwords . filter (not . T.null) . map T.strip . T.lines     unescapeNewlines = T.intercalate "\n" . T.splitOn "\\n"      ----------------------------------------------------------------------@@ -918,7 +916,7 @@      p1IsVirtual = (accountNamePostingType <$> fieldval "account1") == Just VirtualPosting     ps = [p | n <- [1..maxpostings]-         ,let comment  = maybe "" unescapeNewlines $ fieldval ("comment"<> T.pack (show n))+         ,let cmt  = maybe "" unescapeNewlines $ fieldval ("comment"<> T.pack (show n))          ,let currency = fromMaybe "" (fieldval ("currency"<> T.pack (show n)) <|> fieldval "currency")          ,let mamount  = getAmount rules record currency p1IsVirtual n          ,let mbalance = getBalance rules record currency n@@ -930,7 +928,7 @@                              ,pamount           = fromMaybe missingmixedamt mamount                              ,ptransaction      = Just t                              ,pbalanceassertion = mkBalanceAssertion rules record <$> mbalance-                             ,pcomment          = comment+                             ,pcomment          = cmt                              ,ptype             = accountNamePostingType acct                              }          ]@@ -967,7 +965,7 @@     unnumberedfieldnames = ["amount","amount-in","amount-out"]      -- amount field names which can affect this posting-    fieldnames = map (("amount"<> T.pack(show n))<>) ["","-in","-out"]+    fieldnames = map (("amount"<> T.pack (show n))<>) ["","-in","-out"]                  -- For posting 1, also recognise the old amount/amount-in/amount-out names.                  -- For posting 2, the same but only if posting 1 needs balancing.                  ++ if n==1 || n==2 && not p1IsVirtual then unnumberedfieldnames else []@@ -999,17 +997,53 @@   in case discardExcessZeros $ discardUnnumbered assignments of       []      -> Nothing       [(f,a)] -> Just $ negateIfOut f a-      fs      -> error' . T.unpack . T.unlines $  -- PARTIAL:-        ["multiple non-zero amounts assigned,"-        ,"please ensure just one. (https://hledger.org/csv.html#amount)"-        ,"  " <> showRecord record-        ,"  for posting: " <> T.pack (show n)+      fs      -> error' . T.unpack . textChomp . T.unlines $  -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+        ["in CSV rules:"+        ,"While processing " <> showRecord record+        ,"while calculating amount for posting " <> T.pack (show n)         ] ++-        ["  assignment: " <> f <> " " <>+        ["rule \"" <> f <> " " <>           fromMaybe "" (hledgerField rules record f) <>-          "\t=> value: " <> wbToText (showMixedAmountB noColour a) -- XXX not sure this is showing all the right info-        | (f,a) <- fs]-+          "\" assigned value \"" <> wbToText (showMixedAmountB noColour a) <> "\"" -- XXX not sure this is showing all the right info+          | (f,a) <- fs+        ] +++        [""+        ,"Multiple non-zero amounts were assigned for an amount field."+        ,"Please ensure just one non-zero amount is assigned, perhaps with an if rule."+        ,"See also: https://hledger.org/hledger.html#setting-amounts"+        ,"(hledger manual -> CSV format -> Tips -> Setting amounts)"+        ] -- | Figure out the expected balance (assertion or assignment) specified for posting N, -- if any (and its parse position). getBalance :: CsvRules -> CsvRecord -> Text -> Int -> Maybe (Amount, SourcePos)@@ -1033,6 +1067,37 @@ parseAmount :: CsvRules -> CsvRecord -> Text -> Text -> MixedAmount parseAmount rules record currency s =     either mkerror mixedAmount $  -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:     runParser (evalStateT (amountp <* eof) journalparsestate) "" $     currency <> simplifySign s   where@@ -1063,8 +1128,8 @@                   -- the csv record's line number would be good   where     journalparsestate = nulljournal{jparsedecimalmark=parseDecimalMark rules}-    mkerror n s e = error' . T.unpack $ T.unlines-      ["error: could not parse \"" <> s <> "\" as balance"<> T.pack (show n) <> " amount"+    mkerror n' s' e = error' . T.unpack $ T.unlines+      ["error: could not parse \"" <> s' <> "\" as balance"<> T.pack (show n') <> " amount"       ,showRecord record       ,showRules rules record       -- ,"the default-currency is: "++fromMaybe "unspecified" mdefaultcurrency@@ -1183,7 +1248,7 @@  -- | Show a (approximate) recreation of the original CSV record. showRecord :: CsvRecord -> Text-showRecord r = "record values: "<>T.intercalate "," (map (wrap "\"" "\"") r)+showRecord r = "CSV record: "<>T.intercalate "," (map (wrap "\"" "\"") r)  -- | Given the conversion rules, a CSV record and a hledger field name, find -- the value template ultimately assigned to this field, if any, by a field@@ -1247,17 +1312,19 @@ -- column number, ("date" or "1"), from the given CSV record, if such a field exists. csvFieldValue :: CsvRules -> CsvRecord -> CsvFieldName -> Maybe Text csvFieldValue rules record fieldname = do-  fieldindex <- if | T.all isDigit fieldname -> readMay $ T.unpack fieldname-                   | otherwise               -> lookup (T.toLower fieldname) $ rcsvfieldindexes rules+  fieldindex <-+    if T.all isDigit fieldname +    then readMay $ T.unpack fieldname+    else lookup (T.toLower fieldname) $ rcsvfieldindexes rules   T.strip <$> atMay record (fieldindex-1)  -- | Parse the date string using the specified date-format, or if unspecified -- the "simple date" formats (YYYY/MM/DD, YYYY-MM-DD, YYYY.MM.DD, leading -- zeroes optional). parseDateWithCustomOrDefaultFormats :: Maybe DateFormat -> Text -> Maybe Day-parseDateWithCustomOrDefaultFormats mformat s = asum $ map parsewith formats+parseDateWithCustomOrDefaultFormats mformat s = asum $ map parsewith' formats   where-    parsewith = flip (parseTimeM True defaultTimeLocale) (T.unpack s)+    parsewith' = flip (parseTimeM True defaultTimeLocale) (T.unpack s)     formats = map T.unpack $ maybe                ["%Y/%-m/%-d"                ,"%Y-%-m-%-d"@@ -1294,6 +1361,37 @@    ]   ,testGroup "conditionalblockp" [     testCase "space after conditional" $ -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120       parseWithState' defrules conditionalblockp "if a\n account2 b\n \n" @?=         (Right $ CB{cbMatchers=[RecordMatcher None $ toRegexCI' "a"],cbAssignments=[("account2","b")]}) 

@@ -37,6 +37,7 @@     ,reportspan_        :: DateSpan             -- ^ a dirty hack keeping the query dates in InputOpts. This rightfully lives in ReportSpec, but is duplicated here.     ,auto_              :: Bool                 -- ^ generate automatic postings when journal is parsed     ,infer_equity_      :: Bool                 -- ^ generate automatic equity postings from transaction prices+    ,infer_costs_       :: Bool                 -- ^ infer transaction prices from equity conversion postings     ,balancingopts_     :: BalancingOpts        -- ^ options for balancing transactions     ,strict_            :: Bool                 -- ^ do extra error checking (eg, all posted accounts are declared, no prices are inferred)     ,_ioDay             :: Day                  -- ^ today's date, for use with forecast transactions  XXX this duplicates _rsDay, and should eventually be removed when it's not needed anymore.@@ -55,6 +56,7 @@     , reportspan_        = nulldatespan     , auto_              = False     , infer_equity_      = False+    , infer_costs_       = False     , balancingopts_     = defbalancingopts     , strict_            = False     , _ioDay             = nulldate

@@ -185,7 +185,7 @@ -- | Parse and post-process a "Journal" from hledger's journal file -- format, or give an error. parse :: InputOpts -> FilePath -> Text -> ExceptT String IO Journal-parse iopts = parseAndFinaliseJournal journalp' iopts+parse iopts f = parseAndFinaliseJournal journalp' iopts f   where     journalp' = do       -- reverse parsed aliases to ensure that they are applied in order given on commandline@@ -199,7 +199,7 @@ -- which should be finalised/validated before use. -- -- >>> rejp (journalp <* eof) "2015/1/1\n a  0\n"--- Right (Right Journal  with 1 transactions, 1 accounts)+-- Right (Right Journal (unknown) with 1 transactions, 1 accounts) -- journalp :: MonadIO m => ErroringJournalParser m ParsedJournal journalp = do@@ -261,8 +261,8 @@   prefixedglob <- T.unpack <$> takeWhileP Nothing (/= '\n') -- don't consume newline yet   parentoff <- getOffset   parentpos <- getSourcePos-  let (mprefix,glob) = splitReaderPrefix prefixedglob-  paths <- getFilePaths parentoff parentpos glob+  let (mprefix,glb) = splitReaderPrefix prefixedglob+  paths <- getFilePaths parentoff parentpos glb   let prefixedpaths = case mprefix of         Nothing  -> paths         Just fmt -> map ((fmt++":")++) paths@@ -298,21 +298,41 @@       when (filepath `elem` parentfilestack) $         Fail.fail ("Cyclic include: " ++ filepath) -      childInput <- lift $ readFilePortably filepath-                            `orRethrowIOError` (show parentpos ++ " reading " ++ filepath)+      childInput <-+        traceAt 6 ("parseChild: "++takeFileName filepath) $+        lift $ readFilePortably filepath+          `orRethrowIOError` (show parentpos ++ " reading " ++ filepath)       let initChildj = newJournalWithParseStateFrom filepath parentj -      -- Choose a reader/format based on the file path, or fall back-      -- on journal. Duplicating readJournal a bit here.+      -- Choose a reader/parser 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 "trying reader" (rFormat r)+      dbg6IO "parseChild: trying reader" (rFormat r)++      -- Parse the file (of whichever format) to a Journal, with file path and source text attached.       updatedChildj <- journalAddFile (filepath, childInput) <$>                         parseIncludeFile parser initChildj filepath childInput -      -- discard child's parse info,  combine other fields-      put $ updatedChildj <> parentj+      -- Merge this child journal into the parent journal+      -- (with debug logging for troubleshooting account display order).+      -- 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).+      let+        parentj' =+          dbgJournalAcctDeclOrder ("parseChild: child " <> childfilename <> " acct decls: ") updatedChildj+          `journalConcat`+          dbgJournalAcctDeclOrder ("parseChild: parent " <> parentfilename <> " acct decls: ") parentj +          where+            childfilename = takeFileName filepath+            parentfilename = maybe "(unknown)" takeFileName $ headMay $ jincludefilestack parentj  -- XXX more accurate than journalFilePath for some reason++      -- Update the parse state.+      put parentj'+     newJournalWithParseStateFrom :: FilePath -> Journal -> Journal     newJournalWithParseStateFrom filepath j = nulljournal{       jparsedefaultyear      = jparsedefaultyear j@@ -340,6 +360,7 @@ accountdirectivep :: JournalParser m () accountdirectivep = do   off <- getOffset -- XXX figure out a more precise position later+  pos <- getSourcePos    string "account"   lift skipNonNewlineSpaces1@@ -359,7 +380,7 @@     metype = parseAccountTypeCode <$> lookup accountTypeTagName tags    -- update the journal-  addAccountDeclaration (acct, cmt, tags)+  addAccountDeclaration (acct, cmt, tags, pos)   unless (null tags) $ addDeclaredAccountTags acct tags   case metype of     Nothing         -> return ()@@ -392,15 +413,16 @@             T.intercalate ", " ["A","L","E","R","X","C","V","Asset","Liability","Equity","Revenue","Expense","Cash","Conversion"]  -- Add an account declaration to the journal, auto-numbering it.-addAccountDeclaration :: (AccountName,Text,[Tag]) -> JournalParser m ()-addAccountDeclaration (a,cmt,tags) =+addAccountDeclaration :: (AccountName,Text,[Tag],SourcePos) -> JournalParser m ()+addAccountDeclaration (a,cmt,tags,pos) = do   modify' (\j ->              let                decls = jdeclaredaccounts j                d     = (a, nullaccountdeclarationinfo{                               adicomment          = cmt                              ,aditags             = tags-                             ,adideclarationorder = length decls + 1+                             ,adideclarationorder = length decls + 1  -- gets renumbered when Journals are finalised or merged+                             ,adisourcepos        = pos                              })              in                j{jdeclaredaccounts = d:decls})@@ -438,8 +460,8 @@     string "commodity"     lift skipNonNewlineSpaces1     off <- getOffset-    amount <- amountp-    pure $ (off, amount)+    amt <- amountp+    pure $ (off, amt)   lift skipNonNewlineSpaces   _ <- lift followingcommentp   let comm = Commodity{csymbol=acommodity, cformat=Just $ dbg6 "style from commodity directive" astyle}@@ -467,8 +489,8 @@   lift skipNonNewlineSpaces1   sym <- lift commoditysymbolp   _ <- lift followingcommentp-  mformat <- lastMay <$> many (indented $ formatdirectivep sym)-  let comm = Commodity{csymbol=sym, cformat=mformat}+  mfmt <- lastMay <$> many (indented $ formatdirectivep sym)+  let comm = Commodity{csymbol=sym, cformat=mfmt}   modify' (\j -> j{jcommodities=M.insert sym comm $ jcommodities j})   where     indented = (lift skipNonNewlineSpaces1 >>)@@ -491,10 +513,10 @@          printf "commodity directive symbol \"%s\" and format directive symbol \"%s\" should be the same" expectedsym acommodity  keywordp :: String -> JournalParser m ()-keywordp = (() <$) . string . fromString+keywordp = void . string . fromString  spacesp :: JournalParser m ()-spacesp = () <$ lift skipNonNewlineSpaces1+spacesp = void $ lift skipNonNewlineSpaces1  -- | Backtracking parser similar to string, but allows varying amount of space between words keywordsp :: String -> JournalParser m ()@@ -652,7 +674,7 @@   -- first parsing with 'singlespacedtextp', then "re-parsing" with   -- 'periodexprp' saves 'periodexprp' from having to respect the single-   -- and double-space parsing rules-  (interval, span) <- lift $ reparseExcerpt periodExcerpt $ do+  (interval, spn) <- lift $ reparseExcerpt periodExcerpt $ do     pexp <- periodexprp refdate     (<|>) eof $ do       offset1 <- getOffset@@ -665,7 +687,7 @@     pure pexp    -- In periodic transactions, the period expression has an additional constraint:-  case checkPeriodicTransactionStartDate interval span periodtxt of+  case checkPeriodicTransactionStartDate interval spn periodtxt of     Just e -> customFailure $ parseErrorAt off e     Nothing -> pure () @@ -679,7 +701,7 @@   return $ nullperiodictransaction{      ptperiodexpr=periodtxt     ,ptinterval=interval-    ,ptspan=span+    ,ptspan=spn     ,ptstatus=status     ,ptcode=code     ,ptdescription=description@@ -745,7 +767,7 @@     let (ptype, account') = (accountNamePostingType account, textUnbracket account)     lift skipNonNewlineSpaces     mult <- if isPostingRule then multiplierp else pure False-    amount <- optional $ amountpwithmultiplier mult+    amt <- optional $ amountpwithmultiplier mult     lift skipNonNewlineSpaces     massertion <- optional balanceassertionp     lift skipNonNewlineSpaces@@ -755,7 +777,7 @@             , pdate2=mdate2             , pstatus=status             , paccount=account'-            , pamount=maybe missingmixedamt mixedAmount amount+            , pamount=maybe missingmixedamt mixedAmount amt             , pcomment=comment             , ptype=ptype             , ptags=tags@@ -794,8 +816,8 @@     ]   ,testCase "datetimep" $ do      let-       good = assertParse datetimep-       bad  = (\t -> assertParseError datetimep t "")+       good  = assertParse datetimep+       bad t = assertParseError datetimep t ""      good "2011/1/1 00:00"      good "2011/1/1 23:59:59"      bad "2011/1/1"@@ -1010,6 +1032,7 @@         [("a:b", AccountDeclarationInfo{adicomment          = "type:asset\n"                                        ,aditags             = [("type","asset")]                                        ,adideclarationorder = 1+                                       ,adisourcepos        = fst nullsourcepos                                        })         ]       ]

@@ -28,7 +28,6 @@  --- ** language {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PackageImports #-}  --- ** exports module Hledger.Read.TimedotReader (@@ -173,7 +172,7 @@   lift $ optional $ choice [orgheadingprefixp, skipNonNewlineSpaces1]   a <- modifiedaccountnamep   lift skipNonNewlineSpaces-  hrs <-+  hours <-     try (lift followingcommentp >> return 0)     <|> (lift durationp <*          (try (lift followingcommentp) <|> (newline >> return "")))@@ -187,7 +186,7 @@           tstatus    = Cleared,           tpostings  = [             nullposting{paccount=a-                      ,pamount=mixedAmount $ nullamt{acommodity=c, aquantity=hrs, astyle=s}+                      ,pamount=mixedAmount $ nullamt{acommodity=c, aquantity=hours, astyle=s}                       ,ptype=VirtualPosting                       ,ptransaction=Just t                       }

@@ -153,7 +153,7 @@         datelessreportq = filterQuery (not . queryIsDateOrDate2) reportq      items =-        accountTransactionsReportItems reportq thisacctq startbal maNegate+        accountTransactionsReportItems reportq thisacctq startbal maNegate (journalAccountType j)       -- sort by the transaction's register date, then index, for accurate starting balance       . ptraceAtWith 5 (("ts4:\n"++).pshowTransactions.map snd)       . sortBy (comparing (Down . fst) <> comparing (Down . tindex . snd))@@ -171,19 +171,21 @@ -- in the report. This is not necessarily the transaction date - see -- transactionRegisterDate. accountTransactionsReportItems :: Query -> Query -> MixedAmount -> (MixedAmount -> MixedAmount)-                               -> [(Day, Transaction)] -> [AccountTransactionsReportItem]-accountTransactionsReportItems reportq thisacctq bal signfn =-    catMaybes . snd . mapAccumR (accountTransactionsReportItem reportq thisacctq signfn) bal+                               -> (AccountName -> Maybe AccountType) -> [(Day, Transaction)]+                               -> [AccountTransactionsReportItem]+accountTransactionsReportItems reportq thisacctq bal signfn accttypefn =+    catMaybes . snd . mapAccumR (accountTransactionsReportItem reportq thisacctq signfn accttypefn) bal -accountTransactionsReportItem :: Query -> Query -> (MixedAmount -> MixedAmount) -> MixedAmount-                              -> (Day, Transaction) -> (MixedAmount, Maybe AccountTransactionsReportItem)-accountTransactionsReportItem reportq thisacctq signfn bal (d, torig)+accountTransactionsReportItem :: Query -> Query -> (MixedAmount -> MixedAmount)+                              -> (AccountName -> Maybe AccountType) -> MixedAmount -> (Day, Transaction)+                              -> (MixedAmount, Maybe AccountTransactionsReportItem)+accountTransactionsReportItem reportq thisacctq signfn accttypefn bal (d, torig)     -- 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     = (b, Just (torig, tacct{tdate=d}, numotheraccts > 1, otheracctstr, a, b))     where-      tacct@Transaction{tpostings=reportps} = filterTransactionPostings reportq torig  -- TODO needs to consider --date2, #1731+      tacct@Transaction{tpostings=reportps} = filterTransactionPostingsExtra accttypefn reportq torig  -- TODO needs to consider --date2, #1731       (thisacctps, otheracctps) = partition (matchesPosting thisacctq) reportps       numotheraccts = length $ nub $ map paccount otheracctps       otheracctstr | thisacctq == None  = summarisePostingAccounts reportps     -- no current account ? summarise all matched postings@@ -243,8 +245,8 @@ -- balance amount) components that don't involve the specified -- commodity. Other item fields such as the transaction are left unchanged. filterAccountTransactionsReportByCommodity :: CommoditySymbol -> AccountTransactionsReport -> AccountTransactionsReport-filterAccountTransactionsReportByCommodity c =-    fixTransactionsReportItemBalances . concatMap (filterTransactionsReportItemByCommodity c)+filterAccountTransactionsReportByCommodity comm =+    fixTransactionsReportItemBalances . concatMap (filterTransactionsReportItemByCommodity comm)   where     filterTransactionsReportItemByCommodity c (t,t2,s,o,a,bal)       | c `elem` cs = [item']@@ -259,9 +261,9 @@     fixTransactionsReportItemBalances items = reverse $ i:(go startbal is)       where         i:is = reverse items-        startbal = filterMixedAmountByCommodity c $ triBalance i+        startbal = filterMixedAmountByCommodity comm $ triBalance i         go _ [] = []-        go bal ((t,t2,s,o,amt,_):is) = (t,t2,s,o,amt,bal'):go bal' is+        go bal ((t,t2,s,o,amt,_):is') = (t,t2,s,o,amt,bal'):go bal' is'           where bal' = bal `maPlus` amt  -- tests

@@ -26,9 +26,9 @@ import Data.Function (on) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HM-import Data.List (find, partition, transpose, foldl')+import Data.List (find, partition, transpose, foldl', maximumBy) import Data.List.Extra (nubSort)-import Data.Maybe (fromMaybe, catMaybes)+import Data.Maybe (fromMaybe, catMaybes, isJust) import Data.Map (Map) import qualified Data.Map as Map import qualified Data.Set as S@@ -36,6 +36,7 @@ import qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Builder as TB+import Safe (minimumDef) --import System.Console.CmdArgs.Explicit as C --import Lucid as L import qualified Text.Tabular.AsciiWide as Tab@@ -45,6 +46,8 @@ import Hledger.Reports.ReportOptions import Hledger.Reports.ReportTypes import Hledger.Reports.MultiBalanceReport+import Data.Ord (comparing)+import Control.Monad ((>=>))   type BudgetGoal    = Change@@ -96,27 +99,63 @@       | otherwise = budgetgoalreport     budgetreport = combineBudgetAndActual ropts j budgetgoalreport' actualreport --- | Use all periodic transactions in the journal to generate--- budget goal transactions in the specified date span.--- Budget goal transactions are similar to forecast transactions except--- their purpose and effect is to define balance change goals, per account and period,--- for BudgetReport.+-- | 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+-- of the active periodic transaction rules that is on or before the earlier of journal start date,+-- report start date.)+-- Budget goal transactions are similar to forecast transactions except their purpose +-- and effect is to define balance change goals, per account and period, for BudgetReport.+-- journalAddBudgetGoalTransactions :: BalancingOpts -> ReportOpts -> DateSpan -> Journal -> Journal journalAddBudgetGoalTransactions bopts ropts reportspan j =-  either error' id $ journalBalanceTransactions bopts j{ jtxns = budgetts }  -- PARTIAL:+  either error' id $  -- PARTIAL:+    (journalApplyCommodityStyles >=> journalBalanceTransactions bopts) j{ jtxns = budgetts }   where-    budgetspan = dbg3 "budget span" $ reportspan-    pat = fromMaybe "" $ dbg3 "budget pattern" $ T.toLower <$> budgetpat_ ropts+    budgetspan = dbg3 "budget span" $ DateSpan mbudgetgoalsstartdate (spanEnd reportspan)+      where+        mbudgetgoalsstartdate =+          -- We want to also generate budget goal txns before the report start date, in case -H is used.+          -- What should the actual starting date for goal txns be ? This gets tricky. +          -- Consider a journal with a "~ monthly" periodic transaction rule, where the first transaction is on 1/5.+          -- Users will certainly expect a budget goal for january, but "~ monthly" generates transactions+          -- on the first of month, and starting from 1/5 would exclude 1/1.+          -- Secondly, consider a rule like "~ every february 2nd from 2020/01"; we should not start that+          -- before 2020-02-02.+          -- Hopefully the following algorithm produces intuitive behaviour in general:+          -- from the earlier of the journal start date and the report start date,+          -- move backward to the nearest natural start date of the largest period seen among the+          -- active periodic transactions, unless that is disallowed by a start date in the periodic rule.+          -- (Do we need to pay attention to an end date in the rule ? Don't think so.)+          -- (So with "~ monthly", the journal start date 1/5 is adjusted to 1/1.)+          case minimumDef Nothing $ filter isJust [journalStartDate False j, spanStart reportspan] of+            Nothing -> Nothing+            Just d  -> Just d'+              where+                -- the interval and any date span of the periodic transaction with longest period+                (intervl, spn) =+                  case budgetpts of+                    []  -> (Days 1, nulldatespan)+                    pts -> (ptinterval pt, ptspan pt)+                      where pt = maximumBy (comparing ptinterval) pts  -- PARTIAL: maximumBy won't fail+                -- the natural start of this interval on or before the journal/report start+                intervalstart = intervalStartBefore intervl d+                -- the natural interval start before the journal/report start,+                -- or the rule-specified start if later,+                -- but no later than the journal/report start.+                d' = min d $ maybe intervalstart (max intervalstart) $ spanStart spn+     -- select periodic transactions matching a pattern     -- (the argument of the (final) --budget option).     -- XXX two limitations/wishes, requiring more extensive type changes:     -- - give an error if pat is non-null and matches no periodic txns     -- - allow a regexp or a full hledger query, not just a substring+    pat = fromMaybe "" $ dbg3 "budget pattern" $ T.toLower <$> budgetpat_ ropts+    budgetpts = [pt | pt <- jperiodictxns j, pat `T.isInfixOf` T.toLower (ptdescription pt)]     budgetts =       dbg5 "budget goal txns" $       [makeBudgetTxn t-      | pt <- jperiodictxns j-      , pat `T.isInfixOf` T.toLower (ptdescription pt)+      | pt <- budgetpts       , t <- runPeriodicTransaction pt budgetspan       ]     makeBudgetTxn t = txnTieKnot $ t { tdescription = T.pack "Budget transaction" }@@ -269,11 +308,11 @@       | transpose_ = \(Tab.Table rh ch vals) -> Tab.Table ch rh (transpose vals)       | otherwise  = id -    (accts, rows, totalrows) = (accts, prependcs itemscs (padcells texts), prependcs trcs (padtr trtexts))+    (accts, rows, totalrows) = (accts', prependcs itemscs (padcells texts), prependcs trcs (padtr trtexts))       where         shownitems :: [[(AccountName, WideBuilder, BudgetDisplayRow)]]         shownitems = (fmap (\i -> fmap (\(cs, cvals) -> (renderacct i, cs, cvals)) . showrow $ rowToBudgetCells i) items)-        (accts, itemscs, texts) = unzip3 $ concat shownitems+        (accts', itemscs, texts) = unzip3 $ concat shownitems          showntr    :: [[(WideBuilder, BudgetDisplayRow)]]         showntr    = [showrow $ rowToBudgetCells tr]@@ -342,10 +381,8 @@       where         actual' = fromMaybe nullmixedamt actual -        budgetAndPerc b = uncurry zip-          ( showmixed b-          , fmap (wbFromText . T.pack . show . roundTo 0) <$> percbudget actual' b-          )+        budgetAndPerc b = +          zip (showmixed b) (fmap (wbFromText . T.pack . show . roundTo 0) <$> percbudget actual' b)          full           | Just b <- mbudget = Just <$> budgetAndPerc b@@ -358,9 +395,9 @@             (TB.fromText . flip T.replicate " " $ actualwidth - w) <> b          (totalpercentwidth, totalbudgetwidth) =-          let totalpercentwidth = if percentwidth == 0 then 0 else percentwidth + 5-           in ( totalpercentwidth-              , if budgetwidth == 0 then 0 else budgetwidth + totalpercentwidth + 3+          let totalpercentwidth' = if percentwidth == 0 then 0 else percentwidth + 5+           in ( totalpercentwidth'+              , if budgetwidth == 0 then 0 else budgetwidth + totalpercentwidth' + 3               )          -- | Display a padded budget string@@ -408,37 +445,43 @@   = (if transpose_ then transpose else id) $    -- heading row+  ++  -- heading row   ("Account" :   ["Commodity" | layout_ == LayoutBare ]-   ++ concatMap (\span -> [showDateSpan span, "budget"]) colspans+   ++ concatMap (\spn -> [showDateSpan spn, "budget"]) colspans    ++ concat [["Total"  ,"budget"] | row_total_]    ++ concat [["Average","budget"] | average_]   ) :    -- account rows+  ++  -- account rows   concatMap (rowAsTexts prrFullName) items    -- totals row   ++ concat [ rowAsTexts (const "Total:") tr | not no_total_ ]    where-    flattentuples abs = concat [[a,b] | (a,b) <- abs]+    flattentuples tups = concat [[a,b] | (a,b) <- tups]     showNorm = maybe "" (wbToText . showMixedAmountB oneLine)      rowAsTexts :: (PeriodicReportRow a BudgetCell -> Text)                -> PeriodicReportRow a BudgetCell                -> [[Text]]     rowAsTexts render row@(PeriodicReportRow _ as (rowtot,budgettot) (rowavg, budgetavg))-      | layout_ /= LayoutBare = [render row : fmap showNorm all]+      | layout_ /= LayoutBare = [render row : fmap showNorm vals]       | otherwise =             joinNames . zipWith (:) cs  -- add symbols and names           . transpose                   -- each row becomes a list of Text quantities           . fmap (fmap wbToText . showMixedAmountLinesB oneLine{displayOrder=Just cs, displayMinWidth=Nothing}                  .fromMaybe nullmixedamt)-          $ all+          $ vals       where-        cs = S.toList . foldl' S.union mempty . fmap maCommodities $ catMaybes all-        all = flattentuples as+        cs = S.toList . foldl' S.union mempty . fmap maCommodities $ catMaybes vals+        vals = flattentuples as             ++ concat [[rowtot, budgettot] | row_total_]             ++ concat [[rowavg, budgetavg] | average_] 

@@ -165,15 +165,14 @@             , cbcsubreportincreasestotal             )           where+            ropts = cbcsubreportoptions $ _rsReportOpts rspec             -- Add a restriction to this subreport to the report query.             -- XXX in non-thorough way, consider updateReportSpec ?-            q = cbcsubreportquery j-            ropts = cbcsubreportoptions $ _rsReportOpts rspec-            rspecsub = rspec{_rsReportOpts=ropts, _rsQuery=And [q, _rsQuery rspec]}+            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) q) startps-            colps' = map (second $ filter (matchesPostingExtra (journalAccountType j) q)) colps+              filter (matchesPostingExtra (journalAccountType j) cbcsubreportquery) startps+            colps' = map (second $ filter (matchesPostingExtra (journalAccountType j) cbcsubreportquery)) colps      -- Sum the subreport totals by column. Handle these cases:     -- - no subreports@@ -315,20 +314,22 @@     -- The valued row amounts to be displayed: per-period changes,     -- zero-based cumulative totals, or     -- starting-balance-based historical balances.-    rowbals name changes = dbg5 "rowbals" $ case balanceaccum_ ropts of-        PerPeriod  -> changeamts+    rowbals name unvaluedChanges = dbg5 "rowbals" $ case balanceaccum_ ropts of+        PerPeriod  -> changes         Cumulative -> cumulative         Historical -> historical       where-        -- changes to report on: usually just the changes itself, but use the-        -- differences in the historical amount for ValueChangeReports.-        changeamts = case balancecalc_ ropts of-            CalcChange      -> M.mapWithKey avalue changes-            CalcBudget      -> M.mapWithKey avalue changes+        -- 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-        cumulative = cumulativeSum avalue nullacct changeamts-        historical = cumulativeSum avalue startingBalance changes+        -- the historical balance is the valued cumulative sum of all unvalued changes+        historical = M.mapWithKey avalue $ cumulativeSum startingBalance 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 historicalDate) startingBalance @@ -342,7 +343,7 @@     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 [(span, nullacct) | span <- colspans]+    zeros = M.fromList [(spn, nullacct) | spn <- colspans]     colspans = map fst colps  @@ -405,11 +406,11 @@                   -> HashMap AccountName (Map DateSpan Account)                   -> HashMap AccountName DisplayName displayedAccounts ReportSpec{_rsQuery=query,_rsReportOpts=ropts} unelidableaccts valuedaccts-    | depth == 0 = HM.singleton "..." $ DisplayName "..." "..." 1+    | qdepth == 0 = HM.singleton "..." $ DisplayName "..." "..." 1     | otherwise  = HM.mapWithKey (\a _ -> displayedName a) displayedAccts   where     -- Accounts which are to be displayed-    displayedAccts = (if depth == 0 then id else HM.filterWithKey keep) valuedaccts+    displayedAccts = (if qdepth == 0 then id else HM.filterWithKey keep) valuedaccts       where         keep name amts = isInteresting name amts || name `HM.member` interestingParents @@ -428,7 +429,7 @@      -- Accounts interesting for their own sake     isInteresting name amts =-        d <= depth                                 -- Throw out anything too deep+        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@@ -439,8 +440,8 @@             ALFlat -> const True          -- Keep all empty accounts in flat mode             ALTree -> all (null . asubs)  -- Keep only empty leaves in tree mode         balance = maybeStripPrices . case accountlistmode_ ropts of-            ALTree | d == depth -> aibalance-            _                   -> aebalance+            ALTree | d == qdepth -> aibalance+            _                    -> aebalance           where maybeStripPrices = if conversionop_ ropts == Just NoConversionOp then id else mixedAmountStripPrices      -- Accounts interesting because they are a fork for interesting subaccounts@@ -452,7 +453,7 @@         minSubs = if no_elide_ ropts then 1 else 2      isZeroRow balance = all (mixedAmountLooksZero . balance)-    depth = fromMaybe maxBound $  queryDepth query+    qdepth = fromMaybe maxBound $ queryDepth query     numSubs = subaccountTallies . HM.keys $ HM.filterWithKey isInteresting valuedaccts  -- | Sort the rows by amount or by account declaration order.@@ -533,10 +534,10 @@              -> HashMap AccountName (Map DateSpan a) transposeMap = foldr (uncurry addSpan) mempty   where-    addSpan span acctmap seen = HM.foldrWithKey (addAcctSpan span) seen acctmap+    addSpan spn acctmap seen = HM.foldrWithKey (addAcctSpan spn) seen acctmap -    addAcctSpan span acct a = HM.alter f acct-      where f = Just . M.insert span a . fromMaybe mempty+    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.@@ -580,11 +581,9 @@     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 and a valuation--- function.-cumulativeSum :: (DateSpan -> Account -> Account) -> Account -> Map DateSpan Account -> Map DateSpan Account-cumulativeSum value start = snd . M.mapAccumWithKey accumValued start-  where accumValued startAmt date newAmt = let s = sumAcct startAmt newAmt in (s, value date s)+-- | 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  -- | Given a table representing a multi-column balance report (for example, -- made using 'balanceReportAsTable'), render it in a format suitable for

@@ -73,8 +73,8 @@        -- Postings, or summary postings with their subperiod's end date, to be displayed.       displayps :: [(Posting, Maybe Period)]-        | multiperiod = [(p, Just period) | (p, period) <- summariseps reportps]-        | otherwise   = [(p, Nothing) | p <- reportps]+        | multiperiod = [(p', Just period') | (p', period') <- summariseps reportps]+        | otherwise   = [(p', Nothing) | p' <- reportps]         where           summariseps = summarisePostingsByInterval whichdate mdepth showempty colspans           showempty = empty_ || average_@@ -189,9 +189,9 @@ -- with 0 amount. -- summarisePostingsInDateSpan :: DateSpan -> WhichDate -> Maybe Int -> Bool -> [Posting] -> [SummaryPosting]-summarisePostingsInDateSpan span@(DateSpan b e) wd mdepth showempty ps+summarisePostingsInDateSpan spn@(DateSpan b e) wd mdepth showempty ps   | null ps && (isNothing b || isNothing e) = []-  | null ps && showempty = [(summaryp, dateSpanAsPeriod span)]+  | null ps && showempty = [(summaryp, dateSpanAsPeriod spn)]   | otherwise = summarypes   where     postingdate = if wd == PrimaryDate then postingDate else postingDate2@@ -200,14 +200,14 @@     clippedanames = nub $ map (clipAccountName mdepth) anames     summaryps | mdepth == Just 0 = [summaryp{paccount="...",pamount=sumPostings ps}]               | otherwise        = [summaryp{paccount=a,pamount=balance a} | a <- clippedanames]-    summarypes = map (, dateSpanAsPeriod span) $ (if showempty then id else filter (not . mixedAmountLooksZero . pamount)) summaryps+    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     balance a = maybe nullmixedamt bal $ lookupAccount a accts       where         bal = if isclipped a then aibalance else aebalance-        isclipped a = maybe False (accountNameLevel a >=) mdepth+        isclipped a' = maybe False (accountNameLevel a' >=) mdepth  negatePostingAmount :: Posting -> Posting negatePostingAmount = postingTransformAmount negate

@@ -292,8 +292,8 @@  -- | Set the default ConversionOp. setDefaultConversionOp :: ConversionOp -> ReportSpec -> ReportSpec-setDefaultConversionOp def rspec@ReportSpec{_rsReportOpts=ropts} =-    rspec{_rsReportOpts=ropts{conversionop_=conversionop_ ropts <|> Just def}}+setDefaultConversionOp defop rspec@ReportSpec{_rsReportOpts=ropts} =+    rspec{_rsReportOpts=ropts{conversionop_=conversionop_ ropts <|> Just defop}}  accountlistmodeopt :: RawOpts -> AccountListMode accountlistmodeopt =@@ -360,7 +360,7 @@         (s,n) = break (==',') $ map toLower opt         w = case drop 1 n of               "" -> Nothing-              c | Just w <- readMay c -> Just w+              c | Just w' <- readMay c -> Just w'               _ -> usageError "width in --layout=wide,WIDTH must be an integer"          err = usageError "--layout's argument should be \"wide[,WIDTH]\", \"tall\", \"bare\", or \"tidy\""@@ -390,14 +390,14 @@ beginDatesFromRawOpts :: Day -> RawOpts -> [Day] beginDatesFromRawOpts d = collectopts (begindatefromrawopt d)   where-    begindatefromrawopt d (n,v)+    begindatefromrawopt d' (n,v)       | n == "begin" =           either (\e -> usageError $ "could not parse "++n++" date: "++customErrorBundlePretty e) Just $-          fixSmartDateStrEither' d (T.pack v)+          fixSmartDateStrEither' d' (T.pack v)       | n == "period" =         case           either (\e -> usageError $ "could not parse period option: "++customErrorBundlePretty e) id $-          parsePeriodExpr d (stripquotes $ T.pack v)+          parsePeriodExpr d' (stripquotes $ T.pack v)         of           (_, DateSpan (Just b) _) -> Just b           _                        -> Nothing@@ -408,14 +408,14 @@ endDatesFromRawOpts :: Day -> RawOpts -> [Day] endDatesFromRawOpts d = collectopts (enddatefromrawopt d)   where-    enddatefromrawopt d (n,v)+    enddatefromrawopt d' (n,v)       | n == "end" =           either (\e -> usageError $ "could not parse "++n++" date: "++customErrorBundlePretty e) Just $-          fixSmartDateStrEither' d (T.pack v)+          fixSmartDateStrEither' d' (T.pack v)       | n == "period" =         case           either (\e -> usageError $ "could not parse period option: "++customErrorBundlePretty e) id $-          parsePeriodExpr d (stripquotes $ T.pack v)+          parsePeriodExpr d' (stripquotes $ T.pack v)         of           (_, DateSpan _ (Just e)) -> Just e           _                        -> Nothing@@ -589,12 +589,12 @@       CalcGain -> journalMapPostings (\p -> postingTransformAmount (gain p) p) j       _        -> journalMapPostings (\p -> postingTransformAmount (valuation p) p) $ costing j   where-    valuation p = maybe id (mixedAmountApplyValuation priceoracle styles (periodEnd p) (_rsDay rspec) (postingDate p)) (value_ ropts)-    gain      p = maybe id (mixedAmountApplyGain      priceoracle styles (periodEnd p) (_rsDay rspec) (postingDate p)) (value_ ropts)+    valuation p = maybe id (mixedAmountApplyValuation priceoracle styles (postingperiodend p) (_rsDay rspec) (postingDate p)) (value_ ropts)+    gain      p = maybe id (mixedAmountApplyGain      priceoracle styles (postingperiodend p) (_rsDay rspec) (postingDate p)) (value_ ropts)     costing     = journalToCost (fromMaybe NoConversionOp $ conversionop_ ropts)      -- Find the end of the period containing this posting-    periodEnd  = addDays (-1) . fromMaybe err . mPeriodEnd . postingDateOrDate2 (whichDate ropts)+    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)@@ -611,11 +611,11 @@     case valuationAfterSum ropts of         Just mc -> case balancecalc_ ropts of             CalcGain -> gain mc-            _        -> \span -> valuation mc span . costing+            _        -> \spn -> valuation mc spn . costing         Nothing      -> const id   where-    valuation mc span = mixedAmountValueAtDate priceoracle styles mc (maybe err (addDays (-1)) $ spanEnd span)-    gain mc span = mixedAmountGainAtDate priceoracle styles mc (maybe err (addDays (-1)) $ spanEnd span)+    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)     costing = case fromMaybe NoConversionOp $ conversionop_ ropts of         NoConversionOp -> id         ToCost         -> styleMixedAmount styles . mixedAmountCost@@ -797,7 +797,7 @@ -- >>> _rsQuery <$> setEither querystring ["assets"] defreportspec -- Right (Acct (RegexpCI "assets")) -- >>> _rsQuery <$> setEither querystring ["(assets"] defreportspec--- Left "this regular expression could not be compiled: (assets"+-- Left "This regular expression is malformed... -- >>> _rsQuery $ set querystring ["assets"] defreportspec -- Acct (RegexpCI "assets") -- >>> _rsQuery $ set querystring ["(assets"] defreportspec@@ -808,6 +808,8 @@     reportOpts :: ReportableLens' a ReportOpts     reportOpts = reportOptsNoUpdate     {-# INLINE reportOpts #-}++    -- XXX these names are a bit clashy      period :: ReportableLens' a Period     period = reportOpts.periodNoUpdate

@@ -166,7 +166,7 @@ -- Part of a "CompoundBalanceCommandSpec", but also used in hledger-lib. data CBCSubreportSpec a = CBCSubreportSpec   { cbcsubreporttitle          :: Text                      -- ^ The title to use for the subreport-  , cbcsubreportquery          :: Journal -> Query          -- ^ The Query to use for the subreport+  , cbcsubreportquery          :: Query                     -- ^ The Query to use for the subreport   , cbcsubreportoptions        :: ReportOpts -> ReportOpts  -- ^ A function to transform the ReportOpts used to produce the subreport   , cbcsubreporttransform      :: PeriodicReport DisplayName MixedAmount -> PeriodicReport a MixedAmount  -- ^ A function to transform the result of the subreport   , cbcsubreportincreasestotal :: Bool                      -- ^ Whether the subreport and overall report total are of the same sign (e.g. Assets are normally

@@ -183,7 +183,7 @@   where     openFileOrStdin :: String -> IOMode -> IO Handle     openFileOrStdin "-" _ = return stdin-    openFileOrStdin f m   = openFile f m+    openFileOrStdin f' m   = openFile f' m  readHandlePortably :: Handle -> IO Text readHandlePortably h = do@@ -225,9 +225,9 @@   return (h [])   where     go h [] = return h-    go h (m:ms) = do+    go h (m:ms') = do       x <- m-      go (h . (x :)) ms+      go (h . (x :)) ms'  -- | Like mapM but uses sequence'. {-# INLINABLE mapM' #-}@@ -339,7 +339,7 @@     -- HasReportOpts class with some special behaviour. We therefore give the     -- basic lenses a special NoUpdate name to avoid conflicts.     className "ReportOpts" = Just (mkName "HasReportOptsNoUpdate", mkName "reportOptsNoUpdate")-    className (x:xs)       = Just (mkName ("Has" ++ x:xs), mkName (toLower x : xs))+    className (x':xs)       = Just (mkName ("Has" ++ x':xs), mkName (toLower x' : xs))     className []           = Nothing      -- Fields of ReportOpts which need to update the Query when they are updated.

@@ -41,7 +41,11 @@ module Hledger.Utils.Debug (   -- * Pretty printing    pprint+  ,pprint'   ,pshow+  ,pshow'+  ,useColorOnStdout+  ,useColorOnStderr   -- * Tracing   ,traceWith   -- * Pretty tracing@@ -90,17 +94,33 @@   -- ** Trace the state of hledger parsers   ,traceParse   ,dbgparse+  -- ** Debug-logging to a file+  ,dlogTrace+  ,dlogTraceAt+  ,dlogAt+  ,dlog0+  ,dlog1+  ,dlog2+  ,dlog3+  ,dlog4+  ,dlog5+  ,dlog6+  ,dlog7+  ,dlog8+  ,dlog9+  -- ** Re-exports+  ,module Debug.Breakpoint   ,module Debug.Trace-  ,useColorOnStdout-  ,useColorOnStderr-  ,dlog)+  ) where +import           Control.DeepSeq (force) import           Control.Monad (when) import           Control.Monad.IO.Class import           Data.List hiding (uncons) import qualified Data.Text as T import qualified Data.Text.Lazy as TL+import           Debug.Breakpoint import           Debug.Trace import           Hledger.Utils.Parse import           Safe (readDef)@@ -113,25 +133,38 @@ import Data.Maybe (isJust) import System.Console.ANSI (hSupportsANSIColor) import System.IO (stdout, Handle, stderr)+import Control.Exception (evaluate) +-- | pretty-simple options with colour enabled if allowed. prettyopts = -  baseopts+  (if useColorOnStderr then defaultOutputOptionsDarkBg else defaultOutputOptionsNoColor)     { outputOptionsIndentAmount=2     , outputOptionsCompact=True     }-  where-    baseopts-      | useColorOnStderr = defaultOutputOptionsDarkBg -- defaultOutputOptionsLightBg-      | otherwise        = defaultOutputOptionsNoColor +-- | pretty-simple options with colour disabled.+prettyopts' =+  defaultOutputOptionsNoColor+    { outputOptionsIndentAmount=2+    , outputOptionsCompact=True+    }+ -- | Pretty print. Generic alias for pretty-simple's pPrint. pprint :: Show a => a -> IO () pprint = pPrintOpt CheckColorTty prettyopts +-- | Monochrome version of pprint.+pprint' :: Show a => a -> IO ()+pprint' = pPrintOpt CheckColorTty prettyopts'+ -- | Pretty show. Generic alias for pretty-simple's pShow. pshow :: Show a => a -> String pshow = TL.unpack . pShowOpt prettyopts +-- | Monochrome version of pshow.+pshow' :: Show a => a -> String+pshow' = TL.unpack . pShowOpt prettyopts'+ -- XXX some of the below can be improved with pretty-simple, https://github.com/cdepillabout/pretty-simple#readme  -- | Pretty trace. Easier alias for traceShowId + pShow.@@ -284,10 +317,9 @@ ptraceAt :: Show a => Int -> String -> a -> a ptraceAt level     | level > 0 && debugLevel < level = const id-    | otherwise = \s a -> let p = pshow a-                              ls = lines p+    | otherwise = \s a -> let ls = lines $ pshow a                               nlorspace | length ls > 1 = "\n"-                                        | otherwise     = replicate (11 - length s) ' '+                                        | otherwise     = replicate (max 1 $ 11 - length s) ' '                               ls' | length ls > 1 = map (' ':) ls                                   | otherwise     = ls                           in trace (s++":"++nlorspace++intercalate "\n" ls') a@@ -305,10 +337,6 @@                         -- in trace (s++":"++nlorspace++intercalate "\n" ls') a                         in trace p a --- | Log a pretty-printed showable value to "./debug.log". Uses unsafePerformIO.-dlog :: Show a => a -> a-dlog x = unsafePerformIO $ appendFile "debug.log" (pshow x ++ "\n") >> return x- -- "dbg" would clash with megaparsec. -- | Pretty-print a label and the showable value to the console, then return it. dbg0 :: Show a => String -> a -> a@@ -344,6 +372,7 @@ dbg9 = ptraceAt 9  -- | Like dbg0, but also exit the program. Uses unsafePerformIO.+-- {-# NOINLINE dbgExit #-} dbgExit :: Show a => String -> a -> a dbgExit msg = const (unsafePerformIO exitFailure) . dbg0 msg @@ -419,6 +448,70 @@  dbg9IO :: (MonadIO m, Show a) => String -> a -> m () dbg9IO = ptraceAtIO 9++-- | Log a string to ./debug.log before returning the second argument.+-- Uses unsafePerformIO.+-- {-# NOINLINE dlogTrace #-}+dlogTrace :: String -> a -> a+dlogTrace s x = unsafePerformIO $ do+  evaluate (force s)  -- to complete any previous logging before we attempt more+  appendFile "debug.log" (s ++ "\n")+  return x++-- | Log a string to ./debug.log before returning the second argument,+-- if the global debug level is at or above the specified level.+-- At level 0, always logs. Otherwise, uses unsafePerformIO.+dlogTraceAt :: Int -> String -> a -> a+dlogTraceAt level s+  | level > 0 && debugLevel < level = id+  | otherwise = dlogTrace s++-- | Log a label and pretty-printed showable value to "./debug.log",+-- if the global debug level is at or above the specified level.+-- At level 0, always prints. Otherwise, uses unsafePerformIO.+dlogAt :: Show a => Int -> String -> a -> a+dlogAt level+  | level > 0 && debugLevel < level = const id+  | otherwise = \lbl a ->+    let +      ls = lines $ pshow' a+      nlorspace | length ls > 1 = "\n"+                | otherwise     = replicate (max 1 $ 11 - length lbl) ' '+      ls' | length ls > 1 = map (' ':) ls+          | otherwise     = ls+    in dlogTrace (lbl++":"++nlorspace++intercalate "\n" ls') a++-- | Pretty-print a label and the showable value to ./debug.log if at or above+-- a certain debug level, then return it.+dlog0 :: Show a => String -> a -> a+dlog0 = dlogAt 0++dlog1 :: Show a => String -> a -> a+dlog1 = dlogAt 1++dlog2 :: Show a => String -> a -> a+dlog2 = dlogAt 2++dlog3 :: Show a => String -> a -> a+dlog3 = dlogAt 3++dlog4 :: Show a => String -> a -> a+dlog4 = dlogAt 4++dlog5 :: Show a => String -> a -> a+dlog5 = dlogAt 5++dlog6 :: Show a => String -> a -> a+dlog6 = dlogAt 6++dlog7 :: Show a => String -> a -> a+dlog7 = dlogAt 7++dlog8 :: Show a => String -> a -> a+dlog8 = dlogAt 8++dlog9 :: Show a => String -> a -> a+dlog9 = dlogAt 9  -- | Print the provided label (if non-null) and current parser state -- (position and next input) to the console. See also megaparsec's dbg.

@@ -38,6 +38,7 @@   skipNonNewlineSpaces',    -- * re-exports+  HledgerParseErrors,   HledgerParseErrorData ) where

@@ -99,11 +99,11 @@                              RegexpCI _ _ -> showString "RegexpCI "  instance Read Regexp where-  readsPrec d r =  readParen (d > app_prec) (\r -> [(toRegexCI' m,t) |-                                                    ("RegexCI",s) <- lex r,+  readsPrec d r =  readParen (d > app_prec) (\r' -> [(toRegexCI' m,t) |+                                                    ("RegexCI",s) <- lex r',                                                     (m,t) <- readsPrec (app_prec+1) s]) r-                ++ readParen (d > app_prec) (\r -> [(toRegex' m, t) |-                                                    ("Regex",s) <- lex r,+                ++ readParen (d > app_prec) (\r' -> [(toRegex' m, t) |+                                                    ("Regex",s) <- lex r',                                                     (m,t) <- readsPrec (app_prec+1) s]) r     where app_prec = 10 @@ -134,7 +134,7 @@ -- | Make a nice error message for a regexp error. mkRegexErr :: Text -> Maybe a -> Either RegexError a mkRegexErr s = maybe (Left errmsg) Right-  where errmsg = T.unpack $ "this regular expression could not be compiled: " <> s+  where errmsg = T.unpack $ "This regular expression is malformed, please correct it:\n" <> s  -- Convert a Regexp string to a compiled Regex, throw an error toRegex' :: Text -> Regexp@@ -186,7 +186,7 @@ -- but there can still be a runtime error from the replacement -- pattern, eg a backreference referring to a nonexistent match group.) regexReplaceUnmemo :: Regexp -> Replacement -> String -> Either RegexError String-regexReplaceUnmemo re repl s = foldM (replaceMatch repl) s (reverse $ match (reCompiled re) s :: [MatchText String])+regexReplaceUnmemo re repl str = foldM (replaceMatch repl) str (reverse $ match (reCompiled re) str :: [MatchText String])   where     -- Replace one match within the string with the replacement text     -- appropriate for this match. Or return an error message.@@ -195,22 +195,22 @@       case elems matchgroups of          [] -> Right s         ((_,(off,len)):_) ->   -- groups should have 0-based indexes, and there should always be at least one, since this is a match-          erepl >>= \repl -> Right $ pre ++ repl ++ post+          erpl >>= \rpl -> Right $ pre ++ rpl ++ post           where             (pre, post') = splitAt off s             post = drop len post'             -- The replacement text: the replacement pattern with all             -- numeric backreferences replaced by the appropriate groups             -- from this match. Or an error message.-            erepl = regexReplaceAllByM backrefRegex (lookupMatchGroup matchgroups) replpat+            erpl = regexReplaceAllByM backrefRegex (lookupMatchGroup matchgroups) replpat               where                 -- Given some match groups and a numeric backreference,                 -- return the referenced group text, or an error message.                 lookupMatchGroup :: MatchText String -> String -> Either RegexError String-                lookupMatchGroup grps ('\\':s@(_:_)) | all isDigit s =-                  case read s of n | n `elem` indices grps -> Right $ fst (grps ! n)  -- PARTIAL: should not fail, all digits-                                 _                         -> Left $ "no match group exists for backreference \"\\"++s++"\""-                lookupMatchGroup _ s = Left $ "lookupMatchGroup called on non-numeric-backreference \""++s++"\", shouldn't happen"+                lookupMatchGroup grps ('\\':s2@(_:_)) | all isDigit s2 =+                  case read s2 of n | n `elem` indices grps -> Right $ fst (grps ! n)  -- PARTIAL: should not fail, all digits+                                  _                         -> Left $ "no match group exists for backreference \"\\"++s++"\""+                lookupMatchGroup _ s2 = Left $ "lookupMatchGroup called on non-numeric-backreference \""++s2++"\", shouldn't happen"     backrefRegex = toRegex' "\\\\[0-9]+"  -- PARTIAL: should not fail  -- regexReplace' :: Regexp -> Replacement -> String -> String@@ -249,8 +249,8 @@         go :: (Int,String,String->String) -> (Int,Int) ->  (Int,String,String->String)         go (pos,todo,prepend) (off,len) =           let (prematch, matchandrest) = splitAt (off - pos) todo-              (matched, rest) = splitAt len matchandrest-          in (off + len, rest, prepend . (prematch++) . (transform matched ++))+              (matched, rest2) = splitAt len matchandrest+          in (off + len, rest2, prepend . (prematch++) . (transform matched ++))  -- Replace all occurrences of a regexp in a string, transforming each match -- with the given monadic function. Eg if the monad is Either, a Left result

@@ -10,6 +10,7 @@  -- quoting  quoteIfNeeded,  singleQuoteIfNeeded,+ quoteForCommandLine,  -- quotechars,  -- whitespacechars,  words',@@ -118,15 +119,44 @@     escapeQuotes (c:cs)   x = showChar c        $ escapeQuotes cs x  -- | Single-quote this string if it contains whitespace or double-quotes.--- No good for strings containing single quotes.+-- Does not work for strings containing single quotes. singleQuoteIfNeeded :: String -> String-singleQuoteIfNeeded s | any (`elem` s) (quotechars++whitespacechars) = "'"++s++"'"+singleQuoteIfNeeded s | any (`elem` s) (quotechars++whitespacechars) = singleQuote s                       | otherwise = s -quotechars, whitespacechars, redirectchars :: [Char]+-- | Prepend and append single quotes to a string.+singleQuote :: String -> String+singleQuote s = "'"++s++"'"++-- | Try to single- and backslash-quote a string as needed to make it usable+-- as an argument on a (sh/bash) shell command line. At least, well enough +-- to handle common currency symbols, like $. Probably broken in many ways.+--+-- >>> quoteForCommandLine "a"+-- "a"+-- >>> quoteForCommandLine "\""+-- "'\"'"+-- >>> quoteForCommandLine "$"+-- "'\\$'"+--+quoteForCommandLine :: String -> String+quoteForCommandLine s+  | any (`elem` s) (quotechars++whitespacechars++shellchars) = singleQuote $ quoteShellChars s+  | otherwise = s++-- | Try to backslash-quote common shell-significant characters in this string.+-- Doesn't handle single quotes, & probably others.+quoteShellChars :: String -> String+quoteShellChars = concatMap escapeShellChar+  where+    escapeShellChar c | c `elem` shellchars = ['\\',c]+    escapeShellChar c = [c]++quotechars, whitespacechars, redirectchars, shellchars :: [Char] quotechars      = "'\"" whitespacechars = " \t\n\r" redirectchars   = "<>"+shellchars      = "<>(){}[]$7?#!~`"  -- | Quote-aware version of words - don't split on spaces which are inside quotes. -- NB correctly handles "a'b" but not "''a''". Can raise an error if parsing fails.

@@ -120,8 +120,10 @@   -> HledgerParseErrorData parseErrorAtRegion startOffset endOffset msg =   if startOffset < endOffset-    then ErrorFailAt startOffset endOffset msg-    else ErrorFailAt startOffset (startOffset+1) msg+    then ErrorFailAt startOffset endOffset msg'+    else ErrorFailAt startOffset (startOffset+1) msg'+  where+    msg' = "\n" ++ msg   --- * Re-parsing@@ -369,9 +371,9 @@    -- A parse error thrown directly with the 'FinalError' constructor   -- requires both source and filepath.-  FinalError parseError ->+  FinalError err ->     let bundle = ParseErrorBundle-          { bundleErrors = parseError NE.:| []+          { bundleErrors = err NE.:| []           , bundlePosState = initialPosState filePath sourceText }     in  FinalParseErrorBundle'           { finalErrorBundle = bundle

@@ -211,11 +211,11 @@ renderHLine vpos borders pretty w h prop = [renderHLine' vpos borders pretty prop w h]  renderHLine' :: VPos -> Bool -> Bool -> Properties -> [Int] -> Header a -> Builder-renderHLine' vpos borders pretty prop is h = addBorders $ sep <> coreLine <> sep+renderHLine' vpos borders pretty prop is hdr = addBorders $ sep <> coreLine <> sep  where   addBorders xs   = if borders then edge HL <> xs <> edge HR else xs   edge hpos       = boxchar vpos hpos SingleLine prop pretty-  coreLine        = foldMap helper $ flattenHeader $ zipHeader 0 is h+  coreLine        = foldMap helper $ flattenHeader $ zipHeader 0 is hdr   helper          = either vsep dashes   dashes (i,_)    = stimesMonoid i sep   sep             = boxchar vpos HM NoLine prop pretty

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           hledger-lib-version:        1.26.1+version:        1.27 synopsis:       A reusable library providing the core functionality of hledger description:    A reusable library containing hledger's core functionality.                 This is used by most hledger* packages so that they support the same@@ -27,7 +27,7 @@ license-file:   LICENSE build-type:     Simple tested-with:-    GHC==8.6.5, GHC==8.8.4, GHC==8.10.4, GHC==9.0.1+    GHC==8.10.7, GHC==9.0.2, GHC==9.2.4 extra-source-files:     CHANGES.md     README.md@@ -95,7 +95,7 @@       Paths_hledger_lib   hs-source-dirs:       ./-  ghc-options: -Wall -Wno-incomplete-uni-patterns -Wno-missing-signatures -Wno-name-shadowing -Wno-orphans -Wno-type-defaults -Wno-unused-do-bind+  ghc-options: -Wall -Wno-incomplete-uni-patterns -Wno-missing-signatures -Wno-orphans -Wno-type-defaults -Wno-unused-do-bind   build-depends:       Decimal >=0.5.1     , Glob >=0.9@@ -103,8 +103,9 @@     , aeson-pretty     , ansi-terminal >=0.9     , array-    , base >=4.11 && <4.17+    , base >=4.14 && <4.17     , blaze-markup >=0.5.1+    , breakpoint     , bytestring     , call-stack     , cassava@@ -112,6 +113,7 @@     , cmdargs >=0.10     , containers >=0.5.9     , data-default >=0.5+    , deepseq     , directory     , doclayout >=0.3 && <0.5     , extra >=1.6.3@@ -145,7 +147,7 @@   hs-source-dirs:       ./       test-  ghc-options: -Wall -Wno-incomplete-uni-patterns -Wno-missing-signatures -Wno-name-shadowing -Wno-orphans -Wno-type-defaults -Wno-unused-do-bind+  ghc-options: -Wall -Wno-incomplete-uni-patterns -Wno-missing-signatures -Wno-orphans -Wno-type-defaults -Wno-unused-do-bind   build-depends:       Decimal >=0.5.1     , Glob >=0.7@@ -153,8 +155,9 @@     , aeson-pretty     , ansi-terminal >=0.9     , array-    , base >=4.11 && <4.17+    , base >=4.14 && <4.17     , blaze-markup >=0.5.1+    , breakpoint     , bytestring     , call-stack     , cassava@@ -162,6 +165,7 @@     , cmdargs >=0.10     , containers >=0.5.9     , data-default >=0.5+    , deepseq     , directory     , doclayout >=0.3 && <0.5     , doctest >=0.18.1@@ -188,7 +192,7 @@     , uglymemo     , unordered-containers >=0.2     , utf8-string >=0.3.5-  if impl(ghc < 9.2)+  if impl(ghc >= 9.0) && impl(ghc < 9.2)     buildable: False   default-language: Haskell2010 @@ -198,7 +202,7 @@   hs-source-dirs:       ./       test-  ghc-options: -Wall -Wno-incomplete-uni-patterns -Wno-missing-signatures -Wno-name-shadowing -Wno-orphans -Wno-type-defaults -Wno-unused-do-bind+  ghc-options: -Wall -Wno-incomplete-uni-patterns -Wno-missing-signatures -Wno-orphans -Wno-type-defaults -Wno-unused-do-bind   build-depends:       Decimal >=0.5.1     , Glob >=0.9@@ -206,8 +210,9 @@     , aeson-pretty     , ansi-terminal >=0.9     , array-    , base >=4.11 && <4.17+    , base >=4.14 && <4.17     , blaze-markup >=0.5.1+    , breakpoint     , bytestring     , call-stack     , cassava@@ -215,6 +220,7 @@     , cmdargs >=0.10     , containers >=0.5.9     , data-default >=0.5+    , deepseq     , directory     , doclayout >=0.3 && <0.5     , extra >=1.6.3