ADD errors for everything that needs them (ish)
This commit is contained in:
parent
cafc066881
commit
2e0b591312
|
|
@ -255,7 +255,7 @@ runSync threads c bs hs = do
|
|||
rerunnableIO $ fromEither res
|
||||
where
|
||||
root = takeDirectory c
|
||||
err (InsertException es) = do
|
||||
err (AppException es) = do
|
||||
liftIO $ mapM_ TI.putStrLn $ concatMap showError es
|
||||
exitFailure
|
||||
|
||||
|
|
|
|||
|
|
@ -13,7 +13,7 @@ import qualified RIO.NonEmpty as NE
|
|||
import qualified RIO.Text as T
|
||||
import RIO.Time
|
||||
|
||||
readBudget :: (MonadInsertError m, MonadFinance m) => Budget -> m [Tx CommitR]
|
||||
readBudget :: (MonadAppError m, MonadFinance m) => Budget -> m [Tx CommitR]
|
||||
readBudget
|
||||
b@Budget
|
||||
{ bgtLabel
|
||||
|
|
@ -56,7 +56,7 @@ readBudget
|
|||
localSpan <- liftExcept $ resolveDaySpan bi
|
||||
return $ intersectDaySpan globalSpan localSpan
|
||||
|
||||
sortAllo :: MultiAllocation v -> InsertExcept (DaySpanAllocation v)
|
||||
sortAllo :: MultiAllocation v -> AppExcept (DaySpanAllocation v)
|
||||
sortAllo a@Allocation {alloAmts = as} = do
|
||||
bs <- foldSpan [] $ L.sortOn amtWhen as
|
||||
return $ a {alloAmts = reverse bs}
|
||||
|
|
@ -76,7 +76,7 @@ sortAllo a@Allocation {alloAmts = as} = do
|
|||
-- iteration which is a total waste, but the fix requires turning this
|
||||
-- loop into a fold which I don't feel like doing now :(
|
||||
readIncome
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
:: (MonadAppError m, MonadFinance m)
|
||||
=> CommitR
|
||||
-> BudgetName
|
||||
-> IntAllocations
|
||||
|
|
@ -104,7 +104,7 @@ readIncome
|
|||
(combineError incRes nonIncRes (,))
|
||||
(combineError cpRes dayRes (,))
|
||||
$ \_ (cp, days) -> do
|
||||
let gross = realFracToDecimal' (cpPrec cp) incGross
|
||||
let gross = realFracToDecimalP (cpPrec cp) incGross
|
||||
foldDays (allocate cp gross) start days
|
||||
where
|
||||
srcAcnt' = AcntID srcAcnt
|
||||
|
|
@ -163,7 +163,7 @@ periodScaler
|
|||
:: PeriodType
|
||||
-> Day
|
||||
-> Day
|
||||
-> InsertExcept PeriodScaler
|
||||
-> AppExcept PeriodScaler
|
||||
periodScaler pt prev cur = return scale
|
||||
where
|
||||
n = workingDays wds prev cur
|
||||
|
|
@ -172,10 +172,10 @@ periodScaler pt prev cur = return scale
|
|||
Daily ds -> ds
|
||||
scale prec x = case pt of
|
||||
Hourly HourlyPeriod {hpAnnualHours, hpDailyHours} ->
|
||||
realFracToDecimal' prec (x / fromIntegral hpAnnualHours)
|
||||
realFracToDecimalP prec (x / fromIntegral hpAnnualHours)
|
||||
* fromIntegral hpDailyHours
|
||||
* fromIntegral n
|
||||
Daily _ -> realFracToDecimal' prec (x * fromIntegral n / 365.25)
|
||||
Daily _ -> realFracToDecimalP prec (x * fromIntegral n / 365.25)
|
||||
|
||||
-- ASSUME start < end
|
||||
workingDays :: [Weekday] -> Day -> Day -> Natural
|
||||
|
|
@ -191,7 +191,7 @@ workingDays wds start end = fromIntegral $ daysFull + daysTail
|
|||
|
||||
-- ASSUME days is a sorted list
|
||||
foldDays
|
||||
:: MonadInsertError m
|
||||
:: MonadAppError m
|
||||
=> (Day -> Day -> m a)
|
||||
-> Day
|
||||
-> [Day]
|
||||
|
|
@ -201,27 +201,27 @@ foldDays f start days = case NE.nonEmpty days of
|
|||
Just ds
|
||||
| any (start >) ds ->
|
||||
throwError $
|
||||
InsertException [PeriodError start $ minimum ds]
|
||||
AppException [PeriodError start $ minimum ds]
|
||||
| otherwise ->
|
||||
combineErrors $
|
||||
snd $
|
||||
L.mapAccumL (\prevDay day -> (day, f prevDay day)) start days
|
||||
|
||||
isIncomeAcnt :: (MonadInsertError m, MonadFinance m) => AcntID -> m ()
|
||||
isIncomeAcnt :: (MonadAppError m, MonadFinance m) => AcntID -> m ()
|
||||
isIncomeAcnt = checkAcntType IncomeT
|
||||
|
||||
isNotIncomeAcnt :: (MonadInsertError m, MonadFinance m) => AcntID -> m ()
|
||||
isNotIncomeAcnt :: (MonadAppError m, MonadFinance m) => AcntID -> m ()
|
||||
isNotIncomeAcnt = checkAcntTypes (AssetT :| [EquityT, ExpenseT, LiabilityT])
|
||||
|
||||
checkAcntType
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
:: (MonadAppError m, MonadFinance m)
|
||||
=> AcntType
|
||||
-> AcntID
|
||||
-> m ()
|
||||
checkAcntType t = checkAcntTypes (t :| [])
|
||||
|
||||
checkAcntTypes
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
:: (MonadAppError m, MonadFinance m)
|
||||
=> NE.NonEmpty AcntType
|
||||
-> AcntID
|
||||
-> m ()
|
||||
|
|
@ -229,7 +229,7 @@ checkAcntTypes ts i = void $ go =<< lookupAccountType i
|
|||
where
|
||||
go t
|
||||
| t `L.elem` ts = return i
|
||||
| otherwise = throwError $ InsertException [AccountError i ts]
|
||||
| otherwise = throwError $ AppException [AccountTypeError i ts]
|
||||
|
||||
flattenAllo :: SingleAllocation v -> [FlatAllocation v]
|
||||
flattenAllo Allocation {alloAmts, alloTo} = fmap go alloAmts
|
||||
|
|
@ -275,7 +275,7 @@ allocatePre precision gross = L.mapAccumR go M.empty
|
|||
let v =
|
||||
if prePercent
|
||||
then gross *. (preValue / 100)
|
||||
else realFracToDecimal' precision preValue
|
||||
else realFracToDecimalP precision preValue
|
||||
in (mapAdd_ preCategory v m, f {faValue = v})
|
||||
|
||||
allocateTax
|
||||
|
|
@ -324,14 +324,14 @@ allocatePost prec aftertax = fmap (fmap go)
|
|||
where
|
||||
go PosttaxValue {postValue, postPercent}
|
||||
| postPercent = aftertax *. (postValue / 100)
|
||||
| otherwise = realFracToDecimal' prec postValue
|
||||
| otherwise = realFracToDecimalP prec postValue
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- shadow transfers
|
||||
|
||||
-- TODO this is going to be O(n*m), which might be a problem?
|
||||
addShadowTransfers
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
:: (MonadAppError m, MonadFinance m)
|
||||
=> [ShadowTransfer]
|
||||
-> [Tx CommitR]
|
||||
-> m [Tx CommitR]
|
||||
|
|
@ -342,7 +342,7 @@ addShadowTransfers ms = mapErrors go
|
|||
return $ tx {txOther = Right <$> es}
|
||||
|
||||
fromShadow
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
:: (MonadAppError m, MonadFinance m)
|
||||
=> Tx CommitR
|
||||
-> ShadowTransfer
|
||||
-> m (Maybe ShadowEntrySet)
|
||||
|
|
@ -354,7 +354,7 @@ fromShadow tx ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stMatch
|
|||
curRes = lookupCurrencyKey (CurID stCurrency)
|
||||
shaRes = liftExcept $ shadowMatches stMatch tx
|
||||
|
||||
shadowMatches :: TransferMatcher -> Tx CommitR -> InsertExcept Bool
|
||||
shadowMatches :: TransferMatcher -> Tx CommitR -> AppExcept Bool
|
||||
shadowMatches TransferMatcher {tmFrom, tmTo, tmDate, tmVal} Tx {txPrimary, txDate} = do
|
||||
-- NOTE this will only match against the primary entry set since those
|
||||
-- are what are guaranteed to exist from a transfer
|
||||
|
|
|
|||
|
|
@ -107,7 +107,7 @@ nukeTables = do
|
|||
-- toBal = maybe "???" (fmtRational 2) . unValue
|
||||
|
||||
readConfigState
|
||||
:: (MonadInsertError m, MonadSqlQuery m)
|
||||
:: (MonadAppError m, MonadSqlQuery m)
|
||||
=> Config
|
||||
-> [Budget]
|
||||
-> [History]
|
||||
|
|
@ -160,22 +160,23 @@ readConfigState c bs hs = do
|
|||
resolveScope f = liftExcept $ resolveDaySpan $ f $ scope c
|
||||
|
||||
readScopeChanged
|
||||
:: (MonadInsertError m, MonadSqlQuery m)
|
||||
:: (MonadAppError m, MonadSqlQuery m)
|
||||
=> Bool
|
||||
-> BudgetSpan
|
||||
-> HistorySpan
|
||||
-> m (Bool, Bool)
|
||||
readScopeChanged dbempty bscope hscope = do
|
||||
rs <- dumpTbl
|
||||
-- TODO these errors should only fire when someone messed with the DB
|
||||
case rs of
|
||||
[] -> if dbempty then return (True, True) else throwError undefined
|
||||
[] -> if dbempty then return (True, True) else throwAppError $ DBError DBShouldBeEmpty
|
||||
[r] -> do
|
||||
let (ConfigStateR h b) = E.entityVal r
|
||||
return (bscope /= b, hscope /= h)
|
||||
_ -> throwError undefined
|
||||
_ -> throwAppError $ DBError DBMultiScope
|
||||
|
||||
makeTxCRUD
|
||||
:: (MonadInsertError m, MonadSqlQuery m, Hashable a)
|
||||
:: (MonadAppError m, MonadSqlQuery m, Hashable a)
|
||||
=> ExistingConfig
|
||||
-> [a]
|
||||
-> [CommitHash]
|
||||
|
|
@ -354,9 +355,10 @@ trimNames = fmap (AcntID . T.intercalate "_") . go []
|
|||
(_ :| []) -> [key : prev]
|
||||
([] :| xs) ->
|
||||
let next = key : prev
|
||||
other = go next $ fmap (fromMaybe undefined . NE.nonEmpty) xs
|
||||
other = go next $ fmap (fromMaybe err . NE.nonEmpty) xs
|
||||
in next : other
|
||||
(x :| xs) -> go (key : prev) $ fmap (fromMaybe undefined . NE.nonEmpty) (x : xs)
|
||||
(x :| xs) -> go (key : prev) $ fmap (fromMaybe err . NE.nonEmpty) (x : xs)
|
||||
err = error "account path list either not sorted or contains duplicates"
|
||||
|
||||
groupNonEmpty :: Ord a => [NonEmpty a] -> [(a, NonEmpty [a])]
|
||||
groupNonEmpty = fmap (second (NE.tail <$>)) . groupWith NE.head
|
||||
|
|
@ -453,7 +455,7 @@ readInvalidIds ExistingConfig {ecAccounts, ecCurrencies, ecTags} xs = do
|
|||
. groupKey id
|
||||
|
||||
readUpdates
|
||||
:: (MonadInsertError m, MonadSqlQuery m)
|
||||
:: (MonadAppError m, MonadSqlQuery m)
|
||||
=> [CommitHash]
|
||||
-> m ([ReadEntry], [Either TotalUpdateEntrySet FullUpdateEntrySet])
|
||||
readUpdates hashes = do
|
||||
|
|
@ -517,7 +519,7 @@ readUpdates hashes = do
|
|||
, utToRO = toRO
|
||||
, utFromUnk = fromUnk
|
||||
, utToUnk = toUnk
|
||||
, utTotalValue = realFracToDecimal' prec' tot
|
||||
, utTotalValue = realFracToDecimalP prec' tot
|
||||
, utBudget = E.unValue name
|
||||
, utPriority = E.unValue pri
|
||||
}
|
||||
|
|
@ -536,7 +538,8 @@ readUpdates hashes = do
|
|||
, utBudget = E.unValue name
|
||||
, utPriority = E.unValue pri
|
||||
}
|
||||
_ -> throwError undefined
|
||||
-- TODO this error is lame
|
||||
_ -> throwAppError $ DBError $ DBUpdateUnbalanced
|
||||
makeRE ((_, day, name, pri, (curID, prec)), entry) = do
|
||||
let e = entityVal entry
|
||||
in ReadEntry
|
||||
|
|
@ -551,7 +554,7 @@ readUpdates hashes = do
|
|||
splitFrom
|
||||
:: Precision
|
||||
-> NonEmpty (EntryRId, EntryR)
|
||||
-> InsertExcept (Either UEBlank (Either UE_RO UEUnk), [UE_RO], [UEUnk])
|
||||
-> AppExcept (Either UEBlank (Either UE_RO UEUnk), [UE_RO], [UEUnk])
|
||||
splitFrom prec (f0 :| fs) = do
|
||||
-- ASSUME entries are sorted by index
|
||||
-- TODO combine errors here
|
||||
|
|
@ -567,7 +570,7 @@ splitTo
|
|||
-> Either UEBlank (Either UE_RO UEUnk)
|
||||
-> [UEUnk]
|
||||
-> NonEmpty (EntryRId, EntryR)
|
||||
-> InsertExcept
|
||||
-> AppExcept
|
||||
( Either (UEBlank, [UELink]) (Either UE_RO (UEUnk, [UELink]))
|
||||
, [(UEUnk, [UELink])]
|
||||
, UEBlank
|
||||
|
|
@ -621,7 +624,7 @@ zipPaired
|
|||
:: Precision
|
||||
-> [UEUnk]
|
||||
-> [(EntryIndex, NonEmpty (EntryRId, EntryR))]
|
||||
-> InsertExcept ([(UEUnk, [UELink])], [UE_RO])
|
||||
-> AppExcept ([(UEUnk, [UELink])], [UE_RO])
|
||||
zipPaired prec = go ([], [])
|
||||
where
|
||||
nolinks = ((,[]) <$>)
|
||||
|
|
@ -639,41 +642,46 @@ zipPaired prec = go ([], [])
|
|||
let f = maybe (second (++ ros)) (\u -> first (u :)) nextLink
|
||||
go (f acc') fs' ts
|
||||
|
||||
makeLinkUnk :: (EntryRId, EntryR) -> InsertExcept UELink
|
||||
makeLinkUnk :: (EntryRId, EntryR) -> AppExcept UELink
|
||||
makeLinkUnk (k, e) =
|
||||
-- TODO error should state that scale must be present for a link in the db
|
||||
maybe
|
||||
(throwError $ InsertException undefined)
|
||||
(throwAppError $ DBError $ DBLinkError k DBLinkNoScale)
|
||||
(return . makeUE k e . LinkScale)
|
||||
$ fromRational <$> entryRCachedValue e
|
||||
|
||||
splitDeferredValue :: Precision -> (EntryRId, EntryR) -> InsertExcept (Either UE_RO UEUnk)
|
||||
splitDeferredValue prec p = do
|
||||
splitDeferredValue :: Precision -> (EntryRId, EntryR) -> AppExcept (Either UE_RO UEUnk)
|
||||
splitDeferredValue prec p@(k, _) = do
|
||||
res <- readDeferredValue prec p
|
||||
case res of
|
||||
Left _ -> throwError $ InsertException undefined
|
||||
Left _ -> throwAppError $ DBError $ DBLinkError k DBLinkNoValue
|
||||
Right x -> return x
|
||||
|
||||
readDeferredValue :: Precision -> (EntryRId, EntryR) -> InsertExcept (Either UEBlank (Either UE_RO UEUnk))
|
||||
readDeferredValue :: Precision -> (EntryRId, EntryR) -> AppExcept (Either UEBlank (Either UE_RO UEUnk))
|
||||
readDeferredValue prec (k, e) = case (entryRCachedValue e, entryRCachedType e) of
|
||||
(Nothing, Just TFixed) -> return $ Right $ Left $ makeRoUE prec e
|
||||
(Just v, Just TBalance) -> go $ fmap EVBalance $ makeUE k e $ realFracToDecimal' prec v
|
||||
(Just v, Just TBalance) -> go $ fmap EVBalance $ makeUE k e $ realFracToDecimalP prec v
|
||||
(Just v, Just TPercent) -> go $ fmap EVPercent $ makeUE k e $ fromRational v
|
||||
(Nothing, Nothing) -> return $ Left $ makeUnkUE k e
|
||||
_ -> throwError $ InsertException undefined
|
||||
(Just v, Nothing) -> err $ DBLinkInvalidValue v False
|
||||
(Just v, Just TFixed) -> err $ DBLinkInvalidValue v True
|
||||
(Nothing, Just TBalance) -> err $ DBLinkInvalidBalance
|
||||
(Nothing, Just TPercent) -> err $ DBLinkInvalidPercent
|
||||
where
|
||||
go = return . Right . Right
|
||||
err = throwAppError . DBError . DBLinkError k
|
||||
|
||||
makeUE :: i -> EntryR -> v -> UpdateEntry i v
|
||||
makeUE k e v = UpdateEntry k (entryRAccount e) v (entryRIndex e)
|
||||
|
||||
makeRoUE :: Precision -> EntryR -> UpdateEntry () StaticValue
|
||||
makeRoUE prec e = makeUE () e $ StaticValue (realFracToDecimal' prec $ entryRValue e)
|
||||
makeRoUE prec e = makeUE () e $ StaticValue (realFracToDecimalP prec $ entryRValue e)
|
||||
|
||||
makeUnkUE :: EntryRId -> EntryR -> UpdateEntry EntryRId ()
|
||||
makeUnkUE k e = makeUE k e ()
|
||||
|
||||
insertAll
|
||||
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
|
||||
:: (MonadAppError m, MonadSqlQuery m, MonadFinance m)
|
||||
=> [EntryCRU]
|
||||
-> m ()
|
||||
insertAll ebs = do
|
||||
|
|
|
|||
|
|
@ -37,7 +37,7 @@ splitHistory = partitionEithers . fmap go
|
|||
-- Transfers
|
||||
|
||||
readHistTransfer
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
:: (MonadAppError m, MonadFinance m)
|
||||
=> PairedTransfer
|
||||
-> m [Tx CommitR]
|
||||
readHistTransfer ht = do
|
||||
|
|
@ -82,9 +82,9 @@ readImport_
|
|||
-> m [TxRecord]
|
||||
readImport_ n delim tns p = do
|
||||
res <- tryIO $ BL.readFile p
|
||||
bs <- fromEither $ first (InsertException . (: []) . InsertIOError . tshow) res
|
||||
bs <- fromEither $ first (AppException . (: []) . StatementIOError . tshow) res
|
||||
case decodeByNameWithP (parseTxRecord p tns) opts $ skip bs of
|
||||
Left m -> throwIO $ InsertException [ParseError $ T.pack m]
|
||||
Left m -> throwIO $ AppException [ParseError $ T.pack m]
|
||||
Right (_, v) -> return $ catMaybes $ V.toList v
|
||||
where
|
||||
opts = defaultDecodeOptions {decDelimiter = fromIntegral delim}
|
||||
|
|
@ -104,12 +104,12 @@ parseTxRecord p TxOpts {toDate, toAmountFmt, toDesc, toAmount, toOther, toDateFm
|
|||
d' <- parseTimeM True defaultTimeLocale (T.unpack toDateFmt) d
|
||||
return $ Just $ TxRecord d' a e os p
|
||||
|
||||
matchRecords :: MonadFinance m => [MatchRe] -> [TxRecord] -> InsertExceptT m [Tx ()]
|
||||
matchRecords :: MonadFinance m => [MatchRe] -> [TxRecord] -> AppExceptT m [Tx ()]
|
||||
matchRecords ms rs = do
|
||||
(matched, unmatched, notfound) <- matchAll (matchPriorities ms) rs
|
||||
case (matched, unmatched, notfound) of
|
||||
(ms_, [], []) -> return ms_
|
||||
(_, us, ns) -> throwError $ InsertException [StatementError us ns]
|
||||
(_, us, ns) -> throwError $ AppException [StatementError us ns]
|
||||
|
||||
matchPriorities :: [MatchRe] -> [MatchGroup]
|
||||
matchPriorities =
|
||||
|
|
@ -166,7 +166,7 @@ zipperMatch
|
|||
:: MonadFinance m
|
||||
=> Unzipped MatchRe
|
||||
-> TxRecord
|
||||
-> InsertExceptT m (Zipped MatchRe, MatchRes (Tx ()))
|
||||
-> AppExceptT m (Zipped MatchRe, MatchRes (Tx ()))
|
||||
zipperMatch (Unzipped bs cs as) x = go [] cs
|
||||
where
|
||||
go _ [] = return (Zipped bs $ cs ++ as, MatchFail)
|
||||
|
|
@ -183,7 +183,7 @@ zipperMatch'
|
|||
:: MonadFinance m
|
||||
=> Zipped MatchRe
|
||||
-> TxRecord
|
||||
-> InsertExceptT m (Zipped MatchRe, MatchRes (Tx ()))
|
||||
-> AppExceptT m (Zipped MatchRe, MatchRes (Tx ()))
|
||||
zipperMatch' z x = go z
|
||||
where
|
||||
go (Zipped bs (a : as)) = do
|
||||
|
|
@ -204,7 +204,7 @@ matchAll
|
|||
:: MonadFinance m
|
||||
=> [MatchGroup]
|
||||
-> [TxRecord]
|
||||
-> InsertExceptT m ([Tx ()], [TxRecord], [MatchRe])
|
||||
-> AppExceptT m ([Tx ()], [TxRecord], [MatchRe])
|
||||
matchAll = go ([], [])
|
||||
where
|
||||
go (matched, unused) gs rs = case (gs, rs) of
|
||||
|
|
@ -218,7 +218,7 @@ matchGroup
|
|||
:: MonadFinance m
|
||||
=> MatchGroup
|
||||
-> [TxRecord]
|
||||
-> InsertExceptT m ([Tx ()], [TxRecord], [MatchRe])
|
||||
-> AppExceptT m ([Tx ()], [TxRecord], [MatchRe])
|
||||
matchGroup MatchGroup {mgDate = ds, mgNoDate = ns} rs = do
|
||||
(md, rest, ud) <- matchDates ds rs
|
||||
(mn, unmatched, un) <- matchNonDates ns rest
|
||||
|
|
@ -228,7 +228,7 @@ matchDates
|
|||
:: MonadFinance m
|
||||
=> [MatchRe]
|
||||
-> [TxRecord]
|
||||
-> InsertExceptT m ([Tx ()], [TxRecord], [MatchRe])
|
||||
-> AppExceptT m ([Tx ()], [TxRecord], [MatchRe])
|
||||
matchDates ms = go ([], [], initZipper ms)
|
||||
where
|
||||
go (matched, unmatched, z) [] =
|
||||
|
|
@ -253,7 +253,7 @@ matchNonDates
|
|||
:: MonadFinance m
|
||||
=> [MatchRe]
|
||||
-> [TxRecord]
|
||||
-> InsertExceptT m ([Tx ()], [TxRecord], [MatchRe])
|
||||
-> AppExceptT m ([Tx ()], [TxRecord], [MatchRe])
|
||||
matchNonDates ms = go ([], [], initZipper ms)
|
||||
where
|
||||
go (matched, unmatched, z) [] =
|
||||
|
|
@ -270,7 +270,7 @@ matchNonDates ms = go ([], [], initZipper ms)
|
|||
MatchFail -> (matched, r : unmatched)
|
||||
in go (m, u, resetZipper z') rs
|
||||
|
||||
matches :: MonadFinance m => MatchRe -> TxRecord -> InsertExceptT m (MatchRes (Tx ()))
|
||||
matches :: MonadFinance m => MatchRe -> TxRecord -> AppExceptT m (MatchRes (Tx ()))
|
||||
matches
|
||||
StatementParser {spTx, spOther, spVal, spDate, spDesc, spPriority}
|
||||
r@TxRecord {trDate, trAmount, trDesc, trOther} = do
|
||||
|
|
@ -287,7 +287,7 @@ matches
|
|||
desc = maybe (return True) (matchMaybe (unTxDesc trDesc) . snd) spDesc
|
||||
convert tg = MatchPass <$> toTx (fromIntegral spPriority) tg r
|
||||
|
||||
toTx :: MonadFinance m => Int -> TxGetter -> TxRecord -> InsertExceptT m (Tx ())
|
||||
toTx :: MonadFinance m => Int -> TxGetter -> TxRecord -> AppExceptT m (Tx ())
|
||||
toTx
|
||||
priority
|
||||
TxGetter
|
||||
|
|
@ -329,7 +329,7 @@ resolveSubGetter
|
|||
:: MonadFinance m
|
||||
=> TxRecord
|
||||
-> TxSubGetter
|
||||
-> InsertExceptT m SecondayEntrySet
|
||||
-> AppExceptT m SecondayEntrySet
|
||||
resolveSubGetter r TxSubGetter {tsgFrom, tsgTo, tsgValue, tsgCurrency} = do
|
||||
m <- asks csCurrencyMap
|
||||
cur <- liftInner $ resolveCurrency m r tsgCurrency
|
||||
|
|
@ -347,12 +347,12 @@ resolveSubGetter r TxSubGetter {tsgFrom, tsgTo, tsgValue, tsgCurrency} = do
|
|||
}
|
||||
|
||||
resolveHalfEntry
|
||||
:: (Precision -> TxRecord -> n -> InsertExcept v')
|
||||
:: (Precision -> TxRecord -> n -> AppExcept v')
|
||||
-> Precision
|
||||
-> TxRecord
|
||||
-> v
|
||||
-> TxHalfGetter (EntryGetter n)
|
||||
-> InsertExcept (HalfEntrySet v v')
|
||||
-> AppExcept (HalfEntrySet v v')
|
||||
resolveHalfEntry f prec r v TxHalfGetter {thgAcnt, thgComment, thgTags, thgEntries} =
|
||||
combineError acntRes esRes $ \a es ->
|
||||
HalfEntrySet
|
||||
|
|
@ -369,7 +369,7 @@ resolveHalfEntry f prec r v TxHalfGetter {thgAcnt, thgComment, thgTags, thgEntri
|
|||
acntRes = resolveAcnt r thgAcnt
|
||||
esRes = mapErrors (resolveEntry f prec r) thgEntries
|
||||
|
||||
otherMatches :: M.Map T.Text T.Text -> FieldMatcherRe -> InsertExcept Bool
|
||||
otherMatches :: M.Map T.Text T.Text -> FieldMatcherRe -> AppExcept 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
|
||||
|
|
@ -377,25 +377,25 @@ otherMatches dict m = case m of
|
|||
lookup_ t n = lookupErr (MatchField t) n dict
|
||||
|
||||
resolveEntry
|
||||
:: (Precision -> TxRecord -> n -> InsertExcept v)
|
||||
:: (Precision -> TxRecord -> n -> AppExcept v)
|
||||
-> Precision
|
||||
-> TxRecord
|
||||
-> EntryGetter n
|
||||
-> InsertExcept (Entry AcntID v TagID)
|
||||
-> AppExcept (Entry AcntID v TagID)
|
||||
resolveEntry f prec r s@Entry {eAcnt, eValue} =
|
||||
combineError acntRes valRes $ \a v -> s {eAcnt = a, eValue = v}
|
||||
where
|
||||
acntRes = resolveAcnt r eAcnt
|
||||
valRes = f prec r eValue
|
||||
|
||||
resolveFromValue :: Precision -> TxRecord -> EntryNumGetter -> InsertExcept EntryValue
|
||||
resolveFromValue :: Precision -> TxRecord -> EntryNumGetter -> AppExcept EntryValue
|
||||
resolveFromValue = resolveValue
|
||||
|
||||
resolveToValue :: Precision -> TxRecord -> LinkedEntryNumGetter -> InsertExcept EntryLink
|
||||
resolveToValue :: Precision -> TxRecord -> LinkedEntryNumGetter -> AppExcept EntryLink
|
||||
resolveToValue _ _ (Linked l) = return $ LinkIndex l
|
||||
resolveToValue prec r (Getter g) = LinkValue <$> resolveValue prec r g
|
||||
|
||||
resolveValue :: Precision -> TxRecord -> EntryNumGetter -> InsertExcept EntryValue
|
||||
resolveValue :: Precision -> TxRecord -> EntryNumGetter -> AppExcept EntryValue
|
||||
resolveValue prec TxRecord {trOther, trAmount} s = case s of
|
||||
(LookupN t) -> EntryFixed . go <$> (readDouble =<< lookupErr EntryValField t trOther)
|
||||
(ConstN c) -> return $ EntryFixed $ go c
|
||||
|
|
@ -403,20 +403,19 @@ resolveValue prec TxRecord {trOther, trAmount} s = case s of
|
|||
BalanceN x -> return $ EntryBalance $ go x
|
||||
PercentN x -> return $ EntryPercent x
|
||||
where
|
||||
go = realFracToDecimal' prec
|
||||
go = realFracToDecimalP prec
|
||||
|
||||
resolveAcnt :: TxRecord -> EntryAcnt -> InsertExcept AcntID
|
||||
resolveAcnt :: TxRecord -> EntryAcnt -> AppExcept AcntID
|
||||
resolveAcnt r e = AcntID <$> resolveEntryField AcntField r (unAcntID <$> e)
|
||||
|
||||
resolveCurrency :: CurrencyMap -> TxRecord -> EntryCur -> InsertExcept CurrencyPrec
|
||||
resolveCurrency :: CurrencyMap -> TxRecord -> EntryCur -> AppExcept CurrencyPrec
|
||||
resolveCurrency m r c = do
|
||||
i <- resolveEntryField CurField r (unCurID <$> c)
|
||||
case M.lookup (CurID i) m of
|
||||
Just k -> return k
|
||||
-- TODO this should be its own error (I think)
|
||||
Nothing -> throwError $ InsertException [LookupError (EntryIDField CurField) undefined]
|
||||
Nothing -> throwError $ AppException [LookupError (DBKey CurField) i]
|
||||
|
||||
resolveEntryField :: EntryIDType -> TxRecord -> EntryTextGetter T.Text -> InsertExcept T.Text
|
||||
resolveEntryField :: EntryIDType -> TxRecord -> EntryTextGetter T.Text -> AppExcept T.Text
|
||||
resolveEntryField t TxRecord {trOther = o} s = case s of
|
||||
ConstT p -> return p
|
||||
LookupT f -> lookup_ f o
|
||||
|
|
@ -427,15 +426,15 @@ resolveEntryField t TxRecord {trOther = o} s = case s of
|
|||
(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_ :: (Ord k, Show k) => k -> M.Map k v -> AppExcept v
|
||||
lookup_ = lookupErr (EntryIDField t)
|
||||
|
||||
readDouble :: T.Text -> InsertExcept Double
|
||||
readDouble :: T.Text -> AppExcept Double
|
||||
readDouble s = case readMaybe $ T.unpack s of
|
||||
Just x -> return x
|
||||
Nothing -> throwError $ InsertException [ConversionError s]
|
||||
Nothing -> throwError $ AppException [ConversionError s True]
|
||||
|
||||
readRational :: T.Text -> InsertExcept Rational
|
||||
readRational :: T.Text -> AppExcept Rational
|
||||
readRational s = case T.split (== '.') s of
|
||||
[x] -> maybe err (return . fromInteger) $ readT x
|
||||
[x, y] -> case (readT x, readT y) of
|
||||
|
|
@ -447,14 +446,14 @@ readRational s = case T.split (== '.') s of
|
|||
_ -> err
|
||||
where
|
||||
readT = readMaybe . T.unpack
|
||||
err = throwError $ InsertException [ConversionError s]
|
||||
err = throwError $ AppException [ConversionError s False]
|
||||
|
||||
compileOptions :: TxOpts T.Text -> InsertExcept TxOptsRe
|
||||
compileOptions :: TxOpts T.Text -> AppExcept TxOptsRe
|
||||
compileOptions o@TxOpts {toAmountFmt = pat} = do
|
||||
re <- compileRegex True pat
|
||||
return $ o {toAmountFmt = re}
|
||||
|
||||
compileMatch :: StatementParser T.Text -> InsertExcept MatchRe
|
||||
compileMatch :: StatementParser T.Text -> AppExcept MatchRe
|
||||
compileMatch m@StatementParser {spDesc, spOther} = do
|
||||
combineError dres ores $ \d os -> m {spDesc = d, spOther = os}
|
||||
where
|
||||
|
|
@ -462,10 +461,10 @@ compileMatch m@StatementParser {spDesc, spOther} = do
|
|||
dres = mapM go spDesc
|
||||
ores = combineErrors $ fmap (mapM go) spOther
|
||||
|
||||
compileRegex :: Bool -> T.Text -> InsertExcept (Text, Regex)
|
||||
compileRegex :: Bool -> T.Text -> AppExcept (Text, Regex)
|
||||
compileRegex groups pat = case res of
|
||||
Right re -> return (pat, re)
|
||||
Left _ -> throwError $ InsertException [RegexError pat]
|
||||
Left _ -> throwError $ AppException [RegexError pat]
|
||||
where
|
||||
res =
|
||||
compile
|
||||
|
|
@ -473,10 +472,10 @@ compileRegex groups pat = case res of
|
|||
(blankExecOpt {captureGroups = groups})
|
||||
pat
|
||||
|
||||
matchMaybe :: T.Text -> Regex -> InsertExcept Bool
|
||||
matchMaybe :: T.Text -> Regex -> AppExcept Bool
|
||||
matchMaybe q re = case execute re q of
|
||||
Right res -> return $ isJust res
|
||||
Left _ -> throwError $ InsertException [RegexError "this should not happen"]
|
||||
Left _ -> throwError $ AppException [RegexError "this should not happen"]
|
||||
|
||||
matchGroupsMaybe :: T.Text -> Regex -> [T.Text]
|
||||
matchGroupsMaybe q re = case regexec re q of
|
||||
|
|
|
|||
|
|
@ -26,6 +26,8 @@ import Text.Regex.TDFA
|
|||
--------------------------------------------------------------------------------
|
||||
-- database cache types
|
||||
|
||||
type MonadFinance = MonadReader ConfigState
|
||||
|
||||
data DeleteTxs = DeleteTxs
|
||||
{ dtTxs :: ![TransactionRId]
|
||||
, dtEntrySets :: ![EntrySetRId]
|
||||
|
|
@ -36,6 +38,7 @@ data DeleteTxs = DeleteTxs
|
|||
|
||||
type CDOps c d = CRUDOps [c] () () [d]
|
||||
|
||||
-- TODO split the entry stuff from the account metadata stuff
|
||||
data ConfigState = ConfigState
|
||||
{ csCurrencies :: !(CDOps (Entity CurrencyR) CurrencyRId)
|
||||
, csAccounts :: !(CDOps (Entity AccountR) AccountRId)
|
||||
|
|
@ -142,8 +145,6 @@ data EntryCRU
|
|||
| ToRead ReadEntry
|
||||
| ToInsert (Tx CommitR)
|
||||
|
||||
type MonadFinance = MonadReader ConfigState
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- misc
|
||||
|
||||
|
|
@ -240,8 +241,6 @@ data MatchRes a = MatchPass !a | MatchFail | MatchSkip
|
|||
--------------------------------------------------------------------------------
|
||||
-- exception types
|
||||
|
||||
data BalanceType = TooFewEntries | NotOneBlank deriving (Show)
|
||||
|
||||
data MatchType = MatchNumeric | MatchText deriving (Show)
|
||||
|
||||
data EntryIDType = AcntField | CurField | TagField deriving (Show)
|
||||
|
|
@ -253,42 +252,49 @@ data LookupSuberr
|
|||
| DBKey !EntryIDType
|
||||
deriving (Show)
|
||||
|
||||
data AllocationSuberr
|
||||
= NoAllocations
|
||||
| ExceededTotal
|
||||
| MissingBlank
|
||||
| TooManyBlanks
|
||||
deriving (Show)
|
||||
|
||||
data PatternSuberr = ZeroLength | ZeroRepeats deriving (Show)
|
||||
|
||||
data InsertError
|
||||
data DBLinkSubError
|
||||
= DBLinkNoScale
|
||||
| DBLinkNoValue
|
||||
| DBLinkInvalidValue !Rational !Bool
|
||||
| DBLinkInvalidBalance
|
||||
| DBLinkInvalidPercent
|
||||
deriving (Show)
|
||||
|
||||
data DBSubError
|
||||
= DBShouldBeEmpty
|
||||
| DBMultiScope
|
||||
| DBUpdateUnbalanced
|
||||
| DBLinkError !EntryRId !DBLinkSubError
|
||||
deriving (Show)
|
||||
|
||||
data AppError
|
||||
= RegexError !T.Text
|
||||
| MatchValPrecisionError !Natural !Natural
|
||||
| AccountError !AcntID !(NE.NonEmpty AcntType)
|
||||
| InsertIOError !T.Text
|
||||
| AccountTypeError !AcntID !(NE.NonEmpty AcntType)
|
||||
| StatementIOError !T.Text
|
||||
| ParseError !T.Text
|
||||
| ConversionError !T.Text
|
||||
| IndexError !(Entry AcntID LinkedNumGetter TagID) !Day
|
||||
| RoundError !CurID
|
||||
| ConversionError !T.Text !Bool
|
||||
| LookupError !LookupSuberr !T.Text
|
||||
| IncomeError !Day !T.Text !Rational
|
||||
| PatternError !Natural !Natural !(Maybe Natural) !PatternSuberr
|
||||
| DatePatternError !Natural !Natural !(Maybe Natural) !PatternSuberr
|
||||
| DaySpanError !Gregorian !(Maybe Gregorian)
|
||||
| StatementError ![TxRecord] ![MatchRe]
|
||||
| PeriodError !Day !Day
|
||||
| LinkError !EntryIndex !EntryIndex
|
||||
| DBError !DBSubError
|
||||
deriving (Show)
|
||||
|
||||
newtype InsertException = InsertException [InsertError]
|
||||
deriving (Show, Semigroup) via [InsertError]
|
||||
newtype AppException = AppException [AppError]
|
||||
deriving (Show, Semigroup) via [AppError]
|
||||
|
||||
instance Exception InsertException
|
||||
instance Exception AppException
|
||||
|
||||
type MonadInsertError = MonadError InsertException
|
||||
type MonadAppError = MonadError AppException
|
||||
|
||||
type InsertExceptT = ExceptT InsertException
|
||||
type AppExceptT = ExceptT AppException
|
||||
|
||||
type InsertExcept = InsertExceptT Identity
|
||||
type AppExcept = AppExceptT Identity
|
||||
|
||||
type MatchRe = StatementParser (T.Text, Regex)
|
||||
|
||||
|
|
|
|||
|
|
@ -8,6 +8,7 @@ module Internal.Utils
|
|||
, resolveDaySpan
|
||||
, resolveDaySpan_
|
||||
, intersectDaySpan
|
||||
, throwAppError
|
||||
, liftInner
|
||||
, liftExceptT
|
||||
, liftExcept
|
||||
|
|
@ -28,7 +29,6 @@ module Internal.Utils
|
|||
, mapErrorsIO
|
||||
, mapErrorsPooledIO
|
||||
, showError
|
||||
, tshow
|
||||
, lookupErr
|
||||
, uncurry3
|
||||
, dateMatches
|
||||
|
|
@ -49,7 +49,7 @@ module Internal.Utils
|
|||
, entryPair
|
||||
, singleQuote
|
||||
, keyVals
|
||||
, realFracToDecimal'
|
||||
, realFracToDecimalP
|
||||
, roundToP
|
||||
)
|
||||
where
|
||||
|
|
@ -58,6 +58,7 @@ import Control.Monad.Error.Class
|
|||
import Control.Monad.Except
|
||||
import Data.Decimal
|
||||
import Data.Time.Format.ISO8601
|
||||
import qualified Database.Esqueleto.Experimental as E
|
||||
import GHC.Real
|
||||
import Internal.Types.Main
|
||||
import RIO
|
||||
|
|
@ -72,7 +73,7 @@ import qualified RIO.Vector as V
|
|||
--------------------------------------------------------------------------------
|
||||
-- intervals
|
||||
|
||||
expandDatePat :: DaySpan -> DatePat -> InsertExcept [Day]
|
||||
expandDatePat :: DaySpan -> DatePat -> AppExcept [Day]
|
||||
expandDatePat b (Cron cp) = expandCronPat b cp
|
||||
expandDatePat i (Mod mp) = return $ expandModPat mp i
|
||||
|
||||
|
|
@ -91,7 +92,7 @@ expandModPat ModPat {mpStart = s, mpBy = b, mpUnit = u, mpRepeats = r} bs =
|
|||
Month -> addGregorianMonthsClip
|
||||
Year -> addGregorianYearsClip
|
||||
|
||||
expandCronPat :: DaySpan -> CronPat -> InsertExcept [Day]
|
||||
expandCronPat :: DaySpan -> CronPat -> AppExcept [Day]
|
||||
expandCronPat b CronPat {cpYear, cpMonth, cpDay, cpWeekly} =
|
||||
combineError3 yRes mRes dRes $ \ys ms ds ->
|
||||
filter validWeekday $
|
||||
|
|
@ -122,14 +123,14 @@ expandCronPat b CronPat {cpYear, cpMonth, cpDay, cpWeekly} =
|
|||
| m `elem` [4, 6, 9, 11] && d > 30 = Nothing
|
||||
| otherwise = Just $ fromGregorian y m d
|
||||
|
||||
expandMDYPat :: Natural -> Natural -> MDYPat -> InsertExcept [Natural]
|
||||
expandMDYPat :: Natural -> Natural -> MDYPat -> AppExcept [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]
|
||||
| b < 1 = throwAppError $ DatePatternError s b r ZeroLength
|
||||
| otherwise = do
|
||||
k <- limit r
|
||||
return $ dropWhile (<= lower) $ takeWhile (<= k) [s + i * b | i <- [0 ..]]
|
||||
|
|
@ -138,14 +139,14 @@ expandMDYPat lower upper (Repeat RepeatPat {rpStart = s, rpBy = b, rpRepeats = r
|
|||
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]
|
||||
| n < 1 = throwAppError $ DatePatternError 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)
|
||||
:: (MonadFinance m, MonadAppError m)
|
||||
=> DatePat
|
||||
-> Maybe Interval
|
||||
-> m [Day]
|
||||
|
|
@ -224,7 +225,7 @@ inDaySpan bs = withinDays (fromDaySpan bs)
|
|||
withinDays :: (Day, Day) -> Day -> Bool
|
||||
withinDays (d0, d1) x = d0 <= x && x < d1
|
||||
|
||||
resolveDaySpan :: Interval -> InsertExcept DaySpan
|
||||
resolveDaySpan :: Interval -> AppExcept DaySpan
|
||||
resolveDaySpan i@Interval {intStart = s} =
|
||||
resolveDaySpan_ (s {gYear = gYear s + 50}) i
|
||||
|
||||
|
|
@ -237,14 +238,14 @@ intersectDaySpan a b =
|
|||
a' = max a0 a1
|
||||
b' = min b0 b1
|
||||
|
||||
resolveDaySpan_ :: Gregorian -> Interval -> InsertExcept DaySpan
|
||||
resolveDaySpan_ :: Gregorian -> Interval -> AppExcept DaySpan
|
||||
resolveDaySpan_ def Interval {intStart = s, intEnd = e} =
|
||||
-- TODO the default isn't checked here :/
|
||||
case fromGregorian' <$> e of
|
||||
Nothing -> return $ toDaySpan_ $ fromGregorian' def
|
||||
Just e_
|
||||
| s_ < e_ -> return $ toDaySpan_ e_
|
||||
| otherwise -> throwError $ InsertException [DaySpanError s e]
|
||||
| otherwise -> throwAppError $ DaySpanError s e
|
||||
where
|
||||
s_ = fromGregorian' s
|
||||
toDaySpan_ end = toDaySpan (s_, end)
|
||||
|
|
@ -259,9 +260,9 @@ toDaySpan (a, b) = (a, fromIntegral $ diffDays b a - 1)
|
|||
--------------------------------------------------------------------------------
|
||||
-- matching
|
||||
|
||||
valMatches :: ValMatcher -> Rational -> InsertExcept Bool
|
||||
valMatches :: ValMatcher -> Rational -> AppExcept Bool
|
||||
valMatches ValMatcher {vmDen, vmSign, vmNum, vmPrec} x
|
||||
| Just d_ <- vmDen, d_ >= p = throwError $ InsertException [MatchValPrecisionError d_ p]
|
||||
| Just d_ <- vmDen, d_ >= p = throwAppError $ MatchValPrecisionError d_ p
|
||||
| otherwise =
|
||||
return $
|
||||
checkMaybe (s ==) vmSign
|
||||
|
|
@ -279,6 +280,9 @@ dateMatches md = (EQ ==) . compareDate md
|
|||
--------------------------------------------------------------------------------
|
||||
-- error flow control
|
||||
|
||||
throwAppError :: MonadAppError m => AppError -> m a
|
||||
throwAppError e = throwError $ AppException [e]
|
||||
|
||||
liftInner :: Monad m => ExceptT e Identity a -> ExceptT e m a
|
||||
liftInner = mapExceptT (return . runIdentity)
|
||||
|
||||
|
|
@ -288,41 +292,37 @@ liftExceptT x = runExceptT x >>= either throwError return
|
|||
liftExcept :: MonadError e m => Except e a -> m a
|
||||
liftExcept = either throwError return . runExcept
|
||||
|
||||
liftIOExceptT :: MonadIO m => InsertExceptT m a -> m a
|
||||
liftIOExceptT :: MonadIO m => AppExceptT m a -> m a
|
||||
liftIOExceptT = fromEither <=< runExceptT
|
||||
|
||||
liftIOExcept :: MonadIO m => InsertExcept a -> m a
|
||||
liftIOExcept :: MonadIO m => AppExcept a -> m a
|
||||
liftIOExcept = fromEither . runExcept
|
||||
|
||||
combineError :: MonadError InsertException m => m a -> m b -> (a -> b -> c) -> m c
|
||||
combineError :: MonadAppError 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_ :: MonadAppError 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 :: MonadAppError 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 :: MonadAppError 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 :: MonadAppError 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)
|
||||
mapErrors :: (Traversable t, MonadAppError 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.
|
||||
|
|
@ -333,7 +333,7 @@ mapErrors f xs = mapM go $ enumTraversable 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 :: (Traversable t, MonadAppError m) => t (m a) -> m (t a)
|
||||
combineErrors = mapErrors id
|
||||
|
||||
enumTraversable :: (Num n, Traversable t) => t a -> t (n, a)
|
||||
|
|
@ -349,9 +349,9 @@ 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))
|
||||
a' <- catch a $ \(AppException es) ->
|
||||
(throwIO . AppException)
|
||||
=<< catch (es <$ b) (\(AppException es') -> return (es' ++ es))
|
||||
f a' =<< b
|
||||
|
||||
combineErrorIOM3 :: MonadUnliftIO m => m a -> m b -> m c -> (a -> b -> c -> m d) -> m d
|
||||
|
|
@ -361,39 +361,39 @@ combineErrorIOM3 a b c f =
|
|||
mapErrorsPooledIO :: (Traversable t, MonadUnliftIO m) => Int -> (a -> m b) -> t a -> m (t b)
|
||||
mapErrorsPooledIO t f xs = pooledMapConcurrentlyN t go $ enumTraversable xs
|
||||
where
|
||||
go (n, x) = catch (f x) $ \(InsertException e) -> do
|
||||
go (n, x) = catch (f x) $ \(AppException 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
|
||||
throwIO $ AppException $ foldr (<>) e es
|
||||
err x = catch (Nothing <$ x) $ \(AppException es) -> pure $ Just es
|
||||
|
||||
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
|
||||
go (n, x) = catch (f x) $ \(AppException 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
|
||||
throwIO $ AppException $ foldr (<>) e es
|
||||
err x = catch (Nothing <$ x) $ \(AppException es) -> pure $ Just es
|
||||
|
||||
collectErrorsIO :: (Traversable t, MonadUnliftIO m) => t (m a) -> m (t a)
|
||||
collectErrorsIO = mapErrorsIO id
|
||||
|
||||
lookupErr :: (Ord k, Show k) => LookupSuberr -> k -> M.Map k v -> InsertExcept v
|
||||
lookupErr :: (Ord k, Show k) => LookupSuberr -> k -> M.Map k v -> AppExcept v
|
||||
lookupErr what k m = case M.lookup k m of
|
||||
Just x -> return x
|
||||
_ -> throwError $ InsertException [LookupError what $ tshow k]
|
||||
_ -> throwAppError $ LookupError what $ tshow k
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- error display
|
||||
|
||||
showError :: InsertError -> [T.Text]
|
||||
showError :: AppError -> [T.Text]
|
||||
showError other = case other of
|
||||
(StatementError ts ms) -> (tshowx <$> ts) ++ (showMatch <$> ms)
|
||||
(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) ->
|
||||
(AccountTypeError a ts) ->
|
||||
[ T.unwords
|
||||
[ "account type of key"
|
||||
, singleQuote $ unAcntID a
|
||||
|
|
@ -403,7 +403,7 @@ showError other = case other of
|
|||
]
|
||||
where
|
||||
ts_ = T.intercalate ", " $ NE.toList $ fmap atName ts
|
||||
(PatternError s b r p) -> [T.unwords [msg, "in pattern: ", pat]]
|
||||
(DatePatternError s b r p) -> [T.unwords [msg, "in pattern: ", pat]]
|
||||
where
|
||||
pat =
|
||||
keyVals $
|
||||
|
|
@ -418,8 +418,15 @@ showError other = case other 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]
|
||||
(ConversionError x isDouble) ->
|
||||
[ T.unwords
|
||||
[ "Could not convert to"
|
||||
, if isDouble then "double" else "rational"
|
||||
, "number: "
|
||||
, x
|
||||
]
|
||||
]
|
||||
(StatementIOError msg) -> [T.append "IO Error: " msg]
|
||||
(ParseError msg) -> [T.append "Parse Error: " msg]
|
||||
(MatchValPrecisionError d p) ->
|
||||
[T.unwords ["Match denominator", tshow d, "must be less than", tshow p]]
|
||||
|
|
@ -437,16 +444,6 @@ showError other = case other of
|
|||
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"
|
||||
, tshow day
|
||||
, "where balance is"
|
||||
, tshow (fromRational balance :: Double)
|
||||
]
|
||||
]
|
||||
(PeriodError start next) ->
|
||||
[ T.unwords
|
||||
[ "First pay period on "
|
||||
|
|
@ -455,28 +452,40 @@ showError other = case other of
|
|||
, singleQuote $ tshow next
|
||||
]
|
||||
]
|
||||
(IndexError Entry {eValue = LinkedNumGetter {lngIndex}, eAcnt} day) ->
|
||||
(LinkError i m) ->
|
||||
[ T.unwords
|
||||
[ "No credit entry for index"
|
||||
, singleQuote $ tshow lngIndex
|
||||
, "for entry with account"
|
||||
, singleQuote $ unAcntID eAcnt
|
||||
, "on"
|
||||
, tshow day
|
||||
[ "entry index"
|
||||
, singleQuote $ tshow i
|
||||
, "out of range: max index is"
|
||||
, singleQuote $ tshow m
|
||||
]
|
||||
]
|
||||
(RoundError cur) ->
|
||||
(DBError d) -> case d of
|
||||
DBShouldBeEmpty -> ["database has no rows in 'config_state' but has other data"]
|
||||
DBMultiScope -> ["database has multiple rows in 'config_state'"]
|
||||
DBUpdateUnbalanced -> ["update is missing debit or credit entries"]
|
||||
DBLinkError k l ->
|
||||
let k' = T.append "in entry key: " $ tshow $ E.fromSqlKey k
|
||||
in case l of
|
||||
DBLinkNoScale -> [T.append "no link scale" k']
|
||||
DBLinkNoValue -> [T.append "no link value" k']
|
||||
DBLinkInvalidValue v isfixed ->
|
||||
[ T.unwords
|
||||
[ "Could not look up precision for currency"
|
||||
, singleQuote $ unCurID cur
|
||||
[ if isfixed
|
||||
then "fixed link should not have value"
|
||||
else "untyped value is ambiguous"
|
||||
, singleQuote $ tshow v
|
||||
, k'
|
||||
]
|
||||
]
|
||||
DBLinkInvalidBalance -> [T.append "no value given for balance link" k']
|
||||
DBLinkInvalidPercent -> [T.append "no value given for percent link" k']
|
||||
|
||||
showGregorian_ :: Gregorian -> T.Text
|
||||
showGregorian_ Gregorian {gYear, gMonth, gDay} = T.intercalate "-" $ tshow <$> [gYear, gMonth, gDay]
|
||||
|
||||
tshowx :: TxRecord -> T.Text
|
||||
tshowx TxRecord {trDate = d, trAmount = v, trDesc = e, trFile = f} =
|
||||
showTx :: TxRecord -> T.Text
|
||||
showTx TxRecord {trDate = d, trAmount = v, trDesc = e, trFile = f} =
|
||||
T.append "Unmatched transaction: " $
|
||||
keyVals
|
||||
[ ("path", T.pack f)
|
||||
|
|
@ -589,29 +598,29 @@ 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
|
||||
|
||||
lookupAccount :: (MonadInsertError m, MonadFinance m) => AcntID -> m (AccountRId, AcntType)
|
||||
lookupAccount :: (MonadAppError m, MonadFinance m) => AcntID -> m (AccountRId, AcntType)
|
||||
lookupAccount = lookupFinance AcntField csAccountMap
|
||||
|
||||
lookupAccountKey :: (MonadInsertError m, MonadFinance m) => AcntID -> m AccountRId
|
||||
lookupAccountKey :: (MonadAppError m, MonadFinance m) => AcntID -> m AccountRId
|
||||
lookupAccountKey = fmap fst . lookupAccount
|
||||
|
||||
lookupAccountType :: (MonadInsertError m, MonadFinance m) => AcntID -> m AcntType
|
||||
lookupAccountType :: (MonadAppError m, MonadFinance m) => AcntID -> m AcntType
|
||||
lookupAccountType = fmap snd . lookupAccount
|
||||
|
||||
lookupCurrency :: (MonadInsertError m, MonadFinance m) => CurID -> m CurrencyPrec
|
||||
lookupCurrency :: (MonadAppError m, MonadFinance m) => CurID -> m CurrencyPrec
|
||||
lookupCurrency = lookupFinance CurField csCurrencyMap
|
||||
|
||||
lookupCurrencyKey :: (MonadInsertError m, MonadFinance m) => CurID -> m CurrencyRId
|
||||
lookupCurrencyKey :: (MonadAppError m, MonadFinance m) => CurID -> m CurrencyRId
|
||||
lookupCurrencyKey = fmap cpID . lookupCurrency
|
||||
|
||||
lookupCurrencyPrec :: (MonadInsertError m, MonadFinance m) => CurID -> m Precision
|
||||
lookupCurrencyPrec :: (MonadAppError m, MonadFinance m) => CurID -> m Precision
|
||||
lookupCurrencyPrec = fmap cpPrec . lookupCurrency
|
||||
|
||||
lookupTag :: (MonadInsertError m, MonadFinance m) => TagID -> m TagRId
|
||||
lookupTag :: (MonadAppError m, MonadFinance m) => TagID -> m TagRId
|
||||
lookupTag = lookupFinance TagField csTagMap
|
||||
|
||||
lookupFinance
|
||||
:: (MonadInsertError m, MonadFinance m, Ord k, Show k)
|
||||
:: (MonadAppError m, MonadFinance m, Ord k, Show k)
|
||||
=> EntryIDType
|
||||
-> (ConfigState -> M.Map k a)
|
||||
-> k
|
||||
|
|
@ -619,7 +628,7 @@ lookupFinance
|
|||
lookupFinance t f c = (liftExcept . lookupErr (DBKey t) c) =<< asks f
|
||||
|
||||
balanceTxs
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
:: (MonadAppError m, MonadFinance m)
|
||||
=> [EntryCRU]
|
||||
-> m ([UEBalanced], [InsertTx])
|
||||
balanceTxs ebs =
|
||||
|
|
@ -796,7 +805,7 @@ updateUnknown k e = do
|
|||
-- balancing
|
||||
|
||||
balancePrimaryEntrySet
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
:: (MonadAppError m, MonadFinance m)
|
||||
=> BudgetName
|
||||
-> PrimaryEntrySet
|
||||
-> StateT EntryBals m InsertEntrySet
|
||||
|
|
@ -821,7 +830,7 @@ balancePrimaryEntrySet
|
|||
balanceFinal bc (-esTotalValue) fs'' t0' ts'
|
||||
|
||||
balanceSecondaryEntrySet
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
:: (MonadAppError m, MonadFinance m)
|
||||
=> BudgetName
|
||||
-> SecondayEntrySet
|
||||
-> StateT EntryBals m InsertEntrySet
|
||||
|
|
@ -846,7 +855,7 @@ balanceSecondaryEntrySet
|
|||
bc = (esCurrency, budgetName)
|
||||
|
||||
balanceFinal
|
||||
:: (MonadInsertError m)
|
||||
:: (MonadAppError m)
|
||||
=> BCKey
|
||||
-> Decimal
|
||||
-> NonEmpty InsertEntry
|
||||
|
|
@ -865,7 +874,7 @@ balanceFinal k@(curID, _) tot fs t0 ts = do
|
|||
}
|
||||
|
||||
balanceTotalEntrySet
|
||||
:: (MonadInsertError m)
|
||||
:: (MonadAppError m)
|
||||
=> (ABCKey -> v -> StateT EntryBals m (Decimal, Maybe CachedEntry))
|
||||
-> BCKey
|
||||
-> Decimal
|
||||
|
|
@ -890,19 +899,19 @@ liftInnerS :: Monad m => StateT e Identity a -> StateT e m a
|
|||
liftInnerS = mapStateT (return . runIdentity)
|
||||
|
||||
balanceLinked
|
||||
:: MonadInsertError m
|
||||
:: MonadAppError m
|
||||
=> Vector Decimal
|
||||
-> ABCKey
|
||||
-> EntryLink
|
||||
-> StateT EntryBals m (Decimal, Maybe CachedEntry)
|
||||
balanceLinked from k lg = case lg of
|
||||
(LinkIndex LinkedNumGetter {lngIndex, lngScale}) -> do
|
||||
let res = fmap (go lngScale) $ from V.!? fromIntegral lngIndex
|
||||
let i = fromIntegral lngIndex
|
||||
upper = EntryIndex $ V.length from
|
||||
res = fmap (go lngScale) $ from V.!? i
|
||||
case res of
|
||||
Just v -> return (v, Just $ CachedLink (EntryIndex $ fromIntegral lngIndex) (LinkScale lngScale))
|
||||
-- TODO this error would be much more informative if I had access to the
|
||||
-- file from which it came
|
||||
Nothing -> throwError undefined
|
||||
Nothing -> throwAppError $ LinkError (EntryIndex i) upper
|
||||
(LinkValue d) -> liftInnerS $ balanceDeferred k d
|
||||
where
|
||||
go s = negate . (*. s)
|
||||
|
|
@ -917,7 +926,7 @@ balanceDeferred k e = do
|
|||
return (newval, d)
|
||||
|
||||
balanceEntry
|
||||
:: (MonadInsertError m)
|
||||
:: (MonadAppError m)
|
||||
=> (ABCKey -> v -> StateT EntryBals m (Decimal, Maybe CachedEntry))
|
||||
-> BCKey
|
||||
-> Entry AccountRId v TagRId
|
||||
|
|
@ -932,7 +941,7 @@ balanceEntry f k e@Entry {eValue, eAcnt = acntID} = do
|
|||
}
|
||||
|
||||
resolveAcntAndTags
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
:: (MonadAppError m, MonadFinance m)
|
||||
=> Entry AcntID v TagID
|
||||
-> m (Entry AccountRId v TagRId)
|
||||
resolveAcntAndTags e@Entry {eAcnt, eTags} = do
|
||||
|
|
@ -952,7 +961,7 @@ findBalance k e = do
|
|||
-- transfers
|
||||
|
||||
expandTransfers
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
:: (MonadAppError m, MonadFinance m)
|
||||
=> CommitR
|
||||
-> BudgetName
|
||||
-> DaySpan
|
||||
|
|
@ -961,7 +970,7 @@ expandTransfers
|
|||
expandTransfers tc name bounds = fmap concat . mapErrors (expandTransfer tc name bounds)
|
||||
|
||||
expandTransfer
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
:: (MonadAppError m, MonadFinance m)
|
||||
=> CommitR
|
||||
-> BudgetName
|
||||
-> DaySpan
|
||||
|
|
@ -980,7 +989,7 @@ expandTransfer tc name bounds Transfer {transAmounts, transTo, transCurrency, tr
|
|||
} = do
|
||||
cp <- lookupCurrency transCurrency
|
||||
let v' = (-v)
|
||||
let dec = realFracToDecimal' (cpPrec cp) v'
|
||||
let dec = realFracToDecimalP (cpPrec cp) v'
|
||||
let v'' = case t of
|
||||
TFixed -> EntryFixed dec
|
||||
TPercent -> EntryPercent v'
|
||||
|
|
@ -1021,7 +1030,7 @@ entryPair (TaggedAcnt fa fts) (TaggedAcnt ta tts) curid com totval val1 =
|
|||
}
|
||||
|
||||
withDates
|
||||
:: (MonadFinance m, MonadInsertError m)
|
||||
:: (MonadFinance m, MonadAppError m)
|
||||
=> DaySpan
|
||||
-> DatePat
|
||||
-> (Day -> m a)
|
||||
|
|
@ -1036,8 +1045,8 @@ sumM f = mapAccumM (\s -> fmap (first (+ s)) . f) 0
|
|||
mapAccumM :: (Monad m) => (s -> a -> m (s, b)) -> s -> [a] -> m (s, [b])
|
||||
mapAccumM f s = foldM (\(s', ys) -> fmap (second (: ys)) . f s') (s, [])
|
||||
|
||||
realFracToDecimal' :: (Integral i, RealFrac r) => Precision -> r -> DecimalRaw i
|
||||
realFracToDecimal' p = realFracToDecimal (unPrecision p)
|
||||
realFracToDecimalP :: (Integral i, RealFrac r) => Precision -> r -> DecimalRaw i
|
||||
realFracToDecimalP p = realFracToDecimal (unPrecision p)
|
||||
|
||||
roundToP :: Integral i => Precision -> DecimalRaw i -> DecimalRaw i
|
||||
roundToP p = roundTo (unPrecision p)
|
||||
|
|
|
|||
Loading…
Reference in New Issue