diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -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 diff --git a/Hledger/Data.hs b/Hledger/Data.hs --- a/Hledger/Data.hs +++ b/Hledger/Data.hs @@ -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 diff --git a/Hledger/Data/Account.hs b/Hledger/Data/Account.hs --- a/Hledger/Data/Account.hs +++ b/Hledger/Data/Account.hs @@ -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] {- diff --git a/Hledger/Data/AccountName.hs b/Hledger/Data/AccountName.hs --- a/Hledger/Data/AccountName.hs +++ b/Hledger/Data/AccountName.hs @@ -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 diff --git a/Hledger/Data/Amount.hs b/Hledger/Data/Amount.hs --- a/Hledger/Data/Amount.hs +++ b/Hledger/Data/Amount.hs @@ -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 diff --git a/Hledger/Data/Balancing.hs b/Hledger/Data/Balancing.hs --- a/Hledger/Data/Balancing.hs +++ b/Hledger/Data/Balancing.hs @@ -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 diff --git a/Hledger/Data/Currency.hs b/Hledger/Data/Currency.hs new file mode 100644 --- /dev/null +++ b/Hledger/Data/Currency.hs @@ -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" [] diff --git a/Hledger/Data/Errors.hs b/Hledger/Data/Errors.hs --- a/Hledger/Data/Errors.hs +++ b/Hledger/Data/Errors.hs @@ -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 diff --git a/Hledger/Data/Journal.hs b/Hledger/Data/Journal.hs --- a/Hledger/Data/Journal.hs +++ b/Hledger/Data/Journal.hs @@ -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, diff --git a/Hledger/Data/JournalChecks.hs b/Hledger/Data/JournalChecks.hs --- a/Hledger/Data/JournalChecks.hs +++ b/Hledger/Data/JournalChecks.hs @@ -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 () diff --git a/Hledger/Data/Ledger.hs b/Hledger/Data/Ledger.hs --- a/Hledger/Data/Ledger.hs +++ b/Hledger/Data/Ledger.hs @@ -97,7 +97,7 @@ -- | All commodities used in this ledger. ledgerCommodities :: Ledger -> [CommoditySymbol] -ledgerCommodities = M.keys . jinferredcommodities . ljournal +ledgerCommodities = M.keys . jinferredcommoditystyles . ljournal -- tests diff --git a/Hledger/Data/PeriodicTransaction.hs b/Hledger/Data/PeriodicTransaction.hs --- a/Hledger/Data/PeriodicTransaction.hs +++ b/Hledger/Data/PeriodicTransaction.hs @@ -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' diff --git a/Hledger/Data/Posting.hs b/Hledger/Data/Posting.hs --- a/Hledger/Data/Posting.hs +++ b/Hledger/Data/Posting.hs @@ -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 diff --git a/Hledger/Data/RawOptions.hs b/Hledger/Data/RawOptions.hs --- a/Hledger/Data/RawOptions.hs +++ b/Hledger/Data/RawOptions.hs @@ -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 diff --git a/Hledger/Data/Transaction.hs b/Hledger/Data/Transaction.hs --- a/Hledger/Data/Transaction.hs +++ b/Hledger/Data/Transaction.hs @@ -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 diff --git a/Hledger/Data/TransactionModifier.hs b/Hledger/Data/TransactionModifier.hs --- a/Hledger/Data/TransactionModifier.hs +++ b/Hledger/Data/TransactionModifier.hs @@ -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 diff --git a/Hledger/Data/Types.hs b/Hledger/Data/Types.hs --- a/Hledger/Data/Types.hs +++ b/Hledger/Data/Types.hs @@ -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) diff --git a/Hledger/Data/Valuation.hs b/Hledger/Data/Valuation.hs --- a/Hledger/Data/Valuation.hs +++ b/Hledger/Data/Valuation.hs @@ -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 diff --git a/Hledger/Query.hs b/Hledger/Query.hs --- a/Hledger/Query.hs +++ b/Hledger/Query.hs @@ -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 diff --git a/Hledger/Read.hs b/Hledger/Read.hs --- a/Hledger/Read.hs +++ b/Hledger/Read.hs @@ -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) diff --git a/Hledger/Read/Common.hs b/Hledger/Read/Common.hs --- a/Hledger/Read/Common.hs +++ b/Hledger/Read/Common.hs @@ -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) diff --git a/Hledger/Read/InputOptions.hs b/Hledger/Read/InputOptions.hs --- a/Hledger/Read/InputOptions.hs +++ b/Hledger/Read/InputOptions.hs @@ -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 diff --git a/Hledger/Read/JournalReader.hs b/Hledger/Read/JournalReader.hs --- a/Hledger/Read/JournalReader.hs +++ b/Hledger/Read/JournalReader.hs @@ -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 diff --git a/Hledger/Read/RulesReader.hs b/Hledger/Read/RulesReader.hs --- a/Hledger/Read/RulesReader.hs +++ b/Hledger/Read/RulesReader.hs @@ -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")] } ] } diff --git a/Hledger/Reports/AccountTransactionsReport.hs b/Hledger/Reports/AccountTransactionsReport.hs --- a/Hledger/Reports/AccountTransactionsReport.hs +++ b/Hledger/Reports/AccountTransactionsReport.hs @@ -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 diff --git a/Hledger/Reports/BalanceReport.hs b/Hledger/Reports/BalanceReport.hs --- a/Hledger/Reports/BalanceReport.hs +++ b/Hledger/Reports/BalanceReport.hs @@ -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" ,"--------------------" diff --git a/Hledger/Reports/EntriesReport.hs b/Hledger/Reports/EntriesReport.hs --- a/Hledger/Reports/EntriesReport.hs +++ b/Hledger/Reports/EntriesReport.hs @@ -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" [ diff --git a/Hledger/Reports/MultiBalanceReport.hs b/Hledger/Reports/MultiBalanceReport.hs --- a/Hledger/Reports/MultiBalanceReport.hs +++ b/Hledger/Reports/MultiBalanceReport.hs @@ -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 diff --git a/Hledger/Reports/PostingsReport.hs b/Hledger/Reports/PostingsReport.hs --- a/Hledger/Reports/PostingsReport.hs +++ b/Hledger/Reports/PostingsReport.hs @@ -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 diff --git a/Hledger/Reports/ReportOptions.hs b/Hledger/Reports/ReportOptions.hs --- a/Hledger/Reports/ReportOptions.hs +++ b/Hledger/Reports/ReportOptions.hs @@ -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 diff --git a/Hledger/Reports/ReportTypes.hs b/Hledger/Reports/ReportTypes.hs --- a/Hledger/Reports/ReportTypes.hs +++ b/Hledger/Reports/ReportTypes.hs @@ -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 diff --git a/Hledger/Utils.hs b/Hledger/Utils.hs --- a/Hledger/Utils.hs +++ b/Hledger/Utils.hs @@ -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)) diff --git a/Hledger/Utils/Debug.hs b/Hledger/Utils/Debug.hs --- a/Hledger/Utils/Debug.hs +++ b/Hledger/Utils/Debug.hs @@ -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. diff --git a/Hledger/Utils/IO.hs b/Hledger/Utils/IO.hs --- a/Hledger/Utils/IO.hs +++ b/Hledger/Utils/IO.hs @@ -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 - diff --git a/Hledger/Utils/Regex.hs b/Hledger/Utils/Regex.hs --- a/Hledger/Utils/Regex.hs +++ b/Hledger/Utils/Regex.hs @@ -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 diff --git a/Hledger/Write/Beancount.hs b/Hledger/Write/Beancount.hs new file mode 100644 --- /dev/null +++ b/Hledger/Write/Beancount.hs @@ -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. +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. +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; +-- 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, +-- 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" [ + ] diff --git a/Hledger/Write/Html.hs b/Hledger/Write/Html.hs --- a/Hledger/Write/Html.hs +++ b/Hledger/Write/Html.hs @@ -1,39 +1,38 @@ {-# LANGUAGE OverloadedStrings #-} {- | -Export spreadsheet table data as HTML table. - -This is derived from +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"] diff --git a/Hledger/Write/Html/Attribute.hs b/Hledger/Write/Html/Attribute.hs new file mode 100644 --- /dev/null +++ b/Hledger/Write/Html/Attribute.hs @@ -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" diff --git a/Hledger/Write/Html/Blaze.hs b/Hledger/Write/Html/Blaze.hs new file mode 100644 --- /dev/null +++ b/Hledger/Write/Html/Blaze.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE OverloadedStrings #-} +{- | +Export spreadsheet table data as HTML table. + +This is derived from +-} +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_ diff --git a/Hledger/Write/Html/Lucid.hs b/Hledger/Write/Html/Lucid.hs new file mode 100644 --- /dev/null +++ b/Hledger/Write/Html/Lucid.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE OverloadedStrings #-} +{- | +Export spreadsheet table data as HTML table. + +This is derived from +-} +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 diff --git a/Hledger/Write/Ods.hs b/Hledger/Write/Ods.hs --- a/Hledger/Write/Ods.hs +++ b/Hledger/Write/Ods.hs @@ -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'>" : "" : - " " : - " " : - " " : - " " : - " " : - " " : - " " : - " " : - " " : - " " : - " " : - " " : - " " : - " " : " " : " " : " -" : @@ -78,12 +70,9 @@ " -" : " " : " " : - " " : - " " : - " " : - " " : + " " : + " " : + " " : customStyles ++ "" : [] @@ -99,14 +88,14 @@ " " : " " : (fold $ - flip Map.mapWithKey tableNames $ \tableName (mTopRow,mLeftColumn) -> + flip Map.mapWithKey tableNames $ \tableName (topRow,leftColumn) -> printf " " tableName : - (flip foldMap mLeftColumn $ \leftColumn -> + ((guard (leftColumn>0) >>) $ " 2" : printf " %d" leftColumn : printf " %d" leftColumn : []) ++ - (flip foldMap mTopRow $ \topRow -> + ((guard (topRow>0) >>) $ " 2" : printf " %d" topRow : printf " %d" 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 " " $ + (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 = " " + alignTop = + " " + alignParagraph = + printf " " + 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 : [] - Total -> + _ -> printf " " style : - " " : + moreStyles ++ " " : [] -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 "%s" + (escape $ T.unpack $ Spr.cellAnchor cell) text + in - printf "" style valueType : - printf "%s" (escape $ T.unpack $ cellContent cell) : - "" : + printf "" covered style span_ valueType : + printf "%s" + (anchor $ escape $ T.unpack $ cellContent cell) : + printf "" 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 = diff --git a/Hledger/Write/Spreadsheet.hs b/Hledger/Write/Spreadsheet.hs --- a/Hledger/Write/Spreadsheet.hs +++ b/Hledger/Write/Spreadsheet.hs @@ -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} diff --git a/Text/Tabular/AsciiWide.hs b/Text/Tabular/AsciiWide.hs --- a/Text/Tabular/AsciiWide.hs +++ b/Text/Tabular/AsciiWide.hs @@ -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 diff --git a/hledger-lib.cabal b/hledger-lib.cabal --- a/hledger-lib.cabal +++ b/hledger-lib.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: hledger-lib -version: 1.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