diff --git a/lib/Internal/Insert.hs b/lib/Internal/Insert.hs index 29e6c47..bbf584e 100644 --- a/lib/Internal/Insert.hs +++ b/lib/Internal/Insert.hs @@ -1,6 +1,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE NoImplicitPrelude #-} module Internal.Insert ( insertStatements @@ -16,35 +17,9 @@ import Internal.Statement import Internal.Types hiding (sign) import Internal.Utils import RIO hiding (to) -import qualified RIO.Map as M import qualified RIO.Text as T import RIO.Time -lookupKey :: (Ord k, Show k, MonadUnliftIO m) => M.Map k v -> k -> m (Maybe v) -lookupKey m k = do - let v = M.lookup k m - when (isNothing v) $ - liftIO $ - putStrLn $ - "key does not exist: " ++ show k - return v - -lookupAccount :: MonadUnliftIO m => AcntID -> MappingT m (Maybe (Key AccountR, AcntSign)) -lookupAccount p = do - m <- asks kmAccount - lookupKey m p - -lookupAccountKey :: MonadUnliftIO m => AcntID -> MappingT m (Maybe (Key AccountR)) -lookupAccountKey = fmap (fmap fst) . lookupAccount - -lookupAccountSign :: MonadUnliftIO m => AcntID -> MappingT m (Maybe AcntSign) -lookupAccountSign = fmap (fmap snd) . lookupAccount - -lookupCurrency :: MonadUnliftIO m => T.Text -> MappingT m (Maybe (Key CurrencyR)) -lookupCurrency c = do - m <- asks kmCurrency - lookupKey m c - -------------------------------------------------------------------------------- -- intervals @@ -118,8 +93,9 @@ mdyPatternMatches check x p = case p of insertBudget :: MonadUnliftIO m => Budget -> MappingT m [InsertError] insertBudget Budget {income = is, expenses = es} = do - mapM_ insertExpense es - concat <$> mapM insertIncome is + es1 <- mapM insertIncome is + es2 <- mapM insertExpense es + return $ concat $ es1 ++ es2 -- TODO this hashes twice (not that it really matters) whenHash @@ -140,15 +116,19 @@ insertIncome { incCurrency = cur , incWhen = dp , incAccount = from - , incTaxes = ts + , incTaxes = taxes } = - whenHash CTIncome i [] $ \c -> do - bounds <- (liftIO . resolveBounds) =<< asks kmBudgetInterval + whenHash CTIncome i [] $ \c -> unlessLeft (balanceIncome i) $ \balanced -> do - forM_ (expandDatePat bounds dp) $ \day -> do - alloTx <- concat <$> mapM (allocationToTx from day) balanced - taxTx <- fmap (,Fixed) <$> mapM (taxToTx from day cur) ts - lift $ mapM_ (\(t, b) -> insertTxBucket (Just b) c t) $ alloTx ++ taxTx + bounds <- (liftIO . resolveBounds) =<< asks kmBudgetInterval + fmap concat $ forM (expandDatePat bounds dp) $ \day -> do + -- TODO why are these separate? + nontaxRes <- alloTxs concat (allocationToTx from day) balanced + taxRes <- alloTxs (fmap (,Fixed)) (taxToTx from day cur) taxes + unlessLefts_ (concatEithers2 nontaxRes taxRes (++)) $ \txs -> + lift $ mapM_ (\(t, b) -> insertTxBucket (Just b) c t) txs + where + alloTxs squish toTx = fmap (fmap squish . concatEithersL) . mapM toTx balanceIncome :: Income -> EitherErr [BalAllocation] balanceIncome @@ -202,7 +182,7 @@ allocationToTx => AcntID -> Day -> BalAllocation - -> MappingT m [(KeyTx, Bucket)] + -> MappingT m (EitherErrs [(KeyTx, Bucket)]) allocationToTx from day @@ -212,9 +192,15 @@ allocationToTx , alloCurrency = cur , alloAmts = as } = - fmap (,b) <$> mapM (transferToTx day from to cur) as + second (fmap (,b)) . concatEithersL <$> mapM (transferToTx day from to cur) as -taxToTx :: MonadUnliftIO m => AcntID -> Day -> T.Text -> Tax -> MappingT m KeyTx +taxToTx + :: MonadUnliftIO m + => AcntID + -> Day + -> T.Text + -> Tax + -> MappingT m (EitherErrs KeyTx) taxToTx from day cur Tax {taxAcnt = to, taxValue = v} = txPair day from to cur (dec2Rat v) "" @@ -225,11 +211,11 @@ transferToTx -> AcntID -> T.Text -> BalAmount - -> MappingT m KeyTx + -> MappingT m (EitherErrs KeyTx) transferToTx day from to cur Amount {amtValue = v, amtDesc = d} = txPair day from to cur v d -insertExpense :: MonadUnliftIO m => Expense -> MappingT m () +insertExpense :: MonadUnliftIO m => Expense -> MappingT m [InsertError] insertExpense e@Expense { expFrom = from @@ -238,11 +224,12 @@ insertExpense , expBucket = buc , expAmounts = as } = do - whenHash CTExpense e () $ \key -> mapM_ (go key) as + whenHash CTExpense e [] $ \key -> concat <$> mapM (go key) as where go key amt = do - keys <- timeAmountToTx from to cur amt - lift $ mapM_ (insertTxBucket (Just buc) key) keys + res <- timeAmountToTx from to cur amt + unlessLefts_ res $ + lift . mapM_ (insertTxBucket (Just buc) key) timeAmountToTx :: MonadUnliftIO m @@ -250,7 +237,7 @@ timeAmountToTx -> AcntID -> CurID -> TimeAmount - -> MappingT m [KeyTx] + -> MappingT m (EitherErrs [KeyTx]) timeAmountToTx from to @@ -264,7 +251,7 @@ timeAmountToTx } } = do bounds <- (liftIO . resolveBounds) =<< asks kmBudgetInterval - mapM tx $ expandDatePat bounds dp + concatEithersL <$> mapM tx (expandDatePat bounds dp) where tx day = txPair day from to cur (dec2Rat v) d @@ -277,10 +264,10 @@ insertStatements conf = concat <$> mapM insertStatement (statements conf) -- unless (null es) $ throwIO $ InsertException es insertStatement :: MonadUnliftIO m => Statement -> MappingT m [InsertError] -insertStatement (StmtManual m) = insertManual m >> return [] +insertStatement (StmtManual m) = insertManual m insertStatement (StmtImport i) = insertImport i -insertManual :: MonadUnliftIO m => Manual -> MappingT m () +insertManual :: MonadUnliftIO m => Manual -> MappingT m [InsertError] insertManual m@Manual { manualDate = dp @@ -290,10 +277,10 @@ insertManual , manualCurrency = u , manualDesc = e } = do - whenHash CTManual m () $ \c -> do + whenHash CTManual m [] $ \c -> do bounds <- (liftIO . resolveBounds) =<< asks kmStatementInterval - ts <- mapM tx $ expandDatePat bounds dp - lift $ mapM_ (insertTx c) ts + res <- mapM tx $ expandDatePat bounds dp + unlessLefts_ (concatEithersL res) $ lift . mapM_ (insertTx c) where tx day = txPair day from to u (dec2Rat v) e @@ -301,15 +288,18 @@ insertImport :: MonadUnliftIO m => Import -> MappingT m [InsertError] insertImport i = whenHash CTImport i [] $ \c -> do -- TODO this isn't efficient, the whole file will be read and maybe no -- transactions will be desired - res <- tryIO $ readImport i - case res of - Right r -> unlessLefts r $ \bs -> do - bounds <- asks kmStatementInterval - rs <- mapM resolveTx $ filter (inMaybeBounds bounds . txDate) bs - lift $ mapM_ (insertTx c) rs - -- If file is not found (or something else happens) then collect the - -- error try the remaining imports - Left e -> return [InsertIOError $ showT e] + recoverIO (readImport i) $ \r -> unlessLefts r $ \bs -> do + bounds <- asks kmStatementInterval + res <- mapM resolveTx $ filter (inMaybeBounds bounds . txDate) bs + unlessLefts_ (concatEithersL res) $ lift . mapM_ (insertTx c) + where + recoverIO x rest = do + res <- tryIO x + case res of + Right r -> rest r + -- If file is not found (or something else happens) then collect the + -- error try the remaining imports + Left e -> return [InsertIOError $ showT e] -------------------------------------------------------------------------------- -- low-level transaction stuff @@ -322,7 +312,7 @@ txPair -> T.Text -> Rational -> T.Text - -> MappingT m KeyTx + -> MappingT m (EitherErrs KeyTx) txPair day from to cur val desc = resolveTx tx where split a v = Split {sAcnt = a, sValue = v, sComment = "", sCurrency = cur} @@ -334,27 +324,27 @@ txPair day from to cur val desc = resolveTx tx , txSplits = [split from (-val), split to val] } -resolveTx :: MonadUnliftIO m => BalTx -> MappingT m KeyTx +resolveTx :: MonadUnliftIO m => BalTx -> MappingT m (EitherErrs KeyTx) resolveTx t@Tx {txSplits = ss} = do - rs <- catMaybes <$> mapM resolveSplit ss - return $ t {txSplits = rs} + res <- concatEithersL <$> mapM resolveSplit ss + return $ fmap (\kss -> t {txSplits = kss}) res -resolveSplit :: MonadUnliftIO m => BalSplit -> MappingT m (Maybe KeySplit) +resolveSplit :: MonadUnliftIO m => BalSplit -> MappingT m (EitherErrs KeySplit) resolveSplit s@Split {sAcnt = p, sCurrency = c, sValue = v} = do aid <- lookupAccountKey p cid <- lookupCurrency c sign <- lookupAccountSign p -- TODO correct sign here? -- TODO lenses would be nice here - return $ case (aid, cid, sign) of - (Just aid', Just cid', Just sign') -> - Just $ - s - { sAcnt = aid' - , sCurrency = cid' - , sValue = v * fromIntegral (sign2Int sign') - } - _ -> Nothing + return $ concatEither3 aid cid sign $ \aid_ cid_ sign_ -> + s + { sAcnt = aid_ + , sCurrency = cid_ + , sValue = v * fromIntegral (sign2Int sign_) + } + +-- return $ case (aid, cid, sign) of +-- _ -> Nothing insertTxBucket :: MonadUnliftIO m => Maybe Bucket -> Key CommitR -> KeyTx -> SqlPersistT m () insertTxBucket b c Tx {txDate = d, txDescr = e, txSplits = ss} = do @@ -367,3 +357,15 @@ insertTx = insertTxBucket Nothing insertSplit :: MonadUnliftIO m => Key TransactionR -> KeySplit -> SqlPersistT m () insertSplit t Split {sAcnt = aid, sCurrency = cid, sValue = v, sComment = c} = do insert_ $ SplitR t cid aid c v + +lookupAccount :: MonadUnliftIO m => AcntID -> MappingT m (EitherErr (Key AccountR, AcntSign)) +lookupAccount p = lookupErr (DBKey AcntField) p <$> asks kmAccount + +lookupAccountKey :: MonadUnliftIO m => AcntID -> MappingT m (EitherErr (Key AccountR)) +lookupAccountKey = fmap (fmap fst) . lookupAccount + +lookupAccountSign :: MonadUnliftIO m => AcntID -> MappingT m (EitherErr AcntSign) +lookupAccountSign = fmap (fmap snd) . lookupAccount + +lookupCurrency :: MonadUnliftIO m => T.Text -> MappingT m (EitherErr (Key CurrencyR)) +lookupCurrency c = lookupErr (DBKey CurField) c <$> asks kmCurrency diff --git a/lib/Internal/Types.hs b/lib/Internal/Types.hs index 1355994..226d219 100644 --- a/lib/Internal/Types.hs +++ b/lib/Internal/Types.hs @@ -11,6 +11,7 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE NoImplicitPrelude #-} module Internal.Types where @@ -529,6 +530,7 @@ data LookupSuberr = SplitIDField SplitIDType | SplitValField | MatchField MatchType + | DBKey SplitIDType deriving (Show) data AllocationSuberr @@ -542,6 +544,7 @@ data InsertError = RegexError T.Text | MatchValPrecisionError Natural Natural | InsertIOError T.Text + | ParseError T.Text | ConversionError T.Text | LookupError LookupSuberr T.Text | BalanceError BalanceType CurID [RawSplit] @@ -556,10 +559,3 @@ instance Exception InsertException type EitherErr = Either InsertError type EitherErrs = Either [InsertError] - --- type StateErr = State [InsertError] - --- runErrors :: StateErr a -> Either [InsertError] a --- runErrors x = case runState x [] of --- (y, []) -> Right y --- (_, es) -> Left es diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs index 3b7ee22..da3feee 100644 --- a/lib/Internal/Utils.hs +++ b/lib/Internal/Utils.hs @@ -1,6 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NoImplicitPrelude #-} module Internal.Utils ( compareDate @@ -12,14 +13,20 @@ module Internal.Utils , leftToMaybe , dec2Rat , concatEithers2 + , concatEither3 , concatEither2 + , concatEitherL + , concatEithersL , parseRational , showError + , unlessLeft_ + , unlessLefts_ , unlessLeft , unlessLefts , inMaybeBounds , acntPath2Text , showT + , lookupErr ) where @@ -282,29 +289,21 @@ showError other = (: []) $ case other of (RegexError re) -> T.append "could not make regex from pattern: " re (ConversionError x) -> T.append "Could not convert to rational number: " x (InsertIOError msg) -> T.append "IO Error: " msg + (ParseError msg) -> T.append "Parse Error: " msg (MatchValPrecisionError d p) -> T.unwords ["Match denominator", showT d, "must be less than", showT p] (LookupError t f) -> - T.unwords - [ "Could not find field" - , singleQuote f - , "when resolving" - , what - ] + T.unwords ["Could not find field", singleQuote f, "when resolving", what] where what = case t of - SplitIDField st -> - T.unwords - [ "split" - , case st of AcntField -> "account"; CurField -> "currency" - , "ID" - ] + SplitIDField st -> T.unwords ["split", idName st, "ID"] SplitValField -> "split value" - MatchField mt -> - T.unwords - [ case mt of MatchNumeric -> "numeric"; MatchText -> "text" - , "match" - ] + MatchField mt -> T.unwords [matchName mt, "match"] + DBKey st -> T.unwords ["database", idName st, "ID key"] + idName AcntField = "account" + idName CurField = "currency" + matchName MatchNumeric = "numeric" + matchName MatchText = "text" (AllocationError t dp) -> T.concat [msg, ": datepattern=", showT dp] where msg = case t of @@ -467,13 +466,19 @@ leftToMaybe :: Either a b -> Maybe a leftToMaybe (Left a) = Just a leftToMaybe _ = Nothing -unlessLeft :: (Monad m, MonadPlus n) => Either a b -> (b -> m ()) -> m (n a) +unlessLeft :: (Monad m, MonadPlus n) => Either a b -> (b -> m (n a)) -> m (n a) unlessLeft (Left es) _ = return (return es) -unlessLeft (Right rs) f = f rs >> return mzero +unlessLeft (Right rs) f = f rs -unlessLefts :: (Monad m, MonadPlus n) => Either (n a) b -> (b -> m ()) -> m (n a) +unlessLefts :: (Monad m) => Either (n a) b -> (b -> m (n a)) -> m (n a) unlessLefts (Left es) _ = return es -unlessLefts (Right rs) f = f rs >> return mzero +unlessLefts (Right rs) f = f rs + +unlessLeft_ :: (Monad m, MonadPlus n) => Either a b -> (b -> m ()) -> m (n a) +unlessLeft_ e f = unlessLeft e (\x -> void (f x) >> return mzero) + +unlessLefts_ :: (Monad m, MonadPlus n) => Either (n a) b -> (b -> m ()) -> m (n a) +unlessLefts_ e f = unlessLefts e (\x -> void (f x) >> return mzero) plural :: Either a b -> Either [a] b plural = first (: [])