REF clean up code

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)

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
+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
     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
+    (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
+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
   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

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