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 Control.Monad.Reader
|
||||||
import qualified Data.Text.IO as TI
|
import qualified Data.Text.IO as TI
|
||||||
import Database.Persist.Monad
|
import Database.Persist.Monad
|
||||||
import Internal.Config
|
import Dhall hiding (double, record)
|
||||||
import Internal.Database.Ops
|
import Internal.Budget
|
||||||
import Internal.Insert
|
import Internal.Database
|
||||||
import Internal.Types
|
import Internal.History
|
||||||
|
import Internal.Types.Main
|
||||||
import Internal.Utils
|
import Internal.Utils
|
||||||
import Options.Applicative
|
import Options.Applicative
|
||||||
import RIO
|
import RIO
|
||||||
|
@ -168,25 +169,31 @@ runSync c = do
|
||||||
-- _ <- askLoggerIO
|
-- _ <- askLoggerIO
|
||||||
|
|
||||||
-- get the current DB state
|
-- get the current DB state
|
||||||
s <- runSqlQueryT pool $ do
|
(state, updates) <- runSqlQueryT pool $ do
|
||||||
runMigration migrateAll
|
runMigration migrateAll
|
||||||
fmap (\f -> f $ takeDirectory c) $ liftIOExceptT $ getDBState config
|
liftIOExceptT $ getDBState config
|
||||||
|
|
||||||
-- read desired statements from disk
|
-- 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
|
-- update the DB
|
||||||
runSqlQueryT pool $ withTransaction $ flip runReaderT s $ do
|
runSqlQueryT pool $ withTransaction $ flip runReaderT state $ do
|
||||||
let hTransRes = mapErrors insertHistTransfer hTs
|
let hTransRes = mapErrors insertHistTransfer hTs
|
||||||
let bgtRes = mapErrors insertBudget $ budget config
|
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
|
res <- runExceptT $ do
|
||||||
mapM_ (uncurry insertHistStmt) bSs
|
mapM_ (uncurry insertHistStmt) bSs
|
||||||
combineError hTransRes bgtRes $ \_ _ -> ()
|
combineError hTransRes bgtRes $ \_ _ -> ()
|
||||||
rerunnableIO $ fromEither res
|
rerunnableIO $ fromEither res
|
||||||
where
|
where
|
||||||
|
root = takeDirectory c
|
||||||
err (InsertException es) = do
|
err (InsertException es) = do
|
||||||
liftIO $ mapM_ TI.putStrLn $ concatMap showError es
|
liftIO $ mapM_ TI.putStrLn $ concatMap showError es
|
||||||
exitFailure
|
exitFailure
|
||||||
|
|
||||||
-- showBalances
|
-- 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
|
library
|
||||||
exposed-modules:
|
exposed-modules:
|
||||||
Internal.Config
|
Internal.Budget
|
||||||
Internal.Database.Ops
|
Internal.Database
|
||||||
Internal.Insert
|
Internal.History
|
||||||
Internal.Statement
|
Internal.Types.Database
|
||||||
Internal.TH
|
Internal.Types.Dhall
|
||||||
Internal.Types
|
Internal.Types.Main
|
||||||
|
Internal.Types.TH
|
||||||
Internal.Utils
|
Internal.Utils
|
||||||
other-modules:
|
other-modules:
|
||||||
Paths_budget
|
Paths_budget
|
||||||
|
|
|
@ -1018,6 +1018,7 @@ let Budget =
|
||||||
, bgtPosttax : List (MultiAllocation PosttaxValue)
|
, bgtPosttax : List (MultiAllocation PosttaxValue)
|
||||||
, bgtTransfers : List BudgetTransfer
|
, bgtTransfers : List BudgetTransfer
|
||||||
, bgtShadowTransfers : List ShadowTransfer
|
, bgtShadowTransfers : List ShadowTransfer
|
||||||
|
, bgtInterval : Optional Interval
|
||||||
}
|
}
|
||||||
|
|
||||||
in { CurID
|
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
|
( runDB
|
||||||
, nukeTables
|
, nukeTables
|
||||||
, updateHashes
|
, updateHashes
|
||||||
|
@ -8,6 +8,10 @@ module Internal.Database.Ops
|
||||||
, flattenAcntRoot
|
, flattenAcntRoot
|
||||||
, paths2IDs
|
, paths2IDs
|
||||||
, mkPool
|
, mkPool
|
||||||
|
, whenHash
|
||||||
|
, whenHash_
|
||||||
|
, insertEntry
|
||||||
|
, resolveEntry
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
|
@ -19,10 +23,18 @@ import Database.Esqueleto.Experimental ((==.), (^.))
|
||||||
import qualified Database.Esqueleto.Experimental as E
|
import qualified Database.Esqueleto.Experimental as E
|
||||||
import Database.Esqueleto.Internal.Internal (SqlSelect)
|
import Database.Esqueleto.Internal.Internal (SqlSelect)
|
||||||
import Database.Persist.Monad
|
import Database.Persist.Monad
|
||||||
-- import Database.Persist.Sql hiding (delete, runMigration, (==.), (||.))
|
import Database.Persist.Sqlite hiding
|
||||||
import Database.Persist.Sqlite hiding (delete, deleteWhere, insert, insertKey, runMigration, (==.), (||.))
|
( delete
|
||||||
|
, deleteWhere
|
||||||
|
, insert
|
||||||
|
, insertKey
|
||||||
|
, insert_
|
||||||
|
, runMigration
|
||||||
|
, (==.)
|
||||||
|
, (||.)
|
||||||
|
)
|
||||||
import GHC.Err
|
import GHC.Err
|
||||||
import Internal.Types
|
import Internal.Types.Main
|
||||||
import Internal.Utils
|
import Internal.Utils
|
||||||
import RIO hiding (LogFunc, isNothing, on, (^.))
|
import RIO hiding (LogFunc, isNothing, on, (^.))
|
||||||
import RIO.List ((\\))
|
import RIO.List ((\\))
|
||||||
|
@ -288,79 +300,117 @@ indexAcntRoot r =
|
||||||
getDBState
|
getDBState
|
||||||
:: (MonadInsertError m, MonadSqlQuery m)
|
:: (MonadInsertError m, MonadSqlQuery m)
|
||||||
=> Config
|
=> Config
|
||||||
-> m (FilePath -> DBState)
|
-> m (DBState, DBUpdates)
|
||||||
getDBState c = do
|
getDBState c = do
|
||||||
(del, new) <- getConfigHashes c
|
(del, new) <- getConfigHashes c
|
||||||
-- TODO not sure how I feel about this, probably will change this struct alot
|
combineError bi si $ \b s ->
|
||||||
-- in the future so whatever...for now
|
( DBState
|
||||||
combineError bi si $ \b s f ->
|
{ kmCurrency = currencyMap cs
|
||||||
-- TODO this can be cleaned up, half of it is meant to be queried when
|
, kmAccount = am
|
||||||
-- determining how to insert budgets/history and the rest is just
|
, kmBudgetInterval = b
|
||||||
-- holdover data to delete upon successful insertion
|
, kmStatementInterval = s
|
||||||
DBState
|
, kmTag = tagMap ts
|
||||||
{ kmCurrency = currencyMap cs
|
, kmNewCommits = new
|
||||||
, kmAccount = am
|
}
|
||||||
, kmBudgetInterval = b
|
, DBUpdates
|
||||||
, kmStatementInterval = s
|
{ duOldCommits = del
|
||||||
, kmNewCommits = new
|
, duNewTagIds = ts
|
||||||
, kmOldCommits = del
|
, duNewAcntPaths = paths
|
||||||
, kmConfigDir = f
|
, duNewAcntIds = acnts
|
||||||
, kmTag = tagMap ts
|
, duNewCurrencyIds = cs
|
||||||
, kmTagAll = ts
|
}
|
||||||
, kmAcntPaths = paths
|
)
|
||||||
, kmAcntsOld = acnts
|
|
||||||
, kmCurrenciesOld = cs
|
|
||||||
}
|
|
||||||
where
|
where
|
||||||
bi = liftExcept $ resolveBounds $ budgetInterval $ global c
|
bi = liftExcept $ resolveDaySpan $ budgetInterval $ global c
|
||||||
si = liftExcept $ resolveBounds $ statementInterval $ global c
|
si = liftExcept $ resolveDaySpan $ statementInterval $ global c
|
||||||
(acnts, paths, am) = indexAcntRoot $ accounts c
|
(acnts, paths, am) = indexAcntRoot $ accounts c
|
||||||
cs = currency2Record <$> currencies c
|
cs = currency2Record <$> currencies c
|
||||||
ts = toRecord <$> tags c
|
ts = toRecord <$> tags c
|
||||||
toRecord t@Tag {tagID, tagDesc} = Entity (toKey t) $ TagR tagID tagDesc
|
toRecord t@Tag {tagID, tagDesc} = Entity (toKey t) $ TagR tagID tagDesc
|
||||||
tagMap = M.fromList . fmap (\e -> (tagRSymbol $ entityVal e, entityKey e))
|
tagMap = M.fromList . fmap (\e -> (tagRSymbol $ entityVal e, entityKey e))
|
||||||
|
|
||||||
updateHashes :: (MonadFinance m, MonadSqlQuery m) => m ()
|
updateHashes :: (MonadSqlQuery m) => DBUpdates -> m ()
|
||||||
updateHashes = do
|
updateHashes DBUpdates {duOldCommits} = nukeDBHashes duOldCommits
|
||||||
old <- askDBState kmOldCommits
|
|
||||||
nukeDBHashes old
|
|
||||||
|
|
||||||
updateTags :: (MonadFinance m, MonadSqlQuery m) => m ()
|
updateTags :: (MonadFinance m, MonadSqlQuery m) => DBUpdates -> m ()
|
||||||
updateTags = do
|
updateTags DBUpdates {duNewTagIds} = do
|
||||||
tags <- askDBState kmTagAll
|
|
||||||
tags' <- selectE $ E.from $ E.table @TagR
|
tags' <- selectE $ E.from $ E.table @TagR
|
||||||
let (toIns, toDel) = setDiff tags tags'
|
let (toIns, toDel) = setDiff duNewTagIds tags'
|
||||||
mapM_ deleteTag toDel
|
mapM_ deleteTag toDel
|
||||||
mapM_ insertFull toIns
|
mapM_ insertFull toIns
|
||||||
|
|
||||||
updateAccounts :: (MonadFinance m, MonadSqlQuery m) => m ()
|
updateAccounts :: (MonadFinance m, MonadSqlQuery m) => DBUpdates -> m ()
|
||||||
updateAccounts = do
|
updateAccounts DBUpdates {duNewAcntIds, duNewAcntPaths} = do
|
||||||
acnts <- askDBState kmAcntsOld
|
|
||||||
paths <- askDBState kmAcntPaths
|
|
||||||
acnts' <- dumpTbl
|
acnts' <- dumpTbl
|
||||||
let (toIns, toDel) = setDiff acnts acnts'
|
let (toIns, toDel) = setDiff duNewAcntIds acnts'
|
||||||
deleteWhere ([] :: [Filter AccountPathR])
|
deleteWhere ([] :: [Filter AccountPathR])
|
||||||
mapM_ deleteAccount toDel
|
mapM_ deleteAccount toDel
|
||||||
mapM_ insertFull toIns
|
mapM_ insertFull toIns
|
||||||
mapM_ insert paths
|
mapM_ insert duNewAcntPaths
|
||||||
|
|
||||||
updateCurrencies :: (MonadFinance m, MonadSqlQuery m) => m ()
|
updateCurrencies :: (MonadFinance m, MonadSqlQuery m) => DBUpdates -> m ()
|
||||||
updateCurrencies = do
|
updateCurrencies DBUpdates {duNewCurrencyIds} = do
|
||||||
curs <- askDBState kmCurrenciesOld
|
|
||||||
curs' <- selectE $ E.from $ E.table @CurrencyR
|
curs' <- selectE $ E.from $ E.table @CurrencyR
|
||||||
let (toIns, toDel) = setDiff curs curs'
|
let (toIns, toDel) = setDiff duNewCurrencyIds curs'
|
||||||
mapM_ deleteCurrency toDel
|
mapM_ deleteCurrency toDel
|
||||||
mapM_ insertFull toIns
|
mapM_ insertFull toIns
|
||||||
|
|
||||||
updateDBState :: (MonadFinance m, MonadSqlQuery m) => m ()
|
updateDBState :: (MonadFinance m, MonadSqlQuery m) => DBUpdates -> m ()
|
||||||
updateDBState = do
|
updateDBState u = do
|
||||||
updateHashes
|
updateHashes u
|
||||||
updateTags
|
updateTags u
|
||||||
updateAccounts
|
updateAccounts u
|
||||||
updateCurrencies
|
updateCurrencies u
|
||||||
|
|
||||||
deleteE :: (MonadSqlQuery m) => E.SqlQuery () -> m ()
|
deleteE :: (MonadSqlQuery m) => E.SqlQuery () -> m ()
|
||||||
deleteE q = unsafeLiftSql "esqueleto-delete" (E.delete q)
|
deleteE q = unsafeLiftSql "esqueleto-delete" (E.delete q)
|
||||||
|
|
||||||
selectE :: (MonadSqlQuery m, SqlSelect a r) => E.SqlQuery a -> m [r]
|
selectE :: (MonadSqlQuery m, SqlSelect a r) => E.SqlQuery a -> m [r]
|
||||||
selectE q = unsafeLiftSql "esqueleto-select" (E.select q)
|
selectE q = unsafeLiftSql "esqueleto-select" (E.select q)
|
||||||
|
|
||||||
|
whenHash
|
||||||
|
:: (Hashable a, MonadFinance m, MonadSqlQuery m)
|
||||||
|
=> ConfigType
|
||||||
|
-> a
|
||||||
|
-> b
|
||||||
|
-> (CommitRId -> m b)
|
||||||
|
-> m b
|
||||||
|
whenHash t o def f = do
|
||||||
|
let h = hash o
|
||||||
|
hs <- askDBState kmNewCommits
|
||||||
|
if h `elem` hs then f =<< insert (CommitR h t) else return def
|
||||||
|
|
||||||
|
whenHash_
|
||||||
|
:: (Hashable a, MonadFinance m)
|
||||||
|
=> ConfigType
|
||||||
|
-> a
|
||||||
|
-> m b
|
||||||
|
-> m (Maybe (CommitR, b))
|
||||||
|
whenHash_ t o f = do
|
||||||
|
let h = hash o
|
||||||
|
let c = CommitR h t
|
||||||
|
hs <- askDBState kmNewCommits
|
||||||
|
if h `elem` hs then Just . (c,) <$> f else return Nothing
|
||||||
|
|
||||||
|
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.History
|
||||||
|
( splitHistory
|
||||||
module Internal.Statement
|
, insertHistTransfer
|
||||||
( readImport
|
, readHistStmt
|
||||||
|
, insertHistStmt
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
import Control.Monad.Error.Class
|
|
||||||
import Control.Monad.Except
|
import Control.Monad.Except
|
||||||
import Data.Csv
|
import Data.Csv
|
||||||
import Internal.Types
|
import Database.Persist.Monad
|
||||||
|
import Internal.Database
|
||||||
|
import Internal.Types.Main
|
||||||
import Internal.Utils
|
import Internal.Utils
|
||||||
import RIO
|
import RIO hiding (to)
|
||||||
import qualified RIO.ByteString.Lazy as BL
|
import qualified RIO.ByteString.Lazy as BL
|
||||||
import RIO.FilePath
|
import RIO.FilePath
|
||||||
import qualified RIO.List as L
|
import qualified RIO.List as L
|
||||||
|
@ -19,30 +21,118 @@ import qualified RIO.Text as T
|
||||||
import RIO.Time
|
import RIO.Time
|
||||||
import qualified RIO.Vector as V
|
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?)
|
-- TODO this probably won't scale well (pipes?)
|
||||||
readImport :: (MonadUnliftIO m, MonadFinance m) => Statement -> m [BalTx]
|
readImport :: (MonadUnliftIO m, MonadFinance m) => FilePath -> Statement -> m [BalTx]
|
||||||
readImport Statement {..} = do
|
readImport root Statement {stmtTxOpts, stmtParsers, stmtSkipLines, stmtDelim, stmtPaths} = do
|
||||||
let ores = compileOptions stmtTxOpts
|
let ores = compileOptions stmtTxOpts
|
||||||
let cres = combineErrors $ compileMatch <$> stmtParsers
|
let cres = combineErrors $ compileMatch <$> stmtParsers
|
||||||
(compiledOptions, compiledMatches) <- liftIOExcept $ combineError ores cres (,)
|
(compiledOptions, compiledMatches) <- liftIOExcept $ combineError ores cres (,)
|
||||||
let readStmt = readImport_ stmtSkipLines stmtDelim compiledOptions
|
let readStmt = readImport_ stmtSkipLines stmtDelim compiledOptions
|
||||||
records <- L.sort . concat <$> mapErrorsIO readStmt stmtPaths
|
records <- L.sort . concat <$> mapErrorsIO readStmt paths
|
||||||
m <- askDBState kmCurrency
|
m <- askDBState kmCurrency
|
||||||
fromEither $
|
fromEither $
|
||||||
flip runReader m $
|
flip runReader m $
|
||||||
runExceptT $
|
runExceptT $
|
||||||
matchRecords compiledMatches records
|
matchRecords compiledMatches records
|
||||||
|
where
|
||||||
|
paths = (root </>) <$> stmtPaths
|
||||||
|
|
||||||
readImport_
|
readImport_
|
||||||
:: (MonadUnliftIO m, MonadFinance m)
|
:: MonadUnliftIO m
|
||||||
=> Natural
|
=> Natural
|
||||||
-> Word
|
-> Word
|
||||||
-> TxOptsRe
|
-> TxOptsRe
|
||||||
-> FilePath
|
-> FilePath
|
||||||
-> m [TxRecord]
|
-> m [TxRecord]
|
||||||
readImport_ n delim tns p = do
|
readImport_ n delim tns p = do
|
||||||
dir <- askDBState kmConfigDir
|
res <- tryIO $ BL.readFile p
|
||||||
res <- tryIO $ BL.readFile $ dir </> p
|
|
||||||
bs <- fromEither $ first (InsertException . (: []) . InsertIOError . showT) res
|
bs <- fromEither $ first (InsertException . (: []) . InsertIOError . showT) res
|
||||||
case decodeByNameWithP (parseTxRecord p tns) opts $ skip bs of
|
case decodeByNameWithP (parseTxRecord p tns) opts $ skip bs of
|
||||||
Left m -> throwIO $ InsertException [ParseError $ T.pack m]
|
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
|
-- 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
|
-- blank dates but will likely want to make this more flexible
|
||||||
parseTxRecord :: FilePath -> TxOptsRe -> NamedRecord -> Parser (Maybe TxRecord)
|
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
|
d <- r .: T.encodeUtf8 toDate
|
||||||
if d == ""
|
if d == ""
|
||||||
then return Nothing
|
then return Nothing
|
||||||
|
@ -69,7 +159,6 @@ matchRecords :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM [BalTx]
|
||||||
matchRecords ms rs = do
|
matchRecords ms rs = do
|
||||||
(matched, unmatched, notfound) <- matchAll (matchPriorities ms) rs
|
(matched, unmatched, notfound) <- matchAll (matchPriorities ms) rs
|
||||||
case (matched, unmatched, notfound) of
|
case (matched, unmatched, notfound) of
|
||||||
-- TODO record number of times each match hits for debugging
|
|
||||||
(ms_, [], []) -> liftInner $ combineErrors $ fmap balanceTx ms_
|
(ms_, [], []) -> liftInner $ combineErrors $ fmap balanceTx ms_
|
||||||
(_, us, ns) -> throwError $ InsertException [StatementError us ns]
|
(_, us, ns) -> throwError $ InsertException [StatementError us ns]
|
||||||
|
|
||||||
|
@ -85,7 +174,6 @@ matchToGroup ms =
|
||||||
first (L.sortOn spDate) $
|
first (L.sortOn spDate) $
|
||||||
L.partition (isJust . spDate) ms
|
L.partition (isJust . spDate) ms
|
||||||
|
|
||||||
-- TDOO could use a better struct to flatten the maybe date subtype
|
|
||||||
data MatchGroup = MatchGroup
|
data MatchGroup = MatchGroup
|
||||||
{ mgDate :: ![MatchRe]
|
{ mgDate :: ![MatchRe]
|
||||||
, mgNoDate :: ![MatchRe]
|
, mgNoDate :: ![MatchRe]
|
||||||
|
@ -141,7 +229,6 @@ zipperMatch (Unzipped bs cs as) x = go [] cs
|
||||||
ms' = maybe ms (: ms) (matchDec m)
|
ms' = maybe ms (: ms) (matchDec m)
|
||||||
in return (Zipped bs $ ps ++ ms' ++ as, skipOrPass)
|
in return (Zipped bs $ ps ++ ms' ++ as, skipOrPass)
|
||||||
|
|
||||||
-- TODO all this unpacking left/error crap is annoying
|
|
||||||
zipperMatch'
|
zipperMatch'
|
||||||
:: Zipped MatchRe
|
:: Zipped MatchRe
|
||||||
-> TxRecord
|
-> TxRecord
|
||||||
|
@ -217,12 +304,12 @@ matchNonDates ms = go ([], [], initZipper ms)
|
||||||
in go (m, u, resetZipper z') rs
|
in go (m, u, resetZipper z') rs
|
||||||
|
|
||||||
balanceTx :: RawTx -> InsertExcept BalTx
|
balanceTx :: RawTx -> InsertExcept BalTx
|
||||||
balanceTx t@Tx {txSplits = ss} = do
|
balanceTx t@Tx {txEntries = ss} = do
|
||||||
bs <- balanceSplits ss
|
bs <- balanceEntries ss
|
||||||
return $ t {txSplits = bs}
|
return $ t {txEntries = bs}
|
||||||
|
|
||||||
balanceSplits :: [RawSplit] -> InsertExcept [BalSplit]
|
balanceEntries :: [RawEntry] -> InsertExcept [BalEntry]
|
||||||
balanceSplits ss =
|
balanceEntries ss =
|
||||||
fmap concat
|
fmap concat
|
||||||
<$> mapM (uncurry bal)
|
<$> mapM (uncurry bal)
|
||||||
$ groupByKey
|
$ groupByKey
|
||||||
|
@ -231,7 +318,7 @@ balanceSplits ss =
|
||||||
haeValue s@Entry {eValue = Just v} = Right s {eValue = v}
|
haeValue s@Entry {eValue = Just v} = Right s {eValue = v}
|
||||||
haeValue s = Left s
|
haeValue s = Left s
|
||||||
bal cur rss
|
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
|
| otherwise = case partitionEithers $ fmap haeValue rss of
|
||||||
([noVal], val) -> return $ noVal {eValue = foldr (\s x -> x - eValue s) 0 val} : val
|
([noVal], val) -> return $ noVal {eValue = foldr (\s x -> x - eValue s) 0 val} : val
|
||||||
([], val) -> return 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 TemplateHaskell #-}
|
||||||
{-# LANGUAGE UndecidableInstances #-}
|
{-# 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 Control.Monad.Except
|
||||||
import Data.Fix (Fix (..), foldFix)
|
import Data.Fix (Fix (..), foldFix)
|
||||||
import Data.Functor.Foldable (embed)
|
import Data.Functor.Foldable (embed)
|
||||||
import qualified Data.Functor.Foldable.TH as TH
|
import qualified Data.Functor.Foldable.TH as TH
|
||||||
import Database.Persist.Sql hiding (Desc, In, Statement)
|
import Database.Persist.Sql hiding (Desc, In, Statement)
|
||||||
import Database.Persist.TH
|
|
||||||
import Dhall hiding (embed, maybe)
|
import Dhall hiding (embed, maybe)
|
||||||
import Dhall.TH
|
import Dhall.TH
|
||||||
import Internal.TH (deriveProduct)
|
import Internal.Types.TH (deriveProduct)
|
||||||
import Language.Haskell.TH.Syntax (Lift)
|
import Language.Haskell.TH.Syntax (Lift)
|
||||||
import RIO
|
import RIO
|
||||||
import qualified RIO.Map as M
|
import qualified RIO.Map as M
|
||||||
import qualified RIO.NonEmpty as NE
|
|
||||||
import qualified RIO.Text as T
|
import qualified RIO.Text as T
|
||||||
import RIO.Time
|
import RIO.Time
|
||||||
import Text.Regex.TDFA
|
import Text.Regex.TDFA
|
||||||
|
|
||||||
-------------------------------------------------------------------------------
|
|
||||||
-- DHALL CONFIG
|
|
||||||
-------------------------------------------------------------------------------
|
|
||||||
|
|
||||||
makeHaskellTypesWith
|
makeHaskellTypesWith
|
||||||
(defaultGenerateOptions {generateToDhallInstance = False, generateFromDhallInstance = False})
|
(defaultGenerateOptions {generateToDhallInstance = False, generateFromDhallInstance = False})
|
||||||
[ MultipleConstructors "SqlConfig" "(./dhall/Types.dhall).SqlConfig"
|
[ MultipleConstructors "SqlConfig" "(./dhall/Types.dhall).SqlConfig"
|
||||||
|
@ -200,6 +195,7 @@ data Budget = Budget
|
||||||
, bgtPosttax :: [MultiAllocation PosttaxValue]
|
, bgtPosttax :: [MultiAllocation PosttaxValue]
|
||||||
, bgtTransfers :: [BudgetTransfer]
|
, bgtTransfers :: [BudgetTransfer]
|
||||||
, bgtShadowTransfers :: [ShadowTransfer]
|
, bgtShadowTransfers :: [ShadowTransfer]
|
||||||
|
, bgtInterval :: !(Maybe Interval)
|
||||||
}
|
}
|
||||||
|
|
||||||
deriving instance Hashable PretaxValue
|
deriving instance Hashable PretaxValue
|
||||||
|
@ -425,7 +421,7 @@ data History
|
||||||
| HistStatement !Statement
|
| HistStatement !Statement
|
||||||
deriving (Eq, Generic, Hashable, FromDhall)
|
deriving (Eq, Generic, Hashable, FromDhall)
|
||||||
|
|
||||||
type EntryGetter = Entry SplitAcnt (Maybe EntryNumGetter) SplitCur TagID
|
type EntryGetter = Entry EntryAcnt (Maybe EntryNumGetter) EntryCur TagID
|
||||||
|
|
||||||
instance FromDhall EntryGetter
|
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
|
data Tx s = Tx
|
||||||
{ txDescr :: !T.Text
|
{ txDescr :: !T.Text
|
||||||
, txDate :: !Day
|
, txDate :: !Day
|
||||||
, txSplits :: ![s]
|
, txEntries :: ![s]
|
||||||
}
|
}
|
||||||
deriving (Generic)
|
deriving (Generic)
|
||||||
|
|
||||||
|
@ -467,7 +463,7 @@ data Statement = Statement
|
||||||
}
|
}
|
||||||
deriving (Eq, Hashable, Generic, FromDhall)
|
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
|
-- can either be a raw (constant) value, a lookup from the record, or a map
|
||||||
-- between the lookup and some other value
|
-- between the lookup and some other value
|
||||||
data EntryTextGetter t
|
data EntryTextGetter t
|
||||||
|
@ -477,9 +473,9 @@ data EntryTextGetter t
|
||||||
| Map2T !(FieldMap (T.Text, T.Text) t)
|
| Map2T !(FieldMap (T.Text, T.Text) t)
|
||||||
deriving (Eq, Generic, Hashable, Show, FromDhall)
|
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)
|
deriving instance (Show k, Show v) => Show (Field k v)
|
||||||
|
|
||||||
|
@ -508,8 +504,8 @@ data FieldMatcher re
|
||||||
deriving instance Show (FieldMatcher T.Text)
|
deriving instance Show (FieldMatcher T.Text)
|
||||||
|
|
||||||
data TxGetter = TxGetter
|
data TxGetter = TxGetter
|
||||||
{ tgCurrency :: !SplitCur
|
{ tgCurrency :: !EntryCur
|
||||||
, tgAcnt :: !SplitAcnt
|
, tgAcnt :: !EntryAcnt
|
||||||
, tgEntries :: ![EntryGetter]
|
, tgEntries :: ![EntryGetter]
|
||||||
}
|
}
|
||||||
deriving (Eq, Generic, Hashable, Show, FromDhall)
|
deriving (Eq, Generic, Hashable, Show, FromDhall)
|
||||||
|
@ -527,270 +523,5 @@ data StatementParser re = StatementParser
|
||||||
|
|
||||||
deriving instance Show (StatementParser T.Text)
|
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
|
instance Show (StatementParser (T.Text, Regex)) where
|
||||||
show = show . fmap fst
|
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 Language.Haskell.TH.Syntax (Dec (..), Q (..), Type (..), mkName)
|
||||||
import RIO
|
import RIO
|
|
@ -1,13 +1,15 @@
|
||||||
module Internal.Utils
|
module Internal.Utils
|
||||||
( compareDate
|
( compareDate
|
||||||
|
, expandDatePat
|
||||||
|
, askDays
|
||||||
, fromWeekday
|
, fromWeekday
|
||||||
, inBounds
|
, inDaySpan
|
||||||
, expandBounds
|
|
||||||
, fmtRational
|
, fmtRational
|
||||||
, matches
|
, matches
|
||||||
, fromGregorian'
|
, fromGregorian'
|
||||||
, resolveBounds
|
, resolveDaySpan
|
||||||
, resolveBounds_
|
, resolveDaySpan_
|
||||||
|
, intersectDaySpan
|
||||||
, liftInner
|
, liftInner
|
||||||
, liftExceptT
|
, liftExceptT
|
||||||
, liftExcept
|
, liftExcept
|
||||||
|
@ -26,15 +28,6 @@ module Internal.Utils
|
||||||
, combineErrorIOM3
|
, combineErrorIOM3
|
||||||
, collectErrorsIO
|
, collectErrorsIO
|
||||||
, mapErrorsIO
|
, mapErrorsIO
|
||||||
-- , leftToMaybe
|
|
||||||
-- , concatEithers2
|
|
||||||
-- , concatEithers3
|
|
||||||
-- , concatEither3
|
|
||||||
-- , concatEither2
|
|
||||||
-- , concatEitherL
|
|
||||||
-- , concatEithersL
|
|
||||||
-- , concatEither2M
|
|
||||||
-- , concatEithers2M
|
|
||||||
, parseRational
|
, parseRational
|
||||||
, showError
|
, showError
|
||||||
, unlessLeft_
|
, unlessLeft_
|
||||||
|
@ -50,13 +43,18 @@ module Internal.Utils
|
||||||
, sndOf3
|
, sndOf3
|
||||||
, thdOf3
|
, thdOf3
|
||||||
, xGregToDay
|
, xGregToDay
|
||||||
-- , plural
|
|
||||||
, compileMatch
|
, compileMatch
|
||||||
, compileOptions
|
, compileOptions
|
||||||
, dateMatches
|
, dateMatches
|
||||||
, valMatches
|
, valMatches
|
||||||
, roundPrecision
|
, roundPrecision
|
||||||
, roundPrecisionCur
|
, roundPrecisionCur
|
||||||
|
, lookupAccountKey
|
||||||
|
, lookupAccountSign
|
||||||
|
, lookupAccountType
|
||||||
|
, lookupCurrencyKey
|
||||||
|
, lookupCurrencyPrec
|
||||||
|
, lookupTag
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
|
@ -65,7 +63,7 @@ import Control.Monad.Except
|
||||||
import Control.Monad.Reader
|
import Control.Monad.Reader
|
||||||
import Data.Time.Format.ISO8601
|
import Data.Time.Format.ISO8601
|
||||||
import GHC.Real
|
import GHC.Real
|
||||||
import Internal.Types
|
import Internal.Types.Main
|
||||||
import RIO
|
import RIO
|
||||||
import qualified RIO.List as L
|
import qualified RIO.List as L
|
||||||
import qualified RIO.Map as M
|
import qualified RIO.Map as M
|
||||||
|
@ -75,6 +73,96 @@ import RIO.Time
|
||||||
import Text.Regex.TDFA
|
import Text.Regex.TDFA
|
||||||
import Text.Regex.TDFA.Text
|
import Text.Regex.TDFA.Text
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
-- intervals
|
||||||
|
|
||||||
|
expandDatePat :: DaySpan -> DatePat -> InsertExcept [Day]
|
||||||
|
expandDatePat b (Cron cp) = expandCronPat b cp
|
||||||
|
expandDatePat i (Mod mp) = return $ expandModPat mp i
|
||||||
|
|
||||||
|
expandModPat :: ModPat -> DaySpan -> [Day]
|
||||||
|
expandModPat ModPat {mpStart = s, mpBy = b, mpUnit = u, mpRepeats = r} bs =
|
||||||
|
takeWhile (<= upper) $
|
||||||
|
(`addFun` start) . (* b')
|
||||||
|
<$> maybe id (take . fromIntegral) r [0 ..]
|
||||||
|
where
|
||||||
|
(lower, upper) = fromDaySpan bs
|
||||||
|
start = maybe lower fromGregorian' s
|
||||||
|
b' = fromIntegral b
|
||||||
|
addFun = case u of
|
||||||
|
Day -> addDays
|
||||||
|
Week -> addDays . (* 7)
|
||||||
|
Month -> addGregorianMonthsClip
|
||||||
|
Year -> addGregorianYearsClip
|
||||||
|
|
||||||
|
expandCronPat :: DaySpan -> CronPat -> InsertExcept [Day]
|
||||||
|
expandCronPat b CronPat {cpYear, cpMonth, cpDay, cpWeekly} =
|
||||||
|
combineError3 yRes mRes dRes $ \ys ms ds ->
|
||||||
|
filter validWeekday $
|
||||||
|
mapMaybe (uncurry3 toDay) $
|
||||||
|
takeWhile (\((y, _), m, d) -> (y, m, d) <= (yb1, mb1, db1)) $
|
||||||
|
dropWhile (\((y, _), m, d) -> (y, m, d) < (yb0, mb0, db0)) $
|
||||||
|
[(y, m, d) | y <- (\y -> (y, isLeapYear y)) <$> ys, m <- ms, d <- ds]
|
||||||
|
where
|
||||||
|
yRes = case cpYear of
|
||||||
|
Nothing -> return [yb0 .. yb1]
|
||||||
|
Just pat -> do
|
||||||
|
ys <- expandMDYPat (fromIntegral yb0) (fromIntegral yb1) pat
|
||||||
|
return $ dropWhile (< yb0) $ fromIntegral <$> ys
|
||||||
|
mRes = expandMD 12 cpMonth
|
||||||
|
dRes = expandMD 31 cpDay
|
||||||
|
(s, e) = fromDaySpan b
|
||||||
|
(yb0, mb0, db0) = toGregorian s
|
||||||
|
(yb1, mb1, db1) = toGregorian $ addDays (-1) e
|
||||||
|
expandMD lim =
|
||||||
|
fmap (fromIntegral <$>)
|
||||||
|
. maybe (return [1 .. lim]) (expandMDYPat 1 lim)
|
||||||
|
expandW (OnDay x) = [fromEnum x]
|
||||||
|
expandW (OnDays xs) = fromEnum <$> xs
|
||||||
|
ws = maybe [] expandW cpWeekly
|
||||||
|
validWeekday = if null ws then const True else \day -> dayToWeekday day `elem` ws
|
||||||
|
toDay (y, leap) m d
|
||||||
|
| m == 2 && (not leap && d > 28 || leap && d > 29) = Nothing
|
||||||
|
| m `elem` [4, 6, 9, 11] && d > 30 = Nothing
|
||||||
|
| otherwise = Just $ fromGregorian y m d
|
||||||
|
|
||||||
|
expandMDYPat :: Natural -> Natural -> MDYPat -> InsertExcept [Natural]
|
||||||
|
expandMDYPat lower upper (Single x) = return [x | lower <= x && x <= upper]
|
||||||
|
expandMDYPat lower upper (Multi xs) = return $ dropWhile (<= lower) $ takeWhile (<= upper) xs
|
||||||
|
expandMDYPat lower upper (After x) = return [max lower x .. upper]
|
||||||
|
expandMDYPat lower upper (Before x) = return [lower .. min upper x]
|
||||||
|
expandMDYPat lower upper (Between x y) = return [max lower x .. min upper y]
|
||||||
|
expandMDYPat lower upper (Repeat RepeatPat {rpStart = s, rpBy = b, rpRepeats = r})
|
||||||
|
| b < 1 = throwError $ InsertException [PatternError s b r ZeroLength]
|
||||||
|
| otherwise = do
|
||||||
|
k <- limit r
|
||||||
|
return $ dropWhile (<= lower) $ takeWhile (<= k) [s + i * b | i <- [0 ..]]
|
||||||
|
where
|
||||||
|
limit Nothing = return upper
|
||||||
|
limit (Just n)
|
||||||
|
-- this guard not only produces the error for the user but also protects
|
||||||
|
-- from an underflow below it
|
||||||
|
| n < 1 = throwError $ InsertException [PatternError s b r ZeroRepeats]
|
||||||
|
| otherwise = return $ min (s + b * (n - 1)) upper
|
||||||
|
|
||||||
|
dayToWeekday :: Day -> Int
|
||||||
|
dayToWeekday (ModifiedJulianDay d) = mod (fromIntegral d + 2) 7
|
||||||
|
|
||||||
|
askDays
|
||||||
|
:: (MonadFinance m, MonadInsertError m)
|
||||||
|
=> DatePat
|
||||||
|
-> Maybe Interval
|
||||||
|
-> m [Day]
|
||||||
|
askDays dp i = do
|
||||||
|
globalSpan <- askDBState kmBudgetInterval
|
||||||
|
case i of
|
||||||
|
Just i' -> do
|
||||||
|
localSpan <- liftExcept $ resolveDaySpan i'
|
||||||
|
maybe (return []) expand $ intersectDaySpan globalSpan localSpan
|
||||||
|
Nothing -> expand globalSpan
|
||||||
|
where
|
||||||
|
expand = liftExcept . (`expandDatePat` dp)
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- dates
|
-- dates
|
||||||
|
|
||||||
|
@ -161,27 +249,42 @@ compareDate (In md offset) x = do
|
||||||
fromGregorian' :: Gregorian -> Day
|
fromGregorian' :: Gregorian -> Day
|
||||||
fromGregorian' = uncurry3 fromGregorian . gregTup
|
fromGregorian' = uncurry3 fromGregorian . gregTup
|
||||||
|
|
||||||
-- TODO misleading name
|
inDaySpan :: DaySpan -> Day -> Bool
|
||||||
inBounds :: (Day, Day) -> Day -> Bool
|
inDaySpan bs = withinDays (fromDaySpan bs)
|
||||||
inBounds (d0, d1) x = d0 <= x && x < d1
|
|
||||||
|
|
||||||
resolveBounds :: Interval -> InsertExcept Bounds
|
withinDays :: (Day, Day) -> Day -> Bool
|
||||||
resolveBounds i@Interval {intStart = s} =
|
withinDays (d0, d1) x = d0 <= x && x < d1
|
||||||
resolveBounds_ (s {gYear = gYear s + 50}) i
|
|
||||||
|
|
||||||
resolveBounds_ :: Gregorian -> Interval -> InsertExcept Bounds
|
resolveDaySpan :: Interval -> InsertExcept DaySpan
|
||||||
resolveBounds_ def Interval {intStart = s, intEnd = e} =
|
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
|
case fromGregorian' <$> e of
|
||||||
Nothing -> return $ toBounds $ fromGregorian' def
|
Nothing -> return $ toDaySpan_ $ fromGregorian' def
|
||||||
Just e_
|
Just e_
|
||||||
| s_ < e_ -> return $ toBounds e_
|
| s_ < e_ -> return $ toDaySpan_ e_
|
||||||
| otherwise -> throwError $ InsertException [BoundsError s e]
|
| otherwise -> throwError $ InsertException [DaySpanError s e]
|
||||||
where
|
where
|
||||||
s_ = fromGregorian' s
|
s_ = fromGregorian' s
|
||||||
toBounds end = (s_, fromIntegral $ diffDays end s_ - 1)
|
toDaySpan_ end = toDaySpan (s_, end)
|
||||||
|
|
||||||
expandBounds :: Bounds -> (Day, Day)
|
fromDaySpan :: DaySpan -> (Day, Day)
|
||||||
expandBounds (d, n) = (d, addDays (fromIntegral n + 1) d)
|
fromDaySpan (d, n) = (d, addDays (fromIntegral n + 1) d)
|
||||||
|
|
||||||
|
-- ASSUME a < b
|
||||||
|
toDaySpan :: (Day, Day) -> DaySpan
|
||||||
|
toDaySpan (a, b) = (a, fromIntegral $ diffDays b a - 1)
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- matching
|
-- matching
|
||||||
|
@ -203,10 +306,10 @@ matches
|
||||||
desc = maybe (return True) (matchMaybe trDesc . snd) spDesc
|
desc = maybe (return True) (matchMaybe trDesc . snd) spDesc
|
||||||
convert (TxGetter cur a ss) = MatchPass <$> toTx cur a ss r
|
convert (TxGetter cur a ss) = MatchPass <$> toTx cur a ss r
|
||||||
|
|
||||||
toTx :: SplitCur -> SplitAcnt -> [EntryGetter] -> TxRecord -> InsertExceptT CurrencyM RawTx
|
toTx :: EntryCur -> EntryAcnt -> [EntryGetter] -> TxRecord -> InsertExceptT CurrencyM RawTx
|
||||||
toTx sc sa toSplits r@TxRecord {trAmount, trDate, trDesc} = do
|
toTx sc sa toEntries r@TxRecord {trAmount, trDate, trDesc} = do
|
||||||
combineError3 acntRes curRes ssRes $ \a c ss ->
|
combineError3 acntRes curRes ssRes $ \a c es ->
|
||||||
let fromSplit =
|
let fromEntry =
|
||||||
Entry
|
Entry
|
||||||
{ eAcnt = a
|
{ eAcnt = a
|
||||||
, eCurrency = c
|
, eCurrency = c
|
||||||
|
@ -217,12 +320,12 @@ toTx sc sa toSplits r@TxRecord {trAmount, trDate, trDesc} = do
|
||||||
in Tx
|
in Tx
|
||||||
{ txDate = trDate
|
{ txDate = trDate
|
||||||
, txDescr = trDesc
|
, txDescr = trDesc
|
||||||
, txSplits = fromSplit : ss
|
, txEntries = fromEntry : es
|
||||||
}
|
}
|
||||||
where
|
where
|
||||||
acntRes = liftInner $ resolveAcnt r sa
|
acntRes = liftInner $ resolveAcnt r sa
|
||||||
curRes = liftInner $ resolveCurrency r sc
|
curRes = liftInner $ resolveCurrency r sc
|
||||||
ssRes = combineErrors $ fmap (resolveEntry r) toSplits
|
ssRes = combineErrors $ fmap (resolveEntry r) toEntries
|
||||||
|
|
||||||
valMatches :: ValMatcher -> Rational -> InsertExcept Bool
|
valMatches :: ValMatcher -> Rational -> InsertExcept Bool
|
||||||
valMatches ValMatcher {vmDen, vmSign, vmNum, vmPrec} x
|
valMatches ValMatcher {vmDen, vmSign, vmNum, vmPrec} x
|
||||||
|
@ -248,7 +351,7 @@ otherMatches dict m = case m of
|
||||||
where
|
where
|
||||||
lookup_ t n = lookupErr (MatchField t) n dict
|
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
|
resolveEntry r s@Entry {eAcnt, eValue, eCurrency} = do
|
||||||
m <- ask
|
m <- ask
|
||||||
liftInner $ combineErrorM3 acntRes curRes valRes $ \a c v -> do
|
liftInner $ combineErrorM3 acntRes curRes valRes $ \a c v -> do
|
||||||
|
@ -344,18 +447,18 @@ collectErrorsIO = mapErrorsIO id
|
||||||
|
|
||||||
resolveValue :: TxRecord -> EntryNumGetter -> InsertExcept Double
|
resolveValue :: TxRecord -> EntryNumGetter -> InsertExcept Double
|
||||||
resolveValue TxRecord {trOther, trAmount} s = case s of
|
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
|
(ConstN c) -> return c
|
||||||
AmountN m -> return $ (* m) $ fromRational trAmount
|
AmountN m -> return $ (* m) $ fromRational trAmount
|
||||||
|
|
||||||
resolveAcnt :: TxRecord -> SplitAcnt -> InsertExcept T.Text
|
resolveAcnt :: TxRecord -> EntryAcnt -> InsertExcept T.Text
|
||||||
resolveAcnt = resolveSplitField AcntField
|
resolveAcnt = resolveEntryField AcntField
|
||||||
|
|
||||||
resolveCurrency :: TxRecord -> SplitCur -> InsertExcept T.Text
|
resolveCurrency :: TxRecord -> EntryCur -> InsertExcept T.Text
|
||||||
resolveCurrency = resolveSplitField CurField
|
resolveCurrency = resolveEntryField CurField
|
||||||
|
|
||||||
resolveSplitField :: SplitIDType -> TxRecord -> SplitAcnt -> InsertExcept T.Text
|
resolveEntryField :: EntryIDType -> TxRecord -> EntryAcnt -> InsertExcept T.Text
|
||||||
resolveSplitField t TxRecord {trOther = o} s = case s of
|
resolveEntryField t TxRecord {trOther = o} s = case s of
|
||||||
ConstT p -> return p
|
ConstT p -> return p
|
||||||
LookupT f -> lookup_ f o
|
LookupT f -> lookup_ f o
|
||||||
MapT (Field f m) -> do
|
MapT (Field f m) -> do
|
||||||
|
@ -366,7 +469,7 @@ resolveSplitField t TxRecord {trOther = o} s = case s of
|
||||||
lookup_ (k1, k2) m
|
lookup_ (k1, k2) m
|
||||||
where
|
where
|
||||||
lookup_ :: (Ord k, Show k) => k -> M.Map k v -> InsertExcept v
|
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 :: (Ord k, Show k) => LookupSuberr -> k -> M.Map k v -> InsertExcept v
|
||||||
lookupErr what k m = case M.lookup k m of
|
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 :: InsertError -> [T.Text]
|
||||||
showError other = case other of
|
showError other = case other of
|
||||||
(StatementError ts ms) -> (showTx <$> ts) ++ (showMatch <$> ms)
|
(StatementError ts ms) -> (showTx <$> ts) ++ (showMatch <$> ms)
|
||||||
(BoundsError a b) ->
|
(DaySpanError a b) ->
|
||||||
[T.unwords ["Could not create bounds from", showGregorian_ a, "and", showGreg b]]
|
[T.unwords ["Could not create bounds from", showGregorian_ a, "and", showGreg b]]
|
||||||
where
|
where
|
||||||
showGreg (Just g) = showGregorian_ g
|
showGreg (Just g) = showGregorian_ g
|
||||||
|
@ -493,8 +596,8 @@ showError other = case other of
|
||||||
[T.unwords ["Could not find field", f, "when resolving", what]]
|
[T.unwords ["Could not find field", f, "when resolving", what]]
|
||||||
where
|
where
|
||||||
what = case t of
|
what = case t of
|
||||||
SplitIDField st -> T.unwords ["split", idName st, "ID"]
|
EntryIDField st -> T.unwords ["entry", idName st, "ID"]
|
||||||
SplitValField -> "split value"
|
EntryValField -> "entry value"
|
||||||
MatchField mt -> T.unwords [matchName mt, "match"]
|
MatchField mt -> T.unwords [matchName mt, "match"]
|
||||||
DBKey st -> T.unwords ["database", idName st, "ID key"]
|
DBKey st -> T.unwords ["database", idName st, "ID key"]
|
||||||
-- TODO this should be its own function
|
-- TODO this should be its own function
|
||||||
|
@ -526,15 +629,15 @@ showError other = case other of
|
||||||
[ msg
|
[ msg
|
||||||
, "for currency"
|
, "for currency"
|
||||||
, singleQuote cur
|
, singleQuote cur
|
||||||
, "and for splits"
|
, "and for entries"
|
||||||
, splits
|
, entries
|
||||||
]
|
]
|
||||||
]
|
]
|
||||||
where
|
where
|
||||||
msg = case t of
|
msg = case t of
|
||||||
TooFewSplits -> "Need at least two splits to balance"
|
TooFewEntries -> "Need at least two entries to balance"
|
||||||
NotOneBlank -> "Exactly one split must be blank"
|
NotOneBlank -> "Exactly one entries must be blank"
|
||||||
splits = T.intercalate ", " $ fmap (singleQuote . showSplit) rss
|
entries = T.intercalate ", " $ fmap (singleQuote . showEntry) rss
|
||||||
|
|
||||||
showGregorian_ :: Gregorian -> T.Text
|
showGregorian_ :: Gregorian -> T.Text
|
||||||
showGregorian_ Gregorian {gYear, gMonth, gDay} = T.intercalate "-" $ showT <$> [gYear, gMonth, gDay]
|
showGregorian_ Gregorian {gYear, gMonth, gDay} = T.intercalate "-" $ showT <$> [gYear, gMonth, gDay]
|
||||||
|
@ -622,8 +725,8 @@ showMatchOther (Val (Field f mv)) =
|
||||||
, singleQuote $ fromMaybe "*" $ showValMatcher mv
|
, singleQuote $ fromMaybe "*" $ showValMatcher mv
|
||||||
]
|
]
|
||||||
|
|
||||||
showSplit :: RawSplit -> T.Text
|
showEntry :: RawEntry -> T.Text
|
||||||
showSplit Entry {eAcnt, eValue, eComment} =
|
showEntry Entry {eAcnt, eValue, eComment} =
|
||||||
keyVals
|
keyVals
|
||||||
[ ("account", eAcnt)
|
[ ("account", eAcnt)
|
||||||
, ("value", T.pack $ show ((fromRational <$> eValue) :: Maybe Float))
|
, ("value", T.pack $ show ((fromRational <$> eValue) :: Maybe Float))
|
||||||
|
@ -791,3 +894,35 @@ matchGroupsMaybe q re = case regexec re q of
|
||||||
Right (Just (_, _, _, xs)) -> xs
|
Right (Just (_, _, _, xs)) -> xs
|
||||||
-- this should never fail as regexec always returns Right
|
-- this should never fail as regexec always returns Right
|
||||||
Left _ -> []
|
Left _ -> []
|
||||||
|
|
||||||
|
lookupAccount :: (MonadInsertError m, MonadFinance m) => AcntID -> m (AccountRId, AcntSign, AcntType)
|
||||||
|
lookupAccount = lookupFinance AcntField kmAccount
|
||||||
|
|
||||||
|
lookupAccountKey :: (MonadInsertError m, MonadFinance m) => AcntID -> m AccountRId
|
||||||
|
lookupAccountKey = fmap fstOf3 . lookupAccount
|
||||||
|
|
||||||
|
lookupAccountSign :: (MonadInsertError m, MonadFinance m) => AcntID -> m AcntSign
|
||||||
|
lookupAccountSign = fmap sndOf3 . lookupAccount
|
||||||
|
|
||||||
|
lookupAccountType :: (MonadInsertError m, MonadFinance m) => AcntID -> m AcntType
|
||||||
|
lookupAccountType = fmap thdOf3 . lookupAccount
|
||||||
|
|
||||||
|
lookupCurrency :: (MonadInsertError m, MonadFinance m) => T.Text -> m (CurrencyRId, Natural)
|
||||||
|
lookupCurrency = lookupFinance CurField kmCurrency
|
||||||
|
|
||||||
|
lookupCurrencyKey :: (MonadInsertError m, MonadFinance m) => AcntID -> m CurrencyRId
|
||||||
|
lookupCurrencyKey = fmap fst . lookupCurrency
|
||||||
|
|
||||||
|
lookupCurrencyPrec :: (MonadInsertError m, MonadFinance m) => AcntID -> m Natural
|
||||||
|
lookupCurrencyPrec = fmap snd . lookupCurrency
|
||||||
|
|
||||||
|
lookupTag :: (MonadInsertError m, MonadFinance m) => TagID -> m TagRId
|
||||||
|
lookupTag = lookupFinance TagField kmTag
|
||||||
|
|
||||||
|
lookupFinance
|
||||||
|
:: (MonadInsertError m, MonadFinance m)
|
||||||
|
=> 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