WIP track running balances in budget
This commit is contained in:
parent
88dec70ce6
commit
e6a39cb5ea
13
app/Main.hs
13
app/Main.hs
|
|
@ -1,7 +1,8 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ImplicitPrelude #-}
|
||||
|
||||
module Main (main) where
|
||||
|
||||
import Control.Monad.Reader
|
||||
import qualified Data.Text.IO as TI
|
||||
import Internal.Config
|
||||
import Internal.Database.Ops
|
||||
|
|
@ -162,11 +163,11 @@ runSync c = do
|
|||
case res of
|
||||
Left es -> throwIO $ InsertException es
|
||||
Right s -> do
|
||||
flip runReaderT (s $ takeDirectory c) $ do
|
||||
es1 <- concat <$> mapM insertBudget (budget config)
|
||||
es2 <- insertStatements config
|
||||
let es = es1 ++ es2
|
||||
unless (null es) $ throwIO $ InsertException es
|
||||
let run = mapReaderT $ flip runReaderT (s $ takeDirectory c)
|
||||
es1 <- concat <$> mapM (run . insertBudget) (budget config)
|
||||
es2 <- run $ insertStatements config
|
||||
let es = es1 ++ es2
|
||||
unless (null es) $ throwIO $ InsertException es
|
||||
where
|
||||
err (InsertException es) = do
|
||||
liftIO $ mapM_ TI.putStrLn $ concatMap showError es
|
||||
|
|
|
|||
76
budget.cabal
76
budget.cabal
|
|
@ -1,6 +1,6 @@
|
|||
cabal-version: 1.12
|
||||
|
||||
-- This file has been generated from package.yaml by hpack version 0.35.1.
|
||||
-- This file has been generated from package.yaml by hpack version 0.35.2.
|
||||
--
|
||||
-- see: https://github.com/sol/hpack
|
||||
|
||||
|
|
@ -36,6 +36,42 @@ library
|
|||
Paths_budget
|
||||
hs-source-dirs:
|
||||
lib/
|
||||
default-extensions:
|
||||
OverloadedStrings
|
||||
FlexibleContexts
|
||||
FlexibleInstances
|
||||
InstanceSigs
|
||||
MultiParamTypeClasses
|
||||
EmptyCase
|
||||
LambdaCase
|
||||
MultiWayIf
|
||||
NamedFieldPuns
|
||||
TupleSections
|
||||
DeriveFoldable
|
||||
DeriveFunctor
|
||||
DeriveGeneric
|
||||
DeriveLift
|
||||
DeriveTraversable
|
||||
DerivingStrategies
|
||||
DeriveDataTypeable
|
||||
EmptyDataDecls
|
||||
PartialTypeSignatures
|
||||
GeneralizedNewtypeDeriving
|
||||
StandaloneDeriving
|
||||
BangPatterns
|
||||
TypeOperators
|
||||
ScopedTypeVariables
|
||||
TypeApplications
|
||||
ConstraintKinds
|
||||
RankNTypes
|
||||
GADTs
|
||||
DefaultSignatures
|
||||
NoImplicitPrelude
|
||||
FunctionalDependencies
|
||||
DataKinds
|
||||
TypeFamilies
|
||||
BinaryLiterals
|
||||
ViewPatterns
|
||||
ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wpartial-fields -Werror -O2
|
||||
build-depends:
|
||||
base >=4.12 && <10
|
||||
|
|
@ -50,6 +86,7 @@ library
|
|||
, hashable
|
||||
, lens >=5.0.1
|
||||
, monad-logger >=0.3.36
|
||||
, mtl
|
||||
, optparse-applicative
|
||||
, persistent >=2.13.3.1
|
||||
, persistent-sqlite >=2.13.1.0
|
||||
|
|
@ -67,6 +104,42 @@ executable pwncash
|
|||
Paths_budget
|
||||
hs-source-dirs:
|
||||
app
|
||||
default-extensions:
|
||||
OverloadedStrings
|
||||
FlexibleContexts
|
||||
FlexibleInstances
|
||||
InstanceSigs
|
||||
MultiParamTypeClasses
|
||||
EmptyCase
|
||||
LambdaCase
|
||||
MultiWayIf
|
||||
NamedFieldPuns
|
||||
TupleSections
|
||||
DeriveFoldable
|
||||
DeriveFunctor
|
||||
DeriveGeneric
|
||||
DeriveLift
|
||||
DeriveTraversable
|
||||
DerivingStrategies
|
||||
DeriveDataTypeable
|
||||
EmptyDataDecls
|
||||
PartialTypeSignatures
|
||||
GeneralizedNewtypeDeriving
|
||||
StandaloneDeriving
|
||||
BangPatterns
|
||||
TypeOperators
|
||||
ScopedTypeVariables
|
||||
TypeApplications
|
||||
ConstraintKinds
|
||||
RankNTypes
|
||||
GADTs
|
||||
DefaultSignatures
|
||||
NoImplicitPrelude
|
||||
FunctionalDependencies
|
||||
DataKinds
|
||||
TypeFamilies
|
||||
BinaryLiterals
|
||||
ViewPatterns
|
||||
ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wpartial-fields -Werror -O2 -threaded
|
||||
build-depends:
|
||||
base >=4.12 && <10
|
||||
|
|
@ -82,6 +155,7 @@ executable pwncash
|
|||
, hashable
|
||||
, lens >=5.0.1
|
||||
, monad-logger >=0.3.36
|
||||
, mtl
|
||||
, optparse-applicative
|
||||
, persistent >=2.13.3.1
|
||||
, persistent-sqlite >=2.13.1.0
|
||||
|
|
|
|||
|
|
@ -187,7 +187,9 @@ let IncomeBucket = < PreTax | IntraTax | PostTax >
|
|||
|
||||
let Amount = { amtValue : Decimal, amtDesc : Text }
|
||||
|
||||
let TimeAmount = { taWhen : DatePat, taAmt : Amount }
|
||||
let AmountType = < FixedAmt | Percent | Target >
|
||||
|
||||
let TimeAmount = { taWhen : DatePat, taAmt : Amount, taAmtType : AmountType }
|
||||
|
||||
let Tax = { taxAcnt : AcntID, taxValue : Decimal }
|
||||
|
||||
|
|
@ -264,4 +266,5 @@ in { CurID
|
|||
, Allocation
|
||||
, Amount
|
||||
, TimeAmount
|
||||
, AmountType
|
||||
}
|
||||
|
|
|
|||
|
|
@ -1,5 +1,3 @@
|
|||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
|
||||
module Internal.Config
|
||||
( readConfig
|
||||
-- , readYaml
|
||||
|
|
|
|||
|
|
@ -1,20 +1,6 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE EmptyDataDecls #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
|
||||
module Internal.Database.Model where
|
||||
|
||||
|
|
@ -84,13 +70,42 @@ data DBState = DBState
|
|||
, kmStatementInterval :: !Bounds
|
||||
, kmNewCommits :: ![Int]
|
||||
, kmConfigDir :: !FilePath
|
||||
, kmBoundsCache :: !(MVar (M.Map (Bounds, DatePat) [Day]))
|
||||
}
|
||||
|
||||
type MappingT m a = ReaderT DBState (SqlPersistT m) a
|
||||
type MappingT m = ReaderT DBState (SqlPersistT m)
|
||||
|
||||
type KeySplit = Split AccountRId Rational CurrencyRId
|
||||
|
||||
type KeyTx = Tx KeySplit
|
||||
|
||||
type TreeR = Tree ([T.Text], AccountRId)
|
||||
|
||||
type Balances = M.Map AccountRId Rational
|
||||
|
||||
type BalanceM m = ReaderT (MVar Balances) m
|
||||
|
||||
class MonadUnliftIO m => MonadFinance m where
|
||||
askDBState :: (DBState -> a) -> m a
|
||||
|
||||
instance MonadUnliftIO m => MonadFinance (ReaderT DBState m) where
|
||||
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
|
||||
|
|
|
|||
|
|
@ -1,11 +1,3 @@
|
|||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
|
||||
module Internal.Database.Ops
|
||||
( migrate_
|
||||
, nukeTables
|
||||
|
|
@ -48,6 +40,7 @@ migrate_ c more =
|
|||
(openConnection c)
|
||||
( \backend ->
|
||||
flip runSqlConn backend $ do
|
||||
_ <- askLoggerIO
|
||||
runMigration migrateAll
|
||||
more
|
||||
)
|
||||
|
|
@ -198,7 +191,8 @@ updateCurrencies cs = do
|
|||
return $ currencyMap curs
|
||||
|
||||
currency2Record :: Currency -> Entity CurrencyR
|
||||
currency2Record c@Currency {..} = Entity (toKey c) $ CurrencyR curSymbol curFullname
|
||||
currency2Record c@Currency {curSymbol, curFullname} =
|
||||
Entity (toKey c) $ CurrencyR curSymbol curFullname
|
||||
|
||||
currencyMap :: [Entity CurrencyR] -> CurrencyMap
|
||||
currencyMap = M.fromList . fmap (\e -> (currencyRSymbol $ entityVal e, entityKey e))
|
||||
|
|
@ -291,7 +285,7 @@ xs !? n
|
|||
n
|
||||
|
||||
flattenAcntRoot :: AccountRoot -> [(AcntType, AccountTree)]
|
||||
flattenAcntRoot AccountRoot_ {..} =
|
||||
flattenAcntRoot AccountRoot_ {arIncome, arExpenses, arLiabilities, arAssets, arEquity} =
|
||||
((IncomeT,) <$> arIncome)
|
||||
++ ((ExpenseT,) <$> arExpenses)
|
||||
++ ((LiabilityT,) <$> arLiabilities)
|
||||
|
|
@ -315,7 +309,6 @@ getDBState c = do
|
|||
am <- updateAccounts $ accounts c
|
||||
cm <- updateCurrencies $ currencies c
|
||||
hs <- updateHashes c
|
||||
v <- newMVar M.empty
|
||||
-- TODO not sure how I feel about this, probably will change this struct alot
|
||||
-- in the future so whatever...for now
|
||||
return $ concatEither2 bi si $ \b s f ->
|
||||
|
|
@ -326,7 +319,6 @@ getDBState c = do
|
|||
, kmStatementInterval = s
|
||||
, kmNewCommits = hs
|
||||
, kmConfigDir = f
|
||||
, kmBoundsCache = v
|
||||
}
|
||||
where
|
||||
bi = resolveBounds $ budgetInterval $ global c
|
||||
|
|
|
|||
|
|
@ -1,8 +1,3 @@
|
|||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
|
||||
module Internal.Insert
|
||||
( insertStatements
|
||||
, insertBudget
|
||||
|
|
@ -17,6 +12,8 @@ import Internal.Statement
|
|||
import Internal.Types hiding (sign)
|
||||
import Internal.Utils
|
||||
import RIO hiding (to)
|
||||
import qualified RIO.List as L
|
||||
import qualified RIO.Map as M
|
||||
import qualified RIO.Text as T
|
||||
import RIO.Time
|
||||
|
||||
|
|
@ -43,12 +40,13 @@ expandModPat ModPat {mpStart = s, mpBy = b, mpUnit = u, mpRepeats = r} bs =
|
|||
Year -> addGregorianYearsClip
|
||||
|
||||
expandCronPat :: Bounds -> CronPat -> EitherErrs [Day]
|
||||
expandCronPat b CronPat {..} = concatEither3 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]
|
||||
expandCronPat b CronPat {cronYear, cronMonth, cronDay, cronWeekly} =
|
||||
concatEither3 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 cronYear of
|
||||
Nothing -> return [yb0 .. yb1]
|
||||
|
|
@ -95,36 +93,36 @@ dayToWeekday :: Day -> Int
|
|||
dayToWeekday (ModifiedJulianDay d) = mod (fromIntegral d + 2) 7
|
||||
|
||||
withDates
|
||||
:: MonadUnliftIO m
|
||||
:: MonadFinance m
|
||||
=> DatePat
|
||||
-> (Day -> MappingT m a)
|
||||
-> MappingT m (EitherErrs [a])
|
||||
-> (Day -> SqlPersistT m a)
|
||||
-> SqlPersistT m (EitherErrs [a])
|
||||
withDates dp f = do
|
||||
bounds <- asks kmBudgetInterval
|
||||
bounds <- lift $ askDBState kmBudgetInterval
|
||||
let days = expandDatePat bounds dp
|
||||
mapM (mapM f) days
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- budget
|
||||
|
||||
insertBudget :: MonadUnliftIO m => Budget -> MappingT m [InsertError]
|
||||
insertBudget :: MonadFinance m => Budget -> SqlPersistT m [InsertError]
|
||||
insertBudget Budget {budgetLabel = name, income = is, transfers = es} = do
|
||||
es1 <- mapM (insertIncome name) is
|
||||
es2 <- mapM (insertTransfer name) es
|
||||
return $ concat $ es1 ++ es2
|
||||
es2 <- insertTransfers name es
|
||||
return $ concat es1 ++ es2
|
||||
|
||||
-- TODO this hashes twice (not that it really matters)
|
||||
whenHash
|
||||
:: (Hashable a, MonadUnliftIO m)
|
||||
:: (Hashable a, MonadFinance m)
|
||||
=> ConfigType
|
||||
-> a
|
||||
-> b
|
||||
-> (Key CommitR -> MappingT m b)
|
||||
-> MappingT m b
|
||||
-> (Key CommitR -> SqlPersistT m b)
|
||||
-> SqlPersistT m b
|
||||
whenHash t o def f = do
|
||||
let h = hash o
|
||||
hs <- asks kmNewCommits
|
||||
if h `elem` hs then f =<< lift (insert $ CommitR h t) else return def
|
||||
hs <- lift $ askDBState kmNewCommits
|
||||
if h `elem` hs then f =<< insert (CommitR h t) else return def
|
||||
|
||||
-- TODO allow currency conversions here
|
||||
data BudgetSplit b = BudgetSplit
|
||||
|
|
@ -147,26 +145,28 @@ data BudgetTx = BudgetTx
|
|||
, btDesc :: !T.Text
|
||||
}
|
||||
|
||||
insertIncome :: MonadUnliftIO m => T.Text -> Income -> MappingT m [InsertError]
|
||||
insertIncome name i@Income {..} =
|
||||
whenHash CTIncome i [] $ \c ->
|
||||
unlessLeft (balanceIncome i) $ \balance -> do
|
||||
res <- withDates incWhen $ \day -> do
|
||||
let meta = BudgetMeta c day incCurrency name
|
||||
let fromAllos b = concatMap (fromAllo meta incFrom (Just b))
|
||||
let pre = fromAllos PreTax incPretax
|
||||
let tax = fmap (fromTax meta incFrom) incTaxes
|
||||
let post = fromAllos PostTax incPosttax
|
||||
let bal =
|
||||
BudgetTx
|
||||
{ btMeta = meta
|
||||
, btFrom = BudgetSplit incFrom $ Just PostTax
|
||||
, btTo = BudgetSplit incToBal Nothing
|
||||
, btValue = balance
|
||||
, btDesc = "balance after deductions"
|
||||
}
|
||||
fmap concat $ mapM insertBudgetTx $ bal : (pre ++ tax ++ post)
|
||||
unlessLefts res $ return . concat
|
||||
insertIncome :: MonadFinance m => T.Text -> Income -> SqlPersistT m [InsertError]
|
||||
insertIncome
|
||||
name
|
||||
i@Income {incWhen, incCurrency, incFrom, incPretax, incPosttax, incTaxes, incToBal} =
|
||||
whenHash CTIncome i [] $ \c ->
|
||||
unlessLeft (balanceIncome i) $ \balance -> do
|
||||
res <- withDates incWhen $ \day -> do
|
||||
let meta = BudgetMeta c day incCurrency name
|
||||
let fromAllos b = concatMap (fromAllo meta incFrom (Just b))
|
||||
let pre = fromAllos PreTax incPretax
|
||||
let tax = fmap (fromTax meta incFrom) incTaxes
|
||||
let post = fromAllos PostTax incPosttax
|
||||
let bal =
|
||||
BudgetTx
|
||||
{ btMeta = meta
|
||||
, btFrom = BudgetSplit incFrom $ Just PostTax
|
||||
, btTo = BudgetSplit incToBal Nothing
|
||||
, btValue = balance
|
||||
, btDesc = "balance after deductions"
|
||||
}
|
||||
fmap concat $ mapM insertBudgetTx $ bal : (pre ++ tax ++ post)
|
||||
unlessLefts res $ return . concat
|
||||
|
||||
fromAllo
|
||||
:: BudgetMeta
|
||||
|
|
@ -174,7 +174,8 @@ fromAllo
|
|||
-> Maybe IncomeBucket
|
||||
-> Allocation
|
||||
-> [BudgetTx]
|
||||
fromAllo meta from ib Allocation {..} = fmap (toBT alloPath) alloAmts
|
||||
fromAllo meta from ib Allocation {alloPath, alloAmts, alloBucket} =
|
||||
fmap (toBT alloPath) alloAmts
|
||||
where
|
||||
toBT to (Amount desc v) =
|
||||
BudgetTx
|
||||
|
|
@ -215,33 +216,98 @@ sumAllocation = sum . fmap (dec2Rat . amtValue) . alloAmts
|
|||
sumTaxes :: [Tax] -> Rational
|
||||
sumTaxes = sum . fmap (dec2Rat . taxValue)
|
||||
|
||||
insertTransfer :: MonadUnliftIO m => T.Text -> Transfer -> MappingT m [InsertError]
|
||||
insertTransfer name t@Transfer {..} =
|
||||
fmap concat $ whenHash CTExpense t [] $ \key -> do
|
||||
forM transAmounts $ \(TimeAmount amt pat) -> do
|
||||
res <- withDates pat $ \day -> insertBudgetTx $ budgetTx amt day key
|
||||
unlessLefts res $ return . concat
|
||||
where
|
||||
meta d c =
|
||||
BudgetMeta
|
||||
{ bmWhen = d
|
||||
, bmCur = transCurrency
|
||||
, bmCommit = c
|
||||
, bmName = name
|
||||
}
|
||||
budgetTx (Amount desc v) d c =
|
||||
BudgetTx
|
||||
{ btMeta = meta d c
|
||||
, btFrom = BudgetSplit transFrom Nothing
|
||||
, btTo = BudgetSplit transTo Nothing
|
||||
, btValue = dec2Rat v
|
||||
, btDesc = desc
|
||||
}
|
||||
insertTransfers :: MonadFinance m => T.Text -> [Transfer] -> SqlPersistT m [InsertError]
|
||||
insertTransfers name ts = do
|
||||
res <- expandTransfers name ts
|
||||
unlessLefts res $ \txs ->
|
||||
fmap concat <$> mapM insertBudgetTx $ balanceTransfers txs
|
||||
|
||||
insertBudgetTx :: MonadUnliftIO m => BudgetTx -> MappingT m [InsertError]
|
||||
insertBudgetTx BudgetTx {..} = do
|
||||
expandTransfers :: MonadFinance m => T.Text -> [Transfer] -> SqlPersistT m (EitherErrs [TransferTx])
|
||||
expandTransfers name ts = do
|
||||
txs <- mapM (expandTransfer name) ts
|
||||
return $ L.sortOn (bmWhen . trxMeta) . concat <$> concatEithersL txs
|
||||
|
||||
-- TODO the entire budget needs to have this process applied to it
|
||||
balanceTransfers :: [TransferTx] -> [BudgetTx]
|
||||
balanceTransfers ts = snd $ L.mapAccumR go initBals $ L.sortOn (bmWhen . trxMeta) ts
|
||||
where
|
||||
initBals = M.fromList $ fmap (,0) $ L.nub $ (fmap trxTo ts ++ fmap trxTo ts)
|
||||
updateBal x = M.update (Just . (+ x))
|
||||
lookupBal = M.findWithDefault (error "this should not happen")
|
||||
go bals TransferTx {trxMeta, trxFrom, trxTo, trxValue, trxType, trxDesc} =
|
||||
let bal = lookupBal trxTo bals
|
||||
x = amtToMove bal trxType trxValue
|
||||
t =
|
||||
BudgetTx
|
||||
{ btMeta = trxMeta
|
||||
, btFrom = BudgetSplit trxFrom Nothing
|
||||
, btTo = BudgetSplit trxTo Nothing
|
||||
, btValue = x
|
||||
, btDesc = trxDesc
|
||||
}
|
||||
in (updateBal x trxFrom $ updateBal (-x) trxFrom bals, t)
|
||||
-- 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 _ FixedAmt x = x
|
||||
amtToMove bal Percent x = -(x / 100 * bal)
|
||||
amtToMove bal Target x = x - bal
|
||||
|
||||
expandTransfer :: MonadFinance m => T.Text -> Transfer -> SqlPersistT m (EitherErrs [TransferTx])
|
||||
expandTransfer name t@Transfer {transAmounts, transTo, transCurrency, transFrom} =
|
||||
whenHash CTExpense t (Right []) $ \key -> do
|
||||
res <- forM transAmounts $ \(TimeAmount (Amount desc v) atype pat) ->
|
||||
withDates pat $ \day ->
|
||||
let meta =
|
||||
BudgetMeta
|
||||
{ bmWhen = day
|
||||
, bmCur = transCurrency
|
||||
, bmCommit = key
|
||||
, bmName = name
|
||||
}
|
||||
in return $
|
||||
TransferTx
|
||||
{ trxMeta = meta
|
||||
, trxFrom = transFrom
|
||||
, trxTo = transTo
|
||||
, trxValue = dec2Rat v
|
||||
, trxType = atype
|
||||
, trxDesc = desc
|
||||
}
|
||||
return $ concat <$> concatEithersL res
|
||||
|
||||
data TransferTx = TransferTx
|
||||
{ trxMeta :: !BudgetMeta
|
||||
, trxFrom :: !AcntID
|
||||
, trxTo :: !AcntID
|
||||
, trxValue :: !Rational
|
||||
, trxType :: AmountType
|
||||
, trxDesc :: !T.Text
|
||||
}
|
||||
|
||||
-- amountBalance
|
||||
-- :: (MonadFinance m, MonadBalance m)
|
||||
-- => AmountType
|
||||
-- -> AcntID
|
||||
-- -> Rational
|
||||
-- -> SqlPersistT m (EitherErr Rational)
|
||||
-- amountBalance at i v = do
|
||||
-- res <- lookupAccountKey i
|
||||
-- case res of
|
||||
-- Left e -> return $ Left e
|
||||
-- Right k -> do
|
||||
-- b <- lookupBalance k
|
||||
-- return $ Right $ case at of
|
||||
-- FixedAmt -> v
|
||||
-- -- TODO what is the sign for this?
|
||||
-- Percent -> v / 100 * b
|
||||
-- -- TODO what is the sign for this?
|
||||
-- Target -> b - v
|
||||
|
||||
insertBudgetTx :: MonadFinance m => BudgetTx -> SqlPersistT m [InsertError]
|
||||
insertBudgetTx BudgetTx {btFrom, btTo, btMeta, btValue, btDesc} = do
|
||||
res <- splitPair (bsAcnt btFrom) (bsAcnt btTo) (bmCur btMeta) btValue
|
||||
unlessLefts_ res $ \(sFrom, sTo) -> lift $ do
|
||||
unlessLefts_ res $ \(sFrom, sTo) -> do
|
||||
k <- insert $ TransactionR (bmCommit btMeta) (bmWhen btMeta) btDesc
|
||||
insertBudgetLabel name k IncomeBucketR sFrom btFrom
|
||||
insertBudgetLabel name k ExpenseBucketR sTo btTo
|
||||
|
|
@ -262,12 +328,12 @@ insertBudgetLabel name k bucketType split bs = do
|
|||
forM_ (bsBucket bs) $ insert_ . bucketType bk
|
||||
|
||||
splitPair
|
||||
:: MonadUnliftIO m
|
||||
:: MonadFinance m
|
||||
=> AcntID
|
||||
-> AcntID
|
||||
-> CurID
|
||||
-> Rational
|
||||
-> MappingT m (EitherErrs (KeySplit, KeySplit))
|
||||
-> SqlPersistT m (EitherErrs (KeySplit, KeySplit))
|
||||
splitPair from to cur val = do
|
||||
s1 <- split from (-val)
|
||||
s2 <- split to val
|
||||
|
|
@ -285,14 +351,14 @@ splitPair from to cur val = do
|
|||
--------------------------------------------------------------------------------
|
||||
-- statements
|
||||
|
||||
insertStatements :: MonadUnliftIO m => Config -> MappingT m [InsertError]
|
||||
insertStatements :: MonadFinance m => Config -> SqlPersistT m [InsertError]
|
||||
insertStatements conf = concat <$> mapM insertStatement (statements conf)
|
||||
|
||||
insertStatement :: MonadUnliftIO m => Statement -> MappingT m [InsertError]
|
||||
insertStatement :: MonadFinance m => Statement -> SqlPersistT m [InsertError]
|
||||
insertStatement (StmtManual m) = insertManual m
|
||||
insertStatement (StmtImport i) = insertImport i
|
||||
|
||||
insertManual :: MonadUnliftIO m => Manual -> MappingT m [InsertError]
|
||||
insertManual :: MonadFinance m => Manual -> SqlPersistT m [InsertError]
|
||||
insertManual
|
||||
m@Manual
|
||||
{ manualDate = dp
|
||||
|
|
@ -303,23 +369,23 @@ insertManual
|
|||
, manualDesc = e
|
||||
} = do
|
||||
whenHash CTManual m [] $ \c -> do
|
||||
bounds <- asks kmStatementInterval
|
||||
bounds <- lift $ askDBState kmStatementInterval
|
||||
-- let days = expandDatePat bounds dp
|
||||
let dayRes = expandDatePat bounds dp
|
||||
unlessLefts dayRes $ \days -> do
|
||||
txRes <- mapM tx days
|
||||
unlessLefts_ (concatEithersL txRes) $ lift . mapM_ (insertTx c)
|
||||
unlessLefts_ (concatEithersL txRes) $ mapM_ (insertTx c)
|
||||
where
|
||||
tx day = txPair day from to u (dec2Rat v) e
|
||||
|
||||
insertImport :: MonadUnliftIO m => Import -> MappingT m [InsertError]
|
||||
insertImport :: MonadFinance m => Import -> SqlPersistT m [InsertError]
|
||||
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
|
||||
recoverIO (readImport i) $ \r -> unlessLefts r $ \bs -> do
|
||||
bounds <- expandBounds <$> asks kmStatementInterval
|
||||
recoverIO (lift $ readImport i) $ \r -> unlessLefts r $ \bs -> do
|
||||
bounds <- expandBounds <$> lift (askDBState kmStatementInterval)
|
||||
res <- mapM resolveTx $ filter (inBounds bounds . txDate) bs
|
||||
unlessLefts_ (concatEithersL res) $ lift . mapM_ (insertTx c)
|
||||
unlessLefts_ (concatEithersL res) $ mapM_ (insertTx c)
|
||||
where
|
||||
recoverIO x rest = do
|
||||
res <- tryIO x
|
||||
|
|
@ -333,14 +399,14 @@ insertImport i = whenHash CTImport i [] $ \c -> do
|
|||
-- low-level transaction stuff
|
||||
|
||||
txPair
|
||||
:: MonadUnliftIO m
|
||||
:: MonadFinance m
|
||||
=> Day
|
||||
-> AcntID
|
||||
-> AcntID
|
||||
-> CurID
|
||||
-> Rational
|
||||
-> T.Text
|
||||
-> MappingT m (EitherErrs KeyTx)
|
||||
-> SqlPersistT m (EitherErrs KeyTx)
|
||||
txPair day from to cur val desc = resolveTx tx
|
||||
where
|
||||
split a v = Split {sAcnt = a, sValue = v, sComment = "", sCurrency = cur}
|
||||
|
|
@ -352,12 +418,12 @@ txPair day from to cur val desc = resolveTx tx
|
|||
, txSplits = [split from (-val), split to val]
|
||||
}
|
||||
|
||||
resolveTx :: MonadUnliftIO m => BalTx -> MappingT m (EitherErrs KeyTx)
|
||||
resolveTx :: MonadFinance m => BalTx -> SqlPersistT m (EitherErrs KeyTx)
|
||||
resolveTx t@Tx {txSplits = ss} = do
|
||||
res <- concatEithersL <$> mapM resolveSplit ss
|
||||
return $ fmap (\kss -> t {txSplits = kss}) res
|
||||
|
||||
resolveSplit :: MonadUnliftIO m => BalSplit -> MappingT m (EitherErrs KeySplit)
|
||||
resolveSplit :: MonadFinance m => BalSplit -> SqlPersistT m (EitherErrs KeySplit)
|
||||
resolveSplit s@Split {sAcnt = p, sCurrency = c, sValue = v} = do
|
||||
aid <- lookupAccountKey p
|
||||
cid <- lookupCurrency c
|
||||
|
|
@ -380,14 +446,14 @@ insertSplit :: MonadUnliftIO m => Key TransactionR -> KeySplit -> SqlPersistT m
|
|||
insertSplit t Split {sAcnt = aid, sCurrency = cid, sValue = v, sComment = c} = do
|
||||
insert $ SplitR t cid aid c v
|
||||
|
||||
lookupAccount :: MonadUnliftIO m => AcntID -> MappingT m (EitherErr (Key AccountR, AcntSign))
|
||||
lookupAccount p = lookupErr (DBKey AcntField) p <$> asks kmAccount
|
||||
lookupAccount :: MonadFinance m => AcntID -> SqlPersistT m (EitherErr (Key AccountR, AcntSign))
|
||||
lookupAccount p = lookupErr (DBKey AcntField) p <$> lift (askDBState kmAccount)
|
||||
|
||||
lookupAccountKey :: MonadUnliftIO m => AcntID -> MappingT m (EitherErr (Key AccountR))
|
||||
lookupAccountKey :: MonadFinance m => AcntID -> SqlPersistT m (EitherErr (Key AccountR))
|
||||
lookupAccountKey = fmap (fmap fst) . lookupAccount
|
||||
|
||||
lookupAccountSign :: MonadUnliftIO m => AcntID -> MappingT m (EitherErr AcntSign)
|
||||
lookupAccountSign :: MonadFinance m => AcntID -> SqlPersistT m (EitherErr AcntSign)
|
||||
lookupAccountSign = fmap (fmap snd) . lookupAccount
|
||||
|
||||
lookupCurrency :: MonadUnliftIO m => T.Text -> MappingT m (EitherErr (Key CurrencyR))
|
||||
lookupCurrency c = lookupErr (DBKey CurField) c <$> asks kmCurrency
|
||||
lookupCurrency :: MonadFinance m => T.Text -> SqlPersistT m (EitherErr (Key CurrencyR))
|
||||
lookupCurrency c = lookupErr (DBKey CurField) c <$> lift (askDBState kmCurrency)
|
||||
|
|
|
|||
|
|
@ -1,8 +1,4 @@
|
|||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
|
||||
module Internal.Statement
|
||||
( readImport
|
||||
|
|
@ -24,7 +20,7 @@ import qualified RIO.Vector as V
|
|||
|
||||
-- TODO this probably won't scale well (pipes?)
|
||||
|
||||
readImport :: MonadUnliftIO m => Import -> MappingT m (EitherErrs [BalTx])
|
||||
readImport :: MonadFinance m => Import -> m (EitherErrs [BalTx])
|
||||
readImport Import {..} = do
|
||||
let ores = plural $ compileOptions impTxOpts
|
||||
let cres = concatEithersL $ compileMatch <$> impMatches
|
||||
|
|
@ -37,14 +33,14 @@ readImport Import {..} = do
|
|||
Left es -> return $ Left es
|
||||
|
||||
readImport_
|
||||
:: MonadUnliftIO m
|
||||
:: MonadFinance m
|
||||
=> Natural
|
||||
-> Word
|
||||
-> TxOptsRe
|
||||
-> FilePath
|
||||
-> MappingT m (EitherErr [TxRecord])
|
||||
-> m (EitherErr [TxRecord])
|
||||
readImport_ n delim tns p = do
|
||||
dir <- asks kmConfigDir
|
||||
dir <- askDBState kmConfigDir
|
||||
bs <- liftIO $ BL.readFile $ dir </> p
|
||||
case decodeByNameWithP (parseTxRecord p tns) opts $ skip bs of
|
||||
Left m -> return $ Left $ ParseError $ T.pack m
|
||||
|
|
|
|||
|
|
@ -1,17 +1,5 @@
|
|||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DeriveLift #-}
|
||||
{-# LANGUAGE DeriveTraversable #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
|
||||
module Internal.Types where
|
||||
|
||||
|
|
@ -45,6 +33,7 @@ makeHaskellTypesWith
|
|||
, MultipleConstructors "SplitNum" "(./dhall/Types.dhall).SplitNum"
|
||||
, MultipleConstructors "ExpenseBucket" "(./dhall/Types.dhall).ExpenseBucket"
|
||||
, MultipleConstructors "IncomeBucket" "(./dhall/Types.dhall).IncomeBucket"
|
||||
, MultipleConstructors "AmountType" "(./dhall/Types.dhall).AmountType"
|
||||
, SingleConstructor "Currency" "Currency" "(./dhall/Types.dhall).Currency"
|
||||
, SingleConstructor "Gregorian" "Gregorian" "(./dhall/Types.dhall).Gregorian"
|
||||
, SingleConstructor "GregorianM" "GregorianM" "(./dhall/Types.dhall).GregorianM"
|
||||
|
|
@ -303,6 +292,10 @@ instance PersistField ExpenseBucket where
|
|||
instance PersistFieldSql ExpenseBucket where
|
||||
sqlType _ = SqlString
|
||||
|
||||
deriving instance Eq AmountType
|
||||
|
||||
deriving instance Hashable AmountType
|
||||
|
||||
deriving instance Eq TimeAmount
|
||||
|
||||
deriving instance Hashable TimeAmount
|
||||
|
|
|
|||
|
|
@ -1,8 +1,3 @@
|
|||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
|
||||
module Internal.Utils
|
||||
( compareDate
|
||||
, inBounds
|
||||
|
|
@ -78,14 +73,14 @@ xGregToDay :: XGregorian -> Day
|
|||
xGregToDay XGregorian {xgYear = y, xgMonth = m, xgDay = d} = fromGregorian (fromIntegral y) m d
|
||||
|
||||
gregTup :: Gregorian -> (Integer, Int, Int)
|
||||
gregTup Gregorian {..} =
|
||||
gregTup Gregorian {gYear, gMonth, gDay} =
|
||||
( fromIntegral gYear
|
||||
, fromIntegral gMonth
|
||||
, fromIntegral gDay
|
||||
)
|
||||
|
||||
gregMTup :: GregorianM -> (Integer, Int)
|
||||
gregMTup GregorianM {..} =
|
||||
gregMTup GregorianM {gmYear, gmMonth} =
|
||||
( fromIntegral gmYear
|
||||
, fromIntegral gmMonth
|
||||
)
|
||||
|
|
@ -145,20 +140,22 @@ expandBounds (d, n) = (d, addDays (fromIntegral n + 1) d)
|
|||
-- matching
|
||||
|
||||
matches :: MatchRe -> TxRecord -> EitherErrs (MatchRes RawTx)
|
||||
matches Match {..} r@TxRecord {..} = do
|
||||
res <- concatEither3 val other desc $ \x y z -> x && y && z
|
||||
if date && res
|
||||
then maybe (Right MatchSkip) (fmap MatchPass . convert) mTx
|
||||
else Right MatchFail
|
||||
where
|
||||
val = valMatches mVal trAmount
|
||||
date = maybe True (`dateMatches` trDate) mDate
|
||||
other = foldM (\a o -> (a &&) <$> otherMatches trOther o) True mOther
|
||||
desc = maybe (return True) (matchMaybe trDesc . snd) mDesc
|
||||
convert (ToTx cur a ss) = toTx cur a ss r
|
||||
matches
|
||||
Match {mTx, mOther, mVal, mDate, mDesc}
|
||||
r@TxRecord {trDate, trAmount, trDesc, trOther} = do
|
||||
res <- concatEither3 val other desc $ \x y z -> x && y && z
|
||||
if date && res
|
||||
then maybe (Right MatchSkip) (fmap MatchPass . convert) mTx
|
||||
else Right MatchFail
|
||||
where
|
||||
val = valMatches mVal trAmount
|
||||
date = maybe True (`dateMatches` trDate) mDate
|
||||
other = foldM (\a o -> (a &&) <$> otherMatches trOther o) True mOther
|
||||
desc = maybe (return True) (matchMaybe trDesc . snd) mDesc
|
||||
convert (ToTx cur a ss) = toTx cur a ss r
|
||||
|
||||
toTx :: SplitCur -> SplitAcnt -> [ExpSplit] -> TxRecord -> EitherErrs RawTx
|
||||
toTx sc sa toSplits r@TxRecord {..} =
|
||||
toTx sc sa toSplits r@TxRecord {trAmount, trDate, trDesc} =
|
||||
concatEithers2 acRes ssRes $ \(a_, c_) ss_ ->
|
||||
let fromSplit =
|
||||
Split
|
||||
|
|
@ -178,7 +175,7 @@ toTx sc sa toSplits r@TxRecord {..} =
|
|||
ssRes = concatEithersL $ fmap (resolveSplit r) toSplits
|
||||
|
||||
valMatches :: MatchVal -> Rational -> EitherErr Bool
|
||||
valMatches MatchVal {..} x
|
||||
valMatches MatchVal {mvDen, mvSign, mvNum, mvPrec} x
|
||||
| Just d_ <- mvDen, d_ >= p = Left $ MatchValPrecisionError d_ p
|
||||
| otherwise =
|
||||
Right $
|
||||
|
|
@ -251,8 +248,9 @@ parseRational (pat, re) s = case matchGroupsMaybe s re of
|
|||
_ -> msg "malformed decimal"
|
||||
where
|
||||
readT what t = case readMaybe $ T.unpack t of
|
||||
Just d -> return $ fromInteger d
|
||||
Just d -> return d
|
||||
_ -> msg $ T.unwords ["could not parse", what, t]
|
||||
msg :: MonadFail m => T.Text -> m a
|
||||
msg m =
|
||||
fail $
|
||||
T.unpack $
|
||||
|
|
@ -296,7 +294,7 @@ fmtRational precision x = T.concat [s, txt n', ".", pad 2 "0" $ txt d']
|
|||
pad i c z = T.append (T.replicate (i - T.length z) c) z
|
||||
|
||||
dec2Rat :: Decimal -> Rational
|
||||
dec2Rat D {..} =
|
||||
dec2Rat D {sign, whole, decimal, precision} =
|
||||
k * (fromIntegral whole + (fromIntegral decimal % (10 ^ precision)))
|
||||
where
|
||||
k = if sign then 1 else -1
|
||||
|
|
@ -364,7 +362,7 @@ showError other = (: []) $ case other of
|
|||
splits = T.intercalate ", " $ fmap (singleQuote . showSplit) rss
|
||||
|
||||
showGregorian_ :: Gregorian -> T.Text
|
||||
showGregorian_ Gregorian {..} = T.intercalate "-" $ showT <$> [gYear, gMonth, gDay]
|
||||
showGregorian_ Gregorian {gYear, gMonth, gDay} = T.intercalate "-" $ showT <$> [gYear, gMonth, gDay]
|
||||
|
||||
showTx :: TxRecord -> T.Text
|
||||
showTx TxRecord {trDate = d, trAmount = v, trDesc = e, trFile = f} =
|
||||
|
|
@ -428,7 +426,8 @@ showYMD_ md =
|
|||
|
||||
showMatchVal :: MatchVal -> Maybe T.Text
|
||||
showMatchVal MatchVal {mvSign = Nothing, mvNum = Nothing, mvDen = Nothing} = Nothing
|
||||
showMatchVal MatchVal {..} = Just $ singleQuote $ keyVals [(k, v) | (k, Just v) <- kvs]
|
||||
showMatchVal MatchVal {mvNum, mvDen, mvSign, mvPrec} =
|
||||
Just $ singleQuote $ keyVals [(k, v) | (k, Just v) <- kvs]
|
||||
where
|
||||
kvs =
|
||||
[ ("sign", (\s -> if s then "+" else "-") <$> mvSign)
|
||||
|
|
|
|||
72
package.yaml
72
package.yaml
|
|
@ -10,15 +10,59 @@ extra-source-files:
|
|||
- README.md
|
||||
- ChangeLog.md
|
||||
|
||||
# Metadata used when publishing your package
|
||||
# synopsis: Short description of your package
|
||||
# category: Web
|
||||
|
||||
# To avoid duplicated efforts in documentation and dealing with the
|
||||
# complications of embedding Haddock markup inside cabal files, it is
|
||||
# common to point users to the README.md file.
|
||||
description: Please see the README on GitHub at <https://github.com/ndwarshuis/budget#readme>
|
||||
|
||||
default-extensions:
|
||||
- OverloadedStrings
|
||||
- FlexibleContexts
|
||||
- FlexibleInstances
|
||||
- InstanceSigs
|
||||
- MultiParamTypeClasses
|
||||
- EmptyCase
|
||||
- LambdaCase
|
||||
- MultiWayIf
|
||||
- NamedFieldPuns
|
||||
- TupleSections
|
||||
- DeriveFoldable
|
||||
- DeriveFunctor
|
||||
- DeriveGeneric
|
||||
- DeriveLift
|
||||
- DeriveTraversable
|
||||
- DerivingStrategies
|
||||
- DeriveDataTypeable
|
||||
- EmptyDataDecls
|
||||
- PartialTypeSignatures
|
||||
- GeneralizedNewtypeDeriving
|
||||
- StandaloneDeriving
|
||||
- BangPatterns
|
||||
- TypeOperators
|
||||
- ScopedTypeVariables
|
||||
- TypeApplications
|
||||
- ConstraintKinds
|
||||
- RankNTypes
|
||||
- GADTs
|
||||
- DefaultSignatures
|
||||
- NoImplicitPrelude
|
||||
- FunctionalDependencies
|
||||
- DataKinds
|
||||
- TypeFamilies
|
||||
- BinaryLiterals
|
||||
- ViewPatterns
|
||||
|
||||
ghc-options:
|
||||
- -Wall
|
||||
- -Wcompat
|
||||
- -Widentities
|
||||
- -Wincomplete-record-updates
|
||||
- -Wincomplete-uni-patterns
|
||||
- -Wredundant-constraints
|
||||
- -Wpartial-fields
|
||||
- -Werror
|
||||
- -O2
|
||||
|
||||
dependencies:
|
||||
- base >= 4.12 && < 10
|
||||
- rio >= 0.1.21.0
|
||||
|
|
@ -41,34 +85,16 @@ dependencies:
|
|||
- recursion-schemes
|
||||
- data-fix
|
||||
- filepath
|
||||
- mtl
|
||||
|
||||
library:
|
||||
source-dirs: lib/
|
||||
ghc-options:
|
||||
- -Wall
|
||||
- -Wcompat
|
||||
- -Widentities
|
||||
- -Wincomplete-record-updates
|
||||
- -Wincomplete-uni-patterns
|
||||
- -Wredundant-constraints
|
||||
- -Wpartial-fields
|
||||
- -Werror
|
||||
- -O2
|
||||
|
||||
executables:
|
||||
pwncash:
|
||||
main: Main.hs
|
||||
source-dirs: app
|
||||
ghc-options:
|
||||
- -Wall
|
||||
- -Wcompat
|
||||
- -Widentities
|
||||
- -Wincomplete-record-updates
|
||||
- -Wincomplete-uni-patterns
|
||||
- -Wredundant-constraints
|
||||
- -Wpartial-fields
|
||||
- -Werror
|
||||
- -O2
|
||||
- -threaded
|
||||
dependencies:
|
||||
- budget
|
||||
|
|
|
|||
Loading…
Reference in New Issue