ADD errors for everything that needs them (ish)

This commit is contained in:
Nathan Dwarshuis 2023-07-16 19:55:33 -04:00
parent cafc066881
commit 2e0b591312
6 changed files with 223 additions and 201 deletions

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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)

View File

@ -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)