module Internal.Utils ( compareDate , expandDatePat , askDays , fromWeekday , inDaySpan , fmtRational , matches , fromGregorian' , resolveDaySpan , resolveDaySpan_ , intersectDaySpan , liftInner , liftExceptT , liftExcept , liftIOExcept , liftIOExceptT , combineError , combineError_ , combineError3 , combineErrors , mapErrors , combineErrorM , combineErrorM3 , combineErrorIO2 , combineErrorIO3 , combineErrorIOM2 , combineErrorIOM3 , collectErrorsIO , mapErrorsIO , parseRational , showError , unlessLeft_ , unlessLefts_ , unlessLeft , unlessLefts , acntPath2Text , showT , lookupErr , gregorians , uncurry3 , fstOf3 , sndOf3 , thdOf3 , xGregToDay , compileMatch , compileOptions , dateMatches , valMatches , roundPrecision , roundPrecisionCur , lookupAccount , lookupAccountKey , lookupAccountSign , lookupAccountType , lookupCurrency , lookupCurrencyKey , lookupCurrencyPrec , lookupTag , mapAdd_ , groupKey , groupWith ) 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.Main 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 -------------------------------------------------------------------------------- -- intervals expandDatePat :: DaySpan -> DatePat -> InsertExcept [Day] expandDatePat b (Cron cp) = expandCronPat b cp expandDatePat i (Mod mp) = return $ expandModPat mp i expandModPat :: ModPat -> DaySpan -> [Day] expandModPat ModPat {mpStart = s, mpBy = b, mpUnit = u, mpRepeats = r} bs = takeWhile (<= upper) $ (`addFun` start) . (* b') <$> maybe id (take . fromIntegral) r [0 ..] where (lower, upper) = fromDaySpan bs start = maybe lower fromGregorian' s b' = fromIntegral b addFun = case u of Day -> addDays Week -> addDays . (* 7) Month -> addGregorianMonthsClip Year -> addGregorianYearsClip expandCronPat :: DaySpan -> CronPat -> InsertExcept [Day] expandCronPat b CronPat {cpYear, cpMonth, cpDay, cpWeekly} = combineError3 yRes mRes dRes $ \ys ms ds -> filter validWeekday $ mapMaybe (uncurry3 toDay) $ takeWhile (\((y, _), m, d) -> (y, m, d) <= (yb1, mb1, db1)) $ dropWhile (\((y, _), m, d) -> (y, m, d) < (yb0, mb0, db0)) $ [(y, m, d) | y <- (\y -> (y, isLeapYear y)) <$> ys, m <- ms, d <- ds] where yRes = case cpYear of Nothing -> return [yb0 .. yb1] Just pat -> do ys <- expandMDYPat (fromIntegral yb0) (fromIntegral yb1) pat return $ dropWhile (< yb0) $ fromIntegral <$> ys mRes = expandMD 12 cpMonth dRes = expandMD 31 cpDay (s, e) = fromDaySpan b (yb0, mb0, db0) = toGregorian s (yb1, mb1, db1) = toGregorian $ addDays (-1) e expandMD lim = fmap (fromIntegral <$>) . maybe (return [1 .. lim]) (expandMDYPat 1 lim) expandW (OnDay x) = [fromEnum x] expandW (OnDays xs) = fromEnum <$> xs ws = maybe [] expandW cpWeekly validWeekday = if null ws then const True else \day -> dayToWeekday day `elem` ws toDay (y, leap) m d | m == 2 && (not leap && d > 28 || leap && d > 29) = Nothing | m `elem` [4, 6, 9, 11] && d > 30 = Nothing | otherwise = Just $ fromGregorian y m d expandMDYPat :: Natural -> Natural -> MDYPat -> InsertExcept [Natural] expandMDYPat lower upper (Single x) = return [x | lower <= x && x <= upper] expandMDYPat lower upper (Multi xs) = return $ dropWhile (<= lower) $ takeWhile (<= upper) xs expandMDYPat lower upper (After x) = return [max lower x .. upper] expandMDYPat lower upper (Before x) = return [lower .. min upper x] expandMDYPat lower upper (Between x y) = return [max lower x .. min upper y] expandMDYPat lower upper (Repeat RepeatPat {rpStart = s, rpBy = b, rpRepeats = r}) | b < 1 = throwError $ InsertException [PatternError s b r ZeroLength] | otherwise = do k <- limit r return $ dropWhile (<= lower) $ takeWhile (<= k) [s + i * b | i <- [0 ..]] where limit Nothing = return upper limit (Just n) -- this guard not only produces the error for the user but also protects -- from an underflow below it | n < 1 = throwError $ InsertException [PatternError s b r ZeroRepeats] | otherwise = return $ min (s + b * (n - 1)) upper dayToWeekday :: Day -> Int dayToWeekday (ModifiedJulianDay d) = mod (fromIntegral d + 2) 7 askDays :: (MonadFinance m, MonadInsertError m) => DatePat -> Maybe Interval -> m [Day] askDays dp i = do globalSpan <- askDBState kmBudgetInterval case i of Just i' -> do localSpan <- liftExcept $ resolveDaySpan i' maybe (return []) expand $ intersectDaySpan globalSpan localSpan Nothing -> expand globalSpan where expand = liftExcept . (`expandDatePat` dp) -------------------------------------------------------------------------------- -- dates -- | Lame weekday converter since day of weeks aren't in dhall (yet) fromWeekday :: Weekday -> DayOfWeek fromWeekday Mon = Monday fromWeekday Tue = Tuesday fromWeekday Wed = Wednesday fromWeekday Thu = Thursday fromWeekday Fri = Friday fromWeekday Sat = Saturday fromWeekday Sun = Sunday -- | 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 inDaySpan :: DaySpan -> Day -> Bool inDaySpan bs = withinDays (fromDaySpan bs) withinDays :: (Day, Day) -> Day -> Bool withinDays (d0, d1) x = d0 <= x && x < d1 resolveDaySpan :: Interval -> InsertExcept DaySpan resolveDaySpan i@Interval {intStart = s} = resolveDaySpan_ (s {gYear = gYear s + 50}) i intersectDaySpan :: DaySpan -> DaySpan -> Maybe DaySpan intersectDaySpan a b = if b' > a' then Nothing else Just $ toDaySpan (a', b') where (a0, a1) = fromDaySpan a (b0, b1) = fromDaySpan b a' = max a0 a1 b' = min b0 b1 resolveDaySpan_ :: Gregorian -> Interval -> InsertExcept DaySpan resolveDaySpan_ def Interval {intStart = s, intEnd = e} = case fromGregorian' <$> e of Nothing -> return $ toDaySpan_ $ fromGregorian' def Just e_ | s_ < e_ -> return $ toDaySpan_ e_ | otherwise -> throwError $ InsertException [DaySpanError s e] where s_ = fromGregorian' s toDaySpan_ end = toDaySpan (s_, end) fromDaySpan :: DaySpan -> (Day, Day) fromDaySpan (d, n) = (d, addDays (fromIntegral n + 1) d) -- ASSUME a < b toDaySpan :: (Day, Day) -> DaySpan toDaySpan (a, b) = (a, fromIntegral $ diffDays b a - 1) -------------------------------------------------------------------------------- -- matching matches :: MatchRe -> TxRecord -> InsertExceptT CurrencyM (MatchRes (DeferredTx ())) 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 :: TxGetter -> TxRecord -> InsertExceptT CurrencyM (DeferredTx ()) toTx TxGetter { tgFrom , tgTo , tgCurrency , tgOtherEntries , tgScale } r@TxRecord {trAmount, trDate, trDesc} = do combineError curRes subRes $ \(cur, f, t, v) ss -> -- TODO might be more efficient to set rebalance flag when balancing Tx { txDate = trDate , txDescr = trDesc , txCommit = () , txEntries = EntrySet { esTotalValue = v , esCurrency = cur , esFrom = f , esTo = t } : ss } where curRes = do m <- ask cur <- liftInner $ resolveCurrency r tgCurrency let fromRes = resolveHalfEntry resolveFromValue cur r tgFrom let toRes = resolveHalfEntry resolveToValue cur r tgTo let totRes = liftExcept $ roundPrecisionCur cur m $ tgScale * fromRational trAmount combineError3 fromRes toRes totRes (cur,,,) subRes = mapErrors (resolveSubGetter r) tgOtherEntries -- anyDeferred :: DeferredEntrySet -> Bool -- anyDeferred -- EntrySet -- { esFrom = HalfEntrySet {hesOther = fs} -- , esTo = HalfEntrySet {hesOther = ts} -- } = -- any checkFrom fs || any checkTo ts -- where -- checkFrom Entry {eValue = (Deferred True _)} = True -- checkFrom _ = False -- checkTo = undefined resolveSubGetter :: TxRecord -> TxSubGetter -> InsertExceptT CurrencyM (EntrySet AcntID CurID TagID Rational) resolveSubGetter r TxSubGetter {tsgFrom, tsgTo, tsgValue, tsgCurrency} = do m <- ask cur <- liftInner $ resolveCurrency r tsgCurrency (_, val) <- liftInner $ mapM (roundPrecisionCur cur m) =<< resolveValue r tsgValue let fromRes = resolveHalfEntry resolveFromValue cur r tsgFrom let toRes = resolveHalfEntry resolveToValue cur r tsgTo combineError fromRes toRes $ \f t -> EntrySet { esTotalValue = val , esCurrency = cur , esFrom = f , esTo = t } resolveHalfEntry :: Traversable f => (TxRecord -> n -> InsertExcept (f Double)) -> CurID -> TxRecord -> TxHalfGetter (EntryGetter n) -> InsertExceptT CurrencyM (HalfEntrySet AcntID CurID TagID (f Rational)) resolveHalfEntry f cur r TxHalfGetter {thgAcnt, thgComment, thgTags, thgEntries} = combineError acntRes esRes $ \a es -> HalfEntrySet { hesPrimary = Entry { eAcnt = a , eValue = () , eComment = thgComment , eTags = thgTags } , hesOther = es } where acntRes = liftInner $ resolveAcnt r thgAcnt esRes = mapErrors (resolveEntry f cur r) thgEntries -- resolveSubGetter -- :: TxRecord -- -> TxSubGetter -- -> InsertExceptT CurrencyM DeferredEntrySet -- resolveSubGetter -- r -- TxSubGetter -- { tsgFromAcnt -- , tsgToAcnt -- , tsgFromTags -- , tsgToTags -- , tsgFromComment -- , tsgToComment -- , tsgValue -- , tsgCurrency -- , tsgFromEntries -- , tsgToEntries -- } = combineErrorM acntRes curRes $ \(fa, ta) (cur, fe, te) -> -- do -- m <- ask -- -- TODO laaaaame... -- (Deferred _ val) <- liftInner $ mapM (roundPrecisionCur cur m) =<< resolveValue r tsgValue -- let fromEntry = -- Entry -- { eAcnt = fa -- , eValue = () -- , eComment = tsgFromComment -- , eTags = tsgFromTags -- } -- let toEntry = -- Entry -- { eAcnt = ta -- , eValue = () -- , eComment = tsgToComment -- , eTags = tsgToTags -- } -- return -- EntrySet -- { desTotalValue = val -- , desCurrency = cur -- , desFromEntry0 = fromEntry -- , desFromEntries = fe -- , desToEntries = te -- , desToEntryBal = toEntry -- } -- where -- resolveAcnt_ = liftInner . resolveAcnt r -- acntRes = -- combineError -- (resolveAcnt_ tsgFromAcnt) -- (resolveAcnt_ tsgToAcnt) -- (,) -- curRes = do -- cur <- liftInner $ resolveCurrency r tsgCurrency -- let feRes = mapErrors (resolveEntry cur r) tsgFromEntries -- let teRes = mapErrors (resolveEntry cur r) tsgToEntries -- combineError feRes teRes (cur,,) 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 :: Traversable f => (TxRecord -> n -> InsertExcept (f Double)) -> CurID -> TxRecord -> EntryGetter n -> InsertExceptT CurrencyM (Entry AcntID (f Rational) TagID) resolveEntry f cur r s@Entry {eAcnt, eValue} = do m <- ask liftInner $ combineErrorM acntRes valRes $ \a v -> do v' <- mapM (roundPrecisionCur cur m) v return $ s {eAcnt = a, eValue = v'} where acntRes = resolveAcnt r eAcnt valRes = f r eValue -- resolveEntry -- :: CurID -- -> TxRecord -- -> EntryGetter n -- -> InsertExceptT CurrencyM (Entry AcntID (Deferred Rational) TagID) -- resolveEntry cur r s@Entry {eAcnt, eValue} = do -- m <- ask -- liftInner $ combineErrorM acntRes valRes $ \a v -> do -- v' <- mapM (roundPrecisionCur cur m) v -- return $ s {eAcnt = a, eValue = v'} -- where -- acntRes = resolveAcnt r eAcnt -- valRes = resolveValue r eValue -- curRes = resolveCurrency r eCurrency -- -- TODO wet code (kinda, not sure if it's worth combining with above) -- resolveToEntry :: TxRecord -> EntryGetter -> InsertExceptT CurrencyM RawEntry -- resolveToEntry 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 = maybe Derive (ConstD False) v', eCurrency = c} -- where -- acntRes = resolveAcnt r eAcnt -- curRes = resolveCurrency r eCurrency -- valRes = mapM (resolveToValue 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 mapErrors :: (Traversable t, MonadError InsertException m) => (a -> m b) -> t a -> m (t b) -- First, record number of each action. Then try each action. On first failure, -- note it's position in the sequence, skip ahead to the untried actions, -- collect failures and add to the first failure. mapErrors f xs = mapM go $ enumTraversable xs where go (n, x) = catchError (f x) $ \e -> do es <- fmap catMaybes $ mapM (err . f) $ drop (n + 1) $ toList xs throwError $ foldr (<>) e es err x = catchError (Nothing <$ x) (pure . Just) combineErrors :: (Traversable t, MonadError InsertException m) => t (m a) -> m (t a) combineErrors = mapErrors id enumTraversable :: (Num n, Traversable t) => t a -> t (n, a) enumTraversable = snd . L.mapAccumL go 0 where go n x = (n + 1, (n, x)) 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 :: (Traversable t, MonadUnliftIO m) => (a -> m b) -> t a -> m (t b) mapErrorsIO f xs = mapM go $ enumTraversable xs where go (n, x) = catch (f x) $ \(InsertException e) -> do es <- fmap catMaybes $ mapM (err . f) $ drop (n + 1) $ toList xs throwIO $ InsertException $ foldr (<>) e es err x = catch (Nothing <$ x) $ \(InsertException es) -> pure $ Just es collectErrorsIO :: (Traversable t, MonadUnliftIO m) => t (m a) -> m (t a) collectErrorsIO = mapErrorsIO id resolveFromValue :: TxRecord -> EntryNumGetter -> InsertExcept (Deferred Double) resolveFromValue r = fmap (uncurry Deferred) . resolveValue r resolveToValue :: TxRecord -> LinkedEntryNumGetter -> InsertExcept (LinkDeferred Double) resolveToValue _ (Linked l) = return $ LinkIndex l resolveToValue r (Getter g) = do (l, v) <- resolveValue r g return $ LinkDeferred (Deferred l v) resolveValue :: TxRecord -> EntryNumGetter -> InsertExcept (Bool, Double) resolveValue TxRecord {trOther, trAmount} s = case s of (LookupN t) -> (False,) <$> (readDouble =<< lookupErr EntryValField t trOther) (ConstN c) -> return (False, c) AmountN m -> return $ (False,) <$> (* m) $ fromRational trAmount BalanceN x -> return (True, x) resolveAcnt :: TxRecord -> EntryAcnt -> InsertExcept T.Text resolveAcnt = resolveEntryField AcntField resolveCurrency :: TxRecord -> EntryCur -> InsertExcept T.Text resolveCurrency = resolveEntryField CurField 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 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 [RoundError c] 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) (DaySpanError 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 EntryIDField st -> T.unwords ["entry", idName st, "ID"] EntryValField -> "entry 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 (fromRational balance :: Double) ] ] (PeriodError start next) -> [ T.unwords [ "First pay period on " , singleQuote $ showT start , "must start before first income payment on " , singleQuote $ showT next ] ] (IndexError Entry {eValue = LinkedNumGetter {lngIndex}, eAcnt} day) -> [ T.unwords [ "No credit entry for index" , singleQuote $ showT lngIndex , "for entry with account" , singleQuote eAcnt , "on" , showT day ] ] (RoundError cur) -> [ T.unwords [ "Could not look up precision for currency" , singleQuote cur ] ] 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 ] 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) -- 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, [b])] groupKey f = fmap go . NE.groupAllWith (f . fst) where go xs@((c, _) :| _) = (c, NE.toList $ fmap snd xs) groupWith :: Ord b => (a -> b) -> [a] -> [(b, [a])] groupWith f = fmap go . NE.groupAllWith fst . fmap (\x -> (f x, x)) where go xs@((c, _) :| _) = (c, NE.toList $ fmap snd xs) mapAdd_ :: (Ord k, Num v) => k -> v -> M.Map k v -> M.Map k v mapAdd_ k v = M.alter (maybe (Just v) (Just . (+ v))) k 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 _ -> [] lookupAccount :: (MonadInsertError m, MonadFinance m) => AcntID -> m (AccountRId, AcntSign, AcntType) lookupAccount = lookupFinance AcntField kmAccount lookupAccountKey :: (MonadInsertError m, MonadFinance m) => AcntID -> m AccountRId lookupAccountKey = fmap fstOf3 . lookupAccount lookupAccountSign :: (MonadInsertError m, MonadFinance m) => AcntID -> m AcntSign lookupAccountSign = fmap sndOf3 . lookupAccount lookupAccountType :: (MonadInsertError m, MonadFinance m) => AcntID -> m AcntType lookupAccountType = fmap thdOf3 . lookupAccount lookupCurrency :: (MonadInsertError m, MonadFinance m) => CurID -> m (CurrencyRId, Natural) lookupCurrency = lookupFinance CurField kmCurrency lookupCurrencyKey :: (MonadInsertError m, MonadFinance m) => AcntID -> m CurrencyRId lookupCurrencyKey = fmap fst . lookupCurrency lookupCurrencyPrec :: (MonadInsertError m, MonadFinance m) => AcntID -> m Natural lookupCurrencyPrec = fmap snd . lookupCurrency lookupTag :: (MonadInsertError m, MonadFinance m) => TagID -> m TagRId lookupTag = lookupFinance TagField kmTag lookupFinance :: (MonadInsertError m, MonadFinance m) => EntryIDType -> (DBState -> M.Map T.Text a) -> T.Text -> m a lookupFinance t f c = (liftExcept . lookupErr (DBKey t) c) =<< askDBState f