ENH don't print db lookup errors
This commit is contained in:
parent
95514df295
commit
5e967ae9cb
|
@ -1,6 +1,7 @@
|
||||||
{-# LANGUAGE GADTs #-}
|
{-# LANGUAGE GADTs #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE TupleSections #-}
|
{-# LANGUAGE TupleSections #-}
|
||||||
|
{-# LANGUAGE NoImplicitPrelude #-}
|
||||||
|
|
||||||
module Internal.Insert
|
module Internal.Insert
|
||||||
( insertStatements
|
( insertStatements
|
||||||
|
@ -16,35 +17,9 @@ import Internal.Statement
|
||||||
import Internal.Types hiding (sign)
|
import Internal.Types hiding (sign)
|
||||||
import Internal.Utils
|
import Internal.Utils
|
||||||
import RIO hiding (to)
|
import RIO hiding (to)
|
||||||
import qualified RIO.Map as M
|
|
||||||
import qualified RIO.Text as T
|
import qualified RIO.Text as T
|
||||||
import RIO.Time
|
import RIO.Time
|
||||||
|
|
||||||
lookupKey :: (Ord k, Show k, MonadUnliftIO m) => M.Map k v -> k -> m (Maybe v)
|
|
||||||
lookupKey m k = do
|
|
||||||
let v = M.lookup k m
|
|
||||||
when (isNothing v) $
|
|
||||||
liftIO $
|
|
||||||
putStrLn $
|
|
||||||
"key does not exist: " ++ show k
|
|
||||||
return v
|
|
||||||
|
|
||||||
lookupAccount :: MonadUnliftIO m => AcntID -> MappingT m (Maybe (Key AccountR, AcntSign))
|
|
||||||
lookupAccount p = do
|
|
||||||
m <- asks kmAccount
|
|
||||||
lookupKey m p
|
|
||||||
|
|
||||||
lookupAccountKey :: MonadUnliftIO m => AcntID -> MappingT m (Maybe (Key AccountR))
|
|
||||||
lookupAccountKey = fmap (fmap fst) . lookupAccount
|
|
||||||
|
|
||||||
lookupAccountSign :: MonadUnliftIO m => AcntID -> MappingT m (Maybe AcntSign)
|
|
||||||
lookupAccountSign = fmap (fmap snd) . lookupAccount
|
|
||||||
|
|
||||||
lookupCurrency :: MonadUnliftIO m => T.Text -> MappingT m (Maybe (Key CurrencyR))
|
|
||||||
lookupCurrency c = do
|
|
||||||
m <- asks kmCurrency
|
|
||||||
lookupKey m c
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- intervals
|
-- intervals
|
||||||
|
|
||||||
|
@ -118,8 +93,9 @@ mdyPatternMatches check x p = case p of
|
||||||
|
|
||||||
insertBudget :: MonadUnliftIO m => Budget -> MappingT m [InsertError]
|
insertBudget :: MonadUnliftIO m => Budget -> MappingT m [InsertError]
|
||||||
insertBudget Budget {income = is, expenses = es} = do
|
insertBudget Budget {income = is, expenses = es} = do
|
||||||
mapM_ insertExpense es
|
es1 <- mapM insertIncome is
|
||||||
concat <$> mapM insertIncome is
|
es2 <- mapM insertExpense es
|
||||||
|
return $ concat $ es1 ++ es2
|
||||||
|
|
||||||
-- TODO this hashes twice (not that it really matters)
|
-- TODO this hashes twice (not that it really matters)
|
||||||
whenHash
|
whenHash
|
||||||
|
@ -140,15 +116,19 @@ insertIncome
|
||||||
{ incCurrency = cur
|
{ incCurrency = cur
|
||||||
, incWhen = dp
|
, incWhen = dp
|
||||||
, incAccount = from
|
, incAccount = from
|
||||||
, incTaxes = ts
|
, incTaxes = taxes
|
||||||
} =
|
} =
|
||||||
whenHash CTIncome i [] $ \c -> do
|
whenHash CTIncome i [] $ \c ->
|
||||||
bounds <- (liftIO . resolveBounds) =<< asks kmBudgetInterval
|
|
||||||
unlessLeft (balanceIncome i) $ \balanced -> do
|
unlessLeft (balanceIncome i) $ \balanced -> do
|
||||||
forM_ (expandDatePat bounds dp) $ \day -> do
|
bounds <- (liftIO . resolveBounds) =<< asks kmBudgetInterval
|
||||||
alloTx <- concat <$> mapM (allocationToTx from day) balanced
|
fmap concat $ forM (expandDatePat bounds dp) $ \day -> do
|
||||||
taxTx <- fmap (,Fixed) <$> mapM (taxToTx from day cur) ts
|
-- TODO why are these separate?
|
||||||
lift $ mapM_ (\(t, b) -> insertTxBucket (Just b) c t) $ alloTx ++ taxTx
|
nontaxRes <- alloTxs concat (allocationToTx from day) balanced
|
||||||
|
taxRes <- alloTxs (fmap (,Fixed)) (taxToTx from day cur) taxes
|
||||||
|
unlessLefts_ (concatEithers2 nontaxRes taxRes (++)) $ \txs ->
|
||||||
|
lift $ mapM_ (\(t, b) -> insertTxBucket (Just b) c t) txs
|
||||||
|
where
|
||||||
|
alloTxs squish toTx = fmap (fmap squish . concatEithersL) . mapM toTx
|
||||||
|
|
||||||
balanceIncome :: Income -> EitherErr [BalAllocation]
|
balanceIncome :: Income -> EitherErr [BalAllocation]
|
||||||
balanceIncome
|
balanceIncome
|
||||||
|
@ -202,7 +182,7 @@ allocationToTx
|
||||||
=> AcntID
|
=> AcntID
|
||||||
-> Day
|
-> Day
|
||||||
-> BalAllocation
|
-> BalAllocation
|
||||||
-> MappingT m [(KeyTx, Bucket)]
|
-> MappingT m (EitherErrs [(KeyTx, Bucket)])
|
||||||
allocationToTx
|
allocationToTx
|
||||||
from
|
from
|
||||||
day
|
day
|
||||||
|
@ -212,9 +192,15 @@ allocationToTx
|
||||||
, alloCurrency = cur
|
, alloCurrency = cur
|
||||||
, alloAmts = as
|
, alloAmts = as
|
||||||
} =
|
} =
|
||||||
fmap (,b) <$> mapM (transferToTx day from to cur) as
|
second (fmap (,b)) . concatEithersL <$> mapM (transferToTx day from to cur) as
|
||||||
|
|
||||||
taxToTx :: MonadUnliftIO m => AcntID -> Day -> T.Text -> Tax -> MappingT m KeyTx
|
taxToTx
|
||||||
|
:: MonadUnliftIO m
|
||||||
|
=> AcntID
|
||||||
|
-> Day
|
||||||
|
-> T.Text
|
||||||
|
-> Tax
|
||||||
|
-> MappingT m (EitherErrs KeyTx)
|
||||||
taxToTx from day cur Tax {taxAcnt = to, taxValue = v} =
|
taxToTx from day cur Tax {taxAcnt = to, taxValue = v} =
|
||||||
txPair day from to cur (dec2Rat v) ""
|
txPair day from to cur (dec2Rat v) ""
|
||||||
|
|
||||||
|
@ -225,11 +211,11 @@ transferToTx
|
||||||
-> AcntID
|
-> AcntID
|
||||||
-> T.Text
|
-> T.Text
|
||||||
-> BalAmount
|
-> BalAmount
|
||||||
-> MappingT m KeyTx
|
-> MappingT m (EitherErrs KeyTx)
|
||||||
transferToTx day from to cur Amount {amtValue = v, amtDesc = d} =
|
transferToTx day from to cur Amount {amtValue = v, amtDesc = d} =
|
||||||
txPair day from to cur v d
|
txPair day from to cur v d
|
||||||
|
|
||||||
insertExpense :: MonadUnliftIO m => Expense -> MappingT m ()
|
insertExpense :: MonadUnliftIO m => Expense -> MappingT m [InsertError]
|
||||||
insertExpense
|
insertExpense
|
||||||
e@Expense
|
e@Expense
|
||||||
{ expFrom = from
|
{ expFrom = from
|
||||||
|
@ -238,11 +224,12 @@ insertExpense
|
||||||
, expBucket = buc
|
, expBucket = buc
|
||||||
, expAmounts = as
|
, expAmounts = as
|
||||||
} = do
|
} = do
|
||||||
whenHash CTExpense e () $ \key -> mapM_ (go key) as
|
whenHash CTExpense e [] $ \key -> concat <$> mapM (go key) as
|
||||||
where
|
where
|
||||||
go key amt = do
|
go key amt = do
|
||||||
keys <- timeAmountToTx from to cur amt
|
res <- timeAmountToTx from to cur amt
|
||||||
lift $ mapM_ (insertTxBucket (Just buc) key) keys
|
unlessLefts_ res $
|
||||||
|
lift . mapM_ (insertTxBucket (Just buc) key)
|
||||||
|
|
||||||
timeAmountToTx
|
timeAmountToTx
|
||||||
:: MonadUnliftIO m
|
:: MonadUnliftIO m
|
||||||
|
@ -250,7 +237,7 @@ timeAmountToTx
|
||||||
-> AcntID
|
-> AcntID
|
||||||
-> CurID
|
-> CurID
|
||||||
-> TimeAmount
|
-> TimeAmount
|
||||||
-> MappingT m [KeyTx]
|
-> MappingT m (EitherErrs [KeyTx])
|
||||||
timeAmountToTx
|
timeAmountToTx
|
||||||
from
|
from
|
||||||
to
|
to
|
||||||
|
@ -264,7 +251,7 @@ timeAmountToTx
|
||||||
}
|
}
|
||||||
} = do
|
} = do
|
||||||
bounds <- (liftIO . resolveBounds) =<< asks kmBudgetInterval
|
bounds <- (liftIO . resolveBounds) =<< asks kmBudgetInterval
|
||||||
mapM tx $ expandDatePat bounds dp
|
concatEithersL <$> mapM tx (expandDatePat bounds dp)
|
||||||
where
|
where
|
||||||
tx day = txPair day from to cur (dec2Rat v) d
|
tx day = txPair day from to cur (dec2Rat v) d
|
||||||
|
|
||||||
|
@ -277,10 +264,10 @@ insertStatements conf = concat <$> mapM insertStatement (statements conf)
|
||||||
-- unless (null es) $ throwIO $ InsertException es
|
-- unless (null es) $ throwIO $ InsertException es
|
||||||
|
|
||||||
insertStatement :: MonadUnliftIO m => Statement -> MappingT m [InsertError]
|
insertStatement :: MonadUnliftIO m => Statement -> MappingT m [InsertError]
|
||||||
insertStatement (StmtManual m) = insertManual m >> return []
|
insertStatement (StmtManual m) = insertManual m
|
||||||
insertStatement (StmtImport i) = insertImport i
|
insertStatement (StmtImport i) = insertImport i
|
||||||
|
|
||||||
insertManual :: MonadUnliftIO m => Manual -> MappingT m ()
|
insertManual :: MonadUnliftIO m => Manual -> MappingT m [InsertError]
|
||||||
insertManual
|
insertManual
|
||||||
m@Manual
|
m@Manual
|
||||||
{ manualDate = dp
|
{ manualDate = dp
|
||||||
|
@ -290,10 +277,10 @@ insertManual
|
||||||
, manualCurrency = u
|
, manualCurrency = u
|
||||||
, manualDesc = e
|
, manualDesc = e
|
||||||
} = do
|
} = do
|
||||||
whenHash CTManual m () $ \c -> do
|
whenHash CTManual m [] $ \c -> do
|
||||||
bounds <- (liftIO . resolveBounds) =<< asks kmStatementInterval
|
bounds <- (liftIO . resolveBounds) =<< asks kmStatementInterval
|
||||||
ts <- mapM tx $ expandDatePat bounds dp
|
res <- mapM tx $ expandDatePat bounds dp
|
||||||
lift $ mapM_ (insertTx c) ts
|
unlessLefts_ (concatEithersL res) $ lift . mapM_ (insertTx c)
|
||||||
where
|
where
|
||||||
tx day = txPair day from to u (dec2Rat v) e
|
tx day = txPair day from to u (dec2Rat v) e
|
||||||
|
|
||||||
|
@ -301,15 +288,18 @@ insertImport :: MonadUnliftIO m => Import -> MappingT m [InsertError]
|
||||||
insertImport i = whenHash CTImport i [] $ \c -> do
|
insertImport i = whenHash CTImport i [] $ \c -> do
|
||||||
-- TODO this isn't efficient, the whole file will be read and maybe no
|
-- TODO this isn't efficient, the whole file will be read and maybe no
|
||||||
-- transactions will be desired
|
-- transactions will be desired
|
||||||
res <- tryIO $ readImport i
|
recoverIO (readImport i) $ \r -> unlessLefts r $ \bs -> do
|
||||||
case res of
|
bounds <- asks kmStatementInterval
|
||||||
Right r -> unlessLefts r $ \bs -> do
|
res <- mapM resolveTx $ filter (inMaybeBounds bounds . txDate) bs
|
||||||
bounds <- asks kmStatementInterval
|
unlessLefts_ (concatEithersL res) $ lift . mapM_ (insertTx c)
|
||||||
rs <- mapM resolveTx $ filter (inMaybeBounds bounds . txDate) bs
|
where
|
||||||
lift $ mapM_ (insertTx c) rs
|
recoverIO x rest = do
|
||||||
-- If file is not found (or something else happens) then collect the
|
res <- tryIO x
|
||||||
-- error try the remaining imports
|
case res of
|
||||||
Left e -> return [InsertIOError $ showT e]
|
Right r -> rest r
|
||||||
|
-- If file is not found (or something else happens) then collect the
|
||||||
|
-- error try the remaining imports
|
||||||
|
Left e -> return [InsertIOError $ showT e]
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- low-level transaction stuff
|
-- low-level transaction stuff
|
||||||
|
@ -322,7 +312,7 @@ txPair
|
||||||
-> T.Text
|
-> T.Text
|
||||||
-> Rational
|
-> Rational
|
||||||
-> T.Text
|
-> T.Text
|
||||||
-> MappingT m KeyTx
|
-> MappingT m (EitherErrs KeyTx)
|
||||||
txPair day from to cur val desc = resolveTx tx
|
txPair day from to cur val desc = resolveTx tx
|
||||||
where
|
where
|
||||||
split a v = Split {sAcnt = a, sValue = v, sComment = "", sCurrency = cur}
|
split a v = Split {sAcnt = a, sValue = v, sComment = "", sCurrency = cur}
|
||||||
|
@ -334,27 +324,27 @@ txPair day from to cur val desc = resolveTx tx
|
||||||
, txSplits = [split from (-val), split to val]
|
, txSplits = [split from (-val), split to val]
|
||||||
}
|
}
|
||||||
|
|
||||||
resolveTx :: MonadUnliftIO m => BalTx -> MappingT m KeyTx
|
resolveTx :: MonadUnliftIO m => BalTx -> MappingT m (EitherErrs KeyTx)
|
||||||
resolveTx t@Tx {txSplits = ss} = do
|
resolveTx t@Tx {txSplits = ss} = do
|
||||||
rs <- catMaybes <$> mapM resolveSplit ss
|
res <- concatEithersL <$> mapM resolveSplit ss
|
||||||
return $ t {txSplits = rs}
|
return $ fmap (\kss -> t {txSplits = kss}) res
|
||||||
|
|
||||||
resolveSplit :: MonadUnliftIO m => BalSplit -> MappingT m (Maybe KeySplit)
|
resolveSplit :: MonadUnliftIO m => BalSplit -> MappingT m (EitherErrs KeySplit)
|
||||||
resolveSplit s@Split {sAcnt = p, sCurrency = c, sValue = v} = do
|
resolveSplit s@Split {sAcnt = p, sCurrency = c, sValue = v} = do
|
||||||
aid <- lookupAccountKey p
|
aid <- lookupAccountKey p
|
||||||
cid <- lookupCurrency c
|
cid <- lookupCurrency c
|
||||||
sign <- lookupAccountSign p
|
sign <- lookupAccountSign p
|
||||||
-- TODO correct sign here?
|
-- TODO correct sign here?
|
||||||
-- TODO lenses would be nice here
|
-- TODO lenses would be nice here
|
||||||
return $ case (aid, cid, sign) of
|
return $ concatEither3 aid cid sign $ \aid_ cid_ sign_ ->
|
||||||
(Just aid', Just cid', Just sign') ->
|
s
|
||||||
Just $
|
{ sAcnt = aid_
|
||||||
s
|
, sCurrency = cid_
|
||||||
{ sAcnt = aid'
|
, sValue = v * fromIntegral (sign2Int sign_)
|
||||||
, sCurrency = cid'
|
}
|
||||||
, sValue = v * fromIntegral (sign2Int sign')
|
|
||||||
}
|
-- return $ case (aid, cid, sign) of
|
||||||
_ -> Nothing
|
-- _ -> Nothing
|
||||||
|
|
||||||
insertTxBucket :: MonadUnliftIO m => Maybe Bucket -> Key CommitR -> KeyTx -> SqlPersistT m ()
|
insertTxBucket :: MonadUnliftIO m => Maybe Bucket -> Key CommitR -> KeyTx -> SqlPersistT m ()
|
||||||
insertTxBucket b c Tx {txDate = d, txDescr = e, txSplits = ss} = do
|
insertTxBucket b c Tx {txDate = d, txDescr = e, txSplits = ss} = do
|
||||||
|
@ -367,3 +357,15 @@ insertTx = insertTxBucket Nothing
|
||||||
insertSplit :: MonadUnliftIO m => Key TransactionR -> KeySplit -> SqlPersistT m ()
|
insertSplit :: MonadUnliftIO m => Key TransactionR -> KeySplit -> SqlPersistT m ()
|
||||||
insertSplit t Split {sAcnt = aid, sCurrency = cid, sValue = v, sComment = c} = do
|
insertSplit t Split {sAcnt = aid, sCurrency = cid, sValue = v, sComment = c} = do
|
||||||
insert_ $ SplitR t cid aid c v
|
insert_ $ SplitR t cid aid c v
|
||||||
|
|
||||||
|
lookupAccount :: MonadUnliftIO m => AcntID -> MappingT m (EitherErr (Key AccountR, AcntSign))
|
||||||
|
lookupAccount p = lookupErr (DBKey AcntField) p <$> asks kmAccount
|
||||||
|
|
||||||
|
lookupAccountKey :: MonadUnliftIO m => AcntID -> MappingT m (EitherErr (Key AccountR))
|
||||||
|
lookupAccountKey = fmap (fmap fst) . lookupAccount
|
||||||
|
|
||||||
|
lookupAccountSign :: MonadUnliftIO m => AcntID -> MappingT m (EitherErr AcntSign)
|
||||||
|
lookupAccountSign = fmap (fmap snd) . lookupAccount
|
||||||
|
|
||||||
|
lookupCurrency :: MonadUnliftIO m => T.Text -> MappingT m (EitherErr (Key CurrencyR))
|
||||||
|
lookupCurrency c = lookupErr (DBKey CurField) c <$> asks kmCurrency
|
||||||
|
|
|
@ -11,6 +11,7 @@
|
||||||
{-# LANGUAGE StandaloneDeriving #-}
|
{-# LANGUAGE StandaloneDeriving #-}
|
||||||
{-# LANGUAGE TemplateHaskell #-}
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
|
{-# LANGUAGE NoImplicitPrelude #-}
|
||||||
|
|
||||||
module Internal.Types where
|
module Internal.Types where
|
||||||
|
|
||||||
|
@ -529,6 +530,7 @@ data LookupSuberr
|
||||||
= SplitIDField SplitIDType
|
= SplitIDField SplitIDType
|
||||||
| SplitValField
|
| SplitValField
|
||||||
| MatchField MatchType
|
| MatchField MatchType
|
||||||
|
| DBKey SplitIDType
|
||||||
deriving (Show)
|
deriving (Show)
|
||||||
|
|
||||||
data AllocationSuberr
|
data AllocationSuberr
|
||||||
|
@ -542,6 +544,7 @@ data InsertError
|
||||||
= RegexError T.Text
|
= RegexError T.Text
|
||||||
| MatchValPrecisionError Natural Natural
|
| MatchValPrecisionError Natural Natural
|
||||||
| InsertIOError T.Text
|
| InsertIOError T.Text
|
||||||
|
| ParseError T.Text
|
||||||
| ConversionError T.Text
|
| ConversionError T.Text
|
||||||
| LookupError LookupSuberr T.Text
|
| LookupError LookupSuberr T.Text
|
||||||
| BalanceError BalanceType CurID [RawSplit]
|
| BalanceError BalanceType CurID [RawSplit]
|
||||||
|
@ -556,10 +559,3 @@ instance Exception InsertException
|
||||||
type EitherErr = Either InsertError
|
type EitherErr = Either InsertError
|
||||||
|
|
||||||
type EitherErrs = Either [InsertError]
|
type EitherErrs = Either [InsertError]
|
||||||
|
|
||||||
-- type StateErr = State [InsertError]
|
|
||||||
|
|
||||||
-- runErrors :: StateErr a -> Either [InsertError] a
|
|
||||||
-- runErrors x = case runState x [] of
|
|
||||||
-- (y, []) -> Right y
|
|
||||||
-- (_, es) -> Left es
|
|
||||||
|
|
|
@ -1,6 +1,7 @@
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE RecordWildCards #-}
|
{-# LANGUAGE RecordWildCards #-}
|
||||||
|
{-# LANGUAGE NoImplicitPrelude #-}
|
||||||
|
|
||||||
module Internal.Utils
|
module Internal.Utils
|
||||||
( compareDate
|
( compareDate
|
||||||
|
@ -12,14 +13,20 @@ module Internal.Utils
|
||||||
, leftToMaybe
|
, leftToMaybe
|
||||||
, dec2Rat
|
, dec2Rat
|
||||||
, concatEithers2
|
, concatEithers2
|
||||||
|
, concatEither3
|
||||||
, concatEither2
|
, concatEither2
|
||||||
|
, concatEitherL
|
||||||
|
, concatEithersL
|
||||||
, parseRational
|
, parseRational
|
||||||
, showError
|
, showError
|
||||||
|
, unlessLeft_
|
||||||
|
, unlessLefts_
|
||||||
, unlessLeft
|
, unlessLeft
|
||||||
, unlessLefts
|
, unlessLefts
|
||||||
, inMaybeBounds
|
, inMaybeBounds
|
||||||
, acntPath2Text
|
, acntPath2Text
|
||||||
, showT
|
, showT
|
||||||
|
, lookupErr
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
|
@ -282,29 +289,21 @@ showError other = (: []) $ case other of
|
||||||
(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
|
||||||
(InsertIOError msg) -> T.append "IO Error: " msg
|
(InsertIOError msg) -> T.append "IO Error: " msg
|
||||||
|
(ParseError msg) -> T.append "Parse Error: " msg
|
||||||
(MatchValPrecisionError d p) ->
|
(MatchValPrecisionError d p) ->
|
||||||
T.unwords ["Match denominator", showT d, "must be less than", showT p]
|
T.unwords ["Match denominator", showT d, "must be less than", showT p]
|
||||||
(LookupError t f) ->
|
(LookupError t f) ->
|
||||||
T.unwords
|
T.unwords ["Could not find field", singleQuote f, "when resolving", what]
|
||||||
[ "Could not find field"
|
|
||||||
, singleQuote f
|
|
||||||
, "when resolving"
|
|
||||||
, what
|
|
||||||
]
|
|
||||||
where
|
where
|
||||||
what = case t of
|
what = case t of
|
||||||
SplitIDField st ->
|
SplitIDField st -> T.unwords ["split", idName st, "ID"]
|
||||||
T.unwords
|
|
||||||
[ "split"
|
|
||||||
, case st of AcntField -> "account"; CurField -> "currency"
|
|
||||||
, "ID"
|
|
||||||
]
|
|
||||||
SplitValField -> "split value"
|
SplitValField -> "split value"
|
||||||
MatchField mt ->
|
MatchField mt -> T.unwords [matchName mt, "match"]
|
||||||
T.unwords
|
DBKey st -> T.unwords ["database", idName st, "ID key"]
|
||||||
[ case mt of MatchNumeric -> "numeric"; MatchText -> "text"
|
idName AcntField = "account"
|
||||||
, "match"
|
idName CurField = "currency"
|
||||||
]
|
matchName MatchNumeric = "numeric"
|
||||||
|
matchName MatchText = "text"
|
||||||
(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
|
||||||
|
@ -467,13 +466,19 @@ leftToMaybe :: Either a b -> Maybe a
|
||||||
leftToMaybe (Left a) = Just a
|
leftToMaybe (Left a) = Just a
|
||||||
leftToMaybe _ = Nothing
|
leftToMaybe _ = Nothing
|
||||||
|
|
||||||
unlessLeft :: (Monad m, MonadPlus n) => Either a b -> (b -> m ()) -> m (n a)
|
unlessLeft :: (Monad m, MonadPlus n) => Either a b -> (b -> m (n a)) -> m (n a)
|
||||||
unlessLeft (Left es) _ = return (return es)
|
unlessLeft (Left es) _ = return (return es)
|
||||||
unlessLeft (Right rs) f = f rs >> return mzero
|
unlessLeft (Right rs) f = f rs
|
||||||
|
|
||||||
unlessLefts :: (Monad m, MonadPlus n) => Either (n a) b -> (b -> m ()) -> m (n a)
|
unlessLefts :: (Monad m) => Either (n a) b -> (b -> m (n a)) -> 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
|
||||||
|
|
||||||
|
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 :: Either a b -> Either [a] b
|
||||||
plural = first (: [])
|
plural = first (: [])
|
||||||
|
|
Loading…
Reference in New Issue