WIP track running balances in budget
This commit is contained in:
parent
88dec70ce6
commit
e6a39cb5ea
|
@ -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
|
||||||
|
|
76
budget.cabal
76
budget.cabal
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
}
|
}
|
||||||
|
|
|
@ -1,5 +1,3 @@
|
||||||
{-# LANGUAGE NoImplicitPrelude #-}
|
|
||||||
|
|
||||||
module Internal.Config
|
module Internal.Config
|
||||||
( readConfig
|
( readConfig
|
||||||
-- , readYaml
|
-- , readYaml
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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)
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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)
|
||||||
|
|
72
package.yaml
72
package.yaml
|
@ -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
|
||||||
|
|
Loading…
Reference in New Issue