WIP show useful errors for insertions

2023-01-24 23:24:41 -05:00 · 2023-01-24 23:24:41 -05:00 · b94fd4b667
parent 7ad754bead
commit b94fd4b667
4 changed files with 77 additions and 67 deletions
--- 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
--- 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 (: []))
--- 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
--- 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