REF split history and budget

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

View File

@ -8,9 +8,10 @@ import Control.Monad.Logger
import Control.Monad.Reader import 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

View File

@ -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

View File

@ -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

View File

@ -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
}

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

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

View File

@ -44,8 +44,8 @@ data DBState = DBState
{ kmCurrency :: !CurrencyMap { 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)

View File

@ -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