REF split history and budget
This commit is contained in:
parent
02747b4678
commit
62b39b61aa
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
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
|
||||
|
||||
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
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
data FlatTransfer v = FlatTransfer
|
||||
{ ftFrom :: !TaggedAcnt
|
||||
, ftTo :: !TaggedAcnt
|
||||
, ftValue :: !v
|
||||
, ftWhen :: !Day
|
||||
, ftDesc :: !T.Text
|
||||
, ftMeta :: !BudgetMeta
|
||||
, ftCur :: !BudgetCurrency
|
||||
}
|
||||
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
|
||||
|
||||
data UnbalancedValue = UnbalancedValue
|
||||
{ cvType :: !BudgetTransferType
|
||||
, cvValue :: !Rational
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
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
|
||||
|
||||
data FlatAllocation v = FlatAllocation
|
||||
{ faValue :: !v
|
||||
, faDesc :: !T.Text
|
||||
, faTo :: !TaggedAcnt
|
||||
, faCur :: !BudgetCurrency
|
||||
}
|
||||
|
||||
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
|
||||
deriving (Functor, Show)
|
||||
|
|
@ -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
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue