WIP assign buckets more sanely
This commit is contained in:
parent
a16f6fbdd2
commit
53e1dde60f
|
|
@ -193,9 +193,18 @@ let TimeAmount = { taWhen : DatePat, taAmt : Amount, taAmtType : AmountType }
|
|||
|
||||
let Tax = { taxAcnt : AcntID, taxValue : Decimal }
|
||||
|
||||
let TransferTarget =
|
||||
< ExpenseTarget :
|
||||
{ _1xtarget :
|
||||
{- this is the only place expense accounts may be specified -}
|
||||
AcntID
|
||||
, _2xtarget : ExpenseBucket
|
||||
}
|
||||
| GenericTarget : AcntID
|
||||
>
|
||||
|
||||
let Allocation =
|
||||
{ alloPath : AcntID
|
||||
, alloBucket : ExpenseBucket
|
||||
{ alloPath : TransferTarget
|
||||
, alloAmts : List Amount
|
||||
, alloCurrency : CurID
|
||||
}
|
||||
|
|
@ -204,17 +213,19 @@ let Income =
|
|||
{ incGross : Decimal
|
||||
, incCurrency : CurID
|
||||
, incWhen : DatePat
|
||||
, incFrom : AcntID
|
||||
, incFrom :
|
||||
{- this must be an income AcntID, and is the only place income
|
||||
accounts may be specified in the entire budget -}
|
||||
AcntID
|
||||
, incPretax : List Allocation
|
||||
, incTaxes : List Tax
|
||||
, incPosttax : List Allocation
|
||||
, incToBal : AcntID
|
||||
, incToBal : TransferTarget
|
||||
}
|
||||
|
||||
let Transfer =
|
||||
{ transFrom : AcntID
|
||||
, transTo : AcntID
|
||||
, transBucket : ExpenseBucket
|
||||
, transTo : TransferTarget
|
||||
, transAmounts : List TimeAmount
|
||||
, transCurrency : CurID
|
||||
}
|
||||
|
|
@ -267,4 +278,5 @@ in { CurID
|
|||
, Amount
|
||||
, TimeAmount
|
||||
, AmountType
|
||||
, TransferTarget
|
||||
}
|
||||
|
|
|
|||
|
|
@ -59,7 +59,7 @@ IncomeBucketR sql=income_buckets
|
|||
deriving Show Eq
|
||||
|]
|
||||
|
||||
type AccountMap = M.Map AcntID (AccountRId, AcntSign)
|
||||
type AccountMap = M.Map AcntID (AccountRId, AcntSign, AcntType)
|
||||
|
||||
type CurrencyMap = M.Map CurID CurrencyRId
|
||||
|
||||
|
|
|
|||
|
|
@ -212,7 +212,7 @@ tree2Entity t parents name des =
|
|||
tree2Records
|
||||
:: AcntType
|
||||
-> AccountTree
|
||||
-> ([Entity AccountR], [AccountPathR], [(AcntPath, (AccountRId, AcntSign))])
|
||||
-> ([Entity AccountR], [AccountPathR], [(AcntPath, (AccountRId, AcntSign, AcntType))])
|
||||
tree2Records t = go []
|
||||
where
|
||||
go ps (Placeholder d n cs) =
|
||||
|
|
@ -227,7 +227,7 @@ tree2Records t = go []
|
|||
k = entityKey e
|
||||
in ( [acnt k n (fmap snd ps) d]
|
||||
, expand k $ fmap fst ps
|
||||
, [(AcntPath t $ reverse $ n : fmap snd ps, (k, sign))]
|
||||
, [(AcntPath t $ reverse $ n : fmap snd ps, (k, sign, t))]
|
||||
)
|
||||
toPath = T.intercalate "/" . (atName t :) . reverse
|
||||
acnt k n ps = Entity k . AccountR n (toPath ps)
|
||||
|
|
|
|||
|
|
@ -7,6 +7,7 @@ where
|
|||
import Data.Hashable
|
||||
import Database.Persist.Class
|
||||
import Database.Persist.Sql hiding (Single, Statement)
|
||||
import GHC.Utils.Misc hiding (split)
|
||||
import Internal.Database.Model
|
||||
import Internal.Statement
|
||||
import Internal.Types hiding (sign)
|
||||
|
|
@ -14,6 +15,7 @@ import Internal.Utils
|
|||
import RIO hiding (to)
|
||||
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
|
||||
|
||||
|
|
@ -95,12 +97,13 @@ dayToWeekday (ModifiedJulianDay d) = mod (fromIntegral d + 2) 7
|
|||
withDates
|
||||
:: MonadFinance m
|
||||
=> DatePat
|
||||
-> (Day -> SqlPersistT m a)
|
||||
-> (Day -> SqlPersistT m (EitherErrs a))
|
||||
-> SqlPersistT m (EitherErrs [a])
|
||||
withDates dp f = do
|
||||
bounds <- lift $ askDBState kmBudgetInterval
|
||||
let days = expandDatePat bounds dp
|
||||
mapM (mapM f) days
|
||||
case expandDatePat bounds dp of
|
||||
Left es -> return $ Left es
|
||||
Right days -> concatEithersL <$> mapM f days
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- budget
|
||||
|
|
@ -159,55 +162,88 @@ insertIncome :: MonadFinance m => T.Text -> Income -> SqlPersistT m (EitherErrs
|
|||
insertIncome
|
||||
name
|
||||
i@Income {incWhen, incCurrency, incFrom, incPretax, incPosttax, incTaxes, incToBal} =
|
||||
whenHash CTIncome i (Right []) $ \c -> case (balanceIncome i) of
|
||||
Left e -> return $ Left [e]
|
||||
Right balance ->
|
||||
fmap (fmap concat) $ withDates incWhen $ \day -> do
|
||||
let meta = BudgetMeta c day incCurrency name
|
||||
let fromAllos b = concatMap (fromAllo meta incFrom (Just b))
|
||||
let pre = fromAllos PreTax incPretax
|
||||
let tax = fmap (fromTax meta incFrom) incTaxes
|
||||
let post = fromAllos PostTax incPosttax
|
||||
let bal =
|
||||
TransferTx
|
||||
{ trxMeta = meta
|
||||
, trxFrom = BudgetSplit incFrom $ Just PostTax
|
||||
, trxTo = BudgetSplit incToBal Nothing
|
||||
, trxValue = balance
|
||||
, trxType = FixedAmt
|
||||
, trxDesc = "balance after deductions"
|
||||
}
|
||||
return $ bal : (pre ++ tax ++ post)
|
||||
whenHash CTIncome i (Right []) $ \c -> do
|
||||
let balRes = balanceIncome i
|
||||
fromRes <- lift $ checkAcntType IncomeT incFrom (\j -> BudgetSplit j . Just)
|
||||
toRes <- lift $ expandTarget incToBal
|
||||
case concatEither3 balRes fromRes toRes (,,) of
|
||||
Left es -> return $ Left es
|
||||
Right (balance, fromFun, to) ->
|
||||
fmap (fmap (concat . concat)) $
|
||||
withDates incWhen $ \day -> do
|
||||
let meta = BudgetMeta c day incCurrency name
|
||||
let fromAllos b =
|
||||
fmap (fmap concat . concatEitherL)
|
||||
. mapM (lift . fromAllo meta (fromFun b))
|
||||
pre <- fromAllos PreTax incPretax
|
||||
tax <-
|
||||
concatEitherL
|
||||
<$> mapM (lift . fromTax meta (fromFun IntraTax)) incTaxes
|
||||
post <- fromAllos PostTax incPosttax
|
||||
let bal =
|
||||
TransferTx
|
||||
{ trxMeta = meta
|
||||
, trxFrom = fromFun PostTax
|
||||
, trxTo = to
|
||||
, trxValue = balance
|
||||
, trxType = FixedAmt
|
||||
, trxDesc = "balance after deductions"
|
||||
}
|
||||
return $ concatEithersL [Right [bal], tax, pre, post]
|
||||
|
||||
fromAllo
|
||||
:: BudgetMeta
|
||||
-> AcntID
|
||||
-> Maybe IncomeBucket
|
||||
:: MonadFinance m
|
||||
=> BudgetMeta
|
||||
-> BudgetSplit IncomeBucket
|
||||
-> Allocation
|
||||
-> [TransferTx]
|
||||
fromAllo meta from ib Allocation {alloPath, alloAmts, alloBucket} =
|
||||
fmap (toBT alloPath) alloAmts
|
||||
-> m (EitherErr [TransferTx])
|
||||
fromAllo meta from Allocation {alloPath, alloAmts} = do
|
||||
-- TODO this is going to be repeated a zillion times (might matter)
|
||||
res <- expandTarget alloPath
|
||||
return $ (\to -> fmap (toBT to) alloAmts) <$> res
|
||||
where
|
||||
toBT to (Amount desc v) =
|
||||
TransferTx
|
||||
{ trxFrom = BudgetSplit from ib
|
||||
, trxTo = BudgetSplit to $ Just alloBucket
|
||||
{ trxFrom = from
|
||||
, trxTo = to
|
||||
, trxValue = dec2Rat v
|
||||
, trxDesc = desc
|
||||
, trxType = FixedAmt
|
||||
, trxMeta = meta
|
||||
}
|
||||
|
||||
fromTax :: BudgetMeta -> AcntID -> Tax -> TransferTx
|
||||
expandTarget :: MonadFinance m => TransferTarget -> m (EitherErr (BudgetSplit ExpenseBucket))
|
||||
expandTarget t = case t of
|
||||
ExpenseTarget i b -> checkAcntType ExpenseT i $ (`BudgetSplit` (Just b))
|
||||
GenericTarget i -> checkAcntTypes (LiabilityT :| [AssetT, EquityT]) i $ (`BudgetSplit` Nothing)
|
||||
|
||||
checkAcntType :: MonadFinance m => AcntType -> AcntID -> (AcntID -> a) -> m (EitherErr a)
|
||||
checkAcntType t = checkAcntTypes (t :| [])
|
||||
|
||||
checkAcntTypes :: MonadFinance m => NE.NonEmpty AcntType -> AcntID -> (AcntID -> a) -> m (EitherErr a)
|
||||
checkAcntTypes ts i f = (go =<<) <$> lookupAccountType i
|
||||
where
|
||||
go t
|
||||
| t `L.elem` ts = Right $ f i
|
||||
| otherwise = Left $ AccountError i t
|
||||
|
||||
fromTax
|
||||
:: MonadFinance m
|
||||
=> BudgetMeta
|
||||
-> BudgetSplit IncomeBucket
|
||||
-> Tax
|
||||
-> m (EitherErr TransferTx)
|
||||
fromTax meta from Tax {taxAcnt = to, taxValue = v} =
|
||||
TransferTx
|
||||
{ trxFrom = BudgetSplit from (Just IntraTax)
|
||||
, trxTo = BudgetSplit to (Just Fixed)
|
||||
, trxValue = dec2Rat v
|
||||
, trxDesc = ""
|
||||
, trxType = FixedAmt
|
||||
, trxMeta = meta
|
||||
}
|
||||
-- TODO this is going to be repeated a zillion times (might matter)
|
||||
checkAcntType ExpenseT to $ \to_ ->
|
||||
TransferTx
|
||||
{ trxFrom = from
|
||||
, trxTo = BudgetSplit to_ (Just Fixed)
|
||||
, trxValue = dec2Rat v
|
||||
, trxDesc = ""
|
||||
, trxType = FixedAmt
|
||||
, trxMeta = meta
|
||||
}
|
||||
|
||||
balanceIncome :: Income -> EitherErr Rational
|
||||
balanceIncome
|
||||
|
|
@ -234,7 +270,6 @@ expandTransfers name ts = do
|
|||
txs <- mapM (expandTransfer name) ts
|
||||
return $ L.sortOn (bmWhen . trxMeta) . concat <$> concatEithersL txs
|
||||
|
||||
-- TODO the entire budget needs to have this process applied to it
|
||||
balanceTransfers :: [TransferTx] -> [BudgetTx]
|
||||
balanceTransfers ts = snd $ L.mapAccumR go initBals $ L.sortOn (bmWhen . trxMeta) ts
|
||||
where
|
||||
|
|
@ -268,30 +303,35 @@ balanceTransfers ts = snd $ L.mapAccumR go initBals $ L.sortOn (bmWhen . trxMeta
|
|||
|
||||
expandTransfer :: MonadFinance m => T.Text -> Transfer -> SqlPersistT m (EitherErrs [TransferTx])
|
||||
expandTransfer name t@Transfer {transAmounts, transTo, transCurrency, transFrom} =
|
||||
whenHash CTExpense t (Right []) $ \key -> do
|
||||
res <- forM transAmounts $ \(TimeAmount (Amount desc v) atype pat) ->
|
||||
withDates pat $ \day ->
|
||||
let meta =
|
||||
BudgetMeta
|
||||
{ bmWhen = day
|
||||
, bmCur = transCurrency
|
||||
, bmCommit = key
|
||||
, bmName = name
|
||||
}
|
||||
in return $
|
||||
TransferTx
|
||||
{ trxMeta = meta
|
||||
, trxFrom = BudgetSplit transFrom Nothing
|
||||
, trxTo = BudgetSplit transTo Nothing
|
||||
, trxValue = dec2Rat v
|
||||
, trxType = atype
|
||||
, trxDesc = desc
|
||||
}
|
||||
return $ concat <$> concatEithersL res
|
||||
whenHash CTExpense t (Right []) $ \key ->
|
||||
fmap (fmap concat . concatEithersL) $
|
||||
forM transAmounts $ \(TimeAmount (Amount desc v) atype pat) -> do
|
||||
-- TODO this is going to be repeated a zillion times (might matter)
|
||||
res <- lift $ expandTarget transTo
|
||||
case res of
|
||||
Left e -> return $ Left [e]
|
||||
Right to -> withDates pat $ \day ->
|
||||
let meta =
|
||||
BudgetMeta
|
||||
{ bmWhen = day
|
||||
, bmCur = transCurrency
|
||||
, bmCommit = key
|
||||
, bmName = name
|
||||
}
|
||||
tx =
|
||||
TransferTx
|
||||
{ trxMeta = meta
|
||||
, trxFrom = BudgetSplit transFrom Nothing
|
||||
, trxTo = to
|
||||
, trxValue = dec2Rat v
|
||||
, trxType = atype
|
||||
, trxDesc = desc
|
||||
}
|
||||
in return $ Right tx
|
||||
|
||||
insertBudgetTx :: MonadFinance m => BudgetTx -> SqlPersistT m [InsertError]
|
||||
insertBudgetTx BudgetTx {btFrom, btTo, btMeta, btValue, btDesc} = do
|
||||
res <- splitPair (bsAcnt btFrom) (bsAcnt btTo) (bmCur btMeta) btValue
|
||||
res <- lift $ splitPair (bsAcnt btFrom) (bsAcnt btTo) (bmCur btMeta) btValue
|
||||
unlessLefts_ res $ \(sFrom, sTo) -> do
|
||||
k <- insert $ TransactionR (bmCommit btMeta) (bmWhen btMeta) btDesc
|
||||
insertBudgetLabel name k IncomeBucketR sFrom btFrom
|
||||
|
|
@ -318,7 +358,7 @@ splitPair
|
|||
-> AcntID
|
||||
-> CurID
|
||||
-> Rational
|
||||
-> SqlPersistT m (EitherErrs (KeySplit, KeySplit))
|
||||
-> m (EitherErrs (KeySplit, KeySplit))
|
||||
splitPair from to cur val = do
|
||||
s1 <- split from (-val)
|
||||
s2 <- split to val
|
||||
|
|
@ -358,7 +398,7 @@ insertManual
|
|||
-- let days = expandDatePat bounds dp
|
||||
let dayRes = expandDatePat bounds dp
|
||||
unlessLefts dayRes $ \days -> do
|
||||
txRes <- mapM tx days
|
||||
txRes <- mapM (lift . tx) days
|
||||
unlessLefts_ (concatEithersL txRes) $ mapM_ (insertTx c)
|
||||
where
|
||||
tx day = txPair day from to u (dec2Rat v) e
|
||||
|
|
@ -369,7 +409,7 @@ insertImport i = whenHash CTImport i [] $ \c -> do
|
|||
-- transactions will be desired
|
||||
recoverIO (lift $ readImport i) $ \r -> unlessLefts r $ \bs -> do
|
||||
bounds <- expandBounds <$> lift (askDBState kmStatementInterval)
|
||||
res <- mapM resolveTx $ filter (inBounds bounds . txDate) bs
|
||||
res <- mapM (lift . resolveTx) $ filter (inBounds bounds . txDate) bs
|
||||
unlessLefts_ (concatEithersL res) $ mapM_ (insertTx c)
|
||||
where
|
||||
recoverIO x rest = do
|
||||
|
|
@ -391,7 +431,7 @@ txPair
|
|||
-> CurID
|
||||
-> Rational
|
||||
-> T.Text
|
||||
-> SqlPersistT m (EitherErrs KeyTx)
|
||||
-> m (EitherErrs KeyTx)
|
||||
txPair day from to cur val desc = resolveTx tx
|
||||
where
|
||||
split a v = Split {sAcnt = a, sValue = v, sComment = "", sCurrency = cur}
|
||||
|
|
@ -403,12 +443,12 @@ txPair day from to cur val desc = resolveTx tx
|
|||
, txSplits = [split from (-val), split to val]
|
||||
}
|
||||
|
||||
resolveTx :: MonadFinance m => BalTx -> SqlPersistT m (EitherErrs KeyTx)
|
||||
resolveTx :: MonadFinance m => BalTx -> m (EitherErrs KeyTx)
|
||||
resolveTx t@Tx {txSplits = ss} = do
|
||||
res <- concatEithersL <$> mapM resolveSplit ss
|
||||
return $ fmap (\kss -> t {txSplits = kss}) res
|
||||
|
||||
resolveSplit :: MonadFinance m => BalSplit -> SqlPersistT m (EitherErrs KeySplit)
|
||||
resolveSplit :: MonadFinance m => BalSplit -> m (EitherErrs KeySplit)
|
||||
resolveSplit s@Split {sAcnt = p, sCurrency = c, sValue = v} = do
|
||||
aid <- lookupAccountKey p
|
||||
cid <- lookupCurrency c
|
||||
|
|
@ -431,17 +471,20 @@ insertSplit :: MonadUnliftIO m => Key TransactionR -> KeySplit -> SqlPersistT m
|
|||
insertSplit t Split {sAcnt = aid, sCurrency = cid, sValue = v, sComment = c} = do
|
||||
insert $ SplitR t cid aid c v
|
||||
|
||||
lookupAccount :: MonadFinance m => AcntID -> SqlPersistT m (EitherErr (Key AccountR, AcntSign))
|
||||
lookupAccount p = lookupErr (DBKey AcntField) p <$> lift (askDBState kmAccount)
|
||||
lookupAccount :: MonadFinance m => AcntID -> m (EitherErr (Key AccountR, AcntSign, AcntType))
|
||||
lookupAccount p = lookupErr (DBKey AcntField) p <$> (askDBState kmAccount)
|
||||
|
||||
lookupAccountKey :: MonadFinance m => AcntID -> SqlPersistT m (EitherErr (Key AccountR))
|
||||
lookupAccountKey = fmap (fmap fst) . lookupAccount
|
||||
lookupAccountKey :: MonadFinance m => AcntID -> m (EitherErr (Key AccountR))
|
||||
lookupAccountKey = (fmap (fmap fstOf3)) . lookupAccount
|
||||
|
||||
lookupAccountSign :: MonadFinance m => AcntID -> SqlPersistT m (EitherErr AcntSign)
|
||||
lookupAccountSign = fmap (fmap snd) . lookupAccount
|
||||
lookupAccountSign :: MonadFinance m => AcntID -> m (EitherErr AcntSign)
|
||||
lookupAccountSign = fmap (fmap sndOf3) . lookupAccount
|
||||
|
||||
lookupCurrency :: MonadFinance m => T.Text -> SqlPersistT m (EitherErr (Key CurrencyR))
|
||||
lookupCurrency c = lookupErr (DBKey CurField) c <$> lift (askDBState kmCurrency)
|
||||
lookupAccountType :: MonadFinance m => AcntID -> m (EitherErr AcntType)
|
||||
lookupAccountType = fmap (fmap thdOf3) . lookupAccount
|
||||
|
||||
lookupCurrency :: MonadFinance m => T.Text -> m (EitherErr (Key CurrencyR))
|
||||
lookupCurrency c = lookupErr (DBKey CurField) c <$> (askDBState kmCurrency)
|
||||
|
||||
-- TODO this hashes twice (not that it really matters)
|
||||
whenHash
|
||||
|
|
|
|||
|
|
@ -34,6 +34,7 @@ makeHaskellTypesWith
|
|||
, MultipleConstructors "ExpenseBucket" "(./dhall/Types.dhall).ExpenseBucket"
|
||||
, MultipleConstructors "IncomeBucket" "(./dhall/Types.dhall).IncomeBucket"
|
||||
, MultipleConstructors "AmountType" "(./dhall/Types.dhall).AmountType"
|
||||
, MultipleConstructors "TransferTarget" "(./dhall/Types.dhall).TransferTarget"
|
||||
, SingleConstructor "Currency" "Currency" "(./dhall/Types.dhall).Currency"
|
||||
, SingleConstructor "Gregorian" "Gregorian" "(./dhall/Types.dhall).Gregorian"
|
||||
, SingleConstructor "GregorianM" "GregorianM" "(./dhall/Types.dhall).GregorianM"
|
||||
|
|
@ -50,8 +51,8 @@ makeHaskellTypesWith
|
|||
, SingleConstructor "TimeAmount" "TimeAmount" "(./dhall/Types.dhall).TimeAmount"
|
||||
, SingleConstructor "Allocation" "Allocation" "(./dhall/Types.dhall).Allocation"
|
||||
, SingleConstructor "Income" "Income" "(./dhall/Types.dhall).Income"
|
||||
, SingleConstructor "Transfer" "Transfer" "(./dhall/Types.dhall).Transfer"
|
||||
, SingleConstructor "Budget" "Budget" "(./dhall/Types.dhall).Budget"
|
||||
, SingleConstructor "Transfer" "Transfer" "(./dhall/Types.dhall).Transfer"
|
||||
]
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
|
|
@ -300,6 +301,10 @@ deriving instance Eq TimeAmount
|
|||
|
||||
deriving instance Hashable TimeAmount
|
||||
|
||||
deriving instance Eq TransferTarget
|
||||
|
||||
deriving instance Hashable TransferTarget
|
||||
|
||||
deriving instance Eq Transfer
|
||||
|
||||
deriving instance Hashable Transfer
|
||||
|
|
@ -582,6 +587,7 @@ data PatternSuberr = ZeroLength | ZeroRepeats deriving (Show)
|
|||
data InsertError
|
||||
= RegexError !T.Text
|
||||
| MatchValPrecisionError !Natural !Natural
|
||||
| AccountError !AcntID !AcntType
|
||||
| InsertIOError !T.Text
|
||||
| ParseError !T.Text
|
||||
| ConversionError !T.Text
|
||||
|
|
|
|||
|
|
@ -9,10 +9,13 @@ module Internal.Utils
|
|||
, leftToMaybe
|
||||
, dec2Rat
|
||||
, concatEithers2
|
||||
, concatEithers3
|
||||
, concatEither3
|
||||
, concatEither2
|
||||
, concatEitherL
|
||||
, concatEithersL
|
||||
, concatEither2M
|
||||
, concatEithers2M
|
||||
, parseRational
|
||||
, showError
|
||||
, unlessLeft_
|
||||
|
|
@ -23,7 +26,8 @@ module Internal.Utils
|
|||
, showT
|
||||
, lookupErr
|
||||
, gregorians
|
||||
, uncurry3
|
||||
-- , uncurry3
|
||||
|
||||
, xGregToDay
|
||||
, plural
|
||||
, compileMatch
|
||||
|
|
@ -313,6 +317,8 @@ showError other = (: []) $ case other of
|
|||
where
|
||||
showGreg (Just g) = showGregorian_ g
|
||||
showGreg Nothing = "Inf"
|
||||
-- TODO define
|
||||
(AccountError _ _) -> undefined
|
||||
(PatternError s b r p) -> T.unwords [msg, "in pattern: ", pat]
|
||||
where
|
||||
pat =
|
||||
|
|
@ -478,6 +484,11 @@ 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_
|
||||
|
|
@ -486,13 +497,21 @@ concatEither3 a b c fun = case (a, b, c) of
|
|||
concatEithers2 :: Either [x] a -> Either [x] b -> (a -> b -> c) -> Either [x] c
|
||||
concatEithers2 a b = merge . concatEither2 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
|
||||
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
|
||||
|
|
|
|||
Loading…
Reference in New Issue