ENH remove buckets entirely
This commit is contained in:
parent
61aabf45a3
commit
4e38f9ed8d
|
|
@ -26,7 +26,6 @@ source-repository head
|
|||
library
|
||||
exposed-modules:
|
||||
Internal.Config
|
||||
Internal.Database.Model
|
||||
Internal.Database.Ops
|
||||
Internal.Insert
|
||||
Internal.Statement
|
||||
|
|
|
|||
|
|
@ -181,10 +181,6 @@ let 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 AmountType = < FixedAmt | Percent | Target >
|
||||
|
|
@ -193,23 +189,13 @@ let TimeAmount = { taWhen : DatePat, taAmt : Amount, taAmtType : AmountType }
|
|||
|
||||
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 =
|
||||
{ xFromCur : CurID, xToCur : CurID, xAcnt : AcntID, xRate : Decimal }
|
||||
|
||||
let BudgetCurrency = < NoX : CurID | X : Exchange >
|
||||
|
||||
let Allocation =
|
||||
{ alloPath : TransferTarget
|
||||
{ alloPath : AcntID
|
||||
, alloAmts : List Amount
|
||||
, alloCurrency : BudgetCurrency
|
||||
}
|
||||
|
|
@ -225,12 +211,12 @@ let Income =
|
|||
, incPretax : List Allocation
|
||||
, incTaxes : List Tax
|
||||
, incPosttax : List Allocation
|
||||
, incToBal : TransferTarget
|
||||
, incToBal : AcntID
|
||||
}
|
||||
|
||||
let Transfer =
|
||||
{ transFrom : AcntID
|
||||
, transTo : TransferTarget
|
||||
, transTo : AcntID
|
||||
, transAmounts : List TimeAmount
|
||||
, transCurrency : BudgetCurrency
|
||||
}
|
||||
|
|
@ -308,15 +294,12 @@ in { CurID
|
|||
, Statement
|
||||
, Transfer
|
||||
, Income
|
||||
, IncomeBucket
|
||||
, ExpenseBucket
|
||||
, Budget
|
||||
, Tax
|
||||
, Allocation
|
||||
, Amount
|
||||
, TimeAmount
|
||||
, AmountType
|
||||
, TransferTarget
|
||||
, ShadowMatch
|
||||
, ShadowTransfer
|
||||
, 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
|
||||
( migrate_
|
||||
, nukeTables
|
||||
-- , showBalances
|
||||
, updateHashes
|
||||
, getDBState
|
||||
, tree2Records
|
||||
|
|
@ -18,7 +17,6 @@ import Database.Persist.Sql hiding (delete, (==.), (||.))
|
|||
import Database.Persist.Sqlite hiding (delete, (==.), (||.))
|
||||
import Database.Sqlite hiding (Config)
|
||||
import GHC.Err
|
||||
import Internal.Database.Model
|
||||
import Internal.Types
|
||||
import Internal.Utils
|
||||
import RIO hiding (LogFunc, isNothing, on, (^.))
|
||||
|
|
|
|||
|
|
@ -8,7 +8,6 @@ import Data.Hashable
|
|||
import Database.Persist.Class
|
||||
import Database.Persist.Sql hiding (Single, Statement)
|
||||
import GHC.Utils.Misc hiding (split)
|
||||
import Internal.Database.Model
|
||||
import Internal.Statement
|
||||
import Internal.Types hiding (sign)
|
||||
import Internal.Utils
|
||||
|
|
@ -151,9 +150,8 @@ fromShadow tx t@ShadowTransfer {stFrom, stTo, stDesc, stRatio} = do
|
|||
BudgetTx
|
||||
{ btMeta = btMeta $ bttTx tx
|
||||
, btWhen = btWhen $ bttTx tx
|
||||
, -- TODO what are these supposed to do?
|
||||
btFrom = BudgetSplit stFrom Nothing
|
||||
, btTo = BudgetSplit stTo Nothing
|
||||
, btFrom = stFrom
|
||||
, btTo = stTo
|
||||
, btValue = dec2Rat stRatio * (btValue $ bttTx tx)
|
||||
, 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?
|
||||
valRes <- valMatches smVal (btValue tx_)
|
||||
return $
|
||||
memberMaybe (bsAcnt $ btFrom tx_) smFrom
|
||||
&& memberMaybe (bsAcnt $ btTo tx_) smTo
|
||||
memberMaybe (btFrom tx_) smFrom
|
||||
&& memberMaybe (btTo tx_) smTo
|
||||
&& maybe True (`dateMatches` (btWhen tx_)) smDate
|
||||
&& valRes
|
||||
where
|
||||
|
|
@ -181,13 +179,13 @@ balanceTransfers ts = snd $ L.mapAccumR go initBals $ L.sortOn (btWhen . bttTx)
|
|||
M.fromList $
|
||||
fmap (,0) $
|
||||
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))
|
||||
lookupBal = M.findWithDefault (error "this should not happen")
|
||||
go bals btt =
|
||||
let tx = bttTx btt
|
||||
from = bsAcnt $ btFrom tx
|
||||
to = bsAcnt $ btTo tx
|
||||
from = btFrom tx
|
||||
to = btTo tx
|
||||
bal = lookupBal to bals
|
||||
x = amtToMove bal (bttType btt) (btValue tx)
|
||||
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 Target x = x - bal
|
||||
|
||||
-- TODO allow currency conversions here
|
||||
data BudgetSplit b = BudgetSplit
|
||||
{ bsAcnt :: !AcntID
|
||||
, bsBucket :: !(Maybe b)
|
||||
}
|
||||
|
||||
data BudgetMeta = BudgetMeta
|
||||
{ bmCommit :: !(Key CommitR)
|
||||
, bmCur :: !BudgetCurrency
|
||||
|
|
@ -213,8 +205,8 @@ data BudgetMeta = BudgetMeta
|
|||
data BudgetTx = BudgetTx
|
||||
{ btMeta :: !BudgetMeta
|
||||
, btWhen :: !Day
|
||||
, btFrom :: !(BudgetSplit IncomeBucket)
|
||||
, btTo :: !(BudgetSplit ExpenseBucket)
|
||||
, btFrom :: !AcntID
|
||||
, btTo :: !AcntID
|
||||
, btValue :: !Rational
|
||||
, btDesc :: !T.Text
|
||||
}
|
||||
|
|
@ -231,55 +223,52 @@ insertIncome
|
|||
whenHash CTIncome i (Right []) $ \c -> do
|
||||
let meta = BudgetMeta c (NoX incCurrency) name
|
||||
let balRes = balanceIncome i
|
||||
fromRes <- lift $ checkAcntType IncomeT incFrom (\j -> BudgetSplit j . Just)
|
||||
toRes <- lift $ expandTarget incToBal
|
||||
case concatEither3 balRes fromRes toRes (,,) of
|
||||
fromRes <- lift $ checkAcntType IncomeT incFrom
|
||||
case concatEither2 balRes fromRes (,) of
|
||||
Left es -> return $ Left es
|
||||
Right (balance, fromFun, to) ->
|
||||
Right (balance, from) ->
|
||||
fmap (fmap (concat . concat)) $
|
||||
withDates incWhen $ \day -> do
|
||||
let fromAllos b =
|
||||
fmap (fmap concat . concatEitherL)
|
||||
. mapM (lift . fromAllo day meta (fromFun b))
|
||||
pre <- fromAllos PreTax incPretax
|
||||
let fromAllos = fmap concat . mapM (lift . fromAllo day meta from)
|
||||
pre <- fromAllos incPretax
|
||||
tax <-
|
||||
concatEitherL
|
||||
<$> mapM (lift . fromTax day meta (fromFun IntraTax)) incTaxes
|
||||
post <- fromAllos PostTax incPosttax
|
||||
<$> mapM (lift . fromTax day meta from) incTaxes
|
||||
post <- fromAllos incPosttax
|
||||
let bal =
|
||||
BudgetTxType
|
||||
{ bttTx =
|
||||
BudgetTx
|
||||
{ btMeta = meta
|
||||
, btWhen = day
|
||||
, btFrom = fromFun PostTax
|
||||
, btTo = to
|
||||
, btFrom = from
|
||||
, btTo = incToBal
|
||||
, btValue = balance
|
||||
, btDesc = "balance after deductions"
|
||||
}
|
||||
, bttType = FixedAmt
|
||||
}
|
||||
return $ concatEithersL [Right [bal], tax, pre, post]
|
||||
return $ concatEithersL [Right [bal], tax, Right pre, Right post]
|
||||
|
||||
fromAllo
|
||||
:: MonadFinance m
|
||||
=> Day
|
||||
-> BudgetMeta
|
||||
-> BudgetSplit IncomeBucket
|
||||
-> AcntID
|
||||
-> Allocation
|
||||
-> m (EitherErr [BudgetTxType])
|
||||
-> m [BudgetTxType]
|
||||
fromAllo day meta from Allocation {alloPath, alloAmts} = do
|
||||
-- TODO this is going to be repeated a zillion times (might matter)
|
||||
res <- expandTarget alloPath
|
||||
return $ (\to -> fmap (toBT to) alloAmts) <$> res
|
||||
-- res <- expandTarget alloPath
|
||||
return $ fmap toBT alloAmts
|
||||
where
|
||||
toBT to (Amount desc v) =
|
||||
toBT (Amount desc v) =
|
||||
BudgetTxType
|
||||
{ bttTx =
|
||||
BudgetTx
|
||||
{ btFrom = from
|
||||
, btWhen = day
|
||||
, btTo = to
|
||||
, btTo = alloPath
|
||||
, btValue = dec2Rat v
|
||||
, btDesc = desc
|
||||
, btMeta = meta
|
||||
|
|
@ -291,18 +280,20 @@ fromTax
|
|||
:: MonadFinance m
|
||||
=> Day
|
||||
-> BudgetMeta
|
||||
-> BudgetSplit IncomeBucket
|
||||
-> AcntID
|
||||
-> Tax
|
||||
-> m (EitherErr BudgetTxType)
|
||||
fromTax day meta from Tax {taxAcnt = to, taxValue = v} =
|
||||
-- TODO this is going to be repeated a zillion times (might matter)
|
||||
checkAcntType ExpenseT to $ \to_ ->
|
||||
fromTax day meta from Tax {taxAcnt = to, taxValue = v} = do
|
||||
res <- checkAcntType ExpenseT to
|
||||
return $ fmap go res
|
||||
where
|
||||
go to_ =
|
||||
BudgetTxType
|
||||
{ bttTx =
|
||||
BudgetTx
|
||||
{ btFrom = from
|
||||
, btWhen = day
|
||||
, btTo = BudgetSplit to_ (Just Fixed)
|
||||
, btTo = to_
|
||||
, btValue = dec2Rat v
|
||||
, btDesc = ""
|
||||
, btMeta = meta
|
||||
|
|
@ -344,11 +335,7 @@ expandTransfer name t@Transfer {transAmounts, transTo, transCurrency, transFrom}
|
|||
whenHash CTExpense t (Right []) $ \key ->
|
||||
fmap (fmap concat . concatEithersL) $
|
||||
forM transAmounts $ \(TimeAmount (Amount desc v) atype pat) -> do
|
||||
-- TODO this is going to be repeated a zillion times (might matter)
|
||||
res <- lift $ expandTarget transTo
|
||||
case res of
|
||||
Left e -> return $ Left [e]
|
||||
Right to -> withDates pat $ \day ->
|
||||
withDates pat $ \day ->
|
||||
let meta =
|
||||
BudgetMeta
|
||||
{ bmCur = transCurrency
|
||||
|
|
@ -361,8 +348,8 @@ expandTransfer name t@Transfer {transAmounts, transTo, transCurrency, transFrom}
|
|||
BudgetTx
|
||||
{ btMeta = meta
|
||||
, btWhen = day
|
||||
, btFrom = BudgetSplit transFrom Nothing
|
||||
, btTo = to
|
||||
, btFrom = transFrom
|
||||
, btTo = transTo
|
||||
, btValue = dec2Rat v
|
||||
, btDesc = desc
|
||||
}
|
||||
|
|
@ -372,29 +359,18 @@ expandTransfer name t@Transfer {transAmounts, transTo, transCurrency, transFrom}
|
|||
|
||||
insertBudgetTx :: MonadFinance m => BudgetTx -> SqlPersistT m [InsertError]
|
||||
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
|
||||
insertPair sFrom sTo
|
||||
forM_ exchange $ \(xFrom, xTo) -> insertPair xFrom xTo
|
||||
where
|
||||
insertPair from to = do
|
||||
k <- insert $ TransactionR (bmCommit btMeta) btWhen btDesc
|
||||
insertBudgetLabel name k IncomeBucketR from btFrom
|
||||
insertBudgetLabel name k ExpenseBucketR to btTo
|
||||
name = bmName btMeta
|
||||
|
||||
insertBudgetLabel
|
||||
:: (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
|
||||
insertBudgetLabel k from
|
||||
insertBudgetLabel k to
|
||||
insertBudgetLabel k split = do
|
||||
sk <- insertSplit k split
|
||||
bk <- insert $ BudgetLabelR sk name
|
||||
forM_ (bsBucket bs) $ insert_ . bucketType bk
|
||||
insert_ $ BudgetLabelR sk $ bmName btMeta
|
||||
|
||||
type SplitPair = (KeySplit, KeySplit)
|
||||
|
||||
|
|
@ -425,34 +401,22 @@ splitPair from to cur val = case cur of
|
|||
, 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
|
||||
:: MonadFinance m
|
||||
=> AcntType
|
||||
-> AcntID
|
||||
-> (AcntID -> a)
|
||||
-> m (EitherErr a)
|
||||
-> m (EitherErr AcntID)
|
||||
checkAcntType t = checkAcntTypes (t :| [])
|
||||
|
||||
checkAcntTypes
|
||||
:: MonadFinance m
|
||||
=> NE.NonEmpty AcntType
|
||||
-> AcntID
|
||||
-> (AcntID -> a)
|
||||
-> m (EitherErr a)
|
||||
checkAcntTypes ts i f = (go =<<) <$> lookupAccountType i
|
||||
-> m (EitherErr AcntID)
|
||||
checkAcntTypes ts i = (go =<<) <$> lookupAccountType i
|
||||
where
|
||||
go t
|
||||
| t `L.elem` ts = Right $ f i
|
||||
| t `L.elem` ts = Right i
|
||||
| otherwise = Left $ AccountError i ts
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
|
|||
|
|
@ -6,7 +6,6 @@ module Internal.Statement
|
|||
where
|
||||
|
||||
import Data.Csv
|
||||
import Internal.Database.Model
|
||||
import Internal.Types
|
||||
import Internal.Utils
|
||||
import RIO
|
||||
|
|
|
|||
|
|
@ -1,5 +1,7 @@
|
|||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
module Internal.Types where
|
||||
|
||||
|
|
@ -7,6 +9,7 @@ import Data.Fix (Fix (..), foldFix)
|
|||
import Data.Functor.Foldable (embed)
|
||||
import qualified Data.Functor.Foldable.TH as TH
|
||||
import Database.Persist.Sql hiding (Desc, In, Statement)
|
||||
import Database.Persist.TH
|
||||
import Dhall hiding (embed, maybe)
|
||||
import Dhall.TH
|
||||
import Language.Haskell.TH.Syntax (Lift)
|
||||
|
|
@ -32,10 +35,7 @@ makeHaskellTypesWith
|
|||
, MultipleConstructors "MatchYMD" "(./dhall/Types.dhall).MatchYMD"
|
||||
, MultipleConstructors "MatchDate" "(./dhall/Types.dhall).MatchDate"
|
||||
, 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 "TransferTarget" "(./dhall/Types.dhall).TransferTarget"
|
||||
, MultipleConstructors "BudgetCurrency" "(./dhall/Types.dhall).BudgetCurrency"
|
||||
, SingleConstructor "Currency" "Currency" "(./dhall/Types.dhall).Currency"
|
||||
, SingleConstructor "Gregorian" "Gregorian" "(./dhall/Types.dhall).Gregorian"
|
||||
|
|
@ -62,36 +62,7 @@ makeHaskellTypesWith
|
|||
]
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- account tree
|
||||
|
||||
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
|
||||
-- lots of instances for dhall types
|
||||
|
||||
deriving instance Eq Currency
|
||||
|
||||
|
|
@ -99,49 +70,6 @@ deriving instance Lift 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 Ord TimeUnit
|
||||
|
|
@ -234,9 +162,6 @@ deriving instance Show DatePat
|
|||
|
||||
deriving instance Hashable DatePat
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Budget (projecting into the future)
|
||||
|
||||
deriving instance Eq Budget
|
||||
|
||||
deriving instance Hashable Budget
|
||||
|
|
@ -265,14 +190,6 @@ deriving instance Eq 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 = PersistText . T.pack . show
|
||||
|
||||
|
|
@ -283,30 +200,6 @@ fromPersistText what (PersistText t) = case readMaybe $ T.unpack t of
|
|||
fromPersistText what 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 Hashable AmountType
|
||||
|
|
@ -315,10 +208,6 @@ deriving instance Eq TimeAmount
|
|||
|
||||
deriving instance Hashable TimeAmount
|
||||
|
||||
deriving instance Eq TransferTarget
|
||||
|
||||
deriving instance Hashable TransferTarget
|
||||
|
||||
deriving instance Eq Transfer
|
||||
|
||||
deriving instance Hashable Transfer
|
||||
|
|
@ -335,18 +224,133 @@ deriving instance Eq 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
|
||||
= StmtManual !Manual
|
||||
| StmtImport !Import
|
||||
deriving (Eq, Hashable, Generic, FromDhall)
|
||||
|
||||
deriving instance Eq Manual
|
||||
|
||||
deriving instance Hashable Manual
|
||||
|
||||
data Split a v c = Split
|
||||
{ sAcnt :: !a
|
||||
, sValue :: !v
|
||||
|
|
@ -388,52 +392,6 @@ data Import = Import
|
|||
}
|
||||
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)
|
||||
-- can either be a raw (constant) value, a lookup from the record, or a map
|
||||
-- between the lookup and some other value
|
||||
|
|
@ -487,13 +445,47 @@ data Match re = Match
|
|||
deriving instance Show (Match T.Text)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Specialized dhall types
|
||||
-- DATABASE MODEL
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
deriving instance Eq Decimal
|
||||
|
||||
deriving instance Hashable Decimal
|
||||
|
||||
deriving instance Show Decimal
|
||||
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
|
||||
|]
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- database cache types
|
||||
|
|
@ -519,6 +511,57 @@ instance PersistField ConfigType where
|
|||
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
|
||||
|
||||
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
|
||||
|
||||
|
|
@ -554,8 +597,6 @@ data TxRecord = TxRecord
|
|||
|
||||
type Bounds = (Day, Natural)
|
||||
|
||||
-- type MaybeBounds = (Maybe Day, Maybe Day)
|
||||
|
||||
data Keyed a = Keyed
|
||||
{ kKey :: !Int64
|
||||
, kVal :: !a
|
||||
|
|
@ -588,6 +629,9 @@ 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)
|
||||
|
|
|
|||
Loading…
Reference in New Issue