hledger-lib 1.34 → 1.40

raw patch · 30 files changed

+1274/−1110 lines, 30 filesdep +luciddep ~megaparsecPVP ok

version bump matches the API change (PVP)

Dependencies added: lucid

Dependency ranges changed: megaparsec

API changes (from Hackage documentation)

Files

• CHANGES.md +16/−2
• Hledger/Data/Amount.hs +12/−4
• Hledger/Data/Dates.hs +156/−135
• Hledger/Data/Journal.hs +60/−18
• Hledger/Data/JournalChecks.hs +5/−4
• Hledger/Data/Period.hs +11/−8
• Hledger/Data/PeriodicTransaction.hs +0/−16
• Hledger/Data/Types.hs +7/−18
• Hledger/Read/Common.hs +22/−6
• Hledger/Read/CsvUtils.hs +0/−56
• Hledger/Read/JournalReader.hs +0/−1
• Hledger/Read/RulesReader.hs +4/−5
• Hledger/Read/TimedotReader.hs +19/−37
• Hledger/Reports/BudgetReport.hs +2/−300
• Hledger/Reports/MultiBalanceReport.hs +3/−29
• Hledger/Reports/PostingsReport.hs +40/−3
• Hledger/Reports/ReportOptions.hs +52/−5
• Hledger/Utils/Debug.hs +1/−1
• Hledger/Utils/IO.hs +9/−6
• Hledger/Utils/Parse.hs +434/−4
• Hledger/Utils/Regex.hs +1/−1
• Hledger/Utils/String.hs +1/−1
• Hledger/Utils/Test.hs +3/−3
• Hledger/Write/Csv.hs +56/−0
• Hledger/Write/Html.hs +39/−0
• Hledger/Write/Ods.hs +259/−0
• Hledger/Write/Spreadsheet.hs +49/−0
• Text/Megaparsec/Custom.hs +0/−437
• Text/Tabular/AsciiWide.hs +1/−3
• hledger-lib.cabal +12/−7

@@ -7,20 +7,34 @@  Breaking changes -Improvements- Fixes +Improvements      + --> Internal/api/developer-ish changes in the hledger-lib (and hledger) packages. For user-visible changes, see the hledger package changelog. ++# 1.40 2024-09-09++Breaking changes++- Some constructors of the Interval type have been renamed for clarity.+- Hledger.Read.CsvUtils has moved to Hledger.Write.Csv. (Henning Thielemann)+- Tabular report rendering code has been added/reworked to allow new output formats and more reuse. (Henning Thielemann)++Improvements++- Added `journalDbg` debug output helper.++- Allow doclayout 0.5.  # 1.34 2024-06-01 

@@ -155,6 +155,7 @@   showMixedAmountWithZeroCommodity,   showMixedAmountB,   showMixedAmountLinesB,+  showMixedAmountLinesPartsB,   wbToText,   wbUnpack,   mixedAmountSetPrecision,@@ -763,7 +764,7 @@     negate = maNegate     (+)    = maPlus     (*)    = error "error, mixed amounts do not support multiplication" -- PARTIAL:-    abs    = error "error, mixed amounts do not support abs"+    abs    = mapMixedAmount (\amt -> amt { aquantity = abs (aquantity amt)})     signum = error "error, mixed amounts do not support signum"  -- | Calculate the key used to store an Amount within a MixedAmount.@@ -1120,10 +1121,17 @@ -- This returns the list of WideBuilders: one for each Amount, and padded/elided to the appropriate width. -- This does not honour displayOneLine; all amounts will be displayed as if displayOneLine were False. showMixedAmountLinesB :: AmountFormat -> MixedAmount -> [WideBuilder]-showMixedAmountLinesB opts@AmountFormat{displayMaxWidth=mmax,displayMinWidth=mmin} ma =-    map (adBuilder . pad) elided+showMixedAmountLinesB opts ma =+    map fst $ showMixedAmountLinesPartsB opts ma++-- | Like 'showMixedAmountLinesB' but also returns+-- the amounts associated with each text builder.+showMixedAmountLinesPartsB :: AmountFormat -> MixedAmount -> [(WideBuilder, Amount)]+showMixedAmountLinesPartsB opts@AmountFormat{displayMaxWidth=mmax,displayMinWidth=mmin} ma =+    zip (map (adBuilder . pad) elided) amts   where-    astrs = amtDisplayList (wbWidth sep) (showAmountB opts) . orderedAmounts opts $+    astrs = amtDisplayList (wbWidth sep) (showAmountB opts) amts+    amts = orderedAmounts opts $               if displayCost opts then ma else mixedAmountStripCosts ma     sep   = WideBuilder (TB.singleton '\n') 0     width = maximum $ map (wbWidth . adBuilder) elided

@@ -43,7 +43,7 @@   showEFDate,   showDateSpan,   showDateSpanDebug,-  showDateSpanMonthAbbrev,+  showDateSpanAbbrev,   elapsedSeconds,   prevday,   periodexprp,@@ -139,8 +139,8 @@  -- | Like showDateSpan, but show month spans as just the abbreviated month name -- in the current locale.-showDateSpanMonthAbbrev :: DateSpan -> Text-showDateSpanMonthAbbrev = showPeriodMonthAbbrev . dateSpanAsPeriod+showDateSpanAbbrev :: DateSpan -> Text+showDateSpanAbbrev = showPeriodAbbrev . dateSpanAsPeriod  -- | Get the current local date. getCurrentDay :: IO Day@@ -188,14 +188,20 @@ spansSpan spans = DateSpan (spanStartDate =<< headMay spans) (spanEndDate =<< lastMay spans)  -- | Split a DateSpan into consecutive exact spans of the specified Interval.--- If the first argument is true and the interval is Weeks, Months, Quarters or Years,--- the start date will be adjusted backward if needed to nearest natural interval boundary--- (a monday, first of month, first of quarter or first of year). -- If no interval is specified, the original span is returned. -- If the original span is the null date span, ie unbounded, the null date span is returned. -- If the original span is empty, eg if the end date is <= the start date, no spans are returned. ----- ==== Examples:+-- ==== Date adjustment+-- Some intervals respect the "adjust" flag (years, quarters, months, weeks, every Nth weekday+-- of month seem to be the ones that need it). This will move the start date earlier, if needed,+-- to the previous natural interval boundary (first of year, first of quarter, first of month,+-- monday, previous Nth weekday of month). Related: #1982 #2218+--+-- The end date is always moved later if needed to the next natural interval boundary,+-- so that the last period is the same length as the others.+--+-- ==== Examples -- >>> let t i y1 m1 d1 y2 m2 d2 = splitSpan True i $ DateSpan (Just $ Flex $ fromGregorian y1 m1 d1) (Just $ Flex $ fromGregorian y2 m2 d2) -- >>> t NoInterval 2008 01 01 2009 01 01 -- [DateSpan 2008]@@ -212,38 +218,38 @@ -- >>> t (Months 2) 2008 01 01 2008 04 01 -- [DateSpan 2008-01-01..2008-02-29,DateSpan 2008-03-01..2008-04-30] -- >>> t (Weeks 1) 2008 01 01 2008 01 15--- [DateSpan 2007-12-31W01,DateSpan 2008-01-07W02,DateSpan 2008-01-14W03]+-- [DateSpan 2007-W01,DateSpan 2008-W02,DateSpan 2008-W03] -- >>> t (Weeks 2) 2008 01 01 2008 01 15 -- [DateSpan 2007-12-31..2008-01-13,DateSpan 2008-01-14..2008-01-27]--- >>> t (DayOfMonth 2) 2008 01 01 2008 04 01--- [DateSpan 2007-12-02..2008-01-01,DateSpan 2008-01-02..2008-02-01,DateSpan 2008-02-02..2008-03-01,DateSpan 2008-03-02..2008-04-01]--- >>> t (WeekdayOfMonth 2 4) 2011 01 01 2011 02 15+-- >>> t (MonthDay 2) 2008 01 01 2008   04 01+-- [DateSpan 2008-01-02..2008-02-01,DateSpan 2008-02-02..2008-03-01,DateSpan 2008-03-02..2008-04-01]+-- >>> t (NthWeekdayOfMonth 2 4) 2011 01 01 2011 02 15 -- [DateSpan 2010-12-09..2011-01-12,DateSpan 2011-01-13..2011-02-09,DateSpan 2011-02-10..2011-03-09] -- >>> t (DaysOfWeek [2]) 2011 01 01 2011 01 15 -- [DateSpan 2010-12-28..2011-01-03,DateSpan 2011-01-04..2011-01-10,DateSpan 2011-01-11..2011-01-17]--- >>> t (DayOfYear 11 29) 2011 10 01 2011 10 15--- [DateSpan 2010-11-29..2011-11-28]--- >>> t (DayOfYear 11 29) 2011 12 01 2012 12 15--- [DateSpan 2011-11-29..2012-11-28,DateSpan 2012-11-29..2013-11-28]+-- >>> t (MonthAndDay 11 29) 2012 10 01 2013 10 15+-- [DateSpan 2012-11-29..2013-11-28] -- splitSpan :: Bool -> Interval -> DateSpan -> [DateSpan]-splitSpan _ _ (DateSpan Nothing Nothing) = [DateSpan Nothing Nothing]-splitSpan _ _ ds | isEmptySpan ds = []-splitSpan _ _ ds@(DateSpan (Just s) (Just e)) | s == e = [ds]-splitSpan _ NoInterval ds = [ds]-splitSpan _ (Days n) ds = splitspan id addDays n                    ds-splitSpan adjust (Weeks n)    ds = splitspan (if adjust then startofweek    else id) addDays (7*n)                ds-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 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+splitSpan _      _                        (DateSpan Nothing Nothing) = [DateSpan Nothing Nothing]+splitSpan _      _                        ds | isEmptySpan ds = []+splitSpan _      _                        ds@(DateSpan (Just s) (Just e)) | s == e = [ds]+splitSpan _      NoInterval               ds = [ds]+splitSpan _      (Days n)                 ds = splitspan id addDays n ds+splitSpan adjust (Weeks n)                ds = splitspan (if adjust then startofweek    else id) addDays                 (7*n) ds+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 adjust (NthWeekdayOfMonth n wd) ds = splitspan (if adjust then prevstart else nextstart) advancemonths          1     ds   where+    prevstart = prevNthWeekdayOfMonth n wd+    nextstart = nextNthWeekdayOfMonth n wd     advancemonths 0 = id-    advancemonths w = advancetonthweekday n wd . startofmonth . addGregorianMonthsClip w-splitSpan _ (DaysOfWeek [])         ds = [ds]-splitSpan _ (DaysOfWeek days@(n:_)) ds = spansFromBoundaries e bdrys+    advancemonths m = advanceToNthWeekday n wd . startofmonth . addGregorianMonthsClip m+splitSpan _      (MonthDay dom)           ds = splitspan (nextnthdayofmonth dom) (addGregorianMonthsToMonthday dom) 1 ds+splitSpan _      (MonthAndDay m d)        ds = splitspan (nextmonthandday m d)   (addGregorianYearsClip)            1 ds+splitSpan _      (DaysOfWeek [])          ds = [ds]+splitSpan _      (DaysOfWeek days@(n:_))  ds = spansFromBoundaries e bdrys   where     (s, e) = dateSpanSplitLimits (nthdayofweekcontaining n) nextday ds     bdrys = concatMap (flip map starts . addDays) [0,7..]@@ -260,16 +266,18 @@   in fromGregorian y m dom  -- Split the given span into exact spans using the provided helper functions:--- 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.+--+-- 1. The start function is used to adjust the provided span's start date to get the first sub-span's start date.+--+-- 2. The next function is used to calculate subsequent sub-spans' start dates, possibly with stride increased by a multiplier.+--    It should handle spans of varying length, eg when splitting on "every 31st of month",+--    it adjusts to 28/29/30 in short months but returns to 31 in the long months.+-- splitspan :: (Day -> Day) -> (Integer -> Day -> Day) -> Int -> DateSpan -> [DateSpan]-splitspan start addInterval mult ds = spansFromBoundaries e bdrys+splitspan start next mult ds = spansFromBoundaries e bdrys   where-    (s, e) = dateSpanSplitLimits start (addInterval (toInteger mult)) ds-    bdrys = mapM (addInterval . toInteger) [0,mult..] $ start s+    (s, e) = dateSpanSplitLimits start (next (toInteger mult)) ds+    bdrys = mapM (next . toInteger) [0,mult..] $ start s  -- | Fill in missing start/end dates for calculating 'splitSpan'. dateSpanSplitLimits :: (Day -> Day) -> (Day -> Day) -> DateSpan -> (Day, Day)@@ -490,8 +498,7 @@ fixSmartDateStrEither :: Day -> Text -> Either HledgerParseErrors Text fixSmartDateStrEither d = fmap showEFDate . fixSmartDateStrEither' d -fixSmartDateStrEither'-  :: Day -> Text -> Either HledgerParseErrors EFDay+fixSmartDateStrEither' :: Day -> Text -> Either HledgerParseErrors EFDay fixSmartDateStrEither' d s = case parsewith smartdateonly (T.toLower s) of                                Right sd -> Right $ fixSmartDate d sd                                Left e -> Left e@@ -621,7 +628,7 @@       firstmonthofquarter m2 = ((m2-1) `div` 3) * 3 + 1  thisyear = startofyear-prevyear = startofyear . addGregorianYearsClip (-1)+-- prevyear = startofyear . addGregorianYearsClip (-1) nextyear = startofyear . addGregorianYearsClip 1 startofyear day = fromGregorian y 1 1 where (y,_,_) = toGregorian day @@ -633,65 +640,50 @@     (DateSpan (Just start) _:_) -> fromEFDay start     _ -> d --- | For given date d find year-long interval that starts on given--- MM/DD of year and covers it.--- The given MM and DD should be basically valid (1-12 & 1-31),--- or an error is raised.+-- | Find the next occurrence of the specified month and day of month, on or after the given date.+-- The month should be 1-12 and the day of month should be 1-31, or an error will be raised. ----- Examples: lets take 2017-11-22. Year-long intervals covering it that--- starts before Nov 22 will start in 2017. However--- intervals that start after Nov 23rd should start in 2016: -- >>> let wed22nd = fromGregorian 2017 11 22--- >>> nthdayofyearcontaining 11 21 wed22nd--- 2017-11-21--- >>> nthdayofyearcontaining 11 22 wed22nd+-- >>> nextmonthandday 11 21 wed22nd+-- 2018-11-21+-- >>> nextmonthandday 11 22 wed22nd -- 2017-11-22--- >>> nthdayofyearcontaining 11 23 wed22nd--- 2016-11-23--- >>> nthdayofyearcontaining 12 02 wed22nd--- 2016-12-02--- >>> nthdayofyearcontaining 12 31 wed22nd--- 2016-12-31--- >>> nthdayofyearcontaining 1 1 wed22nd--- 2017-01-01-nthdayofyearcontaining :: Month -> MonthDay -> Day -> Day-nthdayofyearcontaining m mdy date+-- >>> nextmonthandday 11 23 wed22nd+-- 2017-11-23+nextmonthandday :: Month -> MonthDay -> Day -> Day+nextmonthandday m n date   -- PARTIAL:-  | not (validMonth m)  = error' $ "nthdayofyearcontaining: invalid month "++show m-  | not (validDay   mdy) = error' $ "nthdayofyearcontaining: invalid day "  ++show mdy-  | mmddOfSameYear <= date = mmddOfSameYear-  | otherwise = mmddOfPrevYear-  where mmddOfSameYear = addDays (toInteger mdy-1) $ applyN (m-1) nextmonth s-        mmddOfPrevYear = addDays (toInteger mdy-1) $ applyN (m-1) nextmonth $ prevyear s-        s = startofyear date+  | not (validMonth m) = error' $ "nextmonthandday: month should be 1..12, not "++show m+  | not (validDay   n) = error' $ "nextmonthandday: day should be 1..31, not "  ++show n+  | mdthisyear >= date = mdthisyear+  | otherwise          = mdnextyear+  where+    s = startofyear date+    advancetomonth = applyN (m-1) nextmonth+    advancetoday = addDays (toInteger n-1)+    mdthisyear = advancetoday $ advancetomonth s+    mdnextyear = advancetoday $ advancetomonth $ nextyear s --- | 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.+-- | Find the next occurrence of the specified day of month, on or after the given date.+-- The day of month should be 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--- intervals that start on 23rd-30th of month should start in Oct: -- >>> let wed22nd = fromGregorian 2017 11 22--- >>> nthdayofmonthcontaining 1 wed22nd--- 2017-11-01--- >>> nthdayofmonthcontaining 12 wed22nd--- 2017-11-12--- >>> nthdayofmonthcontaining 22 wed22nd+-- >>> nextnthdayofmonth 21 wed22nd+-- 2017-12-21+-- >>> nextnthdayofmonth 22 wed22nd -- 2017-11-22--- >>> nthdayofmonthcontaining 23 wed22nd--- 2017-10-23--- >>> nthdayofmonthcontaining 30 wed22nd--- 2017-10-30-nthdayofmonthcontaining :: MonthDay -> Day -> Day-nthdayofmonthcontaining mdy date+-- >>> nextnthdayofmonth 23 wed22nd+-- 2017-11-23+nextnthdayofmonth :: MonthDay -> Day -> Day+nextnthdayofmonth n date   -- PARTIAL:-  | not (validDay mdy) = error' $ "nthdayofmonthcontaining: invalid day "  ++show mdy-  | nthOfSameMonth <= date = nthOfSameMonth-  | otherwise = nthOfPrevMonth-  where nthOfSameMonth = nthdayofmonth mdy s-        nthOfPrevMonth = nthdayofmonth mdy $ prevmonth s-        s = startofmonth date+  | not (validDay n)       = error' $ "nextnthdayofmonth: day should be 1..31, not "  ++show n+  | nthofthismonth >= date = nthofthismonth+  | otherwise              = nthofnextmonth+  where+    s = startofmonth date+    nthofthismonth = nthdayofmonth n s+    nthofnextmonth = nthdayofmonth n $ nextmonth s  -- | For given date d find week-long interval that starts on nth day of week -- and covers it.@@ -717,37 +709,66 @@           nthOfPrevWeek = addDays (toInteger n-1) $ prevweek s           s = startofweek d --- | For given date d find month-long interval that starts on nth weekday of month--- and covers it.+-- -- | Find the next occurrence of some weekday, on or after the given date d.+-- --+-- -- >>> let wed22nd = fromGregorian 2017 11 22+-- -- >>> nextnthdayofweek 1 wed22nd+-- -- 2017-11-20+-- -- >>> nextnthdayofweek 2 wed22nd+-- -- 2017-11-21+-- -- >>> nextnthdayofweek 3 wed22nd+-- -- 2017-11-22+-- -- >>> nextnthdayofweek 4 wed22nd+-- -- 2017-11-16+-- -- >>> nextnthdayofweek 5 wed22nd+-- -- 2017-11-17+-- nextdayofweek :: WeekDay -> Day -> Day+-- nextdayofweek n d | nthOfSameWeek <= d = nthOfSameWeek+--                            | otherwise = nthOfPrevWeek+--     where nthOfSameWeek = addDays (toInteger n-1) s+--           nthOfPrevWeek = addDays (toInteger n-1) $ prevweek s+--           s = startofweek d++-- | Find the next occurrence of some nth weekday of a month, on or after the given date d. ----- Examples: 2017-11-22 is 3rd Wed of Nov. Month-long intervals that cover it and--- start on 1st-4th Wed will start in Nov. However--- intervals that start on 4th Thu or Fri or later should start in Oct: -- >>> let wed22nd = fromGregorian 2017 11 22--- >>> nthweekdayofmonthcontaining 1 3 wed22nd--- 2017-11-01--- >>> nthweekdayofmonthcontaining 3 2 wed22nd--- 2017-11-21--- >>> nthweekdayofmonthcontaining 4 3 wed22nd+-- >>> nextNthWeekdayOfMonth 3 3 wed22nd  -- next third wednesday+-- 2017-12-20+-- >>> nextNthWeekdayOfMonth 4 3 wed22nd  -- next fourth wednesday -- 2017-11-22--- >>> nthweekdayofmonthcontaining 4 4 wed22nd--- 2017-10-26--- >>> nthweekdayofmonthcontaining 4 5 wed22nd--- 2017-10-27-nthweekdayofmonthcontaining :: Int -> WeekDay -> Day -> Day-nthweekdayofmonthcontaining n wd d | nthWeekdaySameMonth <= d  = nthWeekdaySameMonth-                                   | otherwise = nthWeekdayPrevMonth-    where nthWeekdaySameMonth = advancetonthweekday n wd $ startofmonth d-          nthWeekdayPrevMonth = advancetonthweekday n wd $ prevmonth d+-- >>> nextNthWeekdayOfMonth 5 3 wed22nd  -- next fifth wednesday+-- 2017-11-29+nextNthWeekdayOfMonth :: Int -> WeekDay -> Day -> Day+nextNthWeekdayOfMonth n wd d+  | nthweekdaythismonth >= d = nthweekdaythismonth+  | otherwise                = nthweekdaynextmonth+  where+    nthweekdaythismonth = advanceToNthWeekday n wd $ startofmonth d+    nthweekdaynextmonth = advanceToNthWeekday n wd $ nextmonth d --- | Advance to nth weekday wd after given start day s+-- | Find the previous occurrence of some nth weekday of a month, on or before the given date d.+--+-- >>> let wed22nd = fromGregorian 2017 11 22+-- >>> prevNthWeekdayOfMonth 4 3 wed22nd+-- 2017-11-22+-- >>> prevNthWeekdayOfMonth 5 2 wed22nd+-- 2017-10-31+prevNthWeekdayOfMonth :: Int -> WeekDay -> Day -> Day+prevNthWeekdayOfMonth n wd d+  | nthweekdaythismonth <= d = nthweekdaythismonth+  | otherwise                = nthweekdayprevmonth+  where+    nthweekdaythismonth = advanceToNthWeekday n wd $ startofmonth d+    nthweekdayprevmonth = advanceToNthWeekday n wd $ prevmonth d++-- | Advance to the nth occurrence of the given weekday, on or after the given date. -- Can call error.-advancetonthweekday :: Int -> WeekDay -> Day -> Day-advancetonthweekday n wd s =+advanceToNthWeekday :: Int -> WeekDay -> Day -> Day+advanceToNthWeekday n wd s =   -- PARTIAL:   maybe err (addWeeks (n-1)) $ firstMatch (>=s) $ iterate (addWeeks 1) $ firstweekday s   where-    err = error' "advancetonthweekday: should not happen"+    err = error' "advanceToNthWeekday: should not happen"     addWeeks k = addDays (7 * toInteger k)     firstMatch p = headMay . dropWhile (not . p)     firstweekday = addDays (toInteger wd-1) . startofweek@@ -966,41 +987,41 @@ -- >>> p "every week to 2009" -- Right (Weeks 1,DateSpan ..2008-12-31) -- >>> p "every 2nd day of month"--- Right (DayOfMonth 2,DateSpan ..)+-- Right (MonthDay 2,DateSpan ..) -- >>> p "every 2nd day"--- Right (DayOfMonth 2,DateSpan ..)+-- Right (MonthDay 2,DateSpan ..) -- >>> p "every 2nd day 2009.."--- Right (DayOfMonth 2,DateSpan 2009-01-01..)+-- Right (MonthDay 2,DateSpan 2009-01-01..) -- >>> p "every 2nd day 2009-"--- Right (DayOfMonth 2,DateSpan 2009-01-01..)+-- Right (MonthDay 2,DateSpan 2009-01-01..) -- >>> p "every 29th Nov"--- Right (DayOfYear 11 29,DateSpan ..)+-- Right (MonthAndDay 11 29,DateSpan ..) -- >>> p "every 29th nov ..2009"--- Right (DayOfYear 11 29,DateSpan ..2008-12-31)+-- Right (MonthAndDay 11 29,DateSpan ..2008-12-31) -- >>> p "every nov 29th"--- Right (DayOfYear 11 29,DateSpan ..)+-- Right (MonthAndDay 11 29,DateSpan ..) -- >>> p "every Nov 29th 2009.."--- Right (DayOfYear 11 29,DateSpan 2009-01-01..)+-- Right (MonthAndDay 11 29,DateSpan 2009-01-01..) -- >>> p "every 11/29 from 2009"--- Right (DayOfYear 11 29,DateSpan 2009-01-01..)+-- Right (MonthAndDay 11 29,DateSpan 2009-01-01..) -- >>> p "every 11/29 since 2009"--- Right (DayOfYear 11 29,DateSpan 2009-01-01..)+-- Right (MonthAndDay 11 29,DateSpan 2009-01-01..) -- >>> p "every 2nd Thursday of month to 2009"--- Right (WeekdayOfMonth 2 4,DateSpan ..2008-12-31)+-- Right (NthWeekdayOfMonth 2 4,DateSpan ..2008-12-31) -- >>> p "every 1st monday of month to 2009"--- Right (WeekdayOfMonth 1 1,DateSpan ..2008-12-31)+-- Right (NthWeekdayOfMonth 1 1,DateSpan ..2008-12-31) -- >>> p "every tue" -- Right (DaysOfWeek [2],DateSpan ..) -- >>> p "every 2nd day of week" -- Right (DaysOfWeek [2],DateSpan ..) -- >>> p "every 2nd day of month"--- Right (DayOfMonth 2,DateSpan ..)+-- Right (MonthDay 2,DateSpan ..) -- >>> p "every 2nd day"--- Right (DayOfMonth 2,DateSpan ..)+-- Right (MonthDay 2,DateSpan ..) -- >>> p "every 2nd day 2009.."--- Right (DayOfMonth 2,DateSpan 2009-01-01..)+-- Right (MonthDay 2,DateSpan 2009-01-01..) -- >>> p "every 2nd day of month 2009.."--- Right (DayOfMonth 2,DateSpan 2009-01-01..)+-- Right (MonthDay 2,DateSpan 2009-01-01..) periodexprp :: Day -> TextParser m (Interval, DateSpan) periodexprp rdate = do   skipNonNewlineSpaces@@ -1029,9 +1050,9 @@     , Months 2 <$ string' "bimonthly"     , string' "every" *> skipNonNewlineSpaces *> choice'         [ DaysOfWeek . pure <$> (nth <* skipNonNewlineSpaces <* string' "day" <* of_ "week")-        , DayOfMonth <$> (nth <* skipNonNewlineSpaces <* string' "day" <* optOf_ "month")-        , liftA2 WeekdayOfMonth nth $ skipNonNewlineSpaces *> weekday <* optOf_ "month"-        , uncurry DayOfYear <$> (md <* optOf_ "year")+        , MonthDay <$> (nth <* skipNonNewlineSpaces <* string' "day" <* optOf_ "month")+        , liftA2 NthWeekdayOfMonth nth $ skipNonNewlineSpaces *> weekday <* optOf_ "month"+        , uncurry MonthAndDay <$> (md <* optOf_ "year")         , DaysOfWeek <$> weekdaysp         , DaysOfWeek [1..5] <$ string' "weekday"         , DaysOfWeek [6..7] <$ string' "weekendday"@@ -1050,8 +1071,8 @@     optOf_ period = optional . try $ of_ period      nth = decimal <* choice (map string' ["st","nd","rd","th"])-    d_o_y = runPermutation $ liftA2 DayOfYear (toPermutation $ (month <|> mon) <* skipNonNewlineSpaces)-                                              (toPermutation $ nth <* skipNonNewlineSpaces)+    d_o_y = runPermutation $ liftA2 MonthAndDay (toPermutation $ (month <|> mon) <* skipNonNewlineSpaces)+                                                (toPermutation $ nth <* skipNonNewlineSpaces)      -- Parse any of several variants of a basic interval, eg "daily", "every day", "every N days".     tryinterval :: Text -> Text -> (Int -> Interval) -> TextParser m Interval

@@ -21,6 +21,7 @@   addTransactionModifier,   addPeriodicTransaction,   addTransaction,+  journalDbg,   journalInferMarketPricesFromTransactions,   journalInferCommodityStyles,   journalStyleAmounts,@@ -134,7 +135,6 @@ import Data.Tree (Tree(..), flatten) import Text.Printf (printf) import Text.Megaparsec (ParsecT)-import Text.Megaparsec.Custom (FinalParseError)  import Hledger.Utils import Hledger.Data.Types@@ -182,17 +182,39 @@              -- ++ (show $ journalTransactions l)              where accounts = filter (/= "root") $ flatten $ journalAccountNameTree j --- showJournalDebug j = unlines [---                       show j---                      ,show (jtxns j)---                      ,show (jtxnmodifiers j)---                      ,show (jperiodictxns j)---                      ,show $ jparsetimeclockentries j---                      ,show $ jpricedirectives j---                      ,show $ jfinalcommentlines j---                      ,show $ jparsestate j---                      ,show $ map fst $ jfiles j---                      ]+journalDbg j@Journal{..} = chomp $ unlines $+  ("Journal " ++ takeFileName (journalFilePath j)++":") :  --  ++ " {"+  map (" "<>) [+   "jparsedefaultyear: "         <> shw jparsedefaultyear+  ,"jparsedefaultcommodity: "    <> shw jparsedefaultcommodity+  ,"jparsedecimalmark: "         <> shw jparsedecimalmark+  ,"jparseparentaccounts: "      <> shw jparseparentaccounts+  ,"jparsealiases: "             <> shw jparsealiases+  -- ,"jparsetimeclockentries: " <> shw jparsetimeclockentries+  ,"jincludefilestack: "         <> shw jincludefilestack+  ,"jdeclaredpayees: "           <> shw jdeclaredpayees+  ,"jdeclaredtags: "             <> shw jdeclaredtags+  ,"jdeclaredaccounts: "         <> shw jdeclaredaccounts+  ,"jdeclaredaccounttags: "      <> shw jdeclaredaccounttags+  ,"jdeclaredaccounttypes: "     <> shw jdeclaredaccounttypes+  ,"jaccounttypes: "             <> shw jaccounttypes+  ,"jglobalcommoditystyles: "    <> shw jglobalcommoditystyles+  ,"jcommodities: "              <> shw jcommodities+  ,"jinferredcommodities: "      <> shw jinferredcommodities+  ,"jpricedirectives: "          <> shw jpricedirectives+  ,"jinferredmarketprices: "     <> shw jinferredmarketprices+  ,"jtxnmodifiers: "             <> shw jtxnmodifiers+  -- ,"jperiodictxns: "          <> shw jperiodictxns+  ,"jtxns: "                     <> shw jtxns+  ,"jfinalcommentlines: "        <> shw jfinalcommentlines+  ,"jfiles: "                    <> shw jfiles+  ,"jlastreadtime: "             <> shw jlastreadtime+  ]+  -- ++ ["}"]+  where+    shw :: Show a => a -> String+    shw = show+    -- shw = pshow  -- The semigroup instance for Journal is useful for two situations. --@@ -232,12 +254,32 @@     ,jdeclaredpayees            = jdeclaredpayees            j1 <> jdeclaredpayees            j2     ,jdeclaredtags              = jdeclaredtags              j1 <> jdeclaredtags              j2     ,jdeclaredaccounts          = jdeclaredaccounts          j1 <> jdeclaredaccounts          j2-    ,jdeclaredaccounttags       = jdeclaredaccounttags       j1 <> jdeclaredaccounttags       j2-    ,jdeclaredaccounttypes      = jdeclaredaccounttypes      j1 <> jdeclaredaccounttypes      j2-    ,jaccounttypes              = jaccounttypes              j1 <> jaccounttypes              j2-    ,jglobalcommoditystyles     = jglobalcommoditystyles     j1 <> jglobalcommoditystyles     j2-    ,jcommodities               = jcommodities               j1 <> jcommodities               j2-    ,jinferredcommodities       = jinferredcommodities       j1 <> jinferredcommodities       j2+    --+    -- The next six fields are Maps, which need to be merged carefully for correct semantics,+    -- especially the first two, which have list values. There may still be room for improvement here.+    --+    -- ,jdeclaredaccounttags   :: M.Map AccountName [Tag]+    -- jdeclaredaccounttags can have multiple duplicated/conflicting values for an account's tag.+    ,jdeclaredaccounttags       = M.unionWith (<>) (jdeclaredaccounttags j1) (jdeclaredaccounttags j2)+    --+    -- ,jdeclaredaccounttypes  :: M.Map AccountType [AccountName]+    -- jdeclaredaccounttypes can have multiple duplicated/conflicting values for an account's type.+    ,jdeclaredaccounttypes      = M.unionWith (<>) (jdeclaredaccounttypes j1) (jdeclaredaccounttypes j2)+    --+    -- ,jaccounttypes          :: M.Map AccountName AccountType+    -- jaccounttypes has a single type for any given account. When it had multiple type declarations, the last/rightmost wins.+    ,jaccounttypes              = M.unionWith (const id) (jaccounttypes j1) (jaccounttypes j2)+    --+    -- ,jglobalcommoditystyles :: M.Map CommoditySymbol AmountStyle+    ,jglobalcommoditystyles     = (<>) (jglobalcommoditystyles j1) (jglobalcommoditystyles j2)+    --+    -- ,jcommodities           :: M.Map CommoditySymbol Commodity+    ,jcommodities               = (<>) (jcommodities j1) (jcommodities j2)+    --+    -- ,jinferredcommodities   :: M.Map CommoditySymbol AmountStyle+    ,jinferredcommodities       = (<>) (jinferredcommodities j1) (jinferredcommodities j2)+    --+    --     ,jpricedirectives           = jpricedirectives           j1 <> jpricedirectives           j2     ,jinferredmarketprices      = jinferredmarketprices      j1 <> jinferredmarketprices      j2     ,jtxnmodifiers              = jtxnmodifiers              j1 <> jtxnmodifiers              j2

@@ -289,18 +289,19 @@       "%s\n",       "The recentassertions check is enabled, so accounts with balance assertions must",       "have a balance assertion within %d days of their latest posting.",-      "In account \"%s\", this posting is %d days later",-      "than the last balance assertion, which was on %s.",       "",+      "In %s,",+      "this posting is %d days later than the balance assertion on %s.",+      "",       "Consider adding a more recent balance assertion for this account. Eg:",       "",-      "%s\n    %s    %s0 = %s0  ; (adjust asserted amount)"+      "%s\n    %s    %s0 = %sAMT"       ])     f     l     (textChomp ex)     maxlag-    acct+    (bold' $ T.unpack acct)     lag     (showDate latestassertdate)     (show today)

@@ -15,7 +15,7 @@   ,isStandardPeriod   ,periodTextWidth   ,showPeriod-  ,showPeriodMonthAbbrev+  ,showPeriodAbbrev   ,periodStart   ,periodEnd   ,periodNext@@ -173,10 +173,10 @@ -- | Render a period as a compact display string suitable for user output. -- -- >>> showPeriod (WeekPeriod (fromGregorian 2016 7 25))--- "2016-07-25W30"+-- "2016-W30" showPeriod :: Period -> Text showPeriod (DayPeriod b)       = T.pack $ formatTime defaultTimeLocale "%F" b              -- DATE-showPeriod (WeekPeriod b)      = T.pack $ formatTime defaultTimeLocale "%FW%V" b           -- STARTDATEWYEARWEEK+showPeriod (WeekPeriod b)      = T.pack $ formatTime defaultTimeLocale "%0Y-W%V" b         -- YYYY-Www showPeriod (MonthPeriod y m)   = T.pack $ printf "%04d-%02d" y m                           -- YYYY-MM showPeriod (QuarterPeriod y q) = T.pack $ printf "%04dQ%d" y q                             -- YYYYQN showPeriod (YearPeriod y)      = T.pack $ printf "%04d" y                                  -- YYYY@@ -186,13 +186,16 @@ showPeriod (PeriodTo e)        = T.pack $ formatTime defaultTimeLocale "..%F" (addDays (-1) e)    -- ..INCLUSIVEENDDATE showPeriod PeriodAll           = ".." --- | Like showPeriod, but if it's a month period show just--- the 3 letter month name abbreviation for the current locale.-showPeriodMonthAbbrev :: Period -> Text-showPeriodMonthAbbrev (MonthPeriod _ m)                           -- Jan+-- | Like showPeriod, but if it's a month or week period show+-- an abbreviated form.+-- >>> showPeriodAbbrev (WeekPeriod (fromGregorian 2016 7 25))+-- "W30"+showPeriodAbbrev :: Period -> Text+showPeriodAbbrev (MonthPeriod _ m)                                              -- Jan   | m > 0 && m <= length monthnames = T.pack . snd $ monthnames !! (m-1)   where monthnames = months defaultTimeLocale-showPeriodMonthAbbrev p = showPeriod p+showPeriodAbbrev (WeekPeriod b) = T.pack $ formatTime defaultTimeLocale "W%V" b -- Www+showPeriodAbbrev p = showPeriod p  periodStart :: Period -> Maybe Day periodStart p = fromEFDay <$> mb

@@ -114,10 +114,6 @@ -- <BLANKLINE> -- -- >>> _ptgen "every 2nd day of month from 2017/02 to 2017/04"--- 2017-01-02---     ; generated-transaction: ~ every 2nd day of month from 2017/02 to 2017/04---     a           $1.00--- <BLANKLINE> -- 2017-02-02 --     ; generated-transaction: ~ every 2nd day of month from 2017/02 to 2017/04 --     a           $1.00@@ -128,10 +124,6 @@ -- <BLANKLINE> -- -- >>> _ptgen "every 30th day of month from 2017/1 to 2017/5"--- 2016-12-30---     ; generated-transaction: ~ every 30th day of month from 2017/1 to 2017/5---     a           $1.00--- <BLANKLINE> -- 2017-01-30 --     ; generated-transaction: ~ every 30th day of month from 2017/1 to 2017/5 --     a           $1.00@@ -150,10 +142,6 @@ -- <BLANKLINE> -- -- >>> _ptgen "every 2nd Thursday of month from 2017/1 to 2017/4"--- 2016-12-08---     ; generated-transaction: ~ every 2nd Thursday of month from 2017/1 to 2017/4---     a           $1.00--- <BLANKLINE> -- 2017-01-12 --     ; generated-transaction: ~ every 2nd Thursday of month from 2017/1 to 2017/4 --     a           $1.00@@ -168,10 +156,6 @@ -- <BLANKLINE> -- -- >>> _ptgen "every nov 29th from 2017 to 2019"--- 2016-11-29---     ; generated-transaction: ~ every nov 29th from 2017 to 2019---     a           $1.00--- <BLANKLINE> -- 2017-11-29 --     ; generated-transaction: ~ every nov 29th from 2017 to 2019 --     a           $1.00

@@ -116,7 +116,7 @@  instance Default DateSpan where def = DateSpan Nothing Nothing --- Typical report periods (spans of time), both finite and open-ended.+-- Some common report subperiods, both finite and open-ended. -- A higher-level abstraction than DateSpan. data Period =     DayPeriod Day@@ -132,16 +132,8 @@  instance Default Period where def = PeriodAll ----- Typical report period/subperiod durations, from a day to a year.---data Duration =---    DayLong---   WeekLong---   MonthLong---   QuarterLong---   YearLong---  deriving (Eq,Ord,Show,Generic)---- Ways in which a period can be divided into subperiods.+-- All the kinds of report interval allowed in a period expression+-- (to generate periodic reports or periodic transactions). data Interval =     NoInterval   | Days Int@@ -149,13 +141,10 @@   | Months Int   | Quarters Int   | Years Int-  | DayOfMonth Int-  | WeekdayOfMonth Int Int-  | DaysOfWeek [Int]-  | DayOfYear Int Int -- Month, Day-  -- WeekOfYear Int-  -- MonthOfYear Int-  -- QuarterOfYear Int+  | NthWeekdayOfMonth Int Int  -- n,              weekday 1-7+  | MonthDay Int               -- 1-31+  | MonthAndDay Int Int        -- month 1-12,     monthday 1-31+  | DaysOfWeek [Int]           -- [weekday 1-7]   deriving (Eq,Show,Ord,Generic)  instance Default Interval where def = NoInterval

@@ -96,6 +96,7 @@   isSameLineCommentStart,   multilinecommentp,   emptyorcommentlinep,+  emptyorcommentlinep2,   followingcommentp,   transactioncommentp,   commenttagsp,@@ -150,9 +151,6 @@ import Text.Megaparsec import Text.Megaparsec.Char (char, char', digitChar, newline, string) import Text.Megaparsec.Char.Lexer (decimal)-import Text.Megaparsec.Custom-  (FinalParseError, attachSource, finalErrorBundlePretty, parseErrorAt, parseErrorAtRegion)--- import Text.Megaparsec.Debug (dbg)  -- from megaparsec 9.3+  import Hledger.Data import Hledger.Query (Query(..), filterQuery, parseQueryTerm, queryEndDate, queryStartDate, queryIsDate, simplifyQuery)@@ -211,7 +209,7 @@     in definputopts{        -- files_             = listofstringopt "file" rawopts        mformat_           = Nothing-      ,mrules_file_       = maybestringopt "rules-file" rawopts+      ,mrules_file_       = maybestringopt "rules" rawopts       ,aliases_           = listofstringopt "alias" rawopts       ,anon_              = boolopt "obfuscate" rawopts       ,new_               = boolopt "new" rawopts@@ -361,7 +359,7 @@        -- >>= Right . dbg0With (concatMap (T.unpack.showTransaction).jtxns)        -- >>= \j -> deepseq (concatMap (T.unpack.showTransaction).jtxns $ j) (return j)       <&> dbg9With (lbl "amounts after styling, forecasting, auto-posting".showJournalAmountsDebug)-      >>= (\j -> if checkordereddates then journalCheckOrdereddates j <&> const j else Right j)  -- check ordereddates before assertions. The outer parentheses are needed.+      >>= (\j -> if checkordereddates then journalCheckOrdereddates j $> j else Right j)  -- check ordereddates before assertions. The outer parentheses are needed.       >>= journalBalanceTransactions balancingopts_{ignore_assertions_=not checkassertions}  -- infer balance assignments and missing amounts, and maybe check balance assertions.       <&> dbg9With (lbl "amounts after transaction-balancing".showJournalAmountsDebug)       -- <&> dbg9With (("journalFinalise amounts after styling, forecasting, auto postings, transaction balancing"<>).showJournalAmountsDebug)@@ -409,6 +407,10 @@ getYear :: JournalParser m (Maybe Year) getYear = fmap jparsedefaultyear get +dp :: String -> TextParser m ()+dp = const $ return ()  -- no-op+-- dp = dbgparse 1  -- trace parse state at this --debug level+ -- | Get the decimal mark that has been specified for parsing, if any -- (eg by the CSV decimal-mark rule, or possibly a future journal directive). -- Return it as an AmountStyle that amount parsers can use.@@ -1262,9 +1264,10 @@  -- | A blank or comment line in journal format: a line that's empty or -- containing only whitespace or whose first non-whitespace character--- is semicolon, hash, or star.+-- is semicolon, hash, or star. See also emptyorcommentlinep2. emptyorcommentlinep :: TextParser m () emptyorcommentlinep = do+  dp "emptyorcommentlinep"   skipNonNewlineSpaces   skiplinecommentp <|> void newline   where@@ -1276,6 +1279,19 @@       pure ()  {-# INLINABLE emptyorcommentlinep #-}++-- | A newer comment line parser.+-- Parses a line which is empty, all blanks, or whose first non-blank character is one of those provided.+emptyorcommentlinep2 :: [Char] -> TextParser m ()+emptyorcommentlinep2 cs =+  label ("empty line or comment line beginning with "++cs) $ do+    dp "emptyorcommentlinep2"+    skipNonNewlineSpaces+    void newline <|> void commentp+    where+      commentp = do+        choice (map (some.char) cs)+        takeWhileP Nothing (/='\n') <* newline  -- | Is this a character that, as the first non-whitespace on a line, -- starts a comment line ?

@@ -1,56 +0,0 @@---- * -*- outline-regexp:"--- \\*"; -*----- ** doc-{-|--CSV utilities.---}----- ** language-{-# LANGUAGE OverloadedStrings    #-}----- ** exports-module Hledger.Read.CsvUtils (-  CSV, CsvRecord, CsvValue,-  printCSV,-  printTSV,-  -- * 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 "\"" "\"\""--printTSV :: [CsvRecord] -> TL.Text-printTSV = TB.toLazyText . unlinesB . map printRecord-    where printRecord = foldMap TB.fromText . intersperse "\t" . map printField-          printField = T.map replaceWhitespace-          replaceWhitespace c | c `elem` ['\t', '\n', '\r'] = ' '-          replaceWhitespace c = c----- ** tests--tests_CsvUtils :: TestTree-tests_CsvUtils = testGroup "CsvUtils" [-  ]

@@ -91,7 +91,6 @@ import Safe import Text.Megaparsec hiding (parse) import Text.Megaparsec.Char-import Text.Megaparsec.Custom import Text.Printf import System.FilePath import "Glob" System.FilePath.Glob hiding (match)

@@ -72,13 +72,12 @@ import Data.Foldable (asum, toList) import Text.Megaparsec hiding (match, parse) import Text.Megaparsec.Char (char, newline, string, digitChar)-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, commenttagsp )-import Hledger.Read.CsvUtils+import Hledger.Write.Csv import System.Directory (doesFileExist, getHomeDirectory) import Data.Either (fromRight) @@ -113,7 +112,7 @@ -- 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.+-- The provided text, or a --rules option, are ignored by this reader. -- Balance assertions are not checked. parse :: InputOpts -> FilePath -> Text -> ExceptT String IO Journal parse iopts f _ = do@@ -368,7 +367,7 @@  QUOTED-FIELD-NAME: " (any CHAR except double-quote)+ " -BARE-FIELD-NAME: any CHAR except space, tab, #, ;+BARE-FIELD-NAME: (any CHAR except space, tab, #, ;)+  FIELD-ASSIGNMENT: JOURNAL-FIELD ASSIGNMENT-SEPARATOR FIELD-VALUE @@ -884,7 +883,7 @@ -- 4. Return the transactions as a Journal. -- readJournalFromCsv :: Maybe (Either CsvRules FilePath) -> FilePath -> Text -> Maybe SepFormat -> ExceptT String IO Journal-readJournalFromCsv Nothing "-" _ _ = throwError "please use --rules-file when reading CSV from stdin"+readJournalFromCsv Nothing "-" _ _ = throwError "please use --rules when reading CSV from stdin" readJournalFromCsv merulesfile csvfile csvtext sep = do     -- for now, correctness is the priority here, efficiency not so much 

@@ -50,7 +50,7 @@ import Text.Megaparsec.Char  import Hledger.Data-import Hledger.Read.Common hiding (emptyorcommentlinep)+import Hledger.Read.Common import Hledger.Utils import Data.Decimal (roundTo) import Data.Functor ((<&>))@@ -80,12 +80,10 @@  --- ** utilities -traceparse, traceparse' :: String -> TextParser m ()-traceparse  = const $ return ()-traceparse' = const $ return ()--- for debugging:--- traceparse  s = traceParse (s++"?")--- traceparse' s = trace s $ return ()+-- Trace parser state above a certain --debug level ?+tracelevel = 9+dp :: String -> JournalParser m ()+dp = if tracelevel >= 0 then lift . dbgparse tracelevel else const $ return ()  --- ** parsers {-@@ -113,9 +111,8 @@  preamblep :: JournalParser m () preamblep = do-  lift $ traceparse "preamblep"-  many $ notFollowedBy datelinep >> (lift $ emptyorcommentlinep "#;*")-  lift $ traceparse' "preamblep"+  dp "preamblep"+  void $ many $ notFollowedBy datelinep >> (lift $ emptyorcommentlinep2 "#;*")  -- | Parse timedot day entries to multi-posting time transactions for that day. -- @@@ -126,11 +123,13 @@ -- @ dayp :: JournalParser m () dayp = label "timedot day entry" $ do-  lift $ traceparse "dayp"+  dp "dayp"   pos <- getSourcePos   (date,desc,comment,tags) <- datelinep+  dp "dayp1"   commentlinesp-  ps <- (many $ timedotentryp <* commentlinesp) <&> concat+  dp "dayp2"+  ps <- (many $ dp "dayp3" >> timedotentryp <* commentlinesp) <&> concat   endpos <- getSourcePos   let t = txnTieKnot $ nulltransaction{     tsourcepos   = (pos, endpos),@@ -145,7 +144,7 @@  datelinep :: JournalParser m (Day,Text,Text,[Tag]) datelinep = do-  lift $ traceparse "datelinep"+  dp "datelinep"   lift $ optional orgheadingprefixp   date <- datep   desc <- T.strip <$> lift descriptionp@@ -156,16 +155,15 @@ -- or org headlines which do not start a new day. commentlinesp :: JournalParser m () commentlinesp = do-  lift $ traceparse "commentlinesp"-  void $ many $ try $ lift $ emptyorcommentlinep "#;"+  dp "commentlinesp"+  void $ many $ try $ lift $ emptyorcommentlinep2 "#;"  -- orgnondatelinep :: JournalParser m () -- orgnondatelinep = do---   lift $ traceparse "orgnondatelinep"+--   dp "orgnondatelinep" --   lift orgheadingprefixp --   notFollowedBy datelinep --   void $ lift restofline---   lift $ traceparse' "orgnondatelinep"  orgheadingprefixp = skipSome (char '*') >> skipNonNewlineSpaces1 @@ -175,7 +173,7 @@ -- @ timedotentryp :: JournalParser m [Posting] timedotentryp = do-  lift $ traceparse "timedotentryp"+  dp "timedotentryp"   notFollowedBy datelinep   lift $ optional $ choice [orgheadingprefixp, skipNonNewlineSpaces1]   a <- modifiedaccountnamep@@ -225,7 +223,7 @@ -- @ numericquantityp :: TextParser m Hours numericquantityp = do-  -- lift $ traceparse "numericquantityp"+  -- dp "numericquantityp"   (q, _, _, _) <- numberp Nothing   msymbol <- optional $ choice $ map (string . fst) timeUnits   skipNonNewlineSpaces@@ -257,7 +255,7 @@ -- @ dotquantityp :: TextParser m Hours dotquantityp = do-  -- lift $ traceparse "dotquantityp"+  -- dp "dotquantityp"   char '.'   dots <- many (oneOf ['.', ' ']) <&> filter (not.isSpace)   return $ fromIntegral (1 + length dots) / 4@@ -267,7 +265,7 @@ -- ignoring any interspersed spaces after the first letter. letterquantitiesp :: TextParser m [(Hours, TagValue)] letterquantitiesp =-  -- dbg "letterquantitiesp" $ +  -- dp "letterquantitiesp"   do     letter1 <- letterChar     letters <- many (letterChar <|> spacenonewline) <&> filter (not.isSpace)@@ -276,19 +274,3 @@           | t@(c:_) <- group $ sort $ letter1:letters           ]     return groups---- | XXX new comment line parser, move to Hledger.Read.Common.emptyorcommentlinep--- Parse empty lines, all-blank lines, and lines beginning with any of the provided--- comment-beginning characters.-emptyorcommentlinep :: [Char] -> TextParser m ()-emptyorcommentlinep cs =-  label ("empty line or comment line beginning with "++cs) $ do-    traceparse "emptyorcommentlinep" -- XXX possible to combine label and traceparse ?-    skipNonNewlineSpaces-    void newline <|> void commentp-    traceparse' "emptyorcommentlinep"-    where-      commentp = do-        choice (map (some.char) cs)-        takeWhileP Nothing (/='\n') <* newline-

@@ -1,5 +1,4 @@ {-# LANGUAGE OverloadedStrings   #-}-{-# LANGUAGE RecordWildCards     #-} {-# LANGUAGE ScopedTypeVariables #-}  module Hledger.Reports.BudgetReport (@@ -10,9 +9,6 @@   BudgetReportRow,   BudgetReport,   budgetReport,-  budgetReportAsTable,-  budgetReportAsText,-  budgetReportAsCsv,   -- * Helpers   combineBudgetAndActual,   -- * Tests@@ -21,25 +17,16 @@ where  import Control.Applicative ((<|>))-import Control.Arrow ((***))-import Data.Decimal (roundTo)-import Data.Function (on) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HM-import Data.List (find, partition, transpose, foldl', maximumBy, intercalate)+import Data.List (find, partition, maximumBy, intercalate) import Data.List.Extra (nubSort)-import Data.Maybe (fromMaybe, catMaybes, isJust)+import Data.Maybe (fromMaybe, isJust) import Data.Map (Map) import qualified Data.Map as Map import qualified Data.Set as S-import Data.Text (Text) import qualified Data.Text as T-import qualified Data.Text.Lazy as TL-import qualified Data.Text.Lazy.Builder as TB import Safe (minimumDef)---import System.Console.CmdArgs.Explicit as C---import Lucid as L-import qualified Text.Tabular.AsciiWide as Tab  import Hledger.Data import Hledger.Utils@@ -62,17 +49,6 @@ -- | A full budget report table. type BudgetReport    = PeriodicReport    DisplayName BudgetCell --- A BudgetCell's data values rendered for display - the actual change amount,--- the budget goal amount if any, and the corresponding goal percentage if possible.-type BudgetDisplayCell = (WideBuilder, Maybe (WideBuilder, Maybe WideBuilder))--- | A row of rendered budget data cells.-type BudgetDisplayRow  = [BudgetDisplayCell]---- | An amount render helper for the budget report. Renders each commodity separately.-type BudgetShowAmountsFn   = MixedAmount -> [WideBuilder]--- | A goal percentage calculating helper for the budget report.-type BudgetCalcPercentagesFn  = Change -> BudgetGoal -> [Maybe Percentage]- _brrShowDebug :: BudgetReportRow -> String _brrShowDebug (PeriodicReportRow dname budgetpairs _tot _avg) =   unwords [@@ -278,280 +254,6 @@         totGoalByPeriod = Map.fromList $ zip budgetperiods budgettots :: Map DateSpan BudgetTotal         totActualByPeriod = Map.fromList $ zip actualperiods actualtots :: Map DateSpan Change         budget b = if mixedAmountLooksZero b then Nothing else Just b---- | Render a budget report as plain text suitable for console output.-budgetReportAsText :: ReportOpts -> BudgetReport -> TL.Text-budgetReportAsText ropts@ReportOpts{..} budgetr = TB.toLazyText $-    TB.fromText title <> TB.fromText "\n\n" <>-      balanceReportTableAsText ropts (budgetReportAsTable ropts budgetr)-  where-    title = "Budget performance in " <> showDateSpan (periodicReportSpan budgetr)-           <> (case conversionop_ of-                 Just ToCost -> ", converted to cost"-                 _           -> "")-           <> (case value_ of-                 Just (AtThen _mc)   -> ", valued at posting date"-                 Just (AtEnd _mc)    -> ", valued at period ends"-                 Just (AtNow _mc)    -> ", current value"-                 Just (AtDate d _mc) -> ", valued at " <> showDate d-                 Nothing             -> "")-           <> ":"---- | Build a 'Table' from a multi-column balance report.-budgetReportAsTable :: ReportOpts -> BudgetReport -> Tab.Table Text Text WideBuilder-budgetReportAsTable ReportOpts{..} (PeriodicReport spans items totrow) =-  maybetransposetable $-  addtotalrow $-    Tab.Table-      (Tab.Group Tab.NoLine $ map Tab.Header accts)-      (Tab.Group Tab.NoLine $ map Tab.Header colheadings)-      rows-  where-    maybetransposetable-      | transpose_ = \(Tab.Table rh ch vals) -> Tab.Table ch rh (transpose vals)-      | otherwise  = id--    addtotalrow-      | no_total_ = id-      | otherwise = let rh = Tab.Group Tab.NoLine . replicate (length totalrows) $ Tab.Header ""-                        ch = Tab.Header [] -- ignored-                     in (flip (Tab.concatTables Tab.SingleLine) $ Tab.Table rh ch totalrows)--    colheadings = ["Commodity" | layout_ == LayoutBare]-                  ++ map (reportPeriodName balanceaccum_ spans) spans-                  ++ ["  Total" | row_total_]-                  ++ ["Average" | average_]--    (accts, rows, totalrows) =-      (accts'-      ,maybecommcol itemscs  $ showcells  texts-      ,maybecommcol totrowcs $ showtotrow totrowtexts)-      where-        -- If --layout=bare, prepend a commodities column.-        maybecommcol :: [WideBuilder] -> [[WideBuilder]] -> [[WideBuilder]]-        maybecommcol cs-          | layout_ == LayoutBare = zipWith (:) cs-          | otherwise             = id--        showcells, showtotrow :: [[BudgetDisplayCell]] -> [[WideBuilder]]-        (showcells, showtotrow) =-          (maybetranspose . map (zipWith showBudgetDisplayCell widths)       . maybetranspose-          ,maybetranspose . map (zipWith showBudgetDisplayCell totrowwidths) . maybetranspose)-          where-            -- | Combine a BudgetDisplayCell's rendered values into a "[PERCENT of GOAL]" rendering,-            -- respecting the given widths.-            showBudgetDisplayCell :: (Int, Int, Int) -> BudgetDisplayCell -> WideBuilder-            showBudgetDisplayCell (actualwidth, budgetwidth, percentwidth) (actual, mbudget) =-              flip WideBuilder (actualwidth + totalbudgetwidth) $-                toPadded actual <> maybe emptycell showBudgetGoalAndPercentage mbudget--              where-                toPadded (WideBuilder b w) = (TB.fromText . flip T.replicate " " $ actualwidth - w) <> b--                (totalpercentwidth, totalbudgetwidth) =-                  let totalpercentwidth' = if percentwidth == 0 then 0 else percentwidth + 5-                   in ( totalpercentwidth'-                      , if budgetwidth == 0 then 0 else budgetwidth + totalpercentwidth' + 3-                      )--                emptycell :: TB.Builder-                emptycell = TB.fromText $ T.replicate totalbudgetwidth " "--                showBudgetGoalAndPercentage :: (WideBuilder, Maybe WideBuilder) -> TB.Builder-                showBudgetGoalAndPercentage (goal, perc) =-                  let perct = case perc of-                        Nothing  -> T.replicate totalpercentwidth " "-                        Just pct -> T.replicate (percentwidth - wbWidth pct) " " <> wbToText pct <> "% of "-                   in TB.fromText $ " [" <> perct <> T.replicate (budgetwidth - wbWidth goal) " " <> wbToText goal <> "]"--            -- | Build a list of widths for each column.-            -- When --transpose is used, the totals row must be included in this list.-            widths :: [(Int, Int, Int)]-            widths = zip3 actualwidths budgetwidths percentwidths-              where-                actualwidths  = map (maximum' . map first3 ) $ cols-                budgetwidths  = map (maximum' . map second3) $ cols-                percentwidths = map (maximum' . map third3 ) $ cols-                catcolumnwidths = foldl' (zipWith (++)) $ repeat []-                cols = maybetranspose $ catcolumnwidths $ map (cellswidth . rowToBudgetCells) items ++ [cellswidth $ rowToBudgetCells totrow]--                cellswidth :: [BudgetCell] -> [[(Int, Int, Int)]]-                cellswidth row =-                  let cs = budgetCellsCommodities row-                      (showmixed, percbudget) = mkBudgetDisplayFns cs-                      disp = showcell showmixed percbudget-                      budgetpercwidth = wbWidth *** maybe 0 wbWidth-                      cellwidth (am, bm) = let (bw, pw) = maybe (0, 0) budgetpercwidth bm in (wbWidth am, bw, pw)-                   in map (map cellwidth . disp) row--            totrowwidths :: [(Int, Int, Int)]-            totrowwidths-              | transpose_ = drop (length texts) widths-              | otherwise = widths--            maybetranspose-              | transpose_ = transpose-              | otherwise  = id--        (accts', itemscs, texts) = unzip3 $ concat shownitems-          where-            shownitems :: [[(AccountName, WideBuilder, BudgetDisplayRow)]]-            shownitems =-              map (\i ->-                let-                  addacctcolumn = map (\(cs, cvals) -> (renderacct i, cs, cvals))-                  isunbudgetedrow = displayFull (prrName i) == unbudgetedAccountName-                in addacctcolumn $ showrow isunbudgetedrow $ rowToBudgetCells i)-              items-              where-                -- FIXME. Have to check explicitly for which to render here, since-                -- budgetReport sets accountlistmode to ALTree. Find a principled way to do-                -- this.-                renderacct row = case accountlistmode_ of-                  ALTree -> T.replicate ((prrDepth row - 1)*2) " " <> prrDisplayName row-                  ALFlat -> accountNameDrop (drop_) $ prrFullName row--        (totrowcs, totrowtexts)  = unzip  $ concat showntotrow-          where-            showntotrow :: [[(WideBuilder, BudgetDisplayRow)]]-            showntotrow = [showrow False $ rowToBudgetCells totrow]--        -- | Get the data cells from a row or totals row, maybe adding -        -- the row total and/or row average depending on options.-        rowToBudgetCells :: PeriodicReportRow a BudgetCell -> [BudgetCell]-        rowToBudgetCells (PeriodicReportRow _ as rowtot rowavg) = as-            ++ [rowtot | row_total_ && not (null as)]-            ++ [rowavg | average_   && not (null as)]--        -- | Render a row's data cells as "BudgetDisplayCell"s, and a rendered list of commodity symbols.-        -- Also requires a flag indicating whether this is the special <unbudgeted> row.-        -- (The types make that hard to check here.)-        showrow :: Bool -> [BudgetCell] -> [(WideBuilder, BudgetDisplayRow)]-        showrow isunbudgetedrow cells =-          let-            cs = budgetCellsCommodities cells-            -- #2071 If there are no commodities - because there are no actual or goal amounts --            -- the zipped list would be empty, causing this row not to be shown.-            -- But rows like this sometimes need to be shown to preserve the account tree structure.-            -- So, ensure 0 will be shown as actual amount(s).-            -- Unfortunately this disables boring parent eliding, as if --no-elide had been used.-            -- (Just turning on --no-elide higher up doesn't work right.)-            -- Note, no goal amount will be shown for these rows,-            -- whereas --no-elide is likely to show a goal amount aggregated from children.-            cs1 = if null cs && not isunbudgetedrow then [""] else cs-            (showmixed, percbudget) = mkBudgetDisplayFns cs1-          in-            zip (map wbFromText cs1) $-            transpose $-            map (showcell showmixed percbudget)-            cells--        budgetCellsCommodities :: [BudgetCell] -> [CommoditySymbol]-        budgetCellsCommodities = S.toList . foldl' S.union mempty . map budgetCellCommodities-          where-            budgetCellCommodities :: BudgetCell -> S.Set CommoditySymbol-            budgetCellCommodities (am, bm) = f am `S.union` f bm-              where f = maybe mempty maCommodities--        -- | Render a "BudgetCell"'s amounts as "BudgetDisplayCell"s (one per commodity).-        showcell :: BudgetShowAmountsFn -> BudgetCalcPercentagesFn -> BudgetCell -> BudgetDisplayRow-        showcell showCommodityAmounts calcCommodityPercentages (mactual, mbudget) =-          zip actualamts budgetinfos-          where-            actual = fromMaybe nullmixedamt mactual-            actualamts = showCommodityAmounts actual-            budgetinfos =-              case mbudget of-                Nothing   -> repeat Nothing-                Just goal -> map Just $ showGoalAmountsAndPercentages goal-                where-                  showGoalAmountsAndPercentages :: MixedAmount -> [(WideBuilder, Maybe WideBuilder)]-                  showGoalAmountsAndPercentages goal = zip amts mpcts-                    where-                      amts  = showCommodityAmounts goal-                      mpcts = map (showrounded <$>) $ calcCommodityPercentages actual goal-                        where showrounded = wbFromText . T.pack . show . roundTo 0--        -- | Make budget info display helpers that adapt to --layout=wide.-        mkBudgetDisplayFns :: [CommoditySymbol] -> (BudgetShowAmountsFn, BudgetCalcPercentagesFn)-        mkBudgetDisplayFns cs = case layout_ of-          LayoutWide width ->-               ( pure . showMixedAmountB oneLineNoCostFmt{displayMaxWidth=width, displayColour=color_}-               , \a -> pure . percentage a)-          _ -> ( showMixedAmountLinesB noCostFmt{displayCommodity=layout_/=LayoutBare, displayCommodityOrder=Just cs, displayMinWidth=Nothing, displayColour=color_}-               , \a b -> map (percentage' a b) cs)-          where-            -- | Calculate the percentage of actual change to budget goal to show, if any.-            -- If valuing at cost, both amounts are converted to cost before comparing.-            -- A percentage will not be shown if:-            ---            -- - actual or goal are not the same, single, commodity-            ---            -- - the goal is zero-            ---            percentage :: Change -> BudgetGoal -> Maybe Percentage-            percentage actual budget =-              case (costedAmounts actual, costedAmounts budget) of-                ([a], [b]) | (acommodity a == acommodity b || amountLooksZero a) && not (amountLooksZero b)-                    -> Just $ 100 * aquantity a / aquantity b-                _   -> Nothing-              where-                costedAmounts = case conversionop_ of-                    Just ToCost -> amounts . mixedAmountCost-                    _           -> amounts--            -- | Like percentage, but accept multicommodity actual and budget amounts,-            -- and extract the specified commodity from both.-            percentage' :: Change -> BudgetGoal -> CommoditySymbol -> Maybe Percentage-            percentage' am bm c = case ((,) `on` find ((==) c . acommodity) . amounts) am bm of-                (Just a, Just b) -> percentage (mixedAmount a) (mixedAmount b)-                _                -> Nothing---- XXX generalise this with multiBalanceReportAsCsv ?--- | Render a budget report as CSV. Like multiBalanceReportAsCsv,--- but includes alternating actual and budget amount columns.-budgetReportAsCsv :: ReportOpts -> BudgetReport -> [[Text]]-budgetReportAsCsv-  ReportOpts{..}-  (PeriodicReport colspans items totrow)-  = (if transpose_ then transpose else id) $--  -- heading row-  ("Account" :-  ["Commodity" | layout_ == LayoutBare ]-   ++ concatMap (\spn -> [showDateSpan spn, "budget"]) colspans-   ++ concat [["Total"  ,"budget"] | row_total_]-   ++ concat [["Average","budget"] | average_]-  ) :--  -- account rows-  concatMap (rowAsTexts prrFullName) items--  -- totals row-  ++ concat [ rowAsTexts (const "Total:") totrow | not no_total_ ]--  where-    flattentuples tups = concat [[a,b] | (a,b) <- tups]-    showNorm = maybe "" (wbToText . showMixedAmountB oneLineNoCostFmt)--    rowAsTexts :: (PeriodicReportRow a BudgetCell -> Text)-               -> PeriodicReportRow a BudgetCell-               -> [[Text]]-    rowAsTexts render row@(PeriodicReportRow _ as (rowtot,budgettot) (rowavg, budgetavg))-      | layout_ /= LayoutBare = [render row : map showNorm vals]-      | otherwise =-            joinNames . zipWith (:) cs  -- add symbols and names-          . transpose                   -- each row becomes a list of Text quantities-          . map (map wbToText . showMixedAmountLinesB dopts . fromMaybe nullmixedamt)-          $ vals-      where-        cs = S.toList . foldl' S.union mempty . map maCommodities $ catMaybes vals-        dopts = oneLineNoCostFmt{displayCommodity=layout_ /= LayoutBare, displayCommodityOrder=Just cs, displayMinWidth=Nothing}-        vals = flattentuples as-            ++ concat [[rowtot, budgettot] | row_total_]-            ++ concat [[rowavg, budgetavg] | average_]--        joinNames = map (render row :)  -- tests 

@@ -28,7 +28,6 @@   getPostings,   startingPostings,   generateMultiBalanceReport,-  balanceReportTableAsText,    -- -- * Tests   tests_MultiBalanceReport@@ -39,7 +38,7 @@ import Data.Bifunctor (second) import Data.Foldable (toList) import Data.List (sortOn, transpose)-import Data.List.NonEmpty (NonEmpty(..))+import Data.List.NonEmpty (NonEmpty((:|))) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HM import Data.Map (Map)@@ -52,11 +51,6 @@ import Data.Time.Calendar (fromGregorian) import Safe (lastDef, minimumMay) -import Data.Default (def)-import qualified Data.Text as T-import qualified Data.Text.Lazy.Builder as TB-import qualified Text.Tabular.AsciiWide as Tab- import Hledger.Data import Hledger.Query import Hledger.Utils hiding (dbg3,dbg4,dbg5)@@ -594,33 +588,13 @@ cumulativeSum :: Account -> Map DateSpan Account -> Map DateSpan Account cumulativeSum start = snd . M.mapAccum (\a b -> let s = sumAcct a b in (s, s)) start --- | Given a table representing a multi-column balance report (for example,--- made using 'balanceReportAsTable'), render it in a format suitable for--- console output. Amounts with more than two commodities will be elided--- unless --no-elide is used.-balanceReportTableAsText :: ReportOpts -> Tab.Table T.Text T.Text WideBuilder -> TB.Builder-balanceReportTableAsText ReportOpts{..} =-    Tab.renderTableByRowsB def{Tab.tableBorders=False, Tab.prettyTable=pretty_} renderCh renderRow-  where-    renderCh-      | layout_ /= LayoutBare || transpose_ = fmap (Tab.textCell Tab.TopRight)-      | otherwise = zipWith ($) (Tab.textCell Tab.TopLeft : repeat (Tab.textCell Tab.TopRight))--    renderRow (rh, row)-      | layout_ /= LayoutBare || transpose_ =-          (Tab.textCell Tab.TopLeft rh, fmap (Tab.Cell Tab.TopRight . pure) row)-      | otherwise =-          (Tab.textCell Tab.TopLeft rh, zipWith ($) (Tab.Cell Tab.TopLeft : repeat (Tab.Cell Tab.TopRight)) (fmap pure row))--- -- tests  tests_MultiBalanceReport = testGroup "MultiBalanceReport" [    let-    amt0 = Amount {acommodity="$", aquantity=0, acost=Nothing, -      astyle=AmountStyle {ascommodityside = L, ascommodityspaced = False, asdigitgroups = Nothing, +    amt0 = Amount {acommodity="$", aquantity=0, acost=Nothing,+      astyle=AmountStyle {ascommodityside = L, ascommodityspaced = False, asdigitgroups = Nothing,       asdecimalmark = Just '.', asprecision = Precision 2, asrounding = NoRounding}}     (rspec,journal) `gives` r = do       let rspec' = rspec{_rsQuery=And [queryFromFlags $ _rsReportOpts rspec, _rsQuery rspec]}

@@ -15,15 +15,18 @@   PostingsReportItem,   postingsReport,   mkpostingsReportItem,+  SortSpec,+  defsortspec,    -- * Tests   tests_PostingsReport ) where -import Data.List (nub, sortOn)+import Data.List (nub, sortBy, sortOn) import Data.List.Extra (nubSort)-import Data.Maybe (isJust, isNothing)+import Data.Maybe (isJust, isNothing, fromMaybe)+import Data.Ord import Data.Text (Text) import Data.Time.Calendar (Day) import Safe (headMay)@@ -82,10 +85,12 @@           summariseps = summarisePostingsByInterval whichdate mdepth showempty colspans           showempty = empty_ || average_ +      sortedps = if sortspec_ /= defsortspec then sortPostings ropts sortspec_ displayps else displayps+       -- Posting report items ready for display.       items =         dbg4 "postingsReport items" $-        postingsReportItems displayps (nullposting,Nothing) whichdate mdepth startbal runningcalc startnum+        postingsReportItems postings (nullposting,Nothing) whichdate mdepth startbal runningcalc startnum         where           -- In historical mode we'll need a starting balance, which we           -- may be converting to value per hledger_options.m4.md "Effect@@ -100,6 +105,10 @@            runningcalc = registerRunningCalculationFn ropts           startnum = if historical then length precedingps + 1 else 1+          postings | historical = if sortspec_ /= defsortspec +                        then error "--historical and --sort should not be used together" +                        else sortedps+                   | otherwise = sortedps  -- | Based on the given report options, return a function that does the appropriate -- running calculation for the register report, ie a running average or running total.@@ -109,6 +118,34 @@ registerRunningCalculationFn ropts   | average_ ropts = \i avg amt -> avg `maPlus` divideMixedAmount (fromIntegral i) (amt `maMinus` avg)   | otherwise      = \_ bal amt -> bal `maPlus` amt++-- | Sort two postings by the current list of value expressions (given in SortSpec).+comparePostings :: ReportOpts -> SortSpec -> (Posting, Maybe Period) -> (Posting, Maybe Period) -> Ordering+comparePostings _ [] _ _ = EQ+comparePostings ropts (ex:es) (a, pa) (b, pb) = +    let +    getDescription p = +        let tx = ptransaction p +            description = fmap (\t -> tdescription t) tx+        -- If there's no transaction attached, then use empty text for the description+        in fromMaybe "" description+    comparison = case ex of+          AbsAmount' False -> compare (abs (pamount a)) (abs (pamount b))+          Amount' False -> compare (pamount a) (pamount b)+          Account' False -> compare (paccount a) (paccount b)+          Date' False -> compare (postingDateOrDate2 (whichDate ropts) a) (postingDateOrDate2 (whichDate ropts) b)+          Description' False -> compare (getDescription a) (getDescription b)+          AbsAmount' True -> compare (Down (abs (pamount a))) (Down (abs (pamount b)))+          Amount' True -> compare (Down (pamount a)) (Down (pamount b))+          Account' True -> compare (Down (paccount a)) (Down (paccount b))+          Date' True -> compare (Down (postingDateOrDate2 (whichDate ropts) a)) (Down (postingDateOrDate2 (whichDate ropts) b))+          Description' True -> compare (Down (getDescription a)) (Down (getDescription b))+    in +    if comparison == EQ then comparePostings ropts es (a, pa) (b, pb) else comparison++-- | Sort postings by the current SortSpec.+sortPostings :: ReportOpts -> SortSpec -> [(Posting, Maybe Period)] -> [(Posting, Maybe Period)]+sortPostings ropts sspec = sortBy (comparePostings ropts sspec)  -- | Find postings matching a given query, within a given date span, -- and also any similarly-matched postings before that date span.

@@ -21,6 +21,9 @@   HasReportOpts(..),   ReportSpec(..),   HasReportSpec(..),+  SortField(..),+  SortSpec,+  sortKeysDescription,   overEither,   setEither,   BalanceCalculation(..),@@ -31,6 +34,7 @@   defreportopts,   rawOptsToReportOpts,   defreportspec,+  defsortspec,   setDefaultConversionOp,   reportOptsToSpec,   updateReportSpec,@@ -71,15 +75,13 @@ import Data.Either (fromRight) import Data.Either.Extra (eitherToMaybe) import Data.Functor.Identity (Identity(..))-import Data.List.Extra (find, isPrefixOf, nubSort)+import Data.List.Extra (find, isPrefixOf, nubSort, stripPrefix) import Data.Maybe (fromMaybe, isJust, isNothing) import qualified Data.Text as T import Data.Time.Calendar (Day, addDays) import Data.Default (Default(..)) import Safe (headMay, lastDef, lastMay, maximumMay, readMay) -import Text.Megaparsec.Custom- import Hledger.Data import Hledger.Query import Hledger.Utils@@ -144,6 +146,8 @@     ,average_          :: Bool     -- for posting reports (register)     ,related_          :: Bool+    -- for sorting reports (register)+    ,sortspec_             :: SortSpec     -- for account transactions reports (aregister)     ,txn_dates_        :: Bool     -- for balance reports (bal, bs, cf, is)@@ -199,6 +203,7 @@     , querystring_      = []     , average_          = False     , related_          = False+    , sortspec_         = defsortspec      , txn_dates_        = False     , balancecalc_      = def     , balanceaccum_     = def@@ -253,6 +258,7 @@           ,querystring_      = querystring           ,average_          = boolopt "average" rawopts           ,related_          = boolopt "related" rawopts+          ,sortspec_         = getSortSpec rawopts           ,txn_dates_        = boolopt "txn-dates" rawopts           ,balancecalc_      = balancecalcopt rawopts           ,balanceaccum_     = balanceaccumopt rawopts@@ -665,6 +671,47 @@     consIf f b = if b then (f True:) else id     consJust f = maybe id ((:) . f) +-- Methods/types needed for --sort argument++-- Possible arguments taken by the --sort command+-- Each of these takes a bool, which shows if it has been inverted+-- (True -> has been inverted, reverse the order)+data SortField+    = AbsAmount' Bool+    | Account' Bool+    | Amount' Bool+    | Date' Bool+    | Description' Bool+    deriving (Show, Eq)+type SortSpec = [SortField]++-- By default, sort by date in ascending order+defsortspec :: SortSpec+defsortspec = [Date' False]++-- Load a SortSpec from the argument given to --sort+-- If there is no spec given, then sort by [Date' False] by default+getSortSpec :: RawOpts -> SortSpec+getSortSpec opts = +    let opt = maybestringopt "sort" opts+        optParser s = +          let terms = map strip $ splitAtElement ',' s +              termParser t = case trimmed of+                "date"        -> Date'        isNegated+                "desc"        -> Description' isNegated+                "description" -> Description' isNegated+                "account"     -> Account'     isNegated+                "amount"      -> Amount'      isNegated+                "absamount"   -> AbsAmount'   isNegated+                _ -> error' $ "unknown --sort key " ++ t ++ ". Supported keys are: " <> sortKeysDescription <> "."+                where isNegated = isPrefixOf "-" t+                      trimmed = fromMaybe t (stripPrefix "-" t)+          in map termParser terms+    in maybe defsortspec optParser opt ++-- for option's help and parse error message+sortKeysDescription = "date, desc, account, amount, absamount"  -- 'description' is also accepted+ -- Report dates.  -- | The effective report span is the start and end dates specified by@@ -766,7 +813,7 @@ reportPeriodName :: BalanceAccumulation -> [DateSpan] -> DateSpan -> T.Text reportPeriodName balanceaccumulation spans =   case balanceaccumulation of-    PerPeriod -> if multiyear then showDateSpan else showDateSpanMonthAbbrev+    PerPeriod -> if multiyear then showDateSpan else showDateSpanAbbrev       where         multiyear = (>1) $ length $ nubSort $ map spanStartYear spans     _ -> maybe "" (showDate . prevday) . spanEnd@@ -819,7 +866,7 @@ -- >>> _rsQuery <$> setEither querystring ["assets"] defreportspec -- Right (Acct (RegexpCI "assets")) -- >>> _rsQuery <$> setEither querystring ["(assets"] defreportspec--- Left "This regular expression is malformed, please correct it:\n(assets"+-- Left "This regular expression is invalid or unsupported, please correct it:\n(assets" -- >>> _rsQuery $ set querystring ["assets"] defreportspec -- Acct (RegexpCI "assets") -- >>> _rsQuery $ set querystring ["(assets"] defreportspec

@@ -53,7 +53,7 @@ Debug level:  What to show: ------------  --------------------------------------------------------- 0             normal command output only (no warnings, eg)-1             useful warnings, most common troubleshooting info, eg valuation+1             useful warnings, most common troubleshooting info (config file args, valuation..) 2             common troubleshooting info, more detail 3             report options selection 4             report generation

@@ -97,8 +97,10 @@ import           Data.Colour.RGBSpace (RGB(RGB)) import           Data.Colour.RGBSpace.HSL (lightness) import           Data.FileEmbed (makeRelativeToProject, embedStringFile)+import           Data.Functor ((<&>)) import           Data.List hiding (uncons) import           Data.Maybe (isJust)+import           Data.Ord (comparing, Down (Down)) import qualified Data.Text as T import qualified Data.Text.IO as T import qualified Data.Text.Lazy as TL@@ -115,6 +117,7 @@ import           System.Directory (getHomeDirectory, getModificationTime) import           System.Environment (getArgs, lookupEnv, setEnv) import           System.FilePath (isRelative, (</>))+import "Glob"    System.FilePath.Glob (glob) import           System.IO   (Handle, IOMode (..), hGetEncoding, hSetEncoding, hSetNewlineMode,    openFile, stdin, stdout, stderr, universalNewlineMode, utf8_bom, hIsTerminalDevice)@@ -127,15 +130,14 @@   defaultOutputOptionsDarkBg, defaultOutputOptionsNoColor, pShowOpt, pPrintOpt)  import Hledger.Utils.Text (WideBuilder(WideBuilder))-import "Glob" 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 = +prettyopts =   (if useColorOnStderr then defaultOutputOptionsDarkBg else defaultOutputOptionsNoColor)     { outputOptionsIndentAmount = 2     -- , outputOptionsCompact      = True  -- fills lines, but does not respect page width (https://github.com/cdepillabout/pretty-simple/issues/126)@@ -225,7 +227,7 @@ -- | Read the value of the -o/--output-file command line option provided at program startup, -- if any, using unsafePerformIO. outputFileOption :: Maybe String-outputFileOption = +outputFileOption =   -- keep synced with output-file flag definition in hledger:CliOptions.   let args = progArgs in   case dropWhile (not . ("-o" `isPrefixOf`)) args of@@ -315,7 +317,7 @@ -- | Read the value of the --color or --colour command line option provided at program startup -- using unsafePerformIO. If this option was not provided, returns the empty string. colorOption :: String-colorOption = +colorOption =   -- similar to debugLevel   -- keep synced with color/colour flag definition in hledger:CliOptions   let args = progArgs in@@ -462,7 +464,7 @@ sortByModTime :: [FilePath] -> IO [FilePath] sortByModTime fs = do   ftimes <- forM fs $ \f -> do {t <- getModificationTime f; return (t,f)}-  return $ map snd $ reverse $ sort ftimes+  return $ map snd $ sortBy (comparing Data.Ord.Down) ftimes  -- | Like readFilePortably, but read all of the file before proceeding. readFileStrictly :: FilePath -> IO T.Text@@ -515,4 +517,5 @@   t <- getCurrentTime   tz <- getCurrentTimeZone   return $ utcToZonedTime tz t+ 

@@ -1,8 +1,15 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}  module Hledger.Utils.Parse (++  -- * Some basic hledger parser flavours   SimpleStringParser,   SimpleTextParser,   TextParser,@@ -15,6 +22,7 @@   sourcePosPretty,   sourcePosPairPretty, +  -- * Parsers and helpers   choice',   choiceInState,   surroundedBy,@@ -32,7 +40,6 @@   isNonNewlineSpace,   restofline,   eolof,-   spacenonewline,   skipNonNewlineSpaces,   skipNonNewlineSpaces1,@@ -42,10 +49,44 @@   dbgparse,   traceOrLogParse, -  -- * re-exports-  HledgerParseErrors,+  -- * More helpers, previously in Text.Megaparsec.Custom++  -- ** Custom parse error types   HledgerParseErrorData,+  HledgerParseErrors,++  -- ** Failing with an arbitrary source position+  parseErrorAt,+  parseErrorAtRegion,++  -- ** Re-parsing+  SourceExcerpt,+  getExcerptText,+  excerpt_,+  reparseExcerpt,++  -- ** Pretty-printing custom parse errors   customErrorBundlePretty,++  -- ** "Final" parse errors+  FinalParseError,+  FinalParseError',+  FinalParseErrorBundle,+  FinalParseErrorBundle',++  -- *** Constructing "final" parse errors+  finalError,+  finalFancyFailure,+  finalFail,+  finalCustomFailure,++  -- *** Pretty-printing "final" parse errors+  finalErrorBundlePretty,+  attachSource,++  -- *** Handling parse errors from include files with "final" parse errors+  parseIncludeFile,+ ) where @@ -61,7 +102,15 @@ import Data.List import Data.Text (Text) import Text.Megaparsec.Char-import Text.Megaparsec.Custom+-- import Text.Megaparsec.Debug (dbg)  -- from megaparsec 9.3+++import Control.Monad.Except (ExceptT, MonadError, catchError, throwError)+-- import Control.Monad.State.Strict (StateT, evalStateT)+import Control.Monad.Trans.Class (lift)+import qualified Data.List.NonEmpty as NE+import Data.Monoid (Alt(..))+import qualified Data.Set as S+ import Hledger.Utils.Debug (debugLevel, traceOrLog)  -- | A parser of string to some type.@@ -200,3 +249,384 @@  eolof :: TextParser m () eolof = void newline <|> eof++++-- A bunch of megaparsec helpers, eg for re-parsing (formerly in Text.Megaparsec.Custom).+-- I think these are generic apart from the HledgerParseError name.++--- * Custom parse error types++-- | Custom error data for hledger parsers. Specialised for a 'Text' parse stream.+-- ReparseableTextParseErrorData ?+data HledgerParseErrorData+  -- | Fail with a message at a specific source position interval. The+  -- interval must be contained within a single line.+  = ErrorFailAt Int -- Starting offset+                Int -- Ending offset+                String -- Error message+  -- | Re-throw parse errors obtained from the "re-parsing" of an excerpt+  -- of the source text.+  | ErrorReparsing+      (NE.NonEmpty (ParseError Text HledgerParseErrorData)) -- Source fragment parse errors+  deriving (Show, Eq, Ord)++-- | A specialised version of ParseErrorBundle: +-- a non-empty collection of hledger parse errors, +-- equipped with PosState to help pretty-print them.+-- Specialised for a 'Text' parse stream.+type HledgerParseErrors = ParseErrorBundle Text HledgerParseErrorData++-- We require an 'Ord' instance for 'CustomError' so that they may be+-- stored in a 'Set'. The actual instance is inconsequential, so we just+-- derive it, but the derived instance requires an (orphan) instance for+-- 'ParseError'. Hopefully this does not cause any trouble.++deriving instance Ord (ParseError Text HledgerParseErrorData)++-- Note: the pretty-printing of our 'HledgerParseErrorData' type is only partally+-- defined in its 'ShowErrorComponent' instance; we perform additional+-- adjustments in 'customErrorBundlePretty'.++instance ShowErrorComponent HledgerParseErrorData where+  showErrorComponent (ErrorFailAt _ _ errMsg) = errMsg+  showErrorComponent (ErrorReparsing _) = "" -- dummy value++  errorComponentLen (ErrorFailAt startOffset endOffset _) =+    endOffset - startOffset+  errorComponentLen (ErrorReparsing _) = 1 -- dummy value+++--- * Failing with an arbitrary source position++-- | Fail at a specific source position, given by the raw offset from the+-- start of the input stream (the number of tokens processed at that+-- point).++parseErrorAt :: Int -> String -> HledgerParseErrorData+parseErrorAt offset = ErrorFailAt offset (offset+1)++-- | Fail at a specific source interval, given by the raw offsets of its+-- endpoints from the start of the input stream (the numbers of tokens+-- processed at those points).+--+-- Note that care must be taken to ensure that the specified interval does+-- not span multiple lines of the input source. This will not be checked.++parseErrorAtRegion+  :: Int    -- ^ Start offset+  -> Int    -- ^ End end offset+  -> String -- ^ Error message+  -> HledgerParseErrorData+parseErrorAtRegion startOffset endOffset msg =+  if startOffset < endOffset+    then ErrorFailAt startOffset endOffset msg'+    else ErrorFailAt startOffset (startOffset+1) msg'+  where+    msg' = "\n" ++ msg+++--- * Re-parsing++-- | A fragment of source suitable for "re-parsing". The purpose of this+-- data type is to preserve the content and source position of the excerpt+-- so that parse errors raised during "re-parsing" may properly reference+-- the original source.++data SourceExcerpt = SourceExcerpt Int  -- Offset of beginning of excerpt+                                   Text -- Fragment of source file++-- | Get the raw text of a source excerpt.++getExcerptText :: SourceExcerpt -> Text+getExcerptText (SourceExcerpt _ txt) = txt++-- | 'excerpt_ p' applies the given parser 'p' and extracts the portion of+-- the source consumed by 'p', along with the source position of this+-- portion. This is the only way to create a source excerpt suitable for+-- "re-parsing" by 'reparseExcerpt'.++-- This function could be extended to return the result of 'p', but we don't+-- currently need this.++excerpt_ :: MonadParsec HledgerParseErrorData Text m => m a -> m SourceExcerpt+excerpt_ p = do+  offset <- getOffset+  (!txt, _) <- match p+  pure $ SourceExcerpt offset txt++-- | 'reparseExcerpt s p' "re-parses" the source excerpt 's' using the+-- parser 'p'. Parse errors raised by 'p' will be re-thrown at the source+-- position of the source excerpt.+--+-- In order for the correct source file to be displayed when re-throwing+-- parse errors, we must ensure that the source file during the use of+-- 'reparseExcerpt s p' is the same as that during the use of 'excerpt_'+-- that generated the source excerpt 's'. However, we can usually expect+-- this condition to be satisfied because, at the time of writing, the+-- only changes of source file in the codebase take place through include+-- files, and the parser for include files neither accepts nor returns+-- 'SourceExcerpt's.++reparseExcerpt+  :: Monad m+  => SourceExcerpt+  -> ParsecT HledgerParseErrorData Text m a+  -> ParsecT HledgerParseErrorData Text m a+reparseExcerpt (SourceExcerpt offset txt) p = do+  (_, res) <- lift $ runParserT' p (offsetInitialState offset txt)+  case res of+    Right result -> pure result+    Left errBundle -> customFailure $ ErrorReparsing $ bundleErrors errBundle++  where+    offsetInitialState :: Int -> s ->+#if MIN_VERSION_megaparsec(8,0,0)+      State s e+#else+      State s+#endif+    offsetInitialState initialOffset s = State+      { stateInput  = s+      , stateOffset = initialOffset+      , statePosState = PosState+        { pstateInput = s+        , pstateOffset = initialOffset+        , pstateSourcePos = initialPos ""+        , pstateTabWidth = defaultTabWidth+        , pstateLinePrefix = ""+        }+#if MIN_VERSION_megaparsec(8,0,0)+      , stateParseErrors = []+#endif+      }++--- * Pretty-printing custom parse errors++-- | Pretty-print our custom parse errors. It is necessary to use this+-- instead of 'errorBundlePretty' when custom parse errors are thrown.+--+-- This function intercepts our custom parse errors and applies final+-- adjustments ('finalizeCustomError') before passing them to+-- 'errorBundlePretty'. These adjustments are part of the implementation+-- of the behaviour of our custom parse errors.+--+-- Note: We must ensure that the offset of the 'PosState' of the provided+-- 'ParseErrorBundle' is no larger than the offset specified by a+-- 'ErrorFailAt' constructor. This is guaranteed if this offset is set to+-- 0 (that is, the beginning of the source file), which is the+-- case for 'ParseErrorBundle's returned from 'runParserT'.++customErrorBundlePretty :: HledgerParseErrors -> String+customErrorBundlePretty errBundle =+  let errBundle' = errBundle { bundleErrors =+        NE.sortWith errorOffset $ -- megaparsec requires that the list of errors be sorted by their offsets+        bundleErrors errBundle >>= finalizeCustomError }+  in  errorBundlePretty errBundle'++  where+    finalizeCustomError+      :: ParseError Text HledgerParseErrorData -> NE.NonEmpty (ParseError Text HledgerParseErrorData)+    finalizeCustomError err = case findCustomError err of+      Nothing -> pure err++      Just errFailAt@(ErrorFailAt startOffset _ _) ->+        -- Adjust the offset+        pure $ FancyError startOffset $ S.singleton $ ErrorCustom errFailAt++      Just (ErrorReparsing errs) ->+        -- Extract and finalize the inner errors+        errs >>= finalizeCustomError++    -- If any custom errors are present, arbitrarily take the first one+    -- (since only one custom error should be used at a time).+    findCustomError :: ParseError Text HledgerParseErrorData -> Maybe HledgerParseErrorData+    findCustomError err = case err of+      FancyError _ errSet ->+        finds (\case {ErrorCustom e -> Just e; _ -> Nothing}) errSet+      _ -> Nothing++    finds :: (Foldable t) => (a -> Maybe b) -> t a -> Maybe b+    finds f = getAlt . foldMap (Alt . f)+++--- * "Final" parse errors+--+-- | A type representing "final" parse errors that cannot be backtracked+-- from and are guaranteed to halt parsing. The anti-backtracking+-- behaviour is implemented by an 'ExceptT' layer in the parser's monad+-- stack, using this type as the 'ExceptT' error type.+--+-- We have three goals for this type:+-- (1) it should be possible to convert any parse error into a "final"+-- parse error,+-- (2) it should be possible to take a parse error thrown from an include+-- file and re-throw it in the parent file, and+-- (3) the pretty-printing of "final" parse errors should be consistent+-- with that of ordinary parse errors, but should also report a stack of+-- files for errors thrown from include files.+--+-- In order to pretty-print a "final" parse error (goal 3), it must be+-- bundled with include filepaths and its full source text. When a "final"+-- parse error is thrown from within a parser, we do not have access to+-- the full source, so we must hold the parse error until it can be joined+-- with its source (and include filepaths, if it was thrown from an+-- include file) by the parser's caller.+--+-- A parse error with include filepaths and its full source text is+-- represented by the 'FinalParseErrorBundle' type, while a parse error in+-- need of either include filepaths, full source text, or both is+-- represented by the 'FinalParseError' type.++data FinalParseError' e+  -- a parse error thrown as a "final" parse error+  = FinalError           (ParseError Text e)+  -- a parse error obtained from running a parser, e.g. using 'runParserT'+  | FinalBundle          (ParseErrorBundle Text e)+  -- a parse error thrown from an include file+  | FinalBundleWithStack (FinalParseErrorBundle' e)+  deriving (Show)++type FinalParseError = FinalParseError' HledgerParseErrorData++-- We need a 'Monoid' instance for 'FinalParseError' so that 'ExceptT+-- FinalParseError m' is an instance of Alternative and MonadPlus, which+-- is needed to use some parser combinators, e.g. 'many'.+--+-- This monoid instance simply takes the first (left-most) error.++instance Semigroup (FinalParseError' e) where+  e <> _ = e++instance Monoid (FinalParseError' e) where+  mempty = FinalError $ FancyError 0 $+            S.singleton (ErrorFail "default parse error")+  mappend = (<>)++-- | A type bundling a 'ParseError' with its full source text, filepath,+-- and stack of include files. Suitable for pretty-printing.+--+-- Megaparsec's 'ParseErrorBundle' type already bundles a parse error with+-- its full source text and filepath, so we just add a stack of include+-- files.++data FinalParseErrorBundle' e = FinalParseErrorBundle'+  { finalErrorBundle :: ParseErrorBundle Text e+  , includeFileStack :: [FilePath]+  } deriving (Show)++type FinalParseErrorBundle = FinalParseErrorBundle' HledgerParseErrorData+++--- * Constructing and throwing final parse errors++-- | Convert a "regular" parse error into a "final" parse error.++finalError :: ParseError Text e -> FinalParseError' e+finalError = FinalError++-- | Like megaparsec's 'fancyFailure', but as a "final" parse error.++finalFancyFailure+  :: (MonadParsec e s m, MonadError (FinalParseError' e) m)+  => S.Set (ErrorFancy e) -> m a+finalFancyFailure errSet = do+  offset <- getOffset+  throwError $ FinalError $ FancyError offset errSet++-- | Like 'fail', but as a "final" parse error.++finalFail+  :: (MonadParsec e s m, MonadError (FinalParseError' e) m) => String -> m a+finalFail = finalFancyFailure . S.singleton . ErrorFail++-- | Like megaparsec's 'customFailure', but as a "final" parse error.++finalCustomFailure+  :: (MonadParsec e s m, MonadError (FinalParseError' e) m) => e -> m a+finalCustomFailure = finalFancyFailure . S.singleton . ErrorCustom+++--- * Pretty-printing "final" parse errors++-- | Pretty-print a "final" parse error: print the stack of include files,+-- then apply the pretty-printer for parse error bundles. Note that+-- 'attachSource' must be used on a "final" parse error before it can be+-- pretty-printed.++finalErrorBundlePretty :: FinalParseErrorBundle' HledgerParseErrorData -> String+finalErrorBundlePretty bundle =+     concatMap showIncludeFilepath (includeFileStack bundle)+  <> customErrorBundlePretty (finalErrorBundle bundle)+  where+    showIncludeFilepath path = "in file included from " <> path <> ",\n"++-- | Supply a filepath and source text to a "final" parse error so that it+-- can be pretty-printed. You must ensure that you provide the appropriate+-- source text and filepath.++attachSource+  :: FilePath -> Text -> FinalParseError' e -> FinalParseErrorBundle' e+attachSource filePath sourceText finalParseError = case finalParseError of++  -- A parse error thrown directly with the 'FinalError' constructor+  -- requires both source and filepath.+  FinalError err ->+    let bundle = ParseErrorBundle+          { bundleErrors = err NE.:| []+          , bundlePosState = initialPosState filePath sourceText }+    in  FinalParseErrorBundle'+          { finalErrorBundle = bundle+          , includeFileStack  = [] }++  -- A 'ParseErrorBundle' already has the appropriate source and filepath+  -- and so needs neither.+  FinalBundle peBundle -> FinalParseErrorBundle'+    { finalErrorBundle = peBundle+    , includeFileStack = [] }++  -- A parse error from a 'FinalParseErrorBundle' was thrown from an+  -- include file, so we add the filepath to the stack.+  FinalBundleWithStack fpeBundle -> fpeBundle+    { includeFileStack = filePath : includeFileStack fpeBundle }+++--- * Handling parse errors from include files with "final" parse errors++-- | Parse a file with the given parser and initial state, discarding the+-- final state and re-throwing any parse errors as "final" parse errors.++parseIncludeFile+  :: Monad m+  => StateT st (ParsecT HledgerParseErrorData Text (ExceptT FinalParseError m)) a+  -> st+  -> FilePath+  -> Text+  -> StateT st (ParsecT HledgerParseErrorData Text (ExceptT FinalParseError m)) a+parseIncludeFile parser initialState filepath text =+  catchError parser' handler+  where+    parser' = do+      eResult <- lift $ lift $+                  runParserT (evalStateT parser initialState) filepath text+      case eResult of+        Left parseErrorBundle -> throwError $ FinalBundle parseErrorBundle+        Right result -> pure result++    -- Attach source and filepath of the include file to its parse errors+    handler e = throwError $ FinalBundleWithStack $ attachSource filepath text e+++--- * Helpers++-- Like megaparsec's 'initialState', but instead for 'PosState'. Used when+-- constructing 'ParseErrorBundle's. The values for "tab width" and "line+-- prefix" are taken from 'initialState'.++initialPosState :: FilePath -> Text -> PosState Text+initialPosState filePath sourceText = PosState+  { pstateInput      = sourceText+  , pstateOffset     = 0+  , pstateSourcePos  = initialPos filePath+  , pstateTabWidth   = defaultTabWidth+  , pstateLinePrefix = "" }

@@ -136,7 +136,7 @@ -- | Make a nice error message for a regexp error. mkRegexErr :: Text -> Maybe a -> Either RegexError a mkRegexErr s = maybe (Left errmsg) Right-  where errmsg = T.unpack $ "This regular expression is malformed, please correct it:\n" <> s+  where errmsg = T.unpack $ "This regular expression is invalid or unsupported, please correct it:\n" <> s  -- Convert a Regexp string to a compiled Regex, throw an error toRegex' :: Text -> Regexp

@@ -190,7 +190,7 @@ -- NB correctly handles "a'b" but not "''a''". Can raise an error if parsing fails. words' :: String -> [String] words' "" = []-words' s  = map stripquotes $ fromparse $ parsewithString p s+words' s  = map stripquotes $ fromparse $ parsewithString p s  -- PARTIAL     where       p = (singleQuotedPattern <|> doubleQuotedPattern <|> patterns) `sepBy` skipNonNewlineSpaces1           -- eof

@@ -31,15 +31,15 @@ -- import Test.Tasty.QuickCheck as QC -- import Test.Tasty.SmallCheck as SC import Text.Megaparsec-import Text.Megaparsec.Custom++import Hledger.Utils.IO (pshow)+import Hledger.Utils.Parse   ( HledgerParseErrorData,     FinalParseError,     attachSource,     customErrorBundlePretty,     finalErrorBundlePretty,   )--import Hledger.Utils.IO (pshow)  -- * tasty helpers 

@@ -0,0 +1,56 @@+--- * -*- outline-regexp:"--- \\*"; -*-+--- ** doc+{-|++CSV utilities.++-}++--- ** language+{-# LANGUAGE OverloadedStrings    #-}++--- ** exports+module Hledger.Write.Csv (+  CSV, CsvRecord, CsvValue,+  printCSV,+  printTSV,+  -- * 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 :: CSV -> TL.Text+printCSV = TB.toLazyText . unlinesB . map printRecord+    where printRecord = foldMap TB.fromText . intersperse "," . map printField+          printField = wrap "\"" "\"" . T.replace "\"" "\"\""++printTSV :: CSV -> TL.Text+printTSV = TB.toLazyText . unlinesB . map printRecord+    where printRecord = foldMap TB.fromText . intersperse "\t" . map printField+          printField = T.map replaceWhitespace+          replaceWhitespace c | c `elem` ['\t', '\n', '\r'] = ' '+          replaceWhitespace c = c++--- ** tests++tests_CsvUtils :: TestTree+tests_CsvUtils = testGroup "CsvUtils" [+  ]

@@ -0,0 +1,39 @@+{-# LANGUAGE OverloadedStrings #-}+{- |+Export spreadsheet table data as HTML table.++This is derived from <https://hackage.haskell.org/package/classify-frog-0.2.4.3/src/src/Spreadsheet/Format.hs>+-}+module Hledger.Write.Html (+    printHtml,+    ) where++import Hledger.Write.Spreadsheet (Type(..), Style(..), Emphasis(..), Cell(..))++import qualified Lucid.Base as LucidBase+import qualified Lucid+import Data.Foldable (for_)+++printHtml :: [[Cell (Lucid.Html ())]] -> Lucid.Html ()+printHtml table =+    Lucid.table_ $ for_ table $ \row ->+    Lucid.tr_ $ for_ row $ \cell ->+    formatCell cell++formatCell :: Cell (Lucid.Html ()) -> Lucid.Html ()+formatCell cell =+    let str = cellContent cell in+    case cellStyle cell of+        Head -> Lucid.th_ str+        Body emph ->+            let align =+                    case cellType cell of+                        TypeString -> []+                        TypeDate -> []+                        _ -> [LucidBase.makeAttribute "align" "right"]+                withEmph =+                    case emph of+                        Item -> id+                        Total -> Lucid.b_+            in  Lucid.td_ align $ withEmph str

@@ -0,0 +1,259 @@+{- |+Export table data as OpenDocument Spreadsheet+<https://docs.oasis-open.org/office/OpenDocument/v1.3/>.+This format supports character encodings, fixed header rows and columns,+number formatting, text styles, merged cells, formulas, hyperlinks.+Currently we support Flat ODS, a plain uncompressed XML format.++This is derived from <https://hackage.haskell.org/package/classify-frog-0.2.4.3/src/src/Spreadsheet/Format.hs>++-}+module Hledger.Write.Ods (+    printFods,+    ) where++import Hledger.Write.Spreadsheet (Type(..), Style(..), Emphasis(..), Cell(..))+import Hledger.Data.Types (CommoditySymbol, AmountPrecision(..))+import Hledger.Data.Types (acommodity, aquantity, astyle, asprecision)++import qualified Data.Text.Lazy as TL+import qualified Data.Text as T+import Data.Text (Text)++import qualified Data.Map as Map+import qualified Data.Set as Set+import Data.Foldable (fold)+import Data.Map (Map)+import Data.Set (Set)+import Data.Maybe (mapMaybe)++import qualified System.IO as IO+import Text.Printf (printf)+++printFods ::+    IO.TextEncoding ->+    Map Text ((Maybe Int, Maybe Int), [[Cell Text]]) -> TL.Text+printFods encoding tables =+    let fileOpen customStyles =+          map (map (\c -> case c of '\'' -> '"'; _ -> c)) $+          printf "<?xml version='1.0' encoding='%s'?>" (show encoding) :+          "<office:document" :+          "  office:mimetype='application/vnd.oasis.opendocument.spreadsheet'" :+          "  office:version='1.3'" :+          "  xmlns:xsi='http://www.w3.org/2001/XMLSchema-instance'" :+          "  xmlns:xsd='http://www.w3.org/2001/XMLSchema'" :+          "  xmlns:text='urn:oasis:names:tc:opendocument:xmlns:text:1.0'" :+          "  xmlns:style='urn:oasis:names:tc:opendocument:xmlns:style:1.0'" :+          "  xmlns:meta='urn:oasis:names:tc:opendocument:xmlns:meta:1.0'" :+          "  xmlns:config='urn:oasis:names:tc:opendocument:xmlns:config:1.0'" :+          "  xmlns:xlink='http://www.w3.org/1999/xlink'" :+          "  xmlns:fo='urn:oasis:names:tc:opendocument:xmlns:xsl-fo-compatible:1.0'" :+          "  xmlns:ooo='http://openoffice.org/2004/office'" :+          "  xmlns:office='urn:oasis:names:tc:opendocument:xmlns:office:1.0'" :+          "  xmlns:table='urn:oasis:names:tc:opendocument:xmlns:table:1.0'" :+          "  xmlns:number='urn:oasis:names:tc:opendocument:xmlns:datastyle:1.0'" :+          "  xmlns:of='urn:oasis:names:tc:opendocument:xmlns:of:1.2'" :+          "  xmlns:field='urn:openoffice:names:experimental:ooo-ms-interop:xmlns:field:1.0'" :+          "  xmlns:form='urn:oasis:names:tc:opendocument:xmlns:form:1.0'>" :+          "<office:styles>" :+          "  <style:style style:name='head' style:family='table-cell'>" :+          "    <style:paragraph-properties fo:text-align='center'/>" :+          "    <style:text-properties fo:font-weight='bold'/>" :+          "  </style:style>" :+          "  <style:style style:name='foot' style:family='table-cell'>" :+          "    <style:text-properties fo:font-weight='bold'/>" :+          "  </style:style>" :+          "  <style:style style:name='amount' style:family='table-cell'>" :+          "    <style:paragraph-properties fo:text-align='end'/>" :+          "  </style:style>" :+          "  <style:style style:name='total-amount' style:family='table-cell'>" :+          "    <style:paragraph-properties fo:text-align='end'/>" :+          "    <style:text-properties fo:font-weight='bold'/>" :+          "  </style:style>" :+          "  <number:date-style style:name='iso-date'>" :+          "    <number:year number:style='long'/>" :+          "    <number:text>-</number:text>" :+          "    <number:month number:style='long'/>" :+          "    <number:text>-</number:text>" :+          "    <number:day number:style='long'/>" :+          "  </number:date-style>" :+          "  <style:style style:name='date' style:family='table-cell'" :+          "      style:data-style-name='iso-date'/>" :+          "  <style:style style:name='foot-date' style:family='table-cell'" :+          "      style:data-style-name='iso-date'>" :+          "    <style:text-properties fo:font-weight='bold'/>" :+          "  </style:style>" :+          customStyles +++          "</office:styles>" :+          []++        fileClose =+          "</office:document>" :+          []++        tableConfig tableNames =+          " <office:settings>" :+          "  <config:config-item-set config:name='ooo:view-settings'>" :+          "   <config:config-item-map-indexed config:name='Views'>" :+          "    <config:config-item-map-entry>" :+          "     <config:config-item-map-named config:name='Tables'>" :+          (fold $+           flip Map.mapWithKey tableNames $ \tableName (mTopRow,mLeftColumn) ->+             printf "      <config:config-item-map-entry config:name='%s'>" tableName :+             (flip foldMap mLeftColumn $ \leftColumn ->+                "       <config:config-item config:name='HorizontalSplitMode' config:type='short'>2</config:config-item>" :+                printf "       <config:config-item config:name='HorizontalSplitPosition' config:type='int'>%d</config:config-item>" leftColumn :+                printf "       <config:config-item config:name='PositionRight' config:type='int'>%d</config:config-item>" leftColumn :+                []) +++             (flip foldMap mTopRow $ \topRow ->+                "       <config:config-item config:name='VerticalSplitMode' config:type='short'>2</config:config-item>" :+                printf "       <config:config-item config:name='VerticalSplitPosition' config:type='int'>%d</config:config-item>" topRow :+                printf "       <config:config-item config:name='PositionBottom' config:type='int'>%d</config:config-item>" topRow :+                []) +++             "      </config:config-item-map-entry>" :+             []) +++          "     </config:config-item-map-named>" :+          "    </config:config-item-map-entry>" :+          "   </config:config-item-map-indexed>" :+          "  </config:config-item-set>" :+          " </office:settings>" :+          []++        tableOpen name =+          "<office:body>" :+          "<office:spreadsheet>" :+          printf "<table:table table:name='%s'>" name :+          []++        tableClose =+          "</table:table>" :+          "</office:spreadsheet>" :+          "</office:body>" :+          []++    in  TL.unlines $ map (TL.fromStrict . T.pack) $+        fileOpen+          (let styles = cellStyles (foldMap (concat.snd) tables) in+           (numberConfig =<< Set.toList (Set.map snd styles))+           +++           (cellConfig =<< Set.toList styles)) +++        tableConfig (fmap fst tables) +++        (Map.toAscList tables >>= \(name,(_,table)) ->+            tableOpen name +++            (table >>= \row ->+                "<table:table-row>" :+                (row >>= formatCell) +++                "</table:table-row>" :+                []) +++            tableClose) +++        fileClose+++cellStyles :: [Cell Text] -> Set (Emphasis, (CommoditySymbol, AmountPrecision))+cellStyles =+    Set.fromList .+    mapMaybe (\cell ->+        case cellType cell of+            TypeAmount amt ->+                Just+                    (case cellStyle cell of+                        Body emph -> emph+                        Head -> Total,+                     (acommodity amt, asprecision $ astyle amt))+            _ -> Nothing)++numberStyleName :: (CommoditySymbol, AmountPrecision) -> String+numberStyleName (comm, prec) =+    printf "%s-%s" comm $+    case prec of+        NaturalPrecision -> "natural"+        Precision k -> show k++numberConfig :: (CommoditySymbol, AmountPrecision) -> [String]+numberConfig (comm, prec) =+    let precStr =+            case prec of+                NaturalPrecision -> ""+                Precision k -> printf " number:decimal-places='%d'" k+        name = numberStyleName (comm, prec)+    in+    printf "  <number:number-style style:name='number-%s'>" name :+    printf "    <number:number number:min-integer-digits='1'%s/>" precStr :+    printf "    <number:text>%s%s</number:text>"+      (if T.null comm then "" else " ") comm :+    "  </number:number-style>" :+    []++emphasisName :: Emphasis -> String+emphasisName emph =+    case emph of+        Item -> "item"+        Total -> "total"++cellConfig :: (Emphasis, (CommoditySymbol, AmountPrecision)) -> [String]+cellConfig (emph, numParam) =+    let name = numberStyleName numParam in+    let style :: String+        style =+            printf "style:name='%s-%s' style:data-style-name='number-%s'"+                (emphasisName emph) name name in+    case emph of+        Item ->+            printf "  <style:style style:family='table-cell' %s/>" style :+            []+        Total ->+            printf "  <style:style style:family='table-cell' %s>" style :+            "    <style:text-properties fo:font-weight='bold'/>" :+            "  </style:style>" :+            []+++formatCell :: Cell Text -> [String]+formatCell cell =+    let style, valueType :: String+        style =+          case (cellStyle cell, cellType cell) of+            (Body emph, TypeAmount amt) -> tableStyle $ numberStyle emph amt+            (Body Item, TypeString) -> ""+            (Body Item, TypeMixedAmount) -> tableStyle "amount"+            (Body Item, TypeDate) -> tableStyle "date"+            (Body Total, TypeString) -> tableStyle "foot"+            (Body Total, TypeMixedAmount) -> tableStyle "total-amount"+            (Body Total, TypeDate) -> tableStyle "foot-date"+            (Head, _) -> tableStyle "head"+        numberStyle emph amt =+            printf "%s-%s"+                (emphasisName emph)+                (numberStyleName (acommodity amt, asprecision $ astyle amt))+        tableStyle = printf " table:style-name='%s'"++        valueType =+            case cellType cell of+                TypeAmount amt ->+                    printf+                        "office:value-type='float' office:value='%s'"+                        (show $ aquantity amt)+                TypeDate ->+                    printf+                        "office:value-type='date' office:date-value='%s'"+                        (cellContent cell)+                _ -> "office:value-type='string'"++    in+    printf "<table:table-cell%s %s>" style valueType :+    printf "<text:p>%s</text:p>" (escape $ T.unpack $ cellContent cell) :+    "</table:table-cell>" :+    []++escape :: String -> String+escape =+    concatMap $ \c ->+        case c of+            '\n' -> "&#10;"+            '&' -> "&amp;"+            '<' -> "&lt;"+            '>' -> "&gt;"+            '"' -> "&quot;"+            '\'' -> "&apos;"+            _ -> [c]

@@ -0,0 +1,49 @@+{- |+Rich data type to describe data in a table.+This is the basis for ODS and HTML export.+-}+module Hledger.Write.Spreadsheet (+    Type(..),+    Style(..),+    Emphasis(..),+    Cell(..),+    defaultCell,+    emptyCell,+    ) where++import Hledger.Data.Types (Amount)+++data Type =+      TypeString+    | TypeAmount !Amount+    | TypeMixedAmount+    | TypeDate+    deriving (Eq, Ord, Show)++data Style = Body Emphasis | Head+    deriving (Eq, Ord, Show)++data Emphasis = Item | Total+    deriving (Eq, Ord, Show)++data Cell text =+    Cell {+        cellType :: Type,+        cellStyle :: Style,+        cellContent :: text+    }++instance Functor Cell where+    fmap f (Cell typ style content) = Cell typ style $ f content++defaultCell :: text -> Cell text+defaultCell text =+    Cell {+        cellType = TypeString,+        cellStyle = Body Item,+        cellContent = text+    }++emptyCell :: (Monoid text) => Cell text+emptyCell = defaultCell mempty

@@ -1,437 +0,0 @@--- A bunch of megaparsec helpers for re-parsing etc.--- I think these are generic apart from the HledgerParseError name.--{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-} -- new-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-} -- new--module Text.Megaparsec.Custom (-  -- * Custom parse error types-  HledgerParseErrorData,-  HledgerParseErrors,--  -- * Failing with an arbitrary source position-  parseErrorAt,-  parseErrorAtRegion,--  -- * Re-parsing-  SourceExcerpt,-  getExcerptText,--  excerpt_,-  reparseExcerpt,--  -- * Pretty-printing custom parse errors-  customErrorBundlePretty,---  -- * "Final" parse errors-  FinalParseError,-  FinalParseError',-  FinalParseErrorBundle,-  FinalParseErrorBundle',--  -- * Constructing "final" parse errors-  finalError,-  finalFancyFailure,-  finalFail,-  finalCustomFailure,--  -- * Pretty-printing "final" parse errors-  finalErrorBundlePretty,-  attachSource,--  -- * Handling parse errors from include files with "final" parse errors-  parseIncludeFile,-)-where--import Control.Monad.Except (ExceptT, MonadError, catchError, throwError)-import Control.Monad.State.Strict (StateT, evalStateT)-import Control.Monad.Trans.Class (lift)-import qualified Data.List.NonEmpty as NE-import Data.Monoid (Alt(..))-import qualified Data.Set as S-import Data.Text (Text)-import Text.Megaparsec------ * Custom parse error types---- | Custom error data for hledger parsers. Specialised for a 'Text' parse stream.--- ReparseableTextParseErrorData ?-data HledgerParseErrorData-  -- | Fail with a message at a specific source position interval. The-  -- interval must be contained within a single line.-  = ErrorFailAt Int -- Starting offset-                Int -- Ending offset-                String -- Error message-  -- | Re-throw parse errors obtained from the "re-parsing" of an excerpt-  -- of the source text.-  | ErrorReparsing-      (NE.NonEmpty (ParseError Text HledgerParseErrorData)) -- Source fragment parse errors-  deriving (Show, Eq, Ord)---- | A specialised version of ParseErrorBundle: --- a non-empty collection of hledger parse errors, --- equipped with PosState to help pretty-print them.--- Specialised for a 'Text' parse stream.-type HledgerParseErrors = ParseErrorBundle Text HledgerParseErrorData---- We require an 'Ord' instance for 'CustomError' so that they may be--- stored in a 'Set'. The actual instance is inconsequential, so we just--- derive it, but the derived instance requires an (orphan) instance for--- 'ParseError'. Hopefully this does not cause any trouble.--deriving instance Ord (ParseError Text HledgerParseErrorData)---- Note: the pretty-printing of our 'HledgerParseErrorData' type is only partally--- defined in its 'ShowErrorComponent' instance; we perform additional--- adjustments in 'customErrorBundlePretty'.--instance ShowErrorComponent HledgerParseErrorData where-  showErrorComponent (ErrorFailAt _ _ errMsg) = errMsg-  showErrorComponent (ErrorReparsing _) = "" -- dummy value--  errorComponentLen (ErrorFailAt startOffset endOffset _) =-    endOffset - startOffset-  errorComponentLen (ErrorReparsing _) = 1 -- dummy value------ * Failing with an arbitrary source position---- | Fail at a specific source position, given by the raw offset from the--- start of the input stream (the number of tokens processed at that--- point).--parseErrorAt :: Int -> String -> HledgerParseErrorData-parseErrorAt offset = ErrorFailAt offset (offset+1)---- | Fail at a specific source interval, given by the raw offsets of its--- endpoints from the start of the input stream (the numbers of tokens--- processed at those points).------ Note that care must be taken to ensure that the specified interval does--- not span multiple lines of the input source. This will not be checked.--parseErrorAtRegion-  :: Int    -- ^ Start offset-  -> Int    -- ^ End end offset-  -> String -- ^ Error message-  -> HledgerParseErrorData-parseErrorAtRegion startOffset endOffset msg =-  if startOffset < endOffset-    then ErrorFailAt startOffset endOffset msg'-    else ErrorFailAt startOffset (startOffset+1) msg'-  where-    msg' = "\n" ++ msg------ * Re-parsing---- | A fragment of source suitable for "re-parsing". The purpose of this--- data type is to preserve the content and source position of the excerpt--- so that parse errors raised during "re-parsing" may properly reference--- the original source.--data SourceExcerpt = SourceExcerpt Int  -- Offset of beginning of excerpt-                                   Text -- Fragment of source file---- | Get the raw text of a source excerpt.--getExcerptText :: SourceExcerpt -> Text-getExcerptText (SourceExcerpt _ txt) = txt---- | 'excerpt_ p' applies the given parser 'p' and extracts the portion of--- the source consumed by 'p', along with the source position of this--- portion. This is the only way to create a source excerpt suitable for--- "re-parsing" by 'reparseExcerpt'.---- This function could be extended to return the result of 'p', but we don't--- currently need this.--excerpt_ :: MonadParsec HledgerParseErrorData Text m => m a -> m SourceExcerpt-excerpt_ p = do-  offset <- getOffset-  (!txt, _) <- match p-  pure $ SourceExcerpt offset txt---- | 'reparseExcerpt s p' "re-parses" the source excerpt 's' using the--- parser 'p'. Parse errors raised by 'p' will be re-thrown at the source--- position of the source excerpt.------ In order for the correct source file to be displayed when re-throwing--- parse errors, we must ensure that the source file during the use of--- 'reparseExcerpt s p' is the same as that during the use of 'excerpt_'--- that generated the source excerpt 's'. However, we can usually expect--- this condition to be satisfied because, at the time of writing, the--- only changes of source file in the codebase take place through include--- files, and the parser for include files neither accepts nor returns--- 'SourceExcerpt's.--reparseExcerpt-  :: Monad m-  => SourceExcerpt-  -> ParsecT HledgerParseErrorData Text m a-  -> ParsecT HledgerParseErrorData Text m a-reparseExcerpt (SourceExcerpt offset txt) p = do-  (_, res) <- lift $ runParserT' p (offsetInitialState offset txt)-  case res of-    Right result -> pure result-    Left errBundle -> customFailure $ ErrorReparsing $ bundleErrors errBundle--  where-    offsetInitialState :: Int -> s ->-#if MIN_VERSION_megaparsec(8,0,0)-      State s e-#else-      State s-#endif-    offsetInitialState initialOffset s = State-      { stateInput  = s-      , stateOffset = initialOffset-      , statePosState = PosState-        { pstateInput = s-        , pstateOffset = initialOffset-        , pstateSourcePos = initialPos ""-        , pstateTabWidth = defaultTabWidth-        , pstateLinePrefix = ""-        }-#if MIN_VERSION_megaparsec(8,0,0)-      , stateParseErrors = []-#endif-      }----- * Pretty-printing custom parse errors---- | Pretty-print our custom parse errors. It is necessary to use this--- instead of 'errorBundlePretty' when custom parse errors are thrown.------ This function intercepts our custom parse errors and applies final--- adjustments ('finalizeCustomError') before passing them to--- 'errorBundlePretty'. These adjustments are part of the implementation--- of the behaviour of our custom parse errors.------ Note: We must ensure that the offset of the 'PosState' of the provided--- 'ParseErrorBundle' is no larger than the offset specified by a--- 'ErrorFailAt' constructor. This is guaranteed if this offset is set to--- 0 (that is, the beginning of the source file), which is the--- case for 'ParseErrorBundle's returned from 'runParserT'.--customErrorBundlePretty :: HledgerParseErrors -> String-customErrorBundlePretty errBundle =-  let errBundle' = errBundle { bundleErrors =-        NE.sortWith errorOffset $ -- megaparsec requires that the list of errors be sorted by their offsets-        bundleErrors errBundle >>= finalizeCustomError }-  in  errorBundlePretty errBundle'--  where-    finalizeCustomError-      :: ParseError Text HledgerParseErrorData -> NE.NonEmpty (ParseError Text HledgerParseErrorData)-    finalizeCustomError err = case findCustomError err of-      Nothing -> pure err--      Just errFailAt@(ErrorFailAt startOffset _ _) ->-        -- Adjust the offset-        pure $ FancyError startOffset $ S.singleton $ ErrorCustom errFailAt--      Just (ErrorReparsing errs) ->-        -- Extract and finalize the inner errors-        errs >>= finalizeCustomError--    -- If any custom errors are present, arbitrarily take the first one-    -- (since only one custom error should be used at a time).-    findCustomError :: ParseError Text HledgerParseErrorData -> Maybe HledgerParseErrorData-    findCustomError err = case err of-      FancyError _ errSet ->-        finds (\case {ErrorCustom e -> Just e; _ -> Nothing}) errSet-      _ -> Nothing--    finds :: (Foldable t) => (a -> Maybe b) -> t a -> Maybe b-    finds f = getAlt . foldMap (Alt . f)------ * "Final" parse errors------ | A type representing "final" parse errors that cannot be backtracked--- from and are guaranteed to halt parsing. The anti-backtracking--- behaviour is implemented by an 'ExceptT' layer in the parser's monad--- stack, using this type as the 'ExceptT' error type.------ We have three goals for this type:--- (1) it should be possible to convert any parse error into a "final"--- parse error,--- (2) it should be possible to take a parse error thrown from an include--- file and re-throw it in the parent file, and--- (3) the pretty-printing of "final" parse errors should be consistent--- with that of ordinary parse errors, but should also report a stack of--- files for errors thrown from include files.------ In order to pretty-print a "final" parse error (goal 3), it must be--- bundled with include filepaths and its full source text. When a "final"--- parse error is thrown from within a parser, we do not have access to--- the full source, so we must hold the parse error until it can be joined--- with its source (and include filepaths, if it was thrown from an--- include file) by the parser's caller.------ A parse error with include filepaths and its full source text is--- represented by the 'FinalParseErrorBundle' type, while a parse error in--- need of either include filepaths, full source text, or both is--- represented by the 'FinalParseError' type.--data FinalParseError' e-  -- a parse error thrown as a "final" parse error-  = FinalError           (ParseError Text e)-  -- a parse error obtained from running a parser, e.g. using 'runParserT'-  | FinalBundle          (ParseErrorBundle Text e)-  -- a parse error thrown from an include file-  | FinalBundleWithStack (FinalParseErrorBundle' e)-  deriving (Show)--type FinalParseError = FinalParseError' HledgerParseErrorData---- We need a 'Monoid' instance for 'FinalParseError' so that 'ExceptT--- FinalParseError m' is an instance of Alternative and MonadPlus, which--- is needed to use some parser combinators, e.g. 'many'.------ This monoid instance simply takes the first (left-most) error.--instance Semigroup (FinalParseError' e) where-  e <> _ = e--instance Monoid (FinalParseError' e) where-  mempty = FinalError $ FancyError 0 $-            S.singleton (ErrorFail "default parse error")-  mappend = (<>)---- | A type bundling a 'ParseError' with its full source text, filepath,--- and stack of include files. Suitable for pretty-printing.------ Megaparsec's 'ParseErrorBundle' type already bundles a parse error with--- its full source text and filepath, so we just add a stack of include--- files.--data FinalParseErrorBundle' e = FinalParseErrorBundle'-  { finalErrorBundle :: ParseErrorBundle Text e-  , includeFileStack :: [FilePath]-  } deriving (Show)--type FinalParseErrorBundle = FinalParseErrorBundle' HledgerParseErrorData------ * Constructing and throwing final parse errors---- | Convert a "regular" parse error into a "final" parse error.--finalError :: ParseError Text e -> FinalParseError' e-finalError = FinalError---- | Like megaparsec's 'fancyFailure', but as a "final" parse error.--finalFancyFailure-  :: (MonadParsec e s m, MonadError (FinalParseError' e) m)-  => S.Set (ErrorFancy e) -> m a-finalFancyFailure errSet = do-  offset <- getOffset-  throwError $ FinalError $ FancyError offset errSet---- | Like 'fail', but as a "final" parse error.--finalFail-  :: (MonadParsec e s m, MonadError (FinalParseError' e) m) => String -> m a-finalFail = finalFancyFailure . S.singleton . ErrorFail---- | Like megaparsec's 'customFailure', but as a "final" parse error.--finalCustomFailure-  :: (MonadParsec e s m, MonadError (FinalParseError' e) m) => e -> m a-finalCustomFailure = finalFancyFailure . S.singleton . ErrorCustom------ * Pretty-printing "final" parse errors---- | Pretty-print a "final" parse error: print the stack of include files,--- then apply the pretty-printer for parse error bundles. Note that--- 'attachSource' must be used on a "final" parse error before it can be--- pretty-printed.--finalErrorBundlePretty :: FinalParseErrorBundle' HledgerParseErrorData -> String-finalErrorBundlePretty bundle =-     concatMap showIncludeFilepath (includeFileStack bundle)-  <> customErrorBundlePretty (finalErrorBundle bundle)-  where-    showIncludeFilepath path = "in file included from " <> path <> ",\n"---- | Supply a filepath and source text to a "final" parse error so that it--- can be pretty-printed. You must ensure that you provide the appropriate--- source text and filepath.--attachSource-  :: FilePath -> Text -> FinalParseError' e -> FinalParseErrorBundle' e-attachSource filePath sourceText finalParseError = case finalParseError of--  -- A parse error thrown directly with the 'FinalError' constructor-  -- requires both source and filepath.-  FinalError err ->-    let bundle = ParseErrorBundle-          { bundleErrors = err NE.:| []-          , bundlePosState = initialPosState filePath sourceText }-    in  FinalParseErrorBundle'-          { finalErrorBundle = bundle-          , includeFileStack  = [] }--  -- A 'ParseErrorBundle' already has the appropriate source and filepath-  -- and so needs neither.-  FinalBundle peBundle -> FinalParseErrorBundle'-    { finalErrorBundle = peBundle-    , includeFileStack = [] }--  -- A parse error from a 'FinalParseErrorBundle' was thrown from an-  -- include file, so we add the filepath to the stack.-  FinalBundleWithStack fpeBundle -> fpeBundle-    { includeFileStack = filePath : includeFileStack fpeBundle }------ * Handling parse errors from include files with "final" parse errors---- | Parse a file with the given parser and initial state, discarding the--- final state and re-throwing any parse errors as "final" parse errors.--parseIncludeFile-  :: Monad m-  => StateT st (ParsecT HledgerParseErrorData Text (ExceptT FinalParseError m)) a-  -> st-  -> FilePath-  -> Text-  -> StateT st (ParsecT HledgerParseErrorData Text (ExceptT FinalParseError m)) a-parseIncludeFile parser initialState filepath text =-  catchError parser' handler-  where-    parser' = do-      eResult <- lift $ lift $-                  runParserT (evalStateT parser initialState) filepath text-      case eResult of-        Left parseErrorBundle -> throwError $ FinalBundle parseErrorBundle-        Right result -> pure result--    -- Attach source and filepath of the include file to its parse errors-    handler e = throwError $ FinalBundleWithStack $ attachSource filepath text e------ * Helpers---- Like megaparsec's 'initialState', but instead for 'PosState'. Used when--- constructing 'ParseErrorBundle's. The values for "tab width" and "line--- prefix" are taken from 'initialState'.--initialPosState :: FilePath -> Text -> PosState Text-initialPosState filePath sourceText = PosState-  { pstateInput      = sourceText-  , pstateOffset     = 0-  , pstateSourcePos  = initialPos filePath-  , pstateTabWidth   = defaultTabWidth-  , pstateLinePrefix = "" }

@@ -145,9 +145,7 @@  -- | A version of renderRow which returns the underlying Builder. renderRowB:: TableOpts -> Header Cell -> Builder-renderRowB topts h = renderColumns topts is h-  where is = map cellWidth $ headerContents h-+renderRowB topts h = renderColumns topts ws h where ws = map cellWidth $ headerContents h  verticalBar :: Bool -> Char verticalBar pretty = if pretty then '│' else '|'

@@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.36.0.+-- This file has been generated from package.yaml by hpack version 0.37.0. -- -- see: https://github.com/sol/hpack  name:           hledger-lib-version:        1.34+version:        1.40 synopsis:       A library providing the core functionality of hledger description:    This library contains hledger's core functionality.                 It is used by most hledger* packages so that they support the same@@ -80,12 +80,15 @@       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.Write.Csv+      Hledger.Write.Ods+      Hledger.Write.Html+      Hledger.Write.Spreadsheet       Hledger.Reports       Hledger.Reports.ReportOptions       Hledger.Reports.ReportTypes@@ -105,7 +108,6 @@       Hledger.Utils.Text       Text.Tabular.AsciiWide   other-modules:-      Text.Megaparsec.Custom       Text.WideString       Paths_hledger_lib   hs-source-dirs:@@ -131,11 +133,12 @@     , data-default >=0.5     , deepseq     , directory-    , doclayout >=0.3 && <0.5+    , doclayout >=0.3 && <0.6     , extra >=1.6.3     , file-embed >=0.0.10     , filepath     , hashtables >=1.2.3.1+    , lucid     , megaparsec >=7.0.0 && <9.7     , microlens >=0.4     , microlens-th >=0.4@@ -193,12 +196,13 @@     , data-default >=0.5     , deepseq     , directory-    , doclayout >=0.3 && <0.5+    , doclayout >=0.3 && <0.6     , doctest >=0.18.1     , extra >=1.6.3     , file-embed >=0.0.10     , filepath     , hashtables >=1.2.3.1+    , lucid     , megaparsec >=7.0.0 && <9.7     , microlens >=0.4     , microlens-th >=0.4@@ -258,12 +262,13 @@     , data-default >=0.5     , deepseq     , directory-    , doclayout >=0.3 && <0.5+    , doclayout >=0.3 && <0.6     , extra >=1.6.3     , file-embed >=0.0.10     , filepath     , hashtables >=1.2.3.1     , hledger-lib+    , lucid     , megaparsec >=7.0.0 && <9.7     , microlens >=0.4     , microlens-th >=0.4