1 {-|
    2 
    3 A 'RawLedger' is a parsed ledger file. We call it raw to distinguish from
    4 the cached 'Ledger'.
    5 
    6 -}
    7 
    8 module Ledger.RawLedger
    9 where
   10 import qualified Data.Map as Map
   11 import Data.Map ((!))
   12 import Ledger.Utils
   13 import Ledger.Types
   14 import Ledger.AccountName
   15 import Ledger.Amount
   16 import Ledger.LedgerTransaction
   17 import Ledger.Transaction
   18 import Ledger.Posting
   19 import Ledger.TimeLog
   20 
   21 
   22 instance Show RawLedger where
   23     show l = printf "RawLedger with %d transactions, %d accounts: %s"
   24              ((length $ ledger_txns l) +
   25               (length $ modifier_txns l) +
   26               (length $ periodic_txns l))
   27              (length accounts)
   28              (show accounts)
   29              -- ++ (show $ rawLedgerTransactions l)
   30              where accounts = flatten $ rawLedgerAccountNameTree l
   31 
   32 rawLedgerEmpty :: RawLedger
   33 rawLedgerEmpty = RawLedger { modifier_txns = []
   34                            , periodic_txns = []
   35                            , ledger_txns = []
   36                            , open_timelog_entries = []
   37                            , historical_prices = []
   38                            , final_comment_lines = []
   39                            , filepath = ""
   40                            }
   41 
   42 addLedgerTransaction :: LedgerTransaction -> RawLedger -> RawLedger
   43 addLedgerTransaction t l0 = l0 { ledger_txns = t : (ledger_txns l0) }
   44 
   45 addModifierTransaction :: ModifierTransaction -> RawLedger -> RawLedger
   46 addModifierTransaction mt l0 = l0 { modifier_txns = mt : (modifier_txns l0) }
   47 
   48 addPeriodicTransaction :: PeriodicTransaction -> RawLedger -> RawLedger
   49 addPeriodicTransaction pt l0 = l0 { periodic_txns = pt : (periodic_txns l0) }
   50 
   51 addHistoricalPrice :: HistoricalPrice -> RawLedger -> RawLedger
   52 addHistoricalPrice h l0 = l0 { historical_prices = h : (historical_prices l0) }
   53 
   54 addTimeLogEntry :: TimeLogEntry -> RawLedger -> RawLedger
   55 addTimeLogEntry tle l0 = l0 { open_timelog_entries = tle : (open_timelog_entries l0) }
   56 
   57 rawLedgerTransactions :: RawLedger -> [Transaction]
   58 rawLedgerTransactions = txnsof . ledger_txns
   59     where txnsof ts = concat $ map flattenLedgerTransaction $ zip ts [1..]
   60 
   61 rawLedgerAccountNamesUsed :: RawLedger -> [AccountName]
   62 rawLedgerAccountNamesUsed = accountNamesFromTransactions . rawLedgerTransactions
   63 
   64 rawLedgerAccountNames :: RawLedger -> [AccountName]
   65 rawLedgerAccountNames = sort . expandAccountNames . rawLedgerAccountNamesUsed
   66 
   67 rawLedgerAccountNameTree :: RawLedger -> Tree AccountName
   68 rawLedgerAccountNameTree l = accountNameTreeFrom $ rawLedgerAccountNames l
   69 
   70 -- | Remove ledger transactions we are not interested in.
   71 -- Keep only those which fall between the begin and end dates, and match
   72 -- the description pattern, and are cleared or real if those options are active.
   73 filterRawLedger :: DateSpan -> [String] -> Maybe Bool -> Bool -> RawLedger -> RawLedger
   74 filterRawLedger span pats clearedonly realonly = 
   75     filterRawLedgerPostingsByRealness realonly .
   76     filterRawLedgerTransactionsByClearedStatus clearedonly .
   77     filterRawLedgerTransactionsByDate span .
   78     filterRawLedgerTransactionsByDescription pats
   79 
   80 -- | Keep only ledger transactions whose description matches the description patterns.
   81 filterRawLedgerTransactionsByDescription :: [String] -> RawLedger -> RawLedger
   82 filterRawLedgerTransactionsByDescription pats (RawLedger ms ps ts tls hs f fp) = 
   83     RawLedger ms ps (filter matchdesc ts) tls hs f fp
   84     where matchdesc = matchpats pats . ltdescription
   85 
   86 -- | Keep only ledger transactions which fall between begin and end dates. 
   87 -- We include transactions on the begin date and exclude transactions on the end
   88 -- date, like ledger.  An empty date string means no restriction.
   89 filterRawLedgerTransactionsByDate :: DateSpan -> RawLedger -> RawLedger
   90 filterRawLedgerTransactionsByDate (DateSpan begin end) (RawLedger ms ps ts tls hs f fp) = 
   91     RawLedger ms ps (filter matchdate ts) tls hs f fp
   92     where 
   93       matchdate t = (maybe True (ltdate t>=) begin) && (maybe True (ltdate t<) end)
   94 
   95 -- | Keep only ledger transactions which have the requested
   96 -- cleared/uncleared status, if there is one.
   97 filterRawLedgerTransactionsByClearedStatus :: Maybe Bool -> RawLedger -> RawLedger
   98 filterRawLedgerTransactionsByClearedStatus Nothing rl = rl
   99 filterRawLedgerTransactionsByClearedStatus (Just val) (RawLedger ms ps ts tls hs f fp) =
  100     RawLedger ms ps (filter ((==val).ltstatus) ts) tls hs f fp
  101 
  102 -- | Strip out any virtual postings, if the flag is true, otherwise do
  103 -- no filtering.
  104 filterRawLedgerPostingsByRealness :: Bool -> RawLedger -> RawLedger
  105 filterRawLedgerPostingsByRealness False l = l
  106 filterRawLedgerPostingsByRealness True (RawLedger mts pts ts tls hs f fp) =
  107     RawLedger mts pts (map filtertxns ts) tls hs f fp
  108     where filtertxns t@LedgerTransaction{ltpostings=ps} = t{ltpostings=filter isReal ps}
  109 
  110 -- | Strip out any postings to accounts deeper than the specified depth
  111 -- (and any ledger transactions which have no postings as a result).
  112 filterRawLedgerPostingsByDepth :: Int -> RawLedger -> RawLedger
  113 filterRawLedgerPostingsByDepth depth (RawLedger mts pts ts tls hs f fp) =
  114     RawLedger mts pts (filter (not . null . ltpostings) $ map filtertxns ts) tls hs f fp
  115     where filtertxns t@LedgerTransaction{ltpostings=ps} = 
  116               t{ltpostings=filter ((<= depth) . accountNameLevel . paccount) ps}
  117 
  118 -- | Keep only ledger transactions which affect accounts matched by the account patterns.
  119 filterRawLedgerTransactionsByAccount :: [String] -> RawLedger -> RawLedger
  120 filterRawLedgerTransactionsByAccount apats (RawLedger ms ps ts tls hs f fp) =
  121     RawLedger ms ps (filter (any (matchpats apats . paccount) . ltpostings) ts) tls hs f fp
  122 
  123 -- | Give all a ledger's amounts their canonical display settings.  That
  124 -- is, in each commodity, amounts will use the display settings of the
  125 -- first amount detected, and the greatest precision of the amounts
  126 -- detected. Also, amounts are converted to cost basis if that flag is
  127 -- active.
  128 canonicaliseAmounts :: Bool -> RawLedger -> RawLedger
  129 canonicaliseAmounts costbasis l@(RawLedger ms ps ts tls hs f fp) = RawLedger ms ps (map fixledgertransaction ts) tls hs f fp
  130     where 
  131       fixledgertransaction (LedgerTransaction d s c de co ts pr) = LedgerTransaction d s c de co (map fixrawposting ts) pr
  132       fixrawposting (Posting s ac a c t) = Posting s ac (fixmixedamount a) c t
  133       fixmixedamount (Mixed as) = Mixed $ map fixamount as
  134       fixamount = fixcommodity . (if costbasis then costOfAmount else id)
  135       fixcommodity a = a{commodity=c} where c = canonicalcommoditymap ! (symbol $ commodity a)
  136       canonicalcommoditymap = 
  137           Map.fromList [(s,firstc{precision=maxp}) | s <- commoditysymbols,
  138                         let cs = commoditymap ! s,
  139                         let firstc = head cs,
  140                         let maxp = maximum $ map precision cs
  141                        ]
  142       commoditymap = Map.fromList [(s,commoditieswithsymbol s) | s <- commoditysymbols]
  143       commoditieswithsymbol s = filter ((s==) . symbol) commodities
  144       commoditysymbols = nub $ map symbol commodities
  145       commodities = map commodity $ concatMap (amounts . tamount) $ rawLedgerTransactions l
  146 
  147 -- | Get just the amounts from a ledger, in the order parsed.
  148 rawLedgerAmounts :: RawLedger -> [MixedAmount]
  149 rawLedgerAmounts = map tamount . rawLedgerTransactions
  150 
  151 -- | Get just the ammount commodities from a ledger, in the order parsed.
  152 rawLedgerCommodities :: RawLedger -> [Commodity]
  153 rawLedgerCommodities = map commodity . concatMap amounts . rawLedgerAmounts
  154 
  155 -- | Get just the amount precisions from a ledger, in the order parsed.
  156 rawLedgerPrecisions :: RawLedger -> [Int]
  157 rawLedgerPrecisions = map precision . rawLedgerCommodities
  158 
  159 -- | Close any open timelog sessions using the provided current time.
  160 rawLedgerConvertTimeLog :: LocalTime -> RawLedger -> RawLedger
  161 rawLedgerConvertTimeLog t l0 = l0 { ledger_txns = convertedTimeLog ++ ledger_txns l0
  162                                   , open_timelog_entries = []
  163                                   }
  164     where convertedTimeLog = entriesFromTimeLogEntries t $ open_timelog_entries l0
  165 
  166 
  167 -- | The (fully specified) date span containing all the raw ledger's transactions,
  168 -- or DateSpan Nothing Nothing if there are none.
  169 rawLedgerDateSpan :: RawLedger -> DateSpan
  170 rawLedgerDateSpan rl
  171     | null ts = DateSpan Nothing Nothing
  172     | otherwise = DateSpan (Just $ ltdate $ head ts) (Just $ addDays 1 $ ltdate $ last ts)
  173     where
  174       ts = sortBy (comparing ltdate) $ ledger_txns rl
  175 
  176 -- | Check if a set of ledger account/description patterns matches the
  177 -- given account name or entry description.  Patterns are case-insensitive
  178 -- regular expression strings; those beginning with - are anti-patterns.
  179 matchpats :: [String] -> String -> Bool
  180 matchpats pats str =
  181     (null positives || any match positives) && (null negatives || not (any match negatives))
  182     where
  183       (negatives,positives) = partition isnegativepat pats
  184       match "" = True
  185       match pat = containsRegex (abspat pat) str
  186       negateprefix = "not:"
  187       isnegativepat pat = negateprefix `isPrefixOf` pat
  188       abspat pat = if isnegativepat pat then drop (length negateprefix) pat else pat