REF clean up useless types

app/Main.hs

@@ -231,11 +231,11 @@ runSync threads c bs hs = do
     -- the database, don't read it but record the commit so we can update it.
     toIns <-
       flip runReaderT state $ do
-        (CRUDOps hSs _ _ _) <- askDBState csHistStmts
+        (CRUDOps hSs _ _ _) <- asks csHistStmts
         hSs' <- mapErrorsIO (readHistStmt root) hSs
-        (CRUDOps hTs _ _ _) <- askDBState csHistTrans
+        (CRUDOps hTs _ _ _) <- asks csHistTrans
         hTs' <- liftIOExceptT $ mapErrors readHistTransfer hTs
-        (CRUDOps bTs _ _ _) <- askDBState csBudgets
+        (CRUDOps bTs _ _ _) <- asks csBudgets
         bTs' <- liftIOExceptT $ mapErrors readBudget bTs
         return $ concat $ hSs' ++ hTs' ++ bTs'
 
@@ -244,9 +244,9 @@ runSync threads c bs hs = do
       -- NOTE this must come first (unless we defer foreign keys)
       updateDBState
       res <- runExceptT $ do
-        (CRUDOps _ bRs bUs _) <- askDBState csBudgets
+        (CRUDOps _ bRs bUs _) <- asks csBudgets
-        (CRUDOps _ tRs tUs _) <- askDBState csHistTrans
+        (CRUDOps _ tRs tUs _) <- asks csHistTrans
-        (CRUDOps _ sRs sUs _) <- askDBState csHistStmts
+        (CRUDOps _ sRs sUs _) <- asks csHistStmts
         let ebs = fmap ToUpdate (bUs ++ tUs ++ sUs) ++ fmap ToRead (bRs ++ tRs ++ sRs) ++ fmap ToInsert toIns
         insertAll ebs
       -- NOTE this rerunnable thing is a bit misleading; fromEither will throw
@@ -259,8 +259,6 @@ runSync threads c bs hs = do
       liftIO $ mapM_ TI.putStrLn $ concatMap showError es
       exitFailure
 
--- showBalances
-
 readConfig :: MonadUnliftIO m => FilePath -> m Config
 readConfig = fmap unfix . readDhall
 

lib/Internal/Budget.hs

@@ -49,7 +49,7 @@ readBudget
           ++ (alloAcnt <$> bgtTax)
           ++ (alloAcnt <$> bgtPosttax)
       getSpan = do
-        globalSpan <- askDBState (unBSpan . csBudgetScope)
+        globalSpan <- asks (unBSpan . csBudgetScope)
         case bgtInterval of
           Nothing -> return $ Just globalSpan
           Just bi -> do
@@ -253,20 +253,22 @@ selectAllos day Allocation {alloAmts, alloTo} =
         , faDesc = amtDesc
         }
 
-allo2Trans :: FlatAllocation Decimal -> Entry AcntID LinkDeferred TagID
+allo2Trans :: FlatAllocation Decimal -> Entry AcntID EntryLink TagID
 allo2Trans FlatAllocation {faValue, faTo = TaggedAcnt {taAcnt, taTags}, faDesc} =
   Entry
-    { eValue = LinkDeferred (EntryFixed faValue)
+    { eValue = LinkValue (EntryFixed faValue)
     , eComment = faDesc
     , eAcnt = AcntID taAcnt
     , eTags = TagID <$> taTags
     }
 
+type PreDeductions = M.Map T.Text Decimal
+
 allocatePre
   :: Precision
   -> Decimal
   -> [FlatAllocation PretaxValue]
-  -> (M.Map T.Text Decimal, [FlatAllocation Decimal])
+  -> (PreDeductions, [FlatAllocation Decimal])
 allocatePre precision gross = L.mapAccumR go M.empty
   where
     go m f@FlatAllocation {faValue = PretaxValue {preCategory, preValue, prePercent}} =
@@ -279,7 +281,7 @@ allocatePre precision gross = L.mapAccumR go M.empty
 allocateTax
   :: Precision
   -> Decimal
-  -> M.Map T.Text Decimal
+  -> PreDeductions
   -> PeriodScaler
   -> [FlatAllocation TaxValue]
   -> [FlatAllocation Decimal]

lib/Internal/Database.hs

@@ -674,7 +674,7 @@ makeUnkUE k e = makeUE k e ()
 
 insertAll
   :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
-  => [EntryBin]
+  => [EntryCRU]
   -> m ()
 insertAll ebs = do
   (toUpdate, toInsert) <- balanceTxs ebs
@@ -692,7 +692,7 @@ insertTx c InsertTx {itxDate, itxDescr, itxEntrySets, itxBudget, itxPriority} =
     insertEntrySet tk i InsertEntrySet {iesCurrency, iesFromEntries, iesToEntries} = do
       let fs = NE.toList iesFromEntries
       let ts = NE.toList iesToEntries
-      let rebalance = any (isJust . ieDeferred) (fs ++ ts)
+      let rebalance = any (isJust . ieCached) (fs ++ ts)
       esk <- insert $ EntrySetR tk iesCurrency i rebalance
       mapM_ (uncurry (go esk)) $ zip [0 ..] ts ++ zip (negate <$> [1 ..]) fs
     go k i e = void $ insertEntry k i e
@@ -703,17 +703,17 @@ insertEntry
   i
   InsertEntry
     { ieEntry = Entry {eValue, eTags, eAcnt, eComment}
-    , ieDeferred
+    , ieCached
     } =
     do
       ek <- insert $ EntryR k eAcnt eComment (toRational eValue) i cval ctype deflink
       mapM_ (insert_ . TagRelationR ek) eTags
       return ek
     where
-      (cval, ctype, deflink) = case ieDeferred of
+      (cval, ctype, deflink) = case ieCached of
-        (Just (DBEntryLinked x s)) -> (Just (toRational s), Nothing, Just $ fromIntegral x)
+        (Just (CachedLink x s)) -> (Just (toRational s), Nothing, Just x)
-        (Just (DBEntryBalance b)) -> (Just (toRational b), Just TBalance, Nothing)
+        (Just (CachedBalance b)) -> (Just (toRational b), Just TBalance, Nothing)
-        (Just (DBEntryPercent p)) -> (Just (toRational p), Just TPercent, Nothing)
+        (Just (CachedPercent p)) -> (Just (toRational p), Just TPercent, Nothing)
         Nothing -> (Nothing, Just TFixed, Nothing)
 
 updateTx :: MonadSqlQuery m => UEBalanced -> m ()

lib/Internal/History.hs

@@ -41,7 +41,7 @@ readHistTransfer
   => PairedTransfer
   -> m [Tx CommitR]
 readHistTransfer ht = do
-  bounds <- askDBState (unHSpan . csHistoryScope)
+  bounds <- asks (unHSpan . csHistoryScope)
   expandTransfer c historyName bounds ht
   where
     c = CommitR (CommitHash $ hash ht) CTHistoryTransfer
@@ -56,7 +56,7 @@ readHistStmt
   -> m [Tx CommitR]
 readHistStmt root i = do
   bs <- readImport root i
-  bounds <- askDBState (unHSpan . csHistoryScope)
+  bounds <- asks (unHSpan . csHistoryScope)
   return $ filter (inDaySpan bounds . txDate) $ fmap (\t -> t {txCommit = c}) bs
   where
     c = CommitR (CommitHash $ hash i) CTHistoryStatement
@@ -317,7 +317,7 @@ toTx
         }
     where
       curRes = do
-        m <- askDBState csCurrencyMap
+        m <- asks csCurrencyMap
         cur <- liftInner $ resolveCurrency m r tgCurrency
         let prec = cpPrec cur
         let fromRes = liftInner $ resolveHalfEntry resolveFromValue prec r () tgFrom
@@ -331,7 +331,7 @@ resolveSubGetter
   -> TxSubGetter
   -> InsertExceptT m SecondayEntrySet
 resolveSubGetter r TxSubGetter {tsgFrom, tsgTo, tsgValue, tsgCurrency} = do
-  m <- askDBState csCurrencyMap
+  m <- asks csCurrencyMap
   cur <- liftInner $ resolveCurrency m r tsgCurrency
   let prec = cpPrec cur
   let toRes = resolveHalfEntry resolveToValue prec r () tsgTo
@@ -391,9 +391,9 @@ resolveEntry f prec r s@Entry {eAcnt, eValue} =
 resolveFromValue :: Precision -> TxRecord -> EntryNumGetter -> InsertExcept EntryValue
 resolveFromValue = resolveValue
 
-resolveToValue :: Precision -> TxRecord -> LinkedEntryNumGetter -> InsertExcept LinkDeferred
+resolveToValue :: Precision -> TxRecord -> LinkedEntryNumGetter -> InsertExcept EntryLink
 resolveToValue _ _ (Linked l) = return $ LinkIndex l
-resolveToValue prec r (Getter g) = LinkDeferred <$> resolveValue prec r g
+resolveToValue prec r (Getter g) = LinkValue <$> resolveValue prec r g
 
 resolveValue :: Precision -> TxRecord -> EntryNumGetter -> InsertExcept EntryValue
 resolveValue prec TxRecord {trOther, trAmount} s = case s of

lib/Internal/Types/Main.hs

@@ -75,10 +75,10 @@ data CRUDOps c r u d = CRUDOps
   }
   deriving (Show)
 
-data DBDeferred
+data CachedEntry
-  = DBEntryLinked Natural Double
+  = CachedLink EntryIndex LinkScale
-  | DBEntryBalance Decimal
+  | CachedBalance Decimal
-  | DBEntryPercent Double
+  | CachedPercent Double
 
 data ReadEntry = ReadEntry
   { reCurrency :: !CurrencyRId
@@ -98,12 +98,10 @@ data UpdateEntry i v = UpdateEntry
   }
   deriving (Show)
 
-data CurrencyRound = CurrencyRound CurID Natural
-
 deriving instance Functor (UpdateEntry i)
 
-newtype LinkScale = LinkScale {unLinkScale :: Decimal}
+newtype LinkScale = LinkScale {unLinkScale :: Double}
-  deriving newtype (Num, Show)
+  deriving newtype (Num, Show, Eq, Ord, Real, Fractional)
 
 newtype StaticValue = StaticValue {unStaticValue :: Decimal}
   deriving newtype (Num, Show)
@@ -139,18 +137,13 @@ type TotalUpdateEntrySet = UpdateEntrySet (UEBlank, [UELink]) Decimal
 
 type FullUpdateEntrySet = UpdateEntrySet (Either UE_RO (UEUnk, [UELink])) ()
 
-data EntryBin
+data EntryCRU
   = ToUpdate (Either TotalUpdateEntrySet FullUpdateEntrySet)
   | ToRead ReadEntry
   | ToInsert (Tx CommitR)
 
-type TreeR = Tree ([T.Text], AccountRId)
-
 type MonadFinance = MonadReader ConfigState
 
-askDBState :: MonadFinance m => (ConfigState -> a) -> m a
-askDBState = asks
-
 -------------------------------------------------------------------------------
 -- misc
 
@@ -190,13 +183,13 @@ type TotalEntrySet v0 vpN vtN = EntrySet v0 () vpN vtN
 
 type FullEntrySet vp0 vpN vtN = EntrySet () vp0 vpN vtN
 
-type PrimaryEntrySet = TotalEntrySet Decimal EntryValue LinkDeferred
+type PrimaryEntrySet = TotalEntrySet Decimal EntryValue EntryLink
 
-type SecondayEntrySet = FullEntrySet EntryValue EntryValue LinkDeferred
+type SecondayEntrySet = FullEntrySet EntryValue EntryValue EntryLink
 
 type TransferEntrySet = SecondayEntrySet
 
-type ShadowEntrySet = TotalEntrySet Double EntryValue LinkDeferred
+type ShadowEntrySet = TotalEntrySet Double EntryValue EntryLink
 
 data TxCommit = HistoryCommit CommitR | BudgetCommit CommitR T.Text
   deriving (Eq, Ord, Show)
@@ -213,7 +206,7 @@ data Tx k = Tx
   deriving (Generic, Show)
 
 data InsertEntry = InsertEntry
-  { ieDeferred :: !(Maybe DBDeferred)
+  { ieCached :: !(Maybe CachedEntry)
   , ieEntry :: !(Entry AccountRId Decimal TagRId)
   }
 
@@ -233,18 +226,13 @@ data InsertTx = InsertTx
   }
   deriving (Generic)
 
-data Deferred a = Deferred Bool a
-  deriving (Show, Functor, Foldable, Traversable)
-
 data EntryValue_ a = EntryValue_ TransferType a
   deriving (Show, Functor, Foldable, Traversable)
 
 data EntryValue = EntryFixed Decimal | EntryPercent Double | EntryBalance Decimal
   deriving (Show, Eq, Ord)
 
-data LinkDeferred
+data EntryLink = LinkValue EntryValue | LinkIndex LinkedNumGetter
-  = LinkDeferred EntryValue
-  | LinkIndex LinkedNumGetter
   deriving (Show)
 
 data MatchRes a = MatchPass !a | MatchFail | MatchSkip
@@ -302,13 +290,6 @@ type InsertExceptT = ExceptT InsertException
 
 type InsertExcept = InsertExceptT Identity
 
-data XGregorian = XGregorian
-  { xgYear :: !Int
-  , xgMonth :: !Int
-  , xgDay :: !Int
-  , xgDayOfWeek :: !Int
-  }
-
 type MatchRe = StatementParser (T.Text, Regex)
 
 type TxOptsRe = TxOpts (T.Text, Regex)

lib/Internal/Utils.hs

@@ -30,9 +30,7 @@ module Internal.Utils
   , showError
   , tshow
   , lookupErr
-  , gregorians
   , uncurry3
-  , xGregToDay
   , dateMatches
   , valMatches
   , lookupAccount
@@ -152,7 +150,7 @@ askDays
   -> Maybe Interval
   -> m [Day]
 askDays dp i = do
-  globalSpan <- askDBState (unBSpan . csBudgetScope)
+  globalSpan <- asks (unBSpan . csBudgetScope)
   case i of
     Just i' -> do
       localSpan <- liftExcept $ resolveDaySpan i'
@@ -174,33 +172,6 @@ fromWeekday Fri = Friday
 fromWeekday Sat = Saturday
 fromWeekday Sun = Sunday
 
--- | find the next date
--- this is meant to go in a very tight loop and be very fast (hence no
--- complex date functions, most of which heavily use 'mod' and friends)
-nextXGreg :: XGregorian -> XGregorian
-nextXGreg XGregorian {xgYear = y, xgMonth = m, xgDay = d, xgDayOfWeek = w}
-  | m == 12 && d == 31 = XGregorian (y + 1) 1 1 w_
-  | (m == 2 && (not leap && d == 28 || (leap && d == 29)))
-      || (m `elem` [4, 6, 9, 11] && d == 30)
-      || (d == 31) =
-      XGregorian y (m + 1) 1 w_
-  | otherwise = XGregorian y m (d + 1) w_
-  where
-    -- don't use DayOfWeek from Data.Time since this uses mod (which uses a
-    -- division opcode) and thus will be slower than just checking for equality
-    -- and adding
-    w_ = if w == 6 then 0 else w + 1
-    leap = isLeapYear $ fromIntegral y
-
-gregorians :: Day -> [XGregorian]
-gregorians x = L.iterate nextXGreg $ XGregorian (fromIntegral y) m d w
-  where
-    (y, m, d) = toGregorian x
-    w = fromEnum $ dayOfWeek x
-
-xGregToDay :: XGregorian -> Day
-xGregToDay XGregorian {xgYear = y, xgMonth = m, xgDay = d} = fromGregorian (fromIntegral y) m d
-
 gregTup :: Gregorian -> (Integer, Int, Int)
 gregTup Gregorian {gYear, gMonth, gDay} =
   ( fromIntegral gYear
@@ -645,11 +616,11 @@ lookupFinance
   -> (ConfigState -> M.Map k a)
   -> k
   -> m a
-lookupFinance t f c = (liftExcept . lookupErr (DBKey t) c) =<< askDBState f
+lookupFinance t f c = (liftExcept . lookupErr (DBKey t) c) =<< asks f
 
 balanceTxs
   :: (MonadInsertError m, MonadFinance m)
-  => [EntryBin]
+  => [EntryCRU]
   -> m ([UEBalanced], [InsertTx])
 balanceTxs ebs =
   first concat . partitionEithers . catMaybes
@@ -684,7 +655,7 @@ balanceTxs ebs =
             (balancePrimaryEntrySet txBudget . fromShadow tot)
         fromShadow tot e@EntrySet {esTotalValue} = e {esTotalValue = tot *. esTotalValue}
 
-binDate :: EntryBin -> (Day, Int)
+binDate :: EntryCRU -> (Day, Int)
 binDate (ToRead ReadEntry {reDate, rePriority}) = (reDate, rePriority)
 binDate (ToInsert Tx {txDate, txPriority}) = (txDate, txPriority)
 binDate (ToUpdate u) = either go go u
@@ -768,7 +739,7 @@ rebalanceDebit k ro linked = do
       return (v, e0' : es')
 
 unlink :: Decimal -> UELink -> UEBalanced
-unlink v e = e {ueValue = StaticValue $ (-v) * unLinkScale (ueValue e)}
+unlink v e = e {ueValue = StaticValue $ (-v) *. unLinkScale (ueValue e)}
 
 rebalanceCredit
   :: BCKey
@@ -880,7 +851,7 @@ balanceFinal
   -> Decimal
   -> NonEmpty InsertEntry
   -> Entry AccountRId () TagRId
-  -> [Entry AccountRId LinkDeferred TagRId]
+  -> [Entry AccountRId EntryLink TagRId]
   -> StateT EntryBals m InsertEntrySet
 balanceFinal k@(curID, _) tot fs t0 ts = do
   let fv = V.fromList $ NE.toList $ fmap (eValue . ieEntry) fs
@@ -895,7 +866,7 @@ balanceFinal k@(curID, _) tot fs t0 ts = do
 
 balanceTotalEntrySet
   :: (MonadInsertError m)
-  => (ABCKey -> v -> StateT EntryBals m (Decimal, Maybe DBDeferred))
+  => (ABCKey -> v -> StateT EntryBals m (Decimal, Maybe CachedEntry))
   -> BCKey
   -> Decimal
   -> Entry AccountRId () TagRId
@@ -909,7 +880,7 @@ balanceTotalEntrySet f k tot e@Entry {eAcnt = acntID} es = do
   let e' =
         InsertEntry
           { ieEntry = e {eValue = e0val, eAcnt = acntID}
-          , ieDeferred = Nothing
+          , ieCached = Nothing
           }
   return $ e' :| es'
   where
@@ -922,42 +893,42 @@ balanceLinked
   :: MonadInsertError m
   => Vector Decimal
   -> ABCKey
-  -> LinkDeferred
+  -> EntryLink
-  -> StateT EntryBals m (Decimal, Maybe DBDeferred)
+  -> StateT EntryBals m (Decimal, Maybe CachedEntry)
 balanceLinked from k lg = case lg of
   (LinkIndex LinkedNumGetter {lngIndex, lngScale}) -> do
     let res = fmap (go lngScale) $ from V.!? fromIntegral lngIndex
     case res of
-      Just v -> return (v, Just $ DBEntryLinked lngIndex 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
       -- file from which it came
       Nothing -> throwError undefined
-  (LinkDeferred d) -> liftInnerS $ balanceDeferred k d
+  (LinkValue d) -> liftInnerS $ balanceDeferred k d
   where
     go s = negate . (*. s)
 
-balanceDeferred :: ABCKey -> EntryValue -> State EntryBals (Decimal, Maybe DBDeferred)
+balanceDeferred :: ABCKey -> EntryValue -> State EntryBals (Decimal, Maybe CachedEntry)
 balanceDeferred k e = do
   newval <- findBalance k e
   let d = case e of
         EntryFixed _ -> Nothing
-        EntryBalance v -> Just $ DBEntryBalance v
+        EntryBalance v -> Just $ CachedBalance v
-        EntryPercent v -> Just $ DBEntryPercent v
+        EntryPercent v -> Just $ CachedPercent v
   return (newval, d)
 
 balanceEntry
   :: (MonadInsertError m)
-  => (ABCKey -> v -> StateT EntryBals m (Decimal, Maybe DBDeferred))
+  => (ABCKey -> v -> StateT EntryBals m (Decimal, Maybe CachedEntry))
   -> BCKey
   -> Entry AccountRId v TagRId
   -> StateT EntryBals m InsertEntry
 balanceEntry f k e@Entry {eValue, eAcnt = acntID} = do
-  (newVal, deferred) <- f (acntID, k) eValue
+  (newVal, cached) <- f (acntID, k) eValue
   modify (mapAdd_ (acntID, k) newVal)
   return $
     InsertEntry
       { ieEntry = e {eValue = newVal, eAcnt = acntID}
-      , ieDeferred = deferred
+      , ieCached = cached
       }
 
 resolveAcntAndTags