From 4e38f9ed8da130091a51f91932d3da5cd3e738e8 Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Sun, 26 Feb 2023 18:57:40 -0500 Subject: [PATCH] ENH remove buckets entirely --- budget.cabal | 1 - dhall/Types.dhall | 23 +- lib/Internal/Database/Model.hs | 111 ---------- lib/Internal/Database/Ops.hs | 2 - lib/Internal/Insert.hs | 184 +++++++--------- lib/Internal/Statement.hs | 1 - lib/Internal/Types.hs | 392 ++++++++++++++++++--------------- 7 files changed, 295 insertions(+), 419 deletions(-) delete mode 100644 lib/Internal/Database/Model.hs diff --git a/budget.cabal b/budget.cabal index d2df83b..22bd659 100644 --- a/budget.cabal +++ b/budget.cabal @@ -26,7 +26,6 @@ source-repository head library exposed-modules: Internal.Config - Internal.Database.Model Internal.Database.Ops Internal.Insert Internal.Statement diff --git a/dhall/Types.dhall b/dhall/Types.dhall index e7fa3c7..de72dab 100644 --- a/dhall/Types.dhall +++ b/dhall/Types.dhall @@ -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 diff --git a/lib/Internal/Database/Model.hs b/lib/Internal/Database/Model.hs deleted file mode 100644 index 74790db..0000000 --- a/lib/Internal/Database/Model.hs +++ /dev/null @@ -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 diff --git a/lib/Internal/Database/Ops.hs b/lib/Internal/Database/Ops.hs index e961234..151f388 100644 --- a/lib/Internal/Database/Ops.hs +++ b/lib/Internal/Database/Ops.hs @@ -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, (^.)) diff --git a/lib/Internal/Insert.hs b/lib/Internal/Insert.hs index 2bc5939..df523a4 100644 --- a/lib/Internal/Insert.hs +++ b/lib/Internal/Insert.hs @@ -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,24 +280,26 @@ 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_ -> - BudgetTxType - { bttTx = - BudgetTx - { btFrom = from - , btWhen = day - , btTo = BudgetSplit to_ (Just Fixed) - , btValue = dec2Rat v - , btDesc = "" - , btMeta = meta - } - , bttType = FixedAmt - } +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 = to_ + , btValue = dec2Rat v + , btDesc = "" + , btMeta = meta + } + , bttType = FixedAmt + } balanceIncome :: Income -> EitherErr Rational balanceIncome @@ -344,57 +335,42 @@ 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 -> - let meta = - BudgetMeta - { bmCur = transCurrency - , bmCommit = key - , bmName = name - } - tx = - BudgetTxType - { bttTx = - BudgetTx - { btMeta = meta - , btWhen = day - , btFrom = BudgetSplit transFrom Nothing - , btTo = to - , btValue = dec2Rat v - , btDesc = desc - } - , bttType = atype - } - in return $ Right tx + withDates pat $ \day -> + let meta = + BudgetMeta + { bmCur = transCurrency + , bmCommit = key + , bmName = name + } + tx = + BudgetTxType + { bttTx = + BudgetTx + { btMeta = meta + , btWhen = day + , btFrom = transFrom + , btTo = transTo + , btValue = dec2Rat v + , btDesc = desc + } + , bttType = atype + } + in return $ Right tx 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 - sk <- insertSplit k split - bk <- insert $ BudgetLabelR sk name - forM_ (bsBucket bs) $ insert_ . bucketType bk + insertBudgetLabel k from + insertBudgetLabel k to + insertBudgetLabel k split = do + sk <- insertSplit k split + 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 -------------------------------------------------------------------------------- diff --git a/lib/Internal/Statement.hs b/lib/Internal/Statement.hs index a558bcb..dffc499 100644 --- a/lib/Internal/Statement.hs +++ b/lib/Internal/Statement.hs @@ -6,7 +6,6 @@ module Internal.Statement where import Data.Csv -import Internal.Database.Model import Internal.Types import Internal.Utils import RIO diff --git a/lib/Internal/Types.hs b/lib/Internal/Types.hs index 41f810c..c2c289b 100644 --- a/lib/Internal/Types.hs +++ b/lib/Internal/Types.hs @@ -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)