diff --git a/lib/Internal/Insert.hs b/lib/Internal/Insert.hs index ba0a736..dc4c7f8 100644 --- a/lib/Internal/Insert.hs +++ b/lib/Internal/Insert.hs @@ -128,17 +128,16 @@ insertBudget Budget {income = is, expenses = es} = do -- TODO this hashes twice (not that it really matters) whenHash - :: Hashable a - => MonadUnliftIO m + :: (Hashable a, MonadUnliftIO m) => ConfigType -> a - -> (Key CommitR -> MappingT m ()) - -> MappingT m () -whenHash t o f = do + -> b + -> (Key CommitR -> MappingT m b) + -> MappingT m b +whenHash t o def f = do let h = hash o hs <- asks kmNewCommits - when (h `elem` hs) $ do - f =<< lift (insert $ CommitR h t) + if h `elem` hs then f =<< lift (insert $ CommitR h t) else return def insertIncome :: MonadUnliftIO m => Income -> MappingT m () insertIncome @@ -148,7 +147,7 @@ insertIncome , incAccount = from , incTaxes = ts } = - whenHash CTIncome i $ \c -> do + whenHash CTIncome i () $ \c -> do case balanceIncome i of Left m -> liftIO $ print m Right as -> do @@ -244,7 +243,7 @@ insertExpense , expBucket = buc , expAmounts = as } = do - whenHash CTExpense e $ \c -> do + whenHash CTExpense e () $ \c -> do ts <- concat <$> mapM (timeAmountToTx from to cur) as lift $ mapM_ (insertTxBucket (Just buc) c) ts @@ -276,10 +275,12 @@ timeAmountToTx -- statements insertStatements :: MonadUnliftIO m => Config -> MappingT m () -insertStatements = mapM_ insertStatement . statements +insertStatements conf = do + es <- catMaybes <$> mapM insertStatement (statements conf) + unless (null es) $ throwIO $ InsertException es -insertStatement :: MonadUnliftIO m => Statement -> MappingT m () -insertStatement (StmtManual m) = insertManual m +insertStatement :: MonadUnliftIO m => Statement -> MappingT m (Maybe InsertError) +insertStatement (StmtManual m) = insertManual m >> return Nothing insertStatement (StmtImport i) = insertImport i insertManual :: MonadUnliftIO m => Manual -> MappingT m () @@ -292,24 +293,25 @@ 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 where tx day = txPair day from to u (dec2Rat v) e -insertImport :: MonadUnliftIO m => Import -> MappingT m () -insertImport i = whenHash CTImport i $ \c -> do +insertImport :: MonadUnliftIO m => Import -> MappingT m (Maybe InsertError) +insertImport i = whenHash CTImport i Nothing $ \c -> do bounds <- asks kmStatementInterval res <- readImport i -- TODO this isn't efficient, the whole file will be read and maybe no -- transactions will be desired case res of - StatementPass bs -> do + Right bs -> do rs <- mapM resolveTx $ filter (inMaybeBounds bounds . txDate) bs lift $ mapM_ (insertTx c) rs - StatementFail _ -> throwIO MatchException + return Nothing + Left e -> return $ Just e -------------------------------------------------------------------------------- -- low-level transaction stuff diff --git a/lib/Internal/Statement.hs b/lib/Internal/Statement.hs index 1b83efb..ac2fa05 100644 --- a/lib/Internal/Statement.hs +++ b/lib/Internal/Statement.hs @@ -23,12 +23,10 @@ import qualified RIO.Vector as V -- TODO this probably won't scale well (pipes?) -readImport :: MonadUnliftIO m => Import -> MappingT m StatementRes -readImport Import {..} = do - rs <- L.sort . concat <$> mapM (readImport_ impSkipLines impDelim impTxOpts) impPaths - -- TODO show more useful information here (eg which file emitted this - -- error and possibly where) - return $ matchRecords impMatches rs +readImport :: MonadUnliftIO m => Import -> MappingT m (EitherErr [BalTx]) +readImport Import {..} = + matchRecords impMatches . L.sort . concat + <$> mapM (readImport_ impSkipLines impDelim impTxOpts) impPaths readImport_ :: MonadUnliftIO m @@ -40,7 +38,7 @@ readImport_ readImport_ n delim tns p = do dir <- asks kmConfigDir bs <- liftIO $ BL.readFile $ dir p - case decodeByNameWithP (parseTxRecord tns) opts $ skip bs of + case decodeByNameWithP (parseTxRecord p tns) opts $ skip bs of Left m -> liftIO $ putStrLn m >> return [] Right (_, v) -> return $ catMaybes $ V.toList v where @@ -49,8 +47,8 @@ readImport_ n delim tns p = do -- TODO handle this better, this maybe thing is a hack to skip lines with -- blank dates but will likely want to make this more flexible -parseTxRecord :: TxOpts -> NamedRecord -> Parser (Maybe TxRecord) -parseTxRecord TxOpts {..} r = do +parseTxRecord :: FilePath -> TxOpts -> NamedRecord -> Parser (Maybe TxRecord) +parseTxRecord p TxOpts {..} r = do d <- r .: T.encodeUtf8 toDate if d == "" then return Nothing @@ -59,17 +57,16 @@ parseTxRecord TxOpts {..} r = do e <- r .: T.encodeUtf8 toDesc os <- M.fromList <$> mapM (\n -> (n,) <$> r .: T.encodeUtf8 n) toOther d' <- parseTimeM True defaultTimeLocale (T.unpack toDateFmt) d - return $ Just $ TxRecord d' a e os + return $ Just $ TxRecord d' a e os p -matchRecords :: [Match] -> [TxRecord] -> StatementRes -matchRecords ms rs = case matchAll (matchPriorities ms) rs of - Left e -> StatementFail $ StatementErrors [] [] [e] - Right (matched, unmatched, notfound) -> - -- TODO record number of times each match hits for debugging - let (errors, matched_) = partitionEithers $ balanceTx <$> matched - in case (matched_, unmatched, notfound, errors) of - (xs, [], [], []) -> StatementPass xs - (_, us, ns, es) -> StatementFail $ StatementErrors us ns es +matchRecords :: [Match] -> [TxRecord] -> EitherErr [BalTx] +matchRecords ms rs = do + (matched, unmatched, notfound) <- matchAll (matchPriorities ms) rs + -- TODO record number of times each match hits for debugging + matched_ <- mapM balanceTx matched + case (matched_, unmatched, notfound) of + (xs, [], []) -> Right xs + (_, us, ns) -> Left $ StatementError us ns matchPriorities :: [Match] -> [MatchGroup] matchPriorities = @@ -117,7 +114,7 @@ zipperSlice f x = go EQ -> goEq $ Unzipped bs (a : cs) as LT -> z -zipperMatch :: Unzipped Match -> TxRecord -> PureErr (Zipped Match, MatchRes RawTx) +zipperMatch :: Unzipped Match -> TxRecord -> EitherErr (Zipped Match, MatchRes RawTx) zipperMatch (Unzipped bs cs as) x = go [] cs where go _ [] = Right (Zipped bs $ cs ++ as, MatchFail) @@ -130,7 +127,7 @@ zipperMatch (Unzipped bs cs as) x = go [] cs ms' = maybe ms (: ms) (matchDec m) in Right (Zipped bs $ ps ++ ms' ++ as, skipOrPass) -zipperMatch' :: Zipped Match -> TxRecord -> PureErr (Zipped Match, MatchRes RawTx) +zipperMatch' :: Zipped Match -> TxRecord -> EitherErr (Zipped Match, MatchRes RawTx) zipperMatch' z x = go z where go (Zipped bs (a : as)) = do @@ -146,7 +143,7 @@ matchDec m@Match {mTimes = t} = where t' = fmap pred t -matchAll :: [MatchGroup] -> [TxRecord] -> PureErr ([RawTx], [TxRecord], [Match]) +matchAll :: [MatchGroup] -> [TxRecord] -> EitherErr ([RawTx], [TxRecord], [Match]) matchAll = go ([], []) where go (matched, unused) gs rs = case (gs, rs) of @@ -156,13 +153,13 @@ matchAll = go ([], []) (ts, unmatched, us) <- matchGroup g rs go (ts ++ matched, us ++ unused) gs' unmatched -matchGroup :: MatchGroup -> [TxRecord] -> PureErr ([RawTx], [TxRecord], [Match]) +matchGroup :: MatchGroup -> [TxRecord] -> EitherErr ([RawTx], [TxRecord], [Match]) 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) . mTimes) $ ud ++ un) -matchDates :: [Match] -> [TxRecord] -> PureErr ([RawTx], [TxRecord], [Match]) +matchDates :: [Match] -> [TxRecord] -> EitherErr ([RawTx], [TxRecord], [Match]) matchDates ms = go ([], [], initZipper ms) where go (matched, unmatched, z) [] = @@ -182,7 +179,7 @@ matchDates ms = go ([], [], initZipper ms) go (m, u, z') rs findDate m r = maybe EQ (`compareDate` trDate r) $ mDate m -matchNonDates :: [Match] -> [TxRecord] -> PureErr ([RawTx], [TxRecord], [Match]) +matchNonDates :: [Match] -> [TxRecord] -> EitherErr ([RawTx], [TxRecord], [Match]) matchNonDates ms = go ([], [], initZipper ms) where go (matched, unmatched, z) [] = @@ -199,12 +196,12 @@ matchNonDates ms = go ([], [], initZipper ms) MatchFail -> (matched, r : unmatched) in go (m, u, resetZipper z') rs -balanceTx :: RawTx -> PureErr BalTx +balanceTx :: RawTx -> EitherErr BalTx balanceTx t@Tx {txSplits = ss} = do bs <- balanceSplits ss return $ t {txSplits = bs} -balanceSplits :: [RawSplit] -> PureErr [BalSplit] +balanceSplits :: [RawSplit] -> EitherErr [BalSplit] balanceSplits ss = fmap concat <$> mapM (uncurry bal) @@ -214,11 +211,11 @@ balanceSplits ss = hasValue s@(Split {sValue = Just v}) = Right s {sValue = v} hasValue s = Left s bal cur rss - | length rss < 2 = Left $ T.append "Need at least two splits to balance: " cur + | length rss < 2 = Left $ BalanceError TooFewSplits cur | otherwise = case partitionEithers $ fmap hasValue rss of ([noVal], val) -> Right $ noVal {sValue = foldr (\s x -> x - sValue s) 0 val} : val ([], val) -> Right val - _ -> Left $ T.append "Exactly one split must be blank: " cur + _ -> Left $ BalanceError NotOneBlank cur groupByKey :: Ord k => [(k, v)] -> [(k, [v])] groupByKey = M.toList . M.fromListWith (++) . fmap (second (: [])) diff --git a/lib/Internal/Types.hs b/lib/Internal/Types.hs index b1f8b4d..dede2c8 100644 --- a/lib/Internal/Types.hs +++ b/lib/Internal/Types.hs @@ -458,6 +458,7 @@ data TxRecord = TxRecord , trAmount :: !Rational , trDesc :: !T.Text , trOther :: M.Map T.Text T.Text + , trFile :: FilePath } deriving (Show, Eq, Ord) @@ -503,19 +504,20 @@ type RawTx = Tx RawSplit type BalTx = Tx BalSplit -type PureErr a = Either T.Text a - data MatchRes a = MatchPass a | MatchFail | MatchSkip -data InsertException = MatchException | RegexException deriving (Show) +data BalanceType = TooFewSplits | NotOneBlank deriving (Show) --- TODO retain file information here for clearer printing purposes -data StatementErrors = StatementErrors - { seUnmatched :: [TxRecord] - , seNotFound :: [Match] - , seErrors :: [T.Text] - } +data InsertError + = RegexError T.Text + | ConversionError T.Text + | LookupError T.Text + | BalanceError BalanceType CurID + | StatementError [TxRecord] [Match] + deriving (Show) -data StatementRes = StatementPass [BalTx] | StatementFail StatementErrors +newtype InsertException = InsertException [InsertError] deriving (Show) instance Exception InsertException + +type EitherErr = Either InsertError diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs index edd920c..5fc5fd7 100644 --- a/lib/Internal/Utils.hs +++ b/lib/Internal/Utils.hs @@ -116,7 +116,7 @@ lookupErr what k m = case M.lookup k m of Just x -> x _ -> errorT $ T.concat [what, " does not exist: ", T.pack $ show k] -matches :: Match -> TxRecord -> PureErr (MatchRes RawTx) +matches :: Match -> TxRecord -> EitherErr (MatchRes RawTx) matches Match {..} r@TxRecord {..} = do let date = checkMaybe (`dateMatches` trDate) mDate let val = valMatches mVal trAmount @@ -129,19 +129,17 @@ matches Match {..} r@TxRecord {..} = do where eval (ToTx cur a ss) = toTx cur a ss r -matchMaybe :: RegexContext Regex query b => query -> T.Text -> PureErr b -matchMaybe q re = first (const msg) $ pureTry $ q =~ re - where - msg = T.concat ["Could not make regexp from pattern: '", re, "'"] +matchMaybe :: RegexContext Regex query b => query -> T.Text -> EitherErr b +matchMaybe q re = first (const $ RegexError re) $ pureTry $ q =~ re -fieldMatches :: M.Map T.Text T.Text -> MatchOther -> PureErr Bool +fieldMatches :: M.Map T.Text T.Text -> MatchOther -> EitherErr Bool fieldMatches dict m = case m of Val (Field n mv) -> valMatches mv <$> (readRationalMsg =<< lookup_ n) Desc (Field n md) -> (`matchMaybe` md) =<< lookup_ n where lookup_ n = case M.lookup n dict of Just r -> Right r - Nothing -> Left $ T.append "Could not find field: " n + Nothing -> Left $ LookupError n checkMaybe :: (a -> Bool) -> Maybe a -> Bool checkMaybe = maybe True @@ -196,10 +194,8 @@ parseRational pat s = case ms of k <- readSign sign return (k, w) -readRationalMsg :: T.Text -> PureErr Rational -readRationalMsg t = maybe (Left msg) Right $ readRational t - where - msg = T.append "Could not convert to rational number: " t +readRationalMsg :: T.Text -> EitherErr Rational +readRationalMsg t = maybe (Left $ ConversionError t) Right $ readRational t -- TODO don't use a partial function readRational :: MonadFail m => T.Text -> m Rational @@ -279,3 +275,16 @@ dec2Rat D {..} = acntPath2Text :: AcntPath -> T.Text acntPath2Text (AcntPath t cs) = T.intercalate "/" (atName t : cs) + +showError :: InsertError -> [T.Text] +showError (StatementError ts ms) = (showTx <$> ts) ++ (showMatch <$> ms) + where + showTx = undefined + showMatch = undefined +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 + (LookupError f) -> T.append "Could not find field: " f + -- TODO these balance errors are useless, need more info on the tx being balanced + (BalanceError TooFewSplits cur) -> T.append "Need at least two splits to balance: " cur + (BalanceError NotOneBlank cur) -> T.append "Exactly one split must be blank: " cur