WIP make field errors useful
This commit is contained in:
parent
bb1c79b9a4
commit
0faea1161c
|
@ -521,7 +521,15 @@ data MatchRes a = MatchPass a | MatchFail | MatchSkip
|
||||||
|
|
||||||
data BalanceType = TooFewSplits | NotOneBlank deriving (Show)
|
data BalanceType = TooFewSplits | NotOneBlank deriving (Show)
|
||||||
|
|
||||||
data LookupField = AccountField | CurrencyField | OtherField deriving (Show)
|
data MatchType = MatchNumeric | MatchText deriving (Show)
|
||||||
|
|
||||||
|
data SplitIDType = AcntField | CurField deriving (Show)
|
||||||
|
|
||||||
|
data LookupSuberr
|
||||||
|
= SplitIDField SplitIDType
|
||||||
|
| SplitValField
|
||||||
|
| MatchField MatchType
|
||||||
|
deriving (Show)
|
||||||
|
|
||||||
data AllocationSuberr
|
data AllocationSuberr
|
||||||
= NoAllocations
|
= NoAllocations
|
||||||
|
@ -530,13 +538,11 @@ data AllocationSuberr
|
||||||
| TooManyBlanks
|
| TooManyBlanks
|
||||||
deriving (Show)
|
deriving (Show)
|
||||||
|
|
||||||
-- data ConversionSubError = Malformed | deriving (Show)
|
|
||||||
|
|
||||||
data InsertError
|
data InsertError
|
||||||
= RegexError T.Text
|
= RegexError T.Text
|
||||||
| YearError Natural
|
| YearError Natural
|
||||||
| ConversionError T.Text
|
| ConversionError T.Text
|
||||||
| LookupError LookupField T.Text
|
| LookupError LookupSuberr T.Text
|
||||||
| BalanceError BalanceType CurID [RawSplit]
|
| BalanceError BalanceType CurID [RawSplit]
|
||||||
| AllocationError AllocationSuberr DatePat
|
| AllocationError AllocationSuberr DatePat
|
||||||
| StatementError [TxRecord] [Match]
|
| StatementError [TxRecord] [Match]
|
||||||
|
|
|
@ -14,9 +14,8 @@ import qualified RIO.Text as T
|
||||||
import RIO.Time
|
import RIO.Time
|
||||||
import Text.Regex.TDFA
|
import Text.Regex.TDFA
|
||||||
|
|
||||||
-- when bifunctor fails...
|
--------------------------------------------------------------------------------
|
||||||
thrice :: (a -> d) -> (b -> e) -> (c -> f) -> (a, b, c) -> (d, e, f)
|
-- gregorian
|
||||||
thrice f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z)
|
|
||||||
|
|
||||||
gregTup :: Gregorian -> EitherErr (Integer, Int, Int)
|
gregTup :: Gregorian -> EitherErr (Integer, Int, Int)
|
||||||
gregTup Gregorian {..}
|
gregTup Gregorian {..}
|
||||||
|
@ -71,84 +70,50 @@ compareDate (In md offset) x = do
|
||||||
| otherwise = if (start + fromIntegral offset - 1) < z then GT else EQ
|
| otherwise = if (start + fromIntegral offset - 1) < z then GT else EQ
|
||||||
toMonth year month = (year * 12) + fromIntegral month
|
toMonth year month = (year * 12) + fromIntegral month
|
||||||
|
|
||||||
dateMatches :: MatchDate -> Day -> EitherErr Bool
|
boundsFromGregorian :: (Gregorian, Gregorian) -> EitherErrs Bounds
|
||||||
dateMatches md = fmap (EQ ==) . compareDate md
|
boundsFromGregorian (a, b) = concatEither2 a_ b_ (,)
|
||||||
|
|
||||||
valMatches :: MatchVal -> Rational -> Bool
|
|
||||||
valMatches MatchVal {..} x =
|
|
||||||
checkMaybe (s ==) mvSign
|
|
||||||
&& checkMaybe (n ==) mvNum
|
|
||||||
&& checkMaybe ((d * p ==) . fromIntegral) mvDen
|
|
||||||
where
|
where
|
||||||
(n, d) = properFraction $ abs x
|
a_ = fromGregorian' a
|
||||||
p = 10 ^ mvPrec
|
b_ = fromGregorian' b
|
||||||
s = signum x >= 0
|
|
||||||
|
|
||||||
evalSplit :: TxRecord -> ExpSplit -> EitherErrs RawSplit
|
fromGregorian' :: Gregorian -> EitherErr Day
|
||||||
evalSplit r s@Split {sAcnt = a, sValue = v, sCurrency = c} =
|
fromGregorian' = fmap (uncurry3 fromGregorian) . gregTup
|
||||||
concatEither3 (evalAcnt r a) (evalCurrency r c) (mapM (evalExp r) v) $
|
|
||||||
\a_ c_ v_ -> (s {sAcnt = a_, sValue = v_, sCurrency = c_})
|
|
||||||
|
|
||||||
evalAcnt :: TxRecord -> SplitAcnt -> EitherErr T.Text
|
inBounds :: Bounds -> Day -> Bool
|
||||||
evalAcnt TxRecord {trOther = o} s = case s of
|
inBounds (d0, d1) x = d0 <= x && x <= d1
|
||||||
ConstT p -> Right p
|
|
||||||
LookupT f -> lookupErr AccountField f o
|
|
||||||
MapT (Field f m) -> do
|
|
||||||
k <- lookupErr AccountField f o
|
|
||||||
lookupErr AccountField k m
|
|
||||||
Map2T (Field (f1, f2) m) -> do
|
|
||||||
k1 <- lookupErr AccountField f1 o
|
|
||||||
k2 <- lookupErr AccountField f2 o
|
|
||||||
lookupErr AccountField (k1, k2) m
|
|
||||||
|
|
||||||
-- TODO wett codde
|
inMaybeBounds :: MaybeBounds -> Day -> Bool
|
||||||
evalCurrency :: TxRecord -> SplitCur -> EitherErr T.Text
|
inMaybeBounds (d0, d1) x = maybe True (x >=) d0 && maybe True (x <=) d1
|
||||||
evalCurrency TxRecord {trOther = o} s = case s of
|
|
||||||
ConstT p -> Right p
|
|
||||||
LookupT f -> lookupErr CurrencyField f o
|
|
||||||
MapT (Field f m) -> do
|
|
||||||
k <- lookupErr CurrencyField f o
|
|
||||||
lookupErr CurrencyField k m
|
|
||||||
Map2T (Field (f1, f2) m) -> do
|
|
||||||
k1 <- lookupErr CurrencyField f1 o
|
|
||||||
k2 <- lookupErr CurrencyField f2 o
|
|
||||||
lookupErr CurrencyField (k1, k2) m
|
|
||||||
|
|
||||||
errorT :: T.Text -> a
|
intervalMaybeBounds :: Interval -> EitherErrs MaybeBounds
|
||||||
errorT = error . T.unpack
|
intervalMaybeBounds Interval {intStart = s, intEnd = e} = concatEither2 s_ e_ (,)
|
||||||
|
where
|
||||||
|
s_ = mapM fromGregorian' s
|
||||||
|
e_ = mapM fromGregorian' e
|
||||||
|
|
||||||
lookupErr :: (Ord k, Show k) => LookupField -> k -> M.Map k v -> EitherErr v
|
resolveBounds :: MonadUnliftIO m => MaybeBounds -> m Bounds
|
||||||
lookupErr what k m = case M.lookup k m of
|
resolveBounds (s, e) = do
|
||||||
Just x -> Right x
|
s' <- maybe getDay return s
|
||||||
_ -> Left $ LookupError what $ showT k
|
e' <- maybe (addGregorianYearsClip 50 <$> getDay) return e
|
||||||
|
return (s', e')
|
||||||
|
where
|
||||||
|
getDay = utctDay <$> getCurrentTime
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
-- matching
|
||||||
|
|
||||||
matches :: Match -> TxRecord -> EitherErrs (MatchRes RawTx)
|
matches :: Match -> TxRecord -> EitherErrs (MatchRes RawTx)
|
||||||
matches Match {..} r@TxRecord {..} = do
|
matches Match {..} r@TxRecord {..} = do
|
||||||
res <- concatEither3 date other desc (\x y z -> x && y && z)
|
res <- concatEither3 date other desc (\x y z -> x && y && z)
|
||||||
if val && res
|
if val && res
|
||||||
then maybe (Right MatchSkip) (fmap MatchPass . eval) mTx
|
then maybe (Right MatchSkip) (fmap MatchPass . convert) mTx
|
||||||
else Right MatchFail
|
else Right MatchFail
|
||||||
where
|
where
|
||||||
val = valMatches mVal trAmount
|
val = valMatches mVal trAmount
|
||||||
date = maybe (Right True) (`dateMatches` trDate) mDate
|
date = maybe (Right True) (`dateMatches` trDate) mDate
|
||||||
other = foldM (\a o -> (a &&) <$> fieldMatches trOther o) True mOther
|
other = foldM (\a o -> (a &&) <$> otherMatches trOther o) True mOther
|
||||||
desc = maybe (return True) (matchMaybe trDesc) mDesc
|
desc = maybe (return True) (matchMaybe trDesc) mDesc
|
||||||
eval (ToTx cur a ss) = toTx cur a ss r
|
convert (ToTx cur a ss) = toTx cur a ss r
|
||||||
|
|
||||||
matchMaybe :: RegexContext Regex query b => query -> T.Text -> EitherErr b
|
|
||||||
matchMaybe q re = first (const $ RegexError re) $ pureTry $ q =~ re
|
|
||||||
|
|
||||||
fieldMatches :: M.Map T.Text T.Text -> MatchOther -> EitherErr Bool
|
|
||||||
fieldMatches dict m = case m of
|
|
||||||
Val (Field n mv) -> valMatches mv <$> (readRational =<< lookup_ n)
|
|
||||||
Desc (Field n md) -> (`matchMaybe` md) =<< lookup_ n
|
|
||||||
where
|
|
||||||
lookup_ n = case M.lookup n dict of
|
|
||||||
Just r -> Right r
|
|
||||||
Nothing -> Left $ LookupError OtherField n
|
|
||||||
|
|
||||||
checkMaybe :: (a -> Bool) -> Maybe a -> Bool
|
|
||||||
checkMaybe = maybe True
|
|
||||||
|
|
||||||
toTx :: SplitCur -> SplitAcnt -> [ExpSplit] -> TxRecord -> EitherErrs RawTx
|
toTx :: SplitCur -> SplitAcnt -> [ExpSplit] -> TxRecord -> EitherErrs RawTx
|
||||||
toTx sc sa toSplits r@TxRecord {..} =
|
toTx sc sa toSplits r@TxRecord {..} =
|
||||||
|
@ -167,8 +132,68 @@ toTx sc sa toSplits r@TxRecord {..} =
|
||||||
, txSplits = fromSplit : ss_
|
, txSplits = fromSplit : ss_
|
||||||
}
|
}
|
||||||
where
|
where
|
||||||
acRes = concatEither2 (evalAcnt r sa) (evalCurrency r sc) (,)
|
acRes = concatEithers2 (resolveAcnt r sa) (resolveCurrency r sc) (,)
|
||||||
ssRes = concatEithersL $ fmap (evalSplit r) toSplits
|
ssRes = concatEithersL $ fmap (resolveSplit r) toSplits
|
||||||
|
|
||||||
|
valMatches :: MatchVal -> Rational -> Bool
|
||||||
|
valMatches MatchVal {..} x =
|
||||||
|
checkMaybe (s ==) mvSign
|
||||||
|
&& checkMaybe (n ==) mvNum
|
||||||
|
&& checkMaybe ((d * p ==) . fromIntegral) mvDen
|
||||||
|
where
|
||||||
|
(n, d) = properFraction $ abs x
|
||||||
|
p = 10 ^ mvPrec
|
||||||
|
s = signum x >= 0
|
||||||
|
checkMaybe = maybe True
|
||||||
|
|
||||||
|
dateMatches :: MatchDate -> Day -> EitherErr Bool
|
||||||
|
dateMatches md = fmap (EQ ==) . compareDate md
|
||||||
|
|
||||||
|
otherMatches :: M.Map T.Text T.Text -> MatchOther -> EitherErr 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
|
||||||
|
|
||||||
|
resolveSplit :: TxRecord -> ExpSplit -> EitherErrs RawSplit
|
||||||
|
resolveSplit r s@Split {sAcnt = a, sValue = v, sCurrency = c} =
|
||||||
|
concatEithers2 acRes valRes $
|
||||||
|
\(a_, c_) v_ -> (s {sAcnt = a_, sValue = v_, sCurrency = c_})
|
||||||
|
where
|
||||||
|
acRes = concatEithers2 (resolveAcnt r a) (resolveCurrency r c) (,)
|
||||||
|
valRes = plural $ mapM (resolveValue r) v
|
||||||
|
|
||||||
|
resolveValue :: TxRecord -> SplitNum -> EitherErr Rational
|
||||||
|
resolveValue r s = case s of
|
||||||
|
(LookupN t) -> readRational =<< lookupErr SplitValField t (trOther r)
|
||||||
|
(ConstN c) -> Right $ dec2Rat c
|
||||||
|
AmountN -> Right $ trAmount r
|
||||||
|
|
||||||
|
resolveAcnt :: TxRecord -> SplitAcnt -> EitherErrs T.Text
|
||||||
|
resolveAcnt = resolveSplitField AcntField
|
||||||
|
|
||||||
|
resolveCurrency :: TxRecord -> SplitCur -> EitherErrs T.Text
|
||||||
|
resolveCurrency = resolveSplitField CurField
|
||||||
|
|
||||||
|
resolveSplitField :: SplitIDType -> TxRecord -> SplitAcnt -> EitherErrs T.Text
|
||||||
|
resolveSplitField t TxRecord {trOther = o} s = case s of
|
||||||
|
ConstT p -> Right p
|
||||||
|
LookupT f -> plural $ lookup_ f o
|
||||||
|
MapT (Field f m) -> plural $ do
|
||||||
|
k <- lookup_ f o
|
||||||
|
lookup_ k m
|
||||||
|
Map2T (Field (f1, f2) m) -> do
|
||||||
|
(k1, k2) <- concatEither2 (lookup_ f1 o) (lookup_ f2 o) (,)
|
||||||
|
plural $ lookup_ (k1, k2) m
|
||||||
|
where
|
||||||
|
lookup_ :: (Ord k, Show k) => k -> M.Map k v -> EitherErr v
|
||||||
|
lookup_ = lookupErr (SplitIDField t)
|
||||||
|
|
||||||
|
lookupErr :: (Ord k, Show k) => LookupSuberr -> k -> M.Map k v -> EitherErr v
|
||||||
|
lookupErr what k m = case M.lookup k m of
|
||||||
|
Just x -> Right x
|
||||||
|
_ -> Left $ LookupError what $ showT k
|
||||||
|
|
||||||
parseRational :: MonadFail m => T.Text -> T.Text -> m Rational
|
parseRational :: MonadFail m => T.Text -> T.Text -> m Rational
|
||||||
parseRational pat s = case ms of
|
parseRational pat s = case ms of
|
||||||
|
@ -221,35 +246,6 @@ readRational s = case T.split (== '.') s of
|
||||||
mapTxSplits :: (a -> b) -> Tx a -> Tx b
|
mapTxSplits :: (a -> b) -> Tx a -> Tx b
|
||||||
mapTxSplits f t@Tx {txSplits = ss} = t {txSplits = fmap f ss}
|
mapTxSplits f t@Tx {txSplits = ss} = t {txSplits = fmap f ss}
|
||||||
|
|
||||||
boundsFromGregorian :: (Gregorian, Gregorian) -> EitherErrs Bounds
|
|
||||||
boundsFromGregorian (a, b) = concatEither2 a_ b_ (,)
|
|
||||||
where
|
|
||||||
a_ = fromGregorian' a
|
|
||||||
b_ = fromGregorian' b
|
|
||||||
|
|
||||||
fromGregorian' :: Gregorian -> EitherErr Day
|
|
||||||
fromGregorian' = fmap (uncurry3 fromGregorian) . gregTup
|
|
||||||
|
|
||||||
inBounds :: Bounds -> Day -> Bool
|
|
||||||
inBounds (d0, d1) x = d0 <= x && x <= d1
|
|
||||||
|
|
||||||
inMaybeBounds :: MaybeBounds -> Day -> Bool
|
|
||||||
inMaybeBounds (d0, d1) x = maybe True (x >=) d0 && maybe True (x <=) d1
|
|
||||||
|
|
||||||
intervalMaybeBounds :: Interval -> EitherErrs MaybeBounds
|
|
||||||
intervalMaybeBounds Interval {intStart = s, intEnd = e} = concatEither2 s_ e_ (,)
|
|
||||||
where
|
|
||||||
s_ = mapM fromGregorian' s
|
|
||||||
e_ = mapM fromGregorian' e
|
|
||||||
|
|
||||||
resolveBounds :: MonadUnliftIO m => MaybeBounds -> m Bounds
|
|
||||||
resolveBounds (s, e) = do
|
|
||||||
s' <- maybe getDay return s
|
|
||||||
e' <- maybe (addGregorianYearsClip 50 <$> getDay) return e
|
|
||||||
return (s', e')
|
|
||||||
where
|
|
||||||
getDay = utctDay <$> getCurrentTime
|
|
||||||
|
|
||||||
fmtRational :: Natural -> Rational -> T.Text
|
fmtRational :: Natural -> Rational -> T.Text
|
||||||
fmtRational precision x = T.concat [s, txt n', ".", pad 2 "0" $ txt d']
|
fmtRational precision x = T.concat [s, txt n', ".", pad 2 "0" $ txt d']
|
||||||
where
|
where
|
||||||
|
@ -261,21 +257,6 @@ fmtRational precision x = T.concat [s, txt n', ".", pad 2 "0" $ txt d']
|
||||||
txt = T.pack . show
|
txt = T.pack . show
|
||||||
pad i c z = T.append (T.replicate (i - T.length z) c) z
|
pad i c z = T.append (T.replicate (i - T.length z) c) z
|
||||||
|
|
||||||
uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d
|
|
||||||
uncurry3 f (a, b, c) = f a b 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
|
|
||||||
|
|
||||||
evalExp :: TxRecord -> SplitNum -> EitherErr Rational
|
|
||||||
evalExp r s = case s of
|
|
||||||
(LookupN t) -> readRational =<< lookupErr OtherField t (trOther r)
|
|
||||||
(ConstN c) -> Right $ dec2Rat c
|
|
||||||
AmountN -> Right $ trAmount r
|
|
||||||
|
|
||||||
dec2Rat :: Decimal -> Rational
|
dec2Rat :: Decimal -> Rational
|
||||||
dec2Rat D {..} =
|
dec2Rat D {..} =
|
||||||
k * (fromIntegral whole + (fromIntegral decimal % (10 ^ precision)))
|
k * (fromIntegral whole + (fromIntegral decimal % (10 ^ precision)))
|
||||||
|
@ -285,14 +266,38 @@ dec2Rat D {..} =
|
||||||
acntPath2Text :: AcntPath -> T.Text
|
acntPath2Text :: AcntPath -> T.Text
|
||||||
acntPath2Text (AcntPath t cs) = T.intercalate "/" (atName t : cs)
|
acntPath2Text (AcntPath t cs) = T.intercalate "/" (atName t : cs)
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
-- error display
|
||||||
|
|
||||||
showError :: InsertError -> [T.Text]
|
showError :: InsertError -> [T.Text]
|
||||||
showError (StatementError ts ms) = (showTx <$> ts) ++ (showMatch <$> ms)
|
showError (StatementError ts ms) = (showTx <$> ts) ++ (showMatch <$> ms)
|
||||||
showError other = (: []) $ case other of
|
showError other = (: []) $ case other of
|
||||||
|
-- TODO show whole date here since this is kinda useless
|
||||||
(YearError y) -> T.append "Year must be two digits: " $ showT y
|
(YearError y) -> T.append "Year must be two digits: " $ showT y
|
||||||
(RegexError re) -> T.append "could not make regex from pattern: " re
|
(RegexError re) -> T.append "could not make regex from pattern: " re
|
||||||
(ConversionError x) -> T.append "Could not convert to rational number: " x
|
(ConversionError x) -> T.append "Could not convert to rational number: " x
|
||||||
-- TODO use the field indicator
|
-- TODO use the field indicator
|
||||||
(LookupError _ f) -> T.append "Could not find field: " f
|
(LookupError t f) ->
|
||||||
|
T.unwords
|
||||||
|
[ "Could not find field"
|
||||||
|
, singleQuote f
|
||||||
|
, "when resolving"
|
||||||
|
, what
|
||||||
|
]
|
||||||
|
where
|
||||||
|
what = case t of
|
||||||
|
SplitIDField st ->
|
||||||
|
T.unwords
|
||||||
|
[ "split"
|
||||||
|
, case st of AcntField -> "account"; CurField -> "currency"
|
||||||
|
, "ID"
|
||||||
|
]
|
||||||
|
SplitValField -> "split value"
|
||||||
|
MatchField mt ->
|
||||||
|
T.unwords
|
||||||
|
[ case mt of MatchNumeric -> "numeric"; MatchText -> "text"
|
||||||
|
, "match"
|
||||||
|
]
|
||||||
(AllocationError t dp) -> T.concat [msg, ": datepattern=", showT dp]
|
(AllocationError t dp) -> T.concat [msg, ": datepattern=", showT dp]
|
||||||
where
|
where
|
||||||
msg = case t of
|
msg = case t of
|
||||||
|
@ -301,11 +306,11 @@ showError other = (: []) $ case other of
|
||||||
MissingBlank -> "No blank allocation to balance"
|
MissingBlank -> "No blank allocation to balance"
|
||||||
TooManyBlanks -> "Cannot balance multiple blank allocations"
|
TooManyBlanks -> "Cannot balance multiple blank allocations"
|
||||||
(BalanceError t cur rss) ->
|
(BalanceError t cur rss) ->
|
||||||
T.concat
|
T.unwords
|
||||||
[ msg
|
[ msg
|
||||||
, " for currency "
|
, "for currency"
|
||||||
, singleQuote cur
|
, singleQuote cur
|
||||||
, " and for splits "
|
, "and for splits"
|
||||||
, splits
|
, splits
|
||||||
]
|
]
|
||||||
where
|
where
|
||||||
|
@ -357,9 +362,6 @@ showMatchDate md = case md of
|
||||||
-- YMD (Gregorian {..}) -> [gYear, gMonth, gDay]
|
-- YMD (Gregorian {..}) -> [gYear, gMonth, gDay]
|
||||||
-- in T.intercalate "-" $ L.take 3 (fmap showT ys ++ L.repeat "*")
|
-- in T.intercalate "-" $ L.take 3 (fmap showT ys ++ L.repeat "*")
|
||||||
|
|
||||||
showT :: Show a => a -> T.Text
|
|
||||||
showT = T.pack . show
|
|
||||||
|
|
||||||
showMatchVal :: MatchVal -> Maybe T.Text
|
showMatchVal :: MatchVal -> Maybe T.Text
|
||||||
showMatchVal = undefined
|
showMatchVal = undefined
|
||||||
|
|
||||||
|
@ -387,6 +389,12 @@ keyVal a b = T.concat [a, "=", b]
|
||||||
keyVals :: [(T.Text, T.Text)] -> T.Text
|
keyVals :: [(T.Text, T.Text)] -> T.Text
|
||||||
keyVals = T.intercalate "; " . fmap (uncurry keyVal)
|
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 :: Either x a -> Either x b -> (a -> b -> c) -> Either [x] c
|
||||||
concatEither2 a b fun = case (a, b) of
|
concatEither2 a b fun = case (a, b) of
|
||||||
(Right a_, Right b_) -> Right $ fun a_ b_
|
(Right a_, Right b_) -> Right $ fun a_ b_
|
||||||
|
@ -398,7 +406,7 @@ concatEither3 a b c fun = case (a, b, c) of
|
||||||
_ -> Left $ catMaybes [leftToMaybe a, leftToMaybe b, leftToMaybe c]
|
_ -> Left $ catMaybes [leftToMaybe a, leftToMaybe b, leftToMaybe c]
|
||||||
|
|
||||||
concatEithers2 :: Either [x] a -> Either [x] b -> (a -> b -> c) -> Either [x] c
|
concatEithers2 :: Either [x] a -> Either [x] b -> (a -> b -> c) -> Either [x] c
|
||||||
concatEithers2 a b = first concat . concatEither2 a b
|
concatEithers2 a b = merge . concatEither2 a b
|
||||||
|
|
||||||
concatEithers3
|
concatEithers3
|
||||||
:: Either [x] a
|
:: Either [x] a
|
||||||
|
@ -406,7 +414,7 @@ concatEithers3
|
||||||
-> Either [x] c
|
-> Either [x] c
|
||||||
-> (a -> b -> c -> d)
|
-> (a -> b -> c -> d)
|
||||||
-> Either [x] d
|
-> Either [x] d
|
||||||
concatEithers3 a b c = first concat . concatEither3 a b c
|
concatEithers3 a b c = merge . concatEither3 a b c
|
||||||
|
|
||||||
concatEitherL :: [Either x a] -> Either [x] [a]
|
concatEitherL :: [Either x a] -> Either [x] [a]
|
||||||
concatEitherL as = case partitionEithers as of
|
concatEitherL as = case partitionEithers as of
|
||||||
|
@ -414,7 +422,7 @@ concatEitherL as = case partitionEithers as of
|
||||||
(es, _) -> Left es
|
(es, _) -> Left es
|
||||||
|
|
||||||
concatEithersL :: [Either [x] a] -> Either [x] [a]
|
concatEithersL :: [Either [x] a] -> Either [x] [a]
|
||||||
concatEithersL = first concat . concatEitherL
|
concatEithersL = merge . concatEitherL
|
||||||
|
|
||||||
leftToMaybe :: Either a b -> Maybe a
|
leftToMaybe :: Either a b -> Maybe a
|
||||||
leftToMaybe (Left a) = Just a
|
leftToMaybe (Left a) = Just a
|
||||||
|
@ -427,3 +435,28 @@ unlessLeft (Right rs) f = f rs >> return mzero
|
||||||
unlessLefts :: (Monad m, MonadPlus n) => Either (n a) b -> (b -> m ()) -> m (n a)
|
unlessLefts :: (Monad m, MonadPlus n) => Either (n a) b -> (b -> m ()) -> m (n a)
|
||||||
unlessLefts (Left es) _ = return es
|
unlessLefts (Left es) _ = return es
|
||||||
unlessLefts (Right rs) f = f rs >> return mzero
|
unlessLefts (Right rs) f = f rs >> return mzero
|
||||||
|
|
||||||
|
plural :: Either a b -> Either [a] b
|
||||||
|
plural = first (: [])
|
||||||
|
|
||||||
|
merge :: Either [[a]] b -> Either [a] b
|
||||||
|
merge = first concat
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
-- random functions
|
||||||
|
|
||||||
|
-- when bifunctor fails...
|
||||||
|
thrice :: (a -> d) -> (b -> e) -> (c -> f) -> (a, b, c) -> (d, e, f)
|
||||||
|
thrice f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z)
|
||||||
|
|
||||||
|
uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d
|
||||||
|
uncurry3 f (a, b, c) = f a b c
|
||||||
|
|
||||||
|
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
|
||||||
|
|
||||||
|
matchMaybe :: RegexContext Regex query b => query -> T.Text -> EitherErr b
|
||||||
|
matchMaybe q re = first (const $ RegexError re) $ pureTry $ q =~ re
|
||||||
|
|
Loading…
Reference in New Issue