Always propagate errors, select deepest errors on failure

Author: brandonchinn178

src/KDL/Decoder/Arrow.hs

@@ -1056,9 +1056,13 @@ null = valueDataDecoderPrim (SchemaOne NullSchema) $ \case
 
 -- | Return the first result that succeeds.
 --
--- > oneOf [a, b, c] === a <|> b <|> c <|> empty
+-- > oneOf [a, b, c] === a <|> b <|> c
 oneOf :: (Alternative f) => [f a] -> f a
-oneOf = foldr (<|>) empty
+oneOf ms =
+  -- Avoid 'empty' if possible
+  case NonEmpty.nonEmpty ms of
+    Just ms' -> foldr1 (<|>) ms'
+    Nothing -> empty
 
 -- | Return the given default value if the given action fails.
 --

src/KDL/Decoder/Internal/DecodeM.hs

@@ -18,58 +18,112 @@ module KDL.Decoder.Internal.DecodeM (
 ) where
 
 import Control.Applicative (Alternative (..))
+import Data.Bifunctor (first)
+import Data.List.NonEmpty (NonEmpty (..))
+import Data.List.NonEmpty qualified as NonEmpty
 import Data.Text (Text)
 import KDL.Decoder.Internal.Error
 
 -- | The monad that returns either a 'DecodeError' or a result of type @a@.
 --
--- To a first approximation, this monad is equivalent to the @Either DecodeError@
--- monad, with the following changes:
+-- The odd structure here is because of our backtracking semantics. We want to
+-- collect all errors that may appear (even if a value is successfully parsed)
+-- so that if we get a failure later on, we can return the deepest error, even
+-- if it was in a successful branch.
 --
---   * Uses continuation-passing style for performance
---   * Collects as many errors as possible, within an Applicative context
+-- Take this motivating example: a node takes an arbitrary number of string
+-- args. If you pass some strings then a number, it'll successfully parse up to
+-- the number and return success, only for the node to fail later with
+-- "unexpected argument: 123". But the true error was
+-- "unexpected number, expected string".
 data DecodeM a
-  = DecodeM
-      ( forall r.
-        (DecodeError -> r) ->
-        (a -> r) ->
-        r
-      )
+  = DecodeM_Found a [BaseDecodeError]
+  | DecodeM_Fail (NonEmpty BaseDecodeError)
 
 instance Functor DecodeM where
-  fmap f (DecodeM k) = DecodeM $ \onFail onSuccess -> k onFail (onSuccess . f)
+  fmap f = \case
+    DecodeM_Found a es -> DecodeM_Found (f a) es
+    DecodeM_Fail es -> DecodeM_Fail es
 instance Applicative DecodeM where
-  pure x = DecodeM $ \_ onSuccess -> onSuccess x
-  DecodeM kf <*> DecodeM ka = DecodeM $ \onFail onSuccess ->
-    -- Collect all errors
-    kf
-      (\e1 -> ka (\e2 -> onFail $ e1 <> e2) (\_ -> onFail e1))
-      (\f -> ka onFail (onSuccess . f))
+  pure x = DecodeM_Found x []
+  l <*> r =
+    case (l, r) of
+      (DecodeM_Found f es1, DecodeM_Found a es2) -> DecodeM_Found (f a) (mergeErrorsLR es1 es2)
+      (DecodeM_Found _ es1, DecodeM_Fail es2) -> DecodeM_Fail (mergeErrorsL es1 es2)
+      (DecodeM_Fail es1, DecodeM_Found _ es2) -> DecodeM_Fail (mergeErrorsR es1 es2)
+      (DecodeM_Fail es1, DecodeM_Fail es2) -> DecodeM_Fail (mergeErrors es1 es2)
 instance Monad DecodeM where
   (>>) = (*>)
-  DecodeM ka >>= k = DecodeM $ \onFail onSuccess ->
-    ka onFail $ \a -> let DecodeM kb = k a in kb onFail onSuccess
+  m >>= k =
+    case m of
+      DecodeM_Fail es1 -> DecodeM_Fail es1
+      DecodeM_Found a es1 ->
+        case k a of
+          DecodeM_Found b es2 -> DecodeM_Found b (mergeErrorsLR es1 es2)
+          DecodeM_Fail es2 -> DecodeM_Fail (mergeErrorsL es1 es2)
 instance Alternative DecodeM where
-  empty = DecodeM $ \onFail _ -> onFail mempty
-  DecodeM k1 <|> DecodeM k2 = DecodeM $ \onFail onSuccess ->
-    k1
-      (\e1 -> k2 (\e2 -> onFail $ e1 <> e2) onSuccess)
-      onSuccess
+  empty = failM "<empty>"
+  l <|> r =
+    case l of
+      DecodeM_Found a es1 -> DecodeM_Found a es1
+      DecodeM_Fail es1 ->
+        case r of
+          DecodeM_Found a es2 -> DecodeM_Found a (NonEmpty.toList $ mergeErrorsR es1 es2)
+          DecodeM_Fail es2 -> DecodeM_Fail (mergeErrors es1 es2)
 
--- | Run a 'DecodeM' action and return the result or the error.
+-- | Run a 'DecodeM' action and return the result or the deepest error found.
 runDecodeM :: DecodeM a -> Either DecodeError a
-runDecodeM (DecodeM f) = f Left Right
+runDecodeM = \case
+  DecodeM_Found a _ -> Right a
+  DecodeM_Fail errors -> Left DecodeError{filepath = Nothing, errors}
+
+mergeErrors ::
+  NonEmpty BaseDecodeError ->
+  NonEmpty BaseDecodeError ->
+  NonEmpty BaseDecodeError
+mergeErrors es1 es2 =
+  case compare (key es1) (key es2) of
+    LT -> es2
+    EQ -> es1 <> es2
+    GT -> es1
+ where
+  key = length . fst . NonEmpty.head
+
+mergeErrorsL ::
+  [BaseDecodeError] ->
+  NonEmpty BaseDecodeError ->
+  NonEmpty BaseDecodeError
+mergeErrorsL l r = maybe r (\l' -> mergeErrors l' r) (NonEmpty.nonEmpty l)
+
+mergeErrorsR ::
+  NonEmpty BaseDecodeError ->
+  [BaseDecodeError] ->
+  NonEmpty BaseDecodeError
+mergeErrorsR l r = maybe l (\r' -> mergeErrors l r') (NonEmpty.nonEmpty r)
+
+mergeErrorsLR ::
+  [BaseDecodeError] ->
+  [BaseDecodeError] ->
+  [BaseDecodeError]
+mergeErrorsLR l r =
+  case (l, r) of
+    ([], _) -> r
+    (_, []) -> l
+    (x : xs, y : ys) -> NonEmpty.toList $ mergeErrors (x :| xs) (y :| ys)
+
+mapErrors :: (BaseDecodeError -> BaseDecodeError) -> DecodeM a -> DecodeM a
+mapErrors f = \case
+  DecodeM_Found a es -> DecodeM_Found a (fmap f es)
+  DecodeM_Fail es -> DecodeM_Fail (fmap f es)
 
 -- | Throw an error.
 decodeThrow :: DecodeErrorKind -> DecodeM a
-decodeThrow e = DecodeM $ \onFail _ -> onFail $ DecodeError Nothing [([], e)]
+decodeThrow e = DecodeM_Fail . NonEmpty.singleton $ ([], e)
 
 -- | Throw a 'DecodeError_Custom' error.
 failM :: Text -> DecodeM a
 failM = decodeThrow . DecodeError_Custom
 
 -- | Add context to all errors that occur in the given action.
 addContext :: ContextItem -> DecodeM a -> DecodeM a
-addContext ctxItem (DecodeM f) = DecodeM $ \onFail onSuccess -> f (onFail . addCtx) onSuccess
- where
-  addCtx e = e{errors = [(ctxItem : ctx, msg) | (ctx, msg) <- e.errors]}
+addContext ctxItem = mapErrors (first (ctxItem :))

src/KDL/Decoder/Internal/Error.hs

@@ -14,7 +14,8 @@ module KDL.Decoder.Internal.Error (
   renderDecodeError,
 ) where
 
-import Control.Applicative ((<|>))
+import Data.List.NonEmpty (NonEmpty)
+import Data.List.NonEmpty qualified as NonEmpty
 import Data.Map qualified as Map
 import Data.Text (Text)
 import Data.Text qualified as Text
@@ -29,13 +30,9 @@ import KDL.Types (
 
 data DecodeError = DecodeError
   { filepath :: Maybe FilePath
-  , errors :: [BaseDecodeError]
+  , errors :: NonEmpty BaseDecodeError
   }
   deriving (Show, Eq)
-instance Semigroup DecodeError where
-  DecodeError fp1 e1 <> DecodeError fp2 e2 = DecodeError (fp1 <|> fp2) (e1 <> e2)
-instance Monoid DecodeError where
-  mempty = DecodeError Nothing []
 
 type BaseDecodeError = (Context, DecodeErrorKind)
 type Context = [ContextItem]
@@ -74,7 +71,11 @@ renderDecodeError decodeError =
     $ decodeError.errors
  where
   -- Group errors with the same contexts together
-  groupCtxErrors es = Map.toAscList $ Map.fromListWith (<>) [(ctx, [e]) | (ctx, e) <- es]
+  groupCtxErrors es =
+    Map.toAscList . Map.fromListWith (<>) $
+      [ (ctx, [e])
+      | (ctx, e) <- NonEmpty.toList es
+      ]
 
   addPath =
     case decodeError.filepath of

test/KDL/Decoder/SharedSpec/Template.hs

@@ -474,6 +474,7 @@ apiSpec = do
           `shouldSatisfy` decodeErrorMsg
             [ "At: foo #0"
             , "  Unexpected node: bar #0"
+            , "  Expected another node: -"
             ]
 
       it "fails if any child fails to parse" $ do
@@ -569,6 +570,7 @@ apiSpec = do
           `shouldSatisfy` decodeErrorMsg
             [ "At: foo #0"
             , "  Unexpected node: bar #0"
+            , "  Expected another node: -"
             ]
 
     -- Most behaviors tested with `dashNodesAt`