1127 lines
37 KiB
Haskell
1127 lines
37 KiB
Haskell
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
|