REF split history and budget

This commit is contained in:
Nathan Dwarshuis 2023-05-29 15:56:15 -04:00
parent 02747b4678
commit 62b39b61aa
7 changed files with 603 additions and 590 deletions

View File

@ -8,9 +8,10 @@ import Control.Monad.Logger
import Control.Monad.Reader
import qualified Data.Text.IO as TI
import Database.Persist.Monad
import Internal.Budget
import Internal.Config
import Internal.Database.Ops
import Internal.Insert
import Internal.History
import Internal.Types.Main
import Internal.Utils
import Options.Applicative

View File

@ -25,9 +25,10 @@ source-repository head
library
exposed-modules:
Internal.Budget
Internal.Config
Internal.Database.Ops
Internal.Insert
Internal.History
Internal.Statement
Internal.Types.Database
Internal.Types.Dhall

View File

@ -1,16 +1,8 @@
module Internal.Insert
( insertBudget
, splitHistory
, insertHistTransfer
, readHistStmt
, insertHistStmt
)
where
module Internal.Budget (insertBudget) where
import Control.Monad.Except
import Data.Hashable
import Database.Persist.Monad
import Internal.Statement
import Internal.Database.Ops
import Internal.Types.Main
import Internal.Utils
import RIO hiding (to)
@ -20,132 +12,6 @@ import qualified RIO.NonEmpty as NE
import qualified RIO.Text as T
import RIO.Time
--------------------------------------------------------------------------------
-- intervals
expandDatePat :: Bounds -> DatePat -> InsertExcept [Day]
expandDatePat b (Cron cp) = expandCronPat b cp
expandDatePat i (Mod mp) = return $ expandModPat mp i
expandModPat :: ModPat -> Bounds -> [Day]
expandModPat ModPat {mpStart = s, mpBy = b, mpUnit = u, mpRepeats = r} bs =
takeWhile (<= upper) $
(`addFun` start) . (* b')
<$> maybe id (take . fromIntegral) r [0 ..]
where
(lower, upper) = expandBounds bs
start = maybe lower fromGregorian' s
b' = fromIntegral b
addFun = case u of
Day -> addDays
Week -> addDays . (* 7)
Month -> addGregorianMonthsClip
Year -> addGregorianYearsClip
expandCronPat :: Bounds -> CronPat -> InsertExcept [Day]
expandCronPat b CronPat {cpYear, cpMonth, cpDay, cpWeekly} =
combineError3 yRes mRes dRes $ \ys ms ds ->
filter validWeekday $
mapMaybe (uncurry3 toDay) $
takeWhile (\((y, _), m, d) -> (y, m, d) <= (yb1, mb1, db1)) $
dropWhile (\((y, _), m, d) -> (y, m, d) < (yb0, mb0, db0)) $
[(y, m, d) | y <- (\y -> (y, isLeapYear y)) <$> ys, m <- ms, d <- ds]
where
yRes = case cpYear of
Nothing -> return [yb0 .. yb1]
Just pat -> do
ys <- expandMDYPat (fromIntegral yb0) (fromIntegral yb1) pat
return $ dropWhile (< yb0) $ fromIntegral <$> ys
mRes = expandMD 12 cpMonth
dRes = expandMD 31 cpDay
(s, e) = expandBounds b
(yb0, mb0, db0) = toGregorian s
(yb1, mb1, db1) = toGregorian $ addDays (-1) e
expandMD lim =
fmap (fromIntegral <$>)
. maybe (return [1 .. lim]) (expandMDYPat 1 lim)
expandW (OnDay x) = [fromEnum x]
expandW (OnDays xs) = fromEnum <$> xs
ws = maybe [] expandW cpWeekly
validWeekday = if null ws then const True else \day -> dayToWeekday day `elem` ws
toDay (y, leap) m d
| m == 2 && (not leap && d > 28 || leap && d > 29) = Nothing
| m `elem` [4, 6, 9, 11] && d > 30 = Nothing
| otherwise = Just $ fromGregorian y m d
expandMDYPat :: Natural -> Natural -> MDYPat -> InsertExcept [Natural]
expandMDYPat lower upper (Single x) = return [x | lower <= x && x <= upper]
expandMDYPat lower upper (Multi xs) = return $ dropWhile (<= lower) $ takeWhile (<= upper) xs
expandMDYPat lower upper (After x) = return [max lower x .. upper]
expandMDYPat lower upper (Before x) = return [lower .. min upper x]
expandMDYPat lower upper (Between x y) = return [max lower x .. min upper y]
expandMDYPat lower upper (Repeat RepeatPat {rpStart = s, rpBy = b, rpRepeats = r})
| b < 1 = throwError $ InsertException [PatternError s b r ZeroLength]
| otherwise = do
k <- limit r
return $ dropWhile (<= lower) $ takeWhile (<= k) [s + i * b | i <- [0 ..]]
where
limit Nothing = return upper
limit (Just n)
-- this guard not only produces the error for the user but also protects
-- from an underflow below it
| n < 1 = throwError $ InsertException [PatternError s b r ZeroRepeats]
| otherwise = return $ min (s + b * (n - 1)) upper
dayToWeekday :: Day -> Int
dayToWeekday (ModifiedJulianDay d) = mod (fromIntegral d + 2) 7
askDays
:: (MonadFinance m, MonadInsertError m)
=> DatePat
-> Maybe Interval
-> m [Day]
askDays dp i = do
globalBounds <- askDBState kmBudgetInterval
case i of
Just i' -> do
localBounds <- liftExcept $ resolveBounds i'
let bounds = intersectBounds globalBounds localBounds
maybe (return []) expand bounds
Nothing -> expand globalBounds
where
expand bs = liftExcept $ expandDatePat bs dp
withDates
:: (MonadSqlQuery m, MonadFinance m, MonadInsertError m)
=> DatePat
-> (Day -> m a)
-> m [a]
withDates dp f = do
bounds <- askDBState kmBudgetInterval
days <- liftExcept $ expandDatePat bounds dp
combineErrors $ fmap f days
foldDays
:: MonadInsertError m
=> (Day -> Day -> m a)
-> Day
-> [Day]
-> m [a]
foldDays f start days =
combineErrors $
snd $
L.mapAccumL (\prevDay day -> (day, f prevDay day)) start days
--------------------------------------------------------------------------------
-- budget
-- each budget (designated at the top level by a 'name') is processed in the
-- following steps
-- 1. expand all transactions given the desired date range and date patterns for
-- each directive in the budget
-- 2. sort all transactions by date
-- 3. propagate all balances forward, and while doing so assign values to each
-- transaction (some of which depend on the 'current' balance of the
-- target account)
-- 4. assign shadow transactions (TODO)
-- 5. insert all transactions
insertBudget
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
=> Budget
@ -175,75 +41,6 @@ insertBudget
post_ = sortAllos bgtPosttax
sortAllos = liftExcept . combineErrors . fmap sortAllo
type BoundAllocation = Allocation Bounds
type IntAllocations =
( [BoundAllocation PretaxValue]
, [BoundAllocation TaxValue]
, [BoundAllocation PosttaxValue]
)
-- TODO this should actually error if there is no ultimate end date?
sortAllo :: MultiAllocation v -> InsertExcept (BoundAllocation v)
sortAllo a@Allocation {alloAmts = as} = do
bs <- foldBounds [] $ L.sortOn amtWhen as
return $ a {alloAmts = reverse bs}
where
foldBounds acc [] = return acc
foldBounds acc (x : xs) = do
let start = amtWhen x
res <- case xs of
[] -> resolveBounds start
(y : _) -> resolveBounds_ (intStart $ amtWhen y) start
foldBounds (x {amtWhen = res} : acc) xs
-- TODO this is going to be O(n*m), which might be a problem?
addShadowTransfers
:: CurrencyMap
-> [ShadowTransfer]
-> [UnbalancedTransfer]
-> InsertExcept [UnbalancedTransfer]
addShadowTransfers cm ms txs =
fmap catMaybes $
combineErrors $
fmap (uncurry (fromShadow cm)) $
[(t, m) | t <- txs, m <- ms]
fromShadow
:: CurrencyMap
-> UnbalancedTransfer
-> ShadowTransfer
-> InsertExcept (Maybe UnbalancedTransfer)
fromShadow cm tx t@ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stType} = do
res <- shadowMatches (stMatch t) tx
v <- roundPrecisionCur (initialCurrency stCurrency) cm stRatio
return $
if not res
then Nothing
else
Just $
FlatTransfer
{ ftMeta = ftMeta tx
, ftWhen = ftWhen tx
, ftCur = stCurrency
, ftFrom = stFrom
, ftTo = stTo
, ftValue = UnbalancedValue stType $ v * cvValue (ftValue tx)
, ftDesc = stDesc
}
shadowMatches :: TransferMatcher -> UnbalancedTransfer -> InsertExcept Bool
shadowMatches TransferMatcher {tmFrom, tmTo, tmDate, tmVal} tx = do
valRes <- valMatches tmVal $ cvValue $ ftValue tx
return $
memberMaybe (taAcnt $ ftFrom tx) tmFrom
&& memberMaybe (taAcnt $ ftTo tx) tmTo
&& maybe True (`dateMatches` ftWhen tx) tmDate
&& valRes
where
memberMaybe x AcntSet {asList, asInclude} =
(if asInclude then id else not) $ x `elem` asList
balanceTransfers :: [UnbalancedTransfer] -> [BalancedTransfer]
balanceTransfers = snd . L.mapAccumR go M.empty . reverse . L.sortOn ftWhen
where
@ -259,35 +56,71 @@ balanceTransfers = snd . L.mapAccumR go M.empty . reverse . L.sortOn ftWhen
amtToMove bal BTPercent x = -(x / 100 * bal)
amtToMove bal BTTarget x = x - bal
-- TODO this seems too general for this module
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
data BudgetMeta = BudgetMeta
{ bmCommit :: !CommitRId
, bmName :: !T.Text
}
deriving (Show)
insertBudgetTx
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
=> BalancedTransfer
-> m ()
insertBudgetTx FlatTransfer {ftFrom, ftTo, ftMeta, ftCur, ftValue, ftDesc, ftWhen} = do
((sFrom, sTo), exchange) <- entryPair ftFrom ftTo ftCur ftValue
insertPair sFrom sTo
forM_ exchange $ uncurry insertPair
where
insertPair from to = do
k <- insert $ TransactionR (bmCommit ftMeta) ftWhen ftDesc
insertBudgetLabel k from
insertBudgetLabel k to
insertBudgetLabel k split = do
sk <- insertSplit k split
insert_ $ BudgetLabelR sk $ bmName ftMeta
data FlatTransfer v = FlatTransfer
{ ftFrom :: !TaggedAcnt
, ftTo :: !TaggedAcnt
, ftValue :: !v
, ftWhen :: !Day
, ftDesc :: !T.Text
, ftMeta :: !BudgetMeta
, ftCur :: !BudgetCurrency
}
deriving (Show)
entryPair
:: (MonadInsertError m, MonadFinance m)
=> TaggedAcnt
-> TaggedAcnt
-> BudgetCurrency
-> Rational
-> m (SplitPair, Maybe SplitPair)
entryPair from to cur val = case cur of
NoX curid -> (,Nothing) <$> pair curid from to val
X Exchange {xFromCur, xToCur, xAcnt, xRate} -> do
let middle = TaggedAcnt xAcnt []
let res1 = pair xFromCur from middle val
let res2 = pair xToCur middle to (val * roundPrecision 3 xRate)
combineError res1 res2 $ \a b -> (a, Just b)
where
pair curid from_ to_ v = do
let s1 = split curid from_ (-v)
let s2 = split curid to_ v
combineError s1 s2 (,)
split c TaggedAcnt {taAcnt, taTags} v =
resolveSplit $
Entry
{ eAcnt = taAcnt
, eValue = v
, eComment = ""
, eCurrency = c
, eTags = taTags
}
data UnbalancedValue = UnbalancedValue
{ cvType :: !BudgetTransferType
, cvValue :: !Rational
}
deriving (Show)
sortAllo :: MultiAllocation v -> InsertExcept (DaySpanAllocation v)
sortAllo a@Allocation {alloAmts = as} = do
bs <- foldSpan [] $ L.sortOn amtWhen as
return $ a {alloAmts = reverse bs}
where
foldSpan acc [] = return acc
foldSpan acc (x : xs) = do
let start = amtWhen x
res <- case xs of
[] -> resolveDaySpan start
(y : _) -> resolveDaySpan_ (intStart $ amtWhen y) start
foldSpan (x {amtWhen = res} : acc) xs
type UnbalancedTransfer = FlatTransfer UnbalancedValue
type BalancedTransfer = FlatTransfer Rational
--------------------------------------------------------------------------------
-- Income
insertIncome
:: (MonadInsertError m, MonadFinance m)
@ -359,8 +192,6 @@ insertIncome
then throwError $ InsertException [IncomeError day name balance]
else return (bal : fmap (allo2Trans meta day incFrom) (pre ++ tax ++ post))
type PeriodScaler = Natural -> Double -> Double
-- TODO we probably don't need to check for 1/0 each time
periodScaler
:: PeriodType
@ -398,21 +229,58 @@ workingDays wds start end
wds' = L.sort $ (\x -> diff (fromWeekday x) startDay) <$> L.nub wds
diff a b = fromIntegral $ mod (fromEnum a - fromEnum b) 7
allocatePre
:: Natural
-> Rational
-> [FlatAllocation PretaxValue]
-> (M.Map T.Text Rational, [FlatAllocation Rational])
allocatePre precision gross = L.mapAccumR go M.empty
foldDays
:: MonadInsertError m
=> (Day -> Day -> m a)
-> Day
-> [Day]
-> m [a]
foldDays f start days =
combineErrors $
snd $
L.mapAccumL (\prevDay day -> (day, f prevDay day)) start days
checkAcntType
:: (MonadInsertError m, MonadFinance m)
=> AcntType
-> AcntID
-> m AcntID
checkAcntType t = checkAcntTypes (t :| [])
checkAcntTypes
:: (MonadInsertError m, MonadFinance m)
=> NE.NonEmpty AcntType
-> AcntID
-> m AcntID
checkAcntTypes ts i = go =<< lookupAccountType i
where
go m f@FlatAllocation {faValue} =
let c = preCategory faValue
p = preValue faValue
v =
if prePercent faValue
then (roundPrecision 3 p / 100) * gross
else roundPrecision precision p
in (mapAdd_ c v m, f {faValue = v})
go t
| t `L.elem` ts = return i
| otherwise = throwError $ InsertException [AccountError i ts]
flattenAllo :: SingleAllocation v -> [FlatAllocation v]
flattenAllo Allocation {alloAmts, alloCur, alloTo} = fmap go alloAmts
where
go Amount {amtValue, amtDesc} =
FlatAllocation
{ faCur = NoX alloCur
, faTo = alloTo
, faValue = amtValue
, faDesc = amtDesc
}
-- ASSUME allocations are sorted
selectAllos :: Day -> DaySpanAllocation v -> [FlatAllocation v]
selectAllos day Allocation {alloAmts, alloCur, alloTo} =
go <$> filter ((`inDaySpan` day) . amtWhen) alloAmts
where
go Amount {amtValue, amtDesc} =
FlatAllocation
{ faCur = NoX alloCur
, faTo = alloTo
, faValue = amtValue
, faDesc = amtDesc
}
allo2Trans
:: BudgetMeta
@ -431,6 +299,22 @@ allo2Trans meta day from FlatAllocation {faValue, faTo, faDesc, faCur} =
, ftDesc = faDesc
}
allocatePre
:: Natural
-> Rational
-> [FlatAllocation PretaxValue]
-> (M.Map T.Text Rational, [FlatAllocation Rational])
allocatePre precision gross = L.mapAccumR go M.empty
where
go m f@FlatAllocation {faValue} =
let c = preCategory faValue
p = preValue faValue
v =
if prePercent faValue
then (roundPrecision 3 p / 100) * gross
else roundPrecision precision p
in (mapAdd_ c v m, f {faValue = v})
allocateTax
:: Natural
-> Rational
@ -451,19 +335,6 @@ allocateTax precision gross preDeds f = fmap (fmap go)
let taxDed = roundPrecision precision $ f precision tpDeductible
in foldBracket f precision (agi - taxDed) tpBrackets
allocatePost
:: Natural
-> Rational
-> [FlatAllocation PosttaxValue]
-> [FlatAllocation Rational]
allocatePost precision aftertax = fmap (fmap go)
where
go PosttaxValue {postValue, postPercent} =
let v = postValue
in if postPercent
then aftertax * roundPrecision 3 v / 100
else roundPrecision precision v
-- | Compute effective tax percentage of a bracket
-- The algorithm can be thought of in three phases:
-- 1. Find the highest tax bracket by looping backward until the AGI is less
@ -483,37 +354,21 @@ foldBracket f precision agi bs = fst $ foldr go (0, agi) $ L.sortOn tbLowerLimit
p = roundPrecision 3 tbPercent / 100
in if remain >= l then (acc + p * (remain - l), l) else a
data FlatAllocation v = FlatAllocation
{ faValue :: !v
, faDesc :: !T.Text
, faTo :: !TaggedAcnt
, faCur :: !BudgetCurrency
}
deriving (Functor, Show)
flattenAllo :: SingleAllocation v -> [FlatAllocation v]
flattenAllo Allocation {alloAmts, alloCur, alloTo} = fmap go alloAmts
allocatePost
:: Natural
-> Rational
-> [FlatAllocation PosttaxValue]
-> [FlatAllocation Rational]
allocatePost precision aftertax = fmap (fmap go)
where
go Amount {amtValue, amtDesc} =
FlatAllocation
{ faCur = NoX alloCur
, faTo = alloTo
, faValue = amtValue
, faDesc = amtDesc
}
go PosttaxValue {postValue, postPercent} =
let v = postValue
in if postPercent
then aftertax * roundPrecision 3 v / 100
else roundPrecision precision v
-- ASSUME allocations are sorted
selectAllos :: Day -> BoundAllocation v -> [FlatAllocation v]
selectAllos day Allocation {alloAmts, alloCur, alloTo} =
go <$> filter ((`inBounds` day) . amtWhen) alloAmts
where
go Amount {amtValue, amtDesc} =
FlatAllocation
{ faCur = NoX alloCur
, faTo = alloTo
, faValue = amtValue
, faDesc = amtDesc
}
--------------------------------------------------------------------------------
-- Transfer
expandTransfers
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
@ -530,12 +385,8 @@ expandTransfers key name localInterval ts = do
case localInterval of
Nothing -> return txs
Just i -> do
bounds <- liftExcept $ resolveBounds i
return $ filter (inBounds bounds . ftWhen) txs
initialCurrency :: BudgetCurrency -> CurID
initialCurrency (NoX c) = c
initialCurrency (X Exchange {xFromCur = c}) = c
bounds <- liftExcept $ resolveDaySpan i
return $ filter (inDaySpan bounds . ftWhen) txs
expandTransfer
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
@ -567,248 +418,116 @@ expandTransfer key name Transfer {transAmounts, transTo, transCurrency, transFro
, ftDesc = desc
}
insertBudgetTx :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m) => BalancedTransfer -> m ()
insertBudgetTx FlatTransfer {ftFrom, ftTo, ftMeta, ftCur, ftValue, ftDesc, ftWhen} = do
((sFrom, sTo), exchange) <- splitPair ftFrom ftTo ftCur ftValue
insertPair sFrom sTo
forM_ exchange $ uncurry insertPair
withDates
:: (MonadSqlQuery m, MonadFinance m, MonadInsertError m)
=> DatePat
-> (Day -> m a)
-> m [a]
withDates dp f = do
bounds <- askDBState kmBudgetInterval
days <- liftExcept $ expandDatePat bounds dp
combineErrors $ fmap f days
--------------------------------------------------------------------------------
-- shadow transfers
-- TODO this is going to be O(n*m), which might be a problem?
addShadowTransfers
:: CurrencyMap
-> [ShadowTransfer]
-> [UnbalancedTransfer]
-> InsertExcept [UnbalancedTransfer]
addShadowTransfers cm ms txs =
fmap catMaybes $
combineErrors $
fmap (uncurry (fromShadow cm)) $
[(t, m) | t <- txs, m <- ms]
fromShadow
:: CurrencyMap
-> UnbalancedTransfer
-> ShadowTransfer
-> InsertExcept (Maybe UnbalancedTransfer)
fromShadow cm tx t@ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stType} = do
res <- shadowMatches (stMatch t) tx
v <- roundPrecisionCur (initialCurrency stCurrency) cm stRatio
return $
if not res
then Nothing
else
Just $
FlatTransfer
{ ftMeta = ftMeta tx
, ftWhen = ftWhen tx
, ftCur = stCurrency
, ftFrom = stFrom
, ftTo = stTo
, ftValue = UnbalancedValue stType $ v * cvValue (ftValue tx)
, ftDesc = stDesc
}
shadowMatches :: TransferMatcher -> UnbalancedTransfer -> InsertExcept Bool
shadowMatches TransferMatcher {tmFrom, tmTo, tmDate, tmVal} tx = do
valRes <- valMatches tmVal $ cvValue $ ftValue tx
return $
memberMaybe (taAcnt $ ftFrom tx) tmFrom
&& memberMaybe (taAcnt $ ftTo tx) tmTo
&& maybe True (`dateMatches` ftWhen tx) tmDate
&& valRes
where
insertPair from to = do
k <- insert $ TransactionR (bmCommit ftMeta) ftWhen ftDesc
insertBudgetLabel k from
insertBudgetLabel k to
insertBudgetLabel k split = do
sk <- insertSplit k split
insert_ $ BudgetLabelR sk $ bmName ftMeta
memberMaybe x AcntSet {asList, asInclude} =
(if asInclude then id else not) $ x `elem` asList
--------------------------------------------------------------------------------
-- random
initialCurrency :: BudgetCurrency -> CurID
initialCurrency (NoX c) = c
initialCurrency (X Exchange {xFromCur = c}) = c
data UnbalancedValue = UnbalancedValue
{ cvType :: !BudgetTransferType
, cvValue :: !Rational
}
deriving (Show)
type UnbalancedTransfer = FlatTransfer UnbalancedValue
type BalancedTransfer = FlatTransfer Rational
data FlatTransfer v = FlatTransfer
{ ftFrom :: !TaggedAcnt
, ftTo :: !TaggedAcnt
, ftValue :: !v
, ftWhen :: !Day
, ftDesc :: !T.Text
, ftMeta :: !BudgetMeta
, ftCur :: !BudgetCurrency
}
deriving (Show)
data BudgetMeta = BudgetMeta
{ bmCommit :: !CommitRId
, bmName :: !T.Text
}
deriving (Show)
type IntAllocations =
( [DaySpanAllocation PretaxValue]
, [DaySpanAllocation TaxValue]
, [DaySpanAllocation PosttaxValue]
)
type DaySpanAllocation = Allocation DaySpan
type SplitPair = (KeySplit, KeySplit)
splitPair
:: (MonadInsertError m, MonadFinance m)
=> TaggedAcnt
-> TaggedAcnt
-> BudgetCurrency
-> Rational
-> m (SplitPair, Maybe SplitPair)
splitPair from to cur val = case cur of
NoX curid -> (,Nothing) <$> pair curid from to val
X Exchange {xFromCur, xToCur, xAcnt, xRate} -> do
let middle = TaggedAcnt xAcnt []
let res1 = pair xFromCur from middle val
let res2 = pair xToCur middle to (val * roundPrecision 3 xRate)
combineError res1 res2 $ \a b -> (a, Just b)
where
pair curid from_ to_ v = do
let s1 = split curid from_ (-v)
let s2 = split curid to_ v
combineError s1 s2 (,)
split c TaggedAcnt {taAcnt, taTags} v =
resolveSplit $
Entry
{ eAcnt = taAcnt
, eValue = v
, eComment = ""
, eCurrency = c
, eTags = taTags
}
type PeriodScaler = Natural -> Double -> Double
checkAcntType
:: (MonadInsertError m, MonadFinance m)
=> AcntType
-> AcntID
-> m AcntID
checkAcntType t = checkAcntTypes (t :| [])
checkAcntTypes
:: (MonadInsertError m, MonadFinance m)
=> NE.NonEmpty AcntType
-> AcntID
-> m AcntID
checkAcntTypes ts i = go =<< lookupAccountType i
where
go t
| t `L.elem` ts = return i
| otherwise = throwError $ InsertException [AccountError i ts]
--------------------------------------------------------------------------------
-- statements
splitHistory :: [History] -> ([HistTransfer], [Statement])
splitHistory = partitionEithers . fmap go
where
go (HistTransfer x) = Left x
go (HistStatement x) = Right x
-- insertStatement
-- :: (MonadUnliftIO m, MonadSqlQuery m, MonadFinance m)
-- => History
-- -> m ()
-- insertStatement (HistTransfer m) = liftIOExceptT $ insertManual m
-- insertStatement (HistStatement i) = insertImport i
insertHistTransfer
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
=> HistTransfer
-> m ()
insertHistTransfer
m@Transfer
{ transFrom = from
, transTo = to
, transCurrency = u
, transAmounts = amts
} = do
whenHash CTManual m () $ \c -> do
bounds <- askDBState kmStatementInterval
let precRes = lookupCurrencyPrec u
let go Amount {amtWhen, amtValue, amtDesc} = do
let dayRes = liftExcept $ expandDatePat bounds amtWhen
(days, precision) <- combineError dayRes precRes (,)
let tx day = txPair day from to u (roundPrecision precision amtValue) amtDesc
keys <- combineErrors $ fmap tx days
mapM_ (insertTx c) keys
void $ combineErrors $ fmap go amts
readHistStmt :: (MonadUnliftIO m, MonadFinance m) => Statement -> m (Maybe (CommitR, [KeyTx]))
readHistStmt i = whenHash_ CTImport i $ do
bs <- readImport i
bounds <- askDBState kmStatementInterval
liftIOExceptT $ mapErrors resolveTx $ filter (inBounds bounds . txDate) bs
insertHistStmt :: (MonadSqlQuery m) => CommitR -> [KeyTx] -> m ()
insertHistStmt c ks = do
ck <- insert c
mapM_ (insertTx ck) ks
-- insertImport
-- :: (MonadUnliftIO m, MonadSqlQuery m, MonadFinance m)
-- => Statement
-- -> m ()
-- insertImport i = whenHash CTImport i () $ \c -> do
-- -- TODO this isn't efficient, the whole file will be read and maybe no
-- -- transactions will be desired
-- bs <- readImport i
-- bounds <- expandBounds <$> askDBState kmStatementInterval
-- keys <- liftIOExceptT $ mapErrors resolveTx $ filter (inBounds bounds . txDate) bs
-- mapM_ (insertTx c) keys
--------------------------------------------------------------------------------
-- low-level transaction stuff
-- TODO tags here?
txPair
:: (MonadInsertError m, MonadFinance m)
=> Day
-> AcntID
-> AcntID
-> CurID
-> Rational
-> T.Text
-> m KeyTx
txPair day from to cur val desc = resolveTx tx
where
split a v =
Entry
{ eAcnt = a
, eValue = v
, eComment = ""
, eCurrency = cur
, eTags = []
}
tx =
Tx
{ txDescr = desc
, txDate = day
, txSplits = [split from (-val), split to val]
}
resolveTx :: (MonadInsertError m, MonadFinance m) => BalTx -> m KeyTx
resolveTx t@Tx {txSplits = ss} =
fmap (\kss -> t {txSplits = kss}) $
combineErrors $
fmap resolveSplit ss
resolveSplit :: (MonadInsertError m, MonadFinance m) => BalSplit -> m KeySplit
resolveSplit s@Entry {eAcnt, eCurrency, eValue, eTags} = do
let aRes = lookupAccountKey eAcnt
let cRes = lookupCurrencyKey eCurrency
let sRes = lookupAccountSign eAcnt
let tagRes = combineErrors $ fmap lookupTag eTags
-- TODO correct sign here?
-- TODO lenses would be nice here
combineError (combineError3 aRes cRes sRes (,,)) tagRes $
\(aid, cid, sign) tags ->
s
{ eAcnt = aid
, eCurrency = cid
, eValue = eValue * fromIntegral (sign2Int sign)
, eTags = tags
}
insertTx :: MonadSqlQuery m => CommitRId -> KeyTx -> m ()
insertTx c Tx {txDate = d, txDescr = e, txSplits = ss} = do
k <- insert $ TransactionR c d e
mapM_ (insertSplit k) ss
insertSplit :: MonadSqlQuery m => TransactionRId -> KeySplit -> m SplitRId
insertSplit t Entry {eAcnt, eCurrency, eValue, eComment, eTags} = do
k <- insert $ SplitR t eCurrency eAcnt eComment eValue
mapM_ (insert_ . TagRelationR k) eTags
return k
lookupAccount :: (MonadInsertError m, MonadFinance m) => AcntID -> m (AccountRId, AcntSign, AcntType)
lookupAccount = lookupFinance AcntField kmAccount
lookupAccountKey :: (MonadInsertError m, MonadFinance m) => AcntID -> m AccountRId
lookupAccountKey = fmap fstOf3 . lookupAccount
lookupAccountSign :: (MonadInsertError m, MonadFinance m) => AcntID -> m AcntSign
lookupAccountSign = fmap sndOf3 . lookupAccount
lookupAccountType :: (MonadInsertError m, MonadFinance m) => AcntID -> m AcntType
lookupAccountType = fmap thdOf3 . lookupAccount
lookupCurrency :: (MonadInsertError m, MonadFinance m) => T.Text -> m (CurrencyRId, Natural)
lookupCurrency = lookupFinance CurField kmCurrency
lookupCurrencyKey :: (MonadInsertError m, MonadFinance m) => AcntID -> m CurrencyRId
lookupCurrencyKey = fmap fst . lookupCurrency
lookupCurrencyPrec :: (MonadInsertError m, MonadFinance m) => AcntID -> m Natural
lookupCurrencyPrec = fmap snd . lookupCurrency
lookupTag :: (MonadInsertError m, MonadFinance m) => TagID -> m TagRId
lookupTag = lookupFinance TagField kmTag
lookupFinance
:: (MonadInsertError m, MonadFinance m)
=> SplitIDType
-> (DBState -> M.Map T.Text a)
-> T.Text
-> m a
lookupFinance t f c = (liftExcept . lookupErr (DBKey t) c) =<< askDBState f
-- TODO this hashes twice (not that it really matters)
whenHash
:: (Hashable a, MonadFinance m, MonadSqlQuery m)
=> ConfigType
-> a
-> b
-> (CommitRId -> m b)
-> m b
whenHash t o def f = do
let h = hash o
hs <- askDBState kmNewCommits
if h `elem` hs then f =<< insert (CommitR h t) else return def
whenHash_
:: (Hashable a, MonadFinance m)
=> ConfigType
-> a
-> m b
-> m (Maybe (CommitR, b))
whenHash_ t o f = do
let h = hash o
let c = CommitR h t
hs <- askDBState kmNewCommits
if h `elem` hs then Just . (c,) <$> f else return Nothing
data FlatAllocation v = FlatAllocation
{ faValue :: !v
, faDesc :: !T.Text
, faTo :: !TaggedAcnt
, faCur :: !BudgetCurrency
}
deriving (Functor, Show)

View File

@ -8,6 +8,10 @@ module Internal.Database.Ops
, flattenAcntRoot
, paths2IDs
, mkPool
, whenHash
, whenHash_
, insertSplit
, resolveSplit
)
where
@ -24,6 +28,7 @@ import Database.Persist.Sqlite hiding
, deleteWhere
, insert
, insertKey
, insert_
, runMigration
, (==.)
, (||.)
@ -319,8 +324,8 @@ getDBState c = do
, kmCurrenciesOld = cs
}
where
bi = liftExcept $ resolveBounds $ budgetInterval $ global c
si = liftExcept $ resolveBounds $ statementInterval $ global c
bi = liftExcept $ resolveDaySpan $ budgetInterval $ global c
si = liftExcept $ resolveDaySpan $ statementInterval $ global c
(acnts, paths, am) = indexAcntRoot $ accounts c
cs = currency2Record <$> currencies c
ts = toRecord <$> tags c
@ -371,3 +376,50 @@ deleteE q = unsafeLiftSql "esqueleto-delete" (E.delete q)
selectE :: (MonadSqlQuery m, SqlSelect a r) => E.SqlQuery a -> m [r]
selectE q = unsafeLiftSql "esqueleto-select" (E.select q)
whenHash
:: (Hashable a, MonadFinance m, MonadSqlQuery m)
=> ConfigType
-> a
-> b
-> (CommitRId -> m b)
-> m b
whenHash t o def f = do
let h = hash o
hs <- askDBState kmNewCommits
if h `elem` hs then f =<< insert (CommitR h t) else return def
whenHash_
:: (Hashable a, MonadFinance m)
=> ConfigType
-> a
-> m b
-> m (Maybe (CommitR, b))
whenHash_ t o f = do
let h = hash o
let c = CommitR h t
hs <- askDBState kmNewCommits
if h `elem` hs then Just . (c,) <$> f else return Nothing
insertSplit :: MonadSqlQuery m => TransactionRId -> KeySplit -> m SplitRId
insertSplit t Entry {eAcnt, eCurrency, eValue, eComment, eTags} = do
k <- insert $ SplitR t eCurrency eAcnt eComment eValue
mapM_ (insert_ . TagRelationR k) eTags
return k
resolveSplit :: (MonadInsertError m, MonadFinance m) => BalSplit -> m KeySplit
resolveSplit s@Entry {eAcnt, eCurrency, eValue, eTags} = do
let aRes = lookupAccountKey eAcnt
let cRes = lookupCurrencyKey eCurrency
let sRes = lookupAccountSign eAcnt
let tagRes = combineErrors $ fmap lookupTag eTags
-- TODO correct sign here?
-- TODO lenses would be nice here
combineError (combineError3 aRes cRes sRes (,,)) tagRes $
\(aid, cid, sign) tags ->
s
{ eAcnt = aid
, eCurrency = cid
, eValue = eValue * fromIntegral (sign2Int sign)
, eTags = tags
}

133
lib/Internal/History.hs Normal file
View File

@ -0,0 +1,133 @@
module Internal.History
( splitHistory
, insertHistTransfer
, readHistStmt
, insertHistStmt
)
where
import Control.Monad.Except
import Database.Persist.Monad
import Internal.Database.Ops
import Internal.Statement
import Internal.Types.Main
import Internal.Utils
import RIO hiding (to)
import qualified RIO.Text as T
import RIO.Time
--------------------------------------------------------------------------------
-- budget
-- each budget (designated at the top level by a 'name') is processed in the
-- following steps
-- 1. expand all transactions given the desired date range and date patterns for
-- each directive in the budget
-- 2. sort all transactions by date
-- 3. propagate all balances forward, and while doing so assign values to each
-- transaction (some of which depend on the 'current' balance of the
-- target account)
-- 4. assign shadow transactions (TODO)
-- 5. insert all transactions
--------------------------------------------------------------------------------
-- statements
splitHistory :: [History] -> ([HistTransfer], [Statement])
splitHistory = partitionEithers . fmap go
where
go (HistTransfer x) = Left x
go (HistStatement x) = Right x
-- insertStatement
-- :: (MonadUnliftIO m, MonadSqlQuery m, MonadFinance m)
-- => History
-- -> m ()
-- insertStatement (HistTransfer m) = liftIOExceptT $ insertManual m
-- insertStatement (HistStatement i) = insertImport i
insertHistTransfer
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
=> HistTransfer
-> m ()
insertHistTransfer
m@Transfer
{ transFrom = from
, transTo = to
, transCurrency = u
, transAmounts = amts
} = do
whenHash CTManual m () $ \c -> do
bounds <- askDBState kmStatementInterval
let precRes = lookupCurrencyPrec u
let go Amount {amtWhen, amtValue, amtDesc} = do
let dayRes = liftExcept $ expandDatePat bounds amtWhen
(days, precision) <- combineError dayRes precRes (,)
let tx day = txPair day from to u (roundPrecision precision amtValue) amtDesc
keys <- combineErrors $ fmap tx days
mapM_ (insertTx c) keys
void $ combineErrors $ fmap go amts
readHistStmt :: (MonadUnliftIO m, MonadFinance m) => Statement -> m (Maybe (CommitR, [KeyTx]))
readHistStmt i = whenHash_ CTImport i $ do
bs <- readImport i
bounds <- askDBState kmStatementInterval
liftIOExceptT $ mapErrors resolveTx $ filter (inDaySpan bounds . txDate) bs
insertHistStmt :: (MonadSqlQuery m) => CommitR -> [KeyTx] -> m ()
insertHistStmt c ks = do
ck <- insert c
mapM_ (insertTx ck) ks
-- insertImport
-- :: (MonadUnliftIO m, MonadSqlQuery m, MonadFinance m)
-- => Statement
-- -> m ()
-- insertImport i = whenHash CTImport i () $ \c -> do
-- -- TODO this isn't efficient, the whole file will be read and maybe no
-- -- transactions will be desired
-- bs <- readImport i
-- bounds <- expandBounds <$> askDBState kmStatementInterval
-- keys <- liftIOExceptT $ mapErrors resolveTx $ filter (inBounds bounds . txDate) bs
-- mapM_ (insertTx c) keys
--------------------------------------------------------------------------------
-- low-level transaction stuff
-- TODO tags here?
txPair
:: (MonadInsertError m, MonadFinance m)
=> Day
-> AcntID
-> AcntID
-> CurID
-> Rational
-> T.Text
-> m KeyTx
txPair day from to cur val desc = resolveTx tx
where
split a v =
Entry
{ eAcnt = a
, eValue = v
, eComment = ""
, eCurrency = cur
, eTags = []
}
tx =
Tx
{ txDescr = desc
, txDate = day
, txSplits = [split from (-val), split to val]
}
resolveTx :: (MonadInsertError m, MonadFinance m) => BalTx -> m KeyTx
resolveTx t@Tx {txSplits = ss} =
fmap (\kss -> t {txSplits = kss}) $
combineErrors $
fmap resolveSplit ss
insertTx :: MonadSqlQuery m => CommitRId -> KeyTx -> m ()
insertTx c Tx {txDate = d, txDescr = e, txSplits = ss} = do
k <- insert $ TransactionR c d e
mapM_ (insertSplit k) ss

View File

@ -44,8 +44,8 @@ data DBState = DBState
{ kmCurrency :: !CurrencyMap
, kmAccount :: !AccountMap
, kmTag :: !TagMap
, kmBudgetInterval :: !Bounds
, kmStatementInterval :: !Bounds
, kmBudgetInterval :: !DaySpan
, kmStatementInterval :: !DaySpan
, kmNewCommits :: ![Int]
, kmOldCommits :: ![Int]
, kmConfigDir :: !FilePath
@ -63,35 +63,11 @@ type KeyTx = Tx KeySplit
type TreeR = Tree ([T.Text], AccountRId)
type Balances = M.Map AccountRId Rational
type BalanceM = ReaderT (MVar Balances)
type MonadFinance = MonadReader DBState
askDBState :: MonadFinance m => (DBState -> a) -> m a
askDBState = asks
class MonadUnliftIO m => MonadBalance m where
askBalances :: m (MVar Balances)
withBalances :: (Balances -> m a) -> m a
withBalances f = do
bs <- askBalances
withMVar bs f
modifyBalances :: (Balances -> m (Balances, a)) -> m a
modifyBalances f = do
bs <- askBalances
modifyMVar bs f
lookupBalance :: AccountRId -> m Rational
lookupBalance i = withBalances $ return . fromMaybe 0 . M.lookup i
addBalance :: AccountRId -> Rational -> m ()
addBalance i v =
modifyBalances $ return . (,()) . M.alter (Just . maybe v (v +)) i
-------------------------------------------------------------------------------
-- misc
@ -125,8 +101,7 @@ data TxRecord = TxRecord
}
deriving (Show, Eq, Ord)
-- TODO pick a better name for this (something like DayInterval or something)
type Bounds = (Day, Natural)
type DaySpan = (Day, Natural)
data Keyed a = Keyed
{ kKey :: !Int64
@ -196,7 +171,7 @@ data InsertError
| BalanceError !BalanceType !CurID ![RawSplit]
| IncomeError !Day !T.Text !Rational
| PatternError !Natural !Natural !(Maybe Natural) !PatternSuberr
| BoundsError !Gregorian !(Maybe Gregorian)
| DaySpanError !Gregorian !(Maybe Gregorian)
| StatementError ![TxRecord] ![MatchRe]
| PeriodError !Day !Day
deriving (Show)

View File

@ -1,14 +1,15 @@
module Internal.Utils
( compareDate
, expandDatePat
, askDays
, fromWeekday
, inBounds
, expandBounds
, inDaySpan
, fmtRational
, matches
, fromGregorian'
, resolveBounds
, resolveBounds_
, intersectBounds
, resolveDaySpan
, resolveDaySpan_
, intersectDaySpan
, liftInner
, liftExceptT
, liftExcept
@ -48,6 +49,12 @@ module Internal.Utils
, valMatches
, roundPrecision
, roundPrecisionCur
, lookupAccountKey
, lookupAccountSign
, lookupAccountType
, lookupCurrencyKey
, lookupCurrencyPrec
, lookupTag
)
where
@ -66,6 +73,96 @@ import RIO.Time
import Text.Regex.TDFA
import Text.Regex.TDFA.Text
--------------------------------------------------------------------------------
-- intervals
expandDatePat :: DaySpan -> DatePat -> InsertExcept [Day]
expandDatePat b (Cron cp) = expandCronPat b cp
expandDatePat i (Mod mp) = return $ expandModPat mp i
expandModPat :: ModPat -> DaySpan -> [Day]
expandModPat ModPat {mpStart = s, mpBy = b, mpUnit = u, mpRepeats = r} bs =
takeWhile (<= upper) $
(`addFun` start) . (* b')
<$> maybe id (take . fromIntegral) r [0 ..]
where
(lower, upper) = fromDaySpan bs
start = maybe lower fromGregorian' s
b' = fromIntegral b
addFun = case u of
Day -> addDays
Week -> addDays . (* 7)
Month -> addGregorianMonthsClip
Year -> addGregorianYearsClip
expandCronPat :: DaySpan -> CronPat -> InsertExcept [Day]
expandCronPat b CronPat {cpYear, cpMonth, cpDay, cpWeekly} =
combineError3 yRes mRes dRes $ \ys ms ds ->
filter validWeekday $
mapMaybe (uncurry3 toDay) $
takeWhile (\((y, _), m, d) -> (y, m, d) <= (yb1, mb1, db1)) $
dropWhile (\((y, _), m, d) -> (y, m, d) < (yb0, mb0, db0)) $
[(y, m, d) | y <- (\y -> (y, isLeapYear y)) <$> ys, m <- ms, d <- ds]
where
yRes = case cpYear of
Nothing -> return [yb0 .. yb1]
Just pat -> do
ys <- expandMDYPat (fromIntegral yb0) (fromIntegral yb1) pat
return $ dropWhile (< yb0) $ fromIntegral <$> ys
mRes = expandMD 12 cpMonth
dRes = expandMD 31 cpDay
(s, e) = fromDaySpan b
(yb0, mb0, db0) = toGregorian s
(yb1, mb1, db1) = toGregorian $ addDays (-1) e
expandMD lim =
fmap (fromIntegral <$>)
. maybe (return [1 .. lim]) (expandMDYPat 1 lim)
expandW (OnDay x) = [fromEnum x]
expandW (OnDays xs) = fromEnum <$> xs
ws = maybe [] expandW cpWeekly
validWeekday = if null ws then const True else \day -> dayToWeekday day `elem` ws
toDay (y, leap) m d
| m == 2 && (not leap && d > 28 || leap && d > 29) = Nothing
| m `elem` [4, 6, 9, 11] && d > 30 = Nothing
| otherwise = Just $ fromGregorian y m d
expandMDYPat :: Natural -> Natural -> MDYPat -> InsertExcept [Natural]
expandMDYPat lower upper (Single x) = return [x | lower <= x && x <= upper]
expandMDYPat lower upper (Multi xs) = return $ dropWhile (<= lower) $ takeWhile (<= upper) xs
expandMDYPat lower upper (After x) = return [max lower x .. upper]
expandMDYPat lower upper (Before x) = return [lower .. min upper x]
expandMDYPat lower upper (Between x y) = return [max lower x .. min upper y]
expandMDYPat lower upper (Repeat RepeatPat {rpStart = s, rpBy = b, rpRepeats = r})
| b < 1 = throwError $ InsertException [PatternError s b r ZeroLength]
| otherwise = do
k <- limit r
return $ dropWhile (<= lower) $ takeWhile (<= k) [s + i * b | i <- [0 ..]]
where
limit Nothing = return upper
limit (Just n)
-- this guard not only produces the error for the user but also protects
-- from an underflow below it
| n < 1 = throwError $ InsertException [PatternError s b r ZeroRepeats]
| otherwise = return $ min (s + b * (n - 1)) upper
dayToWeekday :: Day -> Int
dayToWeekday (ModifiedJulianDay d) = mod (fromIntegral d + 2) 7
askDays
:: (MonadFinance m, MonadInsertError m)
=> DatePat
-> Maybe Interval
-> m [Day]
askDays dp i = do
globalSpan <- askDBState kmBudgetInterval
case i of
Just i' -> do
localSpan <- liftExcept $ resolveDaySpan i'
maybe (return []) expand $ intersectDaySpan globalSpan localSpan
Nothing -> expand globalSpan
where
expand = liftExcept . (`expandDatePat` dp)
--------------------------------------------------------------------------------
-- dates
@ -152,39 +249,42 @@ compareDate (In md offset) x = do
fromGregorian' :: Gregorian -> Day
fromGregorian' = uncurry3 fromGregorian . gregTup
inBounds :: Bounds -> Day -> Bool
inBounds bs = withinDays (expandBounds bs)
inDaySpan :: DaySpan -> Day -> Bool
inDaySpan bs = withinDays (fromDaySpan bs)
withinDays :: (Day, Day) -> Day -> Bool
withinDays (d0, d1) x = d0 <= x && x < d1
resolveBounds :: Interval -> InsertExcept Bounds
resolveBounds i@Interval {intStart = s} =
resolveBounds_ (s {gYear = gYear s + 50}) i
resolveDaySpan :: Interval -> InsertExcept DaySpan
resolveDaySpan i@Interval {intStart = s} =
resolveDaySpan_ (s {gYear = gYear s + 50}) i
-- TODO not DRY
intersectBounds :: Bounds -> Bounds -> Maybe Bounds
intersectBounds a b =
if b' > a' then Nothing else Just (a', fromIntegral $ diffDays b' a' - 1)
intersectDaySpan :: DaySpan -> DaySpan -> Maybe DaySpan
intersectDaySpan a b =
if b' > a' then Nothing else Just $ toDaySpan (a', b')
where
(a0, a1) = expandBounds a
(b0, b1) = expandBounds b
(a0, a1) = fromDaySpan a
(b0, b1) = fromDaySpan b
a' = max a0 a1
b' = min b0 b1
resolveBounds_ :: Gregorian -> Interval -> InsertExcept Bounds
resolveBounds_ def Interval {intStart = s, intEnd = e} =
resolveDaySpan_ :: Gregorian -> Interval -> InsertExcept DaySpan
resolveDaySpan_ def Interval {intStart = s, intEnd = e} =
case fromGregorian' <$> e of
Nothing -> return $ toBounds $ fromGregorian' def
Nothing -> return $ toDaySpan_ $ fromGregorian' def
Just e_
| s_ < e_ -> return $ toBounds e_
| otherwise -> throwError $ InsertException [BoundsError s e]
| s_ < e_ -> return $ toDaySpan_ e_
| otherwise -> throwError $ InsertException [DaySpanError s e]
where
s_ = fromGregorian' s
toBounds end = (s_, fromIntegral $ diffDays end s_ - 1)
toDaySpan_ end = toDaySpan (s_, end)
expandBounds :: Bounds -> (Day, Day)
expandBounds (d, n) = (d, addDays (fromIntegral n + 1) d)
fromDaySpan :: DaySpan -> (Day, Day)
fromDaySpan (d, n) = (d, addDays (fromIntegral n + 1) d)
-- ASSUME a < b
toDaySpan :: (Day, Day) -> DaySpan
toDaySpan (a, b) = (a, fromIntegral $ diffDays b a - 1)
--------------------------------------------------------------------------------
-- matching
@ -457,7 +557,7 @@ acntPath2Text (AcntPath t cs) = T.intercalate "/" (atName t : cs)
showError :: InsertError -> [T.Text]
showError other = case other of
(StatementError ts ms) -> (showTx <$> ts) ++ (showMatch <$> ms)
(BoundsError a b) ->
(DaySpanError a b) ->
[T.unwords ["Could not create bounds from", showGregorian_ a, "and", showGreg b]]
where
showGreg (Just g) = showGregorian_ g
@ -794,3 +894,35 @@ matchGroupsMaybe q re = case regexec re q of
Right (Just (_, _, _, xs)) -> xs
-- this should never fail as regexec always returns Right
Left _ -> []
lookupAccount :: (MonadInsertError m, MonadFinance m) => AcntID -> m (AccountRId, AcntSign, AcntType)
lookupAccount = lookupFinance AcntField kmAccount
lookupAccountKey :: (MonadInsertError m, MonadFinance m) => AcntID -> m AccountRId
lookupAccountKey = fmap fstOf3 . lookupAccount
lookupAccountSign :: (MonadInsertError m, MonadFinance m) => AcntID -> m AcntSign
lookupAccountSign = fmap sndOf3 . lookupAccount
lookupAccountType :: (MonadInsertError m, MonadFinance m) => AcntID -> m AcntType
lookupAccountType = fmap thdOf3 . lookupAccount
lookupCurrency :: (MonadInsertError m, MonadFinance m) => T.Text -> m (CurrencyRId, Natural)
lookupCurrency = lookupFinance CurField kmCurrency
lookupCurrencyKey :: (MonadInsertError m, MonadFinance m) => AcntID -> m CurrencyRId
lookupCurrencyKey = fmap fst . lookupCurrency
lookupCurrencyPrec :: (MonadInsertError m, MonadFinance m) => AcntID -> m Natural
lookupCurrencyPrec = fmap snd . lookupCurrency
lookupTag :: (MonadInsertError m, MonadFinance m) => TagID -> m TagRId
lookupTag = lookupFinance TagField kmTag
lookupFinance
:: (MonadInsertError m, MonadFinance m)
=> SplitIDType
-> (DBState -> M.Map T.Text a)
-> T.Text
-> m a
lookupFinance t f c = (liftExcept . lookupErr (DBKey t) c) =<< askDBState f