WIP track running balances in budget

This commit is contained in:
Nathan Dwarshuis 2023-02-12 16:23:32 -05:00
parent 88dec70ce6
commit e6a39cb5ea
11 changed files with 358 additions and 195 deletions

View File

@ -1,7 +1,8 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ImplicitPrelude #-}
module Main (main) where module Main (main) where
import Control.Monad.Reader
import qualified Data.Text.IO as TI import qualified Data.Text.IO as TI
import Internal.Config import Internal.Config
import Internal.Database.Ops import Internal.Database.Ops
@ -162,9 +163,9 @@ runSync c = do
case res of case res of
Left es -> throwIO $ InsertException es Left es -> throwIO $ InsertException es
Right s -> do Right s -> do
flip runReaderT (s $ takeDirectory c) $ do let run = mapReaderT $ flip runReaderT (s $ takeDirectory c)
es1 <- concat <$> mapM insertBudget (budget config) es1 <- concat <$> mapM (run . insertBudget) (budget config)
es2 <- insertStatements config es2 <- run $ insertStatements config
let es = es1 ++ es2 let es = es1 ++ es2
unless (null es) $ throwIO $ InsertException es unless (null es) $ throwIO $ InsertException es
where where

View File

@ -1,6 +1,6 @@
cabal-version: 1.12 cabal-version: 1.12
-- This file has been generated from package.yaml by hpack version 0.35.1. -- This file has been generated from package.yaml by hpack version 0.35.2.
-- --
-- see: https://github.com/sol/hpack -- see: https://github.com/sol/hpack
@ -36,6 +36,42 @@ library
Paths_budget Paths_budget
hs-source-dirs: hs-source-dirs:
lib/ lib/
default-extensions:
OverloadedStrings
FlexibleContexts
FlexibleInstances
InstanceSigs
MultiParamTypeClasses
EmptyCase
LambdaCase
MultiWayIf
NamedFieldPuns
TupleSections
DeriveFoldable
DeriveFunctor
DeriveGeneric
DeriveLift
DeriveTraversable
DerivingStrategies
DeriveDataTypeable
EmptyDataDecls
PartialTypeSignatures
GeneralizedNewtypeDeriving
StandaloneDeriving
BangPatterns
TypeOperators
ScopedTypeVariables
TypeApplications
ConstraintKinds
RankNTypes
GADTs
DefaultSignatures
NoImplicitPrelude
FunctionalDependencies
DataKinds
TypeFamilies
BinaryLiterals
ViewPatterns
ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wpartial-fields -Werror -O2 ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wpartial-fields -Werror -O2
build-depends: build-depends:
base >=4.12 && <10 base >=4.12 && <10
@ -50,6 +86,7 @@ library
, hashable , hashable
, lens >=5.0.1 , lens >=5.0.1
, monad-logger >=0.3.36 , monad-logger >=0.3.36
, mtl
, optparse-applicative , optparse-applicative
, persistent >=2.13.3.1 , persistent >=2.13.3.1
, persistent-sqlite >=2.13.1.0 , persistent-sqlite >=2.13.1.0
@ -67,6 +104,42 @@ executable pwncash
Paths_budget Paths_budget
hs-source-dirs: hs-source-dirs:
app app
default-extensions:
OverloadedStrings
FlexibleContexts
FlexibleInstances
InstanceSigs
MultiParamTypeClasses
EmptyCase
LambdaCase
MultiWayIf
NamedFieldPuns
TupleSections
DeriveFoldable
DeriveFunctor
DeriveGeneric
DeriveLift
DeriveTraversable
DerivingStrategies
DeriveDataTypeable
EmptyDataDecls
PartialTypeSignatures
GeneralizedNewtypeDeriving
StandaloneDeriving
BangPatterns
TypeOperators
ScopedTypeVariables
TypeApplications
ConstraintKinds
RankNTypes
GADTs
DefaultSignatures
NoImplicitPrelude
FunctionalDependencies
DataKinds
TypeFamilies
BinaryLiterals
ViewPatterns
ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wpartial-fields -Werror -O2 -threaded ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wpartial-fields -Werror -O2 -threaded
build-depends: build-depends:
base >=4.12 && <10 base >=4.12 && <10
@ -82,6 +155,7 @@ executable pwncash
, hashable , hashable
, lens >=5.0.1 , lens >=5.0.1
, monad-logger >=0.3.36 , monad-logger >=0.3.36
, mtl
, optparse-applicative , optparse-applicative
, persistent >=2.13.3.1 , persistent >=2.13.3.1
, persistent-sqlite >=2.13.1.0 , persistent-sqlite >=2.13.1.0

View File

@ -187,7 +187,9 @@ let IncomeBucket = < PreTax | IntraTax | PostTax >
let Amount = { amtValue : Decimal, amtDesc : Text } let Amount = { amtValue : Decimal, amtDesc : Text }
let TimeAmount = { taWhen : DatePat, taAmt : Amount } let AmountType = < FixedAmt | Percent | Target >
let TimeAmount = { taWhen : DatePat, taAmt : Amount, taAmtType : AmountType }
let Tax = { taxAcnt : AcntID, taxValue : Decimal } let Tax = { taxAcnt : AcntID, taxValue : Decimal }
@ -264,4 +266,5 @@ in { CurID
, Allocation , Allocation
, Amount , Amount
, TimeAmount , TimeAmount
, AmountType
} }

View File

@ -1,5 +1,3 @@
{-# LANGUAGE NoImplicitPrelude #-}
module Internal.Config module Internal.Config
( readConfig ( readConfig
-- , readYaml -- , readYaml

View File

@ -1,20 +1,6 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Internal.Database.Model where module Internal.Database.Model where
@ -84,13 +70,42 @@ data DBState = DBState
, kmStatementInterval :: !Bounds , kmStatementInterval :: !Bounds
, kmNewCommits :: ![Int] , kmNewCommits :: ![Int]
, kmConfigDir :: !FilePath , kmConfigDir :: !FilePath
, kmBoundsCache :: !(MVar (M.Map (Bounds, DatePat) [Day]))
} }
type MappingT m a = ReaderT DBState (SqlPersistT m) a type MappingT m = ReaderT DBState (SqlPersistT m)
type KeySplit = Split AccountRId Rational CurrencyRId type KeySplit = Split AccountRId Rational CurrencyRId
type KeyTx = Tx KeySplit type KeyTx = Tx KeySplit
type TreeR = Tree ([T.Text], AccountRId) 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,11 +1,3 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Internal.Database.Ops module Internal.Database.Ops
( migrate_ ( migrate_
, nukeTables , nukeTables
@ -48,6 +40,7 @@ migrate_ c more =
(openConnection c) (openConnection c)
( \backend -> ( \backend ->
flip runSqlConn backend $ do flip runSqlConn backend $ do
_ <- askLoggerIO
runMigration migrateAll runMigration migrateAll
more more
) )
@ -198,7 +191,8 @@ updateCurrencies cs = do
return $ currencyMap curs return $ currencyMap curs
currency2Record :: Currency -> Entity CurrencyR currency2Record :: Currency -> Entity CurrencyR
currency2Record c@Currency {..} = Entity (toKey c) $ CurrencyR curSymbol curFullname currency2Record c@Currency {curSymbol, curFullname} =
Entity (toKey c) $ CurrencyR curSymbol curFullname
currencyMap :: [Entity CurrencyR] -> CurrencyMap currencyMap :: [Entity CurrencyR] -> CurrencyMap
currencyMap = M.fromList . fmap (\e -> (currencyRSymbol $ entityVal e, entityKey e)) currencyMap = M.fromList . fmap (\e -> (currencyRSymbol $ entityVal e, entityKey e))
@ -291,7 +285,7 @@ xs !? n
n n
flattenAcntRoot :: AccountRoot -> [(AcntType, AccountTree)] flattenAcntRoot :: AccountRoot -> [(AcntType, AccountTree)]
flattenAcntRoot AccountRoot_ {..} = flattenAcntRoot AccountRoot_ {arIncome, arExpenses, arLiabilities, arAssets, arEquity} =
((IncomeT,) <$> arIncome) ((IncomeT,) <$> arIncome)
++ ((ExpenseT,) <$> arExpenses) ++ ((ExpenseT,) <$> arExpenses)
++ ((LiabilityT,) <$> arLiabilities) ++ ((LiabilityT,) <$> arLiabilities)
@ -315,7 +309,6 @@ getDBState c = do
am <- updateAccounts $ accounts c am <- updateAccounts $ accounts c
cm <- updateCurrencies $ currencies c cm <- updateCurrencies $ currencies c
hs <- updateHashes c hs <- updateHashes c
v <- newMVar M.empty
-- TODO not sure how I feel about this, probably will change this struct alot -- TODO not sure how I feel about this, probably will change this struct alot
-- in the future so whatever...for now -- in the future so whatever...for now
return $ concatEither2 bi si $ \b s f -> return $ concatEither2 bi si $ \b s f ->
@ -326,7 +319,6 @@ getDBState c = do
, kmStatementInterval = s , kmStatementInterval = s
, kmNewCommits = hs , kmNewCommits = hs
, kmConfigDir = f , kmConfigDir = f
, kmBoundsCache = v
} }
where where
bi = resolveBounds $ budgetInterval $ global c bi = resolveBounds $ budgetInterval $ global c

View File

@ -1,8 +1,3 @@
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Internal.Insert module Internal.Insert
( insertStatements ( insertStatements
, insertBudget , insertBudget
@ -17,6 +12,8 @@ import Internal.Statement
import Internal.Types hiding (sign) import Internal.Types hiding (sign)
import Internal.Utils import Internal.Utils
import RIO hiding (to) import RIO hiding (to)
import qualified RIO.List as L
import qualified RIO.Map as M
import qualified RIO.Text as T import qualified RIO.Text as T
import RIO.Time import RIO.Time
@ -43,7 +40,8 @@ expandModPat ModPat {mpStart = s, mpBy = b, mpUnit = u, mpRepeats = r} bs =
Year -> addGregorianYearsClip Year -> addGregorianYearsClip
expandCronPat :: Bounds -> CronPat -> EitherErrs [Day] expandCronPat :: Bounds -> CronPat -> EitherErrs [Day]
expandCronPat b CronPat {..} = concatEither3 yRes mRes dRes $ \ys ms ds -> expandCronPat b CronPat {cronYear, cronMonth, cronDay, cronWeekly} =
concatEither3 yRes mRes dRes $ \ys ms ds ->
filter validWeekday $ filter validWeekday $
mapMaybe (uncurry3 toDay) $ mapMaybe (uncurry3 toDay) $
takeWhile (\((y, _), m, d) -> (y, m, d) <= (yb1, mb1, db1)) $ takeWhile (\((y, _), m, d) -> (y, m, d) <= (yb1, mb1, db1)) $
@ -95,36 +93,36 @@ dayToWeekday :: Day -> Int
dayToWeekday (ModifiedJulianDay d) = mod (fromIntegral d + 2) 7 dayToWeekday (ModifiedJulianDay d) = mod (fromIntegral d + 2) 7
withDates withDates
:: MonadUnliftIO m :: MonadFinance m
=> DatePat => DatePat
-> (Day -> MappingT m a) -> (Day -> SqlPersistT m a)
-> MappingT m (EitherErrs [a]) -> SqlPersistT m (EitherErrs [a])
withDates dp f = do withDates dp f = do
bounds <- asks kmBudgetInterval bounds <- lift $ askDBState kmBudgetInterval
let days = expandDatePat bounds dp let days = expandDatePat bounds dp
mapM (mapM f) days mapM (mapM f) days
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- budget -- budget
insertBudget :: MonadUnliftIO m => Budget -> MappingT m [InsertError] insertBudget :: MonadFinance m => Budget -> SqlPersistT m [InsertError]
insertBudget Budget {budgetLabel = name, income = is, transfers = es} = do insertBudget Budget {budgetLabel = name, income = is, transfers = es} = do
es1 <- mapM (insertIncome name) is es1 <- mapM (insertIncome name) is
es2 <- mapM (insertTransfer name) es es2 <- insertTransfers name es
return $ concat $ es1 ++ es2 return $ concat es1 ++ es2
-- TODO this hashes twice (not that it really matters) -- TODO this hashes twice (not that it really matters)
whenHash whenHash
:: (Hashable a, MonadUnliftIO m) :: (Hashable a, MonadFinance m)
=> ConfigType => ConfigType
-> a -> a
-> b -> b
-> (Key CommitR -> MappingT m b) -> (Key CommitR -> SqlPersistT m b)
-> MappingT m b -> SqlPersistT m b
whenHash t o def f = do whenHash t o def f = do
let h = hash o let h = hash o
hs <- asks kmNewCommits hs <- lift $ askDBState kmNewCommits
if h `elem` hs then f =<< lift (insert $ CommitR h t) else return def if h `elem` hs then f =<< insert (CommitR h t) else return def
-- TODO allow currency conversions here -- TODO allow currency conversions here
data BudgetSplit b = BudgetSplit data BudgetSplit b = BudgetSplit
@ -147,8 +145,10 @@ data BudgetTx = BudgetTx
, btDesc :: !T.Text , btDesc :: !T.Text
} }
insertIncome :: MonadUnliftIO m => T.Text -> Income -> MappingT m [InsertError] insertIncome :: MonadFinance m => T.Text -> Income -> SqlPersistT m [InsertError]
insertIncome name i@Income {..} = insertIncome
name
i@Income {incWhen, incCurrency, incFrom, incPretax, incPosttax, incTaxes, incToBal} =
whenHash CTIncome i [] $ \c -> whenHash CTIncome i [] $ \c ->
unlessLeft (balanceIncome i) $ \balance -> do unlessLeft (balanceIncome i) $ \balance -> do
res <- withDates incWhen $ \day -> do res <- withDates incWhen $ \day -> do
@ -174,7 +174,8 @@ fromAllo
-> Maybe IncomeBucket -> Maybe IncomeBucket
-> Allocation -> Allocation
-> [BudgetTx] -> [BudgetTx]
fromAllo meta from ib Allocation {..} = fmap (toBT alloPath) alloAmts fromAllo meta from ib Allocation {alloPath, alloAmts, alloBucket} =
fmap (toBT alloPath) alloAmts
where where
toBT to (Amount desc v) = toBT to (Amount desc v) =
BudgetTx BudgetTx
@ -215,33 +216,98 @@ sumAllocation = sum . fmap (dec2Rat . amtValue) . alloAmts
sumTaxes :: [Tax] -> Rational sumTaxes :: [Tax] -> Rational
sumTaxes = sum . fmap (dec2Rat . taxValue) sumTaxes = sum . fmap (dec2Rat . taxValue)
insertTransfer :: MonadUnliftIO m => T.Text -> Transfer -> MappingT m [InsertError] insertTransfers :: MonadFinance m => T.Text -> [Transfer] -> SqlPersistT m [InsertError]
insertTransfer name t@Transfer {..} = insertTransfers name ts = do
fmap concat $ whenHash CTExpense t [] $ \key -> do res <- expandTransfers name ts
forM transAmounts $ \(TimeAmount amt pat) -> do unlessLefts res $ \txs ->
res <- withDates pat $ \day -> insertBudgetTx $ budgetTx amt day key fmap concat <$> mapM insertBudgetTx $ balanceTransfers txs
unlessLefts res $ return . concat
expandTransfers :: MonadFinance m => T.Text -> [Transfer] -> SqlPersistT m (EitherErrs [TransferTx])
expandTransfers name ts = do
txs <- mapM (expandTransfer name) ts
return $ L.sortOn (bmWhen . trxMeta) . concat <$> concatEithersL txs
-- TODO the entire budget needs to have this process applied to it
balanceTransfers :: [TransferTx] -> [BudgetTx]
balanceTransfers ts = snd $ L.mapAccumR go initBals $ L.sortOn (bmWhen . trxMeta) ts
where where
meta d c = initBals = M.fromList $ fmap (,0) $ L.nub $ (fmap trxTo ts ++ fmap trxTo ts)
updateBal x = M.update (Just . (+ x))
lookupBal = M.findWithDefault (error "this should not happen")
go bals TransferTx {trxMeta, trxFrom, trxTo, trxValue, trxType, trxDesc} =
let bal = lookupBal trxTo bals
x = amtToMove bal trxType trxValue
t =
BudgetTx
{ btMeta = trxMeta
, btFrom = BudgetSplit trxFrom Nothing
, btTo = BudgetSplit trxTo Nothing
, btValue = x
, btDesc = trxDesc
}
in (updateBal x trxFrom $ updateBal (-x) trxFrom bals, t)
-- TODO might need to query signs to make this intuitive; as it is this will
-- probably work, but for credit accounts I might need to supply a negative
-- target value
amtToMove _ FixedAmt x = x
amtToMove bal Percent x = -(x / 100 * bal)
amtToMove bal Target x = x - bal
expandTransfer :: MonadFinance m => T.Text -> Transfer -> SqlPersistT m (EitherErrs [TransferTx])
expandTransfer name t@Transfer {transAmounts, transTo, transCurrency, transFrom} =
whenHash CTExpense t (Right []) $ \key -> do
res <- forM transAmounts $ \(TimeAmount (Amount desc v) atype pat) ->
withDates pat $ \day ->
let meta =
BudgetMeta BudgetMeta
{ bmWhen = d { bmWhen = day
, bmCur = transCurrency , bmCur = transCurrency
, bmCommit = c , bmCommit = key
, bmName = name , bmName = name
} }
budgetTx (Amount desc v) d c = in return $
BudgetTx TransferTx
{ btMeta = meta d c { trxMeta = meta
, btFrom = BudgetSplit transFrom Nothing , trxFrom = transFrom
, btTo = BudgetSplit transTo Nothing , trxTo = transTo
, btValue = dec2Rat v , trxValue = dec2Rat v
, btDesc = desc , trxType = atype
, trxDesc = desc
}
return $ concat <$> concatEithersL res
data TransferTx = TransferTx
{ trxMeta :: !BudgetMeta
, trxFrom :: !AcntID
, trxTo :: !AcntID
, trxValue :: !Rational
, trxType :: AmountType
, trxDesc :: !T.Text
} }
insertBudgetTx :: MonadUnliftIO m => BudgetTx -> MappingT m [InsertError] -- amountBalance
insertBudgetTx BudgetTx {..} = do -- :: (MonadFinance m, MonadBalance m)
-- => AmountType
-- -> AcntID
-- -> Rational
-- -> SqlPersistT m (EitherErr Rational)
-- amountBalance at i v = do
-- res <- lookupAccountKey i
-- case res of
-- Left e -> return $ Left e
-- Right k -> do
-- b <- lookupBalance k
-- return $ Right $ case at of
-- FixedAmt -> v
-- -- TODO what is the sign for this?
-- Percent -> v / 100 * b
-- -- TODO what is the sign for this?
-- Target -> b - v
insertBudgetTx :: MonadFinance m => BudgetTx -> SqlPersistT m [InsertError]
insertBudgetTx BudgetTx {btFrom, btTo, btMeta, btValue, btDesc} = do
res <- splitPair (bsAcnt btFrom) (bsAcnt btTo) (bmCur btMeta) btValue res <- splitPair (bsAcnt btFrom) (bsAcnt btTo) (bmCur btMeta) btValue
unlessLefts_ res $ \(sFrom, sTo) -> lift $ do unlessLefts_ res $ \(sFrom, sTo) -> do
k <- insert $ TransactionR (bmCommit btMeta) (bmWhen btMeta) btDesc k <- insert $ TransactionR (bmCommit btMeta) (bmWhen btMeta) btDesc
insertBudgetLabel name k IncomeBucketR sFrom btFrom insertBudgetLabel name k IncomeBucketR sFrom btFrom
insertBudgetLabel name k ExpenseBucketR sTo btTo insertBudgetLabel name k ExpenseBucketR sTo btTo
@ -262,12 +328,12 @@ insertBudgetLabel name k bucketType split bs = do
forM_ (bsBucket bs) $ insert_ . bucketType bk forM_ (bsBucket bs) $ insert_ . bucketType bk
splitPair splitPair
:: MonadUnliftIO m :: MonadFinance m
=> AcntID => AcntID
-> AcntID -> AcntID
-> CurID -> CurID
-> Rational -> Rational
-> MappingT m (EitherErrs (KeySplit, KeySplit)) -> SqlPersistT m (EitherErrs (KeySplit, KeySplit))
splitPair from to cur val = do splitPair from to cur val = do
s1 <- split from (-val) s1 <- split from (-val)
s2 <- split to val s2 <- split to val
@ -285,14 +351,14 @@ splitPair from to cur val = do
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- statements -- statements
insertStatements :: MonadUnliftIO m => Config -> MappingT m [InsertError] insertStatements :: MonadFinance m => Config -> SqlPersistT m [InsertError]
insertStatements conf = concat <$> mapM insertStatement (statements conf) insertStatements conf = concat <$> mapM insertStatement (statements conf)
insertStatement :: MonadUnliftIO m => Statement -> MappingT m [InsertError] insertStatement :: MonadFinance m => Statement -> SqlPersistT m [InsertError]
insertStatement (StmtManual m) = insertManual m insertStatement (StmtManual m) = insertManual m
insertStatement (StmtImport i) = insertImport i insertStatement (StmtImport i) = insertImport i
insertManual :: MonadUnliftIO m => Manual -> MappingT m [InsertError] insertManual :: MonadFinance m => Manual -> SqlPersistT m [InsertError]
insertManual insertManual
m@Manual m@Manual
{ manualDate = dp { manualDate = dp
@ -303,23 +369,23 @@ insertManual
, manualDesc = e , manualDesc = e
} = do } = do
whenHash CTManual m [] $ \c -> do whenHash CTManual m [] $ \c -> do
bounds <- asks kmStatementInterval bounds <- lift $ askDBState kmStatementInterval
-- let days = expandDatePat bounds dp -- let days = expandDatePat bounds dp
let dayRes = expandDatePat bounds dp let dayRes = expandDatePat bounds dp
unlessLefts dayRes $ \days -> do unlessLefts dayRes $ \days -> do
txRes <- mapM tx days txRes <- mapM tx days
unlessLefts_ (concatEithersL txRes) $ lift . mapM_ (insertTx c) unlessLefts_ (concatEithersL txRes) $ mapM_ (insertTx c)
where where
tx day = txPair day from to u (dec2Rat v) e tx day = txPair day from to u (dec2Rat v) e
insertImport :: MonadUnliftIO m => Import -> MappingT m [InsertError] insertImport :: MonadFinance m => Import -> SqlPersistT m [InsertError]
insertImport i = whenHash CTImport i [] $ \c -> do insertImport i = whenHash CTImport i [] $ \c -> do
-- TODO this isn't efficient, the whole file will be read and maybe no -- TODO this isn't efficient, the whole file will be read and maybe no
-- transactions will be desired -- transactions will be desired
recoverIO (readImport i) $ \r -> unlessLefts r $ \bs -> do recoverIO (lift $ readImport i) $ \r -> unlessLefts r $ \bs -> do
bounds <- expandBounds <$> asks kmStatementInterval bounds <- expandBounds <$> lift (askDBState kmStatementInterval)
res <- mapM resolveTx $ filter (inBounds bounds . txDate) bs res <- mapM resolveTx $ filter (inBounds bounds . txDate) bs
unlessLefts_ (concatEithersL res) $ lift . mapM_ (insertTx c) unlessLefts_ (concatEithersL res) $ mapM_ (insertTx c)
where where
recoverIO x rest = do recoverIO x rest = do
res <- tryIO x res <- tryIO x
@ -333,14 +399,14 @@ insertImport i = whenHash CTImport i [] $ \c -> do
-- low-level transaction stuff -- low-level transaction stuff
txPair txPair
:: MonadUnliftIO m :: MonadFinance m
=> Day => Day
-> AcntID -> AcntID
-> AcntID -> AcntID
-> CurID -> CurID
-> Rational -> Rational
-> T.Text -> T.Text
-> MappingT m (EitherErrs KeyTx) -> SqlPersistT m (EitherErrs KeyTx)
txPair day from to cur val desc = resolveTx tx txPair day from to cur val desc = resolveTx tx
where where
split a v = Split {sAcnt = a, sValue = v, sComment = "", sCurrency = cur} split a v = Split {sAcnt = a, sValue = v, sComment = "", sCurrency = cur}
@ -352,12 +418,12 @@ txPair day from to cur val desc = resolveTx tx
, txSplits = [split from (-val), split to val] , txSplits = [split from (-val), split to val]
} }
resolveTx :: MonadUnliftIO m => BalTx -> MappingT m (EitherErrs KeyTx) resolveTx :: MonadFinance m => BalTx -> SqlPersistT m (EitherErrs KeyTx)
resolveTx t@Tx {txSplits = ss} = do resolveTx t@Tx {txSplits = ss} = do
res <- concatEithersL <$> mapM resolveSplit ss res <- concatEithersL <$> mapM resolveSplit ss
return $ fmap (\kss -> t {txSplits = kss}) res return $ fmap (\kss -> t {txSplits = kss}) res
resolveSplit :: MonadUnliftIO m => BalSplit -> MappingT m (EitherErrs KeySplit) resolveSplit :: MonadFinance m => BalSplit -> SqlPersistT m (EitherErrs KeySplit)
resolveSplit s@Split {sAcnt = p, sCurrency = c, sValue = v} = do resolveSplit s@Split {sAcnt = p, sCurrency = c, sValue = v} = do
aid <- lookupAccountKey p aid <- lookupAccountKey p
cid <- lookupCurrency c cid <- lookupCurrency c
@ -380,14 +446,14 @@ insertSplit :: MonadUnliftIO m => Key TransactionR -> KeySplit -> SqlPersistT m
insertSplit t Split {sAcnt = aid, sCurrency = cid, sValue = v, sComment = c} = do insertSplit t Split {sAcnt = aid, sCurrency = cid, sValue = v, sComment = c} = do
insert $ SplitR t cid aid c v insert $ SplitR t cid aid c v
lookupAccount :: MonadUnliftIO m => AcntID -> MappingT m (EitherErr (Key AccountR, AcntSign)) lookupAccount :: MonadFinance m => AcntID -> SqlPersistT m (EitherErr (Key AccountR, AcntSign))
lookupAccount p = lookupErr (DBKey AcntField) p <$> asks kmAccount lookupAccount p = lookupErr (DBKey AcntField) p <$> lift (askDBState kmAccount)
lookupAccountKey :: MonadUnliftIO m => AcntID -> MappingT m (EitherErr (Key AccountR)) lookupAccountKey :: MonadFinance m => AcntID -> SqlPersistT m (EitherErr (Key AccountR))
lookupAccountKey = fmap (fmap fst) . lookupAccount lookupAccountKey = fmap (fmap fst) . lookupAccount
lookupAccountSign :: MonadUnliftIO m => AcntID -> MappingT m (EitherErr AcntSign) lookupAccountSign :: MonadFinance m => AcntID -> SqlPersistT m (EitherErr AcntSign)
lookupAccountSign = fmap (fmap snd) . lookupAccount lookupAccountSign = fmap (fmap snd) . lookupAccount
lookupCurrency :: MonadUnliftIO m => T.Text -> MappingT m (EitherErr (Key CurrencyR)) lookupCurrency :: MonadFinance m => T.Text -> SqlPersistT m (EitherErr (Key CurrencyR))
lookupCurrency c = lookupErr (DBKey CurField) c <$> asks kmCurrency lookupCurrency c = lookupErr (DBKey CurField) c <$> lift (askDBState kmCurrency)

View File

@ -1,8 +1,4 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Internal.Statement module Internal.Statement
( readImport ( readImport
@ -24,7 +20,7 @@ import qualified RIO.Vector as V
-- TODO this probably won't scale well (pipes?) -- TODO this probably won't scale well (pipes?)
readImport :: MonadUnliftIO m => Import -> MappingT m (EitherErrs [BalTx]) readImport :: MonadFinance m => Import -> m (EitherErrs [BalTx])
readImport Import {..} = do readImport Import {..} = do
let ores = plural $ compileOptions impTxOpts let ores = plural $ compileOptions impTxOpts
let cres = concatEithersL $ compileMatch <$> impMatches let cres = concatEithersL $ compileMatch <$> impMatches
@ -37,14 +33,14 @@ readImport Import {..} = do
Left es -> return $ Left es Left es -> return $ Left es
readImport_ readImport_
:: MonadUnliftIO m :: MonadFinance m
=> Natural => Natural
-> Word -> Word
-> TxOptsRe -> TxOptsRe
-> FilePath -> FilePath
-> MappingT m (EitherErr [TxRecord]) -> m (EitherErr [TxRecord])
readImport_ n delim tns p = do readImport_ n delim tns p = do
dir <- asks kmConfigDir dir <- askDBState kmConfigDir
bs <- liftIO $ BL.readFile $ dir </> p bs <- liftIO $ BL.readFile $ dir </> p
case decodeByNameWithP (parseTxRecord p tns) opts $ skip bs of case decodeByNameWithP (parseTxRecord p tns) opts $ skip bs of
Left m -> return $ Left $ ParseError $ T.pack m Left m -> return $ Left $ ParseError $ T.pack m

View File

@ -1,17 +1,5 @@
{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Internal.Types where module Internal.Types where
@ -45,6 +33,7 @@ makeHaskellTypesWith
, MultipleConstructors "SplitNum" "(./dhall/Types.dhall).SplitNum" , MultipleConstructors "SplitNum" "(./dhall/Types.dhall).SplitNum"
, MultipleConstructors "ExpenseBucket" "(./dhall/Types.dhall).ExpenseBucket" , MultipleConstructors "ExpenseBucket" "(./dhall/Types.dhall).ExpenseBucket"
, MultipleConstructors "IncomeBucket" "(./dhall/Types.dhall).IncomeBucket" , MultipleConstructors "IncomeBucket" "(./dhall/Types.dhall).IncomeBucket"
, MultipleConstructors "AmountType" "(./dhall/Types.dhall).AmountType"
, 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"
, SingleConstructor "GregorianM" "GregorianM" "(./dhall/Types.dhall).GregorianM" , SingleConstructor "GregorianM" "GregorianM" "(./dhall/Types.dhall).GregorianM"
@ -303,6 +292,10 @@ instance PersistField ExpenseBucket where
instance PersistFieldSql ExpenseBucket where instance PersistFieldSql ExpenseBucket where
sqlType _ = SqlString sqlType _ = SqlString
deriving instance Eq AmountType
deriving instance Hashable AmountType
deriving instance Eq TimeAmount deriving instance Eq TimeAmount
deriving instance Hashable TimeAmount deriving instance Hashable TimeAmount

View File

@ -1,8 +1,3 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Internal.Utils module Internal.Utils
( compareDate ( compareDate
, inBounds , inBounds
@ -78,14 +73,14 @@ xGregToDay :: XGregorian -> Day
xGregToDay XGregorian {xgYear = y, xgMonth = m, xgDay = d} = fromGregorian (fromIntegral y) m d xGregToDay XGregorian {xgYear = y, xgMonth = m, xgDay = d} = fromGregorian (fromIntegral y) m d
gregTup :: Gregorian -> (Integer, Int, Int) gregTup :: Gregorian -> (Integer, Int, Int)
gregTup Gregorian {..} = gregTup Gregorian {gYear, gMonth, gDay} =
( fromIntegral gYear ( fromIntegral gYear
, fromIntegral gMonth , fromIntegral gMonth
, fromIntegral gDay , fromIntegral gDay
) )
gregMTup :: GregorianM -> (Integer, Int) gregMTup :: GregorianM -> (Integer, Int)
gregMTup GregorianM {..} = gregMTup GregorianM {gmYear, gmMonth} =
( fromIntegral gmYear ( fromIntegral gmYear
, fromIntegral gmMonth , fromIntegral gmMonth
) )
@ -145,7 +140,9 @@ expandBounds (d, n) = (d, addDays (fromIntegral n + 1) d)
-- matching -- matching
matches :: MatchRe -> TxRecord -> EitherErrs (MatchRes RawTx) matches :: MatchRe -> TxRecord -> EitherErrs (MatchRes RawTx)
matches Match {..} r@TxRecord {..} = do matches
Match {mTx, mOther, mVal, mDate, mDesc}
r@TxRecord {trDate, trAmount, trDesc, trOther} = do
res <- concatEither3 val other desc $ \x y z -> x && y && z res <- concatEither3 val other desc $ \x y z -> x && y && z
if date && res if date && res
then maybe (Right MatchSkip) (fmap MatchPass . convert) mTx then maybe (Right MatchSkip) (fmap MatchPass . convert) mTx
@ -158,7 +155,7 @@ matches Match {..} r@TxRecord {..} = do
convert (ToTx cur a ss) = toTx cur a ss r convert (ToTx cur a ss) = toTx cur a ss r
toTx :: SplitCur -> SplitAcnt -> [ExpSplit] -> TxRecord -> EitherErrs RawTx toTx :: SplitCur -> SplitAcnt -> [ExpSplit] -> TxRecord -> EitherErrs RawTx
toTx sc sa toSplits r@TxRecord {..} = toTx sc sa toSplits r@TxRecord {trAmount, trDate, trDesc} =
concatEithers2 acRes ssRes $ \(a_, c_) ss_ -> concatEithers2 acRes ssRes $ \(a_, c_) ss_ ->
let fromSplit = let fromSplit =
Split Split
@ -178,7 +175,7 @@ toTx sc sa toSplits r@TxRecord {..} =
ssRes = concatEithersL $ fmap (resolveSplit r) toSplits ssRes = concatEithersL $ fmap (resolveSplit r) toSplits
valMatches :: MatchVal -> Rational -> EitherErr Bool valMatches :: MatchVal -> Rational -> EitherErr Bool
valMatches MatchVal {..} x valMatches MatchVal {mvDen, mvSign, mvNum, mvPrec} x
| Just d_ <- mvDen, d_ >= p = Left $ MatchValPrecisionError d_ p | Just d_ <- mvDen, d_ >= p = Left $ MatchValPrecisionError d_ p
| otherwise = | otherwise =
Right $ Right $
@ -251,8 +248,9 @@ parseRational (pat, re) s = case matchGroupsMaybe s re of
_ -> msg "malformed decimal" _ -> msg "malformed decimal"
where where
readT what t = case readMaybe $ T.unpack t of readT what t = case readMaybe $ T.unpack t of
Just d -> return $ fromInteger d Just d -> return d
_ -> msg $ T.unwords ["could not parse", what, t] _ -> msg $ T.unwords ["could not parse", what, t]
msg :: MonadFail m => T.Text -> m a
msg m = msg m =
fail $ fail $
T.unpack $ T.unpack $
@ -296,7 +294,7 @@ fmtRational precision x = T.concat [s, txt n', ".", pad 2 "0" $ txt d']
pad i c z = T.append (T.replicate (i - T.length z) c) z pad i c z = T.append (T.replicate (i - T.length z) c) z
dec2Rat :: Decimal -> Rational dec2Rat :: Decimal -> Rational
dec2Rat D {..} = dec2Rat D {sign, whole, decimal, precision} =
k * (fromIntegral whole + (fromIntegral decimal % (10 ^ precision))) k * (fromIntegral whole + (fromIntegral decimal % (10 ^ precision)))
where where
k = if sign then 1 else -1 k = if sign then 1 else -1
@ -364,7 +362,7 @@ showError other = (: []) $ case other of
splits = T.intercalate ", " $ fmap (singleQuote . showSplit) rss splits = T.intercalate ", " $ fmap (singleQuote . showSplit) rss
showGregorian_ :: Gregorian -> T.Text showGregorian_ :: Gregorian -> T.Text
showGregorian_ Gregorian {..} = T.intercalate "-" $ showT <$> [gYear, gMonth, gDay] showGregorian_ Gregorian {gYear, gMonth, gDay} = T.intercalate "-" $ showT <$> [gYear, gMonth, gDay]
showTx :: TxRecord -> T.Text showTx :: TxRecord -> T.Text
showTx TxRecord {trDate = d, trAmount = v, trDesc = e, trFile = f} = showTx TxRecord {trDate = d, trAmount = v, trDesc = e, trFile = f} =
@ -428,7 +426,8 @@ showYMD_ md =
showMatchVal :: MatchVal -> Maybe T.Text showMatchVal :: MatchVal -> Maybe T.Text
showMatchVal MatchVal {mvSign = Nothing, mvNum = Nothing, mvDen = Nothing} = Nothing showMatchVal MatchVal {mvSign = Nothing, mvNum = Nothing, mvDen = Nothing} = Nothing
showMatchVal MatchVal {..} = Just $ singleQuote $ keyVals [(k, v) | (k, Just v) <- kvs] showMatchVal MatchVal {mvNum, mvDen, mvSign, mvPrec} =
Just $ singleQuote $ keyVals [(k, v) | (k, Just v) <- kvs]
where where
kvs = kvs =
[ ("sign", (\s -> if s then "+" else "-") <$> mvSign) [ ("sign", (\s -> if s then "+" else "-") <$> mvSign)

View File

@ -10,15 +10,59 @@ extra-source-files:
- README.md - README.md
- ChangeLog.md - ChangeLog.md
# Metadata used when publishing your package
# synopsis: Short description of your package # synopsis: Short description of your package
# category: Web # category: Web
# To avoid duplicated efforts in documentation and dealing with the
# complications of embedding Haddock markup inside cabal files, it is
# common to point users to the README.md file.
description: Please see the README on GitHub at <https://github.com/ndwarshuis/budget#readme> description: Please see the README on GitHub at <https://github.com/ndwarshuis/budget#readme>
default-extensions:
- OverloadedStrings
- FlexibleContexts
- FlexibleInstances
- InstanceSigs
- MultiParamTypeClasses
- EmptyCase
- LambdaCase
- MultiWayIf
- NamedFieldPuns
- TupleSections
- DeriveFoldable
- DeriveFunctor
- DeriveGeneric
- DeriveLift
- DeriveTraversable
- DerivingStrategies
- DeriveDataTypeable
- EmptyDataDecls
- PartialTypeSignatures
- GeneralizedNewtypeDeriving
- StandaloneDeriving
- BangPatterns
- TypeOperators
- ScopedTypeVariables
- TypeApplications
- ConstraintKinds
- RankNTypes
- GADTs
- DefaultSignatures
- NoImplicitPrelude
- FunctionalDependencies
- DataKinds
- TypeFamilies
- BinaryLiterals
- ViewPatterns
ghc-options:
- -Wall
- -Wcompat
- -Widentities
- -Wincomplete-record-updates
- -Wincomplete-uni-patterns
- -Wredundant-constraints
- -Wpartial-fields
- -Werror
- -O2
dependencies: dependencies:
- base >= 4.12 && < 10 - base >= 4.12 && < 10
- rio >= 0.1.21.0 - rio >= 0.1.21.0
@ -41,34 +85,16 @@ dependencies:
- recursion-schemes - recursion-schemes
- data-fix - data-fix
- filepath - filepath
- mtl
library: library:
source-dirs: lib/ source-dirs: lib/
ghc-options:
- -Wall
- -Wcompat
- -Widentities
- -Wincomplete-record-updates
- -Wincomplete-uni-patterns
- -Wredundant-constraints
- -Wpartial-fields
- -Werror
- -O2
executables: executables:
pwncash: pwncash:
main: Main.hs main: Main.hs
source-dirs: app source-dirs: app
ghc-options: ghc-options:
- -Wall
- -Wcompat
- -Widentities
- -Wincomplete-record-updates
- -Wincomplete-uni-patterns
- -Wredundant-constraints
- -Wpartial-fields
- -Werror
- -O2
- -threaded - -threaded
dependencies: dependencies:
- budget - budget