ndwarshuis
/
pwncash
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
app/Main.hs
View File

@ -255,7 +255,7 @@ runSync threads c bs hs = do
rerunnableIO $ fromEither res rerunnableIO $ fromEither res
where where
root = takeDirectory c root = takeDirectory c
err (InsertException es) = do err (AppException es) = do
liftIO $ mapM_ TI.putStrLn $ concatMap showError es liftIO $ mapM_ TI.putStrLn $ concatMap showError es
exitFailure exitFailure

38
lib/Internal/Budget.hs
View File

@ -13,7 +13,7 @@ import qualified RIO.NonEmpty as NE
import qualified RIO.Text as T import qualified RIO.Text as T
import RIO.Time import RIO.Time
readBudget :: (MonadInsertError m, MonadFinance m) => Budget -> m [Tx CommitR] readBudget :: (MonadAppError m, MonadFinance m) => Budget -> m [Tx CommitR]
readBudget readBudget
b@Budget b@Budget
{ bgtLabel { bgtLabel
@ -56,7 +56,7 @@ readBudget
localSpan <- liftExcept $ resolveDaySpan bi localSpan <- liftExcept $ resolveDaySpan bi
return $ intersectDaySpan globalSpan localSpan return $ intersectDaySpan globalSpan localSpan
sortAllo :: MultiAllocation v -> InsertExcept (DaySpanAllocation v) sortAllo :: MultiAllocation v -> AppExcept (DaySpanAllocation v)
sortAllo a@Allocation {alloAmts = as} = do sortAllo a@Allocation {alloAmts = as} = do
bs <- foldSpan [] $ L.sortOn amtWhen as bs <- foldSpan [] $ L.sortOn amtWhen as
return $ a {alloAmts = reverse bs} 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 -- iteration which is a total waste, but the fix requires turning this
-- loop into a fold which I don't feel like doing now :( -- loop into a fold which I don't feel like doing now :(
readIncome readIncome
:: (MonadInsertError m, MonadFinance m) :: (MonadAppError m, MonadFinance m)
=> CommitR => CommitR
-> BudgetName -> BudgetName
-> IntAllocations -> IntAllocations
@ -104,7 +104,7 @@ readIncome
(combineError incRes nonIncRes (,)) (combineError incRes nonIncRes (,))
(combineError cpRes dayRes (,)) (combineError cpRes dayRes (,))
$ \_ (cp, days) -> do $ \_ (cp, days) -> do
let gross = realFracToDecimal' (cpPrec cp) incGross let gross = realFracToDecimalP (cpPrec cp) incGross
foldDays (allocate cp gross) start days foldDays (allocate cp gross) start days
where where
srcAcnt' = AcntID srcAcnt srcAcnt' = AcntID srcAcnt
@ -163,7 +163,7 @@ periodScaler
:: PeriodType :: PeriodType
-> Day -> Day
-> Day -> Day
-> InsertExcept PeriodScaler -> AppExcept PeriodScaler
periodScaler pt prev cur = return scale periodScaler pt prev cur = return scale
where where
n = workingDays wds prev cur n = workingDays wds prev cur
@ -172,10 +172,10 @@ periodScaler pt prev cur = return scale
Daily ds -> ds Daily ds -> ds
scale prec x = case pt of scale prec x = case pt of
Hourly HourlyPeriod {hpAnnualHours, hpDailyHours} -> Hourly HourlyPeriod {hpAnnualHours, hpDailyHours} ->
realFracToDecimal' prec (x / fromIntegral hpAnnualHours) realFracToDecimalP prec (x / fromIntegral hpAnnualHours)
* fromIntegral hpDailyHours * fromIntegral hpDailyHours
* fromIntegral n * fromIntegral n
Daily _ -> realFracToDecimal' prec (x * fromIntegral n / 365.25) Daily _ -> realFracToDecimalP prec (x * fromIntegral n / 365.25)
-- ASSUME start < end -- ASSUME start < end
workingDays :: [Weekday] -> Day -> Day -> Natural workingDays :: [Weekday] -> Day -> Day -> Natural
@ -191,7 +191,7 @@ workingDays wds start end = fromIntegral $ daysFull + daysTail
-- ASSUME days is a sorted list -- ASSUME days is a sorted list
foldDays foldDays
:: MonadInsertError m :: MonadAppError m
=> (Day -> Day -> m a) => (Day -> Day -> m a)
-> Day -> Day
-> [Day] -> [Day]
@ -201,27 +201,27 @@ foldDays f start days = case NE.nonEmpty days of
Just ds Just ds
| any (start >) ds -> | any (start >) ds ->
throwError $ throwError $
InsertException [PeriodError start $ minimum ds] AppException [PeriodError start $ minimum ds]
| otherwise -> | otherwise ->
combineErrors $ combineErrors $
snd $ snd $
L.mapAccumL (\prevDay day -> (day, f prevDay day)) start days 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 isIncomeAcnt = checkAcntType IncomeT
isNotIncomeAcnt :: (MonadInsertError m, MonadFinance m) => AcntID -> m () isNotIncomeAcnt :: (MonadAppError m, MonadFinance m) => AcntID -> m ()
isNotIncomeAcnt = checkAcntTypes (AssetT :| [EquityT, ExpenseT, LiabilityT]) isNotIncomeAcnt = checkAcntTypes (AssetT :| [EquityT, ExpenseT, LiabilityT])
checkAcntType checkAcntType
:: (MonadInsertError m, MonadFinance m) :: (MonadAppError m, MonadFinance m)
=> AcntType => AcntType
-> AcntID -> AcntID
-> m () -> m ()
checkAcntType t = checkAcntTypes (t :| []) checkAcntType t = checkAcntTypes (t :| [])
checkAcntTypes checkAcntTypes
:: (MonadInsertError m, MonadFinance m) :: (MonadAppError m, MonadFinance m)
=> NE.NonEmpty AcntType => NE.NonEmpty AcntType
-> AcntID -> AcntID
-> m () -> m ()
@ -229,7 +229,7 @@ checkAcntTypes ts i = void $ go =<< lookupAccountType i
where where
go t go t
| t `L.elem` ts = return i | t `L.elem` ts = return i
| otherwise = throwError $ InsertException [AccountError i ts] | otherwise = throwError $ AppException [AccountTypeError i ts]
flattenAllo :: SingleAllocation v -> [FlatAllocation v] flattenAllo :: SingleAllocation v -> [FlatAllocation v]
flattenAllo Allocation {alloAmts, alloTo} = fmap go alloAmts flattenAllo Allocation {alloAmts, alloTo} = fmap go alloAmts
@ -275,7 +275,7 @@ allocatePre precision gross = L.mapAccumR go M.empty
let v = let v =
if prePercent if prePercent
then gross *. (preValue / 100) then gross *. (preValue / 100)
else realFracToDecimal' precision preValue else realFracToDecimalP precision preValue
in (mapAdd_ preCategory v m, f {faValue = v}) in (mapAdd_ preCategory v m, f {faValue = v})
allocateTax allocateTax
@ -324,14 +324,14 @@ allocatePost prec aftertax = fmap (fmap go)
where where
go PosttaxValue {postValue, postPercent} go PosttaxValue {postValue, postPercent}
| postPercent = aftertax *. (postValue / 100) | postPercent = aftertax *. (postValue / 100)
| otherwise = realFracToDecimal' prec postValue | otherwise = realFracToDecimalP prec postValue
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- shadow transfers -- shadow transfers
-- TODO this is going to be O(n*m), which might be a problem? -- TODO this is going to be O(n*m), which might be a problem?
addShadowTransfers addShadowTransfers
:: (MonadInsertError m, MonadFinance m) :: (MonadAppError m, MonadFinance m)
=> [ShadowTransfer] => [ShadowTransfer]
-> [Tx CommitR] -> [Tx CommitR]
-> m [Tx CommitR] -> m [Tx CommitR]
@ -342,7 +342,7 @@ addShadowTransfers ms = mapErrors go
return $ tx {txOther = Right <$> es} return $ tx {txOther = Right <$> es}
fromShadow fromShadow
:: (MonadInsertError m, MonadFinance m) :: (MonadAppError m, MonadFinance m)
=> Tx CommitR => Tx CommitR
-> ShadowTransfer -> ShadowTransfer
-> m (Maybe ShadowEntrySet) -> m (Maybe ShadowEntrySet)
@ -354,7 +354,7 @@ fromShadow tx ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stMatch
curRes = lookupCurrencyKey (CurID stCurrency) curRes = lookupCurrencyKey (CurID stCurrency)
shaRes = liftExcept $ shadowMatches stMatch tx 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 shadowMatches TransferMatcher {tmFrom, tmTo, tmDate, tmVal} Tx {txPrimary, txDate} = do
-- NOTE this will only match against the primary entry set since those -- NOTE this will only match against the primary entry set since those
-- are what are guaranteed to exist from a transfer -- are what are guaranteed to exist from a transfer

54
lib/Internal/Database.hs
View File

@ -107,7 +107,7 @@ nukeTables = do
-- toBal = maybe "???" (fmtRational 2) . unValue -- toBal = maybe "???" (fmtRational 2) . unValue
readConfigState readConfigState
:: (MonadInsertError m, MonadSqlQuery m) :: (MonadAppError m, MonadSqlQuery m)
=> Config => Config
-> [Budget] -> [Budget]
-> [History] -> [History]
@ -160,22 +160,23 @@ readConfigState c bs hs = do
resolveScope f = liftExcept $ resolveDaySpan $ f $ scope c resolveScope f = liftExcept $ resolveDaySpan $ f $ scope c
readScopeChanged readScopeChanged
:: (MonadInsertError m, MonadSqlQuery m) :: (MonadAppError m, MonadSqlQuery m)
=> Bool => Bool
-> BudgetSpan -> BudgetSpan
-> HistorySpan -> HistorySpan
-> m (Bool, Bool) -> m (Bool, Bool)
readScopeChanged dbempty bscope hscope = do readScopeChanged dbempty bscope hscope = do
rs <- dumpTbl rs <- dumpTbl
-- TODO these errors should only fire when someone messed with the DB
case rs of case rs of
[] -> if dbempty then return (True, True) else throwError undefined [] -> if dbempty then return (True, True) else throwAppError $ DBError DBShouldBeEmpty
[r] -> do [r] -> do
let (ConfigStateR h b) = E.entityVal r let (ConfigStateR h b) = E.entityVal r
return (bscope /= b, hscope /= h) return (bscope /= b, hscope /= h)
_ -> throwError undefined _ -> throwAppError $ DBError DBMultiScope
makeTxCRUD makeTxCRUD
:: (MonadInsertError m, MonadSqlQuery m, Hashable a) :: (MonadAppError m, MonadSqlQuery m, Hashable a)
=> ExistingConfig => ExistingConfig
-> [a] -> [a]
-> [CommitHash] -> [CommitHash]
@ -354,9 +355,10 @@ trimNames = fmap (AcntID . T.intercalate "_") . go []
(_ :| []) -> [key : prev] (_ :| []) -> [key : prev]
([] :| xs) -> ([] :| xs) ->
let next = key : prev 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 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 :: Ord a => [NonEmpty a] -> [(a, NonEmpty [a])]
groupNonEmpty = fmap (second (NE.tail <$>)) . groupWith NE.head groupNonEmpty = fmap (second (NE.tail <$>)) . groupWith NE.head
@ -453,7 +455,7 @@ readInvalidIds ExistingConfig {ecAccounts, ecCurrencies, ecTags} xs = do
. groupKey id . groupKey id
readUpdates readUpdates
:: (MonadInsertError m, MonadSqlQuery m) :: (MonadAppError m, MonadSqlQuery m)
=> [CommitHash] => [CommitHash]
-> m ([ReadEntry], [Either TotalUpdateEntrySet FullUpdateEntrySet]) -> m ([ReadEntry], [Either TotalUpdateEntrySet FullUpdateEntrySet])
readUpdates hashes = do readUpdates hashes = do
@ -517,7 +519,7 @@ readUpdates hashes = do
, utToRO = toRO , utToRO = toRO
, utFromUnk = fromUnk , utFromUnk = fromUnk
, utToUnk = toUnk , utToUnk = toUnk
, utTotalValue = realFracToDecimal' prec' tot , utTotalValue = realFracToDecimalP prec' tot
, utBudget = E.unValue name , utBudget = E.unValue name
, utPriority = E.unValue pri , utPriority = E.unValue pri
} }
@ -536,7 +538,8 @@ readUpdates hashes = do
, utBudget = E.unValue name , utBudget = E.unValue name
, utPriority = E.unValue pri , utPriority = E.unValue pri
} }
_ -> throwError undefined -- TODO this error is lame
_ -> throwAppError $ DBError $ DBUpdateUnbalanced
makeRE ((_, day, name, pri, (curID, prec)), entry) = do makeRE ((_, day, name, pri, (curID, prec)), entry) = do
let e = entityVal entry let e = entityVal entry
in ReadEntry in ReadEntry
@ -551,7 +554,7 @@ readUpdates hashes = do
splitFrom splitFrom
:: Precision :: Precision
-> NonEmpty (EntryRId, EntryR) -> 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 splitFrom prec (f0 :| fs) = do
-- ASSUME entries are sorted by index -- ASSUME entries are sorted by index
-- TODO combine errors here -- TODO combine errors here
@ -567,7 +570,7 @@ splitTo
-> Either UEBlank (Either UE_RO UEUnk) -> Either UEBlank (Either UE_RO UEUnk)
-> [UEUnk] -> [UEUnk]
-> NonEmpty (EntryRId, EntryR) -> NonEmpty (EntryRId, EntryR)
-> InsertExcept -> AppExcept
( Either (UEBlank, [UELink]) (Either UE_RO (UEUnk, [UELink])) ( Either (UEBlank, [UELink]) (Either UE_RO (UEUnk, [UELink]))
, [(UEUnk, [UELink])] , [(UEUnk, [UELink])]
, UEBlank , UEBlank
@ -621,7 +624,7 @@ zipPaired
:: Precision :: Precision
-> [UEUnk] -> [UEUnk]
-> [(EntryIndex, NonEmpty (EntryRId, EntryR))] -> [(EntryIndex, NonEmpty (EntryRId, EntryR))]
-> InsertExcept ([(UEUnk, [UELink])], [UE_RO]) -> AppExcept ([(UEUnk, [UELink])], [UE_RO])
zipPaired prec = go ([], []) zipPaired prec = go ([], [])
where where
nolinks = ((,[]) <$>) nolinks = ((,[]) <$>)
@ -639,41 +642,46 @@ zipPaired prec = go ([], [])
let f = maybe (second (++ ros)) (\u -> first (u :)) nextLink let f = maybe (second (++ ros)) (\u -> first (u :)) nextLink
go (f acc') fs' ts go (f acc') fs' ts
makeLinkUnk :: (EntryRId, EntryR) -> InsertExcept UELink makeLinkUnk :: (EntryRId, EntryR) -> AppExcept UELink
makeLinkUnk (k, e) = makeLinkUnk (k, e) =
-- TODO error should state that scale must be present for a link in the db
maybe maybe
(throwError $ InsertException undefined) (throwAppError $ DBError $ DBLinkError k DBLinkNoScale)
(return . makeUE k e . LinkScale) (return . makeUE k e . LinkScale)
$ fromRational <$> entryRCachedValue e $ fromRational <$> entryRCachedValue e
splitDeferredValue :: Precision -> (EntryRId, EntryR) -> InsertExcept (Either UE_RO UEUnk) splitDeferredValue :: Precision -> (EntryRId, EntryR) -> AppExcept (Either UE_RO UEUnk)
splitDeferredValue prec p = do splitDeferredValue prec p@(k, _) = do
res <- readDeferredValue prec p res <- readDeferredValue prec p
case res of case res of
Left _ -> throwError $ InsertException undefined Left _ -> throwAppError $ DBError $ DBLinkError k DBLinkNoValue
Right x -> return x 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 readDeferredValue prec (k, e) = case (entryRCachedValue e, entryRCachedType e) of
(Nothing, Just TFixed) -> return $ Right $ Left $ makeRoUE prec e (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 (Just v, Just TPercent) -> go $ fmap EVPercent $ makeUE k e $ fromRational v
(Nothing, Nothing) -> return $ Left $ makeUnkUE k e (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 where
go = return . Right . Right go = return . Right . Right
err = throwAppError . DBError . DBLinkError k
makeUE :: i -> EntryR -> v -> UpdateEntry i v makeUE :: i -> EntryR -> v -> UpdateEntry i v
makeUE k e v = UpdateEntry k (entryRAccount e) v (entryRIndex e) makeUE k e v = UpdateEntry k (entryRAccount e) v (entryRIndex e)
makeRoUE :: Precision -> EntryR -> UpdateEntry () StaticValue 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 :: EntryRId -> EntryR -> UpdateEntry EntryRId ()
makeUnkUE k e = makeUE k e () makeUnkUE k e = makeUE k e ()
insertAll insertAll
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m) :: (MonadAppError m, MonadSqlQuery m, MonadFinance m)
=> [EntryCRU] => [EntryCRU]
-> m () -> m ()
insertAll ebs = do insertAll ebs = do

77
lib/Internal/History.hs
View File

@ -37,7 +37,7 @@ splitHistory = partitionEithers . fmap go
-- Transfers -- Transfers
readHistTransfer readHistTransfer
:: (MonadInsertError m, MonadFinance m) :: (MonadAppError m, MonadFinance m)
=> PairedTransfer => PairedTransfer
-> m [Tx CommitR] -> m [Tx CommitR]
readHistTransfer ht = do readHistTransfer ht = do
@ -82,9 +82,9 @@ readImport_
-> m [TxRecord] -> m [TxRecord]
readImport_ n delim tns p = do readImport_ n delim tns p = do
res <- tryIO $ BL.readFile p 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 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 Right (_, v) -> return $ catMaybes $ V.toList v
where where
opts = defaultDecodeOptions {decDelimiter = fromIntegral delim} 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 d' <- parseTimeM True defaultTimeLocale (T.unpack toDateFmt) d
return $ Just $ TxRecord d' a e os p 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 matchRecords ms rs = do
(matched, unmatched, notfound) <- matchAll (matchPriorities ms) rs (matched, unmatched, notfound) <- matchAll (matchPriorities ms) rs
case (matched, unmatched, notfound) of case (matched, unmatched, notfound) of
(ms_, [], []) -> return ms_ (ms_, [], []) -> return ms_
(_, us, ns) -> throwError $ InsertException [StatementError us ns] (_, us, ns) -> throwError $ AppException [StatementError us ns]
matchPriorities :: [MatchRe] -> [MatchGroup] matchPriorities :: [MatchRe] -> [MatchGroup]
matchPriorities = matchPriorities =
@ -166,7 +166,7 @@ zipperMatch
:: MonadFinance m :: MonadFinance m
=> Unzipped MatchRe => Unzipped MatchRe
-> TxRecord -> TxRecord
-> InsertExceptT m (Zipped MatchRe, MatchRes (Tx ())) -> AppExceptT m (Zipped MatchRe, MatchRes (Tx ()))
zipperMatch (Unzipped bs cs as) x = go [] cs zipperMatch (Unzipped bs cs as) x = go [] cs
where where
go _ [] = return (Zipped bs $ cs ++ as, MatchFail) go _ [] = return (Zipped bs $ cs ++ as, MatchFail)
@ -183,7 +183,7 @@ zipperMatch'
:: MonadFinance m :: MonadFinance m
=> Zipped MatchRe => Zipped MatchRe
-> TxRecord -> TxRecord
-> InsertExceptT m (Zipped MatchRe, MatchRes (Tx ())) -> AppExceptT m (Zipped MatchRe, MatchRes (Tx ()))
zipperMatch' z x = go z zipperMatch' z x = go z
where where
go (Zipped bs (a : as)) = do go (Zipped bs (a : as)) = do
@ -204,7 +204,7 @@ matchAll
:: MonadFinance m :: MonadFinance m
=> [MatchGroup] => [MatchGroup]
-> [TxRecord] -> [TxRecord]
-> InsertExceptT m ([Tx ()], [TxRecord], [MatchRe]) -> AppExceptT m ([Tx ()], [TxRecord], [MatchRe])
matchAll = go ([], []) matchAll = go ([], [])
where where
go (matched, unused) gs rs = case (gs, rs) of go (matched, unused) gs rs = case (gs, rs) of
@ -218,7 +218,7 @@ matchGroup
:: MonadFinance m :: MonadFinance m
=> MatchGroup => MatchGroup
-> [TxRecord] -> [TxRecord]
-> InsertExceptT m ([Tx ()], [TxRecord], [MatchRe]) -> AppExceptT m ([Tx ()], [TxRecord], [MatchRe])
matchGroup MatchGroup {mgDate = ds, mgNoDate = ns} rs = do matchGroup MatchGroup {mgDate = ds, mgNoDate = ns} rs = do
(md, rest, ud) <- matchDates ds rs (md, rest, ud) <- matchDates ds rs
(mn, unmatched, un) <- matchNonDates ns rest (mn, unmatched, un) <- matchNonDates ns rest
@ -228,7 +228,7 @@ matchDates
:: MonadFinance m :: MonadFinance m
=> [MatchRe] => [MatchRe]
-> [TxRecord] -> [TxRecord]
-> InsertExceptT m ([Tx ()], [TxRecord], [MatchRe]) -> AppExceptT m ([Tx ()], [TxRecord], [MatchRe])
matchDates ms = go ([], [], initZipper ms) matchDates ms = go ([], [], initZipper ms)
where where
go (matched, unmatched, z) [] = go (matched, unmatched, z) [] =
@ -253,7 +253,7 @@ matchNonDates
:: MonadFinance m :: MonadFinance m
=> [MatchRe] => [MatchRe]
-> [TxRecord] -> [TxRecord]
-> InsertExceptT m ([Tx ()], [TxRecord], [MatchRe]) -> AppExceptT m ([Tx ()], [TxRecord], [MatchRe])
matchNonDates ms = go ([], [], initZipper ms) matchNonDates ms = go ([], [], initZipper ms)
where where
go (matched, unmatched, z) [] = go (matched, unmatched, z) [] =
@ -270,7 +270,7 @@ matchNonDates ms = go ([], [], initZipper ms)
MatchFail -> (matched, r : unmatched) MatchFail -> (matched, r : unmatched)
in go (m, u, resetZipper z') rs 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 matches
StatementParser {spTx, spOther, spVal, spDate, spDesc, spPriority} StatementParser {spTx, spOther, spVal, spDate, spDesc, spPriority}
r@TxRecord {trDate, trAmount, trDesc, trOther} = do r@TxRecord {trDate, trAmount, trDesc, trOther} = do
@ -287,7 +287,7 @@ matches
desc = maybe (return True) (matchMaybe (unTxDesc trDesc) . snd) spDesc desc = maybe (return True) (matchMaybe (unTxDesc trDesc) . snd) spDesc
convert tg = MatchPass <$> toTx (fromIntegral spPriority) tg r 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 toTx
priority priority
TxGetter TxGetter
@ -329,7 +329,7 @@ resolveSubGetter
:: MonadFinance m :: MonadFinance m
=> TxRecord => TxRecord
-> TxSubGetter -> TxSubGetter
-> InsertExceptT m SecondayEntrySet -> AppExceptT m SecondayEntrySet
resolveSubGetter r TxSubGetter {tsgFrom, tsgTo, tsgValue, tsgCurrency} = do resolveSubGetter r TxSubGetter {tsgFrom, tsgTo, tsgValue, tsgCurrency} = do
m <- asks csCurrencyMap m <- asks csCurrencyMap
cur <- liftInner $ resolveCurrency m r tsgCurrency cur <- liftInner $ resolveCurrency m r tsgCurrency
@ -347,12 +347,12 @@ resolveSubGetter r TxSubGetter {tsgFrom, tsgTo, tsgValue, tsgCurrency} = do
} }
resolveHalfEntry resolveHalfEntry
:: (Precision -> TxRecord -> n -> InsertExcept v') :: (Precision -> TxRecord -> n -> AppExcept v')
-> Precision -> Precision
-> TxRecord -> TxRecord
-> v -> v
-> TxHalfGetter (EntryGetter n) -> TxHalfGetter (EntryGetter n)
-> InsertExcept (HalfEntrySet v v') -> AppExcept (HalfEntrySet v v')
resolveHalfEntry f prec r v TxHalfGetter {thgAcnt, thgComment, thgTags, thgEntries} = resolveHalfEntry f prec r v TxHalfGetter {thgAcnt, thgComment, thgTags, thgEntries} =
combineError acntRes esRes $ \a es -> combineError acntRes esRes $ \a es ->
HalfEntrySet HalfEntrySet
@ -369,7 +369,7 @@ resolveHalfEntry f prec r v TxHalfGetter {thgAcnt, thgComment, thgTags, thgEntri
acntRes = resolveAcnt r thgAcnt acntRes = resolveAcnt r thgAcnt
esRes = mapErrors (resolveEntry f prec r) thgEntries 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 otherMatches dict m = case m of
Val (Field n mv) -> valMatches mv =<< (readRational =<< lookup_ MatchNumeric n) Val (Field n mv) -> valMatches mv =<< (readRational =<< lookup_ MatchNumeric n)
Desc (Field n (_, md)) -> (`matchMaybe` md) =<< lookup_ MatchText 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 lookup_ t n = lookupErr (MatchField t) n dict
resolveEntry resolveEntry
:: (Precision -> TxRecord -> n -> InsertExcept v) :: (Precision -> TxRecord -> n -> AppExcept v)
-> Precision -> Precision
-> TxRecord -> TxRecord
-> EntryGetter n -> EntryGetter n
-> InsertExcept (Entry AcntID v TagID) -> AppExcept (Entry AcntID v TagID)
resolveEntry f prec r s@Entry {eAcnt, eValue} = resolveEntry f prec r s@Entry {eAcnt, eValue} =
combineError acntRes valRes $ \a v -> s {eAcnt = a, eValue = v} combineError acntRes valRes $ \a v -> s {eAcnt = a, eValue = v}
where where
acntRes = resolveAcnt r eAcnt acntRes = resolveAcnt r eAcnt
valRes = f prec r eValue valRes = f prec r eValue
resolveFromValue :: Precision -> TxRecord -> EntryNumGetter -> InsertExcept EntryValue resolveFromValue :: Precision -> TxRecord -> EntryNumGetter -> AppExcept EntryValue
resolveFromValue = resolveValue resolveFromValue = resolveValue
resolveToValue :: Precision -> TxRecord -> LinkedEntryNumGetter -> InsertExcept EntryLink resolveToValue :: Precision -> TxRecord -> LinkedEntryNumGetter -> AppExcept EntryLink
resolveToValue _ _ (Linked l) = return $ LinkIndex l resolveToValue _ _ (Linked l) = return $ LinkIndex l
resolveToValue prec r (Getter g) = LinkValue <$> resolveValue prec r g 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 resolveValue prec TxRecord {trOther, trAmount} s = case s of
(LookupN t) -> EntryFixed . go <$> (readDouble =<< lookupErr EntryValField t trOther) (LookupN t) -> EntryFixed . go <$> (readDouble =<< lookupErr EntryValField t trOther)
(ConstN c) -> return $ EntryFixed $ go c (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 BalanceN x -> return $ EntryBalance $ go x
PercentN x -> return $ EntryPercent x PercentN x -> return $ EntryPercent x
where 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) 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 resolveCurrency m r c = do
i <- resolveEntryField CurField r (unCurID <$> c) i <- resolveEntryField CurField r (unCurID <$> c)
case M.lookup (CurID i) m of case M.lookup (CurID i) m of
Just k -> return k Just k -> return k
-- TODO this should be its own error (I think) Nothing -> throwError $ AppException [LookupError (DBKey CurField) i]
Nothing -> throwError $ InsertException [LookupError (EntryIDField CurField) undefined]
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 resolveEntryField t TxRecord {trOther = o} s = case s of
ConstT p -> return p ConstT p -> return p
LookupT f -> lookup_ f o 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) (,) (k1, k2) <- combineError (lookup_ f1 o) (lookup_ f2 o) (,)
lookup_ (k1, k2) m lookup_ (k1, k2) m
where 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) lookup_ = lookupErr (EntryIDField t)
readDouble :: T.Text -> InsertExcept Double readDouble :: T.Text -> AppExcept Double
readDouble s = case readMaybe $ T.unpack s of readDouble s = case readMaybe $ T.unpack s of
Just x -> return x 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 readRational s = case T.split (== '.') s of
[x] -> maybe err (return . fromInteger) $ readT x [x] -> maybe err (return . fromInteger) $ readT x
[x, y] -> case (readT x, readT y) of [x, y] -> case (readT x, readT y) of
@ -447,14 +446,14 @@ readRational s = case T.split (== '.') s of
_ -> err _ -> err
where where
readT = readMaybe . T.unpack 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 compileOptions o@TxOpts {toAmountFmt = pat} = do
re <- compileRegex True pat re <- compileRegex True pat
return $ o {toAmountFmt = re} return $ o {toAmountFmt = re}
compileMatch :: StatementParser T.Text -> InsertExcept MatchRe compileMatch :: StatementParser T.Text -> AppExcept MatchRe
compileMatch m@StatementParser {spDesc, spOther} = do compileMatch m@StatementParser {spDesc, spOther} = do
combineError dres ores $ \d os -> m {spDesc = d, spOther = os} combineError dres ores $ \d os -> m {spDesc = d, spOther = os}
where where
@ -462,10 +461,10 @@ compileMatch m@StatementParser {spDesc, spOther} = do
dres = mapM go spDesc dres = mapM go spDesc
ores = combineErrors $ fmap (mapM go) spOther 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 compileRegex groups pat = case res of
Right re -> return (pat, re) Right re -> return (pat, re)
Left _ -> throwError $ InsertException [RegexError pat] Left _ -> throwError $ AppException [RegexError pat]
where where
res = res =
compile compile
@ -473,10 +472,10 @@ compileRegex groups pat = case res of
(blankExecOpt {captureGroups = groups}) (blankExecOpt {captureGroups = groups})
pat pat
matchMaybe :: T.Text -> Regex -> InsertExcept Bool matchMaybe :: T.Text -> Regex -> AppExcept Bool
matchMaybe q re = case execute re q of matchMaybe q re = case execute re q of
Right res -> return $ isJust res 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 :: T.Text -> Regex -> [T.Text]
matchGroupsMaybe q re = case regexec re q of matchGroupsMaybe q re = case regexec re q of

56
lib/Internal/Types/Main.hs
View File

@ -26,6 +26,8 @@ import Text.Regex.TDFA
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- database cache types -- database cache types
type MonadFinance = MonadReader ConfigState
data DeleteTxs = DeleteTxs data DeleteTxs = DeleteTxs
{ dtTxs :: ![TransactionRId] { dtTxs :: ![TransactionRId]
, dtEntrySets :: ![EntrySetRId] , dtEntrySets :: ![EntrySetRId]
@ -36,6 +38,7 @@ data DeleteTxs = DeleteTxs
type CDOps c d = CRUDOps [c] () () [d] type CDOps c d = CRUDOps [c] () () [d]
-- TODO split the entry stuff from the account metadata stuff
data ConfigState = ConfigState data ConfigState = ConfigState
{ csCurrencies :: !(CDOps (Entity CurrencyR) CurrencyRId) { csCurrencies :: !(CDOps (Entity CurrencyR) CurrencyRId)
, csAccounts :: !(CDOps (Entity AccountR) AccountRId) , csAccounts :: !(CDOps (Entity AccountR) AccountRId)
@ -142,8 +145,6 @@ data EntryCRU
| ToRead ReadEntry | ToRead ReadEntry
| ToInsert (Tx CommitR) | ToInsert (Tx CommitR)
type MonadFinance = MonadReader ConfigState
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
-- misc -- misc
@ -240,8 +241,6 @@ data MatchRes a = MatchPass !a | MatchFail | MatchSkip
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- exception types -- exception types
data BalanceType = TooFewEntries | NotOneBlank deriving (Show)
data MatchType = MatchNumeric | MatchText deriving (Show) data MatchType = MatchNumeric | MatchText deriving (Show)
data EntryIDType = AcntField | CurField | TagField deriving (Show) data EntryIDType = AcntField | CurField | TagField deriving (Show)
@ -253,42 +252,49 @@ data LookupSuberr
| DBKey !EntryIDType | DBKey !EntryIDType
deriving (Show) deriving (Show)
data AllocationSuberr
= NoAllocations
| ExceededTotal
| MissingBlank
| TooManyBlanks
deriving (Show)
data PatternSuberr = ZeroLength | ZeroRepeats 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 = RegexError !T.Text
| MatchValPrecisionError !Natural !Natural | MatchValPrecisionError !Natural !Natural
| AccountError !AcntID !(NE.NonEmpty AcntType) | AccountTypeError !AcntID !(NE.NonEmpty AcntType)
| InsertIOError !T.Text | StatementIOError !T.Text
| ParseError !T.Text | ParseError !T.Text
| ConversionError !T.Text | ConversionError !T.Text !Bool
| IndexError !(Entry AcntID LinkedNumGetter TagID) !Day
| RoundError !CurID
| LookupError !LookupSuberr !T.Text | LookupError !LookupSuberr !T.Text
| IncomeError !Day !T.Text !Rational | DatePatternError !Natural !Natural !(Maybe Natural) !PatternSuberr
| PatternError !Natural !Natural !(Maybe Natural) !PatternSuberr
| DaySpanError !Gregorian !(Maybe Gregorian) | DaySpanError !Gregorian !(Maybe Gregorian)
| StatementError ![TxRecord] ![MatchRe] | StatementError ![TxRecord] ![MatchRe]
| PeriodError !Day !Day | PeriodError !Day !Day
| LinkError !EntryIndex !EntryIndex
| DBError !DBSubError
deriving (Show) deriving (Show)
newtype InsertException = InsertException [InsertError] newtype AppException = AppException [AppError]
deriving (Show, Semigroup) via [InsertError] 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) type MatchRe = StatementParser (T.Text, Regex)

191
lib/Internal/Utils.hs
View File

@ -8,6 +8,7 @@ module Internal.Utils
, resolveDaySpan , resolveDaySpan
, resolveDaySpan_ , resolveDaySpan_
, intersectDaySpan , intersectDaySpan
, throwAppError
, liftInner , liftInner
, liftExceptT , liftExceptT
, liftExcept , liftExcept
@ -28,7 +29,6 @@ module Internal.Utils
, mapErrorsIO , mapErrorsIO
, mapErrorsPooledIO , mapErrorsPooledIO
, showError , showError
, tshow
, lookupErr , lookupErr
, uncurry3 , uncurry3
, dateMatches , dateMatches
@ -49,7 +49,7 @@ module Internal.Utils
, entryPair , entryPair
, singleQuote , singleQuote
, keyVals , keyVals
, realFracToDecimal' , realFracToDecimalP
, roundToP , roundToP
) )
where where
@ -58,6 +58,7 @@ import Control.Monad.Error.Class
import Control.Monad.Except import Control.Monad.Except
import Data.Decimal import Data.Decimal
import Data.Time.Format.ISO8601 import Data.Time.Format.ISO8601
import qualified Database.Esqueleto.Experimental as E
import GHC.Real import GHC.Real
import Internal.Types.Main import Internal.Types.Main
import RIO import RIO
@ -72,7 +73,7 @@ import qualified RIO.Vector as V
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- intervals -- intervals
expandDatePat :: DaySpan -> DatePat -> InsertExcept [Day] expandDatePat :: DaySpan -> DatePat -> AppExcept [Day]
expandDatePat b (Cron cp) = expandCronPat b cp expandDatePat b (Cron cp) = expandCronPat b cp
expandDatePat i (Mod mp) = return $ expandModPat mp i 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 Month -> addGregorianMonthsClip
Year -> addGregorianYearsClip Year -> addGregorianYearsClip
expandCronPat :: DaySpan -> CronPat -> InsertExcept [Day] expandCronPat :: DaySpan -> CronPat -> AppExcept [Day]
expandCronPat b CronPat {cpYear, cpMonth, cpDay, cpWeekly} = expandCronPat b CronPat {cpYear, cpMonth, cpDay, cpWeekly} =
combineError3 yRes mRes dRes $ \ys ms ds -> combineError3 yRes mRes dRes $ \ys ms ds ->
filter validWeekday $ filter validWeekday $
@ -122,14 +123,14 @@ expandCronPat b CronPat {cpYear, cpMonth, cpDay, cpWeekly} =
| m `elem` [4, 6, 9, 11] && d > 30 = Nothing | m `elem` [4, 6, 9, 11] && d > 30 = Nothing
| otherwise = Just $ fromGregorian y m d | 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 (Single x) = return [x | lower <= x && x <= upper]
expandMDYPat lower upper (Multi xs) = return $ dropWhile (<= lower) $ takeWhile (<= upper) xs expandMDYPat lower upper (Multi xs) = return $ dropWhile (<= lower) $ takeWhile (<= upper) xs
expandMDYPat lower upper (After x) = return [max lower x .. upper] expandMDYPat lower upper (After x) = return [max lower x .. upper]
expandMDYPat lower upper (Before x) = return [lower .. min upper x] 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 (Between x y) = return [max lower x .. min upper y]
expandMDYPat lower upper (Repeat RepeatPat {rpStart = s, rpBy = b, rpRepeats = r}) 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 | otherwise = do
k <- limit r k <- limit r
return $ dropWhile (<= lower) $ takeWhile (<= k) [s + i * b | i <- [0 ..]] 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) limit (Just n)
-- this guard not only produces the error for the user but also protects -- this guard not only produces the error for the user but also protects
-- from an underflow below it -- 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 | otherwise = return $ min (s + b * (n - 1)) upper
dayToWeekday :: Day -> Int dayToWeekday :: Day -> Int
dayToWeekday (ModifiedJulianDay d) = mod (fromIntegral d + 2) 7 dayToWeekday (ModifiedJulianDay d) = mod (fromIntegral d + 2) 7
askDays askDays
:: (MonadFinance m, MonadInsertError m) :: (MonadFinance m, MonadAppError m)
=> DatePat => DatePat
-> Maybe Interval -> Maybe Interval
-> m [Day] -> m [Day]
@ -224,7 +225,7 @@ inDaySpan bs = withinDays (fromDaySpan bs)
withinDays :: (Day, Day) -> Day -> Bool withinDays :: (Day, Day) -> Day -> Bool
withinDays (d0, d1) x = d0 <= x && x < d1 withinDays (d0, d1) x = d0 <= x && x < d1
resolveDaySpan :: Interval -> InsertExcept DaySpan resolveDaySpan :: Interval -> AppExcept DaySpan
resolveDaySpan i@Interval {intStart = s} = resolveDaySpan i@Interval {intStart = s} =
resolveDaySpan_ (s {gYear = gYear s + 50}) i resolveDaySpan_ (s {gYear = gYear s + 50}) i
@ -237,14 +238,14 @@ intersectDaySpan a b =
a' = max a0 a1 a' = max a0 a1
b' = min b0 b1 b' = min b0 b1
resolveDaySpan_ :: Gregorian -> Interval -> InsertExcept DaySpan resolveDaySpan_ :: Gregorian -> Interval -> AppExcept DaySpan
resolveDaySpan_ def Interval {intStart = s, intEnd = e} = resolveDaySpan_ def Interval {intStart = s, intEnd = e} =
-- TODO the default isn't checked here :/ -- TODO the default isn't checked here :/
case fromGregorian' <$> e of case fromGregorian' <$> e of
Nothing -> return $ toDaySpan_ $ fromGregorian' def Nothing -> return $ toDaySpan_ $ fromGregorian' def
Just e_ Just e_
| s_ < e_ -> return $ toDaySpan_ e_ | s_ < e_ -> return $ toDaySpan_ e_
| otherwise -> throwError $ InsertException [DaySpanError s e] | otherwise -> throwAppError $ DaySpanError s e
where where
s_ = fromGregorian' s s_ = fromGregorian' s
toDaySpan_ end = toDaySpan (s_, end) toDaySpan_ end = toDaySpan (s_, end)
@ -259,9 +260,9 @@ toDaySpan (a, b) = (a, fromIntegral $ diffDays b a - 1)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- matching -- matching
valMatches :: ValMatcher -> Rational -> InsertExcept Bool valMatches :: ValMatcher -> Rational -> AppExcept Bool
valMatches ValMatcher {vmDen, vmSign, vmNum, vmPrec} x 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 = | otherwise =
return $ return $
checkMaybe (s ==) vmSign checkMaybe (s ==) vmSign
@ -279,6 +280,9 @@ dateMatches md = (EQ ==) . compareDate md
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- error flow control -- 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 :: Monad m => ExceptT e Identity a -> ExceptT e m a
liftInner = mapExceptT (return . runIdentity) 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 :: MonadError e m => Except e a -> m a
liftExcept = either throwError return . runExcept liftExcept = either throwError return . runExcept
liftIOExceptT :: MonadIO m => InsertExceptT m a -> m a liftIOExceptT :: MonadIO m => AppExceptT m a -> m a
liftIOExceptT = fromEither <=< runExceptT liftIOExceptT = fromEither <=< runExceptT
liftIOExcept :: MonadIO m => InsertExcept a -> m a liftIOExcept :: MonadIO m => AppExcept a -> m a
liftIOExcept = fromEither . runExcept 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 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 combineError_ a b = do
_ <- catchError a $ \e -> _ <- catchError a $ \e ->
throwError =<< catchError (e <$ b) (return . (e <>)) throwError =<< catchError (e <$ b) (return . (e <>))
_ <- b _ <- b
return () 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 combineErrorM a b f = do
a' <- catchError a $ \e -> a' <- catchError a $ \e ->
throwError =<< catchError (e <$ b) (return . (e <>)) throwError =<< catchError (e <$ b) (return . (e <>))
f a' =<< b 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 = combineError3 a b c f =
combineError (combineError a b (,)) c $ \(x, y) z -> f x y z 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 combineErrorM3 a b c f = do
combineErrorM (combineErrorM a b (curry return)) c $ \(x, y) z -> f x y z combineErrorM (combineErrorM a b (curry return)) c $ \(x, y) z -> f x y z
mapErrors mapErrors :: (Traversable t, MonadAppError m) => (a -> m b) -> t a -> m (t b)
:: (Traversable t, MonadError InsertException m)
=> (a -> m b)
-> t a
-> m (t b)
-- First, record number of each action. Then try each action. On first failure, -- 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, -- note it's position in the sequence, skip ahead to the untried actions,
-- collect failures and add to the first failure. -- collect failures and add to the first failure.
@ -333,7 +333,7 @@ mapErrors f xs = mapM go $ enumTraversable xs
throwError $ foldr (<>) e es throwError $ foldr (<>) e es
err x = catchError (Nothing <$ x) (pure . Just) 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 combineErrors = mapErrors id
enumTraversable :: (Num n, Traversable t) => t a -> t (n, a) 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 :: MonadUnliftIO m => m a -> m b -> (a -> b -> m c) -> m c
combineErrorIOM2 a b f = do combineErrorIOM2 a b f = do
a' <- catch a $ \(InsertException es) -> a' <- catch a $ \(AppException es) ->
(throwIO . InsertException) (throwIO . AppException)
=<< catch (es <$ b) (\(InsertException es') -> return (es' ++ es)) =<< catch (es <$ b) (\(AppException es') -> return (es' ++ es))
f a' =<< b f a' =<< b
combineErrorIOM3 :: MonadUnliftIO m => m a -> m b -> m c -> (a -> b -> c -> m d) -> m d 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 :: (Traversable t, MonadUnliftIO m) => Int -> (a -> m b) -> t a -> m (t b)
mapErrorsPooledIO t f xs = pooledMapConcurrentlyN t go $ enumTraversable xs mapErrorsPooledIO t f xs = pooledMapConcurrentlyN t go $ enumTraversable xs
where 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 es <- fmap catMaybes $ mapM (err . f) $ drop (n + 1) $ toList xs
throwIO $ InsertException $ foldr (<>) e es throwIO $ AppException $ foldr (<>) e es
err x = catch (Nothing <$ x) $ \(InsertException es) -> pure $ Just 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 :: (Traversable t, MonadUnliftIO m) => (a -> m b) -> t a -> m (t b)
mapErrorsIO f xs = mapM go $ enumTraversable xs mapErrorsIO f xs = mapM go $ enumTraversable xs
where 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 es <- fmap catMaybes $ mapM (err . f) $ drop (n + 1) $ toList xs
throwIO $ InsertException $ foldr (<>) e es throwIO $ AppException $ foldr (<>) e es
err x = catch (Nothing <$ x) $ \(InsertException es) -> pure $ Just es err x = catch (Nothing <$ x) $ \(AppException es) -> pure $ Just es
collectErrorsIO :: (Traversable t, MonadUnliftIO m) => t (m a) -> m (t a) collectErrorsIO :: (Traversable t, MonadUnliftIO m) => t (m a) -> m (t a)
collectErrorsIO = mapErrorsIO id 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 lookupErr what k m = case M.lookup k m of
Just x -> return x Just x -> return x
_ -> throwError $ InsertException [LookupError what $ tshow k] _ -> throwAppError $ LookupError what $ tshow k
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- error display -- error display
showError :: InsertError -> [T.Text] showError :: AppError -> [T.Text]
showError other = case other of showError other = case other of
(StatementError ts ms) -> (tshowx <$> ts) ++ (showMatch <$> ms) (StatementError ts ms) -> (showTx <$> ts) ++ (showMatch <$> ms)
(DaySpanError a b) -> (DaySpanError a b) ->
[T.unwords ["Could not create bounds from", showGregorian_ a, "and", showGreg b]] [T.unwords ["Could not create bounds from", showGregorian_ a, "and", showGreg b]]
where where
showGreg (Just g) = showGregorian_ g showGreg (Just g) = showGregorian_ g
showGreg Nothing = "Inf" showGreg Nothing = "Inf"
(AccountError a ts) -> (AccountTypeError a ts) ->
[ T.unwords [ T.unwords
[ "account type of key" [ "account type of key"
, singleQuote $ unAcntID a , singleQuote $ unAcntID a
@ -403,7 +403,7 @@ showError other = case other of
] ]
where where
ts_ = T.intercalate ", " $ NE.toList $ fmap atName ts 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 where
pat = pat =
keyVals $ keyVals $
@ -418,8 +418,15 @@ showError other = case other of
ZeroLength -> "Zero repeat length" ZeroLength -> "Zero repeat length"
ZeroRepeats -> "Zero repeats" ZeroRepeats -> "Zero repeats"
(RegexError re) -> [T.append "could not make regex from pattern: " re] (RegexError re) -> [T.append "could not make regex from pattern: " re]
(ConversionError x) -> [T.append "Could not convert to rational number: " x] (ConversionError x isDouble) ->
(InsertIOError msg) -> [T.append "IO Error: " msg] [ 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] (ParseError msg) -> [T.append "Parse Error: " msg]
(MatchValPrecisionError d p) -> (MatchValPrecisionError d p) ->
[T.unwords ["Match denominator", tshow d, "must be less than", tshow 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" idName TagField = "tag"
matchName MatchNumeric = "numeric" matchName MatchNumeric = "numeric"
matchName MatchText = "text" 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) -> (PeriodError start next) ->
[ T.unwords [ T.unwords
[ "First pay period on " [ "First pay period on "
@ -455,28 +452,40 @@ showError other = case other of
, singleQuote $ tshow next , singleQuote $ tshow next
] ]
] ]
(IndexError Entry {eValue = LinkedNumGetter {lngIndex}, eAcnt} day) -> (LinkError i m) ->
[ T.unwords [ T.unwords
[ "No credit entry for index" [ "entry index"
, singleQuote $ tshow lngIndex , singleQuote $ tshow i
, "for entry with account" , "out of range: max index is"
, singleQuote $ unAcntID eAcnt , singleQuote $ tshow m
, "on"
, tshow day
] ]
] ]
(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 [ T.unwords
[ "Could not look up precision for currency" [ if isfixed
, singleQuote $ unCurID cur 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 -> T.Text
showGregorian_ Gregorian {gYear, gMonth, gDay} = T.intercalate "-" $ tshow <$> [gYear, gMonth, gDay] showGregorian_ Gregorian {gYear, gMonth, gDay} = T.intercalate "-" $ tshow <$> [gYear, gMonth, gDay]
tshowx :: TxRecord -> T.Text showTx :: TxRecord -> T.Text
tshowx TxRecord {trDate = d, trAmount = v, trDesc = e, trFile = f} = showTx TxRecord {trDate = d, trAmount = v, trDesc = e, trFile = f} =
T.append "Unmatched transaction: " $ T.append "Unmatched transaction: " $
keyVals keyVals
[ ("path", T.pack f) [ ("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 :: (a -> b -> c -> d) -> (a, b, c) -> d
uncurry3 f (a, b, c) = f a b c 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 lookupAccount = lookupFinance AcntField csAccountMap
lookupAccountKey :: (MonadInsertError m, MonadFinance m) => AcntID -> m AccountRId lookupAccountKey :: (MonadAppError m, MonadFinance m) => AcntID -> m AccountRId
lookupAccountKey = fmap fst . lookupAccount lookupAccountKey = fmap fst . lookupAccount
lookupAccountType :: (MonadInsertError m, MonadFinance m) => AcntID -> m AcntType lookupAccountType :: (MonadAppError m, MonadFinance m) => AcntID -> m AcntType
lookupAccountType = fmap snd . lookupAccount lookupAccountType = fmap snd . lookupAccount
lookupCurrency :: (MonadInsertError m, MonadFinance m) => CurID -> m CurrencyPrec lookupCurrency :: (MonadAppError m, MonadFinance m) => CurID -> m CurrencyPrec
lookupCurrency = lookupFinance CurField csCurrencyMap lookupCurrency = lookupFinance CurField csCurrencyMap
lookupCurrencyKey :: (MonadInsertError m, MonadFinance m) => CurID -> m CurrencyRId lookupCurrencyKey :: (MonadAppError m, MonadFinance m) => CurID -> m CurrencyRId
lookupCurrencyKey = fmap cpID . lookupCurrency lookupCurrencyKey = fmap cpID . lookupCurrency
lookupCurrencyPrec :: (MonadInsertError m, MonadFinance m) => CurID -> m Precision lookupCurrencyPrec :: (MonadAppError m, MonadFinance m) => CurID -> m Precision
lookupCurrencyPrec = fmap cpPrec . lookupCurrency lookupCurrencyPrec = fmap cpPrec . lookupCurrency
lookupTag :: (MonadInsertError m, MonadFinance m) => TagID -> m TagRId lookupTag :: (MonadAppError m, MonadFinance m) => TagID -> m TagRId
lookupTag = lookupFinance TagField csTagMap lookupTag = lookupFinance TagField csTagMap
lookupFinance lookupFinance
:: (MonadInsertError m, MonadFinance m, Ord k, Show k) :: (MonadAppError m, MonadFinance m, Ord k, Show k)
=> EntryIDType => EntryIDType
-> (ConfigState -> M.Map k a) -> (ConfigState -> M.Map k a)
-> k -> k
@ -619,7 +628,7 @@ lookupFinance
lookupFinance t f c = (liftExcept . lookupErr (DBKey t) c) =<< asks f lookupFinance t f c = (liftExcept . lookupErr (DBKey t) c) =<< asks f
balanceTxs balanceTxs
:: (MonadInsertError m, MonadFinance m) :: (MonadAppError m, MonadFinance m)
=> [EntryCRU] => [EntryCRU]
-> m ([UEBalanced], [InsertTx]) -> m ([UEBalanced], [InsertTx])
balanceTxs ebs = balanceTxs ebs =
@ -796,7 +805,7 @@ updateUnknown k e = do
-- balancing -- balancing
balancePrimaryEntrySet balancePrimaryEntrySet
:: (MonadInsertError m, MonadFinance m) :: (MonadAppError m, MonadFinance m)
=> BudgetName => BudgetName
-> PrimaryEntrySet -> PrimaryEntrySet
-> StateT EntryBals m InsertEntrySet -> StateT EntryBals m InsertEntrySet
@ -821,7 +830,7 @@ balancePrimaryEntrySet
balanceFinal bc (-esTotalValue) fs'' t0' ts' balanceFinal bc (-esTotalValue) fs'' t0' ts'
balanceSecondaryEntrySet balanceSecondaryEntrySet
:: (MonadInsertError m, MonadFinance m) :: (MonadAppError m, MonadFinance m)
=> BudgetName => BudgetName
-> SecondayEntrySet -> SecondayEntrySet
-> StateT EntryBals m InsertEntrySet -> StateT EntryBals m InsertEntrySet
@ -846,7 +855,7 @@ balanceSecondaryEntrySet
bc = (esCurrency, budgetName) bc = (esCurrency, budgetName)
balanceFinal balanceFinal
:: (MonadInsertError m) :: (MonadAppError m)
=> BCKey => BCKey
-> Decimal -> Decimal
-> NonEmpty InsertEntry -> NonEmpty InsertEntry
@ -865,7 +874,7 @@ balanceFinal k@(curID, _) tot fs t0 ts = do
} }
balanceTotalEntrySet balanceTotalEntrySet
:: (MonadInsertError m) :: (MonadAppError m)
=> (ABCKey -> v -> StateT EntryBals m (Decimal, Maybe CachedEntry)) => (ABCKey -> v -> StateT EntryBals m (Decimal, Maybe CachedEntry))
-> BCKey -> BCKey
-> Decimal -> Decimal
@ -890,19 +899,19 @@ liftInnerS :: Monad m => StateT e Identity a -> StateT e m a
liftInnerS = mapStateT (return . runIdentity) liftInnerS = mapStateT (return . runIdentity)
balanceLinked balanceLinked
:: MonadInsertError m :: MonadAppError m
=> Vector Decimal => Vector Decimal
-> ABCKey -> ABCKey
-> EntryLink -> EntryLink
-> StateT EntryBals m (Decimal, Maybe CachedEntry) -> StateT EntryBals m (Decimal, Maybe CachedEntry)
balanceLinked from k lg = case lg of balanceLinked from k lg = case lg of
(LinkIndex LinkedNumGetter {lngIndex, lngScale}) -> do (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 case res of
Just v -> return (v, Just $ CachedLink (EntryIndex $ fromIntegral lngIndex) (LinkScale lngScale)) 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 Nothing -> throwAppError $ LinkError (EntryIndex i) upper
-- file from which it came
Nothing -> throwError undefined
(LinkValue d) -> liftInnerS $ balanceDeferred k d (LinkValue d) -> liftInnerS $ balanceDeferred k d
where where
go s = negate . (*. s) go s = negate . (*. s)
@ -917,7 +926,7 @@ balanceDeferred k e = do
return (newval, d) return (newval, d)
balanceEntry balanceEntry
:: (MonadInsertError m) :: (MonadAppError m)
=> (ABCKey -> v -> StateT EntryBals m (Decimal, Maybe CachedEntry)) => (ABCKey -> v -> StateT EntryBals m (Decimal, Maybe CachedEntry))
-> BCKey -> BCKey
-> Entry AccountRId v TagRId -> Entry AccountRId v TagRId
@ -932,7 +941,7 @@ balanceEntry f k e@Entry {eValue, eAcnt = acntID} = do
} }
resolveAcntAndTags resolveAcntAndTags
:: (MonadInsertError m, MonadFinance m) :: (MonadAppError m, MonadFinance m)
=> Entry AcntID v TagID => Entry AcntID v TagID
-> m (Entry AccountRId v TagRId) -> m (Entry AccountRId v TagRId)
resolveAcntAndTags e@Entry {eAcnt, eTags} = do resolveAcntAndTags e@Entry {eAcnt, eTags} = do
@ -952,7 +961,7 @@ findBalance k e = do
-- transfers -- transfers
expandTransfers expandTransfers
:: (MonadInsertError m, MonadFinance m) :: (MonadAppError m, MonadFinance m)
=> CommitR => CommitR
-> BudgetName -> BudgetName
-> DaySpan -> DaySpan
@ -961,7 +970,7 @@ expandTransfers
expandTransfers tc name bounds = fmap concat . mapErrors (expandTransfer tc name bounds) expandTransfers tc name bounds = fmap concat . mapErrors (expandTransfer tc name bounds)
expandTransfer expandTransfer
:: (MonadInsertError m, MonadFinance m) :: (MonadAppError m, MonadFinance m)
=> CommitR => CommitR
-> BudgetName -> BudgetName
-> DaySpan -> DaySpan
@ -980,7 +989,7 @@ expandTransfer tc name bounds Transfer {transAmounts, transTo, transCurrency, tr
} = do } = do
cp <- lookupCurrency transCurrency cp <- lookupCurrency transCurrency
let v' = (-v) let v' = (-v)
let dec = realFracToDecimal' (cpPrec cp) v' let dec = realFracToDecimalP (cpPrec cp) v'
let v'' = case t of let v'' = case t of
TFixed -> EntryFixed dec TFixed -> EntryFixed dec
TPercent -> EntryPercent v' TPercent -> EntryPercent v'
@ -1021,7 +1030,7 @@ entryPair (TaggedAcnt fa fts) (TaggedAcnt ta tts) curid com totval val1 =
} }
withDates withDates
:: (MonadFinance m, MonadInsertError m) :: (MonadFinance m, MonadAppError m)
=> DaySpan => DaySpan
-> DatePat -> DatePat
-> (Day -> m a) -> (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 :: (Monad m) => (s -> a -> m (s, b)) -> s -> [a] -> m (s, [b])
mapAccumM f s = foldM (\(s', ys) -> fmap (second (: ys)) . f s') (s, []) mapAccumM f s = foldM (\(s', ys) -> fmap (second (: ys)) . f s') (s, [])
realFracToDecimal' :: (Integral i, RealFrac r) => Precision -> r -> DecimalRaw i realFracToDecimalP :: (Integral i, RealFrac r) => Precision -> r -> DecimalRaw i
realFracToDecimal' p = realFracToDecimal (unPrecision p) realFracToDecimalP p = realFracToDecimal (unPrecision p)
roundToP :: Integral i => Precision -> DecimalRaw i -> DecimalRaw i roundToP :: Integral i => Precision -> DecimalRaw i -> DecimalRaw i
roundToP p = roundTo (unPrecision p) roundToP p = roundTo (unPrecision p)