Compare commits

..

No commits in common. "e6a39cb5ea4f45ec389010504d5caa0412ecc5d6" and "1e5f40d7309b455cfbd3950f83672ce2d140d437" have entirely different histories.

12 changed files with 205 additions and 380 deletions

View File

@ -1,8 +1,7 @@
{-# LANGUAGE ImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
module Main (main) where
import Control.Monad.Reader
import qualified Data.Text.IO as TI
import Internal.Config
import Internal.Database.Ops
@ -163,9 +162,9 @@ runSync c = do
case res of
Left es -> throwIO $ InsertException es
Right s -> do
let run = mapReaderT $ flip runReaderT (s $ takeDirectory c)
es1 <- concat <$> mapM (run . insertBudget) (budget config)
es2 <- run $ insertStatements config
flip runReaderT (s $ takeDirectory c) $ do
es1 <- concat <$> mapM insertBudget (budget config)
es2 <- 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.2.
-- This file has been generated from package.yaml by hpack version 0.35.1.
--
-- see: https://github.com/sol/hpack
@ -36,42 +36,6 @@ 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
@ -86,7 +50,6 @@ 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
@ -104,42 +67,6 @@ 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
@ -155,7 +82,6 @@ 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

@ -25,14 +25,7 @@ let Weekday = < Mon | Tue | Wed | Thu | Fri | Sat | Sun >
let RepeatPat =
{ rpStart : Natural, rpBy : Natural, rpRepeats : Optional Natural }
let MDYPat =
< Single : Natural
| Multi : List Natural
| Repeat : RepeatPat
| After : Natural
| Before : Natural
| Between : { _between1 : Natural, _between2 : Natural }
>
let MDYPat = < Single : Natural | Multi : List Natural | Repeat : RepeatPat >
let ModPat =
{ Type =
@ -187,9 +180,7 @@ let IncomeBucket = < PreTax | IntraTax | PostTax >
let Amount = { amtValue : Decimal, amtDesc : Text }
let AmountType = < FixedAmt | Percent | Target >
let TimeAmount = { taWhen : DatePat, taAmt : Amount, taAmtType : AmountType }
let TimeAmount = { taWhen : DatePat, taAmt : Amount }
let Tax = { taxAcnt : AcntID, taxValue : Decimal }
@ -266,5 +257,4 @@ in { CurID
, Allocation
, Amount
, TimeAmount
, AmountType
}

View File

@ -4,7 +4,7 @@ let List/map =
let T =
./Types.dhall
sha256:10af13e592448321c1e298f55a1e924e77b7e64bd35512147e0952de1f3abcfb
sha256:27c65b31fe1b0dd58ff03ec0a37648f586914c81b81e5f33d3eac5a465475f2b
let nullSplit =
\(a : T.SplitAcnt) ->

View File

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

View File

@ -1,6 +1,20 @@
{-# 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
@ -70,42 +84,13 @@ data DBState = DBState
, kmStatementInterval :: !Bounds
, kmNewCommits :: ![Int]
, kmConfigDir :: !FilePath
, kmBoundsCache :: !(MVar (M.Map (Bounds, DatePat) [Day]))
}
type MappingT m = ReaderT DBState (SqlPersistT m)
type MappingT m a = ReaderT DBState (SqlPersistT m) a
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,3 +1,11 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Internal.Database.Ops
( migrate_
, nukeTables
@ -40,7 +48,6 @@ migrate_ c more =
(openConnection c)
( \backend ->
flip runSqlConn backend $ do
_ <- askLoggerIO
runMigration migrateAll
more
)
@ -191,8 +198,7 @@ updateCurrencies cs = do
return $ currencyMap curs
currency2Record :: Currency -> Entity CurrencyR
currency2Record c@Currency {curSymbol, curFullname} =
Entity (toKey c) $ CurrencyR curSymbol curFullname
currency2Record c@Currency {..} = Entity (toKey c) $ CurrencyR curSymbol curFullname
currencyMap :: [Entity CurrencyR] -> CurrencyMap
currencyMap = M.fromList . fmap (\e -> (currencyRSymbol $ entityVal e, entityKey e))
@ -285,7 +291,7 @@ xs !? n
n
flattenAcntRoot :: AccountRoot -> [(AcntType, AccountTree)]
flattenAcntRoot AccountRoot_ {arIncome, arExpenses, arLiabilities, arAssets, arEquity} =
flattenAcntRoot AccountRoot_ {..} =
((IncomeT,) <$> arIncome)
++ ((ExpenseT,) <$> arExpenses)
++ ((LiabilityT,) <$> arLiabilities)
@ -309,6 +315,7 @@ 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 ->
@ -319,6 +326,7 @@ getDBState c = do
, kmStatementInterval = s
, kmNewCommits = hs
, kmConfigDir = f
, kmBoundsCache = v
}
where
bi = resolveBounds $ budgetInterval $ global c

View File

@ -1,3 +1,8 @@
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Internal.Insert
( insertStatements
, insertBudget
@ -12,8 +17,6 @@ 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
@ -40,8 +43,7 @@ expandModPat ModPat {mpStart = s, mpBy = b, mpUnit = u, mpRepeats = r} bs =
Year -> addGregorianYearsClip
expandCronPat :: Bounds -> CronPat -> EitherErrs [Day]
expandCronPat b CronPat {cronYear, cronMonth, cronDay, cronWeekly} =
concatEither3 yRes mRes dRes $ \ys ms ds ->
expandCronPat b CronPat {..} = concatEither3 yRes mRes dRes $ \ys ms ds ->
filter validWeekday $
mapMaybe (uncurry3 toDay) $
takeWhile (\((y, _), m, d) -> (y, m, d) <= (yb1, mb1, db1)) $
@ -51,16 +53,14 @@ expandCronPat b CronPat {cronYear, cronMonth, cronDay, cronWeekly} =
yRes = case cronYear of
Nothing -> return [yb0 .. yb1]
Just pat -> do
ys <- expandMDYPat (fromIntegral yb0) (fromIntegral yb1) pat
ys <- expandMDYPat (fromIntegral yb1) pat
return $ dropWhile (< yb0) $ fromIntegral <$> ys
mRes = expandMD 12 cronMonth
dRes = expandMD 31 cronDay
(s, e) = expandBounds b
(yb0, mb0, db0) = toGregorian s
(yb1, mb1, db1) = toGregorian $ addDays (-1) e
expandMD lim =
fmap (fromIntegral <$>)
. maybe (return [1 .. lim]) (expandMDYPat 1 lim)
expandMD lim = fmap (fromIntegral <$>) . maybe (return [1 .. lim]) (expandMDYPat lim)
expandW (OnDay x) = [fromEnum x]
expandW (OnDays xs) = fromEnum <$> xs
ws = maybe [] expandW cronWeekly
@ -70,59 +70,56 @@ expandCronPat b CronPat {cronYear, cronMonth, cronDay, cronWeekly} =
| m `elem` [4, 6, 9, 11] && d > 30 = Nothing
| otherwise = Just $ fromGregorian y m d
expandMDYPat :: Natural -> Natural -> MDYPat -> EitherErr [Natural]
expandMDYPat lower upper (Single x) = Right [x | lower <= x && x <= upper]
expandMDYPat lower upper (Multi xs) = Right $ dropWhile (<= lower) $ takeWhile (<= upper) xs
expandMDYPat lower upper (After x) = Right [max lower x .. upper]
expandMDYPat lower upper (Before x) = Right [lower .. min upper x]
expandMDYPat lower upper (Between x y) = Right [max lower x .. min upper y]
expandMDYPat lower upper (Repeat RepeatPat {rpStart = s, rpBy = b, rpRepeats = r})
expandMDYPat :: Natural -> MDYPat -> EitherErr [Natural]
expandMDYPat _ (Single x) = Right [x]
expandMDYPat _ (Multi xs) = Right xs
expandMDYPat lim (Repeat RepeatPat {rpStart = s, rpBy = b, rpRepeats = r})
| b < 1 = Left $ PatternError s b r ZeroLength
| otherwise = do
k <- limit r
return $ dropWhile (<= lower) $ takeWhile (<= k) [s + i * b | i <- [0 ..]]
return $ takeWhile (<= k) [s + i * b | i <- [0 ..]]
where
limit Nothing = Right upper
limit Nothing = Right lim
limit (Just n)
-- this guard not only produces the error for the user but also protects
-- from an underflow below it
| n < 1 = Left $ PatternError s b r ZeroRepeats
| otherwise = Right $ min (s + b * (n - 1)) upper
| otherwise = Right $ min (s + b * (n - 1)) lim
dayToWeekday :: Day -> Int
dayToWeekday (ModifiedJulianDay d) = mod (fromIntegral d + 2) 7
withDates
:: MonadFinance m
:: MonadUnliftIO m
=> DatePat
-> (Day -> SqlPersistT m a)
-> SqlPersistT m (EitherErrs [a])
-> (Day -> MappingT m a)
-> MappingT m (EitherErrs [a])
withDates dp f = do
bounds <- lift $ askDBState kmBudgetInterval
bounds <- asks kmBudgetInterval
let days = expandDatePat bounds dp
mapM (mapM f) days
--------------------------------------------------------------------------------
-- budget
insertBudget :: MonadFinance m => Budget -> SqlPersistT m [InsertError]
insertBudget :: MonadUnliftIO m => Budget -> MappingT m [InsertError]
insertBudget Budget {budgetLabel = name, income = is, transfers = es} = do
es1 <- mapM (insertIncome name) is
es2 <- insertTransfers name es
return $ concat es1 ++ es2
es2 <- mapM (insertTransfer name) es
return $ concat $ es1 ++ es2
-- TODO this hashes twice (not that it really matters)
whenHash
:: (Hashable a, MonadFinance m)
:: (Hashable a, MonadUnliftIO m)
=> ConfigType
-> a
-> b
-> (Key CommitR -> SqlPersistT m b)
-> SqlPersistT m b
-> (Key CommitR -> MappingT m b)
-> MappingT m b
whenHash t o def f = do
let h = hash o
hs <- lift $ askDBState kmNewCommits
if h `elem` hs then f =<< insert (CommitR h t) else return def
hs <- asks kmNewCommits
if h `elem` hs then f =<< lift (insert $ CommitR h t) else return def
-- TODO allow currency conversions here
data BudgetSplit b = BudgetSplit
@ -145,10 +142,8 @@ data BudgetTx = BudgetTx
, btDesc :: !T.Text
}
insertIncome :: MonadFinance m => T.Text -> Income -> SqlPersistT m [InsertError]
insertIncome
name
i@Income {incWhen, incCurrency, incFrom, incPretax, incPosttax, incTaxes, incToBal} =
insertIncome :: MonadUnliftIO m => T.Text -> Income -> MappingT m [InsertError]
insertIncome name i@Income {..} =
whenHash CTIncome i [] $ \c ->
unlessLeft (balanceIncome i) $ \balance -> do
res <- withDates incWhen $ \day -> do
@ -174,8 +169,7 @@ fromAllo
-> Maybe IncomeBucket
-> Allocation
-> [BudgetTx]
fromAllo meta from ib Allocation {alloPath, alloAmts, alloBucket} =
fmap (toBT alloPath) alloAmts
fromAllo meta from ib Allocation {..} = fmap (toBT alloPath) alloAmts
where
toBT to (Amount desc v) =
BudgetTx
@ -216,98 +210,33 @@ sumAllocation = sum . fmap (dec2Rat . amtValue) . alloAmts
sumTaxes :: [Tax] -> Rational
sumTaxes = sum . fmap (dec2Rat . taxValue)
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
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
where
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 =
meta d c =
BudgetMeta
{ bmWhen = day
{ bmWhen = d
, bmCur = transCurrency
, bmCommit = key
, bmCommit = c
, bmName = name
}
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
budgetTx (Amount desc v) d c =
BudgetTx
{ btMeta = meta d c
, btFrom = BudgetSplit transFrom Nothing
, btTo = BudgetSplit transTo Nothing
, btValue = dec2Rat v
, btDesc = desc
}
-- 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
insertBudgetTx :: MonadUnliftIO m => BudgetTx -> MappingT m [InsertError]
insertBudgetTx BudgetTx {..} = do
res <- splitPair (bsAcnt btFrom) (bsAcnt btTo) (bmCur btMeta) btValue
unlessLefts_ res $ \(sFrom, sTo) -> do
unlessLefts_ res $ \(sFrom, sTo) -> lift $ do
k <- insert $ TransactionR (bmCommit btMeta) (bmWhen btMeta) btDesc
insertBudgetLabel name k IncomeBucketR sFrom btFrom
insertBudgetLabel name k ExpenseBucketR sTo btTo
@ -328,12 +257,12 @@ insertBudgetLabel name k bucketType split bs = do
forM_ (bsBucket bs) $ insert_ . bucketType bk
splitPair
:: MonadFinance m
:: MonadUnliftIO m
=> AcntID
-> AcntID
-> CurID
-> Rational
-> SqlPersistT m (EitherErrs (KeySplit, KeySplit))
-> MappingT m (EitherErrs (KeySplit, KeySplit))
splitPair from to cur val = do
s1 <- split from (-val)
s2 <- split to val
@ -351,14 +280,14 @@ splitPair from to cur val = do
--------------------------------------------------------------------------------
-- statements
insertStatements :: MonadFinance m => Config -> SqlPersistT m [InsertError]
insertStatements :: MonadUnliftIO m => Config -> MappingT m [InsertError]
insertStatements conf = concat <$> mapM insertStatement (statements conf)
insertStatement :: MonadFinance m => Statement -> SqlPersistT m [InsertError]
insertStatement :: MonadUnliftIO m => Statement -> MappingT m [InsertError]
insertStatement (StmtManual m) = insertManual m
insertStatement (StmtImport i) = insertImport i
insertManual :: MonadFinance m => Manual -> SqlPersistT m [InsertError]
insertManual :: MonadUnliftIO m => Manual -> MappingT m [InsertError]
insertManual
m@Manual
{ manualDate = dp
@ -369,23 +298,23 @@ insertManual
, manualDesc = e
} = do
whenHash CTManual m [] $ \c -> do
bounds <- lift $ askDBState kmStatementInterval
bounds <- asks kmStatementInterval
-- let days = expandDatePat bounds dp
let dayRes = expandDatePat bounds dp
unlessLefts dayRes $ \days -> do
txRes <- mapM tx days
unlessLefts_ (concatEithersL txRes) $ mapM_ (insertTx c)
unlessLefts_ (concatEithersL txRes) $ lift . mapM_ (insertTx c)
where
tx day = txPair day from to u (dec2Rat v) e
insertImport :: MonadFinance m => Import -> SqlPersistT m [InsertError]
insertImport :: MonadUnliftIO m => Import -> MappingT 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 (lift $ readImport i) $ \r -> unlessLefts r $ \bs -> do
bounds <- expandBounds <$> lift (askDBState kmStatementInterval)
recoverIO (readImport i) $ \r -> unlessLefts r $ \bs -> do
bounds <- expandBounds <$> asks kmStatementInterval
res <- mapM resolveTx $ filter (inBounds bounds . txDate) bs
unlessLefts_ (concatEithersL res) $ mapM_ (insertTx c)
unlessLefts_ (concatEithersL res) $ lift . mapM_ (insertTx c)
where
recoverIO x rest = do
res <- tryIO x
@ -399,14 +328,14 @@ insertImport i = whenHash CTImport i [] $ \c -> do
-- low-level transaction stuff
txPair
:: MonadFinance m
:: MonadUnliftIO m
=> Day
-> AcntID
-> AcntID
-> CurID
-> Rational
-> T.Text
-> SqlPersistT m (EitherErrs KeyTx)
-> MappingT m (EitherErrs KeyTx)
txPair day from to cur val desc = resolveTx tx
where
split a v = Split {sAcnt = a, sValue = v, sComment = "", sCurrency = cur}
@ -418,12 +347,12 @@ txPair day from to cur val desc = resolveTx tx
, txSplits = [split from (-val), split to val]
}
resolveTx :: MonadFinance m => BalTx -> SqlPersistT m (EitherErrs KeyTx)
resolveTx :: MonadUnliftIO m => BalTx -> MappingT m (EitherErrs KeyTx)
resolveTx t@Tx {txSplits = ss} = do
res <- concatEithersL <$> mapM resolveSplit ss
return $ fmap (\kss -> t {txSplits = kss}) res
resolveSplit :: MonadFinance m => BalSplit -> SqlPersistT m (EitherErrs KeySplit)
resolveSplit :: MonadUnliftIO m => BalSplit -> MappingT m (EitherErrs KeySplit)
resolveSplit s@Split {sAcnt = p, sCurrency = c, sValue = v} = do
aid <- lookupAccountKey p
cid <- lookupCurrency c
@ -446,14 +375,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 :: MonadFinance m => AcntID -> SqlPersistT m (EitherErr (Key AccountR, AcntSign))
lookupAccount p = lookupErr (DBKey AcntField) p <$> lift (askDBState kmAccount)
lookupAccount :: MonadUnliftIO m => AcntID -> MappingT m (EitherErr (Key AccountR, AcntSign))
lookupAccount p = lookupErr (DBKey AcntField) p <$> asks kmAccount
lookupAccountKey :: MonadFinance m => AcntID -> SqlPersistT m (EitherErr (Key AccountR))
lookupAccountKey :: MonadUnliftIO m => AcntID -> MappingT m (EitherErr (Key AccountR))
lookupAccountKey = fmap (fmap fst) . lookupAccount
lookupAccountSign :: MonadFinance m => AcntID -> SqlPersistT m (EitherErr AcntSign)
lookupAccountSign :: MonadUnliftIO m => AcntID -> MappingT m (EitherErr AcntSign)
lookupAccountSign = fmap (fmap snd) . lookupAccount
lookupCurrency :: MonadFinance m => T.Text -> SqlPersistT m (EitherErr (Key CurrencyR))
lookupCurrency c = lookupErr (DBKey CurField) c <$> lift (askDBState kmCurrency)
lookupCurrency :: MonadUnliftIO m => T.Text -> MappingT m (EitherErr (Key CurrencyR))
lookupCurrency c = lookupErr (DBKey CurField) c <$> asks kmCurrency

View File

@ -1,4 +1,8 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Internal.Statement
( readImport
@ -20,7 +24,7 @@ import qualified RIO.Vector as V
-- TODO this probably won't scale well (pipes?)
readImport :: MonadFinance m => Import -> m (EitherErrs [BalTx])
readImport :: MonadUnliftIO m => Import -> MappingT m (EitherErrs [BalTx])
readImport Import {..} = do
let ores = plural $ compileOptions impTxOpts
let cres = concatEithersL $ compileMatch <$> impMatches
@ -33,14 +37,14 @@ readImport Import {..} = do
Left es -> return $ Left es
readImport_
:: MonadFinance m
:: MonadUnliftIO m
=> Natural
-> Word
-> TxOptsRe
-> FilePath
-> m (EitherErr [TxRecord])
-> MappingT m (EitherErr [TxRecord])
readImport_ n delim tns p = do
dir <- askDBState kmConfigDir
dir <- asks 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,5 +1,17 @@
{-# 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
@ -33,7 +45,6 @@ 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"
@ -292,10 +303,6 @@ 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,3 +1,8 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Internal.Utils
( compareDate
, inBounds
@ -73,14 +78,14 @@ xGregToDay :: XGregorian -> Day
xGregToDay XGregorian {xgYear = y, xgMonth = m, xgDay = d} = fromGregorian (fromIntegral y) m d
gregTup :: Gregorian -> (Integer, Int, Int)
gregTup Gregorian {gYear, gMonth, gDay} =
gregTup Gregorian {..} =
( fromIntegral gYear
, fromIntegral gMonth
, fromIntegral gDay
)
gregMTup :: GregorianM -> (Integer, Int)
gregMTup GregorianM {gmYear, gmMonth} =
gregMTup GregorianM {..} =
( fromIntegral gmYear
, fromIntegral gmMonth
)
@ -140,9 +145,7 @@ expandBounds (d, n) = (d, addDays (fromIntegral n + 1) d)
-- matching
matches :: MatchRe -> TxRecord -> EitherErrs (MatchRes RawTx)
matches
Match {mTx, mOther, mVal, mDate, mDesc}
r@TxRecord {trDate, trAmount, trDesc, trOther} = do
matches Match {..} r@TxRecord {..} = do
res <- concatEither3 val other desc $ \x y z -> x && y && z
if date && res
then maybe (Right MatchSkip) (fmap MatchPass . convert) mTx
@ -155,7 +158,7 @@ matches
convert (ToTx cur a ss) = toTx cur a ss r
toTx :: SplitCur -> SplitAcnt -> [ExpSplit] -> TxRecord -> EitherErrs RawTx
toTx sc sa toSplits r@TxRecord {trAmount, trDate, trDesc} =
toTx sc sa toSplits r@TxRecord {..} =
concatEithers2 acRes ssRes $ \(a_, c_) ss_ ->
let fromSplit =
Split
@ -175,7 +178,7 @@ toTx sc sa toSplits r@TxRecord {trAmount, trDate, trDesc} =
ssRes = concatEithersL $ fmap (resolveSplit r) toSplits
valMatches :: MatchVal -> Rational -> EitherErr Bool
valMatches MatchVal {mvDen, mvSign, mvNum, mvPrec} x
valMatches MatchVal {..} x
| Just d_ <- mvDen, d_ >= p = Left $ MatchValPrecisionError d_ p
| otherwise =
Right $
@ -248,9 +251,8 @@ 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 d
Just d -> return $ fromInteger d
_ -> msg $ T.unwords ["could not parse", what, t]
msg :: MonadFail m => T.Text -> m a
msg m =
fail $
T.unpack $
@ -294,7 +296,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 {sign, whole, decimal, precision} =
dec2Rat D {..} =
k * (fromIntegral whole + (fromIntegral decimal % (10 ^ precision)))
where
k = if sign then 1 else -1
@ -362,7 +364,7 @@ showError other = (: []) $ case other of
splits = T.intercalate ", " $ fmap (singleQuote . showSplit) rss
showGregorian_ :: Gregorian -> T.Text
showGregorian_ Gregorian {gYear, gMonth, gDay} = T.intercalate "-" $ showT <$> [gYear, gMonth, gDay]
showGregorian_ Gregorian {..} = T.intercalate "-" $ showT <$> [gYear, gMonth, gDay]
showTx :: TxRecord -> T.Text
showTx TxRecord {trDate = d, trAmount = v, trDesc = e, trFile = f} =
@ -426,8 +428,7 @@ showYMD_ md =
showMatchVal :: MatchVal -> Maybe T.Text
showMatchVal MatchVal {mvSign = Nothing, mvNum = Nothing, mvDen = Nothing} = Nothing
showMatchVal MatchVal {mvNum, mvDen, mvSign, mvPrec} =
Just $ singleQuote $ keyVals [(k, v) | (k, Just v) <- kvs]
showMatchVal MatchVal {..} = Just $ singleQuote $ keyVals [(k, v) | (k, Just v) <- kvs]
where
kvs =
[ ("sign", (\s -> if s then "+" else "-") <$> mvSign)

View File

@ -10,59 +10,15 @@ 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
@ -85,16 +41,34 @@ 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