pwncash/lib/Internal/Utils.hs

929 lines
31 KiB
Haskell
Raw Normal View History

2023-01-28 19:32:56 -05:00
module Internal.Utils
( compareDate
2023-05-29 15:56:15 -04:00
, expandDatePat
, askDays
2023-05-14 19:20:10 -04:00
, fromWeekday
2023-05-29 15:56:15 -04:00
, inDaySpan
2023-01-28 19:32:56 -05:00
, fmtRational
, matches
, fromGregorian'
2023-05-29 15:56:15 -04:00
, resolveDaySpan
, resolveDaySpan_
, intersectDaySpan
2023-05-07 20:29:33 -04:00
, liftInner
, liftExceptT
, liftExcept
, liftIOExcept
, liftIOExceptT
, combineError
, combineError_
, combineError3
, combineErrors
, mapErrors
, combineErrorM
, combineErrorM3
, combineErrorIO2
, combineErrorIO3
, combineErrorIOM2
, combineErrorIOM3
, collectErrorsIO
, mapErrorsIO
2023-01-28 19:32:56 -05:00
, parseRational
, showError
2023-01-28 22:55:07 -05:00
, unlessLeft_
, unlessLefts_
2023-01-28 19:32:56 -05:00
, unlessLeft
, unlessLefts
, acntPath2Text
, showT
2023-01-28 22:55:07 -05:00
, lookupErr
, gregorians
2023-04-16 20:09:13 -04:00
, uncurry3
, fstOf3
, sndOf3
, thdOf3
, xGregToDay
2023-02-01 23:02:07 -05:00
, compileMatch
, compileOptions
2023-02-13 19:57:39 -05:00
, dateMatches
, valMatches
2023-05-04 21:48:21 -04:00
, roundPrecision
, roundPrecisionCur
2023-05-29 15:56:15 -04:00
, lookupAccountKey
, lookupAccountSign
, lookupAccountType
, lookupCurrencyKey
, lookupCurrencyPrec
, lookupTag
2023-01-28 19:32:56 -05:00
)
where
2022-12-11 17:51:11 -05:00
2023-05-07 20:29:33 -04:00
import Control.Monad.Error.Class
import Control.Monad.Except
2023-05-04 21:48:21 -04:00
import Control.Monad.Reader
2023-01-25 20:52:27 -05:00
import Data.Time.Format.ISO8601
import GHC.Real
import Internal.Types.Main
import RIO
2023-01-25 20:52:27 -05:00
import qualified RIO.List as L
import qualified RIO.Map as M
2023-02-25 22:56:23 -05:00
import qualified RIO.NonEmpty as NE
import qualified RIO.Text as T
import RIO.Time
import Text.Regex.TDFA
import Text.Regex.TDFA.Text
2022-12-11 17:51:11 -05:00
2023-05-29 15:56:15 -04:00
--------------------------------------------------------------------------------
-- 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)
2023-01-27 23:33:34 -05:00
--------------------------------------------------------------------------------
2023-01-28 19:32:56 -05:00
-- dates
2023-05-14 19:20:10 -04:00
-- | 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
2023-01-28 19:32:56 -05:00
gregTup :: Gregorian -> (Integer, Int, Int)
2023-02-12 16:23:32 -05:00
gregTup Gregorian {gYear, gMonth, gDay} =
2023-01-28 19:32:56 -05:00
( fromIntegral gYear
, fromIntegral gMonth
, fromIntegral gDay
)
gregMTup :: GregorianM -> (Integer, Int)
2023-02-12 16:23:32 -05:00
gregMTup GregorianM {gmYear, gmMonth} =
2023-01-28 19:32:56 -05:00
( fromIntegral gmYear
, fromIntegral gmMonth
)
2023-01-30 22:57:42 -05:00
data YMD_ = Y_ !Integer | YM_ !Integer !Int | YMD_ !Integer !Int !Int
2023-01-28 19:32:56 -05:00
fromYMDMatcher :: YMDMatcher -> YMD_
fromYMDMatcher m = case m of
2023-01-28 19:32:56 -05:00
Y y -> Y_ $ fromIntegral y
YM g -> uncurry YM_ $ gregMTup g
YMD g -> uncurry3 YMD_ $ gregTup g
compareDate :: DateMatcher -> Day -> Ordering
2023-01-28 19:32:56 -05:00
compareDate (On md) x =
case fromYMDMatcher md of
2023-01-25 23:04:54 -05:00
Y_ y' -> compare y y'
YM_ y' m' -> compare (y, m) (y', m')
YMD_ y' m' d' -> compare (y, m, d) (y', m', d')
2022-12-11 17:51:11 -05:00
where
(y, m, d) = toGregorian x
2023-01-25 23:04:54 -05:00
compareDate (In md offset) x = do
case fromYMDMatcher md of
2023-01-25 23:04:54 -05:00
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
2022-12-11 17:51:11 -05:00
where
(y, m, _) = toGregorian x
compareRange start z
2022-12-11 17:51:11 -05:00
| z < start = LT
2022-12-22 20:13:03 -05:00
| otherwise = if (start + fromIntegral offset - 1) < z then GT else EQ
toMonth year month = (year * 12) + fromIntegral month
2022-12-11 17:51:11 -05:00
2023-01-28 19:32:56 -05:00
fromGregorian' :: Gregorian -> Day
fromGregorian' = uncurry3 fromGregorian . gregTup
2022-12-11 17:51:11 -05:00
2023-05-29 15:56:15 -04:00
inDaySpan :: DaySpan -> Day -> Bool
inDaySpan bs = withinDays (fromDaySpan bs)
2023-05-29 13:09:17 -04:00
withinDays :: (Day, Day) -> Day -> Bool
withinDays (d0, d1) x = d0 <= x && x < d1
2023-05-29 15:56:15 -04:00
resolveDaySpan :: Interval -> InsertExcept DaySpan
resolveDaySpan i@Interval {intStart = s} =
resolveDaySpan_ (s {gYear = gYear s + 50}) i
2023-05-29 15:56:15 -04:00
intersectDaySpan :: DaySpan -> DaySpan -> Maybe DaySpan
intersectDaySpan a b =
if b' > a' then Nothing else Just $ toDaySpan (a', b')
2023-05-29 13:09:17 -04:00
where
2023-05-29 15:56:15 -04:00
(a0, a1) = fromDaySpan a
(b0, b1) = fromDaySpan b
2023-05-29 13:09:17 -04:00
a' = max a0 a1
b' = min b0 b1
2023-05-29 15:56:15 -04:00
resolveDaySpan_ :: Gregorian -> Interval -> InsertExcept DaySpan
resolveDaySpan_ def Interval {intStart = s, intEnd = e} =
case fromGregorian' <$> e of
2023-05-29 15:56:15 -04:00
Nothing -> return $ toDaySpan_ $ fromGregorian' def
Just e_
2023-05-29 15:56:15 -04:00
| s_ < e_ -> return $ toDaySpan_ e_
| otherwise -> throwError $ InsertException [DaySpanError s e]
2023-01-27 23:33:34 -05:00
where
s_ = fromGregorian' s
2023-05-29 15:56:15 -04:00
toDaySpan_ end = toDaySpan (s_, end)
fromDaySpan :: DaySpan -> (Day, Day)
fromDaySpan (d, n) = (d, addDays (fromIntegral n + 1) d)
2023-05-29 15:56:15 -04:00
-- ASSUME a < b
toDaySpan :: (Day, Day) -> DaySpan
toDaySpan (a, b) = (a, fromIntegral $ diffDays b a - 1)
2023-01-27 23:33:34 -05:00
--------------------------------------------------------------------------------
-- matching
2022-12-11 17:51:11 -05:00
2023-05-07 20:29:33 -04:00
matches :: MatchRe -> TxRecord -> InsertExceptT CurrencyM (MatchRes RawTx)
2023-02-12 16:23:32 -05:00
matches
2023-04-30 23:28:16 -04:00
StatementParser {spTx, spOther, spVal, spDate, spDesc}
2023-02-12 16:23:32 -05:00
r@TxRecord {trDate, trAmount, trDesc, trOther} = do
2023-05-07 20:29:33 -04:00
res <- liftInner $
combineError3 val other desc $
\x y z -> x && y && z && date
if res
then maybe (return MatchSkip) convert spTx
else return MatchFail
2023-02-12 16:23:32 -05:00
where
2023-04-30 23:28:16 -04:00
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
2023-05-07 20:29:33 -04:00
convert (TxGetter cur a ss) = MatchPass <$> toTx cur a ss r
2023-05-04 21:48:21 -04:00
2023-05-29 16:11:19 -04:00
toTx :: EntryCur -> EntryAcnt -> [EntryGetter] -> TxRecord -> InsertExceptT CurrencyM RawTx
toTx sc sa toEntries r@TxRecord {trAmount, trDate, trDesc} = do
combineError3 acntRes curRes ssRes $ \a c es ->
let fromEntry =
Entry
2023-05-04 21:48:21 -04:00
{ eAcnt = a
, eCurrency = c
2023-04-30 23:28:16 -04:00
, eValue = Just trAmount
, eComment = ""
, eTags = [] -- TODO what goes here?
2023-01-26 23:41:45 -05:00
}
in Tx
2023-02-26 22:56:32 -05:00
{ txDate = trDate
, txDescr = trDesc
2023-05-29 16:11:19 -04:00
, txEntries = fromEntry : es
2023-01-25 23:04:54 -05:00
}
2023-01-26 23:41:45 -05:00
where
2023-05-07 20:29:33 -04:00
acntRes = liftInner $ resolveAcnt r sa
curRes = liftInner $ resolveCurrency r sc
2023-05-29 16:11:19 -04:00
ssRes = combineErrors $ fmap (resolveEntry r) toEntries
2023-01-27 23:33:34 -05:00
2023-05-07 20:29:33 -04:00
valMatches :: ValMatcher -> Rational -> InsertExcept Bool
2023-04-30 23:28:16 -04:00
valMatches ValMatcher {vmDen, vmSign, vmNum, vmPrec} x
2023-05-07 20:29:33 -04:00
| Just d_ <- vmDen, d_ >= p = throwError $ InsertException [MatchValPrecisionError d_ p]
2023-01-28 20:03:58 -05:00
| otherwise =
2023-05-07 20:29:33 -04:00
return $
2023-04-30 23:28:16 -04:00
checkMaybe (s ==) vmSign
&& checkMaybe (n ==) vmNum
&& checkMaybe ((d * fromIntegral p ==) . fromIntegral) vmDen
2023-01-27 23:33:34 -05:00
where
(n, d) = properFraction $ abs x
2023-04-30 23:28:16 -04:00
p = 10 ^ vmPrec
2023-01-27 23:33:34 -05:00
s = signum x >= 0
checkMaybe = maybe True
dateMatches :: DateMatcher -> Day -> Bool
2023-01-28 19:32:56 -05:00
dateMatches md = (EQ ==) . compareDate md
2023-01-27 23:33:34 -05:00
2023-05-07 20:29:33 -04:00
otherMatches :: M.Map T.Text T.Text -> FieldMatcherRe -> InsertExcept Bool
2023-01-27 23:33:34 -05:00
otherMatches dict m = case m of
2023-01-28 20:03:58 -05:00
Val (Field n mv) -> valMatches mv =<< (readRational =<< lookup_ MatchNumeric n)
2023-02-01 23:02:07 -05:00
Desc (Field n (_, md)) -> (`matchMaybe` md) =<< lookup_ MatchText n
2023-01-27 23:33:34 -05:00
where
lookup_ t n = lookupErr (MatchField t) n dict
2023-05-29 16:11:19 -04:00
resolveEntry :: TxRecord -> EntryGetter -> InsertExceptT CurrencyM RawEntry
2023-05-07 20:29:33 -04:00
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}
2023-01-27 23:33:34 -05:00
where
2023-05-07 20:29:33 -04:00
acntRes = resolveAcnt r eAcnt
curRes = resolveCurrency r eCurrency
2023-05-04 21:48:21 -04:00
valRes = mapM (resolveValue r) eValue
2023-01-27 23:33:34 -05:00
2023-05-07 20:29:33 -04:00
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
2023-05-22 23:32:39 -04:00
resolveValue TxRecord {trOther, trAmount} s = case s of
2023-05-29 16:11:19 -04:00
(LookupN t) -> readDouble =<< lookupErr EntryValField t trOther
2023-05-07 20:29:33 -04:00
(ConstN c) -> return c
2023-05-25 00:11:04 -04:00
AmountN m -> return $ (* m) $ fromRational trAmount
2023-01-27 23:33:34 -05:00
2023-05-29 16:11:19 -04:00
resolveAcnt :: TxRecord -> EntryAcnt -> InsertExcept T.Text
resolveAcnt = resolveEntryField AcntField
2023-01-27 23:33:34 -05:00
2023-05-29 16:11:19 -04:00
resolveCurrency :: TxRecord -> EntryCur -> InsertExcept T.Text
resolveCurrency = resolveEntryField CurField
2023-01-27 23:33:34 -05:00
2023-05-29 16:11:19 -04:00
resolveEntryField :: EntryIDType -> TxRecord -> EntryAcnt -> InsertExcept T.Text
resolveEntryField t TxRecord {trOther = o} s = case s of
2023-05-07 20:29:33 -04:00
ConstT p -> return p
2023-05-04 21:48:21 -04:00
LookupT f -> lookup_ f o
MapT (Field f m) -> do
2023-01-27 23:33:34 -05:00
k <- lookup_ f o
lookup_ k m
2023-01-27 23:33:34 -05:00
Map2T (Field (f1, f2) m) -> do
2023-05-07 20:29:33 -04:00
(k1, k2) <- combineError (lookup_ f1 o) (lookup_ f2 o) (,)
2023-05-04 21:48:21 -04:00
lookup_ (k1, k2) m
2023-01-27 23:33:34 -05:00
where
2023-05-07 20:29:33 -04:00
lookup_ :: (Ord k, Show k) => k -> M.Map k v -> InsertExcept v
2023-05-29 16:11:19 -04:00
lookup_ = lookupErr (EntryIDField t)
2023-01-27 23:33:34 -05:00
2023-05-07 20:29:33 -04:00
lookupErr :: (Ord k, Show k) => LookupSuberr -> k -> M.Map k v -> InsertExcept v
2023-01-27 23:33:34 -05:00
lookupErr what k m = case M.lookup k m of
2023-05-07 20:29:33 -04:00
Just x -> return x
_ -> throwError $ InsertException [LookupError what $ showT k]
2022-12-11 17:51:11 -05:00
parseRational :: MonadFail m => (T.Text, Regex) -> T.Text -> m Rational
parseRational (pat, re) s = case matchGroupsMaybe s re of
2022-12-11 17:51:11 -05:00
[sign, x, ""] -> uncurry (*) <$> readWhole sign x
[sign, x, y] -> do
d <- readT "decimal" y
let p = 10 ^ T.length y
2022-12-11 17:51:11 -05:00
(k, w) <- readWhole sign x
return $ k * (w + d % p)
_ -> msg "malformed decimal"
2022-12-11 17:51:11 -05:00
where
readT what t = case readMaybe $ T.unpack t of
2023-02-13 18:49:41 -05:00
Just d -> return $ fromInteger d
_ -> msg $ T.unwords ["could not parse", what, singleQuote t]
2023-02-12 16:23:32 -05:00
msg :: MonadFail m => T.Text -> m a
msg m =
fail $
T.unpack $
T.unwords [m, "-", keyVals [("pattern", pat), ("query", s)]]
2022-12-11 17:51:11 -05:00
readSign x
| x == "-" = return (-1)
| x == "+" || x == "" = return 1
| otherwise = msg $ T.append "invalid sign: " x
2022-12-11 17:51:11 -05:00
readWhole sign x = do
w <- readT "whole number" x
k <- readSign sign
return (k, w)
2023-05-07 20:29:33 -04:00
readDouble :: T.Text -> InsertExcept Double
2023-05-04 21:48:21 -04:00
readDouble s = case readMaybe $ T.unpack s of
2023-05-07 20:29:33 -04:00
Just x -> return x
Nothing -> throwError $ InsertException [ConversionError s]
2023-05-04 21:48:21 -04:00
2023-05-07 20:29:33 -04:00
readRational :: T.Text -> InsertExcept Rational
readRational s = case T.split (== '.') s of
2023-01-25 23:04:54 -05:00
[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
2023-01-25 23:04:54 -05:00
k = if x' >= 0 then 1 else -1
in return $ fromInteger x' + k * y' % p
_ -> err
_ -> err
2022-12-11 17:51:11 -05:00
where
readT = readMaybe . T.unpack
2023-05-07 20:29:33 -04:00
err = throwError $ InsertException [ConversionError s]
2022-12-11 17:51:11 -05:00
-- TODO smells like a lens
2023-01-28 19:32:56 -05:00
-- mapTxSplits :: (a -> b) -> Tx a -> Tx b
-- mapTxSplits f t@Tx {txSplits = ss} = t {txSplits = fmap f ss}
2022-12-11 17:51:11 -05:00
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
2022-12-11 17:51:11 -05:00
p = 10 ^ precision
n' = div n d
d' = (\(a :% b) -> div a b) ((x' - fromIntegral n') * p)
2022-12-11 17:51:11 -05:00
txt = T.pack . show
pad i c z = T.append (T.replicate (i - T.length z) c) z
2023-05-04 21:48:21 -04:00
roundPrecision :: Natural -> Double -> Rational
roundPrecision n = (% p) . round . (* fromIntegral p) . toRational
2022-12-11 17:51:11 -05:00
where
2023-05-04 21:48:21 -04:00
p = 10 ^ n
2023-05-07 20:29:33 -04:00
roundPrecisionCur :: CurID -> CurrencyMap -> Double -> InsertExcept Rational
2023-05-04 21:48:21 -04:00
roundPrecisionCur c m x =
case M.lookup c m of
2023-05-07 20:29:33 -04:00
Just (_, n) -> return $ roundPrecision n x
Nothing -> throwError $ InsertException [undefined]
2022-12-11 17:51:11 -05:00
acntPath2Text :: AcntPath -> T.Text
acntPath2Text (AcntPath t cs) = T.intercalate "/" (atName t : cs)
2023-01-24 23:24:41 -05:00
2023-01-27 23:33:34 -05:00
--------------------------------------------------------------------------------
-- error display
2023-01-24 23:24:41 -05:00
showError :: InsertError -> [T.Text]
2023-04-16 20:09:13 -04:00
showError other = case other of
(StatementError ts ms) -> (showTx <$> ts) ++ (showMatch <$> ms)
2023-05-29 15:56:15 -04:00
(DaySpanError a b) ->
2023-04-16 20:09:13 -04:00
[T.unwords ["Could not create bounds from", showGregorian_ a, "and", showGreg b]]
where
showGreg (Just g) = showGregorian_ g
showGreg Nothing = "Inf"
2023-02-25 22:56:23 -05:00
(AccountError a ts) ->
2023-04-16 20:09:13 -04:00
[ T.unwords
[ "account type of key"
, singleQuote a
, "is not one of:"
, ts_
]
]
2023-02-25 22:56:23 -05:00
where
ts_ = T.intercalate ", " $ NE.toList $ fmap atName ts
2023-04-16 20:09:13 -04:00
(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"
2023-04-16 20:09:13 -04:00
(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]
2023-01-28 20:03:58 -05:00
(MatchValPrecisionError d p) ->
2023-04-16 20:09:13 -04:00
[T.unwords ["Match denominator", showT d, "must be less than", showT p]]
2023-01-27 23:33:34 -05:00
(LookupError t f) ->
2023-04-16 20:09:13 -04:00
[T.unwords ["Could not find field", f, "when resolving", what]]
2023-01-27 23:33:34 -05:00
where
what = case t of
2023-05-29 16:11:19 -04:00
EntryIDField st -> T.unwords ["entry", idName st, "ID"]
EntryValField -> "entry value"
2023-01-28 22:55:07 -05:00
MatchField mt -> T.unwords [matchName mt, "match"]
DBKey st -> T.unwords ["database", idName st, "ID key"]
2023-02-26 22:53:12 -05:00
-- TODO this should be its own function
2023-01-28 22:55:07 -05:00
idName AcntField = "account"
idName CurField = "currency"
2023-02-26 22:53:12 -05:00
idName TagField = "tag"
2023-01-28 22:55:07 -05:00
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"
2023-05-14 19:20:10 -04:00
, 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
]
]
2023-01-25 20:52:27 -05:00
(BalanceError t cur rss) ->
2023-04-16 20:09:13 -04:00
[ T.unwords
[ msg
, "for currency"
, singleQuote cur
2023-05-29 16:11:19 -04:00
, "and for entries"
, entries
2023-04-16 20:09:13 -04:00
]
]
2023-01-25 20:52:27 -05:00
where
msg = case t of
2023-05-29 16:11:19 -04:00
TooFewEntries -> "Need at least two entries to balance"
NotOneBlank -> "Exactly one entries must be blank"
entries = T.intercalate ", " $ fmap (singleQuote . showEntry) rss
2023-01-25 20:52:27 -05:00
showGregorian_ :: Gregorian -> T.Text
2023-02-12 16:23:32 -05:00
showGregorian_ Gregorian {gYear, gMonth, gDay} = T.intercalate "-" $ showT <$> [gYear, gMonth, gDay]
2023-01-25 20:52:27 -05:00
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)
2023-01-25 20:52:27 -05:00
]
2023-02-01 23:02:07 -05:00
showMatch :: MatchRe -> T.Text
2023-04-30 23:28:16 -04:00
showMatch StatementParser {spDate, spVal, spDesc, spOther, spTimes, spPriority} =
2023-01-25 20:52:27 -05:00
T.append "Unused match: " $ keyVals [(x, y) | (x, Just y) <- kvs]
where
kvs =
2023-04-30 23:28:16 -04:00
[ ("date", showDateMatcher <$> spDate)
, ("val", showValMatcher spVal)
, ("desc", fst <$> spDesc)
2023-01-25 20:52:27 -05:00
, ("other", others)
2023-04-30 23:28:16 -04:00
, ("counter", Just $ maybe "Inf" showT spTimes)
, ("priority", Just $ showT spPriority)
2023-01-25 20:52:27 -05:00
]
2023-04-30 23:28:16 -04:00
others = case spOther of
2023-01-25 20:52:27 -05:00
[] -> Nothing
2023-01-28 20:03:58 -05:00
xs -> Just $ singleQuote $ T.concat $ showMatchOther <$> xs
2023-01-25 20:52:27 -05:00
2023-01-28 18:52:28 -05:00
-- | Convert match date to text
2023-01-28 19:32:56 -05:00
-- 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, ")"]
2023-01-28 18:52:28 -05:00
where
2023-01-28 19:32:56 -05:00
-- TODO not DRY (this shifting thing happens during the comparison
-- function (kinda)
end = case fromYMDMatcher start of
2023-01-28 19:32:56 -05:00
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
2023-01-28 18:52:28 -05:00
-- | convert YMD match to text
showYMDMatcher :: YMDMatcher -> T.Text
showYMDMatcher = showYMD_ . fromYMDMatcher
2023-01-28 19:32:56 -05:00
showYMD_ :: YMD_ -> T.Text
showYMD_ md =
2023-01-28 18:52:28 -05:00
T.intercalate "-" $ L.take 3 (fmap showT digits ++ L.repeat "*")
where
digits = case md of
2023-01-28 19:32:56 -05:00
Y_ y -> [fromIntegral y]
YM_ y m -> [fromIntegral y, m]
YMD_ y m d -> [fromIntegral y, m, d]
2023-01-25 20:52:27 -05:00
showValMatcher :: ValMatcher -> Maybe T.Text
2023-04-30 23:28:16 -04:00
showValMatcher ValMatcher {vmSign = Nothing, vmNum = Nothing, vmDen = Nothing} = Nothing
showValMatcher ValMatcher {vmNum, vmDen, vmSign, vmPrec} =
2023-02-12 16:23:32 -05:00
Just $ singleQuote $ keyVals [(k, v) | (k, Just v) <- kvs]
2023-01-28 18:52:28 -05:00
where
2023-01-28 20:03:58 -05:00
kvs =
2023-04-30 23:28:16 -04:00
[ ("sign", (\s -> if s then "+" else "-") <$> vmSign)
, ("numerator", showT <$> vmNum)
, ("denominator", showT <$> vmDen)
, ("precision", Just $ showT vmPrec)
2023-01-28 20:03:58 -05:00
]
2023-01-25 20:52:27 -05:00
2023-04-30 23:28:16 -04:00
showMatchOther :: FieldMatcherRe -> T.Text
2023-02-01 23:02:07 -05:00
showMatchOther (Desc (Field f (re, _))) =
2023-01-28 20:03:58 -05:00
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
2023-01-28 20:03:58 -05:00
]
2023-01-25 20:52:27 -05:00
2023-05-29 16:11:19 -04:00
showEntry :: RawEntry -> T.Text
showEntry Entry {eAcnt, eValue, eComment} =
2023-01-28 20:03:58 -05:00
keyVals
2023-04-30 23:28:16 -04:00
[ ("account", eAcnt)
, ("value", T.pack $ show ((fromRational <$> eValue) :: Maybe Float))
, ("comment", doubleQuote eComment)
2023-01-28 20:03:58 -05:00
]
2023-01-25 20:52:27 -05:00
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)
2023-01-26 23:41:45 -05:00
2023-01-27 23:33:34 -05:00
showT :: Show a => a -> T.Text
showT = T.pack . show
--------------------------------------------------------------------------------
-- pure error processing
2023-05-07 20:29:33 -04:00
-- 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
2023-01-27 20:31:13 -05:00
2023-01-28 22:55:07 -05:00
unlessLeft :: (Monad m, MonadPlus n) => Either a b -> (b -> m (n a)) -> m (n a)
2023-01-27 20:31:13 -05:00
unlessLeft (Left es) _ = return (return es)
2023-01-28 22:55:07 -05:00
unlessLeft (Right rs) f = f rs
2023-01-27 20:31:13 -05:00
2023-01-28 22:55:07 -05:00
unlessLefts :: (Monad m) => Either (n a) b -> (b -> m (n a)) -> m (n a)
2023-01-27 20:31:13 -05:00
unlessLefts (Left es) _ = return es
2023-01-28 22:55:07 -05:00
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)
2023-01-27 23:33:34 -05:00
2023-05-07 20:29:33 -04:00
-- plural :: Either a b -> Either [a] b
-- plural = first (: [])
2023-01-27 23:33:34 -05:00
2023-05-07 20:29:33 -04:00
-- merge :: Either [[a]] b -> Either [a] b
-- merge = first concat
2023-01-27 23:33:34 -05:00
--------------------------------------------------------------------------------
-- random functions
-- when bifunctor fails...
2023-01-28 19:32:56 -05:00
-- 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)
2023-01-27 23:33:34 -05:00
uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d
uncurry3 f (a, b, c) = f a b c
2023-04-16 20:09:13 -04:00
fstOf3 :: (a, b, c) -> a
fstOf3 (a, _, _) = a
sndOf3 :: (a, b, c) -> b
sndOf3 (_, b, _) = b
thdOf3 :: (a, b, c) -> c
thdOf3 (_, _, c) = c
2023-01-28 19:32:56 -05:00
-- lpad :: a -> Int -> [a] -> [a]
-- lpad c n s = replicate (n - length s) c ++ s
2023-01-27 23:33:34 -05:00
2023-01-28 19:32:56 -05:00
-- rpad :: a -> Int -> [a] -> [a]
-- rpad c n s = s ++ replicate (n - length s) c
2023-01-27 23:33:34 -05:00
2023-01-28 20:03:58 -05:00
-- lpadT :: Char -> Int -> T.Text -> T.Text
-- lpadT c n s = T.append (T.replicate (n - T.length s) (T.singleton c)) s
2023-01-28 18:52:28 -05:00
-- 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
2023-02-01 23:02:07 -05:00
-- 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
2023-05-07 20:29:33 -04:00
compileOptions :: TxOpts T.Text -> InsertExcept TxOptsRe
compileOptions o@TxOpts {toAmountFmt = pat} = do
re <- compileRegex True pat
return $ o {toAmountFmt = re}
2023-05-07 20:29:33 -04:00
compileMatch :: StatementParser T.Text -> InsertExcept MatchRe
2023-04-30 23:28:16 -04:00
compileMatch m@StatementParser {spDesc, spOther} = do
2023-05-07 20:29:33 -04:00
combineError dres ores $ \d os -> m {spDesc = d, spOther = os}
where
go = compileRegex False
2023-05-07 20:29:33 -04:00
dres = mapM go spDesc
ores = combineErrors $ fmap (mapM go) spOther
2023-02-01 23:02:07 -05:00
2023-05-07 20:29:33 -04:00
compileRegex :: Bool -> T.Text -> InsertExcept (Text, Regex)
compileRegex groups pat = case res of
2023-05-07 20:29:33 -04:00
Right re -> return (pat, re)
Left _ -> throwError $ InsertException [RegexError pat]
2023-02-01 23:02:07 -05:00
where
res =
compile
(blankCompOpt {newSyntax = True})
(blankExecOpt {captureGroups = groups})
pat
2023-02-01 23:02:07 -05:00
2023-05-07 20:29:33 -04:00
matchMaybe :: T.Text -> Regex -> InsertExcept Bool
2023-02-01 23:02:07 -05:00
matchMaybe q re = case execute re q of
2023-05-07 20:29:33 -04:00
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 _ -> []
2023-05-29 15:56:15 -04:00
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) => T.Text -> 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)
2023-05-29 16:11:19 -04:00
=> EntryIDType
2023-05-29 15:56:15 -04:00
-> (DBState -> M.Map T.Text a)
-> T.Text
-> m a
lookupFinance t f c = (liftExcept . lookupErr (DBKey t) c) =<< askDBState f