hledger-lib 1.40 → 1.41

raw patch · 44 files changed

+2704/−1219 lines, 44 filesdep +blaze-htmldep +processdep −ghc-debug-stubdep −pagerdep −text-ansidep ~basedep ~base-compatdep ~directoryPVP ok

version bump matches the API change (PVP)

Dependencies added: blaze-html, process

Dependencies removed: ghc-debug-stub, pager, text-ansi

Dependency ranges changed: base, base-compat, directory

API changes (from Hackage documentation)

Files

• CHANGES.md +33/−0
• Hledger/Data.hs +4/−1
• Hledger/Data/Account.hs +8/−5
• Hledger/Data/AccountName.hs +95/−81
• Hledger/Data/Amount.hs +9/−3
• Hledger/Data/Balancing.hs +17/−16
• Hledger/Data/Currency.hs +160/−0
• Hledger/Data/Errors.hs +32/−7
• Hledger/Data/Journal.hs +78/−74
• Hledger/Data/JournalChecks.hs +77/−65
• Hledger/Data/Ledger.hs +1/−1
• Hledger/Data/PeriodicTransaction.hs +4/−6
• Hledger/Data/Posting.hs +81/−136
• Hledger/Data/RawOptions.hs +22/−1
• Hledger/Data/Transaction.hs +76/−79
• Hledger/Data/TransactionModifier.hs +4/−8
• Hledger/Data/Types.hs +89/−39
• Hledger/Data/Valuation.hs +32/−21
• Hledger/Query.hs +34/−14
• Hledger/Read.hs +10/−6
• Hledger/Read/Common.hs +79/−73
• Hledger/Read/InputOptions.hs +2/−0
• Hledger/Read/JournalReader.hs +8/−6
• Hledger/Read/RulesReader.hs +97/−58
• Hledger/Reports/AccountTransactionsReport.hs +1/−0
• Hledger/Reports/BalanceReport.hs +4/−4
• Hledger/Reports/EntriesReport.hs +2/−2
• Hledger/Reports/MultiBalanceReport.hs +30/−25
• Hledger/Reports/PostingsReport.hs +5/−8
• Hledger/Reports/ReportOptions.hs +34/−13
• Hledger/Reports/ReportTypes.hs +19/−16
• Hledger/Utils.hs +6/−1
• Hledger/Utils/Debug.hs +7/−2
• Hledger/Utils/IO.hs +471/−296
• Hledger/Utils/Regex.hs +10/−6
• Hledger/Write/Beancount.hs +379/−0
• Hledger/Write/Html.hs +28/−29
• Hledger/Write/Html/Attribute.hs +64/−0
• Hledger/Write/Html/Blaze.hs +78/−0
• Hledger/Write/Html/Lucid.hs +78/−0
• Hledger/Write/Ods.hs +184/−67
• Hledger/Write/Spreadsheet.hs +215/−6
• Text/Tabular/AsciiWide.hs +4/−4
• hledger-lib.cabal +33/−40

@@ -22,6 +22,39 @@ For user-visible changes, see the hledger package changelog.  +# 2024-12-09 1.41++Breaking changes++- New/refactored modules (Hledger.Write.*) and types (Spreadsheet) to help+  abstract rendering in various output formats, eg HTML, FODS and beancount.+  Spreadsheet is an abstraction for tabular reports, in addition to the+  tabular package we already use; there may be some overlap.+  (Henning Thielemann)++- Rename displayDepth/prrDepth to displayIndent/prrIndent, and make them+  correspond to the number of indentation steps.+  (These are about indentation for rendering, not account depth.) [#2246]++Improvements++- Add Hledger.Data.Currency, currencySymbolToCode, currencyCodeToSymbol+- AmountFormat: add displayQuotes flag to control enclosing quotes+- InputOpts: add `posting_account_tags_` flag to control account tags on postings+- Support ghc 9.10 and base 4.20.+  Note, when built with ghc 9.10.1, hledger error messages are displayed with two extra trailing newlines.++Other API/doc changes++- Hledger.Utils.IO: cleanup; rgb' now takes Float arguments instead of Word8+- rename jinferredcommodities to jinferredcommoditystyles+- rename jcommodities to jdeclaredcommodities+- move/rename nullsourcepos+- document isBlockActive, matcherMatches+- posting*AsLines: fix some docs+++ # 1.40 2024-09-09  Breaking changes

@@ -13,6 +13,7 @@                module Hledger.Data.AccountName,                module Hledger.Data.Amount,                module Hledger.Data.Balancing,+               module Hledger.Data.Currency,                module Hledger.Data.Dates,                module Hledger.Data.Errors,                module Hledger.Data.Journal,@@ -38,6 +39,7 @@ import Hledger.Data.AccountName import Hledger.Data.Amount import Hledger.Data.Balancing+import Hledger.Data.Currency import Hledger.Data.Dates import Hledger.Data.Errors import Hledger.Data.Journal@@ -58,8 +60,9 @@ tests_Data = testGroup "Data" [    tests_AccountName   ,tests_Amount-  ,tests_Dates   ,tests_Balancing+  -- ,tests_Currency+  ,tests_Dates   ,tests_Journal   ,tests_Ledger   ,tests_Posting

@@ -34,7 +34,10 @@  import qualified Data.HashSet as HS import qualified Data.HashMap.Strict as HM-import Data.List (find, foldl', sortOn)+import Data.List (find, sortOn)+#if !MIN_VERSION_base(4,20,0)+import Data.List (foldl')+#endif import Data.List.Extra (groupOn) import qualified Data.Map as M import Data.Ord (Down(..))@@ -172,11 +175,11 @@ -- | Remove subaccounts below the specified depth, aggregating their balance at the depth limit -- (accounts at the depth limit will have any sub-balances merged into their exclusive balance). -- If the depth is Nothing, return the original accounts-clipAccountsAndAggregate :: Maybe Int -> [Account] -> [Account]-clipAccountsAndAggregate Nothing  as = as-clipAccountsAndAggregate (Just d) as = combined+clipAccountsAndAggregate :: DepthSpec -> [Account] -> [Account]+clipAccountsAndAggregate (DepthSpec Nothing []) as = as+clipAccountsAndAggregate d                      as = combined     where-      clipped  = [a{aname=clipOrEllipsifyAccountName (Just d) $ aname a} | a <- as]+      clipped  = [a{aname=clipOrEllipsifyAccountName d $ aname a} | a <- as]       combined = [a{aebalance=maSum $ map aebalance same}                  | same@(a:_) <- groupOn aname clipped] {-

@@ -21,7 +21,9 @@   ,accountNameTreeFrom   ,accountSummarisedName   ,accountNameInferType+  ,accountNameInferTypeExcept   ,accountNameType+  ,defaultBaseConversionAccount   ,assetAccountRegex   ,cashAccountRegex   ,liabilityAccountRegex@@ -33,6 +35,7 @@   ,acctsepchar   ,clipAccountName   ,clipOrEllipsifyAccountName+  ,getAccountNameClippedDepth   ,elideAccountName   ,escapeName   ,expandAccountName@@ -53,17 +56,16 @@   ,concatAccountNames   ,accountNameApplyAliases   ,accountNameApplyAliasesMemo-  ,accountNameToBeancount-  ,beancountTopLevelAccounts   ,tests_AccountName ) where  import Control.Applicative ((<|>)) import Control.Monad (foldM)-import Data.Foldable (asum, toList)+import Data.Foldable (asum, find, toList) import qualified Data.List.NonEmpty as NE import qualified Data.Map as M+import Data.Maybe (mapMaybe) import Data.MemoUgly (memo) import qualified Data.Set as S import Data.Text (Text)@@ -74,7 +76,6 @@  import Hledger.Data.Types hiding (asubs) import Hledger.Utils-import Data.Char (isDigit, isLetter) import Data.List (partition)  -- $setup@@ -86,27 +87,9 @@ acctsep :: Text acctsep = T.pack [acctsepchar] --- accountNameComponents :: AccountName -> [String]--- accountNameComponents = splitAtElement acctsepchar--accountNameComponents :: AccountName -> [Text]-accountNameComponents = T.splitOn acctsep--accountNameFromComponents :: [Text] -> AccountName-accountNameFromComponents = T.intercalate acctsep--accountLeafName :: AccountName -> Text-accountLeafName = last . accountNameComponents---- | Truncate all account name components but the last to two characters.-accountSummarisedName :: AccountName -> Text-accountSummarisedName a-  --   length cs > 1 = take 2 (head cs) ++ ":" ++ a'-  | length cs > 1 = T.intercalate ":" (map (T.take 2) $ init cs) <> ":" <> a'-  | otherwise     = a'-    where-      cs = accountNameComponents a-      a' = accountLeafName a+-- The base conversion account name used by --infer-equity,+-- when no other account of type V/Conversion has been declared.+defaultBaseConversionAccount = "equity:conversion"  -- | Regular expressions matching common English top-level account names, -- used as a fallback when account types are not declared.@@ -114,7 +97,7 @@ cashAccountRegex       = toRegexCI' "^assets?(:.+)?:(cash|bank|che(ck|que?)(ing)?|savings?|current)(:|$)" liabilityAccountRegex  = toRegexCI' "^(debts?|liabilit(y|ies))(:|$)" equityAccountRegex     = toRegexCI' "^equity(:|$)"-conversionAccountRegex = toRegexCI' "^equity:(trad(e|ing)|conversion)s?(:|$)"+conversionAccountRegex = toRegexCI' "^equity:(trade|trades|trading|conversion)(:|$)" revenueAccountRegex    = toRegexCI' "^(income|revenue)s?(:|$)" expenseAccountRegex    = toRegexCI' "^expenses?(:|$)" @@ -131,6 +114,15 @@   | regexMatchText expenseAccountRegex    a = Just Expense   | otherwise                               = Nothing +-- | Like accountNameInferType, but exclude the provided types from the guesses.+-- Used eg to prevent "equity:conversion" being inferred as Conversion when a different+-- account has been declared with that type.+accountNameInferTypeExcept :: [AccountType] -> AccountName -> Maybe AccountType+accountNameInferTypeExcept excludedtypes a =+  case accountNameInferType a of+    Just t | not $ t `elem` excludedtypes -> Just t+    _ -> Nothing+ -- Extract the 'AccountType' of an 'AccountName' by looking it up in the -- provided Map, traversing the parent accounts if necessary. If none of those -- work, try 'accountNameInferType'.@@ -138,6 +130,36 @@ accountNameType atypes a = asum (map (`M.lookup` atypes) $ a : parentAccountNames a)                          <|> accountNameInferType a +-- accountNameComponents :: AccountName -> [String]+-- accountNameComponents = splitAtElement acctsepchar++accountNameComponents :: AccountName -> [Text]+accountNameComponents = T.splitOn acctsep++accountNameFromComponents :: [Text] -> AccountName+accountNameFromComponents = T.intercalate acctsep++accountLeafName :: AccountName -> Text+accountLeafName = last . accountNameComponents++-- | Truncate all account name components but the last to two characters.+accountSummarisedName :: AccountName -> Text+accountSummarisedName a+  --   length cs > 1 = take 2 (head cs) ++ ":" ++ a'+  | length cs > 1 = T.intercalate ":" (map (T.take 2) $ init cs) <> ":" <> a'+  | otherwise     = a'+    where+      cs = accountNameComponents a+      a' = accountLeafName a++-- | The level (depth) of an account name.+--+-- >>> accountNameLevel ""  -- special case+-- 0+-- >>> accountNameLevel "assets"+-- 1+-- >>> accountNameLevel "assets:cash"+-- 2 accountNameLevel :: AccountName -> Int accountNameLevel "" = 0 accountNameLevel a = T.length (T.filter (==acctsepchar) a) + 1@@ -315,19 +337,55 @@           | otherwise = done++ss  -- | Keep only the first n components of an account name, where n--- is a positive integer. If n is Just 0, returns the empty string, if n is--- Nothing, return the full name.-clipAccountName :: Maybe Int -> AccountName -> AccountName-clipAccountName Nothing  = id-clipAccountName (Just n) = accountNameFromComponents . take n . accountNameComponents+-- is a positive integer.+clipAccountNameTo :: Int -> AccountName -> AccountName+clipAccountNameTo n = accountNameFromComponents . take n . accountNameComponents --- | Keep only the first n components of an account name, where n--- is a positive integer. If n is Just 0, returns "...", if n is Nothing, return--- the full name.-clipOrEllipsifyAccountName :: Maybe Int -> AccountName -> AccountName-clipOrEllipsifyAccountName (Just 0) = const "..."-clipOrEllipsifyAccountName n        = clipAccountName n+-- | Calculate the depth to which an account name should be clipped for a given+-- 'DepthSpec'.+--+-- First checking whether the account name matches any of the regular+-- expressions controlling depth. If so, clip to the depth of the most specific+-- of those matches, i.e. the one which starts matching the latest as you+-- progress up the parents of the account. Otherwise clip to the flat depth+-- provided, or return the full name if Nothing.+getAccountNameClippedDepth :: DepthSpec -> AccountName -> Maybe Int+getAccountNameClippedDepth (DepthSpec flat regexps) acctName =+    mostSpecificRegexp regexps <|> flat+  where+    -- If any regular expressions match, choose the one with the greatest+    -- specificity and clip to that depth.+    mostSpecificRegexp = fmap snd . foldr takeMax Nothing . mapMaybe matchRegexp+      where+        -- If two regexps match, take the most specific one. If there is a tie,+        -- take the last one (this aligns with the behaviour for flat depths+        -- limiting).+        takeMax (s, d) (Just (s', d')) = Just $ if s'>= s then (s', d') else (s, d)+        takeMax (s, d) Nothing = Just (s, d) +    -- If the regular expression matches the account name, store the specificity and requested depth+    matchRegexp :: (Regexp, Int) -> Maybe (Int, Int)+    matchRegexp (r, d) = if regexMatchText r acctName then Just (getSpecificity r, d) else Nothing+    -- Specificity is the smallest parent of the account which matches the regular expression+    getSpecificity r = maybe maxBound fst $ find (regexMatchText r . snd) acctParents+    acctParents = zip [1..] . initDef [] $ expandAccountName acctName++-- | Clip an account name to a given 'DepthSpec', first checking whether it+-- matches any of the regular expressions controlling depth. If so, clip to the+-- depth of the most specific of those matches, i.e. the one which starts+-- matching the latest as you progress up the parents of the account. Otherwise+-- clip to the flat depth provided, or return the full name if Nothing.+clipAccountName :: DepthSpec -> AccountName -> AccountName+clipAccountName ds a = maybe id clipAccountNameTo (getAccountNameClippedDepth ds a) a++-- | As 'clipAccountName', but return '...' if asked to clip to depth 0.+clipOrEllipsifyAccountName :: DepthSpec -> AccountName -> AccountName+clipOrEllipsifyAccountName ds a = go (getAccountNameClippedDepth ds a)+  where+    go Nothing  = a+    go (Just 0) = "..."+    go (Just n) = clipAccountNameTo n a+ -- | Escape an AccountName for use within a regular expression. -- >>> putStr . T.unpack $ escapeName "First?!#$*?$(*) !@^#*? %)*!@#" -- First\?!#\$\*\?\$\(\*\) !@\^#\*\? %\)\*!@#@@ -358,50 +416,6 @@ -- -- | Does this string look like an exact account-matching regular expression ? --isAccountRegex  :: String -> Bool --isAccountRegex s = take 1 s == "^" && take 5 (reverse s) == ")$|:("--type BeancountAccountName = AccountName-type BeancountAccountNameComponent = AccountName---- Convert a hledger account name to a valid Beancount account name.--- It replaces non-supported characters with @-@ (warning: in extreme cases--- separate accounts could end up with the same name), and it capitalises --- each account name part. It also checks that the first part is one of --- Assets, Liabilities, Equity, Income, or Expenses, and if not it raises an error.--- Account aliases (eg --alias) should be used to set these required--- top-level account names if needed.-accountNameToBeancount :: AccountName -> BeancountAccountName-accountNameToBeancount a =-  -- https://beancount.github.io/docs/beancount_language_syntax.html#accounts-  accountNameFromComponents $-  case map (accountNameComponentToBeancount a) $ accountNameComponents a of-    c:_ | c `notElem` beancountTopLevelAccounts -> error' e-      where-        e = T.unpack $ T.unlines [-          beancountAccountErrorMessage a,-          "For Beancount output, all top-level accounts must be (or be aliased to) one of",-          T.intercalate ", " beancountTopLevelAccounts <> "."-          ]-    cs -> cs--accountNameComponentToBeancount :: AccountName -> AccountName -> BeancountAccountNameComponent-accountNameComponentToBeancount acct part =-  case T.uncons part of-    Just (c,_) | not $ isLetter c -> error' e-      where-        e = unlines [-          T.unpack $ beancountAccountErrorMessage acct,-          "For Beancount output, each account name part must begin with a letter."-          ]-    _ -> textCapitalise part'-      where part' = T.map (\c -> if isBeancountAccountChar c then c else '-') part--beancountAccountErrorMessage :: AccountName -> Text-beancountAccountErrorMessage a = "Could not convert \"" <> a <> "\" to a Beancount account name."--isBeancountAccountChar :: Char -> Bool-isBeancountAccountChar c = c `elem` ("-:"::[Char]) || isLetter c || isDigit c--beancountTopLevelAccounts = ["Assets", "Liabilities", "Equity", "Income", "Expenses"]  tests_AccountName = testGroup "AccountName" [    testCase "accountNameTreeFrom" $ do

@@ -39,6 +39,7 @@  -} +{-# LANGUAGE CPP  #-} {-# LANGUAGE OverloadedStrings  #-} {-# LANGUAGE RecordWildCards    #-} {-# LANGUAGE NamedFieldPuns #-}@@ -175,7 +176,10 @@ import Data.Decimal (DecimalRaw(..), decimalPlaces, normalizeDecimal, roundTo) import Data.Default (Default(..)) import Data.Foldable (toList)-import Data.List (find, foldl', intercalate, intersperse, mapAccumL, partition)+import Data.List (find, intercalate, intersperse, mapAccumL, partition)+#if !MIN_VERSION_base(4,20,0)+import Data.List (foldl')+#endif import Data.List.NonEmpty (NonEmpty(..), nonEmpty) import qualified Data.Map.Strict as M import qualified Data.Set as S@@ -238,6 +242,7 @@   , displayMaxWidth         :: Maybe Int  -- ^ Maximum width to clip to   , displayCost             :: Bool       -- ^ Whether to display Amounts' costs.   , displayColour           :: Bool       -- ^ Whether to ansi-colourise negative Amounts.+  , displayQuotes           :: Bool       -- ^ Whether to enclose complex symbols in quotes (normally true)   } deriving (Show)  -- | By default, display amounts using @defaultFmt@ amount display options.@@ -256,6 +261,7 @@   , displayMaxWidth         = Nothing   , displayCost             = True   , displayColour           = False+  , displayQuotes           = True   }  -- | Like defaultFmt but show zero amounts with commodity symbol and styling, like non-zero amounts.@@ -651,7 +657,7 @@ showAmountB _ Amount{acommodity="AUTO"} = mempty showAmountB   afmt@AmountFormat{displayCommodity, displayZeroCommodity, displayDigitGroups-                   ,displayForceDecimalMark, displayCost, displayColour}+                   ,displayForceDecimalMark, displayCost, displayColour, displayQuotes}   a@Amount{astyle=style} =     color $ case ascommodityside style of       L -> (if displayCommodity then wbFromText comm <> space else mempty) <> quantity' <> cost@@ -662,7 +668,7 @@       if displayDigitGroups then a else a{astyle=(astyle a){asdigitgroups=Nothing}}     (quantity', comm)       | amountLooksZero a && not displayZeroCommodity = (WideBuilder (TB.singleton '0') 1, "")-      | otherwise = (quantity, quoteCommoditySymbolIfNeeded $ acommodity a)+      | otherwise = (quantity, (if displayQuotes then quoteCommoditySymbolIfNeeded else id) $ acommodity a)     space = if not (T.null comm) && ascommodityspaced style then WideBuilder (TB.singleton ' ') 1 else mempty     cost = if displayCost then showAmountCostB afmt a else mempty 

@@ -102,10 +102,11 @@             VirtualPosting         -> (l, r)      -- convert this posting's amount to cost,-    -- without getting confused by redundant costs/equity postings+    -- unless it has been marked as a redundant cost (equivalent to some nearby equity conversion postings),+    -- in which case ignore it.     postingBalancingAmount p-      | "_price-matched" `elem` map fst (ptags p) = mixedAmountStripCosts $ pamount p-      | otherwise                                 = mixedAmountCost $ pamount p+      | costPostingTagName `elem` map fst (ptags p) = mixedAmountStripCosts $ pamount p+      | otherwise                                   = mixedAmountCost $ pamount p      -- transaction balancedness is checked at each commodity's display precision     lookszero = mixedAmountLooksZero . atdisplayprecision@@ -792,7 +793,7 @@                (Transaction                   0                   ""-                  nullsourcepos+                  nullsourcepospair                   (fromGregorian 2007 01 28)                   Nothing                   Unmarked@@ -807,7 +808,7 @@                (Transaction                   0                   ""-                  nullsourcepos+                  nullsourcepospair                   (fromGregorian 2007 01 28)                   Nothing                   Unmarked@@ -824,7 +825,7 @@              (Transaction                 0                 ""-                nullsourcepos+                nullsourcepospair                 (fromGregorian 2007 01 28)                 Nothing                 Unmarked@@ -840,7 +841,7 @@              (Transaction                 0                 ""-                nullsourcepos+                nullsourcepospair                 (fromGregorian 2007 01 28)                 Nothing                 Unmarked@@ -858,7 +859,7 @@             (Transaction                0                ""-               nullsourcepos+               nullsourcepospair                (fromGregorian 2011 01 01)                Nothing                Unmarked@@ -875,7 +876,7 @@             (Transaction                0                ""-               nullsourcepos+               nullsourcepospair                (fromGregorian 2011 01 01)                Nothing                Unmarked@@ -894,7 +895,7 @@           Transaction             0             ""-            nullsourcepos+            nullsourcepospair             (fromGregorian 2009 01 01)             Nothing             Unmarked@@ -912,7 +913,7 @@           Transaction             0             ""-            nullsourcepos+            nullsourcepospair             (fromGregorian 2009 01 01)             Nothing             Unmarked@@ -930,7 +931,7 @@           Transaction             0             ""-            nullsourcepos+            nullsourcepospair             (fromGregorian 2009 01 01)             Nothing             Unmarked@@ -945,7 +946,7 @@           Transaction             0             ""-            nullsourcepos+            nullsourcepospair             (fromGregorian 2009 01 01)             Nothing             Unmarked@@ -960,7 +961,7 @@           Transaction             0             ""-            nullsourcepos+            nullsourcepospair             (fromGregorian 2009 01 01)             Nothing             Unmarked@@ -979,7 +980,7 @@           Transaction             0             ""-            nullsourcepos+            nullsourcepospair             (fromGregorian 2009 01 01)             Nothing             Unmarked@@ -997,7 +998,7 @@           Transaction             0             ""-            nullsourcepos+            nullsourcepospair             (fromGregorian 2009 01 01)             Nothing             Unmarked

@@ -0,0 +1,160 @@+{-|++Currency names, symbols and codes.+Reference:+- https://www.xe.com/symbols+- https://www.xe.com/currency++-}++{-# LANGUAGE OverloadedStrings    #-}++module Hledger.Data.Currency (+  currencies,+  currencySymbolToCode,+  currencyCodeToSymbol,+)+where+import qualified Data.Map as M+import           Data.Text (Text)++-- | An ISO 4217 currency code, like EUR. Usually three upper case letters.+type CurrencyCode = Text++-- | A traditional currency symbol, like $. Usually one character, sometimes more.+-- Different from hledger's more general "CommoditySymbol" type.+type CurrencySymbol = Text++-- | Look for a ISO 4217 currency code corresponding to this currency symbol.+--+-- >>> currencySymbolToCode ""+-- Nothing+-- >>> currencySymbolToCode "$"+-- Just "USD"+currencySymbolToCode :: CurrencySymbol -> Maybe CurrencyCode+currencySymbolToCode s = M.lookup s currencyCodesBySymbol++-- | Look for a currency symbol corresponding to this ISO 4217 currency code.+--+-- >>> currencyCodeToSymbol "CZK"  -- Just "Kč"+-- Just "K\269"+currencyCodeToSymbol :: CurrencyCode -> Maybe CurrencySymbol+currencyCodeToSymbol c = M.lookup c currencySymbolsByCode++currencyCodesBySymbol = M.fromList [(s,c) | (_,c,s) <- currencies]+currencySymbolsByCode = M.fromList [(c,s) | (_,c,s) <- currencies]++currencies = [+  -- country and currency name           ISO 4217 code  symbol+  ("Albania Lek",                               "ALL",  "Lek"),+  ("Afghanistan Afghani",                       "AFN",  "؋"),+  ("Argentina Peso",                            "ARS",  "$"),+  ("Aruba Guilder",                             "AWG",  "ƒ"),+  ("Australia Dollar",                          "AUD",  "$"),+  ("Azerbaijan Manat",                          "AZN",  "₼"),+  ("Bahamas Dollar",                            "BSD",  "$"),+  ("Barbados Dollar",                           "BBD",  "$"),+  ("Belarus Ruble",                             "BYN",  "Br"),+  ("Belize Dollar",                             "BZD",  "BZ$"),+  ("Bermuda Dollar",                            "BMD",  "$"),+  ("Bolivia Bolíviano",                         "BOB",  "$b"),+  ("Bosnia and Herzegovina Convertible Mark",   "BAM",  "KM"),+  ("Botswana Pula",                             "BWP",  "P"),+  ("Bulgaria Lev",                              "BGN",  "лв"),+  ("Brazil Real",                               "BRL",  "R$"),+  ("Brunei Darussalam Dollar",                  "BND",  "$"),+  ("Cambodia Riel",                             "KHR",  "៛"),+  ("Canada Dollar",                             "CAD",  "$"),+  ("Cayman Islands Dollar",                     "KYD",  "$"),+  ("Chile Peso",                                "CLP",  "$"),+  ("China Yuan Renminbi",                       "CNY",  "¥"),+  ("Colombia Peso",                             "COP",  "$"),+  ("Costa Rica Colon",                          "CRC",  "₡"),+  ("Croatia Kuna",                              "HRK",  "kn"),+  ("Cuba Peso",                                 "CUP",  "₱"),+  ("Czech Republic Koruna",                     "CZK",  "Kč"),+  ("Denmark Krone",                             "DKK",  "kr"),+  ("Dominican Republic Peso",                   "DOP",  "RD$"),+  ("East Caribbean Dollar",                     "XCD",  "$"),+  ("Egypt Pound",                               "EGP",  "£"),+  ("El Salvador Colon",                         "SVC",  "$"),+  ("Euro Member Countries",                     "EUR",  "€"),+  ("Falkland Islands (Malvinas) Pound",         "FKP",  "£"),+  ("Fiji Dollar",                               "FJD",  "$"),+  ("Ghana Cedi",                                "GHS",  "¢"),+  ("Gibraltar Pound",                           "GIP",  "£"),+  ("Guatemala Quetzal",                         "GTQ",  "Q"),+  ("Guernsey Pound",                            "GGP",  "£"),+  ("Guyana Dollar",                             "GYD",  "$"),+  ("Honduras Lempira",                          "HNL",  "L"),+  ("Hong Kong Dollar",                          "HKD",  "$"),+  ("Hungary Forint",                            "HUF",  "Ft"),+  ("Iceland Krona",                             "ISK",  "kr"),+  ("India Rupee",                               "INR",  "₹"),+  ("Indonesia Rupiah",                          "IDR",  "Rp"),+  ("Iran Rial",                                 "IRR",  "﷼"),+  ("Isle of Man Pound",                         "IMP",  "£"),+  ("Israel Shekel",                             "ILS",  "₪"),+  ("Jamaica Dollar",                            "JMD",  "J$"),+  ("Japan Yen",                                 "JPY",  "¥"),+  ("Jersey Pound",                              "JEP",  "£"),+  ("Kazakhstan Tenge",                          "KZT",  "лв"),+  ("Korea (North) Won",                         "KPW",  "₩"),+  ("Korea (South) Won",                         "KRW",  "₩"),+  ("Kyrgyzstan Som",                            "KGS",  "лв"),+  ("Laos Kip",                                  "LAK",  "₭"),+  ("Lebanon Pound",                             "LBP",  "£"),+  ("Liberia Dollar",                            "LRD",  "$"),+  ("Macedonia Denar",                           "MKD",  "ден"),+  ("Malaysia Ringgit",                          "MYR",  "RM"),+  ("Mauritius Rupee",                           "MUR",  "₨"),+  ("Mexico Peso",                               "MXN",  "$"),+  ("Mongolia Tughrik",                          "MNT",  "₮"),+  ("Mozambique Metical",                        "MZN",  "MT"),+  ("Namibia Dollar",                            "NAD",  "$"),+  ("Nepal Rupee",                               "NPR",  "₨"),+  ("Netherlands Antilles Guilder",              "ANG",  "ƒ"),+  ("New Zealand Dollar",                        "NZD",  "$"),+  ("Nicaragua Cordoba",                         "NIO",  "C$"),+  ("Nigeria Naira",                             "NGN",  "₦"),+  ("Norway Krone",                              "NOK",  "kr"),+  ("Oman Rial",                                 "OMR",  "﷼"),+  ("Pakistan Rupee",                            "PKR",  "₨"),+  ("Panama Balboa",                             "PAB",  "B/."),+  ("Paraguay Guarani",                          "PYG",  "Gs"),+  ("Peru Sol",                                  "PEN",  "S/."),+  ("Philippines Peso",                          "PHP",  "₱"),+  ("Poland Zloty",                              "PLN",  "zł"),+  ("Qatar Riyal",                               "QAR",  "﷼"),+  ("Romania Leu",                               "RON",  "lei"),+  ("Russia Ruble",                              "RUB",  "₽"),+  ("Saint Helena Pound",                        "SHP",  "£"),+  ("Saudi Arabia Riyal",                        "SAR",  "﷼"),+  ("Serbia Dinar",                              "RSD",  "Дин."),+  ("Seychelles Rupee",                          "SCR",  "₨"),+  ("Singapore Dollar",                          "SGD",  "$"),+  ("Solomon Islands Dollar",                    "SBD",  "$"),+  ("Somalia Shilling",                          "SOS",  "S"),+  ("South Africa Rand",                         "ZAR",  "R"),+  ("Sri Lanka Rupee",                           "LKR",  "₨"),+  ("Sweden Krona",                              "SEK",  "kr"),+  ("Switzerland Franc",                         "CHF",  "CHF"),+  ("Suriname Dollar",                           "SRD",  "$"),+  ("Syria Pound",                               "SYP",  "£"),+  ("Taiwan New Dollar",                         "TWD",  "NT$"),+  ("Thailand Baht",                             "THB",  "฿"),+  ("Trinidad and Tobago Dollar",                "TTD",  "TT$"),+  ("Turkey Lira",                               "TRY",  "₺"),+  ("Tuvalu Dollar",                             "TVD",  "$"),+  ("Ukraine Hryvnia",                           "UAH",  "₴"),+  ("United Kingdom Pound",                      "GBP",  "£"),+  ("United States Dollar",                      "USD",  "$"),+  ("Uruguay Peso",                              "UYU",  "$U"),+  ("Uzbekistan Som",                            "UZS",  "лв"),+  ("Venezuela Bolívar",                         "VEF",  "Bs"),+  ("Viet Nam Dong",                             "VND",  "₫"),+  ("Yemen Rial",                                "YER",  "﷼"),+  ("Zimbabwe Dollar",                           "ZWD",  "Z$")+  ]++-- tests_Currency = testGroup "Currency" []

@@ -7,6 +7,7 @@  module Hledger.Data.Errors (   makeAccountTagErrorExcerpt,+  makePriceDirectiveErrorExcerpt,   makeTransactionErrorExcerpt,   makePostingErrorExcerpt,   makePostingAccountErrorExcerpt,@@ -27,7 +28,10 @@ import Data.Maybe import Safe (headMay) import Hledger.Data.Posting (isVirtual)+import Hledger.Data.Dates (showDate)+import Hledger.Data.Amount (showCommoditySymbol, showAmount) + -- | Given an account name and its account directive, and a problem tag within the latter: -- render it as a megaparsec-style excerpt, showing the original line number and -- marked column or region.@@ -38,10 +42,10 @@ makeAccountTagErrorExcerpt (a, adi) _t = (f, l, merrcols, ex)   -- XXX findtxnerrorcolumns is awkward, I don't think this is the final form   where-    (SourcePos f pos _) = adisourcepos adi+    SourcePos f pos _ = adisourcepos adi     l = unPos pos     txt   = showAccountDirective (a, adi) & textChomp & (<>"\n")-    ex = decorateTagErrorExcerpt l merrcols txt+    ex = decorateExcerpt l merrcols txt     -- Calculate columns which will help highlight the region in the excerpt     -- (but won't exactly match the real data, so won't be shown in the main error line)     merrcols = Nothing@@ -55,9 +59,10 @@   "account " <> a   <> (if not $ T.null adicomment then "    ; " <> adicomment else "") --- | Add megaparsec-style left margin, line number, and optional column marker(s).-decorateTagErrorExcerpt :: Int -> Maybe (Int, Maybe Int) -> Text -> Text-decorateTagErrorExcerpt l mcols txt =+-- | Decorate a data excerpt with megaparsec-style left margin, line number,+-- and marker/underline for the column(s) if known, for inclusion in an error message.+decorateExcerpt :: Int -> Maybe (Int, Maybe Int) -> Text -> Text+decorateExcerpt l mcols txt =   T.unlines $ ls' <> colmarkerline <> map (lineprefix<>) ms   where     (ls,ms) = splitAt 1 $ T.lines txt@@ -70,8 +75,28 @@     lineprefix = T.replicate marginw " " <> "| "       where  marginw = length (show l) + 1 -_showAccountDirective = undefined+-- | Given a problem price directive,+-- and maybe a function to calculate the error region's column(s) (currently ignored):+-- generate a megaparsec-style error message with highlighted excerpt.+-- Returns the source file path, line number, column(s) if known, and the rendered excerpt,+-- or as much of these as possible.+-- Columns will be accurate for the rendered error message, not for the original journal entry.+makePriceDirectiveErrorExcerpt :: PriceDirective -> Maybe (PriceDirective -> Text -> Maybe (Int, Maybe Int)) -> (FilePath, Int, Maybe (Int, Maybe Int), Text)+makePriceDirectiveErrorExcerpt pd _finderrorcolumns = (file, line, merrcols, excerpt)+  where+    SourcePos file pos _ = pdsourcepos pd+    line = unPos pos+    merrcols = Nothing+    excerpt = decorateExcerpt line merrcols $ showPriceDirective pd <> "\n" +showPriceDirective :: PriceDirective -> Text+showPriceDirective PriceDirective{..} = T.unwords [+   "P"+  ,showDate pddate+  ,showCommoditySymbol pdcommodity+  ,T.pack $ showAmount pdamount +  ]+ -- | Given a problem transaction and a function calculating the best -- column(s) for marking the error region: -- render it as a megaparsec-style excerpt, showing the original line number@@ -83,7 +108,7 @@ makeTransactionErrorExcerpt t findtxnerrorcolumns = (f, tl, merrcols, ex)   -- XXX findtxnerrorcolumns is awkward, I don't think this is the final form   where-    (SourcePos f tpos _) = fst $ tsourcepos t+    SourcePos f tpos _ = fst $ tsourcepos t     tl = unPos tpos     txntxt = showTransaction t & textChomp & (<>"\n")     merrcols = findtxnerrorcolumns t

@@ -1,9 +1,10 @@+{-# LANGUAGE CPP                 #-} {-# LANGUAGE NamedFieldPuns      #-} {-# LANGUAGE OverloadedStrings   #-} {-# LANGUAGE Rank2Types          #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections       #-}-{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE RecordWildCards     #-}  {-| @@ -30,8 +31,7 @@   journalCommodityStylesWith,   journalToCost,   journalInferEquityFromCosts,-  journalInferCostsFromEquity,-  journalMarkRedundantCosts,+  journalTagCostsAndEquityAndMaybeInferCosts,   journalReverse,   journalSetLastReadTime,   journalRenumberAccountDeclarations,@@ -95,11 +95,13 @@   journalAccountTypes,   journalAddAccountTypes,   journalPostingsAddAccountTags,+  defaultBaseConversionAccount,   -- journalPrices,-  journalConversionAccount,+  journalBaseConversionAccount,   journalConversionAccounts,   -- * Misc   canonicalStyleFrom,+   nulljournal,   journalConcat,   journalNumberTransactions,@@ -122,7 +124,10 @@ import Data.Char (toUpper, isDigit) import Data.Default (Default(..)) import Data.Foldable (toList)-import Data.List ((\\), find, foldl', sortBy, union, intercalate)+import Data.List ((\\), find, sortBy, union, intercalate)+#if !MIN_VERSION_base(4,20,0)+import Data.List (foldl')+#endif import Data.List.Extra (nubSort) import qualified Data.Map.Strict as M import Data.Maybe (catMaybes, fromMaybe, mapMaybe, maybeToList)@@ -149,6 +154,7 @@ import Data.Ord (comparing) import Hledger.Data.Dates (nulldate) import Data.List (sort)+import Data.Function ((&)) -- import Data.Function ((&))  @@ -178,7 +184,7 @@              (length $ jtxns j)              (length accounts)              (show accounts)-             (show $ jinferredcommodities j)+             (show $ jinferredcommoditystyles j)              -- ++ (show $ journalTransactions l)              where accounts = filter (/= "root") $ flatten $ journalAccountNameTree j @@ -198,9 +204,9 @@   ,"jdeclaredaccounttags: "      <> shw jdeclaredaccounttags   ,"jdeclaredaccounttypes: "     <> shw jdeclaredaccounttypes   ,"jaccounttypes: "             <> shw jaccounttypes+  ,"jdeclaredcommodities: "      <> shw jdeclaredcommodities+  ,"jinferredcommoditystyles: "  <> shw jinferredcommoditystyles   ,"jglobalcommoditystyles: "    <> shw jglobalcommoditystyles-  ,"jcommodities: "              <> shw jcommodities-  ,"jinferredcommodities: "      <> shw jinferredcommodities   ,"jpricedirectives: "          <> shw jpricedirectives   ,"jinferredmarketprices: "     <> shw jinferredmarketprices   ,"jtxnmodifiers: "             <> shw jtxnmodifiers@@ -273,11 +279,11 @@     -- ,jglobalcommoditystyles :: M.Map CommoditySymbol AmountStyle     ,jglobalcommoditystyles     = (<>) (jglobalcommoditystyles j1) (jglobalcommoditystyles j2)     ---    -- ,jcommodities           :: M.Map CommoditySymbol Commodity-    ,jcommodities               = (<>) (jcommodities j1) (jcommodities j2)+    -- ,jdeclaredcommodities           :: M.Map CommoditySymbol Commodity+    ,jdeclaredcommodities               = (<>) (jdeclaredcommodities j1) (jdeclaredcommodities j2)     ---    -- ,jinferredcommodities   :: M.Map CommoditySymbol AmountStyle-    ,jinferredcommodities       = (<>) (jinferredcommodities j1) (jinferredcommodities j2)+    -- ,jinferredcommoditystyles   :: M.Map CommoditySymbol AmountStyle+    ,jinferredcommoditystyles       = (<>) (jinferredcommoditystyles j1) (jinferredcommoditystyles j2)     --     --     ,jpricedirectives           = jpricedirectives           j1 <> jpricedirectives           j2@@ -337,8 +343,8 @@   ,jdeclaredaccounttypes      = M.empty   ,jaccounttypes              = M.empty   ,jglobalcommoditystyles     = M.empty-  ,jcommodities               = M.empty-  ,jinferredcommodities       = M.empty+  ,jdeclaredcommodities               = M.empty+  ,jinferredcommoditystyles       = M.empty   ,jpricedirectives           = []   ,jinferredmarketprices      = []   ,jtxnmodifiers              = []@@ -398,11 +404,15 @@  -- | Sorted unique commodity symbols declared by commodity directives in this journal. journalCommoditiesDeclared :: Journal -> [CommoditySymbol]-journalCommoditiesDeclared = M.keys . jcommodities+journalCommoditiesDeclared = M.keys . jdeclaredcommodities --- | Sorted unique commodity symbols declared or inferred from this journal.+-- | Sorted unique commodity symbols mentioned in this journal. journalCommodities :: Journal -> S.Set CommoditySymbol-journalCommodities j = M.keysSet (jcommodities j) <> M.keysSet (jinferredcommodities j)+journalCommodities j =+     M.keysSet (jdeclaredcommodities j)+  <> M.keysSet (jinferredcommoditystyles j)+  <> S.fromList (concatMap pdcommodities $ jpricedirectives j)+      where pdcommodities pd = [pdcommodity pd, acommodity $ pdamount pd]  -- | Unique transaction descriptions used in this journal. journalDescriptions :: Journal -> [Text]@@ -571,29 +581,34 @@ journalAddAccountTypes :: Journal -> Journal journalAddAccountTypes j = j{jaccounttypes = journalAccountTypes j} +-- | An account type inherited from the parent account(s),+-- and whether it was originally declared by an account directive (true) or inferred from an account name (false).+type ParentAccountType = (AccountType, Bool)+ -- | Build a map of all known account types, explicitly declared -- or inferred from the account's parent or name. journalAccountTypes :: Journal -> M.Map AccountName AccountType journalAccountTypes j = M.fromList [(a,acctType) | (a, Just (acctType,_)) <- flatten t']   where     t = accountNameTreeFrom $ journalAccountNames j :: Tree AccountName-    -- Map from the top of the account tree down to the leaves, propagating-    -- account types downward. Keep track of whether the account is declared-    -- (True), in which case the parent account should be preferred, or merely-    -- inferred (False), in which case the inferred type should be preferred.-    t' = settypes Nothing t :: Tree (AccountName, Maybe (AccountType, Bool))+    -- Traverse downward through the account tree, applying any explicitly declared account types,+    -- otherwise inferring account types from account names when possible, and propagating account types downward.+    -- Declared account types (possibly inherited from parent) are preferred, inferred types are used as a fallback.+    t' = setTypeHereAndBelow Nothing t :: Tree (AccountName, Maybe (AccountType, Bool))       where-        settypes :: Maybe (AccountType, Bool) -> Tree AccountName -> Tree (AccountName, Maybe (AccountType, Bool))-        settypes mparenttype (Node a subs) = Node (a, mtype) (map (settypes mtype) subs)+        declaredtypes       = M.keys $ jdeclaredaccounttypes j+        declaredtypesbyname = journalDeclaredAccountTypes j & fmap (,True)+        setTypeHereAndBelow :: Maybe ParentAccountType -> Tree AccountName -> Tree (AccountName, Maybe ParentAccountType)+        setTypeHereAndBelow mparenttype (Node a subs) = Node (a, mnewtype) (map (setTypeHereAndBelow mnewtype) subs)           where-            mtype = M.lookup a declaredtypes <|> minferred-              where -                declaredtypes = (,True) <$> journalDeclaredAccountTypes j-                minferred = if maybe False snd mparenttype-                            then mparenttype-                            else (,False) <$> accountNameInferType a <|> mparenttype+            mnewtype = mthisacctdeclaredtype <|> mparentacctdeclaredtype <|> mthisacctinferredtype <|> mparentacctinferredtype+              where+                mthisacctdeclaredtype   = M.lookup a declaredtypesbyname+                mparentacctdeclaredtype = if       fromMaybe False $ snd <$> mparenttype then mparenttype else Nothing+                mparentacctinferredtype = if not $ fromMaybe True  $ snd <$> mparenttype then mparenttype else Nothing+                mthisacctinferredtype   = accountNameInferTypeExcept declaredtypes a & fmap (,False)  -- XXX not sure about this Except logic.. but for now, tests pass --- | Build a map of the account types explicitly declared for each account.+-- | Build a map from account names to explicitly declared account types. journalDeclaredAccountTypes :: Journal -> M.Map AccountName AccountType journalDeclaredAccountTypes Journal{jdeclaredaccounttypes} =   M.fromList $ concat [map (,t) as | (t,as) <- M.toList jdeclaredaccounttypes]@@ -605,18 +620,17 @@ journalPostingsAddAccountTags j = journalMapPostings addtags j   where addtags p = p `postingAddTags` (journalInheritedAccountTags j $ paccount p) --- | The account to use for automatically generated conversion postings in this journal:--- the first of the journalConversionAccounts.-journalConversionAccount :: Journal -> AccountName-journalConversionAccount = headDef defaultConversionAccount . journalConversionAccounts+-- | The account name to use for conversion postings generated by --infer-equity.+-- This is the first account declared with type V/Conversion,+-- or otherwise the defaultBaseConversionAccount (equity:conversion).+journalBaseConversionAccount :: Journal -> AccountName+journalBaseConversionAccount = headDef defaultBaseConversionAccount . journalConversionAccounts --- | All the accounts declared or inferred as Conversion type in this journal.+-- | All the accounts in this journal which are declared or inferred as V/Conversion type.+-- This does not include new account names which might be generated by --infer-equity, currently. journalConversionAccounts :: Journal -> [AccountName] journalConversionAccounts = M.keys . M.filter (==Conversion) . jaccounttypes --- The fallback account to use for automatically generated conversion postings--- if no account is declared with the Conversion type.-defaultConversionAccount = "equity:conversion"  -- Various kinds of filtering on journals. We do it differently depending -- on the command.@@ -881,9 +895,9 @@   globalstyles <> declaredstyles <> defaultcommoditystyle <> inferredstyles   where     globalstyles          = jglobalcommoditystyles j-    declaredstyles        = M.mapMaybe cformat $ jcommodities j+    declaredstyles        = M.mapMaybe cformat $ jdeclaredcommodities j     defaultcommoditystyle = M.fromList $ catMaybes [jparsedefaultcommodity j]-    inferredstyles        = jinferredcommodities j+    inferredstyles        = jinferredcommoditystyles j  -- | Like journalCommodityStyles, but attach a particular rounding strategy to the styles, -- affecting how they will affect display precisions when applied.@@ -891,14 +905,13 @@ journalCommodityStylesWith r = amountStylesSetRounding r . journalCommodityStyles  -- | Collect and save inferred amount styles for each commodity based on--- the posting amounts in that commodity (excluding price amounts), ie:--- "the format of the first amount, adjusted to the highest precision of all amounts".+-- the posting amounts in that commodity (excluding price amounts). -- Can return an error message eg if inconsistent number formats are found. journalInferCommodityStyles :: Journal -> Either String Journal journalInferCommodityStyles j =   case commodityStylesFromAmounts $ journalStyleInfluencingAmounts j of     Left e   -> Left e-    Right cs -> Right j{jinferredcommodities = dbg7 "journalInferCommodityStyles" cs}+    Right cs -> Right j{jinferredcommoditystyles = dbg7 "journalInferCommodityStyles" cs}  -- | Given a list of amounts, in parse order (roughly speaking; see journalStyleInfluencingAmounts), -- build a map from their commodity names to standard commodity@@ -971,7 +984,7 @@ journalInferMarketPricesFromTransactions :: Journal -> Journal journalInferMarketPricesFromTransactions j =   j{jinferredmarketprices =-       dbg4 "jinferredmarketprices" .+       dbg4With (("jinferredmarketprices:\n"<>) . showMarketPrices) $        map priceDirectiveToMarketPrice .        concatMap postingPriceDirectivesFromCost $        journalPostings j@@ -981,32 +994,23 @@ journalToCost :: ConversionOp -> Journal -> Journal journalToCost cost j@Journal{jtxns=ts} = j{jtxns=map (transactionToCost cost) ts} +-- | Identify and tag (1) equity conversion postings and (2) postings which have (or could have ?) redundant costs.+-- And if the addcosts flag is true, also add any costs which can be inferred from equity conversion postings.+-- This is always called before transaction balancing to tag the redundant-cost postings so they can be ignored.+-- With --infer-costs, it is called again after transaction balancing (when it has more information to work with) to infer costs from equity postings.+-- See transactionTagCostsAndEquityAndMaybeInferCosts for more details, and hledger manual > Cost reporting for more background.+journalTagCostsAndEquityAndMaybeInferCosts :: Bool -> Bool -> Journal -> Either String Journal+journalTagCostsAndEquityAndMaybeInferCosts verbosetags addcosts j = do+  let conversionaccts = journalConversionAccounts j+  ts <- mapM (transactionTagCostsAndEquityAndMaybeInferCosts verbosetags addcosts conversionaccts) $ jtxns j+  return j{jtxns=ts}+ -- | Add equity postings inferred from costs, where needed and possible. -- See hledger manual > Cost reporting. journalInferEquityFromCosts :: Bool -> Journal -> Journal-journalInferEquityFromCosts verbosetags j = journalMapTransactions (transactionAddInferredEquityPostings verbosetags equityAcct) j-  where-    equityAcct = journalConversionAccount j---- | Add costs inferred from equity conversion postings, where needed and possible.--- See hledger manual > Cost reporting.-journalInferCostsFromEquity :: Journal -> Either String Journal-journalInferCostsFromEquity j = do-  ts <- mapM (transactionInferCostsFromEquity False conversionaccts) $ jtxns j-  return j{jtxns=ts}-  where conversionaccts = journalConversionAccounts j---- XXX duplication of the above--- | Do just the internal tagging that is normally done by journalInferCostsFromEquity,--- identifying equity conversion postings and, in particular, postings which have redundant costs.--- Tagging the latter is useful as it allows them to be ignored during transaction balancedness checking.--- And that allows journalInferCostsFromEquity to be postponed till after transaction balancing,--- when it will have more information (amounts) to work with.-journalMarkRedundantCosts :: Journal -> Either String Journal-journalMarkRedundantCosts j = do-  ts <- mapM (transactionInferCostsFromEquity True conversionaccts) $ jtxns j-  return j{jtxns=ts}-  where conversionaccts = journalConversionAccounts j+journalInferEquityFromCosts verbosetags j =+  journalMapTransactions (transactionInferEquityPostings verbosetags equityAcct) j+  where equityAcct = journalBaseConversionAccount j  -- -- | Get this journal's unique, display-preference-canonicalised commodities, by symbol. -- journalCanonicalCommodities :: Journal -> M.Map String CommoditySymbol@@ -1241,7 +1245,7 @@          {jtxns = [            txnTieKnot $ Transaction {              tindex=0,-             tsourcepos=nullsourcepos,+             tsourcepos=nullsourcepospair,              tdate=fromGregorian 2008 01 01,              tdate2=Nothing,              tstatus=Unmarked,@@ -1258,7 +1262,7 @@           ,            txnTieKnot $ Transaction {              tindex=0,-             tsourcepos=nullsourcepos,+             tsourcepos=nullsourcepospair,              tdate=fromGregorian 2008 06 01,              tdate2=Nothing,              tstatus=Unmarked,@@ -1275,7 +1279,7 @@           ,            txnTieKnot $ Transaction {              tindex=0,-             tsourcepos=nullsourcepos,+             tsourcepos=nullsourcepospair,              tdate=fromGregorian 2008 06 02,              tdate2=Nothing,              tstatus=Unmarked,@@ -1292,7 +1296,7 @@           ,            txnTieKnot $ Transaction {              tindex=0,-             tsourcepos=nullsourcepos,+             tsourcepos=nullsourcepospair,              tdate=fromGregorian 2008 06 03,              tdate2=Nothing,              tstatus=Cleared,@@ -1309,7 +1313,7 @@           ,            txnTieKnot $ Transaction {              tindex=0,-             tsourcepos=nullsourcepos,+             tsourcepos=nullsourcepospair,              tdate=fromGregorian 2008 10 01,              tdate2=Nothing,              tstatus=Unmarked,@@ -1325,7 +1329,7 @@           ,            txnTieKnot $ Transaction {              tindex=0,-             tsourcepos=nullsourcepos,+             tsourcepos=nullsourcepospair,              tdate=fromGregorian 2008 12 31,              tdate2=Nothing,              tstatus=Unmarked,

@@ -33,11 +33,11 @@ import Hledger.Data.Journal import Hledger.Data.JournalChecks.Ordereddates import Hledger.Data.JournalChecks.Uniqueleafnames-import Hledger.Data.Posting (isVirtual, postingDate, transactionAllTags)+import Hledger.Data.Posting (isVirtual, postingDate, transactionAllTags, conversionPostingTagName, costPostingTagName, postingAsLines, generatedPostingTagName, generatedTransactionTagName, modifiedTransactionTagName) import Hledger.Data.Types-import Hledger.Data.Amount (amountIsZero, amountsRaw, missingamt, amounts)+import Hledger.Data.Amount (amountIsZero, amountsRaw, missingamt, oneLineFmt, showMixedAmountWith) import Hledger.Data.Transaction (transactionPayee, showTransactionLineFirstPart, partitionAndCheckConversionPostings)-import Data.Time (Day, diffDays)+import Data.Time (diffDays) import Hledger.Utils import Data.Ord import Hledger.Data.Dates (showDate)@@ -67,8 +67,7 @@           ,"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+          ]) f l ex (show a) a         where           (f,l,_mcols,ex) = makePostingAccountErrorExcerpt p @@ -78,44 +77,53 @@ journalCheckBalanceAssertions :: Journal -> Either String () journalCheckBalanceAssertions = fmap (const ()) . journalBalanceTransactions defbalancingopts --- | Check that all the commodities used in this journal's postings have been declared--- by commodity directives, returning an error message otherwise.+-- | Check that all the commodities used in this journal's postings and P directives+-- have been declared by commodity directives, returning an error message otherwise. journalCheckCommodities :: Journal -> Either String ()-journalCheckCommodities j = mapM_ checkcommodities (journalPostings j)+journalCheckCommodities j = do+  mapM_ checkPriceDirectiveCommodities $ jpricedirectives j+  mapM_ checkPostingCommodities $ journalPostings j   where-    checkcommodities p =-      case findundeclaredcomm p of-        Nothing -> Right ()-        Just (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+    firstUndeclaredOf comms = find (`M.notMember` jdeclaredcommodities j) comms++    errmsg = 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"+      ]++    checkPriceDirectiveCommodities pd@PriceDirective{pdcommodity=c, pdamount=amt} =+      case firstUndeclaredOf [c, acommodity amt] of+        Nothing   -> Right ()+        Just comm -> Left $ printf errmsg f l ex (show comm) comm comm+          where (f,l,_mcols,ex) = makePriceDirectiveErrorExcerpt pd Nothing++    checkPostingCommodities p =+      case firstundeclaredcomm p of+        Nothing                    -> Right ()+        Just (comm, _inpostingamt) -> Left $ printf errmsg f l ex (show comm) comm comm           where             (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-        -- the undeclared symbol was in the posting amount.-        findundeclaredcomm :: Posting -> Maybe (CommoditySymbol, Bool)-        findundeclaredcomm Posting{pamount=amt,pbalanceassertion} =-          case (findundeclared postingcomms, findundeclared assertioncomms) of+        -- Find the first undeclared commodity symbol in this posting's amount or balance assertion amount, if any.+        -- and whether it was in the posting amount.+        -- XXX The latter is currently unused, could be used to refine the error highlighting ?+        firstundeclaredcomm :: Posting -> Maybe (CommoditySymbol, Bool)+        firstundeclaredcomm Posting{pamount=amt,pbalanceassertion} =+          case (firstUndeclaredOf postingcomms, firstUndeclaredOf assertioncomms) of             (Just c, _) -> Just (c, True)             (_, Just c) -> Just (c, False)             _           -> Nothing           where+            assertioncomms = [acommodity a | Just a <- [baamount <$> pbalanceassertion]]             postingcomms = map acommodity $ filter (not . isIgnorable) $ amountsRaw amt               where-                -- Ignore missing amounts and zero amounts without commodity (#1767)-                isIgnorable a = (T.null (acommodity a) && amountIsZero a) || a == missingamt-            assertioncomms = [acommodity a | Just a <- [baamount <$> pbalanceassertion]]-            findundeclared = find (`M.notMember` jcommodities j)+                isIgnorable a = a==missingamt || (amountIsZero a && T.null (acommodity a))  -- #1767          -- Calculate columns suitable for highlighting the excerpt.         -- We won't show these in the main error line as they aren't@@ -215,7 +223,7 @@       ,"tag %s"       ]) --- | Tag names which have special significance to hledger.+-- | Tag names which have special significance to hledger, and need not be declared for `hledger check tags`. -- Keep synced with check-tags.test and hledger manual > Special tags. builtinTags = [    "date"                   -- overrides a posting's date@@ -225,15 +233,17 @@   ,"assert"                 -- appears on txns generated by close --assert   ,"retain"                 -- appears on txns generated by close --retain   ,"start"                  -- appears on txns generated by close --migrate/--close/--open/--assign-  ,"generated-transaction"  -- with --verbose-tags, appears on generated periodic txns-  ,"generated-posting"      -- with --verbose-tags, appears on generated auto postings-  ,"modified"               -- with --verbose-tags, appears on txns which have had auto postings added-  -- hidden tags used internally (and also queryable):-  ,"_generated-transaction" -- always exists on generated periodic txns-  ,"_generated-posting"     -- always exists on generated auto postings-  ,"_modified"              -- always exists on txns which have had auto postings added-  ,"_conversion-matched"    -- exists on postings which have been matched with a nearby @/@@ cost notation   ]+  -- these tags are used in both hidden and visible form+  <> ts <> map toVisibleTagName ts+  where+    ts = [+       generatedTransactionTagName -- marks txns generated by periodic rule+      ,modifiedTransactionTagName  -- marks txns which have had auto postings added+      ,generatedPostingTagName     -- marks postings which have been generated+      ,costPostingTagName          -- marks equity conversion postings which have been matched with a nearby costful posting+      ,conversionPostingTagName    -- marks costful postings which have been matched with a nearby pair of equity conversion postings+      ]  -- | In each tranaction, check that any conversion postings occur in adjacent pairs. journalCheckPairedConversionPostings :: Journal -> Either String ()@@ -255,11 +265,10 @@  -- | Check that accounts with balance assertions have no posting more -- than maxlag days after their latest balance assertion.--- Today's date is provided for error messages.-journalCheckRecentAssertions :: Day -> Journal -> Either String ()-journalCheckRecentAssertions today j =+journalCheckRecentAssertions :: Journal -> Either String ()+journalCheckRecentAssertions j =   let acctps = groupOn paccount $ sortOn paccount $ journalPostings j-  in case mapMaybe (findRecentAssertionError today) acctps of+  in case mapMaybe findRecentAssertionError acctps of     []         -> Right ()     firsterr:_ -> Left firsterr @@ -268,8 +277,8 @@ -- and if any postings are >maxlag days later than the assertion, -- return an error message identifying the first of them. -- Postings on the same date will be handled in parse order (hopefully).-findRecentAssertionError :: Day -> [Posting] -> Maybe String-findRecentAssertionError today ps = do+findRecentAssertionError :: [Posting] -> Maybe String+findRecentAssertionError ps = do   let rps = sortOn (Data.Ord.Down . postingDate) ps   let (afterlatestassertrps, untillatestassertrps) = span (isNothing.pbalanceassertion) rps   latestassertdate <- postingDate <$> headMay untillatestassertrps@@ -278,36 +287,39 @@   let lag = diffDays (postingDate firsterrorp) latestassertdate   let acct = paccount firsterrorp   let (f,l,_mcols,ex) = makePostingAccountErrorExcerpt firsterrorp-  let comm =-        case map acommodity $ amounts $ pamount firsterrorp of-          [] -> ""-          (t:_) | T.length t == 1 -> t-          (t:_) -> t <> " "+  -- let comm =+  --       case map acommodity $ amounts $ pamount firsterrorp of+  --         [] -> ""+  --         (t:_) | T.length t == 1 -> t+  --         (t:_) -> t <> " "   Just $ chomp $ printf     (unlines [       "%s:%d:",       "%s\n",-      "The recentassertions check is enabled, so accounts with balance assertions must",-      "have a balance assertion within %d days of their latest posting.",-      "",-      "In %s,",-      "this posting is %d days later than the balance assertion on %s.",-      "",-      "Consider adding a more recent balance assertion for this account. Eg:",+      -- "The recentassertions check is enabled, so accounts with balance assertions must",+      -- "have a balance assertion within %d days of their latest posting.",+      "The recentassertions check is enabled, so accounts with balance assertions",+      "must have a recent one, not more than %d days older than their latest posting.",+      "In account: %s",+      "the last assertion was on %s, %d days before this latest posting.",+      "Consider adding a new balance assertion to the above posting. Eg:",       "",-      "%s\n    %s    %s0 = %sAMT"+      "%s = BALANCE"       ])     f     l     (textChomp ex)     maxlag     (bold' $ T.unpack acct)-    lag     (showDate latestassertdate)-    (show today)-    acct-    comm-    comm+    lag+    (showposting firsterrorp)+    where+      showposting p =+        headDef "" $ first3 $ postingAsLines False True acctw amtw p{pcomment=""}+        where+          acctw = T.length $ paccount p+          amtw  = length $ showMixedAmountWith oneLineFmt $ pamount p  -- -- | Print the last balance assertion date & status of all accounts with balance assertions. -- printAccountLastAssertions :: Day -> [BalanceAssertionInfo] -> IO ()

@@ -97,7 +97,7 @@  -- | All commodities used in this ledger. ledgerCommodities :: Ledger -> [CommoditySymbol]-ledgerCommodities = M.keys . jinferredcommodities . ljournal+ledgerCommodities = M.keys . jinferredcommoditystyles . ljournal  -- tests 

@@ -20,7 +20,7 @@ import Hledger.Data.Types import Hledger.Data.Dates import Hledger.Data.Amount-import Hledger.Data.Posting (post, commentAddTagNextLine)+import Hledger.Data.Posting (post, generatedTransactionTagName) import Hledger.Data.Transaction  -- $setup@@ -205,13 +205,11 @@           ,tstatus      = ptstatus           ,tcode        = ptcode           ,tdescription = ptdescription-          ,tcomment     = ptcomment &-            (if verbosetags then (`commentAddTagNextLine` ("generated-transaction",period)) else id)-          ,ttags        = pttags &-            (("_generated-transaction",period) :) &-            (if verbosetags then (("generated-transaction" ,period) :) else id)+          ,tcomment     = ptcomment+          ,ttags        = pttags           ,tpostings    = ptpostings           }+        & transactionAddHiddenAndMaybeVisibleTag verbosetags (generatedTransactionTagName, period)     period = "~ " <> ptperiodexpr     -- All the date spans described by this periodic transaction rule.     alltxnspans = splitSpan adjust ptinterval span'

@@ -1,4 +1,3 @@-{-# LANGUAGE NamedFieldPuns #-} {-|  A 'Posting' represents a change (by some 'MixedAmount') of the balance in@@ -8,6 +7,8 @@  -} +{-# LANGUAGE CPP #-}+{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-}  module Hledger.Data.Posting (@@ -18,7 +19,6 @@   vpost,   post',   vpost',-  nullsourcepos,   nullassertion,   balassert,   balassertTot,@@ -41,6 +41,7 @@   postingApplyCommodityStyles,   postingStyleAmounts,   postingAddTags,+  postingAddHiddenAndMaybeVisibleTag,   -- * date operations   postingDate,   postingDate2,@@ -54,17 +55,22 @@   commentAddTag,   commentAddTagUnspaced,   commentAddTagNextLine,+  generatedTransactionTagName,+  modifiedTransactionTagName,+  generatedPostingTagName,+  costPostingTagName,+  conversionPostingTagName,+   -- * arithmetic   sumPostings,+  negatePostingAmount,   -- * rendering   showPosting,   showPostingLines,   postingAsLines,   postingsAsLines,-  postingsAsLinesBeancount,-  postingAsLinesBeancount,+  postingIndent,   showAccountName,-  showAccountNameBeancount,   renderCommentLines,   showBalanceAssertion,   -- * misc.@@ -82,7 +88,10 @@ import Data.Function ((&)) import qualified Data.Map as M import Data.Maybe (fromMaybe, isJust, mapMaybe)-import Data.List (foldl', sort, union)+import Data.List (sort, union)+#if !MIN_VERSION_base(4,20,0)+import Data.List (foldl')+#endif import qualified Data.Set as S import Data.Text (Text) import qualified Data.Text as T@@ -91,7 +100,6 @@ import Data.Time.Calendar (Day) import Safe (maximumBound) import Text.DocLayout (realLength)- import Text.Tabular.AsciiWide hiding (render)  import Hledger.Utils@@ -102,6 +110,17 @@ import Hledger.Data.Valuation  +-- | Special tags hledger sometimes adds to mark various things.+-- These should be hidden tag names, beginning with _.+-- With --verbose-tags, the equivalent visible tags will also be added.+-- These tag names are mentioned in docs and can be matched by user queries, so consider the impact before changing them.+generatedTransactionTagName, modifiedTransactionTagName, costPostingTagName, conversionPostingTagName, generatedPostingTagName :: TagName+generatedTransactionTagName = "_generated-transaction"  -- ^ transactions generated by a periodic txn rule+modifiedTransactionTagName  = "_modified-transaction"   -- ^ transactions modified by an auto posting rule+generatedPostingTagName     = "_generated-posting"      -- ^ postings generated by hledger for one reason or another+costPostingTagName          = "_cost-posting"           -- ^ postings which have or could have a cost that's equivalent to nearby conversion postings+conversionPostingTagName    = "_conversion-posting"     -- ^ postings to an equity account of Conversion type which have an amount that's equivalent to a nearby costful or potentially costful posting+ instance HasAmounts BalanceAssertion where   styleAmounts styles ba@BalanceAssertion{baamount} = ba{baamount=styleAmounts styles baamount} @@ -158,9 +177,6 @@ vpost' :: AccountName -> Amount -> Maybe BalanceAssertion -> Posting vpost' acc amt ass = (post' acc amt ass){ptype=VirtualPosting, pbalanceassertion=ass} -nullsourcepos :: (SourcePos, SourcePos)-nullsourcepos = (SourcePos "" (mkPos 1) (mkPos 1), SourcePos "" (mkPos 2) (mkPos 1))- nullassertion :: BalanceAssertion nullassertion = BalanceAssertion                   {baamount=nullamt@@ -210,11 +226,11 @@     maxacctwidth = maximumBound 0 $ map second3 linesWithWidths     maxamtwidth  = maximumBound 0 $ map third3 linesWithWidths --- | Given a transaction and its postings, render the postings, suitable--- for `print` output. Normally this output will be valid journal syntax which--- hledger can reparse (though it may include no-longer-valid balance assertions).+-- | Render a transaction's postings as indented lines, suitable for `print` output. ----- Explicit amounts are shown, any implicit amounts are not.+-- Normally these will be in valid journal syntax which hledger can reparse+-- (though they may include no-longer-valid balance assertions).+-- Explicit amounts are shown, implicit amounts are not. -- -- Postings with multicommodity explicit amounts are handled as follows: -- if onelineamounts is true, these amounts are shown on one line,@@ -222,12 +238,12 @@ -- Otherwise, they are shown as several similar postings, one per commodity. -- When the posting has a balance assertion, it is attached to the last of these postings. ----- The output will appear to be a balanced transaction.--- Amounts' display precisions, which may have been limited by commodity--- directives, will be increased if necessary to ensure this.--- -- Posting amounts will be aligned with each other, starting about 4 columns -- beyond the widest account name (see postingAsLines for details).+-- The postings will appear balanced (amounts summing to zero).+-- Amounts' display precisions, which may have been limited by commodity directives,+-- will be increased if necessary to ensure this.+-- postingsAsLines :: Bool -> [Posting] -> [Text] postingsAsLines onelineamounts ps = concatMap first3 linesWithWidths   where@@ -236,11 +252,12 @@     maxamtwidth  = maximumBound 0 $ map third3 linesWithWidths  -- | Render one posting, on one or more lines, suitable for `print` output.+-- Also returns the widths calculated for the account and amount fields.+-- -- There will be an indented account name, plus one or more of status flag, -- posting amount, balance assertion, same-line comment, next-line comments. -- -- If the posting's amount is implicit or if elideamount is true, no amount is shown.--- -- If the posting's amount is explicit and multi-commodity, multiple similar -- postings are shown, one for each commodity, to help produce parseable journal syntax. -- Or if onelineamounts is true, such amounts are shown on one line, comma-separated@@ -257,7 +274,6 @@ -- increased if needed to match the posting with the longest account name. -- This is used to align the amounts of a transaction's postings. ----- Also returns the account width and amount width used. postingAsLines :: Bool -> Bool -> Int -> Int -> Posting -> ([Text], Int, Int) postingAsLines elideamount onelineamounts acctwidth amtwidth p =     (concatMap (++ newlinecomments) postingblocks, thisacctwidth, thisamtwidth)@@ -305,7 +321,7 @@             assertion = maybe mempty ((WideBuilder (TB.singleton ' ') 1 <>).showBalanceAssertion) $ pbalanceassertion p      -- pad to the maximum account name width, plus 2 to leave room for status flags, to keep amounts aligned-    statusandaccount = lineIndent . fitText (Just $ 2 + acctwidth) Nothing False True $ pstatusandacct p+    statusandaccount = postingIndent . fitText (Just $ 2 + acctwidth) Nothing False True $ pstatusandacct p     thisacctwidth = realLength $ pacctstr p      (samelinecomment, newlinecomments) =@@ -321,91 +337,6 @@     fmt VirtualPosting         = wrap "(" ")" . maybe id (T.takeEnd . subtract 2) w     fmt BalancedVirtualPosting = wrap "[" "]" . maybe id (T.takeEnd . subtract 2) w --- | Like postingsAsLines but generates Beancount journal format.-postingsAsLinesBeancount :: [Posting] -> [Text]-postingsAsLinesBeancount ps = concatMap first3 linesWithWidths-  where-    linesWithWidths = map (postingAsLinesBeancount False maxacctwidth maxamtwidth) ps-    maxacctwidth = maximumBound 0 $ map second3 linesWithWidths-    maxamtwidth  = maximumBound 0 $ map third3  linesWithWidths---- | Like postingAsLines but generates Beancount journal format.-postingAsLinesBeancount  :: Bool -> Int -> Int -> Posting -> ([Text], Int, Int)-postingAsLinesBeancount elideamount acctwidth amtwidth p =-    (concatMap (++ newlinecomments) postingblocks, thisacctwidth, thisamtwidth)-  where-    -- This needs to be converted to strict Text in order to strip trailing-    -- spaces. This adds a small amount of inefficiency, and the only difference-    -- is whether there are trailing spaces in print (and related) reports. This-    -- could be removed and we could just keep everything as a Text Builder, but-    -- would require adding trailing spaces to 42 failing tests.-    postingblocks = [map T.stripEnd . T.lines . TL.toStrict $-                       render [ textCell BottomLeft statusandaccount-                              , textCell BottomLeft "  "-                              , Cell BottomLeft [pad amt]-                              , textCell BottomLeft samelinecomment-                              ]-                    | (amt,_assertion) <- shownAmountsAssertions]-    render = renderRow def{tableBorders=False, borderSpaces=False} . Group NoLine . map Header-    pad amt = WideBuilder (TB.fromText $ T.replicate w " ") w <> amt-      where w = max 12 amtwidth - wbWidth amt  -- min. 12 for backwards compatibility--    pacct = showAccountNameBeancount Nothing $ paccount p-    pstatusandacct p' = if pstatus p' == Pending then "! " else "" <> pacct--    -- currently prices are considered part of the amount string when right-aligning amounts-    -- Since we will usually be calling this function with the knot tied between-    -- amtwidth and thisamtwidth, make sure thisamtwidth does not depend on-    -- amtwidth at all.-    shownAmounts-      | elideamount = [mempty]-      | otherwise   = showMixedAmountLinesB displayopts a'-        where-          displayopts = defaultFmt{ displayZeroCommodity=True, displayForceDecimalMark=True }-          a' = mapMixedAmount amountToBeancount $ pamount p-    thisamtwidth = maximumBound 0 $ map wbWidth shownAmounts--    -- when there is a balance assertion, show it only on the last posting line-    shownAmountsAssertions = zip shownAmounts shownAssertions-      where-        shownAssertions = replicate (length shownAmounts - 1) mempty ++ [assertion]-          where-            assertion = maybe mempty ((WideBuilder (TB.singleton ' ') 1 <>).showBalanceAssertion) $ pbalanceassertion p--    -- pad to the maximum account name width, plus 2 to leave room for status flags, to keep amounts aligned-    statusandaccount = lineIndent . fitText (Just $ 2 + acctwidth) Nothing False True $ pstatusandacct p-    thisacctwidth = realLength pacct--    (samelinecomment, newlinecomments) =-      case renderCommentLines (pcomment p) of []   -> ("",[])-                                              c:cs -> (c,cs)--type BeancountAmount = Amount---- | Do some best effort adjustments to make an amount that renders--- in a way that Beancount can read: forces the commodity symbol to the right,--- converts a few currency symbols to names, capitalises all letters.-amountToBeancount :: Amount -> BeancountAmount-amountToBeancount a@Amount{acommodity=c,astyle=s,acost=mp} = a{acommodity=c', astyle=s', acost=mp'}-  -- https://beancount.github.io/docs/beancount_language_syntax.html#commodities-currencies-  where-    c' = T.toUpper $-      T.replace "$" "USD" $-      T.replace "€" "EUR" $-      T.replace "¥" "JPY" $-      T.replace "£" "GBP" $-      c-    s' = s{ascommodityside=R, ascommodityspaced=True}-    mp' = costToBeancount <$> mp-      where-        costToBeancount (TotalCost amt) = TotalCost $ amountToBeancount amt-        costToBeancount (UnitCost  amt) = UnitCost  $ amountToBeancount amt---- | Like showAccountName for Beancount journal format.--- Calls accountNameToBeancount first.-showAccountNameBeancount :: Maybe Int -> AccountName -> Text-showAccountNameBeancount w = maybe id T.take w . accountNameToBeancount- -- | Render a transaction or posting's comment as indented, semicolon-prefixed comment lines. -- The first line (unless empty) will have leading space, subsequent lines will have a larger indent. renderCommentLines :: Text -> [Text]@@ -413,14 +344,14 @@   case T.lines t of     []      -> []     [l]     -> [commentSpace $ comment l]        -- single-line comment-    ("":ls) -> "" : map (lineIndent . comment) ls  -- multi-line comment with empty first line-    (l:ls)  -> commentSpace (comment l) : map (lineIndent . comment) ls+    ("":ls) -> "" : map (postingIndent . comment) ls  -- multi-line comment with empty first line+    (l:ls)  -> commentSpace (comment l) : map (postingIndent . comment) ls   where     comment = ("; "<>)  -- | Prepend a suitable indent for a posting (or transaction/posting comment) line.-lineIndent :: Text -> Text-lineIndent = ("    "<>)+postingIndent :: Text -> Text+postingIndent = ("    "<>)  -- | Prepend the space required before a same-line comment. commentSpace :: Text -> Text@@ -450,6 +381,10 @@ sumPostings :: [Posting] -> MixedAmount sumPostings = foldl' (\amt p -> maPlus amt $ pamount p) nullmixedamt +-- | Negate amount in a posting.+negatePostingAmount :: Posting -> Posting+negatePostingAmount = postingTransformAmount negate+ -- | Strip all prices from a Posting. postingStripCosts :: Posting -> Posting postingStripCosts = postingTransformAmount mixedAmountStripCosts@@ -525,9 +460,21 @@           ++ "\n to account name: "++T.unpack paccount++"\n "++e  -- | Add tags to a posting, discarding any for which the posting already has a value.+-- Note this does not add tags to the posting's comment. postingAddTags :: Posting -> [Tag] -> Posting postingAddTags p@Posting{ptags} tags = p{ptags=ptags `union` tags} +-- | Add the given hidden tag to a posting; and with a true argument,+-- also add the equivalent visible tag to the posting's tags and comment fields.+-- If the posting already has these tags (with any value), do nothing.+postingAddHiddenAndMaybeVisibleTag :: Bool -> HiddenTag -> Posting -> Posting+postingAddHiddenAndMaybeVisibleTag verbosetags ht p@Posting{pcomment=c, ptags} =+  (p `postingAddTags` ([ht] <> [vt|verbosetags]))+  {pcomment=if verbosetags && not hadtag then c `commentAddTag` vt else c}+  where+    vt@(vname,_) = toVisibleTag ht+    hadtag = any ((== (T.toLower vname)) . T.toLower . fst) ptags  -- XXX should regex-quote vname+ -- | Apply a specified valuation to this posting's amount, using the -- provided price oracle, commodity styles, and reference dates. -- See amountApplyValuation.@@ -539,44 +486,42 @@ postingToCost :: ConversionOp -> Posting -> Maybe Posting postingToCost NoConversionOp p = Just p postingToCost ToCost         p-  -- If this is a conversion posting with a matched transaction price posting, ignore it-  | "_conversion-matched" `elem` map fst (ptags p) && nocosts = Nothing+  -- If this is an equity conversion posting with an associated cost nearby, ignore it+  | conversionPostingTagName `elem` map fst (ptags p) && nocosts = Nothing   | otherwise = Just $ postingTransformAmount mixedAmountCost p   where     nocosts = (not . any (isJust . acost) . amountsRaw) $ pamount p --- | Generate inferred equity postings from a 'Posting''s costs.--- Make sure not to duplicate them when matching ones exist already.+-- | Generate equity conversion postings corresponding to a 'Posting''s cost(s)+-- (one pair of conversion postings per cost), wherever they don't already exist. postingAddInferredEquityPostings :: Bool -> Text -> Posting -> [Posting] postingAddInferredEquityPostings verbosetags equityAcct p-    | "_price-matched" `elem` map fst (ptags p) = [p]-    | otherwise = taggedPosting : concatMap conversionPostings costs+  -- this posting has no costs+  | null costs = [p]+  -- this posting is already tagged as having associated conversion postings+  | costPostingTagName `elem` map fst (ptags p) = [p]+  -- tag the posting, and for each of its costs, add an equivalent pair of conversion postings after it+  | otherwise =+    postingAddHiddenAndMaybeVisibleTag verbosetags (costPostingTagName,"") p :+    concatMap makeConversionPostings costs   where     costs = filter (isJust . acost) . amountsRaw $ pamount p-    taggedPosting-      | null costs = p-      | otherwise  = p{ ptags = ("_price-matched","") : ptags p }-    conversionPostings amt = case acost amt of-        Nothing -> []-        Just _  -> [ cp{ paccount = accountPrefix <> amtCommodity-                       , pamount = mixedAmount . negate $ amountStripCost amt-                       }-                   , cp{ paccount = accountPrefix <> costCommodity-                       , pamount = mixedAmount cost-                       }-                   ]+    makeConversionPostings amt = case acost amt of+      Nothing -> []+      Just _  -> [ convp{ paccount = accountPrefix <> amtCommodity+                        , pamount = mixedAmount . negate $ amountStripCost amt+                        }+                 , convp{ paccount = accountPrefix <> costCommodity+                        , pamount = mixedAmount cost+                        }+                 ]       where         cost = amountCost amt         amtCommodity  = commodity amt         costCommodity = commodity cost-        cp = p{ pcomment = pcomment p & (if verbosetags then (`commentAddTag` ("generated-posting","conversion")) else id)-              , ptags    =-                   ("_conversion-matched","") : -- implementation-specific internal tag, not for users-                   ("_generated-posting","conversion") :-                   (if verbosetags then [("generated-posting", "conversion")] else [])-              , pbalanceassertion = Nothing-              , poriginal = Nothing-              }+        convp = p{pbalanceassertion=Nothing, poriginal=Nothing}+          & postingAddHiddenAndMaybeVisibleTag verbosetags (conversionPostingTagName,"")+          & postingAddHiddenAndMaybeVisibleTag verbosetags (generatedPostingTagName, "")         accountPrefix = mconcat [ equityAcct, ":", T.intercalate "-" $ sort [amtCommodity, costCommodity], ":"]         -- Take the commodity of an amount and collapse consecutive spaces to a single space         commodity = T.unwords . filter (not . T.null) . T.words . acommodity

@@ -26,7 +26,9 @@   posintopt,   maybeintopt,   maybeposintopt,-  maybecharopt+  maybecharopt,+  maybeynopt,+  maybeynaopt, ) where @@ -35,6 +37,8 @@ import Safe (headMay, lastMay, readDef)  import Hledger.Utils+import Data.Char (toLower)+import Data.List (intercalate)   -- | The result of running cmdargs: an association list of option names to string values.@@ -139,3 +143,20 @@                                          ++ " must lie in the range "                                          ++ show minVal ++ " to " ++ show maxVal                                          ++ ", but is " ++ show n++maybeynopt :: String -> RawOpts -> Maybe Bool+maybeynopt name rawopts =+  case maybestringopt name rawopts of+    Just v | map toLower v `elem` ["y","yes","always"] -> Just True+    Just v | map toLower v `elem` ["n","no","never"]   -> Just False+    Just _ -> error' $ name <> " value should be one of " <> (intercalate ", " ["y","yes","n","no"])+    _ -> Nothing++maybeynaopt :: String -> RawOpts -> Maybe YNA+maybeynaopt name rawopts =+  case maybestringopt name rawopts of+    Just v | map toLower v `elem` ["y","yes","always"] -> Just Yes+    Just v | map toLower v `elem` ["n","no","never"]   -> Just No+    Just v | map toLower v `elem` ["a","auto"]         -> Just Auto+    Just _ -> error' $ name <> " value should be one of " <> (intercalate ", " ["y","yes","n","no","a","auto"])+    _ -> Nothing

@@ -27,13 +27,18 @@ , transactionTransformPostings , transactionApplyValuation , transactionToCost-, transactionAddInferredEquityPostings-, transactionInferCostsFromEquity+, transactionInferEquityPostings+, transactionTagCostsAndEquityAndMaybeInferCosts , transactionApplyAliases , transactionMapPostings , transactionMapPostingAmounts , transactionAmounts , partitionAndCheckConversionPostings+, transactionAddTags+, transactionAddHiddenAndMaybeVisibleTag+  -- * helpers+, payeeAndNoteFromDescription+, payeeAndNoteFromDescription'   -- nonzerobalanceerror   -- * date operations , transactionDate2@@ -46,7 +51,6 @@ , showTransaction , showTransactionOneLineAmounts , showTransactionLineFirstPart-, showTransactionBeancount , transactionFile   -- * transaction errors , annotateErrorWithTransaction@@ -74,6 +78,8 @@ import Hledger.Data.Valuation import Data.Decimal (normalizeDecimal, decimalPlaces) import Data.Functor ((<&>))+import Data.Function ((&))+import Data.List (union)   instance HasAmounts Transaction where@@ -82,7 +88,7 @@ nulltransaction :: Transaction nulltransaction = Transaction {                     tindex=0,-                    tsourcepos=nullsourcepos,+                    tsourcepos=nullsourcepospair,                     tdate=nulldate,                     tdate2=Nothing,                     tstatus=Unmarked,@@ -176,33 +182,6 @@            | otherwise            = ""     code = if T.null (tcode t) then "" else wrap " (" ")" $ tcode t --- | Like showTransaction, but generates Beancount journal format.-showTransactionBeancount :: Transaction -> Text-showTransactionBeancount t =-  -- https://beancount.github.io/docs/beancount_language_syntax.html-  -- similar to showTransactionHelper, but I haven't bothered with Builder-     firstline <> nl-  <> foldMap ((<> nl)) newlinecomments-  <> foldMap ((<> nl)) (postingsAsLinesBeancount $ tpostings t)-  <> nl-  where-    nl = "\n"-    firstline = T.concat [date, status, payee, note, tags, samelinecomment]-    date = showDate $ tdate t-    status = if tstatus t == Pending then " !" else " *"-    (payee,note) =-      case payeeAndNoteFromDescription' $ tdescription t of-        ("","") -> ("",      ""      )-        ("",n ) -> (""     , wrapq n )-        (p ,"") -> (wrapq p, wrapq "")-        (p ,n ) -> (wrapq p, wrapq n )-      where-        wrapq = wrap " \"" "\"" . escapeDoubleQuotes . escapeBackslash-    tags = T.concat $ map ((" #"<>).fst) $ ttags t-    (samelinecomment, newlinecomments) =-      case renderCommentLines (tcomment t) of []   -> ("",[])-                                              c:cs -> (c,cs)- hasRealPostings :: Transaction -> Bool hasRealPostings = not . null . realPostings @@ -260,10 +239,11 @@ transactionToCost :: ConversionOp -> Transaction -> Transaction transactionToCost cost t = t{tpostings = mapMaybe (postingToCost cost) $ tpostings t} --- | Add inferred equity postings to a 'Transaction' using transaction prices.-transactionAddInferredEquityPostings :: Bool -> AccountName -> Transaction -> Transaction-transactionAddInferredEquityPostings verbosetags equityAcct t =-    t{tpostings=concatMap (postingAddInferredEquityPostings verbosetags equityAcct) $ tpostings t}+-- | For any costs in this 'Transaction' which don't have associated equity conversion postings,+-- generate and add those.+transactionInferEquityPostings :: Bool -> AccountName -> Transaction -> Transaction+transactionInferEquityPostings verbosetags equityAcct t =+  t{tpostings=concatMap (postingAddInferredEquityPostings verbosetags equityAcct) $ tpostings t}  type IdxPosting = (Int, Posting) @@ -273,17 +253,35 @@  label s = ((s <> ": ")++) --- | Add costs inferred from equity postings in this transaction.--- The name(s) of conversion equity accounts should be provided.--- For every adjacent pair of conversion postings, it will first search the postings--- with costs to see if any match. If so, it will tag these as matched.--- If no postings with costs match, it will then search the postings without costs,--- and will match the first such posting which matches one of the conversion amounts.--- If it finds a match, it will add a cost and then tag it.--- If the first argument is true, do a dry run instead: identify and tag--- the costful and conversion postings, but don't add costs.-transactionInferCostsFromEquity :: Bool -> [AccountName] -> Transaction -> Either String Transaction-transactionInferCostsFromEquity dryrun conversionaccts t = first (annotateErrorWithTransaction t . T.unpack) $ do+-- | Add tags to a transaction, discarding any for which it already has a value.+-- Note this does not add tags to the transaction's comment.+transactionAddTags :: Transaction -> [Tag] -> Transaction+transactionAddTags t@Transaction{ttags} tags = t{ttags=ttags `union` tags}++-- | Add the given hidden tag to a transaction; and with a true argument,+-- also add the equivalent visible tag to the transaction's tags and comment fields.+-- If the transaction already has these tags (with any value), do nothing.+transactionAddHiddenAndMaybeVisibleTag :: Bool -> HiddenTag -> Transaction -> Transaction+transactionAddHiddenAndMaybeVisibleTag verbosetags ht t@Transaction{tcomment=c, ttags} =+  (t `transactionAddTags` ([ht] <> [vt|verbosetags]))+  {tcomment=if verbosetags && not hadtag then c `commentAddTagNextLine` vt else c}+  where+    vt@(vname,_) = toVisibleTag ht+    hadtag = any ((== (T.toLower vname)) . T.toLower . fst) ttags  -- XXX should regex-quote vname++-- | Find, associate, and tag the corresponding equity conversion postings and costful or potentially costful postings in this transaction.+-- With a true addcosts argument, also generate and add any equivalent costs that are missing.+-- The (previously detected) names of all equity conversion accounts should be provided.+--+-- For every pair of adjacent conversion postings, this first searches for a posting with equivalent cost (1).+-- If no such posting is found, it then searches the costless postings, for one matching one of the conversion amounts (2).+-- If either of these found a candidate posting, it is tagged with costPostingTagName.+-- Then if in addcosts mode, if a costless posting was found, a cost equivalent to the conversion amounts is added to it.+--+-- The name reflects the complexity of this and its helpers; clarification is ongoing.+--+transactionTagCostsAndEquityAndMaybeInferCosts :: Bool -> Bool -> [AccountName] -> Transaction -> Either String Transaction+transactionTagCostsAndEquityAndMaybeInferCosts verbosetags1 addcosts conversionaccts t = first (annotateErrorWithTransaction t . T.unpack) $ do   -- number the postings   let npostings = zip [0..] $ tpostings t @@ -295,7 +293,7 @@   -- 1. each pair of conversion postings, and the corresponding postings which balance them, are tagged for easy identification   -- 2. each pair of balancing postings which did't have an explicit cost, have had a cost calculated and added to one of them   -- 3. if any ambiguous situation was detected, an informative error is raised-  processposting <- transformIndexedPostingsF (addCostsToPostings dryrun) conversionPairs otherps+  processposting <- transformIndexedPostingsF (tagAndMaybeAddCostsForEquityPostings verbosetags1 addcosts) conversionPairs otherps    -- And if there was no error, use it to modify the transaction's postings.   return t{tpostings = map (snd . processposting) npostings}@@ -304,7 +302,7 @@      -- Generate the tricksy processposting function,     -- which when applied to each posting in turn, rather magically has the effect of-    -- applying addCostsToPostings to each pair of conversion postings in the transaction,+    -- applying tagAndMaybeAddCostsForEquityPostings to each pair of conversion postings in the transaction,     -- matching them with the other postings, tagging them and perhaps adding cost information to the other postings.     -- General type:     -- transformIndexedPostingsF :: (Monad m, Foldable t, Traversable t) =>@@ -314,45 +312,44 @@     --   m (a1 -> a1)     -- Concrete type:     transformIndexedPostingsF ::-      ((IdxPosting, IdxPosting) -> StateT ([IdxPosting],[IdxPosting]) (Either Text) (IdxPosting -> IdxPosting)) ->  -- state update function (addCostsToPostings with the bool applied)+      ((IdxPosting, IdxPosting) -> StateT ([IdxPosting],[IdxPosting]) (Either Text) (IdxPosting -> IdxPosting)) ->  -- state update function (tagAndMaybeAddCostsForEquityPostings with the bool applied)       [(IdxPosting, IdxPosting)] ->   -- initial state: the pairs of adjacent conversion postings in the transaction       ([IdxPosting],[IdxPosting]) ->  -- initial state: the other postings in the transaction, separated into costful and costless       (Either Text (IdxPosting -> IdxPosting))  -- returns an error message or a posting transform function     transformIndexedPostingsF updatefn = evalStateT . fmap (appEndo . foldMap Endo) . traverse (updatefn)      -- A tricksy state update helper for processposting/transformIndexedPostingsF.-    -- Approximately: given a pair of conversion postings to match,+    -- Approximately: given a pair of equity conversion postings to match,     -- and lists of the remaining unmatched costful and costless other postings,-    -- 1. find (and consume) two other postings which match the two conversion postings-    -- 2. add identifying tags to the four postings-    -- 3. add an explicit cost, if missing, to one of the matched other postings-    -- 4. or if there is a problem, raise an informative error or do nothing as appropriate.-    -- Or, if the first argument is true:-    -- do a dry run instead: find and consume, add tags, but don't add costs-    -- (and if there are no costful postings at all, do nothing).-    addCostsToPostings :: Bool -> (IdxPosting, IdxPosting) -> StateT ([IdxPosting], [IdxPosting]) (Either Text) (IdxPosting -> IdxPosting)-    addCostsToPostings dryrun' ((n1, cp1), (n2, cp2)) = StateT $ \(costps, otherps) -> do+    -- 1. find (and consume) two other postings whose amounts/cost match the two conversion postings+    -- 2. add hidden identifying tags to the conversion postings and the other posting which has (or could have) an equivalent cost+    -- 3. if in add costs mode, and the potential equivalent-cost posting does not have that explicit cost, add it+    -- 4. or if there is a problem, raise an informative error or do nothing, as appropriate.+    -- Or if there are no costful postings at all, do nothing.+    tagAndMaybeAddCostsForEquityPostings :: Bool -> Bool -> (IdxPosting, IdxPosting) -> StateT ([IdxPosting], [IdxPosting]) (Either Text) (IdxPosting -> IdxPosting)+    tagAndMaybeAddCostsForEquityPostings verbosetags addcosts' ((n1, cp1), (n2, cp2)) = StateT $ \(costps, otherps) -> do       -- Get the two conversion posting amounts, if possible       ca1 <- conversionPostingAmountNoCost cp1       ca2 <- conversionPostingAmountNoCost cp2       let -        -- All costful postings which match the conversion posting pair-        matchingCostPs =+        -- All costful postings whose cost is equivalent to the conversion postings' amounts.+        matchingCostfulPs =           dbg7With (label "matched costful postings".show.length) $            mapMaybe (mapM $ costfulPostingIfMatchesBothAmounts ca1 ca2) costps -        -- All other single-commodity postings whose amount matches at least one of the conversion postings,-        -- with an explicit cost added. Or in dry run mode, all other single-commodity postings.-        matchingOtherPs =+        -- In dry run mode: all other costless, single-commodity postings.+        -- In add costs mode: all other costless, single-commodity postings whose amount matches at least one of the conversion postings,+        -- with the equivalent cost added to one of them. (?)+        matchingCostlessPs =           dbg7With (label "matched costless postings".show.length) $-          if dryrun'-          then [(n,(p, a)) | (n,p) <- otherps, let Just a = postingSingleAmount p]-          else mapMaybe (mapM $ addCostIfMatchesOneAmount ca1 ca2) otherps+          if addcosts'+          then mapMaybe (mapM $ addCostIfMatchesOneAmount ca1 ca2) otherps+          else [(n,(p, a)) | (n,p) <- otherps, let Just a = postingSingleAmount p]          -- A function that adds a cost and/or tag to a numbered posting if appropriate.         postingAddCostAndOrTag np costp (n,p) =-          (n, if | n == np            -> costp `postingAddTags` [("_price-matched","")]-                 | n == n1 || n == n2 -> p     `postingAddTags` [("_conversion-matched","")]+          (n, if | n == np            -> costp & postingAddHiddenAndMaybeVisibleTag verbosetags (costPostingTagName,"")        -- if it's the specified posting number, replace it with the costful posting, and tag it+                 | n == n1 || n == n2 -> p     & postingAddHiddenAndMaybeVisibleTag verbosetags (conversionPostingTagName,"")  -- if it's one of the equity conversion postings, tag it                  | otherwise          -> p)        -- Annotate any errors with the conversion posting pair@@ -362,20 +359,20 @@           -- delete it from the list of costful postings in the state, delete the           -- first matching costless posting from the list of costless postings           -- in the state, and return the transformation function with the new state.-          | [(np, costp)] <- matchingCostPs+          | [(np, costp)] <- matchingCostfulPs           , Just newcostps <- deleteIdx np costps-              -> Right (postingAddCostAndOrTag np costp, (if dryrun' then costps else newcostps, otherps))+              -> Right (postingAddCostAndOrTag np costp, (if addcosts' then newcostps else costps, otherps))            -- If no costful postings match the conversion postings, but some           -- of the costless postings match, check that the first such posting has a           -- different amount from all the others, and if so add a cost to it,           -- then delete it from the list of costless postings in the state,           -- and return the transformation function with the new state.-          | [] <- matchingCostPs-          , (np, (costp, amt)):nps <- matchingOtherPs+          | [] <- matchingCostfulPs+          , (np, (costp, amt)):nps <- matchingCostlessPs           , not $ any (amountsMatch amt . snd . snd) nps           , Just newotherps <- deleteIdx np otherps-              -> Right (postingAddCostAndOrTag np costp, (costps, if dryrun' then otherps else newotherps))+              -> Right (postingAddCostAndOrTag np costp, (costps, if addcosts' then newotherps else otherps))            -- Otherwise, do nothing, leaving the transaction unchanged.           -- We don't want to be over-zealous reporting problems here@@ -445,7 +442,7 @@   -- Left fold processes postings in parse order, so that eg inferred costs   -- will be added to the first (top-most) posting, not the last one.   foldlM select (([], ([], [])), Nothing)-    -- The costless other postings are somehow reversed still; "second (second reverse" fixes that.+    -- The costless other postings are somehow reversed still; "second (second reverse)" fixes that.     <&> fmap (second (second reverse) . fst)   where     select ((cs, others@(ps, os)), Nothing) np@(_, p)@@ -604,7 +601,7 @@                  Transaction                    0                    ""-                   nullsourcepos+                   nullsourcepospair                    (fromGregorian 2007 01 28)                    Nothing                    Unmarked@@ -628,7 +625,7 @@               Transaction                 0                 ""-                nullsourcepos+                nullsourcepospair                 (fromGregorian 2007 01 28)                 Nothing                 Unmarked@@ -651,7 +648,7 @@               Transaction                 0                 ""-                nullsourcepos+                nullsourcepospair                 (fromGregorian 2007 01 28)                 Nothing                 Unmarked@@ -667,7 +664,7 @@               Transaction                 0                 ""-                nullsourcepos+                nullsourcepospair                 (fromGregorian 2010 01 01)                 Nothing                 Unmarked

@@ -23,10 +23,10 @@ import Hledger.Data.Types import Hledger.Data.Amount import Hledger.Data.Dates-import Hledger.Data.Transaction (txnTieKnot)+import Hledger.Data.Transaction (txnTieKnot, transactionAddHiddenAndMaybeVisibleTag) import Hledger.Query (Query, filterQuery, matchesAmount, matchesPostingExtra,                       parseQuery, queryIsAmt, queryIsSym, simplifyQuery)-import Hledger.Data.Posting (commentJoin, commentAddTag, postingAddTags)+import Hledger.Data.Posting (commentJoin, commentAddTag, postingAddTags, modifiedTransactionTagName) import Hledger.Utils (dbg6, wrap)  -- $setup@@ -47,14 +47,10 @@ modifyTransactions atypes atags styles d verbosetags tmods ts = do   fs <- mapM (transactionModifierToFunction atypes atags styles d verbosetags) tmods  -- convert modifiers to functions, or return a parse error   let-    modifytxn t = t''+    modifytxn t =+      t' & if t'/=t then transactionAddHiddenAndMaybeVisibleTag verbosetags (modifiedTransactionTagName,"") else id       where         t' = foldr (flip (.)) id fs t  -- apply each function in turn-        t'' = if t' == t-              then t'-              else t'{tcomment=tcomment t' & (if verbosetags then (`commentAddTag` ("modified","")) else id)-                     ,ttags=ttags t' & (("_modified","") :) & (if verbosetags then (("modified","") :) else id)-                     }    Right $ map modifytxn ts 

@@ -33,17 +33,20 @@ where  import GHC.Generics (Generic)+import Data.Bifunctor (first) import Data.Decimal (Decimal, DecimalRaw(..)) import Data.Default (Default(..)) import Data.Functor (($>))-import Data.List (intercalate)+import Data.List (intercalate, sortBy) --XXX https://hackage.haskell.org/package/containers/docs/Data-Map.html --Note: You should use Data.Map.Strict instead of this module if: --You will eventually need all the values stored. --The stored values don't represent large virtual data structures to be lazily computed. import qualified Data.Map as M import Data.Ord (comparing)+import Data.Semigroup (Min(..)) import Data.Text (Text)+import qualified Data.Text as T import Data.Time.Calendar (Day) import Data.Time.Clock.POSIX (POSIXTime) import Data.Time.LocalTime (LocalTime)@@ -53,6 +56,7 @@  import Hledger.Utils.Regex + -- synonyms for various date-related scalars #if MIN_VERSION_time(1,11,0) import Data.Time.Calendar (Year)@@ -153,6 +157,19 @@  type AccountName = Text +-- A specification indicating how to depth-limit+data DepthSpec = DepthSpec {+  dsFlatDepth    :: Maybe Int,+  dsRegexpDepths :: [(Regexp, Int)]+  } deriving (Eq,Show)++-- Semigroup instance consider all regular expressions, but take the minimum of the simple flat depths+instance Semigroup DepthSpec where+    DepthSpec d1 l1 <> DepthSpec d2 l2 = DepthSpec (getMin <$> (Min <$> d1) <> (Min <$> d2)) (l1 ++ l2)++instance Monoid DepthSpec where+    mempty = DepthSpec Nothing []+ data AccountType =     Asset   | Liability@@ -389,8 +406,32 @@ type TagName = Text type TagValue = Text type Tag = (TagName, TagValue)  -- ^ A tag name and (possibly empty) value.+type HiddenTag = Tag            -- ^ A tag whose name begins with _. type DateTag = (TagName, Day) +-- | Add the _ prefix to a normal visible tag's name, making it a hidden tag.+toHiddenTag :: Tag -> HiddenTag+toHiddenTag = first toHiddenTagName++-- | Drop the _ prefix from a hidden tag's name, making it a normal visible tag.+toVisibleTag :: HiddenTag -> Tag+toVisibleTag = first toVisibleTagName++-- | Does this tag name begin with the hidden tag prefix (_) ?+isHiddenTagName :: TagName -> Bool+isHiddenTagName t =+  case T.uncons t of+    Just ('_',_) -> True+    _ -> False++-- | Add the _ prefix to a normal visible tag's name, making it a hidden tag.+toHiddenTagName :: TagName -> TagName+toHiddenTagName = T.cons '_'++-- | Drop the _ prefix from a hidden tag's name, making it a normal visible tag.+toVisibleTagName :: TagName -> TagName+toVisibleTagName = T.drop 1+ -- | The status of a transaction or posting, recorded with a status mark -- (nothing, !, or *). What these mean is ultimately user defined. data Status = Unmarked | Pending | Cleared@@ -401,6 +442,12 @@   show Pending   = "!"   show Cleared   = "*" +nullsourcepos :: SourcePos+nullsourcepos = SourcePos "" (mkPos 1) (mkPos 1)++nullsourcepospair :: (SourcePos, SourcePos)+nullsourcepospair = (SourcePos "" (mkPos 1) (mkPos 1), SourcePos "" (mkPos 2) (mkPos 1))+ -- | A balance assertion is a declaration about an account's expected balance -- at a certain point (posting date and parse order). They provide additional -- error checking and readability to a journal file.@@ -545,7 +592,8 @@ -- It declares two things: a historical exchange rate between two commodities, -- and an amount display style for the second commodity. data PriceDirective = PriceDirective {-   pddate      :: Day+   pdsourcepos :: SourcePos+  ,pddate      :: Day   ,pdcommodity :: CommoditySymbol   ,pdamount    :: Amount   } deriving (Eq,Ord,Generic,Show)@@ -559,50 +607,52 @@   ,mprate :: Quantity           -- ^ One unit of the "from" commodity is worth this quantity of the "to" commodity.   } deriving (Eq,Ord,Generic, Show) +showMarketPrice MarketPrice{..} = unwords [show mpdate, T.unpack mpfrom <> ">" <> T.unpack mpto, show mprate]+showMarketPrices = intercalate "\n" . map ((' ':).showMarketPrice) . sortBy (comparing mpdate)+ -- additional valuation-related types in Valuation.hs --- | A Journal, containing transactions and various other things.--- The basic data model for hledger.+-- | A journal, containing general ledger transactions; also directives and various other things.+-- This is hledger's main data model. ----- This is used during parsing (as the type alias ParsedJournal), and--- then finalised/validated for use as a Journal. Some extra--- parsing-related fields are included for convenience, at least for--- now. In a ParsedJournal these are updated as parsing proceeds, in a--- Journal they represent the final state at end of parsing (used eg--- by the add command).+-- During parsing, it is used as the type alias "ParsedJournal".+-- The jparse* fields are mainly used during parsing and included here for convenience.+-- The list fields described as "in parse order" are usually reversed for efficiency during parsing.+-- After parsing, "journalFinalise" converts ParsedJournal to a finalised "Journal",+-- which has all lists correctly ordered, and much data inference and validation applied. -- data Journal = Journal {-  -- parsing-related data-   jparsedefaultyear      :: Maybe Year                            -- ^ the current default year, specified by the most recent Y directive (or current date)-  ,jparsedefaultcommodity :: Maybe (CommoditySymbol,AmountStyle)   -- ^ the current default commodity and its format, specified by the most recent D directive-  ,jparsedecimalmark      :: Maybe DecimalMark                     -- ^ the character to always parse as decimal point, if set by CsvReader's decimal-mark (or a future journal directive)-  ,jparseparentaccounts   :: [AccountName]                         -- ^ the current stack of parent account names, specified by apply account directives-  ,jparsealiases          :: [AccountAlias]                        -- ^ the current account name aliases in effect, specified by alias directives (& options ?)+  -- parsing-related state+   jparsedefaultyear        :: Maybe Year                             -- ^ the current default year, specified by the most recent Y directive (or current date)+  ,jparsedefaultcommodity   :: Maybe (CommoditySymbol,AmountStyle)    -- ^ the current default commodity and its format, specified by the most recent D directive+  ,jparsedecimalmark        :: Maybe DecimalMark                      -- ^ the character to always parse as decimal point, if set by CsvReader's decimal-mark (or a future journal directive)+  ,jparseparentaccounts     :: [AccountName]                          -- ^ the current stack of parent account names, specified by apply account directives+  ,jparsealiases            :: [AccountAlias]                         -- ^ the current account name aliases in effect, specified by alias directives (& options ?)   -- ,jparsetransactioncount :: Integer                               -- ^ the current count of transactions parsed so far (only journal format txns, currently)-  ,jparsetimeclockentries :: [TimeclockEntry]                       -- ^ timeclock sessions which have not been clocked out-  ,jincludefilestack      :: [FilePath]+  ,jparsetimeclockentries   :: [TimeclockEntry]                       -- ^ timeclock sessions which have not been clocked out+  ,jincludefilestack        :: [FilePath]   -- principal data-  ,jdeclaredpayees        :: [(Payee,PayeeDeclarationInfo)]         -- ^ Payees declared by payee directives, in parse order (after journal finalisation)-  ,jdeclaredtags          :: [(TagName,TagDeclarationInfo)]         -- ^ Tags declared by tag directives, in parse order (after journal finalisation)-  ,jdeclaredaccounts      :: [(AccountName,AccountDeclarationInfo)] -- ^ Accounts declared by account directives, in parse order (after journal finalisation)-  ,jdeclaredaccounttags   :: M.Map AccountName [Tag]                -- ^ Accounts which have tags declared in their directives, and those tags. (Does not include parents' tags.)-  ,jdeclaredaccounttypes  :: M.Map AccountType [AccountName]        -- ^ Accounts whose type has been explicitly declared in their account directives, grouped by type.-  ,jaccounttypes          :: M.Map AccountName AccountType          -- ^ All accounts for which a type has been declared or can be inferred from its parent or its name.-  ,jglobalcommoditystyles :: M.Map CommoditySymbol AmountStyle      -- ^ per-commodity display styles declared globally, eg by command line option or import command-  ,jcommodities           :: M.Map CommoditySymbol Commodity        -- ^ commodities and formats declared by commodity directives-  ,jinferredcommodities   :: M.Map CommoditySymbol AmountStyle      -- ^ commodities and formats inferred from journal amounts-  ,jpricedirectives       :: [PriceDirective]                       -- ^ Declarations of market prices by P directives, in parse order (after journal finalisation)-  ,jinferredmarketprices  :: [MarketPrice]                          -- ^ Market prices implied by transactions, in parse order (after journal finalisation)-  ,jtxnmodifiers          :: [TransactionModifier]-  ,jperiodictxns          :: [PeriodicTransaction]-  ,jtxns                  :: [Transaction]-  ,jfinalcommentlines     :: Text                                   -- ^ any final trailing comments in the (main) journal file-  ,jfiles                 :: [(FilePath, Text)]                     -- ^ the file path and raw text of the main and-                                                                    --   any included journal files. The main file is first,-                                                                    --   followed by any included files in the order encountered.-                                                                    --   TODO: FilePath is a sloppy type here, don't assume it's a-                                                                    --   real file; values like "", "-", "(string)" can be seen-  ,jlastreadtime          :: POSIXTime                              -- ^ when this journal was last read from its file(s)+  ,jdeclaredpayees          :: [(Payee,PayeeDeclarationInfo)]         -- ^ Payees declared by payee directives, in parse order.+  ,jdeclaredtags            :: [(TagName,TagDeclarationInfo)]         -- ^ Tags declared by tag directives, in parse order.+  ,jdeclaredaccounts        :: [(AccountName,AccountDeclarationInfo)] -- ^ Accounts declared by account directives, in parse order.+  ,jdeclaredaccounttags     :: M.Map AccountName [Tag]                -- ^ Accounts which were declared with tags, and those tags.+  ,jdeclaredaccounttypes    :: M.Map AccountType [AccountName]        -- ^ Accounts which were declared with a type: tag, grouped by the type.+  ,jaccounttypes            :: M.Map AccountName AccountType          -- ^ All the account types known, from account declarations or account names or parent accounts.+  ,jdeclaredcommodities     :: M.Map CommoditySymbol Commodity        -- ^ Commodities (and their display styles) declared by commodity directives, in parse order.+  ,jinferredcommoditystyles :: M.Map CommoditySymbol AmountStyle      -- ^ Commodity display styles inferred from amounts in the journal.+  ,jglobalcommoditystyles   :: M.Map CommoditySymbol AmountStyle      -- ^ Commodity display styles declared by command line options (sometimes augmented, see the import command).+  ,jpricedirectives         :: [PriceDirective]                       -- ^ P (market price) directives in the journal, in parse order.+  ,jinferredmarketprices    :: [MarketPrice]                          -- ^ Market prices inferred from transactions in the journal, in parse order.+  ,jtxnmodifiers            :: [TransactionModifier]                  -- ^ Auto posting rules declared in the journal.+  ,jperiodictxns            :: [PeriodicTransaction]                  -- ^ Periodic transaction rules declared in the journal.+  ,jtxns                    :: [Transaction]                          -- ^ Transactions recorded in the journal. The important bit.+  ,jfinalcommentlines       :: Text                                   -- ^ any final trailing comments in the (main) journal file+  ,jfiles                   :: [(FilePath, Text)]                     -- ^ the file path and raw text of the main and+                                                                      --   any included journal files. The main file is first,+                                                                      --   followed by any included files in the order encountered.+                                                                      --   TODO: FilePath is a sloppy type here, don't assume it's a+                                                                      --   real file; values like "", "-", "(string)" can be seen+  ,jlastreadtime            :: POSIXTime                              -- ^ when this journal was last read from its file(s)   -- NOTE: after adding new fields, eg involving account names, consider updating   -- the Anon instance in Hleger.Cli.Anon   } deriving (Eq, Generic)

@@ -48,7 +48,8 @@ import Hledger.Data.Amount import Hledger.Data.Dates (nulldate) import Text.Printf (printf)-import Data.Decimal (decimalPlaces, roundTo)+import Data.Decimal (decimalPlaces, roundTo, Decimal)+import Data.Word (Word8)   ------------------------------------------------------------------------------@@ -94,7 +95,9 @@ journalPriceOracle infer Journal{jpricedirectives, jinferredmarketprices} =   let     declaredprices = map priceDirectiveToMarketPrice jpricedirectives-    inferredprices = if infer then jinferredmarketprices else []+    inferredprices =+      (if infer then jinferredmarketprices else [])+      & traceOrLogAt 2 ("use prices inferred from costs? " <> if infer then "yes" else "no")     makepricegraph = memo $ makePriceGraph declaredprices inferredprices   in     memo $ uncurry3 $ priceLookup makepricegraph@@ -118,7 +121,7 @@       where u = amountSetFullPrecisionUpTo Nothing $ divideAmount n t     _                            -> Nothing   where-    pd = PriceDirective{pddate = d, pdcommodity = fromcomm, pdamount = nullamt}+    pd = PriceDirective{pdsourcepos=nullsourcepos, pddate=d, pdcommodity=fromcomm, pdamount=nullamt}  ------------------------------------------------------------------------------ -- Converting things to value@@ -273,14 +276,17 @@       Just to            ->         -- We have a commodity to convert to. Find the most direct price available,         -- according to the rules described in makePriceGraph.-        let msg = printf "seeking %s to %s price" (showCommoditySymbol from) (showCommoditySymbol to)-        in case -          (traceOrLogAt 2 (msg++" using forward prices") $ -            pricesShortestPath from to forwardprices)-          <|> -          (traceOrLogAt 2 (msg++" using forward and reverse prices") $ -            pricesShortestPath from to allprices)-        of+        let+          msg = printf "seeking %s to %s price" (showCommoditySymbol from) (showCommoditySymbol to)+          prices =+            (traceOrLogAt 2 (msg++" using forward prices") $+             traceOrLogAt 2 ("forward prices:\n" <> showMarketPrices forwardprices) $+             pricesShortestPath from to forwardprices)+            <|>+            (traceOrLogAt 2 (msg++" using forward and reverse prices") $+             traceOrLogAt 2 ("forward and reverse prices:\n" <> showMarketPrices allprices) $+             pricesShortestPath from to $ dbg5 "all forward and reverse prices" allprices)+        in case prices of           Nothing -> Nothing           Just [] -> Nothing           Just ps -> Just (mpto $ last ps, rate)@@ -290,13 +296,18 @@                 -- aggregate all the prices into one                 product rates                 -- product (Decimal's Num instance) normalises, stripping trailing zeros.-                -- Here we undo that (by restoring the old max precision with roundTo), -                -- so that amountValueAtDate can see the original internal precision,-                -- to use as the display precision of calculated value amounts.-                -- (This can add more than the original number of trailing zeros to some prices,-                -- making them seem more precise than they were, but it seems harmless here.)-                & roundTo (maximum $ map decimalPlaces rates)+                -- But we want to preserve even those, since the number of decimal digits+                -- here will guide amountValueAtDate in setting the Amount display precision later.+                -- So we restore them. Or rather, we ensure as many decimal digits as the maximum seen among rates.+                -- (Some prices might end up more precise than they were, but that seems harmless here.)+                & setMinDecimalPlaces (maximum $ map decimalPlaces rates) +-- Ensure this Decimal has at least this many decimal places, adding trailing zeros if necessary.+setMinDecimalPlaces :: Word8 -> Decimal -> Decimal+setMinDecimalPlaces n d+  | decimalPlaces d < n = roundTo n d  -- too few, add some zeros+  | otherwise           = d            -- more than enough, keep as-is+ tests_priceLookup =   let     p y m d from q to = MarketPrice{mpdate=fromGregorian y m d, mpfrom=from, mpto=to, mprate=q}@@ -326,7 +337,7 @@     -- ^ The date on which these prices are in effect.   ,pgEdges :: [Edge]     -- ^ "Forward" exchange rates between commodity pairs, either-    --   declared by P directives or inferred from transaction prices,+    --   declared by P directives or (with --infer-market-prices) inferred from costs,     --   forming the edges of a directed graph.     ,pgEdgesRev :: [Edge]     -- ^ The same edges, plus any additional edges that can be@@ -334,6 +345,7 @@     --     --   In both of these there will be at most one edge between each     --   directed pair of commodities, eg there can be one USD->EUR and one EUR->USD.+    --   ,pgDefaultValuationCommodities :: M.Map CommoditySymbol CommoditySymbol     -- ^ The default valuation commodity for each source commodity.     --   These are used when a valuation commodity is not specified@@ -352,9 +364,8 @@ pricesShortestPath start end edges =   -- at --debug=2 +, print the pretty path and also the detailed prices   let label = printf "shortest path from %s to %s: " (showCommoditySymbol start) (showCommoditySymbol end) in-  fmap (dbg2With (("price chain:\n"++).pshow)) $ -  dbg2With ((label++).(maybe "none found" (pshowpath ""))) $-+  fmap (dbg2With (("price chain:\n"++).showMarketPrices)) $+  dbg2With ((label++).(maybe "none" (pshowpath ""))) $   find [([],edges)]    where

@@ -23,6 +23,7 @@   parseQueryList,   parseQueryTerm,   parseAccountType,+  parseDepthSpec,   -- * modifying   simplifyQuery,   filterQuery,@@ -82,7 +83,7 @@ import Data.Text (Text) import qualified Data.Text as T import Data.Time.Calendar (Day, fromGregorian )-import Safe (headErr, readDef, readMay, maximumByMay, maximumMay, minimumMay)+import Safe (headErr, readMay, maximumByMay, maximumMay, minimumMay) import Text.Megaparsec (between, noneOf, sepBy, try, (<?>), notFollowedBy) import Text.Megaparsec.Char (char, string, string') @@ -116,6 +117,7 @@   | Acct Regexp               -- ^ match account names infix-matched by this regexp   | Type [AccountType]        -- ^ match accounts whose type is one of these (or with no types, any account)   | Depth Int                 -- ^ match if account depth is less than or equal to this value (or, sometimes used as a display option)+  | DepthAcct Regexp Int      -- ^ match if the account matches and account depth is less than or equal to this value (usually used as a display option)   | Real Bool                 -- ^ match postings with this "realness" value   | Amt OrdPlus Quantity      -- ^ match if the amount's numeric quantity is less than/greater than/equal to/unsignedly equal to some value   | Sym Regexp                -- ^ match if the commodity symbol is fully-matched by this regexp@@ -301,11 +303,7 @@                               Right st -> Right (StatusQ st, []) parseQueryTerm _ (T.stripPrefix "real:" -> Just s) = Right (Real $ parseBool s || T.null s, []) parseQueryTerm _ (T.stripPrefix "amt:" -> Just s) = Right (Amt ord q, []) where (ord, q) = either error id $ parseAmountQueryTerm s  -- PARTIAL:-parseQueryTerm _ (T.stripPrefix "depth:" -> Just s)-  | n >= 0    = Right (Depth n, [])-  | otherwise = Left "depth: should have a positive number"-  where n = readDef 0 (T.unpack s)-+parseQueryTerm _ (T.stripPrefix "depth:" -> Just s) = (,[]) <$> parseDepthSpecQuery s parseQueryTerm _ (T.stripPrefix "cur:" -> Just s) = (,[]) . Sym <$> toRegexCI ("^" <> s <> "$") -- support cur: as an alias parseQueryTerm _ (T.stripPrefix "tag:" -> Just s) = (,[]) <$> parseTag s parseQueryTerm _ (T.stripPrefix "type:" -> Just s) = (,[]) <$> parseTypeCodes s@@ -473,6 +471,25 @@     return $ Tag tag body   where (n,v) = T.break (=='=') s +parseDepthSpec :: T.Text -> Either RegexError DepthSpec+parseDepthSpec s = do+    let depthString = T.unpack $ if T.null b then a else T.tail b+    depth <- case readMay depthString of+        Just d | d >= 0 -> Right d+        _ -> Left $ "depth: should be a positive number, but received " ++ depthString+    regexp <- mapM toRegexCI $ if T.null b then Nothing else Just a+    return $ case regexp of+      Nothing -> DepthSpec (Just depth) []+      Just r  -> DepthSpec Nothing [(r, depth)]+  where+    (a,b) = T.break (=='=') s++parseDepthSpecQuery :: T.Text -> Either RegexError Query+parseDepthSpecQuery s = do+    DepthSpec flat rs <- parseDepthSpec s+    let regexps = map (uncurry DepthAcct) rs+    return . And $ maybe id (\d -> (Depth d :)) flat regexps+ -- | Parse one or more account type code letters to a query matching any of those types. parseTypeCodes :: T.Text -> Either String Query parseTypeCodes s =@@ -639,6 +656,7 @@  queryIsDepth :: Query -> Bool queryIsDepth (Depth _) = True+queryIsDepth (DepthAcct _ _) = True queryIsDepth _ = False  queryIsReal :: Query -> Bool@@ -749,13 +767,12 @@     compareNothingMax (Just a) (Just b) = compare a b  -- | The depth limit this query specifies, if it has one-queryDepth :: Query -> Maybe Int-queryDepth = minimumMay . queryDepth'-  where-    queryDepth' (Depth d) = [d]-    queryDepth' (Or qs)   = concatMap queryDepth' qs-    queryDepth' (And qs)  = concatMap queryDepth' qs-    queryDepth' _         = []+queryDepth :: Query -> DepthSpec+queryDepth (Or qs)         = foldMap queryDepth qs+queryDepth (And qs)        = foldMap queryDepth qs+queryDepth (Depth d)       = DepthSpec (Just d) []+queryDepth (DepthAcct r d) = DepthSpec Nothing [(r,d)]+queryDepth _               = mempty  -- | The account we are currently focussed on, if any, and whether subaccounts are included. -- Just looks at the first query option.@@ -819,6 +836,7 @@ matchesAccount (And ms) a = all (`matchesAccount` a) ms matchesAccount (Acct r) a = regexMatchText r a matchesAccount (Depth d) a = accountNameLevel a <= d+matchesAccount (DepthAcct r d) a = accountNameLevel a <= d || not (regexMatchText r a) matchesAccount (Tag _ _) _ = False matchesAccount _ _ = True @@ -855,6 +873,7 @@ 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@(DepthAcct _ _) 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@@ -897,7 +916,8 @@ 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@(Depth _) t = any (q `matchesPosting`) $ tpostings t+matchesTransaction q@(DepthAcct _ _) t = any (q `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

@@ -125,7 +125,7 @@  --- ** imports import qualified Control.Exception as C-import Control.Monad (unless, when)+import Control.Monad (unless, when, forM) import "mtl" Control.Monad.Except (ExceptT(..), runExceptT, liftEither) import Control.Monad.IO.Class (MonadIO, liftIO) import Data.Default (def)@@ -159,6 +159,7 @@ import Hledger.Utils import Prelude hiding (getContents, writeFile) import Hledger.Data.JournalChecks (journalStrictChecks)+import Text.Printf (printf)  --- ** doctest setup -- $setup@@ -401,12 +402,15 @@ previousLatestDates :: FilePath -> IO LatestDates previousLatestDates f = do   let latestfile = latestDatesFileFor f-      parsedate s = maybe (fail $ "could not parse date \"" ++ s ++ "\"") return $-                      parsedateM s   exists <- doesFileExist latestfile-  if exists-  then traverse (parsedate . T.unpack . T.strip) . T.lines =<< readFileStrictly latestfile-  else return []+  t <- if exists then readFileStrictly latestfile else return T.empty+  let nls = zip [1::Int ..] $ T.lines t+  fmap catMaybes $ forM nls $ \(n,l) -> do+    let s = T.unpack $ T.strip l+    case (s, parsedateM s) of+      ("", _)       -> return Nothing+      (_,  Nothing) -> error' (printf "%s:%d: invalid date: \"%s\"" latestfile n s)+      (_,  Just d)  -> return $ Just d  -- | Where to save latest transaction dates for the given file path. -- (.latest.FILE)

@@ -99,7 +99,7 @@   emptyorcommentlinep2,   followingcommentp,   transactioncommentp,-  commenttagsp,+  commentlinetagsp,   postingcommentp,    -- ** bracketed dates@@ -192,14 +192,14 @@  -- | Parse an InputOpts from a RawOpts and a provided date. -- This will fail with a usage error if the forecast period expression cannot be parsed.-rawOptsToInputOpts :: Day -> RawOpts -> InputOpts-rawOptsToInputOpts day rawopts =+rawOptsToInputOpts :: Day -> Bool -> Bool -> RawOpts -> InputOpts+rawOptsToInputOpts day usecoloronstdout postingaccttags rawopts =      let noinferbalancingcosts = boolopt "strict" rawopts || stringopt "args" rawopts == "balanced"          -- Do we really need to do all this work just to get the requested end date? This is duplicating         -- much of reportOptsToSpec.-        ropts = rawOptsToReportOpts day rawopts+        ropts = rawOptsToReportOpts day usecoloronstdout rawopts         argsquery = map fst . rights . map (parseQueryTerm day) $ querystring_ ropts         datequery = simplifyQuery . filterQuery queryIsDate . And $ queryFromFlags ropts : argsquery @@ -216,6 +216,7 @@       ,new_save_          = True       ,pivot_             = stringopt "pivot" rawopts       ,forecast_          = forecastPeriodFromRawOpts day rawopts+      ,posting_account_tags_ = postingaccttags       ,verbose_tags_      = boolopt "verbose-tags" rawopts       ,reportspan_        = DateSpan (Exact <$> queryStartDate False datequery) (Exact <$> queryEndDate False datequery)       ,auto_              = boolopt "auto" rawopts@@ -326,13 +327,14 @@ -- Others (commodities, accounts..) are done later by journalStrictChecks. -- journalFinalise :: InputOpts -> FilePath -> Text -> ParsedJournal -> ExceptT String IO Journal-journalFinalise iopts@InputOpts{auto_,balancingopts_,infer_costs_,infer_equity_,strict_,verbose_tags_,_ioDay} f txt pj = do+journalFinalise iopts@InputOpts{auto_,balancingopts_,infer_costs_,infer_equity_,strict_,posting_account_tags_,verbose_tags_,_ioDay} f txt pj = do   let     BalancingOpts{commodity_styles_, ignore_assertions_} = balancingopts_     fname = "journalFinalise " <> takeFileName f     lbl = lbl_ fname+    -- Some not so pleasant hacks     -- We want to know when certain checks have been explicitly requested with the check command,-    -- but it does not run until later. For now, hackily inspect the command line with unsafePerformIO.+    -- but it does not run until later. For now, inspect the command line with unsafePerformIO.     checking checkname = "check" `elem` args && checkname `elem` args where args = progArgs     -- We will check ordered dates when "check ordereddates" is used.     checkordereddates = checking "ordereddates"@@ -346,12 +348,11 @@       &   journalAddFile (f, txt)                        -- save the main file's info       &   journalReverse                                 -- convert all lists to the order they were parsed       &   journalAddAccountTypes                         -- build a map of all known account types+            -- XXX does not see conversion accounts generated by journalInferEquityFromCosts below, requiring a workaround in journalCheckAccounts. Do it later ?       &   journalStyleAmounts                            -- Infer and apply commodity styles (but don't round) - should be done early       <&> journalAddForecast verbose_tags_ (forecastPeriod iopts pj)   -- Add forecast transactions if enabled-      <&> journalPostingsAddAccountTags                  -- Add account tags to postings, so they can be matched by auto postings.-      >>= journalMarkRedundantCosts                      -- Mark redundant costs, to help journalBalanceTransactions ignore them.-                                                         -- (Later, journalInferEquityFromCosts will do a similar pass, adding missing equity postings.)-+      <&> (if posting_account_tags_ then journalPostingsAddAccountTags else id)     -- Propagate account tags to postings - unless printing a beancount journal+      >>= journalTagCostsAndEquityAndMaybeInferCosts verbose_tags_ False   -- Tag equity conversion postings and redundant costs, to help journalBalanceTransactions ignore them.       >>= (if auto_ && not (null $ jtxnmodifiers pj)             then journalAddAutoPostings verbose_tags_ _ioDay balancingopts_  -- Add auto postings if enabled, and account tags if needed. Does preliminary transaction balancing.             else pure)@@ -365,8 +366,8 @@       -- <&> dbg9With (("journalFinalise amounts after styling, forecasting, auto postings, transaction balancing"<>).showJournalAmountsDebug)       >>= journalInferCommodityStyles                    -- infer commodity styles once more now that all posting amounts are present       -- >>= Right . dbg0With (pshow.journalCommodityStyles)-      >>= (if infer_costs_  then journalInferCostsFromEquity else pure)     -- Maybe infer costs from equity postings where possible-      <&> (if infer_equity_ then journalInferEquityFromCosts verbose_tags_ else id)  -- Maybe infer equity postings from costs where possible+      >>= (if infer_costs_  then journalTagCostsAndEquityAndMaybeInferCosts verbose_tags_ True else pure)  -- With --infer-costs, infer costs from equity postings where possible+      <&> (if infer_equity_ then journalInferEquityFromCosts verbose_tags_ else id)          -- With --infer-equity, infer equity postings from costs where possible       <&> dbg9With (lbl "amounts after equity-inferring".showJournalAmountsDebug)       <&> journalInferMarketPricesFromTransactions       -- infer market prices from commodity-exchanging transactions       -- <&> traceOrLogAt 6 fname  -- debug logging@@ -437,8 +438,8 @@ -- prior to the current position) commodity directive for the given commodity, if any. getAmountStyle :: CommoditySymbol -> JournalParser m (Maybe AmountStyle) getAmountStyle commodity = do-  Journal{jcommodities} <- get-  let mspecificStyle = M.lookup commodity jcommodities >>= cformat+  Journal{jdeclaredcommodities} <- get+  let mspecificStyle = M.lookup commodity jdeclaredcommodities >>= cformat   mdefaultStyle <- fmap snd <$> getDefaultCommodityAndStyle   return $ listToMaybe $ catMaybes [mspecificStyle, mdefaultStyle] @@ -1307,25 +1308,44 @@ isSameLineCommentStart ';' = True isSameLineCommentStart _   = False --- A parser for (possibly multiline) comments following a journal item.+-- | Parse a comment following a journal item, possibly continued on multiple lines,+-- and return the comment text. ----- 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).+-- >>> rtp followingcommentp ""   -- no comment+-- Right ""+-- >>> rtp followingcommentp ";"    -- just a (empty) same-line comment. newline is added+-- Right "\n"+-- >>> rtp followingcommentp ";  \n"+-- Right "\n"+-- >>> rtp followingcommentp ";\n ;\n"  -- a same-line and a next-line comment+-- Right "\n\n"+-- >>> rtp followingcommentp "\n ;\n"  -- just a next-line comment. Insert an empty same-line comment so the next-line comment doesn't become a same-line comment.+-- Right "\n\n" ----- 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.+followingcommentp :: TextParser m Text+followingcommentp =+  fst <$> followingcommentpWith (void $ takeWhileP Nothing (/= '\n'))  -- XXX support \r\n ?++{-# INLINABLE followingcommentp #-}++-- | Parse a following comment, possibly continued on multiple lines,+-- using the provided line parser to parse each line.+-- This returns the comment text, and the combined results from the line parser. ----- See followingcommentp for tests.+-- Following comments begin with a semicolon and extend to the end of the line.+-- They can optionally be continued on the next lines,+-- where each next line begins with an indent and another semicolon.+-- (This parser expects to see these semicolons and indents.) ---followingcommentp' :: (Monoid a, Show a) => TextParser m a -> TextParser m (Text, a)-followingcommentp' contentp = do+-- Like Ledger, we sometimes allow data to be embedded in comments.+-- account directive comments and transaction comments can contain tags,+-- and posting comments can contain tags or bracketed posting dates.+-- This helper lets us handle these variations. +-- The line parser should consume all input up until the next newline.+-- See followingcommentp for some tests.+--+followingcommentpWith :: (Monoid a, Show a) => TextParser m a -> TextParser m (Text, a)+followingcommentpWith contentp = do   skipNonNewlineSpaces   -- there can be 0 or 1 sameLine   sameLine <- try headerp *> ((:[]) <$> match' contentp) <|> pure []@@ -1346,27 +1366,37 @@   where     headerp = char ';' *> skipNonNewlineSpaces -{-# INLINABLE followingcommentp' #-}+{-# INLINABLE followingcommentpWith #-} --- | Parse the text of a (possibly multiline) comment following a journal item.------ >>> rtp followingcommentp ""   -- no comment--- Right ""--- >>> rtp followingcommentp ";"    -- just a (empty) same-line comment. newline is added--- Right "\n"--- >>> rtp followingcommentp ";  \n"--- Right "\n"--- >>> rtp followingcommentp ";\n ;\n"  -- a same-line and a next-line comment--- Right "\n\n"--- >>> rtp followingcommentp "\n ;\n"  -- just a next-line comment. Insert an empty same-line comment so the next-line comment doesn't become a same-line comment.--- Right "\n\n"----followingcommentp :: TextParser m Text-followingcommentp =-  fst <$> followingcommentp' (void $ takeWhileP Nothing (/= '\n'))  -- XXX support \r\n ?-{-# INLINABLE followingcommentp #-} +-- Parse the tags from a single comment line, eg for use with followingcommentpWith.+-- XXX what part of a comment line ? leading whitespace / semicolon or not ?+commentlinetagsp :: TextParser m [Tag]+commentlinetagsp = do+  -- XXX sketchy+  tagName <- (last . T.split isSpace) <$> takeWhileP Nothing (\c -> c /= ':' && c /= '\n')+  atColon tagName <|> pure [] -- if not ':', then either '\n' or EOF +  where+    atColon :: Text -> TextParser m [Tag]+    atColon name = char ':' *> do+      if T.null name+        then commentlinetagsp+        else do+          skipNonNewlineSpaces+          val <- tagValue+          let tag = (name, val)+          (tag:) <$> commentlinetagsp++    tagValue :: TextParser m Text+    tagValue = do+      val <- T.strip <$> takeWhileP Nothing (\c -> c /= ',' && c /= '\n')+      _ <- optional $ char ','+      pure val++{-# INLINABLE commentlinetagsp #-}++ -- | Parse a transaction comment and extract its tags. -- -- The first line of a transaction may be followed by comments, which@@ -1393,34 +1423,10 @@ -- leading and trailing whitespace. -- transactioncommentp :: TextParser m (Text, [Tag])-transactioncommentp = followingcommentp' commenttagsp+transactioncommentp = followingcommentpWith commentlinetagsp {-# INLINABLE transactioncommentp #-} -commenttagsp :: TextParser m [Tag]-commenttagsp = do-  tagName <- (last . T.split isSpace) <$> takeWhileP Nothing (\c -> c /= ':' && c /= '\n')-  atColon tagName <|> pure [] -- if not ':', then either '\n' or EOF -  where-    atColon :: Text -> TextParser m [Tag]-    atColon name = char ':' *> do-      if T.null name-        then commenttagsp-        else do-          skipNonNewlineSpaces-          val <- tagValue-          let tag = (name, val)-          (tag:) <$> commenttagsp--    tagValue :: TextParser m Text-    tagValue = do-      val <- T.strip <$> takeWhileP Nothing (\c -> c /= ',' && c /= '\n')-      _ <- optional $ char ','-      pure val--{-# INLINABLE commenttagsp #-}-- -- | Parse a posting comment and extract its tags and dates. -- -- Postings may be followed by comments, which begin with semicolons and@@ -1473,7 +1479,7 @@   :: Maybe Year -> TextParser m (Text, [Tag], Maybe Day, Maybe Day) postingcommentp mYear = do   (commentText, (tags, dateTags)) <--    followingcommentp' (commenttagsanddatesp mYear)+    followingcommentpWith (commenttagsanddatesp mYear)   let mdate  = snd <$> find ((=="date") .fst) dateTags       mdate2 = snd <$> find ((=="date2").fst) dateTags   pure (commentText, tags, mdate, mdate2)

@@ -34,6 +34,7 @@     ,new_save_          :: Bool                 -- ^ save latest new transactions state for next time ?     ,pivot_             :: String               -- ^ use the given field's value as the account name     ,forecast_          :: Maybe DateSpan       -- ^ span in which to generate forecast transactions+    ,posting_account_tags_  :: Bool             -- ^ propagate account tags to postings ?     ,verbose_tags_      :: Bool                 -- ^ add user-visible tags when generating/modifying transactions & postings ?     ,reportspan_        :: DateSpan             -- ^ a dirty hack keeping the query dates in InputOpts. This rightfully lives in ReportSpec, but is duplicated here.     ,auto_              :: Bool                 -- ^ generate extra postings according to auto posting rules ?@@ -55,6 +56,7 @@     , new_save_          = True     , pivot_             = ""     , forecast_          = Nothing+    , posting_account_tags_ = False     , verbose_tags_      = False     , reportspan_        = nulldatespan     , auto_              = False

@@ -374,7 +374,7 @@       ,jparseparentaccounts   = jparseparentaccounts j       ,jparsedecimalmark      = jparsedecimalmark j       ,jparsealiases          = jparsealiases j-      ,jcommodities           = jcommodities j+      ,jdeclaredcommodities           = jdeclaredcommodities j       -- ,jparsetransactioncount = jparsetransactioncount j       ,jparsetimeclockentries = jparsetimeclockentries j       ,jincludefilestack      = filepath : jincludefilestack j@@ -509,7 +509,7 @@   let comm = Commodity{csymbol=acommodity, cformat=Just $ dbg6 "style from commodity directive" astyle}   if isNothing $ asdecimalmark astyle   then customFailure $ parseErrorAt off pleaseincludedecimalpoint-  else modify' (\j -> j{jcommodities=M.insert acommodity comm $ jcommodities j})+  else modify' (\j -> j{jdeclaredcommodities=M.insert acommodity comm $ jdeclaredcommodities j})  pleaseincludedecimalpoint :: String pleaseincludedecimalpoint = chomp $ unlines [@@ -535,7 +535,7 @@   subdirectives <- many $ indented (eitherP (formatdirectivep sym) (lift restofline))   let mfmt = lastMay $ lefts subdirectives   let comm = Commodity{csymbol=sym, cformat=mfmt}-  modify' (\j -> j{jcommodities=M.insert sym comm $ jcommodities j})+  modify' (\j -> j{jdeclaredcommodities=M.insert sym comm $ jdeclaredcommodities j})   where     indented = (lift skipNonNewlineSpaces1 >>) @@ -671,15 +671,16 @@  marketpricedirectivep :: JournalParser m PriceDirective marketpricedirectivep = do+  pos <- getSourcePos   char 'P' <?> "market price"   lift skipNonNewlineSpaces   date <- try (do {LocalTime d _ <- datetimep; return d}) <|> datep -- a time is ignored   lift skipNonNewlineSpaces1   symbol <- lift commoditysymbolp-  lift skipNonNewlineSpaces+  lift skipNonNewlineSpaces1   price <- amountp   lift restofline-  return $ PriceDirective date symbol price+  return $ PriceDirective pos date symbol price  ignoredpricecommoditydirectivep :: JournalParser m () ignoredpricecommoditydirectivep = do@@ -1116,7 +1117,7 @@         [("a:b", AccountDeclarationInfo{adicomment          = "type:asset\n"                                        ,aditags             = [("type","asset")]                                        ,adideclarationorder = 1-                                       ,adisourcepos        = fst nullsourcepos+                                       ,adisourcepos        = nullsourcepos                                        })         ]       ]@@ -1145,6 +1146,7 @@   ,testCase "marketpricedirectivep" $ assertParseEq marketpricedirectivep     "P 2017/01/30 BTC $922.83\n"     PriceDirective{+      pdsourcepos = nullsourcepos,       pddate      = fromGregorian 2017 1 30,       pdcommodity = "BTC",       pdamount    = usd 922.83

@@ -14,6 +14,7 @@ -- stack haddock hledger-lib --fast --no-haddock-deps --haddock-arguments='--ignore-all-exports' --open  --- ** language+{-# LANGUAGE CPP    #-} {-# LANGUAGE FlexibleInstances    #-} {-# LANGUAGE OverloadedStrings    #-} {-# LANGUAGE RecordWildCards      #-}@@ -52,7 +53,10 @@ import Data.Char                  (toLower, isDigit, isSpace, isAlphaNum, ord) import Data.Bifunctor             (first) import Data.Functor               ((<&>))-import Data.List (elemIndex, foldl', mapAccumL, nub, sortOn)+import Data.List (elemIndex, mapAccumL, nub, sortOn)+#if !MIN_VERSION_base(4,20,0)+import Data.List (foldl')+#endif import Data.List.Extra (groupOn) import Data.Maybe (catMaybes, fromMaybe, isJust) import Data.MemoUgly (memo)@@ -76,7 +80,7 @@  import Hledger.Data import Hledger.Utils-import Hledger.Read.Common (aliasesFromOpts, Reader(..), InputOpts(..), amountp, statusp, journalFinalise, accountnamep, commenttagsp )+import Hledger.Read.Common (aliasesFromOpts, Reader(..), InputOpts(..), amountp, statusp, journalFinalise, accountnamep, transactioncommentp, postingcommentp ) import Hledger.Write.Csv import System.Directory (doesFileExist, getHomeDirectory) import Data.Either (fromRight)@@ -304,8 +308,13 @@ -- | A strptime date parsing pattern, as supported by Data.Time.Format. type DateFormat       = Text --- | A prefix for a matcher test, either & or none (implicit or).-data MatcherPrefix = And | Not | None+-- | A representation of a matcher's prefix, which indicates how it should be+-- interpreted or combined with other matchers.+data MatcherPrefix =+    Or      -- ^ no prefix+  | And     -- ^ &+  | Not     -- ^ !+  | AndNot  -- ^ & !   deriving (Show, Eq)  -- | A single test for matching a CSV record, in one way or another.@@ -314,6 +323,14 @@   | FieldMatcher MatcherPrefix CsvFieldReference Regexp         -- ^ match if this regexp matches the referenced CSV field's value   deriving (Show, Eq) +matcherPrefix :: Matcher -> MatcherPrefix+matcherPrefix (RecordMatcher prefix _) = prefix+matcherPrefix (FieldMatcher prefix _ _) = prefix++matcherSetPrefix :: MatcherPrefix -> Matcher -> Matcher+matcherSetPrefix p (RecordMatcher _ r)  = RecordMatcher p r+matcherSetPrefix p (FieldMatcher _ f r) = FieldMatcher p f r+ -- | A conditional block: a set of CSV record matchers, and a sequence -- of rules which will be enabled only if one or more of the matchers -- succeeds.@@ -631,6 +648,9 @@         -- A single matcher, on one line.+-- This tries to parse first as a field matcher, then if that fails, as a whole-record matcher;+-- the goal was to not break legacy whole-record patterns that happened to look a bit like a field matcher+-- (eg, beginning with %, possibly preceded by & or !), or at least not to raise an error. matcherp' :: CsvRulesParser () -> CsvRulesParser Matcher matcherp' end = try (fieldmatcherp end) <|> recordmatcherp end @@ -675,13 +695,18 @@ matcherprefixp :: CsvRulesParser MatcherPrefix matcherprefixp = do   lift $ dbgparse 8 "trying matcherprefixp"-  (char '&' >> lift skipNonNewlineSpaces >> return And) <|> (char '!' >> lift skipNonNewlineSpaces >> return Not) <|> return None+  (do+    char '&' >> lift skipNonNewlineSpaces+    fromMaybe And <$> optional (char '!' >> lift skipNonNewlineSpaces >> return AndNot))+  <|> (char '!' >> lift skipNonNewlineSpaces >> return Not)+  <|> return Or  csvfieldreferencep :: CsvRulesParser CsvFieldReference csvfieldreferencep = do   lift $ dbgparse 8 "trying csvfieldreferencep"   char '%'   T.cons '%' . textQuoteIfNeeded <$> fieldnamep+    -- XXX this parses any generic field name, which may not actually be a valid CSV field name [#2289]  -- A single regular expression regexp :: CsvRulesParser () -> CsvRulesParser Regexp@@ -736,7 +761,7 @@  maybeNegate :: MatcherPrefix -> Bool -> Bool maybeNegate Not origbool = not origbool-maybeNegate _ origbool = origbool+maybeNegate _   origbool = origbool  -- | Given the conversion rules, a CSV record and a hledger field name, find -- either the last applicable `ConditionalBlock`, or the final value template@@ -766,24 +791,28 @@ isBlockActive :: CsvRules -> CsvRecord -> ConditionalBlock -> Bool isBlockActive rules record CB{..} = any (all matcherMatches) $ groupedMatchers cbMatchers   where-    -- does this individual matcher match the current csv record ?+    -- Does this individual matcher match the current csv record ?+    -- A matcher's target can be a specific CSV field, or the "whole record".+    --+    -- In the former case, note that the field reference must be either numeric or+    -- a csv field name declared by a `fields` rule; anything else will emit a warning to stderr+    -- (to reduce confusion when a hledger field name doesn't work; not an error, to avoid breaking legacy rules; see #2289).+    --+    -- In the latter case, the matched value will be a synthetic CSV record.+    -- Note this will not necessarily be the same as the original CSV record:+    -- the field separator will be comma, and quotes enclosing field values,+    -- and any whitespace outside those quotes, will be removed.+    -- (This means that a field containing a comma will now look like two fields.)+    --     matcherMatches :: Matcher -> Bool-    matcherMatches (RecordMatcher prefix pat) = maybeNegate prefix origbool-      where-        pat' = dbg7 "regex" pat-        -- A synthetic whole CSV record to match against. Note, this can be-        -- different from the original CSV data:-        -- - any whitespace surrounding field values is preserved-        -- - any quotes enclosing field values are removed-        -- - and the field separator is always comma-        -- which means that a field containing a comma will look like two fields.-        wholecsvline = dbg7 "wholecsvline" $ T.intercalate "," record-        origbool = regexMatchText pat' wholecsvline-    matcherMatches (FieldMatcher prefix csvfieldref pat) = maybeNegate prefix origbool-      where-        -- the value of the referenced CSV field to match against.-        csvfieldvalue = dbg7 "csvfieldvalue" $ replaceCsvFieldReference rules record csvfieldref-        origbool = regexMatchText pat csvfieldvalue+    matcherMatches = \case+      RecordMatcher prefix             pat -> maybeNegate prefix $ match pat $ T.intercalate "," record+      FieldMatcher  prefix csvfieldref pat -> maybeNegate prefix $ match pat $+        fromMaybe "" $ replaceCsvFieldReference rules record csvfieldref+        -- (warn msg "") where msg = "if "<>T.unpack csvfieldref<>": this should be a name declared with 'fields', or %NUM"+        --  #2289: we'd like to warn the user when an unknown CSV field is being referenced,+        --  but it's useful to ignore it for easier reuse of rules files.+      where match p v = regexMatchText (dbg7 "regex" p) (dbg7 "value" v)      -- | Group matchers into associative pairs based on prefix, e.g.:     --   A@@ -792,14 +821,13 @@     --   D     --   & E     --   => [[A, B], [C], [D, E]]+    --  & ! M (and not M) are converted to ! M (not M) within the and groups.     groupedMatchers :: [Matcher] -> [[Matcher]]     groupedMatchers [] = []-    groupedMatchers (x:xs) = (x:ys) : groupedMatchers zs+    groupedMatchers (m:ms) = (m:ands) : groupedMatchers rest       where-        (ys, zs) = span (\y -> matcherPrefix y == And) xs-        matcherPrefix :: Matcher -> MatcherPrefix-        matcherPrefix (RecordMatcher prefix _) = prefix-        matcherPrefix (FieldMatcher prefix _ _) = prefix+        (andandnots, rest) = span (\a -> matcherPrefix a `elem` [And, AndNot]) ms+        ands = [matcherSetPrefix p a | a <- andandnots, let p = if matcherPrefix a == AndNot then Not else And]  -- | Render a field assignment's template, possibly interpolating referenced -- CSV field values or match groups. Outer whitespace is removed from interpolated values.@@ -809,7 +837,7 @@     (many       (   literaltextp       <|> (matchrefp <&> replaceRegexGroupReference rules record)-      <|> (fieldrefp <&> replaceCsvFieldReference   rules record)+      <|> (fieldrefp <&> replaceCsvFieldReference   rules record <&> fromMaybe "")       )     )     t@@ -842,20 +870,18 @@   in atMay matchgroups group  getMatchGroups :: CsvRules -> CsvRecord -> Matcher -> [Text]-getMatchGroups _ record (RecordMatcher _ regex)  = let-  txt = T.intercalate "," record -- see caveats of wholecsvline, in `isBlockActive`-  in regexMatchTextGroups regex txt-getMatchGroups rules record (FieldMatcher _ fieldref regex) = let-  txt = replaceCsvFieldReference rules record fieldref-  in regexMatchTextGroups regex txt+getMatchGroups _ record (RecordMatcher _ regex) =+  regexMatchTextGroups regex $ T.intercalate "," record -- see caveats in matcherMatches+getMatchGroups rules record (FieldMatcher _ fieldref regex) =+  regexMatchTextGroups regex $ fromMaybe "" $ replaceCsvFieldReference rules record fieldref  -- | Replace something that looks like a reference to a csv field ("%date" or "%1) -- with that field's value. If it doesn't look like a field reference, or if we--- can't find such a field, replace it with the empty string.-replaceCsvFieldReference :: CsvRules -> CsvRecord -> CsvFieldReference -> Text+-- can't find a csv field with that name, return nothing.+replaceCsvFieldReference :: CsvRules -> CsvRecord -> CsvFieldReference -> Maybe Text replaceCsvFieldReference rules record s = case T.uncons s of-    Just ('%', fieldname) -> fromMaybe "" $ csvFieldValue rules record fieldname-    _                     -> s+    Just ('%', fieldname) -> csvFieldValue rules record fieldname+    _                     -> Nothing  -- | Get the (whitespace-stripped) value of a CSV field, identified by its name or -- column number, ("date" or "1"), from the given CSV record, if such a field exists.@@ -1111,7 +1137,13 @@     code        = maybe "" singleline' $ fieldval "code"     description = maybe "" singleline' $ fieldval "description"     comment     = maybe "" unescapeNewlines $ fieldval "comment"-    ttags       = fromRight [] $ rtp commenttagsp comment++    -- Convert some parsed comment text back into following comment syntax,+    -- with the semicolons and indents, so it can be parsed again for tags.+    textToFollowingComment :: Text -> Text+    textToFollowingComment = T.stripStart . T.unlines . map (" ;"<>) . T.lines++    ttags       = fromRight [] $ fmap snd $ rtp transactioncommentp $ textToFollowingComment comment     precomment  = maybe "" unescapeNewlines $ fieldval "precomment"      singleline' = T.unwords . filter (not . T.null) . map T.strip . T.lines@@ -1124,7 +1156,15 @@     p1IsVirtual = (accountNamePostingType <$> fieldval "account1") == Just VirtualPosting     ps = [p | n <- [1..maxpostings]          ,let cmt  = maybe "" unescapeNewlines $ fieldval ("comment"<> T.pack (show n))-         ,let ptags = fromRight [] $ rtp commenttagsp cmt+          -- Tags in the comment will be parsed and attached to the posting.+          -- A posting date, in the date: tag or in brackets, will also be parsed and applied to the posting.+          -- But it must have a year, or it will be ignored.+          -- A secondary posting date will also be ignored.+         ,let (tags,mdate) =+                fromRight ([],Nothing) $+                fmap (\(_,ts,md,_)->(ts,md)) $+                rtp (postingcommentp Nothing) $+                textToFollowingComment cmt          ,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@@ -1132,12 +1172,13 @@          ,let acct' | not isfinal && acct==unknownExpenseAccount &&                       fromMaybe False (mamount >>= isNegativeMixedAmount) = unknownIncomeAccount                     | otherwise = acct-         ,let p = nullposting{paccount          = accountNameWithoutPostingType acct'+         ,let p = nullposting{pdate             = mdate+                             ,paccount          = accountNameWithoutPostingType acct'                              ,pamount           = fromMaybe missingmixedamt mamount                              ,ptransaction      = Just t                              ,pbalanceassertion = mkBalanceAssertion rules record <$> mbalance                              ,pcomment          = cmt-                             ,ptags             = ptags+                             ,ptags             = tags                              ,ptype             = accountNamePostingType acct                              }          ]@@ -1310,9 +1351,7 @@       ,showRules rules record       -- ,"the default-currency is: "++fromMaybe "unspecified" (getDirective "default-currency" rules)       ,"the parse error is:      " <> T.pack (customErrorBundlePretty e)-      ,"you may need to \-        \change your amount*, balance*, or currency* rules, \-        \or add or change your skip rule"+      ,"you may need to change your amount*, balance*, or currency* rules, or add or change your skip rule"       ]  -- | Show the values assigned to each journal field.@@ -1492,12 +1531,12 @@      ,testCase "assignment with empty value" $       parseWithState' defrules rulesp "account1 \nif foo\n  account2 foo\n" @?=-        (Right (mkrules $ defrules{rassignments = [("account1","")], rconditionalblocks = [CB{cbMatchers=[RecordMatcher None (toRegex' "foo")],cbAssignments=[("account2","foo")]}]}))+        (Right (mkrules $ defrules{rassignments = [("account1","")], rconditionalblocks = [CB{cbMatchers=[RecordMatcher Or (toRegex' "foo")],cbAssignments=[("account2","foo")]}]}))    ]   ,testGroup "conditionalblockp" [     testCase "space after conditional" $       parseWithState' defrules conditionalblockp "if a\n account2 b\n \n" @?=-        (Right $ CB{cbMatchers=[RecordMatcher None $ toRegexCI' "a"],cbAssignments=[("account2","b")]})+        (Right $ CB{cbMatchers=[RecordMatcher Or $ toRegexCI' "a"],cbAssignments=[("account2","b")]})   ],    testGroup "csvfieldreferencep" [@@ -1509,16 +1548,16 @@   ,testGroup "matcherp" [      testCase "recordmatcherp" $-      parseWithState' defrules matcherp "A A\n" @?= (Right $ RecordMatcher None $ toRegexCI' "A A")+      parseWithState' defrules matcherp "A A\n" @?= (Right $ RecordMatcher Or $ toRegexCI' "A A")     ,testCase "recordmatcherp.starts-with-&" $       parseWithState' defrules matcherp "& A A\n" @?= (Right $ RecordMatcher And $ toRegexCI' "A A")     ,testCase "fieldmatcherp.starts-with-%" $-      parseWithState' defrules matcherp "description A A\n" @?= (Right $ RecordMatcher None $ toRegexCI' "description A A")+      parseWithState' defrules matcherp "description A A\n" @?= (Right $ RecordMatcher Or $ toRegexCI' "description A A")     ,testCase "fieldmatcherp" $-      parseWithState' defrules matcherp "%description A A\n" @?= (Right $ FieldMatcher None "%description" $ toRegexCI' "A A")+      parseWithState' defrules matcherp "%description A A\n" @?= (Right $ FieldMatcher Or "%description" $ toRegexCI' "A A")     ,testCase "fieldmatcherp.starts-with-&" $       parseWithState' defrules matcherp "& %description A A\n" @?= (Right $ FieldMatcher And "%description" $ toRegexCI' "A A")@@ -1533,7 +1572,7 @@      in testCase "toplevel" $ hledgerField rules ["a","b"] "date" @?= (Just "%csvdate") -   ,let rules = mkrules $ defrules{rcsvfieldindexes=[("csvdate",1)], rconditionalblocks=[CB [FieldMatcher None "%csvdate" $ toRegex' "a"] [("date","%csvdate")]]}+   ,let rules = mkrules $ defrules{rcsvfieldindexes=[("csvdate",1)], rconditionalblocks=[CB [FieldMatcher Or "%csvdate" $ toRegex' "a"] [("date","%csvdate")]]}     in testCase "conditional" $ hledgerField rules ["a","b"] "date" @?= (Just "%csvdate")     ,let rules = mkrules $ defrules{rcsvfieldindexes=[("csvdate",1)], rconditionalblocks=[CB [FieldMatcher Not "%csvdate" $ toRegex' "a"] [("date","%csvdate")]]}@@ -1542,16 +1581,16 @@    ,let rules = mkrules $ defrules{rcsvfieldindexes=[("csvdate",1)], rconditionalblocks=[CB [FieldMatcher Not "%csvdate" $ toRegex' "b"] [("date","%csvdate")]]}     in testCase "negated-conditional-true" $ hledgerField rules ["a","b"] "date" @?= (Just "%csvdate") -   ,let rules = mkrules $ defrules{rcsvfieldindexes=[("csvdate",1),("description",2)], rconditionalblocks=[CB [FieldMatcher None "%csvdate" $ toRegex' "a", FieldMatcher None "%description" $ toRegex' "b"] [("date","%csvdate")]]}+   ,let rules = mkrules $ defrules{rcsvfieldindexes=[("csvdate",1),("description",2)], rconditionalblocks=[CB [FieldMatcher Or "%csvdate" $ toRegex' "a", FieldMatcher Or "%description" $ toRegex' "b"] [("date","%csvdate")]]}     in testCase "conditional-with-or-a" $ hledgerField rules ["a"] "date" @?= (Just "%csvdate") -   ,let rules = mkrules $ defrules{rcsvfieldindexes=[("csvdate",1),("description",2)], rconditionalblocks=[CB [FieldMatcher None "%csvdate" $ toRegex' "a", FieldMatcher None "%description" $ toRegex' "b"] [("date","%csvdate")]]}+   ,let rules = mkrules $ defrules{rcsvfieldindexes=[("csvdate",1),("description",2)], rconditionalblocks=[CB [FieldMatcher Or "%csvdate" $ toRegex' "a", FieldMatcher Or "%description" $ toRegex' "b"] [("date","%csvdate")]]}     in testCase "conditional-with-or-b" $ hledgerField rules ["_", "b"] "date" @?= (Just "%csvdate") -   ,let rules = mkrules $ defrules{rcsvfieldindexes=[("csvdate",1),("description",2)], rconditionalblocks=[CB [FieldMatcher None "%csvdate" $ toRegex' "a", FieldMatcher And "%description" $ toRegex' "b"] [("date","%csvdate")]]}+   ,let rules = mkrules $ defrules{rcsvfieldindexes=[("csvdate",1),("description",2)], rconditionalblocks=[CB [FieldMatcher Or "%csvdate" $ toRegex' "a", FieldMatcher And "%description" $ toRegex' "b"] [("date","%csvdate")]]}     in testCase "conditional.with-and" $ hledgerField rules ["a", "b"] "date" @?= (Just "%csvdate") -   ,let rules = mkrules $ defrules{rcsvfieldindexes=[("csvdate",1),("description",2)], rconditionalblocks=[CB [FieldMatcher None "%csvdate" $ toRegex' "a", FieldMatcher And "%description" $ toRegex' "b", FieldMatcher None "%description" $ toRegex' "c"] [("date","%csvdate")]]}+   ,let rules = mkrules $ defrules{rcsvfieldindexes=[("csvdate",1),("description",2)], rconditionalblocks=[CB [FieldMatcher Or "%csvdate" $ toRegex' "a", FieldMatcher And "%description" $ toRegex' "b", FieldMatcher Or "%description" $ toRegex' "c"] [("date","%csvdate")]]}     in testCase "conditional.with-and-or" $ hledgerField rules ["_", "c"] "date" @?= (Just "%csvdate")     ]@@ -1562,9 +1601,9 @@           { rcsvfieldindexes=[ ("date",1), ("description",2) ]           , rassignments=[ ("account2","equity"), ("amount1","1") ]           -- ConditionalBlocks here are in reverse order: mkrules reverses the list-          , rconditionalblocks=[ CB { cbMatchers=[FieldMatcher None "%description" (toRegex' "PREFIX (.*) - (.*)")] +          , rconditionalblocks=[ CB { cbMatchers=[FieldMatcher Or "%description" (toRegex' "PREFIX (.*) - (.*)")]                                     , cbAssignments=[("account1","account:\\1:\\2")] }-                               , CB { cbMatchers=[FieldMatcher None "%description" (toRegex' "PREFIX (.*)")]+                               , CB { cbMatchers=[FieldMatcher Or "%description" (toRegex' "PREFIX (.*)")]                                     , cbAssignments=[("account1","account:\\1"), ("comment1","\\1")] }                                ]           }

@@ -162,6 +162,7 @@       . traceAtWith 5 (("ts4:\n"++).pshowTransactions.map snd)       . sortBy (comparing (Down . fst) <> comparing (Down . tindex . snd))       . map (\t -> (transactionRegisterDate wd reportq thisacctq t, t))+      . map (if invert_ ropts then (\t -> t{tpostings = map negatePostingAmount $ tpostings t}) else id)       $ jtxns acctJournal  pshowTransactions :: [Transaction] -> String

@@ -71,7 +71,7 @@     report = multiBalanceReport rspec j     rows = [( prrFullName row             , prrDisplayName row-            , prrDepth row - 1  -- BalanceReport uses 0-based account depths+            , prrIndent row             , prrTotal row             ) | row <- prRows report]     total = prrTotal $ prTotals report@@ -85,7 +85,7 @@       jtxns = [         txnTieKnot Transaction{           tindex=0,-          tsourcepos=nullsourcepos,+          tsourcepos=nullsourcepospair,           tdate=fromGregorian 2008 01 01,           tdate2=Just $ fromGregorian 2009 01 01,           tstatus=Unmarked,@@ -149,7 +149,7 @@        mixedAmount (usd 0))      ,testCase "with --depth=N" $-     (defreportspec{_rsReportOpts=defreportopts{depth_=Just 1}}, samplejournal) `gives`+     (defreportspec{_rsReportOpts=defreportopts{depth_=DepthSpec (Just 1) []}}, samplejournal) `gives`       ([        ("expenses",    "expenses",     0, mixedAmount (usd 2))        ,("income",      "income",      0, mixedAmount (usd (-2)))@@ -222,7 +222,7 @@        ]        ,testCase "accounts report with account pattern o and --depth 1" ~:-       defreportopts{patterns_=["o"],depth_=Just 1} `gives`+       defreportopts{patterns_=["o"],depth_=(Just 1, [])} `gives`        ["                  $1  expenses"        ,"                 $-2  income"        ,"--------------------"

@@ -21,7 +21,7 @@ import Data.Time (fromGregorian)  import Hledger.Data-import Hledger.Query (Query(..))+import Hledger.Query (Query(..), filterQuery, queryIsDepth) import Hledger.Reports.ReportOptions import Hledger.Utils @@ -37,7 +37,7 @@ entriesReport rspec@ReportSpec{_rsReportOpts=ropts} =     sortBy (comparing $ transactionDateFn ropts) . jtxns     . journalApplyValuationFromOpts (setDefaultConversionOp NoConversionOp rspec)-    . filterJournalTransactions (_rsQuery rspec)+    . filterJournalTransactions (filterQuery (not.queryIsDepth) $ _rsQuery rspec)  tests_EntriesReport = testGroup "EntriesReport" [   testGroup "entriesReport" [

@@ -112,6 +112,8 @@     -- Queries, report/column dates.     (reportspan, colspans) = reportSpan j rspec'     rspec = dbg3 "reportopts" $ makeReportQuery rspec' reportspan+    -- force evaluation order to show price lookup after date spans in debug output (XXX not working)+    -- priceoracle = reportspan `seq` priceoracle0      -- Group postings into their columns.     colps = dbg5 "colps" $ getPostingsByColumn rspec j priceoracle colspans@@ -287,10 +289,12 @@               filterQueryOrNotQuery (\q -> queryIsAcct q || queryIsType q || queryIsTag q) query      filterbydepth = case accountlistmode_ of-      ALTree -> filter ((depthq `matchesAccount`) . aname)    -- a tree - just exclude deeper accounts-      ALFlat -> clipAccountsAndAggregate (queryDepth depthq)  -- a list - aggregate deeper accounts at the depth limit-                . filter ((0<) . anumpostings)                -- and exclude empty parent accounts-      where depthq = dbg3 "depthq" $ filterQuery queryIsDepth query+        ALTree -> filter (depthMatches . aname)       -- a tree - just exclude deeper accounts+        ALFlat -> clipAccountsAndAggregate depthSpec  -- a list - aggregate deeper accounts at the depth limit+                  . filter ((0<) . anumpostings)      -- and exclude empty parent accounts+      where+        depthSpec = dbg3 "depthq" . queryDepth $ filterQuery queryIsDepth query+        depthMatches name = maybe True (accountNameLevel name <=) $ getAccountNameClippedDepth depthSpec name      accts = filterbydepth $ drop 1 $ accountsFromPostings ps' @@ -400,43 +404,43 @@         rowavg = averageMixedAmounts rowbals     balance = case accountlistmode_ ropts of ALTree -> aibalance; ALFlat -> aebalance --- | Calculate accounts which are to be displayed in the report, as well as--- their name and depth+-- | Calculate accounts which are to be displayed in the report,+-- and their name and their indent level if displayed in tree mode. displayedAccounts :: ReportSpec                   -> Set AccountName                   -> HashMap AccountName (Map DateSpan Account)                   -> HashMap AccountName DisplayName displayedAccounts ReportSpec{_rsQuery=query,_rsReportOpts=ropts} unelidableaccts valuedaccts-    | qdepth == 0 = HM.singleton "..." $ DisplayName "..." "..." 1-    | otherwise  = HM.mapWithKey (\a _ -> displayedName a) displayedAccts+    | qdepthIsZero = HM.singleton "..." $ DisplayName "..." "..." 0+    | otherwise    = HM.mapWithKey (\a _ -> displayedName a) displayedAccts   where-    -- Accounts which are to be displayed-    displayedAccts = (if qdepth == 0 then id else HM.filterWithKey keep) valuedaccts-      where-        keep name amts = isInteresting name amts || name `HM.member` interestingParents-     displayedName name = case accountlistmode_ ropts of-        ALTree -> DisplayName name leaf . max 0 $ level - boringParents-        ALFlat -> DisplayName name droppedName 1+        ALTree -> DisplayName name leaf (max 0 $ level - 1 - boringParents)+        ALFlat -> DisplayName name droppedName 0       where-        droppedName = accountNameDrop (drop_ ropts) name-        leaf = accountNameFromComponents . reverse . map accountLeafName $-            droppedName : takeWhile notDisplayed parents--        level = max 0 $ accountNameLevel name - drop_ ropts-        parents = take (level - 1) $ parentAccountNames name+        droppedName   = accountNameDrop (drop_ ropts) name+        leaf          = accountNameFromComponents . reverse . map accountLeafName $+                          droppedName : takeWhile notDisplayed parents+        level         = max 0 $ (accountNameLevel name) - drop_ ropts+        parents       = take (level - 1) $ parentAccountNames name         boringParents = if no_elide_ ropts then 0 else length $ filter notDisplayed parents-        notDisplayed = not . (`HM.member` displayedAccts)+        notDisplayed  = not . (`HM.member` displayedAccts) +    -- Accounts which are to be displayed+    displayedAccts = (if qdepthIsZero then id else HM.filterWithKey keep) valuedaccts+      where+        keep name amts = isInteresting name amts || name `HM.member` interestingParents+     -- Accounts interesting for their own sake     isInteresting name amts =-        d <= qdepth                                  -- 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            )       where         d = accountNameLevel name+        qdepth = fromMaybe maxBound $ getAccountNameClippedDepth depthspec name         keepWhenEmpty = case accountlistmode_ ropts of             ALFlat -> const True          -- Keep all empty accounts in flat mode             ALTree -> all (null . asubs)  -- Keep only empty leaves in tree mode@@ -454,7 +458,8 @@         minSubs = if no_elide_ ropts then 1 else 2      isZeroRow balance = all (mixedAmountLooksZero . balance)-    qdepth = fromMaybe maxBound $ queryDepth query+    depthspec = queryDepth query+    qdepthIsZero = depthspec == DepthSpec (Just 0) []     numSubs = subaccountTallies . HM.keys $ HM.filterWithKey isInteresting valuedaccts  -- | Sort the rows by amount or by account declaration order.@@ -601,7 +606,7 @@           (eitems, etotal) = r           (PeriodicReport _ aitems atotal) = multiBalanceReport rspec' journal           showw (PeriodicReportRow a lAmt amt amt')-              = (displayFull a, displayName a, displayDepth a, map showMixedAmountDebug lAmt, showMixedAmountDebug amt, showMixedAmountDebug amt')+              = (displayFull a, displayName a, displayIndent a, map showMixedAmountDebug lAmt, showMixedAmountDebug amt, showMixedAmountDebug amt')       (map showw aitems) @?= (map showw eitems)       showMixedAmountDebug (prrTotal atotal) @?= showMixedAmountDebug etotal -- we only check the sum of the totals   in

@@ -71,7 +71,7 @@     where       (reportspan, colspans) = reportSpanBothDates j rspec       whichdate   = whichDate ropts-      mdepth      = queryDepth $ _rsQuery rspec+      depthSpec   = queryDepth $ _rsQuery rspec       multiperiod = interval_ /= NoInterval        -- postings to be included in the report, and similarly-matched postings before the report start date@@ -82,7 +82,7 @@         | multiperiod = [(p', Just period') | (p', period') <- summariseps reportps]         | otherwise   = [(p', Nothing) | p' <- reportps]         where-          summariseps = summarisePostingsByInterval whichdate mdepth showempty colspans+          summariseps = summarisePostingsByInterval whichdate (dsFlatDepth depthSpec) showempty colspans           showempty = empty_ || average_        sortedps = if sortspec_ /= defsortspec then sortPostings ropts sortspec_ displayps else displayps@@ -90,7 +90,7 @@       -- Posting report items ready for display.       items =         dbg4 "postingsReport items" $-        postingsReportItems postings (nullposting,Nothing) whichdate mdepth startbal runningcalc startnum+        postingsReportItems postings (nullposting,Nothing) whichdate depthSpec startbal runningcalc startnum         where           -- In historical mode we'll need a starting balance, which we           -- may be converting to value per hledger_options.m4.md "Effect@@ -180,7 +180,7 @@  -- | Generate postings report line items from a list of postings or (with -- non-Nothing periods attached) summary postings.-postingsReportItems :: [(Posting,Maybe Period)] -> (Posting,Maybe Period) -> WhichDate -> Maybe Int -> MixedAmount -> (Int -> MixedAmount -> MixedAmount -> MixedAmount) -> Int -> [PostingsReportItem]+postingsReportItems :: [(Posting,Maybe Period)] -> (Posting,Maybe Period) -> WhichDate -> DepthSpec -> MixedAmount -> (Int -> MixedAmount -> MixedAmount -> MixedAmount) -> Int -> [PostingsReportItem] postingsReportItems [] _ _ _ _ _ _ = [] postingsReportItems ((p,mperiod):ps) (pprev,mperiodprev) wd d b runningcalcfn itemnum =     i:(postingsReportItems ps (p,mperiod) wd d b' runningcalcfn (itemnum+1))@@ -237,7 +237,7 @@     postingdate = if wd == PrimaryDate then postingDate else postingDate2     b' = maybe (maybe nulldate postingdate $ headMay ps) fromEFDay b     summaryp = nullposting{pdate=Just b'}-    clippedanames = nub $ map (clipAccountName mdepth) anames+    clippedanames = nub $ map (clipAccountName (DepthSpec mdepth [])) anames     summaryps | mdepth == Just 0 = [summaryp{paccount="...",pamount=sumPostings ps}]               | otherwise        = [summaryp{paccount=a,pamount=balance a} | a <- clippedanames]     summarypes = map (, dateSpanAsPeriod spn) $ (if showempty then id else filter (not . mixedAmountLooksZero . pamount)) summaryps@@ -248,9 +248,6 @@       where         bal = if isclipped a then aibalance else aebalance         isclipped a' = maybe False (accountNameLevel a' >=) mdepth--negatePostingAmount :: Posting -> Posting-negatePostingAmount = postingTransformAmount negate   -- tests

@@ -75,6 +75,7 @@ import Data.Either (fromRight) import Data.Either.Extra (eitherToMaybe) import Data.Functor.Identity (Identity(..))+import Data.List (partition) import Data.List.Extra (find, isPrefixOf, nubSort, stripPrefix) import Data.Maybe (fromMaybe, isJust, isNothing) import qualified Data.Text as T@@ -134,12 +135,13 @@     ,conversionop_     :: Maybe ConversionOp  -- ^ Which operation should we apply to conversion transactions?     ,value_            :: Maybe ValuationType  -- ^ What value should amounts be converted to ?     ,infer_prices_     :: Bool      -- ^ Infer market prices from transactions ?-    ,depth_            :: Maybe Int+    ,depth_            :: DepthSpec     ,date2_            :: Bool     ,empty_            :: Bool     ,no_elide_         :: Bool     ,real_             :: Bool     ,format_           :: StringFormat+    ,balance_base_url_ :: Maybe T.Text     ,pretty_           :: Bool     ,querystring_      :: [T.Text]     --@@ -193,12 +195,13 @@     , conversionop_     = Nothing     , value_            = Nothing     , infer_prices_     = False-    , depth_            = Nothing+    , depth_            = DepthSpec Nothing []     , date2_            = False     , empty_            = False     , no_elide_         = False     , real_             = False     , format_           = def+    , balance_base_url_ = Nothing     , pretty_           = False     , querystring_      = []     , average_          = False@@ -224,14 +227,14 @@     , layout_           = LayoutWide Nothing     } --- | Generate a ReportOpts from raw command-line input, given a day.+-- | Generate a ReportOpts from raw command-line input, given a day and whether to use ANSI colour/styles in standard output. -- This will fail with a usage error if it is passed -- - an invalid --format argument, -- - an invalid --value argument, -- - if --valuechange is called with a valuation type other than -V/--value=end. -- - an invalid --pretty argument,-rawOptsToReportOpts :: Day -> RawOpts -> ReportOpts-rawOptsToReportOpts d rawopts =+rawOptsToReportOpts :: Day -> Bool -> RawOpts -> ReportOpts+rawOptsToReportOpts d usecoloronstdout rawopts =      let formatstring = T.pack <$> maybestringopt "format" rawopts         querystring  = map T.pack $ listofstringopt "args" rawopts  -- doesn't handle an arg like "" right@@ -249,12 +252,13 @@           ,conversionop_     = conversionOpFromRawOpts rawopts           ,value_            = valuationTypeFromRawOpts rawopts           ,infer_prices_     = boolopt "infer-market-prices" rawopts-          ,depth_            = maybeposintopt "depth" rawopts+          ,depth_            = depthFromRawOpts rawopts           ,date2_            = boolopt "date2" rawopts           ,empty_            = boolopt "empty" rawopts           ,no_elide_         = boolopt "no-elide" rawopts           ,real_             = boolopt "real" rawopts           ,format_           = format+          ,balance_base_url_ = T.pack <$> maybestringopt "base-url" rawopts           ,querystring_      = querystring           ,average_          = boolopt "average" rawopts           ,related_          = boolopt "related" rawopts@@ -274,7 +278,7 @@           ,percent_          = boolopt "percent" rawopts           ,invert_           = boolopt "invert" rawopts           ,pretty_           = pretty-          ,color_            = useColorOnStdout -- a lower-level helper+          ,color_            = usecoloronstdout           ,transpose_        = boolopt "transpose" rawopts           ,layout_           = layoutopt rawopts           }@@ -343,7 +347,7 @@     Just "never"  -> Just False     Just "no"     -> Just False     Just "n"      -> Just False-    Just _        -> usageError "--pretty's argument should be \"yes\" or \"no\" (or y, n, always, never)"+    Just _        -> usageError "this argument should be one of y, yes, n, no"     _             -> Nothing  balanceAccumulationOverride :: RawOpts -> Maybe BalanceAccumulation@@ -538,6 +542,21 @@       | n == "value", takeWhile (/=',') v `elem` ["cost", "c"] = Just ToCost  -- keep supporting --value=cost for now       | otherwise                                   = Nothing +-- | Parse the depth arguments. This can be either a flat depth that applies to+-- all accounts, or a regular expression and depth, which only matches certain+-- accounts. If an account name is matched by a regular expression, then the+-- smallest depth is used. Otherwise, if no regular expressions match, then the+-- flat depth is used. If more than one flat depth is supplied, use only the+-- last one.+depthFromRawOpts :: RawOpts -> DepthSpec+depthFromRawOpts rawopts = lastDef mempty flats <> mconcat regexps+  where+    (flats, regexps) = partition (\(DepthSpec f rs) -> isJust f && null rs) depthSpecs+    depthSpecs = case mapM (parseDepthSpec . T.pack) depths of+      Right d -> d+      Left err -> usageError $ "Unable to parse depth specification: " ++ err+    depths = listofstringopt "depth" rawopts+ -- | Select the Transaction date accessor based on --date2. transactionDateFn :: ReportOpts -> (Transaction -> Day) transactionDateFn ReportOpts{..} = if date2_ then transactionDate2 else tdate@@ -664,11 +683,13 @@ queryFromFlags ReportOpts{..} = simplifyQuery $ And flagsq   where     flagsq = consIf   Real  real_-           . consJust Depth depth_-           $   [ (if date2_ then Date2 else Date) $ periodAsDateSpan period_+           . consJust Depth flatDepth+           $ map (uncurry DepthAcct) regexpDepths+           ++  [ (if date2_ then Date2 else Date) $ periodAsDateSpan period_                , Or $ map StatusQ statuses_                ]     consIf f b = if b then (f True:) else id+    DepthSpec flatDepth regexpDepths = depth_     consJust f = maybe id ((:) . f)  -- Methods/types needed for --sort argument@@ -888,7 +909,7 @@     statuses = reportOpts.statusesNoUpdate     {-# INLINE statuses #-} -    depth :: ReportableLens' a (Maybe Int)+    depth :: ReportableLens' a DepthSpec     depth = reportOpts.depthNoUpdate     {-# INLINE depth #-} @@ -938,5 +959,5 @@  -- | Generate a ReportSpec from RawOpts and a provided day, or return an error -- string if there are regular expression errors.-rawOptsToReportSpec :: Day -> RawOpts -> Either String ReportSpec-rawOptsToReportSpec day = reportOptsToSpec day . rawOptsToReportOpts day+rawOptsToReportSpec :: Day -> Bool -> RawOpts -> Either String ReportSpec+rawOptsToReportSpec day coloronstdout = reportOptsToSpec day . rawOptsToReportOpts day coloronstdout

@@ -31,7 +31,7 @@ , prrShowDebug , prrFullName , prrDisplayName-, prrDepth+, prrIndent , prrAdd ) where @@ -211,36 +211,39 @@   }  --- | A full name, display name, and depth for an account.+-- | The number of indentation steps with which to display a report item.+-- 0 means no indentation. 1 means one indent step, which is normally rendered+-- as two spaces in text output, or two no-break spaces in csv/html output.+type NumberOfIndents = Int++-- | A full name, display name, and indent level for an account. data DisplayName = DisplayName-    { displayFull :: AccountName-    , displayName :: AccountName-    , displayDepth :: Int+    { displayFull   :: AccountName+    , displayName   :: AccountName+    , displayIndent :: NumberOfIndents     } deriving (Show, Eq, Ord)  instance ToJSON DisplayName where     toJSON = toJSON . displayFull     toEncoding = toEncoding . displayFull --- | Construct a flat display name, where the full name is also displayed at--- depth 1+-- | Construct a display name for a list report, where full names are shown unindented. flatDisplayName :: AccountName -> DisplayName-flatDisplayName a = DisplayName a a 1+flatDisplayName a = DisplayName a a 0 --- | Construct a tree display name, where only the leaf is displayed at its--- given depth+-- | Construct a display name for a tree report, where leaf names (possibly prefixed by+-- boring parents) are shown indented). treeDisplayName :: AccountName -> DisplayName treeDisplayName a = DisplayName a (accountLeafName a) (accountNameLevel a) --- | Get the full, canonical, name of a PeriodicReportRow tagged by a--- DisplayName.+-- | Get the full canonical account name from a PeriodicReportRow containing a DisplayName. prrFullName :: PeriodicReportRow DisplayName a -> AccountName prrFullName = displayFull . prrName --- | Get the display name of a PeriodicReportRow tagged by a DisplayName.+-- | Get the account display name from a PeriodicReportRow containing a DisplayName. prrDisplayName :: PeriodicReportRow DisplayName a -> AccountName prrDisplayName = displayName . prrName --- | Get the display depth of a PeriodicReportRow tagged by a DisplayName.-prrDepth :: PeriodicReportRow DisplayName a -> Int-prrDepth = displayDepth . prrName+-- | Get the indent level from a PeriodicReportRow containing a DisplayName.+prrIndent :: PeriodicReportRow DisplayName a -> Int+prrIndent = displayIndent . prrName

@@ -3,6 +3,8 @@ These are the bottom of hledger's module graph. -} +{-# LANGUAGE CPP #-}+ module Hledger.Utils (    -- * Functions@@ -69,7 +71,10 @@  import Data.Char (toLower) import Data.List (intersperse)-import Data.List.Extra (chunksOf, foldl', foldl1', uncons, unsnoc)+import Data.List.Extra (chunksOf, foldl1', uncons, unsnoc)+#if !MIN_VERSION_base(4,20,0)+import Data.List (foldl')+#endif import qualified Data.Set as Set import qualified Data.Text as T (pack, unpack) import Data.Tree (foldTree, Tree (Node, subForest))

@@ -224,11 +224,12 @@                    _                                   -> 0  -- | Whether ghc-debug support is included in this build, and if so, how it will behave.--- When hledger is built with the ghcdebug cabal build flag (normally disabled),+-- When hledger is built with the @ghcdebug@ cabal flag (off by default, because of extra deps), -- it can listen (on unix ?) for connections from ghc-debug clients like ghc-debug-brick, -- for pausing/resuming the program and inspecting memory usage and profile information. ----- This is enabled by running hledger with a negative --debug level, with three different modes:+-- With a ghc-debug-supporting build, ghc-debug can be enabled by running hledger with+-- a negative --debug level. There are three different modes: -- --debug=-1 - run normally (can be paused/resumed by a ghc-debug client), -- --debug=-2 - pause and await client commands at program start (not useful currently), -- --debug=-3 - pause and await client commands at program end.@@ -254,6 +255,7 @@ -- See GhcDebugMode. ghcDebugMode :: GhcDebugMode ghcDebugMode =+#ifdef GHCDEBUG   case debugLevel of     _ | not ghcDebugSupportedInLib -> GDNotSupported     (-1) -> GDNoPause@@ -261,6 +263,9 @@     (-3) -> GDPauseAtEnd     _    -> GDDisabled     -- keep synced with GhcDebugMode+#else+  GDNotSupported+#endif  -- | When ghc-debug support has been built into the program and enabled at runtime with --debug=-N, -- this calls ghc-debug's withGhcDebug; otherwise it's a no-op.

@@ -1,15 +1,12 @@ {- | -Helpers for pretty-printing haskell values, reading command line arguments,-working with ANSI colours, files, and time.-Uses unsafePerformIO.--Limitations:-When running in GHCI, this module must be reloaded to see environmental changes.-The colour scheme may be somewhat hard-coded.-+General and hledger-specific input/output-related helpers for+pretty-printing haskell values, error reporting, time, files, command line parsing,+terminals, pager output, ANSI colour/styles, etc. -} -{-# LANGUAGE CPP, LambdaCase, PackageImports #-}+{-# LANGUAGE LambdaCase          #-}+{-# LANGUAGE PackageImports      #-}+{-# LANGUAGE ScopedTypeVariables #-}  module Hledger.Utils.IO ( @@ -19,32 +16,54 @@   pprint,   pprint', -  -- * Viewing with pager-  pager,-  setupPager,+  -- * Errors+  error',+  usageError,+  warn, +  -- * Time+  getCurrentLocalTime,+  getCurrentZonedTime,++  -- * Files+  embedFileRelative,+  expandHomePath,+  expandPath,+  expandGlob,+  sortByModTime,+  readFileOrStdinPortably,+  readFileStrictly,+  readFilePortably,+  readHandlePortably,+  -- hereFileRelative,++  -- * Command line parsing+  progArgs,+  getOpt,+  parseYN,+  parseYNA,+  YNA(..),+  -- hasOutputFile,+  -- outputFileOption,+   -- * Terminal size   getTerminalHeightWidth,   getTerminalHeight,   getTerminalWidth, -  -- * Command line arguments-  progArgs,-  outputFileOption,-  hasOutputFile,+  -- * Pager output+  setupPager,+  runPager, -  -- * ANSI color+  -- * ANSI colour/styles++  -- ** hledger-specific+   colorOption,   useColorOnStdout,   useColorOnStderr,-  -- XXX needed for using color/bgColor/colorB/bgColorB, but clashing with UIUtils:-  -- Color(..),-  -- ColorIntensity(..),-  color,-  bgColor,-  colorB,-  bgColorB,-  --+  useColorOnStdoutUnsafe,+  useColorOnStderrUnsafe,   bold',   faint',   black',@@ -64,81 +83,74 @@   brightCyan',   brightWhite',   rgb',++  -- ** Generic++  color,+  bgColor,+  colorB,+  bgColorB,+  -- XXX Types used with color/bgColor/colorB/bgColorB,+  -- not re-exported because clashing with UIUtils:+  -- Color(..),+  -- ColorIntensity(..),+   terminalIsLight,   terminalLightness,   terminalFgColor,   terminalBgColor, -  -- * Errors-  error',-  usageError,--  -- * Files-  embedFileRelative,-  expandHomePath,-  expandPath,-  expandGlob,-  sortByModTime,-  readFileOrStdinPortably,-  readFileStrictly,-  readFilePortably,-  readHandlePortably,-  -- hereFileRelative,--  -- * Time-  getCurrentLocalTime,-  getCurrentZonedTime,-   ) where -import qualified Control.Exception as C (evaluate)-import           Control.Monad (when, forM)+import           Control.Concurrent (forkIO)+import           Control.Exception (catch, evaluate, throwIO)+import           Control.Monad (when, forM, guard, void)+import           Data.Char (toLower) import           Data.Colour.RGBSpace (RGB(RGB)) import           Data.Colour.RGBSpace.HSL (lightness)+import           Data.Colour.SRGB (sRGB) import           Data.FileEmbed (makeRelativeToProject, embedStringFile) import           Data.Functor ((<&>)) import           Data.List hiding (uncons)-import           Data.Maybe (isJust)+import           Data.Maybe (isJust, catMaybes) import           Data.Ord (comparing, Down (Down)) import qualified Data.Text as T import qualified Data.Text.IO as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Builder as TB import           Data.Time.Clock (getCurrentTime)-import           Data.Time.LocalTime-  (LocalTime, ZonedTime, getCurrentTimeZone, utcToLocalTime, utcToZonedTime)-import           Data.Word (Word8, Word16)+import           Data.Time.LocalTime (LocalTime, ZonedTime, getCurrentTimeZone, utcToLocalTime, utcToZonedTime)+import           Data.Word (Word16)+import           Debug.Trace (trace)+import           Foreign.C.Error (Errno(..), ePIPE)+import           GHC.IO.Exception (IOException(..), IOErrorType (ResourceVanished)) import           Language.Haskell.TH.Syntax (Q, Exp)-import           String.ANSI-import           System.Console.ANSI (Color(..),ColorIntensity(..),-  ConsoleLayer(..), SGR(..), hSupportsANSIColor, setSGRCode, getLayerColor)+import           Safe (headMay, maximumDef)+import           System.Console.ANSI (Color(..),ColorIntensity(..), ConsoleLayer(..), SGR(..), hSupportsANSIColor, setSGRCode, getLayerColor, ConsoleIntensity (..)) import           System.Console.Terminal.Size (Window (Window), size)-import           System.Directory (getHomeDirectory, getModificationTime)+import           System.Directory (getHomeDirectory, getModificationTime, findExecutable) import           System.Environment (getArgs, lookupEnv, setEnv) import           System.FilePath (isRelative, (</>)) import "Glob"    System.FilePath.Glob (glob)-import           System.IO-  (Handle, IOMode (..), hGetEncoding, hSetEncoding, hSetNewlineMode,-   openFile, stdin, stdout, stderr, universalNewlineMode, utf8_bom, hIsTerminalDevice)+import           System.Info (os)+import           System.IO (Handle, IOMode (..), hGetEncoding, hSetEncoding, hSetNewlineMode, openFile, stdin, stdout, stderr, universalNewlineMode, utf8_bom, hIsTerminalDevice, hPutStr, hClose) import           System.IO.Unsafe (unsafePerformIO)-#ifndef mingw32_HOST_OS-import           System.Pager (printOrPage)-#endif-import           Text.Pretty.Simple-  (CheckColorTty(..), OutputOptions(..),-  defaultOutputOptionsDarkBg, defaultOutputOptionsNoColor, pShowOpt, pPrintOpt)+import           System.Process (CreateProcess(..), StdStream(CreatePipe), shell, waitForProcess, withCreateProcess)+import           Text.Pretty.Simple (CheckColorTty(..), OutputOptions(..), defaultOutputOptionsDarkBg, defaultOutputOptionsNoColor, pShowOpt, pPrintOpt)  import Hledger.Utils.Text (WideBuilder(WideBuilder))  --- Pretty showing/printing with pretty-simple +-- Pretty showing/printing+-- using pretty-simple+ -- https://hackage.haskell.org/package/pretty-simple/docs/Text-Pretty-Simple.html#t:OutputOptions  -- | pretty-simple options with colour enabled if allowed. prettyopts =-  (if useColorOnStderr then defaultOutputOptionsDarkBg else defaultOutputOptionsNoColor)+  (if useColorOnStderrUnsafe then defaultOutputOptionsDarkBg else defaultOutputOptionsNoColor)     { outputOptionsIndentAmount = 2     -- , outputOptionsCompact      = True  -- fills lines, but does not respect page width (https://github.com/cdepillabout/pretty-simple/issues/126)     -- , outputOptionsPageWidth    = fromMaybe 80 $ unsafePerformIO getTerminalWidth@@ -151,7 +163,7 @@     }  -- | Pretty show. An easier alias for pretty-simple's pShow.--- This will probably show in colour if useColorOnStderr is true.+-- This will probably show in colour if useColorOnStderrUnsafe is true. pshow :: Show a => a -> String pshow = TL.unpack . pShowOpt prettyopts @@ -160,9 +172,9 @@ pshow' = TL.unpack . pShowOpt prettyoptsNoColor  -- | Pretty print a showable value. An easier alias for pretty-simple's pPrint.--- This will print in colour if useColorOnStderr is true.+-- This will print in colour if useColorOnStderrUnsafe is true. pprint :: Show a => a -> IO ()-pprint = pPrintOpt (if useColorOnStderr then CheckColorTty else NoCheckColorTty) prettyopts+pprint = pPrintOpt (if useColorOnStderrUnsafe then CheckColorTty else NoCheckColorTty) prettyopts  -- | Monochrome version of pprint. This will never print in colour. pprint' :: Show a => a -> IO ()@@ -170,23 +182,191 @@  -- "Avoid using pshow, pprint, dbg* in the code below to prevent infinite loops." (?) --- | Display the given text on the terminal, using the user's $PAGER if the text is taller --- than the current terminal and stdout is interactive and TERM is not "dumb"--- (except on Windows, where a pager will not be used).--- If the text contains ANSI codes, because hledger thinks the current terminal--- supports those, the pager should be configured to display those, otherwise--- users will see junk on screen (#2015).--- We call "setLessR" at hledger startup to make that less likely.-pager :: String -> IO ()-#ifdef mingw32_HOST_OS-pager = putStrLn-#else-printOrPage' s = do  -- an extra check for Emacs users:-  dumbterm <- (== Just "dumb") <$> lookupEnv "TERM"-  if dumbterm then putStrLn s else printOrPage (T.pack s)-pager = printOrPage'-#endif ++-- Errors++-- | Simpler alias for errorWithoutStackTrace+error' :: String -> a+error' = errorWithoutStackTrace . ("Error: " <>)++-- | A version of errorWithoutStackTrace that adds a usage hint.+usageError :: String -> a+usageError = error' . (++ " (use -h to see usage)")++-- | Show a warning message on stderr before returning the given value.+-- Use this when you want to show the user a message on stderr, without stopping the program.+-- Currently we do this very sparingly in hledger; we prefer to either quietly work,+-- or loudly raise an error. Variable output can make scripting harder.+warn :: String -> a -> a+warn msg = trace ("Warning: " <> msg)++++-- Time++getCurrentLocalTime :: IO LocalTime+getCurrentLocalTime = do+  t <- getCurrentTime+  tz <- getCurrentTimeZone+  return $ utcToLocalTime tz t++getCurrentZonedTime :: IO ZonedTime+getCurrentZonedTime = do+  t <- getCurrentTime+  tz <- getCurrentTimeZone+  return $ utcToZonedTime tz t++++-- Files++-- | Expand a tilde (representing home directory) at the start of a file path.+-- ~username is not supported. Can raise an error.+expandHomePath :: FilePath -> IO FilePath+expandHomePath = \case+    ('~':'/':p)  -> (</> p) <$> getHomeDirectory+    ('~':'\\':p) -> (</> p) <$> getHomeDirectory+    ('~':_)      -> ioError $ userError "~USERNAME in paths is not supported"+    p            -> return p++-- | Given a current directory, convert a possibly relative, possibly tilde-containing+-- file path to an absolute one.+-- ~username is not supported. Leaves "-" unchanged. Can raise an error.+expandPath :: FilePath -> FilePath -> IO FilePath -- general type sig for use in reader parsers+expandPath _ "-" = return "-"+expandPath curdir p = (if isRelative p then (curdir </>) else id) <$> expandHomePath p  -- PARTIAL:++-- | Like expandPath, but treats the expanded path as a glob, and returns+-- zero or more matched absolute file paths, alphabetically sorted.+-- Can raise an error.+expandGlob :: FilePath -> FilePath -> IO [FilePath]+expandGlob curdir p = expandPath curdir p >>= glob <&> sort  -- PARTIAL:++-- | Given a list of existing file paths, sort them by modification time, most recent first.+sortByModTime :: [FilePath] -> IO [FilePath]+sortByModTime fs = do+  ftimes <- forM fs $ \f -> do {t <- getModificationTime f; return (t,f)}+  return $ map snd $ sortBy (comparing Data.Ord.Down) ftimes++-- | Like readFilePortably, but read all of the file before proceeding.+readFileStrictly :: FilePath -> IO T.Text+readFileStrictly f = readFilePortably f >>= \t -> evaluate (T.length t) >> return t++-- | Read text from a file,+-- converting any \r\n line endings to \n,,+-- using the system locale's text encoding,+-- ignoring any utf8 BOM prefix (as seen in paypal's 2018 CSV, eg) if that encoding is utf8.+readFilePortably :: FilePath -> IO T.Text+readFilePortably f =  openFile f ReadMode >>= readHandlePortably++-- | Like readFilePortably, but read from standard input if the path is "-".+readFileOrStdinPortably :: String -> IO T.Text+readFileOrStdinPortably f = openFileOrStdin f ReadMode >>= readHandlePortably+  where+    openFileOrStdin :: String -> IOMode -> IO Handle+    openFileOrStdin "-" _ = return stdin+    openFileOrStdin f' m   = openFile f' m++readHandlePortably :: Handle -> IO T.Text+readHandlePortably h = do+  hSetNewlineMode h universalNewlineMode+  menc <- hGetEncoding h+  when (fmap show menc == Just "UTF-8") $  -- XXX no Eq instance, rely on Show+    hSetEncoding h utf8_bom+  T.hGetContents h++-- | Like embedFile, but takes a path relative to the package directory.+embedFileRelative :: FilePath -> Q Exp+embedFileRelative f = makeRelativeToProject f >>= embedStringFile++-- -- | Like hereFile, but takes a path relative to the package directory.+-- -- Similar to embedFileRelative ?+-- hereFileRelative :: FilePath -> Q Exp+-- hereFileRelative f = makeRelativeToProject f >>= hereFileExp+--   where+--     QuasiQuoter{quoteExp=hereFileExp} = hereFile++++-- Command line parsing++-- | The program's command line arguments.+-- Uses unsafePerformIO; tends to stick in GHCI until reloaded,+-- and may or may not detect args provided by a hledger config file.+{-# NOINLINE progArgs #-}+progArgs :: [String]+progArgs = unsafePerformIO getArgs+-- XX currently this affects:+--  the enabling of orderdates and assertions checks in journalFinalise+--  a few cases involving --color (see useColorOnStdoutUnsafe)+--  --debug++-- | Given one or more long or short option names, read the rightmost value of this option from the command line arguments.+-- If the value is missing raise an error.+-- Concatenated short flags (-a -b written as -ab) are not supported.+getOpt :: [String] -> IO (Maybe String)+getOpt names = do+  rargs <- reverse . splitFlagsAndVals <$> getArgs+  let flags = map toFlag names+  return $+    case break ((`elem` flags)) rargs of+      (_,[])        -> Nothing+      ([],flag:_)   -> error' $ flag <> " requires a value"+      (argsafter,_) -> Just $ last argsafter++-- | Given a list of command line arguments, split any of the form --flag=VAL or -fVAL into two list items.+-- Concatenated short flags (-a -b written as -ab) are not supported.+splitFlagsAndVals :: [String] -> [String]+splitFlagsAndVals = concatMap $+  \case+    a@('-':'-':_) | '=' `elem` a -> let (x,y) = break (=='=') a in [x, drop 1 y]+    a@('-':f:_:_) | not $ f=='-' -> [take 2 a, drop 2 a]+    a -> [a]++-- | Convert a short or long flag name to a flag with leading hyphen(s).+toFlag [c] = ['-',c]+toFlag s   = '-':'-':s++-- | Parse y/yes/always or n/no/never to true or false, or with any other value raise an error.+parseYN :: String -> Bool+parseYN s+  | l `elem` ["y","yes","always"] = True+  | l `elem` ["n","no","never"]   = False+  | otherwise = error' $ "value should be one of " <> (intercalate ", " ["y","yes","n","no"])+  where l = map toLower s++data YNA = Yes | No | Auto deriving (Eq,Show)++-- | Parse y/yes/always or n/no/never or a/auto to a YNA choice, or with any other value raise an error.+parseYNA :: String -> YNA+parseYNA s+  | l `elem` ["y","yes","always"] = Yes+  | l `elem` ["n","no","never"]   = No+  | l `elem` ["a","auto"]         = Auto+  | otherwise = error' $ "value should be one of " <> (intercalate ", " ["y","yes","n","no","a","auto"])+  where l = map toLower s++-- | Is there a --output-file or -o option in the command line arguments ?+-- Uses getOpt; sticky in GHCI until reloaded, may not always be affected by a hledger config file, etc.+hasOutputFile :: IO Bool+hasOutputFile = do+  mv <- getOpt ["output-file","o"]+  return $+    case mv of+      Nothing  -> False+      Just "-" -> False+      _        -> True++-- -- | Get the -o/--output-file option's value, if any, from the command line arguments.+-- -- Uses getOpt; sticky in GHCI until reloaded, may not always be affected by a hledger config file, etc.+-- outputFileOption :: IO (Maybe String)+-- outputFileOption = getOpt ["output-file","o"]++++-- Terminal size+ -- | An alternative to ansi-terminal's getTerminalSize, based on -- the more robust-looking terminal-size package. -- Tries to get stdout's terminal's current height and width.@@ -200,170 +380,257 @@ getTerminalWidth :: IO (Maybe Int) getTerminalWidth  = fmap snd <$> getTerminalHeightWidth --- | Make sure our $LESS and $MORE environment variables contain R,--- to help ensure the common pager `less` will show our ANSI output properly.--- less uses $LESS by default, and $MORE when it is invoked as `more`.--- What the original `more` program does, I'm not sure.--- If $PAGER is configured to something else, this probably will have no effect.+++-- Pager output+-- somewhat hledger-specific++-- Configure some preferred options for the `less` pager,+-- by modifying the LESS environment variable in this program's environment.+-- If you are using some other pager, this will have no effect.+-- By default, this sets the following options, appending them to LESS's current value:+--+--   --chop-long-lines+--   --hilite-unread+--   --ignore-case+--   --mouse+--   --no-init+--   --quit-at-eof+--   --quit-if-one-screen+--   --RAW-CONTROL-CHARS+--   --shift=8+--   --squeeze-blank-lines+--   --use-backslash+--   --use-color+--+-- You can choose different options by setting the HLEDGER_LESS variable;+-- if set, its value will be used instead of LESS.+-- Or you can force hledger to use your exact LESS settings,+-- by setting HLEDGER_LESS equal to LESS.+-- setupPager :: IO () setupPager = do   let-    addR var = do-      mv <- lookupEnv var-      setEnv var $ case mv of-        Nothing -> "R"-        Just v  -> ('R':v)-  addR "LESS"-  addR "MORE"+    -- keep synced with doc above+    deflessopts = unwords [+       "--chop-long-lines"+      ,"--hilite-unread"+      ,"--ignore-case"+      ,"--mouse"+      ,"--no-init"+      ,"--quit-at-eof"+      ,"--quit-if-one-screen"+      ,"--RAW-CONTROL-CHARS"+      ,"--shift=8"+      ,"--squeeze-blank-lines"+      ,"--use-backslash"+      ,"--use-color"+      ]+  mhledgerless <- lookupEnv "HLEDGER_LESS"+  mless        <- lookupEnv "LESS"+  setEnv "LESS" $+    case (mhledgerless, mless) of+      (Just hledgerless, _) -> hledgerless+      (_, Just less)        -> unwords [less, deflessopts]+      _                     -> deflessopts --- Command line arguments+-- | Display the given text on the terminal, trying to use a pager ($PAGER, less, or more)+-- when appropriate, otherwise printing to standard output. Uses maybePagerFor.+--+-- hledger's output may contain ANSI style/color codes+-- (if the terminal supports them and they are not disabled by --color=no or NO_COLOR),+-- so the pager should be configured to handle these.+-- setupPager tries to configure that automatically when using the `less` pager.+--+runPager :: String -> IO ()+runPager s = do+  mpager <- maybePagerFor s+  case mpager of+    Nothing -> putStr s+    Just pager -> do+      withCreateProcess (shell pager){std_in=CreatePipe} $+        \mhin _ _ p -> do+          -- Pipe in the text on stdin.+          case mhin of+            Nothing  -> return ()  -- shouldn't happen+            Just hin -> void $ forkIO $   -- Write from another thread to avoid deadlock ? Maybe unneeded, but just in case.+              (hPutStr hin s >> hClose hin)  -- Be sure to close the pipe so the pager knows we're done.+                -- If the pager quits early, we'll receive an EPIPE error; hide that.+                `catch` \(e::IOException) -> case e of+                  IOError{ioe_type=ResourceVanished, ioe_errno=Just ioe, ioe_handle=Just hdl} | Errno ioe==ePIPE, hdl==hin+                    -> return ()+                  _ -> throwIO e+          void $ waitForProcess p --- | The command line arguments that were used at program startup.--- Uses unsafePerformIO.-{-# NOINLINE progArgs #-}-progArgs :: [String]-progArgs = unsafePerformIO getArgs+-- | Should a pager be used for displaying the given text on stdout, and if so, which one ?+-- Uses a pager if findPager finds one and none of the following conditions are true:+-- We're running in a native MS Windows environment like cmd or powershell.+-- Or the --pager=n|no option is in effect.+-- Or the -o/--output-file option is in effect.+-- Or INSIDE_EMACS is set, to something other than "vterm".+-- Or the terminal's current height and width can't be detected.+-- Or the output text is less wide and less tall than the terminal.+maybePagerFor :: String -> IO (Maybe String)+maybePagerFor output = do+  let+    ls = lines output+    oh = length ls+    ow = maximumDef 0 $ map length ls+    windows = os == "mingw32"+  pagerno    <- maybe False (not.parseYN) <$> getOpt ["pager"]+  outputfile <- hasOutputFile+  emacsterm  <- lookupEnv "INSIDE_EMACS" <&> (`notElem` [Nothing, Just "vterm"])+  mhw        <- getTerminalHeightWidth+  mpager     <- findPager+  return $ do+    guard $ not $ windows || pagerno || outputfile || emacsterm+    (th,tw) <- mhw+    guard $ oh > th || ow > tw+    mpager --- | Read the value of the -o/--output-file command line option provided at program startup,--- if any, using unsafePerformIO.-outputFileOption :: Maybe String-outputFileOption =-  -- keep synced with output-file flag definition in hledger:CliOptions.-  let args = progArgs in-  case dropWhile (not . ("-o" `isPrefixOf`)) args of-    -- -oARG-    ('-':'o':v@(_:_)):_ -> Just v-    -- -o ARG-    "-o":v:_ -> Just v-    _ ->-      case dropWhile (/="--output-file") args of-        -- --output-file ARG-        "--output-file":v:_ -> Just v-        _ ->-          case take 1 $ filter ("--output-file=" `isPrefixOf`) args of-            -- --output=file=ARG-            ['-':'-':'o':'u':'t':'p':'u':'t':'-':'f':'i':'l':'e':'=':v] -> Just v-            _ -> Nothing+-- | Try to find a pager executable robustly, safely handling various error conditions+-- like an unset PATH var or the specified pager not being found as an executable.+-- The pager can be specified by a path or program name in the PAGER environment variable.+-- If that is unset or has a problem, "less" is tried, then "more".+-- If successful, the pager's path or program name is returned.+findPager :: IO (Maybe String)  -- XXX probably a ByteString in fact ?+findPager = do+  mpagervar <- lookupEnv "PAGER"+  let pagers = [p | Just p <- [mpagervar]] <> ["less", "more"]+  headMay . catMaybes <$> mapM findExecutable pagers --- | Check whether the -o/--output-file option has been used at program startup--- with an argument other than "-", using unsafePerformIO.-hasOutputFile :: Bool-hasOutputFile = outputFileOption `notElem` [Nothing, Just "-"]--- XXX shouldn't we check that stdout is interactive. instead ? --- ANSI colour -ifAnsi f = if useColorOnStdout then f else id+-- ANSI colour/styles+-- Some of these use unsafePerformIO to read info. --- | Versions of some of text-ansi's string colors/styles which are more careful--- to not print junk onscreen. These use our useColorOnStdout.+-- hledger-specific:++-- | Get the value of the rightmost --color or --colour option from the program's command line arguments.+colorOption :: IO YNA+colorOption = maybe Auto parseYNA <$> getOpt ["color","colour"]++-- | Should ANSI color and styles be used with this output handle ?+-- Considers colorOption, the NO_COLOR environment variable, and hSupportsANSIColor.+useColorOnHandle :: Handle -> IO Bool+useColorOnHandle h = do+  no_color       <- isJust <$> lookupEnv "NO_COLOR"+  supports_color <- hSupportsANSIColor h+  yna            <- colorOption+  return $ yna==Yes || (yna==Auto && not no_color && supports_color)++-- | Should ANSI color and styles be used for standard output ?+-- Considers useColorOnHandle stdout and hasOutputFile.+useColorOnStdout :: IO Bool+useColorOnStdout = do+  nooutputfile <- not <$> hasOutputFile+  usecolor <- useColorOnHandle stdout+  return $ nooutputfile && usecolor++-- | Should ANSI color and styles be used for standard error output ?+-- Considers useColorOnHandle stderr; is not affected by an --output-file option.+useColorOnStderr :: IO Bool+useColorOnStderr = useColorOnHandle stderr++-- | Like useColorOnStdout, but using unsafePerformIO. Useful eg for low-level debug code.+-- Sticky in GHCI until reloaded, may not always be affected by --color in a hledger config file, etc.+useColorOnStdoutUnsafe :: Bool+useColorOnStdoutUnsafe = unsafePerformIO useColorOnStdout++-- | Like useColorOnStdoutUnsafe, but for stderr.+useColorOnStderrUnsafe :: Bool+useColorOnStderrUnsafe = unsafePerformIO useColorOnStderr++-- | Detect whether ANSI should be used on stdout using useColorOnStdoutUnsafe,+-- and if so prepend and append the given SGR codes to a string.+-- Currently used in a few places (the commands list, the demo command, the recentassertions error message);+-- see useColorOnStdoutUnsafe's limitations.+ansiWrapUnsafe :: SGRString -> SGRString -> String -> String+ansiWrapUnsafe pre post s = if useColorOnStdoutUnsafe then pre<>s<>post else s++type SGRString = String++sgrbold          = setSGRCode [SetConsoleIntensity BoldIntensity]+sgrfaint         = setSGRCode [SetConsoleIntensity FaintIntensity]+sgrnormal        = setSGRCode [SetConsoleIntensity NormalIntensity]+sgrresetfg       = setSGRCode [SetDefaultColor Foreground]+sgrblack         = setSGRCode [SetColor Foreground Dull Black]+sgrred           = setSGRCode [SetColor Foreground Dull Red]+sgrgreen         = setSGRCode [SetColor Foreground Dull Green]+sgryellow        = setSGRCode [SetColor Foreground Dull Yellow]+sgrblue          = setSGRCode [SetColor Foreground Dull Blue]+sgrmagenta       = setSGRCode [SetColor Foreground Dull Magenta]+sgrcyan          = setSGRCode [SetColor Foreground Dull Cyan]+sgrwhite         = setSGRCode [SetColor Foreground Dull White]+sgrbrightblack   = setSGRCode [SetColor Foreground Vivid Black]+sgrbrightred     = setSGRCode [SetColor Foreground Vivid Red]+sgrbrightgreen   = setSGRCode [SetColor Foreground Vivid Green]+sgrbrightyellow  = setSGRCode [SetColor Foreground Vivid Yellow]+sgrbrightblue    = setSGRCode [SetColor Foreground Vivid Blue]+sgrbrightmagenta = setSGRCode [SetColor Foreground Vivid Magenta]+sgrbrightcyan    = setSGRCode [SetColor Foreground Vivid Cyan]+sgrbrightwhite   = setSGRCode [SetColor Foreground Vivid White]+sgrrgb r g b     = setSGRCode [SetRGBColor Foreground $ sRGB r g b]++-- | Set various ANSI styles/colours in a string, only if useColorOnStdoutUnsafe says we should. bold' :: String -> String-bold'  = ifAnsi bold+bold'  = ansiWrapUnsafe sgrbold sgrnormal  faint' :: String -> String-faint'  = ifAnsi faint+faint'  = ansiWrapUnsafe sgrfaint sgrnormal  black' :: String -> String-black'  = ifAnsi black+black'  = ansiWrapUnsafe sgrblack sgrresetfg  red' :: String -> String-red'  = ifAnsi red+red'  = ansiWrapUnsafe sgrred sgrresetfg  green' :: String -> String-green'  = ifAnsi green+green'  = ansiWrapUnsafe sgrgreen sgrresetfg  yellow' :: String -> String-yellow'  = ifAnsi yellow+yellow'  = ansiWrapUnsafe sgryellow sgrresetfg  blue' :: String -> String-blue'  = ifAnsi blue+blue'  = ansiWrapUnsafe sgrblue sgrresetfg  magenta' :: String -> String-magenta'  = ifAnsi magenta+magenta'  = ansiWrapUnsafe sgrmagenta sgrresetfg  cyan' :: String -> String-cyan'  = ifAnsi cyan+cyan'  = ansiWrapUnsafe sgrcyan sgrresetfg  white' :: String -> String-white'  = ifAnsi white+white'  = ansiWrapUnsafe sgrwhite sgrresetfg  brightBlack' :: String -> String-brightBlack'  = ifAnsi brightBlack+brightBlack'  = ansiWrapUnsafe sgrbrightblack sgrresetfg  brightRed' :: String -> String-brightRed'  = ifAnsi brightRed+brightRed'  = ansiWrapUnsafe sgrbrightred sgrresetfg  brightGreen' :: String -> String-brightGreen'  = ifAnsi brightGreen+brightGreen'  = ansiWrapUnsafe sgrbrightgreen sgrresetfg  brightYellow' :: String -> String-brightYellow'  = ifAnsi brightYellow+brightYellow'  = ansiWrapUnsafe sgrbrightyellow sgrresetfg  brightBlue' :: String -> String-brightBlue'  = ifAnsi brightBlue+brightBlue'  = ansiWrapUnsafe sgrbrightblue sgrresetfg  brightMagenta' :: String -> String-brightMagenta'  = ifAnsi brightMagenta+brightMagenta'  = ansiWrapUnsafe sgrbrightmagenta sgrresetfg  brightCyan' :: String -> String-brightCyan'  = ifAnsi brightCyan+brightCyan'  = ansiWrapUnsafe sgrbrightcyan sgrresetfg  brightWhite' :: String -> String-brightWhite'  = ifAnsi brightWhite--rgb' :: Word8 -> Word8 -> Word8 -> String -> String-rgb' r g b  = ifAnsi (rgb r g b)---- | Read the value of the --color or --colour command line option provided at program startup--- using unsafePerformIO. If this option was not provided, returns the empty string.-colorOption :: String-colorOption =-  -- similar to debugLevel-  -- keep synced with color/colour flag definition in hledger:CliOptions-  let args = progArgs in-  case dropWhile (/="--color") args of-    -- --color ARG-    "--color":v:_ -> v-    _ ->-      case take 1 $ filter ("--color=" `isPrefixOf`) args of-        -- --color=ARG-        ['-':'-':'c':'o':'l':'o':'r':'=':v] -> v-        _ ->-          case dropWhile (/="--colour") args of-            -- --colour ARG-            "--colour":v:_ -> v-            _ ->-              case take 1 $ filter ("--colour=" `isPrefixOf`) args of-                -- --colour=ARG-                ['-':'-':'c':'o':'l':'o':'u':'r':'=':v] -> v-                _ -> ""---- | Check the IO environment to see if ANSI colour codes should be used on stdout.--- This is done using unsafePerformIO so it can be used anywhere, eg in--- low-level debug utilities, which should be ok since we are just reading.--- The logic is: use color if--- the program was started with --color=yes|always--- or (---   the program was not started with --color=no|never---   and a NO_COLOR environment variable is not defined---   and stdout supports ANSI color---   and -o/--output-file was not used, or its value is "-"--- ).-useColorOnStdout :: Bool-useColorOnStdout = not hasOutputFile && useColorOnHandle stdout+brightWhite'  = ansiWrapUnsafe sgrbrightwhite sgrresetfg --- | Like useColorOnStdout, but checks for ANSI color support on stderr,--- and is not affected by -o/--output-file.-useColorOnStderr :: Bool-useColorOnStderr = useColorOnHandle stderr+rgb' :: Float -> Float -> Float -> String -> String+rgb' r g b  = ansiWrapUnsafe (sgrrgb r g b) sgrresetfg -useColorOnHandle :: Handle -> Bool-useColorOnHandle h = unsafePerformIO $ do-  no_color       <- isJust <$> lookupEnv "NO_COLOR"-  supports_color <- hSupportsANSIColor h-  let coloroption = colorOption-  return $ coloroption `elem` ["always","yes","y"]-       || (coloroption `notElem` ["never","no","n"] && not no_color && supports_color)+-- Generic:  -- | Wrap a string in ANSI codes to set and reset foreground colour. -- ColorIntensity is @Dull@ or @Vivid@ (ie normal and bold).@@ -386,6 +653,7 @@ bgColorB int col (WideBuilder s w) =     WideBuilder (TB.fromString (setSGRCode [SetColor Background int col]) <> s <> TB.fromString (setSGRCode [])) w + -- | Detect whether the terminal currently has a light background colour, -- if possible, using unsafePerformIO. -- If the terminal is transparent, its apparent light/darkness may be different.@@ -410,7 +678,7 @@ terminalColor :: ConsoleLayer -> Maybe (RGB Float) terminalColor = unsafePerformIO . getLayerColor' --- A version of getLayerColor that is less likely to leak escape sequences to output,+-- A version of ansi-terminal's getLayerColor that is less likely to leak escape sequences to output, -- and that returns a RGB of Floats (0..1) that is more compatible with the colour package. -- This does nothing in a non-interactive context (eg when piping stdout to another command), -- inside emacs (emacs shell buffers show the escape sequence for some reason),@@ -425,97 +693,4 @@   where     fractionalRGB :: (Fractional a) => RGB Word16 -> RGB a     fractionalRGB (RGB r g b) = RGB (fromIntegral r / 65535) (fromIntegral g / 65535) (fromIntegral b / 65535)  -- chatgpt---- Errors---- | Simpler alias for errorWithoutStackTrace-error' :: String -> a-error' = errorWithoutStackTrace . ("Error: " <>)---- | A version of errorWithoutStackTrace that adds a usage hint.-usageError :: String -> a-usageError = error' . (++ " (use -h to see usage)")---- Files---- | Expand a tilde (representing home directory) at the start of a file path.--- ~username is not supported. Can raise an error.-expandHomePath :: FilePath -> IO FilePath-expandHomePath = \case-    ('~':'/':p)  -> (</> p) <$> getHomeDirectory-    ('~':'\\':p) -> (</> p) <$> getHomeDirectory-    ('~':_)      -> ioError $ userError "~USERNAME in paths is not supported"-    p            -> return p---- | Given a current directory, convert a possibly relative, possibly tilde-containing--- file path to an absolute one.--- ~username is not supported. Leaves "-" unchanged. Can raise an error.-expandPath :: FilePath -> FilePath -> IO FilePath -- general type sig for use in reader parsers-expandPath _ "-" = return "-"-expandPath curdir p = (if isRelative p then (curdir </>) else id) <$> expandHomePath p  -- PARTIAL:---- | Like expandPath, but treats the expanded path as a glob, and returns--- zero or more matched absolute file paths, alphabetically sorted.--- Can raise an error.-expandGlob :: FilePath -> FilePath -> IO [FilePath]-expandGlob curdir p = expandPath curdir p >>= glob <&> sort  -- PARTIAL:---- | Given a list of existing file paths, sort them by modification time, most recent first.-sortByModTime :: [FilePath] -> IO [FilePath]-sortByModTime fs = do-  ftimes <- forM fs $ \f -> do {t <- getModificationTime f; return (t,f)}-  return $ map snd $ sortBy (comparing Data.Ord.Down) ftimes---- | Like readFilePortably, but read all of the file before proceeding.-readFileStrictly :: FilePath -> IO T.Text-readFileStrictly f = readFilePortably f >>= \t -> C.evaluate (T.length t) >> return t---- | Read text from a file,--- converting any \r\n line endings to \n,,--- using the system locale's text encoding,--- ignoring any utf8 BOM prefix (as seen in paypal's 2018 CSV, eg) if that encoding is utf8.-readFilePortably :: FilePath -> IO T.Text-readFilePortably f =  openFile f ReadMode >>= readHandlePortably---- | Like readFilePortably, but read from standard input if the path is "-".-readFileOrStdinPortably :: String -> IO T.Text-readFileOrStdinPortably f = openFileOrStdin f ReadMode >>= readHandlePortably-  where-    openFileOrStdin :: String -> IOMode -> IO Handle-    openFileOrStdin "-" _ = return stdin-    openFileOrStdin f' m   = openFile f' m--readHandlePortably :: Handle -> IO T.Text-readHandlePortably h = do-  hSetNewlineMode h universalNewlineMode-  menc <- hGetEncoding h-  when (fmap show menc == Just "UTF-8") $  -- XXX no Eq instance, rely on Show-    hSetEncoding h utf8_bom-  T.hGetContents h---- | Like embedFile, but takes a path relative to the package directory.-embedFileRelative :: FilePath -> Q Exp-embedFileRelative f = makeRelativeToProject f >>= embedStringFile---- -- | Like hereFile, but takes a path relative to the package directory.--- -- Similar to embedFileRelative ?--- hereFileRelative :: FilePath -> Q Exp--- hereFileRelative f = makeRelativeToProject f >>= hereFileExp---   where---     QuasiQuoter{quoteExp=hereFileExp} = hereFile---- Time--getCurrentLocalTime :: IO LocalTime-getCurrentLocalTime = do-  t <- getCurrentTime-  tz <- getCurrentTimeZone-  return $ utcToLocalTime tz t--getCurrentZonedTime :: IO ZonedTime-getCurrentZonedTime = do-  t <- getCurrentTime-  tz <- getCurrentTimeZone-  return $ utcToZonedTime tz t- 

@@ -1,7 +1,3 @@-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings     #-}-{-# LANGUAGE ScopedTypeVariables   #-} {-|  Easy regular expression helpers, currently based on regex-tdfa. These should:@@ -42,6 +38,12 @@  -} +{-# LANGUAGE CPP                   #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE ScopedTypeVariables   #-}+ module Hledger.Utils.Regex (   -- * Regexp type and constructors    Regexp(reString)@@ -66,7 +68,9 @@ import Data.Aeson (ToJSON(..), Value(String)) import Data.Array ((!), elems, indices) import Data.Char (isDigit)+#if !MIN_VERSION_base(4,20,0) import Data.List (foldl')+#endif import Data.MemoUgly (memo) import Data.Text (Text) import qualified Data.Text as T@@ -163,8 +167,8 @@  -- | Tests whether a Regexp matches a Text. ----- This currently unpacks the Text to a String an works on that. This is due to--- a performance bug in regex-tdfa (#9), which may or may not be relevant here.+-- This currently unpacks the Text to a String, to work around a performance bug+-- in regex-tdfa (#9), which may or may not be relevant here. regexMatchText :: Regexp -> Text -> Bool regexMatchText r = matchTest r . T.unpack 

@@ -0,0 +1,379 @@+{-|+Helpers for beancount output.+-}++{-# LANGUAGE OverloadedStrings    #-}++module Hledger.Write.Beancount (+  showTransactionBeancount,+  -- postingsAsLinesBeancount,+  -- postingAsLinesBeancount,+  -- showAccountNameBeancount,+  tagsToBeancountMetadata,+  showBeancountMetadata,+  accountNameToBeancount,+  commodityToBeancount,+  -- beancountTopLevelAccounts,++  -- * Tests+  tests_WriteBeancount+)+where++-- import Prelude hiding (Applicative(..))+import Data.Char+import Data.Default (def)+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Builder as TB+import Safe (maximumBound)+import Text.DocLayout (realLength)+import Text.Printf+import Text.Tabular.AsciiWide hiding (render)++import Hledger.Utils+import Hledger.Data.Types+import Hledger.Data.AccountName+import Hledger.Data.Amount+import Hledger.Data.Currency (currencySymbolToCode)+import Hledger.Data.Dates (showDate)+import Hledger.Data.Posting (renderCommentLines, showBalanceAssertion, postingIndent)+import Hledger.Data.Transaction (payeeAndNoteFromDescription')+import Data.Function ((&))+import Data.List.Extra (groupOnKey)+import Data.Bifunctor (first)+import Data.List (sort)++--- ** doctest setup+-- $setup+-- >>> :set -XOverloadedStrings++-- | Like showTransaction, but applies various adjustments to produce valid Beancount journal data.+showTransactionBeancount :: Transaction -> Text+showTransactionBeancount t =+  -- https://beancount.github.io/docs/beancount_language_syntax.html+  -- similar to showTransactionHelper, but I haven't bothered with Builder+     firstline <> nl+  <> foldMap ((<> nl).postingIndent.showBeancountMetadata (Just maxmdnamewidth)) mds+  <> foldMap ((<> nl)) newlinecomments+  <> foldMap ((<> nl)) (postingsAsLinesBeancount $ tpostings t)+  <> nl+  where+    firstline = T.concat [date, status, payee, note, samelinecomment]+    date = showDate $ tdate t+    status = if tstatus t == Pending then " !" else " *"+    (payee,note) =+      case payeeAndNoteFromDescription' $ tdescription t of+        ("","") -> ("",      ""      )+        ("",n ) -> (""     , wrapq n )+        (p ,"") -> (wrapq p, wrapq "")+        (p ,n ) -> (wrapq p, wrapq n )+      where+        wrapq = wrap " \"" "\"" . escapeDoubleQuotes . escapeBackslash+    mds = tagsToBeancountMetadata $ ttags t+    maxmdnamewidth = maximum' $ map (T.length . fst) mds+    (samelinecomment, newlinecomments) =+      case renderCommentLines (tcomment t) of []   -> ("",[])+                                              c:cs -> (c,cs)++nl = "\n"++type BMetadata = Tag++-- https://beancount.github.io/docs/beancount_language_syntax.html#metadata-1+-- | Render a Beancount metadata as a metadata line (without the indentation or newline).+-- If a maximum name length is provided, space will be left after the colon+-- so that successive metadata values will all start at the same column.+showBeancountMetadata :: Maybe Int -> BMetadata -> Text+showBeancountMetadata mmaxnamewidth (n,v) =+  fitText (fmap (+2) mmaxnamewidth) Nothing False True (n <> ": ")+  <> toBeancountMetadataValue v++-- | Make a list of tags ready to be rendered as Beancount metadata:+-- Encode and lengthen names, encode values, and combine repeated tags into one.+-- Metadatas will be sorted by (encoded) name and then value.+tagsToBeancountMetadata :: [Tag] -> [BMetadata]+tagsToBeancountMetadata = sort . map (first toBeancountMetadataName) . uniquifyTags . filter (not.isHiddenTagName.fst)++-- | In a list of tags, replace each tag that appears more than once+-- with a single tag with all of the values combined into one, comma-and-space-separated.+-- This function also sorts all tags by name and then value.+uniquifyTags :: [Tag] -> [Tag]+uniquifyTags ts = [(k, T.intercalate ", " $ map snd $ tags) | (k, tags) <- groupOnKey fst $ sort ts]++toBeancountMetadataName :: TagName -> Text+toBeancountMetadataName name =+  prependStartCharIfNeeded $+  case T.uncons name of+    Nothing -> ""+    Just (c,cs) ->+      T.concatMap (\d -> if isBeancountMetadataNameChar d then T.singleton d else toBeancountMetadataNameChar d) $ T.cons c cs+  where+    -- If the name is empty, make it "mm".+    -- If it has only one character, prepend "m".+    -- If the first character is not a valid one, prepend "m".+    prependStartCharIfNeeded t =+      case T.uncons t of+        Nothing -> T.replicate 2 $ T.singleton beancountMetadataDummyNameStartChar+        Just (c,cs) | T.null cs || not (isBeancountMetadataNameStartChar c) -> T.cons beancountMetadataDummyNameStartChar t+        _ -> t++-- | Is this a valid character to start a Beancount metadata name (lowercase letter) ?+isBeancountMetadataNameStartChar :: Char -> Bool+isBeancountMetadataNameStartChar c = isLetter c && islowercase c++-- | Dummy valid starting character to prepend to a Beancount metadata name if needed.+beancountMetadataDummyNameStartChar :: Char+beancountMetadataDummyNameStartChar = 'm'++-- | Is this a valid character in the middle of a Beancount metadata name (a lowercase letter, digit, _ or -) ?+isBeancountMetadataNameChar :: Char -> Bool+isBeancountMetadataNameChar c = (isLetter c && islowercase c) || isDigit c || c `elem` ['_', '-']++-- | Convert a character to one or more characters valid inside a Beancount metadata name.+-- Letters are lowercased, spaces are converted to dashes, and unsupported characters are encoded as c<HEXBYTES>.+toBeancountMetadataNameChar :: Char -> Text+toBeancountMetadataNameChar c+  | isBeancountMetadataNameChar c = T.singleton c+  | isLetter c = T.singleton $ toLower c+  | isSpace c = "-"+  | otherwise = T.pack $ printf "c%x" c++toBeancountMetadataValue :: TagValue -> Text+toBeancountMetadataValue = ("\"" <>) . (<> "\"") . T.concatMap toBeancountMetadataValueChar++-- | Is this a valid character in the middle of a Beancount metadata name (a lowercase letter, digit, _ or -) ?+isBeancountMetadataValueChar :: Char -> Bool+isBeancountMetadataValueChar c = c `notElem` ['"']++-- | Convert a character to one or more characters valid inside a Beancount metadata value:+-- a double quote is encoded as c<HEXBYTES>.+toBeancountMetadataValueChar :: Char -> Text+toBeancountMetadataValueChar c+  | isBeancountMetadataValueChar c = T.singleton c+  | otherwise = T.pack $ printf "c%x" c+++-- | Render a transaction's postings as indented lines, suitable for `print -O beancount` output.+-- See also Posting.postingsAsLines.+postingsAsLinesBeancount :: [Posting] -> [Text]+postingsAsLinesBeancount ps = concatMap first3 linesWithWidths+  where+    linesWithWidths = map (postingAsLinesBeancount False maxacctwidth maxamtwidth) ps+    maxacctwidth = maximumBound 0 $ map second3 linesWithWidths+    maxamtwidth  = maximumBound 0 $ map third3  linesWithWidths++-- | Render one posting, on one or more lines, suitable for `print -O beancount` output.+-- Also returns the widths calculated for the account and amount fields.+-- See also Posting.postingAsLines.+postingAsLinesBeancount  :: Bool -> Int -> Int -> Posting -> ([Text], Int, Int)+postingAsLinesBeancount elideamount acctwidth amtwidth p =+    (concatMap (++ (map ("  "<>) $ metadatalines <> newlinecomments)) postingblocks+    ,thisacctwidth+    ,thisamtwidth+    )+  where+    -- This needs to be converted to strict Text in order to strip trailing+    -- spaces. This adds a small amount of inefficiency, and the only difference+    -- is whether there are trailing spaces in print (and related) reports. This+    -- could be removed and we could just keep everything as a Text Builder, but+    -- would require adding trailing spaces to 42 failing tests.+    postingblocks = [map T.stripEnd . T.lines . TL.toStrict $+                       render [ textCell BottomLeft statusandaccount+                              , textCell BottomLeft "  "+                              , Cell BottomLeft [pad amt]+                              , textCell BottomLeft samelinecomment+                              ]+                    | (amt,_assertion) <- shownAmountsAssertions]+    render = renderRow def{tableBorders=False, borderSpaces=False} . Group NoLine . map Header+    pad amt = WideBuilder (TB.fromText $ T.replicate w " ") w <> amt+      where w = max 12 amtwidth - wbWidth amt  -- min. 12 for backwards compatibility++    pacct = showAccountNameBeancount Nothing $ paccount p+    pstatusandacct p' = if pstatus p' == Pending then "! " else "" <> pacct++    -- currently prices are considered part of the amount string when right-aligning amounts+    -- Since we will usually be calling this function with the knot tied between+    -- amtwidth and thisamtwidth, make sure thisamtwidth does not depend on+    -- amtwidth at all.+    shownAmounts+      | elideamount = [mempty]+      | otherwise   = showMixedAmountLinesB displayopts a'+        where+          displayopts = defaultFmt{ displayZeroCommodity=True, displayForceDecimalMark=True, displayQuotes=False }+          a' = mapMixedAmount amountToBeancount $ pamount p+    thisamtwidth = maximumBound 0 $ map wbWidth shownAmounts++    -- when there is a balance assertion, show it only on the last posting line+    shownAmountsAssertions = zip shownAmounts shownAssertions+      where+        shownAssertions = replicate (length shownAmounts - 1) mempty ++ [assertion]+          where+            assertion = maybe mempty ((WideBuilder (TB.singleton ' ') 1 <>).showBalanceAssertion) $ pbalanceassertion p++    -- pad to the maximum account name width, plus 2 to leave room for status flags, to keep amounts aligned+    statusandaccount = postingIndent . fitText (Just $ 2 + acctwidth) Nothing False True $ pstatusandacct p+    thisacctwidth = realLength pacct+    mds = tagsToBeancountMetadata $ ptags p+    metadatalines = map (postingIndent . showBeancountMetadata (Just maxtagnamewidth)) mds+      where maxtagnamewidth = maximum' $ map (T.length . fst) mds+    (samelinecomment, newlinecomments) =+      case renderCommentLines (pcomment p) of []   -> ("",[])+                                              c:cs -> (c,cs)++-- | Like showAccountName for Beancount journal format.+-- Calls accountNameToBeancount first.+showAccountNameBeancount :: Maybe Int -> AccountName -> Text+showAccountNameBeancount w = maybe id T.take w . accountNameToBeancount++type BeancountAccountName = AccountName+type BeancountAccountNameComponent = AccountName++-- | Convert a hledger account name to a valid Beancount account name.+-- It replaces spaces with dashes and other non-supported characters with C<HEXBYTES>;+-- prepends the letter A to any part which doesn't begin with a letter or number;+-- adds a second :A part if there is only one part;+-- and capitalises each part.+-- It also checks that the first part is one of the required english+-- account names Assets, Liabilities, Equity, Income, or Expenses, and if not+-- raises an informative error.+-- Ref: https://beancount.github.io/docs/beancount_language_syntax.html#accounts+accountNameToBeancount :: AccountName -> BeancountAccountName+accountNameToBeancount a = b+  where+    cs1 =+      map accountNameComponentToBeancount $ accountNameComponents $+      dbg9 "hledger account name  " a+    cs2 =+      case cs1 of+        c:_ | c `notElem` beancountTopLevelAccounts -> error' e+          where+            e = T.unpack $ T.unlines [+              "bad top-level account: " <> c+              ,"in beancount account name:           " <> accountNameFromComponents cs1+              ,"converted from hledger account name: " <> a+              ,"For Beancount, top-level accounts must be (or be --alias'ed to)"+              ,"one of " <> T.intercalate ", " beancountTopLevelAccounts <> "."+              -- ,"and not: " <> b+              ]+        [c] -> [c, "A"]+        cs  -> cs+    b = dbg9 "beancount account name" $ accountNameFromComponents cs2++accountNameComponentToBeancount :: AccountName -> BeancountAccountNameComponent+accountNameComponentToBeancount acctpart =+  prependStartCharIfNeeded $+  case T.uncons acctpart of+    Nothing -> ""+    Just (c,cs) ->+      textCapitalise $+      T.concatMap (\d -> if isBeancountAccountChar d then (T.singleton d) else T.pack $ charToBeancount d) $ T.cons c cs+  where+    prependStartCharIfNeeded t =+      case T.uncons t of+        Just (c,_) | not $ isBeancountAccountStartChar c -> T.cons beancountAccountDummyStartChar t+        _ -> t++-- | Dummy valid starting character to prepend to Beancount account name parts if needed (A).+beancountAccountDummyStartChar :: Char+beancountAccountDummyStartChar = 'A'++charToBeancount :: Char -> String+charToBeancount c = if isSpace c then "-" else printf "C%x" c++-- XXX these probably allow too much unicode:++-- https://hackage.haskell.org/package/base-4.20.0.1/docs/Data-Char.html#v:isUpperCase would be more correct,+-- but isn't available till base 4.18/ghc 9.6. isUpper is close enough in practice.+isuppercase = isUpper+-- same story, presumably+islowercase = isLower++-- | Is this a valid character to start a Beancount account name part (capital letter or digit) ?+isBeancountAccountStartChar :: Char -> Bool+isBeancountAccountStartChar c = (isLetter c && isuppercase c) || isDigit c++-- | Is this a valid character to appear elsewhere in a Beancount account name part (letter, digit, or -) ?+isBeancountAccountChar :: Char -> Bool+isBeancountAccountChar c = isLetter c || isDigit c || c=='-'++beancountTopLevelAccounts = ["Assets", "Liabilities", "Equity", "Income", "Expenses"]++type BeancountAmount = Amount++-- | Do some best effort adjustments to make an amount that renders+-- in a way that Beancount can read: force the commodity symbol to the right,+-- capitalise all letters, convert a few currency symbols to codes.+amountToBeancount :: Amount -> BeancountAmount+amountToBeancount a@Amount{acommodity=c,astyle=s,acost=mp} = a{acommodity=c', astyle=s', acost=mp'}+  where+    c' = commodityToBeancount c+    s' = s{ascommodityside=R, ascommodityspaced=True}+    mp' = costToBeancount <$> mp+      where+        costToBeancount (TotalCost amt) = TotalCost $ amountToBeancount amt+        costToBeancount (UnitCost  amt) = UnitCost  $ amountToBeancount amt++type BeancountCommoditySymbol = CommoditySymbol++-- | Convert a hledger commodity name to a valid Beancount commodity name.+-- That is: 2-24 uppercase letters / digits / apostrophe / period / underscore / dash,+-- starting with a letter, and ending with a letter or digit.+-- Ref: https://beancount.github.io/docs/beancount_language_syntax.html#commodities-currencies+-- So this:+-- replaces common currency symbols with their ISO 4217 currency codes,+-- capitalises all letters,+-- replaces spaces with dashes and other invalid characters with C<HEXBYTES>,+-- prepends a C if the first character is not a letter,+-- appends a C if the last character is not a letter or digit,+-- and disables hledger's enclosing double quotes.+--+-- >>> commodityToBeancount ""+-- "C"+-- >>> commodityToBeancount "$"+-- "USD"+-- >>> commodityToBeancount "Usd"+-- "USD"+-- >>> commodityToBeancount "\"a1\""+-- "A1"+-- >>> commodityToBeancount "\"A 1!\""+-- "A-1C21"+--+commodityToBeancount :: CommoditySymbol -> BeancountCommoditySymbol+commodityToBeancount com =+  dbg9 "beancount commodity name" $+  let com' = stripquotes com+  in case currencySymbolToCode com' of+    Just code -> code+    Nothing ->+      com'+      & T.toUpper+      & T.concatMap (\d -> if isBeancountCommodityChar d then T.singleton d else T.pack $ charToBeancount d)+      & fixstart+      & fixend+  where+    fixstart bcom = case T.uncons bcom of+      Just (c,_) | isBeancountCommodityStartChar c -> bcom+      _ -> "C" <> bcom+    fixend bcom = case T.unsnoc bcom of+      Just (_,c) | isBeancountCommodityEndChar c -> bcom+      _ -> bcom <> "C"++-- | Is this a valid character in the middle of a Beancount commodity name (a capital letter, digit, or '._-) ?+isBeancountCommodityChar :: Char -> Bool+isBeancountCommodityChar c = (isLetter c && isuppercase c) || isDigit c || c `elem` ['\'', '.', '_', '-']++-- | Is this a valid character to start a Beancount commodity name (a capital letter) ?+isBeancountCommodityStartChar :: Char -> Bool+isBeancountCommodityStartChar c = isLetter c && isuppercase c++-- | Is this a valid character to end a Beancount commodity name (a capital letter or digit) ?+isBeancountCommodityEndChar :: Char -> Bool+isBeancountCommodityEndChar c = (isLetter c && isuppercase c) || isDigit c++--- ** tests++tests_WriteBeancount :: TestTree+tests_WriteBeancount = testGroup "Write.Beancount" [+  ]

@@ -1,39 +1,38 @@ {-# LANGUAGE OverloadedStrings #-} {- |-Export spreadsheet table data as HTML table.--This is derived from <https://hackage.haskell.org/package/classify-frog-0.2.4.3/src/src/Spreadsheet/Format.hs>+Common definitions for Html.Blaze and Html.Lucid -} module Hledger.Write.Html (-    printHtml,+    Lines(..),+    borderStyles,     ) where -import Hledger.Write.Spreadsheet (Type(..), Style(..), Emphasis(..), Cell(..))+import qualified Hledger.Write.Spreadsheet as Spr+import Hledger.Write.Spreadsheet (Cell(..)) -import qualified Lucid.Base as LucidBase-import qualified Lucid-import Data.Foldable (for_)+import Data.Text (Text)  -printHtml :: [[Cell (Lucid.Html ())]] -> Lucid.Html ()-printHtml table =-    Lucid.table_ $ for_ table $ \row ->-    Lucid.tr_ $ for_ row $ \cell ->-    formatCell cell+borderStyles :: Lines border => Cell border text -> [Text]+borderStyles cell =+    let border field access =+            map (field<>) $ borderLines $ access $ cellBorder cell in+    let leftBorder   = border "border-left:"   Spr.borderLeft   in+    let rightBorder  = border "border-right:"  Spr.borderRight  in+    let topBorder    = border "border-top:"    Spr.borderTop    in+    let bottomBorder = border "border-bottom:" Spr.borderBottom in+    leftBorder++rightBorder++topBorder++bottomBorder -formatCell :: Cell (Lucid.Html ()) -> Lucid.Html ()-formatCell cell =-    let str = cellContent cell in-    case cellStyle cell of-        Head -> Lucid.th_ str-        Body emph ->-            let align =-                    case cellType cell of-                        TypeString -> []-                        TypeDate -> []-                        _ -> [LucidBase.makeAttribute "align" "right"]-                withEmph =-                    case emph of-                        Item -> id-                        Total -> Lucid.b_-            in  Lucid.td_ align $ withEmph str++class (Spr.Lines border) => Lines border where+    borderLines :: border -> [Text]++instance Lines () where+    borderLines () = []++instance Lines Spr.NumLines where+    borderLines prop =+        case prop of+            Spr.NoLine -> []+            Spr.SingleLine -> ["black"]+            Spr.DoubleLine -> ["double black"]

@@ -0,0 +1,64 @@+{-# LANGUAGE OverloadedStrings #-}+{- |+Helpers and CSS styles for HTML output.+-}+module Hledger.Write.Html.Attribute (+    stylesheet,+    concatStyles,+    tableStylesheet,+    tableStyle,+    bold,+    doubleborder,+    topdoubleborder,+    bottomdoubleborder,+    alignright,+    alignleft,+    aligncenter,+    collapse,+    lpad,+    rpad,+    hpad,+    vpad,+    ) where++import qualified Data.Text as Text+import Data.Text (Text)+++stylesheet :: [(Text,Text)] -> Text+stylesheet elstyles =+    Text.unlines $+        "" : [el<>" {"<>styles<>"}" | (el,styles) <- elstyles]++concatStyles :: [Text] -> Text+concatStyles = Text.intercalate "; "+++tableStylesheet :: Text+tableStylesheet = stylesheet tableStyle++tableStyle :: [(Text, Text)]+tableStyle =+  [("table", collapse),+   ("th, td", lpad),+   ("th.account, td.account", "padding-left:0;")]++bold, doubleborder, topdoubleborder, bottomdoubleborder :: Text+bold = "font-weight:bold"+doubleborder = "double black"+topdoubleborder    = "border-top:"<>doubleborder+bottomdoubleborder = "border-bottom:"<>doubleborder++alignright, alignleft, aligncenter :: Text+alignright  = "text-align:right"+alignleft   = "text-align:left"+aligncenter = "text-align:center"++collapse :: Text+collapse = "border-collapse:collapse"++lpad, rpad, hpad, vpad :: Text+lpad = "padding-left:1em"+rpad = "padding-right:1em"+hpad = "padding-left:1em; padding-right:1em"+vpad = "padding-top:1em;  padding-bottom:1em"

@@ -0,0 +1,78 @@+{-# LANGUAGE OverloadedStrings #-}+{- |+Export spreadsheet table data as HTML table.++This is derived from <https://hackage.haskell.org/package/classify-frog-0.2.4.3/src/src/Spreadsheet/Format.hs>+-}+module Hledger.Write.Html.Blaze (+    printHtml,+    formatRow,+    formatCell,+    ) where++import qualified Hledger.Write.Html.Attribute as Attr+import qualified Hledger.Write.Spreadsheet as Spr+import Hledger.Write.Html (Lines, borderStyles)+import Hledger.Write.Spreadsheet (Type(..), Style(..), Emphasis(..), Cell(..))++import qualified Text.Blaze.Html4.Transitional.Attributes as HtmlAttr+import qualified Text.Blaze.Html4.Transitional as Html+import qualified Data.Text as Text+import Text.Blaze.Html4.Transitional (Html, toHtml, (!))+import Data.Foldable (traverse_)+++printHtml :: (Lines border) => [[Cell border Html]] -> Html+printHtml table = do+    Html.style $ toHtml $ Attr.tableStylesheet+    Html.table $ traverse_ formatRow table++formatRow:: (Lines border) => [Cell border Html] -> Html+formatRow = Html.tr . traverse_ formatCell++formatCell :: (Lines border) => Cell border Html -> Html+formatCell cell =+    let str = cellContent cell in+    let content =+            if Text.null $ cellAnchor cell+                then str+                else Html.a str !+                        HtmlAttr.href (Html.textValue (cellAnchor cell)) in+    let style =+            case borderStyles cell of+                [] -> []+                ss -> [HtmlAttr.style $ Html.textValue $+                        Attr.concatStyles ss] in+    let class_ =+            map (HtmlAttr.class_ . Html.textValue) $+            filter (not . Text.null) [Spr.textFromClass $ cellClass cell] in+    let span_ makeCell attrs =+            case Spr.cellSpan cell of+                Spr.NoSpan -> foldl (!) makeCell attrs+                Spr.Covered -> pure ()+                Spr.SpanHorizontal n ->+                    foldl (!) makeCell+                        (HtmlAttr.colspan (Html.stringValue $ show n) : attrs)+                Spr.SpanVertical n ->+                    foldl (!) makeCell+                        (HtmlAttr.rowspan (Html.stringValue $ show n) : attrs)+            in+    case cellStyle cell of+        Head -> span_ (Html.th content) (style++class_)+        Body emph ->+            let align =+                    case cellType cell of+                        TypeString -> []+                        TypeDate -> []+                        _ -> [HtmlAttr.align "right"]+                valign =+                    case Spr.cellSpan cell of+                        Spr.SpanVertical n ->+                            if n>1 then [HtmlAttr.valign "top"] else []+                        _ -> []+                withEmph =+                    case emph of+                        Item -> id+                        Total -> Html.b+            in  span_ (Html.td $ withEmph content) $+                style++align++valign++class_

@@ -0,0 +1,78 @@+{-# LANGUAGE OverloadedStrings #-}+{- |+Export spreadsheet table data as HTML table.++This is derived from <https://hackage.haskell.org/package/classify-frog-0.2.4.3/src/src/Spreadsheet/Format.hs>+-}+module Hledger.Write.Html.Lucid (+    printHtml,+    formatRow,+    formatCell,+    ) where++import qualified Hledger.Write.Html.Attribute as Attr+import qualified Hledger.Write.Spreadsheet as Spr+import Hledger.Write.Html (Lines, borderStyles)+import Hledger.Write.Spreadsheet (Type(..), Style(..), Emphasis(..), Cell(..))++import qualified Data.Text as Text+import qualified Lucid.Base as HtmlBase+import qualified Lucid as Html+import Data.Foldable (traverse_)+++type Html = Html.Html ()++printHtml :: (Lines border) => [[Cell border Html]] -> Html+printHtml table = do+    Html.link_ [Html.rel_ "stylesheet", Html.href_ "hledger.css"]+    Html.style_ Attr.tableStylesheet+    Html.table_ $ traverse_ formatRow table++formatRow:: (Lines border) => [Cell border Html] -> Html+formatRow = Html.tr_ . traverse_ formatCell++formatCell :: (Lines border) => Cell border Html -> Html+formatCell cell =+    let str = cellContent cell in+    let content =+            if Text.null $ cellAnchor cell+                then str+                else Html.a_ [Html.href_ $ cellAnchor cell] str in+    let style =+            case borderStyles cell of+                [] -> []+                ss -> [Html.style_ $ Attr.concatStyles ss] in+    let class_ =+            map Html.class_ $+            filter (not . Text.null) [Spr.textFromClass $ cellClass cell] in+    let span_ makeCell attrs cont =+            case Spr.cellSpan cell of+                Spr.NoSpan -> makeCell attrs cont+                Spr.Covered -> pure ()+                Spr.SpanHorizontal n ->+                    makeCell (Html.colspan_ (Text.pack $ show n) : attrs) cont+                Spr.SpanVertical n ->+                    makeCell (Html.rowspan_ (Text.pack $ show n) : attrs) cont+            in+    case cellStyle cell of+        Head -> span_ Html.th_ (style++class_) content+        Body emph ->+            let align =+                    case cellType cell of+                        TypeString -> []+                        TypeDate -> []+                        _ -> [HtmlBase.makeAttribute "align" "right"]+                valign =+                    case Spr.cellSpan cell of+                        Spr.SpanVertical n ->+                            if n>1+                                then [HtmlBase.makeAttribute "valign" "top"]+                                else []+                        _ -> []+                withEmph =+                    case emph of+                        Item -> id+                        Total -> Html.b_+            in  span_ Html.td_ (style++align++valign++class_) $+                withEmph content

@@ -12,28 +12,34 @@     printFods,     ) where -import Hledger.Write.Spreadsheet (Type(..), Style(..), Emphasis(..), Cell(..))-import Hledger.Data.Types (CommoditySymbol, AmountPrecision(..))-import Hledger.Data.Types (acommodity, aquantity, astyle, asprecision)+import Prelude hiding (Applicative(..))+import Control.Monad (guard)+import Control.Applicative (Applicative(..))  import qualified Data.Text.Lazy as TL import qualified Data.Text as T import Data.Text (Text) +import qualified Data.Foldable as Fold+import qualified Data.List as List import qualified Data.Map as Map import qualified Data.Set as Set import Data.Foldable (fold) import Data.Map (Map) import Data.Set (Set)-import Data.Maybe (mapMaybe)+import Data.Maybe (catMaybes)  import qualified System.IO as IO import Text.Printf (printf) +import qualified Hledger.Write.Spreadsheet as Spr+import Hledger.Write.Spreadsheet (Type(..), Style(..), Emphasis(..), Cell(..))+import Hledger.Data.Types (CommoditySymbol, AmountPrecision(..))+import Hledger.Data.Types (acommodity, aquantity, astyle, asprecision)  printFods ::     IO.TextEncoding ->-    Map Text ((Maybe Int, Maybe Int), [[Cell Text]]) -> TL.Text+    Map Text ((Int, Int), [[Cell Spr.NumLines Text]]) -> TL.Text printFods encoding tables =     let fileOpen customStyles =           map (map (\c -> case c of '\'' -> '"'; _ -> c)) $@@ -57,20 +63,6 @@           "  xmlns:field='urn:openoffice:names:experimental:ooo-ms-interop:xmlns:field:1.0'" :           "  xmlns:form='urn:oasis:names:tc:opendocument:xmlns:form:1.0'>" :           "<office:styles>" :-          "  <style:style style:name='head' style:family='table-cell'>" :-          "    <style:paragraph-properties fo:text-align='center'/>" :-          "    <style:text-properties fo:font-weight='bold'/>" :-          "  </style:style>" :-          "  <style:style style:name='foot' style:family='table-cell'>" :-          "    <style:text-properties fo:font-weight='bold'/>" :-          "  </style:style>" :-          "  <style:style style:name='amount' style:family='table-cell'>" :-          "    <style:paragraph-properties fo:text-align='end'/>" :-          "  </style:style>" :-          "  <style:style style:name='total-amount' style:family='table-cell'>" :-          "    <style:paragraph-properties fo:text-align='end'/>" :-          "    <style:text-properties fo:font-weight='bold'/>" :-          "  </style:style>" :           "  <number:date-style style:name='iso-date'>" :           "    <number:year number:style='long'/>" :           "    <number:text>-</number:text>" :@@ -78,12 +70,9 @@           "    <number:text>-</number:text>" :           "    <number:day number:style='long'/>" :           "  </number:date-style>" :-          "  <style:style style:name='date' style:family='table-cell'" :-          "      style:data-style-name='iso-date'/>" :-          "  <style:style style:name='foot-date' style:family='table-cell'" :-          "      style:data-style-name='iso-date'>" :-          "    <style:text-properties fo:font-weight='bold'/>" :-          "  </style:style>" :+          "  <number:number-style style:name='integer'>" :+          "    <number:number number:min-integer-digits='1'/>" :+          "  </number:number-style>" :           customStyles ++           "</office:styles>" :           []@@ -99,14 +88,14 @@           "    <config:config-item-map-entry>" :           "     <config:config-item-map-named config:name='Tables'>" :           (fold $-           flip Map.mapWithKey tableNames $ \tableName (mTopRow,mLeftColumn) ->+           flip Map.mapWithKey tableNames $ \tableName (topRow,leftColumn) ->              printf "      <config:config-item-map-entry config:name='%s'>" tableName :-             (flip foldMap mLeftColumn $ \leftColumn ->+             ((guard (leftColumn>0) >>) $                 "       <config:config-item config:name='HorizontalSplitMode' config:type='short'>2</config:config-item>" :                 printf "       <config:config-item config:name='HorizontalSplitPosition' config:type='int'>%d</config:config-item>" leftColumn :                 printf "       <config:config-item config:name='PositionRight' config:type='int'>%d</config:config-item>" leftColumn :                 []) ++-             (flip foldMap mTopRow $ \topRow ->+             ((guard (topRow>0) >>) $                 "       <config:config-item config:name='VerticalSplitMode' config:type='short'>2</config:config-item>" :                 printf "       <config:config-item config:name='VerticalSplitPosition' config:type='int'>%d</config:config-item>" topRow :                 printf "       <config:config-item config:name='PositionBottom' config:type='int'>%d</config:config-item>" topRow :@@ -135,7 +124,7 @@     in  TL.unlines $ map (TL.fromStrict . T.pack) $         fileOpen           (let styles = cellStyles (foldMap (concat.snd) tables) in-           (numberConfig =<< Set.toList (Set.map snd styles))+           (numberConfig =<< Set.toList (foldMap (numberParams.snd) styles))            ++            (cellConfig =<< Set.toList styles)) ++         tableConfig (fmap fst tables) ++@@ -150,18 +139,24 @@         fileClose  -cellStyles :: [Cell Text] -> Set (Emphasis, (CommoditySymbol, AmountPrecision))+dataStyleFromType :: Type -> DataStyle+dataStyleFromType typ =+    case typ of+        TypeString -> DataString+        TypeInteger -> DataInteger+        TypeDate -> DataDate+        TypeAmount amt -> DataAmount (acommodity amt) (asprecision $ astyle amt)+        TypeMixedAmount -> DataMixedAmount++cellStyles ::+    (Ord border) =>+    [Cell border Text] ->+    Set ((Spr.Border border, Style), DataStyle) cellStyles =     Set.fromList .-    mapMaybe (\cell ->-        case cellType cell of-            TypeAmount amt ->-                Just-                    (case cellStyle cell of-                        Body emph -> emph-                        Head -> Total,-                     (acommodity amt, asprecision $ astyle amt))-            _ -> Nothing)+    map (\cell ->+            ((cellBorder cell, cellStyle cell),+             dataStyleFromType $ cellType cell))  numberStyleName :: (CommoditySymbol, AmountPrecision) -> String numberStyleName (comm, prec) =@@ -170,6 +165,10 @@         NaturalPrecision -> "natural"         Precision k -> show k +numberParams :: DataStyle -> Set (CommoditySymbol, AmountPrecision)+numberParams (DataAmount comm prec) = Set.singleton (comm, prec)+numberParams _ = Set.empty+ numberConfig :: (CommoditySymbol, AmountPrecision) -> [String] numberConfig (comm, prec) =     let precStr =@@ -191,45 +190,125 @@         Item -> "item"         Total -> "total" -cellConfig :: (Emphasis, (CommoditySymbol, AmountPrecision)) -> [String]-cellConfig (emph, numParam) =-    let name = numberStyleName numParam in-    let style :: String+cellStyleName :: Style -> String+cellStyleName style =+    case style of+        Head -> "head"+        Body emph -> emphasisName emph++linesName :: Spr.NumLines -> Maybe String+linesName prop =+    case prop of+        Spr.NoLine -> Nothing+        Spr.SingleLine -> Just "single"+        Spr.DoubleLine -> Just "double"++linesStyle :: Spr.NumLines -> String+linesStyle prop =+    case prop of+        Spr.NoLine -> "none"+        Spr.SingleLine -> "1.5pt solid #000000"+        Spr.DoubleLine -> "1.5pt double-thin #000000"++borderLabels :: Spr.Border String+borderLabels = Spr.Border "left" "right" "top" "bottom"++borderName :: Spr.Border Spr.NumLines -> String+borderName border =+    (\bs ->+        case bs of+            [] -> "noborder"+            _ ->+                ("border="++) $ List.intercalate "," $+                map (\(name,num) -> name ++ ':' : num) bs) $+    catMaybes $ Fold.toList $+    liftA2+        (\name numLines -> (,) name <$> linesName numLines)+        borderLabels+        border++borderStyle :: Spr.Border Spr.NumLines -> [String]+borderStyle border =+    if border == Spr.noBorder+        then []+        else (:[]) $+            printf "    <style:table-cell-properties%s/>" $+            (id :: String -> String) $ fold $+            liftA2 (printf " fo:border-%s='%s'") borderLabels $+            fmap linesStyle border++data DataStyle =+      DataString+    | DataInteger+    | DataDate+    | DataAmount CommoditySymbol AmountPrecision+    | DataMixedAmount+    deriving (Eq, Ord, Show)++cellConfig :: ((Spr.Border Spr.NumLines, Style), DataStyle) -> [String]+cellConfig ((border, cstyle), dataStyle) =+    let boldStyle = "    <style:text-properties fo:font-weight='bold'/>"+        alignTop =+            "    <style:table-cell-properties style:vertical-align='top'/>"+        alignParagraph =+            printf "    <style:paragraph-properties fo:text-align='%s'/>"+        moreStyles =+            borderStyle border+            +++            (+            case cstyle of+                Body Item ->+                    alignTop :+                    []+                Body Total ->+                    alignTop :+                    boldStyle :+                    []+                Head ->+                    alignParagraph "center" :+                    boldStyle :+                    []+            )+            +++            (+            case dataStyle of+                DataMixedAmount -> [alignParagraph "end"]+                _ -> []+            )+        style :: String         style =-            printf "style:name='%s-%s' style:data-style-name='number-%s'"-                (emphasisName emph) name name in-    case emph of-        Item ->+            let (styleName,dataStyleName) = styleNames cstyle border dataStyle+            in  printf "style:name='%s'" styleName+                +++                foldMap (printf " style:data-style-name='%s'") dataStyleName+    in+    case moreStyles of+        [] ->             printf "  <style:style style:family='table-cell' %s/>" style :             []-        Total ->+        _ ->             printf "  <style:style style:family='table-cell' %s>" style :-            "    <style:text-properties fo:font-weight='bold'/>" :+            moreStyles ++             "  </style:style>" :             []  -formatCell :: Cell Text -> [String]+formatCell :: Cell Spr.NumLines Text -> [String] formatCell cell =     let style, valueType :: String         style =-          case (cellStyle cell, cellType cell) of-            (Body emph, TypeAmount amt) -> tableStyle $ numberStyle emph amt-            (Body Item, TypeString) -> ""-            (Body Item, TypeMixedAmount) -> tableStyle "amount"-            (Body Item, TypeDate) -> tableStyle "date"-            (Body Total, TypeString) -> tableStyle "foot"-            (Body Total, TypeMixedAmount) -> tableStyle "total-amount"-            (Body Total, TypeDate) -> tableStyle "foot-date"-            (Head, _) -> tableStyle "head"-        numberStyle emph amt =-            printf "%s-%s"-                (emphasisName emph)-                (numberStyleName (acommodity amt, asprecision $ astyle amt))-        tableStyle = printf " table:style-name='%s'"+            printf " table:style-name='%s'" $ fst $+            styleNames+                (cellStyle cell)+                (cellBorder cell)+                (dataStyleFromType $ cellType cell)          valueType =             case cellType cell of+                TypeInteger ->+                    printf+                        "office:value-type='float' office:value='%s'"+                        (cellContent cell)                 TypeAmount amt ->                     printf                         "office:value-type='float' office:value='%s'"@@ -240,11 +319,49 @@                         (cellContent cell)                 _ -> "office:value-type='string'" +        covered =+            case cellSpan cell of+                Spr.Covered -> "covered-"+                _ -> ""++        span_ =+            case cellSpan cell of+                Spr.SpanHorizontal n | n>1 ->+                    printf " table:number-columns-spanned='%d'" n+                Spr.SpanVertical n | n>1 ->+                    printf " table:number-rows-spanned='%d'" n+                _ -> ""++        anchor text =+            if T.null $ Spr.cellAnchor cell+                then text+                else printf "<text:a xlink:href='%s'>%s</text:a>"+                        (escape $ T.unpack $ Spr.cellAnchor cell) text+     in-    printf "<table:table-cell%s %s>" style valueType :-    printf "<text:p>%s</text:p>" (escape $ T.unpack $ cellContent cell) :-    "</table:table-cell>" :+    printf "<table:%stable-cell%s%s %s>" covered style span_ valueType :+    printf "<text:p>%s</text:p>"+        (anchor $ escape $ T.unpack $ cellContent cell) :+    printf "</table:%stable-cell>" covered :     []++styleNames ::+    Style -> Spr.Border Spr.NumLines -> DataStyle -> (String, Maybe String)+styleNames cstyle border dataStyle =+    let cstyleName = cellStyleName cstyle in+    let bordName = borderName border in+    case dataStyle of+        DataDate ->+            (printf "%s-%s-date" cstyleName bordName, Just "iso-date")+        DataInteger ->+            (printf "%s-%s-integer" cstyleName bordName, Just "integer")+        DataAmount comm prec ->+            let name = numberStyleName (comm, prec) in+            (printf "%s-%s-%s" cstyleName bordName name,+                Just $ printf "number-%s" name)+        DataMixedAmount ->+            (printf "%s-%s-mixedamount" cstyleName bordName, Nothing)+        DataString -> (printf "%s-%s" cstyleName bordName, Nothing)  escape :: String -> String escape =

@@ -7,15 +7,42 @@     Style(..),     Emphasis(..),     Cell(..),+    Class(Class), textFromClass,+    Span(..),+    Border(..),+    Lines(..),+    NumLines(..),+    noBorder,     defaultCell,+    headerCell,     emptyCell,+    transposeCell,+    transpose,+    horizontalSpan,+    addHeaderBorders,+    addRowSpanHeader,+    rawTableContent,+    cellFromMixedAmount,+    cellsFromMixedAmount,+    cellFromAmount,+    integerCell,     ) where -import Hledger.Data.Types (Amount)+import qualified Hledger.Data.Amount as Amt+import Hledger.Data.Types (Amount, MixedAmount, acommodity)+import Hledger.Data.Amount (AmountFormat) +import qualified Data.List as List+import qualified Data.Text as Text+import Data.Text (Text)+import Text.WideString (WideBuilder) +import Prelude hiding (span)++ data Type =       TypeString+    | TypeInteger     | TypeAmount !Amount     | TypeMixedAmount     | TypeDate@@ -27,23 +54,205 @@ data Emphasis = Item | Total     deriving (Eq, Ord, Show) -data Cell text =++class Lines border where noLine :: border+instance Lines () where noLine = ()+instance Lines NumLines where noLine = NoLine++{- |+The same as Tab.Properties, but has 'Eq' and 'Ord' instances.+We need those for storing 'NumLines' in 'Set's.+-}+data NumLines = NoLine | SingleLine | DoubleLine+    deriving (Eq, Ord, Show)++data Border lines =+    Border {+        borderLeft, borderRight,+        borderTop, borderBottom :: lines+    }+    deriving (Eq, Ord, Show)++instance Functor Border where+    fmap f (Border left right top bottom) =+        Border (f left) (f right) (f top) (f bottom)++instance Applicative Border where+    pure a = Border a a a a+    Border fLeft fRight fTop fBottom <*> Border left right top bottom =+        Border (fLeft left) (fRight right) (fTop top) (fBottom bottom)++instance Foldable Border where+    foldMap f (Border left right top bottom) =+        f left <> f right <> f top <> f bottom++noBorder :: (Lines border) => Border border+noBorder = pure noLine++transposeBorder :: Border lines -> Border lines+transposeBorder (Border left right top bottom) =+    Border top bottom left right+++newtype Class = Class Text++textFromClass :: Class -> Text+textFromClass (Class cls) = cls+++{- |+* 'NoSpan' means a single unmerged cell.++* 'Covered' is a cell if it is part of a horizontally or vertically merged cell.+  We maintain these cells although they are ignored in HTML output.+  In contrast to that, FODS can store covered cells+  and allows to access the hidden cell content via formulas.+  CSV does not support merged cells+  and thus simply writes the content of covered cells.+  Maintaining 'Covered' cells also simplifies transposing.++* @'SpanHorizontal' n@ denotes the first cell in a row+  that is part of a merged cell.+  The merged cell contains @n@ atomic cells, including the first one.+  That is @SpanHorizontal 1@ is actually like @NoSpan@.+  The content of this cell is shown as content of the merged cell.++* @'SpanVertical' n@ starts a vertically merged cell.++The writer functions expect consistent data,+that is, 'Covered' cells must actually be part of a merged cell+and merged cells must only cover 'Covered' cells.+-}+data Span =+      NoSpan+    | Covered+    | SpanHorizontal Int+    | SpanVertical Int+    deriving (Eq)++transposeSpan :: Span -> Span+transposeSpan span =+    case span of+        NoSpan -> NoSpan+        Covered -> Covered+        SpanHorizontal n -> SpanVertical n+        SpanVertical n -> SpanHorizontal n++data Cell border text =     Cell {         cellType :: Type,+        cellBorder :: Border border,         cellStyle :: Style,+        cellSpan :: Span,+        cellAnchor :: Text,+        cellClass :: Class,         cellContent :: text     } -instance Functor Cell where-    fmap f (Cell typ style content) = Cell typ style $ f content+instance Functor (Cell border) where+    fmap f (Cell typ border style span anchor class_ content) =+        Cell typ border style span anchor class_ $ f content -defaultCell :: text -> Cell text+defaultCell :: (Lines border) => text -> Cell border text defaultCell text =     Cell {         cellType = TypeString,+        cellBorder = noBorder,         cellStyle = Body Item,+        cellSpan = NoSpan,+        cellAnchor = mempty,+        cellClass = Class mempty,         cellContent = text     } -emptyCell :: (Monoid text) => Cell text+headerCell :: (Lines borders) => Text -> Cell borders Text+headerCell text = (defaultCell text) {cellStyle = Head}++emptyCell :: (Lines border, Monoid text) => Cell border text emptyCell = defaultCell mempty++transposeCell :: Cell border text -> Cell border text+transposeCell cell =+    cell {+        cellBorder = transposeBorder $ cellBorder cell,+        cellSpan = transposeSpan $ cellSpan cell+    }++transpose :: [[Cell border text]] -> [[Cell border text]]+transpose = List.transpose . map (map transposeCell)+++addHeaderBorders :: [Cell () text] -> [Cell NumLines text]+addHeaderBorders =+    map (\c -> c {cellBorder = noBorder {borderBottom = DoubleLine}})++horizontalSpan ::+    (Lines border, Monoid text) =>+    [a] -> Cell border text -> [Cell border text]+horizontalSpan subCells cell =+    zipWith const+        (cell{cellSpan = SpanHorizontal $ length subCells}+            : repeat (emptyCell {cellSpan = Covered}))+        subCells++addRowSpanHeader ::+    Cell border text ->+    [[Cell border text]] -> [[Cell border text]]+addRowSpanHeader header rows =+    case rows of+        [] -> []+        [row] -> [header:row]+        _ ->+            zipWith (:)+                (header{cellSpan = SpanVertical (length rows)} :+                 repeat header{cellSpan = Covered})+                rows++rawTableContent :: [[Cell border text]] -> [[text]]+rawTableContent = map (map cellContent)++++cellFromMixedAmount ::+    (Lines border) =>+    AmountFormat -> (Class, MixedAmount) -> Cell border WideBuilder+cellFromMixedAmount bopts (cls, mixedAmt) =+    (defaultCell $ Amt.showMixedAmountB bopts mixedAmt) {+        cellClass = cls,+        cellType =+          case Amt.unifyMixedAmount mixedAmt of+            Just amt -> amountType bopts amt+            Nothing -> TypeMixedAmount+    }++cellsFromMixedAmount ::+    (Lines border) =>+    AmountFormat -> (Class, MixedAmount) -> [Cell border WideBuilder]+cellsFromMixedAmount bopts (cls, mixedAmt) =+    map+        (\(str,amt) ->+            (defaultCell str) {+                cellClass = cls,+                cellType = amountType bopts amt+            })+        (Amt.showMixedAmountLinesPartsB bopts mixedAmt)++cellFromAmount ::+    (Lines border) =>+    AmountFormat -> (Class, (wb, Amount)) -> Cell border wb+cellFromAmount bopts (cls, (str,amt)) =+    (defaultCell str) {+        cellClass = cls,+        cellType = amountType bopts amt+    }++amountType :: AmountFormat -> Amount -> Type+amountType bopts amt =+    TypeAmount $+    if Amt.displayCommodity bopts+      then amt+      else amt {acommodity = Text.empty}+++integerCell :: (Lines border) => Integer -> Cell border Text+integerCell k = (defaultCell $ Text.pack $ show k) {cellType = TypeInteger}

@@ -27,7 +27,7 @@ import Data.Bifunctor (bimap) import Data.Maybe (fromMaybe) import Data.Default (Default(..))-import Data.List (intercalate, intersperse, transpose)+import Data.List (intersperse, transpose) import Data.Semigroup (stimesMonoid) import Data.Text (Text) import qualified Data.Text as T@@ -130,9 +130,9 @@    -- maximum width for each column   sizes = map (fromMaybe 0 . maximumMay . map cellWidth) $ transpose cells2-  renderRs (Header s)   = [s]-  renderRs (Group p hs) = intercalate sep $ map renderRs hs-    where sep = renderHLine VM borders pretty sizes ch2 p+  renderRs =+    concatMap (either (renderHLine VM borders pretty sizes ch2) (:[])) .+    flattenHeader    -- borders and bars   addBorders xs = if borders then bar VT SingleLine : xs ++ [bar VB SingleLine] else xs

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           hledger-lib-version:        1.40+version:        1.41 synopsis:       A library providing the core functionality of hledger description:    This library contains hledger's core functionality.                 It is used by most hledger* packages so that they support the same@@ -45,8 +45,8 @@   type: git   location: https://github.com/simonmichael/hledger -flag ghcdebug-  description: Build with support for attaching a ghc-debug client+flag debug+  description: Build with GHC 9.10+'s stack traces enabled   manual: True   default: False @@ -58,6 +58,7 @@       Hledger.Data.AccountName       Hledger.Data.Amount       Hledger.Data.Balancing+      Hledger.Data.Currency       Hledger.Data.Dates       Hledger.Data.Errors       Hledger.Data.Journal@@ -85,9 +86,13 @@       Hledger.Read.RulesReader       Hledger.Read.TimedotReader       Hledger.Read.TimeclockReader+      Hledger.Write.Beancount       Hledger.Write.Csv       Hledger.Write.Ods       Hledger.Write.Html+      Hledger.Write.Html.Attribute+      Hledger.Write.Html.Blaze+      Hledger.Write.Html.Lucid       Hledger.Write.Spreadsheet       Hledger.Reports       Hledger.Reports.ReportOptions@@ -107,8 +112,8 @@       Hledger.Utils.Test       Hledger.Utils.Text       Text.Tabular.AsciiWide-  other-modules:       Text.WideString+  other-modules:       Paths_hledger_lib   hs-source-dirs:       ./@@ -120,8 +125,9 @@     , aeson-pretty     , ansi-terminal >=0.9     , array-    , base >=4.14 && <4.20-    , base-compat+    , base >=4.14 && <4.21+    , base-compat >=0.14.0+    , blaze-html     , blaze-markup >=0.5.1     , bytestring     , call-stack@@ -132,19 +138,20 @@     , containers >=0.5.9     , data-default >=0.5     , deepseq-    , directory+    , directory >=1.2.6.1     , doclayout >=0.3 && <0.6     , extra >=1.6.3     , file-embed >=0.0.10     , filepath     , hashtables >=1.2.3.1     , lucid-    , megaparsec >=7.0.0 && <9.7+    , megaparsec >=7.0.0 && <9.8     , microlens >=0.4     , microlens-th >=0.4     , mtl >=2.2.1     , parser-combinators >=0.4.0     , pretty-simple >4 && <5+    , process     , regex-tdfa     , safe >=0.3.20     , tabular >=0.2@@ -153,7 +160,6 @@     , template-haskell     , terminal-size >=0.3.3     , text >=1.2.4.1-    , text-ansi >=0.2.1     , time >=1.5     , timeit     , transformers >=0.2@@ -161,13 +167,8 @@     , unordered-containers >=0.2     , utf8-string >=0.3.5   default-language: Haskell2010-  if (!(os(windows)))-    build-depends:-        pager >=0.1.1.0-  if (flag(ghcdebug))-    cpp-options: -DGHCDEBUG-    build-depends:-        ghc-debug-stub >=0.6.0.0 && <0.7+  if (flag(debug))+    cpp-options: -DDEBUG  test-suite doctest   type: exitcode-stdio-1.0@@ -183,8 +184,9 @@     , aeson-pretty     , ansi-terminal >=0.9     , array-    , base >=4.14 && <4.20-    , base-compat+    , base >=4.14 && <4.21+    , base-compat >=0.14.0+    , blaze-html     , blaze-markup >=0.5.1     , bytestring     , call-stack@@ -195,7 +197,7 @@     , containers >=0.5.9     , data-default >=0.5     , deepseq-    , directory+    , directory >=1.2.6.1     , doclayout >=0.3 && <0.6     , doctest >=0.18.1     , extra >=1.6.3@@ -203,12 +205,13 @@     , filepath     , hashtables >=1.2.3.1     , lucid-    , megaparsec >=7.0.0 && <9.7+    , megaparsec >=7.0.0 && <9.8     , microlens >=0.4     , microlens-th >=0.4     , mtl >=2.2.1     , parser-combinators >=0.4.0     , pretty-simple >4 && <5+    , process     , regex-tdfa     , safe >=0.3.20     , tabular >=0.2@@ -217,7 +220,6 @@     , template-haskell     , terminal-size >=0.3.3     , text >=1.2.4.1-    , text-ansi >=0.2.1     , time >=1.5     , timeit     , transformers >=0.2@@ -225,13 +227,8 @@     , unordered-containers >=0.2     , utf8-string >=0.3.5   default-language: Haskell2010-  if (!(os(windows)))-    build-depends:-        pager >=0.1.1.0-  if (flag(ghcdebug))-    cpp-options: -DGHCDEBUG-    build-depends:-        ghc-debug-stub >=0.6.0.0 && <0.7+  if (flag(debug))+    cpp-options: -DDEBUG   if impl(ghc >= 9.0) && impl(ghc < 9.2)     buildable: False @@ -249,8 +246,9 @@     , aeson-pretty     , ansi-terminal >=0.9     , array-    , base >=4.14 && <4.20-    , base-compat+    , base >=4.14 && <4.21+    , base-compat >=0.14.0+    , blaze-html     , blaze-markup >=0.5.1     , bytestring     , call-stack@@ -261,7 +259,7 @@     , containers >=0.5.9     , data-default >=0.5     , deepseq-    , directory+    , directory >=1.2.6.1     , doclayout >=0.3 && <0.6     , extra >=1.6.3     , file-embed >=0.0.10@@ -269,12 +267,13 @@     , hashtables >=1.2.3.1     , hledger-lib     , lucid-    , megaparsec >=7.0.0 && <9.7+    , megaparsec >=7.0.0 && <9.8     , microlens >=0.4     , microlens-th >=0.4     , mtl >=2.2.1     , parser-combinators >=0.4.0     , pretty-simple >4 && <5+    , process     , regex-tdfa     , safe >=0.3.20     , tabular >=0.2@@ -283,7 +282,6 @@     , template-haskell     , terminal-size >=0.3.3     , text >=1.2.4.1-    , text-ansi >=0.2.1     , time >=1.5     , timeit     , transformers >=0.2@@ -292,10 +290,5 @@     , utf8-string >=0.3.5   buildable: True   default-language: Haskell2010-  if (!(os(windows)))-    build-depends:-        pager >=0.1.1.0-  if (flag(ghcdebug))-    cpp-options: -DGHCDEBUG-    build-depends:-        ghc-debug-stub >=0.6.0.0 && <0.7+  if (flag(debug))+    cpp-options: -DDEBUG