module Hledger.Data.Transaction (
nulltransaction,
txnTieKnot,
showAccountName,
hasRealPostings,
realPostings,
virtualPostings,
balancedVirtualPostings,
transactionsPostings,
isTransactionBalanced,
transactionActualDate,
transactionEffectiveDate,
journalTransactionWithDate,
transactionPostingBalances,
balanceTransaction,
showTransaction,
showTransactionUnelided,
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="",
ttags=[],
tpostings=[],
tpreceding_comment_lines=""
}
showTransaction :: Transaction -> String
showTransaction = showTransaction' True
showTransactionUnelided :: Transaction -> String
showTransactionUnelided = showTransaction' False
tests_showTransactionUnelided = [
"showTransactionUnelided" ~: do
let t `gives` s = assertEqual "" s (showTransactionUnelided t)
nulltransaction `gives` "0000/01/01\n\n"
nulltransaction{
tdate=parsedate "2012/05/14",
teffectivedate=Just $ parsedate "2012/05/15",
tstatus=False,
tcode="code",
tdescription="desc",
tcomment="tcomment1\ntcomment2\n",
ttags=[("ttag1","val1")],
tpostings=[
nullposting{
pstatus=True,
paccount="a",
pamount=Mixed [dollars 1, hours 2],
pcomment="pcomment1\npcomment2\n",
ptype=RegularPosting,
ptags=[("ptag1","val1"),("ptag2","val2")]
}
]
}
`gives` unlines [
"2012/05/14=2012/05/15 (code) desc ; tcomment1",
" ; tcomment2",
" ; ttag1: val1",
" $1.00",
" * a 2.0h ; pcomment1",
" ; pcomment2",
" ; ptag1: val1",
" ; ptag2: val2",
""
]
]
showTransaction' :: Bool -> Transaction -> String
showTransaction' elide t =
unlines $ [descriptionline]
++ commentlines
++ (tagsAsLines $ ttags t)
++ (postingsAsLines elide t (tpostings t))
++ [""]
where
descriptionline = rstrip $ concat [date, status, code, desc, firstcomment]
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
(firstcomment, commentlines) = commentLines $ tcomment t
commentLines :: String -> (String, [String])
commentLines s
| null s = ("", [])
| otherwise = (" ; " ++ first, map (indent . ("; "++)) rest)
where (first:rest) = lines s
postingsAsLines :: Bool -> Transaction -> [Posting] -> [String]
postingsAsLines elide t ps
| elide && length ps > 1 && isTransactionBalanced Nothing t
= (concatMap (postingAsLines False ps) $ init ps) ++ postingAsLines True ps (last ps)
| otherwise = concatMap (postingAsLines False ps) ps
postingAsLines :: Bool -> [Posting] -> Posting -> [String]
postingAsLines elideamount ps p =
postinglines
++ commentlines
++ tagsAsLines (ptags p)
where
postinglines = map rstrip $ lines $ concatTopPadded [showacct p, " ", amount, firstcomment]
amount = if elideamount then "" else showamt (pamount p)
(firstcomment, commentlines) = commentLines $ pcomment p
showacct p =
indent $ showstatus p ++ printf (printf "%%-%ds" w) (showAccountName Nothing (ptype p) (paccount p))
where
showstatus p = if pstatus p then "* " else ""
w = maximum $ map (length . paccount) ps
showamt =
padleft 12 . showMixedAmount
tests_postingAsLines = [
"postingAsLines" ~: do
let p `gives` ls = assertEqual "" ls (postingAsLines False [p] p)
nullposting `gives` [" 0"]
nullposting{
pstatus=True,
paccount="a",
pamount=Mixed [dollars 1, hours 2],
pcomment="pcomment1\npcomment2\n",
ptype=RegularPosting,
ptags=[("ptag1","val1"),("ptag2","val2")]
}
`gives` [
" $1.00",
" * a 2.0h ; pcomment1",
" ; pcomment2",
" ; ptag1: val1",
" ; ptag2: val2"
]
]
indent :: String -> String
indent = (" "++)
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
transactionPostingBalances :: Transaction -> (MixedAmount,MixedAmount,MixedAmount)
transactionPostingBalances t = (sumPostings $ realPostings t
,sumPostings $ virtualPostings t
,sumPostings $ balancedVirtualPostings t)
isTransactionBalanced :: Maybe (Map.Map String Commodity) -> Transaction -> Bool
isTransactionBalanced canonicalcommoditymap t =
isZeroMixedAmount rsum' && isZeroMixedAmount bvsum'
where
(rsum, _, bvsum) = transactionPostingBalances t
rsum' = canonicaliseMixedAmountCommodity canonicalcommoditymap $ costOfMixedAmount rsum
bvsum' = canonicaliseMixedAmountCommodity canonicalcommoditymap $ costOfMixedAmount bvsum
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
(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
rmixedamountsinorder = map pamount $ realPostings t'
ramountsinorder = concatMap amounts rmixedamountsinorder
rcommoditiesinorder = map commodity ramountsinorder
rsumamounts = amounts $ sum rmixedamountsinorder
t'' = if length rsumamounts == 2 && all (isNothing.price) rsumamounts && t'==t
then t'{tpostings=map inferprice ps}
else t'
where
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
= 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
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
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 " ++ showMixedAmount (costOfMixedAmount rsum)
bvmsg | isReallyZeroMixedAmountCost bvsum = ""
| otherwise = "balanced virtual postings are off by " ++ showMixedAmount (costOfMixedAmount bvsum)
sep = if not (null rmsg) && not (null bvmsg) then "; " else "" :: String
transactionActualDate :: Transaction -> Day
transactionActualDate = tdate
transactionEffectiveDate :: Transaction -> Day
transactionEffectiveDate t = fromMaybe (tdate t) $ teffectivedate t
journalTransactionWithDate :: WhichDate -> Transaction -> Transaction
journalTransactionWithDate ActualDate t = t
journalTransactionWithDate EffectiveDate t = txnTieKnot t{tdate=transactionEffectiveDate t}
txnTieKnot :: Transaction -> Transaction
txnTieKnot t@Transaction{tpostings=ps} = t{tpostings=map (settxn t) ps}
settxn :: Transaction -> Posting -> Posting
settxn t p = p{ptransaction=Just t}
tests_Hledger_Data_Transaction = TestList $ concat [
tests_postingAsLines,
tests_showTransactionUnelided,
[
"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)
,"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" missingmixedamt "" 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" missingmixedamt "" 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" missingmixedamt "" RegularPosting [] Nothing,
Posting False "b" missingmixedamt "" RegularPosting [] Nothing
] ""))
let e = balanceTransaction Nothing (Transaction (parsedate "2007/01/28") Nothing False "" "" "" []
[Posting False "a" (Mixed [dollars 1]) "" RegularPosting [] Nothing,
Posting False "b" missingmixedamt "" 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")
assertBool "balanceTransaction balances based on cost if there are unit prices" (isRight $
balanceTransaction Nothing (Transaction (parsedate "2011/01/01") Nothing False "" "" "" []
[Posting False "a" (Mixed [Amount dollar 1 (Just $ UnitPrice $ Mixed [euros 2])]) "" RegularPosting [] Nothing
,Posting False "a" (Mixed [Amount dollar (2) (Just $ UnitPrice $ Mixed [euros 1])]) "" RegularPosting [] Nothing
] ""))
assertBool "balanceTransaction balances based on cost if there are total prices" (isRight $
balanceTransaction Nothing (Transaction (parsedate "2011/01/01") Nothing False "" "" "" []
[Posting False "a" (Mixed [Amount dollar 1 (Just $ TotalPrice $ Mixed [euros 1])]) "" RegularPosting [] Nothing
,Posting False "a" (Mixed [Amount dollar (2) (Just $ TotalPrice $ Mixed [euros 1])]) "" RegularPosting [] Nothing
] ""))
,"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)
]]