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
split SplitRId
name T.Text
deriving Show Eq
ExpenseBucketR
budgetLabel BudgetLabelRId
bucket T.Text
bucket ExpenseBucket
deriving Show Eq
IncomeBucketR
budgetLabel BudgetLabelRId
bucket T.Text
bucket IncomeBucket
deriving Show Eq
|]
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
-- one/a few cron patterns
cronPatternMatches :: CronPat -> Day -> Bool
cronPatternMatches
CronPat
{ cronWeekly = w
, cronYear = y
, cronMonth = m
, cronDay = d
}
x =
yMaybe y' y && mdMaybe m' m && mdMaybe d' d && wdMaybe (dayOfWeek_ x) w
where
testMaybe = maybe True
yMaybe z = testMaybe (mdyPatternMatches (fromIntegral z))
mdMaybe z = testMaybe (mdyPatternMatches (fromIntegral z))
wdMaybe z = testMaybe (`weekdayPatternMatches` z)
(y', m', d') = toGregorian x
cronPatternMatches CronPat {..} x =
yMaybe y cronYear
&& mdMaybe m cronMonth
&& mdMaybe d cronDay
&& wdMaybe (dayOfWeek_ x) cronWeekly
where
testMaybe = maybe True
yMaybe z = testMaybe (mdyPatternMatches (fromIntegral z))
mdMaybe z = testMaybe (mdyPatternMatches (fromIntegral z))
wdMaybe z = testMaybe (`weekdayPatternMatches` z)
(y, m, d) = toGregorian x
dayOfWeek_ :: Day -> Weekday
dayOfWeek_ d = case dayOfWeek d of
@ -83,6 +79,18 @@ mdyPatternMatches x p = case p of
Repeat (RepeatPat {rpStart = s, rpBy = b, rpRepeats = 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
@ -172,18 +180,6 @@ fromTax meta from Tax {taxAcnt = to, taxValue = v} =
, 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
@ -220,6 +216,41 @@ insertTransfer t@Transfer {..} =
, 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
@ -287,35 +318,6 @@ txPair day from to cur val desc = resolveTx tx
, 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 t@Tx {txSplits = ss} = do
res <- concatEithersL <$> mapM resolveSplit ss
@ -335,55 +337,11 @@ resolveSplit s@Split {sAcnt = p, sCurrency = c, sValue = v} = do
, sValue = v * fromIntegral (sign2Int sign_)
}
-- return $ case (aid, cid, sign) of
-- _ -> Nothing
-- 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
insertTx :: MonadUnliftIO m => Key CommitR -> KeyTx -> SqlPersistT m ()
insertTx c Tx {txDate = d, txDescr = e, txSplits = ss} = do
k <- insert $ TransactionR c d e
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 t Split {sAcnt = aid, sCurrency = cid, sValue = v, sComment = c} = do
insert $ SplitR t cid aid c v

View File

@ -244,12 +244,42 @@ deriving instance Hashable 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 Hashable 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 Hashable TimeAmount