From 8c9dc1e9709ba9dc23959f7be0dfd6710ac0552f Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Tue, 4 Jul 2023 00:11:25 -0400 Subject: [PATCH] REF rearrange stuff --- app/Main.hs | 1 - lib/Internal/History.hs | 241 ++++++++++++++++++++++ lib/Internal/Types/Database.hs | 1 + lib/Internal/Types/Main.hs | 9 +- lib/Internal/Utils.hs | 360 +-------------------------------- 5 files changed, 251 insertions(+), 361 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index a4847bd..4c61c7b 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -180,7 +180,6 @@ runSync c = do hSs' <- mapErrorsIO (readHistStmt root) hSs hTs' <- liftIOExceptT $ mapErrors readHistTransfer hTs bTs <- liftIOExceptT $ mapErrors readBudget $ budget config - -- lift $ print hTs' return $ second concat $ partitionEithers $ hSs' ++ hTs' ++ bTs -- Update the DB. diff --git a/lib/Internal/History.hs b/lib/Internal/History.hs index 3b7176f..f705d45 100644 --- a/lib/Internal/History.hs +++ b/lib/Internal/History.hs @@ -8,6 +8,7 @@ where import Control.Monad.Except import Data.Csv import Data.Foldable +import GHC.Real import Internal.Database import Internal.Types.Main import Internal.Utils @@ -19,6 +20,8 @@ import qualified RIO.Map as M import qualified RIO.Text as T import RIO.Time import qualified RIO.Vector as V +import Text.Regex.TDFA hiding (matchAll) +import Text.Regex.TDFA.Text -- NOTE keep statement and transfer readers separate because the former needs -- the IO monad, and thus will throw IO errors rather than using the ExceptT @@ -261,3 +264,241 @@ matchNonDates ms = go ([], [], initZipper ms) MatchSkip -> (Nothing : matched, unmatched) MatchFail -> (matched, r : unmatched) in go (m, u, resetZipper z') rs + +matches :: MonadFinance m => MatchRe -> TxRecord -> InsertExceptT m (MatchRes (Tx ())) +matches + StatementParser {spTx, spOther, spVal, spDate, spDesc} + r@TxRecord {trDate, trAmount, trDesc, trOther} = do + 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 tg = MatchPass <$> toTx tg r + +toTx :: MonadFinance m => TxGetter -> TxRecord -> InsertExceptT m (Tx ()) +toTx + TxGetter + { tgFrom + , tgTo + , tgCurrency + , tgOtherEntries + , tgScale + } + r@TxRecord {trAmount, trDate, trDesc} = do + combineError curRes subRes $ \(cur, f, t) ss -> + Tx + { txDate = trDate + , txDescr = trDesc + , txCommit = () + , txPrimary = + Left $ + EntrySet + { esTotalValue = roundPrecisionCur cur $ tgScale * fromRational trAmount + , esCurrency = cur + , esFrom = f + , esTo = t + } + , txOther = fmap Left ss + } + where + curRes = do + m <- askDBState kmCurrency + cur <- liftInner $ resolveCurrency m r tgCurrency + let fromRes = liftInner $ resolveHalfEntry resolveFromValue cur r () tgFrom + let toRes = liftInner $ resolveHalfEntry resolveToValue cur r () tgTo + combineError fromRes toRes (cur,,) + subRes = mapErrors (resolveSubGetter r) tgOtherEntries + +resolveSubGetter + :: MonadFinance m + => TxRecord + -> TxSubGetter + -> InsertExceptT m SecondayEntrySet +resolveSubGetter r TxSubGetter {tsgFrom, tsgTo, tsgValue, tsgCurrency} = do + m <- askDBState kmCurrency + cur <- liftInner $ resolveCurrency m r tsgCurrency + let toRes = resolveHalfEntry resolveToValue cur r () tsgTo + let valRes = liftInner $ fmap (roundPrecisionCur cur) <$> resolveValue r tsgValue + liftInner $ combineErrorM toRes valRes $ \t v -> do + f <- resolveHalfEntry resolveFromValue cur r v tsgFrom + return $ + EntrySet + { esTotalValue = () + , esCurrency = cur + , esFrom = f + , esTo = t + } + +resolveHalfEntry + :: Traversable f + => (TxRecord -> n -> InsertExcept (f Double)) + -> CurrencyPrec + -> TxRecord + -> v + -> TxHalfGetter (EntryGetter n) + -> InsertExcept (HalfEntrySet v (f Rational)) +resolveHalfEntry f cur r v TxHalfGetter {thgAcnt, thgComment, thgTags, thgEntries} = + combineError acntRes esRes $ \a es -> + HalfEntrySet + { hesPrimary = + Entry + { eAcnt = a + , eValue = v + , eComment = thgComment + , eTags = thgTags + } + , hesOther = es + } + where + acntRes = resolveAcnt r thgAcnt + esRes = mapErrors (resolveEntry f cur r) thgEntries + +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 + :: Traversable f + => (TxRecord -> n -> InsertExcept (f Double)) + -> CurrencyPrec + -> TxRecord + -> EntryGetter n + -> InsertExcept (Entry AcntID (f Rational) TagID) +resolveEntry f cur r s@Entry {eAcnt, eValue} = do + combineError acntRes valRes $ \a v -> + s {eAcnt = a, eValue = roundPrecisionCur cur <$> v} + where + acntRes = resolveAcnt r eAcnt + valRes = f r eValue + +resolveFromValue :: TxRecord -> EntryNumGetter -> InsertExcept (EntryValue Double) +resolveFromValue = resolveValue + +resolveToValue :: TxRecord -> LinkedEntryNumGetter -> InsertExcept (LinkDeferred Double) +resolveToValue _ (Linked l) = return $ LinkIndex l +resolveToValue r (Getter g) = LinkDeferred <$> resolveValue r g + +resolveValue :: TxRecord -> EntryNumGetter -> InsertExcept (EntryValue Double) +resolveValue TxRecord {trOther, trAmount} s = case s of + (LookupN t) -> EntryValue TFixed <$> (readDouble =<< lookupErr EntryValField t trOther) + (ConstN c) -> return $ EntryValue TFixed c + AmountN m -> return $ EntryValue TFixed $ m * fromRational trAmount + BalanceN x -> return $ EntryValue TBalance x + PercentN x -> return $ EntryValue TPercent x + +resolveAcnt :: TxRecord -> EntryAcnt -> InsertExcept T.Text +resolveAcnt = resolveEntryField AcntField + +resolveCurrency :: CurrencyMap -> TxRecord -> EntryCur -> InsertExcept CurrencyPrec +resolveCurrency m r c = do + i <- resolveEntryField CurField r c + case M.lookup i m of + Just k -> return k + -- TODO this should be its own error (I think) + Nothing -> throwError $ InsertException [LookupError (EntryIDField CurField) undefined] + +resolveEntryField :: EntryIDType -> TxRecord -> EntryAcnt -> InsertExcept T.Text +resolveEntryField t TxRecord {trOther = o} s = case s of + 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) <- combineError (lookup_ f1 o) (lookup_ f2 o) (,) + lookup_ (k1, k2) m + where + lookup_ :: (Ord k, Show k) => k -> M.Map k v -> InsertExcept v + lookup_ = lookupErr (EntryIDField t) + +readDouble :: T.Text -> InsertExcept Double +readDouble s = case readMaybe $ T.unpack s of + Just x -> return x + Nothing -> throwError $ InsertException [ConversionError s] + +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 + (Just x', Just y') -> + let p = 10 ^ T.length y + k = if x' >= 0 then 1 else -1 + in return $ fromInteger x' + k * y' % p + _ -> err + _ -> err + where + readT = readMaybe . T.unpack + err = throwError $ InsertException [ConversionError s] + +compileOptions :: TxOpts T.Text -> InsertExcept TxOptsRe +compileOptions o@TxOpts {toAmountFmt = pat} = do + re <- compileRegex True pat + return $ o {toAmountFmt = re} + +compileMatch :: StatementParser T.Text -> InsertExcept MatchRe +compileMatch m@StatementParser {spDesc, spOther} = do + 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 -> InsertExcept (Text, Regex) +compileRegex groups pat = case res of + Right re -> return (pat, re) + Left _ -> throwError $ InsertException [RegexError pat] + where + res = + compile + (blankCompOpt {newSyntax = True}) + (blankExecOpt {captureGroups = groups}) + pat + +matchMaybe :: T.Text -> Regex -> InsertExcept Bool +matchMaybe q re = case execute re q of + 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 + Right Nothing -> [] + Right (Just (_, _, _, xs)) -> xs + -- this should never fail as regexec always returns Right + Left _ -> [] + +parseRational :: MonadFail m => (T.Text, Regex) -> T.Text -> m Rational +parseRational (pat, re) s = case matchGroupsMaybe s re of + [sign, x, ""] -> uncurry (*) <$> readWhole sign x + [sign, x, y] -> do + d <- readT "decimal" y + let p = 10 ^ T.length y + (k, w) <- readWhole sign x + return $ k * (w + d % p) + _ -> msg "malformed decimal" + where + readT what t = case readMaybe $ T.unpack t of + Just d -> return $ fromInteger d + _ -> msg $ T.unwords ["could not parse", what, singleQuote t] + msg :: MonadFail m => T.Text -> m a + msg m = + fail $ + T.unpack $ + T.unwords [m, "-", keyVals [("pattern", pat), ("query", s)]] + readSign x + | x == "-" = return (-1) + | x == "+" || x == "" = return 1 + | otherwise = msg $ T.append "invalid sign: " x + readWhole sign x = do + w <- readT "whole number" x + k <- readSign sign + return (k, w) diff --git a/lib/Internal/Types/Database.hs b/lib/Internal/Types/Database.hs index 516931b..a3baab0 100644 --- a/lib/Internal/Types/Database.hs +++ b/lib/Internal/Types/Database.hs @@ -64,6 +64,7 @@ EntryR sql=entries TagRelationR sql=tag_relations entry EntryRId OnDeleteCascade tag TagRId OnDeleteCascade + deriving Show Eq BudgetLabelR sql=budget_labels entry EntryRId OnDeleteCascade budgetName T.Text diff --git a/lib/Internal/Types/Main.hs b/lib/Internal/Types/Main.hs index 50e8eb7..6975139 100644 --- a/lib/Internal/Types/Main.hs +++ b/lib/Internal/Types/Main.hs @@ -76,6 +76,7 @@ data ReadEntry = ReadEntry , reValue :: !Rational , reDate :: !Day } + deriving (Show) data UpdateEntry i v = UpdateEntry { ueID :: !i @@ -83,21 +84,22 @@ data UpdateEntry i v = UpdateEntry , ueValue :: !v , ueIndex :: !Int } + deriving (Show) data CurrencyRound = CurrencyRound CurID Natural deriving instance Functor (UpdateEntry i) newtype LinkScale = LinkScale {unLinkScale :: Rational} - deriving newtype (Num) + deriving newtype (Num, Show) -- newtype BalanceTarget = BalanceTarget {unBalanceTarget :: Rational} -- deriving newtype (Num) newtype StaticValue = StaticValue {unStaticValue :: Rational} - deriving newtype (Num) + deriving newtype (Num, Show) -data EntryValueUnk = EVBalance Rational | EVPercent Rational +data EntryValueUnk = EVBalance Rational | EVPercent Rational deriving (Show) type UEUnk = UpdateEntry EntryRId EntryValueUnk @@ -120,6 +122,7 @@ data UpdateEntrySet f t = UpdateEntrySet , utDate :: !Day , utTotalValue :: !t } + deriving (Show) type TotalUpdateEntrySet = UpdateEntrySet (UEBlank, [UELink]) Rational diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs index 84a3dd9..10d4ddb 100644 --- a/lib/Internal/Utils.hs +++ b/lib/Internal/Utils.hs @@ -5,7 +5,6 @@ module Internal.Utils , fromWeekday , inDaySpan , fmtRational - , matches , fromGregorian' , resolveDaySpan , resolveDaySpan_ @@ -28,12 +27,7 @@ module Internal.Utils , combineErrorIOM3 , collectErrorsIO , mapErrorsIO - , parseRational , showError - , unlessLeft_ - , unlessLefts_ - , unlessLeft - , unlessLefts , acntPath2Text , showT , lookupErr @@ -43,8 +37,6 @@ module Internal.Utils , sndOf3 , thdOf3 , xGregToDay - , compileMatch - , compileOptions , dateMatches , valMatches , roundPrecision @@ -64,6 +56,8 @@ module Internal.Utils , expandTransfers , expandTransfer , entryPair + , singleQuote + , keyVals ) where @@ -80,8 +74,6 @@ import RIO.State import qualified RIO.Text as T import RIO.Time import qualified RIO.Vector as V -import Text.Regex.TDFA -import Text.Regex.TDFA.Text -------------------------------------------------------------------------------- -- intervals @@ -300,101 +292,6 @@ toDaySpan (a, b) = (a, fromIntegral $ diffDays b a - 1) -------------------------------------------------------------------------------- -- matching -matches :: MonadFinance m => MatchRe -> TxRecord -> InsertExceptT m (MatchRes (Tx ())) -matches - StatementParser {spTx, spOther, spVal, spDate, spDesc} - r@TxRecord {trDate, trAmount, trDesc, trOther} = do - 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 tg = MatchPass <$> toTx tg r - -toTx :: MonadFinance m => TxGetter -> TxRecord -> InsertExceptT m (Tx ()) -toTx - TxGetter - { tgFrom - , tgTo - , tgCurrency - , tgOtherEntries - , tgScale - } - r@TxRecord {trAmount, trDate, trDesc} = do - combineError curRes subRes $ \(cur, f, t) ss -> - Tx - { txDate = trDate - , txDescr = trDesc - , txCommit = () - , txPrimary = - Left $ - EntrySet - { esTotalValue = roundPrecisionCur cur $ tgScale * fromRational trAmount - , esCurrency = cur - , esFrom = f - , esTo = t - } - , txOther = fmap Left ss - } - where - curRes = do - m <- askDBState kmCurrency - cur <- liftInner $ resolveCurrency m r tgCurrency - let fromRes = liftInner $ resolveHalfEntry resolveFromValue cur r () tgFrom - let toRes = liftInner $ resolveHalfEntry resolveToValue cur r () tgTo - combineError fromRes toRes (cur,,) - subRes = mapErrors (resolveSubGetter r) tgOtherEntries - -resolveSubGetter - :: MonadFinance m - => TxRecord - -> TxSubGetter - -> InsertExceptT m SecondayEntrySet -resolveSubGetter r TxSubGetter {tsgFrom, tsgTo, tsgValue, tsgCurrency} = do - m <- askDBState kmCurrency - cur <- liftInner $ resolveCurrency m r tsgCurrency - let toRes = resolveHalfEntry resolveToValue cur r () tsgTo - let valRes = liftInner $ fmap (roundPrecisionCur cur) <$> resolveValue r tsgValue - liftInner $ combineErrorM toRes valRes $ \t v -> do - f <- resolveHalfEntry resolveFromValue cur r v tsgFrom - return $ - EntrySet - { esTotalValue = () - , esCurrency = cur - , esFrom = f - , esTo = t - } - -resolveHalfEntry - :: Traversable f - => (TxRecord -> n -> InsertExcept (f Double)) - -> CurrencyPrec - -> TxRecord - -> v - -> TxHalfGetter (EntryGetter n) - -> InsertExcept (HalfEntrySet v (f Rational)) -resolveHalfEntry f cur r v TxHalfGetter {thgAcnt, thgComment, thgTags, thgEntries} = - combineError acntRes esRes $ \a es -> - HalfEntrySet - { hesPrimary = - Entry - { eAcnt = a - , eValue = v - , eComment = thgComment - , eTags = thgTags - } - , hesOther = es - } - where - acntRes = resolveAcnt r thgAcnt - esRes = mapErrors (resolveEntry f cur r) thgEntries - valMatches :: ValMatcher -> Rational -> InsertExcept Bool valMatches ValMatcher {vmDen, vmSign, vmNum, vmPrec} x | Just d_ <- vmDen, d_ >= p = throwError $ InsertException [MatchValPrecisionError d_ p] @@ -412,27 +309,6 @@ valMatches ValMatcher {vmDen, vmSign, vmNum, vmPrec} x dateMatches :: DateMatcher -> Day -> Bool dateMatches md = (EQ ==) . compareDate md -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 - :: Traversable f - => (TxRecord -> n -> InsertExcept (f Double)) - -> CurrencyPrec - -> TxRecord - -> EntryGetter n - -> InsertExcept (Entry AcntID (f Rational) TagID) -resolveEntry f cur r s@Entry {eAcnt, eValue} = do - combineError acntRes valRes $ \a v -> - s {eAcnt = a, eValue = roundPrecisionCur cur <$> v} - where - acntRes = resolveAcnt r eAcnt - valRes = f r eValue - liftInner :: Monad m => ExceptT e Identity a -> ExceptT e m a liftInner = mapExceptT (return . runIdentity) @@ -442,9 +318,6 @@ 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 @@ -526,101 +399,11 @@ mapErrorsIO f xs = mapM go $ enumTraversable xs collectErrorsIO :: (Traversable t, MonadUnliftIO m) => t (m a) -> m (t a) collectErrorsIO = mapErrorsIO id -resolveFromValue :: TxRecord -> EntryNumGetter -> InsertExcept (EntryValue Double) -resolveFromValue = resolveValue - -resolveToValue :: TxRecord -> LinkedEntryNumGetter -> InsertExcept (LinkDeferred Double) -resolveToValue _ (Linked l) = return $ LinkIndex l -resolveToValue r (Getter g) = LinkDeferred <$> resolveValue r g - -resolveValue :: TxRecord -> EntryNumGetter -> InsertExcept (EntryValue Double) -resolveValue TxRecord {trOther, trAmount} s = case s of - (LookupN t) -> EntryValue TFixed <$> (readDouble =<< lookupErr EntryValField t trOther) - (ConstN c) -> return $ EntryValue TFixed c - AmountN m -> return $ EntryValue TFixed $ m * fromRational trAmount - BalanceN x -> return $ EntryValue TBalance x - PercentN x -> return $ EntryValue TPercent x - -resolveAcnt :: TxRecord -> EntryAcnt -> InsertExcept T.Text -resolveAcnt = resolveEntryField AcntField - -resolveCurrency :: CurrencyMap -> TxRecord -> EntryCur -> InsertExcept CurrencyPrec -resolveCurrency m r c = do - i <- resolveEntryField CurField r c - case M.lookup i m of - Just k -> return k - -- TODO this should be its own error (I think) - Nothing -> throwError $ InsertException [LookupError (EntryIDField CurField) undefined] - -resolveEntryField :: EntryIDType -> TxRecord -> EntryAcnt -> InsertExcept T.Text -resolveEntryField t TxRecord {trOther = o} s = case s of - 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) <- combineError (lookup_ f1 o) (lookup_ f2 o) (,) - lookup_ (k1, k2) m - where - lookup_ :: (Ord k, Show k) => k -> M.Map k v -> InsertExcept v - lookup_ = lookupErr (EntryIDField t) - 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 -> 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 - [sign, x, ""] -> uncurry (*) <$> readWhole sign x - [sign, x, y] -> do - d <- readT "decimal" y - let p = 10 ^ T.length y - (k, w) <- readWhole sign x - return $ k * (w + d % p) - _ -> msg "malformed decimal" - where - readT what t = case readMaybe $ T.unpack t of - Just d -> return $ fromInteger d - _ -> msg $ T.unwords ["could not parse", what, singleQuote t] - msg :: MonadFail m => T.Text -> m a - msg m = - fail $ - T.unpack $ - T.unwords [m, "-", keyVals [("pattern", pat), ("query", s)]] - readSign x - | x == "-" = return (-1) - | x == "+" || x == "" = return 1 - | otherwise = msg $ T.append "invalid sign: " x - readWhole sign x = do - w <- readT "whole number" x - k <- readSign sign - return (k, w) - -readDouble :: T.Text -> InsertExcept Double -readDouble s = case readMaybe $ T.unpack s of - Just x -> return x - Nothing -> throwError $ InsertException [ConversionError s] - -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 - (Just x', Just y') -> - let p = 10 ^ T.length y - k = if x' >= 0 then 1 else -1 - in return $ fromInteger x' + k * y' % p - _ -> err - _ -> err - where - readT = readMaybe . T.unpack - err = throwError $ InsertException [ConversionError s] - --- TODO smells like a lens --- mapTxSplits :: (a -> b) -> Tx a -> Tx b --- mapTxSplits f t@Tx {txSplits = ss} = t {txSplits = fmap f ss} - fmtRational :: Natural -> Rational -> T.Text fmtRational precision x = T.concat [s, txt n', ".", pad 2 "0" $ txt d'] where @@ -834,87 +617,9 @@ keyVals = T.intercalate "; " . fmap (uncurry keyVal) showT :: Show a => a -> T.Text 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] - --- 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] - --- 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 - --- 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 - --- concatEithersL :: [Either [x] a] -> Either [x] [a] --- concatEithersL = merge . concatEitherL - --- 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) -unlessLeft (Right rs) f = f rs - -unlessLefts :: (Monad m) => Either (n a) b -> (b -> m (n a)) -> m (n a) -unlessLefts (Left es) _ = return es -unlessLefts (Right rs) f = f rs - -unlessLeft_ :: (Monad m, MonadPlus n) => Either a b -> (b -> m ()) -> m (n a) -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 (: []) - --- merge :: Either [[a]] b -> Either [a] b --- merge = first concat - -------------------------------------------------------------------------------- -- random functions --- when bifunctor fails... --- thrice :: (a -> d) -> (b -> e) -> (c -> f) -> (a, b, c) -> (d, e, f) --- thrice f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z) - --- groupKey :: Ord c => (a -> c) -> [(a, b)] -> [(a, [b])] --- groupKey f = fmap go . NE.groupAllWith (f . fst) --- where --- go xs@((c, _) :| _) = (c, NE.toList $ fmap snd xs) - groupKey :: Ord c => (a -> c) -> [(a, b)] -> [(a, NonEmpty b)] groupKey f = fmap go . NE.groupAllWith (f . fst) where @@ -940,65 +645,6 @@ sndOf3 (_, b, _) = b thdOf3 :: (a, b, c) -> c thdOf3 (_, _, c) = c --- lpad :: a -> Int -> [a] -> [a] --- lpad c n s = replicate (n - length s) c ++ s - --- rpad :: a -> Int -> [a] -> [a] --- rpad c n s = s ++ replicate (n - length s) c - --- lpadT :: Char -> Int -> T.Text -> T.Text --- lpadT c n s = T.append (T.replicate (n - T.length s) (T.singleton c)) s - --- TODO this regular expression appears to be compiled each time, which is --- super slow --- NOTE: see https://github.com/haskell-hvr/regex-tdfa/issues/9 - performance --- is likely not going to be optimal for text --- matchMaybe :: T.Text -> T.Text -> EitherErr Bool --- matchMaybe q pat = case compres of --- Right re -> case execute re q of --- Right res -> Right $ isJust res --- Left _ -> Left $ RegexError "this should not happen" --- Left _ -> Left $ RegexError pat --- where --- -- these options barely do anything in terms of performance --- compres = compile (blankCompOpt {newSyntax = True}) (blankExecOpt {captureGroups = False}) pat - -compileOptions :: TxOpts T.Text -> InsertExcept TxOptsRe -compileOptions o@TxOpts {toAmountFmt = pat} = do - re <- compileRegex True pat - return $ o {toAmountFmt = re} - -compileMatch :: StatementParser T.Text -> InsertExcept MatchRe -compileMatch m@StatementParser {spDesc, spOther} = do - 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 -> InsertExcept (Text, Regex) -compileRegex groups pat = case res of - Right re -> return (pat, re) - Left _ -> throwError $ InsertException [RegexError pat] - where - res = - compile - (blankCompOpt {newSyntax = True}) - (blankExecOpt {captureGroups = groups}) - pat - -matchMaybe :: T.Text -> Regex -> InsertExcept Bool -matchMaybe q re = case execute re q of - 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 - Right Nothing -> [] - Right (Just (_, _, _, xs)) -> xs - -- this should never fail as regexec always returns Right - Left _ -> [] - lookupAccount :: (MonadInsertError m, MonadFinance m) => AcntID -> m (AccountRId, AcntSign, AcntType) lookupAccount = lookupFinance AcntField kmAccount @@ -1339,7 +985,7 @@ balanceLinked from curID precision acntID lg = case lg of Nothing -> throwError undefined (LinkDeferred d) -> liftInnerS $ balanceDeferred curID acntID d where - go s = roundPrecision precision . (* s) . fromRational + go s = negate . roundPrecision precision . (* s) . fromRational balanceDeferred :: CurrencyRId