ENH use sane types to simplify tx balancing
This commit is contained in:
parent
6926003c46
commit
ad0975aba7
|
@ -396,31 +396,21 @@ let FieldMatcher_ =
|
|||
|
||||
let FieldMatcher = FieldMatcher_ Text
|
||||
|
||||
let FromEntryNumGetter =
|
||||
let EntryNumGetter =
|
||||
{-
|
||||
Means to get a numeric value from a statement row.
|
||||
|
||||
FLookupN: lookup the value from a field
|
||||
FConstN: a constant value
|
||||
FAmountN: the value of the 'Amount' column
|
||||
FBalanceN: the amount required to make the target account reach a balance
|
||||
LookupN: lookup the value from a field
|
||||
ConstN: a constant value
|
||||
AmountN: the value of the 'Amount' column
|
||||
BalanceN: the amount required to make the target account reach a balance
|
||||
-}
|
||||
< FLookupN : Text
|
||||
| FConstN : Double
|
||||
| FAmountN : Double
|
||||
| FBalanceN : Double
|
||||
< LookupN : Text
|
||||
| ConstN : Double
|
||||
| AmountN : Double
|
||||
| BalanceN : Double
|
||||
>
|
||||
|
||||
let ToEntryNumGetter =
|
||||
{-
|
||||
Means to get a numeric value from a statement row.
|
||||
|
||||
TLookupN: lookup the value from a field
|
||||
TConstN: a constant value
|
||||
TAmountN: the value of the 'Amount' column
|
||||
-}
|
||||
< TLookupN : Text | TConstN : Double | TAmountN : Double >
|
||||
|
||||
let EntryTextGetter =
|
||||
{-
|
||||
Means to get a textual value from a statement row.
|
||||
|
@ -458,7 +448,6 @@ let Entry =
|
|||
-}
|
||||
\(a : Type) ->
|
||||
\(v : Type) ->
|
||||
\(c : Type) ->
|
||||
\(t : Type) ->
|
||||
{ eAcnt :
|
||||
{-
|
||||
|
@ -470,11 +459,6 @@ let Entry =
|
|||
Pertains to value for this entry.
|
||||
-}
|
||||
v
|
||||
, eCurrency :
|
||||
{-
|
||||
Pertains to value for this entry.
|
||||
-}
|
||||
c
|
||||
, eComment :
|
||||
{-
|
||||
A short description of this entry (if none, use a blank string)
|
||||
|
@ -487,31 +471,65 @@ let Entry =
|
|||
List t
|
||||
}
|
||||
|
||||
let FromEntryGetter =
|
||||
let EntryGetter =
|
||||
{-
|
||||
Means for getting an entry from a given row in a statement to apply to the
|
||||
credit side of the transaction.
|
||||
Means for getting an entry from a given row in a statement
|
||||
-}
|
||||
{ Type = Entry EntryAcntGetter FromEntryNumGetter EntryCurGetter TagID
|
||||
, default = { eValue = None FromEntryNumGetter, eComment = "" }
|
||||
{ Type = Entry EntryAcntGetter EntryNumGetter TagID
|
||||
, default = { eValue = None EntryNumGetter, eComment = "" }
|
||||
}
|
||||
|
||||
let ToEntryGetter =
|
||||
let TxSubGetter =
|
||||
{-
|
||||
Means for getting an entry from a given row in a statement to apply to the
|
||||
debit side of the transaction.
|
||||
A means for transforming one row in a statement to a transaction
|
||||
-}
|
||||
{ Type =
|
||||
Entry EntryAcntGetter (Optional ToEntryNumGetter) EntryCurGetter TagID
|
||||
, default = { eValue = None ToEntryNumGetter, eComment = "" }
|
||||
{ tsgFromAcnt :
|
||||
{-
|
||||
-}
|
||||
EntryAcntGetter
|
||||
, tsgToAcnt :
|
||||
{-
|
||||
-}
|
||||
EntryAcntGetter
|
||||
, tsgValue :
|
||||
{-
|
||||
-}
|
||||
EntryNumGetter
|
||||
, tsgCurrency :
|
||||
{-
|
||||
-}
|
||||
EntryCurGetter
|
||||
, tsgFromEntries :
|
||||
{-
|
||||
-}
|
||||
List EntryGetter.Type
|
||||
, tsgToEntries :
|
||||
{-
|
||||
A means of getting entries for this transaction (minimum 1)
|
||||
-}
|
||||
List EntryGetter.Type
|
||||
}
|
||||
|
||||
let TxGetter =
|
||||
{-
|
||||
A means for transforming one row in a statement to a transaction
|
||||
|
||||
Note that N-1 entries need to be specified to make a transaction, as the
|
||||
Nth entry will be balanced with the others.
|
||||
At least two entries must be made for any given transaction. Below these
|
||||
correspond to the 'from' and 'to' accounts, which will share a single value
|
||||
(whose positive is added to 'to' and negative is added to 'from' accounts)
|
||||
given by the record (ie one row in a statement) denominated in the given
|
||||
currency.
|
||||
|
||||
Optionally, both sides of the from/to flow of value can be split with other
|
||||
accounts (given by 'tgFromEntries' and 'tgToEntries'). In either case, the
|
||||
amount actually transferred between the 'from' and 'to' accounts above
|
||||
will be the difference after considering these additional account entries.
|
||||
|
||||
Furthermore, additionally entries denominated in different currencies
|
||||
may be specified via 'tgOtherEntries'. Each member in this list corresponds
|
||||
to a different currency (and associated entries) governed by most of the
|
||||
rules for this type regarding balancing and splitting value.
|
||||
|
||||
-}
|
||||
{ tgFromAcnt :
|
||||
{-
|
||||
|
@ -520,7 +538,14 @@ let TxGetter =
|
|||
entries are specified (see below).
|
||||
-}
|
||||
EntryAcntGetter
|
||||
, tgFromCurrency :
|
||||
, tgToAcnt :
|
||||
{-
|
||||
Account from which this transaction will be balanced. The value of
|
||||
the transaction will be assigned to this account unless other from
|
||||
entries are specified (see below).
|
||||
-}
|
||||
EntryAcntGetter
|
||||
, tgCurrency :
|
||||
{-
|
||||
Currency to assign to the account/value denoted by 'tgFromAcnt'
|
||||
above.
|
||||
|
@ -538,12 +563,16 @@ let TxGetter =
|
|||
This is useful for situations where a particular transaction denotes
|
||||
values that come from multiple subaccounts.
|
||||
-}
|
||||
List FromEntryGetter.Type
|
||||
List EntryGetter.Type
|
||||
, tgToEntries :
|
||||
{-
|
||||
A means of getting entries for this transaction (minimum 1)
|
||||
A means of getting entries for this transaction
|
||||
-}
|
||||
List ToEntryGetter.Type
|
||||
List EntryGetter.Type
|
||||
, tgOtherEntries :
|
||||
{-
|
||||
-}
|
||||
List TxSubGetter
|
||||
}
|
||||
|
||||
let StatementParser_ =
|
||||
|
@ -1088,13 +1117,11 @@ in { CurID
|
|||
, DateMatcher
|
||||
, FieldMatcher
|
||||
, FieldMatcher_
|
||||
, FromEntryNumGetter
|
||||
, ToEntryNumGetter
|
||||
, EntryNumGetter
|
||||
, Field
|
||||
, FieldMap
|
||||
, Entry
|
||||
, FromEntryGetter
|
||||
, ToEntryGetter
|
||||
, EntryGetter
|
||||
, EntryTextGetter
|
||||
, EntryCurGetter
|
||||
, EntryAcntGetter
|
||||
|
|
|
@ -11,7 +11,9 @@ module Internal.Database
|
|||
, whenHash
|
||||
, whenHash_
|
||||
, insertEntry
|
||||
-- , insertEntrySet
|
||||
, resolveEntry
|
||||
-- , resolveEntrySet
|
||||
)
|
||||
where
|
||||
|
||||
|
@ -393,15 +395,15 @@ whenHash_ t o f = do
|
|||
if h `elem` hs then Just . (c,) <$> f else return Nothing
|
||||
|
||||
insertEntry :: MonadSqlQuery m => TransactionRId -> KeyEntry -> m EntryRId
|
||||
insertEntry t Entry {eAcnt, eCurrency, eValue, eComment, eTags} = do
|
||||
k <- insert $ EntryR t eCurrency eAcnt eComment eValue
|
||||
insertEntry t FullEntry {feEntry = Entry {eValue, eTags, eAcnt, eComment}, feCurrency} = do
|
||||
k <- insert $ EntryR t feCurrency eAcnt eComment eValue
|
||||
mapM_ (insert_ . TagRelationR k) eTags
|
||||
return k
|
||||
|
||||
resolveEntry :: (MonadInsertError m, MonadFinance m) => BalEntry -> m KeyEntry
|
||||
resolveEntry s@Entry {eAcnt, eCurrency, eValue, eTags} = do
|
||||
resolveEntry s@FullEntry {feEntry = e@Entry {eValue, eTags, eAcnt}, feCurrency} = do
|
||||
let aRes = lookupAccountKey eAcnt
|
||||
let cRes = lookupCurrencyKey eCurrency
|
||||
let cRes = lookupCurrencyKey feCurrency
|
||||
let sRes = lookupAccountSign eAcnt
|
||||
let tagRes = combineErrors $ fmap lookupTag eTags
|
||||
-- TODO correct sign here?
|
||||
|
@ -409,8 +411,6 @@ resolveEntry s@Entry {eAcnt, eCurrency, eValue, eTags} = do
|
|||
combineError (combineError3 aRes cRes sRes (,,)) tagRes $
|
||||
\(aid, cid, sign) tags ->
|
||||
s
|
||||
{ eAcnt = aid
|
||||
, eCurrency = cid
|
||||
, eValue = fromIntegral (sign2Int sign) * eValue
|
||||
, eTags = tags
|
||||
{ feCurrency = cid
|
||||
, feEntry = e {eAcnt = aid, eValue = fromIntegral (sign2Int sign) * eValue, eTags = tags}
|
||||
}
|
||||
|
|
|
@ -8,7 +8,8 @@ where
|
|||
|
||||
import Control.Monad.Except
|
||||
import Data.Csv
|
||||
import Database.Persist.Monad
|
||||
import Data.Foldable
|
||||
import Database.Persist.Monad hiding (get)
|
||||
import Internal.Database
|
||||
import Internal.Types.Main
|
||||
import Internal.Utils
|
||||
|
@ -18,6 +19,7 @@ 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
|
||||
|
@ -26,7 +28,7 @@ import qualified RIO.Vector as V
|
|||
-- :: (MonadInsertError m, MonadFinance m, MonadUnliftIO m)
|
||||
-- => FilePath
|
||||
-- -> [History]
|
||||
-- -> m [(CommitR, [RawTx])]
|
||||
-- -> m [(CommitR, [DeferredTx])]
|
||||
-- readHistory root hs = do
|
||||
-- let (ts, ss) = splitHistory hs
|
||||
-- ts' <- catMaybes <$> mapErrorsIO readHistTransfer ts
|
||||
|
@ -36,7 +38,7 @@ import qualified RIO.Vector as V
|
|||
readHistTransfer
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
=> HistTransfer
|
||||
-> m (Maybe (CommitR, [RawTx]))
|
||||
-> m (Maybe (CommitR, [DeferredTx]))
|
||||
readHistTransfer
|
||||
m@Transfer
|
||||
{ transFrom = from
|
||||
|
@ -63,11 +65,11 @@ readHistStmt
|
|||
:: (MonadUnliftIO m, MonadFinance m)
|
||||
=> FilePath
|
||||
-> Statement
|
||||
-> m (Maybe (CommitR, [RawTx]))
|
||||
-> m (Maybe (CommitR, [DeferredTx]))
|
||||
readHistStmt root i = whenHash_ CTImport i $ do
|
||||
bs <- readImport root i
|
||||
bounds <- askDBState kmStatementInterval
|
||||
return $ filter (inDaySpan bounds . txDate) bs
|
||||
return $ filter (inDaySpan bounds . dtxDate) bs
|
||||
|
||||
splitHistory :: [History] -> ([HistTransfer], [Statement])
|
||||
splitHistory = partitionEithers . fmap go
|
||||
|
@ -77,7 +79,7 @@ splitHistory = partitionEithers . fmap go
|
|||
|
||||
insertHistory
|
||||
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
|
||||
=> [(CommitR, [RawTx])]
|
||||
=> [(CommitR, [DeferredTx])]
|
||||
-> m ()
|
||||
insertHistory hs = do
|
||||
bs <- balanceTxs $ concatMap (\(c, xs) -> fmap (c,) xs) hs
|
||||
|
@ -96,30 +98,37 @@ txPair
|
|||
-> CurID
|
||||
-> Rational
|
||||
-> T.Text
|
||||
-> RawTx
|
||||
txPair day from to cur val desc = tx
|
||||
-> DeferredTx
|
||||
txPair day from to cur val desc =
|
||||
Tx
|
||||
{ dtxDescr = desc
|
||||
, dtxDate = day
|
||||
, dtxEntries =
|
||||
[ EntrySet
|
||||
{ desTotalValue = val
|
||||
, desCurrency = cur
|
||||
, desFromEntry0 = entry from
|
||||
, desToEntryBal = entry to
|
||||
, desFromEntries = []
|
||||
, desToEntries = []
|
||||
}
|
||||
]
|
||||
}
|
||||
where
|
||||
split a v =
|
||||
entry a =
|
||||
Entry
|
||||
{ eAcnt = a
|
||||
, eValue = ConstD v
|
||||
, eValue = ()
|
||||
, eComment = ""
|
||||
, eCurrency = cur
|
||||
, eTags = []
|
||||
}
|
||||
tx =
|
||||
Tx
|
||||
{ txDescr = desc
|
||||
, txDate = day
|
||||
, txEntries = [split from (-val), split to val]
|
||||
}
|
||||
|
||||
resolveTx :: (MonadInsertError m, MonadFinance m) => BalTx -> m KeyTx
|
||||
resolveTx t@Tx {txEntries = ss} =
|
||||
fmap (\kss -> t {txEntries = kss}) $ combineErrors $ fmap resolveEntry ss
|
||||
resolveTx t@Tx {dtxEntries = ss} =
|
||||
(\kss -> t {dtxEntries = kss}) <$> mapErrors resolveEntry ss
|
||||
|
||||
insertTx :: MonadSqlQuery m => CommitRId -> KeyTx -> m ()
|
||||
insertTx c Tx {txDate = d, txDescr = e, txEntries = ss} = do
|
||||
insertTx c Tx {dtxDate = d, dtxDescr = e, dtxEntries = ss} = do
|
||||
k <- insert $ TransactionR c d e
|
||||
mapM_ (insertEntry k) ss
|
||||
|
||||
|
@ -127,7 +136,7 @@ insertTx c Tx {txDate = d, txDescr = e, txEntries = ss} = do
|
|||
-- Statements
|
||||
|
||||
-- TODO this probably won't scale well (pipes?)
|
||||
readImport :: (MonadUnliftIO m, MonadFinance m) => FilePath -> Statement -> m [RawTx]
|
||||
readImport :: (MonadUnliftIO m, MonadFinance m) => FilePath -> Statement -> m [DeferredTx]
|
||||
readImport root Statement {stmtTxOpts, stmtParsers, stmtSkipLines, stmtDelim, stmtPaths} = do
|
||||
let ores = compileOptions stmtTxOpts
|
||||
let cres = combineErrors $ compileMatch <$> stmtParsers
|
||||
|
@ -175,7 +184,7 @@ parseTxRecord p TxOpts {toDate, toAmountFmt, toDesc, toAmount, toOther, toDateFm
|
|||
|
||||
-- TODO need to somehow balance temporally here (like I do in the budget for
|
||||
-- directives that "pay off" a balance)
|
||||
matchRecords :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM [RawTx]
|
||||
matchRecords :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM [DeferredTx]
|
||||
matchRecords ms rs = do
|
||||
(matched, unmatched, notfound) <- matchAll (matchPriorities ms) rs
|
||||
case (matched, unmatched, notfound) of
|
||||
|
@ -236,7 +245,7 @@ zipperSlice f x = go
|
|||
zipperMatch
|
||||
:: Unzipped MatchRe
|
||||
-> TxRecord
|
||||
-> InsertExceptT CurrencyM (Zipped MatchRe, MatchRes RawTx)
|
||||
-> InsertExceptT CurrencyM (Zipped MatchRe, MatchRes DeferredTx)
|
||||
zipperMatch (Unzipped bs cs as) x = go [] cs
|
||||
where
|
||||
go _ [] = return (Zipped bs $ cs ++ as, MatchFail)
|
||||
|
@ -252,7 +261,7 @@ zipperMatch (Unzipped bs cs as) x = go [] cs
|
|||
zipperMatch'
|
||||
:: Zipped MatchRe
|
||||
-> TxRecord
|
||||
-> InsertExceptT CurrencyM (Zipped MatchRe, MatchRes RawTx)
|
||||
-> InsertExceptT CurrencyM (Zipped MatchRe, MatchRes DeferredTx)
|
||||
zipperMatch' z x = go z
|
||||
where
|
||||
go (Zipped bs (a : as)) = do
|
||||
|
@ -269,7 +278,7 @@ matchDec m = case spTimes m of
|
|||
Just n -> Just $ m {spTimes = Just $ n - 1}
|
||||
Nothing -> Just m
|
||||
|
||||
matchAll :: [MatchGroup] -> [TxRecord] -> InsertExceptT CurrencyM ([RawTx], [TxRecord], [MatchRe])
|
||||
matchAll :: [MatchGroup] -> [TxRecord] -> InsertExceptT CurrencyM ([DeferredTx], [TxRecord], [MatchRe])
|
||||
matchAll = go ([], [])
|
||||
where
|
||||
go (matched, unused) gs rs = case (gs, rs) of
|
||||
|
@ -279,13 +288,13 @@ matchAll = go ([], [])
|
|||
(ts, unmatched, us) <- matchGroup g rs
|
||||
go (ts ++ matched, us ++ unused) gs' unmatched
|
||||
|
||||
matchGroup :: MatchGroup -> [TxRecord] -> InsertExceptT CurrencyM ([RawTx], [TxRecord], [MatchRe])
|
||||
matchGroup :: MatchGroup -> [TxRecord] -> InsertExceptT CurrencyM ([DeferredTx], [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 :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM ([RawTx], [TxRecord], [MatchRe])
|
||||
matchDates :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM ([DeferredTx], [TxRecord], [MatchRe])
|
||||
matchDates ms = go ([], [], initZipper ms)
|
||||
where
|
||||
go (matched, unmatched, z) [] =
|
||||
|
@ -306,7 +315,7 @@ matchDates ms = go ([], [], initZipper ms)
|
|||
go (m, u, z') rs
|
||||
findDate m r = maybe EQ (`compareDate` trDate r) $ spDate m
|
||||
|
||||
matchNonDates :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM ([RawTx], [TxRecord], [MatchRe])
|
||||
matchNonDates :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM ([DeferredTx], [TxRecord], [MatchRe])
|
||||
matchNonDates ms = go ([], [], initZipper ms)
|
||||
where
|
||||
go (matched, unmatched, z) [] =
|
||||
|
@ -323,63 +332,74 @@ matchNonDates ms = go ([], [], initZipper ms)
|
|||
MatchFail -> (matched, r : unmatched)
|
||||
in go (m, u, resetZipper z') rs
|
||||
|
||||
-- TDOO should use a better type here to squish down all the entry sets
|
||||
-- which at this point in the chain should not be necessary
|
||||
balanceTxs
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
=> [(CommitR, RawTx)]
|
||||
=> [(CommitR, DeferredTx)]
|
||||
-> m [(CommitR, KeyTx)]
|
||||
balanceTxs ts = do
|
||||
bs <- mapErrors balanceTx $ snd $ L.mapAccumR balanceTxTargets M.empty ts'
|
||||
return $ zip cs bs
|
||||
keyts <- mapErrors resolveTx balTs
|
||||
return $ zip cs keyts
|
||||
where
|
||||
(cs, ts') = L.unzip $ L.sortOn (txDate . snd) ts
|
||||
(cs, ts') = L.unzip $ L.sortOn (dtxDate . snd) ts
|
||||
go bals t@Tx {dtxEntries} =
|
||||
second (\es -> t {dtxEntries = concat es}) $
|
||||
L.mapAccumL balanceEntrySet bals dtxEntries
|
||||
balTs = snd $ L.mapAccumL go M.empty ts'
|
||||
|
||||
balanceTxTargets
|
||||
:: (Ord a, Ord c)
|
||||
=> M.Map (a, c) Rational
|
||||
-> Tx (Entry a (Deferred Rational) c t)
|
||||
-> (M.Map (a, c) Rational, Tx (Entry a (Maybe Rational) c t))
|
||||
balanceTxTargets bals t@Tx {txEntries} = (bals', t {txEntries = es})
|
||||
where
|
||||
(bals', es) = L.mapAccumR balanceEntryTargets bals txEntries
|
||||
type EntryBals = M.Map (AcntID, CurID) Rational
|
||||
|
||||
balanceEntryTargets
|
||||
:: (Ord a, Ord c)
|
||||
=> M.Map (a, c) Rational
|
||||
-> Entry a (Deferred Rational) c t
|
||||
-> (M.Map (a, c) Rational, Entry a (Maybe Rational) c t)
|
||||
balanceEntryTargets bals e@Entry {eValue, eAcnt, eCurrency} = (bals', e {eValue = v})
|
||||
-- TODO might be faster to also do all the key stuff here since currency
|
||||
-- will be looked up for every entry rather then the entire entry set
|
||||
balanceEntrySet :: EntryBals -> DeferredEntrySet -> (EntryBals, [BalEntry])
|
||||
balanceEntrySet
|
||||
bals
|
||||
EntrySet
|
||||
{ desFromEntry0
|
||||
, desFromEntries
|
||||
, desToEntryBal
|
||||
, desToEntries
|
||||
, desCurrency
|
||||
, desTotalValue
|
||||
} = flipTup $ runState doBalAll bals
|
||||
where
|
||||
flipTup (a, b) = (b, a)
|
||||
doEntries es tot e0 = do
|
||||
es' <- state (\b -> flipTup $ L.mapAccumL (balanceEntry desCurrency) b es)
|
||||
let val0 = tot - entrySum es'
|
||||
modify $ mapAdd_ (eAcnt e0, desCurrency) val0
|
||||
return $ e0 {eValue = val0} : es'
|
||||
doBalAll = do
|
||||
fes <- doEntries desFromEntries desTotalValue desFromEntry0
|
||||
tes <- doEntries desToEntries (-desTotalValue) desToEntryBal
|
||||
return $ toFull <$> fes ++ tes
|
||||
toFull e = FullEntry {feEntry = e, feCurrency = desCurrency}
|
||||
|
||||
entrySum :: Num v => [Entry a v t] -> v
|
||||
entrySum = sum . fmap eValue
|
||||
|
||||
balanceEntry
|
||||
:: CurID
|
||||
-> EntryBals
|
||||
-> Entry AcntID (Deferred Rational) TagID
|
||||
-> (EntryBals, Entry AcntID Rational TagID)
|
||||
balanceEntry curID bals e@Entry {eValue = Deferred toBal v, eAcnt}
|
||||
| toBal = (bals, e {eValue = v})
|
||||
| otherwise = (bals', e {eValue = newVal})
|
||||
where
|
||||
key = (eAcnt, eCurrency)
|
||||
key = (eAcnt, curID)
|
||||
curBal = M.findWithDefault 0 key bals
|
||||
v = case eValue of
|
||||
ConstD x -> Just x
|
||||
Target x -> Just $ x - curBal
|
||||
Derive -> Nothing
|
||||
bals' = maybe bals (\y -> mapAdd_ key y bals) v
|
||||
newVal = v - curBal
|
||||
bals' = mapAdd_ key newVal bals
|
||||
|
||||
balanceTx
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
=> Tx (Entry AcntID (Maybe Rational) CurID TagID)
|
||||
-> m KeyTx
|
||||
balanceTx t@Tx {txEntries = ss} = do
|
||||
bs <- liftExcept $ balanceEntries ss
|
||||
resolveTx $ t {txEntries = bs}
|
||||
|
||||
balanceEntries :: [Entry AcntID (Maybe Rational) CurID TagID] -> InsertExcept [BalEntry]
|
||||
balanceEntries ss =
|
||||
fmap concat
|
||||
<$> mapM (uncurry bal)
|
||||
$ groupByKey
|
||||
$ fmap (\s -> (eCurrency s, s)) ss
|
||||
where
|
||||
haeValue s@Entry {eValue = Just v} = Right s {eValue = v}
|
||||
haeValue s = Left s
|
||||
bal cur rss
|
||||
| length rss < 2 = throwError $ InsertException [BalanceError TooFewEntries cur rss]
|
||||
| otherwise = case partitionEithers $ fmap haeValue rss of
|
||||
([noVal], val) -> return $ noVal {eValue = foldr (\s x -> x - eValue s) 0 val} : val
|
||||
([], val) -> return val
|
||||
_ -> throwError $ InsertException [BalanceError NotOneBlank cur rss]
|
||||
|
||||
groupByKey :: Ord k => [(k, v)] -> [(k, [v])]
|
||||
groupByKey = M.toList . M.fromListWith (++) . fmap (second (: []))
|
||||
-- -- 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
|
||||
|
|
|
@ -19,7 +19,7 @@ import Language.Haskell.TH.Syntax (Lift)
|
|||
import RIO
|
||||
import qualified RIO.Map as M
|
||||
import qualified RIO.Text as T
|
||||
import RIO.Time
|
||||
-- import RIO.Time
|
||||
import Text.Regex.TDFA
|
||||
|
||||
makeHaskellTypesWith
|
||||
|
@ -32,8 +32,7 @@ makeHaskellTypesWith
|
|||
, MultipleConstructors "DatePat" "(./dhall/Types.dhall).DatePat"
|
||||
, MultipleConstructors "YMDMatcher" "(./dhall/Types.dhall).YMDMatcher"
|
||||
, MultipleConstructors "DateMatcher" "(./dhall/Types.dhall).DateMatcher"
|
||||
, MultipleConstructors "ToEntryNumGetter" "(./dhall/Types.dhall).ToEntryNumGetter"
|
||||
, MultipleConstructors "FromEntryNumGetter" "(./dhall/Types.dhall).FromEntryNumGetter"
|
||||
, MultipleConstructors "EntryNumGetter" "(./dhall/Types.dhall).EntryNumGetter"
|
||||
, MultipleConstructors "BudgetCurrency" "(./dhall/Types.dhall).BudgetCurrency"
|
||||
, MultipleConstructors "BudgetTransferType" "(./dhall/Types.dhall).BudgetTransferType"
|
||||
, MultipleConstructors "TaxMethod" "(./dhall/Types.dhall).TaxMethod"
|
||||
|
@ -98,8 +97,7 @@ deriveProduct
|
|||
, "YMDMatcher"
|
||||
, "BudgetCurrency"
|
||||
, "Exchange"
|
||||
, "FromEntryNumGetter"
|
||||
, "ToEntryNumGetter"
|
||||
, "EntryNumGetter"
|
||||
, "TemporalScope"
|
||||
, "SqlConfig"
|
||||
, "PretaxValue"
|
||||
|
@ -340,9 +338,7 @@ instance Ord DateMatcher where
|
|||
compare (On d) (In d' _) = compare d d' <> LT
|
||||
compare (In d _) (On d') = compare d d' <> GT
|
||||
|
||||
deriving instance Hashable FromEntryNumGetter
|
||||
|
||||
deriving instance Hashable ToEntryNumGetter
|
||||
deriving instance Hashable EntryNumGetter
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- top level type with fixed account tree to unroll the recursion in the dhall
|
||||
|
@ -425,28 +421,17 @@ data History
|
|||
| HistStatement !Statement
|
||||
deriving (Eq, Generic, Hashable, FromDhall)
|
||||
|
||||
type ToEntryGetter = Entry EntryAcnt (Maybe ToEntryNumGetter) EntryCur TagID
|
||||
type EntryGetter = Entry EntryAcnt EntryNumGetter TagID
|
||||
|
||||
type FromEntryGetter = Entry EntryAcnt FromEntryNumGetter EntryCur TagID
|
||||
instance FromDhall EntryGetter
|
||||
|
||||
instance FromDhall ToEntryGetter
|
||||
deriving instance (Show a, Show v, Show t) => Show (Entry a v t)
|
||||
|
||||
instance FromDhall FromEntryGetter
|
||||
deriving instance Generic (Entry a v t)
|
||||
|
||||
deriving instance (Show a, Show c, Show v, Show t) => Show (Entry a v c t)
|
||||
deriving instance (Hashable a, Hashable v, Hashable t) => Hashable (Entry a v t)
|
||||
|
||||
deriving instance Generic (Entry a v c t)
|
||||
|
||||
deriving instance (Hashable a, Hashable v, Hashable c, Hashable t) => Hashable (Entry a v c t)
|
||||
|
||||
deriving instance (Eq a, Eq v, Eq c, Eq t) => Eq (Entry a v c t)
|
||||
|
||||
data Tx s = Tx
|
||||
{ txDescr :: !T.Text
|
||||
, txDate :: !Day
|
||||
, txEntries :: ![s]
|
||||
}
|
||||
deriving (Generic)
|
||||
deriving instance (Eq a, Eq v, Eq t) => Eq (Entry a v t)
|
||||
|
||||
data TxOpts re = TxOpts
|
||||
{ toDate :: !T.Text
|
||||
|
@ -507,11 +492,23 @@ data FieldMatcher re
|
|||
|
||||
deriving instance Show (FieldMatcher T.Text)
|
||||
|
||||
data TxSubGetter = TxSubGetter
|
||||
{ tsgFromAcnt :: !EntryAcnt
|
||||
, tsgToAcnt :: !EntryAcnt
|
||||
, tsgValue :: !EntryNumGetter
|
||||
, tsgCurrency :: !EntryCur
|
||||
, tsgFromEntries :: ![EntryGetter]
|
||||
, tsgToEntries :: ![EntryGetter]
|
||||
}
|
||||
deriving (Eq, Generic, Hashable, Show, FromDhall)
|
||||
|
||||
data TxGetter = TxGetter
|
||||
{ tgFromAcnt :: !EntryAcnt
|
||||
, tgFromCurrency :: !EntryCur
|
||||
, tgFromEntries :: ![FromEntryGetter]
|
||||
, tgToEntries :: ![ToEntryGetter]
|
||||
, tgToAcnt :: !EntryAcnt
|
||||
, tgCurrency :: !EntryCur
|
||||
, tgFromEntries :: ![EntryGetter]
|
||||
, tgToEntries :: ![EntryGetter]
|
||||
, tgOtherEntries :: ![TxSubGetter]
|
||||
}
|
||||
deriving (Eq, Generic, Hashable, Show, FromDhall)
|
||||
|
||||
|
|
|
@ -59,13 +59,20 @@ data DBUpdates = DBUpdates
|
|||
|
||||
type CurrencyM = Reader CurrencyMap
|
||||
|
||||
type DeferredKeyEntry = Entry AccountRId (Deferred Rational) CurrencyRId TagRId
|
||||
-- type DeferredKeyEntry = Entry AccountRId (Deferred Rational) CurrencyRId TagRId
|
||||
|
||||
type KeyEntry = Entry AccountRId Rational CurrencyRId TagRId
|
||||
data FullEntry a c t = FullEntry
|
||||
{ feCurrency :: !c
|
||||
, feEntry :: !(Entry a Rational t)
|
||||
}
|
||||
|
||||
type DeferredKeyTx = Tx DeferredKeyEntry
|
||||
type KeyEntry = FullEntry AccountRId CurrencyRId TagRId
|
||||
|
||||
type KeyTx = Tx KeyEntry
|
||||
type BalEntry = FullEntry AcntID CurID TagID
|
||||
|
||||
-- type DeferredKeyTx = Tx DeferredKeyEntry
|
||||
|
||||
-- type KeyTx = Tx KeyEntry
|
||||
|
||||
type TreeR = Tree ([T.Text], AccountRId)
|
||||
|
||||
|
@ -131,18 +138,46 @@ accountSign IncomeT = Credit
|
|||
accountSign LiabilityT = Credit
|
||||
accountSign EquityT = Credit
|
||||
|
||||
data Deferred a = ConstD a | Target a | Derive
|
||||
data EntrySet a c t v = EntrySet
|
||||
{ desTotalValue :: !Rational
|
||||
, desCurrency :: !c
|
||||
, desFromEntry0 :: !(Entry a () t)
|
||||
, desFromEntries :: ![Entry a v t]
|
||||
, desToEntries :: ![Entry a v t]
|
||||
, desToEntryBal :: !(Entry a () t)
|
||||
}
|
||||
|
||||
data Tx e = Tx
|
||||
{ dtxDescr :: !T.Text
|
||||
, dtxDate :: !Day
|
||||
, dtxEntries :: !e
|
||||
}
|
||||
deriving (Generic)
|
||||
|
||||
type DeferredEntrySet = EntrySet AcntID CurID TagID (Deferred Rational)
|
||||
|
||||
type BalEntrySet = EntrySet AcntID CurID TagID Rational
|
||||
|
||||
type KeyEntrySet = EntrySet AccountRId CurrencyRId TagRId Rational
|
||||
|
||||
type DeferredTx = Tx [DeferredEntrySet]
|
||||
|
||||
type BalTx = Tx [BalEntry]
|
||||
|
||||
type KeyTx = Tx [KeyEntry]
|
||||
|
||||
data Deferred a = Deferred Bool a
|
||||
deriving (Show, Functor, Foldable, Traversable)
|
||||
|
||||
type RawEntry = Entry AcntID (Deferred Rational) CurID TagID
|
||||
-- type RawEntry = Entry AcntID (Deferred Rational) CurID TagID
|
||||
|
||||
-- type RawFromEntry = Entry AcntID (Deferred Rational) CurID TagID
|
||||
|
||||
type BalEntry = Entry AcntID Rational CurID TagID
|
||||
-- type BalEntry = Entry AcntID Rational CurID TagID
|
||||
|
||||
type RawTx = Tx RawEntry
|
||||
-- type RawTx = Tx RawEntry
|
||||
|
||||
type BalTx = Tx BalEntry
|
||||
-- type BalTx = Tx BalEntry
|
||||
|
||||
data MatchRes a = MatchPass !a | MatchFail | MatchSkip
|
||||
|
||||
|
@ -179,8 +214,8 @@ data InsertError
|
|||
| ParseError !T.Text
|
||||
| ConversionError !T.Text
|
||||
| LookupError !LookupSuberr !T.Text
|
||||
| BalanceError !BalanceType !CurID ![Entry AcntID (Maybe Rational) CurID TagID]
|
||||
| IncomeError !Day !T.Text !Rational
|
||||
| -- | BalanceError !BalanceType !CurID ![Entry AcntID (Maybe Rational) CurID TagID]
|
||||
IncomeError !Day !T.Text !Rational
|
||||
| PatternError !Natural !Natural !(Maybe Natural) !PatternSuberr
|
||||
| DaySpanError !Gregorian !(Maybe Gregorian)
|
||||
| StatementError ![TxRecord] ![MatchRe]
|
||||
|
|
|
@ -290,7 +290,7 @@ toDaySpan (a, b) = (a, fromIntegral $ diffDays b a - 1)
|
|||
--------------------------------------------------------------------------------
|
||||
-- matching
|
||||
|
||||
matches :: MatchRe -> TxRecord -> InsertExceptT CurrencyM (MatchRes RawTx)
|
||||
matches :: MatchRe -> TxRecord -> InsertExceptT CurrencyM (MatchRes DeferredTx)
|
||||
matches
|
||||
StatementParser {spTx, spOther, spVal, spDate, spDesc}
|
||||
r@TxRecord {trDate, trAmount, trDesc, trOther} = do
|
||||
|
@ -305,39 +305,108 @@ matches
|
|||
date = maybe True (`dateMatches` trDate) spDate
|
||||
other = foldM (\a o -> (a &&) <$> otherMatches trOther o) True spOther
|
||||
desc = maybe (return True) (matchMaybe trDesc . snd) spDesc
|
||||
convert TxGetter {tgFromAcnt, tgFromCurrency, tgFromEntries, tgToEntries} =
|
||||
MatchPass <$> toTx tgFromCurrency tgFromAcnt tgFromEntries tgToEntries r
|
||||
convert tg = MatchPass <$> toTx tg r
|
||||
|
||||
toTx :: TxGetter -> TxRecord -> InsertExceptT CurrencyM DeferredTx
|
||||
toTx
|
||||
:: EntryCur
|
||||
-> EntryAcnt
|
||||
-> [FromEntryGetter]
|
||||
-> [ToEntryGetter]
|
||||
-> TxRecord
|
||||
-> InsertExceptT CurrencyM RawTx
|
||||
toTx sc sa fromEntries toEntries r@TxRecord {trAmount, trDate, trDesc} = do
|
||||
combineError
|
||||
(combineError acntRes curRes (,))
|
||||
(combineError fromRes toRes (,))
|
||||
$ \(a, c) (fs, ts) ->
|
||||
TxGetter {tgFromAcnt, tgToAcnt, tgCurrency, tgFromEntries, tgToEntries, tgOtherEntries}
|
||||
r@TxRecord {trAmount, trDate, trDesc} = do
|
||||
combineError3 acntRes curRes subRes $ \(fa, ta) (cur, fe, te) ss -> do
|
||||
let fromEntry =
|
||||
Entry
|
||||
{ eAcnt = a
|
||||
, eCurrency = c
|
||||
, eValue = ConstD trAmount
|
||||
{ eAcnt = fa
|
||||
, eValue = ()
|
||||
, eComment = "" -- TODO actually fill this in
|
||||
, eTags = [] -- TODO what goes here?
|
||||
}
|
||||
toEntry =
|
||||
Entry
|
||||
{ eAcnt = ta
|
||||
, eValue = ()
|
||||
, eComment = ""
|
||||
, eTags = []
|
||||
}
|
||||
in Tx
|
||||
{ txDate = trDate
|
||||
, txDescr = trDesc
|
||||
, txEntries = fromEntry : fs ++ ts
|
||||
{ dtxDate = trDate
|
||||
, dtxDescr = trDesc
|
||||
, dtxEntries =
|
||||
EntrySet
|
||||
{ desTotalValue = trAmount
|
||||
, desCurrency = cur
|
||||
, desFromEntry0 = fromEntry
|
||||
, desFromEntries = fe
|
||||
, desToEntries = te
|
||||
, desToEntryBal = toEntry
|
||||
}
|
||||
: ss
|
||||
}
|
||||
where
|
||||
acntRes = liftInner $ resolveAcnt r sa
|
||||
curRes = liftInner $ resolveCurrency r sc
|
||||
fromRes = combineErrors $ fmap (resolveFromEntry r) fromEntries
|
||||
toRes = combineErrors $ fmap (resolveToEntry r) toEntries
|
||||
where
|
||||
resolveAcnt_ = liftInner . resolveAcnt r
|
||||
acntRes =
|
||||
combineError
|
||||
(resolveAcnt_ tgFromAcnt)
|
||||
(resolveAcnt_ tgToAcnt)
|
||||
(,)
|
||||
curRes = do
|
||||
cur <- liftInner $ resolveCurrency r tgCurrency
|
||||
let feRes = mapErrors (resolveEntry cur r) tgFromEntries
|
||||
let teRes = mapErrors (resolveEntry cur r) tgToEntries
|
||||
combineError feRes teRes (cur,,)
|
||||
subRes = mapErrors (resolveSubGetter r) tgOtherEntries
|
||||
|
||||
resolveSubGetter
|
||||
:: TxRecord
|
||||
-> TxSubGetter
|
||||
-> InsertExceptT CurrencyM DeferredEntrySet
|
||||
resolveSubGetter
|
||||
r
|
||||
TxSubGetter
|
||||
{ tsgFromAcnt
|
||||
, tsgToAcnt
|
||||
, tsgValue
|
||||
, tsgCurrency
|
||||
, tsgFromEntries
|
||||
, tsgToEntries
|
||||
} = combineErrorM acntRes curRes $ \(fa, ta) (cur, fe, te) ->
|
||||
do
|
||||
m <- ask
|
||||
-- TODO laaaaame...
|
||||
(Deferred _ val) <- liftInner $ mapM (roundPrecisionCur cur m) =<< resolveValue r tsgValue
|
||||
let fromEntry =
|
||||
Entry
|
||||
{ eAcnt = fa
|
||||
, eValue = ()
|
||||
, eComment = "" -- TODO actually fill this in
|
||||
, eTags = [] -- TODO what goes here?
|
||||
}
|
||||
let toEntry =
|
||||
Entry
|
||||
{ eAcnt = ta
|
||||
, eValue = ()
|
||||
, eComment = ""
|
||||
, eTags = []
|
||||
}
|
||||
return
|
||||
EntrySet
|
||||
{ desTotalValue = val
|
||||
, desCurrency = cur
|
||||
, desFromEntry0 = fromEntry
|
||||
, desFromEntries = fe
|
||||
, desToEntries = te
|
||||
, desToEntryBal = toEntry
|
||||
}
|
||||
where
|
||||
resolveAcnt_ = liftInner . resolveAcnt r
|
||||
acntRes =
|
||||
combineError
|
||||
(resolveAcnt_ tsgFromAcnt)
|
||||
(resolveAcnt_ tsgToAcnt)
|
||||
(,)
|
||||
curRes = do
|
||||
cur <- liftInner $ resolveCurrency r tsgCurrency
|
||||
let feRes = mapErrors (resolveEntry cur r) tsgFromEntries
|
||||
let teRes = mapErrors (resolveEntry cur r) tsgToEntries
|
||||
combineError feRes teRes (cur,,)
|
||||
|
||||
valMatches :: ValMatcher -> Rational -> InsertExcept Bool
|
||||
valMatches ValMatcher {vmDen, vmSign, vmNum, vmPrec} x
|
||||
|
@ -363,28 +432,34 @@ otherMatches dict m = case m of
|
|||
where
|
||||
lookup_ t n = lookupErr (MatchField t) n dict
|
||||
|
||||
resolveFromEntry :: TxRecord -> FromEntryGetter -> InsertExceptT CurrencyM RawEntry
|
||||
resolveFromEntry r s@Entry {eAcnt, eValue, eCurrency} = do
|
||||
-- TODO this should be more general?
|
||||
resolveEntry
|
||||
:: CurID
|
||||
-> TxRecord
|
||||
-> EntryGetter
|
||||
-> InsertExceptT CurrencyM (Entry AcntID (Deferred Rational) TagID)
|
||||
resolveEntry cur r s@Entry {eAcnt, eValue} = do
|
||||
m <- ask
|
||||
liftInner $ combineErrorM3 acntRes curRes valRes $ \a c v -> do
|
||||
v' <- mapM (roundPrecisionCur c m) v
|
||||
return $ s {eAcnt = a, eValue = v', eCurrency = c}
|
||||
liftInner $ combineErrorM acntRes valRes $ \a v -> do
|
||||
v' <- mapM (roundPrecisionCur cur m) v
|
||||
return $ s {eAcnt = a, eValue = v'}
|
||||
where
|
||||
acntRes = resolveAcnt r eAcnt
|
||||
curRes = resolveCurrency r eCurrency
|
||||
valRes = resolveFromValue r eValue
|
||||
valRes = resolveValue r eValue
|
||||
|
||||
-- TODO wet code (kinda, not sure if it's worth combining with above)
|
||||
resolveToEntry :: TxRecord -> ToEntryGetter -> InsertExceptT CurrencyM RawEntry
|
||||
resolveToEntry r s@Entry {eAcnt, eValue, eCurrency} = do
|
||||
m <- ask
|
||||
liftInner $ combineErrorM3 acntRes curRes valRes $ \a c v -> do
|
||||
v' <- mapM (roundPrecisionCur c m) v
|
||||
return $ s {eAcnt = a, eValue = maybe Derive Target v', eCurrency = c}
|
||||
where
|
||||
acntRes = resolveAcnt r eAcnt
|
||||
curRes = resolveCurrency r eCurrency
|
||||
valRes = mapM (resolveToValue r) eValue
|
||||
-- curRes = resolveCurrency r eCurrency
|
||||
|
||||
-- -- TODO wet code (kinda, not sure if it's worth combining with above)
|
||||
-- resolveToEntry :: TxRecord -> EntryGetter -> InsertExceptT CurrencyM RawEntry
|
||||
-- resolveToEntry r s@Entry {eAcnt, eValue, eCurrency} = do
|
||||
-- m <- ask
|
||||
-- liftInner $ combineErrorM3 acntRes curRes valRes $ \a c v -> do
|
||||
-- v' <- mapM (roundPrecisionCur c m) v
|
||||
-- return $ s {eAcnt = a, eValue = maybe Derive (ConstD False) v', eCurrency = c}
|
||||
-- where
|
||||
-- acntRes = resolveAcnt r eAcnt
|
||||
-- curRes = resolveCurrency r eCurrency
|
||||
-- valRes = mapM (resolveToValue r) eValue
|
||||
|
||||
liftInner :: Monad m => ExceptT e Identity a -> ExceptT e m a
|
||||
liftInner = mapExceptT (return . runIdentity)
|
||||
|
@ -428,17 +503,28 @@ combineErrorM3 :: MonadError InsertException m => m a -> m b -> m c -> (a -> b -
|
|||
combineErrorM3 a b c f = do
|
||||
combineErrorM (combineErrorM a b (curry return)) c $ \(x, y) z -> f x y z
|
||||
|
||||
combineErrors :: MonadError InsertException m => [m a] -> m [a]
|
||||
mapErrors
|
||||
:: (Traversable t, MonadError InsertException m)
|
||||
=> (a -> m b)
|
||||
-> t a
|
||||
-> m (t b)
|
||||
-- First, record number of each action. Then try each action. On first failure,
|
||||
-- note it's position in the sequence, skip ahead to the untried actions,
|
||||
-- collect failures and add to the first failure.
|
||||
mapErrors f xs = mapM go $ enumTraversable xs
|
||||
where
|
||||
go (n, x) = catchError (f x) $ \e -> do
|
||||
es <- fmap catMaybes $ mapM (err . f) $ drop (n + 1) $ toList xs
|
||||
throwError $ foldr (<>) e es
|
||||
err x = catchError (Nothing <$ x) (pure . Just)
|
||||
|
||||
combineErrors :: (Traversable t, MonadError InsertException m) => t (m a) -> m (t a)
|
||||
combineErrors = mapErrors id
|
||||
|
||||
mapErrors :: MonadError InsertException m => (a -> m b) -> [a] -> m [b]
|
||||
mapErrors f xs = do
|
||||
ys <- mapM (go . f) xs
|
||||
case partitionEithers ys of
|
||||
([], zs) -> return zs
|
||||
(e : es, _) -> throwError $ foldr (<>) e es
|
||||
enumTraversable :: (Num n, Traversable t) => t a -> t (n, a)
|
||||
enumTraversable = snd . L.mapAccumL go 0
|
||||
where
|
||||
go x = catchError (Right <$> x) (pure . Left)
|
||||
go n x = (n + 1, (n, x))
|
||||
|
||||
combineErrorIO2 :: MonadUnliftIO m => m a -> m b -> (a -> b -> c) -> m c
|
||||
combineErrorIO2 a b f = combineErrorIOM2 a b (\x y -> pure $ f x y)
|
||||
|
@ -457,31 +543,30 @@ combineErrorIOM3 :: MonadUnliftIO m => m a -> m b -> m c -> (a -> b -> c -> m d)
|
|||
combineErrorIOM3 a b c f =
|
||||
combineErrorIOM2 (combineErrorIOM2 a b (curry return)) c $ \(x, y) z -> f x y z
|
||||
|
||||
mapErrorsIO :: MonadUnliftIO m => (a -> m b) -> [a] -> m [b]
|
||||
mapErrorsIO f xs = do
|
||||
ys <- mapM (go . f) xs
|
||||
case partitionEithers ys of
|
||||
([], zs) -> return zs
|
||||
(es, _) -> throwIO $ InsertException $ concat es
|
||||
mapErrorsIO :: (Traversable t, MonadUnliftIO m) => (a -> m b) -> t a -> m (t b)
|
||||
mapErrorsIO f xs = mapM go $ enumTraversable xs
|
||||
where
|
||||
go x = catch (Right <$> x) $ \(InsertException es) -> pure $ Left es
|
||||
go (n, x) = catch (f x) $ \(InsertException e) -> do
|
||||
es <- fmap catMaybes $ mapM (err . f) $ drop (n + 1) $ toList xs
|
||||
throwIO $ InsertException $ foldr (<>) e es
|
||||
err x = catch (Nothing <$ x) $ \(InsertException es) -> pure $ Just es
|
||||
|
||||
collectErrorsIO :: MonadUnliftIO m => [m a] -> m [a]
|
||||
collectErrorsIO :: (Traversable t, MonadUnliftIO m) => t (m a) -> m (t a)
|
||||
collectErrorsIO = mapErrorsIO id
|
||||
|
||||
resolveFromValue :: TxRecord -> FromEntryNumGetter -> InsertExcept (Deferred Double)
|
||||
resolveFromValue TxRecord {trOther, trAmount} s = case s of
|
||||
(FLookupN t) -> ConstD <$> (readDouble =<< lookupErr EntryValField t trOther)
|
||||
(FConstN c) -> return $ ConstD c
|
||||
FAmountN m -> return $ ConstD $ (* m) $ fromRational trAmount
|
||||
FBalanceN x -> return $ Target x
|
||||
resolveValue :: TxRecord -> EntryNumGetter -> InsertExcept (Deferred Double)
|
||||
resolveValue TxRecord {trOther, trAmount} s = case s of
|
||||
(LookupN t) -> Deferred False <$> (readDouble =<< lookupErr EntryValField t trOther)
|
||||
(ConstN c) -> return $ Deferred False c
|
||||
AmountN m -> return $ Deferred False $ (* m) $ fromRational trAmount
|
||||
BalanceN x -> return $ Deferred True x
|
||||
|
||||
-- TODO not DRY
|
||||
resolveToValue :: TxRecord -> ToEntryNumGetter -> InsertExcept Double
|
||||
resolveToValue TxRecord {trOther, trAmount} s = case s of
|
||||
(TLookupN t) -> readDouble =<< lookupErr EntryValField t trOther
|
||||
(TConstN c) -> return c
|
||||
TAmountN m -> return $ (* m) $ fromRational trAmount
|
||||
-- -- TODO not DRY
|
||||
-- resolveToValue :: TxRecord -> ToEntryNumGetter -> InsertExcept Double
|
||||
-- resolveToValue TxRecord {trOther, trAmount} s = case s of
|
||||
-- (TLookupN t) -> readDouble =<< lookupErr EntryValField t trOther
|
||||
-- (TConstN c) -> return c
|
||||
-- TAmountN m -> return $ (* m) $ fromRational trAmount
|
||||
|
||||
resolveAcnt :: TxRecord -> EntryAcnt -> InsertExcept T.Text
|
||||
resolveAcnt = resolveEntryField AcntField
|
||||
|
@ -656,20 +741,6 @@ showError other = case other of
|
|||
, singleQuote $ showT next
|
||||
]
|
||||
]
|
||||
(BalanceError t cur rss) ->
|
||||
[ T.unwords
|
||||
[ msg
|
||||
, "for currency"
|
||||
, singleQuote cur
|
||||
, "and for entries"
|
||||
, entries
|
||||
]
|
||||
]
|
||||
where
|
||||
msg = case t of
|
||||
TooFewEntries -> "Need at least two entries to balance"
|
||||
NotOneBlank -> "Exactly one entries must be blank"
|
||||
entries = T.intercalate ", " $ fmap (singleQuote . showEntry) rss
|
||||
|
||||
showGregorian_ :: Gregorian -> T.Text
|
||||
showGregorian_ Gregorian {gYear, gMonth, gDay} = T.intercalate "-" $ showT <$> [gYear, gMonth, gDay]
|
||||
|
@ -757,14 +828,6 @@ showMatchOther (Val (Field f mv)) =
|
|||
, singleQuote $ fromMaybe "*" $ showValMatcher mv
|
||||
]
|
||||
|
||||
showEntry :: Entry AcntID (Maybe Rational) CurID TagID -> T.Text
|
||||
showEntry Entry {eAcnt, eValue, eComment} =
|
||||
keyVals
|
||||
[ ("account", eAcnt)
|
||||
, ("value", T.pack $ show ((fromRational <$> eValue) :: Maybe Float))
|
||||
, ("comment", doubleQuote eComment)
|
||||
]
|
||||
|
||||
singleQuote :: T.Text -> T.Text
|
||||
singleQuote t = T.concat ["'", t, "'"]
|
||||
|
||||
|
@ -856,6 +919,11 @@ unlessLefts_ e f = unlessLefts e (\x -> void (f x) >> return mzero)
|
|||
-- thrice :: (a -> d) -> (b -> e) -> (c -> f) -> (a, b, c) -> (d, e, f)
|
||||
-- thrice f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z)
|
||||
|
||||
-- groupKey :: Ord c => (a -> c) -> [(a, b)] -> [(a, [b])]
|
||||
-- groupKey f = fmap go . NE.groupAllWith (f . fst)
|
||||
-- where
|
||||
-- go xs@((c, _) :| _) = (c, NE.toList $ fmap snd xs)
|
||||
|
||||
mapAdd_ :: (Ord k, Num v) => k -> v -> M.Map k v -> M.Map k v
|
||||
mapAdd_ k v = M.alter (maybe (Just v) (Just . (+ v))) k
|
||||
|
||||
|
|
Loading…
Reference in New Issue