Merge branch 'add_budget_limits'
This commit is contained in:
commit
53d77326f5
25
app/Main.hs
25
app/Main.hs
|
@ -8,10 +8,11 @@ import Control.Monad.Logger
|
|||
import Control.Monad.Reader
|
||||
import qualified Data.Text.IO as TI
|
||||
import Database.Persist.Monad
|
||||
import Internal.Config
|
||||
import Internal.Database.Ops
|
||||
import Internal.Insert
|
||||
import Internal.Types
|
||||
import Dhall hiding (double, record)
|
||||
import Internal.Budget
|
||||
import Internal.Database
|
||||
import Internal.History
|
||||
import Internal.Types.Main
|
||||
import Internal.Utils
|
||||
import Options.Applicative
|
||||
import RIO
|
||||
|
@ -168,25 +169,31 @@ runSync c = do
|
|||
-- _ <- askLoggerIO
|
||||
|
||||
-- get the current DB state
|
||||
s <- runSqlQueryT pool $ do
|
||||
(state, updates) <- runSqlQueryT pool $ do
|
||||
runMigration migrateAll
|
||||
fmap (\f -> f $ takeDirectory c) $ liftIOExceptT $ getDBState config
|
||||
liftIOExceptT $ getDBState config
|
||||
|
||||
-- read desired statements from disk
|
||||
bSs <- flip runReaderT s $ catMaybes <$> mapErrorsIO readHistStmt hSs
|
||||
bSs <-
|
||||
flip runReaderT state $
|
||||
catMaybes <$> mapErrorsIO (readHistStmt root) hSs
|
||||
|
||||
-- update the DB
|
||||
runSqlQueryT pool $ withTransaction $ flip runReaderT s $ do
|
||||
runSqlQueryT pool $ withTransaction $ flip runReaderT state $ do
|
||||
let hTransRes = mapErrors insertHistTransfer hTs
|
||||
let bgtRes = mapErrors insertBudget $ budget config
|
||||
updateDBState -- TODO this will only work if foreign keys are deferred
|
||||
updateDBState updates -- TODO this will only work if foreign keys are deferred
|
||||
res <- runExceptT $ do
|
||||
mapM_ (uncurry insertHistStmt) bSs
|
||||
combineError hTransRes bgtRes $ \_ _ -> ()
|
||||
rerunnableIO $ fromEither res
|
||||
where
|
||||
root = takeDirectory c
|
||||
err (InsertException es) = do
|
||||
liftIO $ mapM_ TI.putStrLn $ concatMap showError es
|
||||
exitFailure
|
||||
|
||||
-- showBalances
|
||||
|
||||
readConfig :: MonadUnliftIO m => FilePath -> m Config
|
||||
readConfig confpath = liftIO $ unfix <$> Dhall.inputFile Dhall.auto confpath
|
||||
|
|
13
budget.cabal
13
budget.cabal
|
@ -25,12 +25,13 @@ source-repository head
|
|||
|
||||
library
|
||||
exposed-modules:
|
||||
Internal.Config
|
||||
Internal.Database.Ops
|
||||
Internal.Insert
|
||||
Internal.Statement
|
||||
Internal.TH
|
||||
Internal.Types
|
||||
Internal.Budget
|
||||
Internal.Database
|
||||
Internal.History
|
||||
Internal.Types.Database
|
||||
Internal.Types.Dhall
|
||||
Internal.Types.Main
|
||||
Internal.Types.TH
|
||||
Internal.Utils
|
||||
other-modules:
|
||||
Paths_budget
|
||||
|
|
|
@ -1018,6 +1018,7 @@ let Budget =
|
|||
, bgtPosttax : List (MultiAllocation PosttaxValue)
|
||||
, bgtTransfers : List BudgetTransfer
|
||||
, bgtShadowTransfers : List ShadowTransfer
|
||||
, bgtInterval : Optional Interval
|
||||
}
|
||||
|
||||
in { CurID
|
||||
|
|
|
@ -0,0 +1,570 @@
|
|||
module Internal.Budget (insertBudget) where
|
||||
|
||||
import Control.Monad.Except
|
||||
import Data.Foldable
|
||||
import Database.Persist.Monad
|
||||
import Internal.Database
|
||||
import Internal.Types.Main
|
||||
import Internal.Utils
|
||||
import RIO hiding (to)
|
||||
import qualified RIO.List as L
|
||||
import qualified RIO.Map as M
|
||||
import qualified RIO.NonEmpty as NE
|
||||
import qualified RIO.Text as T
|
||||
import RIO.Time
|
||||
|
||||
-- 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
|
||||
-- 5. insert all transactions
|
||||
|
||||
insertBudget
|
||||
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
|
||||
=> Budget
|
||||
-> m ()
|
||||
insertBudget
|
||||
b@Budget
|
||||
{ bgtLabel
|
||||
, bgtIncomes
|
||||
, bgtTransfers
|
||||
, bgtShadowTransfers
|
||||
, bgtPretax
|
||||
, bgtTax
|
||||
, bgtPosttax
|
||||
, bgtInterval
|
||||
} =
|
||||
whenHash CTBudget b () $ \key -> do
|
||||
(intAllos, _) <- combineError intAlloRes acntRes (,)
|
||||
let res1 = mapErrors (insertIncome key bgtLabel intAllos bgtInterval) bgtIncomes
|
||||
let res2 = expandTransfers key bgtLabel bgtInterval bgtTransfers
|
||||
txs <- combineError (concat <$> res1) res2 (++)
|
||||
m <- askDBState kmCurrency
|
||||
shadow <- liftExcept $ addShadowTransfers m bgtShadowTransfers txs
|
||||
void $ mapErrors insertBudgetTx $ balanceTransfers $ txs ++ shadow
|
||||
where
|
||||
acntRes = mapErrors isNotIncomeAcnt alloAcnts
|
||||
intAlloRes = combineError3 pre_ tax_ post_ (,,)
|
||||
pre_ = sortAllos bgtPretax
|
||||
tax_ = sortAllos bgtTax
|
||||
post_ = sortAllos bgtPosttax
|
||||
sortAllos = liftExcept . mapErrors sortAllo
|
||||
alloAcnts =
|
||||
(alloAcnt <$> bgtPretax)
|
||||
++ (alloAcnt <$> bgtTax)
|
||||
++ (alloAcnt <$> bgtPosttax)
|
||||
|
||||
balanceTransfers :: [UnbalancedTransfer] -> [BalancedTransfer]
|
||||
balanceTransfers = snd . L.mapAccumR go M.empty . reverse . L.sortOn ftWhen
|
||||
where
|
||||
go bals f@FlatTransfer {ftFrom, ftTo, ftValue = UnbalancedValue {cvValue, cvType}} =
|
||||
let balTo = M.findWithDefault 0 ftTo bals
|
||||
x = amtToMove balTo cvType cvValue
|
||||
bals' = mapAdd_ ftTo x $ mapAdd_ ftFrom (-x) bals
|
||||
in (bals', f {ftValue = x})
|
||||
-- TODO might need to query signs to make this intuitive; as it is this will
|
||||
-- probably work, but for credit accounts I might need to supply a negative
|
||||
-- target value
|
||||
amtToMove _ BTFixed x = x
|
||||
amtToMove bal BTPercent x = -(x / 100 * bal)
|
||||
amtToMove bal BTTarget x = x - bal
|
||||
|
||||
-- TODO this seems too general for this module
|
||||
mapAdd_ :: (Ord k, Num v) => k -> v -> M.Map k v -> M.Map k v
|
||||
mapAdd_ k v = M.alter (maybe (Just v) (Just . (+ v))) k
|
||||
|
||||
insertBudgetTx
|
||||
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
|
||||
=> BalancedTransfer
|
||||
-> m ()
|
||||
insertBudgetTx FlatTransfer {ftFrom, ftTo, ftMeta, ftCur, ftValue, ftDesc, ftWhen} = do
|
||||
((sFrom, sTo), exchange) <- entryPair ftFrom ftTo ftCur ftValue
|
||||
insertPair sFrom sTo
|
||||
forM_ exchange $ uncurry insertPair
|
||||
where
|
||||
insertPair from to = do
|
||||
k <- insert $ TransactionR (bmCommit ftMeta) ftWhen ftDesc
|
||||
insertBudgetLabel k from
|
||||
insertBudgetLabel k to
|
||||
insertBudgetLabel k entry = do
|
||||
sk <- insertEntry k entry
|
||||
insert_ $ BudgetLabelR sk $ bmName ftMeta
|
||||
|
||||
entryPair
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
=> TaggedAcnt
|
||||
-> TaggedAcnt
|
||||
-> BudgetCurrency
|
||||
-> Rational
|
||||
-> m (EntryPair, Maybe EntryPair)
|
||||
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 = entry curid from_ (-v)
|
||||
let s2 = entry curid to_ v
|
||||
combineError s1 s2 (,)
|
||||
entry c TaggedAcnt {taAcnt, taTags} v =
|
||||
resolveEntry $
|
||||
Entry
|
||||
{ eAcnt = taAcnt
|
||||
, eValue = v
|
||||
, eComment = ""
|
||||
, eCurrency = c
|
||||
, eTags = taTags
|
||||
}
|
||||
|
||||
sortAllo :: MultiAllocation v -> InsertExcept (DaySpanAllocation v)
|
||||
sortAllo a@Allocation {alloAmts = as} = do
|
||||
bs <- foldSpan [] $ L.sortOn amtWhen as
|
||||
return $ a {alloAmts = reverse bs}
|
||||
where
|
||||
foldSpan acc [] = return acc
|
||||
foldSpan acc (x : xs) = do
|
||||
let start = amtWhen x
|
||||
res <- case xs of
|
||||
[] -> resolveDaySpan start
|
||||
(y : _) -> resolveDaySpan_ (intStart $ amtWhen y) start
|
||||
foldSpan (x {amtWhen = res} : acc) xs
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Income
|
||||
|
||||
-- TODO this will scan the interval allocations fully each time
|
||||
-- iteration which is a total waste, but the fix requires turning this
|
||||
-- loop into a fold which I don't feel like doing now :(
|
||||
insertIncome
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
=> CommitRId
|
||||
-> T.Text
|
||||
-> IntAllocations
|
||||
-> Maybe Interval
|
||||
-> Income
|
||||
-> m [UnbalancedTransfer]
|
||||
insertIncome
|
||||
key
|
||||
name
|
||||
(intPre, intTax, intPost)
|
||||
localInterval
|
||||
Income
|
||||
{ incWhen
|
||||
, incCurrency
|
||||
, incFrom
|
||||
, incPretax
|
||||
, incPosttax
|
||||
, incTaxes
|
||||
, incToBal
|
||||
, incGross
|
||||
, incPayPeriod
|
||||
} =
|
||||
combineErrorM
|
||||
(combineError incRes nonIncRes (,))
|
||||
(combineError precRes dayRes (,))
|
||||
$ \_ (precision, days) -> do
|
||||
let gross = roundPrecision precision incGross
|
||||
concat <$> foldDays (allocate precision gross) start days
|
||||
where
|
||||
incRes = isIncomeAcnt $ taAcnt incFrom
|
||||
nonIncRes =
|
||||
mapErrors isNotIncomeAcnt $
|
||||
taAcnt incToBal
|
||||
: (alloAcnt <$> incPretax)
|
||||
++ (alloAcnt <$> incTaxes)
|
||||
++ (alloAcnt <$> incPosttax)
|
||||
precRes = lookupCurrencyPrec incCurrency
|
||||
dayRes = askDays incWhen localInterval
|
||||
start = fromGregorian' $ pStart incPayPeriod
|
||||
pType' = pType incPayPeriod
|
||||
meta = BudgetMeta key name
|
||||
flatPre = concatMap flattenAllo incPretax
|
||||
flatTax = concatMap flattenAllo incTaxes
|
||||
flatPost = concatMap flattenAllo incPosttax
|
||||
sumAllos = sum . fmap faValue
|
||||
-- TODO ensure these are all the "correct" accounts
|
||||
allocate precision gross prevDay day = do
|
||||
scaler <- liftExcept $ periodScaler pType' prevDay day
|
||||
let (preDeductions, pre) =
|
||||
allocatePre precision gross $
|
||||
flatPre ++ concatMap (selectAllos day) intPre
|
||||
tax =
|
||||
allocateTax precision gross preDeductions scaler $
|
||||
flatTax ++ concatMap (selectAllos day) intTax
|
||||
aftertaxGross = gross - sumAllos (tax ++ pre)
|
||||
post =
|
||||
allocatePost precision aftertaxGross $
|
||||
flatPost ++ concatMap (selectAllos day) intPost
|
||||
balance = aftertaxGross - sumAllos post
|
||||
bal =
|
||||
FlatTransfer
|
||||
{ ftMeta = meta
|
||||
, ftWhen = day
|
||||
, ftFrom = incFrom
|
||||
, ftCur = NoX incCurrency
|
||||
, ftTo = incToBal
|
||||
, ftValue = UnbalancedValue BTFixed balance
|
||||
, ftDesc = "balance after deductions"
|
||||
}
|
||||
in if balance < 0
|
||||
then throwError $ InsertException [IncomeError day name balance]
|
||||
else return (bal : fmap (allo2Trans meta day incFrom) (pre ++ tax ++ post))
|
||||
|
||||
periodScaler
|
||||
:: PeriodType
|
||||
-> Day
|
||||
-> Day
|
||||
-> InsertExcept PeriodScaler
|
||||
periodScaler pt prev cur = return scale
|
||||
where
|
||||
n = fromIntegral $ workingDays wds prev cur
|
||||
wds = case pt of
|
||||
Hourly HourlyPeriod {hpWorkingDays} -> hpWorkingDays
|
||||
Daily ds -> ds
|
||||
scale precision x = case pt of
|
||||
Hourly HourlyPeriod {hpAnnualHours, hpDailyHours} ->
|
||||
fromRational (rnd $ x / fromIntegral hpAnnualHours)
|
||||
* fromIntegral hpDailyHours
|
||||
* n
|
||||
Daily _ -> x * n / 365.25
|
||||
where
|
||||
rnd = roundPrecision precision
|
||||
|
||||
-- ASSUME start < end
|
||||
workingDays :: [Weekday] -> Day -> Day -> Natural
|
||||
workingDays wds start end = fromIntegral $ daysFull + daysTail
|
||||
where
|
||||
interval = diffDays end start
|
||||
(nFull, nPart) = divMod interval 7
|
||||
daysFull = fromIntegral (length wds') * nFull
|
||||
daysTail = fromIntegral $ length $ takeWhile (< nPart) wds'
|
||||
startDay = dayOfWeek start
|
||||
wds' = L.sort $ (\x -> diff (fromWeekday x) startDay) <$> L.nub wds
|
||||
diff a b = fromIntegral $ mod (fromEnum a - fromEnum b) 7
|
||||
|
||||
-- ASSUME days is a sorted list
|
||||
foldDays
|
||||
:: MonadInsertError m
|
||||
=> (Day -> Day -> m a)
|
||||
-> Day
|
||||
-> [Day]
|
||||
-> m [a]
|
||||
foldDays f start days = case NE.nonEmpty days of
|
||||
Nothing -> return []
|
||||
Just ds
|
||||
| any (start >) ds ->
|
||||
throwError $
|
||||
InsertException [PeriodError start $ minimum ds]
|
||||
| otherwise ->
|
||||
combineErrors $
|
||||
snd $
|
||||
L.mapAccumL (\prevDay day -> (day, f prevDay day)) start days
|
||||
|
||||
isIncomeAcnt :: (MonadInsertError m, MonadFinance m) => AcntID -> m ()
|
||||
isIncomeAcnt = checkAcntType IncomeT
|
||||
|
||||
isNotIncomeAcnt :: (MonadInsertError m, MonadFinance m) => AcntID -> m ()
|
||||
isNotIncomeAcnt = checkAcntTypes (AssetT :| [EquityT, ExpenseT, LiabilityT])
|
||||
|
||||
checkAcntType
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
=> AcntType
|
||||
-> AcntID
|
||||
-> m ()
|
||||
checkAcntType t = checkAcntTypes (t :| [])
|
||||
|
||||
checkAcntTypes
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
=> NE.NonEmpty AcntType
|
||||
-> AcntID
|
||||
-> m ()
|
||||
checkAcntTypes ts i = void $ go =<< lookupAccountType i
|
||||
where
|
||||
go t
|
||||
| t `L.elem` ts = return i
|
||||
| otherwise = throwError $ InsertException [AccountError i ts]
|
||||
|
||||
flattenAllo :: SingleAllocation v -> [FlatAllocation v]
|
||||
flattenAllo Allocation {alloAmts, alloCur, alloTo} = fmap go alloAmts
|
||||
where
|
||||
go Amount {amtValue, amtDesc} =
|
||||
FlatAllocation
|
||||
{ faCur = NoX alloCur
|
||||
, faTo = alloTo
|
||||
, faValue = amtValue
|
||||
, faDesc = amtDesc
|
||||
}
|
||||
|
||||
-- ASSUME allocations are sorted
|
||||
selectAllos :: Day -> DaySpanAllocation v -> [FlatAllocation v]
|
||||
selectAllos day Allocation {alloAmts, alloCur, alloTo} =
|
||||
go <$> filter ((`inDaySpan` day) . amtWhen) alloAmts
|
||||
where
|
||||
go Amount {amtValue, amtDesc} =
|
||||
FlatAllocation
|
||||
{ faCur = NoX alloCur
|
||||
, faTo = alloTo
|
||||
, faValue = amtValue
|
||||
, faDesc = amtDesc
|
||||
}
|
||||
|
||||
allo2Trans
|
||||
:: BudgetMeta
|
||||
-> Day
|
||||
-> TaggedAcnt
|
||||
-> FlatAllocation Rational
|
||||
-> UnbalancedTransfer
|
||||
allo2Trans meta day from FlatAllocation {faValue, faTo, faDesc, faCur} =
|
||||
FlatTransfer
|
||||
{ ftMeta = meta
|
||||
, ftWhen = day
|
||||
, ftFrom = from
|
||||
, ftCur = faCur
|
||||
, ftTo = faTo
|
||||
, ftValue = UnbalancedValue BTFixed faValue
|
||||
, ftDesc = faDesc
|
||||
}
|
||||
|
||||
allocatePre
|
||||
:: Natural
|
||||
-> Rational
|
||||
-> [FlatAllocation PretaxValue]
|
||||
-> (M.Map T.Text Rational, [FlatAllocation Rational])
|
||||
allocatePre precision gross = L.mapAccumR go M.empty
|
||||
where
|
||||
go m f@FlatAllocation {faValue} =
|
||||
let c = preCategory faValue
|
||||
p = preValue faValue
|
||||
v =
|
||||
if prePercent faValue
|
||||
then (roundPrecision 3 p / 100) * gross
|
||||
else roundPrecision precision p
|
||||
in (mapAdd_ c v m, f {faValue = v})
|
||||
|
||||
allocateTax
|
||||
:: Natural
|
||||
-> Rational
|
||||
-> M.Map T.Text Rational
|
||||
-> PeriodScaler
|
||||
-> [FlatAllocation TaxValue]
|
||||
-> [FlatAllocation Rational]
|
||||
allocateTax precision gross preDeds f = fmap (fmap go)
|
||||
where
|
||||
go TaxValue {tvCategories, tvMethod} =
|
||||
let agi = gross - sum (mapMaybe (`M.lookup` preDeds) tvCategories)
|
||||
in case tvMethod of
|
||||
TMPercent p ->
|
||||
roundPrecision precision $
|
||||
fromRational $
|
||||
roundPrecision 3 p / 100 * agi
|
||||
TMBracket TaxProgression {tpDeductible, tpBrackets} ->
|
||||
let taxDed = roundPrecision precision $ f precision tpDeductible
|
||||
in foldBracket f precision (agi - taxDed) tpBrackets
|
||||
|
||||
-- | Compute effective tax percentage of a bracket
|
||||
-- The algorithm can be thought of in three phases:
|
||||
-- 1. Find the highest tax bracket by looping backward until the AGI is less
|
||||
-- than the bracket limit
|
||||
-- 2. Computing the tax in the top bracket by subtracting the AGI from the
|
||||
-- bracket limit and multiplying by the tax percentage.
|
||||
-- 3. Adding all lower brackets, which are just the limit of the bracket less
|
||||
-- the amount of the lower bracket times the percentage.
|
||||
--
|
||||
-- In reality, this can all be done with one loop, but it isn't clear these
|
||||
-- three steps are implemented from this alone.
|
||||
foldBracket :: PeriodScaler -> Natural -> Rational -> [TaxBracket] -> Rational
|
||||
foldBracket f precision agi bs = fst $ foldr go (0, agi) $ L.sortOn tbLowerLimit bs
|
||||
where
|
||||
go TaxBracket {tbLowerLimit, tbPercent} a@(acc, remain) =
|
||||
let l = roundPrecision precision $ f precision tbLowerLimit
|
||||
p = roundPrecision 3 tbPercent / 100
|
||||
in if remain >= l then (acc + p * (remain - l), l) else a
|
||||
|
||||
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
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Standalone Transfer
|
||||
|
||||
expandTransfers
|
||||
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
|
||||
=> CommitRId
|
||||
-> T.Text
|
||||
-> Maybe Interval
|
||||
-> [BudgetTransfer]
|
||||
-> m [UnbalancedTransfer]
|
||||
expandTransfers key name localInterval ts = do
|
||||
txs <-
|
||||
fmap (L.sortOn ftWhen . concat) $
|
||||
combineErrors $
|
||||
fmap (expandTransfer key name) ts
|
||||
case localInterval of
|
||||
Nothing -> return txs
|
||||
Just i -> do
|
||||
bounds <- liftExcept $ resolveDaySpan i
|
||||
return $ filter (inDaySpan bounds . ftWhen) txs
|
||||
|
||||
expandTransfer
|
||||
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
|
||||
=> CommitRId
|
||||
-> T.Text
|
||||
-> BudgetTransfer
|
||||
-> m [UnbalancedTransfer]
|
||||
expandTransfer key name Transfer {transAmounts, transTo, transCurrency, transFrom} = do
|
||||
precision <- lookupCurrencyPrec $ initialCurrency transCurrency
|
||||
fmap concat $ combineErrors $ fmap (go precision) transAmounts
|
||||
where
|
||||
go
|
||||
precision
|
||||
Amount
|
||||
{ amtWhen = pat
|
||||
, amtValue = BudgetTransferValue {btVal = v, btType = y}
|
||||
, amtDesc = desc
|
||||
} =
|
||||
withDates pat $ \day -> do
|
||||
let meta = BudgetMeta {bmCommit = key, bmName = name}
|
||||
return
|
||||
FlatTransfer
|
||||
{ ftMeta = meta
|
||||
, ftWhen = day
|
||||
, ftCur = transCurrency
|
||||
, ftFrom = transFrom
|
||||
, ftTo = transTo
|
||||
, ftValue = UnbalancedValue y $ roundPrecision precision v
|
||||
, ftDesc = desc
|
||||
}
|
||||
|
||||
withDates
|
||||
:: (MonadSqlQuery m, MonadFinance m, MonadInsertError m)
|
||||
=> DatePat
|
||||
-> (Day -> m a)
|
||||
-> m [a]
|
||||
withDates dp f = do
|
||||
bounds <- askDBState kmBudgetInterval
|
||||
days <- liftExcept $ expandDatePat bounds dp
|
||||
combineErrors $ fmap f days
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- shadow transfers
|
||||
|
||||
-- TODO this is going to be O(n*m), which might be a problem?
|
||||
addShadowTransfers
|
||||
:: CurrencyMap
|
||||
-> [ShadowTransfer]
|
||||
-> [UnbalancedTransfer]
|
||||
-> InsertExcept [UnbalancedTransfer]
|
||||
addShadowTransfers cm ms txs =
|
||||
fmap catMaybes $
|
||||
combineErrors $
|
||||
fmap (uncurry (fromShadow cm)) $
|
||||
[(t, m) | t <- txs, m <- ms]
|
||||
|
||||
fromShadow
|
||||
:: CurrencyMap
|
||||
-> UnbalancedTransfer
|
||||
-> ShadowTransfer
|
||||
-> InsertExcept (Maybe UnbalancedTransfer)
|
||||
fromShadow cm tx t@ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stType} = do
|
||||
res <- shadowMatches (stMatch t) tx
|
||||
v <- roundPrecisionCur (initialCurrency stCurrency) cm stRatio
|
||||
return $
|
||||
if not res
|
||||
then Nothing
|
||||
else
|
||||
Just $
|
||||
FlatTransfer
|
||||
{ ftMeta = ftMeta tx
|
||||
, ftWhen = ftWhen tx
|
||||
, ftCur = stCurrency
|
||||
, ftFrom = stFrom
|
||||
, ftTo = stTo
|
||||
, ftValue = UnbalancedValue stType $ v * cvValue (ftValue tx)
|
||||
, ftDesc = stDesc
|
||||
}
|
||||
|
||||
shadowMatches :: TransferMatcher -> UnbalancedTransfer -> InsertExcept Bool
|
||||
shadowMatches TransferMatcher {tmFrom, tmTo, tmDate, tmVal} tx = do
|
||||
valRes <- valMatches tmVal $ cvValue $ ftValue tx
|
||||
return $
|
||||
memberMaybe (taAcnt $ ftFrom tx) tmFrom
|
||||
&& memberMaybe (taAcnt $ ftTo tx) tmTo
|
||||
&& maybe True (`dateMatches` ftWhen tx) tmDate
|
||||
&& valRes
|
||||
where
|
||||
memberMaybe x AcntSet {asList, asInclude} =
|
||||
(if asInclude then id else not) $ x `elem` asList
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- random
|
||||
|
||||
initialCurrency :: BudgetCurrency -> CurID
|
||||
initialCurrency (NoX c) = c
|
||||
initialCurrency (X Exchange {xFromCur = c}) = c
|
||||
|
||||
alloAcnt :: Allocation w v -> AcntID
|
||||
alloAcnt = taAcnt . alloTo
|
||||
|
||||
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 EntryPair = (KeyEntry, KeyEntry)
|
||||
|
||||
type PeriodScaler = Natural -> Double -> Double
|
||||
|
||||
data FlatAllocation v = FlatAllocation
|
||||
{ faValue :: !v
|
||||
, faDesc :: !T.Text
|
||||
, faTo :: !TaggedAcnt
|
||||
, faCur :: !BudgetCurrency
|
||||
}
|
||||
deriving (Functor, Show)
|
|
@ -1,21 +0,0 @@
|
|||
module Internal.Config
|
||||
( readConfig
|
||||
-- , readYaml
|
||||
)
|
||||
where
|
||||
|
||||
-- import Control.Exception
|
||||
-- import Data.Yaml
|
||||
import Dhall hiding (record)
|
||||
import Internal.Types
|
||||
import RIO
|
||||
|
||||
readConfig :: MonadUnliftIO m => FilePath -> m Config
|
||||
readConfig confpath = liftIO $ unfix <$> inputFile auto confpath
|
||||
|
||||
-- readYaml :: FromJSON a => FilePath -> IO a
|
||||
-- readYaml p = do
|
||||
-- r <- decodeFileEither p
|
||||
-- case r of
|
||||
-- Right a -> return a
|
||||
-- Left e -> throw e
|
|
@ -1,4 +1,4 @@
|
|||
module Internal.Database.Ops
|
||||
module Internal.Database
|
||||
( runDB
|
||||
, nukeTables
|
||||
, updateHashes
|
||||
|
@ -8,6 +8,10 @@ module Internal.Database.Ops
|
|||
, flattenAcntRoot
|
||||
, paths2IDs
|
||||
, mkPool
|
||||
, whenHash
|
||||
, whenHash_
|
||||
, insertEntry
|
||||
, resolveEntry
|
||||
)
|
||||
where
|
||||
|
||||
|
@ -19,10 +23,18 @@ import Database.Esqueleto.Experimental ((==.), (^.))
|
|||
import qualified Database.Esqueleto.Experimental as E
|
||||
import Database.Esqueleto.Internal.Internal (SqlSelect)
|
||||
import Database.Persist.Monad
|
||||
-- import Database.Persist.Sql hiding (delete, runMigration, (==.), (||.))
|
||||
import Database.Persist.Sqlite hiding (delete, deleteWhere, insert, insertKey, runMigration, (==.), (||.))
|
||||
import Database.Persist.Sqlite hiding
|
||||
( delete
|
||||
, deleteWhere
|
||||
, insert
|
||||
, insertKey
|
||||
, insert_
|
||||
, runMigration
|
||||
, (==.)
|
||||
, (||.)
|
||||
)
|
||||
import GHC.Err
|
||||
import Internal.Types
|
||||
import Internal.Types.Main
|
||||
import Internal.Utils
|
||||
import RIO hiding (LogFunc, isNothing, on, (^.))
|
||||
import RIO.List ((\\))
|
||||
|
@ -288,79 +300,117 @@ indexAcntRoot r =
|
|||
getDBState
|
||||
:: (MonadInsertError m, MonadSqlQuery m)
|
||||
=> Config
|
||||
-> m (FilePath -> DBState)
|
||||
-> m (DBState, DBUpdates)
|
||||
getDBState c = do
|
||||
(del, new) <- getConfigHashes c
|
||||
-- TODO not sure how I feel about this, probably will change this struct alot
|
||||
-- in the future so whatever...for now
|
||||
combineError bi si $ \b s f ->
|
||||
-- TODO this can be cleaned up, half of it is meant to be queried when
|
||||
-- determining how to insert budgets/history and the rest is just
|
||||
-- holdover data to delete upon successful insertion
|
||||
DBState
|
||||
combineError bi si $ \b s ->
|
||||
( DBState
|
||||
{ kmCurrency = currencyMap cs
|
||||
, kmAccount = am
|
||||
, kmBudgetInterval = b
|
||||
, kmStatementInterval = s
|
||||
, kmNewCommits = new
|
||||
, kmOldCommits = del
|
||||
, kmConfigDir = f
|
||||
, kmTag = tagMap ts
|
||||
, kmTagAll = ts
|
||||
, kmAcntPaths = paths
|
||||
, kmAcntsOld = acnts
|
||||
, kmCurrenciesOld = cs
|
||||
, kmNewCommits = new
|
||||
}
|
||||
, DBUpdates
|
||||
{ duOldCommits = del
|
||||
, duNewTagIds = ts
|
||||
, duNewAcntPaths = paths
|
||||
, duNewAcntIds = acnts
|
||||
, duNewCurrencyIds = cs
|
||||
}
|
||||
)
|
||||
where
|
||||
bi = liftExcept $ resolveBounds $ budgetInterval $ global c
|
||||
si = liftExcept $ resolveBounds $ statementInterval $ global c
|
||||
bi = liftExcept $ resolveDaySpan $ budgetInterval $ global c
|
||||
si = liftExcept $ resolveDaySpan $ statementInterval $ global c
|
||||
(acnts, paths, am) = indexAcntRoot $ accounts c
|
||||
cs = currency2Record <$> currencies c
|
||||
ts = toRecord <$> tags c
|
||||
toRecord t@Tag {tagID, tagDesc} = Entity (toKey t) $ TagR tagID tagDesc
|
||||
tagMap = M.fromList . fmap (\e -> (tagRSymbol $ entityVal e, entityKey e))
|
||||
|
||||
updateHashes :: (MonadFinance m, MonadSqlQuery m) => m ()
|
||||
updateHashes = do
|
||||
old <- askDBState kmOldCommits
|
||||
nukeDBHashes old
|
||||
updateHashes :: (MonadSqlQuery m) => DBUpdates -> m ()
|
||||
updateHashes DBUpdates {duOldCommits} = nukeDBHashes duOldCommits
|
||||
|
||||
updateTags :: (MonadFinance m, MonadSqlQuery m) => m ()
|
||||
updateTags = do
|
||||
tags <- askDBState kmTagAll
|
||||
updateTags :: (MonadFinance m, MonadSqlQuery m) => DBUpdates -> m ()
|
||||
updateTags DBUpdates {duNewTagIds} = do
|
||||
tags' <- selectE $ E.from $ E.table @TagR
|
||||
let (toIns, toDel) = setDiff tags tags'
|
||||
let (toIns, toDel) = setDiff duNewTagIds tags'
|
||||
mapM_ deleteTag toDel
|
||||
mapM_ insertFull toIns
|
||||
|
||||
updateAccounts :: (MonadFinance m, MonadSqlQuery m) => m ()
|
||||
updateAccounts = do
|
||||
acnts <- askDBState kmAcntsOld
|
||||
paths <- askDBState kmAcntPaths
|
||||
updateAccounts :: (MonadFinance m, MonadSqlQuery m) => DBUpdates -> m ()
|
||||
updateAccounts DBUpdates {duNewAcntIds, duNewAcntPaths} = do
|
||||
acnts' <- dumpTbl
|
||||
let (toIns, toDel) = setDiff acnts acnts'
|
||||
let (toIns, toDel) = setDiff duNewAcntIds acnts'
|
||||
deleteWhere ([] :: [Filter AccountPathR])
|
||||
mapM_ deleteAccount toDel
|
||||
mapM_ insertFull toIns
|
||||
mapM_ insert paths
|
||||
mapM_ insert duNewAcntPaths
|
||||
|
||||
updateCurrencies :: (MonadFinance m, MonadSqlQuery m) => m ()
|
||||
updateCurrencies = do
|
||||
curs <- askDBState kmCurrenciesOld
|
||||
updateCurrencies :: (MonadFinance m, MonadSqlQuery m) => DBUpdates -> m ()
|
||||
updateCurrencies DBUpdates {duNewCurrencyIds} = do
|
||||
curs' <- selectE $ E.from $ E.table @CurrencyR
|
||||
let (toIns, toDel) = setDiff curs curs'
|
||||
let (toIns, toDel) = setDiff duNewCurrencyIds curs'
|
||||
mapM_ deleteCurrency toDel
|
||||
mapM_ insertFull toIns
|
||||
|
||||
updateDBState :: (MonadFinance m, MonadSqlQuery m) => m ()
|
||||
updateDBState = do
|
||||
updateHashes
|
||||
updateTags
|
||||
updateAccounts
|
||||
updateCurrencies
|
||||
updateDBState :: (MonadFinance m, MonadSqlQuery m) => DBUpdates -> m ()
|
||||
updateDBState u = do
|
||||
updateHashes u
|
||||
updateTags u
|
||||
updateAccounts u
|
||||
updateCurrencies u
|
||||
|
||||
deleteE :: (MonadSqlQuery m) => E.SqlQuery () -> m ()
|
||||
deleteE q = unsafeLiftSql "esqueleto-delete" (E.delete q)
|
||||
|
||||
selectE :: (MonadSqlQuery m, SqlSelect a r) => E.SqlQuery a -> m [r]
|
||||
selectE q = unsafeLiftSql "esqueleto-select" (E.select q)
|
||||
|
||||
whenHash
|
||||
:: (Hashable a, MonadFinance m, MonadSqlQuery m)
|
||||
=> ConfigType
|
||||
-> a
|
||||
-> b
|
||||
-> (CommitRId -> m b)
|
||||
-> m b
|
||||
whenHash t o def f = do
|
||||
let h = hash o
|
||||
hs <- askDBState kmNewCommits
|
||||
if h `elem` hs then f =<< insert (CommitR h t) else return def
|
||||
|
||||
whenHash_
|
||||
:: (Hashable a, MonadFinance m)
|
||||
=> ConfigType
|
||||
-> a
|
||||
-> m b
|
||||
-> m (Maybe (CommitR, b))
|
||||
whenHash_ t o f = do
|
||||
let h = hash o
|
||||
let c = CommitR h t
|
||||
hs <- askDBState kmNewCommits
|
||||
if h `elem` hs then Just . (c,) <$> f else return Nothing
|
||||
|
||||
insertEntry :: MonadSqlQuery m => TransactionRId -> KeyEntry -> m EntryRId
|
||||
insertEntry t Entry {eAcnt, eCurrency, eValue, eComment, eTags} = do
|
||||
k <- insert $ EntryR t eCurrency eAcnt eComment eValue
|
||||
mapM_ (insert_ . TagRelationR k) eTags
|
||||
return k
|
||||
|
||||
resolveEntry :: (MonadInsertError m, MonadFinance m) => BalEntry -> m KeyEntry
|
||||
resolveEntry s@Entry {eAcnt, eCurrency, eValue, eTags} = do
|
||||
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
|
||||
}
|
|
@ -1,16 +1,18 @@
|
|||
{-# LANGUAGE RecordWildCards #-}
|
||||
|
||||
module Internal.Statement
|
||||
( readImport
|
||||
module Internal.History
|
||||
( splitHistory
|
||||
, insertHistTransfer
|
||||
, readHistStmt
|
||||
, insertHistStmt
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Monad.Error.Class
|
||||
import Control.Monad.Except
|
||||
import Data.Csv
|
||||
import Internal.Types
|
||||
import Database.Persist.Monad
|
||||
import Internal.Database
|
||||
import Internal.Types.Main
|
||||
import Internal.Utils
|
||||
import RIO
|
||||
import RIO hiding (to)
|
||||
import qualified RIO.ByteString.Lazy as BL
|
||||
import RIO.FilePath
|
||||
import qualified RIO.List as L
|
||||
|
@ -19,30 +21,118 @@ import qualified RIO.Text as T
|
|||
import RIO.Time
|
||||
import qualified RIO.Vector as V
|
||||
|
||||
splitHistory :: [History] -> ([HistTransfer], [Statement])
|
||||
splitHistory = partitionEithers . fmap go
|
||||
where
|
||||
go (HistTransfer x) = Left x
|
||||
go (HistStatement x) = Right x
|
||||
|
||||
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)
|
||||
=> FilePath
|
||||
-> Statement
|
||||
-> m (Maybe (CommitR, [KeyTx]))
|
||||
readHistStmt root i = whenHash_ CTImport i $ do
|
||||
bs <- readImport root 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
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- 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
|
||||
, txEntries = [split from (-val), split to val]
|
||||
}
|
||||
|
||||
resolveTx :: (MonadInsertError m, MonadFinance m) => BalTx -> m KeyTx
|
||||
resolveTx t@Tx {txEntries = ss} =
|
||||
fmap (\kss -> t {txEntries = kss}) $
|
||||
combineErrors $
|
||||
fmap resolveEntry ss
|
||||
|
||||
insertTx :: MonadSqlQuery m => CommitRId -> KeyTx -> m ()
|
||||
insertTx c Tx {txDate = d, txDescr = e, txEntries = ss} = do
|
||||
k <- insert $ TransactionR c d e
|
||||
mapM_ (insertEntry k) ss
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Statements
|
||||
|
||||
-- TODO this probably won't scale well (pipes?)
|
||||
readImport :: (MonadUnliftIO m, MonadFinance m) => Statement -> m [BalTx]
|
||||
readImport Statement {..} = do
|
||||
readImport :: (MonadUnliftIO m, MonadFinance m) => FilePath -> Statement -> m [BalTx]
|
||||
readImport root Statement {stmtTxOpts, stmtParsers, stmtSkipLines, stmtDelim, stmtPaths} = do
|
||||
let ores = compileOptions stmtTxOpts
|
||||
let cres = combineErrors $ compileMatch <$> stmtParsers
|
||||
(compiledOptions, compiledMatches) <- liftIOExcept $ combineError ores cres (,)
|
||||
let readStmt = readImport_ stmtSkipLines stmtDelim compiledOptions
|
||||
records <- L.sort . concat <$> mapErrorsIO readStmt stmtPaths
|
||||
records <- L.sort . concat <$> mapErrorsIO readStmt paths
|
||||
m <- askDBState kmCurrency
|
||||
fromEither $
|
||||
flip runReader m $
|
||||
runExceptT $
|
||||
matchRecords compiledMatches records
|
||||
where
|
||||
paths = (root </>) <$> stmtPaths
|
||||
|
||||
readImport_
|
||||
:: (MonadUnliftIO m, MonadFinance m)
|
||||
:: MonadUnliftIO m
|
||||
=> Natural
|
||||
-> Word
|
||||
-> TxOptsRe
|
||||
-> FilePath
|
||||
-> m [TxRecord]
|
||||
readImport_ n delim tns p = do
|
||||
dir <- askDBState kmConfigDir
|
||||
res <- tryIO $ BL.readFile $ dir </> p
|
||||
res <- tryIO $ BL.readFile p
|
||||
bs <- fromEither $ first (InsertException . (: []) . InsertIOError . showT) res
|
||||
case decodeByNameWithP (parseTxRecord p tns) opts $ skip bs of
|
||||
Left m -> throwIO $ InsertException [ParseError $ T.pack m]
|
||||
|
@ -54,7 +144,7 @@ readImport_ n delim tns p = do
|
|||
-- TODO handle this better, this maybe thing is a hack to skip lines with
|
||||
-- blank dates but will likely want to make this more flexible
|
||||
parseTxRecord :: FilePath -> TxOptsRe -> NamedRecord -> Parser (Maybe TxRecord)
|
||||
parseTxRecord p TxOpts {..} r = do
|
||||
parseTxRecord p TxOpts {toDate, toAmountFmt, toDesc, toAmount, toOther, toDateFmt} r = do
|
||||
d <- r .: T.encodeUtf8 toDate
|
||||
if d == ""
|
||||
then return Nothing
|
||||
|
@ -69,7 +159,6 @@ matchRecords :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM [BalTx]
|
|||
matchRecords ms rs = do
|
||||
(matched, unmatched, notfound) <- matchAll (matchPriorities ms) rs
|
||||
case (matched, unmatched, notfound) of
|
||||
-- TODO record number of times each match hits for debugging
|
||||
(ms_, [], []) -> liftInner $ combineErrors $ fmap balanceTx ms_
|
||||
(_, us, ns) -> throwError $ InsertException [StatementError us ns]
|
||||
|
||||
|
@ -85,7 +174,6 @@ matchToGroup ms =
|
|||
first (L.sortOn spDate) $
|
||||
L.partition (isJust . spDate) ms
|
||||
|
||||
-- TDOO could use a better struct to flatten the maybe date subtype
|
||||
data MatchGroup = MatchGroup
|
||||
{ mgDate :: ![MatchRe]
|
||||
, mgNoDate :: ![MatchRe]
|
||||
|
@ -141,7 +229,6 @@ zipperMatch (Unzipped bs cs as) x = go [] cs
|
|||
ms' = maybe ms (: ms) (matchDec m)
|
||||
in return (Zipped bs $ ps ++ ms' ++ as, skipOrPass)
|
||||
|
||||
-- TODO all this unpacking left/error crap is annoying
|
||||
zipperMatch'
|
||||
:: Zipped MatchRe
|
||||
-> TxRecord
|
||||
|
@ -217,12 +304,12 @@ matchNonDates ms = go ([], [], initZipper ms)
|
|||
in go (m, u, resetZipper z') rs
|
||||
|
||||
balanceTx :: RawTx -> InsertExcept BalTx
|
||||
balanceTx t@Tx {txSplits = ss} = do
|
||||
bs <- balanceSplits ss
|
||||
return $ t {txSplits = bs}
|
||||
balanceTx t@Tx {txEntries = ss} = do
|
||||
bs <- balanceEntries ss
|
||||
return $ t {txEntries = bs}
|
||||
|
||||
balanceSplits :: [RawSplit] -> InsertExcept [BalSplit]
|
||||
balanceSplits ss =
|
||||
balanceEntries :: [RawEntry] -> InsertExcept [BalEntry]
|
||||
balanceEntries ss =
|
||||
fmap concat
|
||||
<$> mapM (uncurry bal)
|
||||
$ groupByKey
|
||||
|
@ -231,7 +318,7 @@ balanceSplits ss =
|
|||
haeValue s@Entry {eValue = Just v} = Right s {eValue = v}
|
||||
haeValue s = Left s
|
||||
bal cur rss
|
||||
| length rss < 2 = throwError $ InsertException [BalanceError TooFewSplits cur rss]
|
||||
| length rss < 2 = throwError $ InsertException [BalanceError TooFewEntries cur rss]
|
||||
| otherwise = case partitionEithers $ fmap haeValue rss of
|
||||
([noVal], val) -> return $ noVal {eValue = foldr (\s x -> x - eValue s) 0 val} : val
|
||||
([], val) -> return val
|
|
@ -1,789 +0,0 @@
|
|||
module Internal.Insert
|
||||
( insertBudget
|
||||
, splitHistory
|
||||
, insertHistTransfer
|
||||
, readHistStmt
|
||||
, insertHistStmt
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Monad.Except
|
||||
import Data.Hashable
|
||||
import Database.Persist.Monad
|
||||
import Internal.Statement
|
||||
import Internal.Types
|
||||
import Internal.Utils
|
||||
import RIO hiding (to)
|
||||
import qualified RIO.List as L
|
||||
import qualified RIO.Map as M
|
||||
import qualified RIO.NonEmpty as NE
|
||||
import qualified RIO.Text as T
|
||||
import RIO.Time
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- intervals
|
||||
|
||||
expandDatePat :: Bounds -> DatePat -> InsertExcept [Day]
|
||||
expandDatePat b (Cron cp) = expandCronPat b cp
|
||||
expandDatePat i (Mod mp) = return $ expandModPat mp i
|
||||
|
||||
expandModPat :: ModPat -> Bounds -> [Day]
|
||||
expandModPat ModPat {mpStart = s, mpBy = b, mpUnit = u, mpRepeats = r} bs =
|
||||
takeWhile (<= upper) $
|
||||
(`addFun` start) . (* b')
|
||||
<$> maybe id (take . fromIntegral) r [0 ..]
|
||||
where
|
||||
(lower, upper) = expandBounds bs
|
||||
start = maybe lower fromGregorian' s
|
||||
b' = fromIntegral b
|
||||
addFun = case u of
|
||||
Day -> addDays
|
||||
Week -> addDays . (* 7)
|
||||
Month -> addGregorianMonthsClip
|
||||
Year -> addGregorianYearsClip
|
||||
|
||||
expandCronPat :: Bounds -> CronPat -> InsertExcept [Day]
|
||||
expandCronPat b CronPat {cpYear, cpMonth, cpDay, cpWeekly} =
|
||||
combineError3 yRes mRes dRes $ \ys ms ds ->
|
||||
filter validWeekday $
|
||||
mapMaybe (uncurry3 toDay) $
|
||||
takeWhile (\((y, _), m, d) -> (y, m, d) <= (yb1, mb1, db1)) $
|
||||
dropWhile (\((y, _), m, d) -> (y, m, d) < (yb0, mb0, db0)) $
|
||||
[(y, m, d) | y <- (\y -> (y, isLeapYear y)) <$> ys, m <- ms, d <- ds]
|
||||
where
|
||||
yRes = case cpYear of
|
||||
Nothing -> return [yb0 .. yb1]
|
||||
Just pat -> do
|
||||
ys <- expandMDYPat (fromIntegral yb0) (fromIntegral yb1) pat
|
||||
return $ dropWhile (< yb0) $ fromIntegral <$> ys
|
||||
mRes = expandMD 12 cpMonth
|
||||
dRes = expandMD 31 cpDay
|
||||
(s, e) = expandBounds b
|
||||
(yb0, mb0, db0) = toGregorian s
|
||||
(yb1, mb1, db1) = toGregorian $ addDays (-1) e
|
||||
expandMD lim =
|
||||
fmap (fromIntegral <$>)
|
||||
. maybe (return [1 .. lim]) (expandMDYPat 1 lim)
|
||||
expandW (OnDay x) = [fromEnum x]
|
||||
expandW (OnDays xs) = fromEnum <$> xs
|
||||
ws = maybe [] expandW cpWeekly
|
||||
validWeekday = if null ws then const True else \day -> dayToWeekday day `elem` ws
|
||||
toDay (y, leap) m d
|
||||
| m == 2 && (not leap && d > 28 || leap && d > 29) = Nothing
|
||||
| m `elem` [4, 6, 9, 11] && d > 30 = Nothing
|
||||
| otherwise = Just $ fromGregorian y m d
|
||||
|
||||
expandMDYPat :: Natural -> Natural -> MDYPat -> InsertExcept [Natural]
|
||||
expandMDYPat lower upper (Single x) = return [x | lower <= x && x <= upper]
|
||||
expandMDYPat lower upper (Multi xs) = return $ dropWhile (<= lower) $ takeWhile (<= upper) xs
|
||||
expandMDYPat lower upper (After x) = return [max lower x .. upper]
|
||||
expandMDYPat lower upper (Before x) = return [lower .. min upper x]
|
||||
expandMDYPat lower upper (Between x y) = return [max lower x .. min upper y]
|
||||
expandMDYPat lower upper (Repeat RepeatPat {rpStart = s, rpBy = b, rpRepeats = r})
|
||||
| b < 1 = throwError $ InsertException [PatternError s b r ZeroLength]
|
||||
| otherwise = do
|
||||
k <- limit r
|
||||
return $ dropWhile (<= lower) $ takeWhile (<= k) [s + i * b | i <- [0 ..]]
|
||||
where
|
||||
limit Nothing = return upper
|
||||
limit (Just n)
|
||||
-- this guard not only produces the error for the user but also protects
|
||||
-- from an underflow below it
|
||||
| n < 1 = throwError $ InsertException [PatternError s b r ZeroRepeats]
|
||||
| otherwise = return $ min (s + b * (n - 1)) upper
|
||||
|
||||
dayToWeekday :: Day -> Int
|
||||
dayToWeekday (ModifiedJulianDay d) = mod (fromIntegral d + 2) 7
|
||||
|
||||
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
|
||||
|
||||
foldDates
|
||||
:: (MonadSqlQuery m, MonadFinance m, MonadInsertError m)
|
||||
=> DatePat
|
||||
-> Day
|
||||
-> (Day -> Day -> m a)
|
||||
-> m [a]
|
||||
foldDates dp start f = do
|
||||
bounds <- askDBState kmBudgetInterval
|
||||
days <- liftExcept $ expandDatePat bounds dp
|
||||
combineErrors $
|
||||
snd $
|
||||
L.mapAccumL (\prevDay day -> (day, f prevDay day)) start days
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- budget
|
||||
|
||||
-- each budget (designated at the top level by a 'name') is processed in the
|
||||
-- following steps
|
||||
-- 1. expand all transactions given the desired date range and date patterns for
|
||||
-- each directive in the budget
|
||||
-- 2. sort all transactions by date
|
||||
-- 3. propagate all balances forward, and while doing so assign values to each
|
||||
-- transaction (some of which depend on the 'current' balance of the
|
||||
-- target account)
|
||||
-- 4. assign shadow transactions (TODO)
|
||||
-- 5. insert all transactions
|
||||
|
||||
insertBudget
|
||||
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
|
||||
=> Budget
|
||||
-> m ()
|
||||
insertBudget
|
||||
b@Budget
|
||||
{ bgtLabel
|
||||
, bgtIncomes
|
||||
, bgtTransfers
|
||||
, bgtShadowTransfers
|
||||
, bgtPretax
|
||||
, bgtTax
|
||||
, bgtPosttax
|
||||
} =
|
||||
whenHash CTBudget b () $ \key -> do
|
||||
intAllos <- combineError3 pre_ tax_ post_ (,,)
|
||||
let res1 = mapErrors (insertIncome key bgtLabel intAllos) bgtIncomes
|
||||
let res2 = expandTransfers key bgtLabel bgtTransfers
|
||||
txs <- combineError (concat <$> res1) res2 (++)
|
||||
m <- askDBState kmCurrency
|
||||
shadow <- liftExcept $ addShadowTransfers m bgtShadowTransfers txs
|
||||
void $ mapErrors insertBudgetTx $ balanceTransfers $ txs ++ shadow
|
||||
where
|
||||
pre_ = sortAllos bgtPretax
|
||||
tax_ = sortAllos bgtTax
|
||||
post_ = sortAllos bgtPosttax
|
||||
sortAllos = liftExcept . combineErrors . fmap sortAllo
|
||||
|
||||
type BoundAllocation = Allocation (Day, Day)
|
||||
|
||||
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 = expandBounds 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 $
|
||||
-- TODO does this actually share the same metadata as the "parent" tx?
|
||||
FlatTransfer
|
||||
{ cbtMeta = cbtMeta tx
|
||||
, cbtWhen = cbtWhen tx
|
||||
, cbtCur = stCurrency
|
||||
, cbtFrom = stFrom
|
||||
, cbtTo = stTo
|
||||
, cbtValue = UnbalancedValue stType $ v * cvValue (cbtValue tx)
|
||||
, cbtDesc = stDesc
|
||||
}
|
||||
|
||||
shadowMatches :: TransferMatcher -> UnbalancedTransfer -> InsertExcept Bool
|
||||
shadowMatches TransferMatcher {tmFrom, tmTo, tmDate, tmVal} tx = do
|
||||
valRes <- valMatches tmVal $ cvValue $ cbtValue tx
|
||||
return $
|
||||
memberMaybe (taAcnt $ cbtFrom tx) tmFrom
|
||||
&& memberMaybe (taAcnt $ cbtTo tx) tmTo
|
||||
&& maybe True (`dateMatches` cbtWhen tx) tmDate
|
||||
&& valRes
|
||||
where
|
||||
memberMaybe x AcntSet {asList, asInclude} =
|
||||
(if asInclude then id else not) $ x `elem` asList
|
||||
|
||||
balanceTransfers :: [UnbalancedTransfer] -> [BalancedTransfer]
|
||||
balanceTransfers = snd . L.mapAccumR go M.empty . reverse . L.sortOn cbtWhen
|
||||
where
|
||||
go bals f@FlatTransfer {cbtFrom, cbtTo, cbtValue = UnbalancedValue {cvValue, cvType}} =
|
||||
let balTo = M.findWithDefault 0 cbtTo bals
|
||||
x = amtToMove balTo cvType cvValue
|
||||
bals' = mapAdd_ cbtTo x $ mapAdd_ cbtFrom (-x) bals
|
||||
in (bals', f {cbtValue = x})
|
||||
-- TODO might need to query signs to make this intuitive; as it is this will
|
||||
-- probably work, but for credit accounts I might need to supply a negative
|
||||
-- target value
|
||||
amtToMove _ BTFixed x = x
|
||||
amtToMove bal BTPercent x = -(x / 100 * bal)
|
||||
amtToMove bal BTTarget x = x - bal
|
||||
|
||||
mapAdd_ :: (Ord k, Num v) => k -> v -> M.Map k v -> M.Map k v
|
||||
mapAdd_ k v = M.alter (maybe (Just v) (Just . (+ v))) k
|
||||
|
||||
data BudgetMeta = BudgetMeta
|
||||
{ bmCommit :: !CommitRId
|
||||
, bmName :: !T.Text
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
data FlatTransfer v = FlatTransfer
|
||||
{ cbtFrom :: !TaggedAcnt
|
||||
, cbtTo :: !TaggedAcnt
|
||||
, cbtValue :: !v
|
||||
, cbtWhen :: !Day
|
||||
, cbtDesc :: !T.Text
|
||||
, cbtMeta :: !BudgetMeta
|
||||
, cbtCur :: !BudgetCurrency
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
data UnbalancedValue = UnbalancedValue
|
||||
{ cvType :: !BudgetTransferType
|
||||
, cvValue :: !Rational
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
type UnbalancedTransfer = FlatTransfer UnbalancedValue
|
||||
|
||||
type BalancedTransfer = FlatTransfer Rational
|
||||
|
||||
insertIncome
|
||||
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
|
||||
=> CommitRId
|
||||
-> T.Text
|
||||
-> IntAllocations
|
||||
-> Income
|
||||
-> m [UnbalancedTransfer]
|
||||
insertIncome
|
||||
key
|
||||
name
|
||||
(intPre, intTax, intPost)
|
||||
Income
|
||||
{ incWhen
|
||||
, incCurrency
|
||||
, incFrom
|
||||
, incPretax
|
||||
, incPosttax
|
||||
, incTaxes
|
||||
, incToBal
|
||||
, incGross
|
||||
, incPayPeriod
|
||||
} = do
|
||||
-- TODO check that the other accounts are not income somewhere here
|
||||
_ <- checkAcntType IncomeT $ taAcnt incFrom
|
||||
precision <- lookupCurrencyPrec incCurrency
|
||||
let gross = roundPrecision precision incGross
|
||||
-- TODO this will scan the interval allocations fully each time
|
||||
-- iteration which is a total waste, but the fix requires turning this
|
||||
-- loop into a fold which I don't feel like doing now :(
|
||||
res <- foldDates incWhen start (allocate precision gross)
|
||||
return $ concat res
|
||||
where
|
||||
start = fromGregorian' $ pStart incPayPeriod
|
||||
pType' = pType incPayPeriod
|
||||
meta = BudgetMeta key name
|
||||
flatPre = concatMap flattenAllo incPretax
|
||||
flatTax = concatMap flattenAllo incTaxes
|
||||
flatPost = concatMap flattenAllo incPosttax
|
||||
sumAllos = sum . fmap faValue
|
||||
-- TODO ensure these are all the "correct" accounts
|
||||
allocate precision gross prevDay day = do
|
||||
scaler <- liftExcept $ periodScaler pType' prevDay day
|
||||
let (preDeductions, pre) =
|
||||
allocatePre precision gross $
|
||||
flatPre ++ concatMap (selectAllos day) intPre
|
||||
tax =
|
||||
allocateTax precision gross preDeductions scaler $
|
||||
flatTax ++ concatMap (selectAllos day) intTax
|
||||
aftertaxGross = gross - sumAllos (tax ++ pre)
|
||||
post =
|
||||
allocatePost precision aftertaxGross $
|
||||
flatPost ++ concatMap (selectAllos day) intPost
|
||||
balance = aftertaxGross - sumAllos post
|
||||
bal =
|
||||
FlatTransfer
|
||||
{ cbtMeta = meta
|
||||
, cbtWhen = day
|
||||
, cbtFrom = incFrom
|
||||
, cbtCur = NoX incCurrency
|
||||
, cbtTo = incToBal
|
||||
, cbtValue = UnbalancedValue BTFixed balance
|
||||
, cbtDesc = "balance after deductions"
|
||||
}
|
||||
in if balance < 0
|
||||
then throwError $ InsertException [IncomeError day name balance]
|
||||
else return (bal : fmap (allo2Trans meta day incFrom) (pre ++ tax ++ post))
|
||||
|
||||
type PeriodScaler = Natural -> Double -> Double
|
||||
|
||||
-- TODO we probably don't need to check for 1/0 each time
|
||||
periodScaler
|
||||
:: PeriodType
|
||||
-> Day
|
||||
-> Day
|
||||
-> InsertExcept PeriodScaler
|
||||
periodScaler pt prev cur = do
|
||||
n <- workingDays wds prev cur
|
||||
return $ scale (fromIntegral n)
|
||||
where
|
||||
wds = case pt of
|
||||
Hourly HourlyPeriod {hpWorkingDays} -> hpWorkingDays
|
||||
Daily ds -> ds
|
||||
scale n precision x = case pt of
|
||||
Hourly HourlyPeriod {hpAnnualHours, hpDailyHours} ->
|
||||
fromRational (rnd $ x / fromIntegral hpAnnualHours)
|
||||
* fromIntegral hpDailyHours
|
||||
* n
|
||||
Daily _ -> x * n / 365.25
|
||||
where
|
||||
rnd = roundPrecision precision
|
||||
|
||||
workingDays :: [Weekday] -> Day -> Day -> InsertExcept Natural
|
||||
workingDays wds start end
|
||||
| interval > 0 =
|
||||
let (nFull, nPart) = divMod interval 7
|
||||
daysFull = fromIntegral (length wds') * nFull
|
||||
daysTail = fromIntegral $ length $ takeWhile (< nPart) wds'
|
||||
in return $ fromIntegral $ daysFull + daysTail
|
||||
| otherwise = throwError $ InsertException undefined
|
||||
where
|
||||
interval = diffDays end start
|
||||
startDay = dayOfWeek start
|
||||
wds' = L.sort $ (\x -> diff (fromWeekday x) startDay) <$> L.nub wds
|
||||
diff a b = fromIntegral $ mod (fromEnum a - fromEnum b) 7
|
||||
|
||||
allocatePre
|
||||
:: Natural
|
||||
-> Rational
|
||||
-> [FlatAllocation PretaxValue]
|
||||
-> (M.Map T.Text Rational, [FlatAllocation Rational])
|
||||
allocatePre precision gross = L.mapAccumR go M.empty
|
||||
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})
|
||||
|
||||
allo2Trans
|
||||
:: BudgetMeta
|
||||
-> Day
|
||||
-> TaggedAcnt
|
||||
-> FlatAllocation Rational
|
||||
-> UnbalancedTransfer
|
||||
allo2Trans meta day from FlatAllocation {faValue, faTo, faDesc, faCur} =
|
||||
FlatTransfer
|
||||
{ cbtMeta = meta
|
||||
, cbtWhen = day
|
||||
, cbtFrom = from
|
||||
, cbtCur = faCur
|
||||
, cbtTo = faTo
|
||||
, cbtValue = UnbalancedValue BTFixed faValue
|
||||
, cbtDesc = faDesc
|
||||
}
|
||||
|
||||
allocateTax
|
||||
:: Natural
|
||||
-> Rational
|
||||
-> M.Map T.Text Rational
|
||||
-> PeriodScaler
|
||||
-> [FlatAllocation TaxValue]
|
||||
-> [FlatAllocation Rational]
|
||||
allocateTax precision gross preDeds f = fmap (fmap go)
|
||||
where
|
||||
go TaxValue {tvCategories, tvMethod} =
|
||||
let agi = gross - sum (mapMaybe (`M.lookup` preDeds) tvCategories)
|
||||
in case tvMethod of
|
||||
TMPercent p ->
|
||||
roundPrecision precision $
|
||||
fromRational $
|
||||
roundPrecision 3 p / 100 * agi
|
||||
TMBracket TaxProgression {tpDeductible, tpBrackets} ->
|
||||
let taxDed = roundPrecision precision $ f precision tpDeductible
|
||||
in foldBracket f precision (agi - taxDed) tpBrackets
|
||||
|
||||
allocatePost
|
||||
:: Natural
|
||||
-> Rational
|
||||
-> [FlatAllocation PosttaxValue]
|
||||
-> [FlatAllocation Rational]
|
||||
allocatePost precision aftertax = fmap (fmap go)
|
||||
where
|
||||
go PosttaxValue {postValue, postPercent} =
|
||||
let v = postValue
|
||||
in if postPercent
|
||||
then aftertax * roundPrecision 3 v / 100
|
||||
else roundPrecision precision v
|
||||
|
||||
-- | Compute effective tax percentage of a bracket
|
||||
-- The algorithm can be thought of in three phases:
|
||||
-- 1. Find the highest tax bracket by looping backward until the AGI is less
|
||||
-- than the bracket limit
|
||||
-- 2. Computing the tax in the top bracket by subtracting the AGI from the
|
||||
-- bracket limit and multiplying by the tax percentage.
|
||||
-- 3. Adding all lower brackets, which are just the limit of the bracket less
|
||||
-- the amount of the lower bracket times the percentage.
|
||||
--
|
||||
-- In reality, this can all be done with one loop, but it isn't clear these
|
||||
-- three steps are implemented from this alone.
|
||||
foldBracket :: PeriodScaler -> Natural -> Rational -> [TaxBracket] -> Rational
|
||||
foldBracket f precision agi bs = fst $ foldr go (0, agi) $ L.sortOn tbLowerLimit bs
|
||||
where
|
||||
go TaxBracket {tbLowerLimit, tbPercent} a@(acc, remain) =
|
||||
let l = roundPrecision precision $ f precision tbLowerLimit
|
||||
p = roundPrecision 3 tbPercent / 100
|
||||
in if remain >= l then (acc + p * (remain - l), l) else a
|
||||
|
||||
data FlatAllocation v = FlatAllocation
|
||||
{ faValue :: !v
|
||||
, faDesc :: !T.Text
|
||||
, faTo :: !TaggedAcnt
|
||||
, faCur :: !BudgetCurrency
|
||||
}
|
||||
deriving (Functor, Show)
|
||||
|
||||
flattenAllo :: SingleAllocation v -> [FlatAllocation v]
|
||||
flattenAllo Allocation {alloAmts, alloCur, alloTo} = fmap go alloAmts
|
||||
where
|
||||
go Amount {amtValue, amtDesc} =
|
||||
FlatAllocation
|
||||
{ faCur = NoX alloCur
|
||||
, faTo = alloTo
|
||||
, faValue = amtValue
|
||||
, faDesc = amtDesc
|
||||
}
|
||||
|
||||
-- ASSUME allocations are sorted
|
||||
selectAllos :: Day -> BoundAllocation v -> [FlatAllocation v]
|
||||
selectAllos day Allocation {alloAmts, alloCur, alloTo} =
|
||||
go <$> filter ((`inBounds` day) . amtWhen) alloAmts
|
||||
where
|
||||
go Amount {amtValue, amtDesc} =
|
||||
FlatAllocation
|
||||
{ faCur = NoX alloCur
|
||||
, faTo = alloTo
|
||||
, faValue = amtValue
|
||||
, faDesc = amtDesc
|
||||
}
|
||||
|
||||
expandTransfers
|
||||
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
|
||||
=> CommitRId
|
||||
-> T.Text
|
||||
-> [BudgetTransfer]
|
||||
-> m [UnbalancedTransfer]
|
||||
expandTransfers key name ts =
|
||||
fmap (L.sortOn cbtWhen . concat) $
|
||||
combineErrors $
|
||||
fmap (expandTransfer key name) ts
|
||||
|
||||
initialCurrency :: BudgetCurrency -> CurID
|
||||
initialCurrency (NoX c) = c
|
||||
initialCurrency (X Exchange {xFromCur = c}) = c
|
||||
|
||||
expandTransfer
|
||||
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
|
||||
=> CommitRId
|
||||
-> T.Text
|
||||
-> BudgetTransfer
|
||||
-> m [UnbalancedTransfer]
|
||||
expandTransfer key name Transfer {transAmounts, transTo, transCurrency, transFrom} = do
|
||||
precision <- lookupCurrencyPrec $ initialCurrency transCurrency
|
||||
fmap concat $ combineErrors $ fmap (go precision) transAmounts
|
||||
where
|
||||
go
|
||||
precision
|
||||
Amount
|
||||
{ amtWhen = pat
|
||||
, amtValue = BudgetTransferValue {btVal = v, btType = y}
|
||||
, amtDesc = desc
|
||||
} =
|
||||
withDates pat $ \day -> do
|
||||
let meta = BudgetMeta {bmCommit = key, bmName = name}
|
||||
return
|
||||
FlatTransfer
|
||||
{ cbtMeta = meta
|
||||
, cbtWhen = day
|
||||
, cbtCur = transCurrency
|
||||
, cbtFrom = transFrom
|
||||
, cbtTo = transTo
|
||||
, cbtValue = UnbalancedValue y $ roundPrecision precision v
|
||||
, cbtDesc = desc
|
||||
}
|
||||
|
||||
insertBudgetTx :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m) => BalancedTransfer -> m ()
|
||||
insertBudgetTx FlatTransfer {cbtFrom, cbtTo, cbtMeta, cbtCur, cbtValue, cbtDesc, cbtWhen} = do
|
||||
((sFrom, sTo), exchange) <- splitPair cbtFrom cbtTo cbtCur cbtValue
|
||||
insertPair sFrom sTo
|
||||
forM_ exchange $ uncurry insertPair
|
||||
where
|
||||
insertPair from to = do
|
||||
k <- insert $ TransactionR (bmCommit cbtMeta) cbtWhen cbtDesc
|
||||
insertBudgetLabel k from
|
||||
insertBudgetLabel k to
|
||||
insertBudgetLabel k split = do
|
||||
sk <- insertSplit k split
|
||||
insert_ $ BudgetLabelR sk $ bmName cbtMeta
|
||||
|
||||
type SplitPair = (KeySplit, KeySplit)
|
||||
|
||||
splitPair
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
=> TaggedAcnt
|
||||
-> TaggedAcnt
|
||||
-> BudgetCurrency
|
||||
-> Rational
|
||||
-> m (SplitPair, Maybe SplitPair)
|
||||
splitPair from to cur val = case cur of
|
||||
NoX curid -> (,Nothing) <$> pair curid from to val
|
||||
X Exchange {xFromCur, xToCur, xAcnt, xRate} -> do
|
||||
let middle = TaggedAcnt xAcnt []
|
||||
let res1 = pair xFromCur from middle val
|
||||
let res2 = pair xToCur middle to (val * roundPrecision 3 xRate)
|
||||
combineError res1 res2 $ \a b -> (a, Just b)
|
||||
where
|
||||
pair curid from_ to_ v = do
|
||||
let s1 = split curid from_ (-v)
|
||||
let s2 = split curid to_ v
|
||||
combineError s1 s2 (,)
|
||||
split c TaggedAcnt {taAcnt, taTags} v =
|
||||
resolveSplit $
|
||||
Entry
|
||||
{ eAcnt = taAcnt
|
||||
, eValue = v
|
||||
, eComment = ""
|
||||
, eCurrency = c
|
||||
, eTags = taTags
|
||||
}
|
||||
|
||||
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 <- expandBounds <$> 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
|
|
@ -0,0 +1,75 @@
|
|||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DerivingVia #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
-- | Types corresponding to the database model
|
||||
module Internal.Types.Database where
|
||||
|
||||
import Database.Persist.Sql hiding (Desc, In, Statement)
|
||||
import Database.Persist.TH
|
||||
import RIO
|
||||
import qualified RIO.Text as T
|
||||
import RIO.Time
|
||||
|
||||
share
|
||||
[mkPersist sqlSettings, mkMigrate "migrateAll"]
|
||||
[persistLowerCase|
|
||||
CommitR sql=commits
|
||||
hash Int
|
||||
type ConfigType
|
||||
deriving Show Eq
|
||||
CurrencyR sql=currencies
|
||||
symbol T.Text
|
||||
fullname T.Text
|
||||
precision Int
|
||||
deriving Show Eq
|
||||
TagR sql=tags
|
||||
symbol T.Text
|
||||
fullname T.Text
|
||||
deriving Show Eq
|
||||
AccountR sql=accounts
|
||||
name T.Text
|
||||
fullpath T.Text
|
||||
desc T.Text
|
||||
deriving Show Eq
|
||||
AccountPathR sql=account_paths
|
||||
parent AccountRId OnDeleteCascade
|
||||
child AccountRId OnDeleteCascade
|
||||
depth Int
|
||||
deriving Show Eq
|
||||
TransactionR sql=transactions
|
||||
commit CommitRId OnDeleteCascade
|
||||
date Day
|
||||
description T.Text
|
||||
deriving Show Eq
|
||||
EntryR sql=entries
|
||||
transaction TransactionRId OnDeleteCascade
|
||||
currency CurrencyRId OnDeleteCascade
|
||||
account AccountRId OnDeleteCascade
|
||||
memo T.Text
|
||||
value Rational
|
||||
deriving Show Eq
|
||||
TagRelationR sql=tag_relations
|
||||
entry EntryRId OnDeleteCascade
|
||||
tag TagRId OnDeleteCascade
|
||||
BudgetLabelR sql=budget_labels
|
||||
entry EntryRId OnDeleteCascade
|
||||
budgetName T.Text
|
||||
deriving Show Eq
|
||||
|]
|
||||
|
||||
data ConfigType = CTBudget | CTManual | CTImport
|
||||
deriving (Eq, Show, Read, Enum)
|
||||
|
||||
instance PersistFieldSql ConfigType where
|
||||
sqlType _ = SqlString
|
||||
|
||||
instance PersistField ConfigType where
|
||||
toPersistValue = PersistText . T.pack . show
|
||||
|
||||
-- TODO these error messages *might* be good enough?
|
||||
fromPersistValue (PersistText v) =
|
||||
maybe (Left $ "could not parse: " <> v) Right $ readMaybe $ T.unpack v
|
||||
fromPersistValue _ = Left "wrong type"
|
|
@ -4,29 +4,24 @@
|
|||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
module Internal.Types where
|
||||
-- | Types corresponding to the configuration tree (written in Dhall)
|
||||
module Internal.Types.Dhall where
|
||||
|
||||
import Control.Monad.Except
|
||||
import Data.Fix (Fix (..), foldFix)
|
||||
import Data.Functor.Foldable (embed)
|
||||
import qualified Data.Functor.Foldable.TH as TH
|
||||
import Database.Persist.Sql hiding (Desc, In, Statement)
|
||||
import Database.Persist.TH
|
||||
import Dhall hiding (embed, maybe)
|
||||
import Dhall.TH
|
||||
import Internal.TH (deriveProduct)
|
||||
import Internal.Types.TH (deriveProduct)
|
||||
import Language.Haskell.TH.Syntax (Lift)
|
||||
import RIO
|
||||
import qualified RIO.Map as M
|
||||
import qualified RIO.NonEmpty as NE
|
||||
import qualified RIO.Text as T
|
||||
import RIO.Time
|
||||
import Text.Regex.TDFA
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- DHALL CONFIG
|
||||
-------------------------------------------------------------------------------
|
||||
|
||||
makeHaskellTypesWith
|
||||
(defaultGenerateOptions {generateToDhallInstance = False, generateFromDhallInstance = False})
|
||||
[ MultipleConstructors "SqlConfig" "(./dhall/Types.dhall).SqlConfig"
|
||||
|
@ -200,6 +195,7 @@ data Budget = Budget
|
|||
, bgtPosttax :: [MultiAllocation PosttaxValue]
|
||||
, bgtTransfers :: [BudgetTransfer]
|
||||
, bgtShadowTransfers :: [ShadowTransfer]
|
||||
, bgtInterval :: !(Maybe Interval)
|
||||
}
|
||||
|
||||
deriving instance Hashable PretaxValue
|
||||
|
@ -425,7 +421,7 @@ data History
|
|||
| HistStatement !Statement
|
||||
deriving (Eq, Generic, Hashable, FromDhall)
|
||||
|
||||
type EntryGetter = Entry SplitAcnt (Maybe EntryNumGetter) SplitCur TagID
|
||||
type EntryGetter = Entry EntryAcnt (Maybe EntryNumGetter) EntryCur TagID
|
||||
|
||||
instance FromDhall EntryGetter
|
||||
|
||||
|
@ -440,7 +436,7 @@ deriving instance (Eq a, Eq v, Eq c, Eq t) => Eq (Entry a v c t)
|
|||
data Tx s = Tx
|
||||
{ txDescr :: !T.Text
|
||||
, txDate :: !Day
|
||||
, txSplits :: ![s]
|
||||
, txEntries :: ![s]
|
||||
}
|
||||
deriving (Generic)
|
||||
|
||||
|
@ -467,7 +463,7 @@ data Statement = Statement
|
|||
}
|
||||
deriving (Eq, Hashable, Generic, FromDhall)
|
||||
|
||||
-- | the value of a field in split (text version)
|
||||
-- | the value of a field in entry (text version)
|
||||
-- can either be a raw (constant) value, a lookup from the record, or a map
|
||||
-- between the lookup and some other value
|
||||
data EntryTextGetter t
|
||||
|
@ -477,9 +473,9 @@ data EntryTextGetter t
|
|||
| Map2T !(FieldMap (T.Text, T.Text) t)
|
||||
deriving (Eq, Generic, Hashable, Show, FromDhall)
|
||||
|
||||
type SplitCur = EntryTextGetter CurID
|
||||
type EntryCur = EntryTextGetter CurID
|
||||
|
||||
type SplitAcnt = EntryTextGetter AcntID
|
||||
type EntryAcnt = EntryTextGetter AcntID
|
||||
|
||||
deriving instance (Show k, Show v) => Show (Field k v)
|
||||
|
||||
|
@ -508,8 +504,8 @@ data FieldMatcher re
|
|||
deriving instance Show (FieldMatcher T.Text)
|
||||
|
||||
data TxGetter = TxGetter
|
||||
{ tgCurrency :: !SplitCur
|
||||
, tgAcnt :: !SplitAcnt
|
||||
{ tgCurrency :: !EntryCur
|
||||
, tgAcnt :: !EntryAcnt
|
||||
, tgEntries :: ![EntryGetter]
|
||||
}
|
||||
deriving (Eq, Generic, Hashable, Show, FromDhall)
|
||||
|
@ -527,270 +523,5 @@ data StatementParser re = StatementParser
|
|||
|
||||
deriving instance Show (StatementParser T.Text)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- DATABASE MODEL
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
share
|
||||
[mkPersist sqlSettings, mkMigrate "migrateAll"]
|
||||
[persistLowerCase|
|
||||
CommitR sql=commits
|
||||
hash Int
|
||||
type ConfigType
|
||||
deriving Show Eq
|
||||
CurrencyR sql=currencies
|
||||
symbol T.Text
|
||||
fullname T.Text
|
||||
precision Int
|
||||
deriving Show Eq
|
||||
TagR sql=tags
|
||||
symbol T.Text
|
||||
fullname T.Text
|
||||
deriving Show Eq
|
||||
AccountR sql=accounts
|
||||
name T.Text
|
||||
fullpath T.Text
|
||||
desc T.Text
|
||||
deriving Show Eq
|
||||
AccountPathR sql=account_paths
|
||||
parent AccountRId OnDeleteCascade
|
||||
child AccountRId OnDeleteCascade
|
||||
depth Int
|
||||
deriving Show Eq
|
||||
TransactionR sql=transactions
|
||||
commit CommitRId OnDeleteCascade
|
||||
date Day
|
||||
description T.Text
|
||||
deriving Show Eq
|
||||
SplitR sql=splits
|
||||
transaction TransactionRId OnDeleteCascade
|
||||
currency CurrencyRId OnDeleteCascade
|
||||
account AccountRId OnDeleteCascade
|
||||
memo T.Text
|
||||
value Rational
|
||||
deriving Show Eq
|
||||
TagRelationR sql=tag_relations
|
||||
split SplitRId OnDeleteCascade
|
||||
tag TagRId OnDeleteCascade
|
||||
BudgetLabelR sql=budget_labels
|
||||
split SplitRId OnDeleteCascade
|
||||
budgetName T.Text
|
||||
deriving Show Eq
|
||||
|]
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- database cache types
|
||||
|
||||
data ConfigHashes = ConfigHashes
|
||||
{ chIncome :: ![Int]
|
||||
, chExpense :: ![Int]
|
||||
, chManual :: ![Int]
|
||||
, chImport :: ![Int]
|
||||
}
|
||||
|
||||
data ConfigType = CTBudget | CTManual | CTImport
|
||||
deriving (Eq, Show, Read, Enum)
|
||||
|
||||
instance PersistFieldSql ConfigType where
|
||||
sqlType _ = SqlString
|
||||
|
||||
instance PersistField ConfigType where
|
||||
toPersistValue = PersistText . T.pack . show
|
||||
|
||||
-- TODO these error messages *might* be good enough?
|
||||
fromPersistValue (PersistText v) =
|
||||
maybe (Left $ "could not parse: " <> v) Right $ readMaybe $ T.unpack v
|
||||
fromPersistValue _ = Left "wrong type"
|
||||
|
||||
type AccountMap = M.Map AcntID (AccountRId, AcntSign, AcntType)
|
||||
|
||||
type CurrencyMap = M.Map CurID (CurrencyRId, Natural)
|
||||
|
||||
type TagMap = M.Map TagID TagRId
|
||||
|
||||
data DBState = DBState
|
||||
{ kmCurrency :: !CurrencyMap
|
||||
, kmAccount :: !AccountMap
|
||||
, kmTag :: !TagMap
|
||||
, kmBudgetInterval :: !Bounds
|
||||
, kmStatementInterval :: !Bounds
|
||||
, kmNewCommits :: ![Int]
|
||||
, kmOldCommits :: ![Int]
|
||||
, kmConfigDir :: !FilePath
|
||||
, kmTagAll :: ![Entity TagR]
|
||||
, kmAcntPaths :: ![AccountPathR]
|
||||
, kmAcntsOld :: ![Entity AccountR]
|
||||
, kmCurrenciesOld :: ![Entity CurrencyR]
|
||||
}
|
||||
|
||||
type CurrencyM = Reader CurrencyMap
|
||||
|
||||
type KeySplit = Entry AccountRId Rational CurrencyRId TagRId
|
||||
|
||||
type KeyTx = Tx KeySplit
|
||||
|
||||
type TreeR = Tree ([T.Text], AccountRId)
|
||||
|
||||
type Balances = M.Map AccountRId Rational
|
||||
|
||||
type BalanceM = ReaderT (MVar Balances)
|
||||
|
||||
type MonadFinance = MonadReader DBState
|
||||
|
||||
askDBState :: MonadFinance m => (DBState -> a) -> m a
|
||||
askDBState = asks
|
||||
|
||||
class MonadUnliftIO m => MonadBalance m where
|
||||
askBalances :: m (MVar Balances)
|
||||
|
||||
withBalances :: (Balances -> m a) -> m a
|
||||
withBalances f = do
|
||||
bs <- askBalances
|
||||
withMVar bs f
|
||||
|
||||
modifyBalances :: (Balances -> m (Balances, a)) -> m a
|
||||
modifyBalances f = do
|
||||
bs <- askBalances
|
||||
modifyMVar bs f
|
||||
|
||||
lookupBalance :: AccountRId -> m Rational
|
||||
lookupBalance i = withBalances $ return . fromMaybe 0 . M.lookup i
|
||||
|
||||
addBalance :: AccountRId -> Rational -> m ()
|
||||
addBalance i v =
|
||||
modifyBalances $ return . (,()) . M.alter (Just . maybe v (v +)) i
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- misc
|
||||
|
||||
data AcntType
|
||||
= AssetT
|
||||
| EquityT
|
||||
| ExpenseT
|
||||
| IncomeT
|
||||
| LiabilityT
|
||||
deriving (Show, Eq, Ord, Lift, Hashable, Generic, Read, FromDhall)
|
||||
|
||||
atName :: AcntType -> T.Text
|
||||
atName AssetT = "asset"
|
||||
atName EquityT = "equity"
|
||||
atName ExpenseT = "expense"
|
||||
atName IncomeT = "income"
|
||||
atName LiabilityT = "liability"
|
||||
|
||||
data AcntPath = AcntPath
|
||||
{ apType :: !AcntType
|
||||
, apChildren :: ![T.Text]
|
||||
}
|
||||
deriving (Eq, Ord, Show, Lift, Hashable, Generic, Read, FromDhall)
|
||||
|
||||
data TxRecord = TxRecord
|
||||
{ trDate :: !Day
|
||||
, trAmount :: !Rational
|
||||
, trDesc :: !T.Text
|
||||
, trOther :: !(M.Map T.Text T.Text)
|
||||
, trFile :: !FilePath
|
||||
}
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
type Bounds = (Day, Natural)
|
||||
|
||||
data Keyed a = Keyed
|
||||
{ kKey :: !Int64
|
||||
, kVal :: !a
|
||||
}
|
||||
deriving (Eq, Show, Functor)
|
||||
|
||||
data Tree a = Branch !a ![Tree a] | Leaf !a deriving (Show)
|
||||
|
||||
data AcntSign = Credit | Debit
|
||||
deriving (Show)
|
||||
|
||||
sign2Int :: AcntSign -> Int
|
||||
sign2Int Debit = 1
|
||||
sign2Int Credit = 1
|
||||
|
||||
accountSign :: AcntType -> AcntSign
|
||||
accountSign AssetT = Debit
|
||||
accountSign ExpenseT = Debit
|
||||
accountSign IncomeT = Credit
|
||||
accountSign LiabilityT = Credit
|
||||
accountSign EquityT = Credit
|
||||
|
||||
type RawSplit = Entry AcntID (Maybe Rational) CurID TagID
|
||||
|
||||
type BalSplit = Entry AcntID Rational CurID TagID
|
||||
|
||||
type RawTx = Tx RawSplit
|
||||
|
||||
type BalTx = Tx BalSplit
|
||||
|
||||
data MatchRes a = MatchPass !a | MatchFail | MatchSkip
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- exception types
|
||||
|
||||
data BalanceType = TooFewSplits | NotOneBlank deriving (Show)
|
||||
|
||||
data MatchType = MatchNumeric | MatchText deriving (Show)
|
||||
|
||||
data SplitIDType = AcntField | CurField | TagField deriving (Show)
|
||||
|
||||
data LookupSuberr
|
||||
= SplitIDField !SplitIDType
|
||||
| SplitValField
|
||||
| MatchField !MatchType
|
||||
| DBKey !SplitIDType
|
||||
deriving (Show)
|
||||
|
||||
data AllocationSuberr
|
||||
= NoAllocations
|
||||
| ExceededTotal
|
||||
| MissingBlank
|
||||
| TooManyBlanks
|
||||
deriving (Show)
|
||||
|
||||
data PatternSuberr = ZeroLength | ZeroRepeats deriving (Show)
|
||||
|
||||
data InsertError
|
||||
= RegexError !T.Text
|
||||
| MatchValPrecisionError !Natural !Natural
|
||||
| AccountError !AcntID !(NE.NonEmpty AcntType)
|
||||
| InsertIOError !T.Text
|
||||
| ParseError !T.Text
|
||||
| ConversionError !T.Text
|
||||
| LookupError !LookupSuberr !T.Text
|
||||
| BalanceError !BalanceType !CurID ![RawSplit]
|
||||
| IncomeError !Day !T.Text !Rational
|
||||
| PatternError !Natural !Natural !(Maybe Natural) !PatternSuberr
|
||||
| BoundsError !Gregorian !(Maybe Gregorian)
|
||||
| StatementError ![TxRecord] ![MatchRe]
|
||||
| PeriodError !Day !Day
|
||||
deriving (Show)
|
||||
|
||||
newtype InsertException = InsertException [InsertError]
|
||||
deriving (Show, Semigroup) via [InsertError]
|
||||
|
||||
instance Exception InsertException
|
||||
|
||||
type MonadInsertError = MonadError InsertException
|
||||
|
||||
type InsertExceptT = ExceptT InsertException
|
||||
|
||||
type InsertExcept = InsertExceptT Identity
|
||||
|
||||
data XGregorian = XGregorian
|
||||
{ xgYear :: !Int
|
||||
, xgMonth :: !Int
|
||||
, xgDay :: !Int
|
||||
, xgDayOfWeek :: !Int
|
||||
}
|
||||
|
||||
type MatchRe = StatementParser (T.Text, Regex)
|
||||
|
||||
type TxOptsRe = TxOpts (T.Text, Regex)
|
||||
|
||||
type FieldMatcherRe = FieldMatcher (T.Text, Regex)
|
||||
|
||||
instance Show (StatementParser (T.Text, Regex)) where
|
||||
show = show . fmap fst
|
|
@ -0,0 +1,203 @@
|
|||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DerivingVia #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
-- | Other types used throughout the program; kept in its own module to prevent
|
||||
-- circular imports
|
||||
module Internal.Types.Main
|
||||
( module Internal.Types.Main
|
||||
, module Internal.Types.Dhall
|
||||
, module Internal.Types.Database
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Monad.Except
|
||||
import Database.Persist.Sql hiding (Desc, In, Statement)
|
||||
import Dhall hiding (embed, maybe)
|
||||
import Internal.Types.Database
|
||||
import Internal.Types.Dhall
|
||||
import Language.Haskell.TH.Syntax (Lift)
|
||||
import RIO
|
||||
import qualified RIO.Map as M
|
||||
import qualified RIO.NonEmpty as NE
|
||||
import qualified RIO.Text as T
|
||||
import RIO.Time
|
||||
import Text.Regex.TDFA
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- database cache types
|
||||
|
||||
data ConfigHashes = ConfigHashes
|
||||
{ chIncome :: ![Int]
|
||||
, chExpense :: ![Int]
|
||||
, chManual :: ![Int]
|
||||
, chImport :: ![Int]
|
||||
}
|
||||
|
||||
type AccountMap = M.Map AcntID (AccountRId, AcntSign, AcntType)
|
||||
|
||||
type CurrencyMap = M.Map CurID (CurrencyRId, Natural)
|
||||
|
||||
type TagMap = M.Map TagID TagRId
|
||||
|
||||
data DBState = DBState
|
||||
{ kmCurrency :: !CurrencyMap
|
||||
, kmAccount :: !AccountMap
|
||||
, kmTag :: !TagMap
|
||||
, kmBudgetInterval :: !DaySpan
|
||||
, kmStatementInterval :: !DaySpan
|
||||
, kmNewCommits :: ![Int]
|
||||
}
|
||||
|
||||
data DBUpdates = DBUpdates
|
||||
{ duOldCommits :: ![Int]
|
||||
, duNewTagIds :: ![Entity TagR]
|
||||
, duNewAcntPaths :: ![AccountPathR]
|
||||
, duNewAcntIds :: ![Entity AccountR]
|
||||
, duNewCurrencyIds :: ![Entity CurrencyR]
|
||||
}
|
||||
|
||||
type CurrencyM = Reader CurrencyMap
|
||||
|
||||
type KeyEntry = Entry AccountRId Rational CurrencyRId TagRId
|
||||
|
||||
type KeyTx = Tx KeyEntry
|
||||
|
||||
type TreeR = Tree ([T.Text], AccountRId)
|
||||
|
||||
type MonadFinance = MonadReader DBState
|
||||
|
||||
askDBState :: MonadFinance m => (DBState -> a) -> m a
|
||||
askDBState = asks
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- misc
|
||||
|
||||
data AcntType
|
||||
= AssetT
|
||||
| EquityT
|
||||
| ExpenseT
|
||||
| IncomeT
|
||||
| LiabilityT
|
||||
deriving (Show, Eq, Ord, Lift, Hashable, Generic, Read, FromDhall)
|
||||
|
||||
atName :: AcntType -> T.Text
|
||||
atName AssetT = "asset"
|
||||
atName EquityT = "equity"
|
||||
atName ExpenseT = "expense"
|
||||
atName IncomeT = "income"
|
||||
atName LiabilityT = "liability"
|
||||
|
||||
data AcntPath = AcntPath
|
||||
{ apType :: !AcntType
|
||||
, apChildren :: ![T.Text]
|
||||
}
|
||||
deriving (Eq, Ord, Show, Lift, Hashable, Generic, Read, FromDhall)
|
||||
|
||||
data TxRecord = TxRecord
|
||||
{ trDate :: !Day
|
||||
, trAmount :: !Rational
|
||||
, trDesc :: !T.Text
|
||||
, trOther :: !(M.Map T.Text T.Text)
|
||||
, trFile :: !FilePath
|
||||
}
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
type DaySpan = (Day, Natural)
|
||||
|
||||
data Keyed a = Keyed
|
||||
{ kKey :: !Int64
|
||||
, kVal :: !a
|
||||
}
|
||||
deriving (Eq, Show, Functor)
|
||||
|
||||
data Tree a = Branch !a ![Tree a] | Leaf !a deriving (Show)
|
||||
|
||||
data AcntSign = Credit | Debit
|
||||
deriving (Show)
|
||||
|
||||
sign2Int :: AcntSign -> Int
|
||||
sign2Int Debit = 1
|
||||
sign2Int Credit = 1
|
||||
|
||||
accountSign :: AcntType -> AcntSign
|
||||
accountSign AssetT = Debit
|
||||
accountSign ExpenseT = Debit
|
||||
accountSign IncomeT = Credit
|
||||
accountSign LiabilityT = Credit
|
||||
accountSign EquityT = Credit
|
||||
|
||||
type RawEntry = Entry AcntID (Maybe Rational) CurID TagID
|
||||
|
||||
type BalEntry = Entry AcntID Rational CurID TagID
|
||||
|
||||
type RawTx = Tx RawEntry
|
||||
|
||||
type BalTx = Tx BalEntry
|
||||
|
||||
data MatchRes a = MatchPass !a | MatchFail | MatchSkip
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- exception types
|
||||
|
||||
data BalanceType = TooFewEntries | NotOneBlank deriving (Show)
|
||||
|
||||
data MatchType = MatchNumeric | MatchText deriving (Show)
|
||||
|
||||
data EntryIDType = AcntField | CurField | TagField deriving (Show)
|
||||
|
||||
data LookupSuberr
|
||||
= EntryIDField !EntryIDType
|
||||
| EntryValField
|
||||
| MatchField !MatchType
|
||||
| DBKey !EntryIDType
|
||||
deriving (Show)
|
||||
|
||||
data AllocationSuberr
|
||||
= NoAllocations
|
||||
| ExceededTotal
|
||||
| MissingBlank
|
||||
| TooManyBlanks
|
||||
deriving (Show)
|
||||
|
||||
data PatternSuberr = ZeroLength | ZeroRepeats deriving (Show)
|
||||
|
||||
data InsertError
|
||||
= RegexError !T.Text
|
||||
| MatchValPrecisionError !Natural !Natural
|
||||
| AccountError !AcntID !(NE.NonEmpty AcntType)
|
||||
| InsertIOError !T.Text
|
||||
| ParseError !T.Text
|
||||
| ConversionError !T.Text
|
||||
| LookupError !LookupSuberr !T.Text
|
||||
| BalanceError !BalanceType !CurID ![RawEntry]
|
||||
| IncomeError !Day !T.Text !Rational
|
||||
| PatternError !Natural !Natural !(Maybe Natural) !PatternSuberr
|
||||
| DaySpanError !Gregorian !(Maybe Gregorian)
|
||||
| StatementError ![TxRecord] ![MatchRe]
|
||||
| PeriodError !Day !Day
|
||||
deriving (Show)
|
||||
|
||||
newtype InsertException = InsertException [InsertError]
|
||||
deriving (Show, Semigroup) via [InsertError]
|
||||
|
||||
instance Exception InsertException
|
||||
|
||||
type MonadInsertError = MonadError InsertException
|
||||
|
||||
type InsertExceptT = ExceptT InsertException
|
||||
|
||||
type InsertExcept = InsertExceptT Identity
|
||||
|
||||
data XGregorian = XGregorian
|
||||
{ xgYear :: !Int
|
||||
, xgMonth :: !Int
|
||||
, xgDay :: !Int
|
||||
, xgDayOfWeek :: !Int
|
||||
}
|
||||
|
||||
type MatchRe = StatementParser (T.Text, Regex)
|
||||
|
||||
type TxOptsRe = TxOpts (T.Text, Regex)
|
||||
|
||||
type FieldMatcherRe = FieldMatcher (T.Text, Regex)
|
|
@ -1,4 +1,5 @@
|
|||
module Internal.TH where
|
||||
-- | Helper functions so I don't need to write lots of dhall instances
|
||||
module Internal.Types.TH where
|
||||
|
||||
import Language.Haskell.TH.Syntax (Dec (..), Q (..), Type (..), mkName)
|
||||
import RIO
|
|
@ -1,13 +1,15 @@
|
|||
module Internal.Utils
|
||||
( compareDate
|
||||
, expandDatePat
|
||||
, askDays
|
||||
, fromWeekday
|
||||
, inBounds
|
||||
, expandBounds
|
||||
, inDaySpan
|
||||
, fmtRational
|
||||
, matches
|
||||
, fromGregorian'
|
||||
, resolveBounds
|
||||
, resolveBounds_
|
||||
, resolveDaySpan
|
||||
, resolveDaySpan_
|
||||
, intersectDaySpan
|
||||
, liftInner
|
||||
, liftExceptT
|
||||
, liftExcept
|
||||
|
@ -26,15 +28,6 @@ module Internal.Utils
|
|||
, combineErrorIOM3
|
||||
, collectErrorsIO
|
||||
, mapErrorsIO
|
||||
-- , leftToMaybe
|
||||
-- , concatEithers2
|
||||
-- , concatEithers3
|
||||
-- , concatEither3
|
||||
-- , concatEither2
|
||||
-- , concatEitherL
|
||||
-- , concatEithersL
|
||||
-- , concatEither2M
|
||||
-- , concatEithers2M
|
||||
, parseRational
|
||||
, showError
|
||||
, unlessLeft_
|
||||
|
@ -50,13 +43,18 @@ module Internal.Utils
|
|||
, sndOf3
|
||||
, thdOf3
|
||||
, xGregToDay
|
||||
-- , plural
|
||||
, compileMatch
|
||||
, compileOptions
|
||||
, dateMatches
|
||||
, valMatches
|
||||
, roundPrecision
|
||||
, roundPrecisionCur
|
||||
, lookupAccountKey
|
||||
, lookupAccountSign
|
||||
, lookupAccountType
|
||||
, lookupCurrencyKey
|
||||
, lookupCurrencyPrec
|
||||
, lookupTag
|
||||
)
|
||||
where
|
||||
|
||||
|
@ -65,7 +63,7 @@ import Control.Monad.Except
|
|||
import Control.Monad.Reader
|
||||
import Data.Time.Format.ISO8601
|
||||
import GHC.Real
|
||||
import Internal.Types
|
||||
import Internal.Types.Main
|
||||
import RIO
|
||||
import qualified RIO.List as L
|
||||
import qualified RIO.Map as M
|
||||
|
@ -75,6 +73,96 @@ import RIO.Time
|
|||
import Text.Regex.TDFA
|
||||
import Text.Regex.TDFA.Text
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- intervals
|
||||
|
||||
expandDatePat :: DaySpan -> DatePat -> InsertExcept [Day]
|
||||
expandDatePat b (Cron cp) = expandCronPat b cp
|
||||
expandDatePat i (Mod mp) = return $ expandModPat mp i
|
||||
|
||||
expandModPat :: ModPat -> DaySpan -> [Day]
|
||||
expandModPat ModPat {mpStart = s, mpBy = b, mpUnit = u, mpRepeats = r} bs =
|
||||
takeWhile (<= upper) $
|
||||
(`addFun` start) . (* b')
|
||||
<$> maybe id (take . fromIntegral) r [0 ..]
|
||||
where
|
||||
(lower, upper) = fromDaySpan bs
|
||||
start = maybe lower fromGregorian' s
|
||||
b' = fromIntegral b
|
||||
addFun = case u of
|
||||
Day -> addDays
|
||||
Week -> addDays . (* 7)
|
||||
Month -> addGregorianMonthsClip
|
||||
Year -> addGregorianYearsClip
|
||||
|
||||
expandCronPat :: DaySpan -> CronPat -> InsertExcept [Day]
|
||||
expandCronPat b CronPat {cpYear, cpMonth, cpDay, cpWeekly} =
|
||||
combineError3 yRes mRes dRes $ \ys ms ds ->
|
||||
filter validWeekday $
|
||||
mapMaybe (uncurry3 toDay) $
|
||||
takeWhile (\((y, _), m, d) -> (y, m, d) <= (yb1, mb1, db1)) $
|
||||
dropWhile (\((y, _), m, d) -> (y, m, d) < (yb0, mb0, db0)) $
|
||||
[(y, m, d) | y <- (\y -> (y, isLeapYear y)) <$> ys, m <- ms, d <- ds]
|
||||
where
|
||||
yRes = case cpYear of
|
||||
Nothing -> return [yb0 .. yb1]
|
||||
Just pat -> do
|
||||
ys <- expandMDYPat (fromIntegral yb0) (fromIntegral yb1) pat
|
||||
return $ dropWhile (< yb0) $ fromIntegral <$> ys
|
||||
mRes = expandMD 12 cpMonth
|
||||
dRes = expandMD 31 cpDay
|
||||
(s, e) = fromDaySpan b
|
||||
(yb0, mb0, db0) = toGregorian s
|
||||
(yb1, mb1, db1) = toGregorian $ addDays (-1) e
|
||||
expandMD lim =
|
||||
fmap (fromIntegral <$>)
|
||||
. maybe (return [1 .. lim]) (expandMDYPat 1 lim)
|
||||
expandW (OnDay x) = [fromEnum x]
|
||||
expandW (OnDays xs) = fromEnum <$> xs
|
||||
ws = maybe [] expandW cpWeekly
|
||||
validWeekday = if null ws then const True else \day -> dayToWeekday day `elem` ws
|
||||
toDay (y, leap) m d
|
||||
| m == 2 && (not leap && d > 28 || leap && d > 29) = Nothing
|
||||
| m `elem` [4, 6, 9, 11] && d > 30 = Nothing
|
||||
| otherwise = Just $ fromGregorian y m d
|
||||
|
||||
expandMDYPat :: Natural -> Natural -> MDYPat -> InsertExcept [Natural]
|
||||
expandMDYPat lower upper (Single x) = return [x | lower <= x && x <= upper]
|
||||
expandMDYPat lower upper (Multi xs) = return $ dropWhile (<= lower) $ takeWhile (<= upper) xs
|
||||
expandMDYPat lower upper (After x) = return [max lower x .. upper]
|
||||
expandMDYPat lower upper (Before x) = return [lower .. min upper x]
|
||||
expandMDYPat lower upper (Between x y) = return [max lower x .. min upper y]
|
||||
expandMDYPat lower upper (Repeat RepeatPat {rpStart = s, rpBy = b, rpRepeats = r})
|
||||
| b < 1 = throwError $ InsertException [PatternError s b r ZeroLength]
|
||||
| otherwise = do
|
||||
k <- limit r
|
||||
return $ dropWhile (<= lower) $ takeWhile (<= k) [s + i * b | i <- [0 ..]]
|
||||
where
|
||||
limit Nothing = return upper
|
||||
limit (Just n)
|
||||
-- this guard not only produces the error for the user but also protects
|
||||
-- from an underflow below it
|
||||
| n < 1 = throwError $ InsertException [PatternError s b r ZeroRepeats]
|
||||
| otherwise = return $ min (s + b * (n - 1)) upper
|
||||
|
||||
dayToWeekday :: Day -> Int
|
||||
dayToWeekday (ModifiedJulianDay d) = mod (fromIntegral d + 2) 7
|
||||
|
||||
askDays
|
||||
:: (MonadFinance m, MonadInsertError m)
|
||||
=> DatePat
|
||||
-> Maybe Interval
|
||||
-> m [Day]
|
||||
askDays dp i = do
|
||||
globalSpan <- askDBState kmBudgetInterval
|
||||
case i of
|
||||
Just i' -> do
|
||||
localSpan <- liftExcept $ resolveDaySpan i'
|
||||
maybe (return []) expand $ intersectDaySpan globalSpan localSpan
|
||||
Nothing -> expand globalSpan
|
||||
where
|
||||
expand = liftExcept . (`expandDatePat` dp)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- dates
|
||||
|
||||
|
@ -161,27 +249,42 @@ compareDate (In md offset) x = do
|
|||
fromGregorian' :: Gregorian -> Day
|
||||
fromGregorian' = uncurry3 fromGregorian . gregTup
|
||||
|
||||
-- TODO misleading name
|
||||
inBounds :: (Day, Day) -> Day -> Bool
|
||||
inBounds (d0, d1) x = d0 <= x && x < d1
|
||||
inDaySpan :: DaySpan -> Day -> Bool
|
||||
inDaySpan bs = withinDays (fromDaySpan bs)
|
||||
|
||||
resolveBounds :: Interval -> InsertExcept Bounds
|
||||
resolveBounds i@Interval {intStart = s} =
|
||||
resolveBounds_ (s {gYear = gYear s + 50}) i
|
||||
withinDays :: (Day, Day) -> Day -> Bool
|
||||
withinDays (d0, d1) x = d0 <= x && x < d1
|
||||
|
||||
resolveBounds_ :: Gregorian -> Interval -> InsertExcept Bounds
|
||||
resolveBounds_ def Interval {intStart = s, intEnd = e} =
|
||||
resolveDaySpan :: Interval -> InsertExcept DaySpan
|
||||
resolveDaySpan i@Interval {intStart = s} =
|
||||
resolveDaySpan_ (s {gYear = gYear s + 50}) i
|
||||
|
||||
intersectDaySpan :: DaySpan -> DaySpan -> Maybe DaySpan
|
||||
intersectDaySpan a b =
|
||||
if b' > a' then Nothing else Just $ toDaySpan (a', b')
|
||||
where
|
||||
(a0, a1) = fromDaySpan a
|
||||
(b0, b1) = fromDaySpan b
|
||||
a' = max a0 a1
|
||||
b' = min b0 b1
|
||||
|
||||
resolveDaySpan_ :: Gregorian -> Interval -> InsertExcept DaySpan
|
||||
resolveDaySpan_ def Interval {intStart = s, intEnd = e} =
|
||||
case fromGregorian' <$> e of
|
||||
Nothing -> return $ toBounds $ fromGregorian' def
|
||||
Nothing -> return $ toDaySpan_ $ fromGregorian' def
|
||||
Just e_
|
||||
| s_ < e_ -> return $ toBounds e_
|
||||
| otherwise -> throwError $ InsertException [BoundsError s e]
|
||||
| s_ < e_ -> return $ toDaySpan_ e_
|
||||
| otherwise -> throwError $ InsertException [DaySpanError s e]
|
||||
where
|
||||
s_ = fromGregorian' s
|
||||
toBounds end = (s_, fromIntegral $ diffDays end s_ - 1)
|
||||
toDaySpan_ end = toDaySpan (s_, end)
|
||||
|
||||
expandBounds :: Bounds -> (Day, Day)
|
||||
expandBounds (d, n) = (d, addDays (fromIntegral n + 1) d)
|
||||
fromDaySpan :: DaySpan -> (Day, Day)
|
||||
fromDaySpan (d, n) = (d, addDays (fromIntegral n + 1) d)
|
||||
|
||||
-- ASSUME a < b
|
||||
toDaySpan :: (Day, Day) -> DaySpan
|
||||
toDaySpan (a, b) = (a, fromIntegral $ diffDays b a - 1)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- matching
|
||||
|
@ -203,10 +306,10 @@ matches
|
|||
desc = maybe (return True) (matchMaybe trDesc . snd) spDesc
|
||||
convert (TxGetter cur a ss) = MatchPass <$> toTx cur a ss r
|
||||
|
||||
toTx :: SplitCur -> SplitAcnt -> [EntryGetter] -> TxRecord -> InsertExceptT CurrencyM RawTx
|
||||
toTx sc sa toSplits r@TxRecord {trAmount, trDate, trDesc} = do
|
||||
combineError3 acntRes curRes ssRes $ \a c ss ->
|
||||
let fromSplit =
|
||||
toTx :: EntryCur -> EntryAcnt -> [EntryGetter] -> TxRecord -> InsertExceptT CurrencyM RawTx
|
||||
toTx sc sa toEntries r@TxRecord {trAmount, trDate, trDesc} = do
|
||||
combineError3 acntRes curRes ssRes $ \a c es ->
|
||||
let fromEntry =
|
||||
Entry
|
||||
{ eAcnt = a
|
||||
, eCurrency = c
|
||||
|
@ -217,12 +320,12 @@ toTx sc sa toSplits r@TxRecord {trAmount, trDate, trDesc} = do
|
|||
in Tx
|
||||
{ txDate = trDate
|
||||
, txDescr = trDesc
|
||||
, txSplits = fromSplit : ss
|
||||
, txEntries = fromEntry : es
|
||||
}
|
||||
where
|
||||
acntRes = liftInner $ resolveAcnt r sa
|
||||
curRes = liftInner $ resolveCurrency r sc
|
||||
ssRes = combineErrors $ fmap (resolveEntry r) toSplits
|
||||
ssRes = combineErrors $ fmap (resolveEntry r) toEntries
|
||||
|
||||
valMatches :: ValMatcher -> Rational -> InsertExcept Bool
|
||||
valMatches ValMatcher {vmDen, vmSign, vmNum, vmPrec} x
|
||||
|
@ -248,7 +351,7 @@ otherMatches dict m = case m of
|
|||
where
|
||||
lookup_ t n = lookupErr (MatchField t) n dict
|
||||
|
||||
resolveEntry :: TxRecord -> EntryGetter -> InsertExceptT CurrencyM RawSplit
|
||||
resolveEntry :: TxRecord -> EntryGetter -> InsertExceptT CurrencyM RawEntry
|
||||
resolveEntry r s@Entry {eAcnt, eValue, eCurrency} = do
|
||||
m <- ask
|
||||
liftInner $ combineErrorM3 acntRes curRes valRes $ \a c v -> do
|
||||
|
@ -344,18 +447,18 @@ collectErrorsIO = mapErrorsIO id
|
|||
|
||||
resolveValue :: TxRecord -> EntryNumGetter -> InsertExcept Double
|
||||
resolveValue TxRecord {trOther, trAmount} s = case s of
|
||||
(LookupN t) -> readDouble =<< lookupErr SplitValField t trOther
|
||||
(LookupN t) -> readDouble =<< lookupErr EntryValField t trOther
|
||||
(ConstN c) -> return c
|
||||
AmountN m -> return $ (* m) $ fromRational trAmount
|
||||
|
||||
resolveAcnt :: TxRecord -> SplitAcnt -> InsertExcept T.Text
|
||||
resolveAcnt = resolveSplitField AcntField
|
||||
resolveAcnt :: TxRecord -> EntryAcnt -> InsertExcept T.Text
|
||||
resolveAcnt = resolveEntryField AcntField
|
||||
|
||||
resolveCurrency :: TxRecord -> SplitCur -> InsertExcept T.Text
|
||||
resolveCurrency = resolveSplitField CurField
|
||||
resolveCurrency :: TxRecord -> EntryCur -> InsertExcept T.Text
|
||||
resolveCurrency = resolveEntryField CurField
|
||||
|
||||
resolveSplitField :: SplitIDType -> TxRecord -> SplitAcnt -> InsertExcept T.Text
|
||||
resolveSplitField t TxRecord {trOther = o} s = case s of
|
||||
resolveEntryField :: EntryIDType -> TxRecord -> EntryAcnt -> InsertExcept T.Text
|
||||
resolveEntryField t TxRecord {trOther = o} s = case s of
|
||||
ConstT p -> return p
|
||||
LookupT f -> lookup_ f o
|
||||
MapT (Field f m) -> do
|
||||
|
@ -366,7 +469,7 @@ resolveSplitField t TxRecord {trOther = o} s = case s of
|
|||
lookup_ (k1, k2) m
|
||||
where
|
||||
lookup_ :: (Ord k, Show k) => k -> M.Map k v -> InsertExcept v
|
||||
lookup_ = lookupErr (SplitIDField t)
|
||||
lookup_ = lookupErr (EntryIDField t)
|
||||
|
||||
lookupErr :: (Ord k, Show k) => LookupSuberr -> k -> M.Map k v -> InsertExcept v
|
||||
lookupErr what k m = case M.lookup k m of
|
||||
|
@ -454,7 +557,7 @@ acntPath2Text (AcntPath t cs) = T.intercalate "/" (atName t : cs)
|
|||
showError :: InsertError -> [T.Text]
|
||||
showError other = case other of
|
||||
(StatementError ts ms) -> (showTx <$> ts) ++ (showMatch <$> ms)
|
||||
(BoundsError a b) ->
|
||||
(DaySpanError a b) ->
|
||||
[T.unwords ["Could not create bounds from", showGregorian_ a, "and", showGreg b]]
|
||||
where
|
||||
showGreg (Just g) = showGregorian_ g
|
||||
|
@ -493,8 +596,8 @@ showError other = case other of
|
|||
[T.unwords ["Could not find field", f, "when resolving", what]]
|
||||
where
|
||||
what = case t of
|
||||
SplitIDField st -> T.unwords ["split", idName st, "ID"]
|
||||
SplitValField -> "split value"
|
||||
EntryIDField st -> T.unwords ["entry", idName st, "ID"]
|
||||
EntryValField -> "entry value"
|
||||
MatchField mt -> T.unwords [matchName mt, "match"]
|
||||
DBKey st -> T.unwords ["database", idName st, "ID key"]
|
||||
-- TODO this should be its own function
|
||||
|
@ -526,15 +629,15 @@ showError other = case other of
|
|||
[ msg
|
||||
, "for currency"
|
||||
, singleQuote cur
|
||||
, "and for splits"
|
||||
, splits
|
||||
, "and for entries"
|
||||
, entries
|
||||
]
|
||||
]
|
||||
where
|
||||
msg = case t of
|
||||
TooFewSplits -> "Need at least two splits to balance"
|
||||
NotOneBlank -> "Exactly one split must be blank"
|
||||
splits = T.intercalate ", " $ fmap (singleQuote . showSplit) rss
|
||||
TooFewEntries -> "Need at least two entries to balance"
|
||||
NotOneBlank -> "Exactly one entries must be blank"
|
||||
entries = T.intercalate ", " $ fmap (singleQuote . showEntry) rss
|
||||
|
||||
showGregorian_ :: Gregorian -> T.Text
|
||||
showGregorian_ Gregorian {gYear, gMonth, gDay} = T.intercalate "-" $ showT <$> [gYear, gMonth, gDay]
|
||||
|
@ -622,8 +725,8 @@ showMatchOther (Val (Field f mv)) =
|
|||
, singleQuote $ fromMaybe "*" $ showValMatcher mv
|
||||
]
|
||||
|
||||
showSplit :: RawSplit -> T.Text
|
||||
showSplit Entry {eAcnt, eValue, eComment} =
|
||||
showEntry :: RawEntry -> T.Text
|
||||
showEntry Entry {eAcnt, eValue, eComment} =
|
||||
keyVals
|
||||
[ ("account", eAcnt)
|
||||
, ("value", T.pack $ show ((fromRational <$> eValue) :: Maybe Float))
|
||||
|
@ -791,3 +894,35 @@ matchGroupsMaybe q re = case regexec re q of
|
|||
Right (Just (_, _, _, xs)) -> xs
|
||||
-- this should never fail as regexec always returns Right
|
||||
Left _ -> []
|
||||
|
||||
lookupAccount :: (MonadInsertError m, MonadFinance m) => AcntID -> m (AccountRId, AcntSign, AcntType)
|
||||
lookupAccount = lookupFinance AcntField kmAccount
|
||||
|
||||
lookupAccountKey :: (MonadInsertError m, MonadFinance m) => AcntID -> m AccountRId
|
||||
lookupAccountKey = fmap fstOf3 . lookupAccount
|
||||
|
||||
lookupAccountSign :: (MonadInsertError m, MonadFinance m) => AcntID -> m AcntSign
|
||||
lookupAccountSign = fmap sndOf3 . lookupAccount
|
||||
|
||||
lookupAccountType :: (MonadInsertError m, MonadFinance m) => AcntID -> m AcntType
|
||||
lookupAccountType = fmap thdOf3 . lookupAccount
|
||||
|
||||
lookupCurrency :: (MonadInsertError m, MonadFinance m) => T.Text -> m (CurrencyRId, Natural)
|
||||
lookupCurrency = lookupFinance CurField kmCurrency
|
||||
|
||||
lookupCurrencyKey :: (MonadInsertError m, MonadFinance m) => AcntID -> m CurrencyRId
|
||||
lookupCurrencyKey = fmap fst . lookupCurrency
|
||||
|
||||
lookupCurrencyPrec :: (MonadInsertError m, MonadFinance m) => AcntID -> m Natural
|
||||
lookupCurrencyPrec = fmap snd . lookupCurrency
|
||||
|
||||
lookupTag :: (MonadInsertError m, MonadFinance m) => TagID -> m TagRId
|
||||
lookupTag = lookupFinance TagField kmTag
|
||||
|
||||
lookupFinance
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
=> EntryIDType
|
||||
-> (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