diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -9,14 +9,29 @@ Internal/api/developer-ish changes in the hledger-lib (and hledger) packages. For user-visible changes, see the hledger package changelog. -# a98e6125f +# 1.25 2022-03-04 -Improvements +- hledger-lib now builds with GHC 9.2 and latest deps. + ([#1774](https://github.com/simonmichael/hledger/issues/1774) -- hledger-lib now builds with GHC 9.2 and newer libs (#1774). +- Journal has a new jaccounttypes map. + The journalAccountType lookup function makes it easy to check an account's type. + The journalTags and journalInheritedTags functions look up an account's tags. + Functions like journalFilterPostings and journalFilterTransactions, + and new matching functions matchesAccountExtra, matchesPostingExtra + and matchesTransactionExtra, use these to allow more powerful matching + that is aware of account types and tags. +- Journal has a new jdeclaredaccounttags field + for easy lookup of account tags. + Query.matchesTaggedAccount is a tag-aware version of matchesAccount. + +- Some account name functions have moved from Hledger.Data.Posting + to Hledger.Data.AccountName: + accountNamePostingType, accountNameWithPostingType, accountNameWithoutPostingType, + joinAccountNames, concatAccountNames, accountNameApplyAliases, accountNameApplyAliasesMemo. + - Renamed: CommodityLayout to Layout. - (Stephen Morgan) # 1.24.1 2021-12-10 diff --git a/Hledger/Data/AccountName.hs b/Hledger/Data/AccountName.hs --- a/Hledger/Data/AccountName.hs +++ b/Hledger/Data/AccountName.hs @@ -20,6 +20,15 @@ ,accountNameToAccountRegexCI ,accountNameTreeFrom ,accountSummarisedName + ,accountNameInferType + ,accountNameType + ,assetAccountRegex + ,cashAccountRegex + ,liabilityAccountRegex + ,equityAccountRegex + ,conversionAccountRegex + ,revenueAccountRegex + ,expenseAccountRegex ,acctsep ,acctsepchar ,clipAccountName @@ -36,16 +45,28 @@ ,subAccountNamesFrom ,topAccountNames ,unbudgetedAccountName + ,accountNamePostingType + ,accountNameWithoutPostingType + ,accountNameWithPostingType + ,joinAccountNames + ,concatAccountNames + ,accountNameApplyAliases + ,accountNameApplyAliasesMemo ,tests_AccountName ) where -import Data.Foldable (toList) +import Control.Applicative ((<|>)) +import Control.Monad (foldM) +import Data.Foldable (asum, toList) import qualified Data.List.NonEmpty as NE +import qualified Data.Map as M +import Data.MemoUgly (memo) import qualified Data.Set as S import Data.Text (Text) import qualified Data.Text as T import Data.Tree (Tree(..)) +import Safe import Text.DocLayout (realLength) import Hledger.Data.Types @@ -82,6 +103,36 @@ cs = accountNameComponents a a' = accountLeafName a +-- | Regular expressions matching common English top-level account names, +-- used as a fallback when account types are not declared. +assetAccountRegex = toRegexCI' "^assets?(:|$)" +cashAccountRegex = toRegexCI' "^assets?(:.+)?:(cash|bank|che(ck|que?)(ing)?|savings?|current)(:|$)" +liabilityAccountRegex = toRegexCI' "^(debts?|liabilit(y|ies))(:|$)" +equityAccountRegex = toRegexCI' "^equity(:|$)" +conversionAccountRegex = toRegexCI' "^equity:(trad(e|ing)|conversion)s?(:|$)" +revenueAccountRegex = toRegexCI' "^(income|revenue)s?(:|$)" +expenseAccountRegex = toRegexCI' "^expenses?(:|$)" + +-- | Try to guess an account's type from its name, +-- matching common English top-level account names. +accountNameInferType :: AccountName -> Maybe AccountType +accountNameInferType a + | regexMatchText cashAccountRegex a = Just Cash + | regexMatchText assetAccountRegex a = Just Asset + | regexMatchText liabilityAccountRegex a = Just Liability + | regexMatchText conversionAccountRegex a = Just Conversion + | regexMatchText equityAccountRegex a = Just Equity + | regexMatchText revenueAccountRegex a = Just Revenue + | regexMatchText expenseAccountRegex a = Just Expense + | otherwise = Nothing + +-- Extract the 'AccountType' of an 'AccountName' by looking it up in the +-- provided Map, traversing the parent accounts if necessary. If none of those +-- work, try 'accountNameInferType'. +accountNameType :: M.Map AccountName AccountType -> AccountName -> Maybe AccountType +accountNameType atypes a = asum (map (`M.lookup` atypes) $ a : parentAccountNames a) + <|> accountNameInferType a + accountNameLevel :: AccountName -> Int accountNameLevel "" = 0 accountNameLevel a = T.length (T.filter (==acctsepchar) a) + 1 @@ -91,6 +142,65 @@ unbudgetedAccountName :: T.Text unbudgetedAccountName = "" +accountNamePostingType :: AccountName -> PostingType +accountNamePostingType a + | T.null a = RegularPosting + | T.head a == '[' && T.last a == ']' = BalancedVirtualPosting + | T.head a == '(' && T.last a == ')' = VirtualPosting + | otherwise = RegularPosting + +accountNameWithoutPostingType :: AccountName -> AccountName +accountNameWithoutPostingType a = case accountNamePostingType a of + BalancedVirtualPosting -> textUnbracket a + VirtualPosting -> textUnbracket a + RegularPosting -> a + +accountNameWithPostingType :: PostingType -> AccountName -> AccountName +accountNameWithPostingType BalancedVirtualPosting = wrap "[" "]" . accountNameWithoutPostingType +accountNameWithPostingType VirtualPosting = wrap "(" ")" . accountNameWithoutPostingType +accountNameWithPostingType RegularPosting = accountNameWithoutPostingType + +-- | Prefix one account name to another, preserving posting type +-- indicators like concatAccountNames. +joinAccountNames :: AccountName -> AccountName -> AccountName +joinAccountNames a b = concatAccountNames $ filter (not . T.null) [a,b] + +-- | Join account names into one. If any of them has () or [] posting type +-- indicators, these (the first type encountered) will also be applied to +-- the resulting account name. +concatAccountNames :: [AccountName] -> AccountName +concatAccountNames as = accountNameWithPostingType t $ T.intercalate ":" $ map accountNameWithoutPostingType as + where t = headDef RegularPosting $ filter (/= RegularPosting) $ map accountNamePostingType as + +-- | Rewrite an account name using all matching aliases from the given list, in sequence. +-- Each alias sees the result of applying the previous aliases. +-- Or, return any error arising from a bad regular expression in the aliases. +accountNameApplyAliases :: [AccountAlias] -> AccountName -> Either RegexError AccountName +accountNameApplyAliases aliases a = + let (aname,atype) = (accountNameWithoutPostingType a, accountNamePostingType a) + in foldM + (\acct alias -> dbg6 "result" $ aliasReplace (dbg6 "alias" alias) (dbg6 "account" acct)) + aname + aliases + >>= Right . accountNameWithPostingType atype + +-- | Memoising version of accountNameApplyAliases, maybe overkill. +accountNameApplyAliasesMemo :: [AccountAlias] -> AccountName -> Either RegexError AccountName +accountNameApplyAliasesMemo aliases = memo (accountNameApplyAliases aliases) + -- XXX re-test this memoisation + +-- aliasMatches :: AccountAlias -> AccountName -> Bool +-- aliasMatches (BasicAlias old _) a = old `isAccountNamePrefixOf` a +-- aliasMatches (RegexAlias re _) a = regexMatchesCI re a + +aliasReplace :: AccountAlias -> AccountName -> Either RegexError AccountName +aliasReplace (BasicAlias old new) a + | old `isAccountNamePrefixOf` a || old == a = + Right $ new <> T.drop (T.length old) a + | otherwise = Right a +aliasReplace (RegexAlias re repl) a = + fmap T.pack . regexReplace re repl $ T.unpack a -- XXX + -- | Remove some number of account name components from the front of the account name. -- If the special "" top-level account is present, it is preserved and -- dropping affects the rest of the account name. @@ -255,5 +365,16 @@ "assets:bank" `isSubAccountNameOf` "assets" @?= True "assets:bank:checking" `isSubAccountNameOf` "assets" @?= False "assets:bank" `isSubAccountNameOf` "my assets" @?= False + ,testCase "accountNameInferType" $ do + accountNameInferType "assets" @?= Just Asset + accountNameInferType "assets:cash" @?= Just Cash + accountNameInferType "assets:A/R" @?= Just Asset + accountNameInferType "liabilities" @?= Just Liability + accountNameInferType "equity" @?= Just Equity + accountNameInferType "equity:conversion" @?= Just Conversion + accountNameInferType "expenses" @?= Just Expense + accountNameInferType "revenues" @?= Just Revenue + accountNameInferType "revenue" @?= Just Revenue + accountNameInferType "income" @?= Just Revenue ] diff --git a/Hledger/Data/Amount.hs b/Hledger/Data/Amount.hs --- a/Hledger/Data/Amount.hs +++ b/Hledger/Data/Amount.hs @@ -80,6 +80,7 @@ amountUnstyled, showAmountB, showAmount, + showAmountPrice, cshowAmount, showAmountWithZeroCommodity, showAmountDebug, diff --git a/Hledger/Data/Balancing.hs b/Hledger/Data/Balancing.hs --- a/Hledger/Data/Balancing.hs +++ b/Hledger/Data/Balancing.hs @@ -350,7 +350,7 @@ data BalancingState s = BalancingState { -- read only bsStyles :: Maybe (M.Map CommoditySymbol AmountStyle) -- ^ commodity display styles - ,bsUnassignable :: S.Set AccountName -- ^ accounts in which balance assignments may not be used + ,bsUnassignable :: S.Set AccountName -- ^ accounts where balance assignments may not be used (because of auto posting rules) ,bsAssrt :: Bool -- ^ whether to check balance assertions -- mutable ,bsBalances :: H.HashTable s AccountName MixedAmount -- ^ running account balances, initially empty @@ -422,8 +422,8 @@ -- display precisions used in balanced checking styles = Just $ journalCommodityStyles j bopts = bopts'{commodity_styles_=styles} - -- balance assignments will not be allowed on these - txnmodifieraccts = S.fromList . map (paccount . tmprPosting) . concatMap tmpostingrules $ jtxnmodifiers j + -- balance assignments are not allowed on accounts affected by auto postings + autopostingaccts = S.fromList . map (paccount . tmprPosting) . concatMap tmpostingrules $ jtxnmodifiers j in runST $ do -- We'll update a mutable array of transactions as we balance them, @@ -448,7 +448,7 @@ -- 2. Sort these items by date, preserving the order of same-day items, -- and step through them while keeping running account balances, runningbals <- lift $ H.newSized (length $ journalAccountNamesUsed j) - flip runReaderT (BalancingState styles txnmodifieraccts (not $ ignore_assertions_ bopts) runningbals balancedtxns) $ do + 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. void $ mapM' balanceTransactionAndCheckAssertionsB $ sortOn (either postingDate tdate) psandts @@ -618,30 +618,29 @@ checkBalanceAssignmentPostingDateB :: Posting -> Balancing s () checkBalanceAssignmentPostingDateB p = when (hasBalanceAssignment p && isJust (pdate p)) $ - throwError . T.unpack $ T.unlines - ["postings which are balance assignments may not have a custom date." - ,"Please write the posting amount explicitly, or remove the posting date:" + throwError $ chomp $ unlines [ + "can't use balance assignment with custom posting date" ,"" - ,maybe (T.unlines $ showPostingLines p) showTransaction $ ptransaction p + ,chomp1 $ T.unpack $ maybe (T.unlines $ showPostingLines p) showTransaction $ ptransaction p + ,"Balance assignments may not be used on postings with a custom posting date" + ,"(it makes balancing the journal impossible)." + ,"Please write the posting amount explicitly (or remove the posting date)." ] -- | Throw an error if this posting is trying to do a balance assignment and -- the account does not allow balance assignments (eg because it is referenced --- by a transaction modifier, which might generate additional postings to it). +-- by an auto posting rule, which might generate additional postings to it). checkBalanceAssignmentUnassignableAccountB :: Posting -> Balancing s () checkBalanceAssignmentUnassignableAccountB p = do unassignable <- R.asks bsUnassignable when (hasBalanceAssignment p && paccount p `S.member` unassignable) $ - throwError . T.unpack $ T.unlines - ["balance assignments cannot be used with accounts which are" - ,"posted to by transaction modifier rules (auto postings)." - ,"Please write the posting amount explicitly, or remove the rule." - ,"" - ,"account: " <> paccount p - ,"" - ,"transaction:" + throwError $ chomp $ unlines [ + "can't use balance assignment with auto postings" ,"" - ,maybe (T.unlines $ showPostingLines p) showTransaction $ ptransaction p + ,chomp1 $ T.unpack $ maybe (T.unlines $ showPostingLines p) (showTransaction) $ ptransaction p + ,"Balance assignments may not be used on accounts affected by auto posting rules" + ,"(it makes balancing the journal impossible)." + ,"Please write the posting amount explicitly (or remove the auto posting rule(s))." ] -- lenses diff --git a/Hledger/Data/Dates.hs b/Hledger/Data/Dates.hs --- a/Hledger/Data/Dates.hs +++ b/Hledger/Data/Dates.hs @@ -12,7 +12,8 @@ For date and time values, we use the standard Day and UTCTime types. A 'SmartDate' is a date which may be partially-specified or relative. -Eg 2008\/12\/31, but also 2008\/12, 12\/31, tomorrow, last week, next year. +Eg 2008\/12\/31, but also 2008\/12, 12\/31, tomorrow, last week, next year, +in 5 days, in -3 quarters. We represent these as a triple of strings like (\"2008\",\"12\",\"\"), (\"\",\"\",\"tomorrow\"), (\"\",\"last\",\"week\"). @@ -66,6 +67,7 @@ latestSpanContaining, smartdate, splitSpan, + spansFromBoundaries, groupByDateSpan, fixSmartDate, fixSmartDateStr, @@ -73,7 +75,6 @@ fixSmartDateStrEither', yearp, daysInSpan, - maybePeriod, tests_Dates ) @@ -104,7 +105,7 @@ import Safe (headMay, lastMay, maximumMay, minimumMay) import Text.Megaparsec import Text.Megaparsec.Char (char, char', digitChar, string, string') -import Text.Megaparsec.Char.Lexer (decimal) +import Text.Megaparsec.Char.Lexer (decimal, signed) import Text.Megaparsec.Custom (customErrorBundlePretty) import Text.Printf (printf) @@ -207,52 +208,48 @@ -- splitSpan :: Interval -> DateSpan -> [DateSpan] splitSpan _ (DateSpan Nothing Nothing) = [DateSpan Nothing Nothing] -splitSpan _ s | isEmptySpan s = [] -splitSpan NoInterval s = [s] -splitSpan (Days n) s = splitspan startofday (applyN n nextday) s -splitSpan (Weeks n) s = splitspan startofweek (applyN n nextweek) s -splitSpan (Months n) s = splitspan startofmonth (applyN n nextmonth) s -splitSpan (Quarters n) s = splitspan startofquarter (applyN n nextquarter) s -splitSpan (Years n) s = splitspan startofyear (applyN n nextyear) s -splitSpan (DayOfMonth n) s = splitspan (nthdayofmonthcontaining n) (nthdayofmonth n . nextmonth) s -splitSpan (WeekdayOfMonth n wd) s = splitspan (nthweekdayofmonthcontaining n wd) (advancetonthweekday n wd . nextmonth) s -splitSpan (DaysOfWeek []) s = [s] -- shouldn't happen in parser but for completeness -splitSpan (DaysOfWeek days@(n:_)) ds - | DateSpan Nothing (Just e) <- ds = split (DateSpan (Just $ start e) (Just $ nextday $ start e)) - | DateSpan (Just s) Nothing <- ds = split (DateSpan (Just $ start s) (Just $ nextday $ start s)) - | DateSpan (Just s) (Just e) <- ds = - if s == e then [ds] else split (DateSpan (Just $ start s) (Just e)) +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 where - start = nthdayofweekcontaining n - - wheel = (\x -> zipWith (-) (tail x) x) . concat . zipWith fmap (fmap (+) [0,7..]) . repeat $ days - - split = splitspan' (repeat startofday) (fmap (`applyN` nextday) wheel) - -splitSpan (DayOfYear m n) s = splitspan (nthdayofyearcontaining m n) (applyN (n-1) nextday . applyN (m-1) nextmonth . nextyear) s --- splitSpan (WeekOfYear n) s = splitspan startofweek (applyN n nextweek) s --- splitSpan (MonthOfYear n) s = splitspan startofmonth (applyN n nextmonth) s --- splitSpan (QuarterOfYear n) s = splitspan startofquarter (applyN n nextquarter) s + advancemonths 0 = id + advancemonths w = advancetonthweekday n wd . startofmonth . addGregorianMonthsClip w +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 --- next is applied to a sub-span's start date to get the next sub-span's start date -splitspan :: (Day -> Day) -> (Day -> Day) -> DateSpan -> [DateSpan] -splitspan _ _ (DateSpan Nothing Nothing) = [] -splitspan start next (DateSpan Nothing (Just e)) = splitspan start next (DateSpan (Just $ start e) (Just $ next $ start e)) -splitspan start next (DateSpan (Just s) Nothing) = splitspan start next (DateSpan (Just $ start s) (Just $ next $ start s)) -splitspan start next span@(DateSpan (Just s) (Just e)) - | s == e = [span] - | otherwise = splitspan' (repeat start) (repeat next) span +-- 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 +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 + bdrys = mapM (addInterval . toInteger) [0,mult..] $ start s -splitspan' :: [Day -> Day] -> [Day -> Day] -> DateSpan -> [DateSpan] -splitspan' (start:ss) (next:ns) (DateSpan (Just s) (Just e)) - | s >= e = [] - | otherwise = DateSpan (Just subs) (Just sube) : splitspan' ss ns (DateSpan (Just sube) (Just e)) - where subs = start s - sube = next subs -splitspan' _ _ _ = error' "won't happen, avoids warnings" -- PARTIAL: +-- | Fill in missing endpoints 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 +-- | Construct a list of '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 + -- | 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 @@ -373,9 +370,6 @@ either (error' . ("failed to parse:" ++) . customErrorBundlePretty) id $ -- PARTIAL: parsePeriodExpr refdate s -maybePeriod :: Day -> Text -> Maybe (Interval,DateSpan) -maybePeriod refdate = either (const Nothing) Just . parsePeriodExpr refdate - -- | Show a DateSpan as a human-readable pseudo-period-expression string. -- dateSpanAsText :: DateSpan -> String -- dateSpanAsText (DateSpan Nothing Nothing) = "all" @@ -396,21 +390,11 @@ (ry,rm,_) = toGregorian refdate (b,e) = span sdate span :: SmartDate -> (Day,Day) - span (SmartRelative This Day) = (refdate, nextday refdate) - span (SmartRelative Last Day) = (prevday refdate, refdate) - span (SmartRelative Next Day) = (nextday refdate, addDays 2 refdate) - span (SmartRelative This Week) = (thisweek refdate, nextweek refdate) - span (SmartRelative Last Week) = (prevweek refdate, thisweek refdate) - span (SmartRelative Next Week) = (nextweek refdate, startofweek $ addDays 14 refdate) - span (SmartRelative This Month) = (thismonth refdate, nextmonth refdate) - span (SmartRelative Last Month) = (prevmonth refdate, thismonth refdate) - span (SmartRelative Next Month) = (nextmonth refdate, startofmonth $ addGregorianMonthsClip 2 refdate) - span (SmartRelative This Quarter) = (thisquarter refdate, nextquarter refdate) - span (SmartRelative Last Quarter) = (prevquarter refdate, thisquarter refdate) - span (SmartRelative Next Quarter) = (nextquarter refdate, startofquarter $ addGregorianMonthsClip 6 refdate) - span (SmartRelative This Year) = (thisyear refdate, nextyear refdate) - span (SmartRelative Last Year) = (prevyear refdate, thisyear refdate) - span (SmartRelative Next Year) = (nextyear refdate, startofyear $ addGregorianYearsClip 2 refdate) + span (SmartRelative n Day) = (addDays n refdate, addDays (n+1) refdate) + span (SmartRelative n Week) = let d = thisweek refdate in (addDays (7*n) d, addDays (7*n+7) d) + span (SmartRelative n Month) = let d = thismonth refdate in (addGregorianMonthsClip n d, addGregorianMonthsClip (n+1) d) + span (SmartRelative n Quarter) = let d = thisquarter refdate in (addGregorianMonthsClip (3*n) d, addGregorianMonthsClip (3*n+3) d) + span (SmartRelative n Year) = let d = thisyear refdate in (addGregorianYearsClip n d, addGregorianYearsClip (n+1) d) span (SmartAssumeStart y Nothing) = (startofyear day, nextyear day) where day = fromGregorian y 1 1 span (SmartAssumeStart y (Just (m, Nothing))) = (startofmonth day, nextmonth day) where day = fromGregorian y m 1 span (SmartAssumeStart y (Just (m, Just d))) = (day, nextday day) where day = fromGregorian y m d @@ -510,28 +494,28 @@ -- t "next january" -- "2009-01-01" -- +-- >>> t "in 5 days" +-- "2008-12-01" +-- >>> t "in 7 months" +-- "2009-06-01" +-- >>> t "in -2 weeks" +-- "2008-11-10" +-- >>> t "1 quarter ago" +-- "2008-07-01" +-- >>> t "1 week ahead" +-- "2008-12-01" fixSmartDate :: Day -> SmartDate -> Day fixSmartDate refdate = fix where fix :: SmartDate -> Day - fix (SmartRelative This Day) = refdate - fix (SmartRelative Last Day) = prevday refdate - fix (SmartRelative Next Day) = nextday refdate - fix (SmartRelative This Week) = thisweek refdate - fix (SmartRelative Last Week) = prevweek refdate - fix (SmartRelative Next Week) = nextweek refdate - fix (SmartRelative This Month) = thismonth refdate - fix (SmartRelative Last Month) = prevmonth refdate - fix (SmartRelative Next Month) = nextmonth refdate - fix (SmartRelative This Quarter) = thisquarter refdate - fix (SmartRelative Last Quarter) = prevquarter refdate - fix (SmartRelative Next Quarter) = nextquarter refdate - fix (SmartRelative This Year) = thisyear refdate - fix (SmartRelative Last Year) = prevyear refdate - fix (SmartRelative Next Year) = nextyear refdate - fix (SmartAssumeStart y md) = fromGregorian y (maybe 1 fst md) (fromMaybe 1 $ snd =<< md) - 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 (SmartAssumeStart y md) = fromGregorian y (maybe 1 fst md) (fromMaybe 1 $ snd =<< md) + fix (SmartFromReference m d) = fromGregorian ry (fromMaybe rm m) d + fix (SmartMonth m) = fromGregorian ry m 1 (ry, rm, _) = toGregorian refdate prevday :: Day -> Day @@ -554,8 +538,6 @@ nthdayofmonth d day = fromGregorian y m d where (y,m,_) = toGregorian day thisquarter = startofquarter -prevquarter = startofquarter . addGregorianMonthsClip (-3) -nextquarter = startofquarter . addGregorianMonthsClip 3 startofquarter day = fromGregorian y (firstmonthofquarter m) 1 where (y,m,_) = toGregorian day @@ -726,6 +708,8 @@ > october, oct (start of month in current year) > yesterday, today, tomorrow (-1, 0, 1 days from today) > last/this/next day/week/month/quarter/year (-1, 0, 1 periods from the current period) +> in n days/weeks/months/quarters/years (n periods from the current period) +> n days/weeks/months/quarters/years ago (-n periods from the current period) > 20181201 (8 digit YYYYMMDD with valid year month and day) > 201812 (6 digit YYYYMM with valid year and month) @@ -763,20 +747,27 @@ smartdate :: TextParser m SmartDate smartdate = choice' -- XXX maybe obscures date errors ? see ledgerdate - [ yyyymmdd, ymd + [ relativeP + , yyyymmdd, ymd , (\(m,d) -> SmartFromReference (Just m) d) <$> md , failIfInvalidDate . SmartFromReference Nothing =<< decimal , SmartMonth <$> (month <|> mon) - , SmartRelative This Day <$ string' "today" - , SmartRelative Last Day <$ string' "yesterday" - , SmartRelative Next Day <$ string' "tomorrow" - , liftA2 SmartRelative (seqP <* skipNonNewlineSpaces) intervalP + , SmartRelative 0 Day <$ string' "today" + , SmartRelative (-1) Day <$ string' "yesterday" + , SmartRelative 1 Day <$ string' "tomorrow" ] where - seqP = choice [This <$ string' "this", Last <$ string' "last", Next <$ string' "next"] - intervalP = choice [Day <$ string' "day", Week <$ string' "week", Month <$ string' "month", - Quarter <$ string' "quarter", Year <$ string' "year"] + relativeP = do + optional $ string' "in" <* skipNonNewlineSpaces + num <- seqP <* skipNonNewlineSpaces + interval <- intervalP <* skipNonNewlineSpaces + sign <- choice [negate <$ string' "ago", id <$ string' "ahead", pure id] + return $ SmartRelative (sign num) interval + seqP = choice [ 0 <$ string' "this", -1 <$ string' "last", 1 <$ string' "next", signed skipNonNewlineSpaces decimal ] + intervalP = choice [ Day <$ string' "day", Week <$ string' "week", Month <$ string' "month" + , Quarter <$ string' "quarter", Year <$ string' "year" ] <* optional (char' 's') + -- | Like smartdate, but there must be nothing other than whitespace after the date. smartdateonly :: TextParser m SmartDate smartdateonly = smartdate <* skipNonNewlineSpaces <* eof @@ -968,18 +959,14 @@ (toPermutation $ nth <* skipNonNewlineSpaces) -- Parse any of several variants of a basic interval, eg "daily", "every day", "every N days". - tryinterval :: String -> String -> (Int -> Interval) -> TextParser m Interval + tryinterval :: Text -> Text -> (Int -> Interval) -> TextParser m Interval tryinterval singular compact intcons = intcons <$> choice' - [ 1 <$ string' compact' + [ 1 <$ string' compact , string' "every" *> skipNonNewlineSpaces *> choice - [ 1 <$ string' singular' - , decimal <* skipNonNewlineSpaces <* string' plural' + [ 1 <$ string' singular + , decimal <* skipNonNewlineSpaces <* string' (singular <> "s") ] ] - where - compact' = T.pack compact - singular' = T.pack singular - plural' = T.pack $ singular ++ "s" periodexprdatespanp :: Day -> TextParser m DateSpan periodexprdatespanp rdate = choice $ map try [ @@ -1078,8 +1065,8 @@ ] , testCase "match dayOfWeek" $ do - let dayofweek n s = splitspan (nthdayofweekcontaining n) (applyN (n-1) nextday . nextweek) s - match ds day = dayofweek day ds == splitSpan (DaysOfWeek [day]) ds @?= True + let dayofweek n s = splitspan (nthdayofweekcontaining n) (\w -> (if w == 0 then id else applyN (n-1) nextday . applyN (fromInteger w) nextweek)) 1 s + match ds day = splitSpan (DaysOfWeek [day]) ds @?= dayofweek day ds ys2021 = fromGregorian 2021 01 01 ye2021 = fromGregorian 2021 12 31 ys2022 = fromGregorian 2022 01 01 diff --git a/Hledger/Data/Journal.hs b/Hledger/Data/Journal.hs --- a/Hledger/Data/Journal.hs +++ b/Hledger/Data/Journal.hs @@ -2,6 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} {-| @@ -24,6 +25,7 @@ commodityStylesFromAmounts, journalCommodityStyles, journalToCost, + journalAddInferredEquityPostings, journalReverse, journalSetLastReadTime, journalPivot, @@ -46,7 +48,12 @@ journalAccountNamesDeclared, journalAccountNamesDeclaredOrUsed, journalAccountNamesDeclaredOrImplied, + journalLeafAccountNamesDeclared, journalAccountNames, + journalLeafAccountNames, + journalAccountNameTree, + journalAccountTags, + journalInheritedAccountTags, -- journalAmountAndPriceCommodities, -- journalAmountStyles, -- overJournalAmounts, @@ -70,6 +77,11 @@ journalPrevTransaction, journalPostings, journalTransactionsSimilarTo, + -- * Account types + journalAccountType, + journalAccountTypes, + journalAddAccountTypes, + journalPostingsAddAccountTags, -- journalPrices, -- * Standard account types journalBalanceSheetAccountQuery, @@ -80,6 +92,7 @@ journalLiabilityAccountQuery, journalEquityAccountQuery, journalCashAccountQuery, + journalConversionAccount, -- * Misc canonicalStyleFrom, nulljournal, @@ -92,7 +105,8 @@ samplejournal, samplejournalMaybeExplicit, tests_Journal -,journalLeafAccountNamesDeclared) + -- +) where import Control.Applicative ((<|>)) @@ -101,7 +115,7 @@ import Data.Char (toUpper, isDigit) import Data.Default (Default(..)) import Data.Foldable (toList) -import Data.List ((\\), find, foldl', sortBy) +import Data.List ((\\), find, foldl', sortBy, union) import Data.List.Extra (nubSort) import qualified Data.Map.Strict as M import Data.Maybe (catMaybes, fromMaybe, mapMaybe, maybeToList) @@ -111,7 +125,7 @@ import Safe (headMay, headDef, maximumMay, minimumMay) import Data.Time.Calendar (Day, addDays, fromGregorian) import Data.Time.Clock.POSIX (POSIXTime) -import Data.Tree (Tree, flatten) +import Data.Tree (Tree(..), flatten) import Text.Printf (printf) import Text.Megaparsec (ParsecT) import Text.Megaparsec.Custom (FinalParseError) @@ -120,9 +134,10 @@ import Hledger.Data.Types import Hledger.Data.AccountName import Hledger.Data.Amount +import Hledger.Data.Posting import Hledger.Data.Transaction import Hledger.Data.TransactionModifier -import Hledger.Data.Posting +import Hledger.Data.Valuation import Hledger.Query @@ -193,7 +208,9 @@ ,jincludefilestack = jincludefilestack j2 ,jdeclaredpayees = jdeclaredpayees j1 <> jdeclaredpayees j2 ,jdeclaredaccounts = jdeclaredaccounts j1 <> jdeclaredaccounts j2 + ,jdeclaredaccounttags = jdeclaredaccounttags j1 <> jdeclaredaccounttags j2 ,jdeclaredaccounttypes = jdeclaredaccounttypes j1 <> jdeclaredaccounttypes j2 + ,jaccounttypes = jaccounttypes j1 <> jaccounttypes j2 ,jglobalcommoditystyles = jglobalcommoditystyles j1 <> jglobalcommoditystyles j2 ,jcommodities = jcommodities j1 <> jcommodities j2 ,jinferredcommodities = jinferredcommodities j1 <> jinferredcommodities j2 @@ -222,7 +239,9 @@ ,jincludefilestack = [] ,jdeclaredpayees = [] ,jdeclaredaccounts = [] + ,jdeclaredaccounttags = M.empty ,jdeclaredaccounttypes = M.empty + ,jaccounttypes = M.empty ,jglobalcommoditystyles = M.empty ,jcommodities = M.empty ,jinferredcommodities = M.empty @@ -334,9 +353,26 @@ journalAccountNames :: Journal -> [AccountName] journalAccountNames = journalAccountNamesDeclaredOrImplied +-- | Sorted unique account names declared or implied in this journal +-- which have no children. +journalLeafAccountNames :: Journal -> [AccountName] +journalLeafAccountNames = treeLeaves . journalAccountNameTree + journalAccountNameTree :: Journal -> Tree AccountName journalAccountNameTree = accountNameTreeFrom . journalAccountNamesDeclaredOrImplied +-- | Which tags have been declared explicitly for this account, if any ? +journalAccountTags :: Journal -> AccountName -> [Tag] +journalAccountTags Journal{jdeclaredaccounttags} a = M.findWithDefault [] a jdeclaredaccounttags + +-- | Which tags are in effect for this account, including tags inherited from parent accounts ? +journalInheritedAccountTags :: Journal -> AccountName -> [Tag] +journalInheritedAccountTags j a = + foldl' (\ts a -> ts `union` journalAccountTags j a) [] as + where + as = a : parentAccountNames a +-- PERF: cache in journal ? + -- | Find up to N most similar and most recent transactions matching -- the given transaction description and query. Transactions are -- listed with their description's similarity score (see @@ -395,13 +431,16 @@ -- queries for standard account types -- | Get a query for accounts of the specified types in this journal. --- Account types include Asset, Liability, Equity, Revenue, Expense, Cash. +-- Account types include: +-- Asset, Liability, Equity, Revenue, Expense, Cash, Conversion. -- For each type, if no accounts were declared with this type, the query -- will instead match accounts with names matched by the case-insensitive -- regular expression provided as a fallback. -- The query will match all accounts which were declared as one of -- these types (by account directives with the type: tag), plus all their -- subaccounts which have not been declared as some other type. +-- +-- This is older code pre-dating 2022's expansion of account types. journalAccountTypeQuery :: [AccountType] -> Regexp -> Journal -> Query journalAccountTypeQuery atypes fallbackregex Journal{jdeclaredaccounttypes} = let @@ -427,69 +466,55 @@ -- or otherwise for accounts with names matched by the case-insensitive -- regular expression @^assets?(:|$)@. journalAssetAccountQuery :: Journal -> Query -journalAssetAccountQuery j = +journalAssetAccountQuery j = Or [ - journalAccountTypeQuery [Asset] (toRegexCI' "^assets?(:|$)") j + journalAccountTypeQuery [Asset] assetAccountRegex j ,journalCashAccountOnlyQuery j ] --- | A query for accounts in this journal which have been --- declared as Asset (and not Cash) by account directives, --- or otherwise for accounts with names matched by the case-insensitive --- regular expression @^assets?(:|$)@. -journalAssetNonCashAccountQuery :: Journal -> Query -journalAssetNonCashAccountQuery = journalAccountTypeQuery [Asset] (toRegexCI' "^assets?(:|$)") - -- | A query for Cash (liquid asset) accounts in this journal, ie accounts --- declared as Cash by account directives, or otherwise Asset accounts whose --- names do not include the case-insensitive regular expression --- @(investment|receivable|:A/R|:fixed)@. -journalCashAccountQuery :: Journal -> Query -journalCashAccountQuery j = - case M.lookup Cash (jdeclaredaccounttypes j) of - Just _ -> journalCashAccountOnlyQuery j - Nothing -> - -- no Cash accounts are declared; query for Asset accounts and exclude some of them - And [ journalAssetNonCashAccountQuery j, Not . Acct $ toRegexCI' "(investment|receivable|:A/R|:fixed)" ] +-- declared as Cash by account directives, or otherwise accounts whose +-- names match the case-insensitive regular expression +-- @(^assets:(.+:)?(cash|bank)(:|$)@. +journalCashAccountQuery :: Journal -> Query +journalCashAccountQuery = journalAccountTypeQuery [Cash] cashAccountRegex -- | A query for accounts in this journal specifically declared as Cash by -- account directives, or otherwise the None query. -journalCashAccountOnlyQuery :: Journal -> Query -journalCashAccountOnlyQuery j = - case M.lookup Cash (jdeclaredaccounttypes j) of - Just _ -> - -- Cash accounts are declared; get a query for them (the fallback regex won't be used) - journalAccountTypeQuery [Cash] notused j - where notused = error' "journalCashAccountOnlyQuery: this should not have happened!" -- PARTIAL: - Nothing -> None +journalCashAccountOnlyQuery :: Journal -> Query +journalCashAccountOnlyQuery j + -- Cash accounts are declared; get a query for them (the fallback regex won't be used) + | Cash `M.member` jdeclaredaccounttypes j = journalAccountTypeQuery [Cash] notused j + | otherwise = None + where notused = error' "journalCashAccountOnlyQuery: this should not have happened!" -- PARTIAL: -- | A query for accounts in this journal which have been -- declared as Liability by account directives, or otherwise for -- accounts with names matched by the case-insensitive regular expression -- @^(debts?|liabilit(y|ies))(:|$)@. journalLiabilityAccountQuery :: Journal -> Query -journalLiabilityAccountQuery = journalAccountTypeQuery [Liability] (toRegexCI' "^(debts?|liabilit(y|ies))(:|$)") +journalLiabilityAccountQuery = journalAccountTypeQuery [Liability] liabilityAccountRegex -- | A query for accounts in this journal which have been -- declared as Equity by account directives, or otherwise for -- accounts with names matched by the case-insensitive regular expression -- @^equity(:|$)@. journalEquityAccountQuery :: Journal -> Query -journalEquityAccountQuery = journalAccountTypeQuery [Equity] (toRegexCI' "^equity(:|$)") +journalEquityAccountQuery = journalAccountTypeQuery [Equity] equityAccountRegex -- | A query for accounts in this journal which have been -- declared as Revenue by account directives, or otherwise for -- accounts with names matched by the case-insensitive regular expression -- @^(income|revenue)s?(:|$)@. journalRevenueAccountQuery :: Journal -> Query -journalRevenueAccountQuery = journalAccountTypeQuery [Revenue] (toRegexCI' "^(income|revenue)s?(:|$)") +journalRevenueAccountQuery = journalAccountTypeQuery [Revenue] revenueAccountRegex -- | A query for accounts in this journal which have been -- declared as Expense by account directives, or otherwise for -- accounts with names matched by the case-insensitive regular expression -- @^expenses?(:|$)@. journalExpenseAccountQuery :: Journal -> Query -journalExpenseAccountQuery = journalAccountTypeQuery [Expense] (toRegexCI' "^expenses?(:|$)") +journalExpenseAccountQuery = journalAccountTypeQuery [Expense] expenseAccountRegex -- | A query for Asset, Liability & Equity accounts in this journal. -- Cf . @@ -506,6 +531,54 @@ ,journalExpenseAccountQuery j ] +-- | The 'AccountName' to use for automatically generated conversion postings. +journalConversionAccount :: Journal -> AccountName +journalConversionAccount = + headDef (T.pack "equity:conversion") + . M.findWithDefault [] Conversion + . jdeclaredaccounttypes + +-- Newer account type functionality. + +journalAccountType :: Journal -> AccountName -> Maybe AccountType +journalAccountType Journal{jaccounttypes} = accountNameType jaccounttypes + +-- | Add a map of all known account types to the journal. +journalAddAccountTypes :: Journal -> Journal +journalAddAccountTypes j = j{jaccounttypes = journalAccountTypes j} + +-- | Build a map of all known account types, explicitly declared +-- or inferred from the account's parent or name. +journalAccountTypes :: Journal -> M.Map AccountName AccountType +journalAccountTypes j = M.fromList [(a,acctType) | (a, Just (acctType,_)) <- flatten t'] + where + t = accountNameTreeFrom $ journalAccountNames j :: Tree AccountName + t' = settypes Nothing t :: Tree (AccountName, Maybe (AccountType, Bool)) + -- Map from the top of the account tree down to the leaves, propagating + -- account types downward. Keep track of whether the account is declared + -- (True), in which case the parent account should be preferred, or merely + -- inferred (False), in which case the inferred type should be preferred. + settypes :: Maybe (AccountType, Bool) -> Tree AccountName -> Tree (AccountName, Maybe (AccountType, Bool)) + settypes mparenttype (Node a subs) = Node (a, mtype) (map (settypes mtype) subs) + where + mtype = M.lookup a declaredtypes <|> minferred + minferred = if maybe False snd mparenttype + then mparenttype + else (,False) <$> accountNameInferType a <|> mparenttype + declaredtypes = (,True) <$> journalDeclaredAccountTypes j + +-- | Build a map of the account types explicitly declared. +journalDeclaredAccountTypes :: Journal -> M.Map AccountName AccountType +journalDeclaredAccountTypes Journal{jdeclaredaccounttypes} = + M.fromList $ concat [map (,t) as | (t,as) <- M.toList jdeclaredaccounttypes] + +-- | To all postings in the journal, add any tags from their account +-- (including those inherited from parent accounts). +-- If the same tag exists on posting and account, the latter is ignored. +journalPostingsAddAccountTags :: Journal -> Journal +journalPostingsAddAccountTags j = journalMapPostings addtags j + where addtags p = p `postingAddTags` (journalInheritedAccountTags j $ paccount p) + -- Various kinds of filtering on journals. We do it differently depending -- on the command. @@ -514,12 +587,12 @@ -- | Keep only transactions matching the query expression. filterJournalTransactions :: Query -> Journal -> Journal -filterJournalTransactions q j@Journal{jtxns=ts} = j{jtxns=filter (q `matchesTransaction`) ts} +filterJournalTransactions q j@Journal{jtxns} = j{jtxns=filter (matchesTransactionExtra (journalAccountType j) q) jtxns} -- | Keep only postings matching the query expression. -- This can leave unbalanced transactions. filterJournalPostings :: Query -> Journal -> Journal -filterJournalPostings q j@Journal{jtxns=ts} = j{jtxns=map (filterTransactionPostings q) ts} +filterJournalPostings q j@Journal{jtxns=ts} = j{jtxns=map (filterTransactionPostingsExtra (journalAccountType j) q) ts} -- | Keep only postings which do not match the query expression, but for which a related posting does. -- This can leave unbalanced transactions. @@ -550,6 +623,11 @@ filterTransactionPostings :: Query -> Transaction -> Transaction filterTransactionPostings q t@Transaction{tpostings=ps} = t{tpostings=filter (q `matchesPosting`) ps} +-- Like filterTransactionPostings, but is given the map of account types so can also filter by account type. +filterTransactionPostingsExtra :: (AccountName -> Maybe AccountType) -> Query -> Transaction -> Transaction +filterTransactionPostingsExtra atypes q t@Transaction{tpostings=ps} = + t{tpostings=filter (matchesPostingExtra atypes q) ps} + filterTransactionRelatedPostings :: Query -> Transaction -> Transaction filterTransactionRelatedPostings q t@Transaction{tpostings=ps} = t{tpostings=if null matches then [] else ps \\ matches} @@ -732,7 +810,7 @@ -- relative dates in transaction modifier queries. journalModifyTransactions :: Day -> Journal -> Either String Journal journalModifyTransactions d j = - case modifyTransactions (journalCommodityStyles j) d (jtxnmodifiers j) (jtxns j) of + case modifyTransactions (journalAccountType j) (journalInheritedAccountTags j) (journalCommodityStyles j) d (jtxnmodifiers j) (jtxns j) of Right ts -> Right j{jtxns=ts} Left err -> Left err @@ -870,11 +948,17 @@ -- | Convert all this journal's amounts to cost using the transaction prices, if any. -- The journal's commodity styles are applied to the resulting amounts. -journalToCost :: Journal -> Journal -journalToCost j@Journal{jtxns=ts} = j{jtxns=map (transactionToCost styles) ts} - where - styles = journalCommodityStyles j +journalToCost :: ConversionOp -> Journal -> Journal +journalToCost cost j@Journal{jtxns=ts} = j{jtxns=map (transactionToCost styles cost) ts} + where + styles = journalCommodityStyles j +-- | Add inferred equity postings to a 'Journal' using transaction prices. +journalAddInferredEquityPostings :: Journal -> Journal +journalAddInferredEquityPostings j = journalMapTransactions (transactionAddInferredEquityPostings equityAcct) j + where + equityAcct = journalConversionAccount j + -- -- | Get this journal's unique, display-preference-canonicalised commodities, by symbol. -- journalCanonicalCommodities :: Journal -> M.Map String CommoditySymbol -- journalCanonicalCommodities j = canonicaliseCommodities $ journalAmountCommodities j @@ -1221,7 +1305,7 @@ namesfrom qfunc = journalAccountNamesMatching (qfunc j) j in [testCase "assets" $ assertEqual "" ["assets","assets:bank","assets:bank:checking","assets:bank:saving","assets:cash"] (namesfrom journalAssetAccountQuery) - ,testCase "cash" $ assertEqual "" ["assets","assets:bank","assets:bank:checking","assets:bank:saving","assets:cash"] + ,testCase "cash" $ assertEqual "" ["assets:bank","assets:bank:checking","assets:bank:saving","assets:cash"] (namesfrom journalCashAccountQuery) ,testCase "liabilities" $ assertEqual "" ["liabilities","liabilities:debts"] (namesfrom journalLiabilityAccountQuery) diff --git a/Hledger/Data/PeriodicTransaction.hs b/Hledger/Data/PeriodicTransaction.hs --- a/Hledger/Data/PeriodicTransaction.hs +++ b/Hledger/Data/PeriodicTransaction.hs @@ -263,7 +263,7 @@ _ -> Nothing where checkStart d x = - let firstDate = fixSmartDate d $ SmartRelative This x + let firstDate = fixSmartDate d $ SmartRelative 0 x in if d == firstDate then Nothing diff --git a/Hledger/Data/Posting.hs b/Hledger/Data/Posting.hs --- a/Hledger/Data/Posting.hs +++ b/Hledger/Data/Posting.hs @@ -39,6 +39,7 @@ postingStripPrices, postingApplyAliases, postingApplyCommodityStyles, + postingAddTags, -- * date operations postingDate, postingDate2, @@ -47,13 +48,6 @@ isPostingInDateSpan', -- * account name operations accountNamesFromPostings, - accountNamePostingType, - accountNameWithoutPostingType, - accountNameWithPostingType, - joinAccountNames, - concatAccountNames, - accountNameApplyAliases, - accountNameApplyAliasesMemo, -- * comment/tag operations commentJoin, commentAddTag, @@ -71,24 +65,23 @@ postingTransformAmount, postingApplyValuation, postingToCost, + postingAddInferredEquityPostings, tests_Posting ) where -import Control.Monad (foldM) import Data.Default (def) import Data.Foldable (asum) import qualified Data.Map as M import Data.Maybe (fromMaybe, isJust) -import Data.MemoUgly (memo) -import Data.List (foldl') +import Data.List (foldl', sort, union) import qualified Data.Set as S import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Builder as TB import Data.Time.Calendar (Day) -import Safe (headDef, maximumBound) +import Safe (maximumBound) import Text.DocLayout (realLength) import Text.Tabular.AsciiWide @@ -393,38 +386,6 @@ isEmptyPosting :: Posting -> Bool isEmptyPosting = mixedAmountLooksZero . pamount --- AccountName stuff that depends on PostingType - -accountNamePostingType :: AccountName -> PostingType -accountNamePostingType a - | T.null a = RegularPosting - | T.head a == '[' && T.last a == ']' = BalancedVirtualPosting - | T.head a == '(' && T.last a == ')' = VirtualPosting - | otherwise = RegularPosting - -accountNameWithoutPostingType :: AccountName -> AccountName -accountNameWithoutPostingType a = case accountNamePostingType a of - BalancedVirtualPosting -> T.init $ T.tail a - VirtualPosting -> T.init $ T.tail a - RegularPosting -> a - -accountNameWithPostingType :: PostingType -> AccountName -> AccountName -accountNameWithPostingType BalancedVirtualPosting = wrap "[" "]" . accountNameWithoutPostingType -accountNameWithPostingType VirtualPosting = wrap "(" ")" . accountNameWithoutPostingType -accountNameWithPostingType RegularPosting = accountNameWithoutPostingType - --- | Prefix one account name to another, preserving posting type --- indicators like concatAccountNames. -joinAccountNames :: AccountName -> AccountName -> AccountName -joinAccountNames a b = concatAccountNames $ filter (not . T.null) [a,b] - --- | Join account names into one. If any of them has () or [] posting type --- indicators, these (the first type encountered) will also be applied to --- the resulting account name. -concatAccountNames :: [AccountName] -> AccountName -concatAccountNames as = accountNameWithPostingType t $ T.intercalate ":" $ map accountNameWithoutPostingType as - where t = headDef RegularPosting $ filter (/= RegularPosting) $ map accountNamePostingType as - -- | Apply some account aliases to the posting's account name, as described by accountNameApplyAliases. -- This can fail due to a bad replacement pattern in a regular expression alias. postingApplyAliases :: [AccountAlias] -> Posting -> Either RegexError Posting @@ -444,34 +405,9 @@ where fixbalanceassertion ba = ba{baamount=styleAmountExceptPrecision styles $ baamount ba} --- | Rewrite an account name using all matching aliases from the given list, in sequence. --- Each alias sees the result of applying the previous aliases. --- Or, return any error arising from a bad regular expression in the aliases. -accountNameApplyAliases :: [AccountAlias] -> AccountName -> Either RegexError AccountName -accountNameApplyAliases aliases a = - let (aname,atype) = (accountNameWithoutPostingType a, accountNamePostingType a) - in foldM - (\acct alias -> dbg6 "result" $ aliasReplace (dbg6 "alias" alias) (dbg6 "account" acct)) - aname - aliases - >>= Right . accountNameWithPostingType atype - --- | Memoising version of accountNameApplyAliases, maybe overkill. -accountNameApplyAliasesMemo :: [AccountAlias] -> AccountName -> Either RegexError AccountName -accountNameApplyAliasesMemo aliases = memo (accountNameApplyAliases aliases) - -- XXX re-test this memoisation - --- aliasMatches :: AccountAlias -> AccountName -> Bool --- aliasMatches (BasicAlias old _) a = old `isAccountNamePrefixOf` a --- aliasMatches (RegexAlias re _) a = regexMatchesCI re a - -aliasReplace :: AccountAlias -> AccountName -> Either RegexError AccountName -aliasReplace (BasicAlias old new) a - | old `isAccountNamePrefixOf` a || old == a = - Right $ new <> T.drop (T.length old) a - | otherwise = Right a -aliasReplace (RegexAlias re repl) a = - fmap T.pack . regexReplace re repl $ T.unpack a -- XXX +-- | Add tags to a posting, discarding any for which the posting already has a value. +postingAddTags :: Posting -> [Tag] -> Posting +postingAddTags p@Posting{ptags} tags = p{ptags=ptags `union` tags} -- | Apply a specified valuation to this posting's amount, using the -- provided price oracle, commodity styles, and reference dates. @@ -480,9 +416,45 @@ postingApplyValuation priceoracle styles periodlast today v p = postingTransformAmount (mixedAmountApplyValuation priceoracle styles periodlast today (postingDate p) v) p --- | Convert this posting's amount to cost, and apply the appropriate amount styles. -postingToCost :: M.Map CommoditySymbol AmountStyle -> Posting -> Posting -postingToCost styles = postingTransformAmount (styleMixedAmount styles . mixedAmountCost) +-- | Maybe convert this 'Posting's amount to cost, and apply apply appropriate +-- amount styles. +postingToCost :: M.Map CommoditySymbol AmountStyle -> ConversionOp -> Posting -> Posting +postingToCost _ NoConversionOp p = p +postingToCost styles ToCost p = postingTransformAmount (styleMixedAmount styles . mixedAmountCost) p + +-- | Generate inferred equity postings from a 'Posting' using transaction prices. +postingAddInferredEquityPostings :: Text -> Posting -> [Posting] +postingAddInferredEquityPostings equityAcct p = taggedPosting : concatMap conversionPostings priceAmounts + where + taggedPosting + | null priceAmounts = p + | otherwise = p{ pcomment = pcomment p `commentAddTag` priceTag + , ptags = priceTag : ptags p + } + conversionPostings amt = case aprice amt of + Nothing -> [] + Just _ -> [ cp{ paccount = accountPrefix <> amtCommodity + , pamount = mixedAmount . negate $ amountStripPrices amt + } + , cp{ paccount = accountPrefix <> costCommodity + , pamount = mixedAmount cost + } + ] + where + cost = amountCost amt + amtCommodity = commodity amt + costCommodity = commodity cost + cp = p{ pcomment = pcomment p `commentAddTag` ("generated-posting","") + , ptags = [("generated-posting", ""), ("_generated-posting", "")] + , pbalanceassertion = Nothing + , poriginal = Nothing + } + accountPrefix = mconcat [ equityAcct, ":", T.intercalate "-" $ sort [amtCommodity, costCommodity], ":"] + -- Take the commodity of an amount and collapse consecutive spaces to a single space + commodity = T.unwords . filter (not . T.null) . T.words . acommodity + + priceTag = ("cost", T.strip . wbToText $ foldMap showAmountPrice priceAmounts) + priceAmounts = filter (isJust . aprice) . amountsRaw $ pamount p -- | Apply a transform function to this posting's amount. postingTransformAmount :: (MixedAmount -> MixedAmount) -> Posting -> Posting diff --git a/Hledger/Data/Transaction.hs b/Hledger/Data/Transaction.hs --- a/Hledger/Data/Transaction.hs +++ b/Hledger/Data/Transaction.hs @@ -9,7 +9,6 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} module Hledger.Data.Transaction ( -- * Transaction @@ -27,6 +26,7 @@ , transactionTransformPostings , transactionApplyValuation , transactionToCost +, transactionAddInferredEquityPostings , transactionApplyAliases , transactionMapPostings , transactionMapPostingAmounts @@ -202,9 +202,15 @@ transactionApplyValuation priceoracle styles periodlast today v = transactionTransformPostings (postingApplyValuation priceoracle styles periodlast today v) --- | Convert this transaction's amounts to cost, and apply the appropriate amount styles. -transactionToCost :: M.Map CommoditySymbol AmountStyle -> Transaction -> Transaction -transactionToCost styles = transactionTransformPostings (postingToCost styles) +-- | Maybe convert this 'Transaction's amounts to cost and apply the +-- appropriate amount styles. +transactionToCost :: M.Map CommoditySymbol AmountStyle -> ConversionOp -> Transaction -> Transaction +transactionToCost styles cost = transactionMapPostings (postingToCost styles cost) + +-- | Add inferred equity postings to a 'Transaction' using transaction prices. +transactionAddInferredEquityPostings :: AccountName -> Transaction -> Transaction +transactionAddInferredEquityPostings equityAcct t = + t{tpostings=concatMap (postingAddInferredEquityPostings equityAcct) $ tpostings t} -- | 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. diff --git a/Hledger/Data/TransactionModifier.hs b/Hledger/Data/TransactionModifier.hs --- a/Hledger/Data/TransactionModifier.hs +++ b/Hledger/Data/TransactionModifier.hs @@ -18,12 +18,12 @@ import qualified Data.Text as T import Data.Time.Calendar (Day) import Hledger.Data.Types -import Hledger.Data.Dates import Hledger.Data.Amount +import Hledger.Data.Dates import Hledger.Data.Transaction (txnTieKnot) -import Hledger.Query (Query, filterQuery, matchesAmount, matchesPosting, +import Hledger.Query (Query, filterQuery, matchesAmount, matchesPostingExtra, parseQuery, queryIsAmt, queryIsSym, simplifyQuery) -import Hledger.Data.Posting (commentJoin, commentAddTag, postingApplyCommodityStyles) +import Hledger.Data.Posting (commentJoin, commentAddTag, postingAddTags, postingApplyCommodityStyles) import Hledger.Utils (dbg6, wrap) -- $setup @@ -36,9 +36,13 @@ -- Or if any of them fails to be parsed, return the first error. A reference -- date is provided to help interpret relative dates in transaction modifier -- queries. -modifyTransactions :: M.Map CommoditySymbol AmountStyle -> Day -> [TransactionModifier] -> [Transaction] -> Either String [Transaction] -modifyTransactions styles d tmods ts = do - fs <- mapM (transactionModifierToFunction styles d) tmods -- convert modifiers to functions, or return a parse error +modifyTransactions :: (AccountName -> Maybe AccountType) + -> (AccountName -> [Tag]) + -> M.Map CommoditySymbol AmountStyle + -> Day -> [TransactionModifier] -> [Transaction] + -> Either String [Transaction] +modifyTransactions atypes atags styles d tmods ts = do + fs <- mapM (transactionModifierToFunction atypes atags styles d) tmods -- convert modifiers to functions, or return a parse error let modifytxn t = t'' where @@ -62,7 +66,7 @@ -- >>> import qualified Data.Text.IO as T -- >>> t = nulltransaction{tpostings=["ping" `post` usd 1]} -- >>> tmpost acc amt = TMPostingRule (acc `post` amt) False --- >>> test = either putStr (T.putStr.showTransaction) . fmap ($ t) . transactionModifierToFunction mempty nulldate +-- >>> test = either putStr (T.putStr.showTransaction) . fmap ($ t) . transactionModifierToFunction (const Nothing) (const []) mempty nulldate -- >>> test $ TransactionModifier "" ["pong" `tmpost` usd 2] -- 0000-01-01 -- ping $1.00 @@ -78,13 +82,18 @@ -- pong $3.00 ; generated-posting: = ping -- -- -transactionModifierToFunction :: M.Map CommoditySymbol AmountStyle -> Day -> TransactionModifier -> Either String (Transaction -> Transaction) -transactionModifierToFunction styles refdate TransactionModifier{tmquerytxt, tmpostingrules} = do +transactionModifierToFunction :: (AccountName -> Maybe AccountType) + -> (AccountName -> [Tag]) + -> M.Map CommoditySymbol AmountStyle + -> Day -> TransactionModifier + -> Either String (Transaction -> Transaction) +transactionModifierToFunction atypes atags styles refdate TransactionModifier{tmquerytxt, tmpostingrules} = do q <- simplifyQuery . fst <$> parseQuery refdate tmquerytxt let - fs = map (tmPostingRuleToFunction styles q tmquerytxt) tmpostingrules - generatePostings = concatMap (\p -> p : map ($ p) (if q `matchesPosting` p then fs else [])) - Right $ \t@(tpostings -> ps) -> txnTieKnot t{tpostings=generatePostings ps} + fs = map (\tmpr -> addAccountTags . tmPostingRuleToFunction styles q tmquerytxt tmpr) tmpostingrules + addAccountTags p = p `postingAddTags` atags (paccount p) + generatePostings p = p : map ($ p) (if matchesPostingExtra atypes q p then fs else []) + Right $ \t@(tpostings -> ps) -> txnTieKnot t{tpostings=concatMap generatePostings ps} -- | Converts a 'TransactionModifier''s posting rule to a 'Posting'-generating function, -- which will be used to make a new posting based on the old one (an "automated posting"). diff --git a/Hledger/Data/Types.hs b/Hledger/Data/Types.hs --- a/Hledger/Data/Types.hs +++ b/Hledger/Data/Types.hs @@ -84,10 +84,9 @@ = SmartAssumeStart Year (Maybe (Month, Maybe MonthDay)) | SmartFromReference (Maybe Month) MonthDay | SmartMonth Month - | SmartRelative SmartSequence SmartInterval + | SmartRelative Integer SmartInterval deriving (Show) -data SmartSequence = Last | This | Next deriving (Show) data SmartInterval = Day | Week | Month | Quarter | Year deriving (Show) data WhichDate = PrimaryDate | SecondaryDate deriving (Eq,Show) @@ -151,8 +150,32 @@ | Revenue | Expense | Cash -- ^ a subtype of Asset - liquid assets to show in cashflow report - deriving (Show,Eq,Ord,Generic) + | Conversion -- ^ a subtype of Equity - account in which to generate conversion postings for transaction prices + deriving (Eq,Ord,Generic) +instance Show AccountType where + show Asset = "A" + show Liability = "L" + show Equity = "E" + show Revenue = "R" + show Expense = "X" + show Cash = "C" + show Conversion = "V" + +-- | Check whether the first argument is a subtype of the second: either equal +-- or one of the defined subtypes. +isAccountSubtypeOf :: AccountType -> AccountType -> Bool +isAccountSubtypeOf Asset Asset = True +isAccountSubtypeOf Liability Liability = True +isAccountSubtypeOf Equity Equity = True +isAccountSubtypeOf Revenue Revenue = True +isAccountSubtypeOf Expense Expense = True +isAccountSubtypeOf Cash Cash = True +isAccountSubtypeOf Cash Asset = True +isAccountSubtypeOf Conversion Conversion = True +isAccountSubtypeOf Conversion Equity = True +isAccountSubtypeOf _ _ = False + -- not worth the trouble, letters defined in accountdirectivep for now --instance Read AccountType -- where @@ -362,7 +385,8 @@ pamount :: MixedAmount, pcomment :: Text, -- ^ this posting's comment lines, as a single non-indented multi-line string ptype :: PostingType, - ptags :: [Tag], -- ^ tag names and values, extracted from the comment + ptags :: [Tag], -- ^ tag names and values, extracted from the posting comment + -- and (after finalisation) the posting account's directive if any pbalanceassertion :: Maybe BalanceAssertion, -- ^ an expected balance in the account after this posting, -- in a single commodity, excluding subaccounts. ptransaction :: Maybe Transaction, -- ^ this posting's parent transaction (co-recursive types). @@ -512,7 +536,9 @@ -- principal data ,jdeclaredpayees :: [(Payee,PayeeDeclarationInfo)] -- ^ Payees declared by payee directives, in parse order (after journal finalisation) ,jdeclaredaccounts :: [(AccountName,AccountDeclarationInfo)] -- ^ Accounts declared by account directives, in parse order (after journal finalisation) - ,jdeclaredaccounttypes :: M.Map AccountType [AccountName] -- ^ Accounts whose type has been declared in account directives (usually 5 top-level accounts) + ,jdeclaredaccounttags :: M.Map AccountName [Tag] -- ^ Accounts which have tags declared in their directives, and those tags. (Does not include parents' tags.) + ,jdeclaredaccounttypes :: M.Map AccountType [AccountName] -- ^ Accounts whose type has been explicitly declared in their account directives, grouped by type. + ,jaccounttypes :: M.Map AccountName AccountType -- ^ All accounts for which a type has been declared or can be inferred from its parent or its name. ,jglobalcommoditystyles :: M.Map CommoditySymbol AmountStyle -- ^ per-commodity display styles declared globally, eg by command line option or import command ,jcommodities :: M.Map CommoditySymbol Commodity -- ^ commodities and formats declared by commodity directives ,jinferredcommodities :: M.Map CommoditySymbol AmountStyle -- ^ commodities and formats inferred from journal amounts @@ -528,6 +554,8 @@ -- TODO: FilePath is a sloppy type here, don't assume it's a -- real file; values like "", "-", "(string)" can be seen ,jlastreadtime :: POSIXTime -- ^ when this journal was last read from its file(s) + -- NOTE: after adding new fields, eg involving account names, consider updating + -- the Anon instance in Hleger.Cli.Anon } deriving (Eq, Generic) -- | A journal in the process of being parsed, not yet finalised. diff --git a/Hledger/Data/Valuation.hs b/Hledger/Data/Valuation.hs --- a/Hledger/Data/Valuation.hs +++ b/Hledger/Data/Valuation.hs @@ -13,7 +13,7 @@ {-# LANGUAGE DeriveGeneric #-} module Hledger.Data.Valuation ( - Costing(..) + ConversionOp(..) ,ValuationType(..) ,PriceOracle ,journalPriceOracle @@ -51,8 +51,10 @@ ------------------------------------------------------------------------------ -- Types --- | Whether to convert amounts to cost. -data Costing = Cost | NoCost +-- | Which operation to perform on conversion transactions. +-- (There was also an "infer equity postings" operation, but that is now done +-- earlier, in journal finalisation.) +data ConversionOp = NoConversionOp | ToCost deriving (Show,Eq) -- | What kind of value conversion should be done on amounts ? @@ -98,8 +100,8 @@ -- Converting things to value -- | Convert all component amounts to cost/selling price if requested, and style them. -mixedAmountToCost :: Costing -> M.Map CommoditySymbol AmountStyle -> MixedAmount -> MixedAmount -mixedAmountToCost cost styles = mapMixedAmount (amountToCost cost styles) +mixedAmountToCost :: M.Map CommoditySymbol AmountStyle -> ConversionOp -> MixedAmount -> MixedAmount +mixedAmountToCost styles cost = mapMixedAmount (amountToCost styles cost) -- | Apply a specified valuation to this mixed amount, using the -- provided price oracle, commodity styles, and reference dates. @@ -109,9 +111,9 @@ mapMixedAmount (amountApplyValuation priceoracle styles periodlast today postingdate v) -- | Convert an Amount to its cost if requested, and style it appropriately. -amountToCost :: Costing -> M.Map CommoditySymbol AmountStyle -> Amount -> Amount -amountToCost NoCost _ = id -amountToCost Cost styles = styleAmount styles . amountCost +amountToCost :: M.Map CommoditySymbol AmountStyle -> ConversionOp -> Amount -> Amount +amountToCost styles ToCost = styleAmount styles . amountCost +amountToCost _ NoConversionOp = id -- | Apply a specified valuation to this amount, using the provided -- price oracle, and reference dates. Also fix up its display style diff --git a/Hledger/Query.hs b/Hledger/Query.hs --- a/Hledger/Query.hs +++ b/Hledger/Query.hs @@ -21,6 +21,7 @@ parseQuery, parseQueryList, parseQueryTerm, + parseAccountType, simplifyQuery, filterQuery, filterQueryOrNotQuery, @@ -36,6 +37,8 @@ queryIsSym, queryIsReal, queryIsStatus, + queryIsType, + queryIsTag, queryStartDate, queryEndDate, queryDateSpan, @@ -45,10 +48,13 @@ inAccountQuery, -- * matching matchesTransaction, + matchesTransactionExtra, matchesDescription, matchesPayeeWIP, matchesPosting, + matchesPostingExtra, matchesAccount, + matchesAccountExtra, matchesMixedAmount, matchesAmount, matchesCommodity, @@ -64,7 +70,7 @@ import Control.Applicative ((<|>), many, optional) import Data.Default (Default(..)) import Data.Either (fromLeft, partitionEithers) -import Data.List (partition) +import Data.List (partition, intercalate) import Data.Maybe (fromMaybe, isJust, mapMaybe) import Data.Text (Text) import qualified Data.Text as T @@ -103,6 +109,7 @@ -- and sometimes like a query option (for controlling display) | Tag Regexp (Maybe Regexp) -- ^ match if a tag's name, and optionally its value, is matched by these respective regexps -- matching the regexp if provided, exists + | Type [AccountType] -- ^ match accounts whose type is one of these (or with no types, any account) deriving (Eq,Show) instance Default Query where def = Any @@ -238,6 +245,7 @@ ,"empty" ,"depth" ,"tag" + ,"type" ] defaultprefix :: T.Text @@ -286,6 +294,7 @@ parseQueryTerm _ (T.stripPrefix "cur:" -> Just s) = Left . Sym <$> toRegexCI ("^" <> s <> "$") -- support cur: as an alias parseQueryTerm _ (T.stripPrefix "tag:" -> Just s) = Left <$> parseTag s +parseQueryTerm _ (T.stripPrefix "type:" -> Just s) = Left <$> parseTypeCodes s parseQueryTerm _ "" = Right $ Left $ Any parseQueryTerm d s = parseQueryTerm d $ defaultprefix<>":"<>s @@ -339,6 +348,45 @@ return $ Tag tag body where (n,v) = T.break (=='=') s +-- | Parse one or more account type code letters to a query matching any of those types. +parseTypeCodes :: T.Text -> Either String Query +parseTypeCodes s = + case partitionEithers $ map (parseAccountType False . T.singleton) $ T.unpack s of + ((e:_),_) -> Left $ "could not parse " <> show e <> " as an account type code.\n" <> help + ([],[]) -> Left help + ([],ts) -> Right $ Type ts + where + help = "type:'s argument should be one or more of " ++ accountTypeChoices False ++ " (case insensitive)." + +accountTypeChoices :: Bool -> String +accountTypeChoices allowlongform = + intercalate ", " + -- keep synced with parseAccountType + $ ["A","L","E","R","X","C","V"] + ++ if allowlongform then ["Asset","Liability","Equity","Revenue","Expense","Cash","Conversion"] else [] + +-- | Case-insensitively parse one single-letter code, or one long-form word if permitted, to an account type. +-- On failure, returns the unparseable text. +parseAccountType :: Bool -> Text -> Either String AccountType +parseAccountType allowlongform s = + case T.toLower s of + -- keep synced with accountTypeChoices + "a" -> Right Asset + "l" -> Right Liability + "e" -> Right Equity + "r" -> Right Revenue + "x" -> Right Expense + "c" -> Right Cash + "v" -> Right Conversion + "asset" | allowlongform -> Right Asset + "liability" | allowlongform -> Right Liability + "equity" | allowlongform -> Right Equity + "revenue" | allowlongform -> Right Revenue + "expense" | allowlongform -> Right Expense + "cash" | allowlongform -> Right Cash + "conversion" | allowlongform -> Right Conversion + _ -> Left $ T.unpack s + -- | Parse the value part of a "status:" query, or return an error. parseStatus :: T.Text -> Either String Status parseStatus s | s `elem` ["*","1"] = Right Cleared @@ -457,6 +505,14 @@ queryIsStatus (StatusQ _) = True queryIsStatus _ = False +queryIsType :: Query -> Bool +queryIsType (Type _) = True +queryIsType _ = False + +queryIsTag :: Query -> Bool +queryIsTag (Tag _ _) = True +queryIsTag _ = False + -- | Does this query specify a start date and nothing else (that would -- filter postings prior to the date) ? -- When the flag is true, look for a starting secondary date instead. @@ -562,25 +618,6 @@ -- matching --- | Does the match expression match this account ? --- A matching in: clause is also considered a match. --- When matching by account name pattern, if there's a regular --- expression error, this function calls error. -matchesAccount :: Query -> AccountName -> Bool -matchesAccount (None) _ = False -matchesAccount (Not m) a = not $ matchesAccount m a -matchesAccount (Or ms) a = any (`matchesAccount` a) ms -matchesAccount (And ms) a = all (`matchesAccount` a) ms -matchesAccount (Acct r) a = regexMatchText r a -matchesAccount (Depth d) a = accountNameLevel a <= d -matchesAccount (Tag _ _) _ = False -matchesAccount _ _ = True - -matchesMixedAmount :: Query -> MixedAmount -> Bool -matchesMixedAmount q ma = case amountsRaw ma of - [] -> q `matchesAmount` nullamt - as -> any (q `matchesAmount`) as - matchesCommodity :: Query -> CommoditySymbol -> Bool matchesCommodity (Sym r) = regexMatchText r matchesCommodity _ = const True @@ -596,9 +633,6 @@ matchesAmount (Sym r) a = matchesCommodity (Sym r) (acommodity a) matchesAmount _ _ = True --- | Is this simple (single-amount) mixed amount's quantity less than, greater than, equal to, or unsignedly equal to this number ? --- For multi-amount (multiple commodities, or just unsimplified) mixed amounts this is always true. - -- | Is this amount's quantity less than, greater than, equal to, or unsignedly equal to this number ? compareAmount :: OrdPlus -> Quantity -> Amount -> Bool compareAmount ord q Amount{aquantity=aq} = case ord of Lt -> aq < q @@ -612,9 +646,42 @@ AbsGtEq -> abs aq >= abs q AbsEq -> abs aq == abs q --- | Does the match expression match this posting ? +matchesMixedAmount :: Query -> MixedAmount -> Bool +matchesMixedAmount q ma = case amountsRaw ma of + [] -> q `matchesAmount` nullamt + as -> any (q `matchesAmount`) as + +-- | Does the query match this account name ? +-- A matching in: clause is also considered a match. +matchesAccount :: Query -> AccountName -> Bool +matchesAccount (None) _ = False +matchesAccount (Not m) a = not $ matchesAccount m a +matchesAccount (Or ms) a = any (`matchesAccount` a) ms +matchesAccount (And ms) a = all (`matchesAccount` a) ms +matchesAccount (Acct r) a = regexMatchText r a +matchesAccount (Depth d) a = accountNameLevel a <= d +matchesAccount (Tag _ _) _ = False +matchesAccount _ _ = True + +-- | Like matchesAccount, but with optional extra matching features: -- --- Note that for account match we try both original and effective account +-- - If the account's type is provided, any type: terms in the query +-- must match it (and any negated type: terms must not match it). +-- +-- - If the account's tags are provided, any tag: terms must match +-- at least one of them (and any negated tag: terms must match none). +-- +matchesAccountExtra :: (AccountName -> Maybe AccountType) -> (AccountName -> [Tag]) -> Query -> AccountName -> Bool +matchesAccountExtra atypes atags (Not q ) a = not $ matchesAccountExtra atypes atags q a +matchesAccountExtra atypes atags (Or qs ) a = any (\q -> matchesAccountExtra atypes atags q a) qs +matchesAccountExtra atypes atags (And qs ) a = all (\q -> matchesAccountExtra atypes atags q a) qs +matchesAccountExtra atypes _ (Type ts) a = maybe False (\t -> any (t `isAccountSubtypeOf`) ts) $ atypes a +matchesAccountExtra _ atags (Tag npat vpat) a = matchesTags npat vpat $ atags a +matchesAccountExtra _ _ q a = matchesAccount q a + +-- | Does the match expression match this posting ? +-- When matching account name, and the posting has been transformed +-- in some way, we will match either the original or transformed name. matchesPosting :: Query -> Posting -> Bool matchesPosting (Not q) p = not $ q `matchesPosting` p matchesPosting (Any) _ = True @@ -623,8 +690,7 @@ matchesPosting (And qs) p = all (`matchesPosting` p) qs matchesPosting (Code r) p = maybe False (regexMatchText r . tcode) $ ptransaction p matchesPosting (Desc r) p = maybe False (regexMatchText r . tdescription) $ ptransaction p -matchesPosting (Acct r) p = matches p || maybe False matches (poriginal p) - where matches = regexMatchText r . paccount +matchesPosting (Acct r) p = matches p || maybe False matches (poriginal p) where matches = regexMatchText r . paccount matchesPosting (Date span) p = span `spanContainsDate` postingDate p matchesPosting (Date2 span) p = span `spanContainsDate` postingDate2 p matchesPosting (StatusQ s) p = postingStatus p == s @@ -635,8 +701,19 @@ matchesPosting (Tag n v) p = case (reString n, v) of ("payee", Just v) -> maybe False (regexMatchText v . transactionPayee) $ ptransaction p ("note", Just v) -> maybe False (regexMatchText v . transactionNote) $ ptransaction p - (_, v) -> matchesTags n v $ postingAllTags p + (_, mv) -> matchesTags n mv $ postingAllTags p +matchesPosting (Type _) _ = False +-- | Like matchesPosting, but if the posting's account's type is provided, +-- any type: terms in the query must match it (and any negated type: terms +-- must not match it). +matchesPostingExtra :: (AccountName -> Maybe AccountType) -> Query -> Posting -> Bool +matchesPostingExtra atype (Not q ) p = not $ matchesPostingExtra atype q p +matchesPostingExtra atype (Or qs) p = any (\q -> matchesPostingExtra atype q p) qs +matchesPostingExtra atype (And qs) p = all (\q -> matchesPostingExtra atype q p) qs +matchesPostingExtra atype (Type ts) p = maybe False (\t -> any (t `isAccountSubtypeOf`) ts) . atype $ paccount p +matchesPostingExtra _ q p = matchesPosting q p + -- | Does the match expression match this transaction ? matchesTransaction :: Query -> Transaction -> Bool matchesTransaction (Not q) t = not $ q `matchesTransaction` t @@ -658,7 +735,18 @@ ("payee", Just v) -> regexMatchText v $ transactionPayee t ("note", Just v) -> regexMatchText v $ transactionNote t (_, v) -> matchesTags n v $ transactionAllTags t +matchesTransaction (Type _) _ = False +-- | Like matchesTransaction, but if the journal's account types are provided, +-- any type: terms in the query must match at least one posting's account type +-- (and any negated type: terms must match none). +matchesTransactionExtra :: (AccountName -> Maybe AccountType) -> Query -> Transaction -> Bool +matchesTransactionExtra atype (Not q) t = not $ matchesTransactionExtra atype q t +matchesTransactionExtra atype (Or qs) t = any (\q -> matchesTransactionExtra atype q t) qs +matchesTransactionExtra atype (And qs) t = all (\q -> matchesTransactionExtra atype q t) qs +matchesTransactionExtra atype q@(Type _) t = any (matchesPostingExtra atype q) $ tpostings t +matchesTransactionExtra _ q t = matchesTransaction q t + -- | Does the query match this transaction description ? -- Tests desc: terms, any other terms are ignored. matchesDescription :: Query -> Text -> Bool @@ -669,15 +757,7 @@ matchesDescription (And qs) d = all (`matchesDescription` d) $ filter queryIsDesc qs matchesDescription (Code _) _ = False matchesDescription (Desc r) d = regexMatchText r d -matchesDescription (Acct _) _ = False -matchesDescription (Date _) _ = False -matchesDescription (Date2 _) _ = False -matchesDescription (StatusQ _) _ = False -matchesDescription (Real _) _ = False -matchesDescription (Amt _ _) _ = False -matchesDescription (Depth _) _ = False -matchesDescription (Sym _) _ = False -matchesDescription (Tag _ _) _ = False +matchesDescription _ _ = False -- | Does the query match this transaction payee ? -- Tests desc: (and payee: ?) terms, any other terms are ignored. @@ -800,6 +880,11 @@ assertBool "" $ Date nulldatespan `matchesAccount` "a" assertBool "" $ Date2 nulldatespan `matchesAccount` "a" assertBool "" $ not $ Tag (toRegex' "a") Nothing `matchesAccount` "a" + + ,testCase "matchesAccountExtra" $ do + let tagq = Tag (toRegexCI' "type") Nothing + assertBool "" $ not $ matchesAccountExtra (const Nothing) (const []) tagq "a" + assertBool "" $ matchesAccountExtra (const Nothing) (const [("type","")]) tagq "a" ,testGroup "matchesPosting" [ testCase "positive match on cleared posting status" $ diff --git a/Hledger/Read/Common.hs b/Hledger/Read/Common.hs --- a/Hledger/Read/Common.hs +++ b/Hledger/Read/Common.hs @@ -19,7 +19,6 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NoMonoLocalBinds #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PackageImports #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -49,6 +48,7 @@ getDefaultCommodityAndStyle, getDefaultAmountStyle, getAmountStyle, + addDeclaredAccountTags, addDeclaredAccountType, pushParentAccount, popParentAccount, @@ -129,7 +129,7 @@ import Data.Either (lefts, rights) import Data.Function ((&)) import Data.Functor ((<&>), ($>)) -import Data.List (find, genericReplicate) +import Data.List (find, genericReplicate, union) import Data.List.NonEmpty (NonEmpty(..)) import Data.Maybe (catMaybes, fromMaybe, isJust, listToMaybe) import qualified Data.Map as M @@ -213,6 +213,7 @@ ,forecast_ = forecastPeriodFromRawOpts day rawopts ,reportspan_ = DateSpan (queryStartDate False datequery) (queryEndDate False datequery) ,auto_ = boolopt "auto" rawopts + ,infer_equity_ = boolopt "infer-equity" rawopts && conversionop_ ropts /= Just ToCost ,balancingopts_ = defbalancingopts{ ignore_assertions_ = boolopt "ignore-assertions" rawopts , infer_transaction_prices_ = not noinferprice @@ -287,47 +288,58 @@ -- | Post-process a Journal that has just been parsed or generated, in this order: -- --- - apply canonical amount styles, +-- - add misc info (file path, read time) -- --- - save misc info and reverse transactions into their original parse order, +-- - reverse transactions into their original parse order -- --- - add forecast transactions, +-- - apply canonical commodity styles -- --- - evaluate balance assignments and balance each transaction, +-- - add tags from account directives to postings' tags -- --- - apply transaction modifiers (auto postings) if enabled, +-- - add forecast transactions if enabled -- --- - check balance assertions if enabled. +-- - add tags from account directives to postings' tags (again to affect forecast transactions) -- --- - infer transaction-implied market prices from transaction prices +-- - add auto postings if enabled -- +-- - add tags from account directives to postings' tags (again to affect auto postings) +-- +-- - evaluate balance assignments and balance each transaction +-- +-- - check balance assertions if enabled +-- +-- - infer equity postings in conversion transactions if enabled +-- +-- - infer market prices from costs if enabled +-- +-- - check all accounts have been declared if in strict mode +-- +-- - check all commodities have been declared if in strict mode +-- journalFinalise :: InputOpts -> FilePath -> Text -> ParsedJournal -> ExceptT String IO Journal -journalFinalise iopts@InputOpts{auto_,balancingopts_,strict_} f txt pj = do - t <- liftIO getPOSIXTime - -- Infer and apply canonical styles for each commodity (or throw an error). - -- This affects transaction balancing/assertions/assignments, so needs to be done early. - liftEither $ checkAddAndBalance (_ioDay iopts) <=< journalApplyCommodityStyles $ - pj{jglobalcommoditystyles=fromMaybe mempty $ commodity_styles_ balancingopts_} -- save any global commodity styles - & journalAddFile (f, txt) -- save the main file's info - & journalSetLastReadTime t -- save the last read time - & journalReverse -- convert all lists to the order they were parsed - where - checkAddAndBalance d j = do - when strict_ $ do - -- If in strict mode, check all postings are to declared accounts - journalCheckAccountsDeclared j - -- and using declared commodities - journalCheckCommoditiesDeclared j - - -- Add forecast transactions if enabled - journalAddForecast (forecastPeriod iopts j) j - -- Add auto postings if enabled - & (if auto_ && not (null $ jtxnmodifiers j) then journalAddAutoPostings d balancingopts_ else pure) - -- Balance all transactions and maybe check balance assertions. - >>= journalBalanceTransactions balancingopts_ - -- infer market prices from commodity-exchanging transactions - <&> journalInferMarketPricesFromTransactions +journalFinalise iopts@InputOpts{auto_,infer_equity_,balancingopts_,strict_,_ioDay} f txt pj = do + t <- liftIO getPOSIXTime + liftEither $ do + j <- pj{jglobalcommoditystyles=fromMaybe mempty $ commodity_styles_ balancingopts_} + & journalSetLastReadTime t -- save the last read time + & journalAddFile (f, txt) -- save the main file's info + & journalReverse -- convert all lists to the order they were parsed + & journalAddAccountTypes -- build a map of all known account types + & journalApplyCommodityStyles -- Infer and apply commodity styles - should be done early + <&> journalAddForecast (forecastPeriod iopts pj) -- Add forecast transactions if enabled + <&> journalPostingsAddAccountTags -- Add account tags to postings, so they can be matched by auto postings. + >>= (if auto_ && not (null $ jtxnmodifiers pj) + then journalAddAutoPostings _ioDay balancingopts_ -- Add auto postings if enabled, and account tags if needed + else pure) + >>= journalBalanceTransactions balancingopts_ -- Balance all transactions and maybe check balance assertions. + <&> (if infer_equity_ then journalAddInferredEquityPostings else id) -- Add inferred equity postings, after balancing transactions and generating auto postings + <&> journalInferMarketPricesFromTransactions -- infer market prices from commodity-exchanging transactions + when strict_ $ do + journalCheckAccountsDeclared j -- If in strict mode, check all postings are to declared accounts + journalCheckCommoditiesDeclared j -- and using declared commodities + return j +-- | Apply any auto posting rules to generate extra postings on this journal's transactions. journalAddAutoPostings :: Day -> BalancingOpts -> Journal -> Either String Journal journalAddAutoPostings d bopts = -- Balance all transactions without checking balance assertions, @@ -403,9 +415,14 @@ (linesPrepend " " . (<>"\n") . textChomp $ showTransaction t) where mfirstundeclaredcomm = - find (`M.notMember` jcommodities j) . map acommodity $ - (maybe id ((:) . baamount) pbalanceassertion) . filter (/= missingamt) $ amountsRaw pamount + find (`M.notMember` jcommodities j) + . map acommodity + . (maybe id ((:) . baamount) pbalanceassertion) + . filter (not . isIgnorable) + $ amountsRaw pamount + -- Ignore missing amounts and zero amounts without commodity (#1767) + isIgnorable a = (T.null (acommodity a) && amountIsZero a) || a == missingamt setYear :: Year -> JournalParser m () setYear y = modify' (\j -> j{jparsedefaultyear=Just y}) @@ -444,6 +461,10 @@ mdefaultStyle <- fmap snd <$> getDefaultCommodityAndStyle return $ listToMaybe $ catMaybes [mspecificStyle, mdefaultStyle] +addDeclaredAccountTags :: AccountName -> [Tag] -> JournalParser m () +addDeclaredAccountTags acct atags = + modify' (\j -> j{jdeclaredaccounttags = M.insertWith (flip union) acct atags (jdeclaredaccounttags j)}) + addDeclaredAccountType :: AccountName -> AccountType -> JournalParser m () addDeclaredAccountType acct atype = modify' (\j -> j{jdeclaredaccounttypes = M.insertWith (++) atype [acct] (jdeclaredaccounttypes j)}) @@ -1575,3 +1596,5 @@ ] ] + + diff --git a/Hledger/Read/CsvReader.hs b/Hledger/Read/CsvReader.hs --- a/Hledger/Read/CsvReader.hs +++ b/Hledger/Read/CsvReader.hs @@ -45,7 +45,7 @@ import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.State.Strict (StateT, get, modify', evalStateT) import Control.Monad.Trans.Class (lift) -import Data.Char (toLower, isDigit, isSpace, isAlphaNum, isAscii, ord) +import Data.Char (toLower, isDigit, isSpace, isAlphaNum, ord) import Data.Bifunctor (first) import Data.List (elemIndex, foldl', intersperse, mapAccumL, nub, sortBy) import Data.Maybe (catMaybes, fromMaybe, isJust) @@ -1245,7 +1245,7 @@ t where referencep = liftA2 T.cons (char '%') (takeWhile1P (Just "reference") isFieldNameChar) :: Parsec CustomErr Text Text - isFieldNameChar c = isAscii c && (isAlphaNum c || c == '_' || c == '-') + isFieldNameChar c = isAlphaNum c || c == '_' || c == '-' -- | Replace something that looks like a reference to a csv field ("%date" or "%1) -- with that field's value. If it doesn't look like a field reference, or if we diff --git a/Hledger/Read/InputOptions.hs b/Hledger/Read/InputOptions.hs --- a/Hledger/Read/InputOptions.hs +++ b/Hledger/Read/InputOptions.hs @@ -36,6 +36,7 @@ ,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 ,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. @@ -53,6 +54,7 @@ , forecast_ = Nothing , reportspan_ = nulldatespan , auto_ = False + , infer_equity_ = False , balancingopts_ = defbalancingopts , strict_ = False , _ioDay = nulldate diff --git a/Hledger/Read/JournalReader.hs b/Hledger/Read/JournalReader.hs --- a/Hledger/Read/JournalReader.hs +++ b/Hledger/Read/JournalReader.hs @@ -73,7 +73,7 @@ --- ** imports import qualified Control.Monad.Fail as Fail (fail) import qualified Control.Exception as C -import Control.Monad (forM_, when, void) +import Control.Monad (forM_, when, void, unless) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Except (ExceptT(..), runExceptT) import Control.Monad.State.Strict (evalStateT,get,modify',put) @@ -347,12 +347,6 @@ -- the account name, possibly modified by preceding alias or apply account directives acct <- modifiedaccountnamep - -- maybe an account type code (ALERX) after two or more spaces - -- XXX added in 1.11, deprecated in 1.13, remove in 1.14 - mtypecode :: Maybe Char <- lift $ optional $ try $ do - skipNonNewlineSpaces1 -- at least one more space in addition to the one consumed by modifiedaccountp - choice $ map char "ALERX" - -- maybe a comment, on this and/or following lines (cmt, tags) <- lift transactioncommentp @@ -362,11 +356,11 @@ -- an account type may have been set by account type code or a tag; -- the latter takes precedence let - mtypecode' :: Maybe Text = lookup accountTypeTagName tags <|> (T.singleton <$> mtypecode) - metype = parseAccountTypeCode <$> mtypecode' + metype = parseAccountTypeCode <$> lookup accountTypeTagName tags -- update the journal addAccountDeclaration (acct, cmt, tags) + unless (null tags) $ addDeclaredAccountTags acct tags case metype of Nothing -> return () Just (Right t) -> addDeclaredAccountType acct t @@ -378,22 +372,24 @@ parseAccountTypeCode :: Text -> Either String AccountType parseAccountTypeCode s = case T.toLower s of - "asset" -> Right Asset - "a" -> Right Asset - "liability" -> Right Liability - "l" -> Right Liability - "equity" -> Right Equity - "e" -> Right Equity - "revenue" -> Right Revenue - "r" -> Right Revenue - "expense" -> Right Expense - "x" -> Right Expense - "cash" -> Right Cash - "c" -> Right Cash - _ -> Left err + "asset" -> Right Asset + "a" -> Right Asset + "liability" -> Right Liability + "l" -> Right Liability + "equity" -> Right Equity + "e" -> Right Equity + "revenue" -> Right Revenue + "r" -> Right Revenue + "expense" -> Right Expense + "x" -> Right Expense + "cash" -> Right Cash + "c" -> Right Cash + "conversion" -> Right Conversion + "v" -> Right Conversion + _ -> Left err where err = T.unpack $ "invalid account type code "<>s<>", should be one of " <> - T.intercalate ", " ["A","L","E","R","X","C","Asset","Liability","Equity","Revenue","Expense","Cash"] + T.intercalate ", " ["A","L","E","R","X","C","V","Asset","Liability","Equity","Revenue","Expense","Cash","Conversion"] -- Add an account declaration to the journal, auto-numbering it. addAccountDeclaration :: (AccountName,Text,[Tag]) -> JournalParser m () @@ -1008,7 +1004,7 @@ ,testGroup "accountdirectivep" [ testCase "with-comment" $ assertParse accountdirectivep "account a:b ; a comment\n" ,testCase "does-not-support-!" $ assertParseError accountdirectivep "!account a:b\n" "" - ,testCase "account-type-code" $ assertParse accountdirectivep "account a:b A\n" + ,testCase "account-type-code" $ assertParse accountdirectivep "account a:b ; type:A\n" ,testCase "account-type-tag" $ assertParseStateOn accountdirectivep "account a:b ; type:asset\n" jdeclaredaccounts [("a:b", AccountDeclarationInfo{adicomment = "type:asset\n" diff --git a/Hledger/Reports/BalanceReport.hs b/Hledger/Reports/BalanceReport.hs --- a/Hledger/Reports/BalanceReport.hs +++ b/Hledger/Reports/BalanceReport.hs @@ -313,7 +313,7 @@ ," a:b 10h @ $50" ," c:d " ]) >>= either error' return - let j' = journalCanonicaliseAmounts $ journalToCost j -- enable cost basis adjustment + let j' = journalCanonicaliseAmounts $ journalToCost ToCost j -- enable cost basis adjustment balanceReportAsText defreportopts (balanceReport defreportopts Any j') `is` [" $500 a:b" ," $-500 c:d" diff --git a/Hledger/Reports/BudgetReport.hs b/Hledger/Reports/BudgetReport.hs --- a/Hledger/Reports/BudgetReport.hs +++ b/Hledger/Reports/BudgetReport.hs @@ -82,10 +82,12 @@ jperiodictxns j actualj = journalWithBudgetAccountNames budgetedaccts showunbudgeted j budgetj = journalAddBudgetGoalTransactions bopts ropts reportspan j - actualreport@(PeriodicReport actualspans _ _) = - dbg5 "actualreport" $ multiBalanceReport rspec{_rsReportOpts=ropts{empty_=True}} actualj + priceoracle = journalPriceOracle (infer_prices_ ropts) j budgetgoalreport@(PeriodicReport _ budgetgoalitems budgetgoaltotals) = - dbg5 "budgetgoalreport" $ multiBalanceReport rspec{_rsReportOpts=ropts{empty_=True}} budgetj + dbg5 "budgetgoalreport" $ multiBalanceReportWith rspec{_rsReportOpts=ropts{empty_=True}} budgetj priceoracle mempty + budgetedacctsseen = S.fromList $ map prrFullName budgetgoalitems + actualreport@(PeriodicReport actualspans _ _) = + dbg5 "actualreport" $ multiBalanceReportWith rspec{_rsReportOpts=ropts{empty_=True}} actualj priceoracle budgetedacctsseen budgetgoalreport' -- If no interval is specified: -- budgetgoalreport's span might be shorter actualreport's due to periodic txns; @@ -218,9 +220,9 @@ balanceReportTableAsText ropts (budgetReportAsTable ropts budgetr) where title = "Budget performance in " <> showDateSpan (periodicReportSpan budgetr) - <> (case cost_ of - Cost -> ", converted to cost" - NoCost -> "") + <> (case conversionop_ of + Just ToCost -> ", converted to cost" + _ -> "") <> (case value_ of Just (AtThen _mc) -> ", valued at posting date" Just (AtEnd _mc) -> ", valued at period ends" @@ -386,9 +388,9 @@ _ -> -- trace (pshow $ (maybecost actual, maybecost budget)) -- debug missing percentage Nothing where - costedAmounts = case cost_ of - Cost -> amounts . mixedAmountCost - NoCost -> amounts + costedAmounts = case conversionop_ of + Just ToCost -> amounts . mixedAmountCost + _ -> amounts -- | Calculate the percentage of actual change to budget goal for a particular commodity percentage' :: Change -> BudgetGoal -> CommoditySymbol -> Maybe Percentage diff --git a/Hledger/Reports/EntriesReport.hs b/Hledger/Reports/EntriesReport.hs --- a/Hledger/Reports/EntriesReport.hs +++ b/Hledger/Reports/EntriesReport.hs @@ -36,7 +36,7 @@ entriesReport :: ReportSpec -> Journal -> EntriesReport entriesReport rspec@ReportSpec{_rsReportOpts=ropts} = sortBy (comparing $ transactionDateFn ropts) . jtxns - . journalApplyValuationFromOpts rspec{_rsReportOpts=ropts{show_costs_=True}} + . journalApplyValuationFromOpts (setDefaultConversionOp NoConversionOp rspec) . filterJournalTransactions (_rsQuery rspec) tests_EntriesReport = testGroup "EntriesReport" [ diff --git a/Hledger/Reports/MultiBalanceReport.hs b/Hledger/Reports/MultiBalanceReport.hs --- a/Hledger/Reports/MultiBalanceReport.hs +++ b/Hledger/Reports/MultiBalanceReport.hs @@ -47,6 +47,8 @@ import Data.Maybe (fromMaybe, isJust, mapMaybe) import Data.Ord (Down(..)) import Data.Semigroup (sconcat) +import Data.Set (Set) +import qualified Data.Set as Set import Data.Time.Calendar (fromGregorian) import Safe (lastDef, minimumMay) @@ -102,23 +104,23 @@ -- by the balance command (in multiperiod mode) and (via compoundBalanceReport) -- by the bs/cf/is commands. multiBalanceReport :: ReportSpec -> Journal -> MultiBalanceReport -multiBalanceReport rspec j = multiBalanceReportWith rspec j (journalPriceOracle infer j) +multiBalanceReport rspec j = multiBalanceReportWith rspec j (journalPriceOracle infer j) mempty where infer = infer_prices_ $ _rsReportOpts rspec --- | A helper for multiBalanceReport. This one takes an extra argument, --- a PriceOracle to be used for looking up market prices. Commands which --- run multiple reports (bs etc.) can generate the price oracle just --- once for efficiency, passing it to each report by calling this --- function directly. -multiBalanceReportWith :: ReportSpec -> Journal -> PriceOracle -> MultiBalanceReport -multiBalanceReportWith rspec' j priceoracle = report +-- | A helper for multiBalanceReport. This one takes some extra arguments, +-- a 'PriceOracle' to be used for looking up market prices, and a set of +-- 'AccountName's which should not be elided. Commands which run multiple +-- reports (bs etc.) can generate the price oracle just once for efficiency, +-- passing it to each report by calling this function directly. +multiBalanceReportWith :: ReportSpec -> Journal -> PriceOracle -> Set AccountName -> MultiBalanceReport +multiBalanceReportWith rspec' j priceoracle unelidableaccts = report where -- Queries, report/column dates. - reportspan = dbg3 "reportspan" $ reportSpan j rspec' - rspec = dbg3 "reportopts" $ makeReportQuery rspec' reportspan + (reportspan, colspans) = reportSpan j rspec' + rspec = dbg3 "reportopts" $ makeReportQuery rspec' reportspan -- Group postings into their columns. - colps = dbg5 "colps" $ getPostingsByColumn rspec j priceoracle reportspan + colps = dbg5 "colps" $ getPostingsByColumn rspec j priceoracle colspans -- The matched accounts with a starting balance. All of these should appear -- in the report, even if they have no postings during the report period. @@ -127,7 +129,7 @@ -- Generate and postprocess the report, negating balances and taking percentages if needed report = dbg4 "multiBalanceReportWith" $ - generateMultiBalanceReport rspec j priceoracle colps startbals + generateMultiBalanceReport rspec j priceoracle unelidableaccts colps startbals -- | Generate a compound balance report from a list of CBCSubreportSpec. This -- shares postings between the subreports. @@ -143,11 +145,11 @@ compoundBalanceReportWith rspec' j priceoracle subreportspecs = cbr where -- Queries, report/column dates. - reportspan = dbg3 "reportspan" $ reportSpan j rspec' - rspec = dbg3 "reportopts" $ makeReportQuery rspec' reportspan + (reportspan, colspans) = reportSpan j rspec' + rspec = dbg3 "reportopts" $ makeReportQuery rspec' reportspan -- Group postings into their columns. - colps = dbg5 "colps" $ getPostingsByColumn rspec j priceoracle reportspan + colps = dbg5 "colps" $ getPostingsByColumn rspec j priceoracle colspans -- The matched postings with a starting balance. All of these should appear -- in the report, even if they have no postings during the report period. @@ -159,7 +161,7 @@ ( cbcsubreporttitle -- Postprocess the report, negating balances and taking percentages if needed , cbcsubreporttransform $ - generateMultiBalanceReport rspecsub j priceoracle colps' startbals' + generateMultiBalanceReport rspecsub j priceoracle mempty colps' startbals' , cbcsubreportincreasestotal ) where @@ -169,8 +171,9 @@ ropts = cbcsubreportoptions $ _rsReportOpts rspec rspecsub = rspec{_rsReportOpts=ropts, _rsQuery=And [q, _rsQuery rspec]} -- Starting balances and column postings specific to this subreport. - startbals' = startingBalances rspecsub j priceoracle $ filter (matchesPosting q) startps - colps' = map (second $ filter (matchesPosting q)) colps + startbals' = startingBalances rspecsub j priceoracle $ + filter (matchesPostingExtra (journalAccountType j) q) startps + colps' = map (second $ filter (matchesPostingExtra (journalAccountType j) q)) colps -- Sum the subreport totals by column. Handle these cases: -- - no subreports @@ -240,14 +243,13 @@ dateqcons = if date2_ (_rsReportOpts rspec) then Date2 else Date -- | Group postings, grouped by their column -getPostingsByColumn :: ReportSpec -> Journal -> PriceOracle -> DateSpan -> [(DateSpan, [Posting])] -getPostingsByColumn rspec j priceoracle reportspan = +getPostingsByColumn :: ReportSpec -> Journal -> PriceOracle -> [DateSpan] -> [(DateSpan, [Posting])] +getPostingsByColumn rspec j priceoracle colspans = groupByDateSpan True getDate colspans ps where -- Postings matching the query within the report period. ps = dbg5 "getPostingsByColumn" $ getPostings rspec j priceoracle -- The date spans to be included as report columns. - colspans = dbg3 "colspans" $ splitSpan (interval_ $ _rsReportOpts rspec) reportspan getDate = postingDateOrDate2 (whichDate (_rsReportOpts rspec)) -- | Gather postings matching the query within the report period. @@ -257,7 +259,7 @@ where rspec' = rspec{_rsQuery=depthless, _rsReportOpts = ropts'} ropts' = if isJust (valuationAfterSum ropts) - then ropts{value_=Nothing, cost_=NoCost} -- If we're valuing after the sum, don't do it now + then ropts{value_=Nothing, conversionop_=Just NoConversionOp} -- If we're valuing after the sum, don't do it now else ropts -- The user's query with no depth limit, and expanded to the report span @@ -281,11 +283,15 @@ -- and the declared accounts are really only needed for the former, -- but it's harmless to have them in the column changes as well. ps' = ps ++ if declared_ then declaredacctps else [] - where - declaredacctps = - [nullposting{paccount=n} | n <- journalLeafAccountNamesDeclared j - , acctq `matchesAccount` n] - where acctq = dbg3 "acctq" $ filterQueryOrNotQuery queryIsAcct query + where + declaredacctps = + [nullposting{paccount=a} + | a <- journalLeafAccountNamesDeclared j + , matchesAccountExtra (journalAccountType j) (journalAccountTags j) accttypetagsq a + ] + where + accttypetagsq = dbg3 "accttypetagsq" $ + filterQueryOrNotQuery (\q -> queryIsAcct q || queryIsType q || queryIsTag q) query filterbydepth = case accountlistmode_ of ALTree -> filter ((depthq `matchesAccount`) . aname) -- a tree - just exclude deeper accounts @@ -343,17 +349,17 @@ -- | Lay out a set of postings grouped by date span into a regular matrix with rows -- given by AccountName and columns by DateSpan, then generate a MultiBalanceReport -- from the columns. -generateMultiBalanceReport :: ReportSpec -> Journal -> PriceOracle +generateMultiBalanceReport :: ReportSpec -> Journal -> PriceOracle -> Set AccountName -> [(DateSpan, [Posting])] -> HashMap AccountName Account -> MultiBalanceReport -generateMultiBalanceReport rspec@ReportSpec{_rsReportOpts=ropts} j priceoracle colps startbals = +generateMultiBalanceReport rspec@ReportSpec{_rsReportOpts=ropts} j priceoracle unelidableaccts colps startbals = report where -- Process changes into normal, cumulative, or historical amounts, plus value them matrix = calculateReportMatrix rspec j priceoracle startbals colps -- All account names that will be displayed, possibly depth-clipped. - displaynames = dbg5 "displaynames" $ displayedAccounts rspec matrix + displaynames = dbg5 "displaynames" $ displayedAccounts rspec unelidableaccts matrix -- All the rows of the report. rows = dbg5 "rows" . (if invert_ ropts then map (fmap maNegate) else id) -- Negate amounts if applicable @@ -394,9 +400,11 @@ -- | Calculate accounts which are to be displayed in the report, as well as -- their name and depth -displayedAccounts :: ReportSpec -> HashMap AccountName (Map DateSpan Account) +displayedAccounts :: ReportSpec + -> Set AccountName + -> HashMap AccountName (Map DateSpan Account) -> HashMap AccountName DisplayName -displayedAccounts ReportSpec{_rsQuery=query,_rsReportOpts=ropts} valuedaccts +displayedAccounts ReportSpec{_rsQuery=query,_rsReportOpts=ropts} unelidableaccts valuedaccts | depth == 0 = HM.singleton "..." $ DisplayName "..." "..." 1 | otherwise = HM.mapWithKey (\a _ -> displayedName a) displayedAccts where @@ -421,7 +429,8 @@ -- Accounts interesting for their own sake isInteresting name amts = d <= depth -- Throw out anything too deep - && ( (empty_ ropts && keepWhenEmpty amts) -- Keep empty accounts when called with --empty + && ( name `Set.member` unelidableaccts -- Unelidable accounts should be kept unless too deep + ||(empty_ ropts && keepWhenEmpty amts) -- Keep empty accounts when called with --empty || not (isZeroRow balance amts) -- Keep everything with a non-zero balance in the row ) where @@ -432,7 +441,7 @@ balance = maybeStripPrices . case accountlistmode_ ropts of ALTree | d == depth -> aibalance _ -> aebalance - where maybeStripPrices = if show_costs_ ropts then id else mixedAmountStripPrices + where maybeStripPrices = if conversionop_ ropts == Just NoConversionOp then id else mixedAmountStripPrices -- Accounts interesting because they are a fork for interesting subaccounts interestingParents = dbg5 "interestingParents" $ case accountlistmode_ ropts of diff --git a/Hledger/Reports/PostingsReport.hs b/Hledger/Reports/PostingsReport.hs --- a/Hledger/Reports/PostingsReport.hs +++ b/Hledger/Reports/PostingsReport.hs @@ -63,7 +63,7 @@ postingsReport :: ReportSpec -> Journal -> PostingsReport postingsReport rspec@ReportSpec{_rsReportOpts=ropts@ReportOpts{..}} j = items where - reportspan = reportSpanBothDates j rspec + (reportspan, colspans) = reportSpanBothDates j rspec whichdate = whichDate ropts mdepth = queryDepth $ _rsQuery rspec multiperiod = interval_ /= NoInterval @@ -76,7 +76,7 @@ | multiperiod = [(p, Just period) | (p, period) <- summariseps reportps] | otherwise = [(p, Nothing) | p <- reportps] where - summariseps = summarisePostingsByInterval interval_ whichdate mdepth showempty reportspan + summariseps = summarisePostingsByInterval whichdate mdepth showempty colspans showempty = empty_ || average_ -- Posting report items ready for display. @@ -164,15 +164,12 @@ -- | Convert a list of postings into summary postings, one per interval, -- aggregated to the specified depth if any. -- Each summary posting will have a non-Nothing interval end date. -summarisePostingsByInterval :: Interval -> WhichDate -> Maybe Int -> Bool -> DateSpan -> [Posting] -> [SummaryPosting] -summarisePostingsByInterval interval wd mdepth showempty reportspan = +summarisePostingsByInterval :: WhichDate -> Maybe Int -> Bool -> [DateSpan] -> [Posting] -> [SummaryPosting] +summarisePostingsByInterval wd mdepth showempty colspans = concatMap (\(s,ps) -> summarisePostingsInDateSpan s wd mdepth showempty ps) -- Group postings into their columns. We try to be efficient, since -- there can possibly be a very large number of intervals (cf #1683) . groupByDateSpan showempty (postingDateOrDate2 wd) colspans - where - -- The date spans to be included as report columns. - colspans = splitSpan interval reportspan -- | Given a date span (representing a report interval) and a list of -- postings within it, aggregate the postings into one summary posting per @@ -332,14 +329,14 @@ let periodexpr `gives` dates = do j' <- samplejournal registerdates (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j') `is` dates - where opts = defreportopts{period_=maybePeriod date1 periodexpr} + where opts = defreportopts{period_=Just $ parsePeriodExpr' date1 periodexpr} "" `gives` ["2008/01/01","2008/06/01","2008/06/02","2008/06/03","2008/12/31"] "2008" `gives` ["2008/01/01","2008/06/01","2008/06/02","2008/06/03","2008/12/31"] "2007" `gives` [] "june" `gives` ["2008/06/01","2008/06/02","2008/06/03"] "monthly" `gives` ["2008/01/01","2008/06/01","2008/12/01"] "quarterly" `gives` ["2008/01/01","2008/04/01","2008/10/01"] - let opts = defreportopts{period_=maybePeriod date1 "yearly"} + let opts = defreportopts{period_=Just $ parsePeriodExpr' date1 "yearly"} (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` unlines ["2008/01/01 - 2008/12/31 assets:bank:saving $1 $1" ," assets:cash $-2 $-1" @@ -349,9 +346,9 @@ ," income:salary $-1 $-1" ," liabilities:debts $1 0" ] - let opts = defreportopts{period_=maybePeriod date1 "quarterly"} + let opts = defreportopts{period_=Just $ parsePeriodExpr' date1 "quarterly"} registerdates (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` ["2008/01/01","2008/04/01","2008/10/01"] - let opts = defreportopts{period_=maybePeriod date1 "quarterly",empty_=True} + let opts = defreportopts{period_=Just $ parsePeriodExpr' date1 "quarterly",empty_=True} registerdates (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` ["2008/01/01","2008/04/01","2008/07/01","2008/10/01"] ] @@ -377,7 +374,7 @@ -} ,testCase "summarisePostingsByInterval" $ - summarisePostingsByInterval (Quarters 1) PrimaryDate Nothing False (DateSpan Nothing Nothing) [] @?= [] + summarisePostingsByInterval PrimaryDate Nothing False [DateSpan Nothing Nothing] [] @?= [] -- ,tests_summarisePostingsInDateSpan = [ -- "summarisePostingsInDateSpan" ~: do diff --git a/Hledger/Reports/ReportOptions.hs b/Hledger/Reports/ReportOptions.hs --- a/Hledger/Reports/ReportOptions.hs +++ b/Hledger/Reports/ReportOptions.hs @@ -30,6 +30,7 @@ defreportopts, rawOptsToReportOpts, defreportspec, + setDefaultConversionOp, reportOptsToSpec, updateReportSpec, updateReportSpecWith, @@ -69,7 +70,7 @@ import Data.Either.Extra (eitherToMaybe) import Data.Functor.Identity (Identity(..)) import Data.List.Extra (find, isPrefixOf, nubSort) -import Data.Maybe (fromMaybe, mapMaybe) +import Data.Maybe (fromMaybe, isJust) import qualified Data.Text as T import Data.Time.Calendar (Day, addDays) import Data.Default (Default(..)) @@ -124,7 +125,7 @@ period_ :: Period ,interval_ :: Interval ,statuses_ :: [Status] -- ^ Zero, one, or two statuses to be matched - ,cost_ :: Costing -- ^ Should we convert amounts to cost, when present? + ,conversionop_ :: Maybe ConversionOp -- ^ Which operation should we apply to conversion transactions? ,value_ :: Maybe ValuationType -- ^ What value should amounts be converted to ? ,infer_prices_ :: Bool -- ^ Infer market prices from transactions ? ,depth_ :: Maybe Int @@ -180,7 +181,7 @@ { period_ = PeriodAll , interval_ = NoInterval , statuses_ = [] - , cost_ = NoCost + , conversionop_ = Nothing , value_ = Nothing , infer_prices_ = False , depth_ = Nothing @@ -223,7 +224,6 @@ let formatstring = T.pack <$> maybestringopt "format" rawopts querystring = map T.pack $ listofstringopt "args" rawopts -- doesn't handle an arg like "" right - (costing, valuation) = valuationTypeFromRawOpts rawopts pretty = fromMaybe False $ alwaysneveropt "pretty" rawopts format = case parseStringFormat <$> formatstring of @@ -235,8 +235,8 @@ {period_ = periodFromRawOpts d rawopts ,interval_ = intervalFromRawOpts rawopts ,statuses_ = statusesFromRawOpts rawopts - ,cost_ = costing - ,value_ = valuation + ,conversionop_ = conversionOpFromRawOpts rawopts + ,value_ = valuationTypeFromRawOpts rawopts ,infer_prices_ = boolopt "infer-market-prices" rawopts ,depth_ = maybeposintopt "depth" rawopts ,date2_ = boolopt "date2" rawopts @@ -290,6 +290,11 @@ , _rsQueryOpts = [] } +-- | Set the default ConversionOp. +setDefaultConversionOp :: ConversionOp -> ReportSpec -> ReportSpec +setDefaultConversionOp def rspec@ReportSpec{_rsReportOpts=ropts} = + rspec{_rsReportOpts=ropts{conversionop_=conversionop_ ropts <|> Just def}} + accountlistmodeopt :: RawOpts -> AccountListMode accountlistmodeopt = fromMaybe ALFlat . choiceopt parse where @@ -469,39 +474,32 @@ | s `elem` ss = ropts{statuses_=filter (/= s) ss} | otherwise = ropts{statuses_=simplifyStatuses (s:ss)} --- | Parse the type of valuation and costing to be performed, if any, --- specified by -B/--cost, -V, -X/--exchange, or --value flags. It is --- allowed to combine -B/--cost with any other valuation type. If --- there's more than one valuation type, the rightmost flag wins. --- This will fail with a usage error if an invalid argument is passed --- to --value, or if --valuechange is called with a valuation type --- other than -V/--value=end. -valuationTypeFromRawOpts :: RawOpts -> (Costing, Maybe ValuationType) -valuationTypeFromRawOpts rawopts = case (balancecalcopt rawopts, directcost, directval) of - (CalcValueChange, _, Nothing ) -> (directcost, Just $ AtEnd Nothing) -- If no valuation requested for valuechange, use AtEnd - (CalcValueChange, _, Just (AtEnd _)) -> (directcost, directval) -- If AtEnd valuation requested, use it - (CalcValueChange, _, _ ) -> usageError "--valuechange only produces sensible results with --value=end" - (CalcGain, Cost, _ ) -> usageError "--gain cannot be combined with --cost" - (CalcGain, NoCost, Nothing ) -> (directcost, Just $ AtEnd Nothing) -- If no valuation requested for gain, use AtEnd - (_, _, _ ) -> (directcost, directval) -- Otherwise, use requested valuation +-- | Parse the type of valuation to be performed, if any, specified by -V, +-- -X/--exchange, or --value flags. If there's more than one valuation type, +-- the rightmost flag wins. This will fail with a usage error if an invalid +-- argument is passed to --value, or if --valuechange is called with a +-- valuation type other than -V/--value=end. +valuationTypeFromRawOpts :: RawOpts -> Maybe ValuationType +valuationTypeFromRawOpts rawopts = case (balancecalcopt rawopts, directval) of + (CalcValueChange, Nothing ) -> Just $ AtEnd Nothing -- If no valuation requested for valuechange, use AtEnd + (CalcValueChange, Just (AtEnd _)) -> directval -- If AtEnd valuation requested, use it + (CalcValueChange, _ ) -> usageError "--valuechange only produces sensible results with --value=end" + (CalcGain, Nothing ) -> Just $ AtEnd Nothing -- If no valuation requested for gain, use AtEnd + (_, _ ) -> directval -- Otherwise, use requested valuation where - directcost = if Cost `elem` map fst valuationopts then Cost else NoCost - directval = lastMay $ mapMaybe snd valuationopts - - valuationopts = collectopts valuationfromrawopt rawopts + directval = lastMay $ collectopts valuationfromrawopt rawopts valuationfromrawopt (n,v) -- option name, value - | n == "B" = Just (Cost, Nothing) -- keep supporting --value=cost for now - | n == "V" = Just (NoCost, Just $ AtEnd Nothing) - | n == "X" = Just (NoCost, Just $ AtEnd (Just $ T.pack v)) - | n == "value" = Just $ valueopt v + | n == "V" = Just $ AtEnd Nothing + | n == "X" = Just $ AtEnd (Just $ T.pack v) + | n == "value" = valueopt v | otherwise = Nothing valueopt v - | t `elem` ["cost","c"] = (Cost, AtEnd . Just <$> mc) -- keep supporting --value=cost,COMM for now - | t `elem` ["then" ,"t"] = (NoCost, Just $ AtThen mc) - | t `elem` ["end" ,"e"] = (NoCost, Just $ AtEnd mc) - | t `elem` ["now" ,"n"] = (NoCost, Just $ AtNow mc) + | t `elem` ["cost","c"] = AtEnd . Just <$> mc -- keep supporting --value=cost,COMM for now + | t `elem` ["then" ,"t"] = Just $ AtThen mc + | t `elem` ["end" ,"e"] = Just $ AtEnd mc + | t `elem` ["now" ,"n"] = Just $ AtNow mc | otherwise = case parsedateM t of - Just d -> (NoCost, Just $ AtDate d mc) + Just d -> Just $ AtDate d mc Nothing -> usageError $ "could not parse \""++t++"\" as valuation type, should be: then|end|now|t|e|n|YYYY-MM-DD" where -- parse --value's value: TYPE[,COMM] @@ -510,6 +508,21 @@ "" -> Nothing c -> Just $ T.pack c +-- | Parse the type of costing to be performed, if any, specified by -B/--cost +-- or --value flags. If there's more than one costing type, the rightmost flag +-- wins. This will fail with a usage error if an invalid argument is passed to +-- --cost or if a costing type is requested with --gain. +conversionOpFromRawOpts :: RawOpts -> Maybe ConversionOp +conversionOpFromRawOpts rawopts + | isJust costFlag && balancecalcopt rawopts == CalcGain = usageError "--gain cannot be combined with --cost" + | otherwise = costFlag + where + costFlag = lastMay $ collectopts conversionopfromrawopt rawopts + conversionopfromrawopt (n,v) -- option name, value + | n == "B" = Just ToCost + | n == "value", takeWhile (/=',') v `elem` ["cost", "c"] = Just ToCost -- keep supporting --value=cost for now + | otherwise = Nothing + -- | Select the Transaction date accessor based on --date2. transactionDateFn :: ReportOpts -> (Transaction -> Day) transactionDateFn ReportOpts{..} = if date2_ then transactionDate2 else tdate @@ -578,17 +591,15 @@ where valuation p = maybe id (mixedAmountApplyValuation priceoracle styles (periodEnd p) (_rsDay rspec) (postingDate p)) (value_ ropts) gain p = maybe id (mixedAmountApplyGain priceoracle styles (periodEnd p) (_rsDay rspec) (postingDate p)) (value_ ropts) - costing = case cost_ ropts of - Cost -> journalToCost - NoCost -> id + costing = journalToCost (fromMaybe NoConversionOp $ conversionop_ ropts) -- Find the end of the period containing this posting periodEnd = addDays (-1) . fromMaybe err . mPeriodEnd . postingDate mPeriodEnd = case interval_ ropts of - NoInterval -> const . spanEnd $ reportSpan j rspec + NoInterval -> const . spanEnd . fst $ reportSpan j rspec _ -> spanEnd <=< latestSpanContaining (historical : spans) historical = DateSpan Nothing $ spanStart =<< headMay spans - spans = splitSpan (interval_ ropts) $ reportSpanBothDates j rspec + spans = snd $ reportSpanBothDates j rspec styles = journalCommodityStyles j err = error "journalApplyValuationFromOpts: expected all spans to have an end date" @@ -605,9 +616,9 @@ where valuation mc span = mixedAmountValueAtDate priceoracle styles mc (maybe err (addDays (-1)) $ spanEnd span) gain mc span = mixedAmountGainAtDate priceoracle styles mc (maybe err (addDays (-1)) $ spanEnd span) - costing = case cost_ ropts of - Cost -> styleMixedAmount styles . mixedAmountCost - NoCost -> id + costing = case fromMaybe NoConversionOp $ conversionop_ ropts of + NoConversionOp -> id + ToCost -> styleMixedAmount styles . mixedAmountCost styles = journalCommodityStyles j err = error "mixedAmountApplyValuationAfterSumFromOptsWith: expected all spans to have an end date" @@ -642,18 +653,20 @@ -- options or queries, or otherwise the earliest and latest transaction or -- posting dates in the journal. If no dates are specified by options/queries -- and the journal is empty, returns the null date span. -reportSpan :: Journal -> ReportSpec -> DateSpan +-- Also return the intervals if they are requested. +reportSpan :: Journal -> ReportSpec -> (DateSpan, [DateSpan]) reportSpan = reportSpanHelper False -- | Like reportSpan, but uses both primary and secondary dates when calculating -- the span. -reportSpanBothDates :: Journal -> ReportSpec -> DateSpan +reportSpanBothDates :: Journal -> ReportSpec -> (DateSpan, [DateSpan]) reportSpanBothDates = reportSpanHelper True -- | A helper for reportSpan, which takes a Bool indicating whether to use both -- primary and secondary dates. -reportSpanHelper :: Bool -> Journal -> ReportSpec -> DateSpan -reportSpanHelper bothdates j ReportSpec{_rsQuery=query, _rsReportOpts=ropts} = reportspan +reportSpanHelper :: Bool -> Journal -> ReportSpec -> (DateSpan, [DateSpan]) +reportSpanHelper bothdates j ReportSpec{_rsQuery=query, _rsReportOpts=ropts} = + (reportspan, intervalspans) where -- The date span specified by -b/-e/-p options and query args if any. requestedspan = dbg3 "requestedspan" $ if bothdates then queryDateSpan' query else queryDateSpan (date2_ ropts) query @@ -677,10 +690,10 @@ (spanEnd =<< lastMay intervalspans) reportStartDate :: Journal -> ReportSpec -> Maybe Day -reportStartDate j = spanStart . reportSpan j +reportStartDate j = spanStart . fst . reportSpan j reportEndDate :: Journal -> ReportSpec -> Maybe Day -reportEndDate j = spanEnd . reportSpan j +reportEndDate j = spanEnd . fst . reportSpan j -- Some pure alternatives to the above. XXX review/clean up diff --git a/Hledger/Utils/Text.hs b/Hledger/Utils/Text.hs --- a/Hledger/Utils/Text.hs +++ b/Hledger/Utils/Text.hs @@ -169,15 +169,17 @@ isSingleQuoted :: Text -> Bool isSingleQuoted s = - T.length (T.take 2 s) == 2 && T.head s == '\'' && T.last s == '\'' + T.length s >= 2 && T.head s == '\'' && T.last s == '\'' isDoubleQuoted :: Text -> Bool isDoubleQuoted s = - T.length (T.take 2 s) == 2 && T.head s == '"' && T.last s == '"' + T.length s >= 2 && T.head s == '"' && T.last s == '"' textUnbracket :: Text -> Text textUnbracket s - | (T.head s == '[' && T.last s == ']') || (T.head s == '(' && T.last s == ')') = T.init $ T.tail 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 -- | Join several multi-line strings as side-by-side rectangular strings of the same height, top-padded. diff --git a/hledger-lib.cabal b/hledger-lib.cabal --- a/hledger-lib.cabal +++ b/hledger-lib.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: hledger-lib -version: 1.24.99 +version: 1.25 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