447 lines
22 KiB
Haskell
447 lines
22 KiB
Haskell
{-|
|
|
|
|
A 'Transaction' consists of two or more related 'Posting's which balance
|
|
to zero, representing a movement of some commodity(ies) between accounts,
|
|
plus a date and optional metadata like description and cleared status.
|
|
|
|
-}
|
|
|
|
module Hledger.Data.Transaction (
|
|
-- * Transaction
|
|
nulltransaction,
|
|
txnTieKnot,
|
|
-- settxn,
|
|
-- * operations
|
|
showAccountName,
|
|
hasRealPostings,
|
|
realPostings,
|
|
virtualPostings,
|
|
balancedVirtualPostings,
|
|
transactionsPostings,
|
|
isTransactionBalanced,
|
|
-- nonzerobalanceerror,
|
|
-- * date operations
|
|
transactionActualDate,
|
|
transactionEffectiveDate,
|
|
journalTransactionWithDate,
|
|
-- * arithmetic
|
|
transactionPostingBalances,
|
|
balanceTransaction,
|
|
-- * rendering
|
|
showTransaction,
|
|
showTransactionUnelided,
|
|
-- * misc.
|
|
tests_Hledger_Data_Transaction
|
|
)
|
|
where
|
|
import Data.List
|
|
import Data.Maybe
|
|
import Data.Time.Calendar
|
|
import Test.HUnit
|
|
import Text.Printf
|
|
import qualified Data.Map as Map
|
|
|
|
import Hledger.Utils
|
|
import Hledger.Data.Types
|
|
import Hledger.Data.Dates
|
|
import Hledger.Data.Posting
|
|
import Hledger.Data.Amount
|
|
import Hledger.Data.Commodity
|
|
|
|
instance Show Transaction where show = showTransactionUnelided
|
|
|
|
instance Show ModifierTransaction where
|
|
show t = "= " ++ mtvalueexpr t ++ "\n" ++ unlines (map show (mtpostings t))
|
|
|
|
instance Show PeriodicTransaction where
|
|
show t = "~ " ++ ptperiodicexpr t ++ "\n" ++ unlines (map show (ptpostings t))
|
|
|
|
nulltransaction :: Transaction
|
|
nulltransaction = Transaction {
|
|
tdate=nulldate,
|
|
teffectivedate=Nothing,
|
|
tstatus=False,
|
|
tcode="",
|
|
tdescription="",
|
|
tcomment="",
|
|
tmetadata=[],
|
|
tpostings=[],
|
|
tpreceding_comment_lines=""
|
|
}
|
|
|
|
{-|
|
|
Show a journal transaction, formatted for the print command. ledger 2.x's
|
|
standard format looks like this:
|
|
|
|
@
|
|
yyyy/mm/dd[ *][ CODE] description......... [ ; comment...............]
|
|
account name 1..................... ...$amount1[ ; comment...............]
|
|
account name 2..................... ..$-amount1[ ; comment...............]
|
|
|
|
pcodewidth = no limit -- 10 -- mimicking ledger layout.
|
|
pdescwidth = no limit -- 20 -- I don't remember what these mean,
|
|
pacctwidth = 35 minimum, no maximum -- they were important at the time.
|
|
pamtwidth = 11
|
|
pcommentwidth = no limit -- 22
|
|
@
|
|
-}
|
|
showTransaction :: Transaction -> String
|
|
showTransaction = showTransaction' True
|
|
|
|
showTransactionUnelided :: Transaction -> String
|
|
showTransactionUnelided = showTransaction' False
|
|
|
|
showTransaction' :: Bool -> Transaction -> String
|
|
showTransaction' elide t =
|
|
unlines $ [description] ++ showpostings (tpostings t) ++ [""]
|
|
where
|
|
description = concat [date, status, code, desc, comment]
|
|
date = showdate (tdate t) ++ maybe "" showedate (teffectivedate t)
|
|
showdate = printf "%-10s" . showDate
|
|
showedate = printf "=%s" . showdate
|
|
status = if tstatus t then " *" else ""
|
|
code = if length (tcode t) > 0 then printf " (%s)" $ tcode t else ""
|
|
desc = if null d then "" else " " ++ d where d = tdescription t
|
|
comment = if null c then "" else " ; " ++ c where c = tcomment t
|
|
showpostings ps
|
|
| elide && length ps > 1 && isTransactionBalanced Nothing t -- imprecise balanced check
|
|
= map showposting (init ps) ++ [showpostingnoamt (last ps)]
|
|
| otherwise = map showposting ps
|
|
where
|
|
showpostingnoamt p = rstrip $ showacct p ++ " " ++ showcomment (pcomment p)
|
|
showposting p = concatTopPadded [showacct p
|
|
," "
|
|
,showamt (pamount p)
|
|
,showcomment (pcomment p)
|
|
]
|
|
showacct p = " " ++ showstatus p ++ printf (printf "%%-%ds" w) (showAccountName Nothing (ptype p) (paccount p))
|
|
where w = maximum $ map (length . paccount) ps
|
|
showstatus p = if pstatus p then "* " else ""
|
|
showamt =
|
|
padleft 12 . showMixedAmount
|
|
showcomment s = if null s then "" else " ; "++s
|
|
|
|
-- | Show an account name, clipped to the given width if any, and
|
|
-- appropriately bracketed/parenthesised for the given posting type.
|
|
showAccountName :: Maybe Int -> PostingType -> AccountName -> String
|
|
showAccountName w = fmt
|
|
where
|
|
fmt RegularPosting = take w'
|
|
fmt VirtualPosting = parenthesise . reverse . take (w'-2) . reverse
|
|
fmt BalancedVirtualPosting = bracket . reverse . take (w'-2) . reverse
|
|
w' = fromMaybe 999999 w
|
|
parenthesise s = "("++s++")"
|
|
bracket s = "["++s++"]"
|
|
|
|
hasRealPostings :: Transaction -> Bool
|
|
hasRealPostings = not . null . realPostings
|
|
|
|
realPostings :: Transaction -> [Posting]
|
|
realPostings = filter isReal . tpostings
|
|
|
|
virtualPostings :: Transaction -> [Posting]
|
|
virtualPostings = filter isVirtual . tpostings
|
|
|
|
balancedVirtualPostings :: Transaction -> [Posting]
|
|
balancedVirtualPostings = filter isBalancedVirtual . tpostings
|
|
|
|
transactionsPostings :: [Transaction] -> [Posting]
|
|
transactionsPostings = concat . map tpostings
|
|
|
|
-- | Get the sums of a transaction's real, virtual, and balanced virtual postings.
|
|
transactionPostingBalances :: Transaction -> (MixedAmount,MixedAmount,MixedAmount)
|
|
transactionPostingBalances t = (sumPostings $ realPostings t
|
|
,sumPostings $ virtualPostings t
|
|
,sumPostings $ balancedVirtualPostings t)
|
|
|
|
-- | Is this transaction balanced ? A balanced transaction's real
|
|
-- (non-virtual) postings sum to 0, and any balanced virtual postings
|
|
-- also sum to 0.
|
|
isTransactionBalanced :: Maybe (Map.Map String Commodity) -> Transaction -> Bool
|
|
isTransactionBalanced canonicalcommoditymap t =
|
|
-- isReallyZeroMixedAmountCost rsum && isReallyZeroMixedAmountCost bvsum
|
|
isZeroMixedAmount rsum' && isZeroMixedAmount bvsum'
|
|
where
|
|
(rsum, _, bvsum) = transactionPostingBalances t
|
|
rsum' = canonicaliseMixedAmountCommodity canonicalcommoditymap $ costOfMixedAmount rsum
|
|
bvsum' = canonicaliseMixedAmountCommodity canonicalcommoditymap $ costOfMixedAmount bvsum
|
|
|
|
-- | Ensure this transaction is balanced, possibly inferring a missing
|
|
-- amount or conversion price, or return an error message.
|
|
--
|
|
-- Balancing is affected by commodity display precisions, so those may
|
|
-- be provided.
|
|
--
|
|
-- We can infer a missing real amount when there are multiple real
|
|
-- postings and exactly one of them is amountless (likewise for
|
|
-- balanced virtual postings). Inferred amounts are converted to cost
|
|
-- basis when possible.
|
|
--
|
|
-- We can infer a conversion price when all real amounts are specified
|
|
-- and the sum of real postings' amounts is exactly two
|
|
-- non-explicitly-priced amounts in different commodities (likewise
|
|
-- for balanced virtual postings).
|
|
balanceTransaction :: Maybe (Map.Map String Commodity) -> Transaction -> Either String Transaction
|
|
balanceTransaction canonicalcommoditymap t@Transaction{tpostings=ps}
|
|
| length rwithoutamounts > 1 || length bvwithoutamounts > 1
|
|
= Left $ printerr "could not balance this transaction (too many missing amounts)"
|
|
| not $ isTransactionBalanced canonicalcommoditymap t''' = Left $ printerr $ nonzerobalanceerror t'''
|
|
| otherwise = Right t'''
|
|
where
|
|
-- maybe infer missing amounts
|
|
(rwithamounts, rwithoutamounts) = partition hasAmount $ realPostings t
|
|
(bvwithamounts, bvwithoutamounts) = partition hasAmount $ balancedVirtualPostings t
|
|
ramounts = map pamount rwithamounts
|
|
bvamounts = map pamount bvwithamounts
|
|
t' = t{tpostings=map inferamount ps}
|
|
where
|
|
inferamount p | not (hasAmount p) && isReal p = p{pamount = costOfMixedAmount (- sum ramounts)}
|
|
| not (hasAmount p) && isBalancedVirtual p = p{pamount = costOfMixedAmount (- sum bvamounts)}
|
|
| otherwise = p
|
|
|
|
-- maybe infer conversion prices, for real postings
|
|
rmixedamountsinorder = map pamount $ realPostings t'
|
|
ramountsinorder = concatMap amounts rmixedamountsinorder
|
|
rcommoditiesinorder = map commodity ramountsinorder
|
|
rsumamounts = amounts $ sum rmixedamountsinorder
|
|
-- assumption: the sum of mixed amounts is normalised (one simple amount per commodity)
|
|
t'' = if length rsumamounts == 2 && all (isNothing.price) rsumamounts && t'==t
|
|
then t'{tpostings=map inferprice ps}
|
|
else t'
|
|
where
|
|
-- assumption: a posting's mixed amount contains one simple amount
|
|
inferprice p@Posting{pamount=Mixed [a@Amount{commodity=c,price=Nothing}], ptype=RegularPosting}
|
|
= p{pamount=Mixed [a{price=conversionprice c}]}
|
|
where
|
|
conversionprice c | c == unpricedcommodity
|
|
-- assign a balancing price. Use @@ for more exact output when possible.
|
|
-- invariant: prices should always be positive. Enforced with "abs"
|
|
= if length ramountsinunpricedcommodity == 1
|
|
then Just $ TotalPrice $ Mixed [setAmountPrecision maxprecision $ abs $ targetcommodityamount]
|
|
else Just $ UnitPrice $ Mixed [setAmountPrecision maxprecision $ abs $ targetcommodityamount `divideAmount` (quantity unpricedamount)]
|
|
| otherwise = Nothing
|
|
where
|
|
unpricedcommodity = head $ filter (`elem` (map commodity rsumamounts)) rcommoditiesinorder
|
|
unpricedamount = head $ filter ((==unpricedcommodity).commodity) rsumamounts
|
|
targetcommodityamount = head $ filter ((/=unpricedcommodity).commodity) rsumamounts
|
|
ramountsinunpricedcommodity = filter ((==unpricedcommodity).commodity) ramountsinorder
|
|
inferprice p = p
|
|
|
|
-- maybe infer prices for balanced virtual postings. Just duplicates the above for now.
|
|
bvmixedamountsinorder = map pamount $ balancedVirtualPostings t''
|
|
bvamountsinorder = concatMap amounts bvmixedamountsinorder
|
|
bvcommoditiesinorder = map commodity bvamountsinorder
|
|
bvsumamounts = amounts $ sum bvmixedamountsinorder
|
|
t''' = if length bvsumamounts == 2 && all (isNothing.price) bvsumamounts && t'==t -- XXX could check specifically for bv amount inferring
|
|
then t''{tpostings=map inferprice ps}
|
|
else t''
|
|
where
|
|
inferprice p@Posting{pamount=Mixed [a@Amount{commodity=c,price=Nothing}], ptype=BalancedVirtualPosting}
|
|
= p{pamount=Mixed [a{price=conversionprice c}]}
|
|
where
|
|
conversionprice c | c == unpricedcommodity
|
|
= if length bvamountsinunpricedcommodity == 1
|
|
then Just $ TotalPrice $ Mixed [setAmountPrecision maxprecision $ abs $ targetcommodityamount]
|
|
else Just $ UnitPrice $ Mixed [setAmountPrecision maxprecision $ abs $ targetcommodityamount `divideAmount` (quantity unpricedamount)]
|
|
| otherwise = Nothing
|
|
where
|
|
unpricedcommodity = head $ filter (`elem` (map commodity bvsumamounts)) bvcommoditiesinorder
|
|
unpricedamount = head $ filter ((==unpricedcommodity).commodity) bvsumamounts
|
|
targetcommodityamount = head $ filter ((/=unpricedcommodity).commodity) bvsumamounts
|
|
bvamountsinunpricedcommodity = filter ((==unpricedcommodity).commodity) bvamountsinorder
|
|
inferprice p = p
|
|
|
|
printerr s = intercalate "\n" [s, showTransactionUnelided t]
|
|
|
|
nonzerobalanceerror :: Transaction -> String
|
|
nonzerobalanceerror t = printf "could not balance this transaction (%s%s%s)" rmsg sep bvmsg
|
|
where
|
|
(rsum, _, bvsum) = transactionPostingBalances t
|
|
rmsg | isReallyZeroMixedAmountCost rsum = ""
|
|
| otherwise = "real postings are off by " ++ show (costOfMixedAmount rsum)
|
|
bvmsg | isReallyZeroMixedAmountCost bvsum = ""
|
|
| otherwise = "balanced virtual postings are off by " ++ show (costOfMixedAmount bvsum)
|
|
sep = if not (null rmsg) && not (null bvmsg) then "; " else ""
|
|
|
|
transactionActualDate :: Transaction -> Day
|
|
transactionActualDate = tdate
|
|
|
|
-- Get a transaction's effective date, defaulting to the actual date.
|
|
transactionEffectiveDate :: Transaction -> Day
|
|
transactionEffectiveDate t = fromMaybe (tdate t) $ teffectivedate t
|
|
|
|
-- | Once we no longer need both, set the main transaction date to either
|
|
-- the actual or effective date. A bit hacky.
|
|
journalTransactionWithDate :: WhichDate -> Transaction -> Transaction
|
|
journalTransactionWithDate ActualDate t = t
|
|
journalTransactionWithDate EffectiveDate t = txnTieKnot t{tdate=transactionEffectiveDate t}
|
|
|
|
-- | Ensure a transaction's postings refer back to it.
|
|
txnTieKnot :: Transaction -> Transaction
|
|
txnTieKnot t@Transaction{tpostings=ps} = t{tpostings=map (settxn t) ps}
|
|
|
|
-- | Set a posting's parent transaction.
|
|
settxn :: Transaction -> Posting -> Posting
|
|
settxn t p = p{ptransaction=Just t}
|
|
|
|
tests_Hledger_Data_Transaction = TestList [
|
|
"showTransaction" ~: do
|
|
assertEqual "show a balanced transaction, eliding last amount"
|
|
(unlines
|
|
["2007/01/28 coopportunity"
|
|
," expenses:food:groceries $47.18"
|
|
," assets:checking"
|
|
,""
|
|
])
|
|
(let t = Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" []
|
|
[Posting False "expenses:food:groceries" (Mixed [dollars 47.18]) "" RegularPosting [] (Just t)
|
|
,Posting False "assets:checking" (Mixed [dollars (-47.18)]) "" RegularPosting [] (Just t)
|
|
] ""
|
|
in showTransaction t)
|
|
|
|
,"showTransaction" ~: do
|
|
assertEqual "show a balanced transaction, no eliding"
|
|
(unlines
|
|
["2007/01/28 coopportunity"
|
|
," expenses:food:groceries $47.18"
|
|
," assets:checking $-47.18"
|
|
,""
|
|
])
|
|
(let t = Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" []
|
|
[Posting False "expenses:food:groceries" (Mixed [dollars 47.18]) "" RegularPosting [] (Just t)
|
|
,Posting False "assets:checking" (Mixed [dollars (-47.18)]) "" RegularPosting [] (Just t)
|
|
] ""
|
|
in showTransactionUnelided t)
|
|
|
|
-- document some cases that arise in debug/testing:
|
|
,"showTransaction" ~: do
|
|
assertEqual "show an unbalanced transaction, should not elide"
|
|
(unlines
|
|
["2007/01/28 coopportunity"
|
|
," expenses:food:groceries $47.18"
|
|
," assets:checking $-47.19"
|
|
,""
|
|
])
|
|
(showTransaction
|
|
(txnTieKnot $ Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" []
|
|
[Posting False "expenses:food:groceries" (Mixed [dollars 47.18]) "" RegularPosting [] Nothing
|
|
,Posting False "assets:checking" (Mixed [dollars (-47.19)]) "" RegularPosting [] Nothing
|
|
] ""))
|
|
|
|
,"showTransaction" ~: do
|
|
assertEqual "show an unbalanced transaction with one posting, should not elide"
|
|
(unlines
|
|
["2007/01/28 coopportunity"
|
|
," expenses:food:groceries $47.18"
|
|
,""
|
|
])
|
|
(showTransaction
|
|
(txnTieKnot $ Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" []
|
|
[Posting False "expenses:food:groceries" (Mixed [dollars 47.18]) "" RegularPosting [] Nothing
|
|
] ""))
|
|
|
|
,"showTransaction" ~: do
|
|
assertEqual "show a transaction with one posting and a missing amount"
|
|
(unlines
|
|
["2007/01/28 coopportunity"
|
|
," expenses:food:groceries "
|
|
,""
|
|
])
|
|
(showTransaction
|
|
(txnTieKnot $ Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" []
|
|
[Posting False "expenses:food:groceries" missingamt "" RegularPosting [] Nothing
|
|
] ""))
|
|
|
|
,"showTransaction" ~: do
|
|
assertEqual "show a transaction with a priced commodityless amount"
|
|
(unlines
|
|
["2010/01/01 x"
|
|
," a 1 @ $2"
|
|
," b "
|
|
,""
|
|
])
|
|
(showTransaction
|
|
(txnTieKnot $ Transaction (parsedate "2010/01/01") Nothing False "" "x" "" []
|
|
[Posting False "a" (Mixed [Amount unknown 1 (Just $ UnitPrice $ Mixed [Amount dollar{precision=0} 2 Nothing])]) "" RegularPosting [] Nothing
|
|
,Posting False "b" missingamt "" RegularPosting [] Nothing
|
|
] ""))
|
|
|
|
,"balanceTransaction" ~: do
|
|
assertBool "detect unbalanced entry, sign error"
|
|
(isLeft $ balanceTransaction Nothing
|
|
(Transaction (parsedate "2007/01/28") Nothing False "" "test" "" []
|
|
[Posting False "a" (Mixed [dollars 1]) "" RegularPosting [] Nothing,
|
|
Posting False "b" (Mixed [dollars 1]) "" RegularPosting [] Nothing
|
|
] ""))
|
|
assertBool "detect unbalanced entry, multiple missing amounts"
|
|
(isLeft $ balanceTransaction Nothing
|
|
(Transaction (parsedate "2007/01/28") Nothing False "" "test" "" []
|
|
[Posting False "a" missingamt "" RegularPosting [] Nothing,
|
|
Posting False "b" missingamt "" RegularPosting [] Nothing
|
|
] ""))
|
|
let e = balanceTransaction Nothing (Transaction (parsedate "2007/01/28") Nothing False "" "" "" []
|
|
[Posting False "a" (Mixed [dollars 1]) "" RegularPosting [] Nothing,
|
|
Posting False "b" missingamt "" RegularPosting [] Nothing
|
|
] "")
|
|
assertBool "balanceTransaction allows one missing amount" (isRight e)
|
|
assertEqual "balancing amount is inferred"
|
|
(Mixed [dollars (-1)])
|
|
(case e of
|
|
Right e' -> (pamount $ last $ tpostings e')
|
|
Left _ -> error' "should not happen")
|
|
let e = balanceTransaction Nothing (Transaction (parsedate "2011/01/01") Nothing False "" "" "" []
|
|
[Posting False "a" (Mixed [dollars 1.35]) "" RegularPosting [] Nothing,
|
|
Posting False "b" (Mixed [euros (-1)]) "" RegularPosting [] Nothing
|
|
] "")
|
|
assertBool "balanceTransaction can infer conversion price" (isRight e)
|
|
assertEqual "balancing conversion price is inferred"
|
|
(Mixed [Amount{commodity=dollar{precision=2},
|
|
quantity=1.35,
|
|
price=(Just $ TotalPrice $ Mixed [Amount{commodity=euro{precision=maxprecision},
|
|
quantity=1,
|
|
price=Nothing}])}])
|
|
(case e of
|
|
Right e' -> (pamount $ head $ tpostings e')
|
|
Left _ -> error' "should not happen")
|
|
|
|
,"isTransactionBalanced" ~: do
|
|
let t = Transaction (parsedate "2009/01/01") Nothing False "" "a" "" []
|
|
[Posting False "b" (Mixed [dollars 1.00]) "" RegularPosting [] (Just t)
|
|
,Posting False "c" (Mixed [dollars (-1.00)]) "" RegularPosting [] (Just t)
|
|
] ""
|
|
assertBool "detect balanced" (isTransactionBalanced Nothing t)
|
|
let t = Transaction (parsedate "2009/01/01") Nothing False "" "a" "" []
|
|
[Posting False "b" (Mixed [dollars 1.00]) "" RegularPosting [] (Just t)
|
|
,Posting False "c" (Mixed [dollars (-1.01)]) "" RegularPosting [] (Just t)
|
|
] ""
|
|
assertBool "detect unbalanced" (not $ isTransactionBalanced Nothing t)
|
|
let t = Transaction (parsedate "2009/01/01") Nothing False "" "a" "" []
|
|
[Posting False "b" (Mixed [dollars 1.00]) "" RegularPosting [] (Just t)
|
|
] ""
|
|
assertBool "detect unbalanced, one posting" (not $ isTransactionBalanced Nothing t)
|
|
let t = Transaction (parsedate "2009/01/01") Nothing False "" "a" "" []
|
|
[Posting False "b" (Mixed [dollars 0]) "" RegularPosting [] (Just t)
|
|
] ""
|
|
assertBool "one zero posting is considered balanced for now" (isTransactionBalanced Nothing t)
|
|
let t = Transaction (parsedate "2009/01/01") Nothing False "" "a" "" []
|
|
[Posting False "b" (Mixed [dollars 1.00]) "" RegularPosting [] (Just t)
|
|
,Posting False "c" (Mixed [dollars (-1.00)]) "" RegularPosting [] (Just t)
|
|
,Posting False "d" (Mixed [dollars 100]) "" VirtualPosting [] (Just t)
|
|
] ""
|
|
assertBool "virtual postings don't need to balance" (isTransactionBalanced Nothing t)
|
|
let t = Transaction (parsedate "2009/01/01") Nothing False "" "a" "" []
|
|
[Posting False "b" (Mixed [dollars 1.00]) "" RegularPosting [] (Just t)
|
|
,Posting False "c" (Mixed [dollars (-1.00)]) "" RegularPosting [] (Just t)
|
|
,Posting False "d" (Mixed [dollars 100]) "" BalancedVirtualPosting [] (Just t)
|
|
] ""
|
|
assertBool "balanced virtual postings need to balance among themselves" (not $ isTransactionBalanced Nothing t)
|
|
let t = Transaction (parsedate "2009/01/01") Nothing False "" "a" "" []
|
|
[Posting False "b" (Mixed [dollars 1.00]) "" RegularPosting [] (Just t)
|
|
,Posting False "c" (Mixed [dollars (-1.00)]) "" RegularPosting [] (Just t)
|
|
,Posting False "d" (Mixed [dollars 100]) "" BalancedVirtualPosting [] (Just t)
|
|
,Posting False "e" (Mixed [dollars (-100)]) "" BalancedVirtualPosting [] (Just t)
|
|
] ""
|
|
assertBool "balanced virtual postings need to balance among themselves (2)" (isTransactionBalanced Nothing t)
|
|
|
|
]
|