1 {-| 2 3 A 'Transaction' consists of two or more related 'Posting's which balance 4 to zero, representing a movement of some commodity(ies) between accounts, 5 plus a date and optional metadata like description and cleared status. 6 7 -} 8 9 module Hledger.Data.Transaction 10 where 11 import Data.List 12 import Data.Maybe 13 import Test.HUnit 14 import Text.Printf 15 import qualified Data.Map as Map 16 17 import Hledger.Utils 18 import Hledger.Data.Types 19 import Hledger.Data.Dates 20 import Hledger.Data.Posting 21 import Hledger.Data.Amount 22 import Hledger.Data.Commodity 23 24 instance Show Transaction where show = showTransactionUnelided 25 26 instance Show ModifierTransaction where 27 show t = "= " ++ mtvalueexpr t ++ "\n" ++ unlines (map show (mtpostings t)) 28 29 instance Show PeriodicTransaction where 30 show t = "~ " ++ ptperiodicexpr t ++ "\n" ++ unlines (map show (ptpostings t)) 31 32 nulltransaction :: Transaction 33 nulltransaction = Transaction { 34 tdate=nulldate, 35 teffectivedate=Nothing, 36 tstatus=False, 37 tcode="", 38 tdescription="", 39 tcomment="", 40 tmetadata=[], 41 tpostings=[], 42 tpreceding_comment_lines="" 43 } 44 45 {-| 46 Show a journal transaction, formatted for the print command. ledger 2.x's 47 standard format looks like this: 48 49 @ 50 yyyy/mm/dd[ *][ CODE] description......... [ ; comment...............] 51 account name 1..................... ...$amount1[ ; comment...............] 52 account name 2..................... ..$-amount1[ ; comment...............] 53 54 pcodewidth = no limit -- 10 -- mimicking ledger layout. 55 pdescwidth = no limit -- 20 -- I don't remember what these mean, 56 pacctwidth = 35 minimum, no maximum -- they were important at the time. 57 pamtwidth = 11 58 pcommentwidth = no limit -- 22 59 @ 60 -} 61 showTransaction :: Transaction -> String 62 showTransaction = showTransaction' True False 63 64 showTransactionUnelided :: Transaction -> String 65 showTransactionUnelided = showTransaction' False False 66 67 showTransactionForPrint :: Bool -> Transaction -> String 68 showTransactionForPrint effective = showTransaction' False effective 69 70 showTransaction' :: Bool -> Bool -> Transaction -> String 71 showTransaction' elide effective t = 72 unlines $ [description] ++ showpostings (tpostings t) ++ [""] 73 where 74 description = concat [date, status, code, desc, comment] 75 date | effective = showdate $ fromMaybe (tdate t) $ teffectivedate t 76 | otherwise = showdate (tdate t) ++ maybe "" showedate (teffectivedate t) 77 status = if tstatus t then " *" else "" 78 code = if length (tcode t) > 0 then printf " (%s)" $ tcode t else "" 79 desc = if null d then "" else " " ++ d where d = tdescription t 80 comment = if null c then "" else " ; " ++ c where c = tcomment t 81 showdate = printf "%-10s" . showDate 82 showedate = printf "=%s" . showdate 83 showpostings ps 84 | elide && length ps > 1 && isTransactionBalanced Nothing t -- imprecise balanced check 85 = map showposting (init ps) ++ [showpostingnoamt (last ps)] 86 | otherwise = map showposting ps 87 where 88 showpostingnoamt p = rstrip $ showacct p ++ " " ++ showcomment (pcomment p) 89 showposting p = concatTopPadded [showacct p 90 ," " 91 ,showamt (pamount p) 92 ,showcomment (pcomment p) 93 ] 94 showacct p = " " ++ showstatus p ++ printf (printf "%%-%ds" w) (showAccountName Nothing (ptype p) (paccount p)) 95 where w = maximum $ map (length . paccount) ps 96 showstatus p = if pstatus p then "* " else "" 97 showamt = 98 padleft 12 . showMixedAmount 99 showcomment s = if null s then "" else " ; "++s 100 101 -- | Show an account name, clipped to the given width if any, and 102 -- appropriately bracketed/parenthesised for the given posting type. 103 showAccountName :: Maybe Int -> PostingType -> AccountName -> String 104 showAccountName w = fmt 105 where 106 fmt RegularPosting = take w' 107 fmt VirtualPosting = parenthesise . reverse . take (w'-2) . reverse 108 fmt BalancedVirtualPosting = bracket . reverse . take (w'-2) . reverse 109 w' = fromMaybe 999999 w 110 parenthesise s = "("++s++")" 111 bracket s = "["++s++"]" 112 113 hasRealPostings :: Transaction -> Bool 114 hasRealPostings = not . null . realPostings 115 116 realPostings :: Transaction -> [Posting] 117 realPostings = filter isReal . tpostings 118 119 virtualPostings :: Transaction -> [Posting] 120 virtualPostings = filter isVirtual . tpostings 121 122 balancedVirtualPostings :: Transaction -> [Posting] 123 balancedVirtualPostings = filter isBalancedVirtual . tpostings 124 125 transactionsPostings :: [Transaction] -> [Posting] 126 transactionsPostings = concat . map tpostings 127 128 -- | Get the sums of a transaction's real, virtual, and balanced virtual postings. 129 transactionPostingBalances :: Transaction -> (MixedAmount,MixedAmount,MixedAmount) 130 transactionPostingBalances t = (sumPostings $ realPostings t 131 ,sumPostings $ virtualPostings t 132 ,sumPostings $ balancedVirtualPostings t) 133 134 -- | Is this transaction balanced ? A balanced transaction's real 135 -- (non-virtual) postings sum to 0, and any balanced virtual postings 136 -- also sum to 0. 137 isTransactionBalanced :: Maybe (Map.Map String Commodity) -> Transaction -> Bool 138 isTransactionBalanced canonicalcommoditymap t = 139 -- isReallyZeroMixedAmountCost rsum && isReallyZeroMixedAmountCost bvsum 140 isZeroMixedAmount rsum' && isZeroMixedAmount bvsum' 141 where 142 (rsum, _, bvsum) = transactionPostingBalances t 143 rsum' = canonicaliseMixedAmountCommodity canonicalcommoditymap $ costOfMixedAmount rsum 144 bvsum' = canonicaliseMixedAmountCommodity canonicalcommoditymap $ costOfMixedAmount bvsum 145 146 -- | Ensure this transaction is balanced, possibly inferring a missing 147 -- amount or a conversion price first, or return an error message. 148 -- 149 -- Balancing is affected by the provided commodities' display precisions. 150 -- 151 -- We can infer an amount when there are multiple real postings and 152 -- exactly one of them is amountless; likewise for balanced virtual 153 -- postings. Inferred amounts are converted to cost basis when possible. 154 -- 155 -- We can infer a price when all amounts were specified and the sum of 156 -- real postings' amounts is exactly two non-explicitly-priced amounts in 157 -- different commodities; likewise for balanced virtual postings. 158 balanceTransaction :: Maybe (Map.Map String Commodity) -> Transaction -> Either String Transaction 159 balanceTransaction canonicalcommoditymap t@Transaction{tpostings=ps} 160 | length rwithoutamounts > 1 || length bvwithoutamounts > 1 161 = Left $ printerr "could not balance this transaction (too many missing amounts)" 162 | not $ isTransactionBalanced canonicalcommoditymap t''' = Left $ printerr $ nonzerobalanceerror t''' 163 | otherwise = Right t''' 164 where 165 -- maybe infer missing amounts 166 (rwithamounts, rwithoutamounts) = partition hasAmount $ realPostings t 167 (bvwithamounts, bvwithoutamounts) = partition hasAmount $ balancedVirtualPostings t 168 ramounts = map pamount rwithamounts 169 bvamounts = map pamount bvwithamounts 170 t' = t{tpostings=map inferamount ps} 171 where 172 inferamount p | not (hasAmount p) && isReal p = p{pamount = (- sum ramounts)} 173 | not (hasAmount p) && isBalancedVirtual p = p{pamount = (- sum bvamounts)} 174 | otherwise = p 175 176 -- maybe infer conversion prices, for real postings 177 rmixedamountsinorder = map pamount $ realPostings t' 178 ramountsinorder = concatMap amounts rmixedamountsinorder 179 rcommoditiesinorder = map commodity ramountsinorder 180 rsumamounts = amounts $ sum rmixedamountsinorder 181 -- assumption: the sum of mixed amounts is normalised (one simple amount per commodity) 182 t'' = if length rsumamounts == 2 && all (isNothing.price) rsumamounts && t'==t 183 then t'{tpostings=map inferprice ps} 184 else t' 185 where 186 -- assumption: a posting's mixed amount contains one simple amount 187 inferprice p@Posting{pamount=Mixed [a@Amount{commodity=c,price=Nothing}], ptype=RegularPosting} 188 = p{pamount=Mixed [a{price=conversionprice c}]} 189 where 190 conversionprice c | c == unpricedcommodity 191 -- assign a balancing price. Use @@ for more exact output when possible. 192 -- invariant: prices should always be positive. Enforced with "abs" 193 = if length ramountsinunpricedcommodity == 1 194 then Just $ TotalPrice $ Mixed [setAmountPrecision maxprecision $ abs $ targetcommodityamount] 195 else Just $ UnitPrice $ Mixed [setAmountPrecision maxprecision $ abs $ targetcommodityamount `divideAmount` (quantity unpricedamount)] 196 | otherwise = Nothing 197 where 198 unpricedcommodity = head $ filter (`elem` (map commodity rsumamounts)) rcommoditiesinorder 199 unpricedamount = head $ filter ((==unpricedcommodity).commodity) rsumamounts 200 targetcommodityamount = head $ filter ((/=unpricedcommodity).commodity) rsumamounts 201 ramountsinunpricedcommodity = filter ((==unpricedcommodity).commodity) ramountsinorder 202 inferprice p = p 203 204 -- maybe infer prices for balanced virtual postings. Just duplicates the above for now. 205 bvmixedamountsinorder = map pamount $ balancedVirtualPostings t'' 206 bvamountsinorder = concatMap amounts bvmixedamountsinorder 207 bvcommoditiesinorder = map commodity bvamountsinorder 208 bvsumamounts = amounts $ sum bvmixedamountsinorder 209 t''' = if length bvsumamounts == 2 && all (isNothing.price) bvsumamounts && t'==t -- XXX could check specifically for bv amount inferring 210 then t''{tpostings=map inferprice ps} 211 else t'' 212 where 213 inferprice p@Posting{pamount=Mixed [a@Amount{commodity=c,price=Nothing}], ptype=BalancedVirtualPosting} 214 = p{pamount=Mixed [a{price=conversionprice c}]} 215 where 216 conversionprice c | c == unpricedcommodity 217 = if length bvamountsinunpricedcommodity == 1 218 then Just $ TotalPrice $ Mixed [setAmountPrecision maxprecision $ abs $ targetcommodityamount] 219 else Just $ UnitPrice $ Mixed [setAmountPrecision maxprecision $ abs $ targetcommodityamount `divideAmount` (quantity unpricedamount)] 220 | otherwise = Nothing 221 where 222 unpricedcommodity = head $ filter (`elem` (map commodity bvsumamounts)) bvcommoditiesinorder 223 unpricedamount = head $ filter ((==unpricedcommodity).commodity) bvsumamounts 224 targetcommodityamount = head $ filter ((/=unpricedcommodity).commodity) bvsumamounts 225 bvamountsinunpricedcommodity = filter ((==unpricedcommodity).commodity) bvamountsinorder 226 inferprice p = p 227 228 printerr s = intercalate "\n" [s, showTransactionUnelided t] 229 230 nonzerobalanceerror :: Transaction -> String 231 nonzerobalanceerror t = printf "could not balance this transaction (%s%s%s)" rmsg sep bvmsg 232 where 233 (rsum, _, bvsum) = transactionPostingBalances t 234 rmsg | isReallyZeroMixedAmountCost rsum = "" 235 | otherwise = "real postings are off by " ++ show (costOfMixedAmount rsum) 236 bvmsg | isReallyZeroMixedAmountCost bvsum = "" 237 | otherwise = "balanced virtual postings are off by " ++ show (costOfMixedAmount bvsum) 238 sep = if not (null rmsg) && not (null bvmsg) then "; " else "" 239 240 -- | Convert the primary date to either the actual or effective date. 241 journalTransactionWithDate :: WhichDate -> Transaction -> Transaction 242 journalTransactionWithDate ActualDate t = t 243 journalTransactionWithDate EffectiveDate t = txnTieKnot t{tdate=fromMaybe (tdate t) (teffectivedate t)} 244 245 -- | Ensure a transaction's postings refer back to it. 246 txnTieKnot :: Transaction -> Transaction 247 txnTieKnot t@Transaction{tpostings=ps} = t{tpostings=map (settxn t) ps} 248 249 -- | Set a posting's parent transaction. 250 settxn :: Transaction -> Posting -> Posting 251 settxn t p = p{ptransaction=Just t} 252 253 tests_Hledger_Data_Transaction = TestList [ 254 "showTransaction" ~: do 255 assertEqual "show a balanced transaction, eliding last amount" 256 (unlines 257 ["2007/01/28 coopportunity" 258 ," expenses:food:groceries $47.18" 259 ," assets:checking" 260 ,"" 261 ]) 262 (let t = Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" [] 263 [Posting False "expenses:food:groceries" (Mixed [dollars 47.18]) "" RegularPosting [] (Just t) 264 ,Posting False "assets:checking" (Mixed [dollars (-47.18)]) "" RegularPosting [] (Just t) 265 ] "" 266 in showTransaction t) 267 268 ,"showTransaction" ~: do 269 assertEqual "show a balanced transaction, no eliding" 270 (unlines 271 ["2007/01/28 coopportunity" 272 ," expenses:food:groceries $47.18" 273 ," assets:checking $-47.18" 274 ,"" 275 ]) 276 (let t = Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" [] 277 [Posting False "expenses:food:groceries" (Mixed [dollars 47.18]) "" RegularPosting [] (Just t) 278 ,Posting False "assets:checking" (Mixed [dollars (-47.18)]) "" RegularPosting [] (Just t) 279 ] "" 280 in showTransactionUnelided t) 281 282 -- document some cases that arise in debug/testing: 283 ,"showTransaction" ~: do 284 assertEqual "show an unbalanced transaction, should not elide" 285 (unlines 286 ["2007/01/28 coopportunity" 287 ," expenses:food:groceries $47.18" 288 ," assets:checking $-47.19" 289 ,"" 290 ]) 291 (showTransaction 292 (txnTieKnot $ Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" [] 293 [Posting False "expenses:food:groceries" (Mixed [dollars 47.18]) "" RegularPosting [] Nothing 294 ,Posting False "assets:checking" (Mixed [dollars (-47.19)]) "" RegularPosting [] Nothing 295 ] "")) 296 297 ,"showTransaction" ~: do 298 assertEqual "show an unbalanced transaction with one posting, should not elide" 299 (unlines 300 ["2007/01/28 coopportunity" 301 ," expenses:food:groceries $47.18" 302 ,"" 303 ]) 304 (showTransaction 305 (txnTieKnot $ Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" [] 306 [Posting False "expenses:food:groceries" (Mixed [dollars 47.18]) "" RegularPosting [] Nothing 307 ] "")) 308 309 ,"showTransaction" ~: do 310 assertEqual "show a transaction with one posting and a missing amount" 311 (unlines 312 ["2007/01/28 coopportunity" 313 ," expenses:food:groceries " 314 ,"" 315 ]) 316 (showTransaction 317 (txnTieKnot $ Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" [] 318 [Posting False "expenses:food:groceries" missingamt "" RegularPosting [] Nothing 319 ] "")) 320 321 ,"showTransaction" ~: do 322 assertEqual "show a transaction with a priced commodityless amount" 323 (unlines 324 ["2010/01/01 x" 325 ," a 1 @ $2" 326 ," b " 327 ,"" 328 ]) 329 (showTransaction 330 (txnTieKnot $ Transaction (parsedate "2010/01/01") Nothing False "" "x" "" [] 331 [Posting False "a" (Mixed [Amount unknown 1 (Just $ UnitPrice $ Mixed [Amount dollar{precision=0} 2 Nothing])]) "" RegularPosting [] Nothing 332 ,Posting False "b" missingamt "" RegularPosting [] Nothing 333 ] "")) 334 335 ,"balanceTransaction" ~: do 336 assertBool "detect unbalanced entry, sign error" 337 (isLeft $ balanceTransaction Nothing 338 (Transaction (parsedate "2007/01/28") Nothing False "" "test" "" [] 339 [Posting False "a" (Mixed [dollars 1]) "" RegularPosting [] Nothing, 340 Posting False "b" (Mixed [dollars 1]) "" RegularPosting [] Nothing 341 ] "")) 342 assertBool "detect unbalanced entry, multiple missing amounts" 343 (isLeft $ balanceTransaction Nothing 344 (Transaction (parsedate "2007/01/28") Nothing False "" "test" "" [] 345 [Posting False "a" missingamt "" RegularPosting [] Nothing, 346 Posting False "b" missingamt "" RegularPosting [] Nothing 347 ] "")) 348 let e = balanceTransaction Nothing (Transaction (parsedate "2007/01/28") Nothing False "" "" "" [] 349 [Posting False "a" (Mixed [dollars 1]) "" RegularPosting [] Nothing, 350 Posting False "b" missingamt "" RegularPosting [] Nothing 351 ] "") 352 assertBool "balanceTransaction allows one missing amount" (isRight e) 353 assertEqual "balancing amount is inferred" 354 (Mixed [dollars (-1)]) 355 (case e of 356 Right e' -> (pamount $ last $ tpostings e') 357 Left _ -> error' "should not happen") 358 let e = balanceTransaction Nothing (Transaction (parsedate "2011/01/01") Nothing False "" "" "" [] 359 [Posting False "a" (Mixed [dollars 1.35]) "" RegularPosting [] Nothing, 360 Posting False "b" (Mixed [euros (-1)]) "" RegularPosting [] Nothing 361 ] "") 362 assertBool "balanceTransaction can infer conversion price" (isRight e) 363 assertEqual "balancing conversion price is inferred" 364 (Mixed [Amount{commodity=dollar{precision=2}, 365 quantity=1.35, 366 price=(Just $ TotalPrice $ Mixed [Amount{commodity=euro{precision=maxprecision}, 367 quantity=1, 368 price=Nothing}])}]) 369 (case e of 370 Right e' -> (pamount $ head $ tpostings e') 371 Left _ -> error' "should not happen") 372 373 ,"isTransactionBalanced" ~: do 374 let t = Transaction (parsedate "2009/01/01") Nothing False "" "a" "" [] 375 [Posting False "b" (Mixed [dollars 1.00]) "" RegularPosting [] (Just t) 376 ,Posting False "c" (Mixed [dollars (-1.00)]) "" RegularPosting [] (Just t) 377 ] "" 378 assertBool "detect balanced" (isTransactionBalanced Nothing t) 379 let t = Transaction (parsedate "2009/01/01") Nothing False "" "a" "" [] 380 [Posting False "b" (Mixed [dollars 1.00]) "" RegularPosting [] (Just t) 381 ,Posting False "c" (Mixed [dollars (-1.01)]) "" RegularPosting [] (Just t) 382 ] "" 383 assertBool "detect unbalanced" (not $ isTransactionBalanced Nothing t) 384 let t = Transaction (parsedate "2009/01/01") Nothing False "" "a" "" [] 385 [Posting False "b" (Mixed [dollars 1.00]) "" RegularPosting [] (Just t) 386 ] "" 387 assertBool "detect unbalanced, one posting" (not $ isTransactionBalanced Nothing t) 388 let t = Transaction (parsedate "2009/01/01") Nothing False "" "a" "" [] 389 [Posting False "b" (Mixed [dollars 0]) "" RegularPosting [] (Just t) 390 ] "" 391 assertBool "one zero posting is considered balanced for now" (isTransactionBalanced Nothing t) 392 let t = Transaction (parsedate "2009/01/01") Nothing False "" "a" "" [] 393 [Posting False "b" (Mixed [dollars 1.00]) "" RegularPosting [] (Just t) 394 ,Posting False "c" (Mixed [dollars (-1.00)]) "" RegularPosting [] (Just t) 395 ,Posting False "d" (Mixed [dollars 100]) "" VirtualPosting [] (Just t) 396 ] "" 397 assertBool "virtual postings don't need to balance" (isTransactionBalanced Nothing t) 398 let t = Transaction (parsedate "2009/01/01") Nothing False "" "a" "" [] 399 [Posting False "b" (Mixed [dollars 1.00]) "" RegularPosting [] (Just t) 400 ,Posting False "c" (Mixed [dollars (-1.00)]) "" RegularPosting [] (Just t) 401 ,Posting False "d" (Mixed [dollars 100]) "" BalancedVirtualPosting [] (Just t) 402 ] "" 403 assertBool "balanced virtual postings need to balance among themselves" (not $ isTransactionBalanced Nothing t) 404 let t = Transaction (parsedate "2009/01/01") Nothing False "" "a" "" [] 405 [Posting False "b" (Mixed [dollars 1.00]) "" RegularPosting [] (Just t) 406 ,Posting False "c" (Mixed [dollars (-1.00)]) "" RegularPosting [] (Just t) 407 ,Posting False "d" (Mixed [dollars 100]) "" BalancedVirtualPosting [] (Just t) 408 ,Posting False "e" (Mixed [dollars (-100)]) "" BalancedVirtualPosting [] (Just t) 409 ] "" 410 assertBool "balanced virtual postings need to balance among themselves (2)" (isTransactionBalanced Nothing t) 411 412 ]