module Internal.Utils ( compareDate , inBounds , expandBounds , fmtRational , matches , fromGregorian' , resolveBounds , resolveBounds_ , liftInner , liftExceptT , liftExcept , liftIOExcept , liftIOExceptT , combineError , combineError_ , combineError3 , combineErrors , mapErrors , combineErrorM , combineErrorM3 , combineErrorIO2 , combineErrorIO3 , combineErrorIOM2 , combineErrorIOM3 , collectErrorsIO , mapErrorsIO -- , leftToMaybe -- , concatEithers2 -- , concatEithers3 -- , concatEither3 -- , concatEither2 -- , concatEitherL -- , concatEithersL -- , concatEither2M -- , concatEithers2M , parseRational , showError , unlessLeft_ , unlessLefts_ , unlessLeft , unlessLefts , acntPath2Text , showT , lookupErr , gregorians , uncurry3 , fstOf3 , sndOf3 , thdOf3 , xGregToDay -- , plural , compileMatch , compileOptions , dateMatches , valMatches , roundPrecision , roundPrecisionCur ) where import Control.Monad.Error.Class import Control.Monad.Except import Control.Monad.Reader import Data.Time.Format.ISO8601 import GHC.Real import Internal.Types import RIO import qualified RIO.List as L import qualified RIO.Map as M import qualified RIO.NonEmpty as NE import qualified RIO.Text as T import RIO.Time import Text.Regex.TDFA import Text.Regex.TDFA.Text -------------------------------------------------------------------------------- -- dates -- | find the next date -- this is meant to go in a very tight loop and be very fast (hence no -- complex date functions, most of which heavily use 'mod' and friends) nextXGreg :: XGregorian -> XGregorian nextXGreg XGregorian {xgYear = y, xgMonth = m, xgDay = d, xgDayOfWeek = w} | m == 12 && d == 31 = XGregorian (y + 1) 1 1 w_ | (m == 2 && (not leap && d == 28 || (leap && d == 29))) || (m `elem` [4, 6, 9, 11] && d == 30) || (d == 31) = XGregorian y (m + 1) 1 w_ | otherwise = XGregorian y m (d + 1) w_ where -- don't use DayOfWeek from Data.Time since this uses mod (which uses a -- division opcode) and thus will be slower than just checking for equality -- and adding w_ = if w == 6 then 0 else w + 1 leap = isLeapYear $ fromIntegral y gregorians :: Day -> [XGregorian] gregorians x = L.iterate nextXGreg $ XGregorian (fromIntegral y) m d w where (y, m, d) = toGregorian x w = fromEnum $ dayOfWeek x xGregToDay :: XGregorian -> Day xGregToDay XGregorian {xgYear = y, xgMonth = m, xgDay = d} = fromGregorian (fromIntegral y) m d gregTup :: Gregorian -> (Integer, Int, Int) gregTup Gregorian {gYear, gMonth, gDay} = ( fromIntegral gYear , fromIntegral gMonth , fromIntegral gDay ) gregMTup :: GregorianM -> (Integer, Int) gregMTup GregorianM {gmYear, gmMonth} = ( fromIntegral gmYear , fromIntegral gmMonth ) data YMD_ = Y_ !Integer | YM_ !Integer !Int | YMD_ !Integer !Int !Int fromYMDMatcher :: YMDMatcher -> YMD_ fromYMDMatcher m = case m of Y y -> Y_ $ fromIntegral y YM g -> uncurry YM_ $ gregMTup g YMD g -> uncurry3 YMD_ $ gregTup g compareDate :: DateMatcher -> Day -> Ordering compareDate (On md) x = case fromYMDMatcher md of Y_ y' -> compare y y' YM_ y' m' -> compare (y, m) (y', m') YMD_ y' m' d' -> compare (y, m, d) (y', m', d') where (y, m, d) = toGregorian x compareDate (In md offset) x = do case fromYMDMatcher md of Y_ y' -> compareRange y' y YM_ y' m' -> compareRange (toMonth y' m') $ toMonth y m YMD_ y' m' d' -> let s = toModifiedJulianDay $ fromGregorian y' m' d' in compareRange s $ toModifiedJulianDay x where (y, m, _) = toGregorian x compareRange start z | z < start = LT | otherwise = if (start + fromIntegral offset - 1) < z then GT else EQ toMonth year month = (year * 12) + fromIntegral month fromGregorian' :: Gregorian -> Day fromGregorian' = uncurry3 fromGregorian . gregTup -- TODO misleading name inBounds :: (Day, Day) -> Day -> Bool inBounds (d0, d1) x = d0 <= x && x < d1 resolveBounds :: Interval -> InsertExcept Bounds resolveBounds i@Interval {intStart = s} = resolveBounds_ (s {gYear = gYear s + 50}) i resolveBounds_ :: Gregorian -> Interval -> InsertExcept Bounds resolveBounds_ def Interval {intStart = s, intEnd = e} = case fromGregorian' <$> e of Nothing -> return $ toBounds $ fromGregorian' def Just e_ | s_ < e_ -> return $ toBounds e_ | otherwise -> throwError $ InsertException [BoundsError s e] where s_ = fromGregorian' s toBounds end = (s_, fromIntegral $ diffDays end s_ - 1) expandBounds :: Bounds -> (Day, Day) expandBounds (d, n) = (d, addDays (fromIntegral n + 1) d) -------------------------------------------------------------------------------- -- matching matches :: MatchRe -> TxRecord -> InsertExceptT CurrencyM (MatchRes RawTx) 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 (TxGetter cur a ss) = MatchPass <$> toTx cur a ss r toTx :: SplitCur -> SplitAcnt -> [EntryGetter] -> TxRecord -> InsertExceptT CurrencyM RawTx toTx sc sa toSplits r@TxRecord {trAmount, trDate, trDesc} = do combineError3 acntRes curRes ssRes $ \a c ss -> let fromSplit = Entry { eAcnt = a , eCurrency = c , eValue = Just trAmount , eComment = "" , eTags = [] -- TODO what goes here? } in Tx { txDate = trDate , txDescr = trDesc , txSplits = fromSplit : ss } where acntRes = liftInner $ resolveAcnt r sa curRes = liftInner $ resolveCurrency r sc ssRes = combineErrors $ fmap (resolveEntry r) toSplits valMatches :: ValMatcher -> Rational -> InsertExcept Bool valMatches ValMatcher {vmDen, vmSign, vmNum, vmPrec} x | Just d_ <- vmDen, d_ >= p = throwError $ InsertException [MatchValPrecisionError d_ p] | otherwise = return $ checkMaybe (s ==) vmSign && checkMaybe (n ==) vmNum && checkMaybe ((d * fromIntegral p ==) . fromIntegral) vmDen where (n, d) = properFraction $ abs x p = 10 ^ vmPrec s = signum x >= 0 checkMaybe = maybe True 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 :: TxRecord -> EntryGetter -> InsertExceptT CurrencyM RawSplit resolveEntry r s@Entry {eAcnt, eValue, eCurrency} = do m <- ask liftInner $ combineErrorM3 acntRes curRes valRes $ \a c v -> do v' <- mapM (roundPrecisionCur c m) v return $ s {eAcnt = a, eValue = v', eCurrency = c} where acntRes = resolveAcnt r eAcnt curRes = resolveCurrency r eCurrency valRes = mapM (resolveValue r) eValue liftInner :: Monad m => ExceptT e Identity a -> ExceptT e m a liftInner = mapExceptT (return . runIdentity) liftExceptT :: MonadError e m => ExceptT e m a -> m a liftExceptT x = runExceptT x >>= either throwError return liftExcept :: MonadError e m => Except e a -> m a liftExcept = either throwError return . runExcept -- tryError :: MonadError e m => m a -> m (Either e a) -- tryError action = (Right <$> action) `catchError` (pure . Left) liftIOExceptT :: MonadIO m => InsertExceptT m a -> m a liftIOExceptT = fromEither <=< runExceptT liftIOExcept :: MonadIO m => InsertExcept a -> m a liftIOExcept = fromEither . runExcept combineError :: MonadError InsertException m => m a -> m b -> (a -> b -> c) -> m c combineError a b f = combineErrorM a b (\x y -> pure $ f x y) combineError_ :: MonadError InsertException m => m a -> m b -> m () combineError_ a b = do _ <- catchError a $ \e -> throwError =<< catchError (e <$ b) (return . (e <>)) _ <- b return () combineErrorM :: MonadError InsertException m => m a -> m b -> (a -> b -> m c) -> m c combineErrorM a b f = do a' <- catchError a $ \e -> throwError =<< catchError (e <$ b) (return . (e <>)) f a' =<< b combineError3 :: MonadError InsertException m => m a -> m b -> m c -> (a -> b -> c -> d) -> m d combineError3 a b c f = combineError (combineError a b (,)) c $ \(x, y) z -> f x y z combineErrorM3 :: MonadError InsertException m => m a -> m b -> m c -> (a -> b -> c -> m d) -> m d combineErrorM3 a b c f = do combineErrorM (combineErrorM a b (curry return)) c $ \(x, y) z -> f x y z combineErrors :: MonadError InsertException m => [m a] -> m [a] combineErrors = mapErrors id mapErrors :: MonadError InsertException m => (a -> m b) -> [a] -> m [b] mapErrors f xs = do ys <- mapM (go . f) xs case partitionEithers ys of ([], zs) -> return zs (e : es, _) -> throwError $ foldr (<>) e es where go x = catchError (Right <$> x) (pure . Left) combineErrorIO2 :: MonadUnliftIO m => m a -> m b -> (a -> b -> c) -> m c combineErrorIO2 a b f = combineErrorIOM2 a b (\x y -> pure $ f x y) combineErrorIO3 :: MonadUnliftIO m => m a -> m b -> m c -> (a -> b -> c -> d) -> m d combineErrorIO3 a b c f = combineErrorIOM3 a b c (\x y z -> pure $ f x y z) combineErrorIOM2 :: MonadUnliftIO m => m a -> m b -> (a -> b -> m c) -> m c combineErrorIOM2 a b f = do a' <- catch a $ \(InsertException es) -> (throwIO . InsertException) =<< catch (es <$ b) (\(InsertException es') -> return (es' ++ es)) f a' =<< b combineErrorIOM3 :: MonadUnliftIO m => m a -> m b -> m c -> (a -> b -> c -> m d) -> m d combineErrorIOM3 a b c f = combineErrorIOM2 (combineErrorIOM2 a b (curry return)) c $ \(x, y) z -> f x y z mapErrorsIO :: MonadUnliftIO m => (a -> m b) -> [a] -> m [b] mapErrorsIO f xs = do ys <- mapM (go . f) xs case partitionEithers ys of ([], zs) -> return zs (es, _) -> throwIO $ InsertException $ concat es where go x = catch (Right <$> x) $ \(InsertException es) -> pure $ Left es collectErrorsIO :: MonadUnliftIO m => [m a] -> m [a] collectErrorsIO = mapErrorsIO id resolveValue :: TxRecord -> EntryNumGetter -> InsertExcept Double resolveValue r s = case s of (LookupN t) -> readDouble =<< lookupErr SplitValField t (trOther r) (ConstN c) -> return c -- TODO don't coerce to rational in trAmount AmountN -> return $ fromRational $ trAmount r resolveAcnt :: TxRecord -> SplitAcnt -> InsertExcept T.Text resolveAcnt = resolveSplitField AcntField resolveCurrency :: TxRecord -> SplitCur -> InsertExcept T.Text resolveCurrency = resolveSplitField CurField resolveSplitField :: SplitIDType -> TxRecord -> SplitAcnt -> InsertExcept T.Text resolveSplitField 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 (SplitIDField 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 s = if x >= 0 then "" else "-" x'@(n :% d) = abs x p = 10 ^ precision n' = div n d d' = (\(a :% b) -> div a b) ((x' - fromIntegral n') * p) txt = T.pack . show pad i c z = T.append (T.replicate (i - T.length z) c) z roundPrecision :: Natural -> Double -> Rational roundPrecision n = (% p) . round . (* fromIntegral p) . toRational where p = 10 ^ n roundPrecisionCur :: CurID -> CurrencyMap -> Double -> InsertExcept Rational roundPrecisionCur c m x = case M.lookup c m of Just (_, n) -> return $ roundPrecision n x Nothing -> throwError $ InsertException [undefined] acntPath2Text :: AcntPath -> T.Text acntPath2Text (AcntPath t cs) = T.intercalate "/" (atName t : cs) -------------------------------------------------------------------------------- -- error display showError :: InsertError -> [T.Text] showError other = case other of (StatementError ts ms) -> (showTx <$> ts) ++ (showMatch <$> ms) (BoundsError a b) -> [T.unwords ["Could not create bounds from", showGregorian_ a, "and", showGreg b]] where showGreg (Just g) = showGregorian_ g showGreg Nothing = "Inf" (AccountError a ts) -> [ T.unwords [ "account type of key" , singleQuote a , "is not one of:" , ts_ ] ] where ts_ = T.intercalate ", " $ NE.toList $ fmap atName ts (PatternError s b r p) -> [T.unwords [msg, "in pattern: ", pat]] where pat = keyVals $ [ (k, v) | (k, Just v) <- [ ("start", Just $ showT s) , ("by", Just $ showT b) , ("repeats", showT <$> r) ] ] msg = case p of ZeroLength -> "Zero repeat length" ZeroRepeats -> "Zero repeats" (RegexError re) -> [T.append "could not make regex from pattern: " re] (ConversionError x) -> [T.append "Could not convert to rational number: " x] (InsertIOError msg) -> [T.append "IO Error: " msg] (ParseError msg) -> [T.append "Parse Error: " msg] (MatchValPrecisionError d p) -> [T.unwords ["Match denominator", showT d, "must be less than", showT p]] (LookupError t f) -> [T.unwords ["Could not find field", f, "when resolving", what]] where what = case t of SplitIDField st -> T.unwords ["split", idName st, "ID"] SplitValField -> "split value" MatchField mt -> T.unwords [matchName mt, "match"] DBKey st -> T.unwords ["database", idName st, "ID key"] -- TODO this should be its own function idName AcntField = "account" idName CurField = "currency" idName TagField = "tag" matchName MatchNumeric = "numeric" matchName MatchText = "text" (IncomeError day name balance) -> [ T.unwords [ "Income allocations for budget" , singleQuote name , "exceed total on day" , showT day , "where balance is" , showT balance ] ] (BalanceError t cur rss) -> [ T.unwords [ msg , "for currency" , singleQuote cur , "and for splits" , splits ] ] where msg = case t of TooFewSplits -> "Need at least two splits to balance" NotOneBlank -> "Exactly one split must be blank" splits = T.intercalate ", " $ fmap (singleQuote . showSplit) rss showGregorian_ :: Gregorian -> T.Text showGregorian_ Gregorian {gYear, gMonth, gDay} = T.intercalate "-" $ showT <$> [gYear, gMonth, gDay] showTx :: TxRecord -> T.Text showTx TxRecord {trDate = d, trAmount = v, trDesc = e, trFile = f} = T.append "Unmatched transaction: " $ keyVals [ ("path", T.pack f) , ("date", T.pack $ iso8601Show d) , ("value", showT (fromRational v :: Float)) , ("description", doubleQuote e) ] showMatch :: MatchRe -> T.Text showMatch StatementParser {spDate, spVal, spDesc, spOther, spTimes, spPriority} = T.append "Unused match: " $ keyVals [(x, y) | (x, Just y) <- kvs] where kvs = [ ("date", showDateMatcher <$> spDate) , ("val", showValMatcher spVal) , ("desc", fst <$> spDesc) , ("other", others) , ("counter", Just $ maybe "Inf" showT spTimes) , ("priority", Just $ showT spPriority) ] others = case spOther of [] -> Nothing xs -> Just $ singleQuote $ T.concat $ showMatchOther <$> xs -- | Convert match date to text -- Single date matches will just show the single date, and ranged matches will -- show an interval like [YY-MM-DD, YY-MM-DD) showDateMatcher :: DateMatcher -> T.Text showDateMatcher md = case md of (On x) -> showYMDMatcher x (In start n) -> T.concat ["[", showYMDMatcher start, " ", showYMD_ end, ")"] where -- TODO not DRY (this shifting thing happens during the comparison -- function (kinda) end = case fromYMDMatcher start of Y_ y -> Y_ $ y + fromIntegral n YM_ y m -> let (y_, m_) = divMod (m + fromIntegral n - 1) 12 in YM_ (y + fromIntegral y_) (m + m_ + 1) YMD_ y m d -> uncurry3 YMD_ $ toGregorian $ addDays (fromIntegral n) $ fromGregorian y m d -- | convert YMD match to text showYMDMatcher :: YMDMatcher -> T.Text showYMDMatcher = showYMD_ . fromYMDMatcher showYMD_ :: YMD_ -> T.Text showYMD_ md = T.intercalate "-" $ L.take 3 (fmap showT digits ++ L.repeat "*") where digits = case md of Y_ y -> [fromIntegral y] YM_ y m -> [fromIntegral y, m] YMD_ y m d -> [fromIntegral y, m, d] showValMatcher :: ValMatcher -> Maybe T.Text showValMatcher ValMatcher {vmSign = Nothing, vmNum = Nothing, vmDen = Nothing} = Nothing showValMatcher ValMatcher {vmNum, vmDen, vmSign, vmPrec} = Just $ singleQuote $ keyVals [(k, v) | (k, Just v) <- kvs] where kvs = [ ("sign", (\s -> if s then "+" else "-") <$> vmSign) , ("numerator", showT <$> vmNum) , ("denominator", showT <$> vmDen) , ("precision", Just $ showT vmPrec) ] showMatchOther :: FieldMatcherRe -> T.Text showMatchOther (Desc (Field f (re, _))) = T.unwords ["desc field", singleQuote f, "with re", singleQuote re] showMatchOther (Val (Field f mv)) = T.unwords [ "val field" , singleQuote f , "with match value" , singleQuote $ fromMaybe "*" $ showValMatcher mv ] showSplit :: RawSplit -> T.Text showSplit Entry {eAcnt, eValue, eComment} = keyVals [ ("account", eAcnt) , ("value", T.pack $ show ((fromRational <$> eValue) :: Maybe Float)) , ("comment", doubleQuote eComment) ] singleQuote :: T.Text -> T.Text singleQuote t = T.concat ["'", t, "'"] doubleQuote :: T.Text -> T.Text doubleQuote t = T.concat ["'", t, "'"] keyVal :: T.Text -> T.Text -> T.Text keyVal a b = T.concat [a, "=", b] keyVals :: [(T.Text, T.Text)] -> T.Text 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) uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d uncurry3 f (a, b, c) = f a b c fstOf3 :: (a, b, c) -> a fstOf3 (a, _, _) = a sndOf3 :: (a, b, c) -> b 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 _ -> []