ndwarshuis
/
pwncash
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

ENH use doubles and get clean compile

This commit is contained in:
Nathan Dwarshuis 2023-05-07 20:29:33 -04:00
parent 38710b1f56
commit 9a1dd1ac3e
9 changed files with 562 additions and 495 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
app/Main.hs
View File

@ -103,7 +103,7 @@ sync =
parse :: Options -> IO ()
parse (Options c Reset) = do
config <- readConfig c
migrate_ (sqlConfig config) nukeTables
runDB (sqlConfig config) nukeTables
parse (Options c DumpAccounts) = runDumpAccounts c
parse (Options c DumpAccountKeys) = runDumpAccountKeys c
parse (Options c DumpCurrencies) = runDumpCurrencies c
@ -155,19 +155,14 @@ runDumpAccountKeys c = do
t3 (_, _, x) = x
double x = (x, x)
runSync :: MonadUnliftIO m => FilePath -> m ()
runSync :: FilePath -> IO ()
runSync c = do
config <- readConfig c
handle err $ migrate_ (sqlConfig config) $ do
res <- getDBState config
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
let es = es1 ++ es2
unless (null es) $ throwIO $ InsertException es
handle err $ runDB (sqlConfig config) $ do
let bgtRes = liftIOExceptT $ mapErrors insertBudget $ budget config
let histRes = mapErrorsIO insertStatement $ statements config
s <- fmap (\f -> f $ takeDirectory c) $ liftIOExceptT $ getDBState config
flip runReaderT s $ combineErrorIO2 bgtRes histRes $ \_ _ -> ()
where
err (InsertException es) = do
liftIO $ mapM_ TI.putStrLn $ concatMap showError es

2
budget.cabal
View File

@ -89,6 +89,7 @@ library
, mtl
, optparse-applicative
, persistent >=2.13.3.1
, persistent-mtl >=0.3.0.0
, persistent-sqlite
, recursion-schemes
, regex-tdfa
@ -158,6 +159,7 @@ executable pwncash
, mtl
, optparse-applicative
, persistent >=2.13.3.1
, persistent-mtl >=0.3.0.0
, persistent-sqlite
, recursion-schemes
, regex-tdfa

119
lib/Internal/Database/Ops.hs
View File

@ -1,5 +1,5 @@
module Internal.Database.Ops
( migrate_
( runDB
, nukeTables
, updateHashes
, getDBState
@ -10,12 +10,15 @@ module Internal.Database.Ops
where
import Conduit
import Control.Monad.Except
import Control.Monad.Logger
import Data.Hashable
import Database.Esqueleto.Experimental
import Database.Persist.Sql hiding (delete, (==.), (||.))
import Database.Persist.Sqlite hiding (delete, (==.), (||.))
import Database.Sqlite hiding (Config)
import Database.Esqueleto.Experimental ((==.), (^.))
import qualified Database.Esqueleto.Experimental as E
import Database.Esqueleto.Internal.Internal (SqlSelect)
import Database.Persist.Monad
-- import Database.Persist.Sql hiding (delete, runMigration, (==.), (||.))
import Database.Persist.Sqlite hiding (delete, deleteWhere, insert, insertKey, runMigration, (==.), (||.))
import GHC.Err
import Internal.Types
import Internal.Utils
@ -26,31 +29,27 @@ import qualified RIO.Map as M
import qualified RIO.NonEmpty as N
import qualified RIO.Text as T
migrate_
runDB
:: MonadUnliftIO m
=> SqlConfig
-> SqlPersistT (ResourceT (NoLoggingT m)) ()
-> m ()
migrate_ c more =
runNoLoggingT $
runResourceT $
withSqlConn
(openConnection c)
( \backend ->
flip runSqlConn backend $ do
_ <- askLoggerIO
-> SqlQueryT (NoLoggingT m) a
-> m a
runDB c more =
runNoLoggingT $ do
pool <- mkPool c
runSqlQueryT pool $ do
_ <- lift askLoggerIO
runMigration migrateAll
more
)
openConnection :: MonadUnliftIO m => SqlConfig -> LogFunc -> m SqlBackend
openConnection c logfn = case c of
Sqlite p -> liftIO $ do
conn <- open p
wrapConnection conn logfn
mkPool :: (MonadLoggerIO m, MonadUnliftIO m) => SqlConfig -> m ConnectionPool
mkPool c = case c of
Sqlite p -> createSqlitePool p 10
-- conn <- open p
-- wrapConnection conn logfn
Postgres -> error "postgres not implemented"
nukeTables :: MonadUnliftIO m => SqlPersistT m ()
nukeTables :: MonadSqlQuery m => m ()
nukeTables = do
deleteWhere ([] :: [Filter CommitR])
deleteWhere ([] :: [Filter CurrencyR])
@ -118,54 +117,54 @@ setDiff as bs = (as \\ bs, bs \\ as)
-- | f a b = Just bs
-- | otherwise = inB a bs
getDBHashes :: MonadUnliftIO m => SqlPersistT m [Int]
getDBHashes :: MonadSqlQuery m => m [Int]
getDBHashes = fmap (commitRHash . entityVal) <$> dumpTbl
nukeDBHash :: MonadUnliftIO m => Int -> SqlPersistT m ()
nukeDBHash h = delete $ do
c <- from table
where_ (c ^. CommitRHash ==. val h)
nukeDBHash :: MonadSqlQuery m => Int -> m ()
nukeDBHash h = deleteE $ do
c <- E.from E.table
E.where_ (c ^. CommitRHash ==. E.val h)
nukeDBHashes :: MonadUnliftIO m => [Int] -> SqlPersistT m ()
nukeDBHashes :: MonadSqlQuery m => [Int] -> m ()
nukeDBHashes = mapM_ nukeDBHash
getConfigHashes :: MonadUnliftIO m => Config -> SqlPersistT m ([Int], [Int])
getConfigHashes :: MonadSqlQuery m => Config -> m ([Int], [Int])
getConfigHashes c = do
let ch = hashConfig c
dh <- getDBHashes
return $ setDiff dh ch
updateHashes :: MonadUnliftIO m => Config -> SqlPersistT m [Int]
updateHashes :: MonadSqlQuery m => Config -> m [Int]
updateHashes c = do
(del, new) <- getConfigHashes c
nukeDBHashes del
return new
dumpTbl :: (PersistEntity r, MonadUnliftIO m) => SqlPersistT m [Entity r]
dumpTbl = select $ from table
dumpTbl :: (MonadSqlQuery m, PersistEntity r) => m [Entity r]
dumpTbl = selectE $ E.from E.table
deleteAccount :: MonadUnliftIO m => Entity AccountR -> SqlPersistT m ()
deleteAccount e = delete $ do
c <- from $ table @AccountR
where_ (c ^. AccountRId ==. val k)
deleteAccount :: MonadSqlQuery m => Entity AccountR -> m ()
deleteAccount e = deleteE $ do
c <- E.from $ E.table @AccountR
E.where_ (c ^. AccountRId ==. E.val k)
where
k = entityKey e
deleteCurrency :: MonadUnliftIO m => Entity CurrencyR -> SqlPersistT m ()
deleteCurrency e = delete $ do
c <- from $ table @CurrencyR
where_ (c ^. CurrencyRId ==. val k)
deleteCurrency :: MonadSqlQuery m => Entity CurrencyR -> m ()
deleteCurrency e = deleteE $ do
c <- E.from $ E.table @CurrencyR
E.where_ (c ^. CurrencyRId ==. E.val k)
where
k = entityKey e
deleteTag :: MonadUnliftIO m => Entity TagR -> SqlPersistT m ()
deleteTag e = delete $ do
c <- from $ table @TagR
where_ (c ^. TagRId ==. val k)
deleteTag :: MonadSqlQuery m => Entity TagR -> m ()
deleteTag e = deleteE $ do
c <- E.from $ E.table @TagR
E.where_ (c ^. TagRId ==. E.val k)
where
k = entityKey e
updateAccounts :: MonadUnliftIO m => AccountRoot -> SqlPersistT m AccountMap
updateAccounts :: MonadSqlQuery m => AccountRoot -> m AccountMap
updateAccounts ar = do
let (acnts, paths, acntMap) = indexAcntRoot ar
acnts' <- dumpTbl
@ -179,15 +178,15 @@ updateAccounts ar = do
-- TODO slip-n-slide code...
insertFull
:: (MonadUnliftIO m, PersistStoreWrite b, PersistRecordBackend r b)
:: (PersistRecordBackend r SqlBackend, Typeable r, MonadSqlQuery m)
=> Entity r
-> ReaderT b m ()
-> m ()
insertFull (Entity k v) = insertKey k v
updateCurrencies :: MonadUnliftIO m => [Currency] -> SqlPersistT m CurrencyMap
updateCurrencies :: MonadSqlQuery m => [Currency] -> m CurrencyMap
updateCurrencies cs = do
let curs = fmap currency2Record cs
curs' <- select $ from $ table @CurrencyR
curs' <- selectE $ E.from $ E.table @CurrencyR
let (toIns, toDel) = setDiff curs curs'
mapM_ deleteCurrency toDel
mapM_ insertFull toIns
@ -207,10 +206,10 @@ currencyMap =
)
)
updateTags :: MonadUnliftIO m => [Tag] -> SqlPersistT m TagMap
updateTags :: MonadSqlQuery m => [Tag] -> m TagMap
updateTags cs = do
let tags = fmap toRecord cs
tags' <- select $ from $ table @TagR
tags' <- selectE $ E.from $ E.table @TagR
let (toIns, toDel) = setDiff tags tags'
mapM_ deleteTag toDel
mapM_ insertFull toIns
@ -324,9 +323,9 @@ indexAcntRoot r =
(ars, aprs, ms) = L.unzip3 $ uncurry tree2Records <$> flattenAcntRoot r
getDBState
:: MonadUnliftIO m
:: (MonadInsertError m, MonadSqlQuery m)
=> Config
-> SqlPersistT m (EitherErrs (FilePath -> DBState))
-> m (FilePath -> DBState)
getDBState c = do
am <- updateAccounts $ accounts c
cm <- updateCurrencies $ currencies c
@ -334,7 +333,7 @@ getDBState c = do
hs <- updateHashes c
-- 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 ->
combineError bi si $ \b s f ->
DBState
{ kmCurrency = cm
, kmAccount = am
@ -345,5 +344,11 @@ getDBState c = do
, kmTag = ts
}
where
bi = resolveBounds $ budgetInterval $ global c
si = resolveBounds $ statementInterval $ global c
bi = liftExcept $ resolveBounds $ budgetInterval $ global c
si = liftExcept $ resolveBounds $ statementInterval $ global c
deleteE :: (MonadSqlQuery m) => E.SqlQuery () -> m ()
deleteE q = unsafeLiftSql "esqueleto-delete" (E.delete q)
selectE :: (MonadSqlQuery m, SqlSelect a r) => E.SqlQuery a -> m [r]
selectE q = unsafeLiftSql "esqueleto-select" (E.select q)

339
lib/Internal/Insert.hs
View File

@ -1,14 +1,14 @@
module Internal.Insert
( insertStatements
( insertStatement
, insertBudget
)
where
import Control.Monad.Except
import Data.Hashable
import Database.Persist.Class
import Database.Persist.Sql hiding (Single, Statement)
import Database.Persist.Monad
import Internal.Statement
import Internal.Types hiding (CurrencyM, sign)
import Internal.Types
import Internal.Utils
import RIO hiding (to)
import qualified RIO.List as L
@ -20,9 +20,9 @@ import RIO.Time
--------------------------------------------------------------------------------
-- intervals
expandDatePat :: Bounds -> DatePat -> EitherErrs [Day]
expandDatePat :: Bounds -> DatePat -> InsertExcept [Day]
expandDatePat b (Cron cp) = expandCronPat b cp
expandDatePat i (Mod mp) = Right $ expandModPat mp i
expandDatePat i (Mod mp) = return $ expandModPat mp i
expandModPat :: ModPat -> Bounds -> [Day]
expandModPat ModPat {mpStart = s, mpBy = b, mpUnit = u, mpRepeats = r} bs =
@ -39,9 +39,9 @@ expandModPat ModPat {mpStart = s, mpBy = b, mpUnit = u, mpRepeats = r} bs =
Month -> addGregorianMonthsClip
Year -> addGregorianYearsClip
expandCronPat :: Bounds -> CronPat -> EitherErrs [Day]
expandCronPat :: Bounds -> CronPat -> InsertExcept [Day]
expandCronPat b CronPat {cpYear, cpMonth, cpDay, cpWeekly} =
concatEither3 yRes mRes dRes $ \ys ms ds ->
combineError3 yRes mRes dRes $ \ys ms ds ->
filter validWeekday $
mapMaybe (uncurry3 toDay) $
takeWhile (\((y, _), m, d) -> (y, m, d) <= (yb1, mb1, db1)) $
@ -70,38 +70,37 @@ expandCronPat b CronPat {cpYear, cpMonth, cpDay, cpWeekly} =
| 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 :: Natural -> Natural -> MDYPat -> InsertExcept [Natural]
expandMDYPat lower upper (Single x) = return [x | lower <= x && x <= upper]
expandMDYPat lower upper (Multi xs) = return $ dropWhile (<= lower) $ takeWhile (<= upper) xs
expandMDYPat lower upper (After x) = return [max lower x .. upper]
expandMDYPat lower upper (Before x) = return [lower .. min upper x]
expandMDYPat lower upper (Between x y) = return [max lower x .. min upper y]
expandMDYPat lower upper (Repeat RepeatPat {rpStart = s, rpBy = b, rpRepeats = r})
| b < 1 = Left $ PatternError s b r ZeroLength
| b < 1 = throwError $ InsertException [PatternError s b r ZeroLength]
| otherwise = do
k <- limit r
return $ dropWhile (<= lower) $ takeWhile (<= k) [s + i * b | i <- [0 ..]]
where
limit Nothing = Right upper
limit Nothing = return upper
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
| n < 1 = throwError $ InsertException [PatternError s b r ZeroRepeats]
| otherwise = return $ min (s + b * (n - 1)) upper
dayToWeekday :: Day -> Int
dayToWeekday (ModifiedJulianDay d) = mod (fromIntegral d + 2) 7
withDates
:: MonadFinance m
:: (MonadSqlQuery m, MonadFinance m, MonadInsertError m)
=> DatePat
-> (Day -> SqlPersistT m (EitherErrs a))
-> SqlPersistT m (EitherErrs [a])
-> (Day -> m a)
-> m [a]
withDates dp f = do
bounds <- lift $ askDBState kmBudgetInterval
case expandDatePat bounds dp of
Left es -> return $ Left es
Right days -> concatEithersL <$> mapM f days
bounds <- askDBState kmBudgetInterval
days <- liftExcept $ expandDatePat bounds dp
combineErrors $ fmap f days
--------------------------------------------------------------------------------
-- budget
@ -117,7 +116,7 @@ withDates dp f = do
-- 4. assign shadow transactions (TODO)
-- 5. insert all transactions
insertBudget :: MonadFinance m => Budget -> SqlPersistT m [InsertError]
insertBudget :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m) => Budget -> m ()
insertBudget
b@Budget
{ bgtLabel
@ -128,23 +127,21 @@ insertBudget
, bgtTax
, bgtPosttax
} =
whenHash CTBudget b [] $ \key -> do
unlessLefts intAllos $ \intAllos_ -> do
res1 <- mapM (insertIncome key bgtLabel intAllos_) bgtIncomes
res2 <- expandTransfers key bgtLabel bgtTransfers
unlessLefts (concatEithers2 (concat <$> concatEithersL res1) res2 (++)) $
\txs -> do
m <- lift $ askDBState kmCurrency
unlessLefts (addShadowTransfers m bgtShadowTransfers txs) $ \shadow -> do
whenHash CTBudget b () $ \key -> do
intAllos <- combineError3 pre_ tax_ post_ (,,)
let res1 = combineErrors $ fmap (insertIncome key bgtLabel intAllos) bgtIncomes
let res2 = expandTransfers key bgtLabel bgtTransfers
txs <- combineError (concat <$> res1) res2 (++)
m <- askDBState kmCurrency
shadow <- liftExcept $ addShadowTransfers m bgtShadowTransfers txs
let bals = balanceTransfers $ txs ++ shadow
concat <$> mapM insertBudgetTx bals
_ <- combineErrors $ fmap insertBudgetTx bals
return ()
where
intAllos =
let pre_ = sortAllos bgtPretax
pre_ = sortAllos bgtPretax
tax_ = sortAllos bgtTax
post_ = sortAllos bgtPosttax
in concatEithers3 pre_ tax_ post_ (,,)
sortAllos = concatEithersL . fmap sortAllo
sortAllos = liftExcept . combineErrors . fmap sortAllo
type BoundAllocation = Allocation (Day, Day)
@ -155,9 +152,9 @@ type IntAllocations =
)
-- TODO this should actually error if there is no ultimate end date?
sortAllo :: MultiAllocation v -> EitherErrs (BoundAllocation v)
sortAllo :: MultiAllocation v -> InsertExcept (BoundAllocation v)
sortAllo a@Allocation {alloAmts = as} = do
bs <- foldBounds (Right []) $ L.sortOn amtWhen as
bs <- foldBounds (return []) $ L.sortOn amtWhen as
return $ a {alloAmts = reverse bs}
where
foldBounds acc [] = acc
@ -166,17 +163,17 @@ sortAllo a@Allocation {alloAmts = as} = do
[] -> resolveBounds $ amtWhen x
(y : _) -> resolveBounds_ (intStart $ amtWhen y) $ amtWhen x
concatRes bs acc' = x {amtWhen = expandBounds bs} : acc'
in foldBounds (concatEithers2 (plural res) acc concatRes) xs
in foldBounds (combineError res acc concatRes) xs
-- TODO this is going to be O(n*m), which might be a problem?
addShadowTransfers
:: CurrencyMap
-> [ShadowTransfer]
-> [UnbalancedTransfer]
-> EitherErrs [UnbalancedTransfer]
-> InsertExcept [UnbalancedTransfer]
addShadowTransfers cm ms txs =
fmap catMaybes $
concatEithersL $
combineErrors $
fmap (uncurry (fromShadow cm)) $
[(t, m) | t <- txs, m <- ms]
@ -184,7 +181,7 @@ fromShadow
:: CurrencyMap
-> UnbalancedTransfer
-> ShadowTransfer
-> EitherErrs (Maybe UnbalancedTransfer)
-> InsertExcept (Maybe UnbalancedTransfer)
fromShadow cm tx t@ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stType} = do
res <- shadowMatches (stMatch t) tx
v <- roundPrecisionCur (initialCurrency stCurrency) cm stRatio
@ -204,7 +201,7 @@ fromShadow cm tx t@ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, st
, cbtDesc = stDesc
}
shadowMatches :: TransferMatcher -> UnbalancedTransfer -> EitherErrs Bool
shadowMatches :: TransferMatcher -> UnbalancedTransfer -> InsertExcept Bool
shadowMatches TransferMatcher {tmFrom, tmTo, tmDate, tmVal} tx = do
valRes <- valMatches tmVal $ cvValue $ cbtValue tx
return $
@ -265,28 +262,26 @@ type UnbalancedTransfer = FlatTransfer UnbalancedValue
type BalancedTransfer = FlatTransfer Rational
insertIncome
:: MonadFinance m
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
=> CommitRId
-> T.Text
-> IntAllocations
-> Income
-> SqlPersistT m (EitherErrs [UnbalancedTransfer])
-> m [UnbalancedTransfer]
insertIncome
key
name
(intPre, intTax, intPost)
Income {incWhen, incCurrency, incFrom, incPretax, incPosttax, incTaxes, incToBal, incGross} = do
-- TODO check that the other accounts are not income somewhere here
fromRes <- lift $ checkAcntType IncomeT $ taAcnt incFrom
precRes <- lift $ lookupCurrencyPrec incCurrency
case concatEithers2 fromRes precRes (,) of
Left e -> return $ Left e
_ <- checkAcntType IncomeT $ taAcnt incFrom
precision <- lookupCurrencyPrec incCurrency
-- TODO this will scan the interval allocations fully each time
-- iteration which is a total waste, but the fix requires turning this
-- loop into a fold which I don't feel like doing now :(
Right (_, p) ->
let gross = roundPrecision p incGross
in fmap concat <$> withDates incWhen (return . allocate p gross)
let gross = roundPrecision precision incGross
res <- withDates incWhen (allocate precision gross)
return $ concat res
where
meta = BudgetMeta key name
flatPre = concatMap flattenAllo incPretax
@ -317,8 +312,8 @@ insertIncome
, cbtDesc = "balance after deductions"
}
in if balance < 0
then Left [IncomeError day name balance]
else Right $ bal : fmap (allo2Trans meta day incFrom) (pre ++ tax ++ post)
then throwError $ InsertException [IncomeError day name balance]
else return (bal : fmap (allo2Trans meta day incFrom) (pre ++ tax ++ post))
allocatePre
:: Natural
@ -421,60 +416,53 @@ selectAllos day Allocation {alloAmts, alloCur, alloTo} =
}
expandTransfers
:: MonadFinance m
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
=> CommitRId
-> T.Text
-> [BudgetTransfer]
-> SqlPersistT m (EitherErrs [UnbalancedTransfer])
expandTransfers key name ts = do
txs <- mapM (expandTransfer key name) ts
return $ L.sortOn cbtWhen . concat <$> concatEithersL txs
-> m [UnbalancedTransfer]
expandTransfers key name ts =
fmap (L.sortOn cbtWhen . concat) $
combineErrors $
fmap (expandTransfer key name) ts
initialCurrency :: BudgetCurrency -> CurID
initialCurrency (NoX c) = c
initialCurrency (X Exchange {xFromCur = c}) = c
expandTransfer
:: MonadFinance m
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
=> CommitRId
-> T.Text
-> BudgetTransfer
-> SqlPersistT m (EitherErrs [UnbalancedTransfer])
-> m [UnbalancedTransfer]
expandTransfer key name Transfer {transAmounts, transTo, transCurrency, transFrom} = do
pRes <- lift $ lookupCurrencyPrec $ initialCurrency transCurrency
case pRes of
Left es -> return $ Left es
Right p ->
fmap (fmap concat . concatEithersL) $
forM transAmounts $
\Amount
precision <- lookupCurrencyPrec $ initialCurrency transCurrency
fmap concat $ combineErrors $ fmap (go precision) transAmounts
where
go
precision
Amount
{ amtWhen = pat
, amtValue = BudgetTransferValue {btVal = v, btType = y}
, amtDesc = desc
} ->
do
withDates pat $ \day ->
let meta =
BudgetMeta
{ bmCommit = key
, bmName = name
}
tx =
} =
withDates pat $ \day -> do
let meta = BudgetMeta {bmCommit = key, bmName = name}
return
FlatTransfer
{ cbtMeta = meta
, cbtWhen = day
, cbtCur = transCurrency
, cbtFrom = transFrom
, cbtTo = transTo
, cbtValue = UnbalancedValue y $ roundPrecision p v
, cbtValue = UnbalancedValue y $ roundPrecision precision v
, cbtDesc = desc
}
in return $ Right tx
insertBudgetTx :: MonadFinance m => BalancedTransfer -> SqlPersistT m [InsertError]
insertBudgetTx :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m) => BalancedTransfer -> m ()
insertBudgetTx FlatTransfer {cbtFrom, cbtTo, cbtMeta, cbtCur, cbtValue, cbtDesc, cbtWhen} = do
res <- lift $ splitPair cbtFrom cbtTo cbtCur cbtValue
unlessLefts_ res $ \((sFrom, sTo), exchange) -> do
((sFrom, sTo), exchange) <- splitPair cbtFrom cbtTo cbtCur cbtValue
insertPair sFrom sTo
forM_ exchange $ uncurry insertPair
where
@ -489,24 +477,24 @@ insertBudgetTx FlatTransfer {cbtFrom, cbtTo, cbtMeta, cbtCur, cbtValue, cbtDesc,
type SplitPair = (KeySplit, KeySplit)
splitPair
:: MonadFinance m
:: (MonadInsertError m, MonadFinance m)
=> TaggedAcnt
-> TaggedAcnt
-> BudgetCurrency
-> Rational
-> m (EitherErrs (SplitPair, Maybe SplitPair))
-> m (SplitPair, Maybe SplitPair)
splitPair from to cur val = case cur of
NoX curid -> fmap (,Nothing) <$> pair curid from to val
NoX curid -> (,Nothing) <$> pair curid from to val
X Exchange {xFromCur, xToCur, xAcnt, xRate} -> do
let middle = TaggedAcnt xAcnt []
res1 <- pair xFromCur from middle val
res2 <- pair xToCur middle to (val * roundPrecision 3 xRate)
return $ concatEithers2 res1 res2 $ \a b -> (a, Just b)
let res1 = pair xFromCur from middle val
let res2 = pair xToCur middle to (val * roundPrecision 3 xRate)
combineError res1 res2 $ \a b -> (a, Just b)
where
pair curid from_ to_ v = do
s1 <- split curid from_ (-v)
s2 <- split curid to_ v
return $ concatEithers2 s1 s2 (,)
let s1 = split curid from_ (-v)
let s2 = split curid to_ v
combineError s1 s2 (,)
split c TaggedAcnt {taAcnt, taTags} v =
resolveSplit $
Entry
@ -518,34 +506,37 @@ splitPair from to cur val = case cur of
}
checkAcntType
:: MonadFinance m
:: (MonadInsertError m, MonadFinance m)
=> AcntType
-> AcntID
-> m (EitherErrs AcntID)
-> m AcntID
checkAcntType t = checkAcntTypes (t :| [])
checkAcntTypes
:: MonadFinance m
:: (MonadInsertError m, MonadFinance m)
=> NE.NonEmpty AcntType
-> AcntID
-> m (EitherErrs AcntID)
checkAcntTypes ts i = (go =<<) <$> lookupAccountType i
-> m AcntID
checkAcntTypes ts i = go =<< lookupAccountType i
where
go t
| t `L.elem` ts = Right i
| otherwise = Left [AccountError i ts]
| t `L.elem` ts = return i
| otherwise = throwError $ InsertException [AccountError i ts]
--------------------------------------------------------------------------------
-- statements
insertStatements :: MonadFinance m => Config -> SqlPersistT m [InsertError]
insertStatements conf = concat <$> mapM insertStatement (statements conf)
insertStatement :: MonadFinance m => History -> SqlPersistT m [InsertError]
insertStatement (HistTransfer m) = insertManual m
insertStatement
:: (MonadUnliftIO m, MonadSqlQuery m, MonadFinance m)
=> History
-> m ()
insertStatement (HistTransfer m) = liftIOExceptT $ insertManual m
insertStatement (HistStatement i) = insertImport i
insertManual :: MonadFinance m => HistTransfer -> SqlPersistT m [InsertError]
insertManual
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
=> HistTransfer
-> m ()
insertManual
m@Transfer
{ transFrom = from
@ -553,48 +544,42 @@ insertManual
, transCurrency = u
, transAmounts = amts
} = do
whenHash CTManual m [] $ \c -> do
bounds <- lift $ askDBState kmStatementInterval
precRes <- lift $ lookupCurrencyPrec u
es <- forM amts $ \Amount {amtWhen, amtValue, amtDesc} -> do
let dayRes = expandDatePat bounds amtWhen
-- TODO rounding too often
unlessLefts (concatEithers2 dayRes precRes (,)) $ \(days, p) -> do
let tx day = txPair day from to u (roundPrecision p amtValue) amtDesc
txRes <- mapM (lift . tx) days
unlessLefts_ (concatEithersL txRes) $ mapM_ (insertTx c)
return $ concat es
whenHash CTManual m () $ \c -> do
bounds <- askDBState kmStatementInterval
let precRes = lookupCurrencyPrec u
let go Amount {amtWhen, amtValue, amtDesc} = do
let dayRes = liftExcept $ expandDatePat bounds amtWhen
(days, precision) <- combineError dayRes precRes (,)
let tx day = txPair day from to u (roundPrecision precision amtValue) amtDesc
keys <- combineErrors $ fmap tx days
mapM_ (insertTx c) keys
void $ combineErrors $ fmap go amts
insertImport :: MonadFinance m => Statement -> SqlPersistT m [InsertError]
insertImport i = whenHash CTImport i [] $ \c -> do
insertImport
:: (MonadUnliftIO m, MonadSqlQuery m, MonadFinance m)
=> Statement
-> m ()
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)
res <- mapM (lift . resolveTx) $ filter (inBounds bounds . txDate) bs
unlessLefts_ (concatEithersL res) $ mapM_ (insertTx c)
where
recoverIO x rest = do
res <- tryIO x
case res of
Right r -> rest r
-- If file is not found (or something else happens) then collect the
-- error try the remaining imports
Left e -> return [InsertIOError $ showT e]
bs <- readImport i
bounds <- expandBounds <$> askDBState kmStatementInterval
keys <- liftIOExceptT $ mapErrors resolveTx $ filter (inBounds bounds . txDate) bs
mapM_ (insertTx c) keys
--------------------------------------------------------------------------------
-- low-level transaction stuff
-- TODO tags here?
txPair
:: MonadFinance m
:: (MonadInsertError m, MonadFinance m)
=> Day
-> AcntID
-> AcntID
-> CurID
-> Rational
-> T.Text
-> m (EitherErrs KeyTx)
-> m KeyTx
txPair day from to cur val desc = resolveTx tx
where
split a v =
@ -612,73 +597,83 @@ txPair day from to cur val desc = resolveTx tx
, txSplits = [split from (-val), split to val]
}
resolveTx :: MonadFinance m => BalTx -> m (EitherErrs KeyTx)
resolveTx t@Tx {txSplits = ss} = do
res <- concatEithersL <$> mapM resolveSplit ss
return $ fmap (\kss -> t {txSplits = kss}) res
resolveTx :: (MonadInsertError m, MonadFinance m) => BalTx -> m KeyTx
resolveTx t@Tx {txSplits = ss} =
fmap (\kss -> t {txSplits = kss}) $
combineErrors $
fmap resolveSplit ss
resolveSplit :: MonadFinance m => BalSplit -> m (EitherErrs KeySplit)
resolveSplit :: (MonadInsertError m, MonadFinance m) => BalSplit -> m KeySplit
resolveSplit s@Entry {eAcnt, eCurrency, eValue, eTags} = do
aid <- lookupAccountKey eAcnt
cid <- lookupCurrencyKey eCurrency
sign <- lookupAccountSign eAcnt
tags <- mapM lookupTag eTags
let aRes = lookupAccountKey eAcnt
let cRes = lookupCurrencyKey eCurrency
let sRes = lookupAccountSign eAcnt
let tagRes = combineErrors $ fmap lookupTag eTags
-- TODO correct sign here?
-- TODO lenses would be nice here
return $
concatEithers2 (concatEithers3 aid cid sign (,,)) (concatEithersL tags) $
\(aid_, cid_, sign_) tags_ ->
combineError (combineError3 aRes cRes sRes (,,)) tagRes $
\(aid, cid, sign) tags ->
s
{ eAcnt = aid_
, eCurrency = cid_
, eValue = eValue * fromIntegral (sign2Int sign_)
, eTags = tags_
{ eAcnt = aid
, eCurrency = cid
, eValue = eValue * fromIntegral (sign2Int sign)
, eTags = tags
}
insertTx :: MonadUnliftIO m => Key CommitR -> KeyTx -> SqlPersistT m ()
insertTx :: MonadSqlQuery m => CommitRId -> KeyTx -> m ()
insertTx c Tx {txDate = d, txDescr = e, txSplits = ss} = do
k <- insert $ TransactionR c d e
mapM_ (insertSplit k) ss
insertSplit :: MonadUnliftIO m => Key TransactionR -> KeySplit -> SqlPersistT m (Key SplitR)
insertSplit :: MonadSqlQuery m => TransactionRId -> KeySplit -> m SplitRId
insertSplit t Entry {eAcnt, eCurrency, eValue, eComment, eTags} = do
k <- insert $ SplitR t eCurrency eAcnt eComment eValue
mapM_ (insert_ . TagRelationR k) eTags
return k
lookupAccount :: MonadFinance m => AcntID -> m (EitherErrs (Key AccountR, AcntSign, AcntType))
lookupAccount p = lookupErr (DBKey AcntField) p <$> askDBState kmAccount
lookupAccount :: (MonadInsertError m, MonadFinance m) => AcntID -> m (AccountRId, AcntSign, AcntType)
lookupAccount = lookupFinance AcntField kmAccount
lookupAccountKey :: MonadFinance m => AcntID -> m (EitherErrs (Key AccountR))
lookupAccountKey = fmap (fmap fstOf3) . lookupAccount
lookupAccountKey :: (MonadInsertError m, MonadFinance m) => AcntID -> m AccountRId
lookupAccountKey = fmap fstOf3 . lookupAccount
lookupAccountSign :: MonadFinance m => AcntID -> m (EitherErrs AcntSign)
lookupAccountSign = fmap (fmap sndOf3) . lookupAccount
lookupAccountSign :: (MonadInsertError m, MonadFinance m) => AcntID -> m AcntSign
lookupAccountSign = fmap sndOf3 . lookupAccount
lookupAccountType :: MonadFinance m => AcntID -> m (EitherErrs AcntType)
lookupAccountType = fmap (fmap thdOf3) . lookupAccount
lookupAccountType :: (MonadInsertError m, MonadFinance m) => AcntID -> m AcntType
lookupAccountType = fmap thdOf3 . lookupAccount
lookupCurrency :: MonadFinance m => T.Text -> m (EitherErrs (Key CurrencyR, Natural))
lookupCurrency c = lookupErr (DBKey CurField) c <$> askDBState kmCurrency
lookupCurrency :: (MonadInsertError m, MonadFinance m) => T.Text -> m (CurrencyRId, Natural)
lookupCurrency = lookupFinance CurField kmCurrency
lookupCurrencyKey :: MonadFinance m => AcntID -> m (EitherErrs (Key CurrencyR))
lookupCurrencyKey = fmap (fmap fst) . lookupCurrency
lookupCurrencyKey :: (MonadInsertError m, MonadFinance m) => AcntID -> m CurrencyRId
lookupCurrencyKey = fmap fst . lookupCurrency
lookupCurrencyPrec :: MonadFinance m => AcntID -> m (EitherErrs Natural)
lookupCurrencyPrec = fmap (fmap snd) . lookupCurrency
lookupCurrencyPrec :: (MonadInsertError m, MonadFinance m) => AcntID -> m Natural
lookupCurrencyPrec = fmap snd . lookupCurrency
lookupTag :: MonadFinance m => TagID -> m (EitherErrs (Key TagR))
lookupTag c = lookupErr (DBKey TagField) c <$> askDBState kmTag
lookupTag :: (MonadInsertError m, MonadFinance m) => TagID -> m TagRId
lookupTag = lookupFinance TagField kmTag
lookupFinance
:: (MonadInsertError m, MonadFinance m)
=> SplitIDType
-> (DBState -> M.Map T.Text a)
-> T.Text
-> m a
lookupFinance t f c = (liftExcept . lookupErr (DBKey t) c) =<< askDBState f
-- TODO this hashes twice (not that it really matters)
-- TODO generalize this (persistent mtl)
whenHash
:: (Hashable a, MonadFinance m)
:: (Hashable a, MonadFinance m, MonadSqlQuery m)
=> ConfigType
-> a
-> b
-> (Key CommitR -> SqlPersistT m b)
-> SqlPersistT m b
-> (CommitRId -> m b)
-> m b
whenHash t o def f = do
let h = hash o
hs <- lift $ askDBState kmNewCommits
hs <- askDBState kmNewCommits
if h `elem` hs then f =<< insert (CommitR h t) else return def

129
lib/Internal/Statement.hs
View File

@ -5,6 +5,8 @@ module Internal.Statement
)
where
import Control.Monad.Error.Class
import Control.Monad.Except
import Data.Csv
import Internal.Types
import Internal.Utils
@ -18,33 +20,33 @@ import RIO.Time
import qualified RIO.Vector as V
-- TODO this probably won't scale well (pipes?)
readImport :: MonadFinance m => Statement -> m (EitherErrs [BalTx])
readImport :: (MonadUnliftIO m, MonadFinance m) => Statement -> m [BalTx]
readImport Statement {..} = do
let ores = plural $ compileOptions stmtTxOpts
let cres = concatEithersL $ compileMatch <$> stmtParsers
let ores = compileOptions stmtTxOpts
let cres = combineErrors $ compileMatch <$> stmtParsers
(compiledOptions, compiledMatches) <- liftIOExcept $ combineError ores cres (,)
let readStmt = readImport_ stmtSkipLines stmtDelim compiledOptions
records <- L.sort . concat <$> mapErrorsIO readStmt stmtPaths
m <- askDBState kmCurrency
case concatEithers2 ores cres (,) of
Right (compiledOptions, compiledMatches) -> do
ires <- mapM (readImport_ stmtSkipLines stmtDelim compiledOptions) stmtPaths
case concatEitherL ires of
Right records -> return $ runReader (matchRecords compiledMatches $ L.sort $ concat records) m
Left es -> return $ Left es
Left es -> return $ Left es
fromEither $
flip runReader m $
runExceptT $
matchRecords compiledMatches records
readImport_
:: MonadFinance m
:: (MonadUnliftIO m, MonadFinance m)
=> Natural
-> Word
-> TxOptsRe
-> FilePath
-> m (EitherErr [TxRecord])
-> m [TxRecord]
readImport_ n delim tns p = do
dir <- askDBState kmConfigDir
bs <- liftIO $ BL.readFile $ dir </> p
res <- tryIO $ BL.readFile $ dir </> p
bs <- fromEither $ first (InsertException . (: []) . InsertIOError . showT) res
case decodeByNameWithP (parseTxRecord p tns) opts $ skip bs of
Left m -> return $ Left $ ParseError $ T.pack m
Right (_, v) -> return $ Right $ catMaybes $ V.toList v
Left m -> throwIO $ InsertException [ParseError $ T.pack m]
Right (_, v) -> return $ catMaybes $ V.toList v
where
opts = defaultDecodeOptions {decDelimiter = fromIntegral delim}
skip = BL.intercalate "\n" . L.drop (fromIntegral n) . BL.split 10
@ -63,17 +65,13 @@ parseTxRecord p TxOpts {..} r = do
d' <- parseTimeM True defaultTimeLocale (T.unpack toDateFmt) d
return $ Just $ TxRecord d' a e os p
matchRecords :: [MatchRe] -> [TxRecord] -> CurrencyM (EitherErrs [BalTx])
matchRecords :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM [BalTx]
matchRecords ms rs = do
res <- matchAll (matchPriorities ms) rs
case res of
Left es -> return $ Left es
Right (matched, unmatched, notfound) -> do
(matched, unmatched, notfound) <- matchAll (matchPriorities ms) rs
case (matched, unmatched, notfound) of
(ms_, [], []) -> do
-- TODO record number of times each match hits for debugging
return $ first (: []) $ mapM balanceTx ms_
(_, us, ns) -> return $ Left [StatementError us ns]
(ms_, [], []) -> liftInner $ combineErrors $ fmap balanceTx ms_
(_, us, ns) -> throwError $ InsertException [StatementError us ns]
matchPriorities :: [MatchRe] -> [MatchGroup]
matchPriorities =
@ -130,35 +128,33 @@ zipperSlice f x = go
zipperMatch
:: Unzipped MatchRe
-> TxRecord
-> CurrencyM (EitherErrs (Zipped MatchRe, MatchRes RawTx))
-> InsertExceptT CurrencyM (Zipped MatchRe, MatchRes RawTx)
zipperMatch (Unzipped bs cs as) x = go [] cs
where
go _ [] = return $ Right (Zipped bs $ cs ++ as, MatchFail)
go _ [] = return (Zipped bs $ cs ++ as, MatchFail)
go prev (m : ms) = do
res <- matches m x
case res of
Right MatchFail -> go (m : prev) ms
Right skipOrPass ->
MatchFail -> go (m : prev) ms
skipOrPass ->
let ps = reverse prev
ms' = maybe ms (: ms) (matchDec m)
in return $ Right (Zipped bs $ ps ++ ms' ++ as, skipOrPass)
Left es -> return $ Left es
in return (Zipped bs $ ps ++ ms' ++ as, skipOrPass)
-- TODO all this unpacking left/error crap is annoying
zipperMatch'
:: Zipped MatchRe
-> TxRecord
-> CurrencyM (EitherErrs (Zipped MatchRe, MatchRes RawTx))
-> InsertExceptT CurrencyM (Zipped MatchRe, MatchRes RawTx)
zipperMatch' z x = go z
where
go (Zipped bs (a : as)) = do
res <- matches a x
case res of
Right MatchFail -> go (Zipped (a : bs) as)
Right skipOrPass ->
return $ Right (Zipped (maybe bs (: bs) $ matchDec a) as, skipOrPass)
Left es -> return $ Left es
go z' = return $ Right (z', MatchFail)
MatchFail -> go (Zipped (a : bs) as)
skipOrPass ->
return (Zipped (maybe bs (: bs) $ matchDec a) as, skipOrPass)
go z' = return (z', MatchFail)
matchDec :: MatchRe -> Maybe MatchRe
matchDec m = case spTimes m of
@ -166,37 +162,27 @@ matchDec m = case spTimes m of
Just n -> Just $ m {spTimes = Just $ n - 1}
Nothing -> Just m
matchAll :: [MatchGroup] -> [TxRecord] -> CurrencyM (EitherErrs ([RawTx], [TxRecord], [MatchRe]))
matchAll :: [MatchGroup] -> [TxRecord] -> InsertExceptT CurrencyM ([RawTx], [TxRecord], [MatchRe])
matchAll = go ([], [])
where
go (matched, unused) gs rs = case (gs, rs) of
(_, []) -> return $ Right (matched, [], unused)
([], _) -> return $ Right (matched, rs, unused)
(_, []) -> return (matched, [], unused)
([], _) -> return (matched, rs, unused)
(g : gs', _) -> do
res <- matchGroup g rs
case res of
Right (ts, unmatched, us) ->
(ts, unmatched, us) <- matchGroup g rs
go (ts ++ matched, us ++ unused) gs' unmatched
Left es -> return $ Left es
matchGroup :: MatchGroup -> [TxRecord] -> CurrencyM (EitherErrs ([RawTx], [TxRecord], [MatchRe]))
matchGroup :: MatchGroup -> [TxRecord] -> InsertExceptT CurrencyM ([RawTx], [TxRecord], [MatchRe])
matchGroup MatchGroup {mgDate = ds, mgNoDate = ns} rs = do
res <- matchDates ds rs
case res of
Left es -> return $ Left es
Right (md, rest, ud) -> do
res' <- matchNonDates ns rest
case res' of
Right (mn, unmatched, un) -> do
return $ Right $ (md ++ mn, unmatched, filter ((/= Nothing) . spTimes) $ ud ++ un)
Left es -> return $ Left es
(md, rest, ud) <- matchDates ds rs
(mn, unmatched, un) <- matchNonDates ns rest
return (md ++ mn, unmatched, filter ((/= Nothing) . spTimes) $ ud ++ un)
matchDates :: [MatchRe] -> [TxRecord] -> CurrencyM (EitherErrs ([RawTx], [TxRecord], [MatchRe]))
matchDates :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM ([RawTx], [TxRecord], [MatchRe])
matchDates ms = go ([], [], initZipper ms)
where
go (matched, unmatched, z) [] =
return $
Right
return
( catMaybes matched
, reverse unmatched
, recoverZipper z
@ -205,44 +191,37 @@ matchDates ms = go ([], [], initZipper ms)
case zipperSlice findDate r z of
Left zipped -> go (matched, r : unmatched, zipped) rs
Right unzipped -> do
res <- zipperMatch unzipped r
case res of
Right (z', res') -> do
let (m, u) = case res' of
(z', res) <- zipperMatch unzipped r
let (m, u) = case res of
(MatchPass p) -> (Just p : matched, unmatched)
MatchSkip -> (Nothing : matched, unmatched)
MatchFail -> (matched, r : unmatched)
go (m, u, z') rs
Left es -> return $ Left es
findDate m r = maybe EQ (`compareDate` trDate r) $ spDate m
matchNonDates :: [MatchRe] -> [TxRecord] -> CurrencyM (EitherErrs ([RawTx], [TxRecord], [MatchRe]))
matchNonDates :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM ([RawTx], [TxRecord], [MatchRe])
matchNonDates ms = go ([], [], initZipper ms)
where
go (matched, unmatched, z) [] =
return $
Right
return
( catMaybes matched
, reverse unmatched
, recoverZipper z
)
go (matched, unmatched, z) (r : rs) = do
res <- zipperMatch' z r
case res of
Left es -> return $ Left es
Right (z', res') -> do
let (m, u) = case res' of
(z', res) <- zipperMatch' z r
let (m, u) = case res of
MatchPass p -> (Just p : matched, unmatched)
MatchSkip -> (Nothing : matched, unmatched)
MatchFail -> (matched, r : unmatched)
in go (m, u, resetZipper z') rs
balanceTx :: RawTx -> EitherErr BalTx
balanceTx :: RawTx -> InsertExcept BalTx
balanceTx t@Tx {txSplits = ss} = do
bs <- balanceSplits ss
return $ t {txSplits = bs}
balanceSplits :: [RawSplit] -> EitherErr [BalSplit]
balanceSplits :: [RawSplit] -> InsertExcept [BalSplit]
balanceSplits ss =
fmap concat
<$> mapM (uncurry bal)
@ -252,11 +231,11 @@ balanceSplits ss =
haeValue s@Entry {eValue = Just v} = Right s {eValue = v}
haeValue s = Left s
bal cur rss
| length rss < 2 = Left $ BalanceError TooFewSplits cur rss
| length rss < 2 = throwError $ InsertException [BalanceError TooFewSplits cur rss]
| otherwise = case partitionEithers $ fmap haeValue rss of
([noVal], val) -> Right $ noVal {eValue = foldr (\s x -> x - eValue s) 0 val} : val
([], val) -> Right val
_ -> Left $ BalanceError NotOneBlank cur rss
([noVal], val) -> return $ noVal {eValue = foldr (\s x -> x - eValue s) 0 val} : val
([], val) -> return val
_ -> throwError $ InsertException [BalanceError NotOneBlank cur rss]
groupByKey :: Ord k => [(k, v)] -> [(k, [v])]
groupByKey = M.toList . M.fromListWith (++) . fmap (second (: []))

25
lib/Internal/Types.hs
View File

@ -1,11 +1,12 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UndecidableInstances #-}
module Internal.Types where
-- import Control.Monad.Except
import Control.Monad.Except
import Data.Fix (Fix (..), foldFix)
import Data.Functor.Foldable (embed)
import qualified Data.Functor.Foldable.TH as TH
@ -601,8 +602,6 @@ data DBState = DBState
type CurrencyM = Reader CurrencyMap
type MappingT m = ReaderT DBState (SqlPersistT m)
type KeySplit = Entry AccountRId Rational CurrencyRId TagRId
type KeyTx = Tx KeySplit
@ -611,13 +610,12 @@ type TreeR = Tree ([T.Text], AccountRId)
type Balances = M.Map AccountRId Rational
type BalanceM m = ReaderT (MVar Balances) m
type BalanceM = ReaderT (MVar Balances)
class MonadUnliftIO m => MonadFinance m where
askDBState :: (DBState -> a) -> m a
type MonadFinance = MonadReader DBState
instance MonadUnliftIO m => MonadFinance (ReaderT DBState m) where
askDBState = asks
askDBState :: MonadFinance m => (DBState -> a) -> m a
askDBState = asks
class MonadUnliftIO m => MonadBalance m where
askBalances :: m (MVar Balances)
@ -746,17 +744,16 @@ data InsertError
| StatementError ![TxRecord] ![MatchRe]
deriving (Show)
newtype InsertException = InsertException [InsertError] deriving (Show)
newtype InsertException = InsertException [InsertError]
deriving (Show, Semigroup) via [InsertError]
instance Exception InsertException
type EitherErr = Either InsertError
type MonadInsertError = MonadError InsertException
type EitherErrs = Either [InsertError]
type InsertExceptT = ExceptT InsertException
-- type InsertExceptT m = ExceptT [InsertError] m
-- type InsertExcept = InsertExceptT Identity
type InsertExcept = InsertExceptT Identity
data XGregorian = XGregorian
{ xgYear :: !Int

336
lib/Internal/Utils.hs
View File

@ -7,15 +7,33 @@ module Internal.Utils
, fromGregorian'
, resolveBounds
, resolveBounds_
, leftToMaybe
, concatEithers2
, concatEithers3
, concatEither3
, concatEither2
, concatEitherL
, concatEithersL
, concatEither2M
, concatEithers2M
, liftInner
, liftExceptT
, liftExcept
, liftIOExcept
, liftIOExceptT
, combineError
, combineError_
, combineError3
, combineErrors
, mapErrors
, combineErrorM
, combineErrorM3
, combineErrorIO2
, combineErrorIO3
, combineErrorIOM2
, combineErrorIOM3
, collectErrorsIO
, mapErrorsIO
-- , leftToMaybe
-- , concatEithers2
-- , concatEithers3
-- , concatEither3
-- , concatEither2
-- , concatEitherL
-- , concatEithersL
-- , concatEither2M
-- , concatEithers2M
, parseRational
, showError
, unlessLeft_
@ -31,7 +49,7 @@ module Internal.Utils
, sndOf3
, thdOf3
, xGregToDay
, plural
-- , plural
, compileMatch
, compileOptions
, dateMatches
@ -41,6 +59,8 @@ module Internal.Utils
)
where
import Control.Monad.Error.Class
import Control.Monad.Except
import Control.Monad.Reader
import Data.Time.Format.ISO8601
import GHC.Real
@ -134,17 +154,17 @@ fromGregorian' = uncurry3 fromGregorian . gregTup
inBounds :: (Day, Day) -> Day -> Bool
inBounds (d0, d1) x = d0 <= x && x < d1
resolveBounds :: Interval -> EitherErr Bounds
resolveBounds :: Interval -> InsertExcept Bounds
resolveBounds i@Interval {intStart = s} =
resolveBounds_ (s {gYear = gYear s + 50}) i
resolveBounds_ :: Gregorian -> Interval -> EitherErr Bounds
resolveBounds_ :: Gregorian -> Interval -> InsertExcept Bounds
resolveBounds_ def Interval {intStart = s, intEnd = e} =
case fromGregorian' <$> e of
Nothing -> Right $ toBounds $ fromGregorian' def
Nothing -> return $ toBounds $ fromGregorian' def
Just e_
| s_ < e_ -> Right $ toBounds e_
| otherwise -> Left $ BoundsError s e
| s_ < e_ -> return $ toBounds e_
| otherwise -> throwError $ InsertException [BoundsError s e]
where
s_ = fromGregorian' s
toBounds end = (s_, fromIntegral $ diffDays end s_ - 1)
@ -155,30 +175,26 @@ expandBounds (d, n) = (d, addDays (fromIntegral n + 1) d)
--------------------------------------------------------------------------------
-- matching
matches :: MatchRe -> TxRecord -> CurrencyM (EitherErrs (MatchRes RawTx))
matches :: MatchRe -> TxRecord -> InsertExceptT CurrencyM (MatchRes RawTx)
matches
StatementParser {spTx, spOther, spVal, spDate, spDesc}
r@TxRecord {trDate, trAmount, trDesc, trOther} = do
let res = concatEithers3 val other desc $ \x y z -> x && y && z && date
case res of
Right test
| test -> maybe (return $ Right MatchSkip) convert spTx
| otherwise -> return $ Right MatchFail
Left es -> return $ Left es
res <- liftInner $
combineError3 val other desc $
\x y z -> x && y && z && date
if res
then maybe (return MatchSkip) convert spTx
else return MatchFail
where
val = valMatches spVal trAmount
date = maybe True (`dateMatches` trDate) spDate
other = foldM (\a o -> (a &&) <$> otherMatches trOther o) True spOther
desc = maybe (return True) (matchMaybe trDesc . snd) spDesc
convert (TxGetter cur a ss) = do
res <- toTx cur a ss r
return $ fmap MatchPass res
convert (TxGetter cur a ss) = MatchPass <$> toTx cur a ss r
toTx :: SplitCur -> SplitAcnt -> [EntryGetter] -> TxRecord -> CurrencyM (EitherErrs RawTx)
toTx :: SplitCur -> SplitAcnt -> [EntryGetter] -> TxRecord -> InsertExceptT CurrencyM RawTx
toTx sc sa toSplits r@TxRecord {trAmount, trDate, trDesc} = do
m <- ask
let ssRes = concatEithersL $ fmap (resolveEntry m r) toSplits
return $ concatEithers2 acRes ssRes $ \(a, c) ss ->
combineError3 acntRes curRes ssRes $ \a c ss ->
let fromSplit =
Entry
{ eAcnt = a
@ -193,13 +209,15 @@ toTx sc sa toSplits r@TxRecord {trAmount, trDate, trDesc} = do
, txSplits = fromSplit : ss
}
where
acRes = concatEithers2 (resolveAcnt r sa) (resolveCurrency r sc) (,)
acntRes = liftInner $ resolveAcnt r sa
curRes = liftInner $ resolveCurrency r sc
ssRes = combineErrors $ fmap (resolveEntry r) toSplits
valMatches :: ValMatcher -> Rational -> EitherErrs Bool
valMatches :: ValMatcher -> Rational -> InsertExcept Bool
valMatches ValMatcher {vmDen, vmSign, vmNum, vmPrec} x
| Just d_ <- vmDen, d_ >= p = Left [MatchValPrecisionError d_ p]
| Just d_ <- vmDen, d_ >= p = throwError $ InsertException [MatchValPrecisionError d_ p]
| otherwise =
Right $
return $
checkMaybe (s ==) vmSign
&& checkMaybe (n ==) vmNum
&& checkMaybe ((d * fromIntegral p ==) . fromIntegral) vmDen
@ -212,58 +230,138 @@ valMatches ValMatcher {vmDen, vmSign, vmNum, vmPrec} x
dateMatches :: DateMatcher -> Day -> Bool
dateMatches md = (EQ ==) . compareDate md
otherMatches :: M.Map T.Text T.Text -> FieldMatcherRe -> EitherErrs Bool
otherMatches :: M.Map T.Text T.Text -> FieldMatcherRe -> InsertExcept Bool
otherMatches dict m = case m of
Val (Field n mv) -> valMatches mv =<< (readRational =<< lookup_ MatchNumeric n)
Desc (Field n (_, md)) -> (`matchMaybe` md) =<< lookup_ MatchText n
where
lookup_ t n = lookupErr (MatchField t) n dict
resolveEntry :: CurrencyMap -> TxRecord -> EntryGetter -> EitherErrs RawSplit
resolveEntry m r s@Entry {eAcnt, eValue, eCurrency} = do
(a, c, v) <- concatEithers2 acRes valRes $ \(a, c) v -> (a, c, v)
resolveEntry :: TxRecord -> EntryGetter -> InsertExceptT CurrencyM RawSplit
resolveEntry r s@Entry {eAcnt, eValue, eCurrency} = do
m <- ask
liftInner $ combineErrorM3 acntRes curRes valRes $ \a c v -> do
v' <- mapM (roundPrecisionCur c m) v
return $
s
{ eAcnt = a
, eValue = v'
, eCurrency = c
}
return $ s {eAcnt = a, eValue = v', eCurrency = c}
where
acRes = concatEithers2 (resolveAcnt r eAcnt) (resolveCurrency r eCurrency) (,)
acntRes = resolveAcnt r eAcnt
curRes = resolveCurrency r eCurrency
valRes = mapM (resolveValue r) eValue
resolveValue :: TxRecord -> EntryNumGetter -> EitherErrs Double
liftInner :: Monad m => ExceptT e Identity a -> ExceptT e m a
liftInner = mapExceptT (return . runIdentity)
liftExceptT :: MonadError e m => ExceptT e m a -> m a
liftExceptT x = runExceptT x >>= either throwError return
liftExcept :: MonadError e m => Except e a -> m a
liftExcept = either throwError return . runExcept
-- tryError :: MonadError e m => m a -> m (Either e a)
-- tryError action = (Right <$> action) `catchError` (pure . Left)
liftIOExceptT :: MonadIO m => InsertExceptT m a -> m a
liftIOExceptT = fromEither <=< runExceptT
liftIOExcept :: MonadIO m => InsertExcept a -> m a
liftIOExcept = fromEither . runExcept
combineError :: MonadError InsertException m => m a -> m b -> (a -> b -> c) -> m c
combineError a b f = combineErrorM a b (\x y -> pure $ f x y)
combineError_ :: MonadError InsertException m => m a -> m b -> m ()
combineError_ a b = do
_ <- catchError a $ \e ->
throwError =<< catchError (e <$ b) (return . (e <>))
_ <- b
return ()
combineErrorM :: MonadError InsertException m => m a -> m b -> (a -> b -> m c) -> m c
combineErrorM a b f = do
a' <- catchError a $ \e ->
throwError =<< catchError (e <$ b) (return . (e <>))
f a' =<< b
combineError3 :: MonadError InsertException m => m a -> m b -> m c -> (a -> b -> c -> d) -> m d
combineError3 a b c f =
combineError (combineError a b (,)) c $ \(x, y) z -> f x y z
combineErrorM3 :: MonadError InsertException m => m a -> m b -> m c -> (a -> b -> c -> m d) -> m d
combineErrorM3 a b c f = do
combineErrorM (combineErrorM a b (curry return)) c $ \(x, y) z -> f x y z
combineErrors :: MonadError InsertException m => [m a] -> m [a]
combineErrors = mapErrors id
mapErrors :: MonadError InsertException m => (a -> m b) -> [a] -> m [b]
mapErrors f xs = do
ys <- mapM (go . f) xs
case partitionEithers ys of
([], zs) -> return zs
(e : es, _) -> throwError $ foldr (<>) e es
where
go x = catchError (Right <$> x) (pure . Left)
combineErrorIO2 :: MonadUnliftIO m => m a -> m b -> (a -> b -> c) -> m c
combineErrorIO2 a b f = combineErrorIOM2 a b (\x y -> pure $ f x y)
combineErrorIO3 :: MonadUnliftIO m => m a -> m b -> m c -> (a -> b -> c -> d) -> m d
combineErrorIO3 a b c f = combineErrorIOM3 a b c (\x y z -> pure $ f x y z)
combineErrorIOM2 :: MonadUnliftIO m => m a -> m b -> (a -> b -> m c) -> m c
combineErrorIOM2 a b f = do
a' <- catch a $ \(InsertException es) ->
(throwIO . InsertException)
=<< catch (es <$ b) (\(InsertException es') -> return (es' ++ es))
f a' =<< b
combineErrorIOM3 :: MonadUnliftIO m => m a -> m b -> m c -> (a -> b -> c -> m d) -> m d
combineErrorIOM3 a b c f =
combineErrorIOM2 (combineErrorIOM2 a b (curry return)) c $ \(x, y) z -> f x y z
mapErrorsIO :: MonadUnliftIO m => (a -> m b) -> [a] -> m [b]
mapErrorsIO f xs = do
ys <- mapM (go . f) xs
case partitionEithers ys of
([], zs) -> return zs
(es, _) -> throwIO $ InsertException $ concat es
where
go x = catch (Right <$> x) $ \(InsertException es) -> pure $ Left es
collectErrorsIO :: MonadUnliftIO m => [m a] -> m [a]
collectErrorsIO = mapErrorsIO id
resolveValue :: TxRecord -> EntryNumGetter -> InsertExcept Double
resolveValue r s = case s of
(LookupN t) -> readDouble =<< lookupErr SplitValField t (trOther r)
(ConstN c) -> Right c
(ConstN c) -> return c
-- TODO don't coerce to rational in trAmount
AmountN -> Right $ fromRational $ trAmount r
AmountN -> return $ fromRational $ trAmount r
resolveAcnt :: TxRecord -> SplitAcnt -> EitherErrs T.Text
resolveAcnt :: TxRecord -> SplitAcnt -> InsertExcept T.Text
resolveAcnt = resolveSplitField AcntField
resolveCurrency :: TxRecord -> SplitCur -> EitherErrs T.Text
resolveCurrency :: TxRecord -> SplitCur -> InsertExcept T.Text
resolveCurrency = resolveSplitField CurField
resolveSplitField :: SplitIDType -> TxRecord -> SplitAcnt -> EitherErrs T.Text
resolveSplitField :: SplitIDType -> TxRecord -> SplitAcnt -> InsertExcept T.Text
resolveSplitField t TxRecord {trOther = o} s = case s of
ConstT p -> Right p
ConstT p -> return p
LookupT f -> lookup_ f o
MapT (Field f m) -> do
k <- lookup_ f o
lookup_ k m
Map2T (Field (f1, f2) m) -> do
(k1, k2) <- concatEithers2 (lookup_ f1 o) (lookup_ f2 o) (,)
(k1, k2) <- combineError (lookup_ f1 o) (lookup_ f2 o) (,)
lookup_ (k1, k2) m
where
lookup_ :: (Ord k, Show k) => k -> M.Map k v -> EitherErrs v
lookup_ :: (Ord k, Show k) => k -> M.Map k v -> InsertExcept v
lookup_ = lookupErr (SplitIDField t)
lookupErr :: (Ord k, Show k) => LookupSuberr -> k -> M.Map k v -> EitherErrs v
lookupErr :: (Ord k, Show k) => LookupSuberr -> k -> M.Map k v -> InsertExcept v
lookupErr what k m = case M.lookup k m of
Just x -> Right x
_ -> Left [LookupError what $ showT k]
Just x -> return x
_ -> throwError $ InsertException [LookupError what $ showT k]
parseRational :: MonadFail m => (T.Text, Regex) -> T.Text -> m Rational
parseRational (pat, re) s = case matchGroupsMaybe s re of
@ -292,12 +390,12 @@ parseRational (pat, re) s = case matchGroupsMaybe s re of
k <- readSign sign
return (k, w)
readDouble :: T.Text -> EitherErrs Double
readDouble :: T.Text -> InsertExcept Double
readDouble s = case readMaybe $ T.unpack s of
Just x -> Right x
Nothing -> Left [ConversionError s]
Just x -> return x
Nothing -> throwError $ InsertException [ConversionError s]
readRational :: T.Text -> EitherErrs Rational
readRational :: T.Text -> InsertExcept Rational
readRational s = case T.split (== '.') s of
[x] -> maybe err (return . fromInteger) $ readT x
[x, y] -> case (readT x, readT y) of
@ -309,7 +407,7 @@ readRational s = case T.split (== '.') s of
_ -> err
where
readT = readMaybe . T.unpack
err = Left [ConversionError s]
err = throwError $ InsertException [ConversionError s]
-- TODO smells like a lens
-- mapTxSplits :: (a -> b) -> Tx a -> Tx b
@ -331,17 +429,11 @@ roundPrecision n = (% p) . round . (* fromIntegral p) . toRational
where
p = 10 ^ n
roundPrecisionCur :: CurID -> CurrencyMap -> Double -> EitherErrs Rational
roundPrecisionCur :: CurID -> CurrencyMap -> Double -> InsertExcept Rational
roundPrecisionCur c m x =
case M.lookup c m of
Just (_, n) -> Right $ roundPrecision n x
Nothing -> Left undefined
-- dec2Rat :: Decimal -> Rational
-- dec2Rat D {sign, whole, decimal, precision} =
-- k * (fromIntegral whole + (fromIntegral decimal % (10 ^ precision)))
-- where
-- k = if sign then 1 else -1
Just (_, n) -> return $ roundPrecision n x
Nothing -> throwError $ InsertException [undefined]
acntPath2Text :: AcntPath -> T.Text
acntPath2Text (AcntPath t cs) = T.intercalate "/" (atName t : cs)
@ -538,51 +630,51 @@ showT = T.pack . show
--------------------------------------------------------------------------------
-- pure error processing
concatEither2 :: Either x a -> Either x b -> (a -> b -> c) -> Either [x] c
concatEither2 a b fun = case (a, b) of
(Right a_, Right b_) -> Right $ fun a_ b_
_ -> Left $ catMaybes [leftToMaybe a, leftToMaybe b]
-- concatEither2 :: Either x a -> Either x b -> (a -> b -> c) -> Either [x] c
-- concatEither2 a b fun = case (a, b) of
-- (Right a_, Right b_) -> Right $ fun a_ b_
-- _ -> Left $ catMaybes [leftToMaybe a, leftToMaybe b]
concatEither2M :: Monad m => Either x a -> Either x b -> (a -> b -> m c) -> m (Either [x] c)
concatEither2M a b fun = case (a, b) of
(Right a_, Right b_) -> Right <$> fun a_ b_
_ -> return $ Left $ catMaybes [leftToMaybe a, leftToMaybe b]
-- concatEither2M :: Monad m => Either x a -> Either x b -> (a -> b -> m c) -> m (Either [x] c)
-- concatEither2M a b fun = case (a, b) of
-- (Right a_, Right b_) -> Right <$> fun a_ b_
-- _ -> return $ Left $ catMaybes [leftToMaybe a, leftToMaybe b]
concatEither3 :: Either x a -> Either x b -> Either x c -> (a -> b -> c -> d) -> Either [x] d
concatEither3 a b c fun = case (a, b, c) of
(Right a_, Right b_, Right c_) -> Right $ fun a_ b_ c_
_ -> Left $ catMaybes [leftToMaybe a, leftToMaybe b, leftToMaybe c]
-- concatEither3 :: Either x a -> Either x b -> Either x c -> (a -> b -> c -> d) -> Either [x] d
-- concatEither3 a b c fun = case (a, b, c) of
-- (Right a_, Right b_, Right c_) -> Right $ fun a_ b_ c_
-- _ -> Left $ catMaybes [leftToMaybe a, leftToMaybe b, leftToMaybe c]
concatEithers2 :: Either [x] a -> Either [x] b -> (a -> b -> c) -> Either [x] c
concatEithers2 a b = merge . concatEither2 a b
-- concatEithers2 :: Either [x] a -> Either [x] b -> (a -> b -> c) -> Either [x] c
-- concatEithers2 a b = merge . concatEither2 a b
concatEithers2M
:: Monad m
=> Either [x] a
-> Either [x] b
-> (a -> b -> m c)
-> m (Either [x] c)
concatEithers2M a b = fmap merge . concatEither2M a b
-- concatEithers2M
-- :: Monad m
-- => Either [x] a
-- -> Either [x] b
-- -> (a -> b -> m c)
-- -> m (Either [x] c)
-- concatEithers2M a b = fmap merge . concatEither2M a b
concatEithers3
:: Either [x] a
-> Either [x] b
-> Either [x] c
-> (a -> b -> c -> d)
-> Either [x] d
concatEithers3 a b c = merge . concatEither3 a b c
-- concatEithers3
-- :: Either [x] a
-- -> Either [x] b
-- -> Either [x] c
-- -> (a -> b -> c -> d)
-- -> Either [x] d
-- concatEithers3 a b c = merge . concatEither3 a b c
concatEitherL :: [Either x a] -> Either [x] [a]
concatEitherL as = case partitionEithers as of
([], bs) -> Right bs
(es, _) -> Left es
-- concatEitherL :: [Either x a] -> Either [x] [a]
-- concatEitherL as = case partitionEithers as of
-- ([], bs) -> Right bs
-- (es, _) -> Left es
concatEithersL :: [Either [x] a] -> Either [x] [a]
concatEithersL = merge . concatEitherL
-- concatEithersL :: [Either [x] a] -> Either [x] [a]
-- concatEithersL = merge . concatEitherL
leftToMaybe :: Either a b -> Maybe a
leftToMaybe (Left a) = Just a
leftToMaybe _ = Nothing
-- leftToMaybe :: Either a b -> Maybe a
-- leftToMaybe (Left a) = Just a
-- leftToMaybe _ = Nothing
unlessLeft :: (Monad m, MonadPlus n) => Either a b -> (b -> m (n a)) -> m (n a)
unlessLeft (Left es) _ = return (return es)
@ -598,11 +690,11 @@ unlessLeft_ e f = unlessLeft e (\x -> void (f x) >> return mzero)
unlessLefts_ :: (Monad m, MonadPlus n) => Either (n a) b -> (b -> m ()) -> m (n a)
unlessLefts_ e f = unlessLefts e (\x -> void (f x) >> return mzero)
plural :: Either a b -> Either [a] b
plural = first (: [])
-- plural :: Either a b -> Either [a] b
-- plural = first (: [])
merge :: Either [[a]] b -> Either [a] b
merge = first concat
-- merge :: Either [[a]] b -> Either [a] b
-- merge = first concat
--------------------------------------------------------------------------------
-- random functions
@ -646,23 +738,23 @@ thdOf3 (_, _, c) = c
-- -- these options barely do anything in terms of performance
-- compres = compile (blankCompOpt {newSyntax = True}) (blankExecOpt {captureGroups = False}) pat
compileOptions :: TxOpts T.Text -> EitherErr TxOptsRe
compileOptions :: TxOpts T.Text -> InsertExcept TxOptsRe
compileOptions o@TxOpts {toAmountFmt = pat} = do
re <- compileRegex True pat
return $ o {toAmountFmt = re}
compileMatch :: StatementParser T.Text -> EitherErrs MatchRe
compileMatch :: StatementParser T.Text -> InsertExcept MatchRe
compileMatch m@StatementParser {spDesc, spOther} = do
let dres = plural $ mapM go spDesc
let ores = concatEitherL $ fmap (mapM go) spOther
concatEithers2 dres ores $ \d_ os_ -> m {spDesc = d_, spOther = os_}
combineError dres ores $ \d os -> m {spDesc = d, spOther = os}
where
go = compileRegex False
dres = mapM go spDesc
ores = combineErrors $ fmap (mapM go) spOther
compileRegex :: Bool -> T.Text -> EitherErr (Text, Regex)
compileRegex :: Bool -> T.Text -> InsertExcept (Text, Regex)
compileRegex groups pat = case res of
Right re -> Right (pat, re)
Left _ -> Left $ RegexError pat
Right re -> return (pat, re)
Left _ -> throwError $ InsertException [RegexError pat]
where
res =
compile
@ -670,10 +762,10 @@ compileRegex groups pat = case res of
(blankExecOpt {captureGroups = groups})
pat
matchMaybe :: T.Text -> Regex -> EitherErrs Bool
matchMaybe :: T.Text -> Regex -> InsertExcept Bool
matchMaybe q re = case execute re q of
Right res -> Right $ isJust res
Left _ -> Left [RegexError "this should not happen"]
Right res -> return $ isJust res
Left _ -> throwError $ InsertException [RegexError "this should not happen"]
matchGroupsMaybe :: T.Text -> Regex -> [T.Text]
matchGroupsMaybe q re = case regexec re q of

1
package.yaml
View File

@ -86,6 +86,7 @@ dependencies:
- data-fix
- filepath
- mtl
- persistent-mtl >= 0.3.0.0
library:
source-dirs: lib/

1
stack.yaml
View File

@ -46,6 +46,7 @@ extra-deps:
commit: ffd1ba94ef39b875aba8adc1c498f28aa02e36e4
subdirs: [dhall]
- hashable-1.3.5.0
- persistent-mtl-0.3.0.0
#
# extra-deps: []