1 {-|
    2 
    3 A 'LedgerTransaction' represents a regular transaction in the ledger
    4 file. It normally contains two or more balanced 'Posting's.
    5 
    6 -}
    7 
    8 module Ledger.LedgerTransaction
    9 where
   10 import Ledger.Utils
   11 import Ledger.Types
   12 import Ledger.Dates
   13 import Ledger.Posting
   14 import Ledger.Amount
   15 
   16 
   17 instance Show LedgerTransaction where show = showLedgerTransaction
   18 
   19 instance Show ModifierTransaction where 
   20     show t = "= " ++ (mtvalueexpr t) ++ "\n" ++ unlines (map show (mtpostings t))
   21 
   22 instance Show PeriodicTransaction where 
   23     show t = "~ " ++ (ptperiodicexpr t) ++ "\n" ++ unlines (map show (ptpostings t))
   24 
   25 nullledgertxn :: LedgerTransaction
   26 nullledgertxn = LedgerTransaction {
   27               ltdate=parsedate "1900/1/1", 
   28               ltstatus=False, 
   29               ltcode="", 
   30               ltdescription="", 
   31               ltcomment="",
   32               ltpostings=[],
   33               ltpreceding_comment_lines=""
   34             }
   35 
   36 {-|
   37 Show a ledger entry, formatted for the print command. ledger 2.x's
   38 standard format looks like this:
   39 
   40 @
   41 yyyy/mm/dd[ *][ CODE] description.........          [  ; comment...............]
   42     account name 1.....................  ...$amount1[  ; comment...............]
   43     account name 2.....................  ..$-amount1[  ; comment...............]
   44 
   45 pcodewidth    = no limit -- 10          -- mimicking ledger layout.
   46 pdescwidth    = no limit -- 20          -- I don't remember what these mean,
   47 pacctwidth    = 35 minimum, no maximum  -- they were important at the time.
   48 pamtwidth     = 11
   49 pcommentwidth = no limit -- 22
   50 @
   51 -}
   52 showLedgerTransaction :: LedgerTransaction -> String
   53 showLedgerTransaction = showLedgerTransaction' True
   54 
   55 showLedgerTransactionUnelided :: LedgerTransaction -> String
   56 showLedgerTransactionUnelided = showLedgerTransaction' False
   57 
   58 showLedgerTransaction' :: Bool -> LedgerTransaction -> String
   59 showLedgerTransaction' elide t = 
   60     unlines $ [{-precedingcomment ++ -}description] ++ (showpostings $ ltpostings t) ++ [""]
   61     where
   62       precedingcomment = ltpreceding_comment_lines t
   63       description = concat [date, status, code, desc] -- , comment]
   64       date = showdate $ ltdate t
   65       status = if ltstatus t then " *" else ""
   66       code = if (length $ ltcode t) > 0 then (printf " (%s)" $ ltcode t) else ""
   67       desc = " " ++ ltdescription t
   68       comment = if (length $ ltcomment t) > 0 then "  ; "++(ltcomment t) else ""
   69       showdate d = printf "%-10s" (showDate d)
   70       showpostings ps
   71           | elide && length ps > 1 && isLedgerTransactionBalanced t
   72               = map showposting (init ps) ++ [showpostingnoamt (last ps)]
   73           | otherwise = map showposting ps
   74           where
   75             showposting p = showacct p ++ "  " ++ (showamount $ pamount p) ++ (showcomment $ pcomment p)
   76             showpostingnoamt p = rstrip $ showacct p ++ "              " ++ (showcomment $ pcomment p)
   77             showacct p = "    " ++ showstatus p ++ (printf "%-34s" $ showAccountName (Just 34) (ptype p) (paccount p))
   78             showamount = printf "%12s" . showMixedAmount
   79             showcomment s = if (length s) > 0 then "  ; "++s else ""
   80             showstatus p = if pstatus p then "* " else ""
   81 
   82 -- | Show an account name, clipped to the given width if any, and
   83 -- appropriately bracketed/parenthesised for the given posting type.
   84 showAccountName :: Maybe Int -> PostingType -> AccountName -> String
   85 showAccountName w = fmt
   86     where
   87       fmt RegularPosting = take w'
   88       fmt VirtualPosting = parenthesise . reverse . take (w'-2) . reverse
   89       fmt BalancedVirtualPosting = bracket . reverse . take (w'-2) . reverse
   90       w' = fromMaybe 999999 w
   91       parenthesise s = "("++s++")"
   92       bracket s = "["++s++"]"
   93 
   94 isLedgerTransactionBalanced :: LedgerTransaction -> Bool
   95 isLedgerTransactionBalanced (LedgerTransaction {ltpostings=ps}) = 
   96     all (isReallyZeroMixedAmount . costOfMixedAmount . sum . map pamount)
   97             [filter isReal ps, filter isBalancedVirtual ps]
   98 
   99 -- | Ensure that this entry is balanced, possibly auto-filling a missing
  100 -- amount first. We can auto-fill if there is just one non-virtual
  101 -- transaction without an amount. The auto-filled balance will be
  102 -- converted to cost basis if possible. If the entry can not be balanced,
  103 -- return an error message instead.
  104 balanceLedgerTransaction :: LedgerTransaction -> Either String LedgerTransaction
  105 balanceLedgerTransaction t@LedgerTransaction{ltpostings=ps}
  106     | length missingamounts > 1 = Left $ printerr "could not balance this transaction, too many missing amounts"
  107     | not $ isLedgerTransactionBalanced t' = Left $ printerr nonzerobalanceerror
  108     | otherwise = Right t'
  109     where
  110       (withamounts, missingamounts) = partition hasAmount $ filter isReal ps
  111       t' = t{ltpostings=ps'}
  112       ps' | length missingamounts == 1 = map balance ps
  113           | otherwise = ps
  114           where 
  115             balance p | isReal p && not (hasAmount p) = p{pamount = costOfMixedAmount (-otherstotal)}
  116                       | otherwise = p
  117                       where otherstotal = sum $ map pamount withamounts
  118       printerr s = printf "%s:\n%s" s (showLedgerTransactionUnelided t)
  119 
  120 nonzerobalanceerror = "could not balance this transaction, amounts do not add up to zero"