REF clean up code

This commit is contained in:
Nathan Dwarshuis 2023-01-30 21:47:17 -05:00
parent 7a64ed77f8
commit 5059c318ef
3 changed files with 95 additions and 104 deletions

View File

@ -62,12 +62,15 @@ SplitR sql=splits
BudgetLabelR BudgetLabelR
split SplitRId split SplitRId
name T.Text name T.Text
deriving Show Eq
ExpenseBucketR ExpenseBucketR
budgetLabel BudgetLabelRId budgetLabel BudgetLabelRId
bucket T.Text bucket ExpenseBucket
deriving Show Eq
IncomeBucketR IncomeBucketR
budgetLabel BudgetLabelRId budgetLabel BudgetLabelRId
bucket T.Text bucket IncomeBucket
deriving Show Eq
|] |]
type AccountMap = M.Map AcntID (AccountRId, AcntSign) type AccountMap = M.Map AcntID (AccountRId, AcntSign)

View File

@ -46,21 +46,17 @@ expandModPat
-- TODO this can be optimized to prevent filtering a bunch of dates for -- TODO this can be optimized to prevent filtering a bunch of dates for
-- one/a few cron patterns -- one/a few cron patterns
cronPatternMatches :: CronPat -> Day -> Bool cronPatternMatches :: CronPat -> Day -> Bool
cronPatternMatches cronPatternMatches CronPat {..} x =
CronPat yMaybe y cronYear
{ cronWeekly = w && mdMaybe m cronMonth
, cronYear = y && mdMaybe d cronDay
, cronMonth = m && wdMaybe (dayOfWeek_ x) cronWeekly
, cronDay = d
}
x =
yMaybe y' y && mdMaybe m' m && mdMaybe d' d && wdMaybe (dayOfWeek_ x) w
where where
testMaybe = maybe True testMaybe = maybe True
yMaybe z = testMaybe (mdyPatternMatches (fromIntegral z)) yMaybe z = testMaybe (mdyPatternMatches (fromIntegral z))
mdMaybe z = testMaybe (mdyPatternMatches (fromIntegral z)) mdMaybe z = testMaybe (mdyPatternMatches (fromIntegral z))
wdMaybe z = testMaybe (`weekdayPatternMatches` z) wdMaybe z = testMaybe (`weekdayPatternMatches` z)
(y', m', d') = toGregorian x (y, m, d) = toGregorian x
dayOfWeek_ :: Day -> Weekday dayOfWeek_ :: Day -> Weekday
dayOfWeek_ d = case dayOfWeek d of dayOfWeek_ d = case dayOfWeek d of
@ -83,6 +79,18 @@ mdyPatternMatches x p = case p of
Repeat (RepeatPat {rpStart = s, rpBy = b, rpRepeats = r}) -> Repeat (RepeatPat {rpStart = s, rpBy = b, rpRepeats = r}) ->
s >= x && mod x b == 0 && maybe True (\y -> x <= s + b * y) r s >= x && mod x b == 0 && maybe True (\y -> x <= s + b * y) r
withDates
:: MonadUnliftIO m
=> DatePat
-> (Day -> MappingT m a)
-> MappingT m [a]
withDates dp f = do
bounds <- askBounds
mapM f (expandDatePat bounds dp)
askBounds :: MonadUnliftIO m => MappingT m Bounds
askBounds = (liftIO . resolveBounds) =<< asks kmBudgetInterval
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- budget -- budget
@ -172,18 +180,6 @@ fromTax meta from Tax {taxAcnt = to, taxValue = v} =
, btMeta = meta , btMeta = meta
} }
withDates
:: MonadUnliftIO m
=> DatePat
-> (Day -> MappingT m a)
-> MappingT m [a]
withDates dp f = do
bounds <- askBounds
mapM f (expandDatePat bounds dp)
askBounds :: MonadUnliftIO m => MappingT m Bounds
askBounds = (liftIO . resolveBounds) =<< asks kmBudgetInterval
balanceIncome :: Income -> EitherErr Rational balanceIncome :: Income -> EitherErr Rational
balanceIncome balanceIncome
Income Income
@ -220,6 +216,41 @@ insertTransfer t@Transfer {..} =
, btDesc = desc , btDesc = desc
} }
insertBudgetTx :: MonadUnliftIO m => BudgetTx -> MappingT m [InsertError]
insertBudgetTx BudgetTx {..} = do
res <- splitPair (bsAcnt btFrom) (bsAcnt btTo) (bmCur btMeta) btValue
unlessLefts_ res $ \(sFrom, sTo) -> lift $ do
k <- insert $ TransactionR (bmCommit btMeta) (bmWhen btMeta) btDesc
skFrom <- insertSplit k sFrom
bFrom <- insert $ BudgetLabelR skFrom ""
forM_ (bsBucket btFrom) $ \b ->
insert_ $ IncomeBucketR bFrom b
skTo <- insertSplit k sTo
bTo <- insert $ BudgetLabelR skTo ""
forM_ (bsBucket btTo) $ \b ->
insert_ $ ExpenseBucketR bTo b
splitPair
:: MonadUnliftIO m
=> AcntID
-> AcntID
-> CurID
-> Rational
-> MappingT m (EitherErrs (KeySplit, KeySplit))
splitPair from to cur val = do
s1 <- split from (-val)
s2 <- split to val
return $ concatEithers2 s1 s2 (,)
where
split a v =
resolveSplit $
Split
{ sAcnt = a
, sValue = v
, sComment = ""
, sCurrency = cur
}
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- statements -- statements
@ -287,35 +318,6 @@ txPair day from to cur val desc = resolveTx tx
, txSplits = [split from (-val), split to val] , txSplits = [split from (-val), split to val]
} }
splitPair
:: MonadUnliftIO m
=> AcntID
-> AcntID
-> CurID
-> Rational
-> MappingT m (EitherErrs (KeySplit, KeySplit))
splitPair from to cur val = do
s1 <- split from (-val)
s2 <- split to val
return $ concatEithers2 s1 s2 (,)
where
split a v =
resolveSplit $
Split
{ sAcnt = a
, sValue = v
, sComment = ""
, sCurrency = cur
}
-- tx =
-- Tx
-- { txDescr = desc
-- , txDate = day
-- , txTags = []
-- , txSplits = [split from (-val), split to val]
-- }
resolveTx :: MonadUnliftIO m => BalTx -> MappingT m (EitherErrs KeyTx) resolveTx :: MonadUnliftIO m => BalTx -> MappingT m (EitherErrs KeyTx)
resolveTx t@Tx {txSplits = ss} = do resolveTx t@Tx {txSplits = ss} = do
res <- concatEithersL <$> mapM resolveSplit ss res <- concatEithersL <$> mapM resolveSplit ss
@ -335,55 +337,11 @@ resolveSplit s@Split {sAcnt = p, sCurrency = c, sValue = v} = do
, sValue = v * fromIntegral (sign2Int sign_) , sValue = v * fromIntegral (sign2Int sign_)
} }
-- return $ case (aid, cid, sign) of insertTx :: MonadUnliftIO m => Key CommitR -> KeyTx -> SqlPersistT m ()
-- _ -> Nothing insertTx c Tx {txDate = d, txDescr = e, txSplits = ss} = do
-- insertTax
-- :: MonadUnliftIO m
-- => AcntID
-- -> CurID
-- -> Day
-- -> Key CommitR
-- -> Tax
-- -> MappingT m [InsertError]
-- insertTax from cur day commit Tax {taxAcnt = to, taxValue = amnt} =
-- insertBudgetValue IntraTax Fixed from to cur commit day "" $ dec2Rat amnt
-- insertAllocation
-- :: MonadUnliftIO m
-- => AcntID
-- -> CurID
-- -> IncomeBucket
-- -> Day
-- -> Key CommitR
-- -> Allocation Decimal
-- -> MappingT m [InsertError]
-- insertAllocation from cur ib d c (Allocation to xb as _) = concat <$> mapM go as
-- where
-- go (Amount v desc) = insertBudgetValue ib xb from to cur c d desc $ dec2Rat v
insertBudgetTx :: MonadUnliftIO m => BudgetTx -> MappingT m [InsertError]
insertBudgetTx BudgetTx {..} = do
res <- splitPair (bsAcnt btFrom) (bsAcnt btTo) (bmCur btMeta) btValue
unlessLefts_ res $ \(sFrom, sTo) -> lift $ do
k <- insert $ TransactionR (bmCommit btMeta) (bmWhen btMeta) btDesc
skFrom <- insertSplit k sFrom
bFrom <- insert $ BudgetLabelR skFrom ""
forM_ (bsBucket btFrom) $ \b ->
insert_ $ IncomeBucketR bFrom $ showT b
skTo <- insertSplit k sTo
bTo <- insert $ BudgetLabelR skTo ""
forM_ (bsBucket btTo) $ \b ->
insert_ $ ExpenseBucketR bTo $ showT b
insertTxBucket :: MonadUnliftIO m => Key CommitR -> KeyTx -> SqlPersistT m ()
insertTxBucket c Tx {txDate = d, txDescr = e, txSplits = ss} = do
k <- insert $ TransactionR c d e k <- insert $ TransactionR c d e
mapM_ (insertSplit k) ss mapM_ (insertSplit k) ss
insertTx :: MonadUnliftIO m => Key CommitR -> KeyTx -> SqlPersistT m ()
insertTx = insertTxBucket
insertSplit :: MonadUnliftIO m => Key TransactionR -> KeySplit -> SqlPersistT m (Key SplitR) insertSplit :: MonadUnliftIO m => Key TransactionR -> KeySplit -> SqlPersistT m (Key SplitR)
insertSplit t Split {sAcnt = aid, sCurrency = cid, sValue = v, sComment = c} = do insertSplit t Split {sAcnt = aid, sCurrency = cid, sValue = v, sComment = c} = do
insert $ SplitR t cid aid c v insert $ SplitR t cid aid c v

View File

@ -244,12 +244,42 @@ deriving instance Hashable IncomeBucket
deriving instance Show IncomeBucket deriving instance Show IncomeBucket
deriving instance Read IncomeBucket
toPersistText :: Show a => a -> PersistValue
toPersistText = PersistText . T.pack . show
fromPersistText :: Read a => T.Text -> PersistValue -> Either T.Text a
fromPersistText what (PersistText t) = case readMaybe $ T.unpack t of
Just v -> Right v
Nothing -> Left $ T.unwords ["error when reading", what, "from text:", t]
fromPersistText what x =
Left $ T.unwords ["error when deserializing", what, "; got", T.pack (show x)]
instance PersistField IncomeBucket where
toPersistValue = toPersistText
fromPersistValue = fromPersistText "IncomeBucket"
instance PersistFieldSql IncomeBucket where
sqlType _ = SqlString
deriving instance Eq ExpenseBucket deriving instance Eq ExpenseBucket
deriving instance Hashable ExpenseBucket deriving instance Hashable ExpenseBucket
deriving instance Show ExpenseBucket deriving instance Show ExpenseBucket
deriving instance Read ExpenseBucket
instance PersistField ExpenseBucket where
toPersistValue = toPersistText
fromPersistValue = fromPersistText "ExpenseBucket"
instance PersistFieldSql ExpenseBucket where
sqlType _ = SqlString
deriving instance Eq TimeAmount deriving instance Eq TimeAmount
deriving instance Hashable TimeAmount deriving instance Hashable TimeAmount