From 5059c318ef03f9a70b45658a9e8594bfbd0ed4fc Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Mon, 30 Jan 2023 21:47:17 -0500 Subject: [PATCH] REF clean up code --- lib/Internal/Database/Model.hs | 7 +- lib/Internal/Insert.hs | 162 ++++++++++++--------------------- lib/Internal/Types.hs | 30 ++++++ 3 files changed, 95 insertions(+), 104 deletions(-) diff --git a/lib/Internal/Database/Model.hs b/lib/Internal/Database/Model.hs index e88f8f0..e508a36 100644 --- a/lib/Internal/Database/Model.hs +++ b/lib/Internal/Database/Model.hs @@ -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) diff --git a/lib/Internal/Insert.hs b/lib/Internal/Insert.hs index ad5b60f..97c0e0e 100644 --- a/lib/Internal/Insert.hs +++ b/lib/Internal/Insert.hs @@ -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 diff --git a/lib/Internal/Types.hs b/lib/Internal/Types.hs index c750674..b897798 100644 --- a/lib/Internal/Types.hs +++ b/lib/Internal/Types.hs @@ -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