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
import Control.Monad.Reader
import qualified Data.Text.IO as TI
import Internal.Config
import Internal.Database.Ops
@ -162,9 +163,9 @@ runSync c = do
case res of
Left es -> throwIO $ InsertException es
Right s -> do
flip runReaderT (s $ takeDirectory c) $ do
es1 <- concat <$> mapM insertBudget (budget config)
es2 <- insertStatements config
let run = mapReaderT $ flip runReaderT (s $ takeDirectory c)
es1 <- concat <$> mapM (run . insertBudget) (budget config)
es2 <- run $ insertStatements config
let es = es1 ++ es2
unless (null es) $ throwIO $ InsertException es
where

View File

@ -1,6 +1,6 @@
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
@ -36,6 +36,42 @@ library
Paths_budget
hs-source-dirs:
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
build-depends:
base >=4.12 && <10
@ -50,6 +86,7 @@ library
, hashable
, lens >=5.0.1
, monad-logger >=0.3.36
, mtl
, optparse-applicative
, persistent >=2.13.3.1
, persistent-sqlite >=2.13.1.0
@ -67,6 +104,42 @@ executable pwncash
Paths_budget
hs-source-dirs:
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
build-depends:
base >=4.12 && <10
@ -82,6 +155,7 @@ executable pwncash
, hashable
, lens >=5.0.1
, monad-logger >=0.3.36
, mtl
, optparse-applicative
, persistent >=2.13.3.1
, persistent-sqlite >=2.13.1.0

View File

@ -187,7 +187,9 @@ let IncomeBucket = < PreTax | IntraTax | PostTax >
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 }
@ -264,4 +266,5 @@ in { CurID
, Allocation
, Amount
, TimeAmount
, AmountType
}

View File

@ -1,5 +1,3 @@
{-# LANGUAGE NoImplicitPrelude #-}
module Internal.Config
( readConfig
-- , 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 ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Internal.Database.Model where
@ -84,13 +70,42 @@ data DBState = DBState
, kmStatementInterval :: !Bounds
, kmNewCommits :: ![Int]
, 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 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,11 +1,3 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Internal.Database.Ops
( migrate_
, nukeTables
@ -48,6 +40,7 @@ migrate_ c more =
(openConnection c)
( \backend ->
flip runSqlConn backend $ do
_ <- askLoggerIO
runMigration migrateAll
more
)
@ -198,7 +191,8 @@ updateCurrencies cs = do
return $ currencyMap curs
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 = M.fromList . fmap (\e -> (currencyRSymbol $ entityVal e, entityKey e))
@ -291,7 +285,7 @@ xs !? n
n
flattenAcntRoot :: AccountRoot -> [(AcntType, AccountTree)]
flattenAcntRoot AccountRoot_ {..} =
flattenAcntRoot AccountRoot_ {arIncome, arExpenses, arLiabilities, arAssets, arEquity} =
((IncomeT,) <$> arIncome)
++ ((ExpenseT,) <$> arExpenses)
++ ((LiabilityT,) <$> arLiabilities)
@ -315,7 +309,6 @@ getDBState c = do
am <- updateAccounts $ accounts c
cm <- updateCurrencies $ currencies c
hs <- updateHashes c
v <- newMVar M.empty
-- TODO not sure how I feel about this, probably will change this struct alot
-- in the future so whatever...for now
return $ concatEither2 bi si $ \b s f ->
@ -326,7 +319,6 @@ getDBState c = do
, kmStatementInterval = s
, kmNewCommits = hs
, kmConfigDir = f
, kmBoundsCache = v
}
where
bi = resolveBounds $ budgetInterval $ global c

View File

@ -1,8 +1,3 @@
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Internal.Insert
( insertStatements
, insertBudget
@ -17,6 +12,8 @@ import Internal.Statement
import Internal.Types hiding (sign)
import Internal.Utils
import RIO hiding (to)
import qualified RIO.List as L
import qualified RIO.Map as M
import qualified RIO.Text as T
import RIO.Time
@ -43,7 +40,8 @@ expandModPat ModPat {mpStart = s, mpBy = b, mpUnit = u, mpRepeats = r} bs =
Year -> addGregorianYearsClip
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 $
mapMaybe (uncurry3 toDay) $
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
withDates
:: MonadUnliftIO m
:: MonadFinance m
=> DatePat
-> (Day -> MappingT m a)
-> MappingT m (EitherErrs [a])
-> (Day -> SqlPersistT m a)
-> SqlPersistT m (EitherErrs [a])
withDates dp f = do
bounds <- asks kmBudgetInterval
bounds <- lift $ askDBState kmBudgetInterval
let days = expandDatePat bounds dp
mapM (mapM f) days
--------------------------------------------------------------------------------
-- budget
insertBudget :: MonadUnliftIO m => Budget -> MappingT m [InsertError]
insertBudget :: MonadFinance m => Budget -> SqlPersistT m [InsertError]
insertBudget Budget {budgetLabel = name, income = is, transfers = es} = do
es1 <- mapM (insertIncome name) is
es2 <- mapM (insertTransfer name) es
return $ concat $ es1 ++ es2
es2 <- insertTransfers name es
return $ concat es1 ++ es2
-- TODO this hashes twice (not that it really matters)
whenHash
:: (Hashable a, MonadUnliftIO m)
:: (Hashable a, MonadFinance m)
=> ConfigType
-> a
-> b
-> (Key CommitR -> MappingT m b)
-> MappingT m b
-> (Key CommitR -> SqlPersistT m b)
-> SqlPersistT m b
whenHash t o def f = do
let h = hash o
hs <- asks kmNewCommits
if h `elem` hs then f =<< lift (insert $ CommitR h t) else return def
hs <- lift $ askDBState kmNewCommits
if h `elem` hs then f =<< insert (CommitR h t) else return def
-- TODO allow currency conversions here
data BudgetSplit b = BudgetSplit
@ -147,8 +145,10 @@ data BudgetTx = BudgetTx
, btDesc :: !T.Text
}
insertIncome :: MonadUnliftIO m => T.Text -> Income -> MappingT m [InsertError]
insertIncome name i@Income {..} =
insertIncome :: MonadFinance m => T.Text -> Income -> SqlPersistT m [InsertError]
insertIncome
name
i@Income {incWhen, incCurrency, incFrom, incPretax, incPosttax, incTaxes, incToBal} =
whenHash CTIncome i [] $ \c ->
unlessLeft (balanceIncome i) $ \balance -> do
res <- withDates incWhen $ \day -> do
@ -174,7 +174,8 @@ fromAllo
-> Maybe IncomeBucket
-> Allocation
-> [BudgetTx]
fromAllo meta from ib Allocation {..} = fmap (toBT alloPath) alloAmts
fromAllo meta from ib Allocation {alloPath, alloAmts, alloBucket} =
fmap (toBT alloPath) alloAmts
where
toBT to (Amount desc v) =
BudgetTx
@ -215,33 +216,98 @@ sumAllocation = sum . fmap (dec2Rat . amtValue) . alloAmts
sumTaxes :: [Tax] -> Rational
sumTaxes = sum . fmap (dec2Rat . taxValue)
insertTransfer :: MonadUnliftIO m => T.Text -> Transfer -> MappingT m [InsertError]
insertTransfer name t@Transfer {..} =
fmap concat $ whenHash CTExpense t [] $ \key -> do
forM transAmounts $ \(TimeAmount amt pat) -> do
res <- withDates pat $ \day -> insertBudgetTx $ budgetTx amt day key
unlessLefts res $ return . concat
insertTransfers :: MonadFinance m => T.Text -> [Transfer] -> SqlPersistT m [InsertError]
insertTransfers name ts = do
res <- expandTransfers name ts
unlessLefts res $ \txs ->
fmap concat <$> mapM insertBudgetTx $ balanceTransfers txs
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
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
{ bmWhen = d
{ bmWhen = day
, bmCur = transCurrency
, bmCommit = c
, bmCommit = key
, bmName = name
}
budgetTx (Amount desc v) d c =
BudgetTx
{ btMeta = meta d c
, btFrom = BudgetSplit transFrom Nothing
, btTo = BudgetSplit transTo Nothing
, btValue = dec2Rat v
, btDesc = desc
in return $
TransferTx
{ trxMeta = meta
, trxFrom = transFrom
, trxTo = transTo
, trxValue = dec2Rat v
, 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]
insertBudgetTx BudgetTx {..} = do
-- amountBalance
-- :: (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
unlessLefts_ res $ \(sFrom, sTo) -> lift $ do
unlessLefts_ res $ \(sFrom, sTo) -> do
k <- insert $ TransactionR (bmCommit btMeta) (bmWhen btMeta) btDesc
insertBudgetLabel name k IncomeBucketR sFrom btFrom
insertBudgetLabel name k ExpenseBucketR sTo btTo
@ -262,12 +328,12 @@ insertBudgetLabel name k bucketType split bs = do
forM_ (bsBucket bs) $ insert_ . bucketType bk
splitPair
:: MonadUnliftIO m
:: MonadFinance m
=> AcntID
-> AcntID
-> CurID
-> Rational
-> MappingT m (EitherErrs (KeySplit, KeySplit))
-> SqlPersistT m (EitherErrs (KeySplit, KeySplit))
splitPair from to cur val = do
s1 <- split from (-val)
s2 <- split to val
@ -285,14 +351,14 @@ splitPair from to cur val = do
--------------------------------------------------------------------------------
-- statements
insertStatements :: MonadUnliftIO m => Config -> MappingT m [InsertError]
insertStatements :: MonadFinance m => Config -> SqlPersistT m [InsertError]
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 (StmtImport i) = insertImport i
insertManual :: MonadUnliftIO m => Manual -> MappingT m [InsertError]
insertManual :: MonadFinance m => Manual -> SqlPersistT m [InsertError]
insertManual
m@Manual
{ manualDate = dp
@ -303,23 +369,23 @@ insertManual
, manualDesc = e
} = do
whenHash CTManual m [] $ \c -> do
bounds <- asks kmStatementInterval
bounds <- lift $ askDBState kmStatementInterval
-- let days = expandDatePat bounds dp
let dayRes = expandDatePat bounds dp
unlessLefts dayRes $ \days -> do
txRes <- mapM tx days
unlessLefts_ (concatEithersL txRes) $ lift . mapM_ (insertTx c)
unlessLefts_ (concatEithersL txRes) $ mapM_ (insertTx c)
where
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
-- TODO this isn't efficient, the whole file will be read and maybe no
-- transactions will be desired
recoverIO (readImport i) $ \r -> unlessLefts r $ \bs -> do
bounds <- expandBounds <$> asks kmStatementInterval
recoverIO (lift $ readImport i) $ \r -> unlessLefts r $ \bs -> do
bounds <- expandBounds <$> lift (askDBState kmStatementInterval)
res <- mapM resolveTx $ filter (inBounds bounds . txDate) bs
unlessLefts_ (concatEithersL res) $ lift . mapM_ (insertTx c)
unlessLefts_ (concatEithersL res) $ mapM_ (insertTx c)
where
recoverIO x rest = do
res <- tryIO x
@ -333,14 +399,14 @@ insertImport i = whenHash CTImport i [] $ \c -> do
-- low-level transaction stuff
txPair
:: MonadUnliftIO m
:: MonadFinance m
=> Day
-> AcntID
-> AcntID
-> CurID
-> Rational
-> T.Text
-> MappingT m (EitherErrs KeyTx)
-> SqlPersistT m (EitherErrs KeyTx)
txPair day from to cur val desc = resolveTx tx
where
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]
}
resolveTx :: MonadUnliftIO m => BalTx -> MappingT m (EitherErrs KeyTx)
resolveTx :: MonadFinance m => BalTx -> SqlPersistT m (EitherErrs KeyTx)
resolveTx t@Tx {txSplits = ss} = do
res <- concatEithersL <$> mapM resolveSplit ss
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
aid <- lookupAccountKey p
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
insert $ SplitR t cid aid c v
lookupAccount :: MonadUnliftIO m => AcntID -> MappingT m (EitherErr (Key AccountR, AcntSign))
lookupAccount p = lookupErr (DBKey AcntField) p <$> asks kmAccount
lookupAccount :: MonadFinance m => AcntID -> SqlPersistT m (EitherErr (Key AccountR, AcntSign))
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
lookupAccountSign :: MonadUnliftIO m => AcntID -> MappingT m (EitherErr AcntSign)
lookupAccountSign :: MonadFinance m => AcntID -> SqlPersistT m (EitherErr AcntSign)
lookupAccountSign = fmap (fmap snd) . lookupAccount
lookupCurrency :: MonadUnliftIO m => T.Text -> MappingT m (EitherErr (Key CurrencyR))
lookupCurrency c = lookupErr (DBKey CurField) c <$> asks kmCurrency
lookupCurrency :: MonadFinance m => T.Text -> SqlPersistT m (EitherErr (Key CurrencyR))
lookupCurrency c = lookupErr (DBKey CurField) c <$> lift (askDBState kmCurrency)

View File

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

View File

@ -1,17 +1,5 @@
{-# 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 TypeFamilies #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Internal.Types where
@ -45,6 +33,7 @@ makeHaskellTypesWith
, MultipleConstructors "SplitNum" "(./dhall/Types.dhall).SplitNum"
, MultipleConstructors "ExpenseBucket" "(./dhall/Types.dhall).ExpenseBucket"
, MultipleConstructors "IncomeBucket" "(./dhall/Types.dhall).IncomeBucket"
, MultipleConstructors "AmountType" "(./dhall/Types.dhall).AmountType"
, SingleConstructor "Currency" "Currency" "(./dhall/Types.dhall).Currency"
, SingleConstructor "Gregorian" "Gregorian" "(./dhall/Types.dhall).Gregorian"
, SingleConstructor "GregorianM" "GregorianM" "(./dhall/Types.dhall).GregorianM"
@ -303,6 +292,10 @@ instance PersistField ExpenseBucket where
instance PersistFieldSql ExpenseBucket where
sqlType _ = SqlString
deriving instance Eq AmountType
deriving instance Hashable AmountType
deriving instance Eq TimeAmount
deriving instance Hashable TimeAmount

View File

@ -1,8 +1,3 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Internal.Utils
( compareDate
, inBounds
@ -78,14 +73,14 @@ xGregToDay :: XGregorian -> Day
xGregToDay XGregorian {xgYear = y, xgMonth = m, xgDay = d} = fromGregorian (fromIntegral y) m d
gregTup :: Gregorian -> (Integer, Int, Int)
gregTup Gregorian {..} =
gregTup Gregorian {gYear, gMonth, gDay} =
( fromIntegral gYear
, fromIntegral gMonth
, fromIntegral gDay
)
gregMTup :: GregorianM -> (Integer, Int)
gregMTup GregorianM {..} =
gregMTup GregorianM {gmYear, gmMonth} =
( fromIntegral gmYear
, fromIntegral gmMonth
)
@ -145,7 +140,9 @@ expandBounds (d, n) = (d, addDays (fromIntegral n + 1) d)
-- matching
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
if date && res
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
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_ ->
let fromSplit =
Split
@ -178,7 +175,7 @@ toTx sc sa toSplits r@TxRecord {..} =
ssRes = concatEithersL $ fmap (resolveSplit r) toSplits
valMatches :: MatchVal -> Rational -> EitherErr Bool
valMatches MatchVal {..} x
valMatches MatchVal {mvDen, mvSign, mvNum, mvPrec} x
| Just d_ <- mvDen, d_ >= p = Left $ MatchValPrecisionError d_ p
| otherwise =
Right $
@ -251,8 +248,9 @@ parseRational (pat, re) s = case matchGroupsMaybe s re of
_ -> msg "malformed decimal"
where
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 :: MonadFail m => T.Text -> m a
msg m =
fail $
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
dec2Rat :: Decimal -> Rational
dec2Rat D {..} =
dec2Rat D {sign, whole, decimal, precision} =
k * (fromIntegral whole + (fromIntegral decimal % (10 ^ precision)))
where
k = if sign then 1 else -1
@ -364,7 +362,7 @@ showError other = (: []) $ case other of
splits = T.intercalate ", " $ fmap (singleQuote . showSplit) rss
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 {trDate = d, trAmount = v, trDesc = e, trFile = f} =
@ -428,7 +426,8 @@ showYMD_ md =
showMatchVal :: MatchVal -> Maybe T.Text
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
kvs =
[ ("sign", (\s -> if s then "+" else "-") <$> mvSign)

View File

@ -10,15 +10,59 @@ extra-source-files:
- README.md
- ChangeLog.md
# Metadata used when publishing your package
# synopsis: Short description of your package
# 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>
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:
- base >= 4.12 && < 10
- rio >= 0.1.21.0
@ -41,34 +85,16 @@ dependencies:
- recursion-schemes
- data-fix
- filepath
- mtl
library:
source-dirs: lib/
ghc-options:
- -Wall
- -Wcompat
- -Widentities
- -Wincomplete-record-updates
- -Wincomplete-uni-patterns
- -Wredundant-constraints
- -Wpartial-fields
- -Werror
- -O2
executables:
pwncash:
main: Main.hs
source-dirs: app
ghc-options:
- -Wall
- -Wcompat
- -Widentities
- -Wincomplete-record-updates
- -Wincomplete-uni-patterns
- -Wredundant-constraints
- -Wpartial-fields
- -Werror
- -O2
- -threaded
dependencies:
- budget