diff --git a/lib/Internal/Database.hs b/lib/Internal/Database.hs index 6457541..a609fbf 100644 --- a/lib/Internal/Database.hs +++ b/lib/Internal/Database.hs @@ -8,6 +8,7 @@ module Internal.Database , flattenAcntRoot , paths2IDs , mkPool + , whenHash0 , whenHash , whenHash_ , insertEntry @@ -380,6 +381,18 @@ whenHash t o def f = do hs <- askDBState kmNewCommits if h `elem` hs then f =<< insert (CommitR h t) else return def +whenHash0 + :: (Hashable a, MonadFinance m) + => ConfigType + -> a + -> b + -> (CommitR -> m b) + -> m b +whenHash0 t o def f = do + let h = hash o + hs <- askDBState kmNewCommits + if h `elem` hs then f (CommitR h t) else return def + whenHash_ :: (Hashable a, MonadFinance m) => ConfigType diff --git a/lib/Internal/History.hs b/lib/Internal/History.hs index c53a02d..1856e21 100644 --- a/lib/Internal/History.hs +++ b/lib/Internal/History.hs @@ -38,21 +38,21 @@ import qualified RIO.Vector as V readHistTransfer :: (MonadInsertError m, MonadFinance m) => HistTransfer - -> m (Maybe (CommitR, [DeferredTx])) + -> m [DeferredTx CommitR] readHistTransfer m@Transfer { transFrom = from , transTo = to , transCurrency = u , transAmounts = amts - } = do - whenHash_ CTManual m $ do + } = + whenHash0 CTManual m [] $ \c -> do bounds <- askDBState kmStatementInterval let precRes = lookupCurrencyPrec u let go Amount {amtWhen, amtValue, amtDesc} = do let dayRes = liftExcept $ expandDatePat bounds amtWhen (days, precision) <- combineError dayRes precRes (,) - let tx day = txPair day from to u (roundPrecision precision amtValue) amtDesc + let tx day = txPair c day from to u (roundPrecision precision amtValue) amtDesc return $ fmap tx days concat <$> mapErrors go amts @@ -61,15 +61,20 @@ groupKey f = fmap go . NE.groupAllWith (f . fst) where go xs@((c, _) :| _) = (c, NE.toList $ fmap snd xs) +groupWith :: Ord b => (a -> b) -> [a] -> [(b, [a])] +groupWith f = fmap go . NE.groupAllWith fst . fmap (\x -> (f x, x)) + where + go xs@((c, _) :| _) = (c, NE.toList $ fmap snd xs) + readHistStmt :: (MonadUnliftIO m, MonadFinance m) => FilePath -> Statement - -> m (Maybe (CommitR, [DeferredTx])) -readHistStmt root i = whenHash_ CTImport i $ do + -> m [DeferredTx CommitR] +readHistStmt root i = whenHash0 CTImport i [] $ \c -> do bs <- readImport root i bounds <- askDBState kmStatementInterval - return $ filter (inDaySpan bounds . txDate) bs + return $ filter (inDaySpan bounds . txDate) $ fmap (\t -> t {txCommit = c}) bs splitHistory :: [History] -> ([HistTransfer], [Statement]) splitHistory = partitionEithers . fmap go @@ -79,11 +84,11 @@ splitHistory = partitionEithers . fmap go insertHistory :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m) - => [(CommitR, [DeferredTx])] + => [DeferredTx CommitR] -> m () insertHistory hs = do - bs <- balanceTxs $ concatMap (\(c, xs) -> fmap (c,) xs) hs - forM_ (groupKey (\(CommitR h _) -> h) bs) $ \(c, ts) -> do + bs <- balanceTxs hs + forM_ (groupWith txCommit bs) $ \(c, ts) -> do ck <- insert c mapM_ (insertTx ck) ts @@ -92,17 +97,19 @@ insertHistory hs = do -- TODO tags here? txPair - :: Day + :: CommitR + -> Day -> AcntID -> AcntID -> CurID -> Rational -> T.Text - -> DeferredTx -txPair day from to cur val desc = + -> DeferredTx CommitR +txPair commit day from to cur val desc = Tx { txDescr = desc , txDate = day + , txCommit = commit , txEntries = [ EntrySet { esTotalValue = -val @@ -121,20 +128,21 @@ txPair day from to cur val desc = , eTags = [] } -resolveTx :: (MonadInsertError m, MonadFinance m) => BalTx -> m KeyTx -resolveTx t@Tx {txEntries = ss} = - (\kss -> t {txEntries = kss}) <$> mapErrors resolveEntry ss +-- resolveTx :: (MonadInsertError m, MonadFinance m) => BalTx CommitR -> m (KeyTx CommitR) +-- resolveTx t@Tx {txEntries = ss} = +-- (\kss -> t {txEntries = kss}) <$> mapErrors resolveEntry ss -insertTx :: MonadSqlQuery m => CommitRId -> KeyTx -> m () +insertTx :: MonadSqlQuery m => CommitRId -> (KeyTx CommitR) -> m () insertTx c Tx {txDate = d, txDescr = e, txEntries = ss} = do - k <- insert $ TransactionR c d e + let anyDeferred = any (isJust . feDeferred) ss + k <- insert $ TransactionR c d e anyDeferred mapM_ (insertEntry k) ss -------------------------------------------------------------------------------- -- Statements -- TODO this probably won't scale well (pipes?) -readImport :: (MonadUnliftIO m, MonadFinance m) => FilePath -> Statement -> m [DeferredTx] +readImport :: (MonadUnliftIO m, MonadFinance m) => FilePath -> Statement -> m [DeferredTx ()] readImport root Statement {stmtTxOpts, stmtParsers, stmtSkipLines, stmtDelim, stmtPaths} = do let ores = compileOptions stmtTxOpts let cres = combineErrors $ compileMatch <$> stmtParsers @@ -182,7 +190,7 @@ parseTxRecord p TxOpts {toDate, toAmountFmt, toDesc, toAmount, toOther, toDateFm -- TODO need to somehow balance temporally here (like I do in the budget for -- directives that "pay off" a balance) -matchRecords :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM [DeferredTx] +matchRecords :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM [DeferredTx ()] matchRecords ms rs = do (matched, unmatched, notfound) <- matchAll (matchPriorities ms) rs case (matched, unmatched, notfound) of @@ -243,7 +251,7 @@ zipperSlice f x = go zipperMatch :: Unzipped MatchRe -> TxRecord - -> InsertExceptT CurrencyM (Zipped MatchRe, MatchRes DeferredTx) + -> InsertExceptT CurrencyM (Zipped MatchRe, MatchRes (DeferredTx ())) zipperMatch (Unzipped bs cs as) x = go [] cs where go _ [] = return (Zipped bs $ cs ++ as, MatchFail) @@ -259,7 +267,7 @@ zipperMatch (Unzipped bs cs as) x = go [] cs zipperMatch' :: Zipped MatchRe -> TxRecord - -> InsertExceptT CurrencyM (Zipped MatchRe, MatchRes DeferredTx) + -> InsertExceptT CurrencyM (Zipped MatchRe, MatchRes (DeferredTx ())) zipperMatch' z x = go z where go (Zipped bs (a : as)) = do @@ -276,7 +284,7 @@ matchDec m = case spTimes m of Just n -> Just $ m {spTimes = Just $ n - 1} Nothing -> Just m -matchAll :: [MatchGroup] -> [TxRecord] -> InsertExceptT CurrencyM ([DeferredTx], [TxRecord], [MatchRe]) +matchAll :: [MatchGroup] -> [TxRecord] -> InsertExceptT CurrencyM ([DeferredTx ()], [TxRecord], [MatchRe]) matchAll = go ([], []) where go (matched, unused) gs rs = case (gs, rs) of @@ -286,13 +294,13 @@ matchAll = go ([], []) (ts, unmatched, us) <- matchGroup g rs go (ts ++ matched, us ++ unused) gs' unmatched -matchGroup :: MatchGroup -> [TxRecord] -> InsertExceptT CurrencyM ([DeferredTx], [TxRecord], [MatchRe]) +matchGroup :: MatchGroup -> [TxRecord] -> InsertExceptT CurrencyM ([DeferredTx ()], [TxRecord], [MatchRe]) matchGroup MatchGroup {mgDate = ds, mgNoDate = ns} rs = do (md, rest, ud) <- matchDates ds rs (mn, unmatched, un) <- matchNonDates ns rest return (md ++ mn, unmatched, filter ((/= Nothing) . spTimes) $ ud ++ un) -matchDates :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM ([DeferredTx], [TxRecord], [MatchRe]) +matchDates :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM ([DeferredTx ()], [TxRecord], [MatchRe]) matchDates ms = go ([], [], initZipper ms) where go (matched, unmatched, z) [] = @@ -313,7 +321,7 @@ matchDates ms = go ([], [], initZipper ms) go (m, u, z') rs findDate m r = maybe EQ (`compareDate` trDate r) $ spDate m -matchNonDates :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM ([DeferredTx], [TxRecord], [MatchRe]) +matchNonDates :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM ([DeferredTx ()], [TxRecord], [MatchRe]) matchNonDates ms = go ([], [], initZipper ms) where go (matched, unmatched, z) [] = @@ -332,25 +340,96 @@ matchNonDates ms = go ([], [], initZipper ms) balanceTxs :: (MonadInsertError m, MonadFinance m) - => [(CommitR, DeferredTx)] - -> m [(CommitR, KeyTx)] -balanceTxs ts = do - keyts <- mapErrors resolveTx =<< evalStateT (mapM go ts') M.empty - return $ zip cs keyts + => [EntryBin] + -> m ([UpdateEntry EntryRId Rational], [KeyTx CommitR]) +balanceTxs es = + (first concat . partitionEithers . catMaybes) + <$> evalStateT (mapM go $ L.sortOn binDate es) M.empty where - (cs, ts') = L.unzip $ L.sortOn (txDate . snd) ts - go t@Tx {txEntries, txDate} = - (\es -> t {txEntries = concat es}) <$> mapM (balanceEntrySet txDate) txEntries + go (ToUpdate utx) = (Just . Left) <$> 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}) + <$> mapM (balanceEntrySet txDate) txEntries -type EntryBals = M.Map (AcntID, CurID) Rational +binDate :: EntryBin -> Day +binDate (ToUpdate (UpdateEntrySet {utDate})) = utDate +binDate (ToRead ReadEntry {reDate}) = reDate +binDate (ToInsert (Tx {txDate})) = txDate + +type EntryBals = M.Map (AccountRId, CurrencyRId) Rational + +data UpdateEntryType a + = UEReadOnly (UpdateEntry () Rational) + | UEBlank (UpdateEntry EntryRId Rational) + | UEPaired (UpdateEntry EntryRId Rational, UpdateEntry EntryRId a) + +rebalanceEntrySet :: UpdateEntrySet -> State EntryBals [UpdateEntry EntryRId Rational] +rebalanceEntrySet + UpdateEntrySet + { utFrom0 + , utTo0 + , utPairs + , utFromUnk + , utToUnk + , utFromRO + , utToRO + , utCurrency + , utTotalValue + } = + do + let fs = + L.sortOn index $ + (UEReadOnly <$> utFromRO) + ++ (UEBlank <$> utFromUnk) + ++ (UEPaired <$> utPairs) + fs' <- mapM goFrom fs + let f0 = utFrom0 {ueValue = utTotalValue - (sum $ fmap value fs')} + let (fs'', tpairs) = partitionEithers $ concatMap flatten fs' + let ts = (Right <$> tpairs) ++ (Right <$> utToUnk) ++ (Left <$> utToRO) + (tsRO, tsUnk) <- partitionEithers <$> mapM goTo ts + let t0 = utTo0 {ueValue = utTotalValue - (sum $ (fmap ueValue tsRO) ++ (fmap ueValue tsUnk))} + return $ f0 : fs'' ++ t0 : tsUnk + where + project f _ _ (UEReadOnly e) = f e + project _ f _ (UEBlank e) = f e + project _ _ f (UEPaired p) = f p + index = project ueIndex ueIndex (ueIndex . fst) + value = project ueValue ueValue (ueValue . fst) + flatten = project (const []) ((: []) . Right) (\(a, b) -> [Right a, Left b]) + -- TODO the following is wetter than the average groupie + goFrom (UEReadOnly e) = do + modify $ mapAdd_ (ueAcnt e, utCurrency) (ueValue e) + return $ UEReadOnly e + goFrom (UEBlank e) = do + let key = (ueAcnt e, utCurrency) + curBal <- gets (M.findWithDefault 0 key) + let newVal = ueValue e - curBal + modify $ mapAdd_ key newVal + return $ UEBlank $ e {ueValue = newVal} + goFrom (UEPaired (e0, e1)) = do + let key = (ueAcnt e0, utCurrency) + curBal <- gets (M.findWithDefault 0 key) + let newVal = ueValue e0 - curBal + modify $ mapAdd_ key newVal + return $ UEPaired $ (e0 {ueValue = newVal}, e1 {ueValue = -newVal}) + goTo (Left e) = do + modify $ mapAdd_ (ueAcnt e, utCurrency) (ueValue e) + return $ Left e + goTo (Right e) = do + let key = (ueAcnt e, utCurrency) + curBal <- gets (M.findWithDefault 0 key) + let newVal = ueValue e - curBal + modify $ mapAdd_ key newVal + return $ Right $ e {ueValue = newVal} --- TODO might be faster to also do all the key stuff here since currency --- will be looked up for every entry rather then the entire entry set balanceEntrySet :: (MonadInsertError m, MonadFinance m) => Day -> DeferredEntrySet - -> StateT EntryBals m [BalEntry] + -> StateT EntryBals m [KeyEntry] balanceEntrySet day EntrySet @@ -360,123 +439,82 @@ balanceEntrySet , esTotalValue } = do - fs' <- doEntries fs esTotalValue f0 - -- let fs'' = fmap (\(i, e@Entry {eValue}) -> toFull) $ zip [0 ..] fs' - let fv = V.fromList $ fmap eValue fs' - let (lts, dts) = partitionEithers $ splitLinked <$> ts - lts' <- lift $ mapErrors (resolveLinked fv esCurrency day) lts - ts' <- doEntries (dts ++ lts') (-esTotalValue) t0 - -- let ts'' = fmap (uncurry toFull) $ zip [0 ..] ts' - return $ fs' -- ++ ts'' - where - doEntries es tot e0 = do - es' <- liftInnerS $ mapM (uncurry (balanceEntry esCurrency)) $ zip [1 ..] es - let val0 = tot - entrySum es' - modify $ mapAdd_ (eAcnt e0, esCurrency) val0 - return $ e0 {eValue = val0} : es' - doEntriesTo es tot e0 = do - es' <- liftInnerS $ mapM (balanceEntry esCurrency) es - let val0 = tot - entrySum es' - modify $ mapAdd_ (eAcnt e0, esCurrency) val0 - return $ e0 {eValue = val0} : es' - toFullDebit i e target = - FullEntry - { feEntry = e - , feCurrency = esCurrency - , feIndex = i - , feDeferred = EntryBalance target - } - splitLinked e@Entry {eValue} = case eValue of - LinkIndex l -> Left e {eValue = l} - LinkDeferred d -> Right e {eValue = d} - entrySum = sum . fmap (eValue . feEntry) + -- get currency first and quit immediately on exception since everything + -- downstream depends on this + (curID, precision) <- lookupCurrency esCurrency + -- 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 fv = V.fromList $ fmap (eValue . feEntry) fs' + + -- finally resolve credit entries + let balToEntry = balanceEntry (balanceLinked fv curID precision) curID + ts' <- doEntries balToEntry curID (-esTotalValue) t0 ts (NE.iterate (+ 1) 0) + return $ fs' ++ ts' + +doEntries + :: (MonadInsertError m, MonadFinance m) + => (Int -> Entry AcntID v TagID -> State EntryBals (FullEntry AccountRId CurrencyRId TagID)) + -> CurrencyRId + -> Rational + -> Entry AcntID () TagID + -> [Entry AcntID v TagID] + -> NonEmpty Int + -> StateT EntryBals m [FullEntry AccountRId CurrencyRId TagID] +doEntries f curID tot e es (i0 :| iN) = do + es' <- liftInnerS $ mapM (uncurry f) $ zip iN es + let val0 = tot - entrySum es' + e' <- balanceEntry (\_ _ -> return (val0, Nothing)) curID i0 e + return $ e' : es' + where + entrySum = sum . fmap (eValue . feEntry) + +liftInnerS :: Monad m => StateT e Identity a -> StateT e m a liftInnerS = mapStateT (return . runIdentity) -resolveCreditEntry - :: (MonadInsertError m, MonadFinance m) - => Vector Rational - -> CurID - -> Day - -> Int - -> Entry AcntID LinkedNumGetter TagID - -> m (FullEntry AcntID CurID TagID) -resolveCreditEntry from cur day index e@Entry {eValue} = do - undefined - -resolveLinked - :: (MonadInsertError m, MonadFinance m) - => Vector Rational - -> CurID - -> Day - -> Entry AcntID LinkedNumGetter TagID - -> m (Entry AcntID (Deferred Rational) TagID) -resolveLinked from cur day e@Entry {eValue = LinkedNumGetter {lngIndex, lngScale}} = do - curMap <- askDBState kmCurrency - case from V.!? fromIntegral lngIndex of - Nothing -> throwError $ InsertException [IndexError e day] - Just v -> do - v' <- liftExcept $ roundPrecisionCur cur curMap $ lngScale * fromRational v - return $ e {eValue = Deferred False v'} - -unlinkGetter - :: (MonadInsertError m, MonadFinance m) - => Vector Rational - -> CurID - -> LinkedNumGetter - -> m (Maybe Rational) -unlinkGetter from cur LinkedNumGetter {lngIndex, lngScale} = do - curMap <- askDBState kmCurrency - maybe (return Nothing) (go curMap) $ from V.!? fromIntegral lngIndex +balanceLinked + :: Vector Rational + -> CurrencyRId + -> Natural + -> AccountRId + -> LinkDeferred Rational + -> StateT EntryBals Identity (Rational, Maybe DBDeferred) +balanceLinked from curID precision acntID lg = case lg of + (LinkIndex g@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 where - go m = fmap Just . liftExcept . roundPrecisionCur cur m . (* lngScale) . fromRational + go s = roundPrecision precision . (* s) . fromRational -balanceFromEntry - :: (MonadInsertError m, MonadFinance m) - => CurID - -> Int - -> Entry AcntID v TagID - -> StateT EntryBals m (FullEntry AcntID CurID TagID) -balanceFromEntry = balanceEntry (\a c -> liftInnerS . balanceDeferrred a c) - -balanceDeferrred - :: AcntID - -> CurID +balanceDeferred + :: CurrencyRId + -> AccountRId -> Deferred Rational -> State EntryBals (Rational, Maybe DBDeferred) -balanceDeferrred acntID curID (Deferred toBal v) = do +balanceDeferred curID acntID (Deferred toBal v) = do newval <- findBalance acntID curID toBal v return $ (newval, if toBal then Just (EntryBalance v) else Nothing) -balanceToEntry - :: (MonadInsertError m, MonadFinance m) - => Vector Rational - -> Day - -> CurID - -> Int - -> Entry AcntID v TagID - -> StateT EntryBals m (FullEntry AcntID CurID TagID) -balanceToEntry from day = balanceEntry go - where - go _ curID (LinkIndex g@LinkedNumGetter {lngIndex, lngScale}) = do - res <- unlinkGetter from curID g - case res of - Just v -> return $ (v, Just $ EntryLinked lngIndex lngScale) - Nothing -> throwError undefined - go acntID curID (LinkDeferred d) = balanceDeferrred acntID curID d - balanceEntry :: (MonadInsertError m, MonadFinance m) - => (AcntID -> CurID -> v -> m (Rational, Maybe DBDeferred)) - -> CurID + => (AccountRId -> v -> StateT EntryBals m (Rational, Maybe DBDeferred)) + -> CurrencyRId -> Int -> Entry AcntID v TagID - -> StateT EntryBals m (FullEntry AcntID CurID TagID) + -> StateT EntryBals m (FullEntry AccountRId CurrencyRId TagID) balanceEntry f curID index e@Entry {eValue, eAcnt} = do - (newVal, deferred) <- lift $ f eAcnt curID eValue + (acntID, sign, _) <- lookupAccount eAcnt + let s = fromIntegral $ sign2Int sign + (newVal, deferred) <- f acntID eValue + modify (mapAdd_ (acntID, curID) newVal) return $ FullEntry - { feEntry = e {eValue = newVal} + { feEntry = e {eValue = s * newVal, eAcnt = acntID} , feCurrency = curID , feDeferred = deferred , feIndex = index @@ -484,14 +522,10 @@ balanceEntry f curID index e@Entry {eValue, eAcnt} = do where key = (eAcnt, curID) -findBalance :: AcntID -> CurID -> Bool -> Rational -> State EntryBals Rational +findBalance :: AccountRId -> CurrencyRId -> Bool -> Rational -> State EntryBals Rational findBalance acnt cur toBal v = do - curBal <- gets (M.findWithDefault 0 key) - let newVal = if toBal then v - curBal else v - modify (mapAdd_ key newVal) - return newVal - where - key = (acnt, cur) + curBal <- gets (M.findWithDefault 0 (acnt, cur)) + return $ if toBal then v - curBal else v -- -- reimplementation from future version :/ -- mapAccumM diff --git a/lib/Internal/Types/Main.hs b/lib/Internal/Types/Main.hs index aeb8c3a..d668b26 100644 --- a/lib/Internal/Types/Main.hs +++ b/lib/Internal/Types/Main.hs @@ -63,6 +63,40 @@ type CurrencyM = Reader CurrencyMap data DBDeferred = EntryLinked Natural Rational | EntryBalance Rational +data ReadEntry = ReadEntry + { reCurrency :: !CurrencyRId + , reAcnt :: !AccountRId + , reValue :: !Rational + , reDate :: !Day + } + +data UpdateEntry i v = UpdateEntry + { ueID :: !i + , ueAcnt :: !AccountRId + , ueValue :: !v + , ueIndex :: !Int -- TODO this isn't needed for primary entries + } + +data UpdateEntrySet = UpdateEntrySet + { utFrom0 :: !(UpdateEntry EntryRId ()) + , utTo0 :: !(UpdateEntry EntryRId ()) + , utPairs :: ![(UpdateEntry EntryRId Rational, UpdateEntry EntryRId ())] + , -- for these two, the Rational number is the balance target (not the + -- value of the account) + utFromUnk :: ![UpdateEntry EntryRId Rational] + , utToUnk :: ![UpdateEntry EntryRId Rational] + , utFromRO :: ![UpdateEntry () Rational] + , utToRO :: ![UpdateEntry () Rational] + , utCurrency :: !CurrencyRId + , utDate :: !Day + , utTotalValue :: !Rational + } + +data EntryBin + = ToUpdate UpdateEntrySet + | ToRead ReadEntry + | ToInsert (DeferredTx CommitR) + data FullEntry a c t = FullEntry { feCurrency :: !c , feIndex :: !Int @@ -131,6 +165,7 @@ data Tree a = Branch !a ![Tree a] | Leaf !a deriving (Show) data AcntSign = Credit | Debit deriving (Show) +-- TODO debit should be negative sign2Int :: AcntSign -> Int sign2Int Debit = 1 sign2Int Credit = 1 @@ -154,10 +189,11 @@ data EntrySet a c t v = EntrySet , esTo :: !(HalfEntrySet a c t (LinkDeferred v)) } -data Tx e = Tx +data Tx e c = Tx { txDescr :: !T.Text , txDate :: !Day , txEntries :: !e + , txCommit :: !c } deriving (Generic) diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs index f52b76b..e64a86e 100644 --- a/lib/Internal/Utils.hs +++ b/lib/Internal/Utils.hs @@ -49,9 +49,11 @@ module Internal.Utils , valMatches , roundPrecision , roundPrecisionCur + , lookupAccount , lookupAccountKey , lookupAccountSign , lookupAccountType + , lookupCurrency , lookupCurrencyKey , lookupCurrencyPrec , lookupTag @@ -290,7 +292,7 @@ toDaySpan (a, b) = (a, fromIntegral $ diffDays b a - 1) -------------------------------------------------------------------------------- -- matching -matches :: MatchRe -> TxRecord -> InsertExceptT CurrencyM (MatchRes DeferredTx) +matches :: MatchRe -> TxRecord -> InsertExceptT CurrencyM (MatchRes (DeferredTx ())) matches StatementParser {spTx, spOther, spVal, spDate, spDesc} r@TxRecord {trDate, trAmount, trDesc, trOther} = do @@ -307,7 +309,7 @@ matches desc = maybe (return True) (matchMaybe trDesc . snd) spDesc convert tg = MatchPass <$> toTx tg r -toTx :: TxGetter -> TxRecord -> InsertExceptT CurrencyM DeferredTx +toTx :: TxGetter -> TxRecord -> InsertExceptT CurrencyM (DeferredTx ()) toTx TxGetter { tgFrom @@ -322,6 +324,7 @@ toTx Tx { txDate = trDate , txDescr = trDesc + , txCommit = () , txEntries = EntrySet { esTotalValue = v @@ -1090,7 +1093,7 @@ lookupAccountSign = fmap sndOf3 . lookupAccount lookupAccountType :: (MonadInsertError m, MonadFinance m) => AcntID -> m AcntType lookupAccountType = fmap thdOf3 . lookupAccount -lookupCurrency :: (MonadInsertError m, MonadFinance m) => T.Text -> m (CurrencyRId, Natural) +lookupCurrency :: (MonadInsertError m, MonadFinance m) => CurID -> m (CurrencyRId, Natural) lookupCurrency = lookupFinance CurField kmCurrency lookupCurrencyKey :: (MonadInsertError m, MonadFinance m) => AcntID -> m CurrencyRId