WIP show useful errors for insertions

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
+  :: (Hashable a, MonadUnliftIO m)
-  => MonadUnliftIO m
   => ConfigType
   -> a
-  -> (Key CommitR -> MappingT m ())
+  -> b
-  -> MappingT m ()
+  -> (Key CommitR -> MappingT m b)
-whenHash t o f = do
+  -> MappingT m b
+whenHash t o def f = do
   let h = hash o
   hs <- asks kmNewCommits
-  when (h `elem` hs) $ do
+  if h `elem` hs then f =<< lift (insert $ CommitR h t) else return def
-    f =<< lift (insert $ CommitR h t)
 
 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 :: MonadUnliftIO m => Statement -> MappingT m (Maybe InsertError)
-insertStatement (StmtManual m) = insertManual m
+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 :: MonadUnliftIO m => Import -> MappingT m (Maybe InsertError)
-insertImport i = whenHash CTImport i $ \c -> do
+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

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 :: MonadUnliftIO m => Import -> MappingT m (EitherErr [BalTx])
-readImport Import {..} = do
+readImport Import {..} =
-  rs <- L.sort . concat <$> mapM (readImport_ impSkipLines impDelim impTxOpts) impPaths
+  matchRecords impMatches . L.sort . concat
-  -- TODO show more useful information here (eg which file emitted this
+    <$> mapM (readImport_ impSkipLines impDelim impTxOpts) impPaths
-  -- error and possibly where)
-  return $ matchRecords impMatches rs
 
 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 :: FilePath -> TxOpts -> NamedRecord -> Parser (Maybe TxRecord)
-parseTxRecord TxOpts {..} r = do
+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 :: [Match] -> [TxRecord] -> EitherErr [BalTx]
-matchRecords ms rs = case matchAll (matchPriorities ms) rs of
+matchRecords ms rs = do
-  Left e -> StatementFail $ StatementErrors [] [] [e]
+  (matched, unmatched, notfound) <- matchAll (matchPriorities ms) rs
-  Right (matched, unmatched, notfound) ->
+  -- TODO record number of times each match hits for debugging
-    -- TODO record number of times each match hits for debugging
+  matched_ <- mapM balanceTx matched
-    let (errors, matched_) = partitionEithers $ balanceTx <$> matched
+  case (matched_, unmatched, notfound) of
-     in case (matched_, unmatched, notfound, errors) of
+    (xs, [], []) -> Right xs
-          (xs, [], [], []) -> StatementPass xs
+    (_, us, ns) -> Left $ StatementError us ns
-          (_, us, ns, es) -> StatementFail $ StatementErrors us ns es
 
 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 (: []))

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 InsertError
-data StatementErrors = StatementErrors
+  = RegexError T.Text
-  { seUnmatched :: [TxRecord]
+  | ConversionError T.Text
-  , seNotFound :: [Match]
+  | LookupError T.Text
-  , seErrors :: [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

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 :: RegexContext Regex query b => query -> T.Text -> EitherErr b
-matchMaybe q re = first (const msg) $ pureTry $ q =~ re
+matchMaybe q re = first (const $ RegexError re) $ pureTry $ q =~ re
-  where
-    msg = T.concat ["Could not make regexp from pattern: '", 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.Text -> EitherErr Rational
-readRationalMsg t = maybe (Left msg) Right $ readRational t
+readRationalMsg t = maybe (Left $ ConversionError t) Right $ readRational t
-  where
-    msg = T.append "Could not convert to rational number: " 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