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

2
budget.cabal
View File

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

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

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

381
lib/Internal/Insert.hs
View File

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

167
lib/Internal/Statement.hs
View File

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

25
lib/Internal/Types.hs
View File

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

338
lib/Internal/Utils.hs
View File

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

1
package.yaml
View File

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

1
stack.yaml
View File

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