hledger-lib 1.29.2 → 1.30

raw patch · 28 files changed

+3744/−1761 lines, 28 filesdep +terminal-sizedep ~megaparsecPVP ok

version bump matches the API change (PVP)

Dependencies added: terminal-size

Dependency ranges changed: megaparsec

API changes (from Hackage documentation)

Files

• CHANGES.md +41/−1
• Hledger/Data/Balancing.hs +20/−8
• Hledger/Data/Dates.hs +19/−7
• Hledger/Data/Errors.hs +10/−2
• Hledger/Data/Journal.hs +45/−24
• Hledger/Data/PeriodicTransaction.hs +11/−10
• Hledger/Data/Posting.hs +8/−4
• Hledger/Data/RawOptions.hs +8/−6
• Hledger/Data/Timeclock.hs +7/−7
• Hledger/Data/Transaction.hs +3/−3
• Hledger/Data/TransactionModifier.hs +22/−19
• Hledger/Data/Types.hs +3/−1
• Hledger/Query.hs +161/−65
• Hledger/Read.hs +2/−0
• Hledger/Read/Common.hs +18/−14
• Hledger/Read/CsvReader.hs +69/−1506
• Hledger/Read/CsvUtils.hs +49/−0
• Hledger/Read/InputOptions.hs +2/−0
• Hledger/Read/JournalReader.hs +5/−3
• Hledger/Read/RulesReader.hs +2994/−0
• Hledger/Read/TimeclockReader.hs +6/−6
• Hledger/Read/TimedotReader.hs +43/−34
• Hledger/Reports/BudgetReport.hs +2/−2
• Hledger/Reports/MultiBalanceReport.hs +12/−5
• Hledger/Reports/ReportOptions.hs +7/−5
• Hledger/Utils.hs +19/−1
• Hledger/Utils/IO.hs +152/−27
• hledger-lib.cabal +6/−1

@@ -5,10 +5,51 @@ | | | |_) | |_|_|_.__/             +Breaking changes++Misc. changes+nn --> Internal/api/developer-ish changes in the hledger-lib (and hledger) packages. For user-visible changes, see the hledger package changelog. +# 1.30 2023-06-01++Breaking changes++- dropped: Hledger.Data.RawOptions.inRawOpts++Misc. changes++- added more terminal size, ANSI style/color helpers in Hledger.Utils.IO+  (and therefore Hledger and Hledger.Cli.Script):++      getTerminalHeightWidth+      getTerminalHeight+      getTerminalWidth+      bold'+      faint'+      black'+      red'+      green'+      yellow'+      blue'+      magenta'+      cyan'+      white'+      brightBlack'+      brightRed'+      brightGreen'+      brightYellow'+      brightBlue'+      brightMagenta'+      brightCyan'+      brightWhite'+      rgb'+      multicol+      expandGlob+      sortByModTime+ # 1.29.2 2023-04-07  # 1.29.1 2023-03-16@@ -23,7 +64,6 @@ - Allow building with GHC 9.6.1; add base-compat (#2011)  # 1.29 2023-03-11- - added terminal colour detection helpers:   terminalIsLight   terminalLightness

@@ -35,6 +35,7 @@ import Data.Array.ST (STArray, getElems, newListArray, writeArray) import Data.Foldable (asum) import Data.Function ((&))+import Data.Functor ((<&>)) import "base-compat" Data.Functor.Compat (void) import qualified Data.HashTable.Class as H (toList) import qualified Data.HashTable.ST.Cuckoo as H@@ -239,6 +240,7 @@         minferredamt = case ptype p of           RegularPosting         | not (hasAmount p) -> Just realsum           BalancedVirtualPosting | not (hasAmount p) -> Just bvsum+          VirtualPosting         | not (hasAmount p) -> Just 0           _                                          -> Nothing       in         case minferredamt of@@ -504,9 +506,17 @@ balanceTransactionAndCheckAssertionsB (Right t@Transaction{tpostings=ps}) = do   -- make sure we can handle the balance assignments   mapM_ checkIllegalBalanceAssignmentB ps-  -- for each posting, infer its amount from the balance assignment if applicable,-  -- update the account's running balance and check the balance assertion if any-  ps' <- mapM (addOrAssignAmountAndCheckAssertionB . postingStripPrices) ps+  -- for each posting, in date order (though without disturbing their display order),+  -- 1. infer its amount from the balance assignment if applicable,+  -- 2. update the account's running balance, and+  -- 3. check the balance assertion if any.+  ps' <- ps+    & zip [1..]                 -- attach original positions+    & sortOn (postingDate.snd)  -- sort by date+    & mapM (addOrAssignAmountAndCheckAssertionB)  -- infer amount, check assertion on each one+    <&> sortOn fst              -- restore original order+    <&> map snd                 -- discard positions+   -- infer any remaining missing amounts, and make sure the transaction is now fully balanced   styles <- R.reader bsStyles   case balanceTransactionHelper defbalancingopts{commodity_styles_=styles} t{tpostings=ps'} of@@ -517,18 +527,20 @@       -- and save the balanced transaction.       updateTransactionB t' +type NumberedPosting = (Integer, Posting)+ -- | If this posting has an explicit amount, add it to the account's running balance. -- If it has a missing amount and a balance assignment, infer the amount from, and -- reset the running balance to, the assigned balance. -- If it has a missing amount and no balance assignment, leave it for later. -- Then test the balance assertion if any.-addOrAssignAmountAndCheckAssertionB :: Posting -> Balancing s Posting-addOrAssignAmountAndCheckAssertionB p@Posting{paccount=acc, pamount=amt, pbalanceassertion=mba}+addOrAssignAmountAndCheckAssertionB :: NumberedPosting -> Balancing s NumberedPosting+addOrAssignAmountAndCheckAssertionB (i,p@Posting{paccount=acc, pamount=amt, pbalanceassertion=mba})   -- an explicit posting amount   | hasAmount p = do       newbal <- addToRunningBalanceB acc amt       whenM (R.reader bsAssrt) $ checkBalanceAssertionB p newbal-      return p+      return (i,p)    -- no explicit posting amount, but there is a balance assignment   | Just BalanceAssertion{baamount,batotal,bainclusive} <- mba = do@@ -542,10 +554,10 @@       diff <- (if bainclusive then setInclusiveRunningBalanceB else setRunningBalanceB) acc newbal       let p' = p{pamount=filterMixedAmount (not . amountIsZero) diff, poriginal=Just $ originalPosting p}       whenM (R.reader bsAssrt) $ checkBalanceAssertionB p' newbal-      return p'+      return (i,p')    -- no explicit posting amount, no balance assignment-  | otherwise = return p+  | otherwise = return (i,p)  -- | Add the posting's amount to its account's running balance, and -- optionally check the posting's balance assertion if any.

@@ -235,8 +235,8 @@ splitSpan adjust (Months n)   ds = splitspan (if adjust then startofmonth   else id) addGregorianMonthsClip n     ds splitSpan adjust (Quarters n) ds = splitspan (if adjust then startofquarter else id) addGregorianMonthsClip (3*n) ds splitSpan adjust (Years n)    ds = splitspan (if adjust then startofyear    else id) addGregorianYearsClip n      ds-splitSpan _ (DayOfMonth n)  ds = splitspan (nthdayofmonthcontaining n)  addGregorianMonthsClip 1 ds-splitSpan _ (DayOfYear m n) ds = splitspan (nthdayofyearcontaining m n) addGregorianYearsClip 1 ds+splitSpan _ (DayOfMonth dom)  ds = splitspan (nthdayofmonthcontaining dom) (addGregorianMonthsToMonthday dom) 1 ds+splitSpan _ (DayOfYear m n)   ds = splitspan (nthdayofyearcontaining m n) (addGregorianYearsClip) 1 ds splitSpan _ (WeekdayOfMonth n wd) ds = splitspan (nthweekdayofmonthcontaining n wd) advancemonths 1 ds   where     advancemonths 0 = id@@ -249,9 +249,21 @@     -- The first representative of each weekday     starts = map (\d -> addDays (toInteger $ d - n) $ nthdayofweekcontaining n s) days +-- Like addGregorianMonthsClip, add one month to the given date, clipping when needed+-- to fit it within the next month's length. But also, keep a target day of month in mind,+-- and revert to that or as close to it as possible in subsequent longer months.+-- Eg, using it to step through 31sts gives 1/31, 2/28, 3/31, 4/30, 5/31..+addGregorianMonthsToMonthday :: MonthDay -> Integer -> Day -> Day+addGregorianMonthsToMonthday dom n d =+  let (y,m,_) = toGregorian $ addGregorianMonthsClip n d+  in fromGregorian y m dom+ -- Split the given span into exact spans using the provided helper functions:--- the start function is applied to the span's start date to get the first sub-span's start date--- the addInterval function is applied to an integer n (multiplying it by mult) and the span's start date to get the nth sub-span's start date+-- 1. The start function is applied to the span's start date to get the first sub-span's start date.+-- 2. The addInterval function is used to calculate the subsequent spans' start dates,+-- possibly with stride increased by the mult multiplier.+-- It should adapt to spans of varying length, eg if splitting on "every 31st of month"+-- addInterval should adjust to 28/29/30 in short months but return to 31 in the long months. splitspan :: (Day -> Day) -> (Integer -> Day -> Day) -> Int -> DateSpan -> [DateSpan] splitspan start addInterval mult ds = spansFromBoundaries e bdrys   where@@ -610,9 +622,9 @@         mmddOfPrevYear = addDays (toInteger mdy-1) $ applyN (m-1) nextmonth $ prevyear s         s = startofyear date --- | For given date d find month-long interval that starts on nth day of month--- and covers it.--- The given day of month should be basically valid (1-31), or an error is raised.+-- | For a given date d find the month-long period that starts on day n of a month+-- that includes d. (It will begin on day n or either d's month or the previous month.)+-- The given day of month should be in the range 1-31, or an error will be raised. -- -- Examples: lets take 2017-11-22. Month-long intervals covering it that -- start on 1st-22nd of month will start in Nov. However

@@ -118,9 +118,17 @@     Just t  -> (f, errabsline, merrcols, ex)       where         (SourcePos f tl _) = fst $ tsourcepos t-        tcommentlines = max 0 (length (T.lines $ tcomment t) - 1)         mpindex = transactionFindPostingIndex (==p) t-        errrelline = maybe 0 (tcommentlines+) mpindex   -- XXX doesn't count posting coment lines+        errrelline = case mpindex of+          Nothing -> 0+          Just pindex ->+            commentExtraLines (tcomment t) + +            sum (map postingLines $ take pindex $ tpostings t)+            where+              -- How many lines are used to render this posting ?+              postingLines p' = 1 + commentExtraLines (pcomment p')+              -- How many extra lines does this comment add to a transaction or posting rendering ?+              commentExtraLines c = max 0 (length (T.lines c) - 1)         errabsline = unPos tl + errrelline         txntxt = showTransaction t & textChomp & (<>"\n")         merrcols = findpostingerrorcolumns p t txntxt

@@ -3,6 +3,7 @@ {-# LANGUAGE Rank2Types          #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections       #-}+{-# LANGUAGE RecordWildCards #-}  {-| @@ -122,8 +123,8 @@ import qualified Data.Set as S import Data.Text (Text) import qualified Data.Text as T-import Safe (headMay, headDef, maximumMay, minimumMay)-import Data.Time.Calendar (Day, addDays, fromGregorian)+import Safe (headMay, headDef, maximumMay, minimumMay, lastDef)+import Data.Time.Calendar (Day, addDays, fromGregorian, diffDays) import Data.Time.Clock.POSIX (POSIXTime) import Data.Tree (Tree(..), flatten) import Text.Printf (printf)@@ -140,6 +141,9 @@ import Hledger.Data.Valuation import Hledger.Query import System.FilePath (takeFileName)+import Data.Ord (comparing)+import Hledger.Data.Dates (nulldate)+import Data.List (sort)   -- | A parser of text that runs in some monad, keeping a Journal as state.@@ -429,20 +433,38 @@     as = a : parentAccountNames a -- PERF: cache in journal ? +type DateWeightedSimilarityScore = Double+type SimilarityScore = Double+type Age = Integer+ -- | Find up to N most similar and most recent transactions matching--- the given transaction description and query. Transactions are--- listed with their description's similarity score (see--- compareDescriptions), sorted by highest score and then by date.--- Only transactions with a similarity score greater than a minimum--- threshold (currently 0) are returned.-journalTransactionsSimilarTo :: Journal -> Query -> Text -> Int -> [(Double,Transaction)]-journalTransactionsSimilarTo Journal{jtxns} q desc n =+-- the given transaction description and query and exceeding the given+-- description similarity score (0 to 1, see compareDescriptions).+-- Returns transactions along with+-- their age in days compared to the latest transaction date,+-- their description similarity score,+-- and a heuristically date-weighted variant of this that favours more recent transactions.+journalTransactionsSimilarTo :: Journal -> Text -> Query -> SimilarityScore -> Int+  -> [(DateWeightedSimilarityScore, Age, SimilarityScore, Transaction)]+journalTransactionsSimilarTo Journal{jtxns} desc q similaritythreshold n =   take n $-  sortBy (\(s1,t1) (s2,t2) -> compare (s2,tdate t2) (s1,tdate t1)) $-  filter ((> threshold).fst)+  dbg1With (+    unlines . +    ("up to 30 transactions above description similarity threshold "<>show similaritythreshold<>" ordered by recency-weighted similarity:":) .+    take 30 .+    map ( \(w,a,s,Transaction{..}) -> printf "weighted:%8.3f  age:%4d similarity:%5.3f  %s %s" w a s (show tdate) tdescription )) $+  sortBy (comparing (negate.first4)) $+  map (\(s,t) -> (weightedScore (s,t), age t, s, t)) $+  filter ((> similaritythreshold).fst)   [(compareDescriptions desc $ tdescription t, t) | t <- jtxns, q `matchesTransaction` t]   where-    threshold = 0+    latest = lastDef nulldate $ sort $ map tdate jtxns+    age = diffDays latest . tdate+    -- Combine similarity and recency heuristically. This gave decent results+    -- in my "find most recent invoice" use case in 2023-03,+    -- but will probably need more attention.+    weightedScore :: (Double, Transaction) -> Double+    weightedScore (s, t) = 100 * s - fromIntegral (age t) / 4  -- | Return a similarity score from 0 to 1.5 for two transaction descriptions.  -- This is based on compareStrings, with the following modifications:@@ -763,13 +785,12 @@ -- postings to transactions, eg). Or if a modifier rule fails to parse, -- return the error message. A reference date is provided to help interpret -- relative dates in transaction modifier queries.-journalModifyTransactions :: Day -> Journal -> Either String Journal-journalModifyTransactions d j =-    case modifyTransactions (journalAccountType j) (journalInheritedAccountTags j) (journalCommodityStyles j) d (jtxnmodifiers j) (jtxns j) of-      Right ts -> Right j{jtxns=ts}-      Left err -> Left err----+-- The first argument selects whether to add visible tags to generated postings & modified transactions.+journalModifyTransactions :: Bool -> Day -> Journal -> Either String Journal+journalModifyTransactions verbosetags d j =+  case modifyTransactions (journalAccountType j) (journalInheritedAccountTags j) (journalCommodityStyles j) d verbosetags (jtxnmodifiers j) (jtxns j) of+    Right ts -> Right j{jtxns=ts}+    Left err -> Left err  -- | Choose and apply a consistent display style to the posting -- amounts in each commodity (see journalCommodityStyles).@@ -895,8 +916,8 @@     styles = journalCommodityStyles j  -- | Add inferred equity postings to a 'Journal' using transaction prices.-journalAddInferredEquityPostings :: Journal -> Journal-journalAddInferredEquityPostings j = journalMapTransactions (transactionAddInferredEquityPostings equityAcct) j+journalAddInferredEquityPostings :: Bool -> Journal -> Journal+journalAddInferredEquityPostings verbosetags j = journalMapTransactions (transactionAddInferredEquityPostings verbosetags equityAcct) j   where     equityAcct = journalConversionAccount j @@ -963,17 +984,17 @@  -- overcomplicated/unused amount traversal stuff ----- | Get an ordered list of 'AmountStyle's from the amounts in this+--  Get an ordered list of 'AmountStyle's from the amounts in this -- journal which influence canonical amount display styles. See -- traverseJournalAmounts. -- journalAmounts :: Journal -> [Amount] -- journalAmounts = getConst . traverseJournalAmounts (Const . (:[])) ----- | Apply a transformation to the journal amounts traversed by traverseJournalAmounts.+--  Apply a transformation to the journal amounts traversed by traverseJournalAmounts. -- overJournalAmounts :: (Amount -> Amount) -> Journal -> Journal -- overJournalAmounts f = runIdentity . traverseJournalAmounts (Identity . f) ----- | A helper that traverses over most amounts in the journal,+--  A helper that traverses over most amounts in the journal, -- in particular the ones which influence canonical amount display styles, -- processing them with the given applicative function. --

@@ -11,6 +11,7 @@ ) where +import Data.Function ((&)) import Data.Maybe (isNothing) import qualified Data.Text as T import qualified Data.Text.IO as T@@ -34,7 +35,7 @@     t = T.pack str     (i,s) = parsePeriodExpr' nulldate t   mapM_ (T.putStr . showTransaction) $-    runPeriodicTransaction+    runPeriodicTransaction True       nullperiodictransaction{ ptperiodexpr=t , ptspan=s, ptinterval=i, ptpostings=["a" `post` usd 1] }       nulldatespan @@ -43,7 +44,7 @@     t = T.pack str     (i,s) = parsePeriodExpr' nulldate t   mapM_ (T.putStr . showTransaction) $-    runPeriodicTransaction+    runPeriodicTransaction True       nullperiodictransaction{ ptperiodexpr=t , ptspan=s, ptinterval=i, ptpostings=["a" `post` usd 1] }       spn @@ -186,7 +187,7 @@ --     a           $1.00 -- <BLANKLINE> ----- >>> let reportperiod="daily from 2018/01/03" in let (i,s) = parsePeriodExpr' nulldate reportperiod in runPeriodicTransaction (nullperiodictransaction{ptperiodexpr=reportperiod, ptspan=s, ptinterval=i, ptpostings=["a" `post` usd 1]}) (DateSpan (Just $ Flex $ fromGregorian 2018 01 01) (Just $ Flex $ fromGregorian 2018 01 03))+-- >>> let reportperiod="daily from 2018/01/03" in let (i,s) = parsePeriodExpr' nulldate reportperiod in runPeriodicTransaction True (nullperiodictransaction{ptperiodexpr=reportperiod, ptspan=s, ptinterval=i, ptpostings=["a" `post` usd 1]}) (DateSpan (Just $ Flex $ fromGregorian 2018 01 01) (Just $ Flex $ fromGregorian 2018 01 03)) -- [] -- -- >>> _ptgenspan "every 3 months from 2019-05" (DateSpan (Just $ Flex $ fromGregorian 2020 01 01) (Just $ Flex $ fromGregorian 2020 02 01))@@ -211,8 +212,8 @@ --     a           $1.00 -- <BLANKLINE> -runPeriodicTransaction :: PeriodicTransaction -> DateSpan -> [Transaction]-runPeriodicTransaction PeriodicTransaction{..} requestedspan =+runPeriodicTransaction :: Bool -> PeriodicTransaction -> DateSpan -> [Transaction]+runPeriodicTransaction verbosetags PeriodicTransaction{..} requestedspan =     [ t{tdate=d} | (DateSpan (Just efd) _) <- alltxnspans, let d = fromEFDay efd, spanContainsDate requestedspan d ]   where     t = nulltransaction{@@ -220,11 +221,11 @@           ,tstatus      = ptstatus           ,tcode        = ptcode           ,tdescription = ptdescription-          ,tcomment     = ptcomment-                          `commentAddTagNextLine` ("generated-transaction",period)-          ,ttags        = ("_generated-transaction",period) :-                          ("generated-transaction" ,period) :-                          pttags+          ,tcomment     = ptcomment &+            (if verbosetags then (`commentAddTagNextLine` ("generated-transaction",period)) else id)+          ,ttags        = pttags &+            (("_generated-transaction",period) :) &+            (if verbosetags then (("generated-transaction" ,period) :) else id)           ,tpostings    = ptpostings           }     period = "~ " <> ptperiodexpr

@@ -74,6 +74,7 @@  import Data.Default (def) import Data.Foldable (asum)+import Data.Function ((&)) import qualified Data.Map as M import Data.Maybe (fromMaybe, isJust, mapMaybe) import Data.List (foldl', sort, union)@@ -439,8 +440,8 @@ -- | Generate inferred equity postings from a 'Posting' using transaction prices. -- Make sure not to generate equity postings when there are already matched -- conversion postings.-postingAddInferredEquityPostings :: Text -> Posting -> [Posting]-postingAddInferredEquityPostings equityAcct p+postingAddInferredEquityPostings :: Bool -> Text -> Posting -> [Posting]+postingAddInferredEquityPostings verbosetags equityAcct p     | "_price-matched" `elem` map fst (ptags p) = [p]     | otherwise = taggedPosting : concatMap conversionPostings priceAmounts   where@@ -460,8 +461,11 @@         cost = amountCost amt         amtCommodity  = commodity amt         costCommodity = commodity cost-        cp = p{ pcomment = pcomment p `commentAddTag` ("generated-posting","")-              , ptags = [("_conversion-matched", ""), ("generated-posting", ""), ("_generated-posting", "")]+        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               }

@@ -13,8 +13,8 @@   setboolopt,   unsetboolopt,   appendopts,-  inRawOpts,   boolopt,+  toggleopt,   choiceopt,   collectopts,   stringopt,@@ -56,12 +56,14 @@ appendopts :: [(String,String)] -> RawOpts -> RawOpts appendopts new = overRawOpts (++new) --- | Is the named option present ?-inRawOpts :: String -> RawOpts -> Bool-inRawOpts name = isJust . lookup name . unRawOpts-+-- | Is the named flag present ? boolopt :: String -> RawOpts -> Bool-boolopt = inRawOpts+boolopt name = isJust . lookup name . unRawOpts++-- | Like boolopt, except if the flag is repeated on the command line it toggles the value.+-- An even number of repetitions is equivalent to none.+toggleopt :: String -> RawOpts -> Bool+toggleopt name rawopts = odd $ length [ n | (n,_) <- unRawOpts rawopts, n==name]  -- | From a list of RawOpts, get the last one (ie the right-most on the command line) -- for which the given predicate returns a Just value.

@@ -57,7 +57,7 @@     | odate > idate = entryFromTimeclockInOut i o' : timeclockEntriesToTransactions now [i',o]     | otherwise = [entryFromTimeclockInOut i o]     where-      o = TimeclockEntry (tlsourcepos i) Out end "" ""+      o = TimeclockEntry (tlsourcepos i) Out end "" "" "" []       end = if itime > now then itime else now       (itime,otime) = (tldatetime i,tldatetime o)       (idate,odate) = (localDay itime,localDay otime)@@ -120,8 +120,8 @@             tstatus      = Cleared,             tcode        = "",             tdescription = desc,-            tcomment     = "",-            ttags        = [],+            tcomment     = tlcomment i,+            ttags        = tltags i,             tpostings    = ps,             tprecedingcomment=""           }@@ -162,11 +162,11 @@           future = utcToLocalTime tz $ addUTCTime 100 now'           futurestr = showtime future       step "started yesterday, split session at midnight"-      txndescs [clockin (mktime yesterday "23:00:00") "" ""] @?= ["23:00-23:59","00:00-"++nowstr]+      txndescs [clockin (mktime yesterday "23:00:00") "" "" "" []] @?= ["23:00-23:59","00:00-"++nowstr]       step "split multi-day sessions at each midnight"-      txndescs [clockin (mktime (addDays (-2) today) "23:00:00") "" ""] @?= ["23:00-23:59","00:00-23:59","00:00-"++nowstr]+      txndescs [clockin (mktime (addDays (-2) today) "23:00:00") "" "" "" []] @?= ["23:00-23:59","00:00-23:59","00:00-"++nowstr]       step "auto-clock-out if needed"-      txndescs [clockin (mktime today "00:00:00") "" ""] @?= ["00:00-"++nowstr]+      txndescs [clockin (mktime today "00:00:00") "" "" "" []] @?= ["00:00-"++nowstr]       step "use the clockin time for auto-clockout if it's in the future"-      txndescs [clockin future "" ""] @?= [printf "%s-%s" futurestr futurestr]+      txndescs [clockin future "" "" "" []] @?= [printf "%s-%s" futurestr futurestr]  ]

@@ -222,9 +222,9 @@ transactionToCost styles cost t = t{tpostings = mapMaybe (postingToCost styles cost) $ tpostings t}  -- | Add inferred equity postings to a 'Transaction' using transaction prices.-transactionAddInferredEquityPostings :: AccountName -> Transaction -> Transaction-transactionAddInferredEquityPostings equityAcct t =-    t{tpostings=concatMap (postingAddInferredEquityPostings equityAcct) $ tpostings t}+transactionAddInferredEquityPostings :: Bool -> AccountName -> Transaction -> Transaction+transactionAddInferredEquityPostings verbosetags equityAcct t =+    t{tpostings=concatMap (postingAddInferredEquityPostings verbosetags equityAcct) $ tpostings t}  type IdxPosting = (Int, Posting) 

@@ -14,6 +14,7 @@  import Prelude hiding (Applicative(..)) import Control.Applicative (Applicative(..), (<|>))+import Data.Function ((&)) import qualified Data.Map as M import Data.Maybe (catMaybes) import qualified Data.Text as T@@ -40,17 +41,20 @@ modifyTransactions :: (AccountName -> Maybe AccountType)                    -> (AccountName -> [Tag])                    -> M.Map CommoditySymbol AmountStyle-                   -> Day -> [TransactionModifier] -> [Transaction]+                   -> Day -> Bool -> [TransactionModifier] -> [Transaction]                    -> Either String [Transaction]-modifyTransactions atypes atags styles d tmods ts = do-  fs <- mapM (transactionModifierToFunction atypes atags styles d) tmods  -- convert modifiers to functions, or return a parse error+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''       where         t' = foldr (flip (.)) id fs t  -- apply each function in turn-        t'' = if t' == t  -- and add some tags if it was changed+        t'' = if t' == t               then t'-              else t'{tcomment=tcomment t' `commentAddTag` ("modified",""), ttags=("modified","") : ttags 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  -- | Converts a 'TransactionModifier' to a 'Transaction'-transforming function@@ -67,7 +71,7 @@ -- >>> import qualified Data.Text.IO as T -- >>> t = nulltransaction{tpostings=["ping" `post` usd 1]} -- >>> tmpost acc amt = TMPostingRule (acc `post` amt) False--- >>> test = either putStr (T.putStr.showTransaction) . fmap ($ t) . transactionModifierToFunction (const Nothing) (const []) mempty nulldate+-- >>> test = either putStr (T.putStr.showTransaction) . fmap ($ t) . transactionModifierToFunction (const Nothing) (const []) mempty nulldate True -- >>> test $ TransactionModifier "" ["pong" `tmpost` usd 2] -- 0000-01-01 --     ping           $1.00@@ -86,12 +90,12 @@ transactionModifierToFunction :: (AccountName -> Maybe AccountType)                               -> (AccountName -> [Tag])                               -> M.Map CommoditySymbol AmountStyle-                              -> Day -> TransactionModifier+                              -> Day -> Bool -> TransactionModifier                               -> Either String (Transaction -> Transaction)-transactionModifierToFunction atypes atags styles refdate TransactionModifier{tmquerytxt, tmpostingrules} = do+transactionModifierToFunction atypes atags styles refdate verbosetags TransactionModifier{tmquerytxt, tmpostingrules} = do   q <- simplifyQuery . fst <$> parseQuery refdate tmquerytxt   let-    fs = map (\tmpr -> addAccountTags . tmPostingRuleToFunction styles q tmquerytxt tmpr) tmpostingrules+    fs = map (\tmpr -> addAccountTags . tmPostingRuleToFunction verbosetags styles q tmquerytxt tmpr) tmpostingrules     addAccountTags p = p `postingAddTags` atags (paccount p)     generatePostings p = p : map ($ p) (if matchesPostingExtra atypes q p then fs else [])   Right $ \t@(tpostings -> ps) -> txnTieKnot t{tpostings=concatMap generatePostings ps}@@ -100,20 +104,19 @@ -- which will be used to make a new posting based on the old one (an "automated posting"). -- The new posting's amount can optionally be the old posting's amount multiplied by a constant. -- If the old posting had a total-priced amount, the new posting's multiplied amount will be unit-priced.--- The new posting will have two tags added: a normal generated-posting: tag which also appears in the comment,--- and a hidden _generated-posting: tag which does not.--- The TransactionModifier's query text is also provided, and saved--- as the tags' value.-tmPostingRuleToFunction :: M.Map CommoditySymbol AmountStyle -> Query -> T.Text -> TMPostingRule -> (Posting -> Posting)-tmPostingRuleToFunction styles query querytxt tmpr =+-- The new posting will have a hidden _generated-posting: tag added,+-- and with a true first argument, also a visible generated-posting: tag.+-- The provided TransactionModifier's query text is saved as the tags' value.+tmPostingRuleToFunction :: Bool -> M.Map CommoditySymbol AmountStyle -> Query -> T.Text -> TMPostingRule -> (Posting -> Posting)+tmPostingRuleToFunction verbosetags styles query querytxt tmpr =   \p -> postingApplyCommodityStyles styles . renderPostingCommentDates $ pr       { pdate    = pdate  pr <|> pdate  p       , pdate2   = pdate2 pr <|> pdate2 p       , pamount  = amount' p-      , pcomment = pcomment pr `commentAddTag` ("generated-posting",qry)-      , ptags    = ("generated-posting", qry) :-                   ("_generated-posting",qry) :-                   ptags pr+      , pcomment = pcomment pr & (if verbosetags then (`commentAddTag` ("generated-posting",qry)) else id)+      , ptags    = ptags pr+                   & (("_generated-posting",qry) :)+                   & (if verbosetags then (("generated-posting", qry) :) else id)       }   where     pr = tmprPosting tmpr

@@ -504,7 +504,9 @@       tlcode        :: TimeclockCode,       tldatetime    :: LocalTime,       tlaccount     :: AccountName,-      tldescription :: Text+      tldescription :: Text,+      tlcomment     :: Text,+      tltags        :: [Tag]     } deriving (Eq,Ord,Generic)  -- | A market price declaration made by the journal format's P directive.

@@ -8,6 +8,7 @@ {-# LANGUAGE FlexibleContexts   #-} {-# LANGUAGE OverloadedStrings  #-} {-# LANGUAGE ViewPatterns       #-}+{-# LANGUAGE TupleSections      #-}  module Hledger.Query (   -- * Query and QueryOpt@@ -75,16 +76,17 @@  import Control.Applicative ((<|>), many, optional) import Data.Default (Default(..))-import Data.Either (fromLeft, partitionEithers)+import Data.Either (partitionEithers) import Data.List (partition, intercalate) import Data.Maybe (fromMaybe, isJust, mapMaybe) import Data.Text (Text) import qualified Data.Text as T import Data.Time.Calendar (Day, fromGregorian ) import Safe (readDef, readMay, maximumByMay, maximumMay, minimumMay)-import Text.Megaparsec (between, noneOf, sepBy)-import Text.Megaparsec.Char (char, string)+import Text.Megaparsec (between, noneOf, sepBy, try, (<?>), notFollowedBy)+import Text.Megaparsec.Char (char, string, string') + import Hledger.Utils hiding (words') import Hledger.Data.Types import Hledger.Data.AccountName@@ -161,17 +163,6 @@ -- whitespace, it (or the whole term including prefix) should be enclosed -- in single or double quotes. ----- >>> parseQuery nulldate "expenses:dining out"--- Right (Or [Acct (RegexpCI "expenses:dining"),Acct (RegexpCI "out")],[])------ >>> parseQuery nulldate "\"expenses:dining out\""--- Right (Acct (RegexpCI "expenses:dining out"),[])-parseQuery :: Day -> T.Text -> Either String (Query,[QueryOpt])-parseQuery d = parseQueryList d . words'' queryprefixes---- | Convert a list of query expression containing to a query and zero--- or more query options; or return an error message if query parsing fails.--- -- A query term is either: -- -- 1. a search pattern, which matches on one or more fields, eg:@@ -191,6 +182,16 @@ -- Period expressions may contain relative dates, so a reference date is -- required to fully parse these. --+-- >>> parseQuery nulldate "expenses:dining out"+-- Right (Or [Acct (RegexpCI "expenses:dining"),Acct (RegexpCI "out")],[])+--+-- >>> parseQuery nulldate "\"expenses:dining out\""+-- Right (Acct (RegexpCI "expenses:dining out"),[])+parseQuery :: Day -> T.Text -> Either String (Query,[QueryOpt])+parseQuery d t = parseQueryList d $ words'' queryprefixes t++-- | Convert a list of space-separated queries to a single query+-- -- Multiple terms are combined as follows: -- 1. multiple account patterns are OR'd together -- 2. multiple description patterns are OR'd together@@ -199,22 +200,28 @@ parseQueryList :: Day -> [T.Text] -> Either String (Query, [QueryOpt]) parseQueryList d termstrs = do   eterms <- mapM (parseQueryTerm d) termstrs-  let (pats, opts) = partitionEithers eterms-      (descpats, pats') = partition queryIsDesc pats-      (acctpats, pats'') = partition queryIsAcct pats'-      (statuspats, otherpats) = partition queryIsStatus pats''-      q = simplifyQuery $ And $ [Or acctpats, Or descpats, Or statuspats] ++ otherpats-  Right (q, opts)+  let (pats, optss) = unzip eterms+      q = combineQueryList pats+  Right (q, concat optss) +combineQueryList :: [Query] -> Query+combineQueryList pats = q+  where+    (descpats, pats') = partition queryIsDesc pats+    (acctpats, pats'') = partition queryIsAcct pats'+    (statuspats, otherpats) = partition queryIsStatus pats''+    q = simplifyQuery $ And $ [Or acctpats, Or descpats, Or statuspats] ++ otherpats+   -- XXX -- | Quote-and-prefix-aware version of words - don't split on spaces which -- are inside quotes, including quotes which may have one of the specified -- prefixes in front, and maybe an additional not: prefix in front of that. words'' :: [T.Text] -> T.Text -> [T.Text]-words'' prefixes = fromparse . parsewith maybeprefixedquotedphrases -- XXX-    where-      maybeprefixedquotedphrases :: SimpleTextParser [T.Text]-      maybeprefixedquotedphrases = choice' [prefixedQuotedPattern, singleQuotedPattern, doubleQuotedPattern, patterns] `sepBy` skipNonNewlineSpaces1+words'' prefixes = fromparse . parsewith maybePrefixedQuotedPhrases -- XXX+   where+      maybePrefixedQuotedPhrases :: SimpleTextParser [T.Text]+      maybePrefixedQuotedPhrases = choice' [prefixedQuotedPattern, singleQuotedPattern, doubleQuotedPattern, patterns] `sepBy`+          (notFollowedBy (skipNonNewlineSpaces >> char ')') >> skipNonNewlineSpaces1)       prefixedQuotedPattern :: SimpleTextParser T.Text       prefixedQuotedPattern = do         not' <- fromMaybe "" `fmap` (optional $ string "not:")@@ -253,6 +260,7 @@     ,"depth"     ,"tag"     ,"type"+    ,"expr"     ]  defaultprefix :: T.Text@@ -270,41 +278,109 @@  -- | Parse a single query term as either a query or a query option, -- or return an error message if parsing fails.-parseQueryTerm :: Day -> T.Text -> Either String (Either Query QueryOpt)-parseQueryTerm _ (T.stripPrefix "inacctonly:" -> Just s) = Right $ Right $ QueryOptInAcctOnly s-parseQueryTerm _ (T.stripPrefix "inacct:" -> Just s) = Right $ Right $ QueryOptInAcct s+parseQueryTerm :: Day -> T.Text -> Either String (Query, [QueryOpt])+parseQueryTerm _ (T.stripPrefix "inacctonly:" -> Just s) = Right (Any, [QueryOptInAcctOnly s])+parseQueryTerm _ (T.stripPrefix "inacct:" -> Just s) = Right (Any, [QueryOptInAcct s]) parseQueryTerm d (T.stripPrefix "not:" -> Just s) =   case parseQueryTerm d s of-    Right (Left m)  -> Right $ Left $ Not m-    Right (Right _) -> Right $ Left Any -- not:somequeryoption will be ignored-    Left err        -> Left err-parseQueryTerm _ (T.stripPrefix "code:" -> Just s) = Left . Code <$> toRegexCI s-parseQueryTerm _ (T.stripPrefix "desc:" -> Just s) = Left . Desc <$> toRegexCI s-parseQueryTerm _ (T.stripPrefix "payee:" -> Just s) = Left <$> payeeTag (Just s)-parseQueryTerm _ (T.stripPrefix "note:" -> Just s) = Left <$> noteTag (Just s)-parseQueryTerm _ (T.stripPrefix "acct:" -> Just s) = Left . Acct <$> toRegexCI s+    Right (q, qopts) -> Right (Not q, qopts)+    Left err         -> Left err+parseQueryTerm _ (T.stripPrefix "code:" -> Just s) = (,[]) . Code <$> toRegexCI s+parseQueryTerm _ (T.stripPrefix "desc:" -> Just s) = (,[]) . Desc <$> toRegexCI s+parseQueryTerm _ (T.stripPrefix "payee:" -> Just s) = (,[]) <$> payeeTag (Just s)+parseQueryTerm _ (T.stripPrefix "note:" -> Just s) = (,[]) <$> noteTag (Just s)+parseQueryTerm _ (T.stripPrefix "acct:" -> Just s) = (,[]) . Acct <$> toRegexCI s parseQueryTerm d (T.stripPrefix "date2:" -> Just s) =         case parsePeriodExpr d s of Left e         -> Left $ "\"date2:"++T.unpack s++"\" gave a "++showDateParseError e-                                    Right (_,spn) -> Right $ Left $ Date2 spn+                                    Right (_,spn) -> Right (Date2 spn, []) parseQueryTerm d (T.stripPrefix "date:" -> Just s) =         case parsePeriodExpr d s of Left e         -> Left $ "\"date:"++T.unpack s++"\" gave a "++showDateParseError e-                                    Right (_,spn) -> Right $ Left $ Date spn+                                    Right (_,spn) -> Right (Date spn, []) parseQueryTerm _ (T.stripPrefix "status:" -> Just s) =         case parseStatus s of Left e   -> Left $ "\"status:"++T.unpack s++"\" gave a parse error: " ++ e-                              Right st -> Right $ Left $ StatusQ st-parseQueryTerm _ (T.stripPrefix "real:" -> Just s) = Right $ Left $ Real $ parseBool s || T.null s-parseQueryTerm _ (T.stripPrefix "amt:" -> Just s) = Right $ Left $ Amt ord q where (ord, q) = either error id $ parseAmountQueryTerm s  -- PARTIAL:+                              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 $ Left $ Depth n+  | n >= 0    = Right (Depth n, [])   | otherwise = Left "depth: should have a positive number"   where n = readDef 0 (T.unpack s) -parseQueryTerm _ (T.stripPrefix "cur:" -> Just s) = Left . Sym <$> toRegexCI ("^" <> s <> "$") -- support cur: as an alias-parseQueryTerm _ (T.stripPrefix "tag:" -> Just s) = Left <$> parseTag s-parseQueryTerm _ (T.stripPrefix "type:" -> Just s) = Left <$> parseTypeCodes s-parseQueryTerm _ "" = Right $ Left $ Any+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+parseQueryTerm d (T.stripPrefix "expr:" -> Just s) = parseBooleanQuery d s+parseQueryTerm _ "" = Right (Any, []) parseQueryTerm d s = parseQueryTerm d $ defaultprefix<>":"<>s +-- | Parses a boolean query expression.+--+-- Boolean queries combine smaller queries into larger ones. The boolean operators+-- made available through this function are "NOT e", "e AND e", "e OR e", and "e e".+-- Query options defined in multiple sub-queries are simply combined by concatenating+-- all options into one list.+--+-- Boolean operators in queries take precedence over one another. For instance, the+-- prefix-operator "NOT e" is always parsed before "e AND e", "e AND e" before "e OR e",+-- and "e OR e" before "e e".+--+-- The space-separation operator is left as it was the default before the introduction of+-- boolean operators. It takes the behaviour defined in the interpretQueryList function,+-- whereas the NOT, OR, and AND operators simply wrap a list of queries with the associated+--+--+-- The result of this function is either an error encountered during parsing of the+-- expression or the combined query and query options.+--+-- >>> parseBooleanQuery nulldate "expenses:dining AND out"+-- Right (And [Acct (RegexpCI "expenses:dining"),Acct (RegexpCI "out")],[])+--+-- >>> parseBooleanQuery nulldate "expenses:dining AND desc:a OR desc:b"+-- Right (Or [And [Acct (RegexpCI "expenses:dining"),Desc (RegexpCI "a")],Desc (RegexpCI "b")],[])+parseBooleanQuery :: Day -> T.Text -> Either String (Query,[QueryOpt])+parseBooleanQuery d t = either (Left . ("failed to parse query:" <>) . customErrorBundlePretty) Right $ parsewith spacedQueriesP t+  where+    regexP       :: SimpleTextParser T.Text+    regexP       = choice'+      [ stripquotes . T.pack <$> between (char '\'') (char '\'') (many $ noneOf ("'" :: [Char])),+        stripquotes . T.pack <$> between (char '"') (char '"') (many $ noneOf ("\"" :: [Char])),+        T.pack <$> (notFollowedBy keywordSpaceP >> (many $ noneOf (") \n\r" :: [Char]))) ]+    queryPrefixP :: SimpleTextParser T.Text+    queryPrefixP = (string "not:" <> (fromMaybe "" <$> optional queryPrefixP))+               <|> choice' (string <$> queryprefixes)+               <?> "query prefix"+    queryTermP   :: SimpleTextParser (Query, [QueryOpt])+    queryTermP   = do+      prefix <- optional queryPrefixP+      queryRegex <- regexP++      case parseQueryTerm d (fromMaybe "" prefix <> queryRegex) of+        Right q  -> return q+        Left err -> error' err++    keywordSpaceP :: SimpleTextParser T.Text+    keywordSpaceP = choice' (string' <$> ["not ", "and ", "or "])++    parQueryP,notQueryP :: SimpleTextParser (Query, [QueryOpt])+    parQueryP = between (char '(' >> skipNonNewlineSpaces)+                        (try $ skipNonNewlineSpaces >> char ')')+                        spacedQueriesP+            <|> queryTermP+    notQueryP = (maybe id (\_ (q, qopts) -> (Not q, qopts)) <$> optional (try $ string' "not" >> notFollowedBy (char ':') >> skipNonNewlineSpaces1)) <*> parQueryP++    andQueriesP,orQueriesP,spacedQueriesP :: SimpleTextParser (Query, [QueryOpt])+    andQueriesP    = nArityOp And <$> notQueryP `sepBy` (try $ skipNonNewlineSpaces >> string' "and" >> skipNonNewlineSpaces1)+    orQueriesP     = nArityOp Or <$> andQueriesP `sepBy` (try $ skipNonNewlineSpaces >> string' "or" >> skipNonNewlineSpaces1)+    spacedQueriesP = nArityOp combineQueryList <$> orQueriesP `sepBy` skipNonNewlineSpaces1++    nArityOp       :: ([Query] -> Query) -> [(Query, [QueryOpt])] -> (Query, [QueryOpt])+    nArityOp f res = let (qs, qoptss) = unzip res+                         qoptss'      = concat qoptss+                      in case qs of+                         []     -> (Any, qoptss')+                         (q:[]) -> (simplifyQuery q, qoptss')+                         _      -> (simplifyQuery $ f qs, qoptss')+ -- | Parse the argument of an amt query term ([OP][SIGN]NUM), to an -- OrdPlus and a Quantity, or if parsing fails, an error message. OP -- can be <=, <, >=, >, or = . NUM can be a simple integer or decimal.@@ -856,6 +932,26 @@      parseQuery nulldate "'a a' 'b"                                    @?= Right (Or [Acct $ toRegexCI' "a a",Acct $ toRegexCI' "'b"], [])      parseQuery nulldate "\""                                          @?= Right (Acct $ toRegexCI' "\"", []) +  ,testCase "parseBooleanQuery" $ do+     parseBooleanQuery nulldate "(tag:'atag=a')"     @?= Right (Tag (toRegexCI' "atag") (Just $ toRegexCI' "a"), [])+     parseBooleanQuery nulldate "(  tag:\"atag=a\"  )"     @?= Right (Tag (toRegexCI' "atag") (Just $ toRegexCI' "a"), [])+     parseBooleanQuery nulldate "(acct:'expenses:food')"     @?= Right (Acct $ toRegexCI' "expenses:food", [])+     parseBooleanQuery nulldate "(((acct:'expenses:food')))" @?= Right (Acct $ toRegexCI' "expenses:food", [])+     parseBooleanQuery nulldate "acct:'expenses:food' AND desc:'b'" @?= Right (And [Acct $ toRegexCI' "expenses:food", Desc $ toRegexCI' "b"], [])+     parseBooleanQuery nulldate "((desc:'a') AND (desc:'b') OR (desc:'c'))" @?= Right (Or [And [Desc $ toRegexCI' "a", Desc $ toRegexCI' "b"], Desc $ toRegexCI' "c"], [])+     parseBooleanQuery nulldate "((desc:'a') OR (desc:'b') AND (desc:'c'))" @?= Right (Or [Desc $ toRegexCI' "a", And [Desc $ toRegexCI' "b", Desc $ toRegexCI' "c"]], [])+     parseBooleanQuery nulldate "((desc:'a') AND desc:'b' AND (desc:'c'))" @?= Right (And [Desc $ toRegexCI' "a", Desc $ toRegexCI' "b", Desc $ toRegexCI' "c"], [])+     parseBooleanQuery nulldate "(NOT (desc:'a') AND (desc:'b'))" @?= Right (And [Not $ Desc $ toRegexCI' "a", Desc $ toRegexCI' "b"], [])+     parseBooleanQuery nulldate "((desc:'a') AND (NOT desc:'b'))" @?= Right (And [Desc $ toRegexCI' "a", Not $ Desc $ toRegexCI' "b"], [])+     parseBooleanQuery nulldate "(desc:'a' AND desc:'b')" @?= Right (And [Desc $ toRegexCI' "a", Desc $ toRegexCI' "b"], [])+     parseBooleanQuery nulldate "(acct:'a' acct:'b')" @?= Right (Or [Acct $ toRegexCI' "a", Acct $ toRegexCI' "b"], [])+     parseBooleanQuery nulldate " acct:'a' acct:'b'" @?= Right (Or [Acct $ toRegexCI' "a", Acct $ toRegexCI' "b"], [])+     parseBooleanQuery nulldate "not:a" @?= Right (Not $ Acct $ toRegexCI' "a", [])+     parseBooleanQuery nulldate "expenses:food OR (tag:A expenses:drink)" @?= Right (Or [Acct $ toRegexCI' "expenses:food", And [Acct $ toRegexCI' "expenses:drink", Tag (toRegexCI' "A") Nothing]], [])+     parseBooleanQuery nulldate "not a" @?= Right (Not $ Acct $ toRegexCI' "a", [])+     parseBooleanQuery nulldate "nota" @?= Right (Acct $ toRegexCI' "nota", [])+     parseBooleanQuery nulldate "not (acct:a)" @?= Right (Not $ Acct $ toRegexCI' "a", [])+   ,testCase "words''" $ do       (words'' [] "a b")                   @?= ["a","b"]       (words'' [] "'a b'")                 @?= ["a b"]@@ -873,25 +969,25 @@      filterQuery queryIsDepth (And [Date nulldatespan, Not (Or [Any, Depth 1])]) @?= Any   -- XXX unclear    ,testCase "parseQueryTerm" $ do-     parseQueryTerm nulldate "a"                                @?= Right (Left $ Acct $ toRegexCI' "a")-     parseQueryTerm nulldate "acct:expenses:autres d\233penses" @?= Right (Left $ Acct $ toRegexCI' "expenses:autres d\233penses")-     parseQueryTerm nulldate "not:desc:a b"                     @?= Right (Left $ Not $ Desc $ toRegexCI' "a b")-     parseQueryTerm nulldate "status:1"                         @?= Right (Left $ StatusQ Cleared)-     parseQueryTerm nulldate "status:*"                         @?= Right (Left $ StatusQ Cleared)-     parseQueryTerm nulldate "status:!"                         @?= Right (Left $ StatusQ Pending)-     parseQueryTerm nulldate "status:0"                         @?= Right (Left $ StatusQ Unmarked)-     parseQueryTerm nulldate "status:"                          @?= Right (Left $ StatusQ Unmarked)-     parseQueryTerm nulldate "payee:x"                          @?= Left <$> payeeTag (Just "x")-     parseQueryTerm nulldate "note:x"                           @?= Left <$> noteTag (Just "x")-     parseQueryTerm nulldate "real:1"                           @?= Right (Left $ Real True)-     parseQueryTerm nulldate "date:2008"                        @?= Right (Left $ Date $ DateSpan (Just $ Flex $ fromGregorian 2008 01 01) (Just $ Flex $ fromGregorian 2009 01 01))-     parseQueryTerm nulldate "date:from 2012/5/17"              @?= Right (Left $ Date $ DateSpan (Just $ Exact $ fromGregorian 2012 05 17) Nothing)-     parseQueryTerm nulldate "date:20180101-201804"             @?= Right (Left $ Date $ DateSpan (Just $ Exact $ fromGregorian 2018 01 01) (Just $ Flex $ fromGregorian 2018 04 01))-     parseQueryTerm nulldate "inacct:a"                         @?= Right (Right $ QueryOptInAcct "a")-     parseQueryTerm nulldate "tag:a"                            @?= Right (Left $ Tag (toRegexCI' "a") Nothing)-     parseQueryTerm nulldate "tag:a=some value"                 @?= Right (Left $ Tag (toRegexCI' "a") (Just $ toRegexCI' "some value"))-     parseQueryTerm nulldate "amt:<0"                           @?= Right (Left $ Amt Lt 0)-     parseQueryTerm nulldate "amt:>10000.10"                    @?= Right (Left $ Amt AbsGt 10000.1)+     parseQueryTerm nulldate "a"                                @?= Right (Acct $ toRegexCI' "a", [])+     parseQueryTerm nulldate "acct:expenses:autres d\233penses" @?= Right (Acct $ toRegexCI' "expenses:autres d\233penses", [])+     parseQueryTerm nulldate "not:desc:a b"                     @?= Right (Not $ Desc $ toRegexCI' "a b", [])+     parseQueryTerm nulldate "status:1"                         @?= Right (StatusQ Cleared, [])+     parseQueryTerm nulldate "status:*"                         @?= Right (StatusQ Cleared, [])+     parseQueryTerm nulldate "status:!"                         @?= Right (StatusQ Pending, [])+     parseQueryTerm nulldate "status:0"                         @?= Right (StatusQ Unmarked, [])+     parseQueryTerm nulldate "status:"                          @?= Right (StatusQ Unmarked, [])+     parseQueryTerm nulldate "payee:x"                          @?= (,[]) <$> payeeTag (Just "x")+     parseQueryTerm nulldate "note:x"                           @?= (,[]) <$> noteTag (Just "x")+     parseQueryTerm nulldate "real:1"                           @?= Right (Real True, [])+     parseQueryTerm nulldate "date:2008"                        @?= Right (Date $ DateSpan (Just $ Flex $ fromGregorian 2008 01 01) (Just $ Flex $ fromGregorian 2009 01 01), [])+     parseQueryTerm nulldate "date:from 2012/5/17"              @?= Right (Date $ DateSpan (Just $ Exact $ fromGregorian 2012 05 17) Nothing, [])+     parseQueryTerm nulldate "date:20180101-201804"             @?= Right (Date $ DateSpan (Just $ Exact $ fromGregorian 2018 01 01) (Just $ Flex $ fromGregorian 2018 04 01), [])+     parseQueryTerm nulldate "inacct:a"                         @?= Right (Any, [QueryOptInAcct "a"])+     parseQueryTerm nulldate "tag:a"                            @?= Right (Tag (toRegexCI' "a") Nothing, [])+     parseQueryTerm nulldate "tag:a=some value"                 @?= Right (Tag (toRegexCI' "a") (Just $ toRegexCI' "some value"), [])+     parseQueryTerm nulldate "amt:<0"                           @?= Right (Amt Lt 0, [])+     parseQueryTerm nulldate "amt:>10000.10"                    @?= Right (Amt AbsGt 10000.1, [])    ,testCase "parseAmountQueryTerm" $ do      parseAmountQueryTerm "<0"        @?= Right (Lt,0) -- special case for convenience, since AbsLt 0 would be always false@@ -961,7 +1057,7 @@       assertBool "" $ not $ (Tag (toRegex' "foo foo") (Just $ toRegex' " ar ba ")) `matchesPosting` nullposting{ptags=[("foo foo","bar bar")]}     ,testCase "a tag match on a posting also sees inherited tags" $ assertBool "" $ (Tag (toRegex' "txntag") Nothing) `matchesPosting` nullposting{ptransaction=Just nulltransaction{ttags=[("txntag","")]}}     ,testCase "cur:" $ do-      let toSym = fromLeft (error' "No query opts") . either error' id . parseQueryTerm (fromGregorian 2000 01 01) . ("cur:"<>)+      let toSym = fst . either error' id . parseQueryTerm (fromGregorian 2000 01 01) . ("cur:"<>)       assertBool "" $ not $ toSym "$" `matchesPosting` nullposting{pamount=mixedAmount $ usd 1} -- becomes "^$$", ie testing for null symbol       assertBool "" $ (toSym "\\$") `matchesPosting` nullposting{pamount=mixedAmount $ usd 1} -- have to quote $ for regexpr       assertBool "" $ (toSym "shekels") `matchesPosting` nullposting{pamount=mixedAmount nullamt{acommodity="shekels"}}

@@ -80,6 +80,7 @@ import Hledger.Read.InputOptions import Hledger.Read.JournalReader as JournalReader import Hledger.Read.CsvReader (tests_CsvReader)+import Hledger.Read.RulesReader (tests_RulesReader) -- import Hledger.Read.TimedotReader (tests_TimedotReader) -- import Hledger.Read.TimeclockReader (tests_TimeclockReader) import Hledger.Utils@@ -308,4 +309,5 @@    tests_Common   ,tests_CsvReader   ,tests_JournalReader+  ,tests_RulesReader   ]

@@ -128,7 +128,7 @@ import Data.Bifunctor (bimap, second) import Data.Char (digitToInt, isDigit, isSpace) import Data.Decimal (DecimalRaw (Decimal), Decimal)-import Data.Either (lefts, rights)+import Data.Either (rights) import Data.Function ((&)) import Data.Functor ((<&>), ($>), void) import Data.List (find, genericReplicate, union)@@ -198,7 +198,7 @@         -- Do we really need to do all this work just to get the requested end date? This is duplicating         -- much of reportOptsToSpec.         ropts = rawOptsToReportOpts day rawopts-        argsquery = lefts . rights . map (parseQueryTerm day) $ querystring_ ropts+        argsquery = map fst . rights . map (parseQueryTerm day) $ querystring_ ropts         datequery = simplifyQuery . filterQuery queryIsDate . And $ queryFromFlags ropts : argsquery          styles = either err id $ commodityStyleFromRawOpts rawopts@@ -214,6 +214,7 @@       ,new_save_          = True       ,pivot_             = stringopt "pivot" rawopts       ,forecast_          = forecastPeriodFromRawOpts day rawopts+      ,verbose_tags_      = boolopt "verbose-tags" rawopts       ,reportspan_        = DateSpan (Exact <$> queryStartDate False datequery) (Exact <$> queryEndDate False datequery)       ,auto_              = boolopt "auto" rawopts       ,infer_equity_      = boolopt "infer-equity" rawopts && conversionop_ ropts /= Just ToCost@@ -322,16 +323,18 @@       &   journalReverse                                 -- convert all lists to the order they were parsed       &   journalAddAccountTypes                         -- build a map of all known account types       &   journalApplyCommodityStyles                    -- Infer and apply commodity styles - should be done early-      <&> journalAddForecast (forecastPeriod iopts pj)   -- Add forecast transactions if enabled+      <&> 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.       >>= (if auto_ && not (null $ jtxnmodifiers pj)-              then journalAddAutoPostings _ioDay balancingopts_  -- Add auto postings if enabled, and account tags if needed-              else pure)-      -- >>= Right . dbg0With (concatMap (T.unpack.showTransaction).jtxns)  -- debug+            then journalAddAutoPostings verbose_tags_ _ioDay balancingopts_  -- Add auto postings if enabled, and account tags if needed+            else pure)+      -- XXX how to force debug output here ?+       -- >>= Right . dbg0With (concatMap (T.unpack.showTransaction).jtxns)+       -- >>= \j -> deepseq (concatMap (T.unpack.showTransaction).jtxns $ j) (return j)       >>= journalMarkRedundantCosts                      -- Mark redundant costs, to help journalBalanceTransactions ignore them       >>= journalBalanceTransactions balancingopts_                         -- Balance all transactions and maybe check balance assertions.       >>= (if infer_costs_  then journalInferCostsFromEquity else pure)     -- Maybe infer costs from equity postings where possible-      <&> (if infer_equity_ then journalAddInferredEquityPostings else id)  -- Maybe infer equity postings from costs where possible+      <&> (if infer_equity_ then journalAddInferredEquityPostings verbose_tags_ else id)  -- Maybe infer equity postings from costs where possible       <&> journalInferMarketPricesFromTransactions       -- infer market prices from commodity-exchanging transactions       <&> traceOrLogAt 6 ("journalFinalise: " <> takeFileName f)  -- debug logging       <&> dbgJournalAcctDeclOrder ("journalFinalise: " <> takeFileName f <> "   acct decls           : ")@@ -346,28 +349,29 @@     return j  -- | Apply any auto posting rules to generate extra postings on this journal's transactions.-journalAddAutoPostings :: Day -> BalancingOpts -> Journal -> Either String Journal-journalAddAutoPostings d bopts =+-- With a true first argument, adds visible tags to generated postings and modified transactions.+journalAddAutoPostings :: Bool -> Day -> BalancingOpts -> Journal -> Either String Journal+journalAddAutoPostings verbosetags d bopts =     -- Balance all transactions without checking balance assertions,     journalBalanceTransactions bopts{ignore_assertions_=True}     -- then add the auto postings     -- (Note adding auto postings after balancing means #893b fails;     -- adding them before balancing probably means #893a, #928, #938 fail.)-    >=> journalModifyTransactions d+    >=> journalModifyTransactions verbosetags d  -- | Generate periodic transactions from all periodic transaction rules in the journal. -- These transactions are added to the in-memory Journal (but not the on-disk file). -- -- The start & end date for generated periodic transactions are determined in -- a somewhat complicated way; see the hledger manual -> Periodic transactions.-journalAddForecast :: Maybe DateSpan -> Journal -> Journal-journalAddForecast Nothing             j = j-journalAddForecast (Just forecastspan) j = j{jtxns = jtxns j ++ forecasttxns}+journalAddForecast :: Bool -> Maybe DateSpan -> Journal -> Journal+journalAddForecast _ Nothing j = j+journalAddForecast verbosetags (Just forecastspan) j = j{jtxns = jtxns j ++ forecasttxns}   where     forecasttxns =         map (txnTieKnot . transactionTransformPostings (postingApplyCommodityStyles $ journalCommodityStyles j))       . filter (spanContainsDate forecastspan . tdate)-      . concatMap (`runPeriodicTransaction` forecastspan)+      . concatMap (\pt -> runPeriodicTransaction verbosetags pt forecastspan)       $ jperiodictxns j  setYear :: Year -> JournalParser m ()

@@ -3,1509 +3,72 @@ -- In Emacs, use TAB on lines beginning with "-- *" to collapse/expand sections. {-| -A reader for CSV data, using an extra rules file to help interpret the data.---}--- Lots of haddocks in this file are for non-exported types.--- Here's a command that will render them:--- stack haddock hledger-lib --fast --no-haddock-deps --haddock-arguments='--ignore-all-exports' --open----- ** language-{-# LANGUAGE FlexibleContexts     #-}-{-# LANGUAGE FlexibleInstances    #-}-{-# LANGUAGE OverloadedStrings    #-}-{-# LANGUAGE RecordWildCards      #-}-{-# LANGUAGE ScopedTypeVariables  #-}-{-# LANGUAGE TypeFamilies         #-}-{-# LANGUAGE ViewPatterns         #-}----- ** exports-module Hledger.Read.CsvReader (-  -- * Reader-  reader,-  -- * Misc.-  CSV, CsvRecord, CsvValue,-  csvFileFor,-  rulesFileFor,-  parseRulesFile,-  printCSV,-  -- * Tests-  tests_CsvReader,-)-where----- ** imports-import Prelude hiding (Applicative(..))-import Control.Applicative (Applicative(..))-import Control.Monad              (unless, when, void)-import Control.Monad.Except       (ExceptT(..), liftEither, throwError)-import qualified Control.Monad.Fail as Fail-import Control.Monad.IO.Class     (MonadIO, liftIO)-import Control.Monad.State.Strict (StateT, get, modify', evalStateT)-import Control.Monad.Trans.Class  (lift)-import Data.Char                  (toLower, isDigit, isSpace, isAlphaNum, ord)-import Data.Bifunctor             (first)-import Data.Functor               ((<&>))-import Data.List (elemIndex, foldl', intersperse, mapAccumL, nub, sortOn)-import Data.List.Extra (groupOn)-import Data.Maybe (catMaybes, fromMaybe, isJust)-import Data.MemoUgly (memo)-import qualified Data.Set as S-import Data.Text (Text)-import qualified Data.Text as T-import qualified Data.Text.Encoding 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 ( Day, TimeZone, UTCTime, LocalTime, ZonedTime(ZonedTime),-  defaultTimeLocale, getCurrentTimeZone, localDay, parseTimeM, utcToLocalTime, localTimeToUTC, zonedTimeToUTC)-import Safe (atMay, headMay, lastMay, readMay)-import System.Directory (doesFileExist)-import System.FilePath ((</>), takeDirectory, takeExtension, takeFileName)-import qualified Data.Csv as Cassava-import qualified Data.Csv.Parser.Megaparsec as CassavaMP-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as BL-import Data.Foldable (asum, toList)-import Text.Megaparsec hiding (match, parse)-import Text.Megaparsec.Char (char, newline, string)-import Text.Megaparsec.Custom (parseErrorAt)-import Text.Printf (printf)--import Hledger.Data-import Hledger.Utils-import Hledger.Read.Common (aliasesFromOpts, Reader(..), InputOpts(..), amountp, statusp, journalFinalise, accountnamep )----- ** doctest setup--- $setup--- >>> :set -XOverloadedStrings----- ** some types--type CSV       = [CsvRecord]-type CsvRecord = [CsvValue]-type CsvValue  = Text----- ** reader--reader :: MonadIO m => Reader m-reader = Reader-  {rFormat     = "csv"-  ,rExtensions = ["csv","tsv","ssv"]-  ,rReadFn     = parse-  ,rParser    = error' "sorry, CSV files can't be included yet"  -- PARTIAL:-  }---- | Parse and post-process a "Journal" from CSV data, or give an error.--- Does not check balance assertions.--- XXX currently ignores the provided data, reads it from the file path instead.-parse :: InputOpts -> FilePath -> Text -> ExceptT String IO Journal-parse iopts f t = do-  let rulesfile = mrules_file_ iopts-  readJournalFromCsv rulesfile f t-  -- apply any command line account aliases. Can fail with a bad replacement pattern.-  >>= liftEither . journalApplyAliases (aliasesFromOpts iopts)-      -- journalFinalise assumes the journal's items are-      -- reversed, as produced by JournalReader's parser.-      -- But here they are already properly ordered. So we'd-      -- better preemptively reverse them once more. XXX inefficient-      . journalReverse-  >>= journalFinalise iopts{balancingopts_=(balancingopts_ iopts){ignore_assertions_=True}} f t----- ** reading rules files---- *** rules utilities---- Not used by hledger; just for lib users,--- | An pure-exception-throwing IO action that parses this file's content--- as CSV conversion rules, interpolating any included files first,--- and runs some extra validation checks.-parseRulesFile :: FilePath -> ExceptT String IO CsvRules-parseRulesFile f =-  liftIO (readFilePortably f >>= expandIncludes (takeDirectory f))-    >>= either throwError return . parseAndValidateCsvRules f---- | Given a CSV file path, what would normally be the corresponding rules file ?-rulesFileFor :: FilePath -> FilePath-rulesFileFor = (++ ".rules")---- | Given a CSV rules file path, what would normally be the corresponding CSV file ?-csvFileFor :: FilePath -> FilePath-csvFileFor = reverse . drop 6 . reverse--defaultRulesText :: FilePath -> Text-defaultRulesText csvfile = T.pack $ unlines-  ["# hledger csv conversion rules for " ++ csvFileFor (takeFileName csvfile)-  ,"# cf http://hledger.org/hledger.html#csv"-  ,""-  ,"account1 assets:bank:checking"-  ,""-  ,"fields date, description, amount1"-  ,""-  ,"#skip 1"-  ,"#newest-first"-  ,""-  ,"#date-format %-d/%-m/%Y"-  ,"#date-format %-m/%-d/%Y"-  ,"#date-format %Y-%h-%d"-  ,""-  ,"#currency $"-  ,""-  ,"if ITUNES"-  ," account2 expenses:entertainment"-  ,""-  ,"if (TO|FROM) SAVINGS"-  ," account2 assets:bank:savings\n"-  ]--addDirective :: (DirectiveName, Text) -> CsvRulesParsed -> CsvRulesParsed-addDirective d r = r{rdirectives=d:rdirectives r}--addAssignment :: (HledgerFieldName, FieldTemplate) -> CsvRulesParsed -> CsvRulesParsed-addAssignment a r = r{rassignments=a:rassignments r}--setIndexesAndAssignmentsFromList :: [CsvFieldName] -> CsvRulesParsed -> CsvRulesParsed-setIndexesAndAssignmentsFromList fs = addAssignmentsFromList fs . setCsvFieldIndexesFromList fs--setCsvFieldIndexesFromList :: [CsvFieldName] -> CsvRulesParsed -> CsvRulesParsed-setCsvFieldIndexesFromList fs r = r{rcsvfieldindexes=zip fs [1..]}--addAssignmentsFromList :: [CsvFieldName] -> CsvRulesParsed -> CsvRulesParsed-addAssignmentsFromList fs r = foldl' maybeAddAssignment r journalfieldnames-  where-    maybeAddAssignment rules f = (maybe id addAssignmentFromIndex $ elemIndex f fs) rules-      where-        addAssignmentFromIndex i = addAssignment (f, T.pack $ '%':show (i+1))--addConditionalBlock :: ConditionalBlock -> CsvRulesParsed -> CsvRulesParsed-addConditionalBlock b r = r{rconditionalblocks=b:rconditionalblocks r}--addConditionalBlocks :: [ConditionalBlock] -> CsvRulesParsed -> CsvRulesParsed-addConditionalBlocks bs r = r{rconditionalblocks=bs++rconditionalblocks r}--getDirective :: DirectiveName -> CsvRules -> Maybe FieldTemplate-getDirective directivename = lookup directivename . rdirectives--instance ShowErrorComponent String where-  showErrorComponent = id---- | Inline all files referenced by include directives in this hledger CSV rules text, recursively.--- Included file paths may be relative to the directory of the provided file path.--- This is done as a pre-parse step to simplify the CSV rules parser.-expandIncludes :: FilePath -> Text -> IO Text-expandIncludes dir0 content = mapM (expandLine dir0) (T.lines content) <&> T.unlines-  where-    expandLine dir1 line =-      case line of-        (T.stripPrefix "include " -> Just f) -> expandIncludes dir2 =<< T.readFile f'-          where-            f' = dir1 </> T.unpack (T.dropWhile isSpace f)-            dir2 = takeDirectory f'-        _ -> return line---- | An error-throwing IO action that parses this text as CSV conversion rules--- and runs some extra validation checks. The file path is used in error messages.-parseAndValidateCsvRules :: FilePath -> T.Text -> Either String CsvRules-parseAndValidateCsvRules rulesfile s =-  case parseCsvRules rulesfile s of-    Left err    -> Left $ customErrorBundlePretty err-    Right rules -> first makeFancyParseError $ validateRules rules-  where-    makeFancyParseError :: String -> String-    makeFancyParseError errorString =-      parseErrorPretty (FancyError 0 (S.singleton $ ErrorFail errorString) :: ParseError Text String)---- | Parse this text as CSV conversion rules. The file path is for error messages.-parseCsvRules :: FilePath -> T.Text -> Either (ParseErrorBundle T.Text HledgerParseErrorData) CsvRules--- parseCsvRules rulesfile s = runParser csvrulesfile nullrules{baseAccount=takeBaseName rulesfile} rulesfile s-parseCsvRules = runParser (evalStateT rulesp defrules)---- | Return the validated rules, or an error.-validateRules :: CsvRules -> Either String CsvRules-validateRules rules = do-  unless (isAssigned "date")   $ Left "Please specify (at top level) the date field. Eg: date %1"-  Right rules-  where-    isAssigned f = isJust $ getEffectiveAssignment rules [] f----- *** rules types---- | A set of data definitions and account-matching patterns sufficient to--- convert a particular CSV data file into meaningful journal transactions.-data CsvRules' a = CsvRules' {-  rdirectives        :: [(DirectiveName,Text)],-    -- ^ top-level rules, as (keyword, value) pairs-  rcsvfieldindexes   :: [(CsvFieldName, CsvFieldIndex)],-    -- ^ csv field names and their column number, if declared by a fields list-  rassignments       :: [(HledgerFieldName, FieldTemplate)],-    -- ^ top-level assignments to hledger fields, as (field name, value template) pairs-  rconditionalblocks :: [ConditionalBlock],-    -- ^ conditional blocks, which containing additional assignments/rules to apply to matched csv records-  rblocksassigning :: a -- (String -> [ConditionalBlock])-    -- ^ all conditional blocks which can potentially assign field with a given name (memoized)-}---- | Type used by parsers. Directives, assignments and conditional blocks--- are in the reverse order compared to what is in the file and rblocksassigning is non-functional,--- could not be used for processing CSV records yet-type CsvRulesParsed = CsvRules' ()---- | Type used after parsing is done. Directives, assignments and conditional blocks--- are in the same order as they were in the unput file and rblocksassigning is functional.--- Ready to be used for CSV record processing-type CsvRules = CsvRules' (Text -> [ConditionalBlock])--instance Eq CsvRules where-  r1 == r2 = (rdirectives r1, rcsvfieldindexes r1, rassignments r1) ==-             (rdirectives r2, rcsvfieldindexes r2, rassignments r2)---- Custom Show instance used for debug output: omit the rblocksassigning field, which isn't showable.-instance Show CsvRules where-  show r = "CsvRules { rdirectives = " ++ show (rdirectives r) ++-           ", rcsvfieldindexes = "     ++ show (rcsvfieldindexes r) ++-           ", rassignments = "         ++ show (rassignments r) ++-           ", rconditionalblocks = "   ++ show (rconditionalblocks r) ++-           " }"--type CsvRulesParser a = StateT CsvRulesParsed SimpleTextParser a---- | The keyword of a CSV rule - "fields", "skip", "if", etc.-type DirectiveName    = Text---- | CSV field name.-type CsvFieldName     = Text---- | 1-based CSV column number.-type CsvFieldIndex    = Int---- | Percent symbol followed by a CSV field name or column number. Eg: %date, %1.-type CsvFieldReference = Text---- | One of the standard hledger fields or pseudo-fields that can be assigned to.--- Eg date, account1, amount, amount1-in, date-format.-type HledgerFieldName = Text---- | A text value to be assigned to a hledger field, possibly--- containing csv field references to be interpolated.-type FieldTemplate    = Text---- | 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 | None-  deriving (Show, Eq)---- | A single test for matching a CSV record, in one way or another.-data Matcher =-    RecordMatcher MatcherPrefix Regexp                          -- ^ match if this regexp matches the overall CSV record-  | FieldMatcher MatcherPrefix CsvFieldReference Regexp         -- ^ match if this regexp matches the referenced CSV field's value-  deriving (Show, Eq)---- | 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.------ Three types of rule are allowed inside conditional blocks: field--- assignments, skip, end. (A skip or end rule is stored as if it was--- a field assignment, and executed in validateCsv. XXX)-data ConditionalBlock = CB {-   cbMatchers    :: [Matcher]-  ,cbAssignments :: [(HledgerFieldName, FieldTemplate)]-  } deriving (Show, Eq)--defrules :: CsvRulesParsed-defrules = CsvRules' {-  rdirectives=[],-  rcsvfieldindexes=[],-  rassignments=[],-  rconditionalblocks=[],-  rblocksassigning = ()-  }---- | Create CsvRules from the content parsed out of the rules file-mkrules :: CsvRulesParsed -> CsvRules-mkrules rules =-  let conditionalblocks = reverse $ rconditionalblocks rules-      maybeMemo = if length conditionalblocks >= 15 then memo else id-  in-    CsvRules' {-    rdirectives=reverse $ rdirectives rules,-    rcsvfieldindexes=rcsvfieldindexes rules,-    rassignments=reverse $ rassignments rules,-    rconditionalblocks=conditionalblocks,-    rblocksassigning = maybeMemo (\f -> filter (any ((==f).fst) . cbAssignments) conditionalblocks)-    }--matcherPrefix :: Matcher -> MatcherPrefix-matcherPrefix (RecordMatcher prefix _) = prefix-matcherPrefix (FieldMatcher prefix _ _) = prefix---- | Group matchers into associative pairs based on prefix, e.g.:---   A---   & B---   C---   D---   & E---   => [[A, B], [C], [D, E]]-groupedMatchers :: [Matcher] -> [[Matcher]]-groupedMatchers [] = []-groupedMatchers (x:xs) = (x:ys) : groupedMatchers zs-  where (ys, zs) = span (\y -> matcherPrefix y == And) xs----- *** rules parsers--{--Grammar for the CSV conversion rules, more or less:--RULES: RULE*--RULE: ( FIELD-LIST | FIELD-ASSIGNMENT | CONDITIONAL-BLOCK | SKIP | TIMEZONE | NEWEST-FIRST | INTRA-DAY-REVERSED | DATE-FORMAT | DECIMAL-MARK | COMMENT | BLANK ) NEWLINE--FIELD-LIST: fields SPACE FIELD-NAME ( SPACE? , SPACE? FIELD-NAME )*--FIELD-NAME: QUOTED-FIELD-NAME | BARE-FIELD-NAME--QUOTED-FIELD-NAME: " (any CHAR except double-quote)+ "--BARE-FIELD-NAME: any CHAR except space, tab, #, ;--FIELD-ASSIGNMENT: JOURNAL-FIELD ASSIGNMENT-SEPARATOR FIELD-VALUE--JOURNAL-FIELD: date | date2 | status | code | description | comment | account1 | account2 | amount | JOURNAL-PSEUDO-FIELD--JOURNAL-PSEUDO-FIELD: amount-in | amount-out | currency--ASSIGNMENT-SEPARATOR: SPACE | ( : SPACE? )--FIELD-VALUE: VALUE (possibly containing CSV-FIELD-REFERENCEs)--CSV-FIELD-REFERENCE: % CSV-FIELD--CSV-FIELD: ( FIELD-NAME | FIELD-NUMBER ) (corresponding to a CSV field)--FIELD-NUMBER: DIGIT+--CONDITIONAL-BLOCK: if ( FIELD-MATCHER NEWLINE )+ INDENTED-BLOCK--FIELD-MATCHER: ( CSV-FIELD-NAME SPACE? )? ( MATCHOP SPACE? )? PATTERNS--MATCHOP: ~--PATTERNS: ( NEWLINE REGEXP )* REGEXP--INDENTED-BLOCK: ( SPACE ( FIELD-ASSIGNMENT | COMMENT ) NEWLINE )+--REGEXP: ( NONSPACE CHAR* ) SPACE?--VALUE: SPACE? ( CHAR* ) SPACE?--COMMENT: SPACE? COMMENT-CHAR VALUE--COMMENT-CHAR: # | ; | *--NONSPACE: any CHAR not a SPACE-CHAR--BLANK: SPACE?--SPACE: SPACE-CHAR+--SPACE-CHAR: space | tab--CHAR: any character except newline--DIGIT: 0-9---}--rulesp :: CsvRulesParser CsvRules-rulesp = do-  _ <- many $ choice-    [blankorcommentlinep                                                <?> "blank or comment line"-    ,(directivep        >>= modify' . addDirective)                     <?> "directive"-    ,(fieldnamelistp    >>= modify' . setIndexesAndAssignmentsFromList) <?> "field name list"-    ,(fieldassignmentp  >>= modify' . addAssignment)                    <?> "field assignment"-    -- conditionalblockp backtracks because it shares "if" prefix with conditionaltablep.-    ,try (conditionalblockp >>= modify' . addConditionalBlock)          <?> "conditional block"-    -- 'reverse' is there to ensure that conditions are added in the order they listed in the file-    ,(conditionaltablep >>= modify' . addConditionalBlocks . reverse)   <?> "conditional table"-    ]-  eof-  mkrules <$> get--blankorcommentlinep :: CsvRulesParser ()-blankorcommentlinep = lift (dbgparse 8 "trying blankorcommentlinep") >> choiceInState [blanklinep, commentlinep]--blanklinep :: CsvRulesParser ()-blanklinep = lift skipNonNewlineSpaces >> newline >> return () <?> "blank line"--commentlinep :: CsvRulesParser ()-commentlinep = lift skipNonNewlineSpaces >> commentcharp >> lift restofline >> return () <?> "comment line"--commentcharp :: CsvRulesParser Char-commentcharp = oneOf (";#*" :: [Char])--directivep :: CsvRulesParser (DirectiveName, Text)-directivep = (do-  lift $ dbgparse 8 "trying directive"-  d <- choiceInState $ map (lift . string) directives-  v <- (((char ':' >> lift (many spacenonewline)) <|> lift (some spacenonewline)) >> directivevalp)-       <|> (optional (char ':') >> lift skipNonNewlineSpaces >> lift eolof >> return "")-  return (d, v)-  ) <?> "directive"--directives :: [Text]-directives =-  ["date-format"-  ,"decimal-mark"-  ,"separator"-  -- ,"default-account"-  -- ,"default-currency"-  ,"skip"-  ,"timezone"-  ,"newest-first"-  ,"intra-day-reversed"-  , "balance-type"-  ]--directivevalp :: CsvRulesParser Text-directivevalp = T.pack <$> anySingle `manyTill` lift eolof--fieldnamelistp :: CsvRulesParser [CsvFieldName]-fieldnamelistp = (do-  lift $ dbgparse 8 "trying fieldnamelist"-  string "fields"-  optional $ char ':'-  lift skipNonNewlineSpaces1-  let separator = lift skipNonNewlineSpaces >> char ',' >> lift skipNonNewlineSpaces-  f <- fromMaybe "" <$> optional fieldnamep-  fs <- some $ (separator >> fromMaybe "" <$> optional fieldnamep)-  lift restofline-  return . map T.toLower $ f:fs-  ) <?> "field name list"--fieldnamep :: CsvRulesParser Text-fieldnamep = quotedfieldnamep <|> barefieldnamep--quotedfieldnamep :: CsvRulesParser Text-quotedfieldnamep =-    char '"' *> takeWhile1P Nothing (`notElem` ("\"\n:;#~" :: [Char])) <* char '"'--barefieldnamep :: CsvRulesParser Text-barefieldnamep = takeWhile1P Nothing (`notElem` (" \t\n,;#~" :: [Char]))--fieldassignmentp :: CsvRulesParser (HledgerFieldName, FieldTemplate)-fieldassignmentp = do-  lift $ dbgparse 8 "trying fieldassignmentp"-  f <- journalfieldnamep-  v <- choiceInState [ assignmentseparatorp >> fieldvalp-                     , lift eolof >> return ""-                     ]-  return (f,v)-  <?> "field assignment"--journalfieldnamep :: CsvRulesParser Text-journalfieldnamep = do-  lift (dbgparse 8 "trying journalfieldnamep")-  choiceInState $ map (lift . string) journalfieldnames--maxpostings = 99---- Transaction fields and pseudo fields for CSV conversion.--- Names must precede any other name they contain, for the parser--- (amount-in before amount; date2 before date). TODO: fix-journalfieldnames =-  concat [[ "account" <> i-          ,"amount" <> i <> "-in"-          ,"amount" <> i <> "-out"-          ,"amount" <> i-          ,"balance" <> i-          ,"comment" <> i-          ,"currency" <> i-          ] | x <- [maxpostings, (maxpostings-1)..1], let i = T.pack $ show x]-  ++-  ["amount-in"-  ,"amount-out"-  ,"amount"-  ,"balance"-  ,"code"-  ,"comment"-  ,"currency"-  ,"date2"-  ,"date"-  ,"description"-  ,"status"-  ,"skip" -- skip and end are not really fields, but we list it here to allow conditional rules that skip records-  ,"end"-  ]--assignmentseparatorp :: CsvRulesParser ()-assignmentseparatorp = do-  lift $ dbgparse 8 "trying assignmentseparatorp"-  _ <- choiceInState [ lift skipNonNewlineSpaces >> char ':' >> lift skipNonNewlineSpaces-                     , lift skipNonNewlineSpaces1-                     ]-  return ()--fieldvalp :: CsvRulesParser Text-fieldvalp = do-  lift $ dbgparse 8 "trying fieldvalp"-  T.pack <$> anySingle `manyTill` lift eolof---- A conditional block: one or more matchers, one per line, followed by one or more indented rules.-conditionalblockp :: CsvRulesParser ConditionalBlock-conditionalblockp = do-  lift $ dbgparse 8 "trying conditionalblockp"-  -- "if\nMATCHER" or "if    \nMATCHER" or "if MATCHER"-  start <- getOffset-  string "if" >> ( (newline >> return Nothing)-                  <|> (lift skipNonNewlineSpaces1 >> optional newline))-  ms <- some matcherp-  as <- catMaybes <$>-    many (lift skipNonNewlineSpaces1 >>-          choice [ lift eolof >> return Nothing-                 , fmap Just fieldassignmentp-                 ])-  when (null as) $-    customFailure $ parseErrorAt start $  "start of conditional block found, but no assignment rules afterward\n(assignment rules in a conditional block should be indented)"-  return $ CB{cbMatchers=ms, cbAssignments=as}-  <?> "conditional block"---- A conditional table: "if" followed by separator, followed by some field names,--- followed by many lines, each of which has:--- one matchers, followed by field assignments (as many as there were fields)-conditionaltablep :: CsvRulesParser [ConditionalBlock]-conditionaltablep = do-  lift $ dbgparse 8 "trying conditionaltablep"-  start <- getOffset-  string "if"-  sep <- lift $ satisfy (\c -> not (isAlphaNum c || isSpace c))-  fields <- journalfieldnamep `sepBy1` (char sep)-  newline-  body <- flip manyTill (lift eolof) $ do-    off <- getOffset-    m <- matcherp' $ void $ char sep-    vs <- T.split (==sep) . T.pack <$> lift restofline-    if (length vs /= length fields)-      then customFailure $ parseErrorAt off $ ((printf "line of conditional table should have %d values, but this one has only %d" (length fields) (length vs)) :: String)-      else return (m,vs)-  when (null body) $-    customFailure $ parseErrorAt start $ "start of conditional table found, but no assignment rules afterward"-  return $ flip map body $ \(m,vs) ->-    CB{cbMatchers=[m], cbAssignments=zip fields vs}-  <?> "conditional table"---- A single matcher, on one line.-matcherp' :: CsvRulesParser () -> CsvRulesParser Matcher-matcherp' end = try (fieldmatcherp end) <|> recordmatcherp end--matcherp :: CsvRulesParser Matcher-matcherp = matcherp' (lift eolof)---- A single whole-record matcher.--- A pattern on the whole line, not beginning with a csv field reference.-recordmatcherp :: CsvRulesParser () -> CsvRulesParser Matcher-recordmatcherp end = do-  lift $ dbgparse 8 "trying recordmatcherp"-  -- pos <- currentPos-  -- _  <- optional (matchoperatorp >> lift skipNonNewlineSpaces >> optional newline)-  p <- matcherprefixp-  r <- regexp end-  return $ RecordMatcher p r-  -- when (null ps) $-  --   Fail.fail "start of record matcher found, but no patterns afterward\n(patterns should not be indented)"-  <?> "record matcher"---- | A single matcher for a specific field. A csv field reference--- (like %date or %1), and a pattern on the rest of the line,--- optionally space-separated. Eg:--- %description chez jacques-fieldmatcherp :: CsvRulesParser () -> CsvRulesParser Matcher-fieldmatcherp end = do-  lift $ dbgparse 8 "trying fieldmatcher"-  -- An optional fieldname (default: "all")-  -- f <- fromMaybe "all" `fmap` (optional $ do-  --        f' <- fieldnamep-  --        lift skipNonNewlineSpaces-  --        return f')-  p <- matcherprefixp-  f <- csvfieldreferencep <* lift skipNonNewlineSpaces-  -- optional operator.. just ~ (case insensitive infix regex) for now-  -- _op <- fromMaybe "~" <$> optional matchoperatorp-  lift skipNonNewlineSpaces-  r <- regexp end-  return $ FieldMatcher p f r-  <?> "field matcher"--matcherprefixp :: CsvRulesParser MatcherPrefix-matcherprefixp = do-  lift $ dbgparse 8 "trying matcherprefixp"-  (char '&' >> lift skipNonNewlineSpaces >> return And) <|> return None--csvfieldreferencep :: CsvRulesParser CsvFieldReference-csvfieldreferencep = do-  lift $ dbgparse 8 "trying csvfieldreferencep"-  char '%'-  T.cons '%' . textQuoteIfNeeded <$> fieldnamep---- A single regular expression-regexp :: CsvRulesParser () -> CsvRulesParser Regexp-regexp end = do-  lift $ dbgparse 8 "trying regexp"-  -- notFollowedBy matchoperatorp-  c <- lift nonspace-  cs <- anySingle `manyTill` end-  case toRegexCI . T.strip . T.pack $ c:cs of-       Left x -> Fail.fail $ "CSV parser: " ++ x-       Right x -> return x---- -- A match operator, indicating the type of match to perform.--- -- Currently just ~ meaning case insensitive infix regex match.--- matchoperatorp :: CsvRulesParser String--- matchoperatorp = fmap T.unpack $ choiceInState $ map string---   ["~"---   -- ,"!~"---   -- ,"="---   -- ,"!="---   ]----- ** reading csv files---- | Read a Journal from the given CSV data (and filename, used for error--- messages), or return an error. Proceed as follows:------ 1. parse CSV conversion rules from the specified rules file, or from---    the default rules file for the specified CSV file, if it exists,---    or throw a parse error; if it doesn't exist, use built-in default rules------ 2. parse the CSV data, or throw a parse error------ 3. convert the CSV records to transactions using the rules------ 4. if the rules file didn't exist, create it with the default rules and filename------ 5. return the transactions as a Journal----readJournalFromCsv :: Maybe FilePath -> FilePath -> Text -> ExceptT String IO Journal-readJournalFromCsv Nothing "-" _ = throwError "please use --rules-file when reading CSV from stdin"-readJournalFromCsv mrulesfile csvfile csvdata = do-    -- parse the csv rules-    let rulesfile = fromMaybe (rulesFileFor csvfile) mrulesfile-    rulesfileexists <- liftIO $ doesFileExist rulesfile-    rulestext <- liftIO $ if rulesfileexists-      then do-        dbg6IO "using conversion rules file" rulesfile-        readFilePortably rulesfile >>= expandIncludes (takeDirectory rulesfile)-      else-        return $ defaultRulesText rulesfile-    rules <- liftEither $ parseAndValidateCsvRules rulesfile rulestext-    dbg6IO "csv rules" rules--    mtzin <- case getDirective "timezone" rules of-              Nothing -> return Nothing-              Just s  ->-                maybe (throwError $ "could not parse time zone: " ++ T.unpack s) (return.Just) $-                parseTimeM False defaultTimeLocale "%Z" $ T.unpack s-    tzout <- liftIO getCurrentTimeZone--    -- skip header lines, if there is a top-level skip rule-    skiplines <- case getDirective "skip" rules of-                      Nothing -> return 0-                      Just "" -> return 1-                      Just s  -> maybe (throwError $ "could not parse skip value: " ++ show s) return . readMay $ T.unpack s-    let csvdata' = T.unlines $ drop skiplines $ T.lines csvdata--    -- parse csv-    let-      -- parsec seems to fail if you pass it "-" here TODO: try again with megaparsec-      parsecfilename = if csvfile == "-" then "(stdin)" else csvfile-      separator =-        case getDirective "separator" rules >>= parseSeparator of-          Just c           -> c-          _ | ext == "ssv" -> ';'-          _ | ext == "tsv" -> '\t'-          _                -> ','-          where-            ext = map toLower $ drop 1 $ takeExtension csvfile-    dbg6IO "using separator" separator-    csv <- dbg7 "parseCsv" <$> parseCsv separator parsecfilename csvdata'-    records <- liftEither $ dbg7 "validateCsv" <$> validateCsv rules csv-    dbg6IO "first 3 csv records" $ take 3 records--    -- identify header lines-    -- let (headerlines, datalines) = identifyHeaderLines records-    --     mfieldnames = lastMay headerlines--    let-      -- convert CSV records to transactions, saving the CSV line numbers for error positions-      txns = dbg7 "csv txns" $ snd $ mapAccumL-                     (\pos r ->-                        let-                          SourcePos name line col = pos-                          line' = (mkPos . (+1) . unPos) line-                          pos' = SourcePos name line' col-                        in-                          (pos', transactionFromCsvRecord timesarezoned mtzin tzout pos rules r)-                     )-                     (initialPos parsecfilename) records-        where-          timesarezoned =-            case csvRule rules "date-format" of-              Just f | any (`T.isInfixOf` f) ["%Z","%z","%EZ","%Ez"] -> True-              _ -> False--      -- Do our best to ensure transactions will be ordered chronologically,-      -- from oldest to newest. This is done in several steps:-      -- 1. Intra-day order: if there's an "intra-day-reversed" rule,-      -- assume each day's CSV records were ordered in reverse of the overall date order,-      -- so reverse each day's txns.-      intradayreversed = dbg6 "intra-day-reversed" $ isJust $ getDirective "intra-day-reversed" rules-      txns1 = dbg7 "txns1" $-        (if intradayreversed then concatMap reverse . groupOn tdate else id) txns-      -- 2. Overall date order: now if there's a "newest-first" rule,-      -- or if there's multiple dates and the first is more recent than the last,-      -- assume CSV records were ordered newest dates first,-      -- so reverse all txns.-      newestfirst = dbg6 "newest-first" $ isJust $ getDirective "newest-first" rules-      mdatalooksnewestfirst = dbg6 "mdatalooksnewestfirst" $-        case nub $ map tdate txns of-          ds | length ds > 1 -> Just $ head ds > last ds-          _                  -> Nothing-      txns2 = dbg7 "txns2" $-        (if newestfirst || mdatalooksnewestfirst == Just True then reverse else id) txns1-      -- 3. Disordered dates: in case the CSV records were ordered by chaos,-      -- do a final sort by date. If it was only a few records out of order,-      -- this will hopefully refine any good ordering done by steps 1 and 2.-      txns3 = dbg7 "date-sorted csv txns" $ sortOn tdate txns2--    liftIO $ unless rulesfileexists $ do-      dbg1IO "creating conversion rules file" rulesfile-      T.writeFile rulesfile rulestext--    return nulljournal{jtxns=txns3}---- | Parse special separator names TAB and SPACE, or return the first--- character. Return Nothing on empty string-parseSeparator :: Text -> Maybe Char-parseSeparator = specials . T.toLower-  where specials "space" = Just ' '-        specials "tab"   = Just '\t'-        specials xs      = fst <$> T.uncons xs--parseCsv :: Char -> FilePath -> Text -> ExceptT String IO CSV-parseCsv separator filePath csvdata = ExceptT $-  case filePath of-    "-" -> parseCassava separator "(stdin)" <$> T.getContents-    _   -> return $ if T.null csvdata then Right mempty else parseCassava separator filePath csvdata--parseCassava :: Char -> FilePath -> Text -> Either String CSV-parseCassava separator path content =-  either (Left . errorBundlePretty) (Right . parseResultToCsv) <$>-  CassavaMP.decodeWith (decodeOptions separator) Cassava.NoHeader path $-  BL.fromStrict $ T.encodeUtf8 content--decodeOptions :: Char -> Cassava.DecodeOptions-decodeOptions separator = Cassava.defaultDecodeOptions {-                      Cassava.decDelimiter = fromIntegral (ord separator)-                    }--parseResultToCsv :: (Foldable t, Functor t) => t (t B.ByteString) -> CSV-parseResultToCsv = toListList . unpackFields-    where-        toListList = toList . fmap toList-        unpackFields  = (fmap . fmap) T.decodeUtf8--printCSV :: CSV -> TL.Text-printCSV = TB.toLazyText . unlinesB . map printRecord-    where printRecord = foldMap TB.fromText . intersperse "," . map printField-          printField = wrap "\"" "\"" . T.replace "\"" "\"\""---- | Return the cleaned up and validated CSV data (can be empty), or an error.-validateCsv :: CsvRules -> CSV -> Either String [CsvRecord]-validateCsv rules = validate . applyConditionalSkips . filternulls-  where-    filternulls = filter (/=[""])-    skipnum r =-      case (getEffectiveAssignment rules r "end", getEffectiveAssignment rules r "skip") of-        (Nothing, Nothing) -> Nothing-        (Just _, _) -> Just maxBound-        (Nothing, Just "") -> Just 1-        (Nothing, Just x) -> Just (read $ T.unpack x)-    applyConditionalSkips [] = []-    applyConditionalSkips (r:rest) =-      case skipnum r of-        Nothing -> r:(applyConditionalSkips rest)-        Just cnt -> applyConditionalSkips (drop (cnt-1) rest)-    validate [] = Right []-    validate rs@(_first:_) = case lessthan2 of-        Just r  -> Left $ printf "CSV record %s has less than two fields" (show r)-        Nothing -> Right rs-      where-        lessthan2 = headMay $ filter ((<2).length) rs---- -- | The highest (0-based) field index referenced in the field--- -- definitions, or -1 if no fields are defined.--- maxFieldIndex :: CsvRules -> Int--- maxFieldIndex r = maximumDef (-1) $ catMaybes [---                    dateField r---                   ,statusField r---                   ,codeField r---                   ,amountField r---                   ,amountInField r---                   ,amountOutField r---                   ,currencyField r---                   ,accountField r---                   ,account2Field r---                   ,date2Field r---                   ]----- ** converting csv records to transactions--showRules rules record =-  T.unlines $ catMaybes [ (("the "<>fld<>" rule is: ")<>) <$> getEffectiveAssignment rules record fld | fld <- journalfieldnames]---- | Look up the value (template) of a csv rule by rule keyword.-csvRule :: CsvRules -> DirectiveName -> Maybe FieldTemplate-csvRule rules = (`getDirective` rules)---- | Look up the value template assigned to a hledger field by field--- list/field assignment rules, taking into account the current record and--- conditional rules.-hledgerField :: CsvRules -> CsvRecord -> HledgerFieldName -> Maybe FieldTemplate-hledgerField = getEffectiveAssignment---- | Look up the final value assigned to a hledger field, with csv field--- references interpolated.-hledgerFieldValue :: CsvRules -> CsvRecord -> HledgerFieldName -> Maybe Text-hledgerFieldValue rules record = fmap (renderTemplate rules record) . hledgerField rules record--transactionFromCsvRecord :: Bool -> Maybe TimeZone -> TimeZone -> SourcePos -> CsvRules -> CsvRecord -> Transaction-transactionFromCsvRecord timesarezoned mtzin tzout sourcepos rules record = t-  where-    -----------------------------------------------------------------------    -- 1. Define some helpers:--    rule     = csvRule           rules        :: DirectiveName    -> Maybe FieldTemplate-    -- ruleval  = csvRuleValue      rules record :: DirectiveName    -> Maybe String-    field    = hledgerField      rules record :: HledgerFieldName -> Maybe FieldTemplate-    fieldval = hledgerFieldValue rules record :: HledgerFieldName -> Maybe Text-    mdateformat = rule "date-format"-    parsedate = parseDateWithCustomOrDefaultFormats timesarezoned mtzin tzout mdateformat-    mkdateerror datefield datevalue mdateformat' = T.unpack $ T.unlines-      ["error: could not parse \""<>datevalue<>"\" as a date using date format "-        <>maybe "\"YYYY/M/D\", \"YYYY-M-D\" or \"YYYY.M.D\"" (T.pack . show) mdateformat'-      ,showRecord record-      ,"the "<>datefield<>" rule is:   "<>(fromMaybe "required, but missing" $ field datefield)-      ,"the date-format is: "<>fromMaybe "unspecified" mdateformat'-      ,"you may need to "-        <>"change your "<>datefield<>" rule, "-        <>maybe "add a" (const "change your") mdateformat'<>" date-format rule, "-        <>"or "<>maybe "add a" (const "change your") mskip<>" skip rule"-      ,"for m/d/y or d/m/y dates, use date-format %-m/%-d/%Y or date-format %-d/%-m/%Y"-      ]-      where-        mskip = rule "skip"--    -----------------------------------------------------------------------    -- 2. Gather values needed for the transaction itself, by evaluating the-    -- field assignment rules using the CSV record's data, and parsing a bit-    -- more where needed (dates, status).--    date        = fromMaybe "" $ fieldval "date"-    -- PARTIAL:-    date'       = fromMaybe (error' $ mkdateerror "date" date mdateformat) $ parsedate date-    mdate2      = fieldval "date2"-    mdate2'     = (maybe (error' $ mkdateerror "date2" (fromMaybe "" mdate2) mdateformat) Just . parsedate) =<< mdate2-    status      =-      case fieldval "status" of-        Nothing -> Unmarked-        Just s  -> either statuserror id $ runParser (statusp <* eof) "" s-          where-            statuserror err = error' . T.unpack $ T.unlines-              ["error: could not parse \""<>s<>"\" as a cleared status (should be *, ! or empty)"-              ,"the parse error is:      "<>T.pack (customErrorBundlePretty err)-              ]-    code        = maybe "" singleline' $ fieldval "code"-    description = maybe "" singleline' $ fieldval "description"-    comment     = maybe "" unescapeNewlines $ fieldval "comment"-    precomment  = maybe "" unescapeNewlines $ fieldval "precomment"--    singleline' = T.unwords . filter (not . T.null) . map T.strip . T.lines-    unescapeNewlines = T.intercalate "\n" . T.splitOn "\\n"--    -----------------------------------------------------------------------    -- 3. Generate the postings for which an account has been assigned-    -- (possibly indirectly due to an amount or balance assignment)--    p1IsVirtual = (accountNamePostingType <$> fieldval "account1") == Just VirtualPosting-    ps = [p | n <- [1..maxpostings]-         ,let cmt  = maybe "" unescapeNewlines $ fieldval ("comment"<> T.pack (show n))-         ,let currency = fromMaybe "" (fieldval ("currency"<> T.pack (show n)) <|> fieldval "currency")-         ,let mamount  = getAmount rules record currency p1IsVirtual n-         ,let mbalance = getBalance rules record currency n-         ,Just (acct,isfinal) <- [getAccount rules record mamount mbalance n]  -- skips Nothings-         ,let acct' | not isfinal && acct==unknownExpenseAccount &&-                      fromMaybe False (mamount >>= isNegativeMixedAmount) = unknownIncomeAccount-                    | otherwise = acct-         ,let p = nullposting{paccount          = accountNameWithoutPostingType acct'-                             ,pamount           = fromMaybe missingmixedamt mamount-                             ,ptransaction      = Just t-                             ,pbalanceassertion = mkBalanceAssertion rules record <$> mbalance-                             ,pcomment          = cmt-                             ,ptype             = accountNamePostingType acct-                             }-         ]--    -----------------------------------------------------------------------    -- 4. Build the transaction (and name it, so the postings can reference it).--    t = nulltransaction{-           tsourcepos        = (sourcepos, sourcepos)  -- the CSV line number-          ,tdate             = date'-          ,tdate2            = mdate2'-          ,tstatus           = status-          ,tcode             = code-          ,tdescription      = description-          ,tcomment          = comment-          ,tprecedingcomment = precomment-          ,tpostings         = ps-          }---- | Figure out the amount specified for posting N, if any.--- A currency symbol to prepend to the amount, if any, is provided,--- and whether posting 1 requires balancing or not.--- This looks for a non-empty amount value assigned to "amountN", "amountN-in", or "amountN-out".--- For postings 1 or 2 it also looks at "amount", "amount-in", "amount-out".--- If more than one of these has a value, it looks for one that is non-zero.--- If there's multiple non-zeros, or no non-zeros but multiple zeros, it throws an error.-getAmount :: CsvRules -> CsvRecord -> Text -> Bool -> Int -> Maybe MixedAmount-getAmount rules record currency p1IsVirtual n =-  -- Warning! Many tricky corner cases here.-  -- Keep synced with:-  -- hledger_csv.m4.md -> CSV FORMAT -> "amount", "Setting amounts",-  -- hledger/test/csv.test -> 13, 31-34-  let-    unnumberedfieldnames = ["amount","amount-in","amount-out"]--    -- amount field names which can affect this posting-    fieldnames = map (("amount"<> T.pack (show n))<>) ["","-in","-out"]-                 -- For posting 1, also recognise the old amount/amount-in/amount-out names.-                 -- For posting 2, the same but only if posting 1 needs balancing.-                 ++ if n==1 || n==2 && not p1IsVirtual then unnumberedfieldnames else []--    -- assignments to any of these field names with non-empty values-    assignments = [(f,a') | f <- fieldnames-                          , Just v <- [T.strip . renderTemplate rules record <$> hledgerField rules record f]-                          , not $ T.null v-                          -- XXX maybe ignore rule-generated values like "", "-", "$", "-$", "$-" ? cf CSV FORMAT -> "amount", "Setting amounts",-                          , let a = parseAmount rules record currency v-                          -- With amount/amount-in/amount-out, in posting 2,-                          -- flip the sign and convert to cost, as they did before 1.17-                          , let a' = if f `elem` unnumberedfieldnames && n==2 then mixedAmountCost (maNegate a) else a-                          ]--    -- if any of the numbered field names are present, discard all the unnumbered ones-    discardUnnumbered xs = if null numbered then xs else numbered-      where-        numbered = filter (T.any isDigit . fst) xs--    -- discard all zero amounts, unless all amounts are zero, in which case discard all but the first-    discardExcessZeros xs = if null nonzeros then take 1 xs else nonzeros-      where-        nonzeros = filter (not . mixedAmountLooksZero . snd) xs--    -- for -out fields, flip the sign  XXX unless it's already negative ? back compat issues / too confusing ?-    negateIfOut f = if "-out" `T.isSuffixOf` f then maNegate else id--  in case discardExcessZeros $ discardUnnumbered assignments of-      []      -> Nothing-      [(f,a)] -> Just $ negateIfOut f a-      fs      -> error' . T.unpack . textChomp . T.unlines $  -- PARTIAL:-          -- PARTIAL:-          -- PARTIAL:-          -- PARTIAL:-          -- PARTIAL:-          -- PARTIAL:-          -- PARTIAL:-          -- PARTIAL:-          -- PARTIAL:-          -- PARTIAL:-          -- PARTIAL:-          -- PARTIAL:-          -- PARTIAL:-          -- PARTIAL:-          -- PARTIAL:-          -- PARTIAL:-          -- PARTIAL:-          -- PARTIAL:-          -- PARTIAL:-          -- PARTIAL:-          -- PARTIAL:-          -- PARTIAL:-          -- PARTIAL:-          -- PARTIAL:-          -- PARTIAL:-          -- PARTIAL:-          -- PARTIAL:-          -- PARTIAL:-          -- PARTIAL:-          -- PARTIAL:-          -- PARTIAL:-          -- PARTIAL:-        ["in CSV rules:"-        ,"While processing " <> showRecord record-        ,"while calculating amount for posting " <> T.pack (show n)-        ] ++-        ["rule \"" <> f <> " " <>-          fromMaybe "" (hledgerField rules record f) <>-          "\" assigned value \"" <> wbToText (showMixedAmountB noColour a) <> "\"" -- XXX not sure this is showing all the right info-          | (f,a) <- fs-        ] ++-        [""-        ,"Multiple non-zero amounts were assigned for an amount field."-        ,"Please ensure just one non-zero amount is assigned, perhaps with an if rule."-        ,"See also: https://hledger.org/hledger.html#setting-amounts"-        ,"(hledger manual -> CSV format -> Tips -> Setting amounts)"-        ]--- | Figure out the expected balance (assertion or assignment) specified for posting N,--- if any (and its parse position).-getBalance :: CsvRules -> CsvRecord -> Text -> Int -> Maybe (Amount, SourcePos)-getBalance rules record currency n = do-  v <- (fieldval ("balance"<> T.pack (show n))-        -- for posting 1, also recognise the old field name-        <|> if n==1 then fieldval "balance" else Nothing)-  case v of-    "" -> Nothing-    s  -> Just (-            parseBalanceAmount rules record currency n s-           ,initialPos ""  -- parse position to show when assertion fails,-           )               -- XXX the csv record's line number would be good-  where-    fieldval = fmap T.strip . hledgerFieldValue rules record :: HledgerFieldName -> Maybe Text---- | Given a non-empty amount string (from CSV) to parse, along with a--- possibly non-empty currency symbol to prepend,--- parse as a hledger MixedAmount (as in journal format), or raise an error.--- The whole CSV record is provided for the error message.-parseAmount :: CsvRules -> CsvRecord -> Text -> Text -> MixedAmount-parseAmount rules record currency s =-    either mkerror mixedAmount $  -- PARTIAL:-      -- PARTIAL:-      -- PARTIAL:-      -- PARTIAL:-      -- PARTIAL:-      -- PARTIAL:-      -- PARTIAL:-      -- PARTIAL:-      -- PARTIAL:-      -- PARTIAL:-      -- PARTIAL:-      -- PARTIAL:-      -- PARTIAL:-      -- PARTIAL:-      -- PARTIAL:-      -- PARTIAL:-      -- PARTIAL:-      -- PARTIAL:-      -- PARTIAL:-      -- PARTIAL:-      -- PARTIAL:-      -- PARTIAL:-      -- PARTIAL:-      -- PARTIAL:-      -- PARTIAL:-      -- PARTIAL:-      -- PARTIAL:-      -- PARTIAL:-      -- PARTIAL:-      -- PARTIAL:-      -- PARTIAL:-      -- PARTIAL:-    runParser (evalStateT (amountp <* eof) journalparsestate) "" $-    currency <> simplifySign s-  where-    journalparsestate = nulljournal{jparsedecimalmark=parseDecimalMark rules}-    mkerror e = error' . T.unpack $ T.unlines-      ["error: could not parse \"" <> s <> "\" as an amount"-      ,showRecord record-      ,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"-      ]---- XXX unify these ^v---- | Almost but not quite the same as parseAmount.--- Given a non-empty amount string (from CSV) to parse, along with a--- possibly non-empty currency symbol to prepend,--- parse as a hledger Amount (as in journal format), or raise an error.--- The CSV record and the field's numeric suffix are provided for the error message.-parseBalanceAmount :: CsvRules -> CsvRecord -> Text -> Int -> Text -> Amount-parseBalanceAmount rules record currency n s =-  either (mkerror n s) id $-    runParser (evalStateT (amountp <* eof) journalparsestate) "" $-    currency <> simplifySign s-                  -- the csv record's line number would be good-  where-    journalparsestate = nulljournal{jparsedecimalmark=parseDecimalMark rules}-    mkerror n' s' e = error' . T.unpack $ T.unlines-      ["error: could not parse \"" <> s' <> "\" as balance"<> T.pack (show n') <> " amount"-      ,showRecord record-      ,showRules rules record-      -- ,"the default-currency is: "++fromMaybe "unspecified" mdefaultcurrency-      ,"the parse error is:      "<> T.pack (customErrorBundlePretty e)-      ]---- Read a valid decimal mark from the decimal-mark rule, if any.--- If the rule is present with an invalid argument, raise an error.-parseDecimalMark :: CsvRules -> Maybe DecimalMark-parseDecimalMark rules = do-    s <- rules `csvRule` "decimal-mark"-    case T.uncons s of-        Just (c, rest) | T.null rest && isDecimalMark c -> return c-        _ -> error' . T.unpack $ "decimal-mark's argument should be \".\" or \",\" (not \""<>s<>"\")"---- | Make a balance assertion for the given amount, with the given parse--- position (to be shown in assertion failures), with the assertion type--- possibly set by a balance-type rule.--- The CSV rules and current record are also provided, to be shown in case--- balance-type's argument is bad (XXX refactor).-mkBalanceAssertion :: CsvRules -> CsvRecord -> (Amount, SourcePos) -> BalanceAssertion-mkBalanceAssertion rules record (amt, pos) = assrt{baamount=amt, baposition=pos}-  where-    assrt =-      case getDirective "balance-type" rules of-        Nothing    -> nullassertion-        Just "="   -> nullassertion-        Just "=="  -> nullassertion{batotal=True}-        Just "=*"  -> nullassertion{bainclusive=True}-        Just "==*" -> nullassertion{batotal=True, bainclusive=True}-        Just x     -> error' . T.unpack $ T.unlines  -- PARTIAL:-          [ "balance-type \"" <> x <>"\" is invalid. Use =, ==, =* or ==*."-          , showRecord record-          , showRules rules record-          ]---- | Figure out the account name specified for posting N, if any.--- And whether it is the default unknown account (which may be--- improved later) or an explicitly set account (which may not).-getAccount :: CsvRules -> CsvRecord -> Maybe MixedAmount -> Maybe (Amount, SourcePos) -> Int -> Maybe (AccountName, Bool)-getAccount rules record mamount mbalance n =-  let-    fieldval = hledgerFieldValue rules record :: HledgerFieldName -> Maybe Text-    maccount = T.strip <$> fieldval ("account"<> T.pack (show n))-  in case maccount of-    -- accountN is set to the empty string - no posting will be generated-    Just "" -> Nothing-    -- accountN is set (possibly to "expenses:unknown"! #1192) - mark it final-    Just a  ->-      -- Check it and reject if invalid.. sometimes people try-      -- to set an amount or comment along with the account name.-      case parsewith (accountnamep >> eof) a of-        Left e  -> usageError $ errorBundlePretty e-        Right _ -> Just (a, True)-    -- accountN is unset-    Nothing ->-      case (mamount, mbalance) of-        -- amountN is set, or implied by balanceN - set accountN to-        -- the default unknown account ("expenses:unknown") and-        -- allow it to be improved later-        (Just _, _) -> Just (unknownExpenseAccount, False)-        (_, Just _) -> Just (unknownExpenseAccount, False)-        -- amountN is also unset - no posting will be generated-        (Nothing, Nothing) -> Nothing---- | Default account names to use when needed.-unknownExpenseAccount = "expenses:unknown"-unknownIncomeAccount  = "income:unknown"--type CsvAmountString = Text---- | Canonicalise the sign in a CSV amount string.--- Such strings can have a minus sign, parentheses (equivalent to minus),--- or any two of these (which cancel out),--- or a plus sign (which is removed),--- or any sign by itself with no following number (which is removed).--- See hledger > CSV FORMAT > Tips > Setting amounts.------ These are supported (note, not every possibile combination):------ >>> simplifySign "1"--- "1"--- >>> simplifySign "+1"--- "1"--- >>> simplifySign "-1"--- "-1"--- >>> simplifySign "(1)"--- "-1"--- >>> simplifySign "--1"--- "1"--- >>> simplifySign "-(1)"--- "1"--- >>> simplifySign "-+1"--- "-1"--- >>> simplifySign "(-1)"--- "1"--- >>> simplifySign "((1))"--- "1"--- >>> simplifySign "-"--- ""--- >>> simplifySign "()"--- ""--- >>> simplifySign "+"--- ""-simplifySign :: CsvAmountString -> CsvAmountString-simplifySign amtstr-  | Just (' ',t) <- T.uncons amtstr = simplifySign t-  | Just (t,' ') <- T.unsnoc amtstr = simplifySign t-  | Just ('(',t) <- T.uncons amtstr, Just (amt,')') <- T.unsnoc t = simplifySign $ negateStr amt-  | Just ('-',b) <- T.uncons amtstr, Just ('(',t) <- T.uncons b, Just (amt,')') <- T.unsnoc t = simplifySign amt-  | Just ('-',m) <- T.uncons amtstr, Just ('-',amt) <- T.uncons m = amt-  | Just ('-',m) <- T.uncons amtstr, Just ('+',amt) <- T.uncons m = negateStr amt-  | amtstr `elem` ["-","+","()"] = ""-  | Just ('+',amt) <- T.uncons amtstr = simplifySign amt-  | otherwise = amtstr--negateStr :: Text -> Text-negateStr amtstr = case T.uncons amtstr of-    Just ('-',s) -> s-    _            -> T.cons '-' amtstr---- | Show a (approximate) recreation of the original CSV record.-showRecord :: CsvRecord -> Text-showRecord r = "CSV record: "<>T.intercalate "," (map (wrap "\"" "\"") r)---- | Given the conversion rules, a CSV record and a hledger field name, find--- the value template ultimately assigned to this field, if any, by a field--- assignment at top level or in a conditional block matching this record.------ Note conditional blocks' patterns are matched against an approximation of the--- CSV record: all the field values, without enclosing quotes, comma-separated.----getEffectiveAssignment :: CsvRules -> CsvRecord -> HledgerFieldName -> Maybe FieldTemplate-getEffectiveAssignment rules record f = lastMay $ map snd $ assignments-  where-    -- all active assignments to field f, in order-    assignments = dbg9 "csv assignments" $ filter ((==f).fst) $ toplevelassignments ++ conditionalassignments-      where-        -- all top level field assignments-        toplevelassignments    = rassignments rules-        -- all field assignments in conditional blocks assigning to field f and active for the current csv record-        conditionalassignments = concatMap cbAssignments $ filter isBlockActive $ (rblocksassigning rules) f-          where-            -- does this conditional block match the current csv record ?-            isBlockActive :: ConditionalBlock -> Bool-            isBlockActive CB{..} = any (all matcherMatches) $ groupedMatchers cbMatchers-              where-                -- does this individual matcher match the current csv record ?-                matcherMatches :: Matcher -> Bool-                matcherMatches (RecordMatcher _ pat) = regexMatchText pat' wholecsvline-                  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-                matcherMatches (FieldMatcher _ csvfieldref pat) = regexMatchText pat csvfieldvalue-                  where-                    -- the value of the referenced CSV field to match against.-                    csvfieldvalue = dbg7 "csvfieldvalue" $ replaceCsvFieldReference rules record csvfieldref---- | Render a field assignment's template, possibly interpolating referenced--- CSV field values. Outer whitespace is removed from interpolated values.-renderTemplate ::  CsvRules -> CsvRecord -> FieldTemplate -> Text-renderTemplate rules record t = maybe t mconcat $ parseMaybe-    (many $ takeWhile1P Nothing (/='%')-        <|> replaceCsvFieldReference rules record <$> referencep)-    t-  where-    referencep = liftA2 T.cons (char '%') (takeWhile1P (Just "reference") isFieldNameChar) :: Parsec HledgerParseErrorData Text Text-    isFieldNameChar c = isAlphaNum c || c == '_' || c == '-'---- | 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-replaceCsvFieldReference rules record s = case T.uncons s of-    Just ('%', fieldname) -> fromMaybe "" $ csvFieldValue rules record fieldname-    _                     -> s---- | 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.-csvFieldValue :: CsvRules -> CsvRecord -> CsvFieldName -> Maybe Text-csvFieldValue rules record fieldname = do-  fieldindex <--    if T.all isDigit fieldname -    then readMay $ T.unpack fieldname-    else lookup (T.toLower fieldname) $ rcsvfieldindexes rules-  T.strip <$> atMay record (fieldindex-1)---- | Parse the date string using the specified date-format, or if unspecified--- the "simple date" formats (YYYY/MM/DD, YYYY-MM-DD, YYYY.MM.DD, leading--- zeroes optional). If a timezone is provided, we assume the DateFormat--- produces a zoned time and we localise that to the given timezone.-parseDateWithCustomOrDefaultFormats :: Bool -> Maybe TimeZone -> TimeZone -> Maybe DateFormat -> Text -> Maybe Day-parseDateWithCustomOrDefaultFormats timesarezoned mtzin tzout mformat s = localdate <$> mutctime-  -- this time code can probably be simpler, I'm just happy to get out alive-  where-    localdate :: UTCTime -> Day =-      localDay .-      dbg7 ("time in output timezone "++show tzout) .-      utcToLocalTime tzout-    mutctime :: Maybe UTCTime = asum $ map parseWithFormat formats--    parseWithFormat :: String -> Maybe UTCTime-    parseWithFormat fmt =-      if timesarezoned-      then-        dbg7 "zoned CSV time, expressed as UTC" $-        parseTimeM True defaultTimeLocale fmt $ T.unpack s :: Maybe UTCTime-      else-        -- parse as a local day and time; then if an input timezone is provided,-        -- assume it's in that, otherwise assume it's in the output timezone;-        -- then convert to UTC like the above-        let-          mlocaltime =-            fmap (dbg7 "unzoned CSV time") $-            parseTimeM True defaultTimeLocale fmt $ T.unpack s :: Maybe LocalTime-          localTimeAsZonedTime tz lt =  ZonedTime lt tz-        in-          case mtzin of-            Just tzin ->-              (dbg7 ("unzoned CSV time, declared as "++show tzin++ ", expressed as UTC") . -              localTimeToUTC tzin)-              <$> mlocaltime-            Nothing ->-              (dbg7 ("unzoned CSV time, treated as "++show tzout++ ", expressed as UTC") .-                zonedTimeToUTC .-                localTimeAsZonedTime tzout)-              <$> mlocaltime--    formats = map T.unpack $ maybe-               ["%Y/%-m/%-d"-               ,"%Y-%-m-%-d"-               ,"%Y.%-m.%-d"-               -- ,"%-m/%-d/%Y"-                -- ,parseTimeM TruedefaultTimeLocale "%Y/%m/%e" (take 5 s ++ "0" ++ drop 5 s)-                -- ,parseTimeM TruedefaultTimeLocale "%Y-%m-%e" (take 5 s ++ "0" ++ drop 5 s)-                -- ,parseTimeM TruedefaultTimeLocale "%m/%e/%Y" ('0':s)-                -- ,parseTimeM TruedefaultTimeLocale "%m-%e-%Y" ('0':s)-               ]-               (:[])-                mformat----- ** tests--tests_CsvReader = testGroup "CsvReader" [-   testGroup "parseCsvRules" [-     testCase "empty file" $-      parseCsvRules "unknown" "" @?= Right (mkrules defrules)-   ]-  ,testGroup "rulesp" [-     testCase "trailing comments" $-      parseWithState' defrules rulesp "skip\n# \n#\n" @?= Right (mkrules $ defrules{rdirectives = [("skip","")]})--    ,testCase "trailing blank lines" $-      parseWithState' defrules rulesp "skip\n\n  \n" @?= (Right (mkrules $ defrules{rdirectives = [("skip","")]}))--    ,testCase "no final newline" $-      parseWithState' defrules rulesp "skip" @?= (Right (mkrules $ defrules{rdirectives=[("skip","")]}))--    ,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")]}]}))-   ]-  ,testGroup "conditionalblockp" [-    testCase "space after conditional" $ -- #1120-       -- #1120-       -- #1120-       -- #1120-       -- #1120-       -- #1120-       -- #1120-       -- #1120-       -- #1120-       -- #1120-       -- #1120-       -- #1120-       -- #1120-       -- #1120-       -- #1120-       -- #1120-       -- #1120-       -- #1120-       -- #1120-       -- #1120-       -- #1120-       -- #1120-       -- #1120-       -- #1120-       -- #1120-       -- #1120-       -- #1120-       -- #1120-       -- #1120-       -- #1120-       -- #1120-       -- #1120-      parseWithState' defrules conditionalblockp "if a\n account2 b\n \n" @?=-        (Right $ CB{cbMatchers=[RecordMatcher None $ toRegexCI' "a"],cbAssignments=[("account2","b")]})--  ,testGroup "csvfieldreferencep" [-    testCase "number" $ parseWithState' defrules csvfieldreferencep "%1" @?= (Right "%1")-   ,testCase "name" $ parseWithState' defrules csvfieldreferencep "%date" @?= (Right "%date")-   ,testCase "quoted name" $ parseWithState' defrules csvfieldreferencep "%\"csv date\"" @?= (Right "%\"csv date\"")-   ]--  ,testGroup "matcherp" [--    testCase "recordmatcherp" $-      parseWithState' defrules matcherp "A A\n" @?= (Right $ RecordMatcher None $ 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")--   ,testCase "fieldmatcherp" $-      parseWithState' defrules matcherp "%description A A\n" @?= (Right $ FieldMatcher None "%description" $ toRegexCI' "A A")--   ,testCase "fieldmatcherp.starts-with-&" $-      parseWithState' defrules matcherp "& %description A A\n" @?= (Right $ FieldMatcher And "%description" $ toRegexCI' "A A")--   -- ,testCase "fieldmatcherp with operator" $-   --    parseWithState' defrules matcherp "%description ~ A A\n" @?= (Right $ FieldMatcher "%description" "A A")--   ]--  ,testGroup "getEffectiveAssignment" [-    let rules = mkrules $ defrules {rcsvfieldindexes=[("csvdate",1)],rassignments=[("date","%csvdate")]}--    in testCase "toplevel" $ getEffectiveAssignment rules ["a","b"] "date" @?= (Just "%csvdate")--   ,let rules = mkrules $ defrules{rcsvfieldindexes=[("csvdate",1)], rconditionalblocks=[CB [FieldMatcher None "%csvdate" $ toRegex' "a"] [("date","%csvdate")]]}-    in testCase "conditional" $ getEffectiveAssignment rules ["a","b"] "date" @?= (Just "%csvdate")--   ,let rules = mkrules $ defrules{rcsvfieldindexes=[("csvdate",1),("description",2)], rconditionalblocks=[CB [FieldMatcher None "%csvdate" $ toRegex' "a", FieldMatcher None "%description" $ toRegex' "b"] [("date","%csvdate")]]}-    in testCase "conditional-with-or-a" $ getEffectiveAssignment rules ["a"] "date" @?= (Just "%csvdate")--   ,let rules = mkrules $ defrules{rcsvfieldindexes=[("csvdate",1),("description",2)], rconditionalblocks=[CB [FieldMatcher None "%csvdate" $ toRegex' "a", FieldMatcher None "%description" $ toRegex' "b"] [("date","%csvdate")]]}-    in testCase "conditional-with-or-b" $ getEffectiveAssignment rules ["_", "b"] "date" @?= (Just "%csvdate")--   ,let rules = mkrules $ defrules{rcsvfieldindexes=[("csvdate",1),("description",2)], rconditionalblocks=[CB [FieldMatcher None "%csvdate" $ toRegex' "a", FieldMatcher And "%description" $ toRegex' "b"] [("date","%csvdate")]]}-    in testCase "conditional.with-and" $ getEffectiveAssignment rules ["a", "b"] "date" @?= (Just "%csvdate")--   ,let rules = mkrules $ defrules{rcsvfieldindexes=[("csvdate",1),("description",2)], rconditionalblocks=[CB [FieldMatcher None "%csvdate" $ toRegex' "a", FieldMatcher And "%description" $ toRegex' "b", FieldMatcher None "%description" $ toRegex' "c"] [("date","%csvdate")]]}-    in testCase "conditional.with-and-or" $ getEffectiveAssignment rules ["_", "c"] "date" @?= (Just "%csvdate")--   ]--  ]-- ]+A reader for CSV (character-separated) data.+This also reads a rules file to help interpret the CSV data.++-}++--- ** language+{-# LANGUAGE FlexibleContexts     #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE OverloadedStrings    #-}+{-# LANGUAGE ScopedTypeVariables  #-}+{-# LANGUAGE TypeFamilies         #-}++--- ** exports+module Hledger.Read.CsvReader (+  -- * Reader+  reader,+  -- * Tests+  tests_CsvReader,+)+where++--- ** imports+import Prelude hiding (Applicative(..))+import Control.Monad.Except       (ExceptT(..), liftEither)+import Control.Monad.IO.Class     (MonadIO)+import Data.Text (Text)++import Hledger.Data+import Hledger.Utils+import Hledger.Read.Common (aliasesFromOpts, Reader(..), InputOpts(..), journalFinalise)+import Hledger.Read.RulesReader (readJournalFromCsv)++--- ** doctest setup+-- $setup+-- >>> :set -XOverloadedStrings++--- ** reader++reader :: MonadIO m => Reader m+reader = Reader+  {rFormat     = "csv"+  ,rExtensions = ["csv","tsv","ssv"]+  ,rReadFn     = parse+  ,rParser     = error' "sorry, CSV files can't be included yet"  -- PARTIAL:+  }++-- | Parse and post-process a "Journal" from CSV data, or give an error.+-- This currently ignores the provided data, and reads it from the file path instead.+-- This file path is normally the CSV(/SSV/TSV) data file, and a corresponding rules file is inferred.+-- But it can also be the rules file, in which case the corresponding data file is inferred.+-- This does not check balance assertions.+parse :: InputOpts -> FilePath -> Text -> ExceptT String IO Journal+parse iopts f t = do+  let mrulesfile = mrules_file_ iopts+  readJournalFromCsv (Right <$> mrulesfile) f t+  -- apply any command line account aliases. Can fail with a bad replacement pattern.+  >>= liftEither . journalApplyAliases (aliasesFromOpts iopts)+      -- journalFinalise assumes the journal's items are+      -- reversed, as produced by JournalReader's parser.+      -- But here they are already properly ordered. So we'd+      -- better preemptively reverse them once more. XXX inefficient+      . journalReverse+  >>= journalFinalise iopts{balancingopts_=(balancingopts_ iopts){ignore_assertions_=True}} f t++--- ** tests++tests_CsvReader = testGroup "CsvReader" [+  ]+

@@ -0,0 +1,49 @@+--- * -*- outline-regexp:"--- \\*"; -*-+--- ** doc+{-|++CSV utilities.++-}++--- ** language+{-# LANGUAGE OverloadedStrings    #-}++--- ** exports+module Hledger.Read.CsvUtils (+  CSV, CsvRecord, CsvValue,+  printCSV,+  -- * Tests+  tests_CsvUtils,+)+where++--- ** imports+import Prelude hiding (Applicative(..))+import Data.List (intersperse)+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 Hledger.Utils++--- ** doctest setup+-- $setup+-- >>> :set -XOverloadedStrings++type CSV       = [CsvRecord]+type CsvRecord = [CsvValue]+type CsvValue  = Text++printCSV :: [CsvRecord] -> TL.Text+printCSV = TB.toLazyText . unlinesB . map printRecord+    where printRecord = foldMap TB.fromText . intersperse "," . map printField+          printField = wrap "\"" "\"" . T.replace "\"" "\"\""++--- ** tests++tests_CsvUtils :: TestTree+tests_CsvUtils = testGroup "CsvUtils" [+  ]+

@@ -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+    ,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 automatic postings when journal is parsed ?     ,infer_equity_      :: Bool                 -- ^ infer equity conversion postings from costs ?@@ -53,6 +54,7 @@     , new_save_          = True     , pivot_             = ""     , forecast_          = Nothing+    , verbose_tags_      = False     , reportspan_        = nulldatespan     , auto_              = False     , infer_equity_      = False

@@ -100,9 +100,10 @@ import Hledger.Read.Common import Hledger.Utils -import qualified Hledger.Read.TimedotReader as TimedotReader (reader)-import qualified Hledger.Read.TimeclockReader as TimeclockReader (reader) import qualified Hledger.Read.CsvReader as CsvReader (reader)+import qualified Hledger.Read.RulesReader as RulesReader (reader)+import qualified Hledger.Read.TimeclockReader as TimeclockReader (reader)+import qualified Hledger.Read.TimedotReader as TimedotReader (reader)  --- ** doctest setup -- $setup@@ -137,6 +138,7 @@   reader  ,TimeclockReader.reader  ,TimedotReader.reader+ ,RulesReader.reader  ,CsvReader.reader --  ,LedgerReader.reader  ]@@ -168,7 +170,7 @@ -- split that off. Eg "csv:-" -> (Just "csv", "-"). splitReaderPrefix :: PrefixedFilePath -> (Maybe String, FilePath) splitReaderPrefix f =-  headDef (Nothing, f)+  headDef (Nothing, f) $   [(Just r, drop (length r + 1) f) | r <- readerNames, (r++":") `isPrefixOf` f]  --- ** reader

@@ -0,0 +1,2994 @@+--- * module+--- ** doc+-- In Emacs, use TAB on lines beginning with "-- *" to collapse/expand sections.+{-|++A reader for a CSV rules file. +This reads the actual data from a file specified by a `source` rule+or from a similarly-named file in the same directory.++Most of the code for reading rules files and csv files is in this module.+-}+-- Lots of haddocks in this file are for non-exported types.+-- Here's a command that will render them:+-- stack haddock hledger-lib --fast --no-haddock-deps --haddock-arguments='--ignore-all-exports' --open++--- ** language+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE OverloadedStrings    #-}+{-# LANGUAGE RecordWildCards      #-}+{-# LANGUAGE ScopedTypeVariables  #-}+{-# LANGUAGE ViewPatterns         #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++--- ** exports+module Hledger.Read.RulesReader (+  -- * Reader+  reader,+  -- * Misc.+  readJournalFromCsv,+  -- readRulesFile,+  -- parseCsvRules,+  -- validateCsvRules,+  -- CsvRules,+  dataFileFor,+  rulesFileFor,+  -- * Tests+  tests_RulesReader,+)+where++--- ** imports+import Prelude hiding (Applicative(..))+import Control.Applicative (Applicative(..))+import Control.Monad              (unless, when, void)+import Control.Monad.Except       (ExceptT(..), liftEither, throwError)+import qualified Control.Monad.Fail as Fail+import Control.Monad.IO.Class     (MonadIO, liftIO)+import Control.Monad.State.Strict (StateT, get, modify', evalStateT)+import Control.Monad.Trans.Class  (lift)+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.Extra (groupOn)+import Data.Maybe (catMaybes, fromMaybe, isJust)+import Data.MemoUgly (memo)+import qualified Data.Set as S+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Text.IO as T+import Data.Time ( Day, TimeZone, UTCTime, LocalTime, ZonedTime(ZonedTime),+  defaultTimeLocale, getCurrentTimeZone, localDay, parseTimeM, utcToLocalTime, localTimeToUTC, zonedTimeToUTC)+import Safe (atMay, headMay, lastMay, readMay)+import System.FilePath ((</>), takeDirectory, takeExtension, stripExtension, takeFileName)+import qualified Data.Csv as Cassava+import qualified Data.Csv.Parser.Megaparsec as CassavaMegaparsec+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import Data.Foldable (asum, toList)+import Text.Megaparsec hiding (match, parse)+import Text.Megaparsec.Char (char, newline, string)+import Text.Megaparsec.Custom (parseErrorAt)+import Text.Printf (printf)++import Hledger.Data+import Hledger.Utils+import Hledger.Read.Common (aliasesFromOpts, Reader(..), InputOpts(..), amountp, statusp, journalFinalise, accountnamep )+import Hledger.Read.CsvUtils+import System.Directory (doesFileExist, getHomeDirectory)++--- ** doctest setup+-- $setup+-- >>> :set -XOverloadedStrings++--- ** reader+_READER__________________________________________ = undefined  -- VSCode outline separator+++reader :: MonadIO m => Reader m+reader = Reader+  {rFormat     = "rules"+  ,rExtensions = ["rules"]+  ,rReadFn     = parse+  ,rParser     = error' "sorry, rules files can't be included"  -- PARTIAL:+  }++isFileName f = takeFileName f == f++getDownloadDir = do+  home <- getHomeDirectory+  return $ home </> "Downloads"  -- XXX++-- | Parse and post-process a "Journal" from the given rules file path, or give an error.+-- A data file is inferred from the @source@ rule, otherwise from a similarly-named file+-- in the same directory.+-- The source rule can specify a glob pattern and supports ~ for home directory.+-- If it is a bare filename it will be relative to the defaut download directory+-- on this system. If is a relative file path it will be relative to the rules+-- file's directory. When a glob pattern matches multiple files, the alphabetically+-- last is used. (Eg in case of multiple numbered downloads, the highest-numbered+-- will be used.)+-- The provided text, or a --rules-file option, are ignored by this reader.+-- Balance assertions are not checked.+parse :: InputOpts -> FilePath -> Text -> ExceptT String IO Journal+parse iopts f _ = do+  rules <- readRulesFile $ dbg4 "reading rules file" f+  -- XXX higher-than usual debug level for file reading to bypass excessive noise from elsewhere, normally 6 or 7+  mdatafile <- liftIO $ do+    dldir <- getDownloadDir+    let rulesdir = takeDirectory f+    let msource = T.unpack <$> getDirective "source" rules+    fs <- case msource of+            Just src -> expandGlob dir (dbg4 "source" src) >>= sortByModTime <&> dbg4 ("matched files"<>desc<>", newest first")+              where (dir,desc) = if isFileName src then (dldir," in download directory") else (rulesdir,"")+            Nothing  -> return [maybe err (dbg4 "inferred source") $ dataFileFor f]  -- shouldn't fail, f has .rules extension+              where err = error' $ "could not infer a data file for " <> f+    return $ dbg4 "data file" $ headMay fs+  case mdatafile of+    Nothing -> return nulljournal  -- data file specified by source rule was not found+    Just dat -> do+      exists <- liftIO $ doesFileExist dat+      if not (dat=="-" || exists)+      then return nulljournal      -- data file inferred from rules file name was not found+      else do+        t <- liftIO $ readFileOrStdinPortably dat+        readJournalFromCsv (Just $ Left rules) dat t+        -- apply any command line account aliases. Can fail with a bad replacement pattern.+        >>= liftEither . journalApplyAliases (aliasesFromOpts iopts)+            -- journalFinalise assumes the journal's items are+            -- reversed, as produced by JournalReader's parser.+            -- But here they are already properly ordered. So we'd+            -- better preemptively reverse them once more. XXX inefficient+            . journalReverse+        >>= journalFinalise iopts{balancingopts_=(balancingopts_ iopts){ignore_assertions_=True}} f ""++--- ** reading rules files+--- *** rules utilities+_RULES_READING__________________________________________ = undefined++-- | Given a rules file path, what would be the corresponding data file ?+-- (Remove a .rules extension.)+dataFileFor :: FilePath -> Maybe FilePath+dataFileFor = stripExtension "rules"++-- | Given a csv file path, what would be the corresponding rules file ?+-- (Add a .rules extension.)+rulesFileFor :: FilePath -> FilePath+rulesFileFor = (++ ".rules")++-- | An exception-throwing IO action that reads and validates+-- the specified CSV rules file (which may include other rules files).+readRulesFile :: FilePath -> ExceptT String IO CsvRules+readRulesFile f =+  liftIO (do+    dbg6IO "using conversion rules file" f+    readFilePortably f >>= expandIncludes (takeDirectory f)+  ) >>= either throwError return . parseAndValidateCsvRules f++-- | Inline all files referenced by include directives in this hledger CSV rules text, recursively.+-- Included file paths may be relative to the directory of the provided file path.+-- This is done as a pre-parse step to simplify the CSV rules parser.+expandIncludes :: FilePath -> Text -> IO Text+expandIncludes dir0 content = mapM (expandLine dir0) (T.lines content) <&> T.unlines+  where+    expandLine dir1 line =+      case line of+        (T.stripPrefix "include " -> Just f) -> expandIncludes dir2 =<< T.readFile f'+          where+            f' = dir1 </> T.unpack (T.dropWhile isSpace f)+            dir2 = takeDirectory f'+        _ -> return line++-- defaultRulesText :: FilePath -> Text+-- defaultRulesText _csvfile = T.pack $ unlines+--   ["# hledger csv conversion rules" --  for " ++ csvFileFor (takeFileName csvfile)+--   ,"# cf http://hledger.org/hledger.html#csv"+--   ,""+--   ,"account1 assets:bank:checking"+--   ,""+--   ,"fields date, description, amount1"+--   ,""+--   ,"#skip 1"+--   ,"#newest-first"+--   ,""+--   ,"#date-format %-d/%-m/%Y"+--   ,"#date-format %-m/%-d/%Y"+--   ,"#date-format %Y-%h-%d"+--   ,""+--   ,"#currency $"+--   ,""+--   ,"if ITUNES"+--   ," account2 expenses:entertainment"+--   ,""+--   ,"if (TO|FROM) SAVINGS"+--   ," account2 assets:bank:savings\n"+--   ]++-- | An error-throwing IO action that parses this text as CSV conversion rules+-- and runs some extra validation checks. The file path is used in error messages.+parseAndValidateCsvRules :: FilePath -> T.Text -> Either String CsvRules+parseAndValidateCsvRules rulesfile s =+  case parseCsvRules rulesfile s of+    Left err    -> Left $ customErrorBundlePretty err+    Right rules -> first makeFancyParseError $ validateCsvRules rules+  where+    makeFancyParseError :: String -> String+    makeFancyParseError errorString =+      parseErrorPretty (FancyError 0 (S.singleton $ ErrorFail errorString) :: ParseError Text String)++instance ShowErrorComponent String where+  showErrorComponent = id++-- | Parse this text as CSV conversion rules. The file path is for error messages.+parseCsvRules :: FilePath -> T.Text -> Either (ParseErrorBundle T.Text HledgerParseErrorData) CsvRules+-- parseCsvRules rulesfile s = runParser csvrulesfile nullrules{baseAccount=takeBaseName rulesfile} rulesfile s+parseCsvRules = runParser (evalStateT rulesp defrules)++-- | Return the validated rules, or an error.+validateCsvRules :: CsvRules -> Either String CsvRules+validateCsvRules rules = do+  unless (isAssigned "date")   $ Left "Please specify (at top level) the date field. Eg: date %1"+  Right rules+  where+    isAssigned f = isJust $ getEffectiveAssignment rules [] f++--- *** rules types+_RULES_TYPES__________________________________________ = undefined++-- | A set of data definitions and account-matching patterns sufficient to+-- convert a particular CSV data file into meaningful journal transactions.+data CsvRules' a = CsvRules' {+  rdirectives        :: [(DirectiveName,Text)],+    -- ^ top-level rules, as (keyword, value) pairs+  rcsvfieldindexes   :: [(CsvFieldName, CsvFieldIndex)],+    -- ^ csv field names and their column number, if declared by a fields list+  rassignments       :: [(HledgerFieldName, FieldTemplate)],+    -- ^ top-level assignments to hledger fields, as (field name, value template) pairs+  rconditionalblocks :: [ConditionalBlock],+    -- ^ conditional blocks, which containing additional assignments/rules to apply to matched csv records+  rblocksassigning :: a -- (String -> [ConditionalBlock])+    -- ^ all conditional blocks which can potentially assign field with a given name (memoized)+}++-- | Type used by parsers. Directives, assignments and conditional blocks+-- are in the reverse order compared to what is in the file and rblocksassigning is non-functional,+-- could not be used for processing CSV records yet+type CsvRulesParsed = CsvRules' ()++-- | Type used after parsing is done. Directives, assignments and conditional blocks+-- are in the same order as they were in the unput file and rblocksassigning is functional.+-- Ready to be used for CSV record processing+type CsvRules = CsvRules' (Text -> [ConditionalBlock])  -- XXX simplify++instance Eq CsvRules where+  r1 == r2 = (rdirectives r1, rcsvfieldindexes r1, rassignments r1) ==+             (rdirectives r2, rcsvfieldindexes r2, rassignments r2)++-- Custom Show instance used for debug output: omit the rblocksassigning field, which isn't showable.+instance Show CsvRules where+  show r = "CsvRules { rdirectives = " ++ show (rdirectives r) +++           ", rcsvfieldindexes = "     ++ show (rcsvfieldindexes r) +++           ", rassignments = "         ++ show (rassignments r) +++           ", rconditionalblocks = "   ++ show (rconditionalblocks r) +++           " }"++type CsvRulesParser a = StateT CsvRulesParsed SimpleTextParser a++-- | The keyword of a CSV rule - "fields", "skip", "if", etc.+type DirectiveName    = Text++-- | CSV field name.+type CsvFieldName     = Text++-- | 1-based CSV column number.+type CsvFieldIndex    = Int++-- | Percent symbol followed by a CSV field name or column number. Eg: %date, %1.+type CsvFieldReference = Text++-- | One of the standard hledger fields or pseudo-fields that can be assigned to.+-- Eg date, account1, amount, amount1-in, date-format.+type HledgerFieldName = Text++-- | A text value to be assigned to a hledger field, possibly+-- containing csv field references to be interpolated.+type FieldTemplate    = Text++-- | 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 | None+  deriving (Show, Eq)++-- | A single test for matching a CSV record, in one way or another.+data Matcher =+    RecordMatcher MatcherPrefix Regexp                          -- ^ match if this regexp matches the overall CSV record+  | FieldMatcher MatcherPrefix CsvFieldReference Regexp         -- ^ match if this regexp matches the referenced CSV field's value+  deriving (Show, Eq)++-- | 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.+--+-- Three types of rule are allowed inside conditional blocks: field+-- assignments, skip, end. (A skip or end rule is stored as if it was+-- a field assignment, and executed in validateCsv. XXX)+data ConditionalBlock = CB {+   cbMatchers    :: [Matcher]+  ,cbAssignments :: [(HledgerFieldName, FieldTemplate)]+  } deriving (Show, Eq)++defrules :: CsvRulesParsed+defrules = CsvRules' {+  rdirectives=[],+  rcsvfieldindexes=[],+  rassignments=[],+  rconditionalblocks=[],+  rblocksassigning = ()+  }++-- | Create CsvRules from the content parsed out of the rules file+mkrules :: CsvRulesParsed -> CsvRules+mkrules rules =+  let conditionalblocks = reverse $ rconditionalblocks rules+      maybeMemo = if length conditionalblocks >= 15 then memo else id+  in+    CsvRules' {+    rdirectives=reverse $ rdirectives rules,+    rcsvfieldindexes=rcsvfieldindexes rules,+    rassignments=reverse $ rassignments rules,+    rconditionalblocks=conditionalblocks,+    rblocksassigning = maybeMemo (\f -> filter (any ((==f).fst) . cbAssignments) conditionalblocks)+    }++--- *** rules parsers+_RULES_PARSING__________________________________________ = undefined++{-+Grammar for the CSV conversion rules, more or less:++RULES: RULE*++RULE: ( SOURCE | FIELD-LIST | FIELD-ASSIGNMENT | CONDITIONAL-BLOCK | SKIP | TIMEZONE | NEWEST-FIRST | INTRA-DAY-REVERSED | DATE-FORMAT | DECIMAL-MARK | COMMENT | BLANK ) NEWLINE++SOURCE: source SPACE FILEPATH++FIELD-LIST: fields SPACE FIELD-NAME ( SPACE? , SPACE? FIELD-NAME )*++FIELD-NAME: QUOTED-FIELD-NAME | BARE-FIELD-NAME++QUOTED-FIELD-NAME: " (any CHAR except double-quote)+ "++BARE-FIELD-NAME: any CHAR except space, tab, #, ;++FIELD-ASSIGNMENT: JOURNAL-FIELD ASSIGNMENT-SEPARATOR FIELD-VALUE++JOURNAL-FIELD: date | date2 | status | code | description | comment | account1 | account2 | amount | JOURNAL-PSEUDO-FIELD++JOURNAL-PSEUDO-FIELD: amount-in | amount-out | currency++ASSIGNMENT-SEPARATOR: SPACE | ( : SPACE? )++FIELD-VALUE: VALUE (possibly containing CSV-FIELD-REFERENCEs)++CSV-FIELD-REFERENCE: % CSV-FIELD++CSV-FIELD: ( FIELD-NAME | FIELD-NUMBER ) (corresponding to a CSV field)++FIELD-NUMBER: DIGIT+++CONDITIONAL-BLOCK: if ( FIELD-MATCHER NEWLINE )+ INDENTED-BLOCK++FIELD-MATCHER: ( CSV-FIELD-NAME SPACE? )? ( MATCHOP SPACE? )? PATTERNS++MATCHOP: ~++PATTERNS: ( NEWLINE REGEXP )* REGEXP++INDENTED-BLOCK: ( SPACE ( FIELD-ASSIGNMENT | COMMENT ) NEWLINE )+++REGEXP: ( NONSPACE CHAR* ) SPACE?++VALUE: SPACE? ( CHAR* ) SPACE?++COMMENT: SPACE? COMMENT-CHAR VALUE++COMMENT-CHAR: # | ; | *++NONSPACE: any CHAR not a SPACE-CHAR++BLANK: SPACE?++SPACE: SPACE-CHAR+++SPACE-CHAR: space | tab++CHAR: any character except newline++DIGIT: 0-9++-}++addDirective :: (DirectiveName, Text) -> CsvRulesParsed -> CsvRulesParsed+addDirective d r = r{rdirectives=d:rdirectives r}++addAssignment :: (HledgerFieldName, FieldTemplate) -> CsvRulesParsed -> CsvRulesParsed+addAssignment a r = r{rassignments=a:rassignments r}++setIndexesAndAssignmentsFromList :: [CsvFieldName] -> CsvRulesParsed -> CsvRulesParsed+setIndexesAndAssignmentsFromList fs = addAssignmentsFromList fs . setCsvFieldIndexesFromList fs+  where+    setCsvFieldIndexesFromList :: [CsvFieldName] -> CsvRulesParsed -> CsvRulesParsed+    setCsvFieldIndexesFromList fs' r = r{rcsvfieldindexes=zip fs' [1..]}++    addAssignmentsFromList :: [CsvFieldName] -> CsvRulesParsed -> CsvRulesParsed+    addAssignmentsFromList fs' r = foldl' maybeAddAssignment r journalfieldnames+      where+        maybeAddAssignment rules f = (maybe id addAssignmentFromIndex $ elemIndex f fs') rules+          where+            addAssignmentFromIndex i = addAssignment (f, T.pack $ '%':show (i+1))++addConditionalBlock :: ConditionalBlock -> CsvRulesParsed -> CsvRulesParsed+addConditionalBlock b r = r{rconditionalblocks=b:rconditionalblocks r}++addConditionalBlocks :: [ConditionalBlock] -> CsvRulesParsed -> CsvRulesParsed+addConditionalBlocks bs r = r{rconditionalblocks=bs++rconditionalblocks r}++rulesp :: CsvRulesParser CsvRules+rulesp = do+  _ <- many $ choice+    [blankorcommentlinep                                                <?> "blank or comment line"+    ,(directivep        >>= modify' . addDirective)                     <?> "directive"+    ,(fieldnamelistp    >>= modify' . setIndexesAndAssignmentsFromList) <?> "field name list"+    ,(fieldassignmentp  >>= modify' . addAssignment)                    <?> "field assignment"+    -- conditionalblockp backtracks because it shares "if" prefix with conditionaltablep.+    ,try (conditionalblockp >>= modify' . addConditionalBlock)          <?> "conditional block"+    -- 'reverse' is there to ensure that conditions are added in the order they listed in the file+    ,(conditionaltablep >>= modify' . addConditionalBlocks . reverse)   <?> "conditional table"+    ]+  eof+  mkrules <$> get++blankorcommentlinep :: CsvRulesParser ()+blankorcommentlinep = lift (dbgparse 8 "trying blankorcommentlinep") >> choiceInState [blanklinep, commentlinep]++blanklinep :: CsvRulesParser ()+blanklinep = lift skipNonNewlineSpaces >> newline >> return () <?> "blank line"++commentlinep :: CsvRulesParser ()+commentlinep = lift skipNonNewlineSpaces >> commentcharp >> lift restofline >> return () <?> "comment line"++commentcharp :: CsvRulesParser Char+commentcharp = oneOf (";#*" :: [Char])++directivep :: CsvRulesParser (DirectiveName, Text)+directivep = (do+  lift $ dbgparse 8 "trying directive"+  d <- choiceInState $ map (lift . string) directives+  v <- (((char ':' >> lift (many spacenonewline)) <|> lift (some spacenonewline)) >> directivevalp)+       <|> (optional (char ':') >> lift skipNonNewlineSpaces >> lift eolof >> return "")+  return (d, v)+  ) <?> "directive"++directives :: [Text]+directives =+  ["source"+  ,"date-format"+  ,"decimal-mark"+  ,"separator"+  -- ,"default-account"+  -- ,"default-currency"+  ,"skip"+  ,"timezone"+  ,"newest-first"+  ,"intra-day-reversed"+  , "balance-type"+  ]++directivevalp :: CsvRulesParser Text+directivevalp = T.pack <$> anySingle `manyTill` lift eolof++fieldnamelistp :: CsvRulesParser [CsvFieldName]+fieldnamelistp = (do+  lift $ dbgparse 8 "trying fieldnamelist"+  string "fields"+  optional $ char ':'+  lift skipNonNewlineSpaces1+  let separator = lift skipNonNewlineSpaces >> char ',' >> lift skipNonNewlineSpaces+  f <- fromMaybe "" <$> optional fieldnamep+  fs <- some $ (separator >> fromMaybe "" <$> optional fieldnamep)+  lift restofline+  return . map T.toLower $ f:fs+  ) <?> "field name list"++fieldnamep :: CsvRulesParser Text+fieldnamep = quotedfieldnamep <|> barefieldnamep++quotedfieldnamep :: CsvRulesParser Text+quotedfieldnamep =+    char '"' *> takeWhile1P Nothing (`notElem` ("\"\n:;#~" :: [Char])) <* char '"'++barefieldnamep :: CsvRulesParser Text+barefieldnamep = takeWhile1P Nothing (`notElem` (" \t\n,;#~" :: [Char]))++fieldassignmentp :: CsvRulesParser (HledgerFieldName, FieldTemplate)+fieldassignmentp = do+  lift $ dbgparse 8 "trying fieldassignmentp"+  f <- journalfieldnamep+  v <- choiceInState [ assignmentseparatorp >> fieldvalp+                     , lift eolof >> return ""+                     ]+  return (f,v)+  <?> "field assignment"++journalfieldnamep :: CsvRulesParser Text+journalfieldnamep = do+  lift (dbgparse 8 "trying journalfieldnamep")+  choiceInState $ map (lift . string) journalfieldnames++maxpostings = 99++-- Transaction fields and pseudo fields for CSV conversion.+-- Names must precede any other name they contain, for the parser+-- (amount-in before amount; date2 before date). TODO: fix+journalfieldnames =+  concat [[ "account" <> i+          ,"amount" <> i <> "-in"+          ,"amount" <> i <> "-out"+          ,"amount" <> i+          ,"balance" <> i+          ,"comment" <> i+          ,"currency" <> i+          ] | x <- [maxpostings, (maxpostings-1)..1], let i = T.pack $ show x]+  +++  ["amount-in"+  ,"amount-out"+  ,"amount"+  ,"balance"+  ,"code"+  ,"comment"+  ,"currency"+  ,"date2"+  ,"date"+  ,"description"+  ,"status"+  ,"skip" -- skip and end are not really fields, but we list it here to allow conditional rules that skip records+  ,"end"+  ]++assignmentseparatorp :: CsvRulesParser ()+assignmentseparatorp = do+  lift $ dbgparse 8 "trying assignmentseparatorp"+  _ <- choiceInState [ lift skipNonNewlineSpaces >> char ':' >> lift skipNonNewlineSpaces+                     , lift skipNonNewlineSpaces1+                     ]+  return ()++fieldvalp :: CsvRulesParser Text+fieldvalp = do+  lift $ dbgparse 8 "trying fieldvalp"+  T.pack <$> anySingle `manyTill` lift eolof++-- A conditional block: one or more matchers, one per line, followed by one or more indented rules.+conditionalblockp :: CsvRulesParser ConditionalBlock+conditionalblockp = do+  lift $ dbgparse 8 "trying conditionalblockp"+  -- "if\nMATCHER" or "if    \nMATCHER" or "if MATCHER"+  start <- getOffset+  string "if" >> ( (newline >> return Nothing)+                  <|> (lift skipNonNewlineSpaces1 >> optional newline))+  ms <- some matcherp+  as <- catMaybes <$>+    many (lift skipNonNewlineSpaces1 >>+          choice [ lift eolof >> return Nothing+                 , fmap Just fieldassignmentp+                 ])+  when (null as) $+    customFailure $ parseErrorAt start $  "start of conditional block found, but no assignment rules afterward\n(assignment rules in a conditional block should be indented)"+  return $ CB{cbMatchers=ms, cbAssignments=as}+  <?> "conditional block"++-- A conditional table: "if" followed by separator, followed by some field names,+-- followed by many lines, each of which has:+-- one matchers, followed by field assignments (as many as there were fields)+conditionaltablep :: CsvRulesParser [ConditionalBlock]+conditionaltablep = do+  lift $ dbgparse 8 "trying conditionaltablep"+  start <- getOffset+  string "if"+  sep <- lift $ satisfy (\c -> not (isAlphaNum c || isSpace c))+  fields <- journalfieldnamep `sepBy1` (char sep)+  newline+  body <- flip manyTill (lift eolof) $ do+    off <- getOffset+    m <- matcherp' $ void $ char sep+    vs <- T.split (==sep) . T.pack <$> lift restofline+    if (length vs /= length fields)+      then customFailure $ parseErrorAt off $ ((printf "line of conditional table should have %d values, but this one has only %d" (length fields) (length vs)) :: String)+      else return (m,vs)+  when (null body) $+    customFailure $ parseErrorAt start $ "start of conditional table found, but no assignment rules afterward"+  return $ flip map body $ \(m,vs) ->+    CB{cbMatchers=[m], cbAssignments=zip fields vs}+  <?> "conditional table"++-- A single matcher, on one line.+matcherp' :: CsvRulesParser () -> CsvRulesParser Matcher+matcherp' end = try (fieldmatcherp end) <|> recordmatcherp end++matcherp :: CsvRulesParser Matcher+matcherp = matcherp' (lift eolof)++-- A single whole-record matcher.+-- A pattern on the whole line, not beginning with a csv field reference.+recordmatcherp :: CsvRulesParser () -> CsvRulesParser Matcher+recordmatcherp end = do+  lift $ dbgparse 8 "trying recordmatcherp"+  -- pos <- currentPos+  -- _  <- optional (matchoperatorp >> lift skipNonNewlineSpaces >> optional newline)+  p <- matcherprefixp+  r <- regexp end+  return $ RecordMatcher p r+  -- when (null ps) $+  --   Fail.fail "start of record matcher found, but no patterns afterward\n(patterns should not be indented)"+  <?> "record matcher"++-- | A single matcher for a specific field. A csv field reference+-- (like %date or %1), and a pattern on the rest of the line,+-- optionally space-separated. Eg:+-- %description chez jacques+fieldmatcherp :: CsvRulesParser () -> CsvRulesParser Matcher+fieldmatcherp end = do+  lift $ dbgparse 8 "trying fieldmatcher"+  -- An optional fieldname (default: "all")+  -- f <- fromMaybe "all" `fmap` (optional $ do+  --        f' <- fieldnamep+  --        lift skipNonNewlineSpaces+  --        return f')+  p <- matcherprefixp+  f <- csvfieldreferencep <* lift skipNonNewlineSpaces+  -- optional operator.. just ~ (case insensitive infix regex) for now+  -- _op <- fromMaybe "~" <$> optional matchoperatorp+  lift skipNonNewlineSpaces+  r <- regexp end+  return $ FieldMatcher p f r+  <?> "field matcher"++matcherprefixp :: CsvRulesParser MatcherPrefix+matcherprefixp = do+  lift $ dbgparse 8 "trying matcherprefixp"+  (char '&' >> lift skipNonNewlineSpaces >> return And) <|> return None++csvfieldreferencep :: CsvRulesParser CsvFieldReference+csvfieldreferencep = do+  lift $ dbgparse 8 "trying csvfieldreferencep"+  char '%'+  T.cons '%' . textQuoteIfNeeded <$> fieldnamep++-- A single regular expression+regexp :: CsvRulesParser () -> CsvRulesParser Regexp+regexp end = do+  lift $ dbgparse 8 "trying regexp"+  -- notFollowedBy matchoperatorp+  c <- lift nonspace+  cs <- anySingle `manyTill` end+  case toRegexCI . T.strip . T.pack $ c:cs of+       Left x -> Fail.fail $ "CSV parser: " ++ x+       Right x -> return x++-- -- A match operator, indicating the type of match to perform.+-- -- Currently just ~ meaning case insensitive infix regex match.+-- matchoperatorp :: CsvRulesParser String+-- matchoperatorp = fmap T.unpack $ choiceInState $ map string+--   ["~"+--   -- ,"!~"+--   -- ,"="+--   -- ,"!="+--   ]++_RULES_LOOKUP__________________________________________ = undefined++getDirective :: DirectiveName -> CsvRules -> Maybe FieldTemplate+getDirective directivename = lookup directivename . rdirectives++-- | Look up the value (template) of a csv rule by rule keyword.+csvRule :: CsvRules -> DirectiveName -> Maybe FieldTemplate+csvRule rules = (`getDirective` rules)++-- | Look up the value template assigned to a hledger field by field+-- list/field assignment rules, taking into account the current record and+-- conditional rules.+hledgerField :: CsvRules -> CsvRecord -> HledgerFieldName -> Maybe FieldTemplate+hledgerField = getEffectiveAssignment++-- | Look up the final value assigned to a hledger field, with csv field+-- references interpolated.+hledgerFieldValue :: CsvRules -> CsvRecord -> HledgerFieldName -> Maybe Text+hledgerFieldValue rules record = fmap (renderTemplate rules record) . hledgerField rules record++-- | Given the conversion rules, a CSV record and a hledger field name, find+-- the value template ultimately assigned to this field, if any, by a field+-- assignment at top level or in a conditional block matching this record.+--+-- Note conditional blocks' patterns are matched against an approximation of the+-- CSV record: all the field values, without enclosing quotes, comma-separated.+--+getEffectiveAssignment :: CsvRules -> CsvRecord -> HledgerFieldName -> Maybe FieldTemplate+getEffectiveAssignment rules record f = lastMay $ map snd $ assignments+  where+    -- all active assignments to field f, in order+    assignments = dbg9 "csv assignments" $ filter ((==f).fst) $ toplevelassignments ++ conditionalassignments+      where+        -- all top level field assignments+        toplevelassignments    = rassignments rules+        -- all field assignments in conditional blocks assigning to field f and active for the current csv record+        conditionalassignments = concatMap cbAssignments $ filter isBlockActive $ (rblocksassigning rules) f+          where+            -- does this conditional block match the current csv record ?+            isBlockActive :: ConditionalBlock -> Bool+            isBlockActive CB{..} = any (all matcherMatches) $ groupedMatchers cbMatchers+              where+                -- does this individual matcher match the current csv record ?+                matcherMatches :: Matcher -> Bool+                matcherMatches (RecordMatcher _ pat) = regexMatchText pat' wholecsvline+                  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+                matcherMatches (FieldMatcher _ csvfieldref pat) = regexMatchText pat csvfieldvalue+                  where+                    -- the value of the referenced CSV field to match against.+                    csvfieldvalue = dbg7 "csvfieldvalue" $ replaceCsvFieldReference rules record csvfieldref++                -- | Group matchers into associative pairs based on prefix, e.g.:+                --   A+                --   & B+                --   C+                --   D+                --   & E+                --   => [[A, B], [C], [D, E]]+                groupedMatchers :: [Matcher] -> [[Matcher]]+                groupedMatchers [] = []+                groupedMatchers (x:xs) = (x:ys) : groupedMatchers zs+                  where+                    (ys, zs) = span (\y -> matcherPrefix y == And) xs+                    matcherPrefix :: Matcher -> MatcherPrefix+                    matcherPrefix (RecordMatcher prefix _) = prefix+                    matcherPrefix (FieldMatcher prefix _ _) = prefix++-- | Render a field assignment's template, possibly interpolating referenced+-- CSV field values. Outer whitespace is removed from interpolated values.+renderTemplate ::  CsvRules -> CsvRecord -> FieldTemplate -> Text+renderTemplate rules record t = maybe t mconcat $ parseMaybe+    (many $ takeWhile1P Nothing (/='%')+        <|> replaceCsvFieldReference rules record <$> referencep)+    t+  where+    referencep = liftA2 T.cons (char '%') (takeWhile1P (Just "reference") isFieldNameChar) :: Parsec HledgerParseErrorData Text Text+    isFieldNameChar c = isAlphaNum c || c == '_' || c == '-'++-- | 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+replaceCsvFieldReference rules record s = case T.uncons s of+    Just ('%', fieldname) -> fromMaybe "" $ csvFieldValue rules record fieldname+    _                     -> s++-- | 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.+csvFieldValue :: CsvRules -> CsvRecord -> CsvFieldName -> Maybe Text+csvFieldValue rules record fieldname = do+  fieldindex <-+    if T.all isDigit fieldname+    then readMay $ T.unpack fieldname+    else lookup (T.toLower fieldname) $ rcsvfieldindexes rules+  T.strip <$> atMay record (fieldindex-1)++_CSV_READING__________________________________________ = undefined++-- | Read a Journal from the given CSV data (and filename, used for error+-- messages), or return an error. Proceed as follows:+--+-- 1. Conversion rules are provided, or they are parsed from the specified+--    rules file, or from the default rules file for the CSV data file.+--    If rules parsing fails, or the required rules file does not exist, throw an error.+--+-- 2. Parse the CSV data using the rules, or throw an error.+--+-- 3. Convert the CSV records to hledger transactions using the rules.+--+-- 4. Return the transactions as a Journal.+--+readJournalFromCsv :: Maybe (Either CsvRules FilePath) -> FilePath -> Text -> ExceptT String IO Journal+readJournalFromCsv Nothing "-" _ = throwError "please use --rules-file when reading CSV from stdin"+readJournalFromCsv merulesfile csvfile csvtext = do+    -- for now, correctness is the priority here, efficiency not so much++    rules <- case merulesfile of+      Just (Left rs)         -> return rs+      Just (Right rulesfile) -> readRulesFile rulesfile+      Nothing                -> readRulesFile $ rulesFileFor csvfile+    dbg6IO "csv rules" rules++    -- convert the csv data to lines and remove all empty/blank lines+    let csvlines1 = dbg9 "csvlines1" $ filter (not . T.null . T.strip) $ dbg9 "csvlines0" $ T.lines csvtext++    -- if there is a top-level skip rule, skip the specified number of non-empty lines+    skiplines <- case getDirective "skip" rules of+                      Nothing -> return 0+                      Just "" -> return 1+                      Just s  -> maybe (throwError $ "could not parse skip value: " ++ show s) return . readMay $ T.unpack s+    let csvlines2 = dbg9 "csvlines2" $ drop skiplines csvlines1++    -- convert back to text and parse as csv records+    let+      csvtext1 = T.unlines csvlines2+      separator =+        case getDirective "separator" rules >>= parseSeparator of+          Just c           -> c+          _ | ext == "ssv" -> ';'+          _ | ext == "tsv" -> '\t'+          _                -> ','+          where+            ext = map toLower $ drop 1 $ takeExtension csvfile+      -- parsec seemed to fail if you pass it "-" here   -- TODO: try again with megaparsec+      parsecfilename = if csvfile == "-" then "(stdin)" else csvfile+    dbg6IO "using separator" separator+    -- parse csv records+    csvrecords0 <- dbg7 "parseCsv" <$> parseCsv separator parsecfilename csvtext1+    -- remove any records skipped by conditional skip or end rules+    let csvrecords1 = applyConditionalSkips rules csvrecords0+    -- and check the remaining records for any obvious problems+    csvrecords <- liftEither $ dbg7 "validateCsv" <$> validateCsv csvrecords1+    dbg6IO "first 3 csv records" $ take 3 csvrecords++    -- XXX identify header lines some day ?+    -- let (headerlines, datalines) = identifyHeaderLines csvrecords'+    --     mfieldnames = lastMay headerlines++    tzout <- liftIO getCurrentTimeZone+    mtzin <- case getDirective "timezone" rules of+              Nothing -> return Nothing+              Just s  ->+                maybe (throwError $ "could not parse time zone: " ++ T.unpack s) (return.Just) $+                parseTimeM False defaultTimeLocale "%Z" $ T.unpack s+    let+      -- convert CSV records to transactions, saving the CSV line numbers for error positions+      txns = dbg7 "csv txns" $ snd $ mapAccumL+                     (\pos r ->+                        let+                          SourcePos name line col = pos+                          line' = (mkPos . (+1) . unPos) line+                          pos' = SourcePos name line' col+                        in+                          (pos', transactionFromCsvRecord timesarezoned mtzin tzout pos rules r)+                     )+                     (initialPos parsecfilename) csvrecords+        where+          timesarezoned =+            case csvRule rules "date-format" of+              Just f | any (`T.isInfixOf` f) ["%Z","%z","%EZ","%Ez"] -> True+              _ -> False++      -- Do our best to ensure transactions will be ordered chronologically,+      -- from oldest to newest. This is done in several steps:+      -- 1. Intra-day order: if there's an "intra-day-reversed" rule,+      -- assume each day's CSV records were ordered in reverse of the overall date order,+      -- so reverse each day's txns.+      intradayreversed = dbg6 "intra-day-reversed" $ isJust $ getDirective "intra-day-reversed" rules+      txns1 = dbg7 "txns1" $+        (if intradayreversed then concatMap reverse . groupOn tdate else id) txns+      -- 2. Overall date order: now if there's a "newest-first" rule,+      -- or if there's multiple dates and the first is more recent than the last,+      -- assume CSV records were ordered newest dates first,+      -- so reverse all txns.+      newestfirst = dbg6 "newest-first" $ isJust $ getDirective "newest-first" rules+      mdatalooksnewestfirst = dbg6 "mdatalooksnewestfirst" $+        case nub $ map tdate txns of+          ds | length ds > 1 -> Just $ head ds > last ds+          _                  -> Nothing+      txns2 = dbg7 "txns2" $+        (if newestfirst || mdatalooksnewestfirst == Just True then reverse else id) txns1+      -- 3. Disordered dates: in case the CSV records were ordered by chaos,+      -- do a final sort by date. If it was only a few records out of order,+      -- this will hopefully refine any good ordering done by steps 1 and 2.+      txns3 = dbg7 "date-sorted csv txns" $ sortOn tdate txns2++    return nulljournal{jtxns=txns3}++-- | Parse special separator names TAB and SPACE, or return the first+-- character. Return Nothing on empty string+parseSeparator :: Text -> Maybe Char+parseSeparator = specials . T.toLower+  where specials "space" = Just ' '+        specials "tab"   = Just '\t'+        specials xs      = fst <$> T.uncons xs++-- Call parseCassava on a file or stdin, converting the result to ExceptT.+parseCsv :: Char -> FilePath -> Text -> ExceptT String IO [CsvRecord]+parseCsv separator filePath csvtext = ExceptT $+  case filePath of+    "-" -> parseCassava separator "(stdin)" <$> T.getContents+    _   -> return $ if T.null csvtext then Right mempty else parseCassava separator filePath csvtext++-- Parse text into CSV records, using Cassava and the given field separator.+parseCassava :: Char -> FilePath -> Text -> Either String [CsvRecord]+parseCassava separator path content =+  -- XXX we now remove all blank lines before parsing; will Cassava will still produce [""] records ?+  -- filter (/=[""])+  either (Left . errorBundlePretty) (Right . parseResultToCsv) <$>+  CassavaMegaparsec.decodeWith decodeOptions Cassava.NoHeader path $+  BL.fromStrict $ T.encodeUtf8 content+  where+    decodeOptions = Cassava.defaultDecodeOptions {+                      Cassava.decDelimiter = fromIntegral (ord separator)+                    }+    parseResultToCsv :: (Foldable t, Functor t) => t (t B.ByteString) -> [CsvRecord]+    parseResultToCsv = toListList . unpackFields+      where+        toListList = toList . fmap toList+        unpackFields  = (fmap . fmap) T.decodeUtf8++-- | Scan for csv records where a conditional `skip` or `end` rule applies,+-- and apply that rule, removing one or more following records.+applyConditionalSkips :: CsvRules -> [CsvRecord] -> [CsvRecord]+applyConditionalSkips _ [] = []+applyConditionalSkips rules (r:rest) =+  case skipnum r of+    Nothing -> r : applyConditionalSkips rules rest+    Just cnt -> applyConditionalSkips rules $ drop (cnt-1) rest+  where+    skipnum r1 =+      case (getEffectiveAssignment rules r1 "end", getEffectiveAssignment rules r1 "skip") of+        (Nothing, Nothing) -> Nothing+        (Just _, _) -> Just maxBound+        (Nothing, Just "") -> Just 1+        (Nothing, Just x) -> Just (read $ T.unpack x)++-- | Do some validation on the parsed CSV records:+-- check that they all have at least two fields.+validateCsv :: [CsvRecord] -> Either String [CsvRecord]+validateCsv [] = Right []+validateCsv rs@(_first:_) =+  case lessthan2 of+    Just r  -> Left $ printf "CSV record %s has less than two fields" (show r)+    Nothing -> Right rs+  where+    lessthan2 = headMay $ filter ((<2).length) rs++-- -- | The highest (0-based) field index referenced in the field+-- -- definitions, or -1 if no fields are defined.+-- maxFieldIndex :: CsvRules -> Int+-- maxFieldIndex r = maximumDef (-1) $ catMaybes [+--                    dateField r+--                   ,statusField r+--                   ,codeField r+--                   ,amountField r+--                   ,amountInField r+--                   ,amountOutField r+--                   ,currencyField r+--                   ,accountField r+--                   ,account2Field r+--                   ,date2Field r+--                   ]++--- ** converting csv records to transactions++transactionFromCsvRecord :: Bool -> Maybe TimeZone -> TimeZone -> SourcePos -> CsvRules -> CsvRecord -> Transaction+transactionFromCsvRecord timesarezoned mtzin tzout sourcepos rules record = t+  where+    ----------------------------------------------------------------------+    -- 1. Define some helpers:++    rule     = csvRule           rules        :: DirectiveName    -> Maybe FieldTemplate+    -- ruleval  = csvRuleValue      rules record :: DirectiveName    -> Maybe String+    field    = hledgerField      rules record :: HledgerFieldName -> Maybe FieldTemplate+    fieldval = hledgerFieldValue rules record :: HledgerFieldName -> Maybe Text+    mdateformat = rule "date-format"+    parsedate = parseDateWithCustomOrDefaultFormats timesarezoned mtzin tzout mdateformat+    mkdateerror datefield datevalue mdateformat' = T.unpack $ T.unlines+      ["error: could not parse \""<>datevalue<>"\" as a date using date format "+        <>maybe "\"YYYY/M/D\", \"YYYY-M-D\" or \"YYYY.M.D\"" (T.pack . show) mdateformat'+      ,showRecord record+      ,"the "<>datefield<>" rule is:   "<>(fromMaybe "required, but missing" $ field datefield)+      ,"the date-format is: "<>fromMaybe "unspecified" mdateformat'+      ,"you may need to "+        <>"change your "<>datefield<>" rule, "+        <>maybe "add a" (const "change your") mdateformat'<>" date-format rule, "+        <>"or "<>maybe "add a" (const "change your") mskip<>" skip rule"+      ,"for m/d/y or d/m/y dates, use date-format %-m/%-d/%Y or date-format %-d/%-m/%Y"+      ]+      where+        mskip = rule "skip"++    ----------------------------------------------------------------------+    -- 2. Gather values needed for the transaction itself, by evaluating the+    -- field assignment rules using the CSV record's data, and parsing a bit+    -- more where needed (dates, status).++    date        = fromMaybe "" $ fieldval "date"+    -- PARTIAL:+    date'       = fromMaybe (error' $ mkdateerror "date" date mdateformat) $ parsedate date+    mdate2      = fieldval "date2"+    mdate2'     = (maybe (error' $ mkdateerror "date2" (fromMaybe "" mdate2) mdateformat) Just . parsedate) =<< mdate2+    status      =+      case fieldval "status" of+        Nothing -> Unmarked+        Just s  -> either statuserror id $ runParser (statusp <* eof) "" s+          where+            statuserror err = error' . T.unpack $ T.unlines+              ["error: could not parse \""<>s<>"\" as a cleared status (should be *, ! or empty)"+              ,"the parse error is:      "<>T.pack (customErrorBundlePretty err)+              ]+    code        = maybe "" singleline' $ fieldval "code"+    description = maybe "" singleline' $ fieldval "description"+    comment     = maybe "" unescapeNewlines $ fieldval "comment"+    precomment  = maybe "" unescapeNewlines $ fieldval "precomment"++    singleline' = T.unwords . filter (not . T.null) . map T.strip . T.lines+    unescapeNewlines = T.intercalate "\n" . T.splitOn "\\n"++    ----------------------------------------------------------------------+    -- 3. Generate the postings for which an account has been assigned+    -- (possibly indirectly due to an amount or balance assignment)++    p1IsVirtual = (accountNamePostingType <$> fieldval "account1") == Just VirtualPosting+    ps = [p | n <- [1..maxpostings]+         ,let cmt  = maybe "" unescapeNewlines $ fieldval ("comment"<> T.pack (show n))+         ,let currency = fromMaybe "" (fieldval ("currency"<> T.pack (show n)) <|> fieldval "currency")+         ,let mamount  = getAmount rules record currency p1IsVirtual n+         ,let mbalance = getBalance rules record currency n+         ,Just (acct,isfinal) <- [getAccount rules record mamount mbalance n]  -- skips Nothings+         ,let acct' | not isfinal && acct==unknownExpenseAccount &&+                      fromMaybe False (mamount >>= isNegativeMixedAmount) = unknownIncomeAccount+                    | otherwise = acct+         ,let p = nullposting{paccount          = accountNameWithoutPostingType acct'+                             ,pamount           = fromMaybe missingmixedamt mamount+                             ,ptransaction      = Just t+                             ,pbalanceassertion = mkBalanceAssertion rules record <$> mbalance+                             ,pcomment          = cmt+                             ,ptype             = accountNamePostingType acct+                             }+         ]++    ----------------------------------------------------------------------+    -- 4. Build the transaction (and name it, so the postings can reference it).++    t = nulltransaction{+           tsourcepos        = (sourcepos, sourcepos)  -- the CSV line number+          ,tdate             = date'+          ,tdate2            = mdate2'+          ,tstatus           = status+          ,tcode             = code+          ,tdescription      = description+          ,tcomment          = comment+          ,tprecedingcomment = precomment+          ,tpostings         = ps+          }++-- | Parse the date string using the specified date-format, or if unspecified+-- the "simple date" formats (YYYY/MM/DD, YYYY-MM-DD, YYYY.MM.DD, leading+-- zeroes optional). If a timezone is provided, we assume the DateFormat+-- produces a zoned time and we localise that to the given timezone.+parseDateWithCustomOrDefaultFormats :: Bool -> Maybe TimeZone -> TimeZone -> Maybe DateFormat -> Text -> Maybe Day+parseDateWithCustomOrDefaultFormats timesarezoned mtzin tzout mformat s = localdate <$> mutctime+  -- this time code can probably be simpler, I'm just happy to get out alive+  where+    localdate :: UTCTime -> Day =+      localDay .+      dbg7 ("time in output timezone "++show tzout) .+      utcToLocalTime tzout+    mutctime :: Maybe UTCTime = asum $ map parseWithFormat formats++    parseWithFormat :: String -> Maybe UTCTime+    parseWithFormat fmt =+      if timesarezoned+      then+        dbg7 "zoned CSV time, expressed as UTC" $+        parseTimeM True defaultTimeLocale fmt $ T.unpack s :: Maybe UTCTime+      else+        -- parse as a local day and time; then if an input timezone is provided,+        -- assume it's in that, otherwise assume it's in the output timezone;+        -- then convert to UTC like the above+        let+          mlocaltime =+            fmap (dbg7 "unzoned CSV time") $+            parseTimeM True defaultTimeLocale fmt $ T.unpack s :: Maybe LocalTime+          localTimeAsZonedTime tz lt =  ZonedTime lt tz+        in+          case mtzin of+            Just tzin ->+              (dbg7 ("unzoned CSV time, declared as "++show tzin++ ", expressed as UTC") .+              localTimeToUTC tzin)+              <$> mlocaltime+            Nothing ->+              (dbg7 ("unzoned CSV time, treated as "++show tzout++ ", expressed as UTC") .+                zonedTimeToUTC .+                localTimeAsZonedTime tzout)+              <$> mlocaltime++    formats = map T.unpack $ maybe+               ["%Y/%-m/%-d"+               ,"%Y-%-m-%-d"+               ,"%Y.%-m.%-d"+               -- ,"%-m/%-d/%Y"+                -- ,parseTimeM TruedefaultTimeLocale "%Y/%m/%e" (take 5 s ++ "0" ++ drop 5 s)+                -- ,parseTimeM TruedefaultTimeLocale "%Y-%m-%e" (take 5 s ++ "0" ++ drop 5 s)+                -- ,parseTimeM TruedefaultTimeLocale "%m/%e/%Y" ('0':s)+                -- ,parseTimeM TruedefaultTimeLocale "%m-%e-%Y" ('0':s)+               ]+               (:[])+                mformat++-- | Figure out the amount specified for posting N, if any.+-- A currency symbol to prepend to the amount, if any, is provided,+-- and whether posting 1 requires balancing or not.+-- This looks for a non-empty amount value assigned to "amountN", "amountN-in", or "amountN-out".+-- For postings 1 or 2 it also looks at "amount", "amount-in", "amount-out".+-- If more than one of these has a value, it looks for one that is non-zero.+-- If there's multiple non-zeros, or no non-zeros but multiple zeros, it throws an error.+getAmount :: CsvRules -> CsvRecord -> Text -> Bool -> Int -> Maybe MixedAmount+getAmount rules record currency p1IsVirtual n =+  -- Warning! Many tricky corner cases here.+  -- Keep synced with:+  -- hledger_csv.m4.md -> CSV FORMAT -> "amount", "Setting amounts",+  -- hledger/test/csv.test -> 13, 31-34+  let+    unnumberedfieldnames = ["amount","amount-in","amount-out"]++    -- amount field names which can affect this posting+    fieldnames = map (("amount"<> T.pack (show n))<>) ["","-in","-out"]+                 -- For posting 1, also recognise the old amount/amount-in/amount-out names.+                 -- For posting 2, the same but only if posting 1 needs balancing.+                 ++ if n==1 || n==2 && not p1IsVirtual then unnumberedfieldnames else []++    -- assignments to any of these field names with non-empty values+    assignments = [(f,a') | f <- fieldnames+                          , Just v <- [T.strip . renderTemplate rules record <$> hledgerField rules record f]+                          , not $ T.null v+                          -- XXX maybe ignore rule-generated values like "", "-", "$", "-$", "$-" ? cf CSV FORMAT -> "amount", "Setting amounts",+                          , let a = parseAmount rules record currency v+                          -- With amount/amount-in/amount-out, in posting 2,+                          -- flip the sign and convert to cost, as they did before 1.17+                          , let a' = if f `elem` unnumberedfieldnames && n==2 then mixedAmountCost (maNegate a) else a+                          ]++    -- if any of the numbered field names are present, discard all the unnumbered ones+    discardUnnumbered xs = if null numbered then xs else numbered+      where+        numbered = filter (T.any isDigit . fst) xs++    -- discard all zero amounts, unless all amounts are zero, in which case discard all but the first+    discardExcessZeros xs = if null nonzeros then take 1 xs else nonzeros+      where+        nonzeros = filter (not . mixedAmountLooksZero . snd) xs++    -- for -out fields, flip the sign  XXX unless it's already negative ? back compat issues / too confusing ?+    negateIfOut f = if "-out" `T.isSuffixOf` f then maNegate else id++  in case discardExcessZeros $ discardUnnumbered assignments of+      []      -> Nothing+      [(f,a)] -> Just $ negateIfOut f a+      fs      -> error' . T.unpack . textChomp . T.unlines $  -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+          -- PARTIAL:+        ["in CSV rules:"+        ,"While processing " <> showRecord record+        ,"while calculating amount for posting " <> T.pack (show n)+        ] +++        ["rule \"" <> f <> " " <>+          fromMaybe "" (hledgerField rules record f) <>+          "\" assigned value \"" <> wbToText (showMixedAmountB noColour a) <> "\"" -- XXX not sure this is showing all the right info+          | (f,a) <- fs+        ] +++        [""+        ,"Multiple non-zero amounts were assigned for an amount field."+        ,"Please ensure just one non-zero amount is assigned, perhaps with an if rule."+        ,"See also: https://hledger.org/hledger.html#setting-amounts"+        ,"(hledger manual -> CSV format -> Tips -> Setting amounts)"+        ]+-- | Figure out the expected balance (assertion or assignment) specified for posting N,+-- if any (and its parse position).+getBalance :: CsvRules -> CsvRecord -> Text -> Int -> Maybe (Amount, SourcePos)+getBalance rules record currency n = do+  v <- (fieldval ("balance"<> T.pack (show n))+        -- for posting 1, also recognise the old field name+        <|> if n==1 then fieldval "balance" else Nothing)+  case v of+    "" -> Nothing+    s  -> Just (+            parseBalanceAmount rules record currency n s+           ,initialPos ""  -- parse position to show when assertion fails,+           )               -- XXX the csv record's line number would be good+  where+    fieldval = fmap T.strip . hledgerFieldValue rules record :: HledgerFieldName -> Maybe Text++-- | Given a non-empty amount string (from CSV) to parse, along with a+-- possibly non-empty currency symbol to prepend,+-- parse as a hledger MixedAmount (as in journal format), or raise an error.+-- The whole CSV record is provided for the error message.+parseAmount :: CsvRules -> CsvRecord -> Text -> Text -> MixedAmount+parseAmount rules record currency s =+    either mkerror mixedAmount $  -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+      -- PARTIAL:+    runParser (evalStateT (amountp <* eof) journalparsestate) "" $+    currency <> simplifySign s+  where+    journalparsestate = nulljournal{jparsedecimalmark=parseDecimalMark rules}+    mkerror e = error' . T.unpack $ T.unlines+      ["error: could not parse \"" <> s <> "\" as an amount"+      ,showRecord record+      ,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"+      ]++-- | Show the values assigned to each journal field.+showRules rules record = T.unlines $ catMaybes+  [ (("the "<>fld<>" rule is: ")<>) <$>+    getEffectiveAssignment rules record fld | fld <- journalfieldnames ]++-- | Show a (approximate) recreation of the original CSV record.+showRecord :: CsvRecord -> Text+showRecord r = "CSV record: "<>T.intercalate "," (map (wrap "\"" "\"") r)++-- XXX unify these ^v++-- | Almost but not quite the same as parseAmount.+-- Given a non-empty amount string (from CSV) to parse, along with a+-- possibly non-empty currency symbol to prepend,+-- parse as a hledger Amount (as in journal format), or raise an error.+-- The CSV record and the field's numeric suffix are provided for the error message.+parseBalanceAmount :: CsvRules -> CsvRecord -> Text -> Int -> Text -> Amount+parseBalanceAmount rules record currency n s =+  either (mkerror n s) id $+    runParser (evalStateT (amountp <* eof) journalparsestate) "" $+    currency <> simplifySign s+                  -- the csv record's line number would be good+  where+    journalparsestate = nulljournal{jparsedecimalmark=parseDecimalMark rules}+    mkerror n' s' e = error' . T.unpack $ T.unlines+      ["error: could not parse \"" <> s' <> "\" as balance"<> T.pack (show n') <> " amount"+      ,showRecord record+      ,showRules rules record+      -- ,"the default-currency is: "++fromMaybe "unspecified" mdefaultcurrency+      ,"the parse error is:      "<> T.pack (customErrorBundlePretty e)+      ]++-- Read a valid decimal mark from the decimal-mark rule, if any.+-- If the rule is present with an invalid argument, raise an error.+parseDecimalMark :: CsvRules -> Maybe DecimalMark+parseDecimalMark rules = do+    s <- rules `csvRule` "decimal-mark"+    case T.uncons s of+        Just (c, rest) | T.null rest && isDecimalMark c -> return c+        _ -> error' . T.unpack $ "decimal-mark's argument should be \".\" or \",\" (not \""<>s<>"\")"++-- | Make a balance assertion for the given amount, with the given parse+-- position (to be shown in assertion failures), with the assertion type+-- possibly set by a balance-type rule.+-- The CSV rules and current record are also provided, to be shown in case+-- balance-type's argument is bad (XXX refactor).+mkBalanceAssertion :: CsvRules -> CsvRecord -> (Amount, SourcePos) -> BalanceAssertion+mkBalanceAssertion rules record (amt, pos) = assrt{baamount=amt, baposition=pos}+  where+    assrt =+      case getDirective "balance-type" rules of+        Nothing    -> nullassertion+        Just "="   -> nullassertion+        Just "=="  -> nullassertion{batotal=True}+        Just "=*"  -> nullassertion{bainclusive=True}+        Just "==*" -> nullassertion{batotal=True, bainclusive=True}+        Just x     -> error' . T.unpack $ T.unlines  -- PARTIAL:+          [ "balance-type \"" <> x <>"\" is invalid. Use =, ==, =* or ==*."+          , showRecord record+          , showRules rules record+          ]++-- | Figure out the account name specified for posting N, if any.+-- And whether it is the default unknown account (which may be+-- improved later) or an explicitly set account (which may not).+getAccount :: CsvRules -> CsvRecord -> Maybe MixedAmount -> Maybe (Amount, SourcePos) -> Int -> Maybe (AccountName, Bool)+getAccount rules record mamount mbalance n =+  let+    fieldval = hledgerFieldValue rules record :: HledgerFieldName -> Maybe Text+    maccount = T.strip <$> fieldval ("account"<> T.pack (show n))+  in case maccount of+    -- accountN is set to the empty string - no posting will be generated+    Just "" -> Nothing+    -- accountN is set (possibly to "expenses:unknown"! #1192) - mark it final+    Just a  ->+      -- Check it and reject if invalid.. sometimes people try+      -- to set an amount or comment along with the account name.+      case parsewith (accountnamep >> eof) a of+        Left e  -> usageError $ errorBundlePretty e+        Right _ -> Just (a, True)+    -- accountN is unset+    Nothing ->+      case (mamount, mbalance) of+        -- amountN is set, or implied by balanceN - set accountN to+        -- the default unknown account ("expenses:unknown") and+        -- allow it to be improved later+        (Just _, _) -> Just (unknownExpenseAccount, False)+        (_, Just _) -> Just (unknownExpenseAccount, False)+        -- amountN is also unset - no posting will be generated+        (Nothing, Nothing) -> Nothing++-- | Default account names to use when needed.+unknownExpenseAccount = "expenses:unknown"+unknownIncomeAccount  = "income:unknown"++type CsvAmountString = Text++-- | Canonicalise the sign in a CSV amount string.+-- Such strings can have a minus sign, parentheses (equivalent to minus),+-- or any two of these (which cancel out),+-- or a plus sign (which is removed),+-- or any sign by itself with no following number (which is removed).+-- See hledger > CSV FORMAT > Tips > Setting amounts.+--+-- These are supported (note, not every possibile combination):+--+-- >>> simplifySign "1"+-- "1"+-- >>> simplifySign "+1"+-- "1"+-- >>> simplifySign "-1"+-- "-1"+-- >>> simplifySign "(1)"+-- "-1"+-- >>> simplifySign "--1"+-- "1"+-- >>> simplifySign "-(1)"+-- "1"+-- >>> simplifySign "-+1"+-- "-1"+-- >>> simplifySign "(-1)"+-- "1"+-- >>> simplifySign "((1))"+-- "1"+-- >>> simplifySign "-"+-- ""+-- >>> simplifySign "()"+-- ""+-- >>> simplifySign "+"+-- ""+simplifySign :: CsvAmountString -> CsvAmountString+simplifySign amtstr+  | Just (' ',t) <- T.uncons amtstr = simplifySign t+  | Just (t,' ') <- T.unsnoc amtstr = simplifySign t+  | Just ('(',t) <- T.uncons amtstr, Just (amt,')') <- T.unsnoc t = simplifySign $ negateStr amt+  | Just ('-',b) <- T.uncons amtstr, Just ('(',t) <- T.uncons b, Just (amt,')') <- T.unsnoc t = simplifySign amt+  | Just ('-',m) <- T.uncons amtstr, Just ('-',amt) <- T.uncons m = amt+  | Just ('-',m) <- T.uncons amtstr, Just ('+',amt) <- T.uncons m = negateStr amt+  | amtstr `elem` ["-","+","()"] = ""+  | Just ('+',amt) <- T.uncons amtstr = simplifySign amt+  | otherwise = amtstr++negateStr :: Text -> Text+negateStr amtstr = case T.uncons amtstr of+    Just ('-',s) -> s+    _            -> T.cons '-' amtstr++--- ** tests+_TESTS__________________________________________ = undefined++tests_RulesReader = testGroup "RulesReader" [+   testGroup "parseCsvRules" [+     testCase "empty file" $+      parseCsvRules "unknown" "" @?= Right (mkrules defrules)+   ]+  ,testGroup "rulesp" [+     testCase "trailing comments" $+      parseWithState' defrules rulesp "skip\n# \n#\n" @?= Right (mkrules $ defrules{rdirectives = [("skip","")]})++    ,testCase "trailing blank lines" $+      parseWithState' defrules rulesp "skip\n\n  \n" @?= (Right (mkrules $ defrules{rdirectives = [("skip","")]}))++    ,testCase "no final newline" $+      parseWithState' defrules rulesp "skip" @?= (Right (mkrules $ defrules{rdirectives=[("skip","")]}))++    ,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")]}]}))+   ]+  ,testGroup "conditionalblockp" [+    testCase "space after conditional" $ -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+       -- #1120+      parseWithState' defrules conditionalblockp "if a\n account2 b\n \n" @?=+        (Right $ CB{cbMatchers=[RecordMatcher None $ toRegexCI' "a"],cbAssignments=[("account2","b")]})++  ],++  testGroup "csvfieldreferencep" [+    testCase "number" $ parseWithState' defrules csvfieldreferencep "%1" @?= (Right "%1")+   ,testCase "name" $ parseWithState' defrules csvfieldreferencep "%date" @?= (Right "%date")+   ,testCase "quoted name" $ parseWithState' defrules csvfieldreferencep "%\"csv date\"" @?= (Right "%\"csv date\"")+   ]++  ,testGroup "matcherp" [++    testCase "recordmatcherp" $+      parseWithState' defrules matcherp "A A\n" @?= (Right $ RecordMatcher None $ 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")++   ,testCase "fieldmatcherp" $+      parseWithState' defrules matcherp "%description A A\n" @?= (Right $ FieldMatcher None "%description" $ toRegexCI' "A A")++   ,testCase "fieldmatcherp.starts-with-&" $+      parseWithState' defrules matcherp "& %description A A\n" @?= (Right $ FieldMatcher And "%description" $ toRegexCI' "A A")++   -- ,testCase "fieldmatcherp with operator" $+   --    parseWithState' defrules matcherp "%description ~ A A\n" @?= (Right $ FieldMatcher "%description" "A A")++   ]++ ,testGroup "getEffectiveAssignment" [+    let rules = mkrules $ defrules {rcsvfieldindexes=[("csvdate",1)],rassignments=[("date","%csvdate")]}++    in testCase "toplevel" $ getEffectiveAssignment rules ["a","b"] "date" @?= (Just "%csvdate")++   ,let rules = mkrules $ defrules{rcsvfieldindexes=[("csvdate",1)], rconditionalblocks=[CB [FieldMatcher None "%csvdate" $ toRegex' "a"] [("date","%csvdate")]]}+    in testCase "conditional" $ getEffectiveAssignment rules ["a","b"] "date" @?= (Just "%csvdate")++   ,let rules = mkrules $ defrules{rcsvfieldindexes=[("csvdate",1),("description",2)], rconditionalblocks=[CB [FieldMatcher None "%csvdate" $ toRegex' "a", FieldMatcher None "%description" $ toRegex' "b"] [("date","%csvdate")]]}+    in testCase "conditional-with-or-a" $ getEffectiveAssignment rules ["a"] "date" @?= (Just "%csvdate")++   ,let rules = mkrules $ defrules{rcsvfieldindexes=[("csvdate",1),("description",2)], rconditionalblocks=[CB [FieldMatcher None "%csvdate" $ toRegex' "a", FieldMatcher None "%description" $ toRegex' "b"] [("date","%csvdate")]]}+    in testCase "conditional-with-or-b" $ getEffectiveAssignment rules ["_", "b"] "date" @?= (Just "%csvdate")++   ,let rules = mkrules $ defrules{rcsvfieldindexes=[("csvdate",1),("description",2)], rconditionalblocks=[CB [FieldMatcher None "%csvdate" $ toRegex' "a", FieldMatcher And "%description" $ toRegex' "b"] [("date","%csvdate")]]}+    in testCase "conditional.with-and" $ getEffectiveAssignment rules ["a", "b"] "date" @?= (Just "%csvdate")++   ,let rules = mkrules $ defrules{rcsvfieldindexes=[("csvdate",1),("description",2)], rconditionalblocks=[CB [FieldMatcher None "%csvdate" $ toRegex' "a", FieldMatcher And "%description" $ toRegex' "b", FieldMatcher None "%description" $ toRegex' "c"] [("date","%csvdate")]]}+    in testCase "conditional.with-and-or" $ getEffectiveAssignment rules ["_", "c"] "date" @?= (Just "%csvdate")++   ]++ ]

@@ -45,7 +45,6 @@  --- ** language {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PackageImports #-}  --- ** exports module Hledger.Read.TimeclockReader (@@ -62,13 +61,13 @@ import           Control.Monad.State.Strict import           Data.Maybe (fromMaybe) import           Data.Text (Text)-import qualified Data.Text as T import           Text.Megaparsec hiding (parse)  import           Hledger.Data -- XXX too much reuse ? import           Hledger.Read.Common import           Hledger.Utils+import Data.Text as T (strip)  --- ** doctest setup -- $setup@@ -119,10 +118,11 @@ -- | Parse a timeclock entry. timeclockentryp :: JournalParser m TimeclockEntry timeclockentryp = do-  sourcepos <- getSourcePos+  pos <- getSourcePos   code <- oneOf ("bhioO" :: [Char])   lift skipNonNewlineSpaces1   datetime <- datetimep-  account <- fromMaybe "" <$> optional (lift skipNonNewlineSpaces1 >> modifiedaccountnamep)-  description <- T.pack . fromMaybe "" <$> lift (optional (skipNonNewlineSpaces1 >> restofline))-  return $ TimeclockEntry sourcepos (read [code]) datetime account description+  account     <- fmap (fromMaybe "") $ optional $ lift skipNonNewlineSpaces1 >> modifiedaccountnamep+  description <- fmap (maybe "" T.strip) $ optional $ lift $ skipNonNewlineSpaces1 >> descriptionp+  (comment, tags) <- lift transactioncommentp+  return $ TimeclockEntry pos (read [code]) datetime account description comment tags

@@ -43,7 +43,6 @@ import Control.Monad.Except (ExceptT, liftEither) import Control.Monad.State.Strict import Data.Char (isSpace)-import Data.List (foldl') import Data.Text (Text) import qualified Data.Text as T import Data.Time (Day)@@ -113,7 +112,7 @@   many $ notFollowedBy datelinep >> (lift $ emptyorcommentlinep "#;*")   lift $ traceparse' "preamblep" --- | Parse timedot day entries to zero or more time transactions for that day.+-- | Parse timedot day entries to multi-posting time transactions for that day. -- @ -- 2020/2/1 optional day description -- fos.haskell  .... ..@@ -123,23 +122,32 @@ dayp :: JournalParser m () dayp = label "timedot day entry" $ do   lift $ traceparse "dayp"-  (d,desc) <- datelinep+  pos <- getSourcePos+  (date,desc,comment,tags) <- datelinep   commentlinesp-  ts <- many $ entryp <* commentlinesp-  modify' $ addTransactions $ map (\t -> t{tdate=d, tdescription=desc}) ts-  lift $ traceparse' "dayp"-  where-    addTransactions :: [Transaction] -> Journal -> Journal-    addTransactions ts j = foldl' (flip ($)) j (map addTransaction ts)+  ps <- many $ timedotentryp <* commentlinesp+  endpos <- getSourcePos+  -- lift $ traceparse' "dayp end"+  let t = txnTieKnot $ nulltransaction{+    tsourcepos   = (pos, endpos),+    tdate        = date,+    tstatus      = Cleared,+    tdescription = desc,+    tcomment     = comment,+    ttags        = tags,+    tpostings    = ps+    }+  modify' $ addTransaction t -datelinep :: JournalParser m (Day,Text)+datelinep :: JournalParser m (Day,Text,Text,[Tag]) datelinep = do   lift $ traceparse "datelinep"   lift $ optional orgheadingprefixp-  d <- datep-  desc <- strip <$> lift restofline-  lift $ traceparse' "datelinep"-  return (d, T.pack desc)+  date <- datep+  desc <- T.strip <$> lift descriptionp+  (comment, tags) <- lift transactioncommentp+  -- lift $ traceparse' "datelinep end"+  return (date, desc, comment, tags)  -- | Zero or more empty lines or hash/semicolon comment lines -- or org headlines which do not start a new day.@@ -164,38 +172,39 @@ -- @ -- fos.haskell  .... .. -- @-entryp :: JournalParser m Transaction-entryp = do-  lift $ traceparse "entryp"-  pos <- getSourcePos+timedotentryp :: JournalParser m Posting+timedotentryp = do+  lift $ traceparse "timedotentryp"   notFollowedBy datelinep   lift $ optional $ choice [orgheadingprefixp, skipNonNewlineSpaces1]   a <- modifiedaccountnamep   lift skipNonNewlineSpaces-  hours <--    try (lift followingcommentp >> return 0)-    <|> (lift durationp <*-         (try (lift followingcommentp) <|> (newline >> return "")))+  (hours, comment, tags) <-+    try (do+      (c,ts) <- lift transactioncommentp  -- or postingp, but let's not bother supporting date:/date2:+      return (0, c, ts)+    )+    <|> (do+      h <- lift durationp+      (c,ts) <- try (lift transactioncommentp) <|> (newline >> return ("",[]))+      return (h,c,ts)+    )   mcs <- getDefaultCommodityAndStyle   let      (c,s) = case mcs of       Just (defc,defs) -> (defc, defs{asprecision=max (asprecision defs) (Precision 2)})       _ -> ("", amountstyle{asprecision=Precision 2})-    t = nulltransaction{-          tsourcepos = (pos, pos),-          tstatus    = Cleared,-          tpostings  = [-            nullposting{paccount=a+  -- lift $ traceparse' "timedotentryp end"+  return $ nullposting{paccount=a                       ,pamount=mixedAmount $ nullamt{acommodity=c, aquantity=hours, astyle=s}                       ,ptype=VirtualPosting-                      ,ptransaction=Just t+                      ,pcomment=comment+                      ,ptags=tags                       }-            ]-          }-  lift $ traceparse' "entryp"-  return t -durationp :: TextParser m Quantity+type Hours = Quantity++durationp :: TextParser m Hours durationp = do   traceparse "durationp"   try numericquantityp <|> dotquantityp@@ -210,7 +219,7 @@ -- 1.5h -- 90m -- @-numericquantityp :: TextParser m Quantity+numericquantityp :: TextParser m Hours numericquantityp = do   -- lift $ traceparse "numericquantityp"   (q, _, _, _) <- numberp Nothing

@@ -81,7 +81,7 @@       expandAccountNames $       accountNamesFromPostings $       concatMap tpostings $-      concatMap (`runPeriodicTransaction` reportspan) $+      concatMap (\pt -> runPeriodicTransaction False pt reportspan) $       jperiodictxns j     actualj = journalWithBudgetAccountNames budgetedaccts showunbudgeted j     budgetj = journalAddBudgetGoalTransactions bopts ropts reportspan j@@ -156,7 +156,7 @@       dbg5 "budget goal txns" $       [makeBudgetTxn t       | pt <- budgetpts-      , t <- runPeriodicTransaction pt budgetspan+      , t <- runPeriodicTransaction False pt budgetspan       ]     makeBudgetTxn t = txnTieKnot $ t { tdescription = T.pack "Budget transaction" } 

@@ -322,10 +322,11 @@         -- changes to report on: usually just the valued changes themselves, but use the         -- differences in the valued historical amount for CalcValueChange and CalcGain.         changes = case balancecalc_ ropts of-            CalcChange      -> M.mapWithKey avalue unvaluedChanges-            CalcBudget      -> M.mapWithKey avalue unvaluedChanges-            CalcValueChange -> periodChanges valuedStart historical-            CalcGain        -> periodChanges valuedStart historical+            CalcChange        -> M.mapWithKey avalue unvaluedChanges+            CalcBudget        -> M.mapWithKey avalue unvaluedChanges+            CalcValueChange   -> periodChanges valuedStart historical+            CalcGain          -> periodChanges valuedStart historical+            CalcPostingsCount -> M.mapWithKey avalue unvaluedChanges         -- the historical balance is the valued cumulative sum of all unvalued changes         historical = M.mapWithKey avalue $ cumulativeSum startingBalance unvaluedChanges         -- since this is a cumulative sum of valued amounts, it should not be valued again@@ -353,9 +354,15 @@ generateMultiBalanceReport :: ReportSpec -> Journal -> PriceOracle -> Set AccountName                            -> [(DateSpan, [Posting])] -> HashMap AccountName Account                            -> MultiBalanceReport-generateMultiBalanceReport rspec@ReportSpec{_rsReportOpts=ropts} j priceoracle unelidableaccts colps startbals =+generateMultiBalanceReport rspec@ReportSpec{_rsReportOpts=ropts} j priceoracle unelidableaccts colps0 startbals =     report   where+    -- If doing --count, set all posting amounts to "1".+    colps =+      if balancecalc_ ropts == CalcPostingsCount+      then map (second (map (postingTransformAmount (const $ mixed [num 1])))) colps0+      else colps0+     -- Process changes into normal, cumulative, or historical amounts, plus value them     matrix = calculateReportMatrix rspec j priceoracle startbals colps 

@@ -88,10 +88,11 @@ -- | What to calculate for each cell in a balance report. -- "Balance report types -> Calculation type" in the hledger manual. data BalanceCalculation =-    CalcChange      -- ^ Sum of posting amounts in the period.-  | CalcBudget      -- ^ Sum of posting amounts and the goal for the period.-  | CalcValueChange -- ^ Change from previous period's historical end value to this period's historical end value.-  | CalcGain        -- ^ Change from previous period's gain, i.e. valuation minus cost basis.+    CalcChange        -- ^ Sum of posting amounts in the period.+  | CalcBudget        -- ^ Sum of posting amounts and the goal for the period.+  | CalcValueChange   -- ^ Change from previous period's historical end value to this period's historical end value.+  | CalcGain          -- ^ Change from previous period's gain, i.e. valuation minus cost basis.+  | CalcPostingsCount -- ^ Number of postings in the period.   deriving (Eq, Show)  instance Default BalanceCalculation where def = CalcChange@@ -318,6 +319,7 @@       "valuechange" -> Just CalcValueChange       "gain"        -> Just CalcGain       "budget"      -> Just CalcBudget+      "count"       -> Just CalcPostingsCount       _             -> Nothing  balanceaccumopt :: RawOpts -> BalanceAccumulation@@ -804,7 +806,7 @@ -- >>> _rsQuery <$> setEither querystring ["assets"] defreportspec -- Right (Acct (RegexpCI "assets")) -- >>> _rsQuery <$> setEither querystring ["(assets"] defreportspec--- Left "This regular expression is malformed...+-- Left "This regular expression is malformed, please correct it:\n(assets" -- >>> _rsQuery $ set querystring ["assets"] defreportspec -- Acct (RegexpCI "assets") -- >>> _rsQuery $ set querystring ["(assets"] defreportspec

@@ -47,6 +47,7 @@   sixth6,    -- * Misc+  multicol,   numDigitsInt,   makeHledgerClassyLenses, @@ -66,8 +67,10 @@ where  import Data.Char (toLower)-import Data.List.Extra (foldl', foldl1', uncons, unsnoc)+import Data.List (intersperse)+import Data.List.Extra (chunksOf, foldl', foldl1', uncons, unsnoc) import qualified Data.Set as Set+import qualified Data.Text as T (pack, unpack) import Data.Tree (foldTree, Tree (Node, subForest)) import Language.Haskell.TH (DecsQ, Name, mkName, nameBase) import Lens.Micro ((&), (.~))@@ -198,6 +201,21 @@ sixth6  (_,_,_,_,_,x) = x  -- Misc++-- | Convert a list of strings to a multi-line multi-column list+-- fitting within the given width. Not wide character aware.+multicol :: Int -> [String] -> String+multicol _ [] = []+multicol width strs =+  let+    maxwidth = maximum' $ map length strs+    numcols = min (length strs) (width `div` (maxwidth+2))+    itemspercol = length strs `div` numcols+    colitems = chunksOf itemspercol strs+    cols = map unlines colitems+    sep = " "+  in+    T.unpack $ textConcatBottomPadded $ map T.pack $ intersperse sep cols  -- | Find the number of digits of an 'Int'. {-# INLINE numDigitsInt #-}

@@ -23,6 +23,11 @@   pager,   setupPager, +  -- * Terminal size+  getTerminalHeightWidth,+  getTerminalHeight,+  getTerminalWidth,+   -- * Command line arguments   progArgs,   outputFileOption,@@ -32,10 +37,33 @@   colorOption,   useColorOnStdout,   useColorOnStderr,+  -- XXX needed for using color/bgColor/colorB/bgColorB, but clashing with UIUtils:+  -- Color(..),+  -- ColorIntensity(..),   color,   bgColor,   colorB,   bgColorB,+  --+  bold',+  faint',+  black',+  red',+  green',+  yellow',+  blue',+  magenta',+  cyan',+  white',+  brightBlack',+  brightRed',+  brightGreen',+  brightYellow',+  brightBlue',+  brightMagenta',+  brightCyan',+  brightWhite',+  rgb',   terminalIsLight,   terminalLightness,   terminalFgColor,@@ -49,6 +77,8 @@   embedFileRelative,   expandHomePath,   expandPath,+  expandGlob,+  sortByModTime,   readFileOrStdinPortably,   readFilePortably,   readHandlePortably,@@ -61,7 +91,7 @@   ) where -import           Control.Monad (when)+import           Control.Monad (when, forM) import           Data.Colour.RGBSpace (RGB(RGB)) import           Data.Colour.RGBSpace.HSL (lightness) import           Data.FileEmbed (makeRelativeToProject, embedStringFile)@@ -74,11 +104,13 @@ import           Data.Time.Clock (getCurrentTime) import           Data.Time.LocalTime   (LocalTime, ZonedTime, getCurrentTimeZone, utcToLocalTime, utcToZonedTime)-import           Data.Word (Word16)+import           Data.Word (Word8, Word16) import           Language.Haskell.TH.Syntax (Q, Exp)-import           System.Console.ANSI-  (Color,ColorIntensity,ConsoleLayer(..), SGR(..), hSupportsANSIColor, setSGRCode, getLayerColor)-import           System.Directory (getHomeDirectory)+import           String.ANSI+import           System.Console.ANSI (Color(..),ColorIntensity(..),+  ConsoleLayer(..), SGR(..), hSupportsANSIColor, setSGRCode, getLayerColor)+import           System.Console.Terminal.Size (Window (Window), size)+import           System.Directory (getHomeDirectory, getModificationTime) import           System.Environment (getArgs, lookupEnv, setEnv) import           System.FilePath (isRelative, (</>)) import           System.IO@@ -89,42 +121,48 @@ import           System.Pager (printOrPage) #endif import           Text.Pretty.Simple-  (CheckColorTty(CheckColorTty), OutputOptions(..), +  (CheckColorTty(..), OutputOptions(..),   defaultOutputOptionsDarkBg, defaultOutputOptionsNoColor, pShowOpt, pPrintOpt)  import Hledger.Utils.Text (WideBuilder(WideBuilder))+import System.FilePath.Glob (glob)+import Data.Functor ((<&>))  -- Pretty showing/printing with 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)-    { outputOptionsIndentAmount=2-    , outputOptionsCompact=True+    { 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     }  -- | pretty-simple options with colour disabled.-prettyopts' =+prettyoptsNoColor =   defaultOutputOptionsNoColor     { outputOptionsIndentAmount=2-    , outputOptionsCompact=True     } --- | Pretty show. Easier alias for pretty-simple's pShow.+-- | Pretty show. An easier alias for pretty-simple's pShow.+-- This will probably show in colour if useColorOnStderr is true. pshow :: Show a => a -> String pshow = TL.unpack . pShowOpt prettyopts --- | Monochrome version of pshow.+-- | Monochrome version of pshow. This will never show in colour. pshow' :: Show a => a -> String-pshow' = TL.unpack . pShowOpt prettyopts'+pshow' = TL.unpack . pShowOpt prettyoptsNoColor --- | Pretty print. Easier alias for pretty-simple's pPrint.+-- | Pretty print a showable value. An easier alias for pretty-simple's pPrint.+-- This will print in colour if useColorOnStderr is true. pprint :: Show a => a -> IO ()-pprint = pPrintOpt CheckColorTty prettyopts+pprint = pPrintOpt (if useColorOnStderr then CheckColorTty else NoCheckColorTty) prettyopts --- | Monochrome version of pprint.+-- | Monochrome version of pprint. This will never print in colour. pprint' :: Show a => a -> IO ()-pprint' = pPrintOpt CheckColorTty prettyopts'+pprint' = pPrintOpt NoCheckColorTty prettyoptsNoColor  -- "Avoid using pshow, pprint, dbg* in the code below to prevent infinite loops." (?) @@ -145,6 +183,19 @@ pager = printOrPage' #endif +-- | 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.+getTerminalHeightWidth :: IO (Maybe (Int,Int))+getTerminalHeightWidth = fmap (fmap unwindow) size+  where unwindow (Window h w) = (h,w)++getTerminalHeight :: IO (Maybe Int)+getTerminalHeight = fmap fst <$> getTerminalHeightWidth++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`.@@ -198,6 +249,67 @@  -- ANSI colour +ifAnsi f = if useColorOnStdout then f else id++-- | Versions of some of text-ansi's string colors/styles which are more careful+-- to not print junk onscreen. These use our useColorOnStdout.+bold' :: String -> String+bold'  = ifAnsi bold++faint' :: String -> String+faint'  = ifAnsi faint++black' :: String -> String+black'  = ifAnsi black++red' :: String -> String+red'  = ifAnsi red++green' :: String -> String+green'  = ifAnsi green++yellow' :: String -> String+yellow'  = ifAnsi yellow++blue' :: String -> String+blue'  = ifAnsi blue++magenta' :: String -> String+magenta'  = ifAnsi magenta++cyan' :: String -> String+cyan'  = ifAnsi cyan++white' :: String -> String+white'  = ifAnsi white++brightBlack' :: String -> String+brightBlack'  = ifAnsi brightBlack++brightRed' :: String -> String+brightRed'  = ifAnsi brightRed++brightGreen' :: String -> String+brightGreen'  = ifAnsi brightGreen++brightYellow' :: String -> String+brightYellow'  = ifAnsi brightYellow++brightBlue' :: String -> String+brightBlue'  = ifAnsi brightBlue++brightMagenta' :: String -> String+brightMagenta'  = ifAnsi brightMagenta++brightCyan' :: String -> String+brightCyan'  = ifAnsi brightCyan++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@@ -250,6 +362,9 @@        || (coloroption `notElem` ["never","no"] && not no_color && supports_color)  -- | Wrap a string in ANSI codes to set and reset foreground colour.+-- ColorIntensity is @Dull@ or @Vivid@ (ie normal and bold).+-- Color is one of @Black@, @Red@, @Green@, @Yellow@, @Blue@, @Magenta@, @Cyan@, @White@.+-- Eg: @color Dull Red "text"@. color :: ColorIntensity -> Color -> String -> String color int col s = setSGRCode [SetColor Foreground int col] ++ s ++ setSGRCode [] @@ -319,15 +434,8 @@  -- Files --- | Convert a possibly relative, possibly tilde-containing file path to an absolute one,--- given the current directory. ~username is not supported. Leave "-" 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:---- | Expand user home path indicated by tilde prefix+-- | 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@@ -335,6 +443,24 @@     ('~':_)      -> 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++-- | Like expandPath, but treats the expanded path as a glob, and returns+-- zero or more matched absolute file paths, alphabetically sorted.+expandGlob :: FilePath -> FilePath -> IO [FilePath]+expandGlob curdir p = expandPath curdir p >>= glob <&> sort++-- | 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 $ reverse $ sort ftimes+ -- | Read text from a file, -- converting any \r\n line endings to \n,, -- using the system locale's text encoding,@@ -359,7 +485,6 @@   T.hGetContents h  -- | Like embedFile, but takes a path relative to the package directory.--- Similar to embedFileRelative ? embedFileRelative :: FilePath -> Q Exp embedFileRelative f = makeRelativeToProject f >>= embedStringFile 

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           hledger-lib-version:        1.29.2+version:        1.30 synopsis:       A reusable library providing the core functionality of hledger description:    A reusable library containing hledger's core functionality.                 This is used by most hledger* packages so that they support the same@@ -68,8 +68,10 @@       Hledger.Read       Hledger.Read.Common       Hledger.Read.CsvReader+      Hledger.Read.CsvUtils       Hledger.Read.InputOptions       Hledger.Read.JournalReader+      Hledger.Read.RulesReader       Hledger.Read.TimedotReader       Hledger.Read.TimeclockReader       Hledger.Reports@@ -134,6 +136,7 @@     , tasty >=1.2.3     , tasty-hunit >=0.10.0.2     , template-haskell+    , terminal-size >=0.3.3     , text >=1.2     , text-ansi >=0.2.1     , time >=1.5@@ -192,6 +195,7 @@     , tasty >=1.2.3     , tasty-hunit >=0.10.0.2     , template-haskell+    , terminal-size >=0.3.3     , text >=1.2     , text-ansi >=0.2.1     , time >=1.5@@ -252,6 +256,7 @@     , tasty >=1.2.3     , tasty-hunit >=0.10.0.2     , template-haskell+    , terminal-size >=0.3.3     , text >=1.2     , text-ansi >=0.2.1     , time >=1.5