simonmichael/hledger
1
1
Fork 0
mirror of https://github.com/simonmichael/hledger.git synced 2024-11-07 21:15:19 +03:00
Code Issues Projects Releases Wiki Activity

code: Strip extraneous trailing whitespace from Haskell sources

Browse Source
This commit is contained in:
Caleb Maclennan 2019-07-15 13:28:52 +03:00 committed by Simon Michael
parent 7e332fda20
commit 11d9e5eb6a
71 changed files with 702 additions and 702 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
Shake.hs
View File

@ -497,7 +497,7 @@ main = do
| pkg <- packages ]
phony "commandhelp" $ need commandtxts
commandtxts |%> \out -> do
let src = out -<.> "md"
need [src]
@ -695,7 +695,7 @@ main = do
-- tagrelease: \
-- $(call def-help,tagrelease, commit a release tag based on $(VERSIONFILE) for each package )
-- for p in $(PACKAGES); do git tag -f $$p-$(VERSION); done
-- MISC
-- Generate the web manuals based on the current checkout and save
@ -777,7 +777,7 @@ wikiLink :: Markdown -> Markdown
wikiLink =
replaceBy wikilinkre wikilinkReplace .
replaceBy labelledwikilinkre labelledwikilinkReplace
-- regex stuff
-- couldn't figure out how to use match subgroups, so we don't

2
bin/_hledger-chart.hs
View File

@ -56,7 +56,7 @@ cmdmode = hledgerCommandMode
[here| chart
Generate a pie chart for the top account balances with the same sign,
in SVG format.
Based on the old hledger-chart package, this is not yet useful.
It's supposed to show only balances of one sign, but this might be broken.
|]

4
bin/hledger-smooth.hs
View File

@ -45,7 +45,7 @@ hledger smooth revenues:consulting | hledger -f- incomestatement -W
FLAGS
|]
[]
[]
[generalflagsgroup1]
[]
([], Just $ argsFlag "ACCT")
@ -64,7 +64,7 @@ main = do
q = queryFromOpts today ropts
acct = T.pack $ headDef (error' "Please provide an account name argument") args
pr = postingsReport ropts (And [Acct $ accountNameToAccountRegex acct, q]) j
-- dates of postings to acct (in report)
pdates = map (postingDate . fourth5) (snd pr)
-- the specified report end date or today's date

18
hledger-lib/Hledger/Data/Account.hs
View File

@ -76,8 +76,8 @@ accountsFromPostings ps =
in
acctsflattened
-- | Convert a list of account names to a tree of Account objects,
-- with just the account names filled in.
-- | Convert a list of account names to a tree of Account objects,
-- with just the account names filled in.
-- A single root account with the given name is added.
accountTree :: AccountName -> [AccountName] -> Account
accountTree rootname as = nullacct{aname=rootname, asubs=map (uncurry accountTree') $ M.assocs m }
@ -193,7 +193,7 @@ filterAccounts p a
| otherwise = concatMap (filterAccounts p) (asubs a)
-- | Sort each group of siblings in an account tree by inclusive amount,
-- so that the accounts with largest normal balances are listed first.
-- so that the accounts with largest normal balances are listed first.
-- The provided normal balance sign determines whether normal balances
-- are negative or positive, affecting the sort order. Ie,
-- if balances are normally negative, then the most negative balances
@ -217,10 +217,10 @@ accountSetDeclarationInfo j a@Account{..} =
-- | Sort account names by the order in which they were declared in
-- the journal, at each level of the account tree (ie within each
-- group of siblings). Undeclared accounts are sorted last and
-- alphabetically.
-- alphabetically.
-- This is hledger's default sort for reports organised by account.
-- The account list is converted to a tree temporarily, adding any
-- missing parents; these can be kept (suitable for a tree-mode report)
-- missing parents; these can be kept (suitable for a tree-mode report)
-- or removed (suitable for a flat-mode report).
--
sortAccountNamesByDeclaration :: Journal -> Bool -> [AccountName] -> [AccountName]
@ -235,14 +235,14 @@ sortAccountNamesByDeclaration j keepparents as =
as
-- | Sort each group of siblings in an account tree by declaration order, then account name.
-- So each group will contain first the declared accounts,
-- in the same order as their account directives were parsed,
-- and then the undeclared accounts, sorted by account name.
-- So each group will contain first the declared accounts,
-- in the same order as their account directives were parsed,
-- and then the undeclared accounts, sorted by account name.
sortAccountTreeByDeclaration :: Account -> Account
sortAccountTreeByDeclaration a
| null $ asubs a = a
| otherwise = a{asubs=
sortOn accountDeclarationOrderAndName $
sortOn accountDeclarationOrderAndName $
map sortAccountTreeByDeclaration $ asubs a
}

10
hledger-lib/Hledger/Data/AccountName.hs
View File

@ -29,7 +29,7 @@ module Hledger.Data.AccountName (
,expandAccountName
,expandAccountNames
,isAccountNamePrefixOf
-- ,isAccountRegex
-- ,isAccountRegex
,isSubAccountNameOf
,parentAccountName
,parentAccountNames
@ -50,7 +50,7 @@ import Data.Tree
import Text.Printf
import Hledger.Data.Types
import Hledger.Utils
import Hledger.Utils
-- $setup
-- >>> :set -XOverloadedStrings
@ -88,13 +88,13 @@ accountNameLevel "" = 0
accountNameLevel a = T.length (T.filter (==acctsepchar) a) + 1
-- | A top-level account prefixed to some accounts in budget reports.
-- Defined here so it can be ignored by accountNameDrop.
-- Defined here so it can be ignored by accountNameDrop.
unbudgetedAccountName :: T.Text
unbudgetedAccountName = "<unbudgeted>"
-- | Remove some number of account name components from the front of the account name.
-- If the special "<unbudgeted>" top-level account is present, it is preserved and
-- dropping affects the rest of the account name.
-- dropping affects the rest of the account name.
accountNameDrop :: Int -> AccountName -> AccountName
accountNameDrop n a
| a == unbudgetedAccountName = a
@ -103,7 +103,7 @@ accountNameDrop n a
"" -> unbudgetedAccountName
a' -> unbudgetedAccountAndSep <> a'
| otherwise = accountNameFromComponents $ drop n $ accountNameComponents a
where
where
unbudgetedAccountAndSep = unbudgetedAccountName <> acctsep
-- | Sorted unique account names implied by these account names,

56
hledger-lib/Hledger/Data/Amount.hs
View File

@ -139,7 +139,7 @@ import Text.Printf
import Hledger.Data.Types
import Hledger.Data.Commodity
import Hledger.Utils
import Hledger.Utils
deriving instance Show MarketPrice
@ -148,7 +148,7 @@ deriving instance Show MarketPrice
-------------------------------------------------------------------------------
-- Amount styles
-- | Default amount style
-- | Default amount style
amountstyle = AmountStyle L False 0 (Just '.') Nothing
@ -222,10 +222,10 @@ amountToCost styles = styleAmount styles . costOfAmount
-- | Replace an amount's TotalPrice, if it has one, with an equivalent UnitPrice.
-- Has no effect on amounts without one.
-- Also increases the unit price's display precision to show one extra decimal place,
-- to help keep transaction amounts balancing.
-- to help keep transaction amounts balancing.
-- Does Decimal division, might be some rounding/irrational number issues.
amountTotalPriceToUnitPrice :: Amount -> Amount
amountTotalPriceToUnitPrice
amountTotalPriceToUnitPrice
a@Amount{aquantity=q, aprice=Just (TotalPrice pa@Amount{aquantity=pq, astyle=ps@AmountStyle{asprecision=pp}})}
= a{aprice = Just $ UnitPrice pa{aquantity=abs (pq/q), astyle=ps{asprecision=pp+1}}}
amountTotalPriceToUnitPrice a = a
@ -317,20 +317,20 @@ showAmountDebug Amount{..} = printf "Amount {acommodity=%s, aquantity=%s, aprice
showAmountWithoutPrice :: Amount -> String
showAmountWithoutPrice a = showAmount a{aprice=Nothing}
-- | Set an amount's internal precision, ie rounds the Decimal representing
-- | Set an amount's internal precision, ie rounds the Decimal representing
-- the amount's quantity to some number of decimal places.
-- Rounding is done with Data.Decimal's default roundTo function:
-- "If the value ends in 5 then it is rounded to the nearest even value (Banker's Rounding)".
-- Does not change the amount's display precision.
-- Intended only for internal use, eg when comparing amounts in tests.
-- Intended only for internal use, eg when comparing amounts in tests.
setAmountInternalPrecision :: Int -> Amount -> Amount
setAmountInternalPrecision p a@Amount{ aquantity=q, astyle=s } = a{
astyle=s{asprecision=p}
setAmountInternalPrecision p a@Amount{ aquantity=q, astyle=s } = a{
astyle=s{asprecision=p}
,aquantity=roundTo (fromIntegral p) q
}
-- | Set an amount's internal precision, flipped.
-- Intended only for internal use, eg when comparing amounts in tests.
-- Intended only for internal use, eg when comparing amounts in tests.
withInternalPrecision :: Amount -> Int -> Amount
withInternalPrecision = flip setAmountInternalPrecision
@ -366,7 +366,7 @@ styleAmount :: M.Map CommoditySymbol AmountStyle -> Amount -> Amount
styleAmount styles a =
case M.lookup (acommodity a) styles of
Just s -> a{astyle=s}
Nothing -> a
Nothing -> a
-- | Get the string representation of an amount, based on its
-- commodity's display settings. String representations equivalent to
@ -375,7 +375,7 @@ styleAmount styles a =
showAmount :: Amount -> String
showAmount = showAmountHelper False
-- | Colour version. For a negative amount, adds ANSI codes to change the colour,
-- | Colour version. For a negative amount, adds ANSI codes to change the colour,
-- currently to hard-coded red.
cshowAmount :: Amount -> String
cshowAmount a =
@ -589,7 +589,7 @@ multiplyMixedAmountAndPrice n = mapMixedAmount (multiplyAmountAndPrice n)
-- | Calculate the average of some mixed amounts.
averageMixedAmounts :: [MixedAmount] -> MixedAmount
averageMixedAmounts [] = 0
averageMixedAmounts as = fromIntegral (length as) `divideMixedAmount` sum as
averageMixedAmounts as = fromIntegral (length as) `divideMixedAmount` sum as
-- | Is this mixed amount negative, if it can be normalised to a single commodity ?
isNegativeMixedAmount :: MixedAmount -> Maybe Bool
@ -620,7 +620,7 @@ isReallyZeroMixedAmountCost = isReallyZeroMixedAmount . costOfMixedAmount
-- | Given a map of standard amount display styles, apply the appropriate ones to each individual amount.
styleMixedAmount :: M.Map CommoditySymbol AmountStyle -> MixedAmount -> MixedAmount
styleMixedAmount styles (Mixed as) = Mixed $ map (styleAmount styles) as
styleMixedAmount styles (Mixed as) = Mixed $ map (styleAmount styles) as
-- | Get the string representation of a mixed amount, after
-- normalising it to one amount per commodity. Assumes amounts have
@ -713,7 +713,7 @@ canonicaliseMixedAmount :: M.Map CommoditySymbol AmountStyle -> MixedAmount -> M
canonicaliseMixedAmount styles (Mixed as) = Mixed $ map (canonicaliseAmount styles) as
-- | Replace each component amount's TotalPrice, if it has one, with an equivalent UnitPrice.
-- Has no effect on amounts without one.
-- Has no effect on amounts without one.
-- Does Decimal division, might be some rounding/irrational number issues.
mixedAmountTotalPriceToUnitPrice :: MixedAmount -> MixedAmount
mixedAmountTotalPriceToUnitPrice (Mixed as) = Mixed $ map amountTotalPriceToUnitPrice as
@ -731,17 +731,17 @@ tests_Amount = tests "Amount" [
,costOfAmount (eur 1){aprice=Just $ TotalPrice $ usd 2} `is` usd 2
,costOfAmount (eur (-1)){aprice=Just $ TotalPrice $ usd 2} `is` usd (-2)
]
,tests "isZeroAmount" [
expect $ isZeroAmount amount
,expect $ isZeroAmount $ usd 0
]
,tests "negating amounts" [
negate (usd 1) `is` (usd 1){aquantity= -1}
,let b = (usd 1){aprice=Just $ UnitPrice $ eur 2} in negate b `is` b{aquantity= -1}
]
,tests "adding amounts without prices" [
(usd 1.23 + usd (-1.23)) `is` usd 0
,(usd 1.23 + usd (-1.23)) `is` usd 0
@ -753,7 +753,7 @@ tests_Amount = tests "Amount" [
-- adding different commodities assumes conversion rate 1
,expect $ isZeroAmount (usd 1.23 - eur 1.23)
]
,tests "showAmount" [
showAmount (usd 0 + gbp 0) `is` "0"
]
@ -770,7 +770,7 @@ tests_Amount = tests "Amount" [
])
`is` Mixed [usd 0 `withPrecision` 3]
]
,tests "adding mixed amounts with total prices" [
sum (map (Mixed . (:[]))
[usd 1 @@ eur 1
@ -780,7 +780,7 @@ tests_Amount = tests "Amount" [
,usd (-2) @@ eur 1
]
]
,tests "showMixedAmount" [
showMixedAmount (Mixed [usd 1]) `is` "$1.00"
,showMixedAmount (Mixed [usd 1 `at` eur 2]) `is` "$1.00 @ €2.00"
@ -788,27 +788,27 @@ tests_Amount = tests "Amount" [
,showMixedAmount (Mixed []) `is` "0"
,showMixedAmount missingmixedamt `is` ""
]
,tests "showMixedAmountWithoutPrice" $
let a = usd 1 `at` eur 2 in
let a = usd 1 `at` eur 2 in
[
showMixedAmountWithoutPrice (Mixed [a]) `is` "$1.00"
,showMixedAmountWithoutPrice (Mixed [a, -a]) `is` "0"
]
,tests "normaliseMixedAmount" [
test "a missing amount overrides any other amounts" $
test "a missing amount overrides any other amounts" $
normaliseMixedAmount (Mixed [usd 1, missingamt]) `is` missingmixedamt
,test "unpriced same-commodity amounts are combined" $
,test "unpriced same-commodity amounts are combined" $
normaliseMixedAmount (Mixed [usd 0, usd 2]) `is` Mixed [usd 2]
,test "amounts with same unit price are combined" $
,test "amounts with same unit price are combined" $
normaliseMixedAmount (Mixed [usd 1 `at` eur 1, usd 1 `at` eur 1]) `is` Mixed [usd 2 `at` eur 1]
,test "amounts with different unit prices are not combined" $
,test "amounts with different unit prices are not combined" $
normaliseMixedAmount (Mixed [usd 1 `at` eur 1, usd 1 `at` eur 2]) `is` Mixed [usd 1 `at` eur 1, usd 1 `at` eur 2]
,test "amounts with total prices are not combined" $
normaliseMixedAmount (Mixed [usd 1 @@ eur 1, usd 1 @@ eur 1]) `is` Mixed [usd 1 @@ eur 1, usd 1 @@ eur 1]
]
,tests "normaliseMixedAmountSquashPricesForDisplay" [
normaliseMixedAmountSquashPricesForDisplay (Mixed []) `is` Mixed [nullamt]
,expect $ isZeroMixedAmount $ normaliseMixedAmountSquashPricesForDisplay

66
hledger-lib/Hledger/Data/Dates.hs
View File

@ -156,7 +156,7 @@ spansSpan spans = DateSpan (maybe Nothing spanStart $ headMay spans) (maybe Noth
-- If no interval is specified, the original span is returned.
-- If the original span is the null date span, ie unbounded, the null date span is returned.
-- If the original span is empty, eg if the end date is <= the start date, no spans are returned.
--
--
--
-- ==== Examples:
-- >>> let t i d1 d2 = splitSpan i $ mkdatespan d1 d2
@ -531,19 +531,19 @@ startofyear day = fromGregorian y 1 1 where (y,_,_) = toGregorian day
-- Examples: lets take 2017-11-22. Year-long intervals covering it that
-- starts before Nov 22 will start in 2017. However
-- intervals that start after Nov 23rd should start in 2016:
-- >>> let wed22nd = parsedate "2017-11-22"
-- >>> let wed22nd = parsedate "2017-11-22"
-- >>> nthdayofyearcontaining 11 21 wed22nd
-- 2017-11-21
-- 2017-11-21
-- >>> nthdayofyearcontaining 11 22 wed22nd
-- 2017-11-22
-- 2017-11-22
-- >>> nthdayofyearcontaining 11 23 wed22nd
-- 2016-11-23
-- 2016-11-23
-- >>> nthdayofyearcontaining 12 02 wed22nd
-- 2016-12-02
-- 2016-12-02
-- >>> nthdayofyearcontaining 12 31 wed22nd
-- 2016-12-31
-- 2016-12-31
-- >>> nthdayofyearcontaining 1 1 wed22nd
-- 2017-01-01
-- 2017-01-01
nthdayofyearcontaining :: Month -> MonthDay -> Day -> Day
nthdayofyearcontaining m md date
| not (validMonth $ show m) = error' $ "nthdayofyearcontaining: invalid month "++show m
@ -555,23 +555,23 @@ nthdayofyearcontaining m md date
s = startofyear date
-- | For given date d find month-long interval that starts on nth day of month
-- and covers it.
-- and covers it.
-- The given day of month should be basically valid (1-31), or an error is raised.
--
-- Examples: lets take 2017-11-22. Month-long intervals covering it that
-- start on 1st-22nd of month will start in Nov. However
-- intervals that start on 23rd-30th of month should start in Oct:
-- >>> let wed22nd = parsedate "2017-11-22"
-- >>> let wed22nd = parsedate "2017-11-22"
-- >>> nthdayofmonthcontaining 1 wed22nd
-- 2017-11-01
-- 2017-11-01
-- >>> nthdayofmonthcontaining 12 wed22nd
-- 2017-11-12
-- 2017-11-12
-- >>> nthdayofmonthcontaining 22 wed22nd
-- 2017-11-22
-- 2017-11-22
-- >>> nthdayofmonthcontaining 23 wed22nd
-- 2017-10-23
-- 2017-10-23
-- >>> nthdayofmonthcontaining 30 wed22nd
-- 2017-10-30
-- 2017-10-30
nthdayofmonthcontaining :: MonthDay -> Day -> Day
nthdayofmonthcontaining md date
| not (validDay $ show md) = error' $ "nthdayofmonthcontaining: invalid day " ++show md
@ -582,22 +582,22 @@ nthdayofmonthcontaining md date
s = startofmonth date
-- | For given date d find week-long interval that starts on nth day of week
-- and covers it.
-- and covers it.
--
-- Examples: 2017-11-22 is Wed. Week-long intervals that cover it and
-- start on Mon, Tue or Wed will start in the same week. However
-- intervals that start on Thu or Fri should start in prev week:
-- >>> let wed22nd = parsedate "2017-11-22"
-- intervals that start on Thu or Fri should start in prev week:
-- >>> let wed22nd = parsedate "2017-11-22"
-- >>> nthdayofweekcontaining 1 wed22nd
-- 2017-11-20
-- 2017-11-20
-- >>> nthdayofweekcontaining 2 wed22nd
-- 2017-11-21
-- >>> nthdayofweekcontaining 3 wed22nd
-- 2017-11-22
-- 2017-11-22
-- >>> nthdayofweekcontaining 4 wed22nd
-- 2017-11-16
-- 2017-11-16
-- >>> nthdayofweekcontaining 5 wed22nd
-- 2017-11-17
-- 2017-11-17
nthdayofweekcontaining :: WeekDay -> Day -> Day
nthdayofweekcontaining n d | nthOfSameWeek <= d = nthOfSameWeek
| otherwise = nthOfPrevWeek
@ -606,12 +606,12 @@ nthdayofweekcontaining n d | nthOfSameWeek <= d = nthOfSameWeek
s = startofweek d
-- | For given date d find month-long interval that starts on nth weekday of month
-- and covers it.
-- and covers it.
--
-- Examples: 2017-11-22 is 3rd Wed of Nov. Month-long intervals that cover it and
-- start on 1st-4th Wed will start in Nov. However
-- intervals that start on 4th Thu or Fri or later should start in Oct:
-- >>> let wed22nd = parsedate "2017-11-22"
-- intervals that start on 4th Thu or Fri or later should start in Oct:
-- >>> let wed22nd = parsedate "2017-11-22"
-- >>> nthweekdayofmonthcontaining 1 3 wed22nd
-- 2017-11-01
-- >>> nthweekdayofmonthcontaining 3 2 wed22nd
@ -630,12 +630,12 @@ nthweekdayofmonthcontaining n wd d | nthWeekdaySameMonth <= d = nthWeekdaySameM
-- | Advance to nth weekday wd after given start day s
advancetonthweekday :: Int -> WeekDay -> Day -> Day
advancetonthweekday n wd s =
advancetonthweekday n wd s =
maybe err (addWeeks (n-1)) $ firstMatch (>=s) $ iterate (addWeeks 1) $ firstweekday s
where
err = error' "advancetonthweekday: should not happen"
addWeeks k = addDays (7 * fromIntegral k)
firstMatch p = headMay . dropWhile (not . p)
firstMatch p = headMay . dropWhile (not . p)
firstweekday = addDays (fromIntegral wd-1) . startofweek
----------------------------------------------------------------------
@ -834,7 +834,7 @@ md = do
failIfInvalidDay d
return ("",m,d)
-- These are compared case insensitively, and should all be kept lower case.
-- These are compared case insensitively, and should all be kept lower case.
months = ["january","february","march","april","may","june",
"july","august","september","october","november","december"]
monthabbrevs = ["jan","feb","mar","apr","may","jun","jul","aug","sep","oct","nov","dec"]
@ -864,8 +864,8 @@ weekday = do
wday <- T.toLower <$> (choice . map string' $ weekdays ++ weekdayabbrevs)
case catMaybes $ [wday `elemIndex` weekdays, wday `elemIndex` weekdayabbrevs] of
(i:_) -> return (i+1)
[] -> fail $ "weekday: should not happen: attempted to find " <>
show wday <> " in " <> show (weekdays ++ weekdayabbrevs)
[] -> fail $ "weekday: should not happen: attempted to find " <>
show wday <> " in " <> show (weekdays ++ weekdayabbrevs)
today,yesterday,tomorrow :: TextParser m SmartDate
today = string' "today" >> return ("","","today")
@ -909,7 +909,7 @@ lastthisnextthing = do
-- >>> p "every 2nd day"
-- Right (DayOfMonth 2,DateSpan -)
-- >>> p "every 2nd day 2009-"
-- Right (DayOfMonth 2,DateSpan 2009/01/01-)
-- Right (DayOfMonth 2,DateSpan 2009/01/01-)
-- >>> p "every 29th Nov"
-- Right (DayOfYear 11 29,DateSpan -)
-- >>> p "every 29th nov -2009"
@ -1007,9 +1007,9 @@ reportingintervalp = choice' [
string' "of"
skipMany spacenonewline
string' period
optOf_ period = optional $ try $ of_ period
nth = do n <- some digitChar
choice' $ map string' ["st","nd","rd","th"]
return $ read n

144
hledger-lib/Hledger/Data/Journal.hs
View File

@ -111,7 +111,7 @@ import Data.Tree
import System.Time (ClockTime(TOD))
import Text.Printf
import Hledger.Utils
import Hledger.Utils
import Hledger.Data.Types
import Hledger.Data.AccountName
import Hledger.Data.Amount
@ -160,12 +160,12 @@ instance Show Journal where
-- ]
-- The monoid instance for Journal is useful for two situations.
--
--
-- 1. concatenating finalised journals, eg with multiple -f options:
-- FIRST <> SECOND. The second's list fields are appended to the
-- first's, map fields are combined, transaction counts are summed,
-- the parse state of the second is kept.
--
--
-- 2. merging a child parsed journal, eg with the include directive:
-- CHILD <> PARENT. A parsed journal's data is in reverse order, so
-- this gives what we want.
@ -268,7 +268,7 @@ journalPostings = concatMap tpostings . jtxns
journalAccountNamesUsed :: Journal -> [AccountName]
journalAccountNamesUsed = accountNamesFromPostings . journalPostings
-- | Sorted unique account names implied by this journal's transactions -
-- | Sorted unique account names implied by this journal's transactions -
-- accounts posted to and all their implied parent accounts.
journalAccountNamesImplied :: Journal -> [AccountName]
journalAccountNamesImplied = expandAccountNames . journalAccountNamesUsed
@ -289,31 +289,31 @@ journalAccountNamesDeclaredOrImplied j = nub $ sort $ journalAccountNamesDeclare
-- | Convenience/compatibility alias for journalAccountNamesDeclaredOrImplied.
journalAccountNames :: Journal -> [AccountName]
journalAccountNames = journalAccountNamesDeclaredOrImplied
journalAccountNames = journalAccountNamesDeclaredOrImplied
journalAccountNameTree :: Journal -> Tree AccountName
journalAccountNameTree = accountNameTreeFrom . journalAccountNames
-- queries for standard account types
-- | Get a query for accounts of a certain type (Asset, Liability..) in this journal.
-- The query will match all accounts which were declared as that type by account directives,
-- plus all their subaccounts which have not been declared as a different type.
-- If no accounts were declared as this type, the query will instead match accounts
-- | Get a query for accounts of a certain type (Asset, Liability..) in this journal.
-- The query will match all accounts which were declared as that type by account directives,
-- plus all their subaccounts which have not been declared as a different type.
-- If no accounts were declared as this type, the query will instead match accounts
-- with names matched by the provided case-insensitive regular expression.
journalAccountTypeQuery :: AccountType -> Regexp -> Journal -> Query
journalAccountTypeQuery atype fallbackregex j =
case M.lookup atype (jdeclaredaccounttypes j) of
Nothing -> Acct fallbackregex
Just as ->
-- XXX Query isn't able to match account type since that requires extra info from the journal.
-- XXX Query isn't able to match account type since that requires extra info from the journal.
-- So we do a hacky search by name instead.
And [
And [
Or $ map (Acct . accountNameToAccountRegex) as
,Not $ Or $ map (Acct . accountNameToAccountRegex) differentlytypedsubs
]
where
differentlytypedsubs = concat
differentlytypedsubs = concat
[subs | (t,bs) <- M.toList (jdeclaredaccounttypes j)
, t /= atype
, let subs = [b | b <- bs, any (`isAccountNamePrefixOf` b) as]
@ -321,35 +321,35 @@ journalAccountTypeQuery atype fallbackregex j =
-- | A query for accounts in this journal which have been
-- declared as Asset by account directives, or otherwise for
-- accounts with names matched by the case-insensitive regular expression
-- accounts with names matched by the case-insensitive regular expression
-- @^assets?(:|$)@.
journalAssetAccountQuery :: Journal -> Query
journalAssetAccountQuery = journalAccountTypeQuery Asset "^assets?(:|$)"
-- | 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
-- accounts with names matched by the case-insensitive regular expression
-- @^(debts?|liabilit(y|ies))(:|$)@.
journalLiabilityAccountQuery :: Journal -> Query
journalLiabilityAccountQuery = journalAccountTypeQuery Liability "^(debts?|liabilit(y|ies))(:|$)"
-- | 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
-- accounts with names matched by the case-insensitive regular expression
-- @^equity(:|$)@.
journalEquityAccountQuery :: Journal -> Query
journalEquityAccountQuery = journalAccountTypeQuery Equity "^equity(:|$)"
-- | 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
-- accounts with names matched by the case-insensitive regular expression
-- @^(income|revenue)s?(:|$)@.
journalRevenueAccountQuery :: Journal -> Query
journalRevenueAccountQuery = journalAccountTypeQuery Revenue "^(income|revenue)s?(:|$)"
-- | 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
-- accounts with names matched by the case-insensitive regular expression
-- @^(income|revenue)s?(:|$)@.
journalExpenseAccountQuery :: Journal -> Query
journalExpenseAccountQuery = journalAccountTypeQuery Expense "^expenses?(:|$)"
@ -371,7 +371,7 @@ journalProfitAndLossAccountQuery j = Or [journalRevenueAccountQuery j
-- | A query for Cash (-equivalent) accounts in this journal (ie,
-- accounts which appear on the cashflow statement.) This is currently
-- hard-coded to be all the Asset accounts except for those with names
-- hard-coded to be all the Asset accounts except for those with names
-- containing the case-insensitive regular expression @(receivable|:A/R|:fixed)@.
journalCashAccountQuery :: Journal -> Query
journalCashAccountQuery j = And [journalAssetAccountQuery j, Not $ Acct "(receivable|:A/R|:fixed)"]
@ -579,7 +579,7 @@ journalTieTransactions j@Journal{jtxns=ts} = j{jtxns=map txnTieKnot ts}
journalUntieTransactions :: Transaction -> Transaction
journalUntieTransactions t@Transaction{tpostings=ps} = t{tpostings=map (\p -> p{ptransaction=Nothing}) ps}
-- | Apply any transaction modifier rules in the journal
-- | Apply any transaction modifier rules in the journal
-- (adding automated postings to transactions, eg).
journalModifyTransactions :: Journal -> Journal
journalModifyTransactions j = j{ jtxns = modifyTransactions (jtxnmodifiers j) (jtxns j) }
@ -591,7 +591,7 @@ journalCheckBalanceAssertions = either Just (const Nothing) . journalBalanceTran
-- "Transaction balancing" - inferring missing amounts and checking transaction balancedness and balance assertions
-- | Monad used for statefully balancing/amount-inferring/assertion-checking
-- | Monad used for statefully balancing/amount-inferring/assertion-checking
-- a sequence of transactions.
-- Perhaps can be simplified, or would a different ordering of layers make sense ?
-- If you see a way, let us know.
@ -613,9 +613,9 @@ data BalancingState s = BalancingState {
withB :: (BalancingState s -> ST s a) -> Balancing s a
withB f = ask >>= lift . lift . f
-- | Get an account's running balance so far.
-- | Get an account's running balance so far.
getAmountB :: AccountName -> Balancing s MixedAmount
getAmountB acc = withB $ \BalancingState{bsBalances} -> do
getAmountB acc = withB $ \BalancingState{bsBalances} -> do
fromMaybe 0 <$> H.lookup bsBalances acc
-- | Add an amount to an account's running balance, and return the new running balance.
@ -626,7 +626,7 @@ addAmountB acc amt = withB $ \BalancingState{bsBalances} -> do
H.insert bsBalances acc new
return new
-- | Set an account's running balance to this amount, and return the difference from the old.
-- | Set an account's running balance to this amount, and return the difference from the old.
setAmountB :: AccountName -> MixedAmount -> Balancing s MixedAmount
setAmountB acc amt = withB $ \BalancingState{bsBalances} -> do
old <- fromMaybe 0 <$> H.lookup bsBalances acc
@ -639,15 +639,15 @@ storeTransactionB t = withB $ \BalancingState{bsTransactions} ->
void $ writeArray bsTransactions (tindex t) t
-- | Infer any missing amounts (to satisfy balance assignments and
-- to balance transactions) and check that all transactions balance
-- to balance transactions) and check that all transactions balance
-- and (optional) all balance assertions pass. Or return an error message
-- (just the first error encountered).
--
-- Assumes journalInferCommodityStyles has been called, since those affect transaction balancing.
--
-- This does multiple things because amount inferring, balance assignments,
-- This does multiple things because amount inferring, balance assignments,
-- balance assertions and posting dates are interdependent.
--
--
-- This can be simplified further. Overview as of 20190219:
-- @
-- ****** parseAndFinaliseJournal['] (Cli/Utils.hs), journalAddForecast (Common.hs), budgetJournal (BudgetReport.hs), tests (BalanceReport.hs)
@ -670,19 +670,19 @@ storeTransactionB t = withB $ \BalancingState{bsTransactions} ->
journalBalanceTransactions :: Bool -> Journal -> Either String Journal
journalBalanceTransactions assrt j' =
let
-- ensure transactions are numbered, so we can store them by number
-- ensure transactions are numbered, so we can store them by number
j@Journal{jtxns=ts} = journalNumberTransactions j'
-- display precisions used in balanced checking
styles = Just $ journalCommodityStyles j
-- balance assignments will not be allowed on these
txnmodifieraccts = S.fromList $ map paccount $ concatMap tmpostingrules $ jtxnmodifiers j
in
runST $ do
txnmodifieraccts = S.fromList $ map paccount $ concatMap tmpostingrules $ jtxnmodifiers j
in
runST $ do
-- We'll update a mutable array of transactions as we balance them,
-- not strictly necessary but avoids a sort at the end I think.
balancedtxns <- newListArray (1, genericLength ts) ts
-- Infer missing posting amounts, check transactions are balanced,
-- Infer missing posting amounts, check transactions are balanced,
-- and check balance assertions. This is done in two passes:
runExceptT $ do
@ -691,14 +691,14 @@ journalBalanceTransactions assrt j' =
-- The postings and not-yet-balanced transactions remain in the same relative order.
psandts :: [Either Posting Transaction] <- fmap concat $ forM ts $ \case
t | null $ assignmentPostings t -> case balanceTransaction styles t of
Left e -> throwError e
Left e -> throwError e
Right t' -> do
lift $ writeArray balancedtxns (tindex t') t'
return $ map Left $ tpostings t'
t -> return [Right t]
-- 2. Sort these items by date, preserving the order of same-day items,
-- and step through them while keeping running account balances,
-- and step through them while keeping running account balances,
runningbals <- lift $ H.newSized (length $ journalAccountNamesUsed j)
flip runReaderT (BalancingState styles txnmodifieraccts assrt runningbals balancedtxns) $ do
-- performing balance assignments in, and balancing, the remaining transactions,
@ -706,17 +706,17 @@ journalBalanceTransactions assrt j' =
void $ mapM' balanceTransactionAndCheckAssertionsB $ sortOn (either postingDate tdate) psandts
ts' <- lift $ getElems balancedtxns
return j{jtxns=ts'}
return j{jtxns=ts'}
-- | This function is called statefully on each of a date-ordered sequence of
-- 1. fully explicit postings from already-balanced transactions and
-- | This function is called statefully on each of a date-ordered sequence of
-- 1. fully explicit postings from already-balanced transactions and
-- 2. not-yet-balanced transactions containing balance assignments.
-- It executes balance assignments and finishes balancing the transactions,
-- It executes balance assignments and finishes balancing the transactions,
-- and checks balance assertions on each posting as it goes.
-- An error will be thrown if a transaction can't be balanced
-- An error will be thrown if a transaction can't be balanced
-- or if an illegal balance assignment is found (cf checkIllegalBalanceAssignment).
-- Transaction prices are removed, which helps eg balance-assertions.test: 15. Mix different commodities and assignments.
-- This stores the balanced transactions in case 2 but not in case 1.
-- This stores the balanced transactions in case 2 but not in case 1.
balanceTransactionAndCheckAssertionsB :: Either Posting Transaction -> Balancing s ()
balanceTransactionAndCheckAssertionsB (Left p@Posting{}) =
@ -726,28 +726,28 @@ balanceTransactionAndCheckAssertionsB (Left p@Posting{}) =
balanceTransactionAndCheckAssertionsB (Right t@Transaction{tpostings=ps}) = do
-- make sure we can handle the balance assignments
mapM_ checkIllegalBalanceAssignmentB ps
-- for each posting, infer its amount from the balance assignment if applicable,
-- for each posting, infer its amount from the balance assignment if applicable,
-- update the account's running balance and check the balance assertion if any
ps' <- forM ps $ \p -> pure (removePrices p) >>= addOrAssignAmountAndCheckAssertionB
-- infer any remaining missing amounts, and make sure the transaction is now fully balanced
-- infer any remaining missing amounts, and make sure the transaction is now fully balanced
styles <- R.reader bsStyles
case balanceTransactionHelper styles t{tpostings=ps'} of
Left err -> throwError err
Left err -> throwError err
Right (t', inferredacctsandamts) -> do
-- for each amount just inferred, update the running balance
-- for each amount just inferred, update the running balance
mapM_ (uncurry addAmountB) inferredacctsandamts
-- and save the balanced transaction.
storeTransactionB t'
storeTransactionB t'
-- | If this posting has an explicit amount, add it to the account's running balance.
-- If it has a missing amount and a balance assignment, infer the amount from, and
-- If it has a missing amount and a balance assignment, infer the amount from, and
-- reset the running balance to, the assigned balance.
-- If it has a missing amount and no balance assignment, leave it for later.
-- Then test the balance assertion if any.
addOrAssignAmountAndCheckAssertionB :: Posting -> Balancing s Posting
addOrAssignAmountAndCheckAssertionB p@Posting{paccount=acc, pamount=amt, pbalanceassertion=mba}
| hasAmount p = do
newbal <- addAmountB acc amt
newbal <- addAmountB acc amt
whenM (R.reader bsAssrt) $ checkBalanceAssertionB p newbal
return p
| Just BalanceAssertion{baamount,batotal} <- mba = do
@ -760,8 +760,8 @@ addOrAssignAmountAndCheckAssertionB p@Posting{paccount=acc, pamount=amt, pbalanc
False -> do
-- a partial balance assignment
oldbalothercommodities <- filterMixedAmount ((acommodity baamount /=) . acommodity) <$> getAmountB acc
let assignedbalthiscommodity = Mixed [baamount]
newbal = oldbalothercommodities + assignedbalthiscommodity
let assignedbalthiscommodity = Mixed [baamount]
newbal = oldbalothercommodities + assignedbalthiscommodity
diff <- setAmountB acc newbal
return (diff,newbal)
let p' = p{pamount=diff, poriginal=Just $ originalPosting p}
@ -774,7 +774,7 @@ addOrAssignAmountAndCheckAssertionB p@Posting{paccount=acc, pamount=amt, pbalanc
-- optionally check the posting's balance assertion if any.
-- The posting is expected to have an explicit amount (otherwise this does nothing).
-- Adding and checking balance assertions are tightly paired because we
-- need to see the balance as it stands after each individual posting.
-- need to see the balance as it stands after each individual posting.
addAmountAndCheckAssertionB :: Posting -> Balancing s Posting
addAmountAndCheckAssertionB p | hasAmount p = do
newbal <- addAmountB (paccount p) (pamount p)
@ -806,17 +806,17 @@ checkBalanceAssertionB _ _ = return ()
checkBalanceAssertionOneCommodityB :: Posting -> Amount -> MixedAmount -> Balancing s ()
checkBalanceAssertionOneCommodityB p@Posting{paccount=assertedacct} assertedamt actualbal = do
let isinclusive = maybe False bainclusive $ pbalanceassertion p
actualbal' <-
if isinclusive
then
-- sum the running balances of this account and any of its subaccounts seen so far
withB $ \BalancingState{bsBalances} ->
H.foldM
(\ibal (acc, amt) -> return $ ibal +
actualbal' <-
if isinclusive
then
-- sum the running balances of this account and any of its subaccounts seen so far
withB $ \BalancingState{bsBalances} ->
H.foldM
(\ibal (acc, amt) -> return $ ibal +
if assertedacct==acc || assertedacct `isAccountNamePrefixOf` acc then amt else 0)
0
0
bsBalances
else return actualbal
else return actualbal
let
assertedcomm = acommodity assertedamt
actualbalincomm = headDef 0 $ amounts $ filterMixedAmountByCommodity assertedcomm $ actualbal'
@ -863,17 +863,17 @@ checkBalanceAssertionOneCommodityB p@Posting{paccount=assertedacct} assertedamt
-- | Throw an error if this posting is trying to do an illegal balance assignment.
checkIllegalBalanceAssignmentB :: Posting -> Balancing s ()
checkIllegalBalanceAssignmentB p = do
checkIllegalBalanceAssignmentB p = do
checkBalanceAssignmentPostingDateB p
checkBalanceAssignmentUnassignableAccountB p
-- XXX these should show position. annotateErrorWithTransaction t ?
-- | Throw an error if this posting is trying to do a balance assignment and
-- has a custom posting date (which makes amount inference too hard/impossible).
checkBalanceAssignmentPostingDateB :: Posting -> Balancing s ()
checkBalanceAssignmentPostingDateB p =
when (hasBalanceAssignment p && isJust (pdate p)) $
when (hasBalanceAssignment p && isJust (pdate p)) $
throwError $ unlines $
["postings which are balance assignments may not have a custom date."
,"Please write the posting amount explicitly, or remove the posting date:"
@ -918,8 +918,8 @@ journalApplyCommodityStyles j@Journal{jtxns=ts, jpricedirectives=pds} = j''
fixbalanceassertion ba = ba{baamount=styleAmount styles $ baamount ba}
fixpricedirective pd@PriceDirective{pdamount=a} = pd{pdamount=styleAmount styles a}
-- | Get all the amount styles defined in this journal, either declared by
-- a commodity directive or inferred from amounts, as a map from symbol to style.
-- | Get all the amount styles defined in this journal, either declared by
-- a commodity directive or inferred from amounts, as a map from symbol to style.
-- Styles declared by commodity directives take precedence, and these also are
-- guaranteed to know their decimal point character.
journalCommodityStyles :: Journal -> M.Map CommoditySymbol AmountStyle
@ -1078,23 +1078,23 @@ journalPivot fieldortagname j = j{jtxns = map (transactionPivot fieldortagname)
-- | Replace this transaction's postings' account names with the value
-- of the given field or tag, if any.
transactionPivot :: Text -> Transaction -> Transaction
transactionPivot :: Text -> Transaction -> Transaction
transactionPivot fieldortagname t = t{tpostings = map (postingPivot fieldortagname) . tpostings $ t}
-- | Replace this posting's account name with the value
-- of the given field or tag, if any, otherwise the empty string.
postingPivot :: Text -> Posting -> Posting
postingPivot :: Text -> Posting -> Posting
postingPivot fieldortagname p = p{paccount = pivotedacct, poriginal = Just $ originalPosting p}
where
pivotedacct
| Just t <- ptransaction p, fieldortagname == "code" = tcode t
| Just t <- ptransaction p, fieldortagname == "description" = tdescription t
| Just t <- ptransaction p, fieldortagname == "payee" = transactionPayee t
| Just t <- ptransaction p, fieldortagname == "note" = transactionNote t
| Just t <- ptransaction p, fieldortagname == "code" = tcode t
| Just t <- ptransaction p, fieldortagname == "description" = tdescription t
| Just t <- ptransaction p, fieldortagname == "payee" = transactionPayee t
| Just t <- ptransaction p, fieldortagname == "note" = transactionNote t
| Just (_, value) <- postingFindTag fieldortagname p = value
| otherwise = ""
postingFindTag :: TagName -> Posting -> Maybe (TagName, TagValue)
postingFindTag :: TagName -> Posting -> Maybe (TagName, TagValue)
postingFindTag tagname p = find ((tagname==) . fst) $ postingAllTags p
-- -- | Build a database of market prices in effect on the given date,
@ -1333,8 +1333,8 @@ tests_Journal = tests "Journal" [
nulljournal{ jtxns = [
transaction "2019/01/01" [ vpost' "a" (num 2) (balassert (num 2)) ]
,transaction "2019/01/01" [
post' "b" (num 1) Nothing
,post' "a" missingamt Nothing
post' "b" (num 1) Nothing
,post' "a" missingamt Nothing
]
,transaction "2019/01/01" [ post' "a" (num 0) (balassert (num 1)) ]
]}

2
hledger-lib/Hledger/Data/Ledger.hs
View File

@ -31,7 +31,7 @@ import qualified Data.Text as T
import Safe (headDef)
import Text.Printf
import Hledger.Utils.Test
import Hledger.Utils.Test
import Hledger.Data.Types
import Hledger.Data.Account
import Hledger.Data.Journal

2
hledger-lib/Hledger/Data/Period.hs
View File

@ -166,7 +166,7 @@ showPeriod (PeriodFrom b) = formatTime defaultTimeLocale "%0C%y/%m/%d-" b
showPeriod (PeriodTo e) = formatTime defaultTimeLocale "-%0C%y/%m/%d" (addDays (-1) e) -- -INCLUSIVEENDDATE
showPeriod PeriodAll = "-"
-- | Like showPeriod, but if it's a month period show just
-- | Like showPeriod, but if it's a month period show just
-- the 3 letter month name abbreviation for the current locale.
showPeriodMonthAbbrev (MonthPeriod _ m) -- Jan
| m > 0 && m <= length monthnames = snd $ monthnames !! (m-1)

28
hledger-lib/Hledger/Data/PeriodicTransaction.hs
View File

@ -34,7 +34,7 @@ import Hledger.Utils.UTF8IOCompat (error')
-- doctest helper, too much hassle to define in the comment
-- XXX duplicates some logic in periodictransactionp
_ptgen str = do
let
let
t = T.pack str
(i,s) = parsePeriodExpr' nulldate t
case checkPeriodicTransactionStartDate i s t of
@ -42,7 +42,7 @@ _ptgen str = do
Nothing ->
mapM_ (putStr . showTransaction) $
runPeriodicTransaction
nullperiodictransaction{ ptperiodexpr=t , ptspan=s, ptinterval=i, ptpostings=["a" `post` usd 1] }
nullperiodictransaction{ ptperiodexpr=t , ptspan=s, ptinterval=i, ptpostings=["a" `post` usd 1] }
nulldatespan
@ -184,13 +184,13 @@ instance Show PeriodicTransaction where
-- *** Exception: Unable to generate transactions according to "weekly from 2017" because 2017-01-01 is not a first day of the week
--
-- >>> _ptgen "monthly from 2017/5/4"
-- *** Exception: Unable to generate transactions according to "monthly from 2017/5/4" because 2017-05-04 is not a first day of the month
-- *** Exception: Unable to generate transactions according to "monthly from 2017/5/4" because 2017-05-04 is not a first day of the month
--
-- >>> _ptgen "every quarter from 2017/1/2"
-- *** Exception: Unable to generate transactions according to "every quarter from 2017/1/2" because 2017-01-02 is not a first day of the quarter
-- *** Exception: Unable to generate transactions according to "every quarter from 2017/1/2" because 2017-01-02 is not a first day of the quarter
--
-- >>> _ptgen "yearly from 2017/1/14"
-- *** Exception: Unable to generate transactions according to "yearly from 2017/1/14" because 2017-01-14 is not a first day of the year
-- *** Exception: Unable to generate transactions according to "yearly from 2017/1/14" because 2017-01-14 is not a first day of the year
--
-- >>> let reportperiod="daily from 2018/01/03" in let (i,s) = parsePeriodExpr' nulldate reportperiod in runPeriodicTransaction (nullperiodictransaction{ptperiodexpr=reportperiod, ptspan=s, ptinterval=i, ptpostings=["a" `post` usd 1]}) (DateSpan (Just $ parsedate "2018-01-01") (Just $ parsedate "2018-01-03"))
-- []
@ -203,28 +203,28 @@ runPeriodicTransaction PeriodicTransaction{..} requestedspan =
t = nulltransaction{
tstatus = ptstatus
,tcode = ptcode
,tdescription = ptdescription
,tdescription = ptdescription
,tcomment = (if T.null ptcomment then "\n" else ptcomment) <> "recur: " <> ptperiodexpr
,ttags = ("recur", ptperiodexpr) : pttags
,ttags = ("recur", ptperiodexpr) : pttags
,tpostings = ptpostings
}
-- | Check that this date span begins at a boundary of this interval,
-- | Check that this date span begins at a boundary of this interval,
-- or return an explanatory error message including the provided period expression
-- (from which the span and interval are derived).
checkPeriodicTransactionStartDate :: Interval -> DateSpan -> T.Text -> Maybe String
checkPeriodicTransactionStartDate i s periodexpr =
checkPeriodicTransactionStartDate :: Interval -> DateSpan -> T.Text -> Maybe String
checkPeriodicTransactionStartDate i s periodexpr =
case (i, spanStart s) of
(Weeks _, Just d) -> checkStart d "week"
(Months _, Just d) -> checkStart d "month"
(Quarters _, Just d) -> checkStart d "quarter"
(Years _, Just d) -> checkStart d "year"
_ -> Nothing
_ -> Nothing
where
checkStart d x =
let firstDate = fixSmartDate d ("","this",x)
in
if d == firstDate
let firstDate = fixSmartDate d ("","this",x)
in
if d == firstDate
then Nothing
else Just $
"Unable to generate transactions according to "++show (T.unpack periodexpr)

4
hledger-lib/Hledger/Data/Posting.hs
View File

@ -78,7 +78,7 @@ import qualified Data.Text as T
import Data.Time.Calendar
import Safe
import Hledger.Utils
import Hledger.Utils
import Hledger.Data.Types
import Hledger.Data.Amount
import Hledger.Data.AccountName
@ -221,7 +221,7 @@ postingDate2 p = headDef nulldate $ catMaybes dates
-- | Get a posting's status. This is cleared or pending if those are
-- explicitly set on the posting, otherwise the status of its parent
-- transaction, or unmarked if there is no parent transaction. (Note
-- the ambiguity, unmarked can mean "posting and transaction are both
-- the ambiguity, unmarked can mean "posting and transaction are both
-- unmarked" or "posting is unmarked and don't know about the transaction".
postingStatus :: Posting -> Status
postingStatus Posting{pstatus=s, ptransaction=mt}

2
hledger-lib/Hledger/Data/StringFormat.hs
View File

@ -137,7 +137,7 @@ fieldp = do
----------------------------------------------------------------------
formatStringTester fs value expected = actual `is` expected
formatStringTester fs value expected = actual `is` expected
where
actual = case fs of
FormatLiteral l -> formatString False Nothing Nothing l

6
hledger-lib/Hledger/Data/Timeclock.hs
View File

@ -26,7 +26,7 @@ import System.Locale (defaultTimeLocale)
#endif
import Text.Printf
import Hledger.Utils
import Hledger.Utils
import Hledger.Data.Types
import Hledger.Data.Dates
import Hledger.Data.Amount
@ -130,10 +130,10 @@ tests_Timeclock = tests "Timeclock" [
parseTime defaultTimeLocale "%H:%M:%S"
#endif
showtime = formatTime defaultTimeLocale "%H:%M"
txndescs = map (T.unpack . tdescription) . timeclockEntriesToTransactions now
txndescs = map (T.unpack . tdescription) . timeclockEntriesToTransactions now
future = utcToLocalTime tz $ addUTCTime 100 now'
futurestr = showtime future
tests "timeclockEntriesToTransactions" [
tests "timeclockEntriesToTransactions" [
test "started yesterday, split session at midnight" $
txndescs [clockin (mktime yesterday "23:00:00") "" ""] `is` ["23:00-23:59","00:00-"++nowstr]
,test "split multi-day sessions at each midnight" $

80
hledger-lib/Hledger/Data/Transaction.hs
View File

@ -62,7 +62,7 @@ import Data.Time.Calendar
import Text.Printf
import qualified Data.Map as Map
import Hledger.Utils
import Hledger.Utils
import Hledger.Data.Types
import Hledger.Data.Dates
import Hledger.Data.Posting
@ -101,7 +101,7 @@ nulltransaction = Transaction {
}
-- | Make a simple transaction with the given date and postings.
transaction :: String -> [Posting] -> Transaction
transaction :: String -> [Posting] -> Transaction
transaction datestr ps = txnTieKnot $ nulltransaction{tdate=parsedate datestr, tpostings=ps}
transactionPayee :: Transaction -> Text
@ -122,7 +122,7 @@ payeeAndNoteFromDescription t
(p, n) = T.span (/= '|') t
{-|
Render a journal transaction as text in the style of Ledger's print command.
Render a journal transaction as text in the style of Ledger's print command.
Ledger 2.x's standard format looks like this:
@ -139,7 +139,7 @@ pcommentwidth = no limit -- 22
@
The output will be parseable journal syntax.
To facilitate this, postings with explicit multi-commodity amounts
To facilitate this, postings with explicit multi-commodity amounts
are displayed as multiple similar postings, one per commodity.
(Normally does not happen with this function).
@ -148,8 +148,8 @@ and the transaction appears obviously balanced
(postings sum to 0, without needing to infer conversion prices),
the last posting's amount will not be shown.
-}
-- XXX why that logic ?
-- XXX where is/should this be still used ?
-- XXX why that logic ?
-- XXX where is/should this be still used ?
-- XXX rename these, after amount expressions/mixed posting amounts lands
-- eg showTransactionSimpleAmountsElidingLast, showTransactionSimpleAmounts, showTransaction
showTransaction :: Transaction -> String
@ -158,19 +158,19 @@ showTransaction = showTransactionHelper True False
-- | Like showTransaction, but does not change amounts' explicitness.
-- Explicit amounts are shown and implicit amounts are not.
-- The output will be parseable journal syntax.
-- To facilitate this, postings with explicit multi-commodity amounts
-- To facilitate this, postings with explicit multi-commodity amounts
-- are displayed as multiple similar postings, one per commodity.
-- Most often, this is the one you want to use.
showTransactionUnelided :: Transaction -> String
showTransactionUnelided = showTransactionHelper False False
-- | Like showTransactionUnelided, but explicit multi-commodity amounts
-- are shown on one line, comma-separated. In this case the output will
-- | Like showTransactionUnelided, but explicit multi-commodity amounts
-- are shown on one line, comma-separated. In this case the output will
-- not be parseable journal syntax.
showTransactionUnelidedOneLineAmounts :: Transaction -> String
showTransactionUnelidedOneLineAmounts = showTransactionHelper False True
-- | Helper for showTransaction*.
-- | Helper for showTransaction*.
showTransactionHelper :: Bool -> Bool -> Transaction -> String
showTransactionHelper elide onelineamounts t =
unlines $ [descriptionline]
@ -205,7 +205,7 @@ renderCommentLines t =
-- for `print` output. Normally this output will be valid journal syntax which
-- hledger can reparse (though it may include no-longer-valid balance assertions).
--
-- Explicit amounts are shown, any implicit amounts are not.
-- Explicit amounts are shown, any implicit amounts are not.
--
-- Setting elide to true forces the last posting's amount to be implicit, if:
-- there are other postings, all with explicit amounts, and the transaction
@ -215,36 +215,36 @@ renderCommentLines t =
-- if onelineamounts is true, these amounts are shown on one line,
-- comma-separated, and the output will not be valid journal syntax.
-- Otherwise, they are shown as several similar postings, one per commodity.
--
--
-- The output will appear to be a balanced transaction.
-- Amounts' display precisions, which may have been limited by commodity
-- directives, will be increased if necessary to ensure this.
--
-- Posting amounts will be aligned with each other, starting about 4 columns
-- beyond the widest account name (see postingAsLines for details).
--
--
postingsAsLines :: Bool -> Bool -> Transaction -> [Posting] -> [String]
postingsAsLines elide onelineamounts t ps
| elide && length ps > 1 && all hasAmount ps && isTransactionBalanced Nothing t -- imprecise balanced check
= concatMap (postingAsLines False onelineamounts ps) (init ps) ++ postingAsLines True onelineamounts ps (last ps)
| otherwise = concatMap (postingAsLines False onelineamounts ps) ps
-- | Render one posting, on one or more lines, suitable for `print` output.
-- | Render one posting, on one or more lines, suitable for `print` output.
-- There will be an indented account name, plus one or more of status flag,
-- posting amount, balance assertion, same-line comment, next-line comments.
--
--
-- If the posting's amount is implicit or if elideamount is true, no amount is shown.
--
-- If the posting's amount is explicit and multi-commodity, multiple similar
-- If the posting's amount is explicit and multi-commodity, multiple similar
-- postings are shown, one for each commodity, to help produce parseable journal syntax.
-- Or if onelineamounts is true, such amounts are shown on one line, comma-separated
-- (and the output will not be valid journal syntax).
--
-- By default, 4 spaces (2 if there's a status flag) are shown between
-- By default, 4 spaces (2 if there's a status flag) are shown between
-- account name and start of amount area, which is typically 12 chars wide
-- and contains a right-aligned amount (so 10-12 visible spaces between
-- and contains a right-aligned amount (so 10-12 visible spaces between
-- account name and amount is typical).
-- When given a list of postings to be aligned with, the whitespace will be
-- When given a list of postings to be aligned with, the whitespace will be
-- increased if needed to match the posting with the longest account name.
-- This is used to align the amounts of a transaction's postings.
--
@ -255,10 +255,10 @@ postingAsLines elideamount onelineamounts pstoalignwith p = concat [
| postingblock <- postingblocks]
where
postingblocks = [map rstrip $ lines $ concatTopPadded [statusandaccount, " ", amount, assertion, samelinecomment] | amount <- shownAmounts]
assertion = maybe "" ((' ':).showBalanceAssertion) $ pbalanceassertion p
assertion = maybe "" ((' ':).showBalanceAssertion) $ pbalanceassertion p
statusandaccount = lineIndent $ fitString (Just $ minwidth) Nothing False True $ pstatusandacct p
where
-- pad to the maximum account name width, plus 2 to leave room for status flags, to keep amounts aligned
-- pad to the maximum account name width, plus 2 to leave room for status flags, to keep amounts aligned
minwidth = maximum $ map ((2+) . textWidth . T.pack . pacctstr) pstoalignwith
pstatusandacct p' = pstatusprefix p' ++ pacctstr p'
pstatusprefix p' | null s = ""
@ -279,8 +279,8 @@ postingAsLines elideamount onelineamounts pstoalignwith p = concat [
case renderCommentLines (pcomment p) of [] -> ("",[])
c:cs -> (c,cs)
-- | Render a balance assertion, as the =[=][*] symbol and expected amount.
showBalanceAssertion BalanceAssertion{..} =
-- | Render a balance assertion, as the =[=][*] symbol and expected amount.
showBalanceAssertion BalanceAssertion{..} =
"=" ++ ['=' | batotal] ++ ['*' | bainclusive] ++ " " ++ showAmountWithZeroCommodity baamount
-- | Render a posting, simply. Used in balance assertion errors.
@ -296,7 +296,7 @@ showBalanceAssertion BalanceAssertion{..} =
-- assertion = maybe "" ((" = " ++) . showAmountWithZeroCommodity . baamount) $ pbalanceassertion p
-- | Render a posting, at the appropriate width for aligning with
-- its siblings if any. Used by the rewrite command.
-- its siblings if any. Used by the rewrite command.
showPostingLines :: Posting -> [String]
showPostingLines p = postingAsLines False False ps p where
ps | Just t <- ptransaction p = tpostings t
@ -366,14 +366,14 @@ isTransactionBalanced styles t =
bvsum' = canonicalise $ costOfMixedAmount bvsum
canonicalise = maybe id canonicaliseMixedAmount styles
-- | Balance this transaction, ensuring that its postings
-- | Balance this transaction, ensuring that its postings
-- (and its balanced virtual postings) sum to 0,
-- by inferring a missing amount or conversion price(s) if needed.
-- by inferring a missing amount or conversion price(s) if needed.
-- Or if balancing is not possible, because the amounts don't sum to 0 or
-- because there's more than one missing amount, return an error message.
--
-- Transactions with balance assignments can have more than one
-- missing amount; to balance those you should use the more powerful
-- missing amount; to balance those you should use the more powerful
-- journalBalanceTransactions.
--
-- The "sum to 0" test is done using commodity display precisions,
@ -383,18 +383,18 @@ balanceTransaction ::
Maybe (Map.Map CommoditySymbol AmountStyle) -- ^ commodity display styles
-> Transaction
-> Either String Transaction
balanceTransaction mstyles = fmap fst . balanceTransactionHelper mstyles
balanceTransaction mstyles = fmap fst . balanceTransactionHelper mstyles
-- | Helper used by balanceTransaction and balanceTransactionWithBalanceAssignmentAndCheckAssertionsB;
-- use one of those instead. It also returns a list of accounts
-- use one of those instead. It also returns a list of accounts
-- and amounts that were inferred.
balanceTransactionHelper ::
Maybe (Map.Map CommoditySymbol AmountStyle) -- ^ commodity display styles
-> Transaction
-> Either String (Transaction, [(AccountName, MixedAmount)])
balanceTransactionHelper mstyles t = do
(t', inferredamtsandaccts) <-
inferBalancingAmount (fromMaybe Map.empty mstyles) $ inferBalancingPrices t
(t', inferredamtsandaccts) <-
inferBalancingAmount (fromMaybe Map.empty mstyles) $ inferBalancingPrices t
if isTransactionBalanced mstyles t'
then Right (txnTieKnot t', inferredamtsandaccts)
else Left $ annotateErrorWithTransaction t' $ nonzerobalanceerror t'
@ -413,7 +413,7 @@ balanceTransactionHelper mstyles t = do
sep = if not (null rmsg) && not (null bvmsg) then "; " else "" :: String
annotateErrorWithTransaction :: Transaction -> String -> String
annotateErrorWithTransaction t s = intercalate "\n" [showGenericSourcePos $ tsourcepos t, s, showTransactionUnelided t]
annotateErrorWithTransaction t s = intercalate "\n" [showGenericSourcePos $ tsourcepos t, s, showTransactionUnelided t]
-- | Infer up to one missing amount for this transactions's real postings, and
-- likewise for its balanced virtual postings, if needed; or return an error
@ -423,7 +423,7 @@ annotateErrorWithTransaction t s = intercalate "\n" [showGenericSourcePos $ tsou
-- We can infer a missing amount when there are multiple postings and exactly
-- one of them is amountless. If the amounts had price(s) the inferred amount
-- have the same price(s), and will be converted to the price commodity.
inferBalancingAmount ::
inferBalancingAmount ::
Map.Map CommoditySymbol AmountStyle -- ^ commodity display styles
-> Transaction
-> Either String (Transaction, [(AccountName, MixedAmount)])
@ -446,16 +446,16 @@ inferBalancingAmount styles t@Transaction{tpostings=ps}
inferamount p =
let
minferredamt = case ptype p of
RegularPosting | not (hasAmount p) -> Just realsum
BalancedVirtualPosting | not (hasAmount p) -> Just bvsum
_ -> Nothing
RegularPosting | not (hasAmount p) -> Just realsum
BalancedVirtualPosting | not (hasAmount p) -> Just bvsum
_ -> Nothing
in
case minferredamt of
Nothing -> (p, Nothing)
Just a -> (p{pamount=a', poriginal=Just $ originalPosting p}, Just a')
Just a -> (p{pamount=a', poriginal=Just $ originalPosting p}, Just a')
where
-- Inferred amounts are converted to cost.
-- Also ensure the new amount has the standard style for its commodity
-- Also ensure the new amount has the standard style for its commodity
-- (since the main amount styling pass happened before this balancing pass);
a' = styleMixedAmount styles $ normaliseMixedAmount $ costOfMixedAmount (-a)
@ -613,7 +613,7 @@ tests_Transaction =
]
]
-- postingsAsLines
-- one implicit amount
-- one implicit amount
, let timp = nulltransaction {tpostings = ["a" `post` usd 1, "b" `post` missingamt]}
-- explicit amounts, balanced
texp = nulltransaction {tpostings = ["a" `post` usd 1, "b" `post` usd (-1)]}
@ -659,7 +659,7 @@ tests_Transaction =
, test "one-explicit-amount-elide-true" $
let t = texp1
in postingsAsLines True False t (tpostings t) `is`
[ " (a) $1.00" -- explicit amount remains explicit since only one posting
[ " (a) $1.00" -- explicit amount remains explicit since only one posting
]
, test "explicit-amounts-two-commodities-elide-true" $
let t = texp2

26
hledger-lib/Hledger/Data/TransactionModifier.hs
View File

@ -4,7 +4,7 @@
{-|
A 'TransactionModifier' is a rule that modifies certain 'Transaction's,
typically adding automated postings to them.
typically adding automated postings to them.
-}
module Hledger.Data.TransactionModifier (
@ -41,7 +41,7 @@ modifyTransactions tmods = map applymods
-- | Converts a 'TransactionModifier' to a 'Transaction'-transforming function,
-- which applies the modification(s) specified by the TransactionModifier.
-- Currently this means adding automated postings when certain other postings are present.
-- The postings of the transformed transaction will reference it in the usual
-- The postings of the transformed transaction will reference it in the usual
-- way (ie, 'txnTieKnot' is called).
--
-- >>> putStr $ showTransaction $ transactionModifierToFunction (TransactionModifier "" ["pong" `post` usd 2]) nulltransaction{tpostings=["ping" `post` usd 1]}
@ -60,16 +60,16 @@ modifyTransactions tmods = map applymods
-- <BLANKLINE>
--
transactionModifierToFunction :: TransactionModifier -> (Transaction -> Transaction)
transactionModifierToFunction mt =
transactionModifierToFunction mt =
\t@(tpostings -> ps) -> txnTieKnot t{ tpostings=generatePostings ps } -- TODO add modifier txn comment/tags ?
where
q = simplifyQuery $ tmParseQuery mt (error' "a transaction modifier's query cannot depend on current date")
mods = map tmPostingRuleToFunction $ tmpostingrules mt
generatePostings ps = [p' | p <- ps
, p' <- if q `matchesPosting` p then p:[ m p | m <- mods] else [p]]
-- | Parse the 'Query' from a 'TransactionModifier's 'tmquerytxt',
-- and return it as a function requiring the current date.
-- | Parse the 'Query' from a 'TransactionModifier's 'tmquerytxt',
-- and return it as a function requiring the current date.
--
-- >>> tmParseQuery (TransactionModifier "" []) undefined
-- Any
@ -85,9 +85,9 @@ tmParseQuery mt = fst . flip parseQuery (tmquerytxt mt)
-- | 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").
-- The new posting's amount can optionally be the old posting's amount multiplied by a constant.
-- If the old posting had a total-priced amount, the new posting's multiplied amount will be unit-priced.
-- If the old posting had a total-priced amount, the new posting's multiplied amount will be unit-priced.
tmPostingRuleToFunction :: TMPostingRule -> (Posting -> Posting)
tmPostingRuleToFunction pr =
tmPostingRuleToFunction pr =
\p -> renderPostingCommentDates $ pr
{ pdate = pdate p
, pdate2 = pdate2 p
@ -103,15 +103,15 @@ tmPostingRuleToFunction pr =
matchedamount = dbg6 "matchedamount" $ pamount p
-- Handle a matched amount with a total price carefully so as to keep the transaction balanced (#928).
-- Approach 1: convert to a unit price and increase the display precision slightly
-- Mixed as = dbg6 "multipliedamount" $ n `multiplyMixedAmount` mixedAmountTotalPriceToUnitPrice matchedamount
-- Approach 2: multiply the total price (keeping it positive) as well as the quantity
Mixed as = dbg6 "multipliedamount" $ n `multiplyMixedAmountAndPrice` matchedamount
-- Mixed as = dbg6 "multipliedamount" $ n `multiplyMixedAmount` mixedAmountTotalPriceToUnitPrice matchedamount
-- Approach 2: multiply the total price (keeping it positive) as well as the quantity
Mixed as = dbg6 "multipliedamount" $ n `multiplyMixedAmountAndPrice` matchedamount
in
case acommodity pramount of
"" -> Mixed as
-- TODO multipliers with commodity symbols are not yet a documented feature.
-- For now: in addition to multiplying the quantity, it also replaces the
-- matched amount's commodity, display style, and price with those of the posting rule.
-- For now: in addition to multiplying the quantity, it also replaces the
-- matched amount's commodity, display style, and price with those of the posting rule.
c -> Mixed [a{acommodity = c, astyle = astyle pramount, aprice = aprice pramount} | a <- as]
postingRuleMultiplier :: TMPostingRule -> Maybe Quantity

26
hledger-lib/Hledger/Data/Types.hs
View File

@ -30,7 +30,7 @@ import Data.Functor (($>))
import Data.Graph.Inductive (Gr,Node,NodeMap)
import Data.List (intercalate)
import Text.Blaze (ToMarkup(..))
--XXX https://hackage.haskell.org/package/containers/docs/Data-Map.html
--XXX https://hackage.haskell.org/package/containers/docs/Data-Map.html
--Note: You should use Data.Map.Strict instead of this module if:
--You will eventually need all the values stored.
--The stored values don't represent large virtual data structures to be lazily computed.
@ -158,7 +158,7 @@ instance ToMarkup Quantity
-- | An amount's per-unit or total cost/selling price in another
-- commodity, as recorded in the journal entry eg with @ or @@.
-- Docs call this "transaction price". The amount is always positive.
data AmountPrice = UnitPrice Amount | TotalPrice Amount
data AmountPrice = UnitPrice Amount | TotalPrice Amount
deriving (Eq,Ord,Typeable,Data,Generic,Show)
instance NFData AmountPrice
@ -301,7 +301,7 @@ data Posting = Posting {
-- Tying this knot gets tedious, Maybe makes it easier/optional.
poriginal :: Maybe Posting -- ^ When this posting has been transformed in some way
-- (eg its amount or price was inferred, or the account name was
-- changed by a pivot or budget report), this references the original
-- changed by a pivot or budget report), this references the original
-- untransformed posting (which will have Nothing in this field).
} deriving (Typeable,Data,Generic)
@ -358,10 +358,10 @@ data Transaction = Transaction {
instance NFData Transaction
-- | A transaction modifier rule. This has a query which matches postings
-- in the journal, and a list of transformations to apply to those
-- in the journal, and a list of transformations to apply to those
-- postings or their transactions. Currently there is one kind of transformation:
-- the TMPostingRule, which adds a posting ("auto posting") to the transaction,
-- optionally setting its amount to the matched posting's amount multiplied by a constant.
-- the TMPostingRule, which adds a posting ("auto posting") to the transaction,
-- optionally setting its amount to the matched posting's amount multiplied by a constant.
data TransactionModifier = TransactionModifier {
tmquerytxt :: Text,
tmpostingrules :: [TMPostingRule]
@ -383,8 +383,8 @@ type TMPostingRule = Posting
-- | A periodic transaction rule, describing a transaction that recurs.
data PeriodicTransaction = PeriodicTransaction {
ptperiodexpr :: Text, -- ^ the period expression as written
ptinterval :: Interval, -- ^ the interval at which this transaction recurs
ptspan :: DateSpan, -- ^ the (possibly unbounded) period during which this transaction recurs. Contains a whole number of intervals.
ptinterval :: Interval, -- ^ the interval at which this transaction recurs
ptspan :: DateSpan, -- ^ the (possibly unbounded) period during which this transaction recurs. Contains a whole number of intervals.
--
ptstatus :: Status, -- ^ some of Transaction's fields
ptcode :: Text,
@ -496,8 +496,8 @@ data Journal = Journal {
,jparsetimeclockentries :: [TimeclockEntry] -- ^ timeclock sessions which have not been clocked out
,jincludefilestack :: [FilePath]
-- principal data
,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)
,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)
,jcommodities :: M.Map CommoditySymbol Commodity -- ^ commodities and formats declared by commodity directives
,jinferredcommodities :: M.Map CommoditySymbol AmountStyle -- ^ commodities and formats inferred from journal amounts TODO misnamed - jusedstyles
,jpricedirectives :: [PriceDirective] -- ^ All market price declarations (P directives), in parse order (after journal finalisation).
@ -558,12 +558,12 @@ data Account = Account {
,aibalance :: MixedAmount -- ^ this account's balance, including subaccounts
} deriving (Typeable, Data, Generic)
-- | Whether an account's balance is normally a positive number (in
-- accounting terms, a debit balance) or a negative number (credit balance).
-- | Whether an account's balance is normally a positive number (in
-- accounting terms, a debit balance) or a negative number (credit balance).
-- Assets and expenses are normally positive (debit), while liabilities, equity
-- and income are normally negative (credit).
-- https://en.wikipedia.org/wiki/Normal_balance
data NormalSign = NormallyPositive | NormallyNegative deriving (Show, Data, Eq)
data NormalSign = NormallyPositive | NormallyNegative deriving (Show, Data, Eq)
-- | A Ledger has the journal it derives from, and the accounts
-- derived from that. Accounts are accessible both list-wise and

14
hledger-lib/Hledger/Data/Valuation.hs
View File

@ -46,9 +46,9 @@ tests_Valuation = tests "Valuation" [
------------------------------------------------------------------------------
-- Valuation
-- Apply a specified valuation to this mixed amount, using the provided
-- prices db, commodity styles, period-end/current dates,
-- prices db, commodity styles, period-end/current dates,
-- and whether this is for a multiperiod report or not.
mixedAmountApplyValuation :: [PriceDirective] -> M.Map CommoditySymbol AmountStyle -> Day -> Day -> Bool -> ValuationType -> MixedAmount -> MixedAmount
mixedAmountApplyValuation prices styles periodend today ismultiperiod v (Mixed as) =
@ -63,7 +63,7 @@ mixedAmountValueAtDate :: [PriceDirective] -> M.Map CommoditySymbol AmountStyle
mixedAmountValueAtDate prices styles mc d (Mixed as) = Mixed $ map (amountValueAtDate prices styles mc d) as
-- | Apply a specified valuation to this amount, using the provided
-- prices db, commodity styles, period-end/current dates,
-- prices db, commodity styles, period-end/current dates,
-- and whether this is for a multiperiod report or not.
amountApplyValuation :: [PriceDirective] -> M.Map CommoditySymbol AmountStyle -> Day -> Day -> Bool -> ValuationType -> Amount -> Amount
amountApplyValuation prices styles periodend today ismultiperiod v a =
@ -101,7 +101,7 @@ amountValueAtDate pricedirectives styles mto d a =
------------------------------------------------------------------------------
-- Building a price graph
-- | Convert a list of market price directives in parse order to a
-- graph of all prices in effect on a given day, allowing efficient
-- lookup of exchange rates between commodity pairs.
@ -148,7 +148,7 @@ marketPriceReverse mp@MarketPrice{..} = mp{mpfrom=mpto, mpto=mpfrom, mprate=1/mp
------------------------------------------------------------------------------
-- Market price lookup
tests_priceLookup =
let
d = parsedate
@ -214,7 +214,7 @@ priceLookup pricedirectives d from mto =
where
-- If to is unspecified, try to pick a default valuation commodity from declared prices (only).
-- XXX how to choose ? Take lowest sorted ?
-- Take first, hoping current order is useful ? <-
-- Take first, hoping current order is useful ? <-
-- Keep parse order in label and take latest parsed ?
mdefaultto =
dbg4 ("default valuation commodity for "++T.unpack from) $
@ -257,7 +257,7 @@ node m = fst . fst . mkNode m
pathEdgeLabels :: (Show b, Ord b) => Gr a b -> [Node] -> [b]
pathEdgeLabels g = map frommaybe . map (nodesEdgeLabel g) . pathEdges
where frommaybe = fromMaybe (error' "pathEdgeLabels: expected no Nothings here")
-- | Convert a path to node pairs representing the path's edges.
pathEdges :: [Node] -> [(Node,Node)]
pathEdges p = [(f,t) | f:t:_ <- tails p]

28
hledger-lib/Hledger/Query.hs
View File

@ -654,7 +654,7 @@ matchesPriceDirective _ _ = True
tests_Query = tests "Query" [
tests "simplifyQuery" [
(simplifyQuery $ Or [Acct "a"]) `is` (Acct "a")
,(simplifyQuery $ Or [Any,None]) `is` (Any)
,(simplifyQuery $ And [Any,None]) `is` (None)
@ -665,7 +665,7 @@ tests_Query = tests "Query" [
`is` (Date (DateSpan (Just $ parsedate "2012-01-01") (Just $ parsedate "2013-01-01")))
,(simplifyQuery $ And [Or [],Or [Desc "b b"]]) `is` (Desc "b b")
]
,tests "parseQuery" [
(parseQuery nulldate "acct:'expenses:autres d\233penses' desc:b") `is` (And [Acct "expenses:autres d\233penses", Desc "b"], [])
,parseQuery nulldate "inacct:a desc:\"b b\"" `is` (Desc "b b", [QueryOptInAcct "a"])
@ -674,18 +674,18 @@ tests_Query = tests "Query" [
,parseQuery nulldate "'a a' 'b" `is` (Or [Acct "a a",Acct "'b"], [])
,parseQuery nulldate "\"" `is` (Acct "\"", [])
]
,tests "words''" [
(words'' [] "a b") `is` ["a","b"]
, (words'' [] "'a b'") `is` ["a b"]
, (words'' [] "not:a b") `is` ["not:a","b"]
, (words'' [] "not:'a b'") `is` ["not:a b"]
, (words'' [] "'not:a b'") `is` ["not:a b"]
, (words'' ["desc:"] "not:desc:'a b'") `is` ["not:desc:a b"]
(words'' [] "a b") `is` ["a","b"]
, (words'' [] "'a b'") `is` ["a b"]
, (words'' [] "not:a b") `is` ["not:a","b"]
, (words'' [] "not:'a b'") `is` ["not:a b"]
, (words'' [] "'not:a b'") `is` ["not:a b"]
, (words'' ["desc:"] "not:desc:'a b'") `is` ["not:desc:a b"]
, (words'' prefixes "\"acct:expenses:autres d\233penses\"") `is` ["acct:expenses:autres d\233penses"]
, (words'' prefixes "\"") `is` ["\""]
]
,tests "filterQuery" [
filterQuery queryIsDepth Any `is` Any
,filterQuery queryIsDepth (Depth 1) `is` Depth 1
@ -714,7 +714,7 @@ tests_Query = tests "Query" [
,parseQueryTerm nulldate "amt:<0" `is` (Left $ Amt Lt 0)
,parseQueryTerm nulldate "amt:>10000.10" `is` (Left $ Amt AbsGt 10000.1)
]
,tests "parseAmountQueryTerm" [
parseAmountQueryTerm "<0" `is` (Lt,0) -- special case for convenience, since AbsLt 0 would be always false
,parseAmountQueryTerm ">0" `is` (Gt,0) -- special case for convenience and consistency with above
@ -725,7 +725,7 @@ tests_Query = tests "Query" [
,parseAmountQueryTerm "-0.23" `is` (Eq,(-0.23))
,_test "number beginning with decimal mark" $ parseAmountQueryTerm "=.23" `is` (AbsEq,0.23) -- XXX
]
,tests "matchesAccount" [
expect $ (Acct "b:c") `matchesAccount` "a:bb:c:d"
,expect $ not $ (Acct "^a:b") `matchesAccount` "c:a:b"
@ -736,7 +736,7 @@ tests_Query = tests "Query" [
,expect $ Date2 nulldatespan `matchesAccount` "a"
,expect $ not $ (Tag "a" Nothing) `matchesAccount` "a"
]
,tests "matchesPosting" [
test "positive match on cleared posting status" $
expect $ (StatusQ Cleared) `matchesPosting` nullposting{pstatus=Cleared}
@ -766,7 +766,7 @@ tests_Query = tests "Query" [
,test "l" $ expect $ (Sym "shekels") `matchesPosting` nullposting{pamount=Mixed [nullamt{acommodity="shekels"}]}
,test "m" $ expect $ not $ (Sym "shek") `matchesPosting` nullposting{pamount=Mixed [nullamt{acommodity="shekels"}]}
]
,tests "matchesTransaction" [
expect $ Any `matchesTransaction` nulltransaction
,expect $ not $ (Desc "x x") `matchesTransaction` nulltransaction{tdescription="x"}

12
hledger-lib/Hledger/Read.hs
View File

@ -184,7 +184,7 @@ findReader Nothing (Just path) =
-- Combining Journals means concatenating them, basically.
-- The parse state resets at the start of each file, which means that
-- directives & aliases do not affect subsequent sibling or parent files.
-- They do affect included child files though.
-- They do affect included child files though.
-- Also the final parse state saved in the Journal does span all files.
readJournalFiles :: InputOpts -> [PrefixedFilePath] -> IO (Either String Journal)
readJournalFiles iopts =
@ -207,7 +207,7 @@ readJournalFiles iopts =
-- generation, a rules file for converting CSV data, etc.
readJournalFile :: InputOpts -> PrefixedFilePath -> IO (Either String Journal)
readJournalFile iopts prefixedfile = do
let
let
(mfmt, f) = splitReaderPrefix prefixedfile
iopts' = iopts{mformat_=firstJust [mfmt, mformat_ iopts]}
requireJournalFileExists f
@ -235,13 +235,13 @@ latestDates = headDef [] . take 1 . group . reverse . sort
-- | Remember that these transaction dates were the latest seen when
-- reading this journal file.
saveLatestDates :: LatestDates -> FilePath -> IO ()
saveLatestDates :: LatestDates -> FilePath -> IO ()
saveLatestDates dates f = writeFile (latestDatesFileFor f) $ unlines $ map showDate dates
-- | What were the latest transaction dates seen the last time this
-- | What were the latest transaction dates seen the last time this
-- journal file was read ? If there were multiple transactions on the
-- latest date, that number of dates is returned, otherwise just one.
-- Or none if no transactions were read, or if latest dates info is not
-- Or none if no transactions were read, or if latest dates info is not
-- available for this file.
previousLatestDates :: FilePath -> IO LatestDates
previousLatestDates f = do
@ -299,7 +299,7 @@ readJournal iopts mfile txt =
--
-- Try to parse the given text to a Journal using each reader in turn,
-- returning the first success, or if all of them fail, the first error message.
--
--
-- Input ioptions (@iopts@) specify CSV conversion rules file to help convert CSV data,
-- enable or disable balance assertion checking and automated posting generation.
--

40
hledger-lib/Hledger/Read/Common.hs
View File

@ -163,12 +163,12 @@ data InputOpts = InputOpts {
,mrules_file_ :: Maybe FilePath -- ^ a conversion rules file to use (when reading CSV)
,separator_ :: Char -- ^ the separator to use (when reading CSV)
,aliases_ :: [String] -- ^ account name aliases to apply
,anon_ :: Bool -- ^ do light anonymisation/obfuscation of the data
,anon_ :: Bool -- ^ do light anonymisation/obfuscation of the data
,ignore_assertions_ :: Bool -- ^ don't check balance assertions
,new_ :: Bool -- ^ read only new transactions since this file was last read
,new_save_ :: Bool -- ^ save latest new transactions state for next time
,pivot_ :: String -- ^ use the given field's value as the account name
,auto_ :: Bool -- ^ generate automatic postings when journal is parsed
,pivot_ :: String -- ^ use the given field's value as the account name
,auto_ :: Bool -- ^ generate automatic postings when journal is parsed
} deriving (Show, Data) --, Typeable)
instance Default InputOpts where def = definputopts
@ -188,7 +188,7 @@ rawOptsToInputOpts rawopts = InputOpts{
,new_ = boolopt "new" rawopts
,new_save_ = True
,pivot_ = stringopt "pivot" rawopts
,auto_ = boolopt "auto" rawopts
,auto_ = boolopt "auto" rawopts
}
--- * parsing utilities
@ -219,7 +219,7 @@ rejp = runErroringJournalParser
genericSourcePos :: SourcePos -> GenericSourcePos
genericSourcePos p = GenericSourcePos (sourceName p) (fromIntegral . unPos $ sourceLine p) (fromIntegral . unPos $ sourceColumn p)
-- | Construct a generic start & end line parse position from start and end megaparsec SourcePos's.
-- | Construct a generic start & end line parse position from start and end megaparsec SourcePos's.
journalSourcePos :: SourcePos -> SourcePos -> GenericSourcePos
journalSourcePos p p' = JournalSourcePos (sourceName p) (fromIntegral . unPos $ sourceLine p, fromIntegral $ line')
where line'
@ -355,7 +355,7 @@ getAmountStyle commodity = do
return effectiveStyle
addDeclaredAccountType :: AccountName -> AccountType -> JournalParser m ()
addDeclaredAccountType acct atype =
addDeclaredAccountType acct atype =
modify' (\j -> j{jdeclaredaccounttypes = M.insertWith (++) atype [acct] (jdeclaredaccounttypes j)})
pushParentAccount :: AccountName -> JournalParser m ()
@ -542,7 +542,7 @@ secondarydatep primaryDate = char '=' *> datep' (Just primaryYear)
--- ** account names
-- | Parse an account name (plus one following space if present),
-- | Parse an account name (plus one following space if present),
-- then apply any parent account prefix and/or account aliases currently in effect,
-- in that order. (Ie first add the parent account prefix, then rewrite with aliases).
modifiedaccountnamep :: JournalParser m AccountName
@ -556,9 +556,9 @@ modifiedaccountnamep = do
joinAccountNames parent
a
-- | Parse an account name, plus one following space if present.
-- | Parse an account name, plus one following space if present.
-- Account names have one or more parts separated by the account separator character,
-- and are terminated by two or more spaces (or end of input).
-- and are terminated by two or more spaces (or end of input).
-- Each part is at least one character long, may have single spaces inside it,
-- and starts with a non-whitespace.
-- Note, this means "{account}", "%^!" and ";comment" are all accepted
@ -791,7 +791,7 @@ exponentp = char' 'e' *> signp <*> decimal <?> "exponent"
--
-- Returns:
-- - the decimal number
-- - the precision (number of digits after the decimal point)
-- - the precision (number of digits after the decimal point)
-- - the decimal point character, if any
-- - the digit group style, if any (digit group character and sizes of digit groups)
fromRawNumber
@ -811,7 +811,7 @@ fromRawNumber raw mExp = case raw of
in Right (quantity, precision, mDecPt, Nothing)
WithSeparators digitSep digitGrps mDecimals -> case mExp of
Nothing ->
Nothing ->
let mDecPt = fmap fst mDecimals
decimalGrp = maybe mempty snd mDecimals
digitGroupStyle = DigitGroups digitSep (groupSizes digitGrps)
@ -1038,7 +1038,7 @@ followingcommentp' contentp = do
-- if there's just a next-line comment, insert an empty same-line comment
-- so the next-line comment doesn't get rendered as a same-line comment.
sameLine' | null sameLine && not (null nextLines) = [("",mempty)]
| otherwise = sameLine
| otherwise = sameLine
(texts, contents) = unzip $ sameLine' ++ nextLines
strippedCommentText = T.unlines $ map T.strip texts
commentContent = mconcat contents
@ -1306,32 +1306,32 @@ tests_Common = tests "Common" [
tests "amountp" [
test "basic" $ expectParseEq amountp "$47.18" (usd 47.18)
,test "ends with decimal mark" $ expectParseEq amountp "$1." (usd 1 `withPrecision` 0)
,test "unit price" $ expectParseEq amountp "$10 @ €0.5"
,test "unit price" $ expectParseEq amountp "$10 @ €0.5"
-- not precise enough:
-- (usd 10 `withPrecision` 0 `at` (eur 0.5 `withPrecision` 1)) -- `withStyle` asdecimalpoint=Just '.'
amount{
acommodity="$"
,aquantity=10 -- need to test internal precision with roundTo ? I think not
,aquantity=10 -- need to test internal precision with roundTo ? I think not
,astyle=amountstyle{asprecision=0, asdecimalpoint=Nothing}
,aprice=Just $ UnitPrice $
amount{
acommodity="€"
,aquantity=0.5
,astyle=amountstyle{asprecision=1, asdecimalpoint=Just '.'}
}
}
}
}
,test "total price" $ expectParseEq amountp "$10 @@ €5"
amount{
acommodity="$"
,aquantity=10
,aquantity=10
,astyle=amountstyle{asprecision=0, asdecimalpoint=Nothing}
,aprice=Just $ TotalPrice $
amount{
acommodity="€"
,aquantity=5
,astyle=amountstyle{asprecision=0, asdecimalpoint=Nothing}
}
}
}
}
]
,let p = lift (numberp Nothing) :: JournalParser IO (Quantity, Int, Maybe Char, Maybe DigitGroupStyle) in
@ -1355,7 +1355,7 @@ tests_Common = tests "Common" [
,test "." $ expectParseError p ".1," ""
,test "." $ expectParseError p ",1." ""
]
,tests "spaceandamountormissingp" [
test "space and amount" $ expectParseEq spaceandamountormissingp " $47.18" (Mixed [usd 47.18])
,test "empty string" $ expectParseEq spaceandamountormissingp "" missingmixedamt

58
hledger-lib/Hledger/Read/JournalReader.hs
View File

@ -107,9 +107,9 @@ reader = Reader
parse :: InputOpts -> FilePath -> Text -> ExceptT String IO Journal
parse iopts = parseAndFinaliseJournal journalp' iopts
where
journalp' = do
journalp' = do
-- reverse parsed aliases to ensure that they are applied in order given on commandline
mapM_ addAccountAlias (reverse $ aliasesFromOpts iopts)
mapM_ addAccountAlias (reverse $ aliasesFromOpts iopts)
journalp
-- | Get the account name aliases from options, if any.
@ -267,12 +267,12 @@ accountdirectivep = do
-- 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
skipSome spacenonewline -- at least one more space in addition to the one consumed by modifiedaccountp
skipSome spacenonewline -- 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
-- maybe Ledger-style subdirectives (ignored)
skipMany indentedlinep
@ -386,7 +386,7 @@ formatdirectivep expectedsym = do
Amount{acommodity,astyle} <- amountp
_ <- lift followingcommentp
if acommodity==expectedsym
then
then
if asdecimalpoint astyle == Nothing
then customFailure $ parseErrorAt off pleaseincludedecimalpoint
else return $ dbg2 "style from format subdirective" astyle
@ -532,7 +532,7 @@ transactionmodifierp = do
-- | Parse a periodic transaction
--
-- This reuses periodexprp which parses period expressions on the command line.
-- This is awkward because periodexprp supports relative and partial dates,
-- This is awkward because periodexprp supports relative and partial dates,
-- which we don't really need here, and it doesn't support the notion of a
-- default year set by a Y directive, which we do need to consider here.
-- We resolve it as follows: in periodic transactions' period expressions,
@ -546,12 +546,12 @@ periodictransactionp = do
lift $ skipMany spacenonewline
-- a period expression
off <- getOffset
-- if there's a default year in effect, use Y/1/1 as base for partial/relative dates
today <- liftIO getCurrentDay
mdefaultyear <- getYear
let refdate = case mdefaultyear of
Nothing -> today
Nothing -> today
Just y -> fromGregorian y 1 1
periodExcerpt <- lift $ excerpt_ $
singlespacedtextsatisfyingp (\c -> c /= ';' && c /= '\n')
@ -576,7 +576,7 @@ periodictransactionp = do
case checkPeriodicTransactionStartDate interval span periodtxt of
Just e -> customFailure $ parseErrorAt off e
Nothing -> pure ()
status <- lift statusp <?> "cleared status"
code <- lift codep <?> "transaction code"
description <- lift $ T.strip <$> descriptionp
@ -678,7 +678,7 @@ tests_JournalReader = tests "JournalReader" [
test "YYYY-MM-DD" $ expectParse datep "2018-01-01"
test "YYYY.MM.DD" $ expectParse datep "2018.01.01"
test "yearless date with no default year" $ expectParseError datep "1/1" "current year is unknown"
test "yearless date with default year" $ do
test "yearless date with default year" $ do
let s = "1/1"
ep <- parseWithState mempty{jparsedefaultyear=Just 2018} datep s
either (fail.("parse error at "++).customErrorBundlePretty) (const ok) ep
@ -703,7 +703,7 @@ tests_JournalReader = tests "JournalReader" [
,tests "periodictransactionp" [
test "more period text in comment after one space" $ expectParseEq periodictransactionp
"~ monthly from 2018/6 ;In 2019 we will change this\n"
"~ monthly from 2018/6 ;In 2019 we will change this\n"
nullperiodictransaction {
ptperiodexpr = "monthly from 2018/6"
,ptinterval = Months 1
@ -713,7 +713,7 @@ tests_JournalReader = tests "JournalReader" [
}
,test "more period text in description after two spaces" $ expectParseEq periodictransactionp
"~ monthly from 2018/6 In 2019 we will change this\n"
"~ monthly from 2018/6 In 2019 we will change this\n"
nullperiodictransaction {
ptperiodexpr = "monthly from 2018/6"
,ptinterval = Months 1
@ -748,16 +748,16 @@ tests_JournalReader = tests "JournalReader" [
]
,tests "postingp" [
test "basic" $ expectParseEq (postingp Nothing)
test "basic" $ expectParseEq (postingp Nothing)
" expenses:food:dining $10.00 ; a: a a \n ; b: b b \n"
posting{
paccount="expenses:food:dining",
pamount=Mixed [usd 10],
pcomment="a: a a\nb: b b\n",
paccount="expenses:food:dining",
pamount=Mixed [usd 10],
pcomment="a: a a\nb: b b\n",
ptags=[("a","a a"), ("b","b b")]
}
,test "posting dates" $ expectParseEq (postingp Nothing)
,test "posting dates" $ expectParseEq (postingp Nothing)
" a 1. ; date:2012/11/28, date2=2012/11/29,b:b\n"
nullposting{
paccount="a"
@ -768,14 +768,14 @@ tests_JournalReader = tests "JournalReader" [
,pdate2=Nothing -- Just $ fromGregorian 2012 11 29
}
,test "posting dates bracket syntax" $ expectParseEq (postingp Nothing)
,test "posting dates bracket syntax" $ expectParseEq (postingp Nothing)
" a 1. ; [2012/11/28=2012/11/29]\n"
nullposting{
paccount="a"
,pamount=Mixed [num 1]
,pcomment="[2012/11/28=2012/11/29]\n"
,ptags=[]
,pdate= Just $ fromGregorian 2012 11 28
,pdate= Just $ fromGregorian 2012 11 28
,pdate2=Just $ fromGregorian 2012 11 29
}
@ -788,7 +788,7 @@ tests_JournalReader = tests "JournalReader" [
,tests "transactionmodifierp" [
test "basic" $ expectParseEq transactionmodifierp
test "basic" $ expectParseEq transactionmodifierp
"= (some value expr)\n some:postings 1.\n"
nulltransactionmodifier {
tmquerytxt = "(some value expr)"
@ -797,10 +797,10 @@ tests_JournalReader = tests "JournalReader" [
]
,tests "transactionp" [
test "just a date" $ expectParseEq transactionp "2015/1/1\n" nulltransaction{tdate=fromGregorian 2015 1 1}
,test "more complex" $ expectParseEq transactionp
,test "more complex" $ expectParseEq transactionp
(T.unlines [
"2012/05/14=2012/05/15 (code) desc ; tcomment1",
" ; tcomment2",
@ -833,7 +833,7 @@ tests_JournalReader = tests "JournalReader" [
}
]
}
,test "parses a well-formed transaction" $
expect $ isRight $ rjp transactionp $ T.unlines
["2007/01/28 coopportunity"
@ -841,10 +841,10 @@ tests_JournalReader = tests "JournalReader" [
," assets:checking $-47.18"
,""
]
,test "does not parse a following comment as part of the description" $
expectParseEqOn transactionp "2009/1/1 a ;comment\n b 1\n" tdescription "a"
,test "transactionp parses a following whitespace line" $
expect $ isRight $ rjp transactionp $ T.unlines
["2012/1/1"
@ -863,7 +863,7 @@ tests_JournalReader = tests "JournalReader" [
]
,test "comments everywhere, two postings parsed" $
expectParseEqOn transactionp
expectParseEqOn transactionp
(T.unlines
["2009/1/1 x ; transaction comment"
," a 1 ; posting 1 comment"
@ -873,13 +873,13 @@ tests_JournalReader = tests "JournalReader" [
])
(length . tpostings)
2
]
-- directives
,tests "directivep" [
test "supports !" $ do
test "supports !" $ do
expectParseE directivep "!account a\n"
expectParseE directivep "!D 1.0\n"
]

2
hledger-lib/Hledger/Read/TimeclockReader.hs
View File

@ -96,7 +96,7 @@ timeclockfilep = do many timeclockitemp
-- As all ledger line types can be distinguished by the first
-- character, excepting transactions versus empty (blank or
-- comment-only) lines, can use choice w/o try
timeclockitemp = choice [
timeclockitemp = choice [
void (lift emptyorcommentlinep)
, timeclockentryp >>= \e -> modify' (\j -> j{jparsetimeclockentries = e : jparsetimeclockentries j})
] <?> "timeclock entry, or default year or historical price directive"

6
hledger-lib/Hledger/Read/TimedotReader.hs
View File

@ -142,16 +142,16 @@ timedotnumericp = do
(q, _, _, _) <- lift $ numberp Nothing
msymbol <- optional $ choice $ map (string . fst) timeUnits
lift (skipMany spacenonewline)
let q' =
let q' =
case msymbol of
Nothing -> q
Just sym ->
case lookup sym timeUnits of
Just mult -> q * mult
Just mult -> q * mult
Nothing -> q -- shouldn't happen.. ignore
return q'
-- (symbol, equivalent in hours).
-- (symbol, equivalent in hours).
timeUnits =
[("s",2.777777777777778e-4)
,("mo",5040) -- before "m"

66
hledger-lib/Hledger/Reports/BalanceReport.hs
View File

@ -11,7 +11,7 @@ module Hledger.Reports.BalanceReport (
BalanceReportItem,
balanceReport,
flatShowsExclusiveBalance,
sortAccountItemsLike,
sortAccountItemsLike,
-- * Tests
tests_BalanceReport
@ -26,7 +26,7 @@ import Data.Time.Calendar
import Hledger.Data
import Hledger.Read (mamountp')
import Hledger.Query
import Hledger.Utils
import Hledger.Utils
import Hledger.Reports.ReportOptions
@ -64,8 +64,8 @@ flatShowsExclusiveBalance = True
-- This is like PeriodChangeReport with a single column (but more mature,
-- eg this can do hierarchical display).
balanceReport :: ReportOpts -> Query -> Journal -> BalanceReport
balanceReport ropts@ReportOpts{..} q j@Journal{..} =
(if invert_ then brNegate else id) $
balanceReport ropts@ReportOpts{..} q j@Journal{..} =
(if invert_ then brNegate else id) $
(sorteditems, total)
where
-- dbg1 = const id -- exclude from debug output
@ -117,24 +117,24 @@ balanceReport ropts@ReportOpts{..} q j@Journal{..} =
items = dbg1 "items" $ map (balanceReportItem ropts q) displayaccts
-- Sort report rows (except sorting by amount in tree mode, which was done above).
sorteditems
sorteditems
| sort_amount_ && tree_ ropts = items
| sort_amount_ = sortFlatBRByAmount items
| otherwise = sortBRByAccountDeclaration items
where
-- Sort the report rows, representing a flat account list, by row total.
where
-- Sort the report rows, representing a flat account list, by row total.
sortFlatBRByAmount :: [BalanceReportItem] -> [BalanceReportItem]
sortFlatBRByAmount = sortBy (maybeflip $ comparing (normaliseMixedAmountSquashPricesForDisplay . fourth4))
where
maybeflip = if normalbalance_ == Just NormallyNegative then id else flip
-- Sort the report rows by account declaration order then account name.
-- Sort the report rows by account declaration order then account name.
sortBRByAccountDeclaration :: [BalanceReportItem] -> [BalanceReportItem]
sortBRByAccountDeclaration rows = sortedrows
where
where
anamesandrows = [(first4 r, r) | r <- rows]
anames = map fst anamesandrows
sortedanames = sortAccountNamesByDeclaration j (tree_ ropts) anames
sortedrows = sortAccountItemsLike sortedanames anamesandrows
sortedrows = sortAccountItemsLike sortedanames anamesandrows
-- Calculate the grand total.
total | not (flat_ ropts) = dbg1 "total" $ sum [amt | (_,_,indent,amt) <- items, indent == 0]
@ -145,7 +145,7 @@ balanceReport ropts@ReportOpts{..} q j@Journal{..} =
-- | A sorting helper: sort a list of things (eg report rows) keyed by account name
-- to match the provided ordering of those same account names.
sortAccountItemsLike :: [AccountName] -> [(AccountName, b)] -> [b]
sortAccountItemsLike :: [AccountName] -> [(AccountName, b)] -> [b]
sortAccountItemsLike sortedas items =
concatMap (\a -> maybe [] (:[]) $ lookup a items) sortedas
@ -181,7 +181,7 @@ balanceReportItem opts q a
-- | Flip the sign of all amounts in a BalanceReport.
brNegate :: BalanceReport -> BalanceReport
brNegate (is, tot) = (map brItemNegate is, -tot)
brNegate (is, tot) = (map brItemNegate is, -tot)
where
brItemNegate (a, a', d, amt) = (a, a', d, -amt)
@ -222,10 +222,10 @@ tests_BalanceReport = tests "BalanceReport" [
(showMixedAmountDebug etotal) `is` (showMixedAmountDebug atotal)
usd0 = usd 0
in [
test "balanceReport with no args on null journal" $
(defreportopts, nulljournal) `gives` ([], Mixed [nullamt])
,test "balanceReport with no args on sample journal" $
(defreportopts, samplejournal) `gives`
([
@ -242,7 +242,7 @@ tests_BalanceReport = tests "BalanceReport" [
,("income:salary","salary",1, mamountp' "$-1.00")
],
Mixed [usd0])
,test "balanceReport with --depth=N" $
(defreportopts{depth_=Just 1}, samplejournal) `gives`
([
@ -250,7 +250,7 @@ tests_BalanceReport = tests "BalanceReport" [
,("income", "income", 0, mamountp' "$-2.00")
],
Mixed [usd0])
,test "balanceReport with depth:N" $
(defreportopts{query_="depth:1"}, samplejournal) `gives`
([
@ -258,7 +258,7 @@ tests_BalanceReport = tests "BalanceReport" [
,("income", "income", 0, mamountp' "$-2.00")
],
Mixed [usd0])
,tests "balanceReport with a date or secondary date span" [
(defreportopts{query_="date:'in 2009'"}, samplejournal2) `gives`
([],
@ -278,7 +278,7 @@ tests_BalanceReport = tests "BalanceReport" [
,("income:salary","income:salary",0, mamountp' "$-1.00")
],
Mixed [usd0])
,test "balanceReport with not:desc:" $
(defreportopts{query_="not:desc:income"}, samplejournal) `gives`
([
@ -291,7 +291,7 @@ tests_BalanceReport = tests "BalanceReport" [
,("income:gifts","income:gifts",0, mamountp' "$-1.00")
],
Mixed [usd0])
,test "balanceReport with period on a populated period" $
(defreportopts{period_= PeriodBetween (fromGregorian 2008 1 1) (fromGregorian 2008 1 2)}, samplejournal) `gives`
(
@ -300,13 +300,13 @@ tests_BalanceReport = tests "BalanceReport" [
,("income:salary","income:salary",0, mamountp' "$-1.00")
],
Mixed [usd0])
,test "balanceReport with period on an unpopulated period" $
(defreportopts{period_= PeriodBetween (fromGregorian 2008 1 2) (fromGregorian 2008 1 3)}, samplejournal) `gives`
([],Mixed [nullamt])
{-
,test "accounts report with account pattern o" ~:
defreportopts{patterns_=["o"]} `gives`
@ -317,7 +317,7 @@ tests_BalanceReport = tests "BalanceReport" [
,"--------------------"
," $-1"
]
,test "accounts report with account pattern o and --depth 1" ~:
defreportopts{patterns_=["o"],depth_=Just 1} `gives`
[" $1 expenses"
@ -325,7 +325,7 @@ tests_BalanceReport = tests "BalanceReport" [
,"--------------------"
," $-1"
]
,test "accounts report with account pattern a" ~:
defreportopts{patterns_=["a"]} `gives`
[" $-1 assets"
@ -336,7 +336,7 @@ tests_BalanceReport = tests "BalanceReport" [
,"--------------------"
," $-1"
]
,test "accounts report with account pattern e" ~:
defreportopts{patterns_=["e"]} `gives`
[" $-1 assets"
@ -352,7 +352,7 @@ tests_BalanceReport = tests "BalanceReport" [
,"--------------------"
," 0"
]
,test "accounts report with unmatched parent of two matched subaccounts" ~:
defreportopts{patterns_=["cash","saving"]} `gives`
[" $-1 assets"
@ -361,14 +361,14 @@ tests_BalanceReport = tests "BalanceReport" [
,"--------------------"
," $-1"
]
,test "accounts report with multi-part account name" ~:
defreportopts{patterns_=["expenses:food"]} `gives`
[" $1 expenses:food"
,"--------------------"
," $1"
]
,test "accounts report with negative account pattern" ~:
defreportopts{patterns_=["not:assets"]} `gives`
[" $2 expenses"
@ -381,20 +381,20 @@ tests_BalanceReport = tests "BalanceReport" [
,"--------------------"
," $1"
]
,test "accounts report negative account pattern always matches full name" ~:
defreportopts{patterns_=["not:e"]} `gives`
["--------------------"
," 0"
]
,test "accounts report negative patterns affect totals" ~:
defreportopts{patterns_=["expenses","not:food"]} `gives`
[" $1 expenses:supplies"
,"--------------------"
," $1"
]
,test "accounts report with -E shows zero-balance accounts" ~:
defreportopts{patterns_=["assets"],empty_=True} `gives`
[" $-1 assets"
@ -405,7 +405,7 @@ tests_BalanceReport = tests "BalanceReport" [
,"--------------------"
," $-1"
]
,test "accounts report with cost basis" $
j <- (readJournal def Nothing $ unlines
[""

54
hledger-lib/Hledger/Reports/BudgetReport.hs
View File

@ -72,14 +72,14 @@ budgetReport ropts' assrt reportspan d j =
-- and that reports with and without --empty make sense when compared side by side
ropts = ropts' { accountlistmode_ = ALTree }
showunbudgeted = empty_ ropts
q = queryFromOpts d ropts
budgetedaccts =
q = queryFromOpts d ropts
budgetedaccts =
dbg2 "budgetedacctsinperiod" $
nub $
nub $
concatMap expandAccountName $
accountNamesFromPostings $
concatMap tpostings $
concatMap (flip runPeriodicTransaction reportspan) $
accountNamesFromPostings $
concatMap tpostings $
concatMap (flip runPeriodicTransaction reportspan) $
jperiodictxns j
actualj = dbg1 "actualj" $ budgetRollUp budgetedaccts showunbudgeted j
budgetj = dbg1 "budgetj" $ budgetJournal assrt ropts reportspan j
@ -87,10 +87,10 @@ budgetReport ropts' assrt reportspan d j =
budgetgoalreport@(MultiBalanceReport (_, budgetgoalitems, budgetgoaltotals)) = dbg1 "budgetgoalreport" $ multiBalanceReport (ropts{empty_=True}) q budgetj
budgetgoalreport'
-- If no interval is specified:
-- budgetgoalreport's span might be shorter actualreport's due to periodic txns;
-- it should be safe to replace it with the latter, so they combine well.
-- budgetgoalreport's span might be shorter actualreport's due to periodic txns;
-- it should be safe to replace it with the latter, so they combine well.
| interval_ ropts == NoInterval = MultiBalanceReport (actualspans, budgetgoalitems, budgetgoaltotals)
| otherwise = budgetgoalreport
| otherwise = budgetgoalreport
budgetreport = combineBudgetAndActual budgetgoalreport' actualreport
sortedbudgetreport = sortBudgetReport ropts j budgetreport
in
@ -100,13 +100,13 @@ budgetReport ropts' assrt reportspan d j =
sortBudgetReport :: ReportOpts -> Journal -> BudgetReport -> BudgetReport
sortBudgetReport ropts j (PeriodicReport (ps, rows, trow)) = PeriodicReport (ps, sortedrows, trow)
where
sortedrows
sortedrows
| sort_amount_ ropts && tree_ ropts = sortTreeBURByActualAmount rows
| sort_amount_ ropts = sortFlatBURByActualAmount rows
| otherwise = sortByAccountDeclaration rows
-- Sort a tree-mode budget report's rows by total actual amount at each level.
sortTreeBURByActualAmount :: [BudgetReportRow] -> [BudgetReportRow]
sortTreeBURByActualAmount :: [BudgetReportRow] -> [BudgetReportRow]
sortTreeBURByActualAmount rows = sortedrows
where
anamesandrows = [(first6 r, r) | r <- rows]
@ -116,21 +116,21 @@ sortBudgetReport ropts j (PeriodicReport (ps, rows, trow)) = PeriodicReport (ps,
accounttreewithbals = mapAccounts setibalance accounttree
where
setibalance a = a{aibalance=
fromMaybe 0 $ -- when there's no actual amount, assume 0; will mess up with negative amounts ? TODO
fromMaybe (error "sortTreeByAmount 1") $ -- should not happen, but it's ugly; TODO
fromMaybe 0 $ -- when there's no actual amount, assume 0; will mess up with negative amounts ? TODO
fromMaybe (error "sortTreeByAmount 1") $ -- should not happen, but it's ugly; TODO
lookup (aname a) atotals
}
sortedaccounttree = sortAccountTreeByAmount (fromMaybe NormallyPositive $ normalbalance_ ropts) accounttreewithbals
sortedanames = map aname $ drop 1 $ flattenAccounts sortedaccounttree
sortedrows = sortAccountItemsLike sortedanames anamesandrows
sortedrows = sortAccountItemsLike sortedanames anamesandrows
-- Sort a flat-mode budget report's rows by total actual amount.
sortFlatBURByActualAmount :: [BudgetReportRow] -> [BudgetReportRow]
sortFlatBURByActualAmount :: [BudgetReportRow] -> [BudgetReportRow]
sortFlatBURByActualAmount = sortBy (maybeflip $ comparing (fst . fifth6))
where
maybeflip = if normalbalance_ ropts == Just NormallyNegative then id else flip
-- Sort the report rows by account declaration order then account name.
-- Sort the report rows by account declaration order then account name.
-- <unbudgeted> remains at the top.
sortByAccountDeclaration rows = sortedrows
where
@ -138,9 +138,9 @@ sortBudgetReport ropts j (PeriodicReport (ps, rows, trow)) = PeriodicReport (ps,
anamesandrows = [(first6 r, r) | r <- rows']
anames = map fst anamesandrows
sortedanames = sortAccountNamesByDeclaration j (tree_ ropts) anames
sortedrows = unbudgetedrow ++ sortAccountItemsLike sortedanames anamesandrows
sortedrows = unbudgetedrow ++ sortAccountItemsLike sortedanames anamesandrows
-- | Use all periodic transactions in the journal to generate
-- | Use all periodic transactions in the journal to generate
-- budget transactions in the specified report period.
-- Budget transactions are similar to forecast transactions except
-- their purpose is to set goal amounts (of change) per account and period.
@ -159,11 +159,11 @@ budgetJournal assrt _ropts reportspan j =
-- | Adjust a journal's account names for budget reporting, in two ways:
--
-- 1. accounts with no budget goal anywhere in their ancestry are moved
-- 1. accounts with no budget goal anywhere in their ancestry are moved
-- under the "unbudgeted" top level account.
--
-- 2. subaccounts with no budget goal are merged with their closest parent account
-- with a budget goal, so that only budgeted accounts are shown.
-- with a budget goal, so that only budgeted accounts are shown.
-- This can be disabled by --empty.
--
budgetRollUp :: [AccountName] -> Bool -> Journal -> Journal
@ -176,7 +176,7 @@ budgetRollUp budgetedaccts showunbudgeted j = j { jtxns = remapTxn <$> jtxns j }
where
remapAccount a
| hasbudget = a
| hasbudgetedparent = if showunbudgeted then a else budgetedparent
| hasbudgetedparent = if showunbudgeted then a else budgetedparent
| otherwise = if showunbudgeted then u <> acctsep <> a else u
where
hasbudget = a `elem` budgetedaccts
@ -270,7 +270,7 @@ budgetReportSpan (PeriodicReport (spans, _, _)) = DateSpan (spanStart $ head spa
-- | Render a budget report as plain text suitable for console output.
budgetReportAsText :: ReportOpts -> BudgetReport -> String
budgetReportAsText ropts@ReportOpts{..} budgetr@(PeriodicReport ( _, rows, _)) =
title ++ "\n\n" ++
title ++ "\n\n" ++
tableAsText ropts showcell (maybetranspose $ budgetReportAsTable ropts budgetr)
where
multiperiod = interval_ /= NoInterval
@ -319,7 +319,7 @@ budgetReportAsText ropts@ReportOpts{..} budgetr@(PeriodicReport ( _, rows, _)) =
percentage :: Change -> BudgetGoal -> Maybe Percentage
percentage actual budget =
case (maybecost $ normaliseMixedAmount actual, maybecost $ normaliseMixedAmount budget) of
(Mixed [a], Mixed [b]) | (acommodity a == acommodity b || isZeroAmount a) && not (isZeroAmount b)
(Mixed [a], Mixed [b]) | (acommodity a == acommodity b || isZeroAmount a) && not (isZeroAmount b)
-> Just $ 100 * aquantity a / aquantity b
_ -> -- trace (pshow $ (maybecost actual, maybecost budget)) -- debug missing percentage
Nothing
@ -337,14 +337,14 @@ budgetReportAsText ropts@ReportOpts{..} budgetr@(PeriodicReport ( _, rows, _)) =
-- | Build a 'Table' from a multi-column balance report.
budgetReportAsTable :: ReportOpts -> BudgetReport -> Table String String (Maybe MixedAmount, Maybe MixedAmount)
budgetReportAsTable
ropts
budgetReportAsTable
ropts
(PeriodicReport
( periods
, rows
, (_, _, _, coltots, grandtot, grandavg)
)) =
addtotalrow $
addtotalrow $
Table
(T.Group NoLine $ map Header accts)
(T.Group NoLine $ map Header colheadings)
@ -368,7 +368,7 @@ budgetReportAsTable
))
-- XXX here for now
-- TODO: does not work for flat-by-default reports with --flat not specified explicitly
-- TODO: does not work for flat-by-default reports with --flat not specified explicitly
-- | Drop leading components of accounts names as specified by --drop, but only in --flat mode.
maybeAccountNameDrop :: ReportOpts -> AccountName -> AccountName
maybeAccountNameDrop opts a | flat_ opts = accountNameDrop (drop_ opts) a

2
hledger-lib/Hledger/Reports/EntriesReport.hs
View File

@ -23,7 +23,7 @@ import Data.Time.Calendar (Day, addDays)
import Hledger.Data
import Hledger.Query
import Hledger.Reports.ReportOptions
import Hledger.Utils
import Hledger.Utils
-- | A journal entries report is a list of whole transactions as

48
hledger-lib/Hledger/Reports/MultiBalanceReport.hs
View File

@ -30,7 +30,7 @@ import Text.Tabular.AsciiWide
import Hledger.Data
import Hledger.Query
import Hledger.Utils
import Hledger.Utils
import Hledger.Read (mamountp')
import Hledger.Reports.ReportOptions
import Hledger.Reports.BalanceReport
@ -85,13 +85,13 @@ type ClippedAccountName = AccountName
-- | Generate a multicolumn balance report for the matched accounts,
-- showing the change of balance, accumulated balance, or historical balance
-- in each of the specified periods. Does not support tree-mode boring parent eliding.
-- If the normalbalance_ option is set, it adjusts the sorting and sign of amounts
-- If the normalbalance_ option is set, it adjusts the sorting and sign of amounts
-- (see ReportOpts and CompoundBalanceCommand).
-- hledger's most powerful and useful report, used by the balance
-- command (in multiperiod mode) and by the bs/cf/is commands.
multiBalanceReport :: ReportOpts -> Query -> Journal -> MultiBalanceReport
multiBalanceReport ropts@ReportOpts{..} q j@Journal{..} =
(if invert_ then mbrNegate else id) $
(if invert_ then mbrNegate else id) $
MultiBalanceReport (colspans, sortedrows, totalsrow)
where
dbg1 s = let p = "multiBalanceReport" in Hledger.Utils.dbg1 (p++" "++s) -- add prefix in this function's debug output
@ -115,18 +115,18 @@ multiBalanceReport ropts@ReportOpts{..} q j@Journal{..} =
-- This list can be empty if the journal was empty,
-- or if hledger-ui has added its special date:-tomorrow to the query
-- and all txns are in the future.
intervalspans = dbg1 "intervalspans" $ splitSpan interval_ requestedspan'
intervalspans = dbg1 "intervalspans" $ splitSpan interval_ requestedspan'
-- The requested span enlarged to enclose a whole number of intervals.
-- This can be the null span if there were no intervals.
-- This can be the null span if there were no intervals.
reportspan = dbg1 "reportspan" $ DateSpan (maybe Nothing spanStart $ headMay intervalspans)
(maybe Nothing spanEnd $ lastMay intervalspans)
mreportstart = spanStart reportspan
-- The user's query with no depth limit, and expanded to the report span
-- if there is one (otherwise any date queries are left as-is, which
-- handles the hledger-ui+future txns case above).
reportq = dbg1 "reportq" $ depthless $
if reportspan == nulldatespan
then q
reportq = dbg1 "reportq" $ depthless $
if reportspan == nulldatespan
then q
else And [datelessq, reportspandatesq]
where
reportspandatesq = dbg1 "reportspandatesq" $ dateqcons reportspan
@ -157,12 +157,12 @@ multiBalanceReport ropts@ReportOpts{..} q j@Journal{..} =
precedingperiod = dateSpanAsPeriod $ spanIntersect (DateSpan Nothing mreportstart) $ periodAsDateSpan period_
-- q projected back before the report start date.
-- When there's no report start date, in case there are future txns (the hledger-ui case above),
-- we use emptydatespan to make sure they aren't counted as starting balance.
-- we use emptydatespan to make sure they aren't counted as starting balance.
startbalq = dbg1 "startbalq" $ And [datelessq, dateqcons precedingspan]
where
precedingspan = case mreportstart of
Just d -> DateSpan Nothing (Just d)
Nothing -> emptydatespan
Nothing -> emptydatespan
-- 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.
startaccts = dbg1 "startaccts" $ map fst startbals
@ -282,7 +282,7 @@ multiBalanceReport ropts@ReportOpts{..} q j@Journal{..} =
(error' "multiBalanceReport: expected all spans to have an end date") -- XXX should not happen
(addDays (-1)))
. spanEnd) colspans
----------------------------------------------------------------------
-- 7. Sort the report rows.
@ -307,24 +307,24 @@ multiBalanceReport ropts@ReportOpts{..} q j@Journal{..} =
accounttree = accountTree "root" anames
accounttreewithbals = mapAccounts setibalance accounttree
where
-- should not happen, but it's dangerous; TODO
-- should not happen, but it's dangerous; TODO
setibalance a = a{aibalance=fromMaybe (error "sortTreeMBRByAmount 1") $ lookup (aname a) atotals}
sortedaccounttree = sortAccountTreeByAmount (fromMaybe NormallyPositive normalbalance_) accounttreewithbals
sortedanames = map aname $ drop 1 $ flattenAccounts sortedaccounttree
sortedrows = sortAccountItemsLike sortedanames anamesandrows
sortedrows = sortAccountItemsLike sortedanames anamesandrows
-- Sort the report rows, representing a flat account list, by row total.
-- Sort the report rows, representing a flat account list, by row total.
sortFlatMBRByAmount = sortBy (maybeflip $ comparing (normaliseMixedAmountSquashPricesForDisplay . fifth6))
where
maybeflip = if normalbalance_ == Just NormallyNegative then id else flip
-- Sort the report rows by account declaration order then account name.
-- Sort the report rows by account declaration order then account name.
sortMBRByAccountDeclaration rows = sortedrows
where
where
anamesandrows = [(first6 r, r) | r <- rows]
anames = map fst anamesandrows
sortedanames = sortAccountNamesByDeclaration j (tree_ ropts) anames
sortedrows = sortAccountItemsLike sortedanames anamesandrows
sortedrows = sortAccountItemsLike sortedanames anamesandrows
----------------------------------------------------------------------
-- 8. Build the report totals row.
@ -364,9 +364,9 @@ multiBalanceReportSpan :: MultiBalanceReport -> DateSpan
multiBalanceReportSpan (MultiBalanceReport ([], _, _)) = DateSpan Nothing Nothing
multiBalanceReportSpan (MultiBalanceReport (colspans, _, _)) = DateSpan (spanStart $ head colspans) (spanEnd $ last colspans)
-- | Generates a simple non-columnar BalanceReport, but using multiBalanceReport,
-- in order to support --historical. Does not support tree-mode boring parent eliding.
-- If the normalbalance_ option is set, it adjusts the sorting and sign of amounts
-- | Generates a simple non-columnar BalanceReport, but using multiBalanceReport,
-- in order to support --historical. Does not support tree-mode boring parent eliding.
-- If the normalbalance_ option is set, it adjusts the sorting and sign of amounts
-- (see ReportOpts and CompoundBalanceCommand).
balanceReportFromMultiBalanceReport :: ReportOpts -> Query -> Journal -> BalanceReport
balanceReportFromMultiBalanceReport opts q j = (rows', total)
@ -408,11 +408,11 @@ tests_MultiBalanceReport = tests "MultiBalanceReport" [
((\(_, b, _) -> showMixedAmountDebug b) atotal) `is` (showMixedAmountDebug etotal) -- we only check the sum of the totals
usd0 = usd 0
amount0 = Amount {acommodity="$", aquantity=0, aprice=Nothing, astyle=AmountStyle {ascommodityside = L, ascommodityspaced = False, asprecision = 2, asdecimalpoint = Just '.', asdigitgroups = Nothing}, aismultiplier=False}
in
in
tests "multiBalanceReport" [
test "null journal" $
(defreportopts, nulljournal) `gives` ([], Mixed [nullamt])
,test "with -H on a populated period" $
(defreportopts{period_= PeriodBetween (fromGregorian 2008 1 1) (fromGregorian 2008 1 2), balancetype_=HistoricalBalance}, samplejournal) `gives`
(
@ -421,7 +421,7 @@ tests_MultiBalanceReport = tests "MultiBalanceReport" [
,("income:salary" ,"salary" , 2, [mamountp' "$-1.00"], Mixed [nullamt], Mixed [amount0 {aquantity=(-1)}])
],
Mixed [nullamt])
,_test "a valid history on an empty period" $
(defreportopts{period_= PeriodBetween (fromGregorian 2008 1 2) (fromGregorian 2008 1 3), balancetype_=HistoricalBalance}, samplejournal) `gives`
(
@ -430,7 +430,7 @@ tests_MultiBalanceReport = tests "MultiBalanceReport" [
,("income:salary","salary",2, [mamountp' "$-1.00"], mamountp' "$-1.00",Mixed [amount0 {aquantity=(-1)}])
],
Mixed [usd0])
,_test "a valid history on an empty period (more complex)" $
(defreportopts{period_= PeriodBetween (fromGregorian 2009 1 1) (fromGregorian 2009 1 2), balancetype_=HistoricalBalance}, samplejournal) `gives`
(

34
hledger-lib/Hledger/Reports/PostingsReport.hs
View File

@ -32,7 +32,7 @@ import Safe (headMay, lastMay)
import Hledger.Data
import Hledger.Query
import Hledger.Utils
import Hledger.Utils
import Hledger.Reports.ReportOptions
@ -103,7 +103,7 @@ postingsReport ropts@ReportOpts{..} q j@Journal{..} =
-- Postings, or summary postings with their subperiod's end date, to be displayed.
displayps :: [(Posting, Maybe Day)]
| multiperiod =
| multiperiod =
let summaryps = summarisePostingsByInterval interval_ whichdate depth showempty reportspan reportps
in [(pvalue p lastday, Just periodend) | (p, periodend) <- summaryps, let lastday = addDays (-1) periodend]
| otherwise =
@ -286,13 +286,13 @@ tests_PostingsReport = tests "PostingsReport" [
,(Depth 2, samplejournal) `gives` 13
,(And [Depth 1, StatusQ Cleared, Acct "expenses"], samplejournal) `gives` 2
,(And [And [Depth 1, StatusQ Cleared], Acct "expenses"], samplejournal) `gives` 2
-- with query and/or command-line options
,(length $ snd $ postingsReport defreportopts Any samplejournal) `is` 13
,(length $ snd $ postingsReport defreportopts{interval_=Months 1} Any samplejournal) `is` 11
,(length $ snd $ postingsReport defreportopts{interval_=Months 1, empty_=True} Any samplejournal) `is` 20
,(length $ snd $ postingsReport defreportopts (Acct "assets:bank:checking") samplejournal) `is` 5
-- (defreportopts, And [Acct "a a", Acct "'b"], samplejournal2) `gives` 0
-- [(Just (parsedate "2008-01-01","income"),assets:bank:checking $1,$1)
-- ,(Nothing,income:salary $-1,0)
@ -304,7 +304,7 @@ tests_PostingsReport = tests "PostingsReport" [
-- ,(Nothing,expenses:supplies $1,$2)
-- ,(Nothing,assets:cash $-2,0)
-- ,(Just (2008-12-31,"pay off"),liabilities:debts $1,$1)
-- ,(Nothing,assets:bank:checking $-1,0)
-- ,(Nothing,assets:bank:checking $-1,0)
{-
let opts = defreportopts
@ -321,7 +321,7 @@ tests_PostingsReport = tests "PostingsReport" [
,"2008/12/31 pay off liabilities:debts $1 $1"
," assets:bank:checking $-1 0"
]
,"postings report with cleared option" ~:
do
let opts = defreportopts{cleared_=True}
@ -333,7 +333,7 @@ tests_PostingsReport = tests "PostingsReport" [
,"2008/12/31 pay off liabilities:debts $1 $1"
," assets:bank:checking $-1 0"
]
,"postings report with uncleared option" ~:
do
let opts = defreportopts{uncleared_=True}
@ -346,7 +346,7 @@ tests_PostingsReport = tests "PostingsReport" [
,"2008/06/02 save assets:bank:saving $1 $1"
," assets:bank:checking $-1 0"
]
,"postings report sorts by date" ~:
do
j <- readJournal' $ unlines
@ -360,7 +360,7 @@ tests_PostingsReport = tests "PostingsReport" [
]
let opts = defreportopts
registerdates (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` ["2008/01/01","2008/02/02"]
,"postings report with account pattern" ~:
do
j <- samplejournal
@ -368,7 +368,7 @@ tests_PostingsReport = tests "PostingsReport" [
(postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` unlines
["2008/06/03 eat & shop assets:cash $-2 $-2"
]
,"postings report with account pattern, case insensitive" ~:
do
j <- samplejournal
@ -376,7 +376,7 @@ tests_PostingsReport = tests "PostingsReport" [
(postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` unlines
["2008/06/03 eat & shop assets:cash $-2 $-2"
]
,"postings report with display expression" ~:
do
j <- samplejournal
@ -388,7 +388,7 @@ tests_PostingsReport = tests "PostingsReport" [
"d=[2008/6/2]" `gives` ["2008/06/02"]
"d>=[2008/6/2]" `gives` ["2008/06/02","2008/06/03","2008/12/31"]
"d>[2008/6/2]" `gives` ["2008/06/03","2008/12/31"]
,"postings report with period expression" ~:
do
j <- samplejournal
@ -416,9 +416,9 @@ tests_PostingsReport = tests "PostingsReport" [
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}
registerdates (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` ["2008/01/01","2008/04/01","2008/07/01","2008/10/01"]
]
, "postings report with depth arg" ~:
do
j <- samplejournal
@ -436,7 +436,7 @@ tests_PostingsReport = tests "PostingsReport" [
,"2008/12/31 pay off liabilities:debts $1 $1"
," assets:bank $-1 0"
]
-}
]
@ -445,7 +445,7 @@ tests_PostingsReport = tests "PostingsReport" [
summarisePostingsByInterval (Quarters 1) PrimaryDate 99999 False (DateSpan Nothing Nothing) [] `is` []
]
]
-- ,tests_summarisePostingsInDateSpan = [
-- "summarisePostingsInDateSpan" ~: do
-- let gives (b,e,depth,showempty,ps) =
@ -481,5 +481,5 @@ tests_PostingsReport = tests "PostingsReport" [
-- [
-- nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="",lpamount=Mixed [usd 15]}
-- ]
]

18
hledger-lib/Hledger/Reports/ReportOptions.hs
View File

@ -81,7 +81,7 @@ instance Default AccountListMode where def = ALDefault
-- | Standard options for customising report filtering and output.
-- Most of these correspond to standard hledger command-line options
-- or query arguments, but not all. Some are used only by certain
-- commands, as noted below.
-- commands, as noted below.
data ReportOpts = ReportOpts {
today_ :: Maybe Day -- ^ The current date. A late addition to ReportOpts.
-- Optional, but when set it may affect some reports:
@ -116,10 +116,10 @@ data ReportOpts = ReportOpts {
-- ^ This can be set when running balance reports on a set of accounts
-- with the same normal balance type (eg all assets, or all incomes).
-- - It helps --sort-amount know how to sort negative numbers
-- (eg in the income section of an income statement)
-- - It helps compound balance report commands (is, bs etc.) do
-- sign normalisation, converting normally negative subreports to
-- normally positive for a more conventional display.
-- (eg in the income section of an income statement)
-- - It helps compound balance report commands (is, bs etc.) do
-- sign normalisation, converting normally negative subreports to
-- normally positive for a more conventional display.
,color_ :: Bool
,forecast_ :: Bool
,transpose_ :: Bool
@ -328,7 +328,7 @@ simplifyStatuses l
| length l' >= numstatuses = []
| otherwise = l'
where
l' = nub $ sort l
l' = nub $ sort l
numstatuses = length [minBound .. maxBound :: Status]
-- | Add/remove this status from the status list. Used by hledger-ui.
@ -442,7 +442,7 @@ queryOptsFromOpts d ReportOpts{..} = flagsqopts ++ argsqopts
-- Report dates.
-- | The effective report span is the start and end dates specified by
-- options or queries, or otherwise the earliest and latest transaction or
-- 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.
-- Needs IO to parse smart dates in options/queries.
@ -500,7 +500,7 @@ reportPeriodOrJournalStart ropts@ReportOpts{..} j =
reportPeriodStart ropts <|> journalStartDate False j
-- Get the last day of the overall report period.
-- This the inclusive end date (one day before the
-- This the inclusive end date (one day before the
-- more commonly used, exclusive, report end date).
-- If no report period is specified, will be Nothing.
-- Will also be Nothing if ReportOpts does not have today_ set,
@ -528,7 +528,7 @@ tests_ReportOptions = tests "ReportOptions" [
(queryFromOpts nulldate defreportopts) `is` Any
,(queryFromOpts nulldate defreportopts{query_="a"}) `is` (Acct "a")
,(queryFromOpts nulldate defreportopts{query_="desc:'a a'"}) `is` (Desc "a a")
,(queryFromOpts nulldate defreportopts{period_=PeriodFrom (parsedate "2012/01/01"),query_="date:'to 2013'" })
,(queryFromOpts nulldate defreportopts{period_=PeriodFrom (parsedate "2012/01/01"),query_="date:'to 2013'" })
`is` (Date $ mkdatespan "2012/01/01" "2013/01/01")
,(queryFromOpts nulldate defreportopts{query_="date2:'in 2012'"}) `is` (Date2 $ mkdatespan "2012/01/01" "2013/01/01")
,(queryFromOpts nulldate defreportopts{query_="'a a' 'b"}) `is` (Or [Acct "a a", Acct "'b"])

2
hledger-lib/Hledger/Reports/ReportTypes.hs
View File

@ -33,7 +33,7 @@ data PeriodicReport a =
type PeriodicReportRow a =
( AccountName -- A full account name.
, AccountName -- Shortened form of the account name to display in tree mode. Usually the leaf name, possibly with parent accounts prefixed.
, Int -- Indent level for displaying this account name in tree mode. 0, 1, 2...
, Int -- Indent level for displaying this account name in tree mode. 0, 1, 2...
, [a] -- The data value for each subperiod.
, a -- The total of this row's values.
, a -- The average of this row's values.

8
hledger-lib/Hledger/Utils.hs
View File

@ -161,14 +161,14 @@ firstJust ms = case dropWhile (==Nothing) ms of
[] -> Nothing
(md:_) -> md
-- | Read text from a file,
-- | Read text from a file,
-- handling any of the usual line ending conventions,
-- using the system locale's text encoding,
-- ignoring any utf8 BOM prefix (as seen in paypal's 2018 CSV, eg) if that encoding is utf8.
-- ignoring any utf8 BOM prefix (as seen in paypal's 2018 CSV, eg) if that encoding is utf8.
readFilePortably :: FilePath -> IO Text
readFilePortably f = openFile f ReadMode >>= readHandlePortably
-- | Like readFilePortably, but read from standard input if the path is "-".
-- | Like readFilePortably, but read from standard input if the path is "-".
readFileOrStdinPortably :: String -> IO Text
readFileOrStdinPortably f = openFileOrStdin f ReadMode >>= readHandlePortably
where
@ -236,7 +236,7 @@ embedFileRelative f = makeRelativeToProject f >>= embedStringFile
-- hereFileRelative f = makeRelativeToProject f >>= hereFileExp
-- where
-- QuasiQuoter{quoteExp=hereFileExp} = hereFile
tests_Utils = tests "Utils" [
tests_Text
]

2
hledger-lib/Hledger/Utils/Color.hs
View File

@ -2,7 +2,7 @@
{-# LANGUAGE OverloadedStrings #-}
module Hledger.Utils.Color
module Hledger.Utils.Color
(
color,
bgColor,

6
hledger-lib/Hledger/Utils/Debug.hs
View File

@ -94,7 +94,7 @@ traceWith f a = trace (f a) a
-- touch and reload this module to see the effect of a new --debug option.
-- After command-line processing, it is also available as the @debug_@
-- field of 'Hledger.Cli.CliOptions.CliOpts'.
-- {-# OPTIONS_GHC -fno-cse #-}
-- {-# OPTIONS_GHC -fno-cse #-}
-- {-# NOINLINE debugLevel #-}
debugLevel :: Int
debugLevel = case snd $ break (=="--debug") args of
@ -251,7 +251,7 @@ dbg9IO = ptraceAtIO 9
plog :: Show a => String -> a -> a
plog = plogAt 0
-- | Log a label and a pretty-printed showable value to ./debug.log,
-- | Log a label and a pretty-printed showable value to ./debug.log,
-- if the global debug level is at or above the specified level.
-- At level 0, always logs. Otherwise, uses unsafePerformIO.
-- Tends to fail if called more than once, at least when built with -threaded
@ -259,7 +259,7 @@ plog = plogAt 0
plogAt :: Show a => Int -> String -> a -> a
plogAt lvl
| lvl > 0 && debugLevel < lvl = flip const
| otherwise = \s a ->
| otherwise = \s a ->
let p = ppShow a
ls = lines p
nlorspace | length ls > 1 = "\n"

4
hledger-lib/Hledger/Utils/String.hs
View File

@ -322,9 +322,9 @@ takeWidth w (c:cs) | cw <= w = c:takeWidth (w-cw) cs
-- see also http://unicode.org/reports/tr11/#Description
-- | Calculate the render width of a string, considering
-- wide characters (counted as double width), ANSI escape codes
-- wide characters (counted as double width), ANSI escape codes
-- (not counted), and line breaks (in a multi-line string, the longest
-- line determines the width).
-- line determines the width).
strWidth :: String -> Int
strWidth "" = 0
strWidth s = maximum $ map (foldr (\a b -> charWidth a + b) 0) $ lines s'

46
hledger-lib/Hledger/Utils/Test.hs
View File

@ -24,7 +24,7 @@ module Hledger.Utils.Test (
,expectParseEqOn
,expectParseEqOnE
,expectParseStateOn
)
)
where
import Control.Exception
@ -36,7 +36,7 @@ import Data.Monoid ((<>))
import Data.CallStack
import Data.List
import qualified Data.Text as T
import Safe
import Safe
import System.Exit
import Text.Megaparsec
import Text.Megaparsec.Custom
@ -50,38 +50,38 @@ import Hledger.Utils.UTF8IOCompat (error')
-- * easytest helpers
-- | Name the given test(s). A readability synonym for easytest's "scope".
test :: T.Text -> E.Test a -> E.Test a
test :: T.Text -> E.Test a -> E.Test a
test = E.scope
-- | Skip the given test(s), with the same type signature as "test".
-- If called in a monadic sequence of tests, also skips following tests.
_test :: T.Text -> E.Test a -> E.Test a
_test _name = (E.skip >>)
_test :: T.Text -> E.Test a -> E.Test a
_test _name = (E.skip >>)
-- | Name the given test(s). A synonym for "test".
it :: T.Text -> E.Test a -> E.Test a
it :: T.Text -> E.Test a -> E.Test a
it = test
-- | Skip the given test(s), and any following tests in a monadic sequence.
-- | Skip the given test(s), and any following tests in a monadic sequence.
-- A synonym for "_test".
_it :: T.Text -> E.Test a -> E.Test a
_it :: T.Text -> E.Test a -> E.Test a
_it = _test
-- | Name and group a list of tests. Combines easytest's "scope" and "tests".
tests :: T.Text -> [E.Test ()] -> E.Test ()
tests :: T.Text -> [E.Test ()] -> E.Test ()
tests name = E.scope name . E.tests
-- | Skip the given list of tests, and any following tests in a monadic sequence,
-- with the same type signature as "group".
_tests :: T.Text -> [E.Test ()] -> E.Test ()
_tests :: T.Text -> [E.Test ()] -> E.Test ()
_tests _name = (E.skip >>) . E.tests
-- | Run some easytest tests, catching easytest's ExitCode exception,
-- returning True if there was a problem.
-- With arguments, runs only the scope (or single test) named by the first argument
-- (exact, case sensitive).
-- (exact, case sensitive).
-- If there is a second argument, it should be an integer and will be used
-- as the seed for randomness.
-- as the seed for randomness.
runEasytests :: [String] -> E.Test () -> IO Bool
runEasytests args tests = (do
case args of
@ -96,7 +96,7 @@ runEasytests args tests = (do
`catch` (\(_::ExitCode) -> return True)
-- | Like easytest's expectEq (asserts the second (actual) value equals the first (expected) value)
-- but pretty-prints the values in the failure output.
-- but pretty-prints the values in the failure output.
expectEqPP :: (Eq a, Show a, HasCallStack) => a -> a -> E.Test ()
expectEqPP expected actual = if expected == actual then E.ok else E.crash $
"\nexpected:\n" <> T.pack (pshow expected) <> "\nbut got:\n" <> T.pack (pshow actual) <> "\n"
@ -105,10 +105,10 @@ expectEqPP expected actual = if expected == actual then E.ok else E.crash $
is :: (Eq a, Show a, HasCallStack) => a -> a -> Test ()
is = flip expectEqPP
-- | Test that this stateful parser runnable in IO successfully parses
-- all of the given input text, showing the parse error if it fails.
-- | Test that this stateful parser runnable in IO successfully parses
-- all of the given input text, showing the parse error if it fails.
-- Suitable for hledger's JournalParser parsers.
expectParse :: (Monoid st, Eq a, Show a, HasCallStack) =>
expectParse :: (Monoid st, Eq a, Show a, HasCallStack) =>
StateT st (ParsecT CustomErr T.Text IO) a -> T.Text -> E.Test ()
expectParse parser input = do
ep <- E.io (runParserT (evalStateT (parser <* eof) mempty) "" input)
@ -135,9 +135,9 @@ expectParseE parser input = do
(const ok)
ep
-- | Test that this stateful parser runnable in IO fails to parse
-- the given input text, with a parse error containing the given string.
expectParseError :: (Monoid st, Eq a, Show a, HasCallStack) =>
-- | Test that this stateful parser runnable in IO fails to parse
-- the given input text, with a parse error containing the given string.
expectParseError :: (Monoid st, Eq a, Show a, HasCallStack) =>
StateT st (ParsecT CustomErr T.Text IO) a -> T.Text -> String -> E.Test ()
expectParseError parser input errstr = do
ep <- E.io (runParserT (evalStateT parser mempty) "" input)
@ -173,8 +173,8 @@ expectParseErrorE parser input errstr = do
else fail $ "\nparse error is not as expected:\n" ++ e' ++ "\n"
-- | Like expectParse, but also test the parse result is an expected value,
-- pretty-printing both if it fails.
expectParseEq :: (Monoid st, Eq a, Show a, HasCallStack) =>
-- pretty-printing both if it fails.
expectParseEq :: (Monoid st, Eq a, Show a, HasCallStack) =>
StateT st (ParsecT CustomErr T.Text IO) a -> T.Text -> a -> E.Test ()
expectParseEq parser input expected = expectParseEqOn parser input id expected
@ -186,9 +186,9 @@ expectParseEqE
-> E.Test ()
expectParseEqE parser input expected = expectParseEqOnE parser input id expected
-- | Like expectParseEq, but transform the parse result with the given function
-- | Like expectParseEq, but transform the parse result with the given function
-- before comparing it.
expectParseEqOn :: (Monoid st, Eq b, Show b, HasCallStack) =>
expectParseEqOn :: (Monoid st, Eq b, Show b, HasCallStack) =>
StateT st (ParsecT CustomErr T.Text IO) a -> T.Text -> (a -> b) -> b -> E.Test ()
expectParseEqOn parser input f expected = do
ep <- E.io $ runParserT (evalStateT (parser <* eof) mempty) "" input

14
hledger-lib/Hledger/Utils/Text.hs
View File

@ -423,11 +423,11 @@ textWidth s = maximum $ map (T.foldr (\a b -> charWidth a + b) 0) $ T.lines s
tests_Text = tests "Text" [
tests "quoteIfSpaced" [
quoteIfSpaced "a'a" `is` "a'a"
,quoteIfSpaced "a\"a" `is` "a\"a"
,quoteIfSpaced "a a" `is` "\"a a\""
,quoteIfSpaced "mimi's cafe" `is` "\"mimi's cafe\""
,quoteIfSpaced "\"alex\" cafe" `is` "\"\\\"alex\\\" cafe\""
,quoteIfSpaced "le'shan's cafe" `is` "\"le'shan's cafe\""
,quoteIfSpaced "\"be'any's\" cafe" `is` "\"\\\"be'any's\\\" cafe\""
]
,quoteIfSpaced "a\"a" `is` "a\"a"
,quoteIfSpaced "a a" `is` "\"a a\""
,quoteIfSpaced "mimi's cafe" `is` "\"mimi's cafe\""
,quoteIfSpaced "\"alex\" cafe" `is` "\"\\\"alex\\\" cafe\""
,quoteIfSpaced "le'shan's cafe" `is` "\"le'shan's cafe\""
,quoteIfSpaced "\"be'any's\" cafe" `is` "\"\\\"be'any's\\\" cafe\""
]
]

4
hledger-lib/Hledger/Utils/UTF8IOCompat.hs
View File

@ -16,7 +16,7 @@ do the right thing, so this file is a no-op and on its way to being removed.
Not carefully tested.
-}
-- TODO obsolete ?
-- TODO obsolete ?
module Hledger.Utils.UTF8IOCompat (
readFile,
@ -119,5 +119,5 @@ userError' = userError . toSystemString
-- | A SystemString-aware version of error that adds a usage hint.
usageError :: String -> a
usageError = error' . (++ " (use -h to see usage)")
usageError = error' . (++ " (use -h to see usage)")

2
hledger-lib/Text/Megaparsec/Custom.hs
View File

@ -230,7 +230,7 @@ customErrorBundlePretty errBundle =
-- (since only one custom error should be used at a time).
findCustomError :: ParseError Text CustomErr -> Maybe CustomErr
findCustomError err = case err of
FancyError _ errSet ->
FancyError _ errSet ->
finds (\case {ErrorCustom e -> Just e; _ -> Nothing}) errSet
_ -> Nothing

2
hledger-lib/Text/Tabular/AsciiWide.hs
View File

@ -98,7 +98,7 @@ renderHLine' pretty prop is sep h = [ cross pretty, sep ] ++ coreLine ++ [sep, c
coreLine = concatMap helper $ flattenHeader $ zipHeader 0 is h
helper = either vsep dashes
dashes (i,_) = replicate i sep
vsep NoLine = replicate 2 sep -- match the double space sep in renderColumns
vsep NoLine = replicate 2 sep -- match the double space sep in renderColumns
vsep SingleLine = sep : cross pretty : [sep]
vsep DoubleLine = sep : cross' ++ [sep]
cross' = case prop of

14
hledger-lib/test/doctests.hs
View File

@ -1,4 +1,4 @@
{-
{-
Run doctests in Hledger source files under the current directory
(./Hledger.hs, ./Hledger/**, ./Text/**) using the doctest runner.
@ -7,7 +7,7 @@ Arguments are case-insensitive file path substrings, to limit the files searched
--slow reloads ghci between each test (https://github.com/sol/doctest#a-note-on-performance).
Eg, in hledger source dir:
$ make ghci-doctest, :main [--verbose] [--slow] [CIFILEPATHSUBSTRINGS]
or:
@ -40,20 +40,20 @@ main = do
]
-- filter by patterns (case insensitive infix substring match)
let
let
fs | null pats = sourcefiles
| otherwise = [f | f <- sourcefiles, let f' = map toLower f, any (`isInfixOf` f') pats']
where pats' = map (map toLower) pats
fslen = length fs
if (null fs)
then do
putStrLn $ "No file paths found matching: " ++ unwords pats
else do
putStrLn $
"Loading and searching for doctests in "
++ show fslen
putStrLn $
"Loading and searching for doctests in "
++ show fslen
++ if fslen > 1 then " files, plus any files they import:" else " file, plus any files it imports:"
when verbose $ putStrLn $ unwords fs

30
hledger-ui/Hledger/UI/AccountsScreen.hs
View File

@ -71,7 +71,7 @@ asInit d reset ui@UIState{
selidx = case (reset, listSelectedElement $ _asList s) of
(True, _) -> 0
(_, Nothing) -> 0
(_, Just (_,AccountsScreenItem{asItemAccountName=a})) ->
(_, Just (_,AccountsScreenItem{asItemAccountName=a})) ->
headDef 0 $ catMaybes [
findIndex (a ==) as
,findIndex (a `isAccountNamePrefixOf`) as
@ -88,7 +88,7 @@ asInit d reset ui@UIState{
pfq | presentorfuture_ uopts == PFFuture = Any
| otherwise = Date $ DateSpan Nothing (Just $ addDays 1 d)
q = And [queryFromOpts d ropts, pfq]
-- run the report
(items,_total) = report ropts' q j
@ -104,14 +104,14 @@ asInit d reset ui@UIState{
displayitem (fullacct, shortacct, indent, bal) =
AccountsScreenItem{asItemIndentLevel = indent
,asItemAccountName = fullacct
,asItemDisplayAccountName = replaceHiddenAccountsNameWith "All" $ if tree_ ropts' then shortacct else fullacct
,asItemDisplayAccountName = replaceHiddenAccountsNameWith "All" $ if tree_ ropts' then shortacct else fullacct
,asItemRenderedAmounts = map showAmountWithoutPrice amts -- like showMixedAmountOneLineWithoutPrice
}
where
Mixed amts = normaliseMixedAmountSquashPricesForDisplay $ stripPrices bal
stripPrices (Mixed as) = Mixed $ map stripprice as where stripprice a = a{aprice=Nothing}
displayitems = map displayitem items
-- blanks added for scrolling control, cf RegisterScreen
-- blanks added for scrolling control, cf RegisterScreen
blankitems = replicate 100
AccountsScreenItem{asItemIndentLevel = 0
,asItemAccountName = ""
@ -201,7 +201,7 @@ asDraw UIState{aopts=uopts@UIOpts{cliopts_=copts@CliOpts{reportopts_=ropts}}
curidx = case _asList s ^. listSelectedL of
Nothing -> "-"
Just i -> show (i + 1)
totidx = show $ V.length nonblanks
totidx = show $ V.length nonblanks
where
nonblanks = V.takeWhile (not . T.null . asItemAccountName) $ s ^. asList . listElementsL
@ -215,7 +215,7 @@ asDraw UIState{aopts=uopts@UIOpts{cliopts_=copts@CliOpts{reportopts_=ropts}}
,("-+", str "depth")
,("T", renderToggle (tree_ ropts) "flat" "tree")
,("H", renderToggle (not ishistorical) "end-bals" "changes")
,("F", renderToggle (presentorfuture_ uopts == PFFuture) "present" "future")
,("F", renderToggle (presentorfuture_ uopts == PFFuture) "present" "future")
--,("/", "filter")
--,("DEL", "unfilter")
--,("ESC", "cancel/top")
@ -346,14 +346,14 @@ asHandle ui0@UIState{
VtyEvent (EvKey (KChar 'l') [MCtrl]) -> scrollSelectionToMiddle _asList >> redraw ui
VtyEvent (EvKey (KChar 'z') [MCtrl]) -> suspend ui
-- enter register screen for selected account (if there is one),
-- enter register screen for selected account (if there is one),
-- centering its selected transaction if possible
VtyEvent e | e `elem` moveRightEvents
VtyEvent e | e `elem` moveRightEvents
, not $ isBlankElement $ listSelectedElement _asList->
-- TODO center selection after entering register screen; neither of these works till second time entering; easy strictifications didn't help
rsCenterAndContinue $
-- TODO center selection after entering register screen; neither of these works till second time entering; easy strictifications didn't help
rsCenterAndContinue $
-- flip rsHandle (VtyEvent (EvKey (KChar 'l') [MCtrl])) $
screenEnter d regscr ui
screenEnter d regscr ui
where
regscr = rsSetAccount selacct isdepthclipped registerScreen
isdepthclipped = case getDepth ui of
@ -363,9 +363,9 @@ asHandle ui0@UIState{
-- prevent moving down over blank padding items;
-- instead scroll down by one, until maximally scrolled - shows the end has been reached
VtyEvent (EvKey (KDown) []) | isBlankElement mnextelement -> do
vScrollBy (viewportScroll $ _asList^.listNameL) 1
vScrollBy (viewportScroll $ _asList^.listNameL) 1
continue ui
where
where
mnextelement = listSelectedElement $ listMoveDown _asList
-- if page down or end leads to a blank padding item, stop at last non-blank
@ -378,7 +378,7 @@ asHandle ui0@UIState{
continue ui{aScreen=scr{_asList=list'}}
else
continue ui{aScreen=scr{_asList=list}}
-- fall through to the list's event handler (handles up/down)
VtyEvent ev -> do
newitems <- handleListEvent (normaliseMovementKeys ev) _asList
@ -398,7 +398,7 @@ asHandle _ _ = error "event handler called with wrong screen type, should not ha
asSetSelectedAccount a s@AccountsScreen{} = s & asSelectedAccount .~ a
asSetSelectedAccount _ s = s
isBlankElement mel = ((asItemAccountName . snd) <$> mel) == Just ""
isBlankElement mel = ((asItemAccountName . snd) <$> mel) == Just ""
asCenterAndContinue ui = do
scrollSelectionToMiddle $ _asList $ aScreen ui

2
hledger-ui/Hledger/UI/Main.hs
View File

@ -163,7 +163,7 @@ runBrickUi uopts@UIOpts{cliopts_=copts@CliOpts{inputopts_=_iopts,reportopts_=rop
}
-- print (length (show ui)) >> exitSuccess -- show any debug output to this point & quit
if not (watch_ uopts')
then
void $ defaultMain brickapp ui

22
hledger-ui/Hledger/UI/RegisterScreen.hs
View File

@ -112,10 +112,10 @@ rsInit d reset ui@UIState{aopts=uopts@UIOpts{cliopts_=CliOpts{reportopts_=ropts}
-- otherwise, the previously selected transaction if possible;
-- otherwise, the transaction nearest in date to it;
-- or if there's several with the same date, the nearest in journal order;
-- otherwise, the last (latest) transaction.
-- otherwise, the last (latest) transaction.
newitems' = listMoveTo newselidx newitems
where
newselidx =
newselidx =
case (reset, listSelectedElement rsList) of
(True, _) -> endidx
(_, Nothing) -> endidx
@ -164,7 +164,7 @@ rsDraw UIState{aopts=uopts@UIOpts{cliopts_=copts@CliOpts{reportopts_=ropts}}
changewidthproportion = fromIntegral maxchangewidthseen / fromIntegral (maxchangewidthseen + maxbalwidthseen)
maxchangewidth = round $ changewidthproportion * fromIntegral maxamtswidth
maxbalwidth = maxamtswidth - maxchangewidth
changewidth = min maxchangewidth maxchangewidthseen
changewidth = min maxchangewidth maxchangewidthseen
balwidth = min maxbalwidth maxbalwidthseen
-- assign the remaining space to the description and accounts columns
-- maxdescacctswidth = totalwidth - (whitespacewidth - 4) - changewidth - balwidth
@ -177,7 +177,7 @@ rsDraw UIState{aopts=uopts@UIOpts{cliopts_=copts@CliOpts{reportopts_=ropts}}
-- descwidthproportion = (descwidth' + acctswidth') / descwidth'
-- maxdescwidth = min (maxdescacctswidth - 7) (maxdescacctswidth / descwidthproportion)
-- maxacctswidth = maxdescacctswidth - maxdescwidth
-- descwidth = min maxdescwidth descwidth'
-- descwidth = min maxdescwidth descwidth'
-- acctswidth = min maxacctswidth acctswidth'
-- allocating equally.
descwidth = maxdescacctswidth `div` 2
@ -232,7 +232,7 @@ rsDraw UIState{aopts=uopts@UIOpts{cliopts_=copts@CliOpts{reportopts_=ropts}}
-- ,("RIGHT", str "transaction")
,("T", renderToggle (tree_ ropts) "flat(-subs)" "tree(+subs)") -- rsForceInclusive may override, but use tree_ to ensure a visible toggle effect
,("H", renderToggle (not ishistorical) "historical" "period")
,("F", renderToggle (presentorfuture_ uopts == PFFuture) "present" "future")
,("F", renderToggle (presentorfuture_ uopts == PFFuture) "present" "future")
-- ,("a", "add")
-- ,("g", "reload")
-- ,("q", "quit")
@ -271,11 +271,11 @@ rsHandle ui@UIState{
,aMode=mode
} ev = do
d <- liftIO getCurrentDay
let
let
journalspan = journalDateSpan False j
nonblanks = V.takeWhile (not . null . rsItemDate) $ rsList^.listElementsL
lastnonblankidx = max 0 (length nonblanks - 1)
case mode of
Minibuffer ed ->
case ev of
@ -358,9 +358,9 @@ rsHandle ui@UIState{
-- prevent moving down over blank padding items;
-- instead scroll down by one, until maximally scrolled - shows the end has been reached
VtyEvent e | e `elem` moveDownEvents, isBlankElement mnextelement -> do
vScrollBy (viewportScroll $ rsList^.listNameL) 1
vScrollBy (viewportScroll $ rsList^.listNameL) 1
continue ui
where
where
mnextelement = listSelectedElement $ listMoveDown rsList
-- if page down or end leads to a blank padding item, stop at last non-blank
@ -373,7 +373,7 @@ rsHandle ui@UIState{
continue ui{aScreen=s{rsList=list'}}
else
continue ui{aScreen=s{rsList=list}}
-- fall through to the list's event handler (handles other [pg]up/down events)
VtyEvent ev -> do
let ev' = normaliseMovementKeys ev
@ -386,7 +386,7 @@ rsHandle ui@UIState{
rsHandle _ _ = error "event handler called with wrong screen type, should not happen"
isBlankElement mel = ((rsItemDate . snd) <$> mel) == Just ""
isBlankElement mel = ((rsItemDate . snd) <$> mel) == Just ""
rsCenterAndContinue ui = do
scrollSelectionToMiddle $ rsList $ aScreen ui

2
hledger-ui/Hledger/UI/Theme.hs
View File

@ -73,7 +73,7 @@ themesList = [
,("border" <> "bold" , currentAttr & bold)
,("border" <> "depth" , active)
,("border" <> "filename" , currentAttr)
,("border" <> "key" , active)
,("border" <> "key" , active)
,("border" <> "minibuffer" , white `on` black & bold)
,("border" <> "query" , active)
,("border" <> "selected" , active)

2
hledger-ui/Hledger/UI/TransactionScreen.hs
View File

@ -136,7 +136,7 @@ tsHandle ui@UIState{aScreen=s@TransactionScreen{tsTransaction=(i,t)
where
(pos,f) = case tsourcepos t of
GenericSourcePos f l c -> (Just (l, Just c),f)
JournalSourcePos f (l1,_) -> (Just (l1, Nothing),f)
JournalSourcePos f (l1,_) -> (Just (l1, Nothing),f)
AppEvent (DateChange old _) | isStandardPeriod p && p `periodContainsDate` old ->
continue $ regenerateScreens j d $ setReportPeriod (DayPeriod d) ui
where

6
hledger-ui/Hledger/UI/UIOptions.hs
View File

@ -85,7 +85,7 @@ rawOptsToUIOpts rawopts = checkUIOpts <$> do
,cliopts_ = cliopts
}
-- | Should transactions dated later than today be included ?
-- | Should transactions dated later than today be included ?
-- Like flat/tree mode, there are three states, and the meaning of default can vary by command.
data PresentOrFutureOpt = PFDefault | PFPresent | PFFuture deriving (Eq, Show, Data, Typeable)
instance Default PresentOrFutureOpt where def = PFDefault
@ -109,7 +109,7 @@ getHledgerUIOpts :: IO UIOpts
--getHledgerUIOpts = processArgs uimode >>= return . decodeRawOpts >>= rawOptsToUIOpts
getHledgerUIOpts = do
args <- getArgs >>= expandArgsAt
let args' = replaceNumericFlags args
let args' = replaceNumericFlags args
let cmdargopts = either usageError id $ process uimode args'
rawOptsToUIOpts $ decodeRawOpts cmdargopts
rawOptsToUIOpts $ decodeRawOpts cmdargopts

12
hledger-ui/Hledger/UI/UIState.hs
View File

@ -35,15 +35,15 @@ toggleCleared :: UIState -> UIState
toggleCleared ui@UIState{aopts=uopts@UIOpts{cliopts_=copts@CliOpts{reportopts_=ropts}}} =
ui{aopts=uopts{cliopts_=copts{reportopts_=reportOptsToggleStatusSomehow Cleared copts ropts}}}
-- TODO testing different status toggle styles
-- TODO testing different status toggle styles
-- | Generate zero or more indicators of the status filters currently active,
-- | Generate zero or more indicators of the status filters currently active,
-- which will be shown comma-separated as part of the indicators list.
uiShowStatus :: CliOpts -> [Status] -> [String]
uiShowStatus copts ss =
case style of
-- in style 2, instead of "Y, Z" show "not X"
Just 2 | length ss == numstatuses-1
-- in style 2, instead of "Y, Z" show "not X"
Just 2 | length ss == numstatuses-1
-> map (("not "++). showstatus) $ sort $ complement ss -- should be just one
_ -> map showstatus $ sort ss
where
@ -55,7 +55,7 @@ uiShowStatus copts ss =
reportOptsToggleStatusSomehow :: Status -> CliOpts -> ReportOpts -> ReportOpts
reportOptsToggleStatusSomehow s copts ropts =
case maybeintopt "status-toggles" $ rawopts_ copts of
case maybeintopt "status-toggles" $ rawopts_ copts of
Just 2 -> reportOptsToggleStatus2 s ropts
Just 3 -> reportOptsToggleStatus3 s ropts
-- Just 4 -> reportOptsToggleStatus4 s ropts
@ -78,7 +78,7 @@ reportOptsToggleStatus1 s ropts@ReportOpts{statuses_=ss}
reportOptsToggleStatus2 s ropts@ReportOpts{statuses_=ss}
| ss == [s] = ropts{statuses_=complement [s]}
| ss == complement [s] = ropts{statuses_=[]}
| otherwise = ropts{statuses_=[s]} -- XXX assume only three values
| otherwise = ropts{statuses_=[s]} -- XXX assume only three values
-- 3 UPC toggles each X
reportOptsToggleStatus3 s ropts@ReportOpts{statuses_=ss}

14
hledger-ui/Hledger/UI/UIUtils.hs
View File

@ -59,7 +59,7 @@ suspendSignal = return ()
#else
import System.Posix.Signals
suspendSignal :: IO ()
suspendSignal = raiseSignal sigSTOP
suspendSignal = raiseSignal sigSTOP
#endif
-- | On posix platforms, suspend the program using the STOP signal,
@ -121,7 +121,7 @@ helpDialog _copts =
vBox [
withAttr ("help" <> "heading") $ str "Filtering"
,renderKey ("/ ", "set a filter query")
,renderKey ("UPC ", "show unmarked/pending/cleared")
,renderKey ("UPC ", "show unmarked/pending/cleared")
,renderKey ("F ", "show future/present txns")
,renderKey ("R ", "show real/all postings")
,renderKey ("Z ", "show nonzero/all amounts")
@ -208,12 +208,12 @@ borderKeysStr' keydescs =
-- sep = str " | "
sep = str " "
-- | Render the two states of a toggle, highlighting the active one.
-- | Render the two states of a toggle, highlighting the active one.
renderToggle :: Bool -> String -> String -> Widget Name
renderToggle isright l r =
let bold = withAttr ("border" <> "selected") in
if isright
then str (l++"/") <+> bold (str r)
then str (l++"/") <+> bold (str r)
else bold (str l) <+> str ("/"++r)
-- temporary shenanigans:
@ -310,13 +310,13 @@ withBorderAttr attr = updateAttrMap (applyAttrMappings [("border", attr)])
--scrollToTop :: List Name e -> EventM Name ()
--scrollToTop list = do
-- let vpname = list^.listNameL
-- setTop (viewportScroll vpname) 0
-- setTop (viewportScroll vpname) 0
-- | Scroll a list's viewport so that the selected item is centered in the
-- middle of the display area.
scrollSelectionToMiddle :: List Name e -> EventM Name ()
scrollSelectionToMiddle list = do
let mselectedrow = list^.listSelectedL
let mselectedrow = list^.listSelectedL
vpname = list^.listNameL
mvp <- lookupViewport vpname
case (mselectedrow, mvp) of
@ -326,7 +326,7 @@ scrollSelectionToMiddle list = do
vpheight = dbg4 "vpheight" $ vp^.vpSize._2
itemsperpage = dbg4 "itemsperpage" $ vpheight `div` itemheight
toprow = dbg4 "toprow" $ max 0 (selectedrow - (itemsperpage `div` 2)) -- assuming ViewportScroll's row offset is measured in list items not screen rows
setTop (viewportScroll vpname) toprow
setTop (viewportScroll vpname) toprow
_ -> return ()
-- arrow keys vi keys emacs keys

2
hledger-web/Hledger/Web/Application.hs
View File

@ -17,7 +17,7 @@ import Yesod.Default.Config
import Hledger.Data (Journal, nulljournal)
import Hledger.Web.Handler.AddR
import Hledger.Web.Handler.MiscR
import Hledger.Web.Handler.MiscR
import Hledger.Web.Handler.EditR
import Hledger.Web.Handler.UploadR
import Hledger.Web.Handler.JournalR

4
hledger-web/Hledger/Web/Handler/AddR.hs
View File

@ -55,7 +55,7 @@ postAddR = do
|]
-- Add a single new transaction, send as JSON via PUT, to the journal.
-- The web form handler above should probably use PUT as well.
-- The web form handler above should probably use PUT as well.
putAddR :: Handler RepJson
putAddR = do
VD{caps, j, opts} <- getViewData
@ -66,4 +66,4 @@ putAddR = do
Error err -> sendStatusJSON status400 ("could not parse json: " ++ err ::String)
Success t -> do
void $ liftIO $ journalAddTransaction j (cliopts_ opts) t
sendResponseCreated TransactionsR
sendResponseCreated TransactionsR

10
hledger-web/Hledger/Web/Handler/MiscR.hs
View File

@ -7,11 +7,11 @@
{-# LANGUAGE TemplateHaskell #-}
module Hledger.Web.Handler.MiscR
( getAccountnamesR
, getTransactionsR
, getPricesR
, getCommoditiesR
, getAccountsR
( getAccountnamesR
, getTransactionsR
, getPricesR
, getCommoditiesR
, getAccountsR
, getAccounttransactionsR
, getDownloadR
, getFaviconR

14
hledger-web/Hledger/Web/Json.hs
View File

@ -21,7 +21,7 @@
--{-# LANGUAGE TypeFamilies #-}
--{-# LANGUAGE TypeOperators #-}
module Hledger.Web.Json (
module Hledger.Web.Json (
-- * Instances
-- * Utilities
readJsonFile
@ -66,11 +66,11 @@ instance ToJSON Posting where
,"ptype" .= toJSON ptype
,"ptags" .= toJSON ptags
,"pbalanceassertion" .= toJSON pbalanceassertion
-- To avoid a cycle, show just the parent transaction's index number
-- To avoid a cycle, show just the parent transaction's index number
-- in a dummy field. When re-parsed, there will be no parent.
,"ptransaction_" .= toJSON (maybe "" (show.tindex) ptransaction)
-- This is probably not wanted in json, we discard it.
,"poriginal" .= toJSON (Nothing :: Maybe Posting)
,"poriginal" .= toJSON (Nothing :: Maybe Posting)
]
instance ToJSON Transaction
@ -82,7 +82,7 @@ instance ToJSON Account where
,"aibalance" .= toJSON (aibalance a)
,"anumpostings" .= toJSON (anumpostings a)
,"aboring" .= toJSON (aboring a)
-- To avoid a cycle, show just the parent account's name
-- To avoid a cycle, show just the parent account's name
-- in a dummy field. When re-parsed, there will be no parent.
,"aparent_" .= toJSON (maybe "" aname $ aparent a)
-- Just the names of subaccounts, as a dummy field, ignored when parsed.
@ -110,14 +110,14 @@ instance FromJSON Posting
instance FromJSON Transaction
instance FromJSON AccountDeclarationInfo
-- XXX The ToJSON instance replaces subaccounts with just names.
-- Here we should try to make use of those to reconstruct the
-- Here we should try to make use of those to reconstruct the
-- parent-child relationships.
instance FromJSON Account
-- Decimal, various attempts
--
-- https://stackoverflow.com/questions/40331851/haskell-data-decimal-as-aeson-type
----instance FromJSON Decimal where parseJSON =
----instance FromJSON Decimal where parseJSON =
---- A.withScientific "Decimal" (return . right . eitherFromRational . toRational)
--
-- https://github.com/bos/aeson/issues/474
@ -156,7 +156,7 @@ instance FromJSON (DecimalRaw Integer)
readJsonFile :: FromJSON a => FilePath -> IO a
readJsonFile f = do
bs <- BL.readFile f
let v = fromMaybe (error "could not decode bytestring as json value") (decode bs :: Maybe Value)
let v = fromMaybe (error "could not decode bytestring as json value") (decode bs :: Maybe Value)
case fromJSON v :: FromJSON a => Result a of
Error e -> error e
Success t -> return t

24
hledger/Hledger/Cli/CliOptions.hs
View File

@ -282,7 +282,7 @@ type CommandDoc = String
-- from a help template and flag/argument specifications.
-- Reduces boilerplate a little, though the complicated cmdargs
-- flag and argument specs are still required.
hledgerCommandMode :: CommandDoc -> [Flag RawOpts] -> [(String, [Flag RawOpts])]
hledgerCommandMode :: CommandDoc -> [Flag RawOpts] -> [(String, [Flag RawOpts])]
-> [Flag RawOpts] -> ([Arg RawOpts], Maybe (Arg RawOpts)) -> Mode RawOpts
hledgerCommandMode doc unnamedflaggroup namedflaggroups hiddenflaggroup argsdescr =
case parseCommandDoc doc of
@ -404,7 +404,7 @@ defaultWidth :: Int
defaultWidth = 80
-- | Replace any numeric flags (eg -2) with their long form (--depth 2),
-- as I'm guessing cmdargs doesn't support this directly.
-- as I'm guessing cmdargs doesn't support this directly.
replaceNumericFlags :: [String] -> [String]
replaceNumericFlags = map replace
where
@ -452,10 +452,10 @@ checkCliOpts opts =
Right _ -> Right ()
-- XXX check registerWidthsFromOpts opts
-- | A helper for addon commands: this parses options and arguments from
-- the current command line using the given hledger-style cmdargs mode,
-- and returns a CliOpts. Or, with --help or -h present, it prints
-- long or short help, and exits the program.
-- | A helper for addon commands: this parses options and arguments from
-- the current command line using the given hledger-style cmdargs mode,
-- and returns a CliOpts. Or, with --help or -h present, it prints
-- long or short help, and exits the program.
-- When --debug is present, also prints some debug output.
-- Note this is not used by the main hledger executable.
--
@ -472,7 +472,7 @@ checkCliOpts opts =
-- hledger options not displayed.
--
-- Tips:
-- Empty lines in the pre/postamble are removed by cmdargs;
-- Empty lines in the pre/postamble are removed by cmdargs;
-- add a space character to preserve them.
--
getHledgerCliOpts :: Mode RawOpts -> IO CliOpts
@ -640,7 +640,7 @@ defaultBalanceLineFormat = BottomAligned [
-- or more versions (or two versions that don't look like a
-- source/compiled pair), they are all included, with file extensions
-- intact.
--
--
hledgerAddons :: IO [String]
hledgerAddons = do
-- past bug generator
@ -658,10 +658,10 @@ dropRedundantSourceVersion [f,g]
| takeExtension g `elem` compiledExts = [g]
dropRedundantSourceVersion fs = fs
compiledExts = ["",".com",".exe"]
compiledExts = ["",".com",".exe"]
-- | Get all sorted unique filenames in the current user's PATH.
-- | Get all sorted unique filenames in the current user's PATH.
-- We do not currently filter out non-file objects or files without execute permission.
likelyExecutablesInPath :: IO [String]
likelyExecutablesInPath = do
@ -677,8 +677,8 @@ likelyExecutablesInPath = do
-- | Get the sorted unique filenames of all hledger-* executables in
-- the current user's PATH. These are files in any of the PATH directories,
-- named hledger-*, with either no extension (and no periods in the name)
-- or one of the addonExtensions.
-- named hledger-*, with either no extension (and no periods in the name)
-- or one of the addonExtensions.
-- We do not currently filter out non-file objects or files without execute permission.
hledgerExecutablesInPath :: IO [String]
hledgerExecutablesInPath = filter isHledgerExeName <$> likelyExecutablesInPath

12
hledger/Hledger/Cli/Commands/Accounts.hs
View File

@ -66,24 +66,24 @@ accounts CliOpts{rawopts_=rawopts, reportopts_=ropts} j = do
accts = dbg5 "accts to show" $ -- no need to nub/sort, accountTree will
if | declared && not used -> matcheddeclaredaccts
| not declared && used -> matchedusedaccts
| otherwise -> matcheddeclaredaccts ++ matchedusedaccts
| otherwise -> matcheddeclaredaccts ++ matchedusedaccts
-- 2. sort them by declaration order and name, at each level of their tree structure
sortedaccts = sortAccountNamesByDeclaration j tree accts
-- 3. if there's a depth limit, depth-clip and remove any no longer useful items
-- 3. if there's a depth limit, depth-clip and remove any no longer useful items
clippedaccts =
dbg1 "clippedaccts" $
filter (matchesAccount acctq) $ -- clipping can leave accounts that no longer match the query, remove such
nub $ -- clipping can leave duplicates (adjacent, hopefully)
filter (not . T.null) $ -- depth:0 can leave nulls
map (clipAccountName depth) $ -- clip at depth if specified
sortedaccts
map (clipAccountName depth) $ -- clip at depth if specified
sortedaccts
-- 4. print what remains as a list or tree, maybe applying --drop in the former case
-- 4. print what remains as a list or tree, maybe applying --drop in the former case
mapM_ (T.putStrLn . render) clippedaccts
where
render a
render a
| tree_ ropts = T.replicate (2 * (accountNameLevel a - 1)) " " <> accountLeafName a
| otherwise = accountNameDrop (drop_ ropts) a

2
hledger/Hledger/Cli/Commands/Activity.hs
View File

@ -2,7 +2,7 @@
{-|
Print a bar chart of posting activity per day, or other report interval.
Print a bar chart of posting activity per day, or other report interval.
-}

18
hledger/Hledger/Cli/Commands/Balance.hs
View File

@ -320,7 +320,7 @@ balance opts@CliOpts{rawopts_=rawopts,reportopts_=ropts@ReportOpts{..}} j = do
"html" -> const $ error' "Sorry, HTML output is not yet implemented for this kind of report." -- TODO
_ -> budgetReportAsText ropts
writeOutput opts $ render budgetreport
else
if multiperiod then do -- multi period balance report
let report = multiBalanceReport ropts (queryFromOpts d ropts) j
@ -337,7 +337,7 @@ balance opts@CliOpts{rawopts_=rawopts,reportopts_=ropts@ReportOpts{..}} j = do
| otherwise = ropts{accountlistmode_=ALTree}
in balanceReportFromMultiBalanceReport ropts' (queryFromOpts d ropts) j
-- for historical balances we must use balanceReportFromMultiBalanceReport (also forces --no-elide)
| otherwise = balanceReport ropts (queryFromOpts d ropts) j -- simple Ledger-style balance report
| otherwise = balanceReport ropts (queryFromOpts d ropts) j -- simple Ledger-style balance report
render = case format of
"csv" -> \ropts r -> (++ "\n") $ printCSV $ balanceReportAsCsv ropts r
"html" -> \_ _ -> error' "Sorry, HTML output is not yet implemented for this kind of report." -- TODO
@ -458,7 +458,7 @@ renderComponent1 opts (acctname, depth, total) (FormatField ljust min max field)
-- and will include the final totals row unless --no-total is set.
multiBalanceReportAsCsv :: ReportOpts -> MultiBalanceReport -> CSV
multiBalanceReportAsCsv opts@ReportOpts{average_, row_total_} (MultiBalanceReport (colspans, items, (coltotals,tot,avg))) =
maybetranspose $
maybetranspose $
("Account" : map showDateSpan colspans
++ ["Total" | row_total_]
++ ["Average" | average_]
@ -481,7 +481,7 @@ multiBalanceReportAsCsv opts@ReportOpts{average_, row_total_} (MultiBalanceRepor
where
maybetranspose | transpose_ opts = transpose
| otherwise = id
-- | Render a multi-column balance report as HTML.
multiBalanceReportAsHtml :: ReportOpts -> MultiBalanceReport -> Html ()
multiBalanceReportAsHtml ropts mbr =
@ -505,7 +505,7 @@ multiBalanceReportHtmlRows ropts mbr =
in
(multiBalanceReportHtmlHeadRow ropts headingsrow
,map (multiBalanceReportHtmlBodyRow ropts) bodyrows
,multiBalanceReportHtmlFootRow ropts <$> mtotalsrow -- TODO pad totals row with zeros when there are
,multiBalanceReportHtmlFootRow ropts <$> mtotalsrow -- TODO pad totals row with zeros when there are
)
-- | Render one MultiBalanceReport heading row as a HTML table row.
@ -548,8 +548,8 @@ multiBalanceReportHtmlBodyRow ropts (label:rest) =
multiBalanceReportHtmlFootRow :: ReportOpts -> [String] -> Html ()
multiBalanceReportHtmlFootRow _ropts [] = mempty
-- TODO pad totals row with zeros when subreport is empty
-- multiBalanceReportHtmlFootRow ropts $
-- ""
-- multiBalanceReportHtmlFootRow ropts $
-- ""
-- : repeat nullmixedamt zeros
-- ++ (if row_total_ ropts then [nullmixedamt] else [])
-- ++ (if average_ ropts then [nullmixedamt] else [])
@ -597,7 +597,7 @@ multiBalanceReportAsText ropts@ReportOpts{..} r =
balanceReportAsTable :: ReportOpts -> MultiBalanceReport -> Table String String MixedAmount
balanceReportAsTable opts@ReportOpts{average_, row_total_, balancetype_} (MultiBalanceReport (colspans, items, (coltotals,tot,avg))) =
maybetranspose $
addtotalrow $
addtotalrow $
Table
(T.Group NoLine $ map Header accts)
(T.Group NoLine $ map Header colheadings)
@ -625,7 +625,7 @@ balanceReportAsTable opts@ReportOpts{average_, row_total_, balancetype_} (MultiB
))
maybetranspose | transpose_ opts = \(Table rh ch vals) -> Table ch rh (transpose vals)
| otherwise = id
-- | Given a table representing a multi-column balance report (for example,
-- made using 'balanceReportAsTable'), render it in a format suitable for
-- console output.

2
hledger/Hledger/Cli/Commands/Checkdupes.hs
View File

@ -3,7 +3,7 @@
module Hledger.Cli.Commands.Checkdupes (
checkdupesmode
,checkdupes
)
)
where
import Data.Function

6
hledger/Hledger/Cli/Commands/Close.hs
View File

@ -4,7 +4,7 @@
module Hledger.Cli.Commands.Close (
closemode
,close
)
)
where
import Control.Monad (when)
@ -29,8 +29,8 @@ closemode = hledgerCommandMode
close CliOpts{rawopts_=rawopts, reportopts_=ropts} j = do
today <- getCurrentDay
let
(opening, closing) =
let
(opening, closing) =
case (boolopt "opening" rawopts, boolopt "closing" rawopts) of
(False, False) -> (True, True) -- by default show both opening and closing
(o, c) -> (o, c)

4
hledger/Hledger/Cli/Commands/Files.hs
View File

@ -34,7 +34,7 @@ files :: CliOpts -> Journal -> IO ()
files CliOpts{rawopts_=rawopts} j = do
let args = listofstringopt "args" rawopts
regex = headMay args
files = maybe id (filter . regexMatches) regex
$ map fst
files = maybe id (filter . regexMatches) regex
$ map fst
$ jfiles j
mapM_ putStrLn files

10
hledger/Hledger/Cli/Commands/Help.hs
View File

@ -46,10 +46,10 @@ helpmode = hledgerCommandMode
[]
([], Just $ argsFlag "[MANUAL]")
-- | List or display one of the hledger manuals in various formats.
-- | List or display one of the hledger manuals in various formats.
-- You can select a docs viewer with one of the `--info`, `--man`, `--pager`, `--cat` flags.
-- Otherwise it will use the first available of: info, man, $PAGER, less, stdout
-- (and always stdout if output is non-interactive).
-- (and always stdout if output is non-interactive).
help' :: CliOpts -> Journal -> IO ()
help' opts _ = do
exes <- likelyExecutablesInPath
@ -60,18 +60,18 @@ help' opts _ = do
topic = case args of
[pat] -> headMay [t | t <- docTopics, map toLower pat `isInfixOf` t]
_ -> Nothing
[info, man, pager, cat] =
[info, man, pager, cat] =
[runInfoForTopic, runManForTopic, runPagerForTopic pagerprog, printHelpForTopic]
viewer
| boolopt "info" $ rawopts_ opts = info
| boolopt "man" $ rawopts_ opts = man
| boolopt "pager" $ rawopts_ opts = pager
| boolopt "cat" $ rawopts_ opts = cat
| not interactive = cat
| not interactive = cat
| "info" `elem` exes = info
| "man" `elem` exes = man
| pagerprog `elem` exes = pager
| otherwise = cat
| otherwise = cat
case topic of
Nothing -> putStrLn $ unlines [
"Please choose a manual by typing \"hledger help MANUAL\" (any substring is ok)."

6
hledger/Hledger/Cli/Commands/Import.hs
View File

@ -4,7 +4,7 @@
module Hledger.Cli.Commands.Import (
importmode
,importcmd
)
)
where
import Control.Monad
@ -18,7 +18,7 @@ import Text.Printf
importmode = hledgerCommandMode
$(embedFileRelative "Hledger/Cli/Commands/Import.txt")
[flagNone ["dry-run"] (setboolopt "dry-run") "just show the transactions to be imported"]
[flagNone ["dry-run"] (setboolopt "dry-run") "just show the transactions to be imported"]
[generalflagsgroup1]
hiddenflags
([], Just $ argsFlag "FILE [...]")
@ -33,7 +33,7 @@ importcmd opts@CliOpts{rawopts_=rawopts,inputopts_=iopts} j = do
fs -> do
enewj <- readJournalFiles iopts' fs
case enewj of
Left e -> error' e
Left e -> error' e
Right newj ->
case sortOn tdate $ jtxns newj of
[] -> return ()

4
hledger/Hledger/Cli/Commands/Prices.hs
View File

@ -3,7 +3,7 @@
module Hledger.Cli.Commands.Prices (
pricesmode
,prices
)
)
where
import Data.Maybe
@ -22,7 +22,7 @@ pricesmode = hledgerCommandMode
hiddenflags
([], Just $ argsFlag "[QUERY]")
-- XXX the original hledger-prices script always ignored assertions
-- XXX the original hledger-prices script always ignored assertions
prices opts j = do
d <- getCurrentDay
let

6
hledger/Hledger/Cli/Commands/Print.hs
View File

@ -59,13 +59,13 @@ printEntries opts@CliOpts{reportopts_=ropts} j = do
writeOutput opts $ render $ entriesReport ropts' q j
entriesReportAsText :: CliOpts -> EntriesReport -> String
entriesReportAsText opts = concatMap (showTransactionUnelided . gettxn)
entriesReportAsText opts = concatMap (showTransactionUnelided . gettxn)
where
gettxn | useexplicittxn = id -- use fully inferred amounts & txn prices
gettxn | useexplicittxn = id -- use fully inferred amounts & txn prices
| otherwise = originalTransaction -- use original as-written amounts/txn prices
-- Original vs inferred transactions/postings were causing problems here, disabling -B (#551).
-- Use the explicit one if -B or -x are active.
-- This passes tests; does it also mean -B sometimes shows missing amounts unnecessarily ?
-- This passes tests; does it also mean -B sometimes shows missing amounts unnecessarily ?
useexplicittxn = boolopt "explicit" (rawopts_ opts) || (valuationTypeIsCost $ reportopts_ opts)
-- Replace this transaction's postings with the original postings if any, but keep the

2
hledger/Hledger/Cli/Commands/Printunique.hs
View File

@ -3,7 +3,7 @@
module Hledger.Cli.Commands.Printunique (
printuniquemode
,printunique
)
)
where
import Data.List

2
hledger/Hledger/Cli/Commands/Registermatch.hs
View File

@ -4,7 +4,7 @@
module Hledger.Cli.Commands.Registermatch (
registermatchmode
,registermatch
)
)
where
import Data.Char (toUpper)

6
hledger/Hledger/Cli/Commands/Rewrite.hs
View File

@ -5,7 +5,7 @@
module Hledger.Cli.Commands.Rewrite (
rewritemode
,rewrite
)
)
where
#if !(MIN_VERSION_base(4,11,0))
@ -36,7 +36,7 @@ rewritemode = hledgerCommandMode
-- TODO interpolating match groups in replacement
-- TODO allow using this on unbalanced entries, eg to rewrite while editing
rewrite opts@CliOpts{rawopts_=rawopts,reportopts_=ropts} j@Journal{jtxns=ts} = do
rewrite opts@CliOpts{rawopts_=rawopts,reportopts_=ropts} j@Journal{jtxns=ts} = do
-- rewrite matched transactions
let modifiers = transactionModifierFromOpts opts : jtxnmodifiers j
let j' = j{jtxns=modifyTransactions modifiers ts}
@ -46,7 +46,7 @@ rewrite opts@CliOpts{rawopts_=rawopts,reportopts_=ropts} j@Journal{jtxns=ts} = d
-- | Build a 'TransactionModifier' from any query arguments and --add-posting flags
-- provided on the command line, or throw a parse error.
transactionModifierFromOpts :: CliOpts -> TransactionModifier
transactionModifierFromOpts CliOpts{rawopts_=rawopts,reportopts_=ropts} =
transactionModifierFromOpts CliOpts{rawopts_=rawopts,reportopts_=ropts} =
TransactionModifier{tmquerytxt=q, tmpostingrules=ps}
where
q = T.pack $ query_ ropts

108
hledger/Hledger/Cli/Commands/Roi.hs
View File

@ -6,7 +6,7 @@ The @roi@ command prints internal rate of return and time-weighted rate of retur
-}
module Hledger.Cli.Commands.Roi (
module Hledger.Cli.Commands.Roi (
roimode
, roi
) where
@ -40,40 +40,40 @@ roimode = hledgerCommandMode
hiddenflags
([], Just $ argsFlag "[QUERY]")
-- One reporting span,
data OneSpan = OneSpan
-- One reporting span,
data OneSpan = OneSpan
Day -- start date, inclusive
Day -- end date, exclusive
Quantity -- value of investment at the beginning of day on spanBegin_
Quantity -- value of investment at the end of day on spanEnd_
[(Day,Quantity)] -- all deposits and withdrawals (but not changes of value) in the DateSpan [spanBegin_,spanEnd_)
deriving (Show)
roi :: CliOpts -> Journal -> IO ()
roi CliOpts{rawopts_=rawopts, reportopts_=ropts} j = do
d <- getCurrentDay
let
let
investmentsQuery = queryFromOpts d $ ropts{query_ = stringopt "investment" rawopts,period_=PeriodAll}
pnlQuery = queryFromOpts d $ ropts{query_ = stringopt "pnl" rawopts,period_=PeriodAll}
showCashFlow = boolopt "cashflow" rawopts
prettyTables = pretty_tables_ ropts
trans = dbg3 "investments" $ jtxns $ filterJournalTransactions investmentsQuery j
journalSpan =
let dates = map transactionDate2 trans in
DateSpan (Just $ minimum dates) (Just $ addDays 1 $ maximum dates)
journalSpan =
let dates = map transactionDate2 trans in
DateSpan (Just $ minimum dates) (Just $ addDays 1 $ maximum dates)
requestedSpan = periodAsDateSpan $ period_ ropts
requestedInterval = interval_ ropts
wholeSpan = spanDefaultsFrom requestedSpan journalSpan
wholeSpan = spanDefaultsFrom requestedSpan journalSpan
when (null trans) $ do
putStrLn "No relevant transactions found. Check your investments query"
exitFailure
let spans = case requestedInterval of
NoInterval -> [wholeSpan]
interval ->
@ -82,23 +82,23 @@ roi CliOpts{rawopts_=rawopts, reportopts_=ropts} j = do
tableBody <- forM spans $ \(DateSpan (Just spanBegin) (Just spanEnd)) -> do
-- Spans are [spanBegin,spanEnd), and spanEnd is 1 day after then actual end date we are interested in
let
let
valueBefore =
total trans (And [ investmentsQuery
, Date (DateSpan Nothing (Just spanBegin))])
valueAfter =
valueAfter =
total trans (And [investmentsQuery
, Date (DateSpan Nothing (Just spanEnd))])
cashFlow =
cashFlow =
calculateCashFlow trans (And [ Not investmentsQuery
, Not pnlQuery
, Date (DateSpan (Just spanBegin) (Just spanEnd)) ] )
thisSpan = dbg3 "processing span" $
thisSpan = dbg3 "processing span" $
OneSpan spanBegin spanEnd valueBefore valueAfter cashFlow
irr <- internalRateOfReturn showCashFlow prettyTables thisSpan
twr <- timeWeightedReturn showCashFlow prettyTables investmentsQuery trans thisSpan
let cashFlowAmt = negate $ sum $ map snd cashFlow
@ -112,28 +112,28 @@ roi CliOpts{rawopts_=rawopts, reportopts_=ropts} j = do
, printf "%0.2f%%" $ smallIsZero irr
, printf "%0.2f%%" $ smallIsZero twr ]
let table = Table
(Tbl.Group NoLine (map (Header . show) (take (length tableBody) [1..])))
(Tbl.Group DoubleLine
let table = Table
(Tbl.Group NoLine (map (Header . show) (take (length tableBody) [1..])))
(Tbl.Group DoubleLine
[ Tbl.Group SingleLine [Header "Begin", Header "End"]
, Tbl.Group SingleLine [Header "Value (begin)", Header "Cashflow", Header "Value (end)", Header "PnL"]
, Tbl.Group SingleLine [Header "IRR", Header "TWR"]])
tableBody
putStrLn $ Ascii.render prettyTables id id id table
timeWeightedReturn showCashFlow prettyTables investmentsQuery trans (OneSpan spanBegin spanEnd valueBefore valueAfter cashFlow) = do
let initialUnitPrice = 100
let initialUnits = valueBefore / initialUnitPrice
let cashflow =
let cashflow =
-- Aggregate all entries for a single day, assuming that intraday interest is negligible
map (\date_cash -> let (dates, cash) = unzip date_cash in (head dates, sum cash))
$ groupBy ((==) `on` fst)
$ sortOn fst
$ map (\(d,a) -> (d, negate a))
$ sortOn fst
$ map (\(d,a) -> (d, negate a))
$ filter ((/=0).snd) cashFlow
let units =
let units =
tail $
scanl
(\(_, _, _, unitBalance) (date, amt) ->
@ -146,14 +146,14 @@ timeWeightedReturn showCashFlow prettyTables investmentsQuery trans (OneSpan spa
in (valueOnDate, unitsBoughtOrSold, unitPrice, unitBalance + unitsBoughtOrSold))
(0, 0, 0, initialUnits)
cashflow
let finalUnitBalance = if null units then initialUnits else let (_,_,_,u) = last units in u
finalUnitPrice = valueAfter / finalUnitBalance
totalTWR = roundTo 2 $ (finalUnitPrice - initialUnitPrice)
years = fromIntegral (diffDays spanEnd spanBegin) / 365 :: Double
annualizedTWR = 100*((1+(realToFrac totalTWR/100))**(1/years)-1) :: Double
let s d = show $ roundTo 2 d
let s d = show $ roundTo 2 d
when showCashFlow $ do
printf "\nTWR cash flow for %s - %s\n" (showDate spanBegin) (showDate (addDays (-1) spanEnd))
let (dates', amounts') = unzip cashflow
@ -165,27 +165,27 @@ timeWeightedReturn showCashFlow prettyTables investmentsQuery trans (OneSpan spa
unitPrices = add initialUnitPrice unitPrices'
unitBalances = add initialUnits unitBalances'
valuesOnDate = add 0 valuesOnDate'
putStr $ Ascii.render prettyTables id id id
(Table
putStr $ Ascii.render prettyTables id id id
(Table
(Tbl.Group NoLine (map (Header . showDate) dates))
(Tbl.Group DoubleLine [ Tbl.Group SingleLine [Header "Portfolio value", Header "Unit balance"]
(Tbl.Group DoubleLine [ Tbl.Group SingleLine [Header "Portfolio value", Header "Unit balance"]
, Tbl.Group SingleLine [Header "Cash", Header "Unit price", Header "Units"]
, Tbl.Group SingleLine [Header "New Unit Balance"]])
[ [value, oldBalance, amt, prc, udelta, balance]
[ [value, oldBalance, amt, prc, udelta, balance]
| value <- map s valuesOnDate
| oldBalance <- map s (0:unitBalances)
| balance <- map s unitBalances
| amt <- map s amounts
| prc <- map s unitPrices
| udelta <- map s unitsBoughtOrSold ])
printf "Final unit price: %s/%s=%s U.\nTotal TWR: %s%%.\nPeriod: %.2f years.\nAnnualized TWR: %.2f%%\n\n" (s valueAfter) (s finalUnitBalance) (s finalUnitPrice) (s totalTWR) years annualizedTWR
return annualizedTWR
internalRateOfReturn showCashFlow prettyTables (OneSpan spanBegin spanEnd valueBefore valueAfter cashFlow) = do
printf "Final unit price: %s/%s=%s U.\nTotal TWR: %s%%.\nPeriod: %.2f years.\nAnnualized TWR: %.2f%%\n\n" (s valueAfter) (s finalUnitBalance) (s finalUnitPrice) (s totalTWR) years annualizedTWR
return annualizedTWR
internalRateOfReturn showCashFlow prettyTables (OneSpan spanBegin spanEnd valueBefore valueAfter cashFlow) = do
let prefix = (spanBegin, negate valueBefore)
postfix = (spanEnd, valueAfter)
@ -193,18 +193,18 @@ internalRateOfReturn showCashFlow prettyTables (OneSpan spanBegin spanEnd valueB
totalCF = filter ((/=0) . snd) $ prefix : (sortOn fst cashFlow) ++ [postfix]
when showCashFlow $ do
printf "\nIRR cash flow for %s - %s\n" (showDate spanBegin) (showDate (addDays (-1) spanEnd))
printf "\nIRR cash flow for %s - %s\n" (showDate spanBegin) (showDate (addDays (-1) spanEnd))
let (dates, amounts) = unzip totalCF
putStrLn $ Ascii.render prettyTables id id id
(Table
putStrLn $ Ascii.render prettyTables id id id
(Table
(Tbl.Group NoLine (map (Header . showDate) dates))
(Tbl.Group SingleLine [Header "Amount"])
(map ((:[]) . show) amounts))
-- 0% is always a solution, so require at least something here
case ridders
case ridders
#if MIN_VERSION_math_functions(0,3,0)
(RiddersParam 100 (AbsTol 0.00001))
(RiddersParam 100 (AbsTol 0.00001))
#else
0.00001
#endif
@ -227,9 +227,9 @@ calculateCashFlow trans query = map go trans
total :: [Transaction] -> Query -> Quantity
total trans query = unMix $ sumPostings $ filter (matchesPosting query) $ concatMap realPostings trans
unMix :: MixedAmount -> Quantity
unMix a =
unMix :: MixedAmount -> Quantity
unMix a =
case (normaliseMixedAmount $ costOfMixedAmount a) of
(Mixed [a]) -> aquantity a
_ -> error "MixedAmount failed to normalize"

12
hledger/Hledger/Cli/Commands/Tags.hs
View File

@ -4,7 +4,7 @@
module Hledger.Cli.Commands.Tags (
tagsmode
,tags
)
)
where
import Data.List
@ -15,7 +15,7 @@ import Hledger.Cli.CliOptions
tagsmode = hledgerCommandMode
$(embedFileRelative "Hledger/Cli/Commands/Tags.txt")
[] -- [flagNone ["strict"] (setboolopt "strict") "makes date comparing strict"] --
[] -- [flagNone ["strict"] (setboolopt "strict") "makes date comparing strict"] --
[generalflagsgroup1]
hiddenflags
([], Just $ argsFlag "[TAGREGEX [QUERY...]]")
@ -26,10 +26,10 @@ tags CliOpts{rawopts_=rawopts,reportopts_=ropts} j = do
args = listofstringopt "args" rawopts
mtagpats = headMay args
queryargs = drop 1 args
q = queryFromOpts d $ ropts{query_ = unwords queryargs}
q = queryFromOpts d $ ropts{query_ = unwords queryargs}
txns = filter (q `matchesTransaction`) $ jtxns $ journalSelectingAmountFromOpts ropts j
tags =
nub $ sort $
(maybe id (filter . regexMatchesCI) mtagpats) $
tags =
nub $ sort $
(maybe id (filter . regexMatchesCI) mtagpats) $
map (T.unpack . fst) $ concatMap transactionAllTags txns
mapM_ putStrLn tags

84
hledger/Hledger/Cli/CompoundBalanceCommand.hs
View File

@ -1,7 +1,7 @@
{-# LANGUAGE OverloadedStrings, RecordWildCards #-}
{-|
Common helpers for making multi-section balance report commands
Common helpers for making multi-section balance report commands
like balancesheet, cashflow, and incomestatement.
-}
@ -27,16 +27,16 @@ import Hledger.Cli.Commands.Balance
import Hledger.Cli.CliOptions
import Hledger.Cli.Utils (writeOutput)
-- | Description of a compound balance report command,
-- | Description of a compound balance report command,
-- from which we generate the command's cmdargs mode and IO action.
-- A compound balance report command shows one or more sections/subreports,
-- each with its own title and subtotals row, in a certain order,
-- A compound balance report command shows one or more sections/subreports,
-- each with its own title and subtotals row, in a certain order,
-- plus a grand totals row if there's more than one section.
-- Examples are the balancesheet, cashflow and incomestatement commands.
--
-- Compound balance reports do sign normalisation: they show all account balances
-- Compound balance reports do sign normalisation: they show all account balances
-- as normally positive, unlike the ordinary BalanceReport and most hledger commands
-- which show income/liability/equity balances as normally negative.
-- which show income/liability/equity balances as normally negative.
-- Each subreport specifies the normal sign of its amounts, and whether
-- it should be added to or subtracted from the grand total.
--
@ -44,7 +44,7 @@ data CompoundBalanceCommandSpec = CompoundBalanceCommandSpec {
cbcdoc :: CommandDoc, -- ^ the command's name(s) and documentation
cbctitle :: String, -- ^ overall report title
cbcqueries :: [CBCSubreportSpec], -- ^ subreport details
cbctype :: BalanceType -- ^ the "balance" type (change, cumulative, historical)
cbctype :: BalanceType -- ^ the "balance" type (change, cumulative, historical)
-- this report shows (overrides command line flags)
}
@ -62,15 +62,15 @@ data CBCSubreportSpec = CBCSubreportSpec {
--
-- * the period (date span) of each column
--
-- * one or more named, normal-positive multi balance reports,
-- * one or more named, normal-positive multi balance reports,
-- with columns corresponding to the above, and a flag indicating
-- whether they increased or decreased the overall totals
--
-- * a list of overall totals for each column, and their grand total and average
--
-- It is used in compound balance report commands like balancesheet,
-- It is used in compound balance report commands like balancesheet,
-- cashflow and incomestatement.
type CompoundBalanceReport =
type CompoundBalanceReport =
( String
, [DateSpan]
, [(String, MultiBalanceReport, Bool)]
@ -78,7 +78,7 @@ type CompoundBalanceReport =
)
-- | Generate a cmdargs option-parsing mode from a compound balance command
-- | Generate a cmdargs option-parsing mode from a compound balance command
-- specification.
compoundBalanceCommandMode :: CompoundBalanceCommandSpec -> Mode RawOpts
compoundBalanceCommandMode CompoundBalanceCommandSpec{..} =
@ -120,7 +120,7 @@ compoundBalanceCommand :: CompoundBalanceCommandSpec -> (CliOpts -> Journal -> I
compoundBalanceCommand CompoundBalanceCommandSpec{..} opts@CliOpts{reportopts_=ropts@ReportOpts{..}, rawopts_=rawopts} j = do
d <- getCurrentDay
let
-- use the default balance type for this report, unless the user overrides
-- use the default balance type for this report, unless the user overrides
mBalanceTypeOverride =
case reverse $ filter (`elem` ["change","cumulative","historical"]) $ map fst rawopts of
"historical":_ -> Just HistoricalBalance
@ -151,13 +151,13 @@ compoundBalanceCommand CompoundBalanceCommandSpec{..} opts@CliOpts{reportopts_=r
Nothing -> ""
-- Set balance type in the report options.
-- Also, use tree mode (by default, at least?) if --cumulative/--historical
-- are used in single column mode, since in that situation we will be using
-- Also, use tree mode (by default, at least?) if --cumulative/--historical
-- are used in single column mode, since in that situation we will be using
-- balanceReportFromMultiBalanceReport which does not support eliding boring parents,
-- and tree mode hides this.. or something.. XXX
-- and tree mode hides this.. or something.. XXX
ropts'
| not (flat_ ropts) &&
interval_==NoInterval &&
| not (flat_ ropts) &&
interval_==NoInterval &&
balancetype `elem` [CumulativeChange, HistoricalBalance]
= ropts{balancetype_=balancetype, accountlistmode_=ALTree}
| otherwise
@ -166,38 +166,38 @@ compoundBalanceCommand CompoundBalanceCommandSpec{..} opts@CliOpts{reportopts_=r
format = outputFormatFromOpts opts
-- make a CompoundBalanceReport
subreports =
map (\CBCSubreportSpec{..} ->
subreports =
map (\CBCSubreportSpec{..} ->
(cbcsubreporttitle
,mbrNormaliseSign cbcsubreportnormalsign $ -- <- convert normal-negative to normal-positive
compoundBalanceSubreport ropts' userq j cbcsubreportquery cbcsubreportnormalsign
,cbcsubreportincreasestotal
))
cbcqueries
subtotalrows =
[(coltotals, increasesoveralltotal)
subtotalrows =
[(coltotals, increasesoveralltotal)
| (_, MultiBalanceReport (_,_,(coltotals,_,_)), increasesoveralltotal) <- subreports
]
-- Sum the subreport totals by column. Handle these cases:
-- - no subreports
-- - empty subreports, having no subtotals (#588)
-- - subreports with a shorter subtotals row than the others
-- - subreports with a shorter subtotals row than the others
overalltotals = case subtotalrows of
[] -> ([], nullmixedamt, nullmixedamt)
rs ->
let
numcols = maximum $ map (length.fst) rs -- partial maximum is ok, rs is non-null
paddedsignedsubtotalrows =
paddedsignedsubtotalrows =
[map (if increasesoveralltotal then id else negate) $ -- maybe flip the signs
take numcols $ as ++ repeat nullmixedamt -- pad short rows with zeros
take numcols $ as ++ repeat nullmixedamt -- pad short rows with zeros
| (as,increasesoveralltotal) <- rs
]
coltotals = foldl' (zipWith (+)) zeros paddedsignedsubtotalrows -- sum the columns
where zeros = replicate numcols nullmixedamt
grandtotal = sum coltotals
grandavg | null coltotals = nullmixedamt
| otherwise = fromIntegral (length coltotals) `divideMixedAmount` grandtotal
in
| otherwise = fromIntegral (length coltotals) `divideMixedAmount` grandtotal
in
(coltotals, grandtotal, grandavg)
colspans =
case subreports of
@ -230,12 +230,12 @@ compoundBalanceSubreport ropts@ReportOpts{..} userq j subreportqfn subreportnorm
-- if user didn't specify --empty, now remove the all-zero rows, unless they have non-zero subaccounts
-- in this report
r' | empty_ = r
| otherwise = MultiBalanceReport (dates, rows', totals)
| otherwise = MultiBalanceReport (dates, rows', totals)
where
nonzeroaccounts =
dbg1 "nonzeroaccounts" $
catMaybes $ map (\(act,_,_,amts,_,_) ->
if not (all isZeroMixedAmount amts) then Just act else Nothing) rows
if not (all isZeroMixedAmount amts) then Just act else Nothing) rows
rows' = filter (not . emptyRow) rows
where
emptyRow (act,_,_,amts,_,_) =
@ -245,34 +245,34 @@ compoundBalanceSubreport ropts@ReportOpts{..} userq j subreportqfn subreportnorm
{- Eg:
Balance Sheet
|| 2017/12/31 Total Average
|| 2017/12/31 Total Average
=============++===============================
Assets ||
Assets ||
-------------++-------------------------------
assets:b || 1 1 1
assets:b || 1 1 1
-------------++-------------------------------
|| 1 1 1
|| 1 1 1
=============++===============================
Liabilities ||
Liabilities ||
-------------++-------------------------------
-------------++-------------------------------
||
||
=============++===============================
Total || 1 1 1
Total || 1 1 1
-}
compoundBalanceReportAsText :: ReportOpts -> CompoundBalanceReport -> String
compoundBalanceReportAsText ropts (title, _colspans, subreports, (coltotals, grandtotal, grandavg)) =
title ++ "\n\n" ++
title ++ "\n\n" ++
balanceReportTableAsText ropts bigtable'
where
singlesubreport = length subreports == 1
bigtable =
bigtable =
case map (subreportAsTable ropts singlesubreport) subreports of
[] -> T.empty
r:rs -> foldl' concatTables r rs
bigtable'
| no_total_ ropts || singlesubreport =
| no_total_ ropts || singlesubreport =
bigtable
| otherwise =
bigtable
@ -332,11 +332,11 @@ compoundBalanceReportAsCsv ropts (title, colspans, subreports, (coltotals, grand
(if row_total_ ropts then (1+) else id) $
(if average_ ropts then (1+) else id) $
maximum $ -- depends on non-null subreports
map (\(MultiBalanceReport (amtcolheadings, _, _)) -> length amtcolheadings) $
map (\(MultiBalanceReport (amtcolheadings, _, _)) -> length amtcolheadings) $
map second3 subreports
addtotals
| no_total_ ropts || length subreports == 1 = id
| otherwise = (++
| otherwise = (++
["Net:" :
map showMixedAmountOneLineWithoutPrice (
coltotals
@ -350,7 +350,7 @@ compoundBalanceReportAsHtml :: ReportOpts -> CompoundBalanceReport -> Html ()
compoundBalanceReportAsHtml ropts cbr =
let
(title, colspans, subreports, (coltotals, grandtotal, grandavg)) = cbr
colspanattr = colspan_ $ TS.pack $ show $
colspanattr = colspan_ $ TS.pack $ show $
1 + length colspans + (if row_total_ ropts then 1 else 0) + (if average_ ropts then 1 else 0)
leftattr = style_ "text-align:left"
blankrow = tr_ $ td_ [colspanattr] $ toHtmlRaw ("&nbsp;"::String)
@ -366,7 +366,7 @@ compoundBalanceReportAsHtml ropts cbr =
thRow :: [String] -> Html ()
thRow = tr_ . mconcat . map (th_ . toHtml)
-- Make rows for a subreport: its title row, not the headings row,
-- the data rows, any totals row, and a blank row for whitespace.
subreportrows :: (String, MultiBalanceReport, Bool) -> [Html ()]

8
hledger/Hledger/Cli/Utils.hs
View File

@ -60,7 +60,7 @@ import Hledger.Reports
import Hledger.Utils
-- | Parse the user's specified journal file(s) as a Journal, maybe apply some
-- transformations according to options, and run a hledger command with it.
-- transformations according to options, and run a hledger command with it.
-- Or, throw an error.
withJournalDo :: CliOpts -> (Journal -> IO a) -> IO a
withJournalDo opts cmd = do
@ -149,10 +149,10 @@ journalAddForecast opts@CliOpts{inputopts_=iopts, reportopts_=ropts} j = do
forecasttxns' = (if auto_ iopts then modifyTransactions (jtxnmodifiers j) else id) forecasttxns
return $
if forecast_ ropts
if forecast_ ropts
then journalBalanceTransactions' opts j{ jtxns = concat [jtxns j, forecasttxns'] }
else j
where
where
journalBalanceTransactions' opts j =
let assrt = not . ignore_assertions_ $ inputopts_ opts
in
@ -164,7 +164,7 @@ writeOutput :: CliOpts -> String -> IO ()
writeOutput opts s = do
f <- outputFileFromOpts opts
(if f == "-" then putStr else writeFile f) s
-- -- | Get a journal from the given string and options, or throw an error.
-- readJournal :: CliOpts -> String -> IO Journal
-- readJournal opts s = readJournal def Nothing s >>= either error' return