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