Redo decode error backtracking to throw deepest error

src/KDL/Decoder/Arrow.hs

@@ -293,7 +293,7 @@ decodeFirstNodeWhere matcher decodeNode = do
       index <- StateT.gets (getNodeIndex name.value)
       StateT.modify $ \s -> s{object = s.object{nodes = nodes'}}
       b <-
-        Trans.lift . makeFatal . addContext ContextNode{name = name, index = index} $
+        Trans.lift . addContext ContextNode{name = name, index = index} $
           decodeNode node_
       StateT.modify $ \s -> s{history = s.history{nodesSeen = inc name.value s.history.nodesSeen}}
       pure $ Just (node_, b)
@@ -697,7 +697,7 @@ argWith' =
       StateT.modify $ \s -> s{object = s.object{entries = entries'}}
 
       b <-
-        Trans.lift . makeFatal . addContext ContextArg{index = index} $
+        Trans.lift . addContext ContextArg{index = index} $
           decodeValue a entry.value
       StateT.modify $ \s -> s{history = s.history{argsSeen = s.history.argsSeen + 1}}
       pure b
@@ -758,7 +758,7 @@ decodeOnePropWhere matcher decodeValue = do
     Just (name, prop_, entries') -> do
       StateT.modify $ \s -> s{object = s.object{entries = entries'}}
       b <-
-        Trans.lift . makeFatal . addContext ContextProp{name = name} $
+        Trans.lift . addContext ContextProp{name = name} $
           decodeValue prop_.value
       StateT.modify $ \s -> s{history = s.history{propsSeen = Set.insert name s.history.propsSeen}}
       pure $ Just (name, b)
@@ -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

@@ -14,82 +14,116 @@ module KDL.Decoder.Internal.DecodeM (
   runDecodeM,
   decodeThrow,
   failM,
-  makeFatal,
-  makeNonFatal,
   addContext,
 ) 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
---   * Has two error channels, one for fatal errors and one for non-fatal errors (see 'makeFatal')
---   * 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) -> -- fatal error, not handled by <|>
-        (DecodeError -> r) -> -- non-fatal error, handled by <|>
-        (a -> r) ->
-        r
-      )
+  = DecodeM_Found a [BaseDecodeError]
+  | DecodeM_Fail (NonEmpty BaseDecodeError)
 
 instance Functor DecodeM where
-  fmap f (DecodeM k) = DecodeM $ \onFatal onFail onSuccess -> k onFatal 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 $ \onFatal onFail onSuccess ->
-    -- Collect all errors
-    kf
-      (\e1 -> ka (\e2 -> onFatal $ e1 <> e2) (\e2 -> onFatal $ e1 <> e2) (\_ -> onFatal e1))
-      (\e1 -> ka (\e2 -> onFatal $ e1 <> e2) (\e2 -> onFail $ e1 <> e2) (\_ -> onFail e1))
-      (\f -> ka onFatal 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 $ \onFatal onFail onSuccess ->
-    ka onFatal onFail $ \a -> let DecodeM kb = k a in kb onFatal 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 $ \onFatal onFail onSuccess ->
-    k1
-      onFatal
-      (\e1 -> k2 onFatal (\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 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.
---
--- This error is non-fatal and can be handled by '<|>'. See 'makeFatal'
--- for more information.
 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
 
--- | Make all errors in the given action fatal errors.
---
--- A la standard parsing libraries like megaparsec, errors should be
--- considered fatal when decoding has started consuming something.
-makeFatal :: DecodeM a -> DecodeM a
-makeFatal (DecodeM f) = DecodeM $ \onFatal _ onSuccess -> f onFatal onFatal onSuccess
-
--- | Make all errors non-fatal errors.
-makeNonFatal :: DecodeM a -> DecodeM a
-makeNonFatal (DecodeM f) = DecodeM $ \_ onFail onSuccess -> f onFail onFail onSuccess
-
 -- | Add context to all errors that occur in the given action.
 addContext :: ContextItem -> DecodeM a -> DecodeM a
-addContext ctxItem (DecodeM f) = DecodeM $ \onFatal onFail onSuccess -> f (onFatal . addCtx) (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`
@@ -690,6 +692,17 @@ apiSpec = do
             , "  Expected annotation to be one of [\"VAL\"], got: test"
             ]
 
+      it "supports backtracking annotations" $ do
+        let config = "foo (l)1 (r)2"
+            decodeArg =
+              KDL.oneOf
+                [ Left <$> KDL.argWith' ["l"] KDL.number
+                , Right <$> KDL.argWith' ["r"] KDL.number
+                ]
+            decoder = KDL.document $ _DO_
+              _STMT_(KDL.nodeWith "foo" . KDL.many $ decodeArg)
+        KDL.decodeWith decoder config `shouldBe` Right [Left 1, Right 2]
+
     describe "prop" $ do
       it "decodes a prop" $ do
         let config = "foo test1=1 test2=hello"