diff --git a/dhall/Types.dhall b/dhall/Types.dhall index 0f02479..8dca7e3 100644 --- a/dhall/Types.dhall +++ b/dhall/Types.dhall @@ -396,15 +396,30 @@ let FieldMatcher_ = let FieldMatcher = FieldMatcher_ Text -let EntryNumGetter = +let FromEntryNumGetter = {- Means to get a numeric value from a statement row. - LookupN: lookup the value from a field - ConstN: a constant value - AmountN: the value of the 'Amount' column + FLookupN: lookup the value from a field + FConstN: a constant value + FAmountN: the value of the 'Amount' column + FBalanceN: the amount required to make the target account reach a balance -} - < LookupN : Text | ConstN : Double | AmountN : Double > + < FLookupN : Text + | FConstN : Double + | FAmountN : Double + | FBalanceN : Double + > + +let ToEntryNumGetter = + {- + Means to get a numeric value from a statement row. + + TLookupN: lookup the value from a field + TConstN: a constant value + TAmountN: the value of the 'Amount' column + -} + < TLookupN : Text | TConstN : Double | TAmountN : Double > let EntryTextGetter = {- @@ -477,8 +492,8 @@ let FromEntryGetter = Means for getting an entry from a given row in a statement to apply to the credit side of the transaction. -} - { Type = Entry EntryAcntGetter EntryNumGetter EntryCurGetter TagID - , default = { eValue = None EntryNumGetter, eComment = "" } + { Type = Entry EntryAcntGetter FromEntryNumGetter EntryCurGetter TagID + , default = { eValue = None FromEntryNumGetter, eComment = "" } } let ToEntryGetter = @@ -487,8 +502,8 @@ let ToEntryGetter = debit side of the transaction. -} { Type = - Entry EntryAcntGetter (Optional EntryNumGetter) EntryCurGetter TagID - , default = { eValue = None EntryNumGetter, eComment = "" } + Entry EntryAcntGetter (Optional ToEntryNumGetter) EntryCurGetter TagID + , default = { eValue = None ToEntryNumGetter, eComment = "" } } let TxGetter = @@ -1073,7 +1088,8 @@ in { CurID , DateMatcher , FieldMatcher , FieldMatcher_ - , EntryNumGetter + , FromEntryNumGetter + , ToEntryNumGetter , Field , FieldMap , Entry diff --git a/lib/Internal/Database.hs b/lib/Internal/Database.hs index 0f429a1..22611ba 100644 --- a/lib/Internal/Database.hs +++ b/lib/Internal/Database.hs @@ -411,6 +411,6 @@ resolveEntry s@Entry {eAcnt, eCurrency, eValue, eTags} = do s { eAcnt = aid , eCurrency = cid - , eValue = eValue * fromIntegral (sign2Int sign) + , eValue = fromIntegral (sign2Int sign) * eValue , eTags = tags } diff --git a/lib/Internal/History.hs b/lib/Internal/History.hs index 2b34f0f..4c6d630 100644 --- a/lib/Internal/History.hs +++ b/lib/Internal/History.hs @@ -1,8 +1,8 @@ module Internal.History ( splitHistory - , insertHistTransfer + , readHistTransfer , readHistStmt - , insertHistStmt + , insertHistory ) where @@ -17,6 +17,7 @@ import qualified RIO.ByteString.Lazy as BL import RIO.FilePath import qualified RIO.List as L import qualified RIO.Map as M +import qualified RIO.NonEmpty as NE import qualified RIO.Text as T import RIO.Time import qualified RIO.Vector as V @@ -27,62 +28,70 @@ splitHistory = partitionEithers . fmap go go (HistTransfer x) = Left x go (HistStatement x) = Right x -insertHistTransfer +insertHistory :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m) - => HistTransfer + => [(CommitR, [RawTx])] -> m () -insertHistTransfer +insertHistory hs = do + bs <- balanceTxs $ concatMap (\(c, xs) -> fmap (c,) xs) hs + forM_ (groupKey (\(CommitR h _) -> h) bs) $ \(c, ts) -> do + ck <- insert c + mapM_ (insertTx ck) ts + +groupKey :: Ord c => (a -> c) -> [(a, b)] -> [(a, [b])] +groupKey f = fmap go . NE.groupAllWith (f . fst) + where + go xs@((c, _) :| _) = (c, NE.toList $ fmap snd xs) + +readHistTransfer + :: (MonadInsertError m, MonadFinance m) + => HistTransfer + -> m (Maybe (CommitR, [RawTx])) +readHistTransfer m@Transfer { transFrom = from , transTo = to , transCurrency = u , transAmounts = amts } = do - whenHash CTManual m () $ \c -> do + whenHash_ CTManual m $ 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 - keys <- combineErrors $ fmap tx days - mapM_ (insertTx c) keys - void $ combineErrors $ fmap go amts + return $ fmap tx days + concat <$> mapErrors go amts readHistStmt :: (MonadUnliftIO m, MonadFinance m) => FilePath -> Statement - -> m (Maybe (CommitR, [KeyTx])) + -> m (Maybe (CommitR, [RawTx])) readHistStmt root i = whenHash_ CTImport i $ do bs <- readImport root i bounds <- askDBState kmStatementInterval - liftIOExceptT $ mapErrors resolveTx $ filter (inDaySpan bounds . txDate) bs - -insertHistStmt :: (MonadSqlQuery m) => CommitR -> [KeyTx] -> m () -insertHistStmt c ks = do - ck <- insert c - mapM_ (insertTx ck) ks + return $ filter (inDaySpan bounds . txDate) bs -------------------------------------------------------------------------------- -- low-level transaction stuff -- TODO tags here? txPair - :: (MonadInsertError m, MonadFinance m) - => Day + :: Day -> AcntID -> AcntID -> CurID -> Rational -> T.Text - -> m KeyTx -txPair day from to cur val desc = resolveTx tx + -> RawTx +txPair day from to cur val desc = tx where split a v = Entry { eAcnt = a - , eValue = v + , eValue = ConstD v , eComment = "" , eCurrency = cur , eTags = [] @@ -109,7 +118,7 @@ insertTx c Tx {txDate = d, txDescr = e, txEntries = ss} = do -- Statements -- TODO this probably won't scale well (pipes?) -readImport :: (MonadUnliftIO m, MonadFinance m) => FilePath -> Statement -> m [BalTx] +readImport :: (MonadUnliftIO m, MonadFinance m) => FilePath -> Statement -> m [RawTx] readImport root Statement {stmtTxOpts, stmtParsers, stmtSkipLines, stmtDelim, stmtPaths} = do let ores = compileOptions stmtTxOpts let cres = combineErrors $ compileMatch <$> stmtParsers @@ -155,11 +164,13 @@ parseTxRecord p TxOpts {toDate, toAmountFmt, toDesc, toAmount, toOther, toDateFm d' <- parseTimeM True defaultTimeLocale (T.unpack toDateFmt) d return $ Just $ TxRecord d' a e os p -matchRecords :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM [BalTx] +-- 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 [RawTx] matchRecords ms rs = do (matched, unmatched, notfound) <- matchAll (matchPriorities ms) rs case (matched, unmatched, notfound) of - (ms_, [], []) -> liftInner $ combineErrors $ fmap balanceTx ms_ + (ms_, [], []) -> return ms_ -- liftInner $ combineErrors $ fmap balanceTx ms_ (_, us, ns) -> throwError $ InsertException [StatementError us ns] matchPriorities :: [MatchRe] -> [MatchGroup] @@ -303,12 +314,37 @@ matchNonDates ms = go ([], [], initZipper ms) MatchFail -> (matched, r : unmatched) in go (m, u, resetZipper z') rs -balanceTx :: RawTx -> InsertExcept BalTx -balanceTx t@Tx {txEntries = ss} = do - bs <- balanceEntries ss - return $ t {txEntries = bs} +balanceTxs + :: (MonadInsertError m, MonadFinance m) + => [(CommitR, RawTx)] + -> m [(CommitR, KeyTx)] +balanceTxs ts = do + bs <- mapM balanceTx $ snd $ L.mapAccumR balanceTxTargets M.empty ts' + return $ zip cs bs + where + (cs, ts') = L.unzip $ L.sortOn (txDate . snd) ts -balanceEntries :: [RawEntry] -> InsertExcept [BalEntry] +balanceTxTargets + :: M.Map a Rational + -> Tx (Entry a (Deferred Rational) c t) + -> (M.Map a Rational, Tx (Entry a (Maybe Rational) c t)) +balanceTxTargets = undefined + +balanceEntryTargets + :: M.Map a Rational + -> Entry a (Deferred Rational) c t + -> (M.Map a Rational, Entry a (Maybe Rational) c t) +balanceEntryTargets = undefined + +balanceTx + :: (MonadInsertError m, MonadFinance m) + => Tx (Entry AcntID (Maybe Rational) CurID TagID) + -> m KeyTx +balanceTx t@Tx {txEntries = ss} = do + bs <- liftExcept $ balanceEntries ss + resolveTx $ t {txEntries = bs} + +balanceEntries :: [Entry AcntID (Maybe Rational) CurID TagID] -> InsertExcept [BalEntry] balanceEntries ss = fmap concat <$> mapM (uncurry bal) diff --git a/lib/Internal/Types/Dhall.hs b/lib/Internal/Types/Dhall.hs index 3533dd4..f08a9ab 100644 --- a/lib/Internal/Types/Dhall.hs +++ b/lib/Internal/Types/Dhall.hs @@ -32,7 +32,8 @@ makeHaskellTypesWith , MultipleConstructors "DatePat" "(./dhall/Types.dhall).DatePat" , MultipleConstructors "YMDMatcher" "(./dhall/Types.dhall).YMDMatcher" , MultipleConstructors "DateMatcher" "(./dhall/Types.dhall).DateMatcher" - , MultipleConstructors "EntryNumGetter" "(./dhall/Types.dhall).EntryNumGetter" + , MultipleConstructors "ToEntryNumGetter" "(./dhall/Types.dhall).ToEntryNumGetter" + , MultipleConstructors "FromEntryNumGetter" "(./dhall/Types.dhall).FromEntryNumGetter" , MultipleConstructors "BudgetCurrency" "(./dhall/Types.dhall).BudgetCurrency" , MultipleConstructors "BudgetTransferType" "(./dhall/Types.dhall).BudgetTransferType" , MultipleConstructors "TaxMethod" "(./dhall/Types.dhall).TaxMethod" @@ -97,7 +98,8 @@ deriveProduct , "YMDMatcher" , "BudgetCurrency" , "Exchange" - , "EntryNumGetter" + , "FromEntryNumGetter" + , "ToEntryNumGetter" , "TemporalScope" , "SqlConfig" , "PretaxValue" @@ -338,7 +340,9 @@ instance Ord DateMatcher where compare (On d) (In d' _) = compare d d' <> LT compare (In d _) (On d') = compare d d' <> GT -deriving instance Hashable EntryNumGetter +deriving instance Hashable FromEntryNumGetter + +deriving instance Hashable ToEntryNumGetter ------------------------------------------------------------------------------- -- top level type with fixed account tree to unroll the recursion in the dhall @@ -421,9 +425,9 @@ data History | HistStatement !Statement deriving (Eq, Generic, Hashable, FromDhall) -type ToEntryGetter = Entry EntryAcnt (Maybe EntryNumGetter) EntryCur TagID +type ToEntryGetter = Entry EntryAcnt (Maybe ToEntryNumGetter) EntryCur TagID -type FromEntryGetter = Entry EntryAcnt EntryNumGetter EntryCur TagID +type FromEntryGetter = Entry EntryAcnt FromEntryNumGetter EntryCur TagID instance FromDhall ToEntryGetter diff --git a/lib/Internal/Types/Main.hs b/lib/Internal/Types/Main.hs index 81c2636..e8ab791 100644 --- a/lib/Internal/Types/Main.hs +++ b/lib/Internal/Types/Main.hs @@ -59,8 +59,12 @@ data DBUpdates = DBUpdates type CurrencyM = Reader CurrencyMap +type DeferredKeyEntry = Entry AccountRId (Deferred Rational) CurrencyRId TagRId + type KeyEntry = Entry AccountRId Rational CurrencyRId TagRId +type DeferredKeyTx = Tx DeferredKeyEntry + type KeyTx = Tx KeyEntry type TreeR = Tree ([T.Text], AccountRId) @@ -127,9 +131,12 @@ accountSign IncomeT = Credit accountSign LiabilityT = Credit accountSign EquityT = Credit -type RawEntry = Entry AcntID (Maybe Rational) CurID TagID +data Deferred a = ConstD a | Target a | Derive + deriving (Show, Functor, Foldable, Traversable) -type RawFromEntry = Entry AcntID Rational CurID TagID +type RawEntry = Entry AcntID (Deferred Rational) CurID TagID + +-- type RawFromEntry = Entry AcntID (Deferred Rational) CurID TagID type BalEntry = Entry AcntID Rational CurID TagID @@ -172,7 +179,7 @@ data InsertError | ParseError !T.Text | ConversionError !T.Text | LookupError !LookupSuberr !T.Text - | BalanceError !BalanceType !CurID ![RawEntry] + | BalanceError !BalanceType !CurID ![Entry AcntID (Maybe Rational) CurID TagID] | IncomeError !Day !T.Text !Rational | PatternError !Natural !Natural !(Maybe Natural) !PatternSuberr | DaySpanError !Gregorian !(Maybe Gregorian) diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs index 909021e..e69d609 100644 --- a/lib/Internal/Utils.hs +++ b/lib/Internal/Utils.hs @@ -319,26 +319,24 @@ toTx sc sa fromEntries toEntries r@TxRecord {trAmount, trDate, trDesc} = do (combineError acntRes curRes (,)) (combineError fromRes toRes (,)) $ \(a, c) (fs, ts) -> - let fromValue = trAmount - sum (fmap eValue fs) - fromEntry = + let fromEntry = Entry { eAcnt = a , eCurrency = c - , eValue = Just fromValue + , eValue = ConstD trAmount , eComment = "" -- TODO actually fill this in , eTags = [] -- TODO what goes here? } in Tx { txDate = trDate , txDescr = trDesc - , txEntries = fromEntry : fmap liftEntry fs ++ ts + , txEntries = fromEntry : fs ++ ts } where acntRes = liftInner $ resolveAcnt r sa curRes = liftInner $ resolveCurrency r sc fromRes = combineErrors $ fmap (resolveFromEntry r) fromEntries toRes = combineErrors $ fmap (resolveToEntry r) toEntries - liftEntry e = e {eValue = Just $ eValue e} valMatches :: ValMatcher -> Rational -> InsertExcept Bool valMatches ValMatcher {vmDen, vmSign, vmNum, vmPrec} x @@ -364,20 +362,8 @@ otherMatches dict m = case m of where lookup_ t n = lookupErr (MatchField t) n dict -resolveFromEntry :: TxRecord -> FromEntryGetter -> InsertExceptT CurrencyM RawFromEntry +resolveFromEntry :: TxRecord -> FromEntryGetter -> InsertExceptT CurrencyM RawEntry resolveFromEntry r s@Entry {eAcnt, eValue, eCurrency} = do - m <- ask - liftInner $ combineErrorM3 acntRes curRes valRes $ \a c v -> do - v' <- roundPrecisionCur c m v - return $ s {eAcnt = a, eValue = v', eCurrency = c} - where - acntRes = resolveAcnt r eAcnt - curRes = resolveCurrency r eCurrency - valRes = resolveValue r eValue - --- TODO wet code (kinda, not sure if it's worth combining with above) -resolveToEntry :: TxRecord -> ToEntryGetter -> InsertExceptT CurrencyM RawEntry -resolveToEntry r s@Entry {eAcnt, eValue, eCurrency} = do m <- ask liftInner $ combineErrorM3 acntRes curRes valRes $ \a c v -> do v' <- mapM (roundPrecisionCur c m) v @@ -385,7 +371,19 @@ resolveToEntry r s@Entry {eAcnt, eValue, eCurrency} = do where acntRes = resolveAcnt r eAcnt curRes = resolveCurrency r eCurrency - valRes = mapM (resolveValue r) eValue + valRes = resolveFromValue r eValue + +-- TODO wet code (kinda, not sure if it's worth combining with above) +resolveToEntry :: TxRecord -> ToEntryGetter -> InsertExceptT CurrencyM RawEntry +resolveToEntry r s@Entry {eAcnt, eValue, eCurrency} = do + m <- ask + liftInner $ combineErrorM3 acntRes curRes valRes $ \a c v -> do + v' <- mapM (roundPrecisionCur c m) v + return $ s {eAcnt = a, eValue = maybe Derive Target v', eCurrency = c} + where + acntRes = resolveAcnt r eAcnt + curRes = resolveCurrency r eCurrency + valRes = mapM (resolveToValue r) eValue liftInner :: Monad m => ExceptT e Identity a -> ExceptT e m a liftInner = mapExceptT (return . runIdentity) @@ -470,11 +468,19 @@ mapErrorsIO f xs = do collectErrorsIO :: MonadUnliftIO m => [m a] -> m [a] collectErrorsIO = mapErrorsIO id -resolveValue :: TxRecord -> EntryNumGetter -> InsertExcept Double -resolveValue TxRecord {trOther, trAmount} s = case s of - (LookupN t) -> readDouble =<< lookupErr EntryValField t trOther - (ConstN c) -> return c - AmountN m -> return $ (* m) $ fromRational trAmount +resolveFromValue :: TxRecord -> FromEntryNumGetter -> InsertExcept (Deferred Double) +resolveFromValue TxRecord {trOther, trAmount} s = case s of + (FLookupN t) -> ConstD <$> (readDouble =<< lookupErr EntryValField t trOther) + (FConstN c) -> return $ ConstD c + FAmountN m -> return $ ConstD $ (* m) $ fromRational trAmount + FBalanceN x -> return $ Target x + +-- TODO not DRY +resolveToValue :: TxRecord -> ToEntryNumGetter -> InsertExcept Double +resolveToValue TxRecord {trOther, trAmount} s = case s of + (TLookupN t) -> readDouble =<< lookupErr EntryValField t trOther + (TConstN c) -> return c + TAmountN m -> return $ (* m) $ fromRational trAmount resolveAcnt :: TxRecord -> EntryAcnt -> InsertExcept T.Text resolveAcnt = resolveEntryField AcntField @@ -750,7 +756,7 @@ showMatchOther (Val (Field f mv)) = , singleQuote $ fromMaybe "*" $ showValMatcher mv ] -showEntry :: RawEntry -> T.Text +showEntry :: Entry AcntID (Maybe Rational) CurID TagID -> T.Text showEntry Entry {eAcnt, eValue, eComment} = keyVals [ ("account", eAcnt)