module Hledger.Data.Transaction (
nullsourcepos,
nulltransaction,
txnTieKnot,
showAccountName,
hasRealPostings,
realPostings,
virtualPostings,
balancedVirtualPostings,
transactionsPostings,
isTransactionBalanced,
transactionDate2,
transactionPostingBalances,
balanceTransaction,
showTransaction,
showTransactionUnelided,
showTransactionUnelidedOneLineAmounts,
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
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))
nullsourcepos :: GenericSourcePos
nullsourcepos = GenericSourcePos "" 1 1
nulltransaction :: Transaction
nulltransaction = Transaction {
tindex=0,
tsourcepos=nullsourcepos,
tdate=nulldate,
tdate2=Nothing,
tstatus=Uncleared,
tcode="",
tdescription="",
tcomment="",
ttags=[],
tpostings=[],
tpreceding_comment_lines=""
}
showTransaction :: Transaction -> String
showTransaction = showTransactionHelper True False
showTransactionUnelided :: Transaction -> String
showTransactionUnelided = showTransactionHelper False 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",
tdate2=Just $ parsedate "2012/05/15",
tstatus=Uncleared,
tcode="code",
tdescription="desc",
tcomment="tcomment1\ntcomment2\n",
ttags=[("ttag1","val1")],
tpostings=[
nullposting{
pstatus=Cleared,
paccount="a",
pamount=Mixed [usd 1, hrs 2],
pcomment="\npcomment2\n",
ptype=RegularPosting,
ptags=[("ptag1","val1"),("ptag2","val2")]
}
]
}
`gives` unlines [
"2012/05/14=2012/05/15 (code) desc ; tcomment1",
" ; tcomment2",
" $1.00",
" * a 2.00h",
" ; pcomment2",
""
]
]
showTransactionUnelidedOneLineAmounts :: Transaction -> String
showTransactionUnelidedOneLineAmounts = showTransactionHelper False True
showTransactionHelper :: Bool -> Bool -> Transaction -> String
showTransactionHelper elide onelineamounts t =
unlines $ [descriptionline]
++ newlinecomments
++ (postingsAsLines elide onelineamounts t (tpostings t))
++ [""]
where
descriptionline = rstrip $ concat [date, status, code, desc, samelinecomment]
date = showDate (tdate t) ++ maybe "" (("="++) . showDate) (tdate2 t)
status | tstatus t == Cleared = " *"
| tstatus t == Pending = " !"
| otherwise = ""
code = if length (tcode t) > 0 then printf " (%s)" $ tcode t else ""
desc = if null d then "" else " " ++ d where d = tdescription t
(samelinecomment, newlinecomments) =
case renderCommentLines (tcomment t) of [] -> ("",[])
c:cs -> (c,cs)
renderCommentLines :: String -> [String]
renderCommentLines s = case lines s of ("":ls) -> "":map commentprefix ls
ls -> map commentprefix ls
where
commentprefix = indent . ("; "++)
postingsAsLines :: Bool -> Bool -> Transaction -> [Posting] -> [String]
postingsAsLines elide onelineamounts t ps
| elide && length ps > 1 && isTransactionBalanced Nothing t
= (concatMap (postingAsLines False onelineamounts ps) $ init ps) ++ postingAsLines True onelineamounts ps (last ps)
| otherwise = concatMap (postingAsLines False onelineamounts ps) ps
postingAsLines :: Bool -> Bool -> [Posting] -> Posting -> [String]
postingAsLines elideamount onelineamounts ps p =
postinglines
++ newlinecomments
where
postinglines = map rstrip $ lines $ concatTopPadded [account, " ", amount, samelinecomment]
account =
indent $
showstatus p ++ fitString (Just acctwidth) Nothing False True (showAccountName Nothing (ptype p) (paccount p))
where
showstatus p = if pstatus p == Cleared then "* " else ""
acctwidth = maximum $ map (strWidth . paccount) ps
amount
| elideamount = ""
| onelineamounts = fitString (Just amtwidth) Nothing False False $ showMixedAmountOneLine $ pamount p
| otherwise = fitStringMulti (Just amtwidth) Nothing False False $ showMixedAmount $ pamount p
where
amtwidth = maximum $ 12 : map (strWidth . showMixedAmount . pamount) ps
(samelinecomment, newlinecomments) =
case renderCommentLines (pcomment p) of [] -> ("",[])
c:cs -> (c,cs)
tests_postingAsLines = [
"postingAsLines" ~: do
let p `gives` ls = assertEqual "" ls (postingAsLines False False [p] p)
posting `gives` [" 0"]
posting{
pstatus=Cleared,
paccount="a",
pamount=Mixed [usd 1, hrs 2],
pcomment="pcomment1\npcomment2\n tag3: val3 \n",
ptype=RegularPosting,
ptags=[("ptag1","val1"),("ptag2","val2")]
}
`gives` [
" $1.00",
" * a 2.00h ; pcomment1",
" ; pcomment2",
" ; tag3: val3 "
]
]
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 Commodity AmountStyle) -> Transaction -> Bool
isTransactionBalanced styles t =
isZeroMixedAmount rsum' && isZeroMixedAmount bvsum'
where
(rsum, _, bvsum) = transactionPostingBalances t
rsum' = canonicalise $ costOfMixedAmount rsum
bvsum' = canonicalise $ costOfMixedAmount bvsum
canonicalise = maybe id canonicaliseMixedAmount styles
balanceTransaction :: Maybe (Map.Map Commodity AmountStyle) -> Transaction -> Either String Transaction
balanceTransaction styles t =
case inferBalancingAmount t of
Left err -> Left err
Right t' -> let t'' = inferBalancingPrices t'
in if isTransactionBalanced styles t''
then Right $ txnTieKnot t''
else Left $ printerr $ nonzerobalanceerror t''
where
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
inferBalancingAmount :: Transaction -> Either String Transaction
inferBalancingAmount t@Transaction{tpostings=ps}
| length amountlessrealps > 1
= Left $ printerr "could not balance this transaction - can't have more than one real posting with no amount (remember to put 2 or more spaces before amounts)"
| length amountlessbvps > 1
= Left $ printerr "could not balance this transaction - can't have more than one balanced virtual posting with no amount (remember to put 2 or more spaces before amounts)"
| otherwise
= Right t{tpostings=map inferamount ps}
where
printerr s = intercalate "\n" [s, showTransactionUnelided t]
((amountfulrealps, amountlessrealps), realsum) = (partition hasAmount (realPostings t), sum $ map pamount amountfulrealps)
((amountfulbvps, amountlessbvps), bvsum) = (partition hasAmount (balancedVirtualPostings t), sum $ map pamount amountfulbvps)
inferamount p@Posting{ptype=RegularPosting} | not (hasAmount p) = p{pamount=costOfMixedAmount (realsum)}
inferamount p@Posting{ptype=BalancedVirtualPosting} | not (hasAmount p) = p{pamount=costOfMixedAmount (bvsum)}
inferamount p = p
inferBalancingPrices :: Transaction -> Transaction
inferBalancingPrices t@Transaction{tpostings=ps} = t{tpostings=ps'}
where
ps' = map (priceInferrerFor t BalancedVirtualPosting) $
map (priceInferrerFor t RegularPosting) $
ps
priceInferrerFor :: Transaction -> PostingType -> (Posting -> Posting)
priceInferrerFor t pt = inferprice
where
postings = filter ((==pt).ptype) $ tpostings t
pmixedamounts = map pamount postings
pamounts = concatMap amounts pmixedamounts
pcommodities = map acommodity pamounts
sumamounts = amounts $ sum pmixedamounts
sumcommodities = map acommodity sumamounts
sumprices = filter (/=NoPrice) $ map aprice sumamounts
caninferprices = length sumcommodities == 2 && null sumprices
inferprice p@Posting{pamount=Mixed [a]}
| caninferprices && ptype p == pt && acommodity a == fromcommodity
= p{pamount=Mixed [a{aprice=conversionprice}]}
where
fromcommodity = head $ filter (`elem` sumcommodities) pcommodities
conversionprice
| fromcount==1 = TotalPrice $ abs toamount `withPrecision` maxprecision
| otherwise = UnitPrice $ abs unitprice `withPrecision` unitprecision
where
fromcount = length $ filter ((==fromcommodity).acommodity) pamounts
fromamount = head $ filter ((==fromcommodity).acommodity) sumamounts
tocommodity = head $ filter (/=fromcommodity) sumcommodities
toamount = head $ filter ((==tocommodity).acommodity) sumamounts
unitprice = toamount `divideAmount` (aquantity fromamount)
unitprecision = max 2 ((asprecision $ astyle $ toamount) + (asprecision $ astyle $ fromamount))
inferprice p = p
transactionDate2 :: Transaction -> Day
transactionDate2 t = fromMaybe (tdate t) $ tdate2 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 0 nullsourcepos (parsedate "2007/01/28") Nothing Uncleared "" "coopportunity" "" []
[posting{paccount="expenses:food:groceries", pamount=Mixed [usd 47.18], ptransaction=Just t}
,posting{paccount="assets:checking", pamount=Mixed [usd (47.18)], ptransaction=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 0 nullsourcepos (parsedate "2007/01/28") Nothing Uncleared "" "coopportunity" "" []
[posting{paccount="expenses:food:groceries", pamount=Mixed [usd 47.18], ptransaction=Just t}
,posting{paccount="assets:checking", pamount=Mixed [usd (47.18)], ptransaction=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 0 nullsourcepos (parsedate "2007/01/28") Nothing Uncleared "" "coopportunity" "" []
[posting{paccount="expenses:food:groceries", pamount=Mixed [usd 47.18]}
,posting{paccount="assets:checking", pamount=Mixed [usd (47.19)]}
] ""))
,"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 0 nullsourcepos (parsedate "2007/01/28") Nothing Uncleared "" "coopportunity" "" []
[posting{paccount="expenses:food:groceries", pamount=Mixed [usd 47.18]}
] ""))
,"showTransaction" ~: do
assertEqual "show a transaction with one posting and a missing amount"
(unlines
["2007/01/28 coopportunity"
," expenses:food:groceries"
,""
])
(showTransaction
(txnTieKnot $ Transaction 0 nullsourcepos (parsedate "2007/01/28") Nothing Uncleared "" "coopportunity" "" []
[posting{paccount="expenses:food:groceries", pamount=missingmixedamt}
] ""))
,"showTransaction" ~: do
assertEqual "show a transaction with a priced commodityless amount"
(unlines
["2010/01/01 x"
," a 1 @ $2"
," b"
,""
])
(showTransaction
(txnTieKnot $ Transaction 0 nullsourcepos (parsedate "2010/01/01") Nothing Uncleared "" "x" "" []
[posting{paccount="a", pamount=Mixed [num 1 `at` (usd 2 `withPrecision` 0)]}
,posting{paccount="b", pamount= missingmixedamt}
] ""))
,"balanceTransaction" ~: do
assertBool "detect unbalanced entry, sign error"
(isLeft $ balanceTransaction Nothing
(Transaction 0 nullsourcepos (parsedate "2007/01/28") Nothing Uncleared "" "test" "" []
[posting{paccount="a", pamount=Mixed [usd 1]}
,posting{paccount="b", pamount=Mixed [usd 1]}
] ""))
assertBool "detect unbalanced entry, multiple missing amounts"
(isLeft $ balanceTransaction Nothing
(Transaction 0 nullsourcepos (parsedate "2007/01/28") Nothing Uncleared "" "test" "" []
[posting{paccount="a", pamount=missingmixedamt}
,posting{paccount="b", pamount=missingmixedamt}
] ""))
let e = balanceTransaction Nothing (Transaction 0 nullsourcepos (parsedate "2007/01/28") Nothing Uncleared "" "" "" []
[posting{paccount="a", pamount=Mixed [usd 1]}
,posting{paccount="b", pamount=missingmixedamt}
] "")
assertBool "balanceTransaction allows one missing amount" (isRight e)
assertEqual "balancing amount is inferred"
(Mixed [usd (1)])
(case e of
Right e' -> (pamount $ last $ tpostings e')
Left _ -> error' "should not happen")
let e = balanceTransaction Nothing (Transaction 0 nullsourcepos (parsedate "2011/01/01") Nothing Uncleared "" "" "" []
[posting{paccount="a", pamount=Mixed [usd 1.35]}
,posting{paccount="b", pamount=Mixed [eur (1)]}
] "")
assertBool "balanceTransaction can infer conversion price" (isRight e)
assertEqual "balancing conversion price is inferred"
(Mixed [usd 1.35 @@ (eur 1 `withPrecision` maxprecision)])
(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 0 nullsourcepos (parsedate "2011/01/01") Nothing Uncleared "" "" "" []
[posting{paccount="a", pamount=Mixed [usd 1 `at` eur 2]}
,posting{paccount="a", pamount=Mixed [usd (2) `at` eur 1]}
] ""))
assertBool "balanceTransaction balances based on cost if there are total prices" (isRight $
balanceTransaction Nothing (Transaction 0 nullsourcepos (parsedate "2011/01/01") Nothing Uncleared "" "" "" []
[posting{paccount="a", pamount=Mixed [usd 1 @@ eur 1]}
,posting{paccount="a", pamount=Mixed [usd (2) @@ eur 1]}
] ""))
,"isTransactionBalanced" ~: do
let t = Transaction 0 nullsourcepos (parsedate "2009/01/01") Nothing Uncleared "" "a" "" []
[posting{paccount="b", pamount=Mixed [usd 1.00], ptransaction=Just t}
,posting{paccount="c", pamount=Mixed [usd (1.00)], ptransaction=Just t}
] ""
assertBool "detect balanced" (isTransactionBalanced Nothing t)
let t = Transaction 0 nullsourcepos (parsedate "2009/01/01") Nothing Uncleared "" "a" "" []
[posting{paccount="b", pamount=Mixed [usd 1.00], ptransaction=Just t}
,posting{paccount="c", pamount=Mixed [usd (1.01)], ptransaction=Just t}
] ""
assertBool "detect unbalanced" (not $ isTransactionBalanced Nothing t)
let t = Transaction 0 nullsourcepos (parsedate "2009/01/01") Nothing Uncleared "" "a" "" []
[posting{paccount="b", pamount=Mixed [usd 1.00], ptransaction=Just t}
] ""
assertBool "detect unbalanced, one posting" (not $ isTransactionBalanced Nothing t)
let t = Transaction 0 nullsourcepos (parsedate "2009/01/01") Nothing Uncleared "" "a" "" []
[posting{paccount="b", pamount=Mixed [usd 0], ptransaction=Just t}
] ""
assertBool "one zero posting is considered balanced for now" (isTransactionBalanced Nothing t)
let t = Transaction 0 nullsourcepos (parsedate "2009/01/01") Nothing Uncleared "" "a" "" []
[posting{paccount="b", pamount=Mixed [usd 1.00], ptransaction=Just t}
,posting{paccount="c", pamount=Mixed [usd (1.00)], ptransaction=Just t}
,posting{paccount="d", pamount=Mixed [usd 100], ptype=VirtualPosting, ptransaction=Just t}
] ""
assertBool "virtual postings don't need to balance" (isTransactionBalanced Nothing t)
let t = Transaction 0 nullsourcepos (parsedate "2009/01/01") Nothing Uncleared "" "a" "" []
[posting{paccount="b", pamount=Mixed [usd 1.00], ptransaction=Just t}
,posting{paccount="c", pamount=Mixed [usd (1.00)], ptransaction=Just t}
,posting{paccount="d", pamount=Mixed [usd 100], ptype=BalancedVirtualPosting, ptransaction=Just t}
] ""
assertBool "balanced virtual postings need to balance among themselves" (not $ isTransactionBalanced Nothing t)
let t = Transaction 0 nullsourcepos (parsedate "2009/01/01") Nothing Uncleared "" "a" "" []
[posting{paccount="b", pamount=Mixed [usd 1.00], ptransaction=Just t}
,posting{paccount="c", pamount=Mixed [usd (1.00)], ptransaction=Just t}
,posting{paccount="d", pamount=Mixed [usd 100], ptype=BalancedVirtualPosting, ptransaction=Just t}
,posting{paccount="3", pamount=Mixed [usd (100)], ptype=BalancedVirtualPosting, ptransaction=Just t}
] ""
assertBool "balanced virtual postings need to balance among themselves (2)" (isTransactionBalanced Nothing t)
]]