slaesvuo/hledger
1
0
Fork 0
Code Issues Pull Requests Actions Packages 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 ] | pkg <- packages ]
phony "commandhelp" $ need commandtxts phony "commandhelp" $ need commandtxts
commandtxts |%> \out -> do commandtxts |%> \out -> do
let src = out -<.> "md" let src = out -<.> "md"
need [src] need [src]
@ -695,7 +695,7 @@ main = do
-- tagrelease: \ -- tagrelease: \
-- $(call def-help,tagrelease, commit a release tag based on $(VERSIONFILE) for each package ) -- $(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 -- for p in $(PACKAGES); do git tag -f $$p-$(VERSION); done
-- MISC -- MISC
-- Generate the web manuals based on the current checkout and save -- Generate the web manuals based on the current checkout and save
@ -777,7 +777,7 @@ wikiLink :: Markdown -> Markdown
wikiLink = wikiLink =
replaceBy wikilinkre wikilinkReplace . replaceBy wikilinkre wikilinkReplace .
replaceBy labelledwikilinkre labelledwikilinkReplace replaceBy labelledwikilinkre labelledwikilinkReplace
-- regex stuff -- regex stuff
-- couldn't figure out how to use match subgroups, so we don't -- 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 [here| chart
Generate a pie chart for the top account balances with the same sign, Generate a pie chart for the top account balances with the same sign,
in SVG format. in SVG format.
Based on the old hledger-chart package, this is not yet useful. 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. 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 FLAGS
|] |]
[] []
[generalflagsgroup1] [generalflagsgroup1]
[] []
([], Just $ argsFlag "ACCT") ([], Just $ argsFlag "ACCT")
@ -64,7 +64,7 @@ main = do
q = queryFromOpts today ropts q = queryFromOpts today ropts
acct = T.pack $ headDef (error' "Please provide an account name argument") args acct = T.pack $ headDef (error' "Please provide an account name argument") args
pr = postingsReport ropts (And [Acct $ accountNameToAccountRegex acct, q]) j pr = postingsReport ropts (And [Acct $ accountNameToAccountRegex acct, q]) j
-- dates of postings to acct (in report) -- dates of postings to acct (in report)
pdates = map (postingDate . fourth5) (snd pr) pdates = map (postingDate . fourth5) (snd pr)
-- the specified report end date or today's date -- 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 in
acctsflattened acctsflattened
-- | Convert a list of account names to a tree of Account objects, -- | Convert a list of account names to a tree of Account objects,
-- with just the account names filled in. -- with just the account names filled in.
-- A single root account with the given name is added. -- A single root account with the given name is added.
accountTree :: AccountName -> [AccountName] -> Account accountTree :: AccountName -> [AccountName] -> Account
accountTree rootname as = nullacct{aname=rootname, asubs=map (uncurry accountTree') $ M.assocs m } 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) | otherwise = concatMap (filterAccounts p) (asubs a)
-- | Sort each group of siblings in an account tree by inclusive amount, -- | 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 -- The provided normal balance sign determines whether normal balances
-- are negative or positive, affecting the sort order. Ie, -- are negative or positive, affecting the sort order. Ie,
-- if balances are normally negative, then the most negative balances -- 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 -- | Sort account names by the order in which they were declared in
-- the journal, at each level of the account tree (ie within each -- the journal, at each level of the account tree (ie within each
-- group of siblings). Undeclared accounts are sorted last and -- group of siblings). Undeclared accounts are sorted last and
-- alphabetically. -- alphabetically.
-- This is hledger's default sort for reports organised by account. -- This is hledger's default sort for reports organised by account.
-- The account list is converted to a tree temporarily, adding any -- 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). -- or removed (suitable for a flat-mode report).
-- --
sortAccountNamesByDeclaration :: Journal -> Bool -> [AccountName] -> [AccountName] sortAccountNamesByDeclaration :: Journal -> Bool -> [AccountName] -> [AccountName]
@ -235,14 +235,14 @@ sortAccountNamesByDeclaration j keepparents as =
as as
-- | Sort each group of siblings in an account tree by declaration order, then account name. -- | Sort each group of siblings in an account tree by declaration order, then account name.
-- So each group will contain first the declared accounts, -- So each group will contain first the declared accounts,
-- in the same order as their account directives were parsed, -- in the same order as their account directives were parsed,
-- and then the undeclared accounts, sorted by account name. -- and then the undeclared accounts, sorted by account name.
sortAccountTreeByDeclaration :: Account -> Account sortAccountTreeByDeclaration :: Account -> Account
sortAccountTreeByDeclaration a sortAccountTreeByDeclaration a
| null $ asubs a = a | null $ asubs a = a
| otherwise = a{asubs= | otherwise = a{asubs=
sortOn accountDeclarationOrderAndName $ sortOn accountDeclarationOrderAndName $
map sortAccountTreeByDeclaration $ asubs a map sortAccountTreeByDeclaration $ asubs a
} }

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

@ -29,7 +29,7 @@ module Hledger.Data.AccountName (
,expandAccountName ,expandAccountName
,expandAccountNames ,expandAccountNames
,isAccountNamePrefixOf ,isAccountNamePrefixOf
-- ,isAccountRegex -- ,isAccountRegex
,isSubAccountNameOf ,isSubAccountNameOf
,parentAccountName ,parentAccountName
,parentAccountNames ,parentAccountNames
@ -50,7 +50,7 @@ import Data.Tree
import Text.Printf import Text.Printf
import Hledger.Data.Types import Hledger.Data.Types
import Hledger.Utils import Hledger.Utils
-- $setup -- $setup
-- >>> :set -XOverloadedStrings -- >>> :set -XOverloadedStrings
@ -88,13 +88,13 @@ accountNameLevel "" = 0
accountNameLevel a = T.length (T.filter (==acctsepchar) a) + 1 accountNameLevel a = T.length (T.filter (==acctsepchar) a) + 1
-- | A top-level account prefixed to some accounts in budget reports. -- | 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 :: T.Text
unbudgetedAccountName = "<unbudgeted>" unbudgetedAccountName = "<unbudgeted>"
-- | Remove some number of account name components from the front of the account name. -- | 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 -- 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 :: Int -> AccountName -> AccountName
accountNameDrop n a accountNameDrop n a
| a == unbudgetedAccountName = a | a == unbudgetedAccountName = a
@ -103,7 +103,7 @@ accountNameDrop n a
"" -> unbudgetedAccountName "" -> unbudgetedAccountName
a' -> unbudgetedAccountAndSep <> a' a' -> unbudgetedAccountAndSep <> a'
| otherwise = accountNameFromComponents $ drop n $ accountNameComponents a | otherwise = accountNameFromComponents $ drop n $ accountNameComponents a
where where
unbudgetedAccountAndSep = unbudgetedAccountName <> acctsep unbudgetedAccountAndSep = unbudgetedAccountName <> acctsep
-- | Sorted unique account names implied by these account names, -- | 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.Types
import Hledger.Data.Commodity import Hledger.Data.Commodity
import Hledger.Utils import Hledger.Utils
deriving instance Show MarketPrice deriving instance Show MarketPrice
@ -148,7 +148,7 @@ deriving instance Show MarketPrice
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
-- Amount styles -- Amount styles
-- | Default amount style -- | Default amount style
amountstyle = AmountStyle L False 0 (Just '.') Nothing 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. -- | Replace an 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.
-- Also increases the unit price's display precision to show one extra decimal place, -- 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. -- Does Decimal division, might be some rounding/irrational number issues.
amountTotalPriceToUnitPrice :: Amount -> Amount amountTotalPriceToUnitPrice :: Amount -> Amount
amountTotalPriceToUnitPrice amountTotalPriceToUnitPrice
a@Amount{aquantity=q, aprice=Just (TotalPrice pa@Amount{aquantity=pq, astyle=ps@AmountStyle{asprecision=pp}})} 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}}} = a{aprice = Just $ UnitPrice pa{aquantity=abs (pq/q), astyle=ps{asprecision=pp+1}}}
amountTotalPriceToUnitPrice a = a amountTotalPriceToUnitPrice a = a
@ -317,20 +317,20 @@ showAmountDebug Amount{..} = printf "Amount {acommodity=%s, aquantity=%s, aprice
showAmountWithoutPrice :: Amount -> String showAmountWithoutPrice :: Amount -> String
showAmountWithoutPrice a = showAmount a{aprice=Nothing} 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. -- the amount's quantity to some number of decimal places.
-- Rounding is done with Data.Decimal's default roundTo function: -- 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)". -- "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. -- 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 :: Int -> Amount -> Amount
setAmountInternalPrecision p a@Amount{ aquantity=q, astyle=s } = a{ setAmountInternalPrecision p a@Amount{ aquantity=q, astyle=s } = a{
astyle=s{asprecision=p} astyle=s{asprecision=p}
,aquantity=roundTo (fromIntegral p) q ,aquantity=roundTo (fromIntegral p) q
} }
-- | Set an amount's internal precision, flipped. -- | 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 :: Amount -> Int -> Amount
withInternalPrecision = flip setAmountInternalPrecision withInternalPrecision = flip setAmountInternalPrecision
@ -366,7 +366,7 @@ styleAmount :: M.Map CommoditySymbol AmountStyle -> Amount -> Amount
styleAmount styles a = styleAmount styles a =
case M.lookup (acommodity a) styles of case M.lookup (acommodity a) styles of
Just s -> a{astyle=s} Just s -> a{astyle=s}
Nothing -> a Nothing -> a
-- | Get the string representation of an amount, based on its -- | Get the string representation of an amount, based on its
-- commodity's display settings. String representations equivalent to -- commodity's display settings. String representations equivalent to
@ -375,7 +375,7 @@ styleAmount styles a =
showAmount :: Amount -> String showAmount :: Amount -> String
showAmount = showAmountHelper False 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. -- currently to hard-coded red.
cshowAmount :: Amount -> String cshowAmount :: Amount -> String
cshowAmount a = cshowAmount a =
@ -589,7 +589,7 @@ multiplyMixedAmountAndPrice n = mapMixedAmount (multiplyAmountAndPrice n)
-- | Calculate the average of some mixed amounts. -- | Calculate the average of some mixed amounts.
averageMixedAmounts :: [MixedAmount] -> MixedAmount averageMixedAmounts :: [MixedAmount] -> MixedAmount
averageMixedAmounts [] = 0 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 ? -- | Is this mixed amount negative, if it can be normalised to a single commodity ?
isNegativeMixedAmount :: MixedAmount -> Maybe Bool 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. -- | Given a map of standard amount display styles, apply the appropriate ones to each individual amount.
styleMixedAmount :: M.Map CommoditySymbol AmountStyle -> MixedAmount -> MixedAmount 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 -- | Get the string representation of a mixed amount, after
-- normalising it to one amount per commodity. Assumes amounts have -- 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 canonicaliseMixedAmount styles (Mixed as) = Mixed $ map (canonicaliseAmount styles) as
-- | Replace each component amount's TotalPrice, if it has one, with an equivalent UnitPrice. -- | 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. -- Does Decimal division, might be some rounding/irrational number issues.
mixedAmountTotalPriceToUnitPrice :: MixedAmount -> MixedAmount mixedAmountTotalPriceToUnitPrice :: MixedAmount -> MixedAmount
mixedAmountTotalPriceToUnitPrice (Mixed as) = Mixed $ map amountTotalPriceToUnitPrice as 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
,costOfAmount (eur (-1)){aprice=Just $ TotalPrice $ usd 2} `is` usd (-2) ,costOfAmount (eur (-1)){aprice=Just $ TotalPrice $ usd 2} `is` usd (-2)
] ]
,tests "isZeroAmount" [ ,tests "isZeroAmount" [
expect $ isZeroAmount amount expect $ isZeroAmount amount
,expect $ isZeroAmount $ usd 0 ,expect $ isZeroAmount $ usd 0
] ]
,tests "negating amounts" [ ,tests "negating amounts" [
negate (usd 1) `is` (usd 1){aquantity= -1} negate (usd 1) `is` (usd 1){aquantity= -1}
,let b = (usd 1){aprice=Just $ UnitPrice $ eur 2} in negate b `is` b{aquantity= -1} ,let b = (usd 1){aprice=Just $ UnitPrice $ eur 2} in negate b `is` b{aquantity= -1}
] ]
,tests "adding amounts without prices" [ ,tests "adding amounts without prices" [
(usd 1.23 + usd (-1.23)) `is` usd 0 (usd 1.23 + usd (-1.23)) `is` usd 0
,(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 -- adding different commodities assumes conversion rate 1
,expect $ isZeroAmount (usd 1.23 - eur 1.23) ,expect $ isZeroAmount (usd 1.23 - eur 1.23)
] ]
,tests "showAmount" [ ,tests "showAmount" [
showAmount (usd 0 + gbp 0) `is` "0" showAmount (usd 0 + gbp 0) `is` "0"
] ]
@ -770,7 +770,7 @@ tests_Amount = tests "Amount" [
]) ])
`is` Mixed [usd 0 `withPrecision` 3] `is` Mixed [usd 0 `withPrecision` 3]
] ]
,tests "adding mixed amounts with total prices" [ ,tests "adding mixed amounts with total prices" [
sum (map (Mixed . (:[])) sum (map (Mixed . (:[]))
[usd 1 @@ eur 1 [usd 1 @@ eur 1
@ -780,7 +780,7 @@ tests_Amount = tests "Amount" [
,usd (-2) @@ eur 1 ,usd (-2) @@ eur 1
] ]
] ]
,tests "showMixedAmount" [ ,tests "showMixedAmount" [
showMixedAmount (Mixed [usd 1]) `is` "$1.00" showMixedAmount (Mixed [usd 1]) `is` "$1.00"
,showMixedAmount (Mixed [usd 1 `at` eur 2]) `is` "$1.00 @ €2.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 (Mixed []) `is` "0"
,showMixedAmount missingmixedamt `is` "" ,showMixedAmount missingmixedamt `is` ""
] ]
,tests "showMixedAmountWithoutPrice" $ ,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]) `is` "$1.00"
,showMixedAmountWithoutPrice (Mixed [a, -a]) `is` "0" ,showMixedAmountWithoutPrice (Mixed [a, -a]) `is` "0"
] ]
,tests "normaliseMixedAmount" [ ,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 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] 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] 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] 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" $ ,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] normaliseMixedAmount (Mixed [usd 1 @@ eur 1, usd 1 @@ eur 1]) `is` Mixed [usd 1 @@ eur 1, usd 1 @@ eur 1]
] ]
,tests "normaliseMixedAmountSquashPricesForDisplay" [ ,tests "normaliseMixedAmountSquashPricesForDisplay" [
normaliseMixedAmountSquashPricesForDisplay (Mixed []) `is` Mixed [nullamt] normaliseMixedAmountSquashPricesForDisplay (Mixed []) `is` Mixed [nullamt]
,expect $ isZeroMixedAmount $ normaliseMixedAmountSquashPricesForDisplay ,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 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 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. -- If the original span is empty, eg if the end date is <= the start date, no spans are returned.
-- --
-- --
-- ==== Examples: -- ==== Examples:
-- >>> let t i d1 d2 = splitSpan i $ mkdatespan d1 d2 -- >>> 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 -- Examples: lets take 2017-11-22. Year-long intervals covering it that
-- starts before Nov 22 will start in 2017. However -- starts before Nov 22 will start in 2017. However
-- intervals that start after Nov 23rd should start in 2016: -- 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 -- >>> nthdayofyearcontaining 11 21 wed22nd
-- 2017-11-21 -- 2017-11-21
-- >>> nthdayofyearcontaining 11 22 wed22nd -- >>> nthdayofyearcontaining 11 22 wed22nd
-- 2017-11-22 -- 2017-11-22
-- >>> nthdayofyearcontaining 11 23 wed22nd -- >>> nthdayofyearcontaining 11 23 wed22nd
-- 2016-11-23 -- 2016-11-23
-- >>> nthdayofyearcontaining 12 02 wed22nd -- >>> nthdayofyearcontaining 12 02 wed22nd
-- 2016-12-02 -- 2016-12-02
-- >>> nthdayofyearcontaining 12 31 wed22nd -- >>> nthdayofyearcontaining 12 31 wed22nd
-- 2016-12-31 -- 2016-12-31
-- >>> nthdayofyearcontaining 1 1 wed22nd -- >>> nthdayofyearcontaining 1 1 wed22nd
-- 2017-01-01 -- 2017-01-01
nthdayofyearcontaining :: Month -> MonthDay -> Day -> Day nthdayofyearcontaining :: Month -> MonthDay -> Day -> Day
nthdayofyearcontaining m md date nthdayofyearcontaining m md date
| not (validMonth $ show m) = error' $ "nthdayofyearcontaining: invalid month "++show m | not (validMonth $ show m) = error' $ "nthdayofyearcontaining: invalid month "++show m
@ -555,23 +555,23 @@ nthdayofyearcontaining m md date
s = startofyear date s = startofyear date
-- | For given date d find month-long interval that starts on nth day of month -- | 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. -- 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 -- Examples: lets take 2017-11-22. Month-long intervals covering it that
-- start on 1st-22nd of month will start in Nov. However -- start on 1st-22nd of month will start in Nov. However
-- intervals that start on 23rd-30th of month should start in Oct: -- 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 -- >>> nthdayofmonthcontaining 1 wed22nd
-- 2017-11-01 -- 2017-11-01
-- >>> nthdayofmonthcontaining 12 wed22nd -- >>> nthdayofmonthcontaining 12 wed22nd
-- 2017-11-12 -- 2017-11-12
-- >>> nthdayofmonthcontaining 22 wed22nd -- >>> nthdayofmonthcontaining 22 wed22nd
-- 2017-11-22 -- 2017-11-22
-- >>> nthdayofmonthcontaining 23 wed22nd -- >>> nthdayofmonthcontaining 23 wed22nd
-- 2017-10-23 -- 2017-10-23
-- >>> nthdayofmonthcontaining 30 wed22nd -- >>> nthdayofmonthcontaining 30 wed22nd
-- 2017-10-30 -- 2017-10-30
nthdayofmonthcontaining :: MonthDay -> Day -> Day nthdayofmonthcontaining :: MonthDay -> Day -> Day
nthdayofmonthcontaining md date nthdayofmonthcontaining md date
| not (validDay $ show md) = error' $ "nthdayofmonthcontaining: invalid day " ++show md | not (validDay $ show md) = error' $ "nthdayofmonthcontaining: invalid day " ++show md
@ -582,22 +582,22 @@ nthdayofmonthcontaining md date
s = startofmonth date s = startofmonth date
-- | For given date d find week-long interval that starts on nth day of week -- | 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 -- 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 -- 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: -- intervals that start on Thu or Fri should start in prev week:
-- >>> let wed22nd = parsedate "2017-11-22" -- >>> let wed22nd = parsedate "2017-11-22"
-- >>> nthdayofweekcontaining 1 wed22nd -- >>> nthdayofweekcontaining 1 wed22nd
-- 2017-11-20 -- 2017-11-20
-- >>> nthdayofweekcontaining 2 wed22nd -- >>> nthdayofweekcontaining 2 wed22nd
-- 2017-11-21 -- 2017-11-21
-- >>> nthdayofweekcontaining 3 wed22nd -- >>> nthdayofweekcontaining 3 wed22nd
-- 2017-11-22 -- 2017-11-22
-- >>> nthdayofweekcontaining 4 wed22nd -- >>> nthdayofweekcontaining 4 wed22nd
-- 2017-11-16 -- 2017-11-16
-- >>> nthdayofweekcontaining 5 wed22nd -- >>> nthdayofweekcontaining 5 wed22nd
-- 2017-11-17 -- 2017-11-17
nthdayofweekcontaining :: WeekDay -> Day -> Day nthdayofweekcontaining :: WeekDay -> Day -> Day
nthdayofweekcontaining n d | nthOfSameWeek <= d = nthOfSameWeek nthdayofweekcontaining n d | nthOfSameWeek <= d = nthOfSameWeek
| otherwise = nthOfPrevWeek | otherwise = nthOfPrevWeek
@ -606,12 +606,12 @@ nthdayofweekcontaining n d | nthOfSameWeek <= d = nthOfSameWeek
s = startofweek d s = startofweek d
-- | For given date d find month-long interval that starts on nth weekday of month -- | 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 -- 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 -- start on 1st-4th Wed will start in Nov. However
-- intervals that start on 4th Thu or Fri or later should start in Oct: -- intervals that start on 4th Thu or Fri or later should start in Oct:
-- >>> let wed22nd = parsedate "2017-11-22" -- >>> let wed22nd = parsedate "2017-11-22"
-- >>> nthweekdayofmonthcontaining 1 3 wed22nd -- >>> nthweekdayofmonthcontaining 1 3 wed22nd
-- 2017-11-01 -- 2017-11-01
-- >>> nthweekdayofmonthcontaining 3 2 wed22nd -- >>> 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 -- | Advance to nth weekday wd after given start day s
advancetonthweekday :: Int -> WeekDay -> Day -> Day 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 maybe err (addWeeks (n-1)) $ firstMatch (>=s) $ iterate (addWeeks 1) $ firstweekday s
where where
err = error' "advancetonthweekday: should not happen" err = error' "advancetonthweekday: should not happen"
addWeeks k = addDays (7 * fromIntegral k) addWeeks k = addDays (7 * fromIntegral k)
firstMatch p = headMay . dropWhile (not . p) firstMatch p = headMay . dropWhile (not . p)
firstweekday = addDays (fromIntegral wd-1) . startofweek firstweekday = addDays (fromIntegral wd-1) . startofweek
---------------------------------------------------------------------- ----------------------------------------------------------------------
@ -834,7 +834,7 @@ md = do
failIfInvalidDay d failIfInvalidDay d
return ("",m,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", months = ["january","february","march","april","may","june",
"july","august","september","october","november","december"] "july","august","september","october","november","december"]
monthabbrevs = ["jan","feb","mar","apr","may","jun","jul","aug","sep","oct","nov","dec"] 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) wday <- T.toLower <$> (choice . map string' $ weekdays ++ weekdayabbrevs)
case catMaybes $ [wday `elemIndex` weekdays, wday `elemIndex` weekdayabbrevs] of case catMaybes $ [wday `elemIndex` weekdays, wday `elemIndex` weekdayabbrevs] of
(i:_) -> return (i+1) (i:_) -> return (i+1)
[] -> fail $ "weekday: should not happen: attempted to find " <> [] -> fail $ "weekday: should not happen: attempted to find " <>
show wday <> " in " <> show (weekdays ++ weekdayabbrevs) show wday <> " in " <> show (weekdays ++ weekdayabbrevs)
today,yesterday,tomorrow :: TextParser m SmartDate today,yesterday,tomorrow :: TextParser m SmartDate
today = string' "today" >> return ("","","today") today = string' "today" >> return ("","","today")
@ -909,7 +909,7 @@ lastthisnextthing = do
-- >>> p "every 2nd day" -- >>> p "every 2nd day"
-- Right (DayOfMonth 2,DateSpan -) -- Right (DayOfMonth 2,DateSpan -)
-- >>> p "every 2nd day 2009-" -- >>> p "every 2nd day 2009-"
-- Right (DayOfMonth 2,DateSpan 2009/01/01-) -- Right (DayOfMonth 2,DateSpan 2009/01/01-)
-- >>> p "every 29th Nov" -- >>> p "every 29th Nov"
-- Right (DayOfYear 11 29,DateSpan -) -- Right (DayOfYear 11 29,DateSpan -)
-- >>> p "every 29th nov -2009" -- >>> p "every 29th nov -2009"
@ -1007,9 +1007,9 @@ reportingintervalp = choice' [
string' "of" string' "of"
skipMany spacenonewline skipMany spacenonewline
string' period string' period
optOf_ period = optional $ try $ of_ period optOf_ period = optional $ try $ of_ period
nth = do n <- some digitChar nth = do n <- some digitChar
choice' $ map string' ["st","nd","rd","th"] choice' $ map string' ["st","nd","rd","th"]
return $ read n 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 System.Time (ClockTime(TOD))
import Text.Printf import Text.Printf
import Hledger.Utils import Hledger.Utils
import Hledger.Data.Types import Hledger.Data.Types
import Hledger.Data.AccountName import Hledger.Data.AccountName
import Hledger.Data.Amount import Hledger.Data.Amount
@ -160,12 +160,12 @@ instance Show Journal where
-- ] -- ]
-- The monoid instance for Journal is useful for two situations. -- The monoid instance for Journal is useful for two situations.
-- --
-- 1. concatenating finalised journals, eg with multiple -f options: -- 1. concatenating finalised journals, eg with multiple -f options:
-- FIRST <> SECOND. The second's list fields are appended to the -- FIRST <> SECOND. The second's list fields are appended to the
-- first's, map fields are combined, transaction counts are summed, -- first's, map fields are combined, transaction counts are summed,
-- the parse state of the second is kept. -- the parse state of the second is kept.
-- --
-- 2. merging a child parsed journal, eg with the include directive: -- 2. merging a child parsed journal, eg with the include directive:
-- CHILD <> PARENT. A parsed journal's data is in reverse order, so -- CHILD <> PARENT. A parsed journal's data is in reverse order, so
-- this gives what we want. -- this gives what we want.
@ -268,7 +268,7 @@ journalPostings = concatMap tpostings . jtxns
journalAccountNamesUsed :: Journal -> [AccountName] journalAccountNamesUsed :: Journal -> [AccountName]
journalAccountNamesUsed = accountNamesFromPostings . journalPostings 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. -- accounts posted to and all their implied parent accounts.
journalAccountNamesImplied :: Journal -> [AccountName] journalAccountNamesImplied :: Journal -> [AccountName]
journalAccountNamesImplied = expandAccountNames . journalAccountNamesUsed journalAccountNamesImplied = expandAccountNames . journalAccountNamesUsed
@ -289,31 +289,31 @@ journalAccountNamesDeclaredOrImplied j = nub $ sort $ journalAccountNamesDeclare
-- | Convenience/compatibility alias for journalAccountNamesDeclaredOrImplied. -- | Convenience/compatibility alias for journalAccountNamesDeclaredOrImplied.
journalAccountNames :: Journal -> [AccountName] journalAccountNames :: Journal -> [AccountName]
journalAccountNames = journalAccountNamesDeclaredOrImplied journalAccountNames = journalAccountNamesDeclaredOrImplied
journalAccountNameTree :: Journal -> Tree AccountName journalAccountNameTree :: Journal -> Tree AccountName
journalAccountNameTree = accountNameTreeFrom . journalAccountNames journalAccountNameTree = accountNameTreeFrom . journalAccountNames
-- queries for standard account types -- queries for standard account types
-- | Get a query for accounts of a certain type (Asset, Liability..) in this journal. -- | 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, -- 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. -- 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 -- If no accounts were declared as this type, the query will instead match accounts
-- with names matched by the provided case-insensitive regular expression. -- with names matched by the provided case-insensitive regular expression.
journalAccountTypeQuery :: AccountType -> Regexp -> Journal -> Query journalAccountTypeQuery :: AccountType -> Regexp -> Journal -> Query
journalAccountTypeQuery atype fallbackregex j = journalAccountTypeQuery atype fallbackregex j =
case M.lookup atype (jdeclaredaccounttypes j) of case M.lookup atype (jdeclaredaccounttypes j) of
Nothing -> Acct fallbackregex Nothing -> Acct fallbackregex
Just as -> 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. -- So we do a hacky search by name instead.
And [ And [
Or $ map (Acct . accountNameToAccountRegex) as Or $ map (Acct . accountNameToAccountRegex) as
,Not $ Or $ map (Acct . accountNameToAccountRegex) differentlytypedsubs ,Not $ Or $ map (Acct . accountNameToAccountRegex) differentlytypedsubs
] ]
where where
differentlytypedsubs = concat differentlytypedsubs = concat
[subs | (t,bs) <- M.toList (jdeclaredaccounttypes j) [subs | (t,bs) <- M.toList (jdeclaredaccounttypes j)
, t /= atype , t /= atype
, let subs = [b | b <- bs, any (`isAccountNamePrefixOf` b) as] , 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 -- | A query for accounts in this journal which have been
-- declared as Asset by account directives, or otherwise for -- 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?(:|$)@. -- @^assets?(:|$)@.
journalAssetAccountQuery :: Journal -> Query journalAssetAccountQuery :: Journal -> Query
journalAssetAccountQuery = journalAccountTypeQuery Asset "^assets?(:|$)" journalAssetAccountQuery = journalAccountTypeQuery Asset "^assets?(:|$)"
-- | A query for accounts in this journal which have been -- | A query for accounts in this journal which have been
-- declared as Liability by account directives, or otherwise for -- 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))(:|$)@. -- @^(debts?|liabilit(y|ies))(:|$)@.
journalLiabilityAccountQuery :: Journal -> Query journalLiabilityAccountQuery :: Journal -> Query
journalLiabilityAccountQuery = journalAccountTypeQuery Liability "^(debts?|liabilit(y|ies))(:|$)" journalLiabilityAccountQuery = journalAccountTypeQuery Liability "^(debts?|liabilit(y|ies))(:|$)"
-- | A query for accounts in this journal which have been -- | A query for accounts in this journal which have been
-- declared as Equity by account directives, or otherwise for -- 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(:|$)@. -- @^equity(:|$)@.
journalEquityAccountQuery :: Journal -> Query journalEquityAccountQuery :: Journal -> Query
journalEquityAccountQuery = journalAccountTypeQuery Equity "^equity(:|$)" journalEquityAccountQuery = journalAccountTypeQuery Equity "^equity(:|$)"
-- | A query for accounts in this journal which have been -- | A query for accounts in this journal which have been
-- declared as Revenue by account directives, or otherwise for -- 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?(:|$)@. -- @^(income|revenue)s?(:|$)@.
journalRevenueAccountQuery :: Journal -> Query journalRevenueAccountQuery :: Journal -> Query
journalRevenueAccountQuery = journalAccountTypeQuery Revenue "^(income|revenue)s?(:|$)" journalRevenueAccountQuery = journalAccountTypeQuery Revenue "^(income|revenue)s?(:|$)"
-- | A query for accounts in this journal which have been -- | A query for accounts in this journal which have been
-- declared as Expense by account directives, or otherwise for -- 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?(:|$)@. -- @^(income|revenue)s?(:|$)@.
journalExpenseAccountQuery :: Journal -> Query journalExpenseAccountQuery :: Journal -> Query
journalExpenseAccountQuery = journalAccountTypeQuery Expense "^expenses?(:|$)" journalExpenseAccountQuery = journalAccountTypeQuery Expense "^expenses?(:|$)"
@ -371,7 +371,7 @@ journalProfitAndLossAccountQuery j = Or [journalRevenueAccountQuery j
-- | A query for Cash (-equivalent) accounts in this journal (ie, -- | A query for Cash (-equivalent) accounts in this journal (ie,
-- accounts which appear on the cashflow statement.) This is currently -- 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)@. -- containing the case-insensitive regular expression @(receivable|:A/R|:fixed)@.
journalCashAccountQuery :: Journal -> Query journalCashAccountQuery :: Journal -> Query
journalCashAccountQuery j = And [journalAssetAccountQuery j, Not $ Acct "(receivable|:A/R|:fixed)"] 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 :: Transaction -> Transaction
journalUntieTransactions t@Transaction{tpostings=ps} = t{tpostings=map (\p -> p{ptransaction=Nothing}) ps} 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). -- (adding automated postings to transactions, eg).
journalModifyTransactions :: Journal -> Journal journalModifyTransactions :: Journal -> Journal
journalModifyTransactions j = j{ jtxns = modifyTransactions (jtxnmodifiers j) (jtxns j) } 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 -- "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. -- a sequence of transactions.
-- Perhaps can be simplified, or would a different ordering of layers make sense ? -- Perhaps can be simplified, or would a different ordering of layers make sense ?
-- If you see a way, let us know. -- 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 :: (BalancingState s -> ST s a) -> Balancing s a
withB f = ask >>= lift . lift . f 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 :: AccountName -> Balancing s MixedAmount
getAmountB acc = withB $ \BalancingState{bsBalances} -> do getAmountB acc = withB $ \BalancingState{bsBalances} -> do
fromMaybe 0 <$> H.lookup bsBalances acc fromMaybe 0 <$> H.lookup bsBalances acc
-- | Add an amount to an account's running balance, and return the new running balance. -- | 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 H.insert bsBalances acc new
return 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 :: AccountName -> MixedAmount -> Balancing s MixedAmount
setAmountB acc amt = withB $ \BalancingState{bsBalances} -> do setAmountB acc amt = withB $ \BalancingState{bsBalances} -> do
old <- fromMaybe 0 <$> H.lookup bsBalances acc old <- fromMaybe 0 <$> H.lookup bsBalances acc
@ -639,15 +639,15 @@ storeTransactionB t = withB $ \BalancingState{bsTransactions} ->
void $ writeArray bsTransactions (tindex t) t void $ writeArray bsTransactions (tindex t) t
-- | Infer any missing amounts (to satisfy balance assignments and -- | 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 -- and (optional) all balance assertions pass. Or return an error message
-- (just the first error encountered). -- (just the first error encountered).
-- --
-- Assumes journalInferCommodityStyles has been called, since those affect transaction balancing. -- 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. -- balance assertions and posting dates are interdependent.
-- --
-- This can be simplified further. Overview as of 20190219: -- This can be simplified further. Overview as of 20190219:
-- @ -- @
-- ****** parseAndFinaliseJournal['] (Cli/Utils.hs), journalAddForecast (Common.hs), budgetJournal (BudgetReport.hs), tests (BalanceReport.hs) -- ****** 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 :: Bool -> Journal -> Either String Journal
journalBalanceTransactions assrt j' = journalBalanceTransactions assrt j' =
let 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' j@Journal{jtxns=ts} = journalNumberTransactions j'
-- display precisions used in balanced checking -- display precisions used in balanced checking
styles = Just $ journalCommodityStyles j styles = Just $ journalCommodityStyles j
-- balance assignments will not be allowed on these -- balance assignments will not be allowed on these
txnmodifieraccts = S.fromList $ map paccount $ concatMap tmpostingrules $ jtxnmodifiers j txnmodifieraccts = S.fromList $ map paccount $ concatMap tmpostingrules $ jtxnmodifiers j
in in
runST $ do runST $ do
-- We'll update a mutable array of transactions as we balance them, -- We'll update a mutable array of transactions as we balance them,
-- not strictly necessary but avoids a sort at the end I think. -- not strictly necessary but avoids a sort at the end I think.
balancedtxns <- newListArray (1, genericLength ts) ts 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: -- and check balance assertions. This is done in two passes:
runExceptT $ do runExceptT $ do
@ -691,14 +691,14 @@ journalBalanceTransactions assrt j' =
-- The postings and not-yet-balanced transactions remain in the same relative order. -- The postings and not-yet-balanced transactions remain in the same relative order.
psandts :: [Either Posting Transaction] <- fmap concat $ forM ts $ \case psandts :: [Either Posting Transaction] <- fmap concat $ forM ts $ \case
t | null $ assignmentPostings t -> case balanceTransaction styles t of t | null $ assignmentPostings t -> case balanceTransaction styles t of
Left e -> throwError e Left e -> throwError e
Right t' -> do Right t' -> do
lift $ writeArray balancedtxns (tindex t') t' lift $ writeArray balancedtxns (tindex t') t'
return $ map Left $ tpostings t' return $ map Left $ tpostings t'
t -> return [Right t] t -> return [Right t]
-- 2. Sort these items by date, preserving the order of same-day items, -- 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) runningbals <- lift $ H.newSized (length $ journalAccountNamesUsed j)
flip runReaderT (BalancingState styles txnmodifieraccts assrt runningbals balancedtxns) $ do flip runReaderT (BalancingState styles txnmodifieraccts assrt runningbals balancedtxns) $ do
-- performing balance assignments in, and balancing, the remaining transactions, -- performing balance assignments in, and balancing, the remaining transactions,
@ -706,17 +706,17 @@ journalBalanceTransactions assrt j' =
void $ mapM' balanceTransactionAndCheckAssertionsB $ sortOn (either postingDate tdate) psandts void $ mapM' balanceTransactionAndCheckAssertionsB $ sortOn (either postingDate tdate) psandts
ts' <- lift $ getElems balancedtxns 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 -- | This function is called statefully on each of a date-ordered sequence of
-- 1. fully explicit postings from already-balanced transactions and -- 1. fully explicit postings from already-balanced transactions and
-- 2. not-yet-balanced transactions containing balance assignments. -- 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. -- 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). -- 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. -- 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 :: Either Posting Transaction -> Balancing s ()
balanceTransactionAndCheckAssertionsB (Left p@Posting{}) = balanceTransactionAndCheckAssertionsB (Left p@Posting{}) =
@ -726,28 +726,28 @@ balanceTransactionAndCheckAssertionsB (Left p@Posting{}) =
balanceTransactionAndCheckAssertionsB (Right t@Transaction{tpostings=ps}) = do balanceTransactionAndCheckAssertionsB (Right t@Transaction{tpostings=ps}) = do
-- make sure we can handle the balance assignments -- make sure we can handle the balance assignments
mapM_ checkIllegalBalanceAssignmentB ps 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 -- update the account's running balance and check the balance assertion if any
ps' <- forM ps $ \p -> pure (removePrices p) >>= addOrAssignAmountAndCheckAssertionB 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 styles <- R.reader bsStyles
case balanceTransactionHelper styles t{tpostings=ps'} of case balanceTransactionHelper styles t{tpostings=ps'} of
Left err -> throwError err Left err -> throwError err
Right (t', inferredacctsandamts) -> do 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 mapM_ (uncurry addAmountB) inferredacctsandamts
-- and save the balanced transaction. -- 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 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. -- reset the running balance to, the assigned balance.
-- If it has a missing amount and no balance assignment, leave it for later. -- If it has a missing amount and no balance assignment, leave it for later.
-- Then test the balance assertion if any. -- Then test the balance assertion if any.
addOrAssignAmountAndCheckAssertionB :: Posting -> Balancing s Posting addOrAssignAmountAndCheckAssertionB :: Posting -> Balancing s Posting
addOrAssignAmountAndCheckAssertionB p@Posting{paccount=acc, pamount=amt, pbalanceassertion=mba} addOrAssignAmountAndCheckAssertionB p@Posting{paccount=acc, pamount=amt, pbalanceassertion=mba}
| hasAmount p = do | hasAmount p = do
newbal <- addAmountB acc amt newbal <- addAmountB acc amt
whenM (R.reader bsAssrt) $ checkBalanceAssertionB p newbal whenM (R.reader bsAssrt) $ checkBalanceAssertionB p newbal
return p return p
| Just BalanceAssertion{baamount,batotal} <- mba = do | Just BalanceAssertion{baamount,batotal} <- mba = do
@ -760,8 +760,8 @@ addOrAssignAmountAndCheckAssertionB p@Posting{paccount=acc, pamount=amt, pbalanc
False -> do False -> do
-- a partial balance assignment -- a partial balance assignment
oldbalothercommodities <- filterMixedAmount ((acommodity baamount /=) . acommodity) <$> getAmountB acc oldbalothercommodities <- filterMixedAmount ((acommodity baamount /=) . acommodity) <$> getAmountB acc
let assignedbalthiscommodity = Mixed [baamount] let assignedbalthiscommodity = Mixed [baamount]
newbal = oldbalothercommodities + assignedbalthiscommodity newbal = oldbalothercommodities + assignedbalthiscommodity
diff <- setAmountB acc newbal diff <- setAmountB acc newbal
return (diff,newbal) return (diff,newbal)
let p' = p{pamount=diff, poriginal=Just $ originalPosting p} 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. -- optionally check the posting's balance assertion if any.
-- The posting is expected to have an explicit amount (otherwise this does nothing). -- The posting is expected to have an explicit amount (otherwise this does nothing).
-- Adding and checking balance assertions are tightly paired because we -- 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 :: Posting -> Balancing s Posting
addAmountAndCheckAssertionB p | hasAmount p = do addAmountAndCheckAssertionB p | hasAmount p = do
newbal <- addAmountB (paccount p) (pamount p) newbal <- addAmountB (paccount p) (pamount p)
@ -806,17 +806,17 @@ checkBalanceAssertionB _ _ = return ()
checkBalanceAssertionOneCommodityB :: Posting -> Amount -> MixedAmount -> Balancing s () checkBalanceAssertionOneCommodityB :: Posting -> Amount -> MixedAmount -> Balancing s ()
checkBalanceAssertionOneCommodityB p@Posting{paccount=assertedacct} assertedamt actualbal = do checkBalanceAssertionOneCommodityB p@Posting{paccount=assertedacct} assertedamt actualbal = do
let isinclusive = maybe False bainclusive $ pbalanceassertion p let isinclusive = maybe False bainclusive $ pbalanceassertion p
actualbal' <- actualbal' <-
if isinclusive if isinclusive
then then
-- sum the running balances of this account and any of its subaccounts seen so far -- sum the running balances of this account and any of its subaccounts seen so far
withB $ \BalancingState{bsBalances} -> withB $ \BalancingState{bsBalances} ->
H.foldM H.foldM
(\ibal (acc, amt) -> return $ ibal + (\ibal (acc, amt) -> return $ ibal +
if assertedacct==acc || assertedacct `isAccountNamePrefixOf` acc then amt else 0) if assertedacct==acc || assertedacct `isAccountNamePrefixOf` acc then amt else 0)
0 0
bsBalances bsBalances
else return actualbal else return actualbal
let let
assertedcomm = acommodity assertedamt assertedcomm = acommodity assertedamt
actualbalincomm = headDef 0 $ amounts $ filterMixedAmountByCommodity assertedcomm $ actualbal' 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. -- | Throw an error if this posting is trying to do an illegal balance assignment.
checkIllegalBalanceAssignmentB :: Posting -> Balancing s () checkIllegalBalanceAssignmentB :: Posting -> Balancing s ()
checkIllegalBalanceAssignmentB p = do checkIllegalBalanceAssignmentB p = do
checkBalanceAssignmentPostingDateB p checkBalanceAssignmentPostingDateB p
checkBalanceAssignmentUnassignableAccountB p checkBalanceAssignmentUnassignableAccountB p
-- XXX these should show position. annotateErrorWithTransaction t ? -- XXX these should show position. annotateErrorWithTransaction t ?
-- | Throw an error if this posting is trying to do a balance assignment and -- | 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). -- has a custom posting date (which makes amount inference too hard/impossible).
checkBalanceAssignmentPostingDateB :: Posting -> Balancing s () checkBalanceAssignmentPostingDateB :: Posting -> Balancing s ()
checkBalanceAssignmentPostingDateB p = checkBalanceAssignmentPostingDateB p =
when (hasBalanceAssignment p && isJust (pdate p)) $ when (hasBalanceAssignment p && isJust (pdate p)) $
throwError $ unlines $ throwError $ unlines $
["postings which are balance assignments may not have a custom date." ["postings which are balance assignments may not have a custom date."
,"Please write the posting amount explicitly, or remove the posting 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} fixbalanceassertion ba = ba{baamount=styleAmount styles $ baamount ba}
fixpricedirective pd@PriceDirective{pdamount=a} = pd{pdamount=styleAmount styles a} fixpricedirective pd@PriceDirective{pdamount=a} = pd{pdamount=styleAmount styles a}
-- | Get all the amount styles defined in this journal, either declared by -- | 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. -- 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 -- Styles declared by commodity directives take precedence, and these also are
-- guaranteed to know their decimal point character. -- guaranteed to know their decimal point character.
journalCommodityStyles :: Journal -> M.Map CommoditySymbol AmountStyle 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 -- | Replace this transaction's postings' account names with the value
-- of the given field or tag, if any. -- 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} transactionPivot fieldortagname t = t{tpostings = map (postingPivot fieldortagname) . tpostings $ t}
-- | Replace this posting's account name with the value -- | Replace this posting's account name with the value
-- of the given field or tag, if any, otherwise the empty string. -- 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} postingPivot fieldortagname p = p{paccount = pivotedacct, poriginal = Just $ originalPosting p}
where where
pivotedacct pivotedacct
| Just t <- ptransaction p, fieldortagname == "code" = tcode t | Just t <- ptransaction p, fieldortagname == "code" = tcode t
| Just t <- ptransaction p, fieldortagname == "description" = tdescription t | Just t <- ptransaction p, fieldortagname == "description" = tdescription t
| Just t <- ptransaction p, fieldortagname == "payee" = transactionPayee t | Just t <- ptransaction p, fieldortagname == "payee" = transactionPayee t
| Just t <- ptransaction p, fieldortagname == "note" = transactionNote t | Just t <- ptransaction p, fieldortagname == "note" = transactionNote t
| Just (_, value) <- postingFindTag fieldortagname p = value | Just (_, value) <- postingFindTag fieldortagname p = value
| otherwise = "" | otherwise = ""
postingFindTag :: TagName -> Posting -> Maybe (TagName, TagValue) postingFindTag :: TagName -> Posting -> Maybe (TagName, TagValue)
postingFindTag tagname p = find ((tagname==) . fst) $ postingAllTags p postingFindTag tagname p = find ((tagname==) . fst) $ postingAllTags p
-- -- | Build a database of market prices in effect on the given date, -- -- | Build a database of market prices in effect on the given date,
@ -1333,8 +1333,8 @@ tests_Journal = tests "Journal" [
nulljournal{ jtxns = [ nulljournal{ jtxns = [
transaction "2019/01/01" [ vpost' "a" (num 2) (balassert (num 2)) ] transaction "2019/01/01" [ vpost' "a" (num 2) (balassert (num 2)) ]
,transaction "2019/01/01" [ ,transaction "2019/01/01" [
post' "b" (num 1) Nothing post' "b" (num 1) Nothing
,post' "a" missingamt Nothing ,post' "a" missingamt Nothing
] ]
,transaction "2019/01/01" [ post' "a" (num 0) (balassert (num 1)) ] ,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 Safe (headDef)
import Text.Printf import Text.Printf
import Hledger.Utils.Test import Hledger.Utils.Test
import Hledger.Data.Types import Hledger.Data.Types
import Hledger.Data.Account import Hledger.Data.Account
import Hledger.Data.Journal 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 (PeriodTo e) = formatTime defaultTimeLocale "-%0C%y/%m/%d" (addDays (-1) e) -- -INCLUSIVEENDDATE
showPeriod PeriodAll = "-" 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. -- the 3 letter month name abbreviation for the current locale.
showPeriodMonthAbbrev (MonthPeriod _ m) -- Jan showPeriodMonthAbbrev (MonthPeriod _ m) -- Jan
| m > 0 && m <= length monthnames = snd $ monthnames !! (m-1) | 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 -- doctest helper, too much hassle to define in the comment
-- XXX duplicates some logic in periodictransactionp -- XXX duplicates some logic in periodictransactionp
_ptgen str = do _ptgen str = do
let let
t = T.pack str t = T.pack str
(i,s) = parsePeriodExpr' nulldate t (i,s) = parsePeriodExpr' nulldate t
case checkPeriodicTransactionStartDate i s t of case checkPeriodicTransactionStartDate i s t of
@ -42,7 +42,7 @@ _ptgen str = do
Nothing -> Nothing ->
mapM_ (putStr . showTransaction) $ mapM_ (putStr . showTransaction) $
runPeriodicTransaction 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 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 -- *** 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" -- >>> _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" -- >>> _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" -- >>> _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")) -- >>> 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{ t = nulltransaction{
tstatus = ptstatus tstatus = ptstatus
,tcode = ptcode ,tcode = ptcode
,tdescription = ptdescription ,tdescription = ptdescription
,tcomment = (if T.null ptcomment then "\n" else ptcomment) <> "recur: " <> ptperiodexpr ,tcomment = (if T.null ptcomment then "\n" else ptcomment) <> "recur: " <> ptperiodexpr
,ttags = ("recur", ptperiodexpr) : pttags ,ttags = ("recur", ptperiodexpr) : pttags
,tpostings = ptpostings ,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 -- or return an explanatory error message including the provided period expression
-- (from which the span and interval are derived). -- (from which the span and interval are derived).
checkPeriodicTransactionStartDate :: Interval -> DateSpan -> T.Text -> Maybe String checkPeriodicTransactionStartDate :: Interval -> DateSpan -> T.Text -> Maybe String
checkPeriodicTransactionStartDate i s periodexpr = checkPeriodicTransactionStartDate i s periodexpr =
case (i, spanStart s) of case (i, spanStart s) of
(Weeks _, Just d) -> checkStart d "week" (Weeks _, Just d) -> checkStart d "week"
(Months _, Just d) -> checkStart d "month" (Months _, Just d) -> checkStart d "month"
(Quarters _, Just d) -> checkStart d "quarter" (Quarters _, Just d) -> checkStart d "quarter"
(Years _, Just d) -> checkStart d "year" (Years _, Just d) -> checkStart d "year"
_ -> Nothing _ -> Nothing
where where
checkStart d x = checkStart d x =
let firstDate = fixSmartDate d ("","this",x) let firstDate = fixSmartDate d ("","this",x)
in in
if d == firstDate if d == firstDate
then Nothing then Nothing
else Just $ else Just $
"Unable to generate transactions according to "++show (T.unpack periodexpr) "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 Data.Time.Calendar
import Safe import Safe
import Hledger.Utils import Hledger.Utils
import Hledger.Data.Types import Hledger.Data.Types
import Hledger.Data.Amount import Hledger.Data.Amount
import Hledger.Data.AccountName 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 -- | Get a posting's status. This is cleared or pending if those are
-- explicitly set on the posting, otherwise the status of its parent -- explicitly set on the posting, otherwise the status of its parent
-- transaction, or unmarked if there is no parent transaction. (Note -- 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". -- unmarked" or "posting is unmarked and don't know about the transaction".
postingStatus :: Posting -> Status postingStatus :: Posting -> Status
postingStatus Posting{pstatus=s, ptransaction=mt} 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 where
actual = case fs of actual = case fs of
FormatLiteral l -> formatString False Nothing Nothing l 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 #endif
import Text.Printf import Text.Printf
import Hledger.Utils import Hledger.Utils
import Hledger.Data.Types import Hledger.Data.Types
import Hledger.Data.Dates import Hledger.Data.Dates
import Hledger.Data.Amount import Hledger.Data.Amount
@ -130,10 +130,10 @@ tests_Timeclock = tests "Timeclock" [
parseTime defaultTimeLocale "%H:%M:%S" parseTime defaultTimeLocale "%H:%M:%S"
#endif #endif
showtime = formatTime defaultTimeLocale "%H:%M" 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' future = utcToLocalTime tz $ addUTCTime 100 now'
futurestr = showtime future futurestr = showtime future
tests "timeclockEntriesToTransactions" [ tests "timeclockEntriesToTransactions" [
test "started yesterday, split session at midnight" $ test "started yesterday, split session at midnight" $
txndescs [clockin (mktime yesterday "23:00:00") "" ""] `is` ["23:00-23:59","00:00-"++nowstr] txndescs [clockin (mktime yesterday "23:00:00") "" ""] `is` ["23:00-23:59","00:00-"++nowstr]
,test "split multi-day sessions at each midnight" $ ,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 Text.Printf
import qualified Data.Map as Map import qualified Data.Map as Map
import Hledger.Utils import Hledger.Utils
import Hledger.Data.Types import Hledger.Data.Types
import Hledger.Data.Dates import Hledger.Data.Dates
import Hledger.Data.Posting import Hledger.Data.Posting
@ -101,7 +101,7 @@ nulltransaction = Transaction {
} }
-- | Make a simple transaction with the given date and postings. -- | 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} transaction datestr ps = txnTieKnot $ nulltransaction{tdate=parsedate datestr, tpostings=ps}
transactionPayee :: Transaction -> Text transactionPayee :: Transaction -> Text
@ -122,7 +122,7 @@ payeeAndNoteFromDescription t
(p, n) = T.span (/= '|') 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: Ledger 2.x's standard format looks like this:
@ -139,7 +139,7 @@ pcommentwidth = no limit -- 22
@ @
The output will be parseable journal syntax. 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. are displayed as multiple similar postings, one per commodity.
(Normally does not happen with this function). (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), (postings sum to 0, without needing to infer conversion prices),
the last posting's amount will not be shown. the last posting's amount will not be shown.
-} -}
-- XXX why that logic ? -- XXX why that logic ?
-- XXX where is/should this be still used ? -- XXX where is/should this be still used ?
-- XXX rename these, after amount expressions/mixed posting amounts lands -- XXX rename these, after amount expressions/mixed posting amounts lands
-- eg showTransactionSimpleAmountsElidingLast, showTransactionSimpleAmounts, showTransaction -- eg showTransactionSimpleAmountsElidingLast, showTransactionSimpleAmounts, showTransaction
showTransaction :: Transaction -> String showTransaction :: Transaction -> String
@ -158,19 +158,19 @@ showTransaction = showTransactionHelper True False
-- | Like showTransaction, but does not change amounts' explicitness. -- | Like showTransaction, but does not change amounts' explicitness.
-- Explicit amounts are shown and implicit amounts are not. -- Explicit amounts are shown and implicit amounts are not.
-- The output will be parseable journal syntax. -- 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. -- are displayed as multiple similar postings, one per commodity.
-- Most often, this is the one you want to use. -- Most often, this is the one you want to use.
showTransactionUnelided :: Transaction -> String showTransactionUnelided :: Transaction -> String
showTransactionUnelided = showTransactionHelper False False showTransactionUnelided = showTransactionHelper False False
-- | Like showTransactionUnelided, but explicit multi-commodity amounts -- | Like showTransactionUnelided, but explicit multi-commodity amounts
-- are shown on one line, comma-separated. In this case the output will -- are shown on one line, comma-separated. In this case the output will
-- not be parseable journal syntax. -- not be parseable journal syntax.
showTransactionUnelidedOneLineAmounts :: Transaction -> String showTransactionUnelidedOneLineAmounts :: Transaction -> String
showTransactionUnelidedOneLineAmounts = showTransactionHelper False True showTransactionUnelidedOneLineAmounts = showTransactionHelper False True
-- | Helper for showTransaction*. -- | Helper for showTransaction*.
showTransactionHelper :: Bool -> Bool -> Transaction -> String showTransactionHelper :: Bool -> Bool -> Transaction -> String
showTransactionHelper elide onelineamounts t = showTransactionHelper elide onelineamounts t =
unlines $ [descriptionline] unlines $ [descriptionline]
@ -205,7 +205,7 @@ renderCommentLines t =
-- for `print` output. Normally this output will be valid journal syntax which -- for `print` output. Normally this output will be valid journal syntax which
-- hledger can reparse (though it may include no-longer-valid balance assertions). -- 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: -- 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 -- 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, -- if onelineamounts is true, these amounts are shown on one line,
-- comma-separated, and the output will not be valid journal syntax. -- comma-separated, and the output will not be valid journal syntax.
-- Otherwise, they are shown as several similar postings, one per commodity. -- Otherwise, they are shown as several similar postings, one per commodity.
-- --
-- The output will appear to be a balanced transaction. -- The output will appear to be a balanced transaction.
-- Amounts' display precisions, which may have been limited by commodity -- Amounts' display precisions, which may have been limited by commodity
-- directives, will be increased if necessary to ensure this. -- directives, will be increased if necessary to ensure this.
-- --
-- Posting amounts will be aligned with each other, starting about 4 columns -- Posting amounts will be aligned with each other, starting about 4 columns
-- beyond the widest account name (see postingAsLines for details). -- beyond the widest account name (see postingAsLines for details).
-- --
postingsAsLines :: Bool -> Bool -> Transaction -> [Posting] -> [String] postingsAsLines :: Bool -> Bool -> Transaction -> [Posting] -> [String]
postingsAsLines elide onelineamounts t ps postingsAsLines elide onelineamounts t ps
| elide && length ps > 1 && all hasAmount ps && isTransactionBalanced Nothing t -- imprecise balanced check | 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) = concatMap (postingAsLines False onelineamounts ps) (init ps) ++ postingAsLines True onelineamounts ps (last ps)
| otherwise = concatMap (postingAsLines False onelineamounts ps) 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, -- There will be an indented account name, plus one or more of status flag,
-- posting amount, balance assertion, same-line comment, next-line comments. -- 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 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. -- 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 -- Or if onelineamounts is true, such amounts are shown on one line, comma-separated
-- (and the output will not be valid journal syntax). -- (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 -- 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). -- 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. -- increased if needed to match the posting with the longest account name.
-- This is used to align the amounts of a transaction's postings. -- This is used to align the amounts of a transaction's postings.
-- --
@ -255,10 +255,10 @@ postingAsLines elideamount onelineamounts pstoalignwith p = concat [
| postingblock <- postingblocks] | postingblock <- postingblocks]
where where
postingblocks = [map rstrip $ lines $ concatTopPadded [statusandaccount, " ", amount, assertion, samelinecomment] | amount <- shownAmounts] 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 statusandaccount = lineIndent $ fitString (Just $ minwidth) Nothing False True $ pstatusandacct p
where 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 minwidth = maximum $ map ((2+) . textWidth . T.pack . pacctstr) pstoalignwith
pstatusandacct p' = pstatusprefix p' ++ pacctstr p' pstatusandacct p' = pstatusprefix p' ++ pacctstr p'
pstatusprefix p' | null s = "" pstatusprefix p' | null s = ""
@ -279,8 +279,8 @@ postingAsLines elideamount onelineamounts pstoalignwith p = concat [
case renderCommentLines (pcomment p) of [] -> ("",[]) case renderCommentLines (pcomment p) of [] -> ("",[])
c:cs -> (c,cs) c:cs -> (c,cs)
-- | Render a balance assertion, as the =[=][*] symbol and expected amount. -- | Render a balance assertion, as the =[=][*] symbol and expected amount.
showBalanceAssertion BalanceAssertion{..} = showBalanceAssertion BalanceAssertion{..} =
"=" ++ ['=' | batotal] ++ ['*' | bainclusive] ++ " " ++ showAmountWithZeroCommodity baamount "=" ++ ['=' | batotal] ++ ['*' | bainclusive] ++ " " ++ showAmountWithZeroCommodity baamount
-- | Render a posting, simply. Used in balance assertion errors. -- | Render a posting, simply. Used in balance assertion errors.
@ -296,7 +296,7 @@ showBalanceAssertion BalanceAssertion{..} =
-- assertion = maybe "" ((" = " ++) . showAmountWithZeroCommodity . baamount) $ pbalanceassertion p -- assertion = maybe "" ((" = " ++) . showAmountWithZeroCommodity . baamount) $ pbalanceassertion p
-- | Render a posting, at the appropriate width for aligning with -- | 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 :: Posting -> [String]
showPostingLines p = postingAsLines False False ps p where showPostingLines p = postingAsLines False False ps p where
ps | Just t <- ptransaction p = tpostings t ps | Just t <- ptransaction p = tpostings t
@ -366,14 +366,14 @@ isTransactionBalanced styles t =
bvsum' = canonicalise $ costOfMixedAmount bvsum bvsum' = canonicalise $ costOfMixedAmount bvsum
canonicalise = maybe id canonicaliseMixedAmount styles 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, -- (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 -- 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. -- because there's more than one missing amount, return an error message.
-- --
-- Transactions with balance assignments can have more than one -- 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. -- journalBalanceTransactions.
-- --
-- The "sum to 0" test is done using commodity display precisions, -- The "sum to 0" test is done using commodity display precisions,
@ -383,18 +383,18 @@ balanceTransaction ::
Maybe (Map.Map CommoditySymbol AmountStyle) -- ^ commodity display styles Maybe (Map.Map CommoditySymbol AmountStyle) -- ^ commodity display styles
-> Transaction -> Transaction
-> Either String Transaction -> Either String Transaction
balanceTransaction mstyles = fmap fst . balanceTransactionHelper mstyles balanceTransaction mstyles = fmap fst . balanceTransactionHelper mstyles
-- | Helper used by balanceTransaction and balanceTransactionWithBalanceAssignmentAndCheckAssertionsB; -- | 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. -- and amounts that were inferred.
balanceTransactionHelper :: balanceTransactionHelper ::
Maybe (Map.Map CommoditySymbol AmountStyle) -- ^ commodity display styles Maybe (Map.Map CommoditySymbol AmountStyle) -- ^ commodity display styles
-> Transaction -> Transaction
-> Either String (Transaction, [(AccountName, MixedAmount)]) -> Either String (Transaction, [(AccountName, MixedAmount)])
balanceTransactionHelper mstyles t = do balanceTransactionHelper mstyles t = do
(t', inferredamtsandaccts) <- (t', inferredamtsandaccts) <-
inferBalancingAmount (fromMaybe Map.empty mstyles) $ inferBalancingPrices t inferBalancingAmount (fromMaybe Map.empty mstyles) $ inferBalancingPrices t
if isTransactionBalanced mstyles t' if isTransactionBalanced mstyles t'
then Right (txnTieKnot t', inferredamtsandaccts) then Right (txnTieKnot t', inferredamtsandaccts)
else Left $ annotateErrorWithTransaction t' $ nonzerobalanceerror t' 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 sep = if not (null rmsg) && not (null bvmsg) then "; " else "" :: String
annotateErrorWithTransaction :: Transaction -> String -> 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 -- | 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 -- 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 -- 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 -- 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. -- have the same price(s), and will be converted to the price commodity.
inferBalancingAmount :: inferBalancingAmount ::
Map.Map CommoditySymbol AmountStyle -- ^ commodity display styles Map.Map CommoditySymbol AmountStyle -- ^ commodity display styles
-> Transaction -> Transaction
-> Either String (Transaction, [(AccountName, MixedAmount)]) -> Either String (Transaction, [(AccountName, MixedAmount)])
@ -446,16 +446,16 @@ inferBalancingAmount styles t@Transaction{tpostings=ps}
inferamount p = inferamount p =
let let
minferredamt = case ptype p of minferredamt = case ptype p of
RegularPosting | not (hasAmount p) -> Just realsum RegularPosting | not (hasAmount p) -> Just realsum
BalancedVirtualPosting | not (hasAmount p) -> Just bvsum BalancedVirtualPosting | not (hasAmount p) -> Just bvsum
_ -> Nothing _ -> Nothing
in in
case minferredamt of case minferredamt of
Nothing -> (p, Nothing) 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 where
-- Inferred amounts are converted to cost. -- 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); -- (since the main amount styling pass happened before this balancing pass);
a' = styleMixedAmount styles $ normaliseMixedAmount $ costOfMixedAmount (-a) a' = styleMixedAmount styles $ normaliseMixedAmount $ costOfMixedAmount (-a)
@ -613,7 +613,7 @@ tests_Transaction =
] ]
] ]
-- postingsAsLines -- postingsAsLines
-- one implicit amount -- one implicit amount
, let timp = nulltransaction {tpostings = ["a" `post` usd 1, "b" `post` missingamt]} , let timp = nulltransaction {tpostings = ["a" `post` usd 1, "b" `post` missingamt]}
-- explicit amounts, balanced -- explicit amounts, balanced
texp = nulltransaction {tpostings = ["a" `post` usd 1, "b" `post` usd (-1)]} texp = nulltransaction {tpostings = ["a" `post` usd 1, "b" `post` usd (-1)]}
@ -659,7 +659,7 @@ tests_Transaction =
, test "one-explicit-amount-elide-true" $ , test "one-explicit-amount-elide-true" $
let t = texp1 let t = texp1
in postingsAsLines True False t (tpostings t) `is` 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" $ , test "explicit-amounts-two-commodities-elide-true" $
let t = texp2 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, 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 ( module Hledger.Data.TransactionModifier (
@ -41,7 +41,7 @@ modifyTransactions tmods = map applymods
-- | Converts a 'TransactionModifier' to a 'Transaction'-transforming function, -- | Converts a 'TransactionModifier' to a 'Transaction'-transforming function,
-- which applies the modification(s) specified by the TransactionModifier. -- which applies the modification(s) specified by the TransactionModifier.
-- Currently this means adding automated postings when certain other postings are present. -- 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). -- way (ie, 'txnTieKnot' is called).
-- --
-- >>> putStr $ showTransaction $ transactionModifierToFunction (TransactionModifier "" ["pong" `post` usd 2]) nulltransaction{tpostings=["ping" `post` usd 1]} -- >>> putStr $ showTransaction $ transactionModifierToFunction (TransactionModifier "" ["pong" `post` usd 2]) nulltransaction{tpostings=["ping" `post` usd 1]}
@ -60,16 +60,16 @@ modifyTransactions tmods = map applymods
-- <BLANKLINE> -- <BLANKLINE>
-- --
transactionModifierToFunction :: TransactionModifier -> (Transaction -> Transaction) transactionModifierToFunction :: TransactionModifier -> (Transaction -> Transaction)
transactionModifierToFunction mt = transactionModifierToFunction mt =
\t@(tpostings -> ps) -> txnTieKnot t{ tpostings=generatePostings ps } -- TODO add modifier txn comment/tags ? \t@(tpostings -> ps) -> txnTieKnot t{ tpostings=generatePostings ps } -- TODO add modifier txn comment/tags ?
where where
q = simplifyQuery $ tmParseQuery mt (error' "a transaction modifier's query cannot depend on current date") q = simplifyQuery $ tmParseQuery mt (error' "a transaction modifier's query cannot depend on current date")
mods = map tmPostingRuleToFunction $ tmpostingrules mt mods = map tmPostingRuleToFunction $ tmpostingrules mt
generatePostings ps = [p' | p <- ps generatePostings ps = [p' | p <- ps
, p' <- if q `matchesPosting` p then p:[ m p | m <- mods] else [p]] , p' <- if q `matchesPosting` p then p:[ m p | m <- mods] else [p]]
-- | Parse the 'Query' from a 'TransactionModifier's 'tmquerytxt', -- | Parse the 'Query' from a 'TransactionModifier's 'tmquerytxt',
-- and return it as a function requiring the current date. -- and return it as a function requiring the current date.
-- --
-- >>> tmParseQuery (TransactionModifier "" []) undefined -- >>> tmParseQuery (TransactionModifier "" []) undefined
-- Any -- Any
@ -85,9 +85,9 @@ tmParseQuery mt = fst . flip parseQuery (tmquerytxt mt)
-- | Converts a 'TransactionModifier''s posting rule to a 'Posting'-generating function, -- | 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"). -- 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. -- 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 :: TMPostingRule -> (Posting -> Posting)
tmPostingRuleToFunction pr = tmPostingRuleToFunction pr =
\p -> renderPostingCommentDates $ pr \p -> renderPostingCommentDates $ pr
{ pdate = pdate p { pdate = pdate p
, pdate2 = pdate2 p , pdate2 = pdate2 p
@ -103,15 +103,15 @@ tmPostingRuleToFunction pr =
matchedamount = dbg6 "matchedamount" $ pamount p matchedamount = dbg6 "matchedamount" $ pamount p
-- Handle a matched amount with a total price carefully so as to keep the transaction balanced (#928). -- 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 -- Approach 1: convert to a unit price and increase the display precision slightly
-- Mixed as = dbg6 "multipliedamount" $ n `multiplyMixedAmount` mixedAmountTotalPriceToUnitPrice matchedamount -- Mixed as = dbg6 "multipliedamount" $ n `multiplyMixedAmount` mixedAmountTotalPriceToUnitPrice matchedamount
-- Approach 2: multiply the total price (keeping it positive) as well as the quantity -- 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 `multiplyMixedAmountAndPrice` matchedamount
in in
case acommodity pramount of case acommodity pramount of
"" -> Mixed as "" -> Mixed as
-- TODO multipliers with commodity symbols are not yet a documented feature. -- TODO multipliers with commodity symbols are not yet a documented feature.
-- For now: in addition to multiplying the quantity, it also replaces the -- 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. -- 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] c -> Mixed [a{acommodity = c, astyle = astyle pramount, aprice = aprice pramount} | a <- as]
postingRuleMultiplier :: TMPostingRule -> Maybe Quantity 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.Graph.Inductive (Gr,Node,NodeMap)
import Data.List (intercalate) import Data.List (intercalate)
import Text.Blaze (ToMarkup(..)) 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: --Note: You should use Data.Map.Strict instead of this module if:
--You will eventually need all the values stored. --You will eventually need all the values stored.
--The stored values don't represent large virtual data structures to be lazily computed. --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 -- | An amount's per-unit or total cost/selling price in another
-- commodity, as recorded in the journal entry eg with @ or @@. -- commodity, as recorded in the journal entry eg with @ or @@.
-- Docs call this "transaction price". The amount is always positive. -- 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) deriving (Eq,Ord,Typeable,Data,Generic,Show)
instance NFData AmountPrice instance NFData AmountPrice
@ -301,7 +301,7 @@ data Posting = Posting {
-- Tying this knot gets tedious, Maybe makes it easier/optional. -- Tying this knot gets tedious, Maybe makes it easier/optional.
poriginal :: Maybe Posting -- ^ When this posting has been transformed in some way poriginal :: Maybe Posting -- ^ When this posting has been transformed in some way
-- (eg its amount or price was inferred, or the account name was -- (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). -- untransformed posting (which will have Nothing in this field).
} deriving (Typeable,Data,Generic) } deriving (Typeable,Data,Generic)
@ -358,10 +358,10 @@ data Transaction = Transaction {
instance NFData Transaction instance NFData Transaction
-- | A transaction modifier rule. This has a query which matches postings -- | 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: -- postings or their transactions. Currently there is one kind of transformation:
-- the TMPostingRule, which adds a posting ("auto posting") to the transaction, -- 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. -- optionally setting its amount to the matched posting's amount multiplied by a constant.
data TransactionModifier = TransactionModifier { data TransactionModifier = TransactionModifier {
tmquerytxt :: Text, tmquerytxt :: Text,
tmpostingrules :: [TMPostingRule] tmpostingrules :: [TMPostingRule]
@ -383,8 +383,8 @@ type TMPostingRule = Posting
-- | A periodic transaction rule, describing a transaction that recurs. -- | A periodic transaction rule, describing a transaction that recurs.
data PeriodicTransaction = PeriodicTransaction { data PeriodicTransaction = PeriodicTransaction {
ptperiodexpr :: Text, -- ^ the period expression as written ptperiodexpr :: Text, -- ^ the period expression as written
ptinterval :: Interval, -- ^ the interval at which this transaction recurs 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. ptspan :: DateSpan, -- ^ the (possibly unbounded) period during which this transaction recurs. Contains a whole number of intervals.
-- --
ptstatus :: Status, -- ^ some of Transaction's fields ptstatus :: Status, -- ^ some of Transaction's fields
ptcode :: Text, ptcode :: Text,
@ -496,8 +496,8 @@ data Journal = Journal {
,jparsetimeclockentries :: [TimeclockEntry] -- ^ timeclock sessions which have not been clocked out ,jparsetimeclockentries :: [TimeclockEntry] -- ^ timeclock sessions which have not been clocked out
,jincludefilestack :: [FilePath] ,jincludefilestack :: [FilePath]
-- principal data -- principal data
,jdeclaredaccounts :: [(AccountName,AccountDeclarationInfo)] -- ^ Accounts declared by account directives, in parse order (after journal finalisation) ,jdeclaredaccounts :: [(AccountName,AccountDeclarationInfo)] -- ^ Accounts declared by account directives, in parse order (after journal finalisation)
,jdeclaredaccounttypes :: M.Map AccountType [AccountName] -- ^ Accounts whose type has been declared in account directives (usually 5 top-level accounts) ,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 ,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 ,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). ,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 ,aibalance :: MixedAmount -- ^ this account's balance, including subaccounts
} deriving (Typeable, Data, Generic) } deriving (Typeable, Data, Generic)
-- | Whether an account's balance is normally a positive number (in -- | Whether an account's balance is normally a positive number (in
-- accounting terms, a debit balance) or a negative number (credit balance). -- accounting terms, a debit balance) or a negative number (credit balance).
-- Assets and expenses are normally positive (debit), while liabilities, equity -- Assets and expenses are normally positive (debit), while liabilities, equity
-- and income are normally negative (credit). -- and income are normally negative (credit).
-- https://en.wikipedia.org/wiki/Normal_balance -- 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 -- | A Ledger has the journal it derives from, and the accounts
-- derived from that. Accounts are accessible both list-wise and -- 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 -- Valuation
-- Apply a specified valuation to this mixed amount, using the provided -- 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. -- and whether this is for a multiperiod report or not.
mixedAmountApplyValuation :: [PriceDirective] -> M.Map CommoditySymbol AmountStyle -> Day -> Day -> Bool -> ValuationType -> MixedAmount -> MixedAmount mixedAmountApplyValuation :: [PriceDirective] -> M.Map CommoditySymbol AmountStyle -> Day -> Day -> Bool -> ValuationType -> MixedAmount -> MixedAmount
mixedAmountApplyValuation prices styles periodend today ismultiperiod v (Mixed as) = 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 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 -- | 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. -- and whether this is for a multiperiod report or not.
amountApplyValuation :: [PriceDirective] -> M.Map CommoditySymbol AmountStyle -> Day -> Day -> Bool -> ValuationType -> Amount -> Amount amountApplyValuation :: [PriceDirective] -> M.Map CommoditySymbol AmountStyle -> Day -> Day -> Bool -> ValuationType -> Amount -> Amount
amountApplyValuation prices styles periodend today ismultiperiod v a = amountApplyValuation prices styles periodend today ismultiperiod v a =
@ -101,7 +101,7 @@ amountValueAtDate pricedirectives styles mto d a =
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
-- Building a price graph -- Building a price graph
-- | Convert a list of market price directives in parse order to a -- | Convert a list of market price directives in parse order to a
-- graph of all prices in effect on a given day, allowing efficient -- graph of all prices in effect on a given day, allowing efficient
-- lookup of exchange rates between commodity pairs. -- 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 -- Market price lookup
tests_priceLookup = tests_priceLookup =
let let
d = parsedate d = parsedate
@ -214,7 +214,7 @@ priceLookup pricedirectives d from mto =
where where
-- If to is unspecified, try to pick a default valuation commodity from declared prices (only). -- If to is unspecified, try to pick a default valuation commodity from declared prices (only).
-- XXX how to choose ? Take lowest sorted ? -- 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 ? -- Keep parse order in label and take latest parsed ?
mdefaultto = mdefaultto =
dbg4 ("default valuation commodity for "++T.unpack from) $ 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 :: (Show b, Ord b) => Gr a b -> [Node] -> [b]
pathEdgeLabels g = map frommaybe . map (nodesEdgeLabel g) . pathEdges pathEdgeLabels g = map frommaybe . map (nodesEdgeLabel g) . pathEdges
where frommaybe = fromMaybe (error' "pathEdgeLabels: expected no Nothings here") where frommaybe = fromMaybe (error' "pathEdgeLabels: expected no Nothings here")
-- | Convert a path to node pairs representing the path's edges. -- | Convert a path to node pairs representing the path's edges.
pathEdges :: [Node] -> [(Node,Node)] pathEdges :: [Node] -> [(Node,Node)]
pathEdges p = [(f,t) | f:t:_ <- tails p] 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_Query = tests "Query" [
tests "simplifyQuery" [ tests "simplifyQuery" [
(simplifyQuery $ Or [Acct "a"]) `is` (Acct "a") (simplifyQuery $ Or [Acct "a"]) `is` (Acct "a")
,(simplifyQuery $ Or [Any,None]) `is` (Any) ,(simplifyQuery $ Or [Any,None]) `is` (Any)
,(simplifyQuery $ And [Any,None]) `is` (None) ,(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"))) `is` (Date (DateSpan (Just $ parsedate "2012-01-01") (Just $ parsedate "2013-01-01")))
,(simplifyQuery $ And [Or [],Or [Desc "b b"]]) `is` (Desc "b b") ,(simplifyQuery $ And [Or [],Or [Desc "b b"]]) `is` (Desc "b b")
] ]
,tests "parseQuery" [ ,tests "parseQuery" [
(parseQuery nulldate "acct:'expenses:autres d\233penses' desc:b") `is` (And [Acct "expenses:autres d\233penses", Desc "b"], []) (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"]) ,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 "'a a' 'b" `is` (Or [Acct "a a",Acct "'b"], [])
,parseQuery nulldate "\"" `is` (Acct "\"", []) ,parseQuery nulldate "\"" `is` (Acct "\"", [])
] ]
,tests "words''" [ ,tests "words''" [
(words'' [] "a b") `is` ["a","b"] (words'' [] "a b") `is` ["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'' [] "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'' ["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 "\"acct:expenses:autres d\233penses\"") `is` ["acct:expenses:autres d\233penses"]
, (words'' prefixes "\"") `is` ["\""] , (words'' prefixes "\"") `is` ["\""]
] ]
,tests "filterQuery" [ ,tests "filterQuery" [
filterQuery queryIsDepth Any `is` Any filterQuery queryIsDepth Any `is` Any
,filterQuery queryIsDepth (Depth 1) `is` Depth 1 ,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:<0" `is` (Left $ Amt Lt 0)
,parseQueryTerm nulldate "amt:>10000.10" `is` (Left $ Amt AbsGt 10000.1) ,parseQueryTerm nulldate "amt:>10000.10" `is` (Left $ Amt AbsGt 10000.1)
] ]
,tests "parseAmountQueryTerm" [ ,tests "parseAmountQueryTerm" [
parseAmountQueryTerm "<0" `is` (Lt,0) -- special case for convenience, since AbsLt 0 would be always false 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 ,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)) ,parseAmountQueryTerm "-0.23" `is` (Eq,(-0.23))
,_test "number beginning with decimal mark" $ parseAmountQueryTerm "=.23" `is` (AbsEq,0.23) -- XXX ,_test "number beginning with decimal mark" $ parseAmountQueryTerm "=.23" `is` (AbsEq,0.23) -- XXX
] ]
,tests "matchesAccount" [ ,tests "matchesAccount" [
expect $ (Acct "b:c") `matchesAccount` "a:bb:c:d" expect $ (Acct "b:c") `matchesAccount` "a:bb:c:d"
,expect $ not $ (Acct "^a:b") `matchesAccount` "c:a:b" ,expect $ not $ (Acct "^a:b") `matchesAccount` "c:a:b"
@ -736,7 +736,7 @@ tests_Query = tests "Query" [
,expect $ Date2 nulldatespan `matchesAccount` "a" ,expect $ Date2 nulldatespan `matchesAccount` "a"
,expect $ not $ (Tag "a" Nothing) `matchesAccount` "a" ,expect $ not $ (Tag "a" Nothing) `matchesAccount` "a"
] ]
,tests "matchesPosting" [ ,tests "matchesPosting" [
test "positive match on cleared posting status" $ test "positive match on cleared posting status" $
expect $ (StatusQ Cleared) `matchesPosting` nullposting{pstatus=Cleared} 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 "l" $ expect $ (Sym "shekels") `matchesPosting` nullposting{pamount=Mixed [nullamt{acommodity="shekels"}]}
,test "m" $ expect $ not $ (Sym "shek") `matchesPosting` nullposting{pamount=Mixed [nullamt{acommodity="shekels"}]} ,test "m" $ expect $ not $ (Sym "shek") `matchesPosting` nullposting{pamount=Mixed [nullamt{acommodity="shekels"}]}
] ]
,tests "matchesTransaction" [ ,tests "matchesTransaction" [
expect $ Any `matchesTransaction` nulltransaction expect $ Any `matchesTransaction` nulltransaction
,expect $ not $ (Desc "x x") `matchesTransaction` nulltransaction{tdescription="x"} ,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. -- Combining Journals means concatenating them, basically.
-- The parse state resets at the start of each file, which means that -- The parse state resets at the start of each file, which means that
-- directives & aliases do not affect subsequent sibling or parent files. -- 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. -- Also the final parse state saved in the Journal does span all files.
readJournalFiles :: InputOpts -> [PrefixedFilePath] -> IO (Either String Journal) readJournalFiles :: InputOpts -> [PrefixedFilePath] -> IO (Either String Journal)
readJournalFiles iopts = readJournalFiles iopts =
@ -207,7 +207,7 @@ readJournalFiles iopts =
-- generation, a rules file for converting CSV data, etc. -- generation, a rules file for converting CSV data, etc.
readJournalFile :: InputOpts -> PrefixedFilePath -> IO (Either String Journal) readJournalFile :: InputOpts -> PrefixedFilePath -> IO (Either String Journal)
readJournalFile iopts prefixedfile = do readJournalFile iopts prefixedfile = do
let let
(mfmt, f) = splitReaderPrefix prefixedfile (mfmt, f) = splitReaderPrefix prefixedfile
iopts' = iopts{mformat_=firstJust [mfmt, mformat_ iopts]} iopts' = iopts{mformat_=firstJust [mfmt, mformat_ iopts]}
requireJournalFileExists f requireJournalFileExists f
@ -235,13 +235,13 @@ latestDates = headDef [] . take 1 . group . reverse . sort
-- | Remember that these transaction dates were the latest seen when -- | Remember that these transaction dates were the latest seen when
-- reading this journal file. -- reading this journal file.
saveLatestDates :: LatestDates -> FilePath -> IO () saveLatestDates :: LatestDates -> FilePath -> IO ()
saveLatestDates dates f = writeFile (latestDatesFileFor f) $ unlines $ map showDate dates 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 -- journal file was read ? If there were multiple transactions on the
-- latest date, that number of dates is returned, otherwise just one. -- 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. -- available for this file.
previousLatestDates :: FilePath -> IO LatestDates previousLatestDates :: FilePath -> IO LatestDates
previousLatestDates f = do 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, -- 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. -- 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, -- Input ioptions (@iopts@) specify CSV conversion rules file to help convert CSV data,
-- enable or disable balance assertion checking and automated posting generation. -- 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) ,mrules_file_ :: Maybe FilePath -- ^ a conversion rules file to use (when reading CSV)
,separator_ :: Char -- ^ the separator to use (when reading CSV) ,separator_ :: Char -- ^ the separator to use (when reading CSV)
,aliases_ :: [String] -- ^ account name aliases to apply ,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 ,ignore_assertions_ :: Bool -- ^ don't check balance assertions
,new_ :: Bool -- ^ read only new transactions since this file was last read ,new_ :: Bool -- ^ read only new transactions since this file was last read
,new_save_ :: Bool -- ^ save latest new transactions state for next time ,new_save_ :: Bool -- ^ save latest new transactions state for next time
,pivot_ :: String -- ^ use the given field's value as the account name ,pivot_ :: String -- ^ use the given field's value as the account name
,auto_ :: Bool -- ^ generate automatic postings when journal is parsed ,auto_ :: Bool -- ^ generate automatic postings when journal is parsed
} deriving (Show, Data) --, Typeable) } deriving (Show, Data) --, Typeable)
instance Default InputOpts where def = definputopts instance Default InputOpts where def = definputopts
@ -188,7 +188,7 @@ rawOptsToInputOpts rawopts = InputOpts{
,new_ = boolopt "new" rawopts ,new_ = boolopt "new" rawopts
,new_save_ = True ,new_save_ = True
,pivot_ = stringopt "pivot" rawopts ,pivot_ = stringopt "pivot" rawopts
,auto_ = boolopt "auto" rawopts ,auto_ = boolopt "auto" rawopts
} }
--- * parsing utilities --- * parsing utilities
@ -219,7 +219,7 @@ rejp = runErroringJournalParser
genericSourcePos :: SourcePos -> GenericSourcePos genericSourcePos :: SourcePos -> GenericSourcePos
genericSourcePos p = GenericSourcePos (sourceName p) (fromIntegral . unPos $ sourceLine p) (fromIntegral . unPos $ sourceColumn p) 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 :: SourcePos -> SourcePos -> GenericSourcePos
journalSourcePos p p' = JournalSourcePos (sourceName p) (fromIntegral . unPos $ sourceLine p, fromIntegral $ line') journalSourcePos p p' = JournalSourcePos (sourceName p) (fromIntegral . unPos $ sourceLine p, fromIntegral $ line')
where line' where line'
@ -355,7 +355,7 @@ getAmountStyle commodity = do
return effectiveStyle return effectiveStyle
addDeclaredAccountType :: AccountName -> AccountType -> JournalParser m () addDeclaredAccountType :: AccountName -> AccountType -> JournalParser m ()
addDeclaredAccountType acct atype = addDeclaredAccountType acct atype =
modify' (\j -> j{jdeclaredaccounttypes = M.insertWith (++) atype [acct] (jdeclaredaccounttypes j)}) modify' (\j -> j{jdeclaredaccounttypes = M.insertWith (++) atype [acct] (jdeclaredaccounttypes j)})
pushParentAccount :: AccountName -> JournalParser m () pushParentAccount :: AccountName -> JournalParser m ()
@ -542,7 +542,7 @@ secondarydatep primaryDate = char '=' *> datep' (Just primaryYear)
--- ** account names --- ** 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, -- 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). -- in that order. (Ie first add the parent account prefix, then rewrite with aliases).
modifiedaccountnamep :: JournalParser m AccountName modifiedaccountnamep :: JournalParser m AccountName
@ -556,9 +556,9 @@ modifiedaccountnamep = do
joinAccountNames parent joinAccountNames parent
a 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, -- 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, -- Each part is at least one character long, may have single spaces inside it,
-- and starts with a non-whitespace. -- and starts with a non-whitespace.
-- Note, this means "{account}", "%^!" and ";comment" are all accepted -- Note, this means "{account}", "%^!" and ";comment" are all accepted
@ -791,7 +791,7 @@ exponentp = char' 'e' *> signp <*> decimal <?> "exponent"
-- --
-- Returns: -- Returns:
-- - the decimal number -- - 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 decimal point character, if any
-- - the digit group style, if any (digit group character and sizes of digit groups) -- - the digit group style, if any (digit group character and sizes of digit groups)
fromRawNumber fromRawNumber
@ -811,7 +811,7 @@ fromRawNumber raw mExp = case raw of
in Right (quantity, precision, mDecPt, Nothing) in Right (quantity, precision, mDecPt, Nothing)
WithSeparators digitSep digitGrps mDecimals -> case mExp of WithSeparators digitSep digitGrps mDecimals -> case mExp of
Nothing -> Nothing ->
let mDecPt = fmap fst mDecimals let mDecPt = fmap fst mDecimals
decimalGrp = maybe mempty snd mDecimals decimalGrp = maybe mempty snd mDecimals
digitGroupStyle = DigitGroups digitSep (groupSizes digitGrps) 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 -- 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. -- so the next-line comment doesn't get rendered as a same-line comment.
sameLine' | null sameLine && not (null nextLines) = [("",mempty)] sameLine' | null sameLine && not (null nextLines) = [("",mempty)]
| otherwise = sameLine | otherwise = sameLine
(texts, contents) = unzip $ sameLine' ++ nextLines (texts, contents) = unzip $ sameLine' ++ nextLines
strippedCommentText = T.unlines $ map T.strip texts strippedCommentText = T.unlines $ map T.strip texts
commentContent = mconcat contents commentContent = mconcat contents
@ -1306,32 +1306,32 @@ tests_Common = tests "Common" [
tests "amountp" [ tests "amountp" [
test "basic" $ expectParseEq amountp "$47.18" (usd 47.18) test "basic" $ expectParseEq amountp "$47.18" (usd 47.18)
,test "ends with decimal mark" $ expectParseEq amountp "$1." (usd 1 `withPrecision` 0) ,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: -- not precise enough:
-- (usd 10 `withPrecision` 0 `at` (eur 0.5 `withPrecision` 1)) -- `withStyle` asdecimalpoint=Just '.' -- (usd 10 `withPrecision` 0 `at` (eur 0.5 `withPrecision` 1)) -- `withStyle` asdecimalpoint=Just '.'
amount{ amount{
acommodity="$" 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} ,astyle=amountstyle{asprecision=0, asdecimalpoint=Nothing}
,aprice=Just $ UnitPrice $ ,aprice=Just $ UnitPrice $
amount{ amount{
acommodity="€" acommodity="€"
,aquantity=0.5 ,aquantity=0.5
,astyle=amountstyle{asprecision=1, asdecimalpoint=Just '.'} ,astyle=amountstyle{asprecision=1, asdecimalpoint=Just '.'}
} }
} }
,test "total price" $ expectParseEq amountp "$10 @@ €5" ,test "total price" $ expectParseEq amountp "$10 @@ €5"
amount{ amount{
acommodity="$" acommodity="$"
,aquantity=10 ,aquantity=10
,astyle=amountstyle{asprecision=0, asdecimalpoint=Nothing} ,astyle=amountstyle{asprecision=0, asdecimalpoint=Nothing}
,aprice=Just $ TotalPrice $ ,aprice=Just $ TotalPrice $
amount{ amount{
acommodity="€" acommodity="€"
,aquantity=5 ,aquantity=5
,astyle=amountstyle{asprecision=0, asdecimalpoint=Nothing} ,astyle=amountstyle{asprecision=0, asdecimalpoint=Nothing}
} }
} }
] ]
,let p = lift (numberp Nothing) :: JournalParser IO (Quantity, Int, Maybe Char, Maybe DigitGroupStyle) in ,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," ""
,test "." $ expectParseError p ",1." "" ,test "." $ expectParseError p ",1." ""
] ]
,tests "spaceandamountormissingp" [ ,tests "spaceandamountormissingp" [
test "space and amount" $ expectParseEq spaceandamountormissingp " $47.18" (Mixed [usd 47.18]) test "space and amount" $ expectParseEq spaceandamountormissingp " $47.18" (Mixed [usd 47.18])
,test "empty string" $ expectParseEq spaceandamountormissingp "" missingmixedamt ,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 :: InputOpts -> FilePath -> Text -> ExceptT String IO Journal
parse iopts = parseAndFinaliseJournal journalp' iopts parse iopts = parseAndFinaliseJournal journalp' iopts
where where
journalp' = do journalp' = do
-- reverse parsed aliases to ensure that they are applied in order given on commandline -- 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 journalp
-- | Get the account name aliases from options, if any. -- | 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 -- maybe an account type code (ALERX) after two or more spaces
-- XXX added in 1.11, deprecated in 1.13, remove in 1.14 -- XXX added in 1.11, deprecated in 1.13, remove in 1.14
mtypecode :: Maybe Char <- lift $ optional $ try $ do 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" choice $ map char "ALERX"
-- maybe a comment, on this and/or following lines -- maybe a comment, on this and/or following lines
(cmt, tags) <- lift transactioncommentp (cmt, tags) <- lift transactioncommentp
-- maybe Ledger-style subdirectives (ignored) -- maybe Ledger-style subdirectives (ignored)
skipMany indentedlinep skipMany indentedlinep
@ -386,7 +386,7 @@ formatdirectivep expectedsym = do
Amount{acommodity,astyle} <- amountp Amount{acommodity,astyle} <- amountp
_ <- lift followingcommentp _ <- lift followingcommentp
if acommodity==expectedsym if acommodity==expectedsym
then then
if asdecimalpoint astyle == Nothing if asdecimalpoint astyle == Nothing
then customFailure $ parseErrorAt off pleaseincludedecimalpoint then customFailure $ parseErrorAt off pleaseincludedecimalpoint
else return $ dbg2 "style from format subdirective" astyle else return $ dbg2 "style from format subdirective" astyle
@ -532,7 +532,7 @@ transactionmodifierp = do
-- | Parse a periodic transaction -- | Parse a periodic transaction
-- --
-- This reuses periodexprp which parses period expressions on the command line. -- 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 -- 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. -- default year set by a Y directive, which we do need to consider here.
-- We resolve it as follows: in periodic transactions' period expressions, -- We resolve it as follows: in periodic transactions' period expressions,
@ -546,12 +546,12 @@ periodictransactionp = do
lift $ skipMany spacenonewline lift $ skipMany spacenonewline
-- a period expression -- a period expression
off <- getOffset off <- getOffset
-- if there's a default year in effect, use Y/1/1 as base for partial/relative dates -- if there's a default year in effect, use Y/1/1 as base for partial/relative dates
today <- liftIO getCurrentDay today <- liftIO getCurrentDay
mdefaultyear <- getYear mdefaultyear <- getYear
let refdate = case mdefaultyear of let refdate = case mdefaultyear of
Nothing -> today Nothing -> today
Just y -> fromGregorian y 1 1 Just y -> fromGregorian y 1 1
periodExcerpt <- lift $ excerpt_ $ periodExcerpt <- lift $ excerpt_ $
singlespacedtextsatisfyingp (\c -> c /= ';' && c /= '\n') singlespacedtextsatisfyingp (\c -> c /= ';' && c /= '\n')
@ -576,7 +576,7 @@ periodictransactionp = do
case checkPeriodicTransactionStartDate interval span periodtxt of case checkPeriodicTransactionStartDate interval span periodtxt of
Just e -> customFailure $ parseErrorAt off e Just e -> customFailure $ parseErrorAt off e
Nothing -> pure () Nothing -> pure ()
status <- lift statusp <?> "cleared status" status <- lift statusp <?> "cleared status"
code <- lift codep <?> "transaction code" code <- lift codep <?> "transaction code"
description <- lift $ T.strip <$> descriptionp 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 "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 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" let s = "1/1"
ep <- parseWithState mempty{jparsedefaultyear=Just 2018} datep s ep <- parseWithState mempty{jparsedefaultyear=Just 2018} datep s
either (fail.("parse error at "++).customErrorBundlePretty) (const ok) ep either (fail.("parse error at "++).customErrorBundlePretty) (const ok) ep
@ -703,7 +703,7 @@ tests_JournalReader = tests "JournalReader" [
,tests "periodictransactionp" [ ,tests "periodictransactionp" [
test "more period text in comment after one space" $ expectParseEq 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 { nullperiodictransaction {
ptperiodexpr = "monthly from 2018/6" ptperiodexpr = "monthly from 2018/6"
,ptinterval = Months 1 ,ptinterval = Months 1
@ -713,7 +713,7 @@ tests_JournalReader = tests "JournalReader" [
} }
,test "more period text in description after two spaces" $ expectParseEq periodictransactionp ,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 { nullperiodictransaction {
ptperiodexpr = "monthly from 2018/6" ptperiodexpr = "monthly from 2018/6"
,ptinterval = Months 1 ,ptinterval = Months 1
@ -748,16 +748,16 @@ tests_JournalReader = tests "JournalReader" [
] ]
,tests "postingp" [ ,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" " expenses:food:dining $10.00 ; a: a a \n ; b: b b \n"
posting{ posting{
paccount="expenses:food:dining", paccount="expenses:food:dining",
pamount=Mixed [usd 10], pamount=Mixed [usd 10],
pcomment="a: a a\nb: b b\n", pcomment="a: a a\nb: b b\n",
ptags=[("a","a a"), ("b","b b")] 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" " a 1. ; date:2012/11/28, date2=2012/11/29,b:b\n"
nullposting{ nullposting{
paccount="a" paccount="a"
@ -768,14 +768,14 @@ tests_JournalReader = tests "JournalReader" [
,pdate2=Nothing -- Just $ fromGregorian 2012 11 29 ,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" " a 1. ; [2012/11/28=2012/11/29]\n"
nullposting{ nullposting{
paccount="a" paccount="a"
,pamount=Mixed [num 1] ,pamount=Mixed [num 1]
,pcomment="[2012/11/28=2012/11/29]\n" ,pcomment="[2012/11/28=2012/11/29]\n"
,ptags=[] ,ptags=[]
,pdate= Just $ fromGregorian 2012 11 28 ,pdate= Just $ fromGregorian 2012 11 28
,pdate2=Just $ fromGregorian 2012 11 29 ,pdate2=Just $ fromGregorian 2012 11 29
} }
@ -788,7 +788,7 @@ tests_JournalReader = tests "JournalReader" [
,tests "transactionmodifierp" [ ,tests "transactionmodifierp" [
test "basic" $ expectParseEq transactionmodifierp test "basic" $ expectParseEq transactionmodifierp
"= (some value expr)\n some:postings 1.\n" "= (some value expr)\n some:postings 1.\n"
nulltransactionmodifier { nulltransactionmodifier {
tmquerytxt = "(some value expr)" tmquerytxt = "(some value expr)"
@ -797,10 +797,10 @@ tests_JournalReader = tests "JournalReader" [
] ]
,tests "transactionp" [ ,tests "transactionp" [
test "just a date" $ expectParseEq transactionp "2015/1/1\n" nulltransaction{tdate=fromGregorian 2015 1 1} 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 [ (T.unlines [
"2012/05/14=2012/05/15 (code) desc ; tcomment1", "2012/05/14=2012/05/15 (code) desc ; tcomment1",
" ; tcomment2", " ; tcomment2",
@ -833,7 +833,7 @@ tests_JournalReader = tests "JournalReader" [
} }
] ]
} }
,test "parses a well-formed transaction" $ ,test "parses a well-formed transaction" $
expect $ isRight $ rjp transactionp $ T.unlines expect $ isRight $ rjp transactionp $ T.unlines
["2007/01/28 coopportunity" ["2007/01/28 coopportunity"
@ -841,10 +841,10 @@ tests_JournalReader = tests "JournalReader" [
," assets:checking $-47.18" ," assets:checking $-47.18"
,"" ,""
] ]
,test "does not parse a following comment as part of the description" $ ,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" expectParseEqOn transactionp "2009/1/1 a ;comment\n b 1\n" tdescription "a"
,test "transactionp parses a following whitespace line" $ ,test "transactionp parses a following whitespace line" $
expect $ isRight $ rjp transactionp $ T.unlines expect $ isRight $ rjp transactionp $ T.unlines
["2012/1/1" ["2012/1/1"
@ -863,7 +863,7 @@ tests_JournalReader = tests "JournalReader" [
] ]
,test "comments everywhere, two postings parsed" $ ,test "comments everywhere, two postings parsed" $
expectParseEqOn transactionp expectParseEqOn transactionp
(T.unlines (T.unlines
["2009/1/1 x ; transaction comment" ["2009/1/1 x ; transaction comment"
," a 1 ; posting 1 comment" ," a 1 ; posting 1 comment"
@ -873,13 +873,13 @@ tests_JournalReader = tests "JournalReader" [
]) ])
(length . tpostings) (length . tpostings)
2 2
] ]
-- directives -- directives
,tests "directivep" [ ,tests "directivep" [
test "supports !" $ do test "supports !" $ do
expectParseE directivep "!account a\n" expectParseE directivep "!account a\n"
expectParseE directivep "!D 1.0\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 -- As all ledger line types can be distinguished by the first
-- character, excepting transactions versus empty (blank or -- character, excepting transactions versus empty (blank or
-- comment-only) lines, can use choice w/o try -- comment-only) lines, can use choice w/o try
timeclockitemp = choice [ timeclockitemp = choice [
void (lift emptyorcommentlinep) void (lift emptyorcommentlinep)
, timeclockentryp >>= \e -> modify' (\j -> j{jparsetimeclockentries = e : jparsetimeclockentries j}) , timeclockentryp >>= \e -> modify' (\j -> j{jparsetimeclockentries = e : jparsetimeclockentries j})
] <?> "timeclock entry, or default year or historical price directive" ] <?> "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 (q, _, _, _) <- lift $ numberp Nothing
msymbol <- optional $ choice $ map (string . fst) timeUnits msymbol <- optional $ choice $ map (string . fst) timeUnits
lift (skipMany spacenonewline) lift (skipMany spacenonewline)
let q' = let q' =
case msymbol of case msymbol of
Nothing -> q Nothing -> q
Just sym -> Just sym ->
case lookup sym timeUnits of case lookup sym timeUnits of
Just mult -> q * mult Just mult -> q * mult
Nothing -> q -- shouldn't happen.. ignore Nothing -> q -- shouldn't happen.. ignore
return q' return q'
-- (symbol, equivalent in hours). -- (symbol, equivalent in hours).
timeUnits = timeUnits =
[("s",2.777777777777778e-4) [("s",2.777777777777778e-4)
,("mo",5040) -- before "m" ,("mo",5040) -- before "m"

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

@ -11,7 +11,7 @@ module Hledger.Reports.BalanceReport (
BalanceReportItem, BalanceReportItem,
balanceReport, balanceReport,
flatShowsExclusiveBalance, flatShowsExclusiveBalance,
sortAccountItemsLike, sortAccountItemsLike,
-- * Tests -- * Tests
tests_BalanceReport tests_BalanceReport
@ -26,7 +26,7 @@ import Data.Time.Calendar
import Hledger.Data import Hledger.Data
import Hledger.Read (mamountp') import Hledger.Read (mamountp')
import Hledger.Query import Hledger.Query
import Hledger.Utils import Hledger.Utils
import Hledger.Reports.ReportOptions import Hledger.Reports.ReportOptions
@ -64,8 +64,8 @@ flatShowsExclusiveBalance = True
-- This is like PeriodChangeReport with a single column (but more mature, -- This is like PeriodChangeReport with a single column (but more mature,
-- eg this can do hierarchical display). -- eg this can do hierarchical display).
balanceReport :: ReportOpts -> Query -> Journal -> BalanceReport balanceReport :: ReportOpts -> Query -> Journal -> BalanceReport
balanceReport ropts@ReportOpts{..} q j@Journal{..} = balanceReport ropts@ReportOpts{..} q j@Journal{..} =
(if invert_ then brNegate else id) $ (if invert_ then brNegate else id) $
(sorteditems, total) (sorteditems, total)
where where
-- dbg1 = const id -- exclude from debug output -- 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 items = dbg1 "items" $ map (balanceReportItem ropts q) displayaccts
-- Sort report rows (except sorting by amount in tree mode, which was done above). -- Sort report rows (except sorting by amount in tree mode, which was done above).
sorteditems sorteditems
| sort_amount_ && tree_ ropts = items | sort_amount_ && tree_ ropts = items
| sort_amount_ = sortFlatBRByAmount items | sort_amount_ = sortFlatBRByAmount items
| otherwise = sortBRByAccountDeclaration items | otherwise = sortBRByAccountDeclaration items
where where
-- Sort the report rows, representing a flat account list, by row total. -- Sort the report rows, representing a flat account list, by row total.
sortFlatBRByAmount :: [BalanceReportItem] -> [BalanceReportItem] sortFlatBRByAmount :: [BalanceReportItem] -> [BalanceReportItem]
sortFlatBRByAmount = sortBy (maybeflip $ comparing (normaliseMixedAmountSquashPricesForDisplay . fourth4)) sortFlatBRByAmount = sortBy (maybeflip $ comparing (normaliseMixedAmountSquashPricesForDisplay . fourth4))
where where
maybeflip = if normalbalance_ == Just NormallyNegative then id else flip 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 :: [BalanceReportItem] -> [BalanceReportItem]
sortBRByAccountDeclaration rows = sortedrows sortBRByAccountDeclaration rows = sortedrows
where where
anamesandrows = [(first4 r, r) | r <- rows] anamesandrows = [(first4 r, r) | r <- rows]
anames = map fst anamesandrows anames = map fst anamesandrows
sortedanames = sortAccountNamesByDeclaration j (tree_ ropts) anames sortedanames = sortAccountNamesByDeclaration j (tree_ ropts) anames
sortedrows = sortAccountItemsLike sortedanames anamesandrows sortedrows = sortAccountItemsLike sortedanames anamesandrows
-- Calculate the grand total. -- Calculate the grand total.
total | not (flat_ ropts) = dbg1 "total" $ sum [amt | (_,_,indent,amt) <- items, indent == 0] 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 -- | 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. -- to match the provided ordering of those same account names.
sortAccountItemsLike :: [AccountName] -> [(AccountName, b)] -> [b] sortAccountItemsLike :: [AccountName] -> [(AccountName, b)] -> [b]
sortAccountItemsLike sortedas items = sortAccountItemsLike sortedas items =
concatMap (\a -> maybe [] (:[]) $ lookup a items) sortedas concatMap (\a -> maybe [] (:[]) $ lookup a items) sortedas
@ -181,7 +181,7 @@ balanceReportItem opts q a
-- | Flip the sign of all amounts in a BalanceReport. -- | Flip the sign of all amounts in a BalanceReport.
brNegate :: BalanceReport -> BalanceReport brNegate :: BalanceReport -> BalanceReport
brNegate (is, tot) = (map brItemNegate is, -tot) brNegate (is, tot) = (map brItemNegate is, -tot)
where where
brItemNegate (a, a', d, amt) = (a, a', d, -amt) brItemNegate (a, a', d, amt) = (a, a', d, -amt)
@ -222,10 +222,10 @@ tests_BalanceReport = tests "BalanceReport" [
(showMixedAmountDebug etotal) `is` (showMixedAmountDebug atotal) (showMixedAmountDebug etotal) `is` (showMixedAmountDebug atotal)
usd0 = usd 0 usd0 = usd 0
in [ in [
test "balanceReport with no args on null journal" $ test "balanceReport with no args on null journal" $
(defreportopts, nulljournal) `gives` ([], Mixed [nullamt]) (defreportopts, nulljournal) `gives` ([], Mixed [nullamt])
,test "balanceReport with no args on sample journal" $ ,test "balanceReport with no args on sample journal" $
(defreportopts, samplejournal) `gives` (defreportopts, samplejournal) `gives`
([ ([
@ -242,7 +242,7 @@ tests_BalanceReport = tests "BalanceReport" [
,("income:salary","salary",1, mamountp' "$-1.00") ,("income:salary","salary",1, mamountp' "$-1.00")
], ],
Mixed [usd0]) Mixed [usd0])
,test "balanceReport with --depth=N" $ ,test "balanceReport with --depth=N" $
(defreportopts{depth_=Just 1}, samplejournal) `gives` (defreportopts{depth_=Just 1}, samplejournal) `gives`
([ ([
@ -250,7 +250,7 @@ tests_BalanceReport = tests "BalanceReport" [
,("income", "income", 0, mamountp' "$-2.00") ,("income", "income", 0, mamountp' "$-2.00")
], ],
Mixed [usd0]) Mixed [usd0])
,test "balanceReport with depth:N" $ ,test "balanceReport with depth:N" $
(defreportopts{query_="depth:1"}, samplejournal) `gives` (defreportopts{query_="depth:1"}, samplejournal) `gives`
([ ([
@ -258,7 +258,7 @@ tests_BalanceReport = tests "BalanceReport" [
,("income", "income", 0, mamountp' "$-2.00") ,("income", "income", 0, mamountp' "$-2.00")
], ],
Mixed [usd0]) Mixed [usd0])
,tests "balanceReport with a date or secondary date span" [ ,tests "balanceReport with a date or secondary date span" [
(defreportopts{query_="date:'in 2009'"}, samplejournal2) `gives` (defreportopts{query_="date:'in 2009'"}, samplejournal2) `gives`
([], ([],
@ -278,7 +278,7 @@ tests_BalanceReport = tests "BalanceReport" [
,("income:salary","income:salary",0, mamountp' "$-1.00") ,("income:salary","income:salary",0, mamountp' "$-1.00")
], ],
Mixed [usd0]) Mixed [usd0])
,test "balanceReport with not:desc:" $ ,test "balanceReport with not:desc:" $
(defreportopts{query_="not:desc:income"}, samplejournal) `gives` (defreportopts{query_="not:desc:income"}, samplejournal) `gives`
([ ([
@ -291,7 +291,7 @@ tests_BalanceReport = tests "BalanceReport" [
,("income:gifts","income:gifts",0, mamountp' "$-1.00") ,("income:gifts","income:gifts",0, mamountp' "$-1.00")
], ],
Mixed [usd0]) Mixed [usd0])
,test "balanceReport with period on a populated period" $ ,test "balanceReport with period on a populated period" $
(defreportopts{period_= PeriodBetween (fromGregorian 2008 1 1) (fromGregorian 2008 1 2)}, samplejournal) `gives` (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") ,("income:salary","income:salary",0, mamountp' "$-1.00")
], ],
Mixed [usd0]) Mixed [usd0])
,test "balanceReport with period on an unpopulated period" $ ,test "balanceReport with period on an unpopulated period" $
(defreportopts{period_= PeriodBetween (fromGregorian 2008 1 2) (fromGregorian 2008 1 3)}, samplejournal) `gives` (defreportopts{period_= PeriodBetween (fromGregorian 2008 1 2) (fromGregorian 2008 1 3)}, samplejournal) `gives`
([],Mixed [nullamt]) ([],Mixed [nullamt])
{- {-
,test "accounts report with account pattern o" ~: ,test "accounts report with account pattern o" ~:
defreportopts{patterns_=["o"]} `gives` defreportopts{patterns_=["o"]} `gives`
@ -317,7 +317,7 @@ tests_BalanceReport = tests "BalanceReport" [
,"--------------------" ,"--------------------"
," $-1" ," $-1"
] ]
,test "accounts report with account pattern o and --depth 1" ~: ,test "accounts report with account pattern o and --depth 1" ~:
defreportopts{patterns_=["o"],depth_=Just 1} `gives` defreportopts{patterns_=["o"],depth_=Just 1} `gives`
[" $1 expenses" [" $1 expenses"
@ -325,7 +325,7 @@ tests_BalanceReport = tests "BalanceReport" [
,"--------------------" ,"--------------------"
," $-1" ," $-1"
] ]
,test "accounts report with account pattern a" ~: ,test "accounts report with account pattern a" ~:
defreportopts{patterns_=["a"]} `gives` defreportopts{patterns_=["a"]} `gives`
[" $-1 assets" [" $-1 assets"
@ -336,7 +336,7 @@ tests_BalanceReport = tests "BalanceReport" [
,"--------------------" ,"--------------------"
," $-1" ," $-1"
] ]
,test "accounts report with account pattern e" ~: ,test "accounts report with account pattern e" ~:
defreportopts{patterns_=["e"]} `gives` defreportopts{patterns_=["e"]} `gives`
[" $-1 assets" [" $-1 assets"
@ -352,7 +352,7 @@ tests_BalanceReport = tests "BalanceReport" [
,"--------------------" ,"--------------------"
," 0" ," 0"
] ]
,test "accounts report with unmatched parent of two matched subaccounts" ~: ,test "accounts report with unmatched parent of two matched subaccounts" ~:
defreportopts{patterns_=["cash","saving"]} `gives` defreportopts{patterns_=["cash","saving"]} `gives`
[" $-1 assets" [" $-1 assets"
@ -361,14 +361,14 @@ tests_BalanceReport = tests "BalanceReport" [
,"--------------------" ,"--------------------"
," $-1" ," $-1"
] ]
,test "accounts report with multi-part account name" ~: ,test "accounts report with multi-part account name" ~:
defreportopts{patterns_=["expenses:food"]} `gives` defreportopts{patterns_=["expenses:food"]} `gives`
[" $1 expenses:food" [" $1 expenses:food"
,"--------------------" ,"--------------------"
," $1" ," $1"
] ]
,test "accounts report with negative account pattern" ~: ,test "accounts report with negative account pattern" ~:
defreportopts{patterns_=["not:assets"]} `gives` defreportopts{patterns_=["not:assets"]} `gives`
[" $2 expenses" [" $2 expenses"
@ -381,20 +381,20 @@ tests_BalanceReport = tests "BalanceReport" [
,"--------------------" ,"--------------------"
," $1" ," $1"
] ]
,test "accounts report negative account pattern always matches full name" ~: ,test "accounts report negative account pattern always matches full name" ~:
defreportopts{patterns_=["not:e"]} `gives` defreportopts{patterns_=["not:e"]} `gives`
["--------------------" ["--------------------"
," 0" ," 0"
] ]
,test "accounts report negative patterns affect totals" ~: ,test "accounts report negative patterns affect totals" ~:
defreportopts{patterns_=["expenses","not:food"]} `gives` defreportopts{patterns_=["expenses","not:food"]} `gives`
[" $1 expenses:supplies" [" $1 expenses:supplies"
,"--------------------" ,"--------------------"
," $1" ," $1"
] ]
,test "accounts report with -E shows zero-balance accounts" ~: ,test "accounts report with -E shows zero-balance accounts" ~:
defreportopts{patterns_=["assets"],empty_=True} `gives` defreportopts{patterns_=["assets"],empty_=True} `gives`
[" $-1 assets" [" $-1 assets"
@ -405,7 +405,7 @@ tests_BalanceReport = tests "BalanceReport" [
,"--------------------" ,"--------------------"
," $-1" ," $-1"
] ]
,test "accounts report with cost basis" $ ,test "accounts report with cost basis" $
j <- (readJournal def Nothing $ unlines 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 -- and that reports with and without --empty make sense when compared side by side
ropts = ropts' { accountlistmode_ = ALTree } ropts = ropts' { accountlistmode_ = ALTree }
showunbudgeted = empty_ ropts showunbudgeted = empty_ ropts
q = queryFromOpts d ropts q = queryFromOpts d ropts
budgetedaccts = budgetedaccts =
dbg2 "budgetedacctsinperiod" $ dbg2 "budgetedacctsinperiod" $
nub $ nub $
concatMap expandAccountName $ concatMap expandAccountName $
accountNamesFromPostings $ accountNamesFromPostings $
concatMap tpostings $ concatMap tpostings $
concatMap (flip runPeriodicTransaction reportspan) $ concatMap (flip runPeriodicTransaction reportspan) $
jperiodictxns j jperiodictxns j
actualj = dbg1 "actualj" $ budgetRollUp budgetedaccts showunbudgeted j actualj = dbg1 "actualj" $ budgetRollUp budgetedaccts showunbudgeted j
budgetj = dbg1 "budgetj" $ budgetJournal assrt ropts reportspan 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@(MultiBalanceReport (_, budgetgoalitems, budgetgoaltotals)) = dbg1 "budgetgoalreport" $ multiBalanceReport (ropts{empty_=True}) q budgetj
budgetgoalreport' budgetgoalreport'
-- If no interval is specified: -- If no interval is specified:
-- budgetgoalreport's span might be shorter actualreport's due to periodic txns; -- 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. -- it should be safe to replace it with the latter, so they combine well.
| interval_ ropts == NoInterval = MultiBalanceReport (actualspans, budgetgoalitems, budgetgoaltotals) | interval_ ropts == NoInterval = MultiBalanceReport (actualspans, budgetgoalitems, budgetgoaltotals)
| otherwise = budgetgoalreport | otherwise = budgetgoalreport
budgetreport = combineBudgetAndActual budgetgoalreport' actualreport budgetreport = combineBudgetAndActual budgetgoalreport' actualreport
sortedbudgetreport = sortBudgetReport ropts j budgetreport sortedbudgetreport = sortBudgetReport ropts j budgetreport
in in
@ -100,13 +100,13 @@ budgetReport ropts' assrt reportspan d j =
sortBudgetReport :: ReportOpts -> Journal -> BudgetReport -> BudgetReport sortBudgetReport :: ReportOpts -> Journal -> BudgetReport -> BudgetReport
sortBudgetReport ropts j (PeriodicReport (ps, rows, trow)) = PeriodicReport (ps, sortedrows, trow) sortBudgetReport ropts j (PeriodicReport (ps, rows, trow)) = PeriodicReport (ps, sortedrows, trow)
where where
sortedrows sortedrows
| sort_amount_ ropts && tree_ ropts = sortTreeBURByActualAmount rows | sort_amount_ ropts && tree_ ropts = sortTreeBURByActualAmount rows
| sort_amount_ ropts = sortFlatBURByActualAmount rows | sort_amount_ ropts = sortFlatBURByActualAmount rows
| otherwise = sortByAccountDeclaration rows | otherwise = sortByAccountDeclaration rows
-- Sort a tree-mode budget report's rows by total actual amount at each level. -- Sort a tree-mode budget report's rows by total actual amount at each level.
sortTreeBURByActualAmount :: [BudgetReportRow] -> [BudgetReportRow] sortTreeBURByActualAmount :: [BudgetReportRow] -> [BudgetReportRow]
sortTreeBURByActualAmount rows = sortedrows sortTreeBURByActualAmount rows = sortedrows
where where
anamesandrows = [(first6 r, r) | r <- rows] anamesandrows = [(first6 r, r) | r <- rows]
@ -116,21 +116,21 @@ sortBudgetReport ropts j (PeriodicReport (ps, rows, trow)) = PeriodicReport (ps,
accounttreewithbals = mapAccounts setibalance accounttree accounttreewithbals = mapAccounts setibalance accounttree
where where
setibalance a = a{aibalance= setibalance a = a{aibalance=
fromMaybe 0 $ -- when there's no actual amount, assume 0; will mess up with negative amounts ? 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 fromMaybe (error "sortTreeByAmount 1") $ -- should not happen, but it's ugly; TODO
lookup (aname a) atotals lookup (aname a) atotals
} }
sortedaccounttree = sortAccountTreeByAmount (fromMaybe NormallyPositive $ normalbalance_ ropts) accounttreewithbals sortedaccounttree = sortAccountTreeByAmount (fromMaybe NormallyPositive $ normalbalance_ ropts) accounttreewithbals
sortedanames = map aname $ drop 1 $ flattenAccounts sortedaccounttree 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. -- Sort a flat-mode budget report's rows by total actual amount.
sortFlatBURByActualAmount :: [BudgetReportRow] -> [BudgetReportRow] sortFlatBURByActualAmount :: [BudgetReportRow] -> [BudgetReportRow]
sortFlatBURByActualAmount = sortBy (maybeflip $ comparing (fst . fifth6)) sortFlatBURByActualAmount = sortBy (maybeflip $ comparing (fst . fifth6))
where where
maybeflip = if normalbalance_ ropts == Just NormallyNegative then id else flip 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. -- <unbudgeted> remains at the top.
sortByAccountDeclaration rows = sortedrows sortByAccountDeclaration rows = sortedrows
where where
@ -138,9 +138,9 @@ sortBudgetReport ropts j (PeriodicReport (ps, rows, trow)) = PeriodicReport (ps,
anamesandrows = [(first6 r, r) | r <- rows'] anamesandrows = [(first6 r, r) | r <- rows']
anames = map fst anamesandrows anames = map fst anamesandrows
sortedanames = sortAccountNamesByDeclaration j (tree_ ropts) anames 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 in the specified report period.
-- Budget transactions are similar to forecast transactions except -- Budget transactions are similar to forecast transactions except
-- their purpose is to set goal amounts (of change) per account and period. -- 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: -- | 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. -- under the "unbudgeted" top level account.
-- --
-- 2. subaccounts with no budget goal are merged with their closest parent 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. -- This can be disabled by --empty.
-- --
budgetRollUp :: [AccountName] -> Bool -> Journal -> Journal budgetRollUp :: [AccountName] -> Bool -> Journal -> Journal
@ -176,7 +176,7 @@ budgetRollUp budgetedaccts showunbudgeted j = j { jtxns = remapTxn <$> jtxns j }
where where
remapAccount a remapAccount a
| hasbudget = 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 | otherwise = if showunbudgeted then u <> acctsep <> a else u
where where
hasbudget = a `elem` budgetedaccts 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. -- | Render a budget report as plain text suitable for console output.
budgetReportAsText :: ReportOpts -> BudgetReport -> String budgetReportAsText :: ReportOpts -> BudgetReport -> String
budgetReportAsText ropts@ReportOpts{..} budgetr@(PeriodicReport ( _, rows, _)) = budgetReportAsText ropts@ReportOpts{..} budgetr@(PeriodicReport ( _, rows, _)) =
title ++ "\n\n" ++ title ++ "\n\n" ++
tableAsText ropts showcell (maybetranspose $ budgetReportAsTable ropts budgetr) tableAsText ropts showcell (maybetranspose $ budgetReportAsTable ropts budgetr)
where where
multiperiod = interval_ /= NoInterval multiperiod = interval_ /= NoInterval
@ -319,7 +319,7 @@ budgetReportAsText ropts@ReportOpts{..} budgetr@(PeriodicReport ( _, rows, _)) =
percentage :: Change -> BudgetGoal -> Maybe Percentage percentage :: Change -> BudgetGoal -> Maybe Percentage
percentage actual budget = percentage actual budget =
case (maybecost $ normaliseMixedAmount actual, maybecost $ normaliseMixedAmount budget) of 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 -> Just $ 100 * aquantity a / aquantity b
_ -> -- trace (pshow $ (maybecost actual, maybecost budget)) -- debug missing percentage _ -> -- trace (pshow $ (maybecost actual, maybecost budget)) -- debug missing percentage
Nothing Nothing
@ -337,14 +337,14 @@ budgetReportAsText ropts@ReportOpts{..} budgetr@(PeriodicReport ( _, rows, _)) =
-- | Build a 'Table' from a multi-column balance report. -- | Build a 'Table' from a multi-column balance report.
budgetReportAsTable :: ReportOpts -> BudgetReport -> Table String String (Maybe MixedAmount, Maybe MixedAmount) budgetReportAsTable :: ReportOpts -> BudgetReport -> Table String String (Maybe MixedAmount, Maybe MixedAmount)
budgetReportAsTable budgetReportAsTable
ropts ropts
(PeriodicReport (PeriodicReport
( periods ( periods
, rows , rows
, (_, _, _, coltots, grandtot, grandavg) , (_, _, _, coltots, grandtot, grandavg)
)) = )) =
addtotalrow $ addtotalrow $
Table Table
(T.Group NoLine $ map Header accts) (T.Group NoLine $ map Header accts)
(T.Group NoLine $ map Header colheadings) (T.Group NoLine $ map Header colheadings)
@ -368,7 +368,7 @@ budgetReportAsTable
)) ))
-- XXX here for now -- 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. -- | Drop leading components of accounts names as specified by --drop, but only in --flat mode.
maybeAccountNameDrop :: ReportOpts -> AccountName -> AccountName maybeAccountNameDrop :: ReportOpts -> AccountName -> AccountName
maybeAccountNameDrop opts a | flat_ opts = accountNameDrop (drop_ opts) a 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.Data
import Hledger.Query import Hledger.Query
import Hledger.Reports.ReportOptions import Hledger.Reports.ReportOptions
import Hledger.Utils import Hledger.Utils
-- | A journal entries report is a list of whole transactions as -- | 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.Data
import Hledger.Query import Hledger.Query
import Hledger.Utils import Hledger.Utils
import Hledger.Read (mamountp') import Hledger.Read (mamountp')
import Hledger.Reports.ReportOptions import Hledger.Reports.ReportOptions
import Hledger.Reports.BalanceReport import Hledger.Reports.BalanceReport
@ -85,13 +85,13 @@ type ClippedAccountName = AccountName
-- | Generate a multicolumn balance report for the matched accounts, -- | Generate a multicolumn balance report for the matched accounts,
-- showing the change of balance, accumulated balance, or historical balance -- showing the change of balance, accumulated balance, or historical balance
-- in each of the specified periods. Does not support tree-mode boring parent eliding. -- 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). -- (see ReportOpts and CompoundBalanceCommand).
-- hledger's most powerful and useful report, used by the balance -- hledger's most powerful and useful report, used by the balance
-- command (in multiperiod mode) and by the bs/cf/is commands. -- command (in multiperiod mode) and by the bs/cf/is commands.
multiBalanceReport :: ReportOpts -> Query -> Journal -> MultiBalanceReport multiBalanceReport :: ReportOpts -> Query -> Journal -> MultiBalanceReport
multiBalanceReport ropts@ReportOpts{..} q j@Journal{..} = multiBalanceReport ropts@ReportOpts{..} q j@Journal{..} =
(if invert_ then mbrNegate else id) $ (if invert_ then mbrNegate else id) $
MultiBalanceReport (colspans, sortedrows, totalsrow) MultiBalanceReport (colspans, sortedrows, totalsrow)
where where
dbg1 s = let p = "multiBalanceReport" in Hledger.Utils.dbg1 (p++" "++s) -- add prefix in this function's debug output 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, -- This list can be empty if the journal was empty,
-- or if hledger-ui has added its special date:-tomorrow to the query -- or if hledger-ui has added its special date:-tomorrow to the query
-- and all txns are in the future. -- 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. -- 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) reportspan = dbg1 "reportspan" $ DateSpan (maybe Nothing spanStart $ headMay intervalspans)
(maybe Nothing spanEnd $ lastMay intervalspans) (maybe Nothing spanEnd $ lastMay intervalspans)
mreportstart = spanStart reportspan mreportstart = spanStart reportspan
-- The user's query with no depth limit, and expanded to the report span -- 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 -- if there is one (otherwise any date queries are left as-is, which
-- handles the hledger-ui+future txns case above). -- handles the hledger-ui+future txns case above).
reportq = dbg1 "reportq" $ depthless $ reportq = dbg1 "reportq" $ depthless $
if reportspan == nulldatespan if reportspan == nulldatespan
then q then q
else And [datelessq, reportspandatesq] else And [datelessq, reportspandatesq]
where where
reportspandatesq = dbg1 "reportspandatesq" $ dateqcons reportspan reportspandatesq = dbg1 "reportspandatesq" $ dateqcons reportspan
@ -157,12 +157,12 @@ multiBalanceReport ropts@ReportOpts{..} q j@Journal{..} =
precedingperiod = dateSpanAsPeriod $ spanIntersect (DateSpan Nothing mreportstart) $ periodAsDateSpan period_ precedingperiod = dateSpanAsPeriod $ spanIntersect (DateSpan Nothing mreportstart) $ periodAsDateSpan period_
-- q projected back before the report start date. -- 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), -- 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] startbalq = dbg1 "startbalq" $ And [datelessq, dateqcons precedingspan]
where where
precedingspan = case mreportstart of precedingspan = case mreportstart of
Just d -> DateSpan Nothing (Just d) Just d -> DateSpan Nothing (Just d)
Nothing -> emptydatespan Nothing -> emptydatespan
-- The matched accounts with a starting balance. All of these should appear -- 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. -- in the report even if they have no postings during the report period.
startaccts = dbg1 "startaccts" $ map fst startbals 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 (error' "multiBalanceReport: expected all spans to have an end date") -- XXX should not happen
(addDays (-1))) (addDays (-1)))
. spanEnd) colspans . spanEnd) colspans
---------------------------------------------------------------------- ----------------------------------------------------------------------
-- 7. Sort the report rows. -- 7. Sort the report rows.
@ -307,24 +307,24 @@ multiBalanceReport ropts@ReportOpts{..} q j@Journal{..} =
accounttree = accountTree "root" anames accounttree = accountTree "root" anames
accounttreewithbals = mapAccounts setibalance accounttree accounttreewithbals = mapAccounts setibalance accounttree
where 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} setibalance a = a{aibalance=fromMaybe (error "sortTreeMBRByAmount 1") $ lookup (aname a) atotals}
sortedaccounttree = sortAccountTreeByAmount (fromMaybe NormallyPositive normalbalance_) accounttreewithbals sortedaccounttree = sortAccountTreeByAmount (fromMaybe NormallyPositive normalbalance_) accounttreewithbals
sortedanames = map aname $ drop 1 $ flattenAccounts sortedaccounttree 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)) sortFlatMBRByAmount = sortBy (maybeflip $ comparing (normaliseMixedAmountSquashPricesForDisplay . fifth6))
where where
maybeflip = if normalbalance_ == Just NormallyNegative then id else flip 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 sortMBRByAccountDeclaration rows = sortedrows
where where
anamesandrows = [(first6 r, r) | r <- rows] anamesandrows = [(first6 r, r) | r <- rows]
anames = map fst anamesandrows anames = map fst anamesandrows
sortedanames = sortAccountNamesByDeclaration j (tree_ ropts) anames sortedanames = sortAccountNamesByDeclaration j (tree_ ropts) anames
sortedrows = sortAccountItemsLike sortedanames anamesandrows sortedrows = sortAccountItemsLike sortedanames anamesandrows
---------------------------------------------------------------------- ----------------------------------------------------------------------
-- 8. Build the report totals row. -- 8. Build the report totals row.
@ -364,9 +364,9 @@ multiBalanceReportSpan :: MultiBalanceReport -> DateSpan
multiBalanceReportSpan (MultiBalanceReport ([], _, _)) = DateSpan Nothing Nothing multiBalanceReportSpan (MultiBalanceReport ([], _, _)) = DateSpan Nothing Nothing
multiBalanceReportSpan (MultiBalanceReport (colspans, _, _)) = DateSpan (spanStart $ head colspans) (spanEnd $ last colspans) multiBalanceReportSpan (MultiBalanceReport (colspans, _, _)) = DateSpan (spanStart $ head colspans) (spanEnd $ last colspans)
-- | Generates a simple non-columnar BalanceReport, but using multiBalanceReport, -- | Generates a simple non-columnar BalanceReport, but using multiBalanceReport,
-- in order to support --historical. Does not support tree-mode boring parent eliding. -- 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 -- If the normalbalance_ option is set, it adjusts the sorting and sign of amounts
-- (see ReportOpts and CompoundBalanceCommand). -- (see ReportOpts and CompoundBalanceCommand).
balanceReportFromMultiBalanceReport :: ReportOpts -> Query -> Journal -> BalanceReport balanceReportFromMultiBalanceReport :: ReportOpts -> Query -> Journal -> BalanceReport
balanceReportFromMultiBalanceReport opts q j = (rows', total) 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 ((\(_, b, _) -> showMixedAmountDebug b) atotal) `is` (showMixedAmountDebug etotal) -- we only check the sum of the totals
usd0 = usd 0 usd0 = usd 0
amount0 = Amount {acommodity="$", aquantity=0, aprice=Nothing, astyle=AmountStyle {ascommodityside = L, ascommodityspaced = False, asprecision = 2, asdecimalpoint = Just '.', asdigitgroups = Nothing}, aismultiplier=False} 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" [ tests "multiBalanceReport" [
test "null journal" $ test "null journal" $
(defreportopts, nulljournal) `gives` ([], Mixed [nullamt]) (defreportopts, nulljournal) `gives` ([], Mixed [nullamt])
,test "with -H on a populated period" $ ,test "with -H on a populated period" $
(defreportopts{period_= PeriodBetween (fromGregorian 2008 1 1) (fromGregorian 2008 1 2), balancetype_=HistoricalBalance}, samplejournal) `gives` (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)}]) ,("income:salary" ,"salary" , 2, [mamountp' "$-1.00"], Mixed [nullamt], Mixed [amount0 {aquantity=(-1)}])
], ],
Mixed [nullamt]) Mixed [nullamt])
,_test "a valid history on an empty period" $ ,_test "a valid history on an empty period" $
(defreportopts{period_= PeriodBetween (fromGregorian 2008 1 2) (fromGregorian 2008 1 3), balancetype_=HistoricalBalance}, samplejournal) `gives` (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)}]) ,("income:salary","salary",2, [mamountp' "$-1.00"], mamountp' "$-1.00",Mixed [amount0 {aquantity=(-1)}])
], ],
Mixed [usd0]) Mixed [usd0])
,_test "a valid history on an empty period (more complex)" $ ,_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` (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.Data
import Hledger.Query import Hledger.Query
import Hledger.Utils import Hledger.Utils
import Hledger.Reports.ReportOptions 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. -- Postings, or summary postings with their subperiod's end date, to be displayed.
displayps :: [(Posting, Maybe Day)] displayps :: [(Posting, Maybe Day)]
| multiperiod = | multiperiod =
let summaryps = summarisePostingsByInterval interval_ whichdate depth showempty reportspan reportps let summaryps = summarisePostingsByInterval interval_ whichdate depth showempty reportspan reportps
in [(pvalue p lastday, Just periodend) | (p, periodend) <- summaryps, let lastday = addDays (-1) periodend] in [(pvalue p lastday, Just periodend) | (p, periodend) <- summaryps, let lastday = addDays (-1) periodend]
| otherwise = | otherwise =
@ -286,13 +286,13 @@ tests_PostingsReport = tests "PostingsReport" [
,(Depth 2, samplejournal) `gives` 13 ,(Depth 2, samplejournal) `gives` 13
,(And [Depth 1, StatusQ Cleared, Acct "expenses"], samplejournal) `gives` 2 ,(And [Depth 1, StatusQ Cleared, Acct "expenses"], samplejournal) `gives` 2
,(And [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 -- with query and/or command-line options
,(length $ snd $ postingsReport defreportopts Any samplejournal) `is` 13 ,(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} Any samplejournal) `is` 11
,(length $ snd $ postingsReport defreportopts{interval_=Months 1, empty_=True} Any samplejournal) `is` 20 ,(length $ snd $ postingsReport defreportopts{interval_=Months 1, empty_=True} Any samplejournal) `is` 20
,(length $ snd $ postingsReport defreportopts (Acct "assets:bank:checking") samplejournal) `is` 5 ,(length $ snd $ postingsReport defreportopts (Acct "assets:bank:checking") samplejournal) `is` 5
-- (defreportopts, And [Acct "a a", Acct "'b"], samplejournal2) `gives` 0 -- (defreportopts, And [Acct "a a", Acct "'b"], samplejournal2) `gives` 0
-- [(Just (parsedate "2008-01-01","income"),assets:bank:checking $1,$1) -- [(Just (parsedate "2008-01-01","income"),assets:bank:checking $1,$1)
-- ,(Nothing,income:salary $-1,0) -- ,(Nothing,income:salary $-1,0)
@ -304,7 +304,7 @@ tests_PostingsReport = tests "PostingsReport" [
-- ,(Nothing,expenses:supplies $1,$2) -- ,(Nothing,expenses:supplies $1,$2)
-- ,(Nothing,assets:cash $-2,0) -- ,(Nothing,assets:cash $-2,0)
-- ,(Just (2008-12-31,"pay off"),liabilities:debts $1,$1) -- ,(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 let opts = defreportopts
@ -321,7 +321,7 @@ tests_PostingsReport = tests "PostingsReport" [
,"2008/12/31 pay off liabilities:debts $1 $1" ,"2008/12/31 pay off liabilities:debts $1 $1"
," assets:bank:checking $-1 0" ," assets:bank:checking $-1 0"
] ]
,"postings report with cleared option" ~: ,"postings report with cleared option" ~:
do do
let opts = defreportopts{cleared_=True} let opts = defreportopts{cleared_=True}
@ -333,7 +333,7 @@ tests_PostingsReport = tests "PostingsReport" [
,"2008/12/31 pay off liabilities:debts $1 $1" ,"2008/12/31 pay off liabilities:debts $1 $1"
," assets:bank:checking $-1 0" ," assets:bank:checking $-1 0"
] ]
,"postings report with uncleared option" ~: ,"postings report with uncleared option" ~:
do do
let opts = defreportopts{uncleared_=True} let opts = defreportopts{uncleared_=True}
@ -346,7 +346,7 @@ tests_PostingsReport = tests "PostingsReport" [
,"2008/06/02 save assets:bank:saving $1 $1" ,"2008/06/02 save assets:bank:saving $1 $1"
," assets:bank:checking $-1 0" ," assets:bank:checking $-1 0"
] ]
,"postings report sorts by date" ~: ,"postings report sorts by date" ~:
do do
j <- readJournal' $ unlines j <- readJournal' $ unlines
@ -360,7 +360,7 @@ tests_PostingsReport = tests "PostingsReport" [
] ]
let opts = defreportopts let opts = defreportopts
registerdates (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` ["2008/01/01","2008/02/02"] registerdates (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` ["2008/01/01","2008/02/02"]
,"postings report with account pattern" ~: ,"postings report with account pattern" ~:
do do
j <- samplejournal j <- samplejournal
@ -368,7 +368,7 @@ tests_PostingsReport = tests "PostingsReport" [
(postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` unlines (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` unlines
["2008/06/03 eat & shop assets:cash $-2 $-2" ["2008/06/03 eat & shop assets:cash $-2 $-2"
] ]
,"postings report with account pattern, case insensitive" ~: ,"postings report with account pattern, case insensitive" ~:
do do
j <- samplejournal j <- samplejournal
@ -376,7 +376,7 @@ tests_PostingsReport = tests "PostingsReport" [
(postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` unlines (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` unlines
["2008/06/03 eat & shop assets:cash $-2 $-2" ["2008/06/03 eat & shop assets:cash $-2 $-2"
] ]
,"postings report with display expression" ~: ,"postings report with display expression" ~:
do do
j <- samplejournal 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"]
"d>=[2008/6/2]" `gives` ["2008/06/02","2008/06/03","2008/12/31"] "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"] "d>[2008/6/2]" `gives` ["2008/06/03","2008/12/31"]
,"postings report with period expression" ~: ,"postings report with period expression" ~:
do do
j <- samplejournal 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"] registerdates (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` ["2008/01/01","2008/04/01","2008/10/01"]
let opts = defreportopts{period_=maybePeriod date1 "quarterly",empty_=True} let opts = defreportopts{period_=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"] 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" ~: , "postings report with depth arg" ~:
do do
j <- samplejournal j <- samplejournal
@ -436,7 +436,7 @@ tests_PostingsReport = tests "PostingsReport" [
,"2008/12/31 pay off liabilities:debts $1 $1" ,"2008/12/31 pay off liabilities:debts $1 $1"
," assets:bank $-1 0" ," assets:bank $-1 0"
] ]
-} -}
] ]
@ -445,7 +445,7 @@ tests_PostingsReport = tests "PostingsReport" [
summarisePostingsByInterval (Quarters 1) PrimaryDate 99999 False (DateSpan Nothing Nothing) [] `is` [] summarisePostingsByInterval (Quarters 1) PrimaryDate 99999 False (DateSpan Nothing Nothing) [] `is` []
] ]
] ]
-- ,tests_summarisePostingsInDateSpan = [ -- ,tests_summarisePostingsInDateSpan = [
-- "summarisePostingsInDateSpan" ~: do -- "summarisePostingsInDateSpan" ~: do
-- let gives (b,e,depth,showempty,ps) = -- 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]} -- 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. -- | Standard options for customising report filtering and output.
-- Most of these correspond to standard hledger command-line options -- Most of these correspond to standard hledger command-line options
-- or query arguments, but not all. Some are used only by certain -- or query arguments, but not all. Some are used only by certain
-- commands, as noted below. -- commands, as noted below.
data ReportOpts = ReportOpts { data ReportOpts = ReportOpts {
today_ :: Maybe Day -- ^ The current date. A late addition to ReportOpts. today_ :: Maybe Day -- ^ The current date. A late addition to ReportOpts.
-- Optional, but when set it may affect some reports: -- 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 -- ^ 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). -- with the same normal balance type (eg all assets, or all incomes).
-- - It helps --sort-amount know how to sort negative numbers -- - It helps --sort-amount know how to sort negative numbers
-- (eg in the income section of an income statement) -- (eg in the income section of an income statement)
-- - It helps compound balance report commands (is, bs etc.) do -- - It helps compound balance report commands (is, bs etc.) do
-- sign normalisation, converting normally negative subreports to -- sign normalisation, converting normally negative subreports to
-- normally positive for a more conventional display. -- normally positive for a more conventional display.
,color_ :: Bool ,color_ :: Bool
,forecast_ :: Bool ,forecast_ :: Bool
,transpose_ :: Bool ,transpose_ :: Bool
@ -328,7 +328,7 @@ simplifyStatuses l
| length l' >= numstatuses = [] | length l' >= numstatuses = []
| otherwise = l' | otherwise = l'
where where
l' = nub $ sort l l' = nub $ sort l
numstatuses = length [minBound .. maxBound :: Status] numstatuses = length [minBound .. maxBound :: Status]
-- | Add/remove this status from the status list. Used by hledger-ui. -- | Add/remove this status from the status list. Used by hledger-ui.
@ -442,7 +442,7 @@ queryOptsFromOpts d ReportOpts{..} = flagsqopts ++ argsqopts
-- Report dates. -- Report dates.
-- | The effective report span is the start and end dates specified by -- | 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 -- posting dates in the journal. If no dates are specified by options/queries
-- and the journal is empty, returns the null date span. -- and the journal is empty, returns the null date span.
-- Needs IO to parse smart dates in options/queries. -- Needs IO to parse smart dates in options/queries.
@ -500,7 +500,7 @@ reportPeriodOrJournalStart ropts@ReportOpts{..} j =
reportPeriodStart ropts <|> journalStartDate False j reportPeriodStart ropts <|> journalStartDate False j
-- Get the last day of the overall report period. -- 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). -- more commonly used, exclusive, report end date).
-- If no report period is specified, will be Nothing. -- If no report period is specified, will be Nothing.
-- Will also be Nothing if ReportOpts does not have today_ set, -- 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) `is` Any
,(queryFromOpts nulldate defreportopts{query_="a"}) `is` (Acct "a") ,(queryFromOpts nulldate defreportopts{query_="a"}) `is` (Acct "a")
,(queryFromOpts nulldate defreportopts{query_="desc:'a a'"}) `is` (Desc "a 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") `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_="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"]) ,(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 = type PeriodicReportRow a =
( AccountName -- A full account name. ( 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. , 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 data value for each subperiod.
, a -- The total of this row's values. , a -- The total of this row's values.
, a -- The average 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 [] -> Nothing
(md:_) -> md (md:_) -> md
-- | Read text from a file, -- | Read text from a file,
-- handling any of the usual line ending conventions, -- handling any of the usual line ending conventions,
-- using the system locale's text encoding, -- 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 :: FilePath -> IO Text
readFilePortably f = openFile f ReadMode >>= readHandlePortably 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 :: String -> IO Text
readFileOrStdinPortably f = openFileOrStdin f ReadMode >>= readHandlePortably readFileOrStdinPortably f = openFileOrStdin f ReadMode >>= readHandlePortably
where where
@ -236,7 +236,7 @@ embedFileRelative f = makeRelativeToProject f >>= embedStringFile
-- hereFileRelative f = makeRelativeToProject f >>= hereFileExp -- hereFileRelative f = makeRelativeToProject f >>= hereFileExp
-- where -- where
-- QuasiQuoter{quoteExp=hereFileExp} = hereFile -- QuasiQuoter{quoteExp=hereFileExp} = hereFile
tests_Utils = tests "Utils" [ tests_Utils = tests "Utils" [
tests_Text tests_Text
] ]

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

@ -2,7 +2,7 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module Hledger.Utils.Color module Hledger.Utils.Color
( (
color, color,
bgColor, 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. -- 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_@ -- After command-line processing, it is also available as the @debug_@
-- field of 'Hledger.Cli.CliOptions.CliOpts'. -- field of 'Hledger.Cli.CliOptions.CliOpts'.
-- {-# OPTIONS_GHC -fno-cse #-} -- {-# OPTIONS_GHC -fno-cse #-}
-- {-# NOINLINE debugLevel #-} -- {-# NOINLINE debugLevel #-}
debugLevel :: Int debugLevel :: Int
debugLevel = case snd $ break (=="--debug") args of debugLevel = case snd $ break (=="--debug") args of
@ -251,7 +251,7 @@ dbg9IO = ptraceAtIO 9
plog :: Show a => String -> a -> a plog :: Show a => String -> a -> a
plog = plogAt 0 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. -- if the global debug level is at or above the specified level.
-- At level 0, always logs. Otherwise, uses unsafePerformIO. -- At level 0, always logs. Otherwise, uses unsafePerformIO.
-- Tends to fail if called more than once, at least when built with -threaded -- 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 :: Show a => Int -> String -> a -> a
plogAt lvl plogAt lvl
| lvl > 0 && debugLevel < lvl = flip const | lvl > 0 && debugLevel < lvl = flip const
| otherwise = \s a -> | otherwise = \s a ->
let p = ppShow a let p = ppShow a
ls = lines p ls = lines p
nlorspace | length ls > 1 = "\n" 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 -- see also http://unicode.org/reports/tr11/#Description
-- | Calculate the render width of a string, considering -- | 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 -- (not counted), and line breaks (in a multi-line string, the longest
-- line determines the width). -- line determines the width).
strWidth :: String -> Int strWidth :: String -> Int
strWidth "" = 0 strWidth "" = 0
strWidth s = maximum $ map (foldr (\a b -> charWidth a + b) 0) $ lines s' 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 ,expectParseEqOn
,expectParseEqOnE ,expectParseEqOnE
,expectParseStateOn ,expectParseStateOn
) )
where where
import Control.Exception import Control.Exception
@ -36,7 +36,7 @@ import Data.Monoid ((<>))
import Data.CallStack import Data.CallStack
import Data.List import Data.List
import qualified Data.Text as T import qualified Data.Text as T
import Safe import Safe
import System.Exit import System.Exit
import Text.Megaparsec import Text.Megaparsec
import Text.Megaparsec.Custom import Text.Megaparsec.Custom
@ -50,38 +50,38 @@ import Hledger.Utils.UTF8IOCompat (error')
-- * easytest helpers -- * easytest helpers
-- | Name the given test(s). A readability synonym for easytest's "scope". -- | 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 test = E.scope
-- | Skip the given test(s), with the same type signature as "test". -- | Skip the given test(s), with the same type signature as "test".
-- If called in a monadic sequence of tests, also skips following tests. -- If called in a monadic sequence of tests, also skips following tests.
_test :: T.Text -> E.Test a -> E.Test a _test :: T.Text -> E.Test a -> E.Test a
_test _name = (E.skip >>) _test _name = (E.skip >>)
-- | Name the given test(s). A synonym for "test". -- | 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 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". -- A synonym for "_test".
_it :: T.Text -> E.Test a -> E.Test a _it :: T.Text -> E.Test a -> E.Test a
_it = _test _it = _test
-- | Name and group a list of tests. Combines easytest's "scope" and "tests". -- | 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 tests name = E.scope name . E.tests
-- | Skip the given list of tests, and any following tests in a monadic sequence, -- | Skip the given list of tests, and any following tests in a monadic sequence,
-- with the same type signature as "group". -- 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 _tests _name = (E.skip >>) . E.tests
-- | Run some easytest tests, catching easytest's ExitCode exception, -- | Run some easytest tests, catching easytest's ExitCode exception,
-- returning True if there was a problem. -- returning True if there was a problem.
-- With arguments, runs only the scope (or single test) named by the first argument -- 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 -- 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 :: [String] -> E.Test () -> IO Bool
runEasytests args tests = (do runEasytests args tests = (do
case args of case args of
@ -96,7 +96,7 @@ runEasytests args tests = (do
`catch` (\(_::ExitCode) -> return True) `catch` (\(_::ExitCode) -> return True)
-- | Like easytest's expectEq (asserts the second (actual) value equals the first (expected) value) -- | 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 :: (Eq a, Show a, HasCallStack) => a -> a -> E.Test ()
expectEqPP expected actual = if expected == actual then E.ok else E.crash $ 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" "\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 :: (Eq a, Show a, HasCallStack) => a -> a -> Test ()
is = flip expectEqPP is = flip expectEqPP
-- | Test that this stateful parser runnable in IO successfully parses -- | Test that this stateful parser runnable in IO successfully parses
-- all of the given input text, showing the parse error if it fails. -- all of the given input text, showing the parse error if it fails.
-- Suitable for hledger's JournalParser parsers. -- 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 () StateT st (ParsecT CustomErr T.Text IO) a -> T.Text -> E.Test ()
expectParse parser input = do expectParse parser input = do
ep <- E.io (runParserT (evalStateT (parser <* eof) mempty) "" input) ep <- E.io (runParserT (evalStateT (parser <* eof) mempty) "" input)
@ -135,9 +135,9 @@ expectParseE parser input = do
(const ok) (const ok)
ep ep
-- | Test that this stateful parser runnable in IO fails to parse -- | Test that this stateful parser runnable in IO fails to parse
-- the given input text, with a parse error containing the given string. -- the given input text, with a parse error containing the given string.
expectParseError :: (Monoid st, Eq a, Show a, HasCallStack) => expectParseError :: (Monoid st, Eq a, Show a, HasCallStack) =>
StateT st (ParsecT CustomErr T.Text IO) a -> T.Text -> String -> E.Test () StateT st (ParsecT CustomErr T.Text IO) a -> T.Text -> String -> E.Test ()
expectParseError parser input errstr = do expectParseError parser input errstr = do
ep <- E.io (runParserT (evalStateT parser mempty) "" input) 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" else fail $ "\nparse error is not as expected:\n" ++ e' ++ "\n"
-- | Like expectParse, but also test the parse result is an expected value, -- | Like expectParse, but also test the parse result is an expected value,
-- pretty-printing both if it fails. -- pretty-printing both if it fails.
expectParseEq :: (Monoid st, Eq a, Show a, HasCallStack) => expectParseEq :: (Monoid st, Eq a, Show a, HasCallStack) =>
StateT st (ParsecT CustomErr T.Text IO) a -> T.Text -> a -> E.Test () StateT st (ParsecT CustomErr T.Text IO) a -> T.Text -> a -> E.Test ()
expectParseEq parser input expected = expectParseEqOn parser input id expected expectParseEq parser input expected = expectParseEqOn parser input id expected
@ -186,9 +186,9 @@ expectParseEqE
-> E.Test () -> E.Test ()
expectParseEqE parser input expected = expectParseEqOnE parser input id expected 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. -- 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 () StateT st (ParsecT CustomErr T.Text IO) a -> T.Text -> (a -> b) -> b -> E.Test ()
expectParseEqOn parser input f expected = do expectParseEqOn parser input f expected = do
ep <- E.io $ runParserT (evalStateT (parser <* eof) mempty) "" input 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_Text = tests "Text" [
tests "quoteIfSpaced" [ tests "quoteIfSpaced" [
quoteIfSpaced "a'a" `is` "a'a" quoteIfSpaced "a'a" `is` "a'a"
,quoteIfSpaced "a\"a" `is` "a\"a" ,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 "mimi's cafe" `is` "\"mimi's cafe\""
,quoteIfSpaced "\"alex\" cafe" `is` "\"\\\"alex\\\" cafe\"" ,quoteIfSpaced "\"alex\" cafe" `is` "\"\\\"alex\\\" cafe\""
,quoteIfSpaced "le'shan's cafe" `is` "\"le'shan's cafe\"" ,quoteIfSpaced "le'shan's cafe" `is` "\"le'shan's cafe\""
,quoteIfSpaced "\"be'any's\" cafe" `is` "\"\\\"be'any'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. Not carefully tested.
-} -}
-- TODO obsolete ? -- TODO obsolete ?
module Hledger.Utils.UTF8IOCompat ( module Hledger.Utils.UTF8IOCompat (
readFile, readFile,
@ -119,5 +119,5 @@ userError' = userError . toSystemString
-- | A SystemString-aware version of error that adds a usage hint. -- | A SystemString-aware version of error that adds a usage hint.
usageError :: String -> a 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). -- (since only one custom error should be used at a time).
findCustomError :: ParseError Text CustomErr -> Maybe CustomErr findCustomError :: ParseError Text CustomErr -> Maybe CustomErr
findCustomError err = case err of findCustomError err = case err of
FancyError _ errSet -> FancyError _ errSet ->
finds (\case {ErrorCustom e -> Just e; _ -> Nothing}) errSet finds (\case {ErrorCustom e -> Just e; _ -> Nothing}) errSet
_ -> Nothing _ -> 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 coreLine = concatMap helper $ flattenHeader $ zipHeader 0 is h
helper = either vsep dashes helper = either vsep dashes
dashes (i,_) = replicate i sep 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 SingleLine = sep : cross pretty : [sep]
vsep DoubleLine = sep : cross' ++ [sep] vsep DoubleLine = sep : cross' ++ [sep]
cross' = case prop of 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 Run doctests in Hledger source files under the current directory
(./Hledger.hs, ./Hledger/**, ./Text/**) using the doctest runner. (./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). --slow reloads ghci between each test (https://github.com/sol/doctest#a-note-on-performance).
Eg, in hledger source dir: Eg, in hledger source dir:
$ make ghci-doctest, :main [--verbose] [--slow] [CIFILEPATHSUBSTRINGS] $ make ghci-doctest, :main [--verbose] [--slow] [CIFILEPATHSUBSTRINGS]
or: or:
@ -40,20 +40,20 @@ main = do
] ]
-- filter by patterns (case insensitive infix substring match) -- filter by patterns (case insensitive infix substring match)
let let
fs | null pats = sourcefiles fs | null pats = sourcefiles
| otherwise = [f | f <- sourcefiles, let f' = map toLower f, any (`isInfixOf` f') pats'] | otherwise = [f | f <- sourcefiles, let f' = map toLower f, any (`isInfixOf` f') pats']
where pats' = map (map toLower) pats where pats' = map (map toLower) pats
fslen = length fs fslen = length fs
if (null fs) if (null fs)
then do then do
putStrLn $ "No file paths found matching: " ++ unwords pats putStrLn $ "No file paths found matching: " ++ unwords pats
else do else do
putStrLn $ putStrLn $
"Loading and searching for doctests in " "Loading and searching for doctests in "
++ show fslen ++ show fslen
++ if fslen > 1 then " files, plus any files they import:" else " file, plus any files it imports:" ++ if fslen > 1 then " files, plus any files they import:" else " file, plus any files it imports:"
when verbose $ putStrLn $ unwords fs 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 selidx = case (reset, listSelectedElement $ _asList s) of
(True, _) -> 0 (True, _) -> 0
(_, Nothing) -> 0 (_, Nothing) -> 0
(_, Just (_,AccountsScreenItem{asItemAccountName=a})) -> (_, Just (_,AccountsScreenItem{asItemAccountName=a})) ->
headDef 0 $ catMaybes [ headDef 0 $ catMaybes [
findIndex (a ==) as findIndex (a ==) as
,findIndex (a `isAccountNamePrefixOf`) as ,findIndex (a `isAccountNamePrefixOf`) as
@ -88,7 +88,7 @@ asInit d reset ui@UIState{
pfq | presentorfuture_ uopts == PFFuture = Any pfq | presentorfuture_ uopts == PFFuture = Any
| otherwise = Date $ DateSpan Nothing (Just $ addDays 1 d) | otherwise = Date $ DateSpan Nothing (Just $ addDays 1 d)
q = And [queryFromOpts d ropts, pfq] q = And [queryFromOpts d ropts, pfq]
-- run the report -- run the report
(items,_total) = report ropts' q j (items,_total) = report ropts' q j
@ -104,14 +104,14 @@ asInit d reset ui@UIState{
displayitem (fullacct, shortacct, indent, bal) = displayitem (fullacct, shortacct, indent, bal) =
AccountsScreenItem{asItemIndentLevel = indent AccountsScreenItem{asItemIndentLevel = indent
,asItemAccountName = fullacct ,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 ,asItemRenderedAmounts = map showAmountWithoutPrice amts -- like showMixedAmountOneLineWithoutPrice
} }
where where
Mixed amts = normaliseMixedAmountSquashPricesForDisplay $ stripPrices bal Mixed amts = normaliseMixedAmountSquashPricesForDisplay $ stripPrices bal
stripPrices (Mixed as) = Mixed $ map stripprice as where stripprice a = a{aprice=Nothing} stripPrices (Mixed as) = Mixed $ map stripprice as where stripprice a = a{aprice=Nothing}
displayitems = map displayitem items displayitems = map displayitem items
-- blanks added for scrolling control, cf RegisterScreen -- blanks added for scrolling control, cf RegisterScreen
blankitems = replicate 100 blankitems = replicate 100
AccountsScreenItem{asItemIndentLevel = 0 AccountsScreenItem{asItemIndentLevel = 0
,asItemAccountName = "" ,asItemAccountName = ""
@ -201,7 +201,7 @@ asDraw UIState{aopts=uopts@UIOpts{cliopts_=copts@CliOpts{reportopts_=ropts}}
curidx = case _asList s ^. listSelectedL of curidx = case _asList s ^. listSelectedL of
Nothing -> "-" Nothing -> "-"
Just i -> show (i + 1) Just i -> show (i + 1)
totidx = show $ V.length nonblanks totidx = show $ V.length nonblanks
where where
nonblanks = V.takeWhile (not . T.null . asItemAccountName) $ s ^. asList . listElementsL 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") ,("-+", str "depth")
,("T", renderToggle (tree_ ropts) "flat" "tree") ,("T", renderToggle (tree_ ropts) "flat" "tree")
,("H", renderToggle (not ishistorical) "end-bals" "changes") ,("H", renderToggle (not ishistorical) "end-bals" "changes")
,("F", renderToggle (presentorfuture_ uopts == PFFuture) "present" "future") ,("F", renderToggle (presentorfuture_ uopts == PFFuture) "present" "future")
--,("/", "filter") --,("/", "filter")
--,("DEL", "unfilter") --,("DEL", "unfilter")
--,("ESC", "cancel/top") --,("ESC", "cancel/top")
@ -346,14 +346,14 @@ asHandle ui0@UIState{
VtyEvent (EvKey (KChar 'l') [MCtrl]) -> scrollSelectionToMiddle _asList >> redraw ui VtyEvent (EvKey (KChar 'l') [MCtrl]) -> scrollSelectionToMiddle _asList >> redraw ui
VtyEvent (EvKey (KChar 'z') [MCtrl]) -> suspend 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 -- centering its selected transaction if possible
VtyEvent e | e `elem` moveRightEvents VtyEvent e | e `elem` moveRightEvents
, not $ isBlankElement $ listSelectedElement _asList-> , not $ isBlankElement $ listSelectedElement _asList->
-- TODO center selection after entering register screen; neither of these works till second time entering; easy strictifications didn't help -- TODO center selection after entering register screen; neither of these works till second time entering; easy strictifications didn't help
rsCenterAndContinue $ rsCenterAndContinue $
-- flip rsHandle (VtyEvent (EvKey (KChar 'l') [MCtrl])) $ -- flip rsHandle (VtyEvent (EvKey (KChar 'l') [MCtrl])) $
screenEnter d regscr ui screenEnter d regscr ui
where where
regscr = rsSetAccount selacct isdepthclipped registerScreen regscr = rsSetAccount selacct isdepthclipped registerScreen
isdepthclipped = case getDepth ui of isdepthclipped = case getDepth ui of
@ -363,9 +363,9 @@ asHandle ui0@UIState{
-- prevent moving down over blank padding items; -- prevent moving down over blank padding items;
-- instead scroll down by one, until maximally scrolled - shows the end has been reached -- instead scroll down by one, until maximally scrolled - shows the end has been reached
VtyEvent (EvKey (KDown) []) | isBlankElement mnextelement -> do VtyEvent (EvKey (KDown) []) | isBlankElement mnextelement -> do
vScrollBy (viewportScroll $ _asList^.listNameL) 1 vScrollBy (viewportScroll $ _asList^.listNameL) 1
continue ui continue ui
where where
mnextelement = listSelectedElement $ listMoveDown _asList mnextelement = listSelectedElement $ listMoveDown _asList
-- if page down or end leads to a blank padding item, stop at last non-blank -- 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'}} continue ui{aScreen=scr{_asList=list'}}
else else
continue ui{aScreen=scr{_asList=list}} continue ui{aScreen=scr{_asList=list}}
-- fall through to the list's event handler (handles up/down) -- fall through to the list's event handler (handles up/down)
VtyEvent ev -> do VtyEvent ev -> do
newitems <- handleListEvent (normaliseMovementKeys ev) _asList 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 a s@AccountsScreen{} = s & asSelectedAccount .~ a
asSetSelectedAccount _ s = s asSetSelectedAccount _ s = s
isBlankElement mel = ((asItemAccountName . snd) <$> mel) == Just "" isBlankElement mel = ((asItemAccountName . snd) <$> mel) == Just ""
asCenterAndContinue ui = do asCenterAndContinue ui = do
scrollSelectionToMiddle $ _asList $ aScreen ui 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 -- print (length (show ui)) >> exitSuccess -- show any debug output to this point & quit
if not (watch_ uopts') if not (watch_ uopts')
then then
void $ defaultMain brickapp ui 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 previously selected transaction if possible;
-- otherwise, the transaction nearest in date to it; -- otherwise, the transaction nearest in date to it;
-- or if there's several with the same date, the nearest in journal order; -- 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 newitems' = listMoveTo newselidx newitems
where where
newselidx = newselidx =
case (reset, listSelectedElement rsList) of case (reset, listSelectedElement rsList) of
(True, _) -> endidx (True, _) -> endidx
(_, Nothing) -> endidx (_, Nothing) -> endidx
@ -164,7 +164,7 @@ rsDraw UIState{aopts=uopts@UIOpts{cliopts_=copts@CliOpts{reportopts_=ropts}}
changewidthproportion = fromIntegral maxchangewidthseen / fromIntegral (maxchangewidthseen + maxbalwidthseen) changewidthproportion = fromIntegral maxchangewidthseen / fromIntegral (maxchangewidthseen + maxbalwidthseen)
maxchangewidth = round $ changewidthproportion * fromIntegral maxamtswidth maxchangewidth = round $ changewidthproportion * fromIntegral maxamtswidth
maxbalwidth = maxamtswidth - maxchangewidth maxbalwidth = maxamtswidth - maxchangewidth
changewidth = min maxchangewidth maxchangewidthseen changewidth = min maxchangewidth maxchangewidthseen
balwidth = min maxbalwidth maxbalwidthseen balwidth = min maxbalwidth maxbalwidthseen
-- assign the remaining space to the description and accounts columns -- assign the remaining space to the description and accounts columns
-- maxdescacctswidth = totalwidth - (whitespacewidth - 4) - changewidth - balwidth -- maxdescacctswidth = totalwidth - (whitespacewidth - 4) - changewidth - balwidth
@ -177,7 +177,7 @@ rsDraw UIState{aopts=uopts@UIOpts{cliopts_=copts@CliOpts{reportopts_=ropts}}
-- descwidthproportion = (descwidth' + acctswidth') / descwidth' -- descwidthproportion = (descwidth' + acctswidth') / descwidth'
-- maxdescwidth = min (maxdescacctswidth - 7) (maxdescacctswidth / descwidthproportion) -- maxdescwidth = min (maxdescacctswidth - 7) (maxdescacctswidth / descwidthproportion)
-- maxacctswidth = maxdescacctswidth - maxdescwidth -- maxacctswidth = maxdescacctswidth - maxdescwidth
-- descwidth = min maxdescwidth descwidth' -- descwidth = min maxdescwidth descwidth'
-- acctswidth = min maxacctswidth acctswidth' -- acctswidth = min maxacctswidth acctswidth'
-- allocating equally. -- allocating equally.
descwidth = maxdescacctswidth `div` 2 descwidth = maxdescacctswidth `div` 2
@ -232,7 +232,7 @@ rsDraw UIState{aopts=uopts@UIOpts{cliopts_=copts@CliOpts{reportopts_=ropts}}
-- ,("RIGHT", str "transaction") -- ,("RIGHT", str "transaction")
,("T", renderToggle (tree_ ropts) "flat(-subs)" "tree(+subs)") -- rsForceInclusive may override, but use tree_ to ensure a visible toggle effect ,("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") ,("H", renderToggle (not ishistorical) "historical" "period")
,("F", renderToggle (presentorfuture_ uopts == PFFuture) "present" "future") ,("F", renderToggle (presentorfuture_ uopts == PFFuture) "present" "future")
-- ,("a", "add") -- ,("a", "add")
-- ,("g", "reload") -- ,("g", "reload")
-- ,("q", "quit") -- ,("q", "quit")
@ -271,11 +271,11 @@ rsHandle ui@UIState{
,aMode=mode ,aMode=mode
} ev = do } ev = do
d <- liftIO getCurrentDay d <- liftIO getCurrentDay
let let
journalspan = journalDateSpan False j journalspan = journalDateSpan False j
nonblanks = V.takeWhile (not . null . rsItemDate) $ rsList^.listElementsL nonblanks = V.takeWhile (not . null . rsItemDate) $ rsList^.listElementsL
lastnonblankidx = max 0 (length nonblanks - 1) lastnonblankidx = max 0 (length nonblanks - 1)
case mode of case mode of
Minibuffer ed -> Minibuffer ed ->
case ev of case ev of
@ -358,9 +358,9 @@ rsHandle ui@UIState{
-- prevent moving down over blank padding items; -- prevent moving down over blank padding items;
-- instead scroll down by one, until maximally scrolled - shows the end has been reached -- instead scroll down by one, until maximally scrolled - shows the end has been reached
VtyEvent e | e `elem` moveDownEvents, isBlankElement mnextelement -> do VtyEvent e | e `elem` moveDownEvents, isBlankElement mnextelement -> do
vScrollBy (viewportScroll $ rsList^.listNameL) 1 vScrollBy (viewportScroll $ rsList^.listNameL) 1
continue ui continue ui
where where
mnextelement = listSelectedElement $ listMoveDown rsList mnextelement = listSelectedElement $ listMoveDown rsList
-- if page down or end leads to a blank padding item, stop at last non-blank -- 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'}} continue ui{aScreen=s{rsList=list'}}
else else
continue ui{aScreen=s{rsList=list}} continue ui{aScreen=s{rsList=list}}
-- fall through to the list's event handler (handles other [pg]up/down events) -- fall through to the list's event handler (handles other [pg]up/down events)
VtyEvent ev -> do VtyEvent ev -> do
let ev' = normaliseMovementKeys ev let ev' = normaliseMovementKeys ev
@ -386,7 +386,7 @@ rsHandle ui@UIState{
rsHandle _ _ = error "event handler called with wrong screen type, should not happen" 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 rsCenterAndContinue ui = do
scrollSelectionToMiddle $ rsList $ aScreen ui scrollSelectionToMiddle $ rsList $ aScreen ui

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

@ -73,7 +73,7 @@ themesList = [
,("border" <> "bold" , currentAttr & bold) ,("border" <> "bold" , currentAttr & bold)
,("border" <> "depth" , active) ,("border" <> "depth" , active)
,("border" <> "filename" , currentAttr) ,("border" <> "filename" , currentAttr)
,("border" <> "key" , active) ,("border" <> "key" , active)
,("border" <> "minibuffer" , white `on` black & bold) ,("border" <> "minibuffer" , white `on` black & bold)
,("border" <> "query" , active) ,("border" <> "query" , active)
,("border" <> "selected" , 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 where
(pos,f) = case tsourcepos t of (pos,f) = case tsourcepos t of
GenericSourcePos f l c -> (Just (l, Just c),f) 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 -> AppEvent (DateChange old _) | isStandardPeriod p && p `periodContainsDate` old ->
continue $ regenerateScreens j d $ setReportPeriod (DayPeriod d) ui continue $ regenerateScreens j d $ setReportPeriod (DayPeriod d) ui
where where

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

@ -85,7 +85,7 @@ rawOptsToUIOpts rawopts = checkUIOpts <$> do
,cliopts_ = cliopts ,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. -- 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) data PresentOrFutureOpt = PFDefault | PFPresent | PFFuture deriving (Eq, Show, Data, Typeable)
instance Default PresentOrFutureOpt where def = PFDefault instance Default PresentOrFutureOpt where def = PFDefault
@ -109,7 +109,7 @@ getHledgerUIOpts :: IO UIOpts
--getHledgerUIOpts = processArgs uimode >>= return . decodeRawOpts >>= rawOptsToUIOpts --getHledgerUIOpts = processArgs uimode >>= return . decodeRawOpts >>= rawOptsToUIOpts
getHledgerUIOpts = do getHledgerUIOpts = do
args <- getArgs >>= expandArgsAt args <- getArgs >>= expandArgsAt
let args' = replaceNumericFlags args let args' = replaceNumericFlags args
let cmdargopts = either usageError id $ process uimode 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}}} = toggleCleared ui@UIState{aopts=uopts@UIOpts{cliopts_=copts@CliOpts{reportopts_=ropts}}} =
ui{aopts=uopts{cliopts_=copts{reportopts_=reportOptsToggleStatusSomehow Cleared copts 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. -- which will be shown comma-separated as part of the indicators list.
uiShowStatus :: CliOpts -> [Status] -> [String] uiShowStatus :: CliOpts -> [Status] -> [String]
uiShowStatus copts ss = uiShowStatus copts ss =
case style of case style of
-- in style 2, instead of "Y, Z" show "not X" -- in style 2, instead of "Y, Z" show "not X"
Just 2 | length ss == numstatuses-1 Just 2 | length ss == numstatuses-1
-> map (("not "++). showstatus) $ sort $ complement ss -- should be just one -> map (("not "++). showstatus) $ sort $ complement ss -- should be just one
_ -> map showstatus $ sort ss _ -> map showstatus $ sort ss
where where
@ -55,7 +55,7 @@ uiShowStatus copts ss =
reportOptsToggleStatusSomehow :: Status -> CliOpts -> ReportOpts -> ReportOpts reportOptsToggleStatusSomehow :: Status -> CliOpts -> ReportOpts -> ReportOpts
reportOptsToggleStatusSomehow s copts ropts = reportOptsToggleStatusSomehow s copts ropts =
case maybeintopt "status-toggles" $ rawopts_ copts of case maybeintopt "status-toggles" $ rawopts_ copts of
Just 2 -> reportOptsToggleStatus2 s ropts Just 2 -> reportOptsToggleStatus2 s ropts
Just 3 -> reportOptsToggleStatus3 s ropts Just 3 -> reportOptsToggleStatus3 s ropts
-- Just 4 -> reportOptsToggleStatus4 s ropts -- Just 4 -> reportOptsToggleStatus4 s ropts
@ -78,7 +78,7 @@ reportOptsToggleStatus1 s ropts@ReportOpts{statuses_=ss}
reportOptsToggleStatus2 s ropts@ReportOpts{statuses_=ss} reportOptsToggleStatus2 s ropts@ReportOpts{statuses_=ss}
| ss == [s] = ropts{statuses_=complement [s]} | ss == [s] = ropts{statuses_=complement [s]}
| ss == complement [s] = ropts{statuses_=[]} | 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 -- 3 UPC toggles each X
reportOptsToggleStatus3 s ropts@ReportOpts{statuses_=ss} reportOptsToggleStatus3 s ropts@ReportOpts{statuses_=ss}

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

@ -59,7 +59,7 @@ suspendSignal = return ()
#else #else
import System.Posix.Signals import System.Posix.Signals
suspendSignal :: IO () suspendSignal :: IO ()
suspendSignal = raiseSignal sigSTOP suspendSignal = raiseSignal sigSTOP
#endif #endif
-- | On posix platforms, suspend the program using the STOP signal, -- | On posix platforms, suspend the program using the STOP signal,
@ -121,7 +121,7 @@ helpDialog _copts =
vBox [ vBox [
withAttr ("help" <> "heading") $ str "Filtering" withAttr ("help" <> "heading") $ str "Filtering"
,renderKey ("/ ", "set a filter query") ,renderKey ("/ ", "set a filter query")
,renderKey ("UPC ", "show unmarked/pending/cleared") ,renderKey ("UPC ", "show unmarked/pending/cleared")
,renderKey ("F ", "show future/present txns") ,renderKey ("F ", "show future/present txns")
,renderKey ("R ", "show real/all postings") ,renderKey ("R ", "show real/all postings")
,renderKey ("Z ", "show nonzero/all amounts") ,renderKey ("Z ", "show nonzero/all amounts")
@ -208,12 +208,12 @@ borderKeysStr' keydescs =
-- sep = str " | " -- sep = str " | "
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 :: Bool -> String -> String -> Widget Name
renderToggle isright l r = renderToggle isright l r =
let bold = withAttr ("border" <> "selected") in let bold = withAttr ("border" <> "selected") in
if isright if isright
then str (l++"/") <+> bold (str r) then str (l++"/") <+> bold (str r)
else bold (str l) <+> str ("/"++r) else bold (str l) <+> str ("/"++r)
-- temporary shenanigans: -- temporary shenanigans:
@ -310,13 +310,13 @@ withBorderAttr attr = updateAttrMap (applyAttrMappings [("border", attr)])
--scrollToTop :: List Name e -> EventM Name () --scrollToTop :: List Name e -> EventM Name ()
--scrollToTop list = do --scrollToTop list = do
-- let vpname = list^.listNameL -- 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 -- | Scroll a list's viewport so that the selected item is centered in the
-- middle of the display area. -- middle of the display area.
scrollSelectionToMiddle :: List Name e -> EventM Name () scrollSelectionToMiddle :: List Name e -> EventM Name ()
scrollSelectionToMiddle list = do scrollSelectionToMiddle list = do
let mselectedrow = list^.listSelectedL let mselectedrow = list^.listSelectedL
vpname = list^.listNameL vpname = list^.listNameL
mvp <- lookupViewport vpname mvp <- lookupViewport vpname
case (mselectedrow, mvp) of case (mselectedrow, mvp) of
@ -326,7 +326,7 @@ scrollSelectionToMiddle list = do
vpheight = dbg4 "vpheight" $ vp^.vpSize._2 vpheight = dbg4 "vpheight" $ vp^.vpSize._2
itemsperpage = dbg4 "itemsperpage" $ vpheight `div` itemheight 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 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 () _ -> return ()
-- arrow keys vi keys emacs keys -- 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.Data (Journal, nulljournal)
import Hledger.Web.Handler.AddR import Hledger.Web.Handler.AddR
import Hledger.Web.Handler.MiscR import Hledger.Web.Handler.MiscR
import Hledger.Web.Handler.EditR import Hledger.Web.Handler.EditR
import Hledger.Web.Handler.UploadR import Hledger.Web.Handler.UploadR
import Hledger.Web.Handler.JournalR 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. -- 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 :: Handler RepJson
putAddR = do putAddR = do
VD{caps, j, opts} <- getViewData VD{caps, j, opts} <- getViewData
@ -66,4 +66,4 @@ putAddR = do
Error err -> sendStatusJSON status400 ("could not parse json: " ++ err ::String) Error err -> sendStatusJSON status400 ("could not parse json: " ++ err ::String)
Success t -> do Success t -> do
void $ liftIO $ journalAddTransaction j (cliopts_ opts) t 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 #-} {-# LANGUAGE TemplateHaskell #-}
module Hledger.Web.Handler.MiscR module Hledger.Web.Handler.MiscR
( getAccountnamesR ( getAccountnamesR
, getTransactionsR , getTransactionsR
, getPricesR , getPricesR
, getCommoditiesR , getCommoditiesR
, getAccountsR , getAccountsR
, getAccounttransactionsR , getAccounttransactionsR
, getDownloadR , getDownloadR
, getFaviconR , getFaviconR

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

@ -21,7 +21,7 @@
--{-# LANGUAGE TypeFamilies #-} --{-# LANGUAGE TypeFamilies #-}
--{-# LANGUAGE TypeOperators #-} --{-# LANGUAGE TypeOperators #-}
module Hledger.Web.Json ( module Hledger.Web.Json (
-- * Instances -- * Instances
-- * Utilities -- * Utilities
readJsonFile readJsonFile
@ -66,11 +66,11 @@ instance ToJSON Posting where
,"ptype" .= toJSON ptype ,"ptype" .= toJSON ptype
,"ptags" .= toJSON ptags ,"ptags" .= toJSON ptags
,"pbalanceassertion" .= toJSON pbalanceassertion ,"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. -- in a dummy field. When re-parsed, there will be no parent.
,"ptransaction_" .= toJSON (maybe "" (show.tindex) ptransaction) ,"ptransaction_" .= toJSON (maybe "" (show.tindex) ptransaction)
-- This is probably not wanted in json, we discard it. -- This is probably not wanted in json, we discard it.
,"poriginal" .= toJSON (Nothing :: Maybe Posting) ,"poriginal" .= toJSON (Nothing :: Maybe Posting)
] ]
instance ToJSON Transaction instance ToJSON Transaction
@ -82,7 +82,7 @@ instance ToJSON Account where
,"aibalance" .= toJSON (aibalance a) ,"aibalance" .= toJSON (aibalance a)
,"anumpostings" .= toJSON (anumpostings a) ,"anumpostings" .= toJSON (anumpostings a)
,"aboring" .= toJSON (aboring 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. -- in a dummy field. When re-parsed, there will be no parent.
,"aparent_" .= toJSON (maybe "" aname $ aparent a) ,"aparent_" .= toJSON (maybe "" aname $ aparent a)
-- Just the names of subaccounts, as a dummy field, ignored when parsed. -- Just the names of subaccounts, as a dummy field, ignored when parsed.
@ -110,14 +110,14 @@ instance FromJSON Posting
instance FromJSON Transaction instance FromJSON Transaction
instance FromJSON AccountDeclarationInfo instance FromJSON AccountDeclarationInfo
-- XXX The ToJSON instance replaces subaccounts with just names. -- 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. -- parent-child relationships.
instance FromJSON Account instance FromJSON Account
-- Decimal, various attempts -- Decimal, various attempts
-- --
-- https://stackoverflow.com/questions/40331851/haskell-data-decimal-as-aeson-type -- 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) ---- A.withScientific "Decimal" (return . right . eitherFromRational . toRational)
-- --
-- https://github.com/bos/aeson/issues/474 -- https://github.com/bos/aeson/issues/474
@ -156,7 +156,7 @@ instance FromJSON (DecimalRaw Integer)
readJsonFile :: FromJSON a => FilePath -> IO a readJsonFile :: FromJSON a => FilePath -> IO a
readJsonFile f = do readJsonFile f = do
bs <- BL.readFile f 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 case fromJSON v :: FromJSON a => Result a of
Error e -> error e Error e -> error e
Success t -> return t 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. -- from a help template and flag/argument specifications.
-- Reduces boilerplate a little, though the complicated cmdargs -- Reduces boilerplate a little, though the complicated cmdargs
-- flag and argument specs are still required. -- 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 -> [Flag RawOpts] -> ([Arg RawOpts], Maybe (Arg RawOpts)) -> Mode RawOpts
hledgerCommandMode doc unnamedflaggroup namedflaggroups hiddenflaggroup argsdescr = hledgerCommandMode doc unnamedflaggroup namedflaggroups hiddenflaggroup argsdescr =
case parseCommandDoc doc of case parseCommandDoc doc of
@ -404,7 +404,7 @@ defaultWidth :: Int
defaultWidth = 80 defaultWidth = 80
-- | Replace any numeric flags (eg -2) with their long form (--depth 2), -- | 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 :: [String] -> [String]
replaceNumericFlags = map replace replaceNumericFlags = map replace
where where
@ -452,10 +452,10 @@ checkCliOpts opts =
Right _ -> Right () Right _ -> Right ()
-- XXX check registerWidthsFromOpts opts -- XXX check registerWidthsFromOpts opts
-- | A helper for addon commands: this parses options and arguments from -- | A helper for addon commands: this parses options and arguments from
-- the current command line using the given hledger-style cmdargs mode, -- the current command line using the given hledger-style cmdargs mode,
-- and returns a CliOpts. Or, with --help or -h present, it prints -- and returns a CliOpts. Or, with --help or -h present, it prints
-- long or short help, and exits the program. -- long or short help, and exits the program.
-- When --debug is present, also prints some debug output. -- When --debug is present, also prints some debug output.
-- Note this is not used by the main hledger executable. -- Note this is not used by the main hledger executable.
-- --
@ -472,7 +472,7 @@ checkCliOpts opts =
-- hledger options not displayed. -- hledger options not displayed.
-- --
-- Tips: -- 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. -- add a space character to preserve them.
-- --
getHledgerCliOpts :: Mode RawOpts -> IO CliOpts getHledgerCliOpts :: Mode RawOpts -> IO CliOpts
@ -640,7 +640,7 @@ defaultBalanceLineFormat = BottomAligned [
-- or more versions (or two versions that don't look like a -- or more versions (or two versions that don't look like a
-- source/compiled pair), they are all included, with file extensions -- source/compiled pair), they are all included, with file extensions
-- intact. -- intact.
-- --
hledgerAddons :: IO [String] hledgerAddons :: IO [String]
hledgerAddons = do hledgerAddons = do
-- past bug generator -- past bug generator
@ -658,10 +658,10 @@ dropRedundantSourceVersion [f,g]
| takeExtension g `elem` compiledExts = [g] | takeExtension g `elem` compiledExts = [g]
dropRedundantSourceVersion fs = fs 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. -- We do not currently filter out non-file objects or files without execute permission.
likelyExecutablesInPath :: IO [String] likelyExecutablesInPath :: IO [String]
likelyExecutablesInPath = do likelyExecutablesInPath = do
@ -677,8 +677,8 @@ likelyExecutablesInPath = do
-- | Get the sorted unique filenames of all hledger-* executables in -- | Get the sorted unique filenames of all hledger-* executables in
-- the current user's PATH. These are files in any of the PATH directories, -- 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) -- named hledger-*, with either no extension (and no periods in the name)
-- or one of the addonExtensions. -- or one of the addonExtensions.
-- We do not currently filter out non-file objects or files without execute permission. -- We do not currently filter out non-file objects or files without execute permission.
hledgerExecutablesInPath :: IO [String] hledgerExecutablesInPath :: IO [String]
hledgerExecutablesInPath = filter isHledgerExeName <$> likelyExecutablesInPath 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 accts = dbg5 "accts to show" $ -- no need to nub/sort, accountTree will
if | declared && not used -> matcheddeclaredaccts if | declared && not used -> matcheddeclaredaccts
| not declared && used -> matchedusedaccts | 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 -- 2. sort them by declaration order and name, at each level of their tree structure
sortedaccts = sortAccountNamesByDeclaration j tree accts 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 = clippedaccts =
dbg1 "clippedaccts" $ dbg1 "clippedaccts" $
filter (matchesAccount acctq) $ -- clipping can leave accounts that no longer match the query, remove such filter (matchesAccount acctq) $ -- clipping can leave accounts that no longer match the query, remove such
nub $ -- clipping can leave duplicates (adjacent, hopefully) nub $ -- clipping can leave duplicates (adjacent, hopefully)
filter (not . T.null) $ -- depth:0 can leave nulls filter (not . T.null) $ -- depth:0 can leave nulls
map (clipAccountName depth) $ -- clip at depth if specified map (clipAccountName depth) $ -- clip at depth if specified
sortedaccts 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 mapM_ (T.putStrLn . render) clippedaccts
where where
render a render a
| tree_ ropts = T.replicate (2 * (accountNameLevel a - 1)) " " <> accountLeafName a | tree_ ropts = T.replicate (2 * (accountNameLevel a - 1)) " " <> accountLeafName a
| otherwise = accountNameDrop (drop_ ropts) 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 "html" -> const $ error' "Sorry, HTML output is not yet implemented for this kind of report." -- TODO
_ -> budgetReportAsText ropts _ -> budgetReportAsText ropts
writeOutput opts $ render budgetreport writeOutput opts $ render budgetreport
else else
if multiperiod then do -- multi period balance report if multiperiod then do -- multi period balance report
let report = multiBalanceReport ropts (queryFromOpts d ropts) j 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} | otherwise = ropts{accountlistmode_=ALTree}
in balanceReportFromMultiBalanceReport ropts' (queryFromOpts d ropts) j in balanceReportFromMultiBalanceReport ropts' (queryFromOpts d ropts) j
-- for historical balances we must use balanceReportFromMultiBalanceReport (also forces --no-elide) -- 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 render = case format of
"csv" -> \ropts r -> (++ "\n") $ printCSV $ balanceReportAsCsv ropts r "csv" -> \ropts r -> (++ "\n") $ printCSV $ balanceReportAsCsv ropts r
"html" -> \_ _ -> error' "Sorry, HTML output is not yet implemented for this kind of report." -- TODO "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. -- and will include the final totals row unless --no-total is set.
multiBalanceReportAsCsv :: ReportOpts -> MultiBalanceReport -> CSV multiBalanceReportAsCsv :: ReportOpts -> MultiBalanceReport -> CSV
multiBalanceReportAsCsv opts@ReportOpts{average_, row_total_} (MultiBalanceReport (colspans, items, (coltotals,tot,avg))) = multiBalanceReportAsCsv opts@ReportOpts{average_, row_total_} (MultiBalanceReport (colspans, items, (coltotals,tot,avg))) =
maybetranspose $ maybetranspose $
("Account" : map showDateSpan colspans ("Account" : map showDateSpan colspans
++ ["Total" | row_total_] ++ ["Total" | row_total_]
++ ["Average" | average_] ++ ["Average" | average_]
@ -481,7 +481,7 @@ multiBalanceReportAsCsv opts@ReportOpts{average_, row_total_} (MultiBalanceRepor
where where
maybetranspose | transpose_ opts = transpose maybetranspose | transpose_ opts = transpose
| otherwise = id | otherwise = id
-- | Render a multi-column balance report as HTML. -- | Render a multi-column balance report as HTML.
multiBalanceReportAsHtml :: ReportOpts -> MultiBalanceReport -> Html () multiBalanceReportAsHtml :: ReportOpts -> MultiBalanceReport -> Html ()
multiBalanceReportAsHtml ropts mbr = multiBalanceReportAsHtml ropts mbr =
@ -505,7 +505,7 @@ multiBalanceReportHtmlRows ropts mbr =
in in
(multiBalanceReportHtmlHeadRow ropts headingsrow (multiBalanceReportHtmlHeadRow ropts headingsrow
,map (multiBalanceReportHtmlBodyRow ropts) bodyrows ,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. -- | Render one MultiBalanceReport heading row as a HTML table row.
@ -548,8 +548,8 @@ multiBalanceReportHtmlBodyRow ropts (label:rest) =
multiBalanceReportHtmlFootRow :: ReportOpts -> [String] -> Html () multiBalanceReportHtmlFootRow :: ReportOpts -> [String] -> Html ()
multiBalanceReportHtmlFootRow _ropts [] = mempty multiBalanceReportHtmlFootRow _ropts [] = mempty
-- TODO pad totals row with zeros when subreport is empty -- TODO pad totals row with zeros when subreport is empty
-- multiBalanceReportHtmlFootRow ropts $ -- multiBalanceReportHtmlFootRow ropts $
-- "" -- ""
-- : repeat nullmixedamt zeros -- : repeat nullmixedamt zeros
-- ++ (if row_total_ ropts then [nullmixedamt] else []) -- ++ (if row_total_ ropts then [nullmixedamt] else [])
-- ++ (if average_ 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 :: ReportOpts -> MultiBalanceReport -> Table String String MixedAmount
balanceReportAsTable opts@ReportOpts{average_, row_total_, balancetype_} (MultiBalanceReport (colspans, items, (coltotals,tot,avg))) = balanceReportAsTable opts@ReportOpts{average_, row_total_, balancetype_} (MultiBalanceReport (colspans, items, (coltotals,tot,avg))) =
maybetranspose $ maybetranspose $
addtotalrow $ addtotalrow $
Table Table
(T.Group NoLine $ map Header accts) (T.Group NoLine $ map Header accts)
(T.Group NoLine $ map Header colheadings) (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) maybetranspose | transpose_ opts = \(Table rh ch vals) -> Table ch rh (transpose vals)
| otherwise = id | otherwise = id
-- | Given a table representing a multi-column balance report (for example, -- | Given a table representing a multi-column balance report (for example,
-- made using 'balanceReportAsTable'), render it in a format suitable for -- made using 'balanceReportAsTable'), render it in a format suitable for
-- console output. -- console output.

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

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

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

@ -4,7 +4,7 @@
module Hledger.Cli.Commands.Close ( module Hledger.Cli.Commands.Close (
closemode closemode
,close ,close
) )
where where
import Control.Monad (when) import Control.Monad (when)
@ -29,8 +29,8 @@ closemode = hledgerCommandMode
close CliOpts{rawopts_=rawopts, reportopts_=ropts} j = do close CliOpts{rawopts_=rawopts, reportopts_=ropts} j = do
today <- getCurrentDay today <- getCurrentDay
let let
(opening, closing) = (opening, closing) =
case (boolopt "opening" rawopts, boolopt "closing" rawopts) of case (boolopt "opening" rawopts, boolopt "closing" rawopts) of
(False, False) -> (True, True) -- by default show both opening and closing (False, False) -> (True, True) -- by default show both opening and closing
(o, c) -> (o, c) (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 files CliOpts{rawopts_=rawopts} j = do
let args = listofstringopt "args" rawopts let args = listofstringopt "args" rawopts
regex = headMay args regex = headMay args
files = maybe id (filter . regexMatches) regex files = maybe id (filter . regexMatches) regex
$ map fst $ map fst
$ jfiles j $ jfiles j
mapM_ putStrLn files mapM_ putStrLn files

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

@ -46,10 +46,10 @@ helpmode = hledgerCommandMode
[] []
([], Just $ argsFlag "[MANUAL]") ([], 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. -- 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 -- 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' :: CliOpts -> Journal -> IO ()
help' opts _ = do help' opts _ = do
exes <- likelyExecutablesInPath exes <- likelyExecutablesInPath
@ -60,18 +60,18 @@ help' opts _ = do
topic = case args of topic = case args of
[pat] -> headMay [t | t <- docTopics, map toLower pat `isInfixOf` t] [pat] -> headMay [t | t <- docTopics, map toLower pat `isInfixOf` t]
_ -> Nothing _ -> Nothing
[info, man, pager, cat] = [info, man, pager, cat] =
[runInfoForTopic, runManForTopic, runPagerForTopic pagerprog, printHelpForTopic] [runInfoForTopic, runManForTopic, runPagerForTopic pagerprog, printHelpForTopic]
viewer viewer
| boolopt "info" $ rawopts_ opts = info | boolopt "info" $ rawopts_ opts = info
| boolopt "man" $ rawopts_ opts = man | boolopt "man" $ rawopts_ opts = man
| boolopt "pager" $ rawopts_ opts = pager | boolopt "pager" $ rawopts_ opts = pager
| boolopt "cat" $ rawopts_ opts = cat | boolopt "cat" $ rawopts_ opts = cat
| not interactive = cat | not interactive = cat
| "info" `elem` exes = info | "info" `elem` exes = info
| "man" `elem` exes = man | "man" `elem` exes = man
| pagerprog `elem` exes = pager | pagerprog `elem` exes = pager
| otherwise = cat | otherwise = cat
case topic of case topic of
Nothing -> putStrLn $ unlines [ Nothing -> putStrLn $ unlines [
"Please choose a manual by typing \"hledger help MANUAL\" (any substring is ok)." "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 ( module Hledger.Cli.Commands.Import (
importmode importmode
,importcmd ,importcmd
) )
where where
import Control.Monad import Control.Monad
@ -18,7 +18,7 @@ import Text.Printf
importmode = hledgerCommandMode importmode = hledgerCommandMode
$(embedFileRelative "Hledger/Cli/Commands/Import.txt") $(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] [generalflagsgroup1]
hiddenflags hiddenflags
([], Just $ argsFlag "FILE [...]") ([], Just $ argsFlag "FILE [...]")
@ -33,7 +33,7 @@ importcmd opts@CliOpts{rawopts_=rawopts,inputopts_=iopts} j = do
fs -> do fs -> do
enewj <- readJournalFiles iopts' fs enewj <- readJournalFiles iopts' fs
case enewj of case enewj of
Left e -> error' e Left e -> error' e
Right newj -> Right newj ->
case sortOn tdate $ jtxns newj of case sortOn tdate $ jtxns newj of
[] -> return () [] -> return ()

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

@ -3,7 +3,7 @@
module Hledger.Cli.Commands.Prices ( module Hledger.Cli.Commands.Prices (
pricesmode pricesmode
,prices ,prices
) )
where where
import Data.Maybe import Data.Maybe
@ -22,7 +22,7 @@ pricesmode = hledgerCommandMode
hiddenflags hiddenflags
([], Just $ argsFlag "[QUERY]") ([], 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 prices opts j = do
d <- getCurrentDay d <- getCurrentDay
let 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 writeOutput opts $ render $ entriesReport ropts' q j
entriesReportAsText :: CliOpts -> EntriesReport -> String entriesReportAsText :: CliOpts -> EntriesReport -> String
entriesReportAsText opts = concatMap (showTransactionUnelided . gettxn) entriesReportAsText opts = concatMap (showTransactionUnelided . gettxn)
where 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 | otherwise = originalTransaction -- use original as-written amounts/txn prices
-- Original vs inferred transactions/postings were causing problems here, disabling -B (#551). -- Original vs inferred transactions/postings were causing problems here, disabling -B (#551).
-- Use the explicit one if -B or -x are active. -- 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) useexplicittxn = boolopt "explicit" (rawopts_ opts) || (valuationTypeIsCost $ reportopts_ opts)
-- Replace this transaction's postings with the original postings if any, but keep the -- 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 ( module Hledger.Cli.Commands.Printunique (
printuniquemode printuniquemode
,printunique ,printunique
) )
where where
import Data.List import Data.List

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

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

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

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

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

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

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

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

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

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