Skip to content

Commit b6b0c85

Browse files
simonmichaelsimonmichael
committed
WIP
1 parent de73f55 commit b6b0c85

File tree

3 files changed

+96
-19
lines changed

3 files changed

+96
-19
lines changed

‎hledger-lib/Hledger/Data/Amount.hs‎

Lines changed: 14 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1,3 +1,4 @@
1+
{-# LANGUAGE NamedFieldPuns #-}
12
{-|
23
A simple 'Amount' is some quantity of money, shares, or anything else.
34
It has a (possibly null) 'CommoditySymbol' and a numeric quantity:
@@ -106,6 +107,7 @@ module Hledger.Data.Amount (
106107
mixedAmountStripPrices,
107108
-- ** arithmetic
108109
mixedAmountCost,
110+
mixedAmountCostPreservingPrecision,
109111
divideMixedAmount,
110112
multiplyMixedAmount,
111113
divideMixedAmountAndPrice,
@@ -319,6 +321,13 @@ amountCost a@Amount{aquantity=q, aprice=mp} =
319321
Just (UnitPrice p@Amount{aquantity=pq}) -> p{aquantity=pq * q}
320322
Just (TotalPrice p@Amount{aquantity=pq}) -> p{aquantity=pq * signum q}
321323

324+
-- | Like amountCost, but then re-apply the display precision of the
325+
-- original commodity.
326+
amountCostPreservingPrecision :: Amount -> Amount
327+
amountCostPreservingPrecision a@Amount{astyle=AmountStyle{asprecision}} =
328+
a'{astyle=astyle'{asprecision=asprecision}}
329+
where a'@Amount{astyle=astyle'} = amountCost a
330+
322331
-- | Replace an amount's TotalPrice, if it has one, with an equivalent UnitPrice.
323332
-- Has no effect on amounts without one.
324333
-- Also increases the unit price's display precision to show one extra decimal place,
@@ -668,6 +677,11 @@ mapMixedAmount f (Mixed as) = Mixed $ map f as
668677
mixedAmountCost :: MixedAmount -> MixedAmount
669678
mixedAmountCost = mapMixedAmount amountCost
670679

680+
-- | Like mixedAmountCost, but then re-apply the display precision of the
681+
-- original commodity.
682+
mixedAmountCostPreservingPrecision :: MixedAmount -> MixedAmount
683+
mixedAmountCostPreservingPrecision = mapMixedAmount amountCostPreservingPrecision
684+
671685
-- | Divide a mixed amount's quantities by a constant.
672686
divideMixedAmount :: Quantity -> MixedAmount -> MixedAmount
673687
divideMixedAmount n = mapMixedAmount (divideAmount n)

‎hledger-lib/Hledger/Data/Transaction.hs‎

Lines changed: 48 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -1,3 +1,4 @@
1+
{-# LANGUAGE NamedFieldPuns #-}
12
{-|
23
34
A 'Transaction' represents a movement of some commodity(ies) between two
@@ -83,6 +84,7 @@ import Hledger.Data.Valuation
8384
import Text.Tabular
8485
import Text.Tabular.AsciiWide
8586
import Control.Applicative ((<|>))
87+
import Text.Printf (printf)
8688

8789
sourceFilePath :: GenericSourcePos -> FilePath
8890
sourceFilePath = \case
@@ -378,10 +380,41 @@ transactionCheckBalanced mglobalstyles t = errs
378380
-- of decimal places specified by its display style, from either the
379381
-- provided global display styles, or local styles inferred from just
380382
-- this transaction.
383+
384+
-- Which local styles (& thence, precisions) exactly should we
385+
-- infer from this transaction ? Since amounts are going to be
386+
-- converted to cost, we may end up with the commodity of
387+
-- transaction prices, so we'll need to pick a style for those too.
388+
--
389+
-- Option 1: also infer styles from the price amounts, which normally isn't done.
390+
-- canonicalise = maybe id canonicaliseMixedAmount (mglobalstyles <|> mtxnstyles)
391+
-- where
392+
-- mtxnstyles = dbg0 "transactionCheckBalanced mtxnstyles" $
393+
-- either (const Nothing) Just $ -- shouldn't get any error here, but if so just.. carry on, comparing uncanonicalised amounts XXX
394+
-- commodityStylesFromAmounts $ concatMap postingAllAmounts $ rps ++ bvps
395+
-- where
396+
-- -- | Get all the individual Amounts from a posting's MixedAmount,
397+
-- -- and all their price Amounts as well.
398+
-- postingAllAmounts :: Posting -> [Amount]
399+
-- postingAllAmounts p = catMaybes $ concat [[Just a, priceamount a] | a <- amounts $ pamount p]
400+
-- where
401+
-- priceamount Amount{aprice} =
402+
-- case aprice of
403+
-- Just (UnitPrice a) -> Just a
404+
-- Just (TotalPrice a) -> Just a
405+
-- Nothing -> Nothing
406+
--
407+
-- Option 2, for amounts converted to cost, where the new commodity appears only in prices,
408+
-- use the precision of their original commodity (by using mixedAmountCostPreservingPrecision).
409+
(tocost,costlabel) = case mglobalstyles of
410+
Just _ -> (mixedAmountCost,"") -- --balancing=styled
411+
Nothing -> (mixedAmountCostPreservingPrecision,"withorigprecision") -- --balancing=exact
381412
canonicalise = maybe id canonicaliseMixedAmount (mglobalstyles <|> mtxnstyles)
382413
where
383-
mtxnstyles = either (const Nothing) Just $ -- shouldn't get any error here, but if so just.. carry on, comparing uncanonicalised amounts XXX
384-
commodityStylesFromAmounts $ concatMap (amounts.pamount) $ rps ++ bvps
414+
mtxnstyles = dbg9 "transactionCheckBalanced mtxnstyles" $
415+
either (const Nothing) Just $ -- shouldn't get an error here, but if so just don't canonicalise
416+
commodityStylesFromAmounts $ concatMap (amounts.pamount) $ rps ++ bvps
417+
385418

386419
-- check for mixed signs, detecting nonzeros at display precision
387420
signsOk ps =
@@ -392,22 +425,28 @@ transactionCheckBalanced mglobalstyles t = errs
392425
(rsignsok, bvsignsok) = (signsOk rps, signsOk bvps)
393426

394427
-- check for zero sum, at display precision
395-
(rsum, bvsum) = (sumPostings rps, sumPostings bvps)
396-
(rsumcost, bvsumcost) = (mixedAmountCost rsum, mixedAmountCost bvsum)
397-
(rsumdisplay, bvsumdisplay) = (canonicalise rsumcost, canonicalise bvsumcost)
398-
(rsumok, bvsumok) = (mixedAmountLooksZero rsumdisplay, mixedAmountLooksZero bvsumdisplay)
428+
(rsum, bvsum) = (dbg9 "transactionCheckBalanced rsum" $ sumPostings rps, sumPostings bvps)
429+
(rsumcost, bvsumcost) = (dbg9 ("transactionCheckBalanced rsumcost"++costlabel) $ tocost rsum, tocost bvsum)
430+
(rsumstyled, bvsumstyled) = (dbg9 "transactionCheckBalanced rsumstyled" $ canonicalise rsumcost, canonicalise bvsumcost)
431+
(rsumok, bvsumok) = (mixedAmountLooksZero rsumstyled, mixedAmountLooksZero bvsumstyled)
399432

400-
-- generate error messages, showing amounts with their original precision
433+
-- generate error messages
401434
errs = filter (not.null) [rmsg, bvmsg]
402435
where
403436
rmsg
404437
| not rsignsok = "real postings all have the same sign"
405-
| not rsumok = "real postings' sum should be 0 but is: " ++ showMixedAmount (mixedAmountSetFullPrecision rsumcost)
438+
| not rsumok = printf "real postings' sum should be %s but is %s (rounded from %s)" rsumexpected rsumactual rsumfull
406439
| otherwise = ""
407440
bvmsg
408441
| not bvsignsok = "balanced virtual postings all have the same sign"
409-
| not bvsumok = "balanced virtual postings' sum should be 0 but is: " ++ showMixedAmount (mixedAmountSetFullPrecision bvsumcost)
442+
| not bvsumok = printf "balanced virtual postings' sum should be %s but is %s (rounded from %s)" bvsumexpected bvsumactual bvsumfull
410443
| otherwise = ""
444+
rsumexpected = showMixedAmountWithZeroCommodity $ mapMixedAmount (\a -> a{aquantity=0}) rsumstyled
445+
rsumactual = showMixedAmount rsumstyled
446+
rsumfull = showMixedAmount (mixedAmountSetFullPrecision rsumcost)
447+
bvsumexpected = showMixedAmountWithZeroCommodity $ mapMixedAmount (\a -> a{aquantity=0}) rsumstyled
448+
bvsumactual = showMixedAmount bvsumstyled
449+
bvsumfull = showMixedAmount (mixedAmountSetFullPrecision bvsumcost)
411450

412451
-- | Legacy form of transactionCheckBalanced.
413452
isTransactionBalanced :: Maybe (M.Map CommoditySymbol AmountStyle) -> Transaction -> Bool

‎hledger/test/journal/transaction-balancing.test‎

Lines changed: 34 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -1,19 +1,43 @@
1-
# test some specific transaction balanced checking issues
1+
# Test cases for balanced-transaction checking, cf #1479
22

3-
# Old journal entries dependent on commodity directives for balancing (#1479)
43
<
54
commodity $0.00
65

76
2021-01-01 move a lot elsewhere, adjusting cost basis due to fees
8-
assets:investments1 AAAA -11.0 @ $0.093735
9-
expenses:fees AAAA 0.6
10-
equity:basis adjustment AAAA -0.6
11-
assets:investments2 AAAA 10.4 @ $0.099143
7+
assets:investments1 A -11.0 @ B 0.093735
8+
expenses:fees A 0.6
9+
equity:basis adjustment A -0.6
10+
assets:investments2 A 10.4 @ B 0.099143
1211

13-
# 1. fail with default "exact" balanced checking
12+
# 1, 2. succeeds with old "styled" and new "exact" balanced checking
13+
$ hledger -f- check --balancing=styled
1414
$ hledger -f- check
15-
>2 /real postings' sum should be 0 but is: \$0.0000022/
16-
>=1
1715

18-
# 2. succeed with "styled" balanced checking
16+
<
17+
commodity $0.00
18+
19+
2021-01-01
20+
a A -11.0 @ B 0.093735
21+
b A 10.4 @ B 0.099143
22+
23+
# 3, 4. succeeds with old and new balanced checking
1924
$ hledger -f- check --balancing=styled
25+
$ hledger -f- check
26+
27+
<
28+
commodity B0.00
29+
30+
2021-01-01
31+
a A -9514.405544 @ B 0.104314
32+
b A 9513.805544 @ B 0.1043206
33+
34+
# 5, 6. succeeds and fails with old and new balanced checking
35+
$ hledger -f- check --balancing=styled
36+
$ hledger -f- check
37+
>2 //
38+
>= 1
39+
40+
# <
41+
# 2021-01-01
42+
# a 1C @ $1.0049
43+
# b $-1.000

0 commit comments

Comments
 (0)