diff --git a/app/Main.hs b/app/Main.hs index 89dee6f..2e55f87 100644 --- a/app/Main.hs +++ b/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 _ tRs tUs _) <- askDBState csHistTrans - (CRUDOps _ sRs sUs _) <- askDBState csHistStmts + (CRUDOps _ bRs bUs _) <- asks csBudgets + (CRUDOps _ tRs tUs _) <- asks csHistTrans + (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 diff --git a/lib/Internal/Budget.hs b/lib/Internal/Budget.hs index 1da9539..0ea61d2 100644 --- a/lib/Internal/Budget.hs +++ b/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] diff --git a/lib/Internal/Database.hs b/lib/Internal/Database.hs index f166c24..5401d55 100644 --- a/lib/Internal/Database.hs +++ b/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 - (Just (DBEntryLinked x s)) -> (Just (toRational s), Nothing, Just $ fromIntegral x) - (Just (DBEntryBalance b)) -> (Just (toRational b), Just TBalance, Nothing) - (Just (DBEntryPercent p)) -> (Just (toRational p), Just TPercent, Nothing) + (cval, ctype, deflink) = case ieCached of + (Just (CachedLink x s)) -> (Just (toRational s), Nothing, Just x) + (Just (CachedBalance b)) -> (Just (toRational b), Just TBalance, Nothing) + (Just (CachedPercent p)) -> (Just (toRational p), Just TPercent, Nothing) Nothing -> (Nothing, Just TFixed, Nothing) updateTx :: MonadSqlQuery m => UEBalanced -> m () diff --git a/lib/Internal/History.hs b/lib/Internal/History.hs index 877e973..fa234ce 100644 --- a/lib/Internal/History.hs +++ b/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 diff --git a/lib/Internal/Types/Main.hs b/lib/Internal/Types/Main.hs index 1b12fbb..476c955 100644 --- a/lib/Internal/Types/Main.hs +++ b/lib/Internal/Types/Main.hs @@ -75,10 +75,10 @@ data CRUDOps c r u d = CRUDOps } deriving (Show) -data DBDeferred - = DBEntryLinked Natural Double - | DBEntryBalance Decimal - | DBEntryPercent Double +data CachedEntry + = CachedLink EntryIndex LinkScale + | CachedBalance Decimal + | 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} - deriving newtype (Num, Show) +newtype LinkScale = LinkScale {unLinkScale :: Double} + 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 - = LinkDeferred EntryValue - | LinkIndex LinkedNumGetter +data EntryLink = LinkValue 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) diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs index 905f0b8..6931fe9 100644 --- a/lib/Internal/Utils.hs +++ b/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 - -> StateT EntryBals m (Decimal, Maybe DBDeferred) + -> EntryLink + -> 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 - EntryPercent v -> Just $ DBEntryPercent v + EntryBalance v -> Just $ CachedBalance 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