625 lines
20 KiB
Haskell
625 lines
20 KiB
Haskell
module Internal.History
|
|
( readHistStmt
|
|
, readHistTransfer
|
|
, insertAll
|
|
, splitHistory
|
|
, balanceTxs
|
|
, updateTx
|
|
)
|
|
where
|
|
|
|
import Control.Monad.Except
|
|
import Data.Csv
|
|
import Data.Foldable
|
|
import Database.Persist ((=.))
|
|
import Database.Persist.Monad hiding (get)
|
|
import Internal.Database
|
|
import Internal.Types.Main
|
|
import Internal.Utils
|
|
import RIO hiding (to)
|
|
import qualified RIO.ByteString.Lazy as BL
|
|
import RIO.FilePath
|
|
import qualified RIO.List as L
|
|
import qualified RIO.Map as M
|
|
import qualified RIO.NonEmpty as NE
|
|
import RIO.State
|
|
import qualified RIO.Text as T
|
|
import RIO.Time
|
|
import qualified RIO.Vector as V
|
|
|
|
-- TODO unify this with the transfer system I use in the budget now
|
|
readHistTransfer
|
|
:: (MonadInsertError m, MonadFinance m)
|
|
=> HistTransfer
|
|
-> m (Either CommitR [Tx TxCommit])
|
|
readHistTransfer
|
|
m@Transfer
|
|
{ transFrom = from
|
|
, transTo = to
|
|
, transCurrency = u
|
|
, transAmounts = amts
|
|
} =
|
|
eitherHash CTManual m return $ \c -> do
|
|
bounds <- askDBState kmStatementInterval
|
|
let curRes = lookupCurrency u
|
|
let go Amount {amtWhen, amtValue, amtDesc} = do
|
|
let dayRes = liftExcept $ expandDatePat bounds amtWhen
|
|
(days, cur) <- combineError dayRes curRes (,)
|
|
let tx day = txPair c day from to cur amtValue amtDesc
|
|
return $ fmap tx days
|
|
concat <$> mapErrors go amts
|
|
|
|
readHistStmt
|
|
:: (MonadUnliftIO m, MonadFinance m)
|
|
=> FilePath
|
|
-> Statement
|
|
-> m (Either CommitR [Tx TxCommit])
|
|
readHistStmt root i = eitherHash CTImport i return $ \c -> do
|
|
bs <- readImport root i
|
|
bounds <- askDBState kmStatementInterval
|
|
return $ filter (inDaySpan bounds . txDate) $ fmap (\t -> t {txCommit = HistoryCommit c}) bs
|
|
|
|
splitHistory :: [History] -> ([HistTransfer], [Statement])
|
|
splitHistory = partitionEithers . fmap go
|
|
where
|
|
go (HistTransfer x) = Left x
|
|
go (HistStatement x) = Right x
|
|
|
|
insertAll
|
|
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
|
|
=> [EntryBin]
|
|
-> m ()
|
|
insertAll ebs = do
|
|
(toUpdate, toInsert) <- balanceTxs ebs
|
|
mapM_ updateTx toUpdate
|
|
forM_ (groupWith itxCommit toInsert) $
|
|
\(c, ts) -> do
|
|
ck <- insert $ getCommit c
|
|
mapM_ (insertTx ck) ts
|
|
where
|
|
getCommit (HistoryCommit c) = c
|
|
getCommit (BudgetCommit c _) = c
|
|
|
|
insertTx :: MonadSqlQuery m => CommitRId -> InsertTx -> m ()
|
|
insertTx c InsertTx {itxDate, itxDescr, itxEntries, itxCommit} = do
|
|
let anyDeferred = any (isJust . feDeferred) itxEntries
|
|
k <- insert $ TransactionR c itxDate itxDescr anyDeferred
|
|
mapM_ (go k) itxEntries
|
|
where
|
|
go k tx = do
|
|
ek <- insertEntry k tx
|
|
case itxCommit of
|
|
BudgetCommit _ name -> insert_ $ BudgetLabelR ek name
|
|
_ -> return ()
|
|
|
|
updateTx :: MonadSqlQuery m => UEBalanced -> m ()
|
|
updateTx UpdateEntry {ueID, ueValue} = update ueID [EntryRValue =. unStaticValue ueValue]
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- low-level transaction stuff
|
|
|
|
-- TODO tags here?
|
|
txPair
|
|
:: CommitR
|
|
-> Day
|
|
-> AcntID
|
|
-> AcntID
|
|
-> CurrencyPrec
|
|
-> TransferValue
|
|
-> T.Text
|
|
-> Tx TxCommit
|
|
txPair commit day from to cur (TransferValue t v) desc =
|
|
Tx
|
|
{ txDescr = desc
|
|
, txDate = day
|
|
, txCommit = HistoryCommit commit
|
|
, txPrimary =
|
|
EntrySet
|
|
{ esTotalValue = EntryValue t $ toRational v
|
|
, esCurrency = cur
|
|
, esFrom = HalfEntrySet {hesPrimary = entry from, hesOther = []}
|
|
, esTo = HalfEntrySet {hesPrimary = entry to, hesOther = []}
|
|
}
|
|
, txOther = []
|
|
}
|
|
where
|
|
entry a =
|
|
Entry
|
|
{ eAcnt = a
|
|
, eValue = ()
|
|
, eComment = ""
|
|
, eTags = []
|
|
}
|
|
|
|
-- resolveTx :: (MonadInsertError m, MonadFinance m) => BalTx CommitR -> m (KeyTx CommitR)
|
|
-- resolveTx t@Tx {txEntries = ss} =
|
|
-- (\kss -> t {txEntries = kss}) <$> mapErrors resolveEntry ss
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- Statements
|
|
|
|
-- TODO this probably won't scale well (pipes?)
|
|
readImport :: (MonadUnliftIO m, MonadFinance m) => FilePath -> Statement -> m [Tx ()]
|
|
readImport root Statement {stmtTxOpts, stmtParsers, stmtSkipLines, stmtDelim, stmtPaths} = do
|
|
let ores = compileOptions stmtTxOpts
|
|
let cres = combineErrors $ compileMatch <$> stmtParsers
|
|
(compiledOptions, compiledMatches) <- liftIOExcept $ combineError ores cres (,)
|
|
let readStmt = readImport_ stmtSkipLines stmtDelim compiledOptions
|
|
records <- L.sort . concat <$> mapErrorsIO readStmt paths
|
|
fromEither =<< runExceptT (matchRecords compiledMatches records)
|
|
where
|
|
paths = (root </>) <$> stmtPaths
|
|
|
|
readImport_
|
|
:: MonadUnliftIO m
|
|
=> Natural
|
|
-> Word
|
|
-> TxOptsRe
|
|
-> FilePath
|
|
-> m [TxRecord]
|
|
readImport_ n delim tns p = do
|
|
res <- tryIO $ BL.readFile p
|
|
bs <- fromEither $ first (InsertException . (: []) . InsertIOError . showT) res
|
|
case decodeByNameWithP (parseTxRecord p tns) opts $ skip bs of
|
|
Left m -> throwIO $ InsertException [ParseError $ T.pack m]
|
|
Right (_, v) -> return $ catMaybes $ V.toList v
|
|
where
|
|
opts = defaultDecodeOptions {decDelimiter = fromIntegral delim}
|
|
skip = BL.intercalate "\n" . L.drop (fromIntegral n) . BL.split 10
|
|
|
|
-- TODO handle this better, this maybe thing is a hack to skip lines with
|
|
-- blank dates but will likely want to make this more flexible
|
|
parseTxRecord :: FilePath -> TxOptsRe -> NamedRecord -> Parser (Maybe TxRecord)
|
|
parseTxRecord p TxOpts {toDate, toAmountFmt, toDesc, toAmount, toOther, toDateFmt} r = do
|
|
d <- r .: T.encodeUtf8 toDate
|
|
if d == ""
|
|
then return Nothing
|
|
else do
|
|
a <- parseRational toAmountFmt =<< r .: T.encodeUtf8 toAmount
|
|
e <- r .: T.encodeUtf8 toDesc
|
|
os <- M.fromList <$> mapM (\n -> (n,) <$> r .: T.encodeUtf8 n) toOther
|
|
d' <- parseTimeM True defaultTimeLocale (T.unpack toDateFmt) d
|
|
return $ Just $ TxRecord d' a e os p
|
|
|
|
matchRecords :: MonadFinance m => [MatchRe] -> [TxRecord] -> InsertExceptT m [Tx ()]
|
|
matchRecords ms rs = do
|
|
(matched, unmatched, notfound) <- matchAll (matchPriorities ms) rs
|
|
case (matched, unmatched, notfound) of
|
|
(ms_, [], []) -> return ms_
|
|
(_, us, ns) -> throwError $ InsertException [StatementError us ns]
|
|
|
|
matchPriorities :: [MatchRe] -> [MatchGroup]
|
|
matchPriorities =
|
|
fmap matchToGroup
|
|
. L.groupBy (\a b -> spPriority a == spPriority b)
|
|
. L.sortOn (Down . spPriority)
|
|
|
|
matchToGroup :: [MatchRe] -> MatchGroup
|
|
matchToGroup ms =
|
|
uncurry MatchGroup $
|
|
first (L.sortOn spDate) $
|
|
L.partition (isJust . spDate) ms
|
|
|
|
data MatchGroup = MatchGroup
|
|
{ mgDate :: ![MatchRe]
|
|
, mgNoDate :: ![MatchRe]
|
|
}
|
|
deriving (Show)
|
|
|
|
data Zipped a = Zipped ![a] ![a]
|
|
|
|
data Unzipped a = Unzipped ![a] ![a] ![a]
|
|
|
|
initZipper :: [a] -> Zipped a
|
|
initZipper = Zipped []
|
|
|
|
resetZipper :: Zipped a -> Zipped a
|
|
resetZipper = initZipper . recoverZipper
|
|
|
|
recoverZipper :: Zipped a -> [a]
|
|
recoverZipper (Zipped as bs) = reverse as ++ bs
|
|
|
|
zipperSlice
|
|
:: (a -> b -> Ordering)
|
|
-> b
|
|
-> Zipped a
|
|
-> Either (Zipped a) (Unzipped a)
|
|
zipperSlice f x = go
|
|
where
|
|
go z@(Zipped _ []) = Left z
|
|
go z@(Zipped bs (a : as)) =
|
|
case f a x of
|
|
GT -> go $ Zipped (a : bs) as
|
|
EQ -> Right $ goEq (Unzipped bs [a] as)
|
|
LT -> Left z
|
|
goEq z@(Unzipped _ _ []) = z
|
|
goEq z@(Unzipped bs cs (a : as)) =
|
|
case f a x of
|
|
GT -> goEq $ Unzipped (a : bs) cs as
|
|
EQ -> goEq $ Unzipped bs (a : cs) as
|
|
LT -> z
|
|
|
|
zipperMatch
|
|
:: MonadFinance m
|
|
=> Unzipped MatchRe
|
|
-> TxRecord
|
|
-> InsertExceptT m (Zipped MatchRe, MatchRes (Tx ()))
|
|
zipperMatch (Unzipped bs cs as) x = go [] cs
|
|
where
|
|
go _ [] = return (Zipped bs $ cs ++ as, MatchFail)
|
|
go prev (m : ms) = do
|
|
res <- matches m x
|
|
case res of
|
|
MatchFail -> go (m : prev) ms
|
|
skipOrPass ->
|
|
let ps = reverse prev
|
|
ms' = maybe ms (: ms) (matchDec m)
|
|
in return (Zipped bs $ ps ++ ms' ++ as, skipOrPass)
|
|
|
|
zipperMatch'
|
|
:: MonadFinance m
|
|
=> Zipped MatchRe
|
|
-> TxRecord
|
|
-> InsertExceptT m (Zipped MatchRe, MatchRes (Tx ()))
|
|
zipperMatch' z x = go z
|
|
where
|
|
go (Zipped bs (a : as)) = do
|
|
res <- matches a x
|
|
case res of
|
|
MatchFail -> go (Zipped (a : bs) as)
|
|
skipOrPass ->
|
|
return (Zipped (maybe bs (: bs) $ matchDec a) as, skipOrPass)
|
|
go z' = return (z', MatchFail)
|
|
|
|
matchDec :: MatchRe -> Maybe MatchRe
|
|
matchDec m = case spTimes m of
|
|
Just 1 -> Nothing
|
|
Just n -> Just $ m {spTimes = Just $ n - 1}
|
|
Nothing -> Just m
|
|
|
|
matchAll
|
|
:: MonadFinance m
|
|
=> [MatchGroup]
|
|
-> [TxRecord]
|
|
-> InsertExceptT m ([Tx ()], [TxRecord], [MatchRe])
|
|
matchAll = go ([], [])
|
|
where
|
|
go (matched, unused) gs rs = case (gs, rs) of
|
|
(_, []) -> return (matched, [], unused)
|
|
([], _) -> return (matched, rs, unused)
|
|
(g : gs', _) -> do
|
|
(ts, unmatched, us) <- matchGroup g rs
|
|
go (ts ++ matched, us ++ unused) gs' unmatched
|
|
|
|
matchGroup
|
|
:: MonadFinance m
|
|
=> MatchGroup
|
|
-> [TxRecord]
|
|
-> InsertExceptT m ([Tx ()], [TxRecord], [MatchRe])
|
|
matchGroup MatchGroup {mgDate = ds, mgNoDate = ns} rs = do
|
|
(md, rest, ud) <- matchDates ds rs
|
|
(mn, unmatched, un) <- matchNonDates ns rest
|
|
return (md ++ mn, unmatched, filter ((/= Nothing) . spTimes) $ ud ++ un)
|
|
|
|
matchDates
|
|
:: MonadFinance m
|
|
=> [MatchRe]
|
|
-> [TxRecord]
|
|
-> InsertExceptT m ([Tx ()], [TxRecord], [MatchRe])
|
|
matchDates ms = go ([], [], initZipper ms)
|
|
where
|
|
go (matched, unmatched, z) [] =
|
|
return
|
|
( catMaybes matched
|
|
, reverse unmatched
|
|
, recoverZipper z
|
|
)
|
|
go (matched, unmatched, z) (r : rs) =
|
|
case zipperSlice findDate r z of
|
|
Left zipped -> go (matched, r : unmatched, zipped) rs
|
|
Right unzipped -> do
|
|
(z', res) <- zipperMatch unzipped r
|
|
let (m, u) = case res of
|
|
(MatchPass p) -> (Just p : matched, unmatched)
|
|
MatchSkip -> (Nothing : matched, unmatched)
|
|
MatchFail -> (matched, r : unmatched)
|
|
go (m, u, z') rs
|
|
findDate m r = maybe EQ (`compareDate` trDate r) $ spDate m
|
|
|
|
matchNonDates
|
|
:: MonadFinance m
|
|
=> [MatchRe]
|
|
-> [TxRecord]
|
|
-> InsertExceptT m ([Tx ()], [TxRecord], [MatchRe])
|
|
matchNonDates ms = go ([], [], initZipper ms)
|
|
where
|
|
go (matched, unmatched, z) [] =
|
|
return
|
|
( catMaybes matched
|
|
, reverse unmatched
|
|
, recoverZipper z
|
|
)
|
|
go (matched, unmatched, z) (r : rs) = do
|
|
(z', res) <- zipperMatch' z r
|
|
let (m, u) = case res of
|
|
MatchPass p -> (Just p : matched, unmatched)
|
|
MatchSkip -> (Nothing : matched, unmatched)
|
|
MatchFail -> (matched, r : unmatched)
|
|
in go (m, u, resetZipper z') rs
|
|
|
|
balanceTxs
|
|
:: (MonadInsertError m, MonadFinance m)
|
|
=> [EntryBin]
|
|
-> m ([UEBalanced], [InsertTx])
|
|
balanceTxs ebs =
|
|
first concat . partitionEithers . catMaybes
|
|
<$> evalStateT (mapErrors go $ L.sortOn binDate ebs) M.empty
|
|
where
|
|
go (ToUpdate utx) = fmap (Just . Left) $ liftInnerS $ rebalanceEntrySet utx
|
|
go (ToRead ReadEntry {reCurrency, reAcnt, reValue}) = do
|
|
modify $ mapAdd_ (reAcnt, reCurrency) reValue
|
|
return Nothing
|
|
go (ToInsert Tx {txPrimary, txOther, txDescr, txCommit, txDate}) = do
|
|
e <- balanceEntrySet primaryBalance txPrimary
|
|
-- TODO this logic is really stupid, I'm balancing the total twice; fix
|
|
-- will likely entail making a separate data structure for txs derived
|
|
-- from transfers vs statements
|
|
let etot = sum $ eValue . feEntry <$> filter ((< 0) . feIndex) e
|
|
es <- mapErrors (balanceEntrySet (secondaryBalance etot)) txOther
|
|
let tx =
|
|
InsertTx
|
|
{ itxDescr = txDescr
|
|
, itxDate = txDate
|
|
, itxEntries = concat $ e : es
|
|
, itxCommit = txCommit
|
|
}
|
|
return $ Just $ Right tx
|
|
primaryBalance Entry {eAcnt} c (EntryValue t v) = findBalance eAcnt c t v
|
|
secondaryBalance tot Entry {eAcnt} c val = case val of
|
|
Right (EntryValue t v) -> findBalance eAcnt c t v
|
|
Left v -> return $ toRational v * tot
|
|
|
|
binDate :: EntryBin -> Day
|
|
binDate (ToUpdate UpdateEntrySet {utDate}) = utDate
|
|
binDate (ToRead ReadEntry {reDate}) = reDate
|
|
binDate (ToInsert Tx {txDate}) = txDate
|
|
|
|
type EntryBals = M.Map (AccountRId, CurrencyRId) Rational
|
|
|
|
data UpdateEntryType a
|
|
= UET_ReadOnly UE_RO
|
|
| UET_Unk UEUnk
|
|
| UET_Linked a
|
|
|
|
-- TODO make sure new values are rounded properly here
|
|
rebalanceEntrySet :: UpdateEntrySet -> State EntryBals [UEBalanced]
|
|
rebalanceEntrySet
|
|
UpdateEntrySet
|
|
{ utFrom0
|
|
, utTo0
|
|
, utPairs
|
|
, utFromUnk
|
|
, utToUnk
|
|
, utFromRO
|
|
, utToRO
|
|
, utCurrency
|
|
, utToUnkLink0
|
|
, utTotalValue
|
|
} =
|
|
do
|
|
(f0val, (tpairs, fs)) <-
|
|
fmap (second partitionEithers) $
|
|
foldM goFrom (utTotalValue, []) $
|
|
L.sortOn idx $
|
|
(UET_ReadOnly <$> utFromRO)
|
|
++ (UET_Unk <$> utFromUnk)
|
|
++ (UET_Linked <$> utPairs)
|
|
let f0 = utFrom0 {ueValue = StaticValue f0val}
|
|
let tsLink0 = fmap (unlink (-f0val)) utToUnkLink0
|
|
(t0val, tsUnk) <-
|
|
fmap (second catMaybes) $
|
|
foldM goTo (-utTotalValue, []) $
|
|
L.sortOn idx2 $
|
|
(UET_Linked <$> (tpairs ++ tsLink0))
|
|
++ (UET_Unk <$> utToUnk)
|
|
++ (UET_ReadOnly <$> utToRO)
|
|
let t0 = utTo0 {ueValue = StaticValue t0val}
|
|
return (f0 : fs ++ (t0 : tsUnk))
|
|
where
|
|
project f _ _ (UET_ReadOnly e) = f e
|
|
project _ f _ (UET_Unk e) = f e
|
|
project _ _ f (UET_Linked p) = f p
|
|
idx = project ueIndex ueIndex (ueIndex . fst)
|
|
idx2 = project ueIndex ueIndex ueIndex
|
|
-- TODO the sum accumulator thing is kinda awkward
|
|
goFrom (tot, es) (UET_ReadOnly e) = do
|
|
v <- updateFixed e
|
|
return (tot - v, es)
|
|
goFrom (tot, esPrev) (UET_Unk e) = do
|
|
v <- updateUnknown e
|
|
return (tot - v, Right e {ueValue = StaticValue v} : esPrev)
|
|
goFrom (tot, esPrev) (UET_Linked (e0, es)) = do
|
|
v <- updateUnknown e0
|
|
let e0' = Right $ e0 {ueValue = StaticValue v}
|
|
let es' = fmap (Left . unlink (-v)) es
|
|
return (tot - v, (e0' : es') ++ esPrev)
|
|
goTo (tot, esPrev) (UET_ReadOnly e) = do
|
|
v <- updateFixed e
|
|
return (tot - v, esPrev)
|
|
goTo (tot, esPrev) (UET_Linked e) = do
|
|
v <- updateFixed e
|
|
return (tot - v, Just e : esPrev)
|
|
goTo (tot, esPrev) (UET_Unk e) = do
|
|
v <- updateUnknown e
|
|
return (tot - v, Just e {ueValue = StaticValue v} : esPrev)
|
|
updateFixed :: UpdateEntry i StaticValue -> State EntryBals Rational
|
|
updateFixed e = do
|
|
let v = unStaticValue $ ueValue e
|
|
modify $ mapAdd_ (ueAcnt e, utCurrency) v
|
|
return v
|
|
updateUnknown e = do
|
|
let key = (ueAcnt e, utCurrency)
|
|
curBal <- gets (M.findWithDefault 0 key)
|
|
let v = case ueValue e of
|
|
EVPercent p -> p * curBal
|
|
EVBalance p -> p - curBal
|
|
modify $ mapAdd_ key v
|
|
return v
|
|
unlink v e = e {ueValue = StaticValue $ v * unLinkScale (ueValue e)}
|
|
|
|
balanceEntrySet
|
|
:: (MonadInsertError m, MonadFinance m)
|
|
=> (Entry AccountRId AcntSign TagRId -> CurrencyRId -> v -> State EntryBals Rational)
|
|
-> DeferredEntrySet v
|
|
-> StateT EntryBals m [KeyEntry]
|
|
balanceEntrySet
|
|
findTot
|
|
EntrySet
|
|
{ esFrom = HalfEntrySet {hesPrimary = f0, hesOther = fs}
|
|
, esTo = HalfEntrySet {hesPrimary = t0, hesOther = ts}
|
|
, esCurrency = CurrencyPrec {cpID = curID, cpPrec = precision}
|
|
, esTotalValue
|
|
} =
|
|
do
|
|
-- 1. Resolve tag and accout ids in primary entries since we (might) need
|
|
-- them later to calculate the total value of the transaction.
|
|
let f0res = resolveAcntAndTags f0
|
|
let t0res = resolveAcntAndTags t0
|
|
combineErrorM f0res t0res $ \f0' t0' -> do
|
|
-- 2. Compute total value of transaction using the primary debit entry
|
|
tot <- liftInnerS $ findTot f0' curID esTotalValue
|
|
|
|
-- 3. Balance all debit entries (including primary). Note the negative
|
|
-- indices, which will signify them to be debit entries when updated
|
|
-- later.
|
|
let balFromEntry = balanceEntry (\a -> liftInnerS . balanceDeferred curID a) curID
|
|
fs' <- doEntries balFromEntry curID tot f0' fs (NE.iterate (+ (-1)) (-1))
|
|
|
|
-- 4. Build an array of debit values be linked as desired in credit entries
|
|
let fv = V.fromList $ fmap (eValue . feEntry) fs'
|
|
|
|
-- 4. Balance credit entries (including primary) analogously.
|
|
let balToEntry = balanceEntry (balanceLinked fv curID precision) curID
|
|
ts' <- doEntries balToEntry curID (-tot) t0' ts (NE.iterate (+ 1) 0)
|
|
return $ fs' ++ ts'
|
|
|
|
doEntries
|
|
:: (MonadInsertError m)
|
|
=> (Int -> Entry AcntID v TagID -> StateT EntryBals m (InsertEntry AccountRId CurrencyRId TagRId))
|
|
-> CurrencyRId
|
|
-> Rational
|
|
-> Entry AccountRId AcntSign TagRId
|
|
-> [Entry AcntID v TagID]
|
|
-> NonEmpty Int
|
|
-> StateT EntryBals m [InsertEntry AccountRId CurrencyRId TagRId]
|
|
doEntries f curID tot e es (i0 :| iN) = do
|
|
es' <- mapErrors (uncurry f) $ zip iN es
|
|
let e0val = tot - entrySum es'
|
|
-- TODO not dry
|
|
let s = fromIntegral $ sign2Int (eValue e) -- NOTE hack
|
|
modify (mapAdd_ (eAcnt e, curID) tot)
|
|
let e' =
|
|
InsertEntry
|
|
{ feEntry = e {eValue = s * e0val}
|
|
, feCurrency = curID
|
|
, feDeferred = Nothing
|
|
, feIndex = i0
|
|
}
|
|
return $ e' : es'
|
|
where
|
|
entrySum = sum . fmap (eValue . feEntry)
|
|
|
|
liftInnerS :: Monad m => StateT e Identity a -> StateT e m a
|
|
liftInnerS = mapStateT (return . runIdentity)
|
|
|
|
balanceLinked
|
|
:: MonadInsertError m
|
|
=> Vector Rational
|
|
-> CurrencyRId
|
|
-> Natural
|
|
-> AccountRId
|
|
-> LinkDeferred Rational
|
|
-> StateT EntryBals m (Rational, Maybe DBDeferred)
|
|
balanceLinked from curID precision acntID lg = case lg of
|
|
(LinkIndex LinkedNumGetter {lngIndex, lngScale}) -> do
|
|
let res = fmap (go lngScale) $ from V.!? fromIntegral lngIndex
|
|
case res of
|
|
Just v -> return (v, Just $ EntryLinked lngIndex $ toRational lngScale)
|
|
-- TODO this error would be much more informative if I had access to the
|
|
-- file from which it came
|
|
Nothing -> throwError undefined
|
|
(LinkDeferred d) -> liftInnerS $ balanceDeferred curID acntID d
|
|
where
|
|
go s = roundPrecision precision . (* s) . fromRational
|
|
|
|
balanceDeferred
|
|
:: CurrencyRId
|
|
-> AccountRId
|
|
-> EntryValue Rational
|
|
-> State EntryBals (Rational, Maybe DBDeferred)
|
|
balanceDeferred curID acntID (EntryValue t v) = do
|
|
newval <- findBalance acntID curID t v
|
|
let d = case t of
|
|
TFixed -> Nothing
|
|
TBalance -> Just $ EntryBalance v
|
|
TPercent -> Just $ EntryPercent v
|
|
return (newval, d)
|
|
|
|
balanceEntry
|
|
:: (MonadInsertError m, MonadFinance m)
|
|
=> (AccountRId -> v -> StateT EntryBals m (Rational, Maybe DBDeferred))
|
|
-> CurrencyRId
|
|
-> Int
|
|
-> Entry AcntID v TagID
|
|
-> StateT EntryBals m (InsertEntry AccountRId CurrencyRId TagRId)
|
|
balanceEntry f curID idx e@Entry {eValue, eAcnt, eTags} = do
|
|
let acntRes = lookupAccount eAcnt
|
|
let tagRes = mapErrors lookupTag eTags
|
|
combineErrorM acntRes tagRes $ \(acntID, sign, _) tags -> do
|
|
let s = fromIntegral $ sign2Int sign
|
|
(newVal, deferred) <- f acntID eValue
|
|
modify (mapAdd_ (acntID, curID) newVal)
|
|
return $
|
|
InsertEntry
|
|
{ feEntry = e {eValue = s * newVal, eAcnt = acntID, eTags = tags}
|
|
, feCurrency = curID
|
|
, feDeferred = deferred
|
|
, feIndex = idx
|
|
}
|
|
|
|
resolveAcntAndTags
|
|
:: (MonadInsertError m, MonadFinance m)
|
|
=> Entry AcntID v TagID
|
|
-> m (Entry AccountRId AcntSign TagRId)
|
|
resolveAcntAndTags e@Entry {eAcnt, eTags} = do
|
|
let acntRes = lookupAccount eAcnt
|
|
let tagRes = mapErrors lookupTag eTags
|
|
-- TODO total hack, store account sign in the value field so I don't need to
|
|
-- make seperate tuple pair thing to haul it around. Weird, but it works.
|
|
combineError acntRes tagRes $
|
|
\(acntID, sign, _) tags -> e {eAcnt = acntID, eTags = tags, eValue = sign}
|
|
|
|
findBalance
|
|
:: AccountRId
|
|
-> CurrencyRId
|
|
-> TransferType
|
|
-> Rational
|
|
-> State EntryBals Rational
|
|
findBalance acnt cur t v = do
|
|
curBal <- gets (M.findWithDefault 0 (acnt, cur))
|
|
return $ case t of
|
|
TBalance -> v - curBal
|
|
TPercent -> v * curBal
|
|
TFixed -> v
|
|
|
|
-- -- reimplementation from future version :/
|
|
-- mapAccumM
|
|
-- :: Monad m
|
|
-- => (s -> a -> m (s, b))
|
|
-- -> s
|
|
-- -> [a]
|
|
-- -> m (s, [b])
|
|
-- mapAccumM f s xs = foldrM go (s, []) xs
|
|
-- where
|
|
-- go x (s', acc) = second (: acc) <$> f s' x
|