ENH remove buckets entirely

This commit is contained in:
Nathan Dwarshuis 2023-02-26 18:57:40 -05:00
parent 61aabf45a3
commit 4e38f9ed8d
7 changed files with 295 additions and 419 deletions

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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, (^.))

View File

@ -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
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------

View File

@ -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

View File

@ -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)