diff --git a/lib/Internal/History.hs b/lib/Internal/History.hs index f1291ec..6465976 100644 --- a/lib/Internal/History.hs +++ b/lib/Internal/History.hs @@ -9,6 +9,7 @@ where import Control.Monad.Except import Data.Csv import Data.Foldable +import Database.Persist ((=.)) import Database.Persist.Monad hiding (get) import Internal.Database import Internal.Types.Main @@ -78,9 +79,11 @@ insertHistory -> m () insertHistory hs = do (toUpdate, toInsert) <- balanceTxs hs - forM_ (groupWith txCommit toInsert) $ \(c, ts) -> do - ck <- insert c - mapM_ (insertTx ck) ts + mapM_ updateTx toUpdate + forM_ (groupKey commitRHash $ (\x -> (txCommit x, x)) <$> toInsert) $ + \(c, ts) -> do + ck <- insert $ c + mapM_ (insertTx ck) ts -------------------------------------------------------------------------------- -- low-level transaction stuff @@ -128,6 +131,9 @@ insertTx c Tx {txDate = d, txDescr = e, txEntries = ss} = do k <- insert $ TransactionR c d e anyDeferred mapM_ (insertEntry k) ss +updateTx :: MonadSqlQuery m => UEBalanced -> m () +updateTx UpdateEntry {ueID, ueValue} = update ueID [EntryRValue =. (unEntryValue ueValue)] + -------------------------------------------------------------------------------- -- Statements @@ -334,14 +340,14 @@ balanceTxs -> m ([UEBalanced], [KeyTx CommitR]) balanceTxs es = (first concat . partitionEithers . catMaybes) - <$> evalStateT (mapM go $ L.sortOn binDate es) M.empty + <$> evalStateT (mapErrors go $ L.sortOn binDate es) M.empty where - go (ToUpdate utx) = (Just . Left) <$> rebalanceEntrySet utx + go (ToUpdate utx) = fmap (Just . Left) $ liftInnerS $ rebalanceEntrySet utx go (ToRead ReadEntry {reCurrency, reAcnt, reValue}) = do modify $ mapAdd_ (reAcnt, reCurrency) reValue return Nothing go (ToInsert (t@Tx {txEntries, txDate})) = - (\es -> Just $ Right $ t {txEntries = concat es}) + (\es' -> Just $ Right $ t {txEntries = concat es'}) <$> mapM (balanceEntrySet txDate) txEntries binDate :: EntryBin -> Day @@ -372,7 +378,7 @@ rebalanceEntrySet } = do let fs = - L.sortOn index $ + L.sortOn idx $ (UET_ReadOnly <$> utFromRO) ++ (UET_Balance <$> utFromUnk) ++ (UET_Linked <$> utPairs) @@ -380,11 +386,12 @@ rebalanceEntrySet let f0val = utTotalValue - (sum $ fmap value fs') let f0 = utFrom0 {ueValue = EntryValue f0val} let (tpairs, fs'') = partitionEithers $ concatMap flatten fs' + let tsLink0 = fmap (\e -> e {ueValue = EntryValue $ -f0val * (unLinkScale $ ueValue e)}) utToUnkLink0 let ts = - (UET_Linked <$> tpairs) - ++ (UET_Balance <$> utToUnk) - ++ (UET_ReadOnly <$> utToRO) - let tsLink0 = fmap (\e -> e {ueValue = -f0val * (unLinkScale $ ueValue e)}) utToUnkLink0 + L.sortOn idx2 $ + (UET_Linked <$> (tpairs ++ tsLink0)) + ++ (UET_Balance <$> utToUnk) + ++ (UET_ReadOnly <$> utToRO) (tsRO, tsUnk) <- partitionEithers <$> mapM goTo ts let t0val = (EntryValue utTotalValue) @@ -395,7 +402,8 @@ rebalanceEntrySet project f _ _ (UET_ReadOnly e) = f e project _ f _ (UET_Balance e) = f e project _ _ f (UET_Linked p) = f p - index = project ueIndex ueIndex (ueIndex . fst) + idx = project ueIndex ueIndex (ueIndex . fst) + idx2 = project ueIndex ueIndex ueIndex value = project (unEntryValue . ueValue) @@ -455,8 +463,8 @@ balanceEntrySet -- resolve accounts and balance debit entries since we need an array -- of debit entries for linked credit entries later - let balFromEntry = balanceEntry (balanceDeferred curID) curID - fs' <- doEntries balFromEntry curID esTotalValue f0 fs (NE.iterate (-1) (-1)) + let balFromEntry = balanceEntry (\a -> liftInnerS . balanceDeferred curID a) curID + fs' <- doEntries balFromEntry curID esTotalValue f0 fs (NE.iterate (+ (-1)) (-1)) let fv = V.fromList $ fmap (eValue . feEntry) fs' -- finally resolve credit entries @@ -466,15 +474,15 @@ balanceEntrySet doEntries :: (MonadInsertError m, MonadFinance m) - => (Int -> Entry AcntID v t -> State EntryBals (FullEntry AccountRId CurrencyRId t)) + => (Int -> Entry AcntID v TagID -> StateT EntryBals m (FullEntry AccountRId CurrencyRId TagRId)) -> CurrencyRId -> Rational - -> Entry AcntID () t - -> [Entry AcntID v t] + -> Entry AcntID () TagID + -> [Entry AcntID v TagID] -> NonEmpty Int - -> StateT EntryBals m [FullEntry AccountRId CurrencyRId t] + -> StateT EntryBals m [FullEntry AccountRId CurrencyRId TagRId] doEntries f curID tot e es (i0 :| iN) = do - es' <- liftInnerS $ mapM (uncurry f) $ zip iN es + es' <- mapM (uncurry f) $ zip iN es let val0 = tot - entrySum es' e' <- balanceEntry (\_ _ -> return (val0, Nothing)) curID i0 e return $ e' : es' @@ -485,19 +493,20 @@ liftInnerS :: Monad m => StateT e Identity a -> StateT e m a liftInnerS = mapStateT (return . runIdentity) balanceLinked - :: Vector Rational + :: MonadInsertError m + => Vector Rational -> CurrencyRId -> Natural -> AccountRId -> LinkDeferred Rational - -> StateT EntryBals Identity (Rational, Maybe DBDeferred) + -> StateT EntryBals m (Rational, Maybe DBDeferred) balanceLinked from curID precision acntID lg = case lg of - (LinkIndex g@LinkedNumGetter {lngIndex, lngScale}) -> do + (LinkIndex LinkedNumGetter {lngIndex, lngScale}) -> do let res = fmap (go lngScale) $ from V.!? fromIntegral lngIndex case res of Just v -> return $ (v, Just $ EntryLinked lngIndex $ toRational lngScale) Nothing -> throwError undefined - (LinkDeferred d) -> balanceDeferred curID acntID d + (LinkDeferred d) -> liftInnerS $ balanceDeferred curID acntID d where go s = roundPrecision precision . (* s) . fromRational @@ -515,22 +524,22 @@ balanceEntry => (AccountRId -> v -> StateT EntryBals m (Rational, Maybe DBDeferred)) -> CurrencyRId -> Int - -> Entry AcntID v t - -> StateT EntryBals m (FullEntry AccountRId CurrencyRId t) -balanceEntry f curID index e@Entry {eValue, eAcnt} = do - (acntID, sign, _) <- lookupAccount eAcnt - let s = fromIntegral $ sign2Int sign - (newVal, deferred) <- f acntID eValue - modify (mapAdd_ (acntID, curID) newVal) - return $ - FullEntry - { feEntry = e {eValue = s * newVal, eAcnt = acntID} - , feCurrency = curID - , feDeferred = deferred - , feIndex = index - } - where - key = (eAcnt, curID) + -> Entry AcntID v TagID + -> StateT EntryBals m (FullEntry AccountRId CurrencyRId TagRId) +balanceEntry f curID idx e@Entry {eValue, eAcnt, eTags} = do + let acntRes = lookupAccount eAcnt + let tagRes = mapErrors lookupTag eTags + combineErrorM acntRes tagRes $ \(acntID, sign, _) tags -> do + let s = fromIntegral $ sign2Int sign + (newVal, deferred) <- f acntID eValue + modify (mapAdd_ (acntID, curID) newVal) + return $ + FullEntry + { feEntry = e {eValue = s * newVal, eAcnt = acntID, eTags = tags} + , feCurrency = curID + , feDeferred = deferred + , feIndex = idx + } findBalance :: AccountRId -> CurrencyRId -> Bool -> Rational -> State EntryBals Rational findBalance acnt cur toBal v = do