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
exposed-modules:
Internal.Config
Internal.Database.Model
Internal.Database.Ops
Internal.Insert
Internal.Statement

View File

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

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

View File

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

View File

@ -6,7 +6,6 @@ module Internal.Statement
where
import Data.Csv
import Internal.Database.Model
import Internal.Types
import Internal.Utils
import RIO

View File

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