ENH remove buckets entirely
This commit is contained in:
parent
61aabf45a3
commit
4e38f9ed8d
|
@ -26,7 +26,6 @@ source-repository head
|
||||||
library
|
library
|
||||||
exposed-modules:
|
exposed-modules:
|
||||||
Internal.Config
|
Internal.Config
|
||||||
Internal.Database.Model
|
|
||||||
Internal.Database.Ops
|
Internal.Database.Ops
|
||||||
Internal.Insert
|
Internal.Insert
|
||||||
Internal.Statement
|
Internal.Statement
|
||||||
|
|
|
@ -181,10 +181,6 @@ let Import =
|
||||||
|
|
||||||
let Statement = < StmtManual : Manual | StmtImport : Import >
|
let Statement = < StmtManual : Manual | StmtImport : Import >
|
||||||
|
|
||||||
let ExpenseBucket = < Fixed | Investment | Savings | Guiltless >
|
|
||||||
|
|
||||||
let IncomeBucket = < PreTax | IntraTax | PostTax >
|
|
||||||
|
|
||||||
let Amount = { amtValue : Decimal, amtDesc : Text }
|
let Amount = { amtValue : Decimal, amtDesc : Text }
|
||||||
|
|
||||||
let AmountType = < FixedAmt | Percent | Target >
|
let AmountType = < FixedAmt | Percent | Target >
|
||||||
|
@ -193,23 +189,13 @@ let TimeAmount = { taWhen : DatePat, taAmt : Amount, taAmtType : AmountType }
|
||||||
|
|
||||||
let Tax = { taxAcnt : AcntID, taxValue : Decimal }
|
let Tax = { taxAcnt : AcntID, taxValue : Decimal }
|
||||||
|
|
||||||
let TransferTarget =
|
|
||||||
< ExpenseTarget :
|
|
||||||
{ _1xtarget :
|
|
||||||
{- this is the only place expense accounts may be specified -}
|
|
||||||
AcntID
|
|
||||||
, _2xtarget : ExpenseBucket
|
|
||||||
}
|
|
||||||
| GenericTarget : AcntID
|
|
||||||
>
|
|
||||||
|
|
||||||
let Exchange =
|
let Exchange =
|
||||||
{ xFromCur : CurID, xToCur : CurID, xAcnt : AcntID, xRate : Decimal }
|
{ xFromCur : CurID, xToCur : CurID, xAcnt : AcntID, xRate : Decimal }
|
||||||
|
|
||||||
let BudgetCurrency = < NoX : CurID | X : Exchange >
|
let BudgetCurrency = < NoX : CurID | X : Exchange >
|
||||||
|
|
||||||
let Allocation =
|
let Allocation =
|
||||||
{ alloPath : TransferTarget
|
{ alloPath : AcntID
|
||||||
, alloAmts : List Amount
|
, alloAmts : List Amount
|
||||||
, alloCurrency : BudgetCurrency
|
, alloCurrency : BudgetCurrency
|
||||||
}
|
}
|
||||||
|
@ -225,12 +211,12 @@ let Income =
|
||||||
, incPretax : List Allocation
|
, incPretax : List Allocation
|
||||||
, incTaxes : List Tax
|
, incTaxes : List Tax
|
||||||
, incPosttax : List Allocation
|
, incPosttax : List Allocation
|
||||||
, incToBal : TransferTarget
|
, incToBal : AcntID
|
||||||
}
|
}
|
||||||
|
|
||||||
let Transfer =
|
let Transfer =
|
||||||
{ transFrom : AcntID
|
{ transFrom : AcntID
|
||||||
, transTo : TransferTarget
|
, transTo : AcntID
|
||||||
, transAmounts : List TimeAmount
|
, transAmounts : List TimeAmount
|
||||||
, transCurrency : BudgetCurrency
|
, transCurrency : BudgetCurrency
|
||||||
}
|
}
|
||||||
|
@ -308,15 +294,12 @@ in { CurID
|
||||||
, Statement
|
, Statement
|
||||||
, Transfer
|
, Transfer
|
||||||
, Income
|
, Income
|
||||||
, IncomeBucket
|
|
||||||
, ExpenseBucket
|
|
||||||
, Budget
|
, Budget
|
||||||
, Tax
|
, Tax
|
||||||
, Allocation
|
, Allocation
|
||||||
, Amount
|
, Amount
|
||||||
, TimeAmount
|
, TimeAmount
|
||||||
, AmountType
|
, AmountType
|
||||||
, TransferTarget
|
|
||||||
, ShadowMatch
|
, ShadowMatch
|
||||||
, ShadowTransfer
|
, ShadowTransfer
|
||||||
, AcntSet
|
, AcntSet
|
||||||
|
|
|
@ -1,111 +0,0 @@
|
||||||
{-# LANGUAGE QuasiQuotes #-}
|
|
||||||
{-# LANGUAGE TemplateHaskell #-}
|
|
||||||
{-# LANGUAGE UndecidableInstances #-}
|
|
||||||
|
|
||||||
module Internal.Database.Model where
|
|
||||||
|
|
||||||
import Database.Esqueleto.Experimental
|
|
||||||
import Database.Persist.TH
|
|
||||||
import Internal.Types
|
|
||||||
import RIO
|
|
||||||
import qualified RIO.Map as M
|
|
||||||
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
|
|
||||||
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
|
|
||||||
BudgetLabelR sql=budget_labels
|
|
||||||
split SplitRId OnDeleteCascade
|
|
||||||
budgetName T.Text
|
|
||||||
deriving Show Eq
|
|
||||||
ExpenseBucketR sql=expense_buckets
|
|
||||||
budgetLabel BudgetLabelRId OnDeleteCascade
|
|
||||||
bucket ExpenseBucket
|
|
||||||
deriving Show Eq
|
|
||||||
IncomeBucketR sql=income_buckets
|
|
||||||
budgetLabel BudgetLabelRId OnDeleteCascade
|
|
||||||
bucket IncomeBucket
|
|
||||||
deriving Show Eq
|
|
||||||
|]
|
|
||||||
|
|
||||||
type AccountMap = M.Map AcntID (AccountRId, AcntSign, AcntType)
|
|
||||||
|
|
||||||
type CurrencyMap = M.Map CurID CurrencyRId
|
|
||||||
|
|
||||||
data DBState = DBState
|
|
||||||
{ kmCurrency :: !CurrencyMap
|
|
||||||
, kmAccount :: !AccountMap
|
|
||||||
, kmBudgetInterval :: !Bounds
|
|
||||||
, kmStatementInterval :: !Bounds
|
|
||||||
, kmNewCommits :: ![Int]
|
|
||||||
, kmConfigDir :: !FilePath
|
|
||||||
}
|
|
||||||
|
|
||||||
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,7 +1,6 @@
|
||||||
module Internal.Database.Ops
|
module Internal.Database.Ops
|
||||||
( migrate_
|
( migrate_
|
||||||
, nukeTables
|
, nukeTables
|
||||||
-- , showBalances
|
|
||||||
, updateHashes
|
, updateHashes
|
||||||
, getDBState
|
, getDBState
|
||||||
, tree2Records
|
, tree2Records
|
||||||
|
@ -18,7 +17,6 @@ import Database.Persist.Sql hiding (delete, (==.), (||.))
|
||||||
import Database.Persist.Sqlite hiding (delete, (==.), (||.))
|
import Database.Persist.Sqlite hiding (delete, (==.), (||.))
|
||||||
import Database.Sqlite hiding (Config)
|
import Database.Sqlite hiding (Config)
|
||||||
import GHC.Err
|
import GHC.Err
|
||||||
import Internal.Database.Model
|
|
||||||
import Internal.Types
|
import Internal.Types
|
||||||
import Internal.Utils
|
import Internal.Utils
|
||||||
import RIO hiding (LogFunc, isNothing, on, (^.))
|
import RIO hiding (LogFunc, isNothing, on, (^.))
|
||||||
|
|
|
@ -8,7 +8,6 @@ import Data.Hashable
|
||||||
import Database.Persist.Class
|
import Database.Persist.Class
|
||||||
import Database.Persist.Sql hiding (Single, Statement)
|
import Database.Persist.Sql hiding (Single, Statement)
|
||||||
import GHC.Utils.Misc hiding (split)
|
import GHC.Utils.Misc hiding (split)
|
||||||
import Internal.Database.Model
|
|
||||||
import Internal.Statement
|
import Internal.Statement
|
||||||
import Internal.Types hiding (sign)
|
import Internal.Types hiding (sign)
|
||||||
import Internal.Utils
|
import Internal.Utils
|
||||||
|
@ -151,9 +150,8 @@ fromShadow tx t@ShadowTransfer {stFrom, stTo, stDesc, stRatio} = do
|
||||||
BudgetTx
|
BudgetTx
|
||||||
{ btMeta = btMeta $ bttTx tx
|
{ btMeta = btMeta $ bttTx tx
|
||||||
, btWhen = btWhen $ bttTx tx
|
, btWhen = btWhen $ bttTx tx
|
||||||
, -- TODO what are these supposed to do?
|
, btFrom = stFrom
|
||||||
btFrom = BudgetSplit stFrom Nothing
|
, btTo = stTo
|
||||||
, btTo = BudgetSplit stTo Nothing
|
|
||||||
, btValue = dec2Rat stRatio * (btValue $ bttTx tx)
|
, btValue = dec2Rat stRatio * (btValue $ bttTx tx)
|
||||||
, btDesc = stDesc
|
, btDesc = stDesc
|
||||||
}
|
}
|
||||||
|
@ -165,8 +163,8 @@ shadowMatches ShadowMatch {smFrom, smTo, smDate, smVal} tx = do
|
||||||
-- TODO what does the amount do for each of the different types?
|
-- TODO what does the amount do for each of the different types?
|
||||||
valRes <- valMatches smVal (btValue tx_)
|
valRes <- valMatches smVal (btValue tx_)
|
||||||
return $
|
return $
|
||||||
memberMaybe (bsAcnt $ btFrom tx_) smFrom
|
memberMaybe (btFrom tx_) smFrom
|
||||||
&& memberMaybe (bsAcnt $ btTo tx_) smTo
|
&& memberMaybe (btTo tx_) smTo
|
||||||
&& maybe True (`dateMatches` (btWhen tx_)) smDate
|
&& maybe True (`dateMatches` (btWhen tx_)) smDate
|
||||||
&& valRes
|
&& valRes
|
||||||
where
|
where
|
||||||
|
@ -181,13 +179,13 @@ balanceTransfers ts = snd $ L.mapAccumR go initBals $ L.sortOn (btWhen . bttTx)
|
||||||
M.fromList $
|
M.fromList $
|
||||||
fmap (,0) $
|
fmap (,0) $
|
||||||
L.nub $
|
L.nub $
|
||||||
(fmap (bsAcnt . btTo . bttTx) ts ++ fmap (bsAcnt . btTo . bttTx) ts)
|
(fmap (btTo . bttTx) ts ++ fmap (btTo . bttTx) ts)
|
||||||
updateBal x = M.update (Just . (+ x))
|
updateBal x = M.update (Just . (+ x))
|
||||||
lookupBal = M.findWithDefault (error "this should not happen")
|
lookupBal = M.findWithDefault (error "this should not happen")
|
||||||
go bals btt =
|
go bals btt =
|
||||||
let tx = bttTx btt
|
let tx = bttTx btt
|
||||||
from = bsAcnt $ btFrom tx
|
from = btFrom tx
|
||||||
to = bsAcnt $ btTo tx
|
to = btTo tx
|
||||||
bal = lookupBal to bals
|
bal = lookupBal to bals
|
||||||
x = amtToMove bal (bttType btt) (btValue tx)
|
x = amtToMove bal (bttType btt) (btValue tx)
|
||||||
in (updateBal x to $ updateBal (-x) from bals, tx {btValue = x})
|
in (updateBal x to $ updateBal (-x) from bals, tx {btValue = x})
|
||||||
|
@ -198,12 +196,6 @@ balanceTransfers ts = snd $ L.mapAccumR go initBals $ L.sortOn (btWhen . bttTx)
|
||||||
amtToMove bal Percent x = -(x / 100 * bal)
|
amtToMove bal Percent x = -(x / 100 * bal)
|
||||||
amtToMove bal Target x = x - bal
|
amtToMove bal Target x = x - bal
|
||||||
|
|
||||||
-- TODO allow currency conversions here
|
|
||||||
data BudgetSplit b = BudgetSplit
|
|
||||||
{ bsAcnt :: !AcntID
|
|
||||||
, bsBucket :: !(Maybe b)
|
|
||||||
}
|
|
||||||
|
|
||||||
data BudgetMeta = BudgetMeta
|
data BudgetMeta = BudgetMeta
|
||||||
{ bmCommit :: !(Key CommitR)
|
{ bmCommit :: !(Key CommitR)
|
||||||
, bmCur :: !BudgetCurrency
|
, bmCur :: !BudgetCurrency
|
||||||
|
@ -213,8 +205,8 @@ data BudgetMeta = BudgetMeta
|
||||||
data BudgetTx = BudgetTx
|
data BudgetTx = BudgetTx
|
||||||
{ btMeta :: !BudgetMeta
|
{ btMeta :: !BudgetMeta
|
||||||
, btWhen :: !Day
|
, btWhen :: !Day
|
||||||
, btFrom :: !(BudgetSplit IncomeBucket)
|
, btFrom :: !AcntID
|
||||||
, btTo :: !(BudgetSplit ExpenseBucket)
|
, btTo :: !AcntID
|
||||||
, btValue :: !Rational
|
, btValue :: !Rational
|
||||||
, btDesc :: !T.Text
|
, btDesc :: !T.Text
|
||||||
}
|
}
|
||||||
|
@ -231,55 +223,52 @@ insertIncome
|
||||||
whenHash CTIncome i (Right []) $ \c -> do
|
whenHash CTIncome i (Right []) $ \c -> do
|
||||||
let meta = BudgetMeta c (NoX incCurrency) name
|
let meta = BudgetMeta c (NoX incCurrency) name
|
||||||
let balRes = balanceIncome i
|
let balRes = balanceIncome i
|
||||||
fromRes <- lift $ checkAcntType IncomeT incFrom (\j -> BudgetSplit j . Just)
|
fromRes <- lift $ checkAcntType IncomeT incFrom
|
||||||
toRes <- lift $ expandTarget incToBal
|
case concatEither2 balRes fromRes (,) of
|
||||||
case concatEither3 balRes fromRes toRes (,,) of
|
|
||||||
Left es -> return $ Left es
|
Left es -> return $ Left es
|
||||||
Right (balance, fromFun, to) ->
|
Right (balance, from) ->
|
||||||
fmap (fmap (concat . concat)) $
|
fmap (fmap (concat . concat)) $
|
||||||
withDates incWhen $ \day -> do
|
withDates incWhen $ \day -> do
|
||||||
let fromAllos b =
|
let fromAllos = fmap concat . mapM (lift . fromAllo day meta from)
|
||||||
fmap (fmap concat . concatEitherL)
|
pre <- fromAllos incPretax
|
||||||
. mapM (lift . fromAllo day meta (fromFun b))
|
|
||||||
pre <- fromAllos PreTax incPretax
|
|
||||||
tax <-
|
tax <-
|
||||||
concatEitherL
|
concatEitherL
|
||||||
<$> mapM (lift . fromTax day meta (fromFun IntraTax)) incTaxes
|
<$> mapM (lift . fromTax day meta from) incTaxes
|
||||||
post <- fromAllos PostTax incPosttax
|
post <- fromAllos incPosttax
|
||||||
let bal =
|
let bal =
|
||||||
BudgetTxType
|
BudgetTxType
|
||||||
{ bttTx =
|
{ bttTx =
|
||||||
BudgetTx
|
BudgetTx
|
||||||
{ btMeta = meta
|
{ btMeta = meta
|
||||||
, btWhen = day
|
, btWhen = day
|
||||||
, btFrom = fromFun PostTax
|
, btFrom = from
|
||||||
, btTo = to
|
, btTo = incToBal
|
||||||
, btValue = balance
|
, btValue = balance
|
||||||
, btDesc = "balance after deductions"
|
, btDesc = "balance after deductions"
|
||||||
}
|
}
|
||||||
, bttType = FixedAmt
|
, bttType = FixedAmt
|
||||||
}
|
}
|
||||||
return $ concatEithersL [Right [bal], tax, pre, post]
|
return $ concatEithersL [Right [bal], tax, Right pre, Right post]
|
||||||
|
|
||||||
fromAllo
|
fromAllo
|
||||||
:: MonadFinance m
|
:: MonadFinance m
|
||||||
=> Day
|
=> Day
|
||||||
-> BudgetMeta
|
-> BudgetMeta
|
||||||
-> BudgetSplit IncomeBucket
|
-> AcntID
|
||||||
-> Allocation
|
-> Allocation
|
||||||
-> m (EitherErr [BudgetTxType])
|
-> m [BudgetTxType]
|
||||||
fromAllo day meta from Allocation {alloPath, alloAmts} = do
|
fromAllo day meta from Allocation {alloPath, alloAmts} = do
|
||||||
-- TODO this is going to be repeated a zillion times (might matter)
|
-- TODO this is going to be repeated a zillion times (might matter)
|
||||||
res <- expandTarget alloPath
|
-- res <- expandTarget alloPath
|
||||||
return $ (\to -> fmap (toBT to) alloAmts) <$> res
|
return $ fmap toBT alloAmts
|
||||||
where
|
where
|
||||||
toBT to (Amount desc v) =
|
toBT (Amount desc v) =
|
||||||
BudgetTxType
|
BudgetTxType
|
||||||
{ bttTx =
|
{ bttTx =
|
||||||
BudgetTx
|
BudgetTx
|
||||||
{ btFrom = from
|
{ btFrom = from
|
||||||
, btWhen = day
|
, btWhen = day
|
||||||
, btTo = to
|
, btTo = alloPath
|
||||||
, btValue = dec2Rat v
|
, btValue = dec2Rat v
|
||||||
, btDesc = desc
|
, btDesc = desc
|
||||||
, btMeta = meta
|
, btMeta = meta
|
||||||
|
@ -291,24 +280,26 @@ fromTax
|
||||||
:: MonadFinance m
|
:: MonadFinance m
|
||||||
=> Day
|
=> Day
|
||||||
-> BudgetMeta
|
-> BudgetMeta
|
||||||
-> BudgetSplit IncomeBucket
|
-> AcntID
|
||||||
-> Tax
|
-> Tax
|
||||||
-> m (EitherErr BudgetTxType)
|
-> m (EitherErr BudgetTxType)
|
||||||
fromTax day meta from Tax {taxAcnt = to, taxValue = v} =
|
fromTax day meta from Tax {taxAcnt = to, taxValue = v} = do
|
||||||
-- TODO this is going to be repeated a zillion times (might matter)
|
res <- checkAcntType ExpenseT to
|
||||||
checkAcntType ExpenseT to $ \to_ ->
|
return $ fmap go res
|
||||||
BudgetTxType
|
where
|
||||||
{ bttTx =
|
go to_ =
|
||||||
BudgetTx
|
BudgetTxType
|
||||||
{ btFrom = from
|
{ bttTx =
|
||||||
, btWhen = day
|
BudgetTx
|
||||||
, btTo = BudgetSplit to_ (Just Fixed)
|
{ btFrom = from
|
||||||
, btValue = dec2Rat v
|
, btWhen = day
|
||||||
, btDesc = ""
|
, btTo = to_
|
||||||
, btMeta = meta
|
, btValue = dec2Rat v
|
||||||
}
|
, btDesc = ""
|
||||||
, bttType = FixedAmt
|
, btMeta = meta
|
||||||
}
|
}
|
||||||
|
, bttType = FixedAmt
|
||||||
|
}
|
||||||
|
|
||||||
balanceIncome :: Income -> EitherErr Rational
|
balanceIncome :: Income -> EitherErr Rational
|
||||||
balanceIncome
|
balanceIncome
|
||||||
|
@ -344,57 +335,42 @@ expandTransfer name t@Transfer {transAmounts, transTo, transCurrency, transFrom}
|
||||||
whenHash CTExpense t (Right []) $ \key ->
|
whenHash CTExpense t (Right []) $ \key ->
|
||||||
fmap (fmap concat . concatEithersL) $
|
fmap (fmap concat . concatEithersL) $
|
||||||
forM transAmounts $ \(TimeAmount (Amount desc v) atype pat) -> do
|
forM transAmounts $ \(TimeAmount (Amount desc v) atype pat) -> do
|
||||||
-- TODO this is going to be repeated a zillion times (might matter)
|
withDates pat $ \day ->
|
||||||
res <- lift $ expandTarget transTo
|
let meta =
|
||||||
case res of
|
BudgetMeta
|
||||||
Left e -> return $ Left [e]
|
{ bmCur = transCurrency
|
||||||
Right to -> withDates pat $ \day ->
|
, bmCommit = key
|
||||||
let meta =
|
, bmName = name
|
||||||
BudgetMeta
|
}
|
||||||
{ bmCur = transCurrency
|
tx =
|
||||||
, bmCommit = key
|
BudgetTxType
|
||||||
, bmName = name
|
{ bttTx =
|
||||||
}
|
BudgetTx
|
||||||
tx =
|
{ btMeta = meta
|
||||||
BudgetTxType
|
, btWhen = day
|
||||||
{ bttTx =
|
, btFrom = transFrom
|
||||||
BudgetTx
|
, btTo = transTo
|
||||||
{ btMeta = meta
|
, btValue = dec2Rat v
|
||||||
, btWhen = day
|
, btDesc = desc
|
||||||
, btFrom = BudgetSplit transFrom Nothing
|
}
|
||||||
, btTo = to
|
, bttType = atype
|
||||||
, btValue = dec2Rat v
|
}
|
||||||
, btDesc = desc
|
in return $ Right tx
|
||||||
}
|
|
||||||
, bttType = atype
|
|
||||||
}
|
|
||||||
in return $ Right tx
|
|
||||||
|
|
||||||
insertBudgetTx :: MonadFinance m => BudgetTx -> SqlPersistT m [InsertError]
|
insertBudgetTx :: MonadFinance m => BudgetTx -> SqlPersistT m [InsertError]
|
||||||
insertBudgetTx BudgetTx {btFrom, btTo, btMeta, btValue, btDesc, btWhen} = do
|
insertBudgetTx BudgetTx {btFrom, btTo, btMeta, btValue, btDesc, btWhen} = do
|
||||||
res <- lift $ splitPair (bsAcnt btFrom) (bsAcnt btTo) (bmCur btMeta) btValue
|
res <- lift $ splitPair btFrom btTo (bmCur btMeta) btValue
|
||||||
unlessLefts_ res $ \((sFrom, sTo), exchange) -> do
|
unlessLefts_ res $ \((sFrom, sTo), exchange) -> do
|
||||||
insertPair sFrom sTo
|
insertPair sFrom sTo
|
||||||
forM_ exchange $ \(xFrom, xTo) -> insertPair xFrom xTo
|
forM_ exchange $ \(xFrom, xTo) -> insertPair xFrom xTo
|
||||||
where
|
where
|
||||||
insertPair from to = do
|
insertPair from to = do
|
||||||
k <- insert $ TransactionR (bmCommit btMeta) btWhen btDesc
|
k <- insert $ TransactionR (bmCommit btMeta) btWhen btDesc
|
||||||
insertBudgetLabel name k IncomeBucketR from btFrom
|
insertBudgetLabel k from
|
||||||
insertBudgetLabel name k ExpenseBucketR to btTo
|
insertBudgetLabel k to
|
||||||
name = bmName btMeta
|
insertBudgetLabel k split = do
|
||||||
|
sk <- insertSplit k split
|
||||||
insertBudgetLabel
|
insert_ $ BudgetLabelR sk $ bmName btMeta
|
||||||
:: (MonadUnliftIO m, PersistRecordBackend record SqlBackend)
|
|
||||||
=> T.Text
|
|
||||||
-> Key TransactionR
|
|
||||||
-> (Key BudgetLabelR -> a -> record)
|
|
||||||
-> KeySplit
|
|
||||||
-> BudgetSplit a
|
|
||||||
-> SqlPersistT m ()
|
|
||||||
insertBudgetLabel name k bucketType split bs = do
|
|
||||||
sk <- insertSplit k split
|
|
||||||
bk <- insert $ BudgetLabelR sk name
|
|
||||||
forM_ (bsBucket bs) $ insert_ . bucketType bk
|
|
||||||
|
|
||||||
type SplitPair = (KeySplit, KeySplit)
|
type SplitPair = (KeySplit, KeySplit)
|
||||||
|
|
||||||
|
@ -425,34 +401,22 @@ splitPair from to cur val = case cur of
|
||||||
, sCurrency = c
|
, sCurrency = c
|
||||||
}
|
}
|
||||||
|
|
||||||
expandTarget
|
|
||||||
:: MonadFinance m
|
|
||||||
=> TransferTarget
|
|
||||||
-> m (EitherErr (BudgetSplit ExpenseBucket))
|
|
||||||
expandTarget t = case t of
|
|
||||||
ExpenseTarget i b -> checkAcntType ExpenseT i $ (`BudgetSplit` (Just b))
|
|
||||||
GenericTarget i ->
|
|
||||||
checkAcntTypes (LiabilityT :| [AssetT, EquityT]) i $
|
|
||||||
(`BudgetSplit` Nothing)
|
|
||||||
|
|
||||||
checkAcntType
|
checkAcntType
|
||||||
:: MonadFinance m
|
:: MonadFinance m
|
||||||
=> AcntType
|
=> AcntType
|
||||||
-> AcntID
|
-> AcntID
|
||||||
-> (AcntID -> a)
|
-> m (EitherErr AcntID)
|
||||||
-> m (EitherErr a)
|
|
||||||
checkAcntType t = checkAcntTypes (t :| [])
|
checkAcntType t = checkAcntTypes (t :| [])
|
||||||
|
|
||||||
checkAcntTypes
|
checkAcntTypes
|
||||||
:: MonadFinance m
|
:: MonadFinance m
|
||||||
=> NE.NonEmpty AcntType
|
=> NE.NonEmpty AcntType
|
||||||
-> AcntID
|
-> AcntID
|
||||||
-> (AcntID -> a)
|
-> m (EitherErr AcntID)
|
||||||
-> m (EitherErr a)
|
checkAcntTypes ts i = (go =<<) <$> lookupAccountType i
|
||||||
checkAcntTypes ts i f = (go =<<) <$> lookupAccountType i
|
|
||||||
where
|
where
|
||||||
go t
|
go t
|
||||||
| t `L.elem` ts = Right $ f i
|
| t `L.elem` ts = Right i
|
||||||
| otherwise = Left $ AccountError i ts
|
| otherwise = Left $ AccountError i ts
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
|
@ -6,7 +6,6 @@ module Internal.Statement
|
||||||
where
|
where
|
||||||
|
|
||||||
import Data.Csv
|
import Data.Csv
|
||||||
import Internal.Database.Model
|
|
||||||
import Internal.Types
|
import Internal.Types
|
||||||
import Internal.Utils
|
import Internal.Utils
|
||||||
import RIO
|
import RIO
|
||||||
|
|
|
@ -1,5 +1,7 @@
|
||||||
{-# LANGUAGE DeriveAnyClass #-}
|
{-# LANGUAGE DeriveAnyClass #-}
|
||||||
|
{-# LANGUAGE QuasiQuotes #-}
|
||||||
{-# LANGUAGE TemplateHaskell #-}
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
|
{-# LANGUAGE UndecidableInstances #-}
|
||||||
|
|
||||||
module Internal.Types where
|
module Internal.Types where
|
||||||
|
|
||||||
|
@ -7,6 +9,7 @@ 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 Language.Haskell.TH.Syntax (Lift)
|
import Language.Haskell.TH.Syntax (Lift)
|
||||||
|
@ -32,10 +35,7 @@ makeHaskellTypesWith
|
||||||
, MultipleConstructors "MatchYMD" "(./dhall/Types.dhall).MatchYMD"
|
, MultipleConstructors "MatchYMD" "(./dhall/Types.dhall).MatchYMD"
|
||||||
, MultipleConstructors "MatchDate" "(./dhall/Types.dhall).MatchDate"
|
, MultipleConstructors "MatchDate" "(./dhall/Types.dhall).MatchDate"
|
||||||
, MultipleConstructors "SplitNum" "(./dhall/Types.dhall).SplitNum"
|
, MultipleConstructors "SplitNum" "(./dhall/Types.dhall).SplitNum"
|
||||||
, MultipleConstructors "ExpenseBucket" "(./dhall/Types.dhall).ExpenseBucket"
|
|
||||||
, MultipleConstructors "IncomeBucket" "(./dhall/Types.dhall).IncomeBucket"
|
|
||||||
, MultipleConstructors "AmountType" "(./dhall/Types.dhall).AmountType"
|
, MultipleConstructors "AmountType" "(./dhall/Types.dhall).AmountType"
|
||||||
, MultipleConstructors "TransferTarget" "(./dhall/Types.dhall).TransferTarget"
|
|
||||||
, MultipleConstructors "BudgetCurrency" "(./dhall/Types.dhall).BudgetCurrency"
|
, MultipleConstructors "BudgetCurrency" "(./dhall/Types.dhall).BudgetCurrency"
|
||||||
, SingleConstructor "Currency" "Currency" "(./dhall/Types.dhall).Currency"
|
, SingleConstructor "Currency" "Currency" "(./dhall/Types.dhall).Currency"
|
||||||
, SingleConstructor "Gregorian" "Gregorian" "(./dhall/Types.dhall).Gregorian"
|
, SingleConstructor "Gregorian" "Gregorian" "(./dhall/Types.dhall).Gregorian"
|
||||||
|
@ -62,36 +62,7 @@ makeHaskellTypesWith
|
||||||
]
|
]
|
||||||
|
|
||||||
-------------------------------------------------------------------------------
|
-------------------------------------------------------------------------------
|
||||||
-- account tree
|
-- lots of instances for dhall types
|
||||||
|
|
||||||
data AccountTree
|
|
||||||
= Placeholder T.Text T.Text [AccountTree]
|
|
||||||
| Account T.Text T.Text
|
|
||||||
deriving (Eq, Generic, Hashable)
|
|
||||||
|
|
||||||
TH.makeBaseFunctor ''AccountTree
|
|
||||||
|
|
||||||
deriving instance Generic (AccountTreeF a)
|
|
||||||
|
|
||||||
deriving instance FromDhall a => FromDhall (AccountTreeF a)
|
|
||||||
|
|
||||||
data AccountRoot_ a = AccountRoot_
|
|
||||||
{ arAssets :: ![a]
|
|
||||||
, arEquity :: ![a]
|
|
||||||
, arExpenses :: ![a]
|
|
||||||
, arIncome :: ![a]
|
|
||||||
, arLiabilities :: ![a]
|
|
||||||
}
|
|
||||||
deriving (Generic)
|
|
||||||
|
|
||||||
type AccountRootF = AccountRoot_ (Fix AccountTreeF)
|
|
||||||
|
|
||||||
deriving instance FromDhall AccountRootF
|
|
||||||
|
|
||||||
type AccountRoot = AccountRoot_ AccountTree
|
|
||||||
|
|
||||||
-------------------------------------------------------------------------------
|
|
||||||
-- curencies
|
|
||||||
|
|
||||||
deriving instance Eq Currency
|
deriving instance Eq Currency
|
||||||
|
|
||||||
|
@ -99,49 +70,6 @@ deriving instance Lift Currency
|
||||||
|
|
||||||
deriving instance Hashable Currency
|
deriving instance Hashable Currency
|
||||||
|
|
||||||
type CurID = T.Text
|
|
||||||
|
|
||||||
-------------------------------------------------------------------------------
|
|
||||||
-- DHALL CONFIG
|
|
||||||
-------------------------------------------------------------------------------
|
|
||||||
|
|
||||||
data Config_ a = Config_
|
|
||||||
{ global :: !Global
|
|
||||||
, budget :: ![Budget]
|
|
||||||
, currencies :: ![Currency]
|
|
||||||
, statements :: ![Statement]
|
|
||||||
, accounts :: !a
|
|
||||||
, sqlConfig :: !SqlConfig
|
|
||||||
}
|
|
||||||
deriving (Generic)
|
|
||||||
|
|
||||||
type ConfigF = Config_ AccountRootF
|
|
||||||
|
|
||||||
type Config = Config_ AccountRoot
|
|
||||||
|
|
||||||
unfix :: ConfigF -> Config
|
|
||||||
unfix c@Config_ {accounts = a} = c {accounts = a'}
|
|
||||||
where
|
|
||||||
a' =
|
|
||||||
AccountRoot_
|
|
||||||
{ arAssets = unfixTree arAssets
|
|
||||||
, arEquity = unfixTree arEquity
|
|
||||||
, arExpenses = unfixTree arExpenses
|
|
||||||
, arIncome = unfixTree arIncome
|
|
||||||
, arLiabilities = unfixTree arLiabilities
|
|
||||||
}
|
|
||||||
unfixTree f = foldFix embed <$> f a
|
|
||||||
|
|
||||||
instance FromDhall a => FromDhall (Config_ a)
|
|
||||||
|
|
||||||
-------------------------------------------------------------------------------
|
|
||||||
-- accounts
|
|
||||||
|
|
||||||
type AcntID = T.Text
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
|
||||||
-- Time Patterns (for assigning when budget events will happen)
|
|
||||||
|
|
||||||
deriving instance Eq TimeUnit
|
deriving instance Eq TimeUnit
|
||||||
|
|
||||||
deriving instance Ord TimeUnit
|
deriving instance Ord TimeUnit
|
||||||
|
@ -234,9 +162,6 @@ deriving instance Show DatePat
|
||||||
|
|
||||||
deriving instance Hashable DatePat
|
deriving instance Hashable DatePat
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
|
||||||
-- Budget (projecting into the future)
|
|
||||||
|
|
||||||
deriving instance Eq Budget
|
deriving instance Eq Budget
|
||||||
|
|
||||||
deriving instance Hashable Budget
|
deriving instance Hashable Budget
|
||||||
|
@ -265,14 +190,6 @@ deriving instance Eq Allocation
|
||||||
|
|
||||||
deriving instance Hashable Allocation
|
deriving instance Hashable Allocation
|
||||||
|
|
||||||
deriving instance Eq IncomeBucket
|
|
||||||
|
|
||||||
deriving instance Hashable IncomeBucket
|
|
||||||
|
|
||||||
deriving instance Show IncomeBucket
|
|
||||||
|
|
||||||
deriving instance Read IncomeBucket
|
|
||||||
|
|
||||||
toPersistText :: Show a => a -> PersistValue
|
toPersistText :: Show a => a -> PersistValue
|
||||||
toPersistText = PersistText . T.pack . show
|
toPersistText = PersistText . T.pack . show
|
||||||
|
|
||||||
|
@ -283,30 +200,6 @@ fromPersistText what (PersistText t) = case readMaybe $ T.unpack t of
|
||||||
fromPersistText what x =
|
fromPersistText what x =
|
||||||
Left $ T.unwords ["error when deserializing", what, "; got", T.pack (show x)]
|
Left $ T.unwords ["error when deserializing", what, "; got", T.pack (show x)]
|
||||||
|
|
||||||
instance PersistField IncomeBucket where
|
|
||||||
toPersistValue = toPersistText
|
|
||||||
|
|
||||||
fromPersistValue = fromPersistText "IncomeBucket"
|
|
||||||
|
|
||||||
instance PersistFieldSql IncomeBucket where
|
|
||||||
sqlType _ = SqlString
|
|
||||||
|
|
||||||
deriving instance Eq ExpenseBucket
|
|
||||||
|
|
||||||
deriving instance Hashable ExpenseBucket
|
|
||||||
|
|
||||||
deriving instance Show ExpenseBucket
|
|
||||||
|
|
||||||
deriving instance Read ExpenseBucket
|
|
||||||
|
|
||||||
instance PersistField ExpenseBucket where
|
|
||||||
toPersistValue = toPersistText
|
|
||||||
|
|
||||||
fromPersistValue = fromPersistText "ExpenseBucket"
|
|
||||||
|
|
||||||
instance PersistFieldSql ExpenseBucket where
|
|
||||||
sqlType _ = SqlString
|
|
||||||
|
|
||||||
deriving instance Eq AmountType
|
deriving instance Eq AmountType
|
||||||
|
|
||||||
deriving instance Hashable AmountType
|
deriving instance Hashable AmountType
|
||||||
|
@ -315,10 +208,6 @@ deriving instance Eq TimeAmount
|
||||||
|
|
||||||
deriving instance Hashable TimeAmount
|
deriving instance Hashable TimeAmount
|
||||||
|
|
||||||
deriving instance Eq TransferTarget
|
|
||||||
|
|
||||||
deriving instance Hashable TransferTarget
|
|
||||||
|
|
||||||
deriving instance Eq Transfer
|
deriving instance Eq Transfer
|
||||||
|
|
||||||
deriving instance Hashable Transfer
|
deriving instance Hashable Transfer
|
||||||
|
@ -335,18 +224,133 @@ deriving instance Eq ShadowMatch
|
||||||
|
|
||||||
deriving instance Hashable ShadowMatch
|
deriving instance Hashable ShadowMatch
|
||||||
|
|
||||||
|
deriving instance Eq MatchVal
|
||||||
|
|
||||||
|
deriving instance Hashable MatchVal
|
||||||
|
|
||||||
|
deriving instance Show MatchVal
|
||||||
|
|
||||||
|
deriving instance Eq MatchYMD
|
||||||
|
|
||||||
|
deriving instance Hashable MatchYMD
|
||||||
|
|
||||||
|
deriving instance Show MatchYMD
|
||||||
|
|
||||||
|
deriving instance Eq MatchDate
|
||||||
|
|
||||||
|
deriving instance Hashable MatchDate
|
||||||
|
|
||||||
|
deriving instance Show MatchDate
|
||||||
|
|
||||||
|
deriving instance Eq Decimal
|
||||||
|
|
||||||
|
deriving instance Hashable Decimal
|
||||||
|
|
||||||
|
deriving instance Show Decimal
|
||||||
|
|
||||||
|
-- TODO this just looks silly...but not sure how to simplify it
|
||||||
|
instance Ord MatchYMD where
|
||||||
|
compare (Y y) (Y y') = compare y y'
|
||||||
|
compare (YM g) (YM g') = compare g g'
|
||||||
|
compare (YMD g) (YMD g') = compare g g'
|
||||||
|
compare (Y y) (YM g) = compare y (gmYear g) <> LT
|
||||||
|
compare (Y y) (YMD g) = compare y (gYear g) <> LT
|
||||||
|
compare (YM g) (Y y') = compare (gmYear g) y' <> GT
|
||||||
|
compare (YMD g) (Y y') = compare (gYear g) y' <> GT
|
||||||
|
compare (YM g) (YMD g') = compare g (gregM g') <> LT
|
||||||
|
compare (YMD g) (YM g') = compare (gregM g) g' <> GT
|
||||||
|
|
||||||
|
gregM :: Gregorian -> GregorianM
|
||||||
|
gregM Gregorian {gYear = y, gMonth = m} =
|
||||||
|
GregorianM {gmYear = y, gmMonth = m}
|
||||||
|
|
||||||
|
instance Ord MatchDate where
|
||||||
|
compare (On d) (On d') = compare d d'
|
||||||
|
compare (In d r) (In d' r') = compare d d' <> compare r r'
|
||||||
|
compare (On d) (In d' _) = compare d d' <> LT
|
||||||
|
compare (In d _) (On d') = compare d d' <> GT
|
||||||
|
|
||||||
|
deriving instance Eq SplitNum
|
||||||
|
|
||||||
|
deriving instance Hashable SplitNum
|
||||||
|
|
||||||
|
deriving instance Show SplitNum
|
||||||
|
|
||||||
|
deriving instance Eq Manual
|
||||||
|
|
||||||
|
deriving instance Hashable Manual
|
||||||
|
|
||||||
|
-------------------------------------------------------------------------------
|
||||||
|
-- top level type with fixed account tree to unroll the recursion in the dhall
|
||||||
|
-- account tree type
|
||||||
|
|
||||||
|
data AccountTree
|
||||||
|
= Placeholder T.Text T.Text [AccountTree]
|
||||||
|
| Account T.Text T.Text
|
||||||
|
deriving (Eq, Generic, Hashable)
|
||||||
|
|
||||||
|
TH.makeBaseFunctor ''AccountTree
|
||||||
|
|
||||||
|
deriving instance Generic (AccountTreeF a)
|
||||||
|
|
||||||
|
deriving instance FromDhall a => FromDhall (AccountTreeF a)
|
||||||
|
|
||||||
|
data AccountRoot_ a = AccountRoot_
|
||||||
|
{ arAssets :: ![a]
|
||||||
|
, arEquity :: ![a]
|
||||||
|
, arExpenses :: ![a]
|
||||||
|
, arIncome :: ![a]
|
||||||
|
, arLiabilities :: ![a]
|
||||||
|
}
|
||||||
|
deriving (Generic)
|
||||||
|
|
||||||
|
type AccountRootF = AccountRoot_ (Fix AccountTreeF)
|
||||||
|
|
||||||
|
deriving instance FromDhall AccountRootF
|
||||||
|
|
||||||
|
type AccountRoot = AccountRoot_ AccountTree
|
||||||
|
|
||||||
|
data Config_ a = Config_
|
||||||
|
{ global :: !Global
|
||||||
|
, budget :: ![Budget]
|
||||||
|
, currencies :: ![Currency]
|
||||||
|
, statements :: ![Statement]
|
||||||
|
, accounts :: !a
|
||||||
|
, sqlConfig :: !SqlConfig
|
||||||
|
}
|
||||||
|
deriving (Generic)
|
||||||
|
|
||||||
|
type ConfigF = Config_ AccountRootF
|
||||||
|
|
||||||
|
type Config = Config_ AccountRoot
|
||||||
|
|
||||||
|
unfix :: ConfigF -> Config
|
||||||
|
unfix c@Config_ {accounts = a} = c {accounts = a'}
|
||||||
|
where
|
||||||
|
a' =
|
||||||
|
AccountRoot_
|
||||||
|
{ arAssets = unfixTree arAssets
|
||||||
|
, arEquity = unfixTree arEquity
|
||||||
|
, arExpenses = unfixTree arExpenses
|
||||||
|
, arIncome = unfixTree arIncome
|
||||||
|
, arLiabilities = unfixTree arLiabilities
|
||||||
|
}
|
||||||
|
unfixTree f = foldFix embed <$> f a
|
||||||
|
|
||||||
|
instance FromDhall a => FromDhall (Config_ a)
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Statements (data from the past)
|
-- dhall type overrides (since dhall can't import types with parameters...yet)
|
||||||
|
|
||||||
|
type AcntID = T.Text
|
||||||
|
|
||||||
|
type CurID = T.Text
|
||||||
|
|
||||||
data Statement
|
data Statement
|
||||||
= StmtManual !Manual
|
= StmtManual !Manual
|
||||||
| StmtImport !Import
|
| StmtImport !Import
|
||||||
deriving (Eq, Hashable, Generic, FromDhall)
|
deriving (Eq, Hashable, Generic, FromDhall)
|
||||||
|
|
||||||
deriving instance Eq Manual
|
|
||||||
|
|
||||||
deriving instance Hashable Manual
|
|
||||||
|
|
||||||
data Split a v c = Split
|
data Split a v c = Split
|
||||||
{ sAcnt :: !a
|
{ sAcnt :: !a
|
||||||
, sValue :: !v
|
, sValue :: !v
|
||||||
|
@ -388,52 +392,6 @@ data Import = Import
|
||||||
}
|
}
|
||||||
deriving (Eq, Hashable, Generic, FromDhall)
|
deriving (Eq, Hashable, Generic, FromDhall)
|
||||||
|
|
||||||
deriving instance Eq MatchVal
|
|
||||||
|
|
||||||
deriving instance Hashable MatchVal
|
|
||||||
|
|
||||||
deriving instance Show MatchVal
|
|
||||||
|
|
||||||
deriving instance Eq MatchYMD
|
|
||||||
|
|
||||||
deriving instance Hashable MatchYMD
|
|
||||||
|
|
||||||
deriving instance Show MatchYMD
|
|
||||||
|
|
||||||
deriving instance Eq MatchDate
|
|
||||||
|
|
||||||
deriving instance Hashable MatchDate
|
|
||||||
|
|
||||||
deriving instance Show MatchDate
|
|
||||||
|
|
||||||
-- TODO this just looks silly...but not sure how to simplify it
|
|
||||||
instance Ord MatchYMD where
|
|
||||||
compare (Y y) (Y y') = compare y y'
|
|
||||||
compare (YM g) (YM g') = compare g g'
|
|
||||||
compare (YMD g) (YMD g') = compare g g'
|
|
||||||
compare (Y y) (YM g) = compare y (gmYear g) <> LT
|
|
||||||
compare (Y y) (YMD g) = compare y (gYear g) <> LT
|
|
||||||
compare (YM g) (Y y') = compare (gmYear g) y' <> GT
|
|
||||||
compare (YMD g) (Y y') = compare (gYear g) y' <> GT
|
|
||||||
compare (YM g) (YMD g') = compare g (gregM g') <> LT
|
|
||||||
compare (YMD g) (YM g') = compare (gregM g) g' <> GT
|
|
||||||
|
|
||||||
gregM :: Gregorian -> GregorianM
|
|
||||||
gregM Gregorian {gYear = y, gMonth = m} =
|
|
||||||
GregorianM {gmYear = y, gmMonth = m}
|
|
||||||
|
|
||||||
instance Ord MatchDate where
|
|
||||||
compare (On d) (On d') = compare d d'
|
|
||||||
compare (In d r) (In d' r') = compare d d' <> compare r r'
|
|
||||||
compare (On d) (In d' _) = compare d d' <> LT
|
|
||||||
compare (In d _) (On d') = compare d d' <> GT
|
|
||||||
|
|
||||||
deriving instance Eq SplitNum
|
|
||||||
|
|
||||||
deriving instance Hashable SplitNum
|
|
||||||
|
|
||||||
deriving instance Show SplitNum
|
|
||||||
|
|
||||||
-- | the value of a field in split (text version)
|
-- | the value of a field in split (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
|
||||||
|
@ -487,13 +445,47 @@ data Match re = Match
|
||||||
deriving instance Show (Match T.Text)
|
deriving instance Show (Match T.Text)
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Specialized dhall types
|
-- DATABASE MODEL
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
deriving instance Eq Decimal
|
share
|
||||||
|
[mkPersist sqlSettings, mkMigrate "migrateAll"]
|
||||||
deriving instance Hashable Decimal
|
[persistLowerCase|
|
||||||
|
CommitR sql=commits
|
||||||
deriving instance Show Decimal
|
hash Int
|
||||||
|
type ConfigType
|
||||||
|
deriving Show Eq
|
||||||
|
CurrencyR sql=currencies
|
||||||
|
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
|
||||||
|
BudgetLabelR sql=budget_labels
|
||||||
|
split SplitRId OnDeleteCascade
|
||||||
|
budgetName T.Text
|
||||||
|
deriving Show Eq
|
||||||
|
|]
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- database cache types
|
-- database cache types
|
||||||
|
@ -519,6 +511,57 @@ instance PersistField ConfigType where
|
||||||
maybe (Left $ "could not parse: " <> v) Right $ readMaybe $ T.unpack v
|
maybe (Left $ "could not parse: " <> v) Right $ readMaybe $ T.unpack v
|
||||||
fromPersistValue _ = Left "wrong type"
|
fromPersistValue _ = Left "wrong type"
|
||||||
|
|
||||||
|
type AccountMap = M.Map AcntID (AccountRId, AcntSign, AcntType)
|
||||||
|
|
||||||
|
type CurrencyMap = M.Map CurID CurrencyRId
|
||||||
|
|
||||||
|
data DBState = DBState
|
||||||
|
{ kmCurrency :: !CurrencyMap
|
||||||
|
, kmAccount :: !AccountMap
|
||||||
|
, kmBudgetInterval :: !Bounds
|
||||||
|
, kmStatementInterval :: !Bounds
|
||||||
|
, kmNewCommits :: ![Int]
|
||||||
|
, kmConfigDir :: !FilePath
|
||||||
|
}
|
||||||
|
|
||||||
|
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
|
||||||
|
|
||||||
-------------------------------------------------------------------------------
|
-------------------------------------------------------------------------------
|
||||||
-- misc
|
-- misc
|
||||||
|
|
||||||
|
@ -554,8 +597,6 @@ data TxRecord = TxRecord
|
||||||
|
|
||||||
type Bounds = (Day, Natural)
|
type Bounds = (Day, Natural)
|
||||||
|
|
||||||
-- type MaybeBounds = (Maybe Day, Maybe Day)
|
|
||||||
|
|
||||||
data Keyed a = Keyed
|
data Keyed a = Keyed
|
||||||
{ kKey :: !Int64
|
{ kKey :: !Int64
|
||||||
, kVal :: !a
|
, kVal :: !a
|
||||||
|
@ -588,6 +629,9 @@ type BalTx = Tx BalSplit
|
||||||
|
|
||||||
data MatchRes a = MatchPass !a | MatchFail | MatchSkip
|
data MatchRes a = MatchPass !a | MatchFail | MatchSkip
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
-- exception types
|
||||||
|
|
||||||
data BalanceType = TooFewSplits | NotOneBlank deriving (Show)
|
data BalanceType = TooFewSplits | NotOneBlank deriving (Show)
|
||||||
|
|
||||||
data MatchType = MatchNumeric | MatchText deriving (Show)
|
data MatchType = MatchNumeric | MatchText deriving (Show)
|
||||||
|
|
Loading…
Reference in New Issue