hledger-lib 1.28 → 1.29

raw patch · 31 files changed

+1007/−483 lines, 31 filesdep +colourdep +pagerdep +text-ansiPVP ok

version bump matches the API change (PVP)

Dependencies added: colour, pager, text-ansi

API changes (from Hackage documentation)

Files

• CHANGES.md +38/−1
• Hledger/Data/AccountName.hs +16/−0
• Hledger/Data/Balancing.hs +63/−57
• Hledger/Data/Dates.hs +126/−101
• Hledger/Data/Errors.hs +47/−1
• Hledger/Data/Journal.hs +41/−10
• Hledger/Data/JournalChecks.hs +55/−4
• Hledger/Data/Json.hs +2/−0
• Hledger/Data/Period.hs +20/−18
• Hledger/Data/PeriodicTransaction.hs +28/−44
• Hledger/Data/Posting.hs +13/−6
• Hledger/Data/RawOptions.hs +4/−0
• Hledger/Data/Transaction.hs +91/−68
• Hledger/Data/Types.hs +37/−5
• Hledger/Query.hs +17/−17
• Hledger/Read/Common.hs +133/−57
• Hledger/Read/CsvReader.hs +20/−14
• Hledger/Read/InputOptions.hs +6/−6
• Hledger/Read/JournalReader.hs +95/−30
• Hledger/Reports/AccountTransactionsReport.hs +12/−6
• Hledger/Reports/BalanceReport.hs +2/−2
• Hledger/Reports/BudgetReport.hs +2/−2
• Hledger/Reports/EntriesReport.hs +1/−1
• Hledger/Reports/MultiBalanceReport.hs +2/−2
• Hledger/Reports/PostingsReport.hs +4/−4
• Hledger/Reports/ReportOptions.hs +15/−10
• Hledger/Reports/ReportTypes.hs +1/−1
• Hledger/Utils/IO.hs +73/−8
• Hledger/Utils/Parse.hs +1/−0
• Hledger/Utils/Text.hs +25/−6
• hledger-lib.cabal +17/−2

@@ -9,7 +9,44 @@ Internal/api/developer-ish changes in the hledger-lib (and hledger) packages. For user-visible changes, see the hledger package changelog. -# 1.28 2022-11-30+# 1.29 2023-03-11++- added terminal colour detection helpers:+  terminalIsLight+  terminalLightness+  terminalFgColor+  terminalBgColor++- Hledger.Data.RawOptions: add unsetboolopt++- add journalMarkRedundantCosts to help with balancing++- journalInferCosts -> journalInferCostsFromEquity++- `BalancingOpts{infer_transaction_prices_ -> infer_balancing_costs_}`++- Hledger.Data.Balancing: inferBalancingPrices -> transactionInferBalancingCosts++- Hledger.Data.Balancing: inferBalancingAmount -> transactionInferBalancingAmount++- Hledger.Data.Journal: transactionAddPricesFromEquity -> transactionInferCostsFromEquity++- Hledger.Data.Journal: journalAddPricesFromEquity -> journalInferCosts++- Hledger.Data.Dates: intervalStartBefore -> intervalBoundaryBefore++- Hledger.Read.Common: cleaned up some amount parsers; describe Ledger lot notation+  ```+  amountpwithmultiplier -> amountp'+  amountpnolotpricesp   -> amountnobasisp+  amountwithoutpricep   -> simpleamountp+  priceamountp          -> costp+  ```++- depend on text-ansi+++# 1.28 2022-12-01  - Hledger.Utils.Debug's debug logging helpers have been unified.   The "trace or log" functions log to stderr by default, or to a file

@@ -376,5 +376,21 @@     accountNameInferType "revenues"          @?= Just Revenue     accountNameInferType "revenue"           @?= Just Revenue     accountNameInferType "income"            @?= Just Revenue+  ,testCase "joinAccountNames" $ do+    joinAccountNames "assets" "cash"     @?= "assets:cash"+    joinAccountNames "assets:cash" "a"   @?= "assets:cash:a"+    joinAccountNames "assets" "(cash)"   @?= "(assets:cash)"+    joinAccountNames "assets" "[cash]"   @?= "[assets:cash]"+    joinAccountNames "(assets)" "cash"   @?= "(assets:cash)"+    joinAccountNames "" "assets"         @?= "assets"+    joinAccountNames "assets" ""         @?= "assets"+  ,testCase "concatAccountNames" $ do+    concatAccountNames ["assets", "cash"]   @?= "assets:cash"+    concatAccountNames ["assets:cash", "a"] @?= "assets:cash:a"+    concatAccountNames ["assets", "(cash)"] @?= "(assets:cash)"+    concatAccountNames ["assets", "[cash]"] @?= "[assets:cash]"+    concatAccountNames ["(assets)", "cash"] @?= "(assets:cash)"+    concatAccountNames ["", "assets"]       @?= ":assets"+    concatAccountNames ["assets", ""]       @?= "assets:"  ] 

@@ -56,16 +56,17 @@   data BalancingOpts = BalancingOpts-  { ignore_assertions_        :: Bool  -- ^ Ignore balance assertions-  , infer_transaction_prices_ :: Bool  -- ^ Infer prices in unbalanced multicommodity amounts-  , commodity_styles_         :: Maybe (M.Map CommoditySymbol AmountStyle)  -- ^ commodity display styles+  { ignore_assertions_     :: Bool  -- ^ should failing balance assertions be ignored ?+  , infer_balancing_costs_ :: Bool  -- ^ Are we permitted to infer missing costs to balance transactions ?+                                    --   Distinct from InputOpts{infer_costs_}.+  , commodity_styles_      :: Maybe (M.Map CommoditySymbol AmountStyle)  -- ^ commodity display styles   } deriving (Show)  defbalancingopts :: BalancingOpts defbalancingopts = BalancingOpts-  { ignore_assertions_        = False-  , infer_transaction_prices_ = True-  , commodity_styles_         = Nothing+  { ignore_assertions_     = False+  , infer_balancing_costs_ = True+  , commodity_styles_      = Nothing   }  -- | Check that this transaction would appear balanced to a human when displayed.@@ -148,15 +149,17 @@ balanceTransaction bopts = fmap fst . balanceTransactionHelper bopts  -- | Helper used by balanceTransaction and balanceTransactionWithBalanceAssignmentAndCheckAssertionsB;--- use one of those instead. It also returns a list of accounts--- and amounts that were inferred.+-- use one of those instead.+-- It also returns a list of accounts and amounts that were inferred. balanceTransactionHelper ::      BalancingOpts   -> Transaction   -> Either String (Transaction, [(AccountName, MixedAmount)]) balanceTransactionHelper bopts t = do-  (t', inferredamtsandaccts) <- inferBalancingAmount (fromMaybe M.empty $ commodity_styles_ bopts) $-    if infer_transaction_prices_ bopts then inferBalancingPrices t else t+  (t', inferredamtsandaccts) <-+    transactionInferBalancingAmount (fromMaybe M.empty $ commodity_styles_ bopts) $+    (if infer_balancing_costs_ bopts then transactionInferBalancingCosts else id)+    t   case transactionCheckBalanced bopts t' of     []   -> Right (txnTieKnot t', inferredamtsandaccts)     errs -> Left $ transactionBalanceError t' errs'@@ -164,7 +167,7 @@         ismulticommodity = (length $ transactionCommodities t') > 1         errs' =           [ "Automatic commodity conversion is not enabled."-          | ismulticommodity && not (infer_transaction_prices_ bopts)+          | ismulticommodity && not (infer_balancing_costs_ bopts)           ] ++           errs ++           if ismulticommodity@@ -204,11 +207,11 @@ -- We can infer a missing amount when there are multiple postings and exactly -- one of them is amountless. If the amounts had price(s) the inferred amount -- have the same price(s), and will be converted to the price commodity.-inferBalancingAmount ::+transactionInferBalancingAmount ::      M.Map CommoditySymbol AmountStyle -- ^ commodity display styles   -> Transaction   -> Either String (Transaction, [(AccountName, MixedAmount)])-inferBalancingAmount styles t@Transaction{tpostings=ps}+transactionInferBalancingAmount styles t@Transaction{tpostings=ps}   | length amountlessrealps > 1       = Left $ transactionBalanceError t         ["There can't be more than one real posting with no amount."@@ -244,55 +247,55 @@               -- (since the main amount styling pass happened before this balancing pass);               a' = styleMixedAmount styles . mixedAmountCost $ maNegate a --- | Infer prices for this transaction's posting amounts, if needed to make--- the postings balance, and if possible. This is done once for the real+-- | Infer costs for this transaction's posting amounts, if needed to make+-- the postings balance, and if permitted. This is done once for the real -- postings and again (separately) for the balanced virtual postings. When -- it's not possible, the transaction is left unchanged. -- -- The simplest example is a transaction with two postings, each in a--- different commodity, with no prices specified. In this case we'll add a--- price to the first posting such that it can be converted to the commodity+-- different commodity, with no costs specified. In this case we'll add a+-- cost to the first posting such that it can be converted to the commodity -- of the second posting (with -B), and such that the postings balance. ----- In general, we can infer a conversion price when the sum of posting amounts--- contains exactly two different commodities and no explicit prices.  Also+-- In general, we can infer a cost (conversion rate) when the sum of posting amounts+-- contains exactly two different commodities and no explicit costs.  Also -- all postings are expected to contain an explicit amount (no missing--- amounts) in a single commodity. Otherwise no price inferring is attempted.+-- amounts) in a single commodity. Otherwise no cost inferring is attempted. -- -- The transaction itself could contain more than two commodities, and/or--- prices, if they cancel out; what matters is that the sum of posting amounts--- contains exactly two commodities and zero prices.+-- costs, if they cancel out; what matters is that the sum of posting amounts+-- contains exactly two commodities and zero costs. -- -- There can also be more than two postings in either of the commodities. ----- We want to avoid excessive display of digits when the calculated price is+-- We want to avoid excessive display of digits when the calculated cost is -- an irrational number, while hopefully also ensuring the displayed numbers -- make sense if the user does a manual calculation. This is (mostly) achieved -- in two ways: ----- - when there is only one posting in the "from" commodity, a total price+-- - when there is only one posting in the "from" commodity, a total cost --   (@@) is used, and all available decimal digits are shown ----- - otherwise, a suitable averaged unit price (@) is applied to the relevant+-- - otherwise, a suitable averaged unit cost (@) is applied to the relevant --   postings, with display precision equal to the summed display precisions --   of the two commodities being converted between, or 2, whichever is larger. ----- (We don't always calculate a good-looking display precision for unit prices+-- (We don't always calculate a good-looking display precision for unit costs -- when the commodity display precisions are low, eg when a journal doesn't--- use any decimal places. The minimum of 2 helps make the prices shown by the+-- use any decimal places. The minimum of 2 helps make the costs shown by the -- print command a bit less surprising in this case. Could do better.) ---inferBalancingPrices :: Transaction -> Transaction-inferBalancingPrices t@Transaction{tpostings=ps} = t{tpostings=ps'}+transactionInferBalancingCosts :: Transaction -> Transaction+transactionInferBalancingCosts t@Transaction{tpostings=ps} = t{tpostings=ps'}   where-    ps' = map (priceInferrerFor t BalancedVirtualPosting . priceInferrerFor t RegularPosting) ps+    ps' = map (costInferrerFor t BalancedVirtualPosting . costInferrerFor t RegularPosting) ps --- | Generate a posting update function which assigns a suitable balancing--- price to the posting, if and as appropriate for the given transaction and--- posting type (real or balanced virtual). If we cannot or should not infer--- prices, just act as the identity on postings.-priceInferrerFor :: Transaction -> PostingType -> (Posting -> Posting)-priceInferrerFor t pt = maybe id inferprice inferFromAndTo+-- | Generate a posting update function which assigns a suitable cost to+-- balance the posting, if and as appropriate for the given transaction and+-- posting type (real or balanced virtual) (or if we cannot or should not infer+-- costs, leaves the posting unchanged).+costInferrerFor :: Transaction -> PostingType -> (Posting -> Posting)+costInferrerFor t pt = maybe id infercost inferFromAndTo   where     postings     = filter ((==pt).ptype) $ tpostings t     pcommodities = map acommodity $ concatMap (amounts . pamount) postings@@ -314,8 +317,8 @@      -- For each posting, if the posting type matches, there is only a single amount in the posting,     -- and the commodity of the amount matches the amount we're converting from,-    -- then set its price based on the ratio between fromamount and toamount.-    inferprice (fromamount, toamount) p+    -- then set its cost based on the ratio between fromamount and toamount.+    infercost (fromamount, toamount) p         | [a] <- amounts (pamount p), ptype p == pt, acommodity a == acommodity fromamount             = p{ pamount   = mixedAmount a{aprice=Just conversionprice}                      , poriginal = Just $ originalPosting p }@@ -427,10 +430,11 @@ updateTransactionB t = withRunningBalance $ \BalancingState{bsTransactions}  ->   void $ writeArray bsTransactions (tindex t) t --- | Infer any missing amounts (to satisfy balance assignments and--- to balance transactions) and check that all transactions balance--- and (optional) all balance assertions pass. Or return an error message--- (just the first error encountered).+-- | Infer any missing amounts and/or conversion costs+-- (as needed to balance transactions and satisfy balance assignments);+-- and check that all transactions are balanced;+-- and (optional) check that all balance assertions pass.+-- Or, return an error message (just the first error encountered). -- -- Assumes journalInferCommodityStyles has been called, since those -- affect transaction balancing.@@ -448,18 +452,18 @@     -- balance assignments are not allowed on accounts affected by auto postings     autopostingaccts = S.fromList . map (paccount . tmprPosting) . concatMap tmpostingrules $ jtxnmodifiers j   in+    -- Store the transactions in a mutable array, which we'll update as we balance them.+    -- Not strictly necessary but avoids a sort at the end I think.     runST $ do-      -- We'll update a mutable array of transactions as we balance them,-      -- not strictly necessary but avoids a sort at the end I think.       balancedtxns <- newListArray (1, toInteger $ length ts) ts -      -- Infer missing posting amounts, check transactions are balanced,-      -- and check balance assertions. This is done in two passes:+      -- Process all transactions, or short-circuit with an error.       runExceptT $ do -        -- 1. Step through the transactions, balancing the ones which don't have balance assignments-        -- and leaving the others for later. The balanced ones are split into their postings.-        -- The postings and not-yet-balanced transactions remain in the same relative order.+        -- Two passes are required:+        -- 1. Step through the transactions, balancing the ones which don't have balance assignments,+        -- postponing those which do until later. The balanced ones are split into their postings,+        -- keeping these and the not-yet-balanced transactions in the same relative order.         psandts :: [Either Posting Transaction] <- fmap concat $ forM ts $ \case           t | null $ assignmentPostings t -> case balanceTransaction bopts t of               Left  e  -> throwError e@@ -468,14 +472,16 @@                 return $ map Left $ tpostings t'           t -> return [Right t] -        -- 2. Sort these items by date, preserving the order of same-day items,-        -- and step through them while keeping running account balances,+        -- 2. Step through these items in date order (and preserved same-day order),+        -- keeping running balances for all accounts.         runningbals <- lift $ H.newSized (length $ journalAccountNamesUsed j)         flip runReaderT (BalancingState styles autopostingaccts (not $ ignore_assertions_ bopts) runningbals balancedtxns) $ do-          -- performing balance assignments in, and balancing, the remaining transactions,-          -- and checking balance assertions as each posting is processed.+          -- On encountering any not-yet-balanced transaction with a balance assignment,+          -- enact the balance assignment then finish balancing the transaction.+          -- And, check any balance assertions encountered along the way.           void $ mapM' balanceTransactionAndCheckAssertionsB $ sortOn (either postingDate tdate) psandts +        -- Return the now fully-balanced and checked transactions.         ts' <- lift $ getElems balancedtxns         return j{jtxns=ts'} @@ -679,11 +685,11 @@ tests_Balancing =   testGroup "Balancing" [ -      testCase "inferBalancingAmount" $ do-         (fst <$> inferBalancingAmount M.empty nulltransaction) @?= Right nulltransaction-         (fst <$> inferBalancingAmount M.empty nulltransaction{tpostings = ["a" `post` usd (-5), "b" `post` missingamt]}) @?=+      testCase "transactionInferBalancingAmount" $ do+         (fst <$> transactionInferBalancingAmount M.empty nulltransaction) @?= Right nulltransaction+         (fst <$> transactionInferBalancingAmount M.empty nulltransaction{tpostings = ["a" `post` usd (-5), "b" `post` missingamt]}) @?=            Right nulltransaction{tpostings = ["a" `post` usd (-5), "b" `post` usd 5]}-         (fst <$> inferBalancingAmount M.empty nulltransaction{tpostings = ["a" `post` usd (-5), "b" `post` (eur 3 @@ usd 4), "c" `post` missingamt]}) @?=+         (fst <$> transactionInferBalancingAmount M.empty nulltransaction{tpostings = ["a" `post` usd (-5), "b" `post` (eur 3 @@ usd 4), "c" `post` missingamt]}) @?=            Right nulltransaction{tpostings = ["a" `post` usd (-5), "b" `post` (eur 3 @@ usd 4), "c" `post` usd 1]}      , testGroup "balanceTransaction" [

@@ -30,6 +30,8 @@  module Hledger.Data.Dates (   -- * Misc date handling utilities+  fromEFDay,+  modifyEFDay,   getCurrentDay,   getCurrentMonth,   getCurrentYear,@@ -38,7 +40,9 @@   periodContainsDate,   parsedateM,   showDate,+  showEFDate,   showDateSpan,+  showDateSpanDebug,   showDateSpanMonthAbbrev,   elapsedSeconds,   prevday,@@ -75,7 +79,7 @@   daysInSpan,    tests_Dates-, intervalStartBefore)+, intervalBoundaryBefore) where  import qualified Control.Monad.Fail as Fail (MonadFail, fail)@@ -118,11 +122,19 @@ showDate :: Day -> Text showDate = T.pack . show +showEFDate :: EFDay -> Text+showEFDate = showDate . fromEFDay+ -- | Render a datespan as a display string, abbreviating into a -- compact form if possible.+-- Warning, hides whether dates are Exact or Flex. showDateSpan :: DateSpan -> Text showDateSpan = showPeriod . dateSpanAsPeriod +-- | Show a DateSpan with its begin/end dates, exact or flex.+showDateSpanDebug :: DateSpan -> String+showDateSpanDebug (DateSpan b e)= "DateSpan (" <> show b <> ") (" <> show e <> ")"+ -- | Like showDateSpan, but show month spans as just the abbreviated month name -- in the current locale. showDateSpanMonthAbbrev :: DateSpan -> Text@@ -144,41 +156,50 @@ elapsedSeconds t1 = realToFrac . diffUTCTime t1  spanStart :: DateSpan -> Maybe Day-spanStart (DateSpan d _) = d+spanStart (DateSpan d _) = fromEFDay <$> d  spanEnd :: DateSpan -> Maybe Day-spanEnd (DateSpan _ d) = d+spanEnd (DateSpan _ d) = fromEFDay <$> d +spanStartDate :: DateSpan -> Maybe EFDay+spanStartDate (DateSpan d _) = d++spanEndDate :: DateSpan -> Maybe EFDay+spanEndDate (DateSpan _ d) = d+ spanStartYear :: DateSpan -> Maybe Year-spanStartYear (DateSpan d _) = fmap (first3 . toGregorian) d+spanStartYear (DateSpan d _) = fmap (first3 . toGregorian . fromEFDay) d  spanEndYear :: DateSpan -> Maybe Year-spanEndYear (DateSpan d _) = fmap (first3 . toGregorian) d+spanEndYear (DateSpan d _) = fmap (first3 . toGregorian. fromEFDay) d  -- | Get the 0-2 years mentioned explicitly in a DateSpan. spanYears :: DateSpan -> [Year]-spanYears (DateSpan ma mb) = mapMaybe (fmap (first3 . toGregorian)) [ma,mb]+spanYears (DateSpan ma mb) = mapMaybe (fmap (first3 . toGregorian. fromEFDay)) [ma,mb]  -- might be useful later: http://en.wikipedia.org/wiki/Allen%27s_interval_algebra  -- | Get overall span enclosing multiple sequentially ordered spans.+-- The start and end date will be exact or flexible depending on+-- the first span's start date and last span's end date. spansSpan :: [DateSpan] -> DateSpan-spansSpan spans = DateSpan (spanStart =<< headMay spans) (spanEnd =<< lastMay spans)+spansSpan spans = DateSpan (spanStartDate =<< headMay spans) (spanEndDate =<< lastMay spans) --- | Split a DateSpan into consecutive whole spans of the specified interval--- which fully encompass the original span (and a little more when necessary).+-- | 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:--- >>> let t i y1 m1 d1 y2 m2 d2 = splitSpan i $ DateSpan (Just $ fromGregorian y1 m1 d1) (Just $ fromGregorian y2 m2 d2)+-- >>> 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] -- >>> t (Quarters 1) 2008 01 01 2009 01 01 -- [DateSpan 2008Q1,DateSpan 2008Q2,DateSpan 2008Q3,DateSpan 2008Q4]--- >>> splitSpan (Quarters 1) nulldatespan+-- >>> splitSpan True (Quarters 1) nulldatespan -- [DateSpan ..] -- >>> t (Days 1) 2008 01 01 2008 01 01  -- an empty datespan -- []@@ -203,53 +224,53 @@ -- >>> t (DayOfYear 11 29) 2011 12 01 2012 12 15 -- [DateSpan 2011-11-29..2012-11-28,DateSpan 2012-11-29..2013-11-28] ---splitSpan :: 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 startofday     addDays n                    ds-splitSpan (Weeks n)       ds = splitspan startofweek    addDays (7*n)                ds-splitSpan (Months n)      ds = splitspan startofmonth   addGregorianMonthsClip n     ds-splitSpan (Quarters n)    ds = splitspan startofquarter addGregorianMonthsClip (3*n) ds-splitSpan (Years n)       ds = splitspan startofyear    addGregorianYearsClip n      ds-splitSpan (DayOfMonth n)  ds = splitspan (nthdayofmonthcontaining n)  addGregorianMonthsClip 1 ds-splitSpan (DayOfYear m n) ds = splitspan (nthdayofyearcontaining m n) addGregorianYearsClip 1 ds-splitSpan (WeekdayOfMonth n wd) ds = splitspan (nthweekdayofmonthcontaining n wd) advancemonths 1 ds+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 n)  ds = splitspan (nthdayofmonthcontaining n)  addGregorianMonthsClip 1 ds+splitSpan _ (DayOfYear m n) ds = splitspan (nthdayofyearcontaining m n) addGregorianYearsClip 1 ds+splitSpan _ (WeekdayOfMonth n wd) ds = splitspan (nthweekdayofmonthcontaining n wd) advancemonths 1 ds   where     advancemonths 0 = id     advancemonths w = advancetonthweekday n wd . startofmonth . addGregorianMonthsClip w-splitSpan (DaysOfWeek [])         ds = [ds]-splitSpan (DaysOfWeek days@(n:_)) ds = spansFromBoundaries e bdrys+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..]     -- The first representative of each weekday     starts = map (\d -> addDays (toInteger $ d - n) $ nthdayofweekcontaining n s) days --- Split the given span using the provided helper functions:--- start is applied to the span's start date to get the first sub-span's start date--- addInterval is applied to an integer n (multiplying it by mult) and the span's start date to get the nth sub-span's start date+-- Split the given span into exact spans using the provided helper functions:+-- the start function is applied to the span's start date to get the first sub-span's start date+-- the addInterval function is applied to an integer n (multiplying it by mult) and the span's start date to get the nth sub-span's start date splitspan :: (Day -> Day) -> (Integer -> Day -> Day) -> Int -> DateSpan -> [DateSpan] splitspan start addInterval mult ds = spansFromBoundaries e bdrys   where-    (s, e) = dateSpanSplitLimits start (addInterval $ toInteger mult) ds+    (s, e) = dateSpanSplitLimits start (addInterval (toInteger mult)) ds     bdrys = mapM (addInterval . toInteger) [0,mult..] $ start s --- | Fill in missing endpoints for calculating 'splitSpan'.+-- | Fill in missing start/end dates for calculating 'splitSpan'. dateSpanSplitLimits :: (Day -> Day) -> (Day -> Day) -> DateSpan -> (Day, Day)-dateSpanSplitLimits start _    (DateSpan (Just s) (Just e)) = (start s, e)-dateSpanSplitLimits start next (DateSpan (Just s) Nothing)  = (start s, next $ start s)-dateSpanSplitLimits start next (DateSpan Nothing  (Just e)) = (start e, next $ start e)-dateSpanSplitLimits _     _    (DateSpan Nothing   Nothing) = error "dateSpanSplitLimits: Should not be nulldatespan"  -- PARTIAL: This case should have been handled in splitSpan+dateSpanSplitLimits start _    (DateSpan (Just s) (Just e)) = (start $ fromEFDay s, fromEFDay e)+dateSpanSplitLimits start next (DateSpan (Just s) Nothing)  = (start $ fromEFDay s, next $ start $ fromEFDay s)+dateSpanSplitLimits start next (DateSpan Nothing  (Just e)) = (start $ fromEFDay e, next $ start $ fromEFDay e)+dateSpanSplitLimits _     _    (DateSpan Nothing   Nothing) = error "dateSpanSplitLimits: should not be nulldatespan"  -- PARTIAL: This case should have been handled in splitSpan --- | Construct a list of 'DateSpan's from a list of boundaries, which fit within a given range.+-- | Construct a list of exact 'DateSpan's from a list of boundaries, which fit within a given range. spansFromBoundaries :: Day -> [Day] -> [DateSpan]-spansFromBoundaries e bdrys = zipWith (DateSpan `on` Just) (takeWhile (< e) bdrys) $ drop 1 bdrys+spansFromBoundaries e bdrys = zipWith (DateSpan `on` (Just . Exact)) (takeWhile (< e) bdrys) $ drop 1 bdrys  -- | Count the days in a DateSpan, or if it is open-ended return Nothing. daysInSpan :: DateSpan -> Maybe Integer-daysInSpan (DateSpan (Just d1) (Just d2)) = Just $ diffDays d2 d1+daysInSpan (DateSpan (Just d1) (Just d2)) = Just $ diffDays (fromEFDay d2) (fromEFDay d1) daysInSpan _ = Nothing  -- | Is this an empty span, ie closed with the end date on or before the start date ?@@ -260,9 +281,9 @@ -- | Does the span include the given date ? spanContainsDate :: DateSpan -> Day -> Bool spanContainsDate (DateSpan Nothing Nothing)   _ = True-spanContainsDate (DateSpan Nothing (Just e))  d = d < e-spanContainsDate (DateSpan (Just b) Nothing)  d = d >= b-spanContainsDate (DateSpan (Just b) (Just e)) d = d >= b && d < e+spanContainsDate (DateSpan Nothing (Just e))  d = d < fromEFDay e+spanContainsDate (DateSpan (Just b) Nothing)  d = d >= fromEFDay b+spanContainsDate (DateSpan (Just b) (Just e)) d = d >= fromEFDay b && d < fromEFDay e  -- | Does the period include the given date ? -- (Here to avoid import cycle).@@ -293,7 +314,7 @@ -- | Calculate the intersection of two datespans. -- -- For non-intersecting spans, gives an empty span beginning on the second's start date:--- >>> DateSpan (Just $ fromGregorian 2018 01 01) (Just $ fromGregorian 2018 01 03) `spanIntersect` DateSpan (Just $ fromGregorian 2018 01 03) (Just $ fromGregorian 2018 01 05)+-- >>> DateSpan (Just $ Flex $ fromGregorian 2018 01 01) (Just $ Flex $ fromGregorian 2018 01 03) `spanIntersect` DateSpan (Just $ Flex $ fromGregorian 2018 01 03) (Just $ Flex $ fromGregorian 2018 01 05) -- DateSpan 2018-01-03..2018-01-02 spanIntersect (DateSpan b1 e1) (DateSpan b2 e2) = DateSpan b e     where@@ -329,7 +350,7 @@ -- usual exclusive-end-date sense: beginning on the earliest, and ending on -- the day after the latest). daysSpan :: [Day] -> DateSpan-daysSpan ds = DateSpan (minimumMay ds) (addDays 1 <$> maximumMay ds)+daysSpan ds = DateSpan (Exact <$> minimumMay ds) (Exact . addDays 1 <$> maximumMay ds)  -- | Select the DateSpan containing a given Day, if any, from a given list of -- DateSpans.@@ -351,7 +372,7 @@         return spn       where         -- The smallest DateSpan larger than any DateSpan containing day.-        supSpan = DateSpan (Just $ addDays 1 day) Nothing+        supSpan = DateSpan (Just $ Exact $ addDays 1 day) Nothing      spanSet = Set.fromList $ filter (not . isEmptySpan) datespans @@ -387,17 +408,17 @@       (ry,rm,_) = toGregorian refdate       (b,e) = span' sdate         where-          span' :: SmartDate -> (Day,Day)-          span' (SmartCompleteDate day)       = (day, nextday day)-          span' (SmartAssumeStart y Nothing)  = (startofyear day, nextyear day) where day = fromGregorian y 1 1-          span' (SmartAssumeStart y (Just m)) = (startofmonth day, nextmonth day) where day = fromGregorian y m 1-          span' (SmartFromReference m d)      = (day, nextday day) where day = fromGregorian ry (fromMaybe rm m) d-          span' (SmartMonth m)                = (startofmonth day, nextmonth day) where day = fromGregorian ry m 1-          span' (SmartRelative n Day)         = (addDays n refdate, addDays (n+1) refdate)-          span' (SmartRelative n Week)        = (addDays (7*n) d, addDays (7*n+7) d) where d = thisweek refdate-          span' (SmartRelative n Month)       = (addGregorianMonthsClip n d, addGregorianMonthsClip (n+1) d) where d = thismonth refdate-          span' (SmartRelative n Quarter)     = (addGregorianMonthsClip (3*n) d, addGregorianMonthsClip (3*n+3) d) where d = thisquarter refdate-          span' (SmartRelative n Year)        = (addGregorianYearsClip n d, addGregorianYearsClip (n+1) d) where d = thisyear refdate+          span' :: SmartDate -> (EFDay, EFDay)+          span' (SmartCompleteDate day)       = (Exact day, Exact $ nextday day)+          span' (SmartAssumeStart y Nothing)  = (Flex $ startofyear day, Flex $ nextyear day) where day = fromGregorian y 1 1+          span' (SmartAssumeStart y (Just m)) = (Flex $ startofmonth day, Flex $ nextmonth day) where day = fromGregorian y m 1+          span' (SmartFromReference m d)      = (Exact day, Exact $ nextday day) where day = fromGregorian ry (fromMaybe rm m) d+          span' (SmartMonth m)                = (Flex $ startofmonth day, Flex $ nextmonth day) where day = fromGregorian ry m 1+          span' (SmartRelative n Day)         = (Exact $ addDays n refdate, Exact $ addDays (n+1) refdate)+          span' (SmartRelative n Week)        = (Flex $ addDays (7*n) d, Flex $ addDays (7*n+7) d) where d = thisweek refdate+          span' (SmartRelative n Month)       = (Flex $ addGregorianMonthsClip n d, Flex $ addGregorianMonthsClip (n+1) d) where d = thismonth refdate+          span' (SmartRelative n Quarter)     = (Flex $ addGregorianMonthsClip (3*n) d, Flex $ addGregorianMonthsClip (3*n+3) d) where d = thisquarter refdate+          span' (SmartRelative n Year)        = (Flex $ addGregorianYearsClip n d, Flex $ addGregorianYearsClip (n+1) d) where d = thisyear refdate  -- showDay :: Day -> String -- showDay day = printf "%04d/%02d/%02d" y m d where (y,m,d) = toGregorian day@@ -411,15 +432,17 @@  -- | A safe version of fixSmartDateStr. fixSmartDateStrEither :: Day -> Text -> Either HledgerParseErrors Text-fixSmartDateStrEither d = fmap showDate . fixSmartDateStrEither' d+fixSmartDateStrEither d = fmap showEFDate . fixSmartDateStrEither' d  fixSmartDateStrEither'-  :: Day -> Text -> Either HledgerParseErrors Day+  :: 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 --- | Convert a SmartDate to an absolute date using the provided reference date.+-- | Convert a SmartDate to a specific date using the provided reference date.+-- This date will be exact or flexible depending on whether the day was+-- specified exactly. (Missing least-significant parts produces a flex date.) -- -- ==== Examples: -- >>> :set -XOverloadedStrings@@ -502,25 +525,24 @@ -- "2008-07-01" -- >>> t "1 week ahead" -- "2008-12-01"-fixSmartDate :: Day -> SmartDate -> Day+fixSmartDate :: Day -> SmartDate -> EFDay fixSmartDate refdate = fix   where-    fix :: SmartDate -> Day-    fix (SmartCompleteDate d)     = d-    fix (SmartAssumeStart y m)    = fromGregorian y (fromMaybe 1 m) 1-    fix (SmartFromReference m d)  = fromGregorian ry (fromMaybe rm m) d-    fix (SmartMonth m)            = fromGregorian ry m 1-    fix (SmartRelative n Day)     = addDays n refdate-    fix (SmartRelative n Week)    = addDays (7*n) $ thisweek refdate-    fix (SmartRelative n Month)   = addGregorianMonthsClip n $ thismonth refdate-    fix (SmartRelative n Quarter) = addGregorianMonthsClip (3*n) $ thisquarter refdate-    fix (SmartRelative n Year)    = addGregorianYearsClip n $ thisyear refdate+    fix :: SmartDate -> EFDay+    fix (SmartCompleteDate d)     = Exact d+    fix (SmartAssumeStart y m)    = Flex  $ fromGregorian y (fromMaybe 1 m) 1+    fix (SmartFromReference m d)  = Exact $ fromGregorian ry (fromMaybe rm m) d+    fix (SmartMonth m)            = Flex  $ fromGregorian ry m 1+    fix (SmartRelative n Day)     = Exact $ addDays n refdate+    fix (SmartRelative n Week)    = Flex  $ addDays (7*n) $ thisweek refdate+    fix (SmartRelative n Month)   = Flex  $ addGregorianMonthsClip n $ thismonth refdate+    fix (SmartRelative n Quarter) = Flex  $ addGregorianMonthsClip (3*n) $ thisquarter refdate+    fix (SmartRelative n Year)    = Flex  $ addGregorianYearsClip n $ thisyear refdate     (ry, rm, _) = toGregorian refdate  prevday :: Day -> Day prevday = addDays (-1) nextday = addDays 1-startofday = id  thisweek = startofweek prevweek = startofweek . addDays (-7)@@ -547,11 +569,12 @@ nextyear = startofyear . addGregorianYearsClip 1 startofyear day = fromGregorian y 1 1 where (y,_,_) = toGregorian day --- Get the natural start for the given interval that falls on or before the given day.-intervalStartBefore :: Interval -> Day -> Day-intervalStartBefore int d =-  case splitSpan int (DateSpan (Just d) (Just $ addDays 1 d)) of-    (DateSpan (Just start) _:_) -> start+-- Get the natural start for the given interval that falls on or before the given day,+-- when applicable. Works for Weeks, Months, Quarters, Years, eg.+intervalBoundaryBefore :: Interval -> Day -> Day+intervalBoundaryBefore i d =+  case splitSpan True i (DateSpan (Just $ Exact d) (Just $ Exact $ addDays 1 d)) of+    (DateSpan (Just start) _:_) -> fromEFDay start     _ -> d  -- | For given date d find year-long interval that starts on given@@ -904,6 +927,8 @@ -- Right (DayOfYear 11 29,DateSpan 2009-01-01..) -- >>> p "every 11/29 from 2009" -- Right (DayOfYear 11 29,DateSpan 2009-01-01..)+-- >>> p "every 11/29 since 2009"+-- Right (DayOfYear 11 29,DateSpan 2009-01-01..) -- >>> p "every 2nd Thursday of month to 2009" -- Right (WeekdayOfMonth 2 4,DateSpan ..2008-12-31) -- >>> p "every 1st monday of month to 2009"@@ -1004,7 +1029,7 @@ -- Right DateSpan 2017 doubledatespanp :: Day -> TextParser m DateSpan doubledatespanp rdate = liftA2 fromToSpan-    (optional (string' "from" *> skipNonNewlineSpaces) *> smartdate)+    (optional ((string' "from" <|> string' "since") *> skipNonNewlineSpaces) *> smartdate)     (skipNonNewlineSpaces *> choice [string' "to", string "..", string "-"]     *> skipNonNewlineSpaces *> smartdate)   where@@ -1027,7 +1052,7 @@  fromdatespanp :: Day -> TextParser m DateSpan fromdatespanp rdate = fromSpan <$> choice-    [ string' "from" *> skipNonNewlineSpaces *> smartdate+    [ (string' "from" <|> string' "since") *> skipNonNewlineSpaces *> smartdate     , smartdate <* choice [string "..", string "-"]     ]   where@@ -1047,9 +1072,9 @@ nulldatespan :: DateSpan nulldatespan = DateSpan Nothing Nothing --- | A datespan of zero length, that matches no date.+-- | An exact datespan of zero length, that matches no date. emptydatespan :: DateSpan-emptydatespan = DateSpan (Just $ addDays 1 nulldate) (Just nulldate)+emptydatespan = DateSpan (Just $ Exact $ addDays 1 nulldate) (Just $ Exact nulldate)  nulldate :: Day nulldate = fromGregorian 0 1 1@@ -1059,39 +1084,39 @@  tests_Dates = testGroup "Dates"   [ testCase "weekday" $ do-      splitSpan (DaysOfWeek [1..5]) (DateSpan (Just $ fromGregorian 2021 07 01) (Just $ fromGregorian 2021 07 08))-        @?= [ (DateSpan (Just $ fromGregorian 2021 06 28) (Just $ fromGregorian 2021 06 29))-            , (DateSpan (Just $ fromGregorian 2021 06 29) (Just $ fromGregorian 2021 06 30))-            , (DateSpan (Just $ fromGregorian 2021 06 30) (Just $ fromGregorian 2021 07 01))-            , (DateSpan (Just $ fromGregorian 2021 07 01) (Just $ fromGregorian 2021 07 02))-            , (DateSpan (Just $ fromGregorian 2021 07 02) (Just $ fromGregorian 2021 07 05))+      splitSpan False (DaysOfWeek [1..5]) (DateSpan (Just $ Exact $ fromGregorian 2021 07 01) (Just $ Exact $ fromGregorian 2021 07 08))+        @?= [ (DateSpan (Just $ Exact $ fromGregorian 2021 06 28) (Just $ Exact $ fromGregorian 2021 06 29))+            , (DateSpan (Just $ Exact $ fromGregorian 2021 06 29) (Just $ Exact $ fromGregorian 2021 06 30))+            , (DateSpan (Just $ Exact $ fromGregorian 2021 06 30) (Just $ Exact $ fromGregorian 2021 07 01))+            , (DateSpan (Just $ Exact $ fromGregorian 2021 07 01) (Just $ Exact $ fromGregorian 2021 07 02))+            , (DateSpan (Just $ Exact $ fromGregorian 2021 07 02) (Just $ Exact $ fromGregorian 2021 07 05))             -- next week-            , (DateSpan (Just $ fromGregorian 2021 07 05) (Just $ fromGregorian 2021 07 06))-            , (DateSpan (Just $ fromGregorian 2021 07 06) (Just $ fromGregorian 2021 07 07))-            , (DateSpan (Just $ fromGregorian 2021 07 07) (Just $ fromGregorian 2021 07 08))+            , (DateSpan (Just $ Exact $ fromGregorian 2021 07 05) (Just $ Exact $ fromGregorian 2021 07 06))+            , (DateSpan (Just $ Exact $ fromGregorian 2021 07 06) (Just $ Exact $ fromGregorian 2021 07 07))+            , (DateSpan (Just $ Exact $ fromGregorian 2021 07 07) (Just $ Exact $ fromGregorian 2021 07 08))             ] -      splitSpan (DaysOfWeek [1, 5]) (DateSpan (Just $ fromGregorian 2021 07 01) (Just $ fromGregorian 2021 07 08))-        @?= [ (DateSpan (Just $ fromGregorian 2021 06 28) (Just $ fromGregorian 2021 07 02))-            , (DateSpan (Just $ fromGregorian 2021 07 02) (Just $ fromGregorian 2021 07 05))+      splitSpan False (DaysOfWeek [1, 5]) (DateSpan (Just $ Exact $ fromGregorian 2021 07 01) (Just $ Exact $ fromGregorian 2021 07 08))+        @?= [ (DateSpan (Just $ Exact $ fromGregorian 2021 06 28) (Just $ Exact $ fromGregorian 2021 07 02))+            , (DateSpan (Just $ Exact $ fromGregorian 2021 07 02) (Just $ Exact $ fromGregorian 2021 07 05))             -- next week-            , (DateSpan (Just $ fromGregorian 2021 07 05) (Just $ fromGregorian 2021 07 09))+            , (DateSpan (Just $ Exact $ fromGregorian 2021 07 05) (Just $ Exact $ fromGregorian 2021 07 09))             ]    , testCase "match dayOfWeek" $ do       let dayofweek n = splitspan (nthdayofweekcontaining n) (\w -> (if w == 0 then id else applyN (n-1) nextday . applyN (fromInteger w) nextweek)) 1-          matchdow ds day = splitSpan (DaysOfWeek [day]) ds @?= dayofweek day ds+          matchdow ds day = splitSpan False (DaysOfWeek [day]) ds @?= dayofweek day ds           ys2021 = fromGregorian 2021 01 01           ye2021 = fromGregorian 2021 12 31           ys2022 = fromGregorian 2022 01 01-      mapM_ (matchdow (DateSpan (Just ys2021) (Just ye2021))) [1..7]-      mapM_ (matchdow (DateSpan (Just ys2021) (Just ys2022))) [1..7]-      mapM_ (matchdow (DateSpan (Just ye2021) (Just ys2022))) [1..7]+      mapM_ (matchdow (DateSpan (Just $ Exact ys2021) (Just $ Exact ye2021))) [1..7]+      mapM_ (matchdow (DateSpan (Just $ Exact ys2021) (Just $ Exact ys2022))) [1..7]+      mapM_ (matchdow (DateSpan (Just $ Exact ye2021) (Just $ Exact ys2022))) [1..7] -      mapM_ (matchdow (DateSpan (Just ye2021) Nothing)) [1..7]-      mapM_ (matchdow (DateSpan (Just ys2022) Nothing)) [1..7]+      mapM_ (matchdow (DateSpan (Just $ Exact ye2021) Nothing)) [1..7]+      mapM_ (matchdow (DateSpan (Just $ Exact ys2022) Nothing)) [1..7] -      mapM_ (matchdow (DateSpan Nothing (Just ye2021))) [1..7]-      mapM_ (matchdow (DateSpan Nothing (Just ys2022))) [1..7]+      mapM_ (matchdow (DateSpan Nothing (Just $ Exact ye2021))) [1..7]+      mapM_ (matchdow (DateSpan Nothing (Just $ Exact ys2022))) [1..7]    ]

@@ -3,8 +3,10 @@ -}  {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}  module Hledger.Data.Errors (+  makeAccountTagErrorExcerpt,   makeTransactionErrorExcerpt,   makePostingErrorExcerpt,   makePostingAccountErrorExcerpt,@@ -25,13 +27,57 @@ import Safe (headMay) import Hledger.Data.Posting (isVirtual) +-- | Given an account name and its account directive, and a problem tag within the latter:+-- render it as a megaparsec-style excerpt, showing the original line number and+-- marked column or region.+-- Returns the file path, line number, column(s) if known,+-- and the rendered excerpt, or as much of these as is possible.+-- The returned columns will be accurate for the rendered error message but not for the original journal data.+makeAccountTagErrorExcerpt :: (AccountName, AccountDeclarationInfo) -> TagName -> (FilePath, Int, Maybe (Int, Maybe Int), Text)+makeAccountTagErrorExcerpt (a, adi) _t = (f, l, merrcols, ex)+  -- XXX findtxnerrorcolumns is awkward, I don't think this is the final form+  where+    (SourcePos f pos _) = adisourcepos adi+    l = unPos pos+    txt   = showAccountDirective (a, adi) & textChomp & (<>"\n")+    ex = decorateTagErrorExcerpt l merrcols txt+    -- Calculate columns which will help highlight the region in the excerpt+    -- (but won't exactly match the real data, so won't be shown in the main error line)+    merrcols = Nothing+      -- don't bother for now+      -- Just (col, Just col2)+      -- where+      --   col  = undefined -- T.length (showTransactionLineFirstPart t') + 2+      --   col2 = undefined -- col + T.length tagname - 1      ++showAccountDirective (a, AccountDeclarationInfo{..}) =+  "account " <> a+  <> (if not $ T.null adicomment then "    ; " <> adicomment else "")++-- | Add megaparsec-style left margin, line number, and optional column marker(s).+decorateTagErrorExcerpt :: Int -> Maybe (Int, Maybe Int) -> Text -> Text+decorateTagErrorExcerpt l mcols txt =+  T.unlines $ ls' <> colmarkerline <> map (lineprefix<>) ms+  where+    (ls,ms) = splitAt 1 $ T.lines txt+    ls' = map ((T.pack (show l) <> " | ") <>) ls+    colmarkerline =+      [lineprefix <> T.replicate (col-1) " " <> T.replicate regionw "^"+      | Just (col, mendcol) <- [mcols]+      , let regionw = maybe 1 (subtract col) mendcol + 1+      ]+    lineprefix = T.replicate marginw " " <> "| "+      where  marginw = length (show l) + 1++_showAccountDirective = undefined+ -- | Given a problem transaction and a function calculating the best -- column(s) for marking the error region: -- render it as a megaparsec-style excerpt, showing the original line number -- on the transaction line, and a column(s) marker. -- Returns the file path, line number, column(s) if known, -- and the rendered excerpt, or as much of these as is possible.--- A limitation: columns will be accurate for the rendered error message but not for the original journal data.+-- The returned columns will be accurate for the rendered error message but not for the original journal data. makeTransactionErrorExcerpt :: Transaction -> (Transaction -> Maybe (Int, Maybe Int)) -> (FilePath, Int, Maybe (Int, Maybe Int), Text) makeTransactionErrorExcerpt t findtxnerrorcolumns = (f, tl, merrcols, ex)   -- XXX findtxnerrorcolumns is awkward, I don't think this is the final form

@@ -26,7 +26,8 @@   journalCommodityStyles,   journalToCost,   journalAddInferredEquityPostings,-  journalAddPricesFromEquity,+  journalInferCostsFromEquity,+  journalMarkRedundantCosts,   journalReverse,   journalSetLastReadTime,   journalRenumberAccountDeclarations,@@ -65,6 +66,9 @@   journalPayeesDeclared,   journalPayeesUsed,   journalPayeesDeclaredOrUsed,+  journalTagsDeclared,+  journalTagsUsed,+  journalTagsDeclaredOrUsed,   journalCommoditiesDeclared,   journalCommodities,   journalDateSpan,@@ -216,6 +220,7 @@     ,jparsetimeclockentries     = jparsetimeclockentries     j1 <> jparsetimeclockentries     j2     ,jincludefilestack          = jincludefilestack j2     ,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@@ -274,6 +279,7 @@   ,jparsetimeclockentries     = []   ,jincludefilestack          = []   ,jdeclaredpayees            = []+  ,jdeclaredtags              = []   ,jdeclaredaccounts          = []   ,jdeclaredaccounttags       = M.empty   ,jdeclaredaccounttypes      = M.empty@@ -355,6 +361,20 @@ journalPayeesDeclaredOrUsed j = toList $ foldMap S.fromList     [journalPayeesDeclared j, journalPayeesUsed j] +-- | Sorted unique tag names declared by tag directives in this journal.+journalTagsDeclared :: Journal -> [TagName]+journalTagsDeclared = nubSort . map fst . jdeclaredtags++-- | Sorted unique tag names used in this journal (in account directives, transactions, postings..)+journalTagsUsed :: Journal -> [TagName]+journalTagsUsed j = nubSort $ map fst $ concatMap transactionAllTags $ jtxns j+  -- tags used in all transactions and postings and postings' accounts++-- | Sorted unique tag names used in transactions or declared by tag directives in this journal.+journalTagsDeclaredOrUsed :: Journal -> [TagName]+journalTagsDeclaredOrUsed j = toList $ foldMap S.fromList+    [journalTagsDeclared j, journalTagsUsed j]+ -- | Sorted unique account names posted to by this journal's transactions. journalAccountNamesUsed :: Journal -> [AccountName] journalAccountNamesUsed = accountNamesFromPostings . journalPostings@@ -880,12 +900,23 @@   where     equityAcct = journalConversionAccount j --- | Add inferred transaction prices from equity postings.-journalAddPricesFromEquity :: Journal -> Either String Journal-journalAddPricesFromEquity j = do-    ts <- mapM (transactionAddPricesFromEquity $ jaccounttypes j) $ jtxns j+-- | Add costs inferred from equity conversion postings, where needed and possible.+-- See hledger manual > Inferring cost from equity postings.+journalInferCostsFromEquity :: Journal -> Either String Journal+journalInferCostsFromEquity j = do+    ts <- mapM (transactionInferCostsFromEquity False $ jaccounttypes j) $ jtxns j     return j{jtxns=ts} +-- | Do just the internal tagging that is normally done by journalInferCostsFromEquity,+-- identifying equity conversion postings and, in particular, postings which have redundant costs.+-- Tagging the latter is useful as it allows them to be ignored during transaction balancedness checking.+-- And that allows journalInferCostsFromEquity to be postponed till after transaction balancing,+-- when it will have more information (amounts) to work with.+journalMarkRedundantCosts :: Journal -> Either String Journal+journalMarkRedundantCosts j = do+    ts <- mapM (transactionInferCostsFromEquity True $ jaccounttypes j) $ jtxns j+    return j{jtxns=ts}+ -- -- | Get this journal's unique, display-preference-canonicalised commodities, by symbol. -- journalCanonicalCommodities :: Journal -> M.Map String CommoditySymbol -- journalCanonicalCommodities j = canonicaliseCommodities $ journalAmountCommodities j@@ -971,7 +1002,7 @@ --     pamt  g p          = (\amt -> p {pamount  =amt}) <$> g (pamount p) --     amts  g (Mixed as) = Mixed <$> g as --- | The fully specified date span enclosing the dates (primary or secondary)+-- | The fully specified exact date span enclosing the dates (primary or secondary) -- of all this journal's transactions and postings, or DateSpan Nothing Nothing -- if there are none. journalDateSpan :: Bool -> Journal -> DateSpan@@ -988,7 +1019,7 @@ -- uses both primary and secondary dates. journalDateSpanHelper :: Maybe WhichDate -> Journal -> DateSpan journalDateSpanHelper whichdate j =-    DateSpan (minimumMay dates) (addDays 1 <$> maximumMay dates)+    DateSpan (Exact <$> minimumMay dates) (Exact . addDays 1 <$> maximumMay dates)   where     dates    = pdates ++ tdates     tdates   = concatMap gettdate ts@@ -1006,12 +1037,12 @@ -- | The earliest of this journal's transaction and posting dates, or -- Nothing if there are none. journalStartDate :: Bool -> Journal -> Maybe Day-journalStartDate secondary j = b where DateSpan b _ = journalDateSpan secondary j+journalStartDate secondary j = fromEFDay <$> b where DateSpan b _ = journalDateSpan secondary j  -- | The "exclusive end date" of this journal: the day following its latest transaction  -- or posting date, or Nothing if there are none. journalEndDate :: Bool -> Journal -> Maybe Day-journalEndDate secondary j = e where DateSpan _ e = journalDateSpan secondary j+journalEndDate secondary j = fromEFDay <$> e where DateSpan _ e = journalDateSpan secondary j  -- | The latest of this journal's transaction and posting dates, or -- Nothing if there are none.@@ -1223,5 +1254,5 @@                               }               ]       }-    @?= (DateSpan (Just $ fromGregorian 2014 1 10) (Just $ fromGregorian 2014 10 11))+    @?= (DateSpan (Just $ Exact $ fromGregorian 2014 1 10) (Just $ Exact $ fromGregorian 2014 10 11))   ]

@@ -12,13 +12,16 @@   journalCheckAccounts,   journalCheckCommodities,   journalCheckPayees,+  journalCheckPairedConversionPostings,   journalCheckRecentAssertions,+  journalCheckTags,   module Hledger.Data.JournalChecks.Ordereddates,   module Hledger.Data.JournalChecks.Uniqueleafnames, ) where  import Data.Char (isSpace)+import Data.List.Extra import Data.Maybe import qualified Data.Map.Strict as M import qualified Data.Text as T@@ -29,13 +32,12 @@ import Hledger.Data.Journal import Hledger.Data.JournalChecks.Ordereddates import Hledger.Data.JournalChecks.Uniqueleafnames-import Hledger.Data.Posting (isVirtual, postingDate, postingStatus)+import Hledger.Data.Posting (isVirtual, postingDate, postingStatus, transactionAllTags) import Hledger.Data.Types import Hledger.Data.Amount (amountIsZero, amountsRaw, missingamt)-import Hledger.Data.Transaction (transactionPayee, showTransactionLineFirstPart)+import Hledger.Data.Transaction (transactionPayee, showTransactionLineFirstPart, partitionAndCheckConversionPostings) import Data.Time (Day, diffDays)-import Data.List.Extra-import Hledger.Utils (chomp, textChomp, sourcePosPretty)+import Hledger.Utils  -- | Check that all the journal's postings are to accounts  with -- account directives, returning an error message otherwise.@@ -155,6 +157,55 @@           where             col  = T.length (showTransactionLineFirstPart t') + 2             col2 = col + T.length (transactionPayee t') - 1++-- | Check that all the journal's tags (on accounts, transactions, postings..)+-- have been declared with tag directives, returning an error message otherwise.+journalCheckTags :: Journal -> Either String ()+journalCheckTags j = do+  mapM_ checkaccttags $ jdeclaredaccounts j+  mapM_ checktxntags  $ jtxns j+  where+    checkaccttags (a, adi) = mapM_ (checkaccttag.fst) $ aditags adi+      where+        checkaccttag tagname+          | tagname `elem` declaredtags = Right ()+          | otherwise = Left $ printf msg f l ex (show tagname) tagname+            where (f,l,_mcols,ex) = makeAccountTagErrorExcerpt (a, adi) tagname+    checktxntags txn = mapM_ (checktxntag . fst) $ transactionAllTags txn+      where+        checktxntag tagname+          | tagname `elem` declaredtags = Right ()+          | otherwise = Left $ printf msg f l ex (show tagname) tagname+            where+              (f,l,_mcols,ex) = makeTransactionErrorExcerpt txn finderrcols+                where+                  finderrcols _txn' = Nothing+                    -- don't bother for now+                    -- Just (col, Just col2)+                    -- where+                    --   col  = T.length (showTransactionLineFirstPart txn') + 2+                    --   col2 = col + T.length tagname - 1+    declaredtags = journalTagsDeclared j+    msg = (unlines [+      "%s:%d:"+      ,"%s"+      ,"Strict tag checking is enabled, and"+      ,"tag %s has not been declared."+      ,"Consider adding a tag directive. Examples:"+      ,""+      ,"tag %s"+      ])++-- | In each tranaction, check that any conversion postings occur in adjacent pairs.+journalCheckPairedConversionPostings :: Journal -> Either String ()+journalCheckPairedConversionPostings j =+  mapM_ (transactionCheckPairedConversionPostings (jaccounttypes j)) $ jtxns j++transactionCheckPairedConversionPostings :: M.Map AccountName AccountType -> Transaction -> Either String ()+transactionCheckPairedConversionPostings accttypes t =+  case partitionAndCheckConversionPostings True accttypes (zip [0..] $ tpostings t) of+    Left err -> Left $ T.unpack err+    Right _  -> Right ()  ---------- 

@@ -125,6 +125,7 @@ instance ToJSON TMPostingRule instance ToJSON PeriodicTransaction instance ToJSON PriceDirective+instance ToJSON EFDay instance ToJSON DateSpan instance ToJSON Interval instance ToJSON Period@@ -133,6 +134,7 @@ instance ToJSONKey AccountType instance ToJSON AccountDeclarationInfo instance ToJSON PayeeDeclarationInfo+instance ToJSON TagDeclarationInfo instance ToJSON Commodity instance ToJSON TimeclockCode instance ToJSON TimeclockEntry

@@ -44,38 +44,38 @@  import Hledger.Data.Types --- | Convert Periods to DateSpans.+-- | Convert Periods to exact DateSpans. ----- >>> periodAsDateSpan (MonthPeriod 2000 1) == DateSpan (Just $ fromGregorian 2000 1 1) (Just $ fromGregorian 2000 2 1)+-- >>> periodAsDateSpan (MonthPeriod 2000 1) == DateSpan (Just $ Flex $ fromGregorian 2000 1 1) (Just $ Flex $ fromGregorian 2000 2 1) -- True periodAsDateSpan :: Period -> DateSpan-periodAsDateSpan (DayPeriod d) = DateSpan (Just d) (Just $ addDays 1 d)-periodAsDateSpan (WeekPeriod b) = DateSpan (Just b) (Just $ addDays 7 b)-periodAsDateSpan (MonthPeriod y m) = DateSpan (Just $ fromGregorian y m 1) (Just $ fromGregorian y' m' 1)+periodAsDateSpan (DayPeriod d) = DateSpan (Just $ Exact d) (Just $ Exact $ addDays 1 d)+periodAsDateSpan (WeekPeriod b) = DateSpan (Just $ Flex b) (Just $ Flex $ addDays 7 b)+periodAsDateSpan (MonthPeriod y m) = DateSpan (Just $ Flex $ fromGregorian y m 1) (Just $ Flex $ fromGregorian y' m' 1)   where     (y',m') | m==12     = (y+1,1)             | otherwise = (y,m+1)-periodAsDateSpan (QuarterPeriod y q) = DateSpan (Just $ fromGregorian y m 1) (Just $ fromGregorian y' m' 1)+periodAsDateSpan (QuarterPeriod y q) = DateSpan (Just $ Flex $ fromGregorian y m 1) (Just $ Flex $ fromGregorian y' m' 1)   where     (y', q') | q==4      = (y+1,1)              | otherwise = (y,q+1)     quarterAsMonth q2 = (q2-1) * 3 + 1     m  = quarterAsMonth q     m' = quarterAsMonth q'-periodAsDateSpan (YearPeriod y) = DateSpan (Just $ fromGregorian y 1 1) (Just $ fromGregorian (y+1) 1 1)-periodAsDateSpan (PeriodBetween b e) = DateSpan (Just b) (Just e)-periodAsDateSpan (PeriodFrom b) = DateSpan (Just b) Nothing-periodAsDateSpan (PeriodTo e) = DateSpan Nothing (Just e)+periodAsDateSpan (YearPeriod y) = DateSpan (Just $ Flex $ fromGregorian y 1 1) (Just $ Flex $ fromGregorian (y+1) 1 1)+periodAsDateSpan (PeriodBetween b e) = DateSpan (Just $ Exact b) (Just $ Exact e)+periodAsDateSpan (PeriodFrom b) = DateSpan (Just $ Exact b) Nothing+periodAsDateSpan (PeriodTo e) = DateSpan Nothing (Just $ Exact e) periodAsDateSpan (PeriodAll) = DateSpan Nothing Nothing  -- | Convert DateSpans to Periods. ----- >>> dateSpanAsPeriod $ DateSpan (Just $ fromGregorian 2000 1 1) (Just $ fromGregorian 2000 2 1)+-- >>> dateSpanAsPeriod $ DateSpan (Just $ Exact $ fromGregorian 2000 1 1) (Just $ Exact $ fromGregorian 2000 2 1) -- MonthPeriod 2000 1 dateSpanAsPeriod :: DateSpan -> Period-dateSpanAsPeriod (DateSpan (Just b) (Just e)) = simplifyPeriod $ PeriodBetween b e-dateSpanAsPeriod (DateSpan (Just b) Nothing) = PeriodFrom b-dateSpanAsPeriod (DateSpan Nothing (Just e)) = PeriodTo e+dateSpanAsPeriod (DateSpan (Just b) (Just e)) = simplifyPeriod $ PeriodBetween (fromEFDay b) (fromEFDay e)+dateSpanAsPeriod (DateSpan (Just b) Nothing) = PeriodFrom (fromEFDay b)+dateSpanAsPeriod (DateSpan Nothing (Just e)) = PeriodTo (fromEFDay e) dateSpanAsPeriod (DateSpan Nothing Nothing) = PeriodAll  -- | Convert PeriodBetweens to a more abstract period where possible.@@ -195,12 +195,12 @@ showPeriodMonthAbbrev p = showPeriod p  periodStart :: Period -> Maybe Day-periodStart p = mb+periodStart p = fromEFDay <$> mb   where     DateSpan mb _ = periodAsDateSpan p  periodEnd :: Period -> Maybe Day-periodEnd p = me+periodEnd p = fromEFDay <$> me   where     DateSpan _ me = periodAsDateSpan p @@ -231,11 +231,12 @@ -- | Move a standard period to the following period of same duration, staying within enclosing dates. -- Non-standard periods are unaffected. periodNextIn :: DateSpan -> Period -> Period-periodNextIn (DateSpan _ (Just e)) p =+periodNextIn (DateSpan _ (Just e0)) p =   case mb of     Just b -> if b < e then p' else p     _      -> p   where+    e = fromEFDay e0     p' = periodNext p     mb = periodStart p' periodNextIn _ p = periodNext p@@ -243,11 +244,12 @@ -- | Move a standard period to the preceding period of same duration, staying within enclosing dates. -- Non-standard periods are unaffected. periodPreviousIn :: DateSpan -> Period -> Period-periodPreviousIn (DateSpan (Just b) _) p =+periodPreviousIn (DateSpan (Just b0) _) p =   case me of     Just e -> if e > b then p' else p     _      -> p   where+    b = fromEFDay b0     p' = periodPrevious p     me = periodEnd p' periodPreviousIn _ p = periodPrevious p

@@ -11,6 +11,7 @@ ) where +import Data.Maybe (isNothing) import qualified Data.Text as T import qualified Data.Text.IO as T import Text.Printf@@ -20,7 +21,6 @@ import Hledger.Data.Amount import Hledger.Data.Posting (post, commentAddTagNextLine) import Hledger.Data.Transaction-import Hledger.Utils  -- $setup -- >>> :set -XOverloadedStrings@@ -33,34 +33,30 @@   let     t = T.pack str     (i,s) = parsePeriodExpr' nulldate t-  case checkPeriodicTransactionStartDate i s t of-    Just e  -> error' e  -- PARTIAL:-    Nothing ->-      mapM_ (T.putStr . showTransaction) $-        runPeriodicTransaction-          nullperiodictransaction{ ptperiodexpr=t , ptspan=s, ptinterval=i, ptpostings=["a" `post` usd 1] }-          nulldatespan+  mapM_ (T.putStr . showTransaction) $+    runPeriodicTransaction+      nullperiodictransaction{ ptperiodexpr=t , ptspan=s, ptinterval=i, ptpostings=["a" `post` usd 1] }+      nulldatespan  _ptgenspan str spn = do   let     t = T.pack str     (i,s) = parsePeriodExpr' nulldate t-  case checkPeriodicTransactionStartDate i s t of-    Just e  -> error' e  -- PARTIAL:-    Nothing ->-      mapM_ (T.putStr . showTransaction) $-        runPeriodicTransaction-          nullperiodictransaction{ ptperiodexpr=t , ptspan=s, ptinterval=i, ptpostings=["a" `post` usd 1] }-          spn+  mapM_ (T.putStr . showTransaction) $+    runPeriodicTransaction+      nullperiodictransaction{ ptperiodexpr=t , ptspan=s, ptinterval=i, ptpostings=["a" `post` usd 1] }+      spn  --deriving instance Show PeriodicTransaction -- for better pretty-printing: instance Show PeriodicTransaction where   show PeriodicTransaction{..} =-    printf "PeriodicTransactionPP {%s, %s, %s, %s, %s, %s, %s, %s, %s}"+    printf "PeriodicTransactionPP {%s, %s, %s, %s, %s, %s, %s, %s, %s, %s}"+      -- Warning, be careful to keep these synced ^ v       ("ptperiodexpr=" ++ show ptperiodexpr)       ("ptinterval=" ++ show ptinterval)       ("ptspan=" ++ show (show ptspan))+      ("ptsourcepos=" ++ show ptsourcepos)       ("ptstatus=" ++ show (show ptstatus))       ("ptcode=" ++ show ptcode)       ("ptdescription=" ++ show ptdescription)@@ -190,33 +186,17 @@ --     a           $1.00 -- <BLANKLINE> ----- >>> _ptgen ""--- *** Exception: Error: failed to parse...--- ...------ >>> _ptgen "weekly from 2017"--- *** Exception: Error: Unable to generate transactions according to "weekly from 2017" because 2017-01-01 is not a first day of the Week------ >>> _ptgen "monthly from 2017/5/4"--- *** Exception: Error: Unable to generate transactions according to "monthly from 2017/5/4" because 2017-05-04 is not a first day of the Month------ >>> _ptgen "every quarter from 2017/1/2"--- *** Exception: Error: Unable to generate transactions according to "every quarter from 2017/1/2" because 2017-01-02 is not a first day of the Quarter------ >>> _ptgen "yearly from 2017/1/14"--- *** Exception: Error: Unable to generate transactions according to "yearly from 2017/1/14" because 2017-01-14 is not a first day of the Year------ >>> let reportperiod="daily from 2018/01/03" in let (i,s) = parsePeriodExpr' nulldate reportperiod in runPeriodicTransaction (nullperiodictransaction{ptperiodexpr=reportperiod, ptspan=s, ptinterval=i, ptpostings=["a" `post` usd 1]}) (DateSpan (Just $ fromGregorian 2018 01 01) (Just $ fromGregorian 2018 01 03))+-- >>> let reportperiod="daily from 2018/01/03" in let (i,s) = parsePeriodExpr' nulldate reportperiod in runPeriodicTransaction (nullperiodictransaction{ptperiodexpr=reportperiod, ptspan=s, ptinterval=i, ptpostings=["a" `post` usd 1]}) (DateSpan (Just $ Flex $ fromGregorian 2018 01 01) (Just $ Flex $ fromGregorian 2018 01 03)) -- [] ----- >>> _ptgenspan "every 3 months from 2019-05" (DateSpan (Just $ fromGregorian 2020 01 01) (Just $ fromGregorian 2020 02 01))+-- >>> _ptgenspan "every 3 months from 2019-05" (DateSpan (Just $ Flex $ fromGregorian 2020 01 01) (Just $ Flex $ fromGregorian 2020 02 01)) ----- >>> _ptgenspan "every 3 months from 2019-05" (DateSpan (Just $ fromGregorian 2020 02 01) (Just $ fromGregorian 2020 03 01))+-- >>> _ptgenspan "every 3 months from 2019-05" (DateSpan (Just $ Flex $ fromGregorian 2020 02 01) (Just $ Flex $ fromGregorian 2020 03 01)) -- 2020-02-01 --     ; generated-transaction: ~ every 3 months from 2019-05 --     a           $1.00 -- <BLANKLINE>--- >>> _ptgenspan "every 3 days from 2018" (DateSpan (Just $ fromGregorian 2018 01 01) (Just $ fromGregorian 2018 01 05))+-- >>> _ptgenspan "every 3 days from 2018" (DateSpan (Just $ Flex $ fromGregorian 2018 01 01) (Just $ Flex $ fromGregorian 2018 01 05)) -- 2018-01-01 --     ; generated-transaction: ~ every 3 days from 2018 --     a           $1.00@@ -225,7 +205,7 @@ --     ; generated-transaction: ~ every 3 days from 2018 --     a           $1.00 -- <BLANKLINE>--- >>> _ptgenspan "every 3 days from 2018" (DateSpan (Just $ fromGregorian 2018 01 02) (Just $ fromGregorian 2018 01 05))+-- >>> _ptgenspan "every 3 days from 2018" (DateSpan (Just $ Flex $ fromGregorian 2018 01 02) (Just $ Flex $ fromGregorian 2018 01 05)) -- 2018-01-04 --     ; generated-transaction: ~ every 3 days from 2018 --     a           $1.00@@ -233,10 +213,11 @@  runPeriodicTransaction :: PeriodicTransaction -> DateSpan -> [Transaction] runPeriodicTransaction PeriodicTransaction{..} requestedspan =-    [ t{tdate=d} | (DateSpan (Just d) _) <- alltxnspans, spanContainsDate requestedspan d ]+    [ t{tdate=d} | (DateSpan (Just efd) _) <- alltxnspans, let d = fromEFDay efd, spanContainsDate requestedspan d ]   where     t = nulltransaction{-           tstatus      = ptstatus+           tsourcepos   = ptsourcepos+          ,tstatus      = ptstatus           ,tcode        = ptcode           ,tdescription = ptdescription           ,tcomment     = ptcomment@@ -247,10 +228,13 @@           ,tpostings    = ptpostings           }     period = "~ " <> ptperiodexpr-    -- All spans described by this periodic transaction, where spanStart is event date.-    -- If transaction does not have start/end date, we set them to start/end of requested span,-    -- to avoid generating (infinitely) many events. -    alltxnspans = dbg3 "alltxnspans" $ ptinterval `splitSpan` (spanDefaultsFrom ptspan requestedspan)+    -- All the date spans described by this periodic transaction rule.+    alltxnspans = splitSpan adjust ptinterval span'+      where+        -- If the PT does not specify  start or end dates, we take them from the requestedspan.+        span' = ptspan `spanDefaultsFrom` requestedspan+        -- Unless the PT specified a start date explicitly, we will adjust the start date to the previous interval boundary.+        adjust = isNothing $ spanStart span'  -- | Check that this date span begins at a boundary of this interval, -- or return an explanatory error message including the provided period expression@@ -265,7 +249,7 @@     _                    -> Nothing     where       checkStart d x =-        let firstDate = fixSmartDate d $ SmartRelative 0 x+        let firstDate = fromEFDay $ fixSmartDate d $ SmartRelative 0 x         in          if d == firstDate          then Nothing

@@ -193,6 +193,7 @@ -- if onelineamounts is true, these amounts are shown on one line, -- comma-separated, and the output will not be valid journal syntax. -- Otherwise, they are shown as several similar postings, one per commodity.+-- When the posting has a balance assertion, it is attached to the last of these postings. -- -- The output will appear to be a balanced transaction. -- Amounts' display precisions, which may have been limited by commodity@@ -243,16 +244,11 @@                               , Cell BottomLeft [assertion]                               , textCell BottomLeft samelinecomment                               ]-                    | amt <- shownAmounts]+                    | (amt,assertion) <- shownAmountsAssertions]     render = renderRow def{tableBorders=False, borderSpaces=False} . Group NoLine . map Header     pad amt = WideBuilder (TB.fromText $ T.replicate w " ") w <> amt       where w = max 12 amtwidth - wbWidth amt  -- min. 12 for backwards compatibility -    assertion = maybe mempty ((WideBuilder (TB.singleton ' ') 1 <>).showBalanceAssertion) $ pbalanceassertion p-    -- pad to the maximum account name width, plus 2 to leave room for status flags, to keep amounts aligned-    statusandaccount = lineIndent . fitText (Just $ 2 + acctwidth) Nothing False True $ pstatusandacct p-    thisacctwidth = realLength $ pacctstr p-     pacctstr p' = showAccountName Nothing (ptype p') (paccount p')     pstatusandacct p' = pstatusprefix p' <> pacctstr p'     pstatusprefix p' = case pstatus p' of@@ -267,6 +263,17 @@       | elideamount = [mempty]       | otherwise   = showMixedAmountLinesB noColour{displayOneLine=onelineamounts} $ pamount p     thisamtwidth = maximumBound 0 $ map wbWidth shownAmounts++    -- when there is a balance assertion, show it only on the last posting line+    shownAmountsAssertions = zip shownAmounts shownAssertions+      where+        shownAssertions = replicate (length shownAmounts - 1) mempty ++ [assertion]+          where+            assertion = maybe mempty ((WideBuilder (TB.singleton ' ') 1 <>).showBalanceAssertion) $ pbalanceassertion p++    -- pad to the maximum account name width, plus 2 to leave room for status flags, to keep amounts aligned+    statusandaccount = lineIndent . fitText (Just $ 2 + acctwidth) Nothing False True $ pstatusandacct p+    thisacctwidth = realLength $ pacctstr p      (samelinecomment, newlinecomments) =       case renderCommentLines (pcomment p) of []   -> ("",[])

@@ -11,6 +11,7 @@   RawOpts,   setopt,   setboolopt,+  unsetboolopt,   appendopts,   inRawOpts,   boolopt,@@ -48,6 +49,9 @@  setboolopt :: String -> RawOpts -> RawOpts setboolopt name = overRawOpts (++ [(name,"")])++unsetboolopt :: String -> RawOpts -> RawOpts+unsetboolopt name = overRawOpts (filter ((/=name).fst))  appendopts :: [(String,String)] -> RawOpts -> RawOpts appendopts new = overRawOpts (++new)

@@ -28,10 +28,11 @@ , transactionApplyValuation , transactionToCost , transactionAddInferredEquityPostings-, transactionAddPricesFromEquity+, transactionInferCostsFromEquity , transactionApplyAliases , transactionMapPostings , transactionMapPostingAmounts+, partitionAndCheckConversionPostings   -- nonzerobalanceerror   -- * date operations , transactionDate2@@ -225,107 +226,103 @@ transactionAddInferredEquityPostings equityAcct t =     t{tpostings=concatMap (postingAddInferredEquityPostings equityAcct) $ tpostings t} --- | Add inferred transaction prices from equity postings. For every adjacent--- pair of conversion postings, it will first search the postings with--- transaction prices to see if any match. If so, it will tag it as matched.--- If no postings with transaction prices match, it will then search the--- postings without transaction prices, and will match the first such posting--- which matches one of the conversion amounts. If it finds a match, it will--- add a transaction price and then tag it. type IdxPosting = (Int, Posting)-transactionAddPricesFromEquity :: M.Map AccountName AccountType -> Transaction -> Either String Transaction-transactionAddPricesFromEquity acctTypes t = first (annotateErrorWithTransaction t . T.unpack) $ do-    (conversionPairs, stateps) <- partitionPs npostings-    f <- transformIndexedPostingsF addPricesToPostings conversionPairs stateps++-- WARNING: twisty code ahead++-- | Add costs inferred from equity postings in this transaction.+-- For every adjacent pair of conversion postings, it will first search the postings+-- with costs to see if any match. If so, it will tag these as matched.+-- If no postings with costs match, it will then search the postings without costs,+-- and will match the first such posting which matches one of the conversion amounts.+-- If it finds a match, it will add a cost and then tag it.+-- If the first argument is true, do a dry run instead: identify and tag+-- the costful and conversion postings, but don't add costs.+transactionInferCostsFromEquity :: Bool -> M.Map AccountName AccountType -> Transaction -> Either String Transaction+transactionInferCostsFromEquity dryrun acctTypes t = first (annotateErrorWithTransaction t . T.unpack) $ do+    (conversionPairs, stateps) <- partitionAndCheckConversionPostings False acctTypes npostings+    f <- transformIndexedPostingsF (addCostsToPostings dryrun) conversionPairs stateps     return t{tpostings = map (snd . f) npostings}   where     -- Include indices for postings     npostings = zip [0..] $ tpostings t     transformIndexedPostingsF f = evalStateT . fmap (appEndo . foldMap Endo) . traverse f -    -- Sort postings into pairs of conversion postings, transaction price postings, and other postings-    partitionPs = fmap fst . foldrM select (([], ([], [])), Nothing)-    select np@(_, p) ((cs, others@(ps, os)), Nothing)-      | isConversion p = Right ((cs, others),      Just np)-      | hasPrice p     = Right ((cs, (np:ps, os)), Nothing)-      | otherwise      = Right ((cs, (ps, np:os)), Nothing)-    select np@(_, p) ((cs, others), Just lst)-      | isConversion p = Right (((lst, np):cs, others), Nothing)-      | otherwise      = Left "Conversion postings must occur in adjacent pairs"-     -- Given a pair of indexed conversion postings, and a state consisting of lists of-    -- priced and unpriced non-conversion postings, create a function which adds transaction-    -- prices to the posting which matches the conversion postings if necessary, and tags-    -- the conversion and matched postings. Then update the state by removing the matched-    -- postings. If there are no matching postings or too much ambiguity, return an error-    -- string annotated with the conversion postings.-    addPricesToPostings :: (IdxPosting, IdxPosting)+    -- costful and costless non-conversion postings, create a function which adds a conversion cost+    -- to the posting which matches the conversion postings if necessary,+    -- and tags the conversion and matched postings. Then update the state by removing the+    -- matched postings. If there are no matching postings or too much ambiguity,+    -- return an error string annotated with the conversion postings.+    -- If the first argument is true, do a dry run instead: identify and tag+    -- the costful and conversion postings, but don't add costs.+    addCostsToPostings :: Bool -> (IdxPosting, IdxPosting)                         -> StateT ([IdxPosting], [IdxPosting]) (Either Text) (IdxPosting -> IdxPosting)-    addPricesToPostings ((n1, cp1), (n2, cp2)) = StateT $ \(priceps, otherps) -> do+    addCostsToPostings dryrun' ((n1, cp1), (n2, cp2)) = StateT $ \(costps, otherps) -> do         -- Get the two conversion posting amounts, if possible-        ca1 <- postingAmountNoPrice cp1-        ca2 <- postingAmountNoPrice cp2-        let -- The function to add transaction prices and tag postings in the indexed list of postings-            transformPostingF np pricep (n,p) =-              (n, if | n == np            -> pricep `postingAddTags` [("_price-matched","")]-                     | n == n1 || n == n2 -> p      `postingAddTags` [("_conversion-matched","")]+        ca1 <- conversionPostingAmountNoCost cp1+        ca2 <- conversionPostingAmountNoCost cp2+        let -- The function to add costs and tag postings in the indexed list of postings+            transformPostingF np costp (n,p) =+              (n, if | n == np            -> costp `postingAddTags` [("_price-matched","")]+                     | n == n1 || n == n2 -> p     `postingAddTags` [("_conversion-matched","")]                      | otherwise          -> p)-            -- All priced postings which match the conversion posting pair-            matchingPricePs = mapMaybe (mapM $ pricedPostingIfMatchesBothAmounts ca1 ca2) priceps-            -- All other postings which match at least one of the conversion posting pair-            matchingOtherPs = mapMaybe (mapM $ addPriceIfMatchesOneAmount ca1 ca2) otherps+            -- All costful postings which match the conversion posting pair+            matchingCostPs = mapMaybe (mapM $ costfulPostingIfMatchesBothAmounts ca1 ca2) costps+            -- All other postings which match at least one of the conversion posting pair.+            -- Add a corresponding cost to these postings, unless in dry run mode.+            matchingOtherPs+              | dryrun'   = [(n,(p, a)) | (n,p) <- otherps, let Just a = postingSingleAmount p]+              | otherwise = mapMaybe (mapM $ addCostIfMatchesOneAmount ca1 ca2) otherps          -- Annotate any errors with the conversion posting pair         first (annotateWithPostings [cp1, cp2]) $-            if -- If a single transaction price posting matches the conversion postings,-               -- delete it from the list of priced postings in the state, delete the-               -- first matching unpriced posting from the list of non-priced postings+            if -- If a single costful posting matches the conversion postings,+               -- delete it from the list of costful postings in the state, delete the+               -- first matching costless posting from the list of costless postings                -- in the state, and return the transformation function with the new state.-               | [(np, (pricep, _))] <- matchingPricePs-               , Just newpriceps <- deleteIdx np priceps-                   -> Right (transformPostingF np pricep, (newpriceps, otherps))-               -- If no transaction price postings match the conversion postings, but some-               -- of the unpriced postings match, check that the first such posting has a-               -- different amount from all the others, and if so add a transaction price to-               -- it, then delete it from the list of non-priced postings in the state, and-               -- return the transformation function with the new state.-               | [] <- matchingPricePs-               , (np, (pricep, amt)):nps <- matchingOtherPs+               | [(np, (costp, _))] <- matchingCostPs+               , Just newcostps <- deleteIdx np costps+                   -> Right (transformPostingF np costp, (if dryrun' then costps else newcostps, otherps))+               -- If no costful postings match the conversion postings, but some+               -- of the costless postings match, check that the first such posting has a+               -- different amount from all the others, and if so add a cost to it,+               -- then delete it from the list of costless postings in the state,+               -- and return the transformation function with the new state.+               | [] <- matchingCostPs+               , (np, (costp, amt)):nps <- matchingOtherPs                , not $ any (amountMatches amt . snd . snd) nps                , Just newotherps <- deleteIdx np otherps-                   -> Right (transformPostingF np pricep, (priceps, newotherps))+                   -> Right (transformPostingF np costp, (costps, if dryrun' then otherps else newotherps))                -- Otherwise it's too ambiguous to make a guess, so return an error.                | otherwise -> Left "There is not a unique posting which matches the conversion posting pair:" -    -- If a posting with transaction price matches both the conversion amounts, return it along+    -- If a posting with cost matches both the conversion amounts, return it along     -- with the matching amount which must be present in another non-conversion posting.-    pricedPostingIfMatchesBothAmounts :: Amount -> Amount -> Posting -> Maybe (Posting, Amount)-    pricedPostingIfMatchesBothAmounts a1 a2 p = do+    costfulPostingIfMatchesBothAmounts :: Amount -> Amount -> Posting -> Maybe (Posting, Amount)+    costfulPostingIfMatchesBothAmounts a1 a2 p = do         a@Amount{aprice=Just _} <- postingSingleAmount p         if | amountMatches (-a1) a && amountMatches a2 (amountCost a) -> Just (p, -a2)            | amountMatches (-a2) a && amountMatches a1 (amountCost a) -> Just (p, -a1)            | otherwise -> Nothing -    -- Add a transaction price to a posting if it matches (negative) one of the-    -- supplied conversion amounts, adding the other amount as the price-    addPriceIfMatchesOneAmount :: Amount -> Amount -> Posting -> Maybe (Posting, Amount)-    addPriceIfMatchesOneAmount a1 a2 p = do+    -- Add a cost to a posting if it matches (negative) one of the+    -- supplied conversion amounts, adding the other amount as the cost.+    addCostIfMatchesOneAmount :: Amount -> Amount -> Posting -> Maybe (Posting, Amount)+    addCostIfMatchesOneAmount a1 a2 p = do         a <- postingSingleAmount p-        let newp price = p{pamount = mixedAmount a{aprice = Just $ TotalPrice price}}+        let newp cost = p{pamount = mixedAmount a{aprice = Just $ TotalPrice cost}}         if | amountMatches (-a1) a -> Just (newp a2, a2)            | amountMatches (-a2) a -> Just (newp a1, a1)            | otherwise             -> Nothing -    hasPrice p = isJust $ aprice =<< postingSingleAmount p-    postingAmountNoPrice p = case postingSingleAmount p of+    -- Get the single-commodity costless amount from a conversion posting, or raise an error.+    conversionPostingAmountNoCost p = case postingSingleAmount p of         Just a@Amount{aprice=Nothing} -> Right a-        _ -> Left $ annotateWithPostings [p] "The posting must only have a single amount with no transaction price"-    postingSingleAmount p = case amountsRaw (pamount p) of-        [a] -> Just a-        _   -> Nothing+        Just Amount{aprice=Just _} -> Left $ annotateWithPostings [p] "Conversion postings must not have a cost:"+        Nothing                    -> Left $ annotateWithPostings [p] "Conversion postings must have a single-commodity amount:"      amountMatches a b = acommodity a == acommodity b && aquantity a == aquantity b-    isConversion p = M.lookup (paccount p) acctTypes == Just Conversion      -- Delete a posting from the indexed list of postings based on either its     -- index or its posting amount.@@ -334,11 +331,37 @@     -- still be more efficient than using a Map or another data structure. Even monster     -- transactions with up to 10 postings, which are generally not a good     -- idea, are still too small for there to be an advantage.+    -- XXX shouldn't assume transactions have few postings     deleteIdx n = deleteUniqueMatch ((n==) . fst)     deleteUniqueMatch p (x:xs) | p x       = if any p xs then Nothing else Just xs                                | otherwise = (x:) <$> deleteUniqueMatch p xs     deleteUniqueMatch _ []                 = Nothing     annotateWithPostings xs str = T.unlines $ str : postingsAsLines False xs++-- Using the provided account types map, sort the given indexed postings+-- into three lists of posting numbers (stored in two pairs), like so:+-- (conversion postings, (costful postings, other postings)).+-- A true first argument activates its secondary function: check that all+-- conversion postings occur in adjacent pairs, otherwise return an error.+partitionAndCheckConversionPostings :: Bool -> M.Map AccountName AccountType -> [IdxPosting] -> Either Text ( [(IdxPosting, IdxPosting)], ([IdxPosting], [IdxPosting]) )+partitionAndCheckConversionPostings check acctTypes = fmap fst . foldrM select (([], ([], [])), Nothing)+  where+    select np@(_, p) ((cs, others@(ps, os)), Nothing)+      | isConversion p = Right ((cs, others),      Just np)+      | hasCost p      = Right ((cs, (np:ps, os)), Nothing)+      | otherwise      = Right ((cs, (ps, np:os)), Nothing)+    select np@(_, p) ((cs, others@(ps,os)), Just lst)+      | isConversion p = Right (((lst, np):cs, others), Nothing)+      | check          = Left "Conversion postings must occur in adjacent pairs"+      | otherwise      = Right ((cs, (ps, np:os)), Nothing)+    isConversion p = M.lookup (paccount p) acctTypes == Just Conversion+    hasCost p = isJust $ aprice =<< postingSingleAmount p++-- | Get a posting's amount if it is single-commodity.+postingSingleAmount :: Posting -> Maybe Amount+postingSingleAmount p = case amountsRaw (pamount p) of+  [a] -> Just a+  _   -> Nothing  -- | Apply some account aliases to all posting account names in the transaction, as described by accountNameApplyAliases. -- This can fail due to a bad replacement pattern in a regular expression alias.

@@ -1,4 +1,4 @@-{-|+  {-|  Most data types are defined here to avoid import cycles. Here is an overview of the hledger data model:@@ -82,8 +82,8 @@ -- containing the reference date. data SmartDate   = SmartCompleteDate Day-  | SmartAssumeStart Year (Maybe Month)-  | SmartFromReference (Maybe Month) MonthDay+  | SmartAssumeStart Year (Maybe Month)         -- XXX improve these constructor names+  | SmartFromReference (Maybe Month) MonthDay   --   | SmartMonth Month   | SmartRelative Integer SmartInterval   deriving (Show)@@ -92,8 +92,28 @@  data WhichDate = PrimaryDate | SecondaryDate deriving (Eq,Show) -data DateSpan = DateSpan (Maybe Day) (Maybe Day) deriving (Eq,Ord,Generic)+-- | A date which is either exact or flexible.+-- Flexible dates are allowed to be adjusted in certain situations.+data EFDay = Exact Day | Flex Day deriving (Eq,Generic,Show) +-- EFDay's Ord instance treats them like ordinary dates, ignoring exact/flexible.+instance Ord EFDay where compare d1 d2 = compare (fromEFDay d1) (fromEFDay d2)++-- instance Ord EFDay where compare = maCompare++fromEFDay :: EFDay -> Day+fromEFDay (Exact d) = d+fromEFDay (Flex  d) = d++modifyEFDay :: (Day -> Day) -> EFDay -> EFDay+modifyEFDay f (Exact d) = Exact $ f d+modifyEFDay f (Flex  d) = Flex  $ f d++-- | A possibly open-ended span of time, from an optional inclusive start date+-- to an optional exclusive end date. Each date can be either exact or flexible.+-- An "exact date span" is a Datepan with exact start and end dates.+data DateSpan = DateSpan (Maybe EFDay) (Maybe EFDay) deriving (Eq,Ord,Generic)+ instance Default DateSpan where def = DateSpan Nothing Nothing  -- Typical report periods (spans of time), both finite and open-ended.@@ -225,7 +245,7 @@  -- | An amount's per-unit or total cost/selling price in another -- commodity, as recorded in the journal entry eg with @ or @@.--- Docs call this "transaction price". The amount is always positive.+-- "Cost", formerly AKA "transaction price". The amount is always positive. data AmountPrice = UnitPrice !Amount | TotalPrice !Amount   deriving (Eq,Ord,Generic,Show) @@ -455,6 +475,7 @@       ptinterval     :: Interval, -- ^ the interval at which this transaction recurs       ptspan         :: DateSpan, -- ^ the (possibly unbounded) period during which this transaction recurs. Contains a whole number of intervals.       --+      ptsourcepos    :: (SourcePos, SourcePos),  -- ^ the file position where the period expression starts, and where the last posting ends       ptstatus       :: Status,   -- ^ some of Transaction's fields       ptcode         :: Text,       ptdescription  :: Text,@@ -467,6 +488,7 @@       ptperiodexpr   = ""      ,ptinterval     = def      ,ptspan         = def+     ,ptsourcepos    = (SourcePos "" (mkPos 1) (mkPos 1), SourcePos "" (mkPos 1) (mkPos 1))      ,ptstatus       = Unmarked      ,ptcode         = ""      ,ptdescription  = ""@@ -527,6 +549,7 @@   ,jincludefilestack      :: [FilePath]   -- principal data   ,jdeclaredpayees        :: [(Payee,PayeeDeclarationInfo)]         -- ^ Payees declared by payee directives, in parse order (after journal finalisation)+  ,jdeclaredtags          :: [(TagName,TagDeclarationInfo)]         -- ^ Tags declared by tag directives, in parse order (after journal finalisation)   ,jdeclaredaccounts      :: [(AccountName,AccountDeclarationInfo)] -- ^ Accounts declared by account directives, in parse order (after journal finalisation)   ,jdeclaredaccounttags   :: M.Map AccountName [Tag]                -- ^ Accounts which have tags declared in their directives, and those tags. (Does not include parents' tags.)   ,jdeclaredaccounttypes  :: M.Map AccountType [AccountName]        -- ^ Accounts whose type has been explicitly declared in their account directives, grouped by type.@@ -567,6 +590,15 @@ nullpayeedeclarationinfo = PayeeDeclarationInfo {    pdicomment          = ""   ,pditags             = []+}++-- | Extra information found in a tag directive.+newtype TagDeclarationInfo = TagDeclarationInfo {+   tdicomment :: Text   -- ^ any comment lines following the tag directive. No tags allowed here.+} deriving (Eq,Show,Generic)++nulltagdeclarationinfo = TagDeclarationInfo {+   tdicomment          = "" }  -- | Extra information about an account that can be derived from

@@ -571,8 +571,8 @@ queryStartDate :: Bool -> Query -> Maybe Day queryStartDate secondary (Or ms) = earliestMaybeDate $ map (queryStartDate secondary) ms queryStartDate secondary (And ms) = latestMaybeDate $ map (queryStartDate secondary) ms-queryStartDate False (Date (DateSpan (Just d) _)) = Just d-queryStartDate True (Date2 (DateSpan (Just d) _)) = Just d+queryStartDate False (Date (DateSpan (Just d) _)) = Just $ fromEFDay d+queryStartDate True (Date2 (DateSpan (Just d) _)) = Just $ fromEFDay d queryStartDate _ _ = Nothing  -- | What end date (or secondary date) does this query specify, if any ?@@ -580,8 +580,8 @@ queryEndDate :: Bool -> Query -> Maybe Day queryEndDate secondary (Or ms) = latestMaybeDate' $ map (queryEndDate secondary) ms queryEndDate secondary (And ms) = earliestMaybeDate' $ map (queryEndDate secondary) ms-queryEndDate False (Date (DateSpan _ (Just d))) = Just d-queryEndDate True (Date2 (DateSpan _ (Just d))) = Just d+queryEndDate False (Date (DateSpan _ (Just d))) = Just $ fromEFDay d+queryEndDate True (Date2 (DateSpan _ (Just d))) = Just $ fromEFDay d queryEndDate _ _ = Nothing  queryTermDateSpan (Date spn) = Just spn@@ -835,8 +835,8 @@      (simplifyQuery $ And [Any,Any])      @?= (Any)      (simplifyQuery $ And [Acct $ toRegex' "b",Any]) @?= (Acct $ toRegex' "b")      (simplifyQuery $ And [Any,And [Date (DateSpan Nothing Nothing)]]) @?= (Any)-     (simplifyQuery $ And [Date (DateSpan Nothing (Just $ fromGregorian 2013 01 01)), Date (DateSpan (Just $ fromGregorian 2012 01 01) Nothing)])-       @?= (Date (DateSpan (Just $ fromGregorian 2012 01 01) (Just $ fromGregorian 2013 01 01)))+     (simplifyQuery $ And [Date (DateSpan Nothing (Just $ Exact $ fromGregorian 2013 01 01)), Date (DateSpan (Just $ Exact $ fromGregorian 2012 01 01) Nothing)])+       @?= (Date (DateSpan (Just $ Exact $ fromGregorian 2012 01 01) (Just $ Exact $ fromGregorian 2013 01 01)))      (simplifyQuery $ And [Or [],Or [Desc $ toRegex' "b b"]]) @?= (Desc $ toRegex' "b b")    ,testCase "parseQuery" $ do@@ -875,9 +875,9 @@      parseQueryTerm nulldate "payee:x"                          @?= Left <$> payeeTag (Just "x")      parseQueryTerm nulldate "note:x"                           @?= Left <$> noteTag (Just "x")      parseQueryTerm nulldate "real:1"                           @?= Right (Left $ Real True)-     parseQueryTerm nulldate "date:2008"                        @?= Right (Left $ Date $ DateSpan (Just $ fromGregorian 2008 01 01) (Just $ fromGregorian 2009 01 01))-     parseQueryTerm nulldate "date:from 2012/5/17"              @?= Right (Left $ Date $ DateSpan (Just $ fromGregorian 2012 05 17) Nothing)-     parseQueryTerm nulldate "date:20180101-201804"             @?= Right (Left $ Date $ DateSpan (Just $ fromGregorian 2018 01 01) (Just $ fromGregorian 2018 04 01))+     parseQueryTerm nulldate "date:2008"                        @?= Right (Left $ Date $ DateSpan (Just $ Flex $ fromGregorian 2008 01 01) (Just $ Flex $ fromGregorian 2009 01 01))+     parseQueryTerm nulldate "date:from 2012/5/17"              @?= Right (Left $ Date $ DateSpan (Just $ Exact $ fromGregorian 2012 05 17) Nothing)+     parseQueryTerm nulldate "date:20180101-201804"             @?= Right (Left $ Date $ DateSpan (Just $ Exact $ fromGregorian 2018 01 01) (Just $ Flex $ fromGregorian 2018 04 01))      parseQueryTerm nulldate "inacct:a"                         @?= Right (Right $ QueryOptInAcct "a")      parseQueryTerm nulldate "tag:a"                            @?= Right (Left $ Tag (toRegexCI' "a") Nothing)      parseQueryTerm nulldate "tag:a=some value"                 @?= Right (Left $ Tag (toRegexCI' "a") (Just $ toRegexCI' "some value"))@@ -899,18 +899,18 @@   ,testCase "queryStartDate" $ do      let small = Just $ fromGregorian 2000 01 01          big   = Just $ fromGregorian 2000 01 02-     queryStartDate False (And [Date $ DateSpan small Nothing, Date $ DateSpan big Nothing])     @?= big-     queryStartDate False (And [Date $ DateSpan small Nothing, Date $ DateSpan Nothing Nothing]) @?= small-     queryStartDate False (Or  [Date $ DateSpan small Nothing, Date $ DateSpan big Nothing])     @?= small-     queryStartDate False (Or  [Date $ DateSpan small Nothing, Date $ DateSpan Nothing Nothing]) @?= Nothing+     queryStartDate False (And [Date $ DateSpan (Exact <$> small) Nothing, Date $ DateSpan (Exact <$> big) Nothing]) @?= big+     queryStartDate False (And [Date $ DateSpan (Exact <$> small) Nothing, Date $ DateSpan Nothing Nothing])         @?= small+     queryStartDate False (Or  [Date $ DateSpan (Exact <$> small) Nothing, Date $ DateSpan (Exact <$> big) Nothing]) @?= small+     queryStartDate False (Or  [Date $ DateSpan (Exact <$> small) Nothing, Date $ DateSpan Nothing Nothing])         @?= Nothing    ,testCase "queryEndDate" $ do      let small = Just $ fromGregorian 2000 01 01          big   = Just $ fromGregorian 2000 01 02-     queryEndDate False (And [Date $ DateSpan Nothing small, Date $ DateSpan Nothing big])     @?= small-     queryEndDate False (And [Date $ DateSpan Nothing small, Date $ DateSpan Nothing Nothing]) @?= small-     queryEndDate False (Or  [Date $ DateSpan Nothing small, Date $ DateSpan Nothing big])     @?= big-     queryEndDate False (Or  [Date $ DateSpan Nothing small, Date $ DateSpan Nothing Nothing]) @?= Nothing+     queryEndDate False (And [Date $ DateSpan Nothing (Exact <$> small), Date $ DateSpan Nothing (Exact <$> big)]) @?= small+     queryEndDate False (And [Date $ DateSpan Nothing (Exact <$> small), Date $ DateSpan Nothing Nothing])         @?= small+     queryEndDate False (Or  [Date $ DateSpan Nothing (Exact <$> small), Date $ DateSpan Nothing (Exact <$> big)]) @?= big+     queryEndDate False (Or  [Date $ DateSpan Nothing (Exact <$> small), Date $ DateSpan Nothing Nothing])         @?= Nothing    ,testCase "matchesAccount" $ do      assertBool "" $ (Acct $ toRegex' "b:c") `matchesAccount` "a:bb:c:d"

@@ -76,11 +76,11 @@   -- ** amounts   spaceandamountormissingp,   amountp,-  amountpwithmultiplier,+  amountp',   commoditysymbolp,-  priceamountp,+  costp,   balanceassertionp,-  lotpricep,+  lotcostp,   numberp,   fromRawNumber,   rawnumberp,@@ -133,24 +133,25 @@ import Data.Maybe (catMaybes, fromMaybe, isJust, listToMaybe) import qualified Data.Map as M import qualified Data.Semigroup as Sem-import Data.Text (Text)+import Data.Text (Text, stripEnd) import qualified Data.Text as T import Data.Time.Calendar (Day, fromGregorianValid, toGregorian) import Data.Time.Clock.POSIX (getPOSIXTime) import Data.Time.LocalTime (LocalTime(..), TimeOfDay(..)) import Data.Word (Word8)+import System.FilePath (takeFileName) 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) import Hledger.Reports.ReportOptions (ReportOpts(..), queryFromFlags, rawOptsToReportOpts) import Hledger.Utils import Hledger.Read.InputOptions-import System.FilePath (takeFileName)  --- ** doctest setup -- $setup@@ -189,7 +190,7 @@ rawOptsToInputOpts :: Day -> RawOpts -> InputOpts rawOptsToInputOpts day rawopts = -    let noinferprice = boolopt "strict" rawopts || stringopt "args" rawopts == "balancednoautoconversion"+    let noinferbalancingcosts = boolopt "strict" rawopts || stringopt "args" rawopts == "balancednoautoconversion"          -- Do we really need to do all this work just to get the requested end date? This is duplicating         -- much of reportOptsToSpec.@@ -210,14 +211,14 @@       ,new_save_          = True       ,pivot_             = stringopt "pivot" rawopts       ,forecast_          = forecastPeriodFromRawOpts day rawopts-      ,reportspan_        = DateSpan (queryStartDate False datequery) (queryEndDate False datequery)+      ,reportspan_        = DateSpan (Exact <$> queryStartDate False datequery) (Exact <$> queryEndDate False datequery)       ,auto_              = boolopt "auto" rawopts       ,infer_equity_      = boolopt "infer-equity" rawopts && conversionop_ ropts /= Just ToCost       ,infer_costs_       = boolopt "infer-costs" rawopts       ,balancingopts_     = defbalancingopts{-                                 ignore_assertions_ = boolopt "ignore-assertions" rawopts-                               , infer_transaction_prices_ = not noinferprice-                               , commodity_styles_  = Just styles+                                 ignore_assertions_     = boolopt "ignore-assertions" rawopts+                               , infer_balancing_costs_ = not noinferbalancingcosts+                               , commodity_styles_      = Just styles                                }       ,strict_            = boolopt "strict" rawopts       ,_ioDay             = day@@ -323,9 +324,11 @@       >>= (if auto_ && not (null $ jtxnmodifiers pj)               then journalAddAutoPostings _ioDay balancingopts_  -- Add auto postings if enabled, and account tags if needed               else pure)-      >>= (if infer_costs_  then journalAddPricesFromEquity else pure)      -- Add inferred transaction prices from equity postings, if present+      -- >>= Right . dbg0With (concatMap (T.unpack.showTransaction).jtxns)  -- debug+      >>= journalMarkRedundantCosts                      -- Mark redundant costs, to help journalBalanceTransactions ignore them       >>= journalBalanceTransactions balancingopts_                         -- Balance all transactions and maybe check balance assertions.-      <&> (if infer_equity_ then journalAddInferredEquityPostings else id)  -- Add inferred equity postings, after balancing and generating auto postings+      >>= (if infer_costs_  then journalInferCostsFromEquity else pure)     -- Maybe infer costs from equity postings where possible+      <&> (if infer_equity_ then journalAddInferredEquityPostings else id)  -- Maybe infer equity postings from costs where possible       <&> journalInferMarketPricesFromTransactions       -- infer market prices from commodity-exchanging transactions       <&> traceOrLogAt 6 ("journalFinalise: " <> takeFileName f)  -- debug logging       <&> dbgJournalAcctDeclOrder ("journalFinalise: " <> takeFileName f <> "   acct decls           : ")@@ -334,6 +337,9 @@     when strict_ $ do       journalCheckAccounts j                     -- If in strict mode, check all postings are to declared accounts       journalCheckCommodities j                  -- and using declared commodities+      -- journalCheckPairedConversionPostings j     -- check conversion postings are in adjacent pairs+                                                    -- disabled for now, single conversion postings are sometimes needed eg with paypal+     return j  -- | Apply any auto posting rules to generate extra postings on this journal's transactions.@@ -675,21 +681,47 @@  --- *** amounts --- | Parse whitespace then an amount, with an optional left or right--- currency symbol and optional price, or return the special--- "missing" marker amount.+-- | Parse whitespace then an amount, or return the special "missing" marker amount. spaceandamountormissingp :: JournalParser m MixedAmount spaceandamountormissingp =   option missingmixedamt $ try $ do     lift $ skipNonNewlineSpaces1     mixedAmount <$> amountp --- | Parse a single-commodity amount, with optional symbol on the left--- or right, followed by, in any order: an optional transaction price,--- an optional ledger-style lot price, and/or an optional ledger-style--- lot date. A lot price and lot date will be ignored.+-- | Parse a single-commodity amount, applying the default commodity if there is no commodity symbol;+-- optionally followed by, in any order:+-- a Ledger-style cost, Ledger-style valuation expression, and/or Ledger-style cost basis, which is one or more of+-- lot cost, lot date, and/or lot note (we loosely call this triple the lot's cost basis).+-- The cost basis makes it a lot rather than just an amount. Both cost basis info and valuation expression+-- are discarded for now.+-- The main amount's sign is significant; here are the possibilities and their interpretation.+-- Also imagine an optional VALUATIONEXPR added to any of these (omitted for clarity):+-- @ ----- To parse the amount's quantity (number) we need to know which character +--   AMT                         -- acquiring an amount+--   AMT COST                    -- acquiring an amount at some cost+--   AMT COST COSTBASIS          -- acquiring a lot at some cost, saving its cost basis+--   AMT COSTBASIS COST          -- like the above+--   AMT COSTBASIS               -- like the above with cost same as the cost basis+--+--  -AMT                         -- releasing an amount+--  -AMT SELLPRICE               -- releasing an amount at some selling price+--  -AMT SELLPRICE COSTBASISSEL  -- releasing a lot at some selling price, selecting it by its cost basis+--  -AMT COSTBASISSEL SELLPRICE  -- like the above+--  -AMT COSTBASISSEL            -- like the above with selling price same as the selected lot's cost basis amount+--+-- COST/SELLPRICE can be @ UNITAMT, @@ TOTALAMT, (@) UNITAMT, or (@@) TOTALAMT. The () are ignored.+-- COSTBASIS    is one or more of {LOTCOST}, [LOTDATE], (LOTNOTE), in any order, with LOTCOST defaulting to COST.+-- COSTBASISSEL is one or more of {LOTCOST}, [LOTDATE], (LOTNOTE), in any order.+-- {LOTCOST} can be {UNITAMT}, {{TOTALAMT}}, {=UNITAMT}, or {{=TOTALAMT}}. The = is ignored.+-- VALUATIONEXPR can be ((VALUE AMOUNT)) or ((VALUE FUNCTION)).+--+-- @+-- Ledger amount syntax is really complex.+-- Rule of thumb: curly braces, parentheses, and/or square brackets+-- in an amount means a Ledger-style cost basis is involved.+--+-- To parse an amount's numeric quantity we need to know which character  -- represents a decimal mark. We find it in one of three ways: -- -- 1. If a decimal mark has been set explicitly in the journal parse state, @@ -700,38 +732,54 @@ -- -- 3. Otherwise we will parse any valid decimal mark appearing in the --    number, as long as the number appears well formed.+--    (This means we handle files with any supported decimal mark without configuration,+--    but it also allows different decimal marks in  different amounts,+--    which is a bit too loose. There's an open issue.) ----- Note 3 is the default zero-config case; it means we automatically handle--- files with any supported decimal mark, but it also allows different decimal marks--- in  different amounts, which is a bit too loose. There's an open issue. amountp :: JournalParser m Amount-amountp = amountpwithmultiplier False+amountp = amountp' False -amountpwithmultiplier :: Bool -> JournalParser m Amount-amountpwithmultiplier mult = label "amount" $ do+-- An amount with optional cost, valuation, and/or cost basis, as described above.+-- A flag indicates whether we are parsing a multiplier amount;+-- if not, a commodity-less amount will have the default commodity applied to it.+amountp' :: Bool -> JournalParser m Amount+amountp' mult =+  -- dbg "amountp'" $ +  label "amount" $ do   let spaces = lift $ skipNonNewlineSpaces-  amt <- amountwithoutpricep mult <* spaces-  (mprice, _elotprice, _elotdate) <- runPermutation $-    (,,) <$> toPermutationWithDefault Nothing (Just <$> priceamountp amt <* spaces)-         <*> toPermutationWithDefault Nothing (Just <$> lotpricep <* spaces)-         <*> toPermutationWithDefault Nothing (Just <$> lotdatep <* spaces)-  pure $ amt { aprice = mprice }+  amt <- simpleamountp mult <* spaces+  (mcost, _valuationexpr, _mlotcost, _mlotdate, _mlotnote) <- runPermutation $+    -- costp, valuationexprp, lotnotep all parse things beginning with parenthesis, try needed+    (,,,,) <$> toPermutationWithDefault Nothing (Just <$> try (costp amt) <* spaces)+          <*> toPermutationWithDefault Nothing (Just <$> valuationexprp <* spaces)  -- XXX no try needed here ?+          <*> toPermutationWithDefault Nothing (Just <$> lotcostp <* spaces)+          <*> toPermutationWithDefault Nothing (Just <$> lotdatep <* spaces)+          <*> toPermutationWithDefault Nothing (Just <$> lotnotep <* spaces)+  pure $ amt { aprice = mcost } -amountpnolotpricesp :: JournalParser m Amount-amountpnolotpricesp = label "amount" $ do+-- An amount with optional cost, but no cost basis.+amountnobasisp :: JournalParser m Amount+amountnobasisp =+  -- dbg "amountnobasisp" $ +  label "amount" $ do   let spaces = lift $ skipNonNewlineSpaces-  amt <- amountwithoutpricep False+  amt <- simpleamountp False   spaces-  mprice <- optional $ priceamountp amt <* spaces+  mprice <- optional $ costp amt <* spaces   pure $ amt { aprice = mprice } -amountwithoutpricep :: Bool -> JournalParser m Amount-amountwithoutpricep mult = do+-- An amount with no cost or cost basis.+-- A flag indicates whether we are parsing a multiplier amount;+-- if not, a commodity-less amount will have the default commodity applied to it.+simpleamountp :: Bool -> JournalParser m Amount+simpleamountp mult = +  -- dbg "simpleamountp" $+  do   sign <- lift signp   leftsymbolamountp sign <|> rightornosymbolamountp sign    where-+  -- An amount with commodity symbol on the left.   leftsymbolamountp :: (Decimal -> Decimal) -> JournalParser m Amount   leftsymbolamountp sign = label "amount" $ do     c <- lift commoditysymbolp@@ -750,6 +798,9 @@     let s = amountstyle{ascommodityside=L, ascommodityspaced=commodityspaced, asprecision=prec, asdecimalpoint=mdec, asdigitgroups=mgrps}     return nullamt{acommodity=c, aquantity=sign (sign2 q), astyle=s, aprice=Nothing} +  -- An amount with commodity symbol on the right or no commodity symbol.+  -- A no-symbol amount will have the default commodity applied to it+  -- unless we are parsing a multiplier amount (*AMT).   rightornosymbolamountp :: (Decimal -> Decimal) -> JournalParser m Amount   rightornosymbolamountp sign = label "amount" $ do     offBeforeNum <- getOffset@@ -831,14 +882,18 @@  quotedcommoditysymbolp :: TextParser m CommoditySymbol quotedcommoditysymbolp =-  between (char '"') (char '"') $ takeWhile1P Nothing f+  between (char '"') (char '"') $ takeWhileP Nothing f   where f c = c /= ';' && c /= '\n' && c /= '\"'  simplecommoditysymbolp :: TextParser m CommoditySymbol simplecommoditysymbolp = takeWhile1P Nothing (not . isNonsimpleCommodityChar) -priceamountp :: Amount -> JournalParser m AmountPrice-priceamountp baseAmt = label "transaction price" $ do+-- | Ledger-style cost notation:+-- @ UNITAMT, @@ TOTALAMT, (@) UNITAMT, or (@@) TOTALAMT. The () are ignored.+costp :: Amount -> JournalParser m AmountPrice+costp baseAmt =+  -- dbg "costp" $+  label "transaction price" $ do   -- https://www.ledger-cli.org/3.0/doc/ledger3.html#Virtual-posting-costs   parenthesised <- option False $ char '(' >> pure True   char '@'@@ -846,7 +901,7 @@   when parenthesised $ void $ char ')'    lift skipNonNewlineSpaces-  priceAmount <- amountwithoutpricep False -- <?> "unpriced amount (specifying a price)"+  priceAmount <- simpleamountp False -- <?> "unpriced amount (specifying a price)"    let amtsign' = signum $ aquantity baseAmt       amtsign  = if amtsign' == 0 then 1 else amtsign'@@ -855,6 +910,15 @@             then TotalPrice priceAmount{aquantity=amtsign * aquantity priceAmount}             else UnitPrice  priceAmount +-- | A valuation function or value can be written in double parentheses after an amount.+valuationexprp :: JournalParser m ()+valuationexprp =+  -- dbg "valuationexprp" $+  label "valuation expression" $ do+  string "(("+  _ <- T.strip . T.pack <$> (many $ noneOf [')','\n'])  -- XXX other line endings ?+  string "))"+  return ()  balanceassertionp :: JournalParser m BalanceAssertion balanceassertionp = do@@ -863,9 +927,9 @@   istotal <- fmap isJust $ optional $ try $ char '='   isinclusive <- fmap isJust $ optional $ try $ char '*'   lift skipNonNewlineSpaces-  -- this amount can have a price; balance assertions ignore it,-  -- but balance assignments will use it-  a <- amountpnolotpricesp <?> "amount (for a balance assertion or assignment)"+  -- this amount can have a cost, but not a cost basis.+  -- balance assertions ignore it, but balance assignments will use it+  a <- amountnobasisp <?> "amount (for a balance assertion or assignment)"   return BalanceAssertion     { baamount    = a     , batotal     = istotal@@ -873,32 +937,44 @@     , baposition  = sourcepos     } --- Parse a Ledger-style fixed {=UNITPRICE} or non-fixed {UNITPRICE}--- or fixed {{=TOTALPRICE}} or non-fixed {{TOTALPRICE}} lot price,--- and ignore it.--- https://www.ledger-cli.org/3.0/doc/ledger3.html#Fixing-Lot-Prices .-lotpricep :: JournalParser m ()-lotpricep = label "ledger-style lot price" $ do+-- Parse a Ledger-style lot cost,+-- {UNITCOST} or {{TOTALCOST}} or {=FIXEDUNITCOST} or {{=FIXEDTOTALCOST}},+-- and discard it.+lotcostp :: JournalParser m ()+lotcostp =+  -- dbg "lotcostp" $+  label "ledger-style lot cost" $ do   char '{'   doublebrace <- option False $ char '{' >> pure True   _fixed <- fmap isJust $ optional $ lift skipNonNewlineSpaces >> char '='   lift skipNonNewlineSpaces-  _a <- amountwithoutpricep False+  _a <- simpleamountp False   lift skipNonNewlineSpaces   char '}'   when (doublebrace) $ void $ char '}' --- Parse a Ledger-style lot date [DATE], and ignore it.--- https://www.ledger-cli.org/3.0/doc/ledger3.html#Fixing-Lot-Prices .+-- Parse a Ledger-style [LOTDATE], and discard it. lotdatep :: JournalParser m ()-lotdatep = (do+lotdatep =+  -- dbg "lotdatep" $+  label "ledger-style lot date" $ do   char '['   lift skipNonNewlineSpaces   _d <- datep   lift skipNonNewlineSpaces   char ']'   return ()-  ) <?> "ledger-style lot date"++-- Parse a Ledger-style (LOT NOTE), and discard it.+lotnotep :: JournalParser m ()+lotnotep =+  -- dbg "lotnotep" $+  label "ledger-style lot note" $ do+  char '('+  lift skipNonNewlineSpaces+  _note <- stripEnd . T.pack <$> (many $ noneOf [')','\n'])  -- XXX other line endings ?+  char ')'+  return ()  -- | Parse a string representation of a number for its value and display -- attributes.

@@ -73,7 +73,7 @@  import Hledger.Data import Hledger.Utils-import Hledger.Read.Common (aliasesFromOpts, Reader(..), InputOpts(..), amountp, statusp, journalFinalise )+import Hledger.Read.Common (aliasesFromOpts, Reader(..), InputOpts(..), amountp, statusp, journalFinalise, accountnamep )  --- ** doctest setup -- $setup@@ -134,7 +134,7 @@ defaultRulesText :: FilePath -> Text defaultRulesText csvfile = T.pack $ unlines   ["# hledger csv conversion rules for " ++ csvFileFor (takeFileName csvfile)-  ,"# cf http://hledger.org/manual#csv-files"+  ,"# cf http://hledger.org/hledger.html#csv"   ,""   ,"account1 assets:bank:checking"   ,""@@ -400,7 +400,7 @@  COMMENT: SPACE? COMMENT-CHAR VALUE -COMMENT-CHAR: # | ;+COMMENT-CHAR: # | ; | *  NONSPACE: any CHAR not a SPACE-CHAR @@ -699,12 +699,6 @@     rules <- liftEither $ parseAndValidateCsvRules rulesfile rulestext     dbg6IO "csv rules" rules -    -- parse the skip directive's value, if any-    skiplines <- case getDirective "skip" rules of-                      Nothing -> return 0-                      Just "" -> return 1-                      Just s  -> maybe (throwError $ "could not parse skip value: " ++ show s) return . readMay $ T.unpack s-     mtzin <- case getDirective "timezone" rules of               Nothing -> return Nothing               Just s  ->@@ -712,6 +706,13 @@                 parseTimeM False defaultTimeLocale "%Z" $ T.unpack s     tzout <- liftIO getCurrentTimeZone +    -- skip header lines, if there is a top-level skip rule+    skiplines <- case getDirective "skip" rules of+                      Nothing -> return 0+                      Just "" -> return 1+                      Just s  -> maybe (throwError $ "could not parse skip value: " ++ show s) return . readMay $ T.unpack s+    let csvdata' = T.unlines $ drop skiplines $ T.lines csvdata+     -- parse csv     let       -- parsec seems to fail if you pass it "-" here TODO: try again with megaparsec@@ -725,8 +726,8 @@           where             ext = map toLower $ drop 1 $ takeExtension csvfile     dbg6IO "using separator" separator-    csv <- dbg7 "parseCsv" <$> parseCsv separator parsecfilename csvdata-    records <- liftEither $ dbg7 "validateCsv" <$> validateCsv rules skiplines csv+    csv <- dbg7 "parseCsv" <$> parseCsv separator parsecfilename csvdata'+    records <- liftEither $ dbg7 "validateCsv" <$> validateCsv rules csv     dbg6IO "first 3 csv records" $ take 3 records      -- identify header lines@@ -818,8 +819,8 @@           printField = wrap "\"" "\"" . T.replace "\"" "\"\""  -- | Return the cleaned up and validated CSV data (can be empty), or an error.-validateCsv :: CsvRules -> Int -> CSV -> Either String [CsvRecord]-validateCsv rules numhdrlines = validate . applyConditionalSkips . drop numhdrlines . filternulls+validateCsv :: CsvRules -> CSV -> Either String [CsvRecord]+validateCsv rules = validate . applyConditionalSkips . filternulls   where     filternulls = filter (/=[""])     skipnum r =@@ -1198,7 +1199,12 @@     -- accountN is set to the empty string - no posting will be generated     Just "" -> Nothing     -- accountN is set (possibly to "expenses:unknown"! #1192) - mark it final-    Just a  -> Just (a, True)+    Just a  ->+      -- Check it and reject if invalid.. sometimes people try+      -- to set an amount or comment along with the account name.+      case parsewith (accountnamep >> eof) a of+        Left e  -> usageError $ errorBundlePretty e+        Right _ -> Just (a, True)     -- accountN is unset     Nothing ->       case (mamount, mbalance) of

@@ -35,9 +35,9 @@     ,pivot_             :: String               -- ^ use the given field's value as the account name     ,forecast_          :: Maybe DateSpan       -- ^ span in which to generate forecast transactions     ,reportspan_        :: DateSpan             -- ^ a dirty hack keeping the query dates in InputOpts. This rightfully lives in ReportSpec, but is duplicated here.-    ,auto_              :: Bool                 -- ^ generate automatic postings when journal is parsed-    ,infer_equity_      :: Bool                 -- ^ generate automatic equity postings from transaction prices-    ,infer_costs_       :: Bool                 -- ^ infer transaction prices from equity conversion postings+    ,auto_              :: Bool                 -- ^ generate automatic postings when journal is parsed ?+    ,infer_equity_      :: Bool                 -- ^ infer equity conversion postings from costs ?+    ,infer_costs_       :: Bool                 -- ^ infer costs from equity conversion postings ? distinct from BalancingOpts{infer_balancing_costs_}     ,balancingopts_     :: BalancingOpts        -- ^ options for balancing transactions     ,strict_            :: Bool                 -- ^ do extra error checking (eg, all posted accounts are declared, no prices are inferred)     ,_ioDay             :: Day                  -- ^ today's date, for use with forecast transactions  XXX this duplicates _rsDay, and should eventually be removed when it's not needed anymore.@@ -76,11 +76,11 @@ forecastPeriod :: InputOpts -> Journal -> Maybe DateSpan forecastPeriod iopts j = do     DateSpan requestedStart requestedEnd <- forecast_ iopts-    let forecastStart = requestedStart <|> max mjournalend reportStart <|> Just (_ioDay iopts)-        forecastEnd   = requestedEnd <|> reportEnd <|> Just (addDays 180 $ _ioDay iopts)+    let forecastStart = fromEFDay <$> requestedStart <|> max mjournalend (fromEFDay <$> reportStart) <|> Just (_ioDay iopts)+        forecastEnd   = fromEFDay <$> requestedEnd <|> fromEFDay <$> reportEnd <|> (Just $ addDays 180 $ _ioDay iopts)         mjournalend   = dbg2 "journalEndDate" $ journalEndDate False j  -- ignore secondary dates         DateSpan reportStart reportEnd = reportspan_ iopts-    return . dbg2 "forecastspan" $ DateSpan forecastStart forecastEnd+    return . dbg2 "forecastspan" $ DateSpan (Exact <$> forecastStart) (Exact <$> forecastEnd)  -- ** Lenses 

@@ -4,7 +4,7 @@ {-|  A reader for hledger's journal file format-(<http://hledger.org/MANUAL.html#the-journal-file>).  hledger's journal+(<http://hledger.org/hledger.html#the-journal-file>).  hledger's journal format is a compatible subset of c++ ledger's (<http://ledger-cli.org/3.0/doc/ledger3.html#Journal-Format>), so this reader should handle many ledger files as well. Example:@@ -79,7 +79,7 @@ import Control.Monad.State.Strict (evalStateT,get,modify',put) import Control.Monad.Trans.Class (lift) import Data.Char (toLower)-import Data.Either (isRight)+import Data.Either (isRight, lefts) import qualified Data.Map.Strict as M import Data.Text (Text) import Data.String@@ -226,27 +226,42 @@ --- *** directives  -- | Parse any journal directive and update the parse state accordingly.--- Cf http://hledger.org/manual.html#directives,+-- Cf http://hledger.org/hledger.html#directives, -- http://ledger-cli.org/3.0/doc/ledger3.html#Command-Directives directivep :: MonadIO m => ErroringJournalParser m () directivep = (do-  optional $ char '!'+  optional $ oneOf ['!','@']   choice [     includedirectivep    ,aliasdirectivep    ,endaliasesdirectivep    ,accountdirectivep    ,applyaccountdirectivep+   ,applyfixeddirectivep+   ,applytagdirectivep+   ,assertdirectivep+   ,bucketdirectivep+   ,capturedirectivep+   ,checkdirectivep+   ,commandlineflagdirectivep    ,commoditydirectivep-   ,endapplyaccountdirectivep-   ,payeedirectivep-   ,tagdirectivep-   ,endtagdirectivep+   ,commodityconversiondirectivep+   ,decimalmarkdirectivep    ,defaultyeardirectivep    ,defaultcommoditydirectivep-   ,commodityconversiondirectivep+   ,definedirectivep+   ,endapplyaccountdirectivep+   ,endapplyfixeddirectivep+   ,endapplytagdirectivep+   ,endapplyyeardirectivep+   ,endtagdirectivep+   ,evaldirectivep+   ,exprdirectivep    ,ignoredpricecommoditydirectivep-   ,decimalmarkdirectivep+   ,payeedirectivep+   ,pythondirectivep+   ,tagdirectivep+   ,valuedirectivep    ]   ) <?> "directive" @@ -366,7 +381,8 @@   lift skipNonNewlineSpaces1    -- the account name, possibly modified by preceding alias or apply account directives-  acct <- modifiedaccountnamep+  acct <- (notFollowedBy (char '(' <|> char '[') <?> "account name without brackets") >>+          modifiedaccountnamep    -- maybe a comment, on this and/or following lines   (cmt, tags) <- lift transactioncommentp@@ -438,6 +454,13 @@                     ,pditags    = tags                     }) +-- Add a tag declaration to the journal.+addTagDeclaration :: (TagName,Text) -> JournalParser m ()+addTagDeclaration (t, cmt) =+  modify' (\j@Journal{jdeclaredtags} -> j{jdeclaredtags=tagandinfo:jdeclaredtags})+  where+    tagandinfo = (t, nulltagdeclarationinfo{tdicomment=cmt})+ indentedlinep :: JournalParser m String indentedlinep = lift skipNonNewlineSpaces1 >> (rstrip <$> lift restofline) @@ -489,7 +512,9 @@   lift skipNonNewlineSpaces1   sym <- lift commoditysymbolp   _ <- lift followingcommentp-  mfmt <- lastMay <$> many (indented $ formatdirectivep sym)+  -- read all subdirectives, saving format subdirectives as Lefts+  subdirectives <- many $ indented (eitherP (formatdirectivep sym) (lift restofline))+  let mfmt = lastMay $ lefts subdirectives   let comm = Commodity{csymbol=sym, cformat=mfmt}   modify' (\j -> j{jcommodities=M.insert sym comm $ jcommodities j})   where@@ -512,6 +537,35 @@     else customFailure $ parseErrorAt off $          printf "commodity directive symbol \"%s\" and format directive symbol \"%s\" should be the same" expectedsym acommodity +-- More Ledger directives, ignore for now:+-- apply fixed, apply tag, assert, bucket, A, capture, check, define, expr+applyfixeddirectivep, endapplyfixeddirectivep, applytagdirectivep, endapplytagdirectivep,+  assertdirectivep, bucketdirectivep, capturedirectivep, checkdirectivep, +  endapplyyeardirectivep, definedirectivep, exprdirectivep, valuedirectivep,+  evaldirectivep, pythondirectivep, commandlineflagdirectivep+  :: JournalParser m ()+applyfixeddirectivep    = do string "apply fixed" >> lift restofline >> return ()+endapplyfixeddirectivep = do string "end apply fixed" >> lift restofline >> return ()+applytagdirectivep      = do string "apply tag" >> lift restofline >> return ()+endapplytagdirectivep   = do string "end apply tag" >> lift restofline >> return ()+endapplyyeardirectivep  = do string "end apply year" >> lift restofline >> return ()+assertdirectivep        = do string "assert"  >> lift restofline >> return ()+bucketdirectivep        = do string "A " <|> string "bucket " >> lift restofline >> return ()+capturedirectivep       = do string "capture" >> lift restofline >> return ()+checkdirectivep         = do string "check"   >> lift restofline >> return ()+definedirectivep        = do string "define"  >> lift restofline >> return ()+exprdirectivep          = do string "expr"    >> lift restofline >> return ()+valuedirectivep         = do string "value"   >> lift restofline >> return ()+evaldirectivep          = do string "eval"   >> lift restofline >> return ()+commandlineflagdirectivep = do string "--" >> lift restofline >> return ()+pythondirectivep = do+  string "python" >> lift restofline+  many $ indentedline <|> blankline+  return ()+  where+    indentedline = lift skipNonNewlineSpaces1 >> lift restofline+    blankline = lift skipNonNewlineSpaces >> newline >> return "" <?> "blank line"+ keywordp :: String -> JournalParser m () keywordp = void . string . fromString @@ -551,15 +605,23 @@ tagdirectivep = do   string "tag" <?> "tag directive"   lift skipNonNewlineSpaces1-  _ <- lift $ some nonspace-  lift restofline+  tagname <- lift $ T.pack <$> some nonspace+  (comment, _) <- lift transactioncommentp+  skipMany indentedlinep+  addTagDeclaration (tagname,comment)   return () +-- end tag or end apply tag endtagdirectivep :: JournalParser m ()-endtagdirectivep = do-  (keywordsp "end tag" <|> keywordp "pop") <?> "end tag or pop directive"-  lift restofline+endtagdirectivep = (do+  string "end"+  lift skipNonNewlineSpaces1+  optional $ string "apply" >> lift skipNonNewlineSpaces1+  string "tag"+  lift skipNonNewlineSpaces+  eol   return ()+  ) <?> "end tag or end apply tag directive"  payeedirectivep :: JournalParser m () payeedirectivep = do@@ -567,12 +629,13 @@   lift skipNonNewlineSpaces1   payee <- lift $ T.strip <$> noncommenttext1p   (comment, tags) <- lift transactioncommentp+  skipMany indentedlinep   addPayeeDeclaration (payee, comment, tags)   return ()  defaultyeardirectivep :: JournalParser m () defaultyeardirectivep = do-  char 'Y' <?> "default year"+  (string "Y" <|> string "year" <|> string "apply year") <?> "default year"   lift skipNonNewlineSpaces   setYear =<< lift yearp @@ -654,12 +717,11 @@ -- relative to Y/1/1. If not, they are calculated related to today as usual. periodictransactionp :: MonadIO m => JournalParser m PeriodicTransaction periodictransactionp = do+  startpos <- getSourcePos    -- first line   char '~' <?> "periodic transaction"   lift $ skipNonNewlineSpaces-  -- a period expression-  off <- getOffset    -- if there's a default year in effect, use Y/1/1 as base for partial/relative dates   today <- liftIO getCurrentDay@@ -686,11 +748,6 @@         <> "\na double space is required between period expression and description/comment"     pure pexp -  -- In periodic transactions, the period expression has an additional constraint:-  case checkPeriodicTransactionStartDate interval spn periodtxt of-    Just e -> customFailure $ parseErrorAt off e-    Nothing -> pure ()-   status <- lift statusp <?> "cleared status"   code <- lift codep <?> "transaction code"   description <- lift $ T.strip <$> descriptionp@@ -698,10 +755,14 @@   -- next lines; use same year determined above   postings <- postingsp (Just $ first3 $ toGregorian refdate) +  endpos <- getSourcePos+  let sourcepos = (startpos, endpos)+   return $ nullperiodictransaction{      ptperiodexpr=periodtxt     ,ptinterval=interval     ,ptspan=spn+    ,ptsourcepos=sourcepos     ,ptstatus=status     ,ptcode=code     ,ptdescription=description@@ -767,7 +828,7 @@     let (ptype, account') = (accountNamePostingType account, textUnbracket account)     lift skipNonNewlineSpaces     mult <- if isPostingRule then multiplierp else pure False-    amt <- optional $ amountpwithmultiplier mult+    amt <- optional $ amountp' mult     lift skipNonNewlineSpaces     massertion <- optional balanceassertionp     lift skipNonNewlineSpaces@@ -837,7 +898,8 @@       nullperiodictransaction {          ptperiodexpr  = "monthly from 2018/6"         ,ptinterval    = Months 1-        ,ptspan        = DateSpan (Just $ fromGregorian 2018 6 1) Nothing+        ,ptspan        = DateSpan (Just $ Flex $ fromGregorian 2018 6 1) Nothing+        ,ptsourcepos   = (SourcePos "" (mkPos 1) (mkPos 1), SourcePos "" (mkPos 2) (mkPos 1))         ,ptdescription = ""         ,ptcomment     = "In 2019 we will change this\n"         }@@ -847,7 +909,8 @@       nullperiodictransaction {          ptperiodexpr  = "monthly from 2018/6"         ,ptinterval    = Months 1-        ,ptspan        = DateSpan (Just $ fromGregorian 2018 6 1) Nothing+        ,ptspan        = DateSpan (Just $ Flex $ fromGregorian 2018 6 1) Nothing+        ,ptsourcepos   = (SourcePos "" (mkPos 1) (mkPos 1), SourcePos "" (mkPos 2) (mkPos 1))         ,ptdescription = "In 2019 we will change this"         ,ptcomment     = ""         }@@ -858,6 +921,7 @@          ptperiodexpr  = "monthly"         ,ptinterval    = Months 1         ,ptspan        = DateSpan Nothing Nothing+        ,ptsourcepos   = (SourcePos "" (mkPos 1) (mkPos 1), SourcePos "" (mkPos 2) (mkPos 1))         ,ptdescription = "Next year blah blah"         ,ptcomment     = ""         }@@ -867,7 +931,8 @@       nullperiodictransaction {          ptperiodexpr  = "2019-01-04"         ,ptinterval    = NoInterval-        ,ptspan        = DateSpan (Just $ fromGregorian 2019 1 4) (Just $ fromGregorian 2019 1 5)+        ,ptspan        = DateSpan (Just $ Exact $ fromGregorian 2019 1 4) (Just $ Exact $ fromGregorian 2019 1 5)+        ,ptsourcepos   = (SourcePos "" (mkPos 1) (mkPos 1), SourcePos "" (mkPos 2) (mkPos 1))         ,ptdescription = ""         ,ptcomment     = ""         }@@ -1076,7 +1141,7 @@    ,testCase "endtagdirectivep" $ do       assertParse endtagdirectivep "end tag \n"-      assertParse endtagdirectivep "pop \n"+      assertParse endtagdirectivep "end apply tag \n"    ,testGroup "journalp" [     testCase "empty file" $ assertParseEqE journalp "" nulljournal

@@ -147,7 +147,7 @@         priorq = dbg5 "priorq" $ And [thisacctq, tostartdateq, datelessreportq]         tostartdateq =           case mstartdate of-            Just _  -> Date (DateSpan Nothing mstartdate)+            Just _  -> Date (DateSpan Nothing (Exact <$> mstartdate))             Nothing -> None  -- no start date specified, there are no prior postings         mstartdate = queryStartDate (date2_ ropts) reportq         datelessreportq = filterQuery (not . queryIsDateOrDate2) reportq@@ -179,20 +179,26 @@ accountTransactionsReportItem :: Query -> Query -> (MixedAmount -> MixedAmount)                               -> (AccountName -> Maybe AccountType) -> MixedAmount -> (Day, Transaction)                               -> (MixedAmount, Maybe AccountTransactionsReportItem)-accountTransactionsReportItem reportq thisacctq signfn accttypefn bal (d, torig)+accountTransactionsReportItem reportq thisacctq signfn accttypefn bal (d, t)     -- 201407: I've lost my grip on this, let's just hope for the best     -- 201606: we now calculate change and balance from filtered postings, check this still works well for all callers XXX     | null reportps = (bal, Nothing)  -- no matched postings in this transaction, skip it-    | otherwise     = (b, Just (torig, tacct{tdate=d}, numotheraccts > 1, otheracctstr, a, b))+    | otherwise     = (bal', Just (t, tacct{tdate=d}, numotheraccts > 1, otheracctstr, amt, bal'))     where-      tacct@Transaction{tpostings=reportps} = filterTransactionPostingsExtra accttypefn reportq torig  -- TODO needs to consider --date2, #1731+      tacct@Transaction{tpostings=reportps} = filterTransactionPostingsExtra accttypefn reportq t  -- TODO needs to consider --date2, #1731       (thisacctps, otheracctps) = partition (matchesPosting thisacctq) reportps       numotheraccts = length $ nub $ map paccount otheracctps       otheracctstr | thisacctq == None  = summarisePostingAccounts reportps     -- no current account ? summarise all matched postings                    | numotheraccts == 0 = summarisePostingAccounts thisacctps   -- only postings to current account ? summarise those                    | otherwise          = summarisePostingAccounts otheracctps  -- summarise matched postings to other account(s)-      a = signfn . maNegate $ sumPostings thisacctps-      b = bal `maPlus` a+      -- 202302: Impact of t on thisacct - normally the sum of thisacctps,+      -- but if they are null it probably means reportq is an account filter+      -- and we should sum otheracctps instead.+      -- This fixes hledger areg ACCT ACCT2 (#2007), hopefully it's correct in general.+      amt+        | null thisacctps = signfn $ sumPostings otheracctps+        | otherwise       = signfn . maNegate $ sumPostings thisacctps+      bal' = bal `maPlus` amt  -- TODO needs checking, cf #1731 -- | What date should be shown for a transaction in an account register report ?

@@ -162,11 +162,11 @@        mixedAmount (usd 0))      ,testCase "with date:" $-     (defreportspec{_rsQuery=Date $ DateSpan (Just $ fromGregorian 2009 01 01) (Just $ fromGregorian 2010 01 01)}, samplejournal2) `gives`+     (defreportspec{_rsQuery=Date $ DateSpan (Just $ Exact $ fromGregorian 2009 01 01) (Just $ Exact $ fromGregorian 2010 01 01)}, samplejournal2) `gives`       ([], nullmixedamt)      ,testCase "with date2:" $-     (defreportspec{_rsQuery=Date2 $ DateSpan (Just $ fromGregorian 2009 01 01) (Just $ fromGregorian 2010 01 01)}, samplejournal2) `gives`+     (defreportspec{_rsQuery=Date2 $ DateSpan (Just $ Exact $ fromGregorian 2009 01 01) (Just $ Exact $ fromGregorian 2010 01 01)}, samplejournal2) `gives`       ([         ("assets:bank:checking","assets:bank:checking",0,mixedAmount (usd 1))        ,("income:salary","income:salary",0,mixedAmount (usd (-1)))

@@ -112,7 +112,7 @@   either error' id $  -- PARTIAL:     (journalApplyCommodityStyles >=> journalBalanceTransactions bopts) j{ jtxns = budgetts }   where-    budgetspan = dbg3 "budget span" $ DateSpan mbudgetgoalsstartdate (spanEnd reportspan)+    budgetspan = dbg3 "budget span" $ DateSpan (Exact <$> mbudgetgoalsstartdate) (Exact <$> spanEnd reportspan)       where         mbudgetgoalsstartdate =           -- We want to also generate budget goal txns before the report start date, in case -H is used.@@ -139,7 +139,7 @@                     pts -> (ptinterval pt, ptspan pt)                       where pt = maximumBy (comparing ptinterval) pts  -- PARTIAL: maximumBy won't fail                 -- the natural start of this interval on or before the journal/report start-                intervalstart = intervalStartBefore intervl d+                intervalstart = intervalBoundaryBefore intervl d                 -- the natural interval start before the journal/report start,                 -- or the rule-specified start if later,                 -- but no later than the journal/report start.

@@ -42,7 +42,7 @@ tests_EntriesReport = testGroup "EntriesReport" [   testGroup "entriesReport" [      testCase "not acct" $ (length $ entriesReport defreportspec{_rsQuery=Not . Acct $ toRegex' "bank"} samplejournal) @?= 1-    ,testCase "date" $ (length $ entriesReport defreportspec{_rsQuery=Date $ DateSpan (Just $ fromGregorian 2008 06 01) (Just $ fromGregorian 2008 07 01)} samplejournal) @?= 3+    ,testCase "date" $ (length $ entriesReport defreportspec{_rsQuery=Date $ DateSpan (Just $ Exact $ fromGregorian 2008 06 01) (Just $ Exact $ fromGregorian 2008 07 01)} samplejournal) @?= 3   ]  ] 

@@ -222,7 +222,7 @@      precedingperiod = dateSpanAsPeriod . spanIntersect precedingspan .                          periodAsDateSpan $ period_ ropts-    precedingspan = DateSpan Nothing $ spanStart reportspan+    precedingspan = DateSpan Nothing (Exact <$> spanStart reportspan)     precedingspanq = (if date2_ ropts then Date2 else Date) $ case precedingspan of         DateSpan Nothing Nothing -> emptydatespan         a -> a@@ -331,7 +331,7 @@         -- since this is a cumulative sum of valued amounts, it should not be valued again         cumulative = cumulativeSum nullacct changes         startingBalance = HM.lookupDefault nullacct name startbals-        valuedStart = avalue (DateSpan Nothing historicalDate) startingBalance+        valuedStart = avalue (DateSpan Nothing (Exact <$> historicalDate)) startingBalance      -- In each column, get each account's balance changes     colacctchanges = dbg5 "colacctchanges" $ map (second $ acctChanges rspec j) colps :: [(DateSpan, HashMap ClippedAccountName Account)]

@@ -23,7 +23,7 @@  import Data.List (nub, sortOn) import Data.List.Extra (nubSort)-import Data.Maybe (fromMaybe, isJust, isNothing)+import Data.Maybe (isJust, isNothing) import Data.Text (Text) import Data.Time.Calendar (Day) import Safe (headMay)@@ -115,7 +115,7 @@ matchedPostingsBeforeAndDuring rspec@ReportSpec{_rsReportOpts=ropts,_rsQuery=q} j reportspan =     dbg5 "beforeps, duringps" $ span (beforestartq `matchesPosting`) beforeandduringps   where-    beforestartq = dbg3 "beforestartq" $ dateqtype $ DateSpan Nothing $ spanStart reportspan+    beforestartq = dbg3 "beforestartq" $ dateqtype $ DateSpan Nothing (Exact <$> spanStart reportspan)     beforeandduringps =          sortOn (postingDateOrDate2 (whichDate ropts))            -- sort postings by date or date2       . (if invert_ ropts then map negatePostingAmount else id)  -- with --invert, invert amounts@@ -132,7 +132,7 @@       where         depthless  = filterQuery (not . queryIsDepth)         dateless   = filterQuery (not . queryIsDateOrDate2)-        beforeendq = dateqtype $ DateSpan Nothing $ spanEnd reportspan+        beforeendq = dateqtype $ DateSpan Nothing (Exact <$> spanEnd reportspan)      dateqtype = if queryIsDate2 dateq || (queryIsDate dateq && date2_ ropts) then Date2 else Date       where@@ -195,7 +195,7 @@   | otherwise = summarypes   where     postingdate = if wd == PrimaryDate then postingDate else postingDate2-    b' = fromMaybe (maybe nulldate postingdate $ headMay ps) b+    b' = maybe (maybe nulldate postingdate $ headMay ps) fromEFDay b     summaryp = nullposting{pdate=Just b'}     clippedanames = nub $ map (clipAccountName mdepth) anames     summaryps | mdepth == Just 0 = [summaryp{paccount="...",pamount=sumPostings ps}]

@@ -13,6 +13,7 @@ {-# LANGUAGE RecordWildCards       #-} {-# LANGUAGE TemplateHaskell       #-} {-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeOperators #-}  module Hledger.Reports.ReportOptions (   ReportOpts(..),@@ -70,7 +71,7 @@ import Data.Either.Extra (eitherToMaybe) import Data.Functor.Identity (Identity(..)) import Data.List.Extra (find, isPrefixOf, nubSort)-import Data.Maybe (fromMaybe, isJust)+import Data.Maybe (fromMaybe, isJust, isNothing) import qualified Data.Text as T import Data.Time.Calendar (Day, addDays) import Data.Default (Default(..))@@ -381,14 +382,14 @@   where     mlastb = case beginDatesFromRawOpts d rawopts of                    [] -> Nothing-                   bs -> Just $ last bs+                   bs -> Just $ fromEFDay $ last bs     mlaste = case endDatesFromRawOpts d rawopts of                    [] -> Nothing-                   es -> Just $ last es+                   es -> Just $ fromEFDay $ last es  -- Get all begin dates specified by -b/--begin or -p/--period options, in order, -- using the given date to interpret relative date expressions.-beginDatesFromRawOpts :: Day -> RawOpts -> [Day]+beginDatesFromRawOpts :: Day -> RawOpts -> [EFDay] beginDatesFromRawOpts d = collectopts (begindatefromrawopt d)   where     begindatefromrawopt d' (n,v)@@ -406,7 +407,7 @@  -- Get all end dates specified by -e/--end or -p/--period options, in order, -- using the given date to interpret relative date expressions.-endDatesFromRawOpts :: Day -> RawOpts -> [Day]+endDatesFromRawOpts :: Day -> RawOpts -> [EFDay] endDatesFromRawOpts d = collectopts (enddatefromrawopt d)   where     enddatefromrawopt d' (n,v)@@ -599,7 +600,7 @@     mPeriodEnd = case interval_ ropts of         NoInterval -> const . spanEnd . fst $ reportSpan j rspec         _          -> spanEnd <=< latestSpanContaining (historical : spans)-    historical = DateSpan Nothing $ spanStart =<< headMay spans+    historical = DateSpan Nothing $ (fmap Exact . spanStart) =<< headMay spans     spans = snd $ reportSpanBothDates j rspec     styles = journalCommodityStyles j     err = error "journalApplyValuationFromOpts: expected all spans to have an end date"@@ -675,7 +676,7 @@     -- include price directives after the last transaction     journalspan = dbg3 "journalspan" $ if bothdates then journalDateSpanBothDates j else journalDateSpan (date2_ ropts) j     pricespan = dbg3 "pricespan" . DateSpan Nothing $ case value_ ropts of-        Just (AtEnd _) -> fmap (addDays 1) . maximumMay . map pddate $ jpricedirectives j+        Just (AtEnd _) -> fmap (Exact . addDays 1) . maximumMay . map pddate $ jpricedirectives j         _              -> Nothing     -- If the requested span is open-ended, close it using the journal's start and end dates.     -- This can still be the null (open) span if the journal is empty.@@ -684,11 +685,15 @@     -- This list can be empty if the journal was empty,     -- or if hledger-ui has added its special date:-tomorrow to the query     -- and all txns are in the future.-    intervalspans  = dbg3 "intervalspans" $ splitSpan (interval_ ropts) requestedspan'+    intervalspans  = dbg3 "intervalspans" $ splitSpan adjust (interval_ ropts) requestedspan'+      where+        -- When calculating report periods, we will adjust the start date back to the nearest interval boundary+        -- unless a start date was specified explicitly.+        adjust = isNothing $ spanStart requestedspan     -- The requested span enlarged to enclose a whole number of intervals.     -- This can be the null span if there were no intervals.-    reportspan = dbg3 "reportspan" $ DateSpan (spanStart =<< headMay intervalspans)-                                              (spanEnd =<< lastMay intervalspans)+    reportspan = dbg3 "reportspan" $ DateSpan (fmap Exact . spanStart =<< headMay intervalspans)+                                              (fmap Exact . spanEnd =<< lastMay intervalspans)  reportStartDate :: Journal -> ReportSpec -> Maybe Day reportStartDate j = spanStart . fst . reportSpan j

@@ -120,7 +120,7 @@ -- | Figure out the overall date span of a PeriodicReport periodicReportSpan :: PeriodicReport a b -> DateSpan periodicReportSpan (PeriodicReport [] _ _)       = DateSpan Nothing Nothing-periodicReportSpan (PeriodicReport colspans _ _) = DateSpan (spanStart $ head colspans) (spanEnd $ last colspans)+periodicReportSpan (PeriodicReport colspans _ _) = DateSpan (fmap Exact . spanStart $ head colspans) (fmap Exact . spanEnd $ last colspans)  -- | Map a function over the row names. prMapName :: (a -> b) -> PeriodicReport a c -> PeriodicReport b c

@@ -9,7 +9,7 @@  -} -{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE CPP, LambdaCase #-}  module Hledger.Utils.IO ( @@ -19,6 +19,9 @@   pprint,   pprint', +  -- * Viewing with pager+  pager,+   -- * Command line arguments   progArgs,   outputFileOption,@@ -31,7 +34,11 @@   color,   bgColor,   colorB,-  bgColorB,  +  bgColorB,+  terminalIsLight,+  terminalLightness,+  terminalFgColor,+  terminalBgColor,    -- * Errors   error',@@ -54,26 +61,32 @@ where  import           Control.Monad (when)+import           Data.Colour.RGBSpace (RGB(RGB))+import           Data.Colour.RGBSpace.HSL (lightness) import           Data.FileEmbed (makeRelativeToProject, embedStringFile) import           Data.List hiding (uncons) import           Data.Maybe (isJust)-import           Data.Text (Text)+import qualified Data.Text as T import qualified Data.Text.IO as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Builder as TB import           Data.Time.Clock (getCurrentTime) import           Data.Time.LocalTime   (LocalTime, ZonedTime, getCurrentTimeZone, utcToLocalTime, utcToZonedTime)+import           Data.Word (Word16) import           Language.Haskell.TH.Syntax (Q, Exp) import           System.Console.ANSI-  (Color,ColorIntensity,ConsoleLayer(..), SGR(..), hSupportsANSIColor, setSGRCode)+  (Color,ColorIntensity,ConsoleLayer(..), SGR(..), hSupportsANSIColor, setSGRCode, getLayerColor) import           System.Directory (getHomeDirectory) import           System.Environment (getArgs, lookupEnv) import           System.FilePath (isRelative, (</>)) import           System.IO   (Handle, IOMode (..), hGetEncoding, hSetEncoding, hSetNewlineMode,-   openFile, stdin, stdout, stderr, universalNewlineMode, utf8_bom)+   openFile, stdin, stdout, stderr, universalNewlineMode, utf8_bom, hIsTerminalDevice) import           System.IO.Unsafe (unsafePerformIO)+#ifndef mingw32_HOST_OS+import           System.Pager (printOrPage)+#endif import           Text.Pretty.Simple   (CheckColorTty(CheckColorTty), OutputOptions(..),    defaultOutputOptionsDarkBg, defaultOutputOptionsNoColor, pShowOpt, pPrintOpt)@@ -114,6 +127,17 @@  -- "Avoid using pshow, pprint, dbg* in the code below to prevent infinite loops." (?) +-- | Display the given text on the terminal, using the user's $PAGER if the text is taller +-- than the current terminal and stdout is interactive and TERM is not "dumb".+pager :: String -> IO ()+#ifdef mingw32_HOST_OS+pager = putStrLn+#else+pager s = do+  dumbterm <- (== Just "dumb") <$> lookupEnv "TERM"+  (if dumbterm then putStrLn else printOrPage . T.pack) s+#endif+ -- Command line arguments  -- | The command line arguments that were used at program startup.@@ -147,6 +171,7 @@ -- with an argument other than "-", using unsafePerformIO. hasOutputFile :: Bool hasOutputFile = outputFileOption `notElem` [Nothing, Just "-"]+-- XXX shouldn't we check that stdout is interactive. instead ?  -- ANSI colour @@ -219,6 +244,46 @@ bgColorB int col (WideBuilder s w) =     WideBuilder (TB.fromString (setSGRCode [SetColor Background int col]) <> s <> TB.fromString (setSGRCode [])) w +-- | Detect whether the terminal currently has a light background colour,+-- if possible, using unsafePerformIO.+-- If the terminal is transparent, its apparent light/darkness may be different.+terminalIsLight :: Maybe Bool+terminalIsLight = (> 0.5) <$> terminalLightness++-- | Detect the terminal's current background lightness (0..1), if possible, using unsafePerformIO.+-- If the terminal is transparent, its apparent lightness may be different.+terminalLightness :: Maybe Float+terminalLightness = lightness <$> terminalColor Background++-- | Detect the terminal's current background colour, if possible, using unsafePerformIO.+terminalBgColor :: Maybe (RGB Float)+terminalBgColor = terminalColor Background++-- | Detect the terminal's current foreground colour, if possible, using unsafePerformIO.+terminalFgColor :: Maybe (RGB Float)+terminalFgColor = terminalColor Foreground++-- | Detect the terminal's current foreground or background colour, if possible, using unsafePerformIO.+{-# NOINLINE terminalColor #-}+terminalColor :: ConsoleLayer -> Maybe (RGB Float)+terminalColor = unsafePerformIO . getLayerColor'++-- A version of getLayerColor that is less likely to leak escape sequences to output,+-- and that returns a RGB of Floats (0..1) that is more compatible with the colour package.+-- This does nothing in a non-interactive context (eg when piping stdout to another command),+-- inside emacs (emacs shell buffers show the escape sequence for some reason),+-- or in a non-colour-supporting terminal.+getLayerColor' :: ConsoleLayer -> IO (Maybe (RGB Float))+getLayerColor' l = do+  inemacs       <- not.null <$> lookupEnv "INSIDE_EMACS"+  interactive   <- hIsTerminalDevice stdout+  supportscolor <- hSupportsANSIColor stdout+  if inemacs || not interactive || not supportscolor then return Nothing+  else fmap fractionalRGB <$> getLayerColor l+  where+    fractionalRGB :: (Fractional a) => RGB Word16 -> RGB a+    fractionalRGB (RGB r g b) = RGB (fromIntegral r / 65535) (fromIntegral g / 65535) (fromIntegral b / 65535)  -- chatgpt+ -- Errors  -- | Simpler alias for errorWithoutStackTrace@@ -251,18 +316,18 @@ -- converting any \r\n line endings to \n,, -- using the system locale's text encoding, -- ignoring any utf8 BOM prefix (as seen in paypal's 2018 CSV, eg) if that encoding is utf8.-readFilePortably :: FilePath -> IO Text+readFilePortably :: FilePath -> IO T.Text readFilePortably f =  openFile f ReadMode >>= readHandlePortably  -- | Like readFilePortably, but read from standard input if the path is "-".-readFileOrStdinPortably :: String -> IO Text+readFileOrStdinPortably :: String -> IO T.Text readFileOrStdinPortably f = openFileOrStdin f ReadMode >>= readHandlePortably   where     openFileOrStdin :: String -> IOMode -> IO Handle     openFileOrStdin "-" _ = return stdin     openFileOrStdin f' m   = openFile f' m -readHandlePortably :: Handle -> IO Text+readHandlePortably :: Handle -> IO T.Text readHandlePortably h = do   hSetNewlineMode h universalNewlineMode   menc <- hGetEncoding h

@@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}  module Hledger.Utils.Parse (   SimpleStringParser,

@@ -53,6 +53,7 @@  import Data.Char (digitToInt) import Data.Default (def)+import Data.Maybe (catMaybes) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Lazy as TL@@ -175,13 +176,18 @@ isDoubleQuoted s =   T.length s >= 2 && T.head s == '"' && T.last s == '"' +-- | Remove all matching pairs of square brackets and parentheses from the text. textUnbracket :: Text -> Text-textUnbracket s-    | T.null s = s-    | T.head s == '[' && T.last s == ']' = T.init $ T.tail s-    | T.head s == '(' && T.last s == ')' = T.init $ T.tail s-    | otherwise = s+textUnbracket s = T.drop stripN $ T.dropEnd stripN s+  where+    matchBracket :: Char -> Maybe Char+    matchBracket '(' = Just ')'+    matchBracket '[' = Just ']'+    matchBracket _ = Nothing +    expectedClosingBrackets = catMaybes $ takeWhile (/= Nothing) $ matchBracket <$> T.unpack s+    stripN = length $ takeWhile (uncurry (==)) $ zip expectedClosingBrackets $ reverse $ T.unpack s+ -- | Join several multi-line strings as side-by-side rectangular strings of the same height, top-padded. -- Treats wide characters as double width. textConcatTopPadded :: [Text] -> Text@@ -271,5 +277,18 @@      quoteIfSpaced "mimi's cafe" @?= "\"mimi's cafe\""      quoteIfSpaced "\"alex\" cafe" @?= "\"\\\"alex\\\" cafe\""      quoteIfSpaced "le'shan's cafe" @?= "\"le'shan's cafe\""-     quoteIfSpaced "\"be'any's\" cafe" @?= "\"\\\"be'any's\\\" cafe\""+     quoteIfSpaced "\"be'any's\" cafe" @?= "\"\\\"be'any's\\\" cafe\"",+   testCase "textUnbracket" $ do+     textUnbracket "()" @?= ""+     textUnbracket "(a)" @?= "a"+     textUnbracket "(ab)" @?= "ab"+     textUnbracket "[ab]" @?= "ab"+     textUnbracket "([ab])" @?= "ab"+     textUnbracket "(()b)" @?= "()b"+     textUnbracket "[[]b]" @?= "[]b"+     textUnbracket "[()b]" @?= "()b"+     textUnbracket "[([]())]" @?= "[]()"+     textUnbracket "[([[[()]]])]" @?= ""+     textUnbracket "[([[[(]]])]" @?= "("+     textUnbracket "[([[[)]]])]" @?= ")"   ]

@@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.35.0.+-- This file has been generated from package.yaml by hpack version 0.35.1. -- -- see: https://github.com/sol/hpack  name:           hledger-lib-version:        1.28+version:        1.29 synopsis:       A reusable library providing the core functionality of hledger description:    A reusable library containing hledger's core functionality.                 This is used by most hledger* packages so that they support the same@@ -111,6 +111,7 @@     , cassava     , cassava-megaparsec     , cmdargs >=0.10+    , colour >=2.3.6     , containers >=0.5.9     , data-default >=0.5     , deepseq@@ -133,6 +134,7 @@     , tasty-hunit >=0.10.0.2     , template-haskell     , text >=1.2+    , text-ansi >=0.2.1     , time >=1.5     , timeit     , transformers >=0.2@@ -140,6 +142,9 @@     , unordered-containers >=0.2     , utf8-string >=0.3.5   default-language: Haskell2010+  if (!(os(windows)))+    build-depends:+        pager >=0.1.1.0  test-suite doctest   type: exitcode-stdio-1.0@@ -162,6 +167,7 @@     , cassava     , cassava-megaparsec     , cmdargs >=0.10+    , colour >=2.3.6     , containers >=0.5.9     , data-default >=0.5     , deepseq@@ -185,6 +191,7 @@     , tasty-hunit >=0.10.0.2     , template-haskell     , text >=1.2+    , text-ansi >=0.2.1     , time >=1.5     , timeit     , transformers >=0.2@@ -192,6 +199,9 @@     , unordered-containers >=0.2     , utf8-string >=0.3.5   default-language: Haskell2010+  if (!(os(windows)))+    build-depends:+        pager >=0.1.1.0   if impl(ghc >= 9.0) && impl(ghc < 9.2)     buildable: False @@ -216,6 +226,7 @@     , cassava     , cassava-megaparsec     , cmdargs >=0.10+    , colour >=2.3.6     , containers >=0.5.9     , data-default >=0.5     , deepseq@@ -239,6 +250,7 @@     , tasty-hunit >=0.10.0.2     , template-haskell     , text >=1.2+    , text-ansi >=0.2.1     , time >=1.5     , timeit     , transformers >=0.2@@ -247,3 +259,6 @@     , utf8-string >=0.3.5   buildable: True   default-language: Haskell2010+  if (!(os(windows)))+    build-depends:+        pager >=0.1.1.0