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 Control.Monad.Reader
|
||||||
import qualified Data.Text.IO as TI
|
import qualified Data.Text.IO as TI
|
||||||
import Database.Persist.Monad
|
import Database.Persist.Monad
|
||||||
|
import Internal.Budget
|
||||||
import Internal.Config
|
import Internal.Config
|
||||||
import Internal.Database.Ops
|
import Internal.Database.Ops
|
||||||
import Internal.Insert
|
import Internal.History
|
||||||
import Internal.Types.Main
|
import Internal.Types.Main
|
||||||
import Internal.Utils
|
import Internal.Utils
|
||||||
import Options.Applicative
|
import Options.Applicative
|
||||||
|
|
|
@ -25,9 +25,10 @@ source-repository head
|
||||||
|
|
||||||
library
|
library
|
||||||
exposed-modules:
|
exposed-modules:
|
||||||
|
Internal.Budget
|
||||||
Internal.Config
|
Internal.Config
|
||||||
Internal.Database.Ops
|
Internal.Database.Ops
|
||||||
Internal.Insert
|
Internal.History
|
||||||
Internal.Statement
|
Internal.Statement
|
||||||
Internal.Types.Database
|
Internal.Types.Database
|
||||||
Internal.Types.Dhall
|
Internal.Types.Dhall
|
||||||
|
|
|
@ -1,16 +1,8 @@
|
||||||
module Internal.Insert
|
module Internal.Budget (insertBudget) where
|
||||||
( insertBudget
|
|
||||||
, splitHistory
|
|
||||||
, insertHistTransfer
|
|
||||||
, readHistStmt
|
|
||||||
, insertHistStmt
|
|
||||||
)
|
|
||||||
where
|
|
||||||
|
|
||||||
import Control.Monad.Except
|
import Control.Monad.Except
|
||||||
import Data.Hashable
|
|
||||||
import Database.Persist.Monad
|
import Database.Persist.Monad
|
||||||
import Internal.Statement
|
import Internal.Database.Ops
|
||||||
import Internal.Types.Main
|
import Internal.Types.Main
|
||||||
import Internal.Utils
|
import Internal.Utils
|
||||||
import RIO hiding (to)
|
import RIO hiding (to)
|
||||||
|
@ -20,132 +12,6 @@ import qualified RIO.NonEmpty as NE
|
||||||
import qualified RIO.Text as T
|
import qualified RIO.Text as T
|
||||||
import RIO.Time
|
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
|
insertBudget
|
||||||
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
|
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
|
||||||
=> Budget
|
=> Budget
|
||||||
|
@ -175,75 +41,6 @@ insertBudget
|
||||||
post_ = sortAllos bgtPosttax
|
post_ = sortAllos bgtPosttax
|
||||||
sortAllos = liftExcept . combineErrors . fmap sortAllo
|
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 :: [UnbalancedTransfer] -> [BalancedTransfer]
|
||||||
balanceTransfers = snd . L.mapAccumR go M.empty . reverse . L.sortOn ftWhen
|
balanceTransfers = snd . L.mapAccumR go M.empty . reverse . L.sortOn ftWhen
|
||||||
where
|
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 BTPercent x = -(x / 100 * bal)
|
||||||
amtToMove bal BTTarget x = x - 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_ :: (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
|
mapAdd_ k v = M.alter (maybe (Just v) (Just . (+ v))) k
|
||||||
|
|
||||||
data BudgetMeta = BudgetMeta
|
insertBudgetTx
|
||||||
{ bmCommit :: !CommitRId
|
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
|
||||||
, bmName :: !T.Text
|
=> 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
|
sortAllo :: MultiAllocation v -> InsertExcept (DaySpanAllocation v)
|
||||||
{ ftFrom :: !TaggedAcnt
|
sortAllo a@Allocation {alloAmts = as} = do
|
||||||
, ftTo :: !TaggedAcnt
|
bs <- foldSpan [] $ L.sortOn amtWhen as
|
||||||
, ftValue :: !v
|
return $ a {alloAmts = reverse bs}
|
||||||
, ftWhen :: !Day
|
where
|
||||||
, ftDesc :: !T.Text
|
foldSpan acc [] = return acc
|
||||||
, ftMeta :: !BudgetMeta
|
foldSpan acc (x : xs) = do
|
||||||
, ftCur :: !BudgetCurrency
|
let start = amtWhen x
|
||||||
}
|
res <- case xs of
|
||||||
deriving (Show)
|
[] -> resolveDaySpan start
|
||||||
|
(y : _) -> resolveDaySpan_ (intStart $ amtWhen y) start
|
||||||
|
foldSpan (x {amtWhen = res} : acc) xs
|
||||||
|
|
||||||
data UnbalancedValue = UnbalancedValue
|
--------------------------------------------------------------------------------
|
||||||
{ cvType :: !BudgetTransferType
|
-- Income
|
||||||
, cvValue :: !Rational
|
|
||||||
}
|
|
||||||
deriving (Show)
|
|
||||||
|
|
||||||
type UnbalancedTransfer = FlatTransfer UnbalancedValue
|
|
||||||
|
|
||||||
type BalancedTransfer = FlatTransfer Rational
|
|
||||||
|
|
||||||
insertIncome
|
insertIncome
|
||||||
:: (MonadInsertError m, MonadFinance m)
|
:: (MonadInsertError m, MonadFinance m)
|
||||||
|
@ -359,8 +192,6 @@ insertIncome
|
||||||
then throwError $ InsertException [IncomeError day name balance]
|
then throwError $ InsertException [IncomeError day name balance]
|
||||||
else return (bal : fmap (allo2Trans meta day incFrom) (pre ++ tax ++ post))
|
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
|
-- TODO we probably don't need to check for 1/0 each time
|
||||||
periodScaler
|
periodScaler
|
||||||
:: PeriodType
|
:: PeriodType
|
||||||
|
@ -398,21 +229,58 @@ workingDays wds start end
|
||||||
wds' = L.sort $ (\x -> diff (fromWeekday x) startDay) <$> L.nub wds
|
wds' = L.sort $ (\x -> diff (fromWeekday x) startDay) <$> L.nub wds
|
||||||
diff a b = fromIntegral $ mod (fromEnum a - fromEnum b) 7
|
diff a b = fromIntegral $ mod (fromEnum a - fromEnum b) 7
|
||||||
|
|
||||||
allocatePre
|
foldDays
|
||||||
:: Natural
|
:: MonadInsertError m
|
||||||
-> Rational
|
=> (Day -> Day -> m a)
|
||||||
-> [FlatAllocation PretaxValue]
|
-> Day
|
||||||
-> (M.Map T.Text Rational, [FlatAllocation Rational])
|
-> [Day]
|
||||||
allocatePre precision gross = L.mapAccumR go M.empty
|
-> 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
|
where
|
||||||
go m f@FlatAllocation {faValue} =
|
go t
|
||||||
let c = preCategory faValue
|
| t `L.elem` ts = return i
|
||||||
p = preValue faValue
|
| otherwise = throwError $ InsertException [AccountError i ts]
|
||||||
v =
|
|
||||||
if prePercent faValue
|
flattenAllo :: SingleAllocation v -> [FlatAllocation v]
|
||||||
then (roundPrecision 3 p / 100) * gross
|
flattenAllo Allocation {alloAmts, alloCur, alloTo} = fmap go alloAmts
|
||||||
else roundPrecision precision p
|
where
|
||||||
in (mapAdd_ c v m, f {faValue = v})
|
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
|
allo2Trans
|
||||||
:: BudgetMeta
|
:: BudgetMeta
|
||||||
|
@ -431,6 +299,22 @@ allo2Trans meta day from FlatAllocation {faValue, faTo, faDesc, faCur} =
|
||||||
, ftDesc = faDesc
|
, 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
|
allocateTax
|
||||||
:: Natural
|
:: Natural
|
||||||
-> Rational
|
-> Rational
|
||||||
|
@ -451,19 +335,6 @@ allocateTax precision gross preDeds f = fmap (fmap go)
|
||||||
let taxDed = roundPrecision precision $ f precision tpDeductible
|
let taxDed = roundPrecision precision $ f precision tpDeductible
|
||||||
in foldBracket f precision (agi - taxDed) tpBrackets
|
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
|
-- | Compute effective tax percentage of a bracket
|
||||||
-- The algorithm can be thought of in three phases:
|
-- The algorithm can be thought of in three phases:
|
||||||
-- 1. Find the highest tax bracket by looping backward until the AGI is less
|
-- 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
|
p = roundPrecision 3 tbPercent / 100
|
||||||
in if remain >= l then (acc + p * (remain - l), l) else a
|
in if remain >= l then (acc + p * (remain - l), l) else a
|
||||||
|
|
||||||
data FlatAllocation v = FlatAllocation
|
allocatePost
|
||||||
{ faValue :: !v
|
:: Natural
|
||||||
, faDesc :: !T.Text
|
-> Rational
|
||||||
, faTo :: !TaggedAcnt
|
-> [FlatAllocation PosttaxValue]
|
||||||
, faCur :: !BudgetCurrency
|
-> [FlatAllocation Rational]
|
||||||
}
|
allocatePost precision aftertax = fmap (fmap go)
|
||||||
deriving (Functor, Show)
|
|
||||||
|
|
||||||
flattenAllo :: SingleAllocation v -> [FlatAllocation v]
|
|
||||||
flattenAllo Allocation {alloAmts, alloCur, alloTo} = fmap go alloAmts
|
|
||||||
where
|
where
|
||||||
go Amount {amtValue, amtDesc} =
|
go PosttaxValue {postValue, postPercent} =
|
||||||
FlatAllocation
|
let v = postValue
|
||||||
{ faCur = NoX alloCur
|
in if postPercent
|
||||||
, faTo = alloTo
|
then aftertax * roundPrecision 3 v / 100
|
||||||
, faValue = amtValue
|
else roundPrecision precision v
|
||||||
, faDesc = amtDesc
|
|
||||||
}
|
|
||||||
|
|
||||||
-- ASSUME allocations are sorted
|
--------------------------------------------------------------------------------
|
||||||
selectAllos :: Day -> BoundAllocation v -> [FlatAllocation v]
|
-- Transfer
|
||||||
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
|
|
||||||
}
|
|
||||||
|
|
||||||
expandTransfers
|
expandTransfers
|
||||||
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
|
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
|
||||||
|
@ -530,12 +385,8 @@ expandTransfers key name localInterval ts = do
|
||||||
case localInterval of
|
case localInterval of
|
||||||
Nothing -> return txs
|
Nothing -> return txs
|
||||||
Just i -> do
|
Just i -> do
|
||||||
bounds <- liftExcept $ resolveBounds i
|
bounds <- liftExcept $ resolveDaySpan i
|
||||||
return $ filter (inBounds bounds . ftWhen) txs
|
return $ filter (inDaySpan bounds . ftWhen) txs
|
||||||
|
|
||||||
initialCurrency :: BudgetCurrency -> CurID
|
|
||||||
initialCurrency (NoX c) = c
|
|
||||||
initialCurrency (X Exchange {xFromCur = c}) = c
|
|
||||||
|
|
||||||
expandTransfer
|
expandTransfer
|
||||||
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
|
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
|
||||||
|
@ -567,248 +418,116 @@ expandTransfer key name Transfer {transAmounts, transTo, transCurrency, transFro
|
||||||
, ftDesc = desc
|
, ftDesc = desc
|
||||||
}
|
}
|
||||||
|
|
||||||
insertBudgetTx :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m) => BalancedTransfer -> m ()
|
withDates
|
||||||
insertBudgetTx FlatTransfer {ftFrom, ftTo, ftMeta, ftCur, ftValue, ftDesc, ftWhen} = do
|
:: (MonadSqlQuery m, MonadFinance m, MonadInsertError m)
|
||||||
((sFrom, sTo), exchange) <- splitPair ftFrom ftTo ftCur ftValue
|
=> DatePat
|
||||||
insertPair sFrom sTo
|
-> (Day -> m a)
|
||||||
forM_ exchange $ uncurry insertPair
|
-> 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
|
where
|
||||||
insertPair from to = do
|
memberMaybe x AcntSet {asList, asInclude} =
|
||||||
k <- insert $ TransactionR (bmCommit ftMeta) ftWhen ftDesc
|
(if asInclude then id else not) $ x `elem` asList
|
||||||
insertBudgetLabel k from
|
|
||||||
insertBudgetLabel k to
|
--------------------------------------------------------------------------------
|
||||||
insertBudgetLabel k split = do
|
-- random
|
||||||
sk <- insertSplit k split
|
|
||||||
insert_ $ BudgetLabelR sk $ bmName ftMeta
|
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)
|
type SplitPair = (KeySplit, KeySplit)
|
||||||
|
|
||||||
splitPair
|
type PeriodScaler = Natural -> Double -> Double
|
||||||
:: (MonadInsertError m, MonadFinance m)
|
|
||||||
=> TaggedAcnt
|
data FlatAllocation v = FlatAllocation
|
||||||
-> TaggedAcnt
|
{ faValue :: !v
|
||||||
-> BudgetCurrency
|
, faDesc :: !T.Text
|
||||||
-> Rational
|
, faTo :: !TaggedAcnt
|
||||||
-> m (SplitPair, Maybe SplitPair)
|
, faCur :: !BudgetCurrency
|
||||||
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
|
|
||||||
}
|
}
|
||||||
|
deriving (Functor, Show)
|
||||||
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
|
|
|
@ -8,6 +8,10 @@ module Internal.Database.Ops
|
||||||
, flattenAcntRoot
|
, flattenAcntRoot
|
||||||
, paths2IDs
|
, paths2IDs
|
||||||
, mkPool
|
, mkPool
|
||||||
|
, whenHash
|
||||||
|
, whenHash_
|
||||||
|
, insertSplit
|
||||||
|
, resolveSplit
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
|
@ -24,6 +28,7 @@ import Database.Persist.Sqlite hiding
|
||||||
, deleteWhere
|
, deleteWhere
|
||||||
, insert
|
, insert
|
||||||
, insertKey
|
, insertKey
|
||||||
|
, insert_
|
||||||
, runMigration
|
, runMigration
|
||||||
, (==.)
|
, (==.)
|
||||||
, (||.)
|
, (||.)
|
||||||
|
@ -319,8 +324,8 @@ getDBState c = do
|
||||||
, kmCurrenciesOld = cs
|
, kmCurrenciesOld = cs
|
||||||
}
|
}
|
||||||
where
|
where
|
||||||
bi = liftExcept $ resolveBounds $ budgetInterval $ global c
|
bi = liftExcept $ resolveDaySpan $ budgetInterval $ global c
|
||||||
si = liftExcept $ resolveBounds $ statementInterval $ global c
|
si = liftExcept $ resolveDaySpan $ statementInterval $ global c
|
||||||
(acnts, paths, am) = indexAcntRoot $ accounts c
|
(acnts, paths, am) = indexAcntRoot $ accounts c
|
||||||
cs = currency2Record <$> currencies c
|
cs = currency2Record <$> currencies c
|
||||||
ts = toRecord <$> tags 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 :: (MonadSqlQuery m, SqlSelect a r) => E.SqlQuery a -> m [r]
|
||||||
selectE q = unsafeLiftSql "esqueleto-select" (E.select q)
|
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
|
{ kmCurrency :: !CurrencyMap
|
||||||
, kmAccount :: !AccountMap
|
, kmAccount :: !AccountMap
|
||||||
, kmTag :: !TagMap
|
, kmTag :: !TagMap
|
||||||
, kmBudgetInterval :: !Bounds
|
, kmBudgetInterval :: !DaySpan
|
||||||
, kmStatementInterval :: !Bounds
|
, kmStatementInterval :: !DaySpan
|
||||||
, kmNewCommits :: ![Int]
|
, kmNewCommits :: ![Int]
|
||||||
, kmOldCommits :: ![Int]
|
, kmOldCommits :: ![Int]
|
||||||
, kmConfigDir :: !FilePath
|
, kmConfigDir :: !FilePath
|
||||||
|
@ -63,35 +63,11 @@ type KeyTx = Tx KeySplit
|
||||||
|
|
||||||
type TreeR = Tree ([T.Text], AccountRId)
|
type TreeR = Tree ([T.Text], AccountRId)
|
||||||
|
|
||||||
type Balances = M.Map AccountRId Rational
|
|
||||||
|
|
||||||
type BalanceM = ReaderT (MVar Balances)
|
|
||||||
|
|
||||||
type MonadFinance = MonadReader DBState
|
type MonadFinance = MonadReader DBState
|
||||||
|
|
||||||
askDBState :: MonadFinance m => (DBState -> a) -> m a
|
askDBState :: MonadFinance m => (DBState -> a) -> m a
|
||||||
askDBState = asks
|
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
|
-- misc
|
||||||
|
|
||||||
|
@ -125,8 +101,7 @@ data TxRecord = TxRecord
|
||||||
}
|
}
|
||||||
deriving (Show, Eq, Ord)
|
deriving (Show, Eq, Ord)
|
||||||
|
|
||||||
-- TODO pick a better name for this (something like DayInterval or something)
|
type DaySpan = (Day, Natural)
|
||||||
type Bounds = (Day, Natural)
|
|
||||||
|
|
||||||
data Keyed a = Keyed
|
data Keyed a = Keyed
|
||||||
{ kKey :: !Int64
|
{ kKey :: !Int64
|
||||||
|
@ -196,7 +171,7 @@ data InsertError
|
||||||
| BalanceError !BalanceType !CurID ![RawSplit]
|
| BalanceError !BalanceType !CurID ![RawSplit]
|
||||||
| IncomeError !Day !T.Text !Rational
|
| IncomeError !Day !T.Text !Rational
|
||||||
| PatternError !Natural !Natural !(Maybe Natural) !PatternSuberr
|
| PatternError !Natural !Natural !(Maybe Natural) !PatternSuberr
|
||||||
| BoundsError !Gregorian !(Maybe Gregorian)
|
| DaySpanError !Gregorian !(Maybe Gregorian)
|
||||||
| StatementError ![TxRecord] ![MatchRe]
|
| StatementError ![TxRecord] ![MatchRe]
|
||||||
| PeriodError !Day !Day
|
| PeriodError !Day !Day
|
||||||
deriving (Show)
|
deriving (Show)
|
||||||
|
|
|
@ -1,14 +1,15 @@
|
||||||
module Internal.Utils
|
module Internal.Utils
|
||||||
( compareDate
|
( compareDate
|
||||||
|
, expandDatePat
|
||||||
|
, askDays
|
||||||
, fromWeekday
|
, fromWeekday
|
||||||
, inBounds
|
, inDaySpan
|
||||||
, expandBounds
|
|
||||||
, fmtRational
|
, fmtRational
|
||||||
, matches
|
, matches
|
||||||
, fromGregorian'
|
, fromGregorian'
|
||||||
, resolveBounds
|
, resolveDaySpan
|
||||||
, resolveBounds_
|
, resolveDaySpan_
|
||||||
, intersectBounds
|
, intersectDaySpan
|
||||||
, liftInner
|
, liftInner
|
||||||
, liftExceptT
|
, liftExceptT
|
||||||
, liftExcept
|
, liftExcept
|
||||||
|
@ -48,6 +49,12 @@ module Internal.Utils
|
||||||
, valMatches
|
, valMatches
|
||||||
, roundPrecision
|
, roundPrecision
|
||||||
, roundPrecisionCur
|
, roundPrecisionCur
|
||||||
|
, lookupAccountKey
|
||||||
|
, lookupAccountSign
|
||||||
|
, lookupAccountType
|
||||||
|
, lookupCurrencyKey
|
||||||
|
, lookupCurrencyPrec
|
||||||
|
, lookupTag
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
|
@ -66,6 +73,96 @@ import RIO.Time
|
||||||
import Text.Regex.TDFA
|
import Text.Regex.TDFA
|
||||||
import Text.Regex.TDFA.Text
|
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
|
-- dates
|
||||||
|
|
||||||
|
@ -152,39 +249,42 @@ compareDate (In md offset) x = do
|
||||||
fromGregorian' :: Gregorian -> Day
|
fromGregorian' :: Gregorian -> Day
|
||||||
fromGregorian' = uncurry3 fromGregorian . gregTup
|
fromGregorian' = uncurry3 fromGregorian . gregTup
|
||||||
|
|
||||||
inBounds :: Bounds -> Day -> Bool
|
inDaySpan :: DaySpan -> Day -> Bool
|
||||||
inBounds bs = withinDays (expandBounds bs)
|
inDaySpan bs = withinDays (fromDaySpan bs)
|
||||||
|
|
||||||
withinDays :: (Day, Day) -> Day -> Bool
|
withinDays :: (Day, Day) -> Day -> Bool
|
||||||
withinDays (d0, d1) x = d0 <= x && x < d1
|
withinDays (d0, d1) x = d0 <= x && x < d1
|
||||||
|
|
||||||
resolveBounds :: Interval -> InsertExcept Bounds
|
resolveDaySpan :: Interval -> InsertExcept DaySpan
|
||||||
resolveBounds i@Interval {intStart = s} =
|
resolveDaySpan i@Interval {intStart = s} =
|
||||||
resolveBounds_ (s {gYear = gYear s + 50}) i
|
resolveDaySpan_ (s {gYear = gYear s + 50}) i
|
||||||
|
|
||||||
-- TODO not DRY
|
intersectDaySpan :: DaySpan -> DaySpan -> Maybe DaySpan
|
||||||
intersectBounds :: Bounds -> Bounds -> Maybe Bounds
|
intersectDaySpan a b =
|
||||||
intersectBounds a b =
|
if b' > a' then Nothing else Just $ toDaySpan (a', b')
|
||||||
if b' > a' then Nothing else Just (a', fromIntegral $ diffDays b' a' - 1)
|
|
||||||
where
|
where
|
||||||
(a0, a1) = expandBounds a
|
(a0, a1) = fromDaySpan a
|
||||||
(b0, b1) = expandBounds b
|
(b0, b1) = fromDaySpan b
|
||||||
a' = max a0 a1
|
a' = max a0 a1
|
||||||
b' = min b0 b1
|
b' = min b0 b1
|
||||||
|
|
||||||
resolveBounds_ :: Gregorian -> Interval -> InsertExcept Bounds
|
resolveDaySpan_ :: Gregorian -> Interval -> InsertExcept DaySpan
|
||||||
resolveBounds_ def Interval {intStart = s, intEnd = e} =
|
resolveDaySpan_ def Interval {intStart = s, intEnd = e} =
|
||||||
case fromGregorian' <$> e of
|
case fromGregorian' <$> e of
|
||||||
Nothing -> return $ toBounds $ fromGregorian' def
|
Nothing -> return $ toDaySpan_ $ fromGregorian' def
|
||||||
Just e_
|
Just e_
|
||||||
| s_ < e_ -> return $ toBounds e_
|
| s_ < e_ -> return $ toDaySpan_ e_
|
||||||
| otherwise -> throwError $ InsertException [BoundsError s e]
|
| otherwise -> throwError $ InsertException [DaySpanError s e]
|
||||||
where
|
where
|
||||||
s_ = fromGregorian' s
|
s_ = fromGregorian' s
|
||||||
toBounds end = (s_, fromIntegral $ diffDays end s_ - 1)
|
toDaySpan_ end = toDaySpan (s_, end)
|
||||||
|
|
||||||
expandBounds :: Bounds -> (Day, Day)
|
fromDaySpan :: DaySpan -> (Day, Day)
|
||||||
expandBounds (d, n) = (d, addDays (fromIntegral n + 1) d)
|
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
|
-- matching
|
||||||
|
@ -457,7 +557,7 @@ acntPath2Text (AcntPath t cs) = T.intercalate "/" (atName t : cs)
|
||||||
showError :: InsertError -> [T.Text]
|
showError :: InsertError -> [T.Text]
|
||||||
showError other = case other of
|
showError other = case other of
|
||||||
(StatementError ts ms) -> (showTx <$> ts) ++ (showMatch <$> ms)
|
(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]]
|
[T.unwords ["Could not create bounds from", showGregorian_ a, "and", showGreg b]]
|
||||||
where
|
where
|
||||||
showGreg (Just g) = showGregorian_ g
|
showGreg (Just g) = showGregorian_ g
|
||||||
|
@ -794,3 +894,35 @@ matchGroupsMaybe q re = case regexec re q of
|
||||||
Right (Just (_, _, _, xs)) -> xs
|
Right (Just (_, _, _, xs)) -> xs
|
||||||
-- this should never fail as regexec always returns Right
|
-- this should never fail as regexec always returns Right
|
||||||
Left _ -> []
|
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