diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,15 @@ +## v1.2.1 + +* Improve error messages to include the source line where the error occurred + +## v1.2.0 + +* Add `Exception` instance to `DecodeError` +* Fix error messages after decoder succeeds after backtracking +* Add `KDL.label` +* Include type information to errors about expected argument/prop +* Rename `TextSchema` to `StringSchema` + ## v1.1.1 * Fix running tests with sdist bundle diff --git a/kdl-hs.cabal b/kdl-hs.cabal --- a/kdl-hs.cabal +++ b/kdl-hs.cabal @@ -1,7 +1,7 @@ cabal-version: 3.0 name: kdl-hs -version: 1.1.1 +version: 1.2.1 synopsis: KDL language parser and API description: KDL language parser and API. homepage: https://github.com/brandonchinn178/kdl-hs#readme @@ -45,6 +45,7 @@ base < 5 , containers , data-default + , filepath , megaparsec , prettyprinter >= 1.7.0 , scientific @@ -68,7 +69,10 @@ test-suite kdl-tests type: exitcode-stdio-1.0 - ghc-options: -F -pgmF=skeletest-preprocessor + ghc-options: + -F -pgmF=skeletest-preprocessor + -- skeletest animations during callProcess + -threaded build-tool-depends: , skeletest:skeletest-preprocessor , kdl-hs:kdl-hs-test-decoder @@ -94,7 +98,7 @@ , pretty-show , process , scientific - , skeletest + , skeletest >= 0.4 , temporary , text default-language: GHC2021 diff --git a/src/KDL/Decoder/Arrow.hs b/src/KDL/Decoder/Arrow.hs --- a/src/KDL/Decoder/Arrow.hs +++ b/src/KDL/Decoder/Arrow.hs @@ -3,6 +3,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} module KDL.Decoder.Arrow ( @@ -85,6 +86,9 @@ bool, null, + -- * Modifiers + label, + -- * Combinators oneOf, many, @@ -99,10 +103,12 @@ ) import Control.Monad (unless, when) import Control.Monad.Trans.Class qualified as Trans +import Control.Monad.Trans.Except qualified as ExceptT import Control.Monad.Trans.State.Strict (StateT) import Control.Monad.Trans.State.Strict qualified as StateT import Data.Bifunctor (first) import Data.Bits (finiteBitSize) +import Data.Functor.Identity (runIdentity) import Data.Int (Int64) import Data.List (partition) import Data.List.NonEmpty qualified as NonEmpty @@ -115,6 +121,7 @@ import Data.Set qualified as Set import Data.Text (Text) import Data.Text qualified as Text +import Data.Text.IO qualified as Text import Data.Typeable (Typeable, typeRep) import Data.Word (Word16, Word32, Word64, Word8) import GHC.Int (Int16, Int32, Int8) @@ -127,30 +134,25 @@ SchemaOf, TypedNodeSchema (..), TypedValueSchema (..), - ) -import KDL.Parser (parse, parseFile) -import KDL.Types ( - Ann (..), - Document, - Entry (..), - Identifier (..), - Node (..), - NodeList (..), - Value (..), - ValueData (..), - def, + getValueSchemaNames, ) +import KDL.Parser (ParseConfig (..), parse, parseFile, parseWith) +import KDL.Types (Ann (..), Document, Entry (..), Identifier (..), IdentifierExtension (..), Node (..), NodeExtension (..), NodeList (..), Span (..), Value (..), ValueData (..), ValueExtension (..), def) import Numeric.Natural (Natural) -import Prelude hiding (any, fail, null) +import Prelude hiding (any, fail, null, span) import Prelude qualified -- | Decode the given KDL configuration with the given decoder. decodeWith :: DocumentDecoder a -> Text -> Either DecodeError a -decodeWith decoder = decodeFromParseResult decoder Nothing . parse +decodeWith decoder input = runIdentity $ do + let doc = parse input + decodeFromParseResult Nothing (pure input) decoder doc -- | Read KDL configuration from the given file path and decode it with the given decoder. decodeFileWith :: DocumentDecoder a -> FilePath -> IO (Either DecodeError a) -decodeFileWith decoder fp = decodeFromParseResult decoder (Just fp) <$> parseFile fp +decodeFileWith decoder fp = do + doc <- parseFile fp + decodeFromParseResult (Just fp) (Text.readFile fp) decoder doc -- | Decode an already-parsed 'Document' with the given decoder. decodeDocWith :: DocumentDecoder a -> Document -> Either DecodeError a @@ -159,15 +161,49 @@ decoder.run () decodeFromParseResult :: - DocumentDecoder a -> + (Monad m) => Maybe FilePath -> + m Text -> + DocumentDecoder a -> Either Text Document -> - Either DecodeError a -decodeFromParseResult decoder mPath = - first (\e -> e{filepath = mPath}) . \case + m (Either DecodeError a) +decodeFromParseResult mPath getInput decoder = + firstM augmentError . \case Left e -> runDecodeM . decodeThrow $ DecodeError_ParseError e Right doc -> decodeDocWith decoder doc + where + augmentError originalError = runEarlyReturn $ do + input <- Trans.lift getInput + doc <- + case parseWith def{includeSpans = True} input of + Right doc -> pure doc + -- should not happen; return the plain error if it happens + Left _ -> returnE originalError + err <- + case decodeDocWith decoder doc of + Left err -> pure err + -- should not happen; return the plain error if it happens + Right _ -> returnE originalError + pure + DecodeError + { filepath = mPath + , errors = fmap (addSrcLine input) err.errors + } + addSrcLine input = + let inputLines = Text.lines input + addSrcLine' ctx span = ctx{srcLine = safeIndex (span.startLine - 1) inputLines} + in first (\ctx -> maybe ctx (addSrcLine' ctx) ctx.span) + + runEarlyReturn m = ExceptT.runExceptT m >>= either pure pure + returnE = ExceptT.throwE + + firstM f = either (fmap Left . f) (pure . Right) + safeIndex (n :: Int) = \case + _ | n < 0 -> Nothing + [] -> Nothing + x : xs -> if n == 0 then Just x else safeIndex (n - 1) xs + {----- Decoder -----} {----- Decoding Document -----} @@ -183,10 +219,7 @@ document decoder = UnsafeDocumentDecoder decoder - { run = \() -> do - a <- decoder.run () - validateNodeList - pure a + { run = \() -> decoder.run () <* validateNodeList } -- | Get the schema of a 'DocumentDecoder'. @@ -211,11 +244,7 @@ node_ : _ -> do let identifier = node_.name index <- StateT.gets (getNodeIndex identifier.value) - Trans.lift . decodeThrow $ - DecodeError_UnexpectedNode - { identifier = identifier - , index = index - } + Trans.lift . decodeThrow $ DecodeError_UnexpectedNode{identifier, index} -- | Decode a node with the given name using a 'DecodeNode' instance. -- @@ -277,7 +306,7 @@ Just (_, b) -> pure b Nothing -> do index <- StateT.gets (getNodeIndex name) - Trans.lift $ decodeThrow DecodeError_ExpectedNode{name = name, index = index} + Trans.lift $ decodeThrow DecodeError_ExpectedNode{name, index} decodeFirstNodeWhere :: (Node -> Bool) -> @@ -293,11 +322,25 @@ index <- StateT.gets (getNodeIndex name.value) StateT.modify $ \s -> s{object = s.object{nodes = nodes'}} b <- - Trans.lift . addContext ContextNode{name = name, index = index} $ + Trans.lift . addContext (nodeSpan node_) ContextNode{name, index} $ decodeNode node_ StateT.modify $ \s -> s{history = s.history{nodesSeen = inc name.value s.history.nodesSeen}} pure $ Just (node_, b) where + -- start of Node span -> end of last Entry span + nodeSpan (node_ :: Node) = + let startSpan = node_.ext.span + endSpan = + case NonEmpty.nonEmpty node_.entries of + Just entries -> (NonEmpty.last entries).value.ext.span + Nothing -> node_.name.ext.span + in Span + { startLine = startSpan.startLine + , startCol = startSpan.startCol + , endLine = endSpan.endLine + , endCol = endSpan.endCol + } + inc k = Map.insertWith (+) k 1 -- | Decode all remaining nodes. @@ -569,7 +612,7 @@ , validTypeAnns = typeAnns , nodeSchema = decoder.schema } - decodeNode a node_ = do + decodeNode a node_ = discardHints $ do validateAnn typeAnns node_.ann runDecodeStateM node_ emptyDecodeHistory $ do -- TODO: add typeHint to Context @@ -582,17 +625,9 @@ [] -> pure () Entry{name = Nothing, value} : _ -> do index <- StateT.gets getArgIndex - Trans.lift . decodeThrow $ - DecodeError_UnexpectedArg - { index = index - , value = value - } + Trans.lift . decodeThrow $ DecodeError_UnexpectedArg{index, value} Entry{name = Just identifier, value} : _ -> do - Trans.lift . decodeThrow $ - DecodeError_UnexpectedProp - { identifier = identifier - , value = value - } + Trans.lift . decodeThrow $ DecodeError_UnexpectedProp{identifier, value} case node_.children of Nothing -> pure () Just children_ -> do @@ -635,7 +670,7 @@ emptyNode name = Node { ann = Nothing - , name = name + , name , entries = [] , children = Nothing , ext = def @@ -689,15 +724,23 @@ withTypedValueDecoder $ \schema decodeValue -> DecodeArrow (SchemaOne $ NodeArg schema) $ \a -> do index <- StateT.gets getArgIndex + let + expectedArgError = + DecodeError_ExpectedArg + { index + , label = Nothing + , expectedTypes = getValueSchemaNames schema.dataSchema + } + argContext = ContextArg{index, label = Nothing} entries <- StateT.gets (.object.entries) (entry, entries') <- - maybe (Trans.lift $ decodeThrow DecodeError_ExpectedArg{index = index}) pure $ + maybe (Trans.lift $ decodeThrow expectedArgError) pure $ extractFirst (isNothing . (.name)) entries StateT.modify $ \s -> s{object = s.object{entries = entries'}} b <- - Trans.lift . addContext ContextArg{index = index} $ + Trans.lift . addContext entry.value.ext.span argContext $ decodeValue a entry.value StateT.modify $ \s -> s{history = s.history{argsSeen = s.history.argsSeen + 1}} pure b @@ -744,8 +787,14 @@ propWith' name = withTypedValueDecoder $ \schema decodeValue -> DecodeArrow (SchemaOne $ NodeProp name schema) $ \a -> do + let expectedPropError = + DecodeError_ExpectedProp + { name + , expectedTypes = getValueSchemaNames schema.dataSchema + } + decodeOnePropWhere (== name) (decodeValue a) - >>= maybe (Trans.lift $ decodeThrow DecodeError_ExpectedProp{name = name}) (pure . snd) + >>= maybe (Trans.lift $ decodeThrow expectedPropError) (pure . snd) decodeOnePropWhere :: (Text -> Bool) -> @@ -758,7 +807,7 @@ Just (name, prop_, entries') -> do StateT.modify $ \s -> s{object = s.object{entries = entries'}} b <- - Trans.lift . addContext ContextProp{name = name} $ + Trans.lift . addContext prop_.value.ext.span ContextProp{name} $ decodeValue prop_.value StateT.modify $ \s -> s{history = s.history{propsSeen = Set.insert name s.history.propsSeen}} pure $ Just (name, b) @@ -1030,7 +1079,7 @@ -- | Decode a KDL string value. string :: DecodeArrow Value a Text -string = valueDataDecoderPrim (SchemaOne TextSchema) $ \case +string = valueDataDecoderPrim (SchemaOne StringSchema) $ \case Value{data_ = String s} -> pure s v -> decodeThrow DecodeError_ValueDecodeFail{expectedType = "string", value = v} @@ -1051,6 +1100,44 @@ null = valueDataDecoderPrim (SchemaOne NullSchema) $ \case Value{data_ = Null} -> pure () v -> decodeThrow DecodeError_ValueDecodeFail{expectedType = "null", value = v} + +{----- Modifiers -----} + +-- | Add a label to any errors that occur in the given decoder. +-- +-- Currently only labels arguments. +-- +-- Behavior is undefined if multiple labellable things are being decoded. +-- +-- === __Example__ +-- +-- @ +-- KDL.label "name" KDL.arg +-- KDL.label "name" $ KDL.argAt "foo" +-- @ +label :: Text -> DecodeArrow o a b -> DecodeArrow o a b +label name decoder = + decoder + { run = \a -> + StateT.mapStateT (mapErrors addLabel) $ + decoder.run a + } + where + addLabel (ctx, kind) = + let ctx' = + ctx + { path = + [ case item of + ContextArg{label = _, ..} -> ContextArg{label = Just name, ..} + _ -> item + | item <- ctx.path + ] + } + kind' = + case kind of + DecodeError_ExpectedArg{label = _, ..} -> DecodeError_ExpectedArg{label = Just name, ..} + _ -> kind + in (ctx', kind') {----- Utilities -----} diff --git a/src/KDL/Decoder/Internal/DecodeM.hs b/src/KDL/Decoder/Internal/DecodeM.hs --- a/src/KDL/Decoder/Internal/DecodeM.hs +++ b/src/KDL/Decoder/Internal/DecodeM.hs @@ -11,46 +11,52 @@ -- * DecodeM monad DecodeM (..), + DecodeHints, runDecodeM, decodeThrow, failM, + mapErrors, addContext, + discardHints, ) where import Control.Applicative (Alternative (..)) import Data.Bifunctor (first) +import Data.Default (def) import Data.List.NonEmpty (NonEmpty (..)) import Data.List.NonEmpty qualified as NonEmpty import Data.Text (Text) import KDL.Decoder.Internal.Error +import KDL.Decoder.Internal.Error qualified as Error +import KDL.Types (Span) +import Prelude hiding (span) -- | The monad that returns either a 'DecodeError' or a result of type @a@. --- --- 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. +data DecodeM a + = DecodeM_Found a DecodeHints + | DecodeM_Fail (NonEmpty BaseDecodeError) + +-- | Hints to provide additional context in a future error after a successful +-- branch. -- -- 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_Found a [BaseDecodeError] - | DecodeM_Fail (NonEmpty BaseDecodeError) +type DecodeHints = [BaseDecodeError] instance Functor DecodeM where 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_Found x [] + pure x = DecodeM_Found x mempty 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_Found f es1, DecodeM_Found a es2) -> DecodeM_Found (f a) (es1 <> es2) + (DecodeM_Found _ es1, DecodeM_Fail es2) -> DecodeM_Fail (mergeHintsL es1 es2) + (DecodeM_Fail es1, DecodeM_Found _ es2) -> DecodeM_Fail (mergeHintsR es1 es2) (DecodeM_Fail es1, DecodeM_Fail es2) -> DecodeM_Fail (mergeErrors es1 es2) instance Monad DecodeM where (>>) = (*>) @@ -59,8 +65,8 @@ 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) + DecodeM_Found b es2 -> DecodeM_Found b (es1 <> es2) + DecodeM_Fail es2 -> DecodeM_Fail (mergeHintsL es1 es2) instance Alternative DecodeM where empty = failM "" l <|> r = @@ -68,7 +74,7 @@ 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_Found a es2 -> DecodeM_Found a (NonEmpty.toList es1 <> es2) DecodeM_Fail es2 -> DecodeM_Fail (mergeErrors es1 es2) -- | Run a 'DecodeM' action and return the result or the deepest error found. @@ -77,6 +83,8 @@ DecodeM_Found a _ -> Right a DecodeM_Fail errors -> Left DecodeError{filepath = Nothing, errors} +{----- mergeErrors -----} + mergeErrors :: NonEmpty BaseDecodeError -> NonEmpty BaseDecodeError -> @@ -87,43 +95,53 @@ EQ -> es1 <> es2 GT -> es1 where - key = length . fst . NonEmpty.head + key = length . (.path) . fst . NonEmpty.head -mergeErrorsL :: - [BaseDecodeError] -> +mergeHintsL :: + DecodeHints -> NonEmpty BaseDecodeError -> NonEmpty BaseDecodeError -mergeErrorsL l r = maybe r (\l' -> mergeErrors l' r) (NonEmpty.nonEmpty l) +mergeHintsL l r = maybe r (\l' -> mergeErrors l' r) (NonEmpty.nonEmpty l) -mergeErrorsR :: +mergeHintsR :: NonEmpty BaseDecodeError -> - [BaseDecodeError] -> + DecodeHints -> NonEmpty BaseDecodeError -mergeErrorsR l r = maybe l (\r' -> mergeErrors l r') (NonEmpty.nonEmpty r) +mergeHintsR 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) +{----- DecodeM operations -----} mapErrors :: (BaseDecodeError -> BaseDecodeError) -> DecodeM a -> DecodeM a mapErrors f = \case - DecodeM_Found a es -> DecodeM_Found a (fmap f es) + DecodeM_Found a es -> DecodeM_Found a (map f es) DecodeM_Fail es -> DecodeM_Fail (fmap f es) +mapErrorContext :: (Error.Context -> Error.Context) -> DecodeM a -> DecodeM a +mapErrorContext f = mapErrors (first f) + -- | Throw an error. decodeThrow :: DecodeErrorKind -> DecodeM a -decodeThrow e = DecodeM_Fail . NonEmpty.singleton $ ([], e) +decodeThrow e = DecodeM_Fail . NonEmpty.singleton $ (def, 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 = mapErrors (first (ctxItem :)) +addContext :: Span -> ContextItem -> DecodeM a -> DecodeM a +addContext span ctxItem = mapErrorContext $ \ctx -> + ctx + { path = ctxItem : ctx.path + , -- Span should only be attached to the nearest context; i.e. the first + -- addContext that runs + span = ctx.span <|> span' + } + where + -- Ignore span if it's empty + span' = if span == def then Nothing else Just span + +-- | Discard hints after validating that an error context is successful. +discardHints :: DecodeM a -> DecodeM a +discardHints = \case + DecodeM_Found a _ -> DecodeM_Found a mempty + DecodeM_Fail es -> DecodeM_Fail es diff --git a/src/KDL/Decoder/Internal/Error.hs b/src/KDL/Decoder/Internal/Error.hs --- a/src/KDL/Decoder/Internal/Error.hs +++ b/src/KDL/Decoder/Internal/Error.hs @@ -9,14 +9,15 @@ DecodeError (..), BaseDecodeError, DecodeErrorKind (..), - Context, + Context (..), ContextItem (..), renderDecodeError, ) where +import Control.Exception (Exception (..)) +import Data.Default (Default (..)) 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 import KDL.Render ( @@ -25,8 +26,11 @@ ) import KDL.Types ( Identifier, + Span (..), Value, ) +import System.FilePath (takeFileName) +import Prelude hiding (span) data DecodeError = DecodeError { filepath :: Maybe FilePath @@ -34,9 +38,26 @@ } deriving (Show, Eq) +instance Exception DecodeError where + displayException = Text.unpack . renderDecodeError + type BaseDecodeError = (Context, DecodeErrorKind) -type Context = [ContextItem] +data Context = Context + { path :: [ContextItem] + , span :: Maybe Span + , srcLine :: Maybe Text + } + deriving (Show, Eq) + +instance Default Context where + def = + Context + { path = [] + , span = Nothing + , srcLine = Nothing + } + data ContextItem = ContextNode { name :: Identifier @@ -44,6 +65,7 @@ } | ContextArg { index :: Int + , label :: Maybe Text } | ContextProp { name :: Identifier @@ -54,8 +76,8 @@ = DecodeError_Custom Text | DecodeError_ParseError Text | DecodeError_ExpectedNode {name :: Text, index :: Int} - | DecodeError_ExpectedArg {index :: Int} - | DecodeError_ExpectedProp {name :: Text} + | DecodeError_ExpectedArg {index :: Int, label :: Maybe Text, expectedTypes :: [Text]} + | DecodeError_ExpectedProp {name :: Text, expectedTypes :: [Text]} | DecodeError_MismatchedAnn {givenAnn :: Identifier, validAnns :: [Text]} | DecodeError_ValueDecodeFail {expectedType :: Text, value :: Value} | DecodeError_UnexpectedNode {identifier :: Identifier, index :: Int} @@ -67,48 +89,119 @@ renderDecodeError decodeError = Text.intercalate "\n" . concatMap renderCtxErrors - . groupCtxErrors + . NonEmpty.groupAllWith1 groupKey $ decodeError.errors where -- Group errors with the same contexts together - groupCtxErrors es = - Map.toAscList . Map.fromListWith (<>) $ - [ (ctx, [e]) - | (ctx, e) <- NonEmpty.toList es - ] - - addPath = - case decodeError.filepath of - Nothing -> id - Just fp -> let msg = "Failed to decode " <> Text.pack fp <> ":" in (msg :) + groupKey (ctx, _) = maybe (Left ctx.path) Right ctx.span renderCtxErrors = \case -- Special case parse errors, which shouldn't have a context - (_, [DecodeError_ParseError msg]) -> [msg] - (ctx, errs) -> addPath $ ("At: " <> renderCtxItems ctx) : renderErrors errs + (_, DecodeError_ParseError msg) NonEmpty.:| _ -> [msg] + errs -> + let (ctx, _) = NonEmpty.head errs + in renderCtx ctx $ (map (renderError . snd) $ NonEmpty.toList errs) - renderCtxItems items - | null items = "" - | otherwise = Text.intercalate " > " . map renderCtxItem $ items - renderCtxItem = \case + renderCtx (ctx :: Context) = + case ctx.span of + Nothing -> renderCtxPath ctx.path + Just span -> renderCtxFull span ctx + + -- If we don't have the error span, the best we can do is render the context path: + -- + -- At: foo.kdl > user #0 > arg #0 + -- ├─ error message + -- └─ another error message + renderCtxPath path errors = + let pathDisplay = + Text.intercalate " > " . concat $ + [ case decodeError.filepath of + Nothing -> [] + Just fp -> [Text.pack $ takeFileName fp] + , if null path then ["(root)"] else map renderCtxPathItem path + ] + errors' = + [ (if isLast then "└─ " else "├─ ") <> err + | (err, isLast) <- withIsLast errors + ] + in ("At: " <> pathDisplay) : errors' + renderCtxPathItem = \case ContextNode{..} -> renderIdentifier name <> " #" <> showT index - ContextArg{..} -> "arg #" <> showT index + ContextArg{..} -> renderArg index label ContextProp{..} -> "prop " <> renderIdentifier name - renderErrors = map (" " <>) . concatMap (Text.lines . renderError) + -- If we have the error span, show a descriptive error message: + -- + -- foo.kdl:3:16: + -- • Expected number, got string + -- | + -- 3 | some_child bad-value + -- | ^^^^^^^^^ + renderCtxFull (span :: Span) ctx errors = + let spanDisplay = + Text.concat . map (<> ":") $ + [ maybe "" Text.pack decodeError.filepath + , showT span.startLine + , showT span.startCol + ] + errors' = map (" • " <>) errors + preview = + case ctx.srcLine of + Nothing -> [] + Just line -> + let lineNum = showT span.startLine + spaces n = Text.replicate n " " + renderPrefix isSpace = (if isSpace then spaces (Text.length lineNum) else lineNum) <> " │" + spanLength = + if span.startLine == span.endLine + then span.endCol - span.startCol + 1 + else Text.length line - span.startCol + 1 + in [ renderPrefix True + , renderPrefix False <> " " <> line + , renderPrefix True <> spaces span.startCol <> Text.replicate spanLength "^" + ] + in spanDisplay : errors' ++ preview + renderError = \case DecodeError_Custom msg -> msg DecodeError_ParseError msg -> msg DecodeError_ExpectedNode{..} | index == 0 -> "Expected node: " <> name | otherwise -> "Expected another node: " <> name - DecodeError_ExpectedArg{..} -> "Expected arg #" <> showT index - DecodeError_ExpectedProp{..} -> "Expected prop: " <> name + DecodeError_ExpectedArg{..} -> + Text.concat + [ "Expected " + , renderArg index label + , if null expectedTypes + then "" + else " with type: " <> oxfordList "or" expectedTypes + ] + DecodeError_ExpectedProp{..} -> + Text.concat + [ "Expected prop '" <> name <> "'" + , if null expectedTypes + then "" + else " with type: " <> oxfordList "or" expectedTypes + ] DecodeError_MismatchedAnn{..} -> "Expected annotation to be one of " <> showT validAnns <> ", got: " <> renderIdentifier givenAnn DecodeError_ValueDecodeFail{..} -> "Expected " <> expectedType <> ", got: " <> renderValue value DecodeError_UnexpectedNode{..} -> "Unexpected node: " <> renderIdentifier identifier <> " #" <> showT index DecodeError_UnexpectedArg{..} -> "Unexpected arg #" <> showT index <> ": " <> renderValue value DecodeError_UnexpectedProp{..} -> "Unexpected prop: " <> renderIdentifier identifier <> "=" <> renderValue value + + renderArg index label = "arg " <> maybe ("#" <> showT index) (\s -> "'" <> s <> "'") label + + oxfordList conj = \case + [x] -> x + [x, y] -> Text.unwords [x, conj, y] + xs -> Text.intercalate ", " $ mapLast ((conj <> " ") <>) xs + + mapLast f = \case + [] -> [] + [x] -> [f x] + x : xs -> x : mapLast f xs + + withIsLast = mapLast (True <$) . map (\x -> (x, False)) -- Replace with Text.show after requiring at least text-2.1.2 showT :: (Show a) => a -> Text diff --git a/src/KDL/Decoder/Schema.hs b/src/KDL/Decoder/Schema.hs --- a/src/KDL/Decoder/Schema.hs +++ b/src/KDL/Decoder/Schema.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} module KDL.Decoder.Schema ( @@ -10,6 +11,10 @@ TypedValueSchema (..), schemaJoin, schemaAlt, + + -- * Fold over schema items + foldSchema, + getValueSchemaNames, ) where import Data.Text (Text) @@ -59,7 +64,7 @@ deriving (Show, Eq) data instance SchemaItem Value - = TextSchema + = StringSchema | NumberSchema | BoolSchema | NullSchema @@ -82,3 +87,22 @@ (SchemaOr [], r) -> r (SchemaOr l, r) -> SchemaOr (l <> [r]) (l, r) -> SchemaOr [l, r] + +{------ Fold over schema items -----} + +foldSchema :: (SchemaItem a -> b) -> SchemaOf a -> [b] +foldSchema f = go + where + go = \case + SchemaOne valSchema -> [f valSchema] + SchemaSome s -> go s + SchemaAnd ss -> concatMap go ss + SchemaOr ss -> concatMap go ss + SchemaUnknown -> [] + +getValueSchemaNames :: SchemaOf Value -> [Text] +getValueSchemaNames = foldSchema $ \case + StringSchema -> "string" + NumberSchema -> "number" + BoolSchema -> "bool" + NullSchema -> "null" diff --git a/test/KDL/ApplicativeSpec.hs b/test/KDL/ApplicativeSpec.hs --- a/test/KDL/ApplicativeSpec.hs +++ b/test/KDL/ApplicativeSpec.hs @@ -58,7 +58,7 @@ , dataSchema = KDL.SchemaOr [ KDL.SchemaOne KDL.BoolSchema - , KDL.SchemaOne KDL.TextSchema + , KDL.SchemaOne KDL.StringSchema ] } } @@ -72,7 +72,7 @@ KDL.TypedValueSchema { typeHint = typeRep $ Proxy @String , validTypeAnns = ["string"] - , dataSchema = KDL.SchemaOne KDL.TextSchema + , dataSchema = KDL.SchemaOne KDL.StringSchema } } , KDL.SchemaAnd [] @@ -86,7 +86,7 @@ KDL.TypedValueSchema { typeHint = typeRep $ Proxy @Text , validTypeAnns = ["string"] - , dataSchema = KDL.SchemaOne KDL.TextSchema + , dataSchema = KDL.SchemaOne KDL.StringSchema } } , KDL.SchemaOne . KDL.NodeNamed "baz" $ diff --git a/test/KDL/Decoder/ArrowSpec.hs b/test/KDL/Decoder/ArrowSpec.hs --- a/test/KDL/Decoder/ArrowSpec.hs +++ b/test/KDL/Decoder/ArrowSpec.hs @@ -56,7 +56,7 @@ , dataSchema = KDL.SchemaOr [ KDL.SchemaOne KDL.BoolSchema - , KDL.SchemaOne KDL.TextSchema + , KDL.SchemaOne KDL.StringSchema ] } } @@ -70,7 +70,7 @@ KDL.TypedValueSchema { typeHint = typeRep $ Proxy @String , validTypeAnns = ["string"] - , dataSchema = KDL.SchemaOne KDL.TextSchema + , dataSchema = KDL.SchemaOne KDL.StringSchema } } , KDL.SchemaAnd [] @@ -84,7 +84,7 @@ KDL.TypedValueSchema { typeHint = typeRep $ Proxy @Text , validTypeAnns = ["string"] - , dataSchema = KDL.SchemaOne KDL.TextSchema + , dataSchema = KDL.SchemaOne KDL.StringSchema } } , KDL.SchemaOne . KDL.NodeNamed "baz" $ diff --git a/test/KDL/Decoder/SharedSpec/Template.hs b/test/KDL/Decoder/SharedSpec/Template.hs --- a/test/KDL/Decoder/SharedSpec/Template.hs +++ b/test/KDL/Decoder/SharedSpec/Template.hs @@ -27,7 +27,8 @@ decodeValueSpec, ) where -import Control.Monad (forM_, unless) +import Control.Applicative ((<|>)) +import Control.Monad (forM_, unless, void) import Data.Map qualified as Map import Data.Text (Text) import Data.Text qualified as Text @@ -116,8 +117,8 @@ _RETURN_((foo1, foo2)) KDL.decodeWith decoder config `shouldSatisfy` decodeErrorMsg - [ "At: " - , " Expected another node: foo" + [ "At: (root)" + , "└─ Expected another node: foo" ] -- Most behaviors tested with `node` @@ -140,8 +141,11 @@ _STMT_(KDL.nodeWith "foo" decodeFoo) KDL.decodeWith decoder config `shouldSatisfy` decodeErrorMsg - [ "At: foo #0 > arg #0" - , " Expected string, got: 1.0" + [ ":1:5:" + , " • Expected string, got: 1.0" + , " │" + , "1 │ foo 1.0" + , " │ ^^^" ] -- Most behaviors tested with `nodeWith` @@ -176,8 +180,11 @@ _STMT_(_APOS_(KDL.nodeWith) "foo" ["FOO"] $ KDL.arg @Int) KDL.decodeWith decoder config `shouldSatisfy` decodeErrorMsg - [ "At: foo #0" - , " Expected annotation to be one of [\"FOO\"], got: test" + [ ":1:1:" + , " • Expected annotation to be one of [\"FOO\"], got: test" + , " │" + , "1 │ (test)foo 2" + , " │ ^^^^^^^^^^^" ] describe "remainingNodes" $ do @@ -239,8 +246,11 @@ _STMT_(KDL.remainingNodesWith decodeNode) KDL.decodeWith decoder config `shouldSatisfy` decodeErrorMsg - [ "At: bar #1 > arg #0" - , " Expected number, got: hello" + [ ":1:19:" + , " • Expected number, got: hello" + , " │" + , "1 │ foo 1; bar 1; bar hello" + , " │ ^^^^^" ] -- Most behaviors tested with `remainingNodesWith` @@ -277,8 +287,11 @@ _STMT_(_APOS_(KDL.remainingNodesWith) ["FOO"] $ KDL.arg @Int) KDL.decodeWith decoder config `shouldSatisfy` decodeErrorMsg - [ "At: foo #1" - , " Expected annotation to be one of [\"FOO\"], got: test" + [ ":1:13:" + , " • Expected annotation to be one of [\"FOO\"], got: test" + , " │" + , "1 │ (FOO)foo 1; (test)foo 2" + , " │ ^^^^^^^^^^^" ] describe "argAt" $ do @@ -296,8 +309,8 @@ _STMT_(KDL.argAt @Int "foo") KDL.decodeWith decoder config `shouldSatisfy` decodeErrorMsg - [ "At: " - , " Expected node: foo" + [ "At: (root)" + , "└─ Expected node: foo" ] it "fails if node has no args" $ do @@ -306,8 +319,11 @@ _STMT_(KDL.argAt @Int "foo") KDL.decodeWith decoder config `shouldSatisfy` decodeErrorMsg - [ "At: foo #0" - , " Expected arg #0" + [ ":1:1:" + , " • Expected arg #0 with type: number" + , " │" + , "1 │ foo" + , " │ ^^^" ] it "fails if arg fails to parse" $ do @@ -316,10 +332,39 @@ _STMT_(KDL.argAt @Text "foo") KDL.decodeWith decoder config `shouldSatisfy` decodeErrorMsg - [ "At: foo #0 > arg #0" - , " Expected string, got: 1" + [ ":1:5:" + , " • Expected string, got: 1" + , " │" + , "1 │ foo 1" + , " │ ^" ] + it "shows label on missing arg" $ do + let config = "foo" + decoder = KDL.document $ _DO_ + _STMT_(KDL.label "value" $ KDL.argAt @Int "foo") + KDL.decodeWith decoder config + `shouldSatisfy` decodeErrorMsg + [ ":1:1:" + , " • Expected arg 'value' with type: number" + , " │" + , "1 │ foo" + , " │ ^^^" + ] + + it "shows label on invalid arg" $ do + let config = "foo 1" + decoder = KDL.document $ _DO_ + _STMT_(KDL.label "value" $ KDL.argAt @Text "foo") + KDL.decodeWith decoder config + `shouldSatisfy` decodeErrorMsg + [ ":1:5:" + , " • Expected string, got: 1" + , " │" + , "1 │ foo 1" + , " │ ^" + ] + -- Most behaviors tested with `argAt` describe "argAtWith" $ do it "gets argument at a node" $ do @@ -360,8 +405,11 @@ _STMT_(_APOS_(KDL.argAtWith) "foo" ["VAL"] KDL.string) KDL.decodeWith decoder config `shouldSatisfy` decodeErrorMsg - [ "At: foo #0 > arg #0" - , " Expected annotation to be one of [\"VAL\"], got: test" + [ ":1:5:" + , " • Expected annotation to be one of [\"VAL\"], got: test" + , " │" + , "1 │ foo (test)a" + , " │ ^^^^^^^" ] describe "argsAt" $ do @@ -389,8 +437,11 @@ _STMT_(KDL.argsAt @Int "foo") KDL.decodeWith decoder config `shouldSatisfy` decodeErrorMsg - [ "At: foo #0 > arg #1" - , " Expected number, got: asdf" + [ ":1:7:" + , " • Expected number, got: asdf" + , " │" + , "1 │ foo 1 asdf" + , " │ ^^^^" ] -- Most behaviors tested with `argsAt` @@ -433,8 +484,11 @@ _STMT_(_APOS_(KDL.argsAtWith) "foo" ["VAL"] KDL.string) KDL.decodeWith decoder config `shouldSatisfy` decodeErrorMsg - [ "At: foo #0 > arg #1" - , " Expected annotation to be one of [\"VAL\"], got: test" + [ ":1:12:" + , " • Expected annotation to be one of [\"VAL\"], got: test" + , " │" + , "1 │ foo (VAL)a (test)b" + , " │ ^^^^^^^" ] describe "dashChildrenAt" $ do @@ -462,8 +516,11 @@ _STMT_(KDL.dashChildrenAt @Int "foo") KDL.decodeWith decoder config `shouldSatisfy` decodeErrorMsg - [ "At: foo #0 > - #0" - , " Unexpected arg #1: 2" + [ ":1:7:" + , " • Unexpected arg #1: 2" + , " │" + , "1 │ foo { - 1 2; - 3 4; }" + , " │ ^^^^^" ] it "fails if node has non-dash children" $ do @@ -472,9 +529,12 @@ _STMT_(KDL.dashChildrenAt @Int "foo") KDL.decodeWith decoder config `shouldSatisfy` decodeErrorMsg - [ "At: foo #0" - , " Unexpected node: bar #0" - , " Expected another node: -" + [ ":1:1:" + , " • Expected another node: -" + , " • Unexpected node: bar #0" + , " │" + , "1 │ foo { - 1; bar 1 2 3; }" + , " │ ^^^" ] it "fails if any child fails to parse" $ do @@ -483,8 +543,11 @@ _STMT_(KDL.dashChildrenAt @Int "foo") KDL.decodeWith decoder config `shouldSatisfy` decodeErrorMsg - [ "At: foo #0 > - #1 > arg #0" - , " Expected number, got: asdf" + [ ":1:14:" + , " • Expected number, got: asdf" + , " │" + , "1 │ foo { - 1; - asdf; }" + , " │ ^^^^" ] -- Most behaviors tested with `dashChildrenAt` @@ -527,8 +590,11 @@ _STMT_(_APOS_(KDL.dashChildrenAtWith) "foo" ["VAL"] KDL.string) KDL.decodeWith decoder config `shouldSatisfy` decodeErrorMsg - [ "At: foo #0 > - #0 > arg #0" - , " Expected annotation to be one of [\"VAL\"], got: test" + [ ":1:9:" + , " • Expected annotation to be one of [\"VAL\"], got: test" + , " │" + , "1 │ foo { - (test)a; }" + , " │ ^^^^^^^" ] describe "dashNodesAt" $ do @@ -568,9 +634,12 @@ _STMT_(KDL.dashNodesAt @Node "foo") KDL.decodeWith decoder config `shouldSatisfy` decodeErrorMsg - [ "At: foo #0" - , " Unexpected node: bar #0" - , " Expected another node: -" + [ ":1:1:" + , " • Expected another node: -" + , " • Unexpected node: bar #0" + , " │" + , "1 │ foo { - 1; bar 1 2 3; }" + , " │ ^^^" ] -- Most behaviors tested with `dashNodesAt` @@ -591,8 +660,11 @@ _STMT_(KDL.dashNodesAtWith "foo" $ KDL.children $ KDL.argAt @Int "bar") KDL.decodeWith decoder config `shouldSatisfy` decodeErrorMsg - [ "At: foo #0 > - #1 > bar #0 > arg #0" - , " Expected number, got: test" + [ ":1:29:" + , " • Expected number, got: test" + , " │" + , "1 │ foo { - { bar 1; }; - { bar test; }; }" + , " │ ^^^^" ] describe "NodeDecoder" $ do @@ -624,8 +696,11 @@ _STMT_(KDL.arg @Int) decodeNode "foo" decoder config `shouldSatisfy` decodeErrorMsg - [ "At: foo #0" - , " Expected arg #0" + [ ":1:1:" + , " • Expected arg #0 with type: number" + , " │" + , "1 │ foo" + , " │ ^^^" ] it "fails if argument fails to parse" $ do @@ -634,8 +709,11 @@ _STMT_(KDL.arg @Int) decodeNode "foo" decoder config `shouldSatisfy` decodeErrorMsg - [ "At: foo #0 > arg #0" - , " Expected number, got: test" + [ ":1:5:" + , " • Expected number, got: test" + , " │" + , "1 │ foo test" + , " │ ^^^^" ] it "fails if not all arguments are decoded" $ do @@ -644,10 +722,52 @@ _STMT_(KDL.arg @Int) decodeNode "foo" decoder config `shouldSatisfy` decodeErrorMsg - [ "At: foo #0" - , " Unexpected arg #1: 2" + [ ":1:1:" + , " • Unexpected arg #1: 2" + , " │" + , "1 │ foo 1 2 3" + , " │ ^^^^^^^^^" ] + it "shows label on missing arg" $ do + let config = "foo" + decoder = _DO_ + _STMT_(KDL.label "value" $ KDL.arg @Int) + decodeNode "foo" decoder config + `shouldSatisfy` decodeErrorMsg + [ ":1:1:" + , " • Expected arg 'value' with type: number" + , " │" + , "1 │ foo" + , " │ ^^^" + ] + + it "shows expected types on missing arg" $ do + let config = "foo" + decoder = _DO_ + _STMT_(KDL.label "value" $ KDL.argWith $ void KDL.number <|> void KDL.string) + decodeNode "foo" decoder config + `shouldSatisfy` decodeErrorMsg + [ ":1:1:" + , " • Expected arg 'value' with type: number or string" + , " │" + , "1 │ foo" + , " │ ^^^" + ] + + it "shows label on invalid arg" $ do + let config = "foo test" + decoder = _DO_ + _STMT_(KDL.label "value" $ KDL.arg @Int) + decodeNode "foo" decoder config + `shouldSatisfy` decodeErrorMsg + [ ":1:5:" + , " • Expected number, got: test" + , " │" + , "1 │ foo test" + , " │ ^^^^" + ] + -- Most behaviors tested with `arg` describe "argWith" $ do it "decodes an argument" $ do @@ -688,8 +808,11 @@ _STMT_(_APOS_(KDL.argWith) ["VAL"] KDL.string) decodeNode "foo" decoder config `shouldSatisfy` decodeErrorMsg - [ "At: foo #0 > arg #0" - , " Expected annotation to be one of [\"VAL\"], got: test" + [ ":1:5:" + , " • Expected annotation to be one of [\"VAL\"], got: test" + , " │" + , "1 │ foo (test)a" + , " │ ^^^^^^^" ] it "supports backtracking annotations" $ do @@ -732,8 +855,11 @@ _STMT_(KDL.prop @Int "test") decodeNode "foo" decoder config `shouldSatisfy` decodeErrorMsg - [ "At: foo #0" - , " Expected prop: test" + [ ":1:1:" + , " • Expected prop 'test' with type: number" + , " │" + , "1 │ foo 123" + , " │ ^^^^^^^" ] it "fails if prop fails to parse" $ do @@ -742,8 +868,11 @@ _STMT_(KDL.prop @Int "hello") decodeNode "foo" decoder config `shouldSatisfy` decodeErrorMsg - [ "At: foo #0 > prop hello" - , " Expected number, got: world" + [ ":1:11:" + , " • Expected number, got: world" + , " │" + , "1 │ foo hello=world" + , " │ ^^^^^" ] it "fails if not all props are decoded" $ do @@ -752,10 +881,26 @@ _STMT_(KDL.prop @Int "a") decodeNode "foo" decoder config `shouldSatisfy` decodeErrorMsg - [ "At: foo #0" - , " Unexpected prop: b=2" + [ ":1:1:" + , " • Unexpected prop: b=2" + , " │" + , "1 │ foo a=1 b=2" + , " │ ^^^^^^^^^^^" ] + it "shows expected types on missing prop" $ do + let config = "foo 123" + decoder = _DO_ + _STMT_(KDL.propWith "test" $ void KDL.number <|> void KDL.string) + decodeNode "foo" decoder config + `shouldSatisfy` decodeErrorMsg + [ ":1:1:" + , " • Expected prop 'test' with type: number or string" + , " │" + , "1 │ foo 123" + , " │ ^^^^^^^" + ] + -- Most behaviors tested with `prop` describe "propWith" $ do it "decodes a prop" $ do @@ -796,8 +941,11 @@ _STMT_(_APOS_(KDL.propWith) "a" ["VAL"] KDL.number) decodeNode "foo" decoder config `shouldSatisfy` decodeErrorMsg - [ "At: foo #0 > prop a" - , " Expected annotation to be one of [\"VAL\"], got: test" + [ ":1:7:" + , " • Expected annotation to be one of [\"VAL\"], got: test" + , " │" + , "1 │ foo a=(test)1" + , " │ ^^^^^^^" ] describe "remainingProps" $ do @@ -823,8 +971,11 @@ _STMT_(KDL.remainingProps @Int) decodeNode "foo" decoder config `shouldSatisfy` decodeErrorMsg - [ "At: foo #0 > prop c" - , " Expected number, got: test" + [ ":1:19:" + , " • Expected number, got: test" + , " │" + , "1 │ foo a=1 b=1 c=2 c=test" + , " │ ^^^^" ] -- Most behaviors tested with `remainingProps` @@ -871,8 +1022,11 @@ _STMT_(_APOS_(KDL.remainingPropsWith) ["VAL"] KDL.number) decodeNode "foo" decoder config `shouldSatisfy` decodeErrorMsg - [ "At: foo #0 > prop b" - , " Expected annotation to be one of [\"VAL\"], got: test" + [ ":1:16:" + , " • Expected annotation to be one of [\"VAL\"], got: test" + , " │" + , "1 │ foo a=(VAL)1 b=(test)2" + , " │ ^^^^^^^" ] describe "children" $ do @@ -910,8 +1064,11 @@ _STMT_(KDL.children $ KDL.node @Node "bar") decodeNode "foo" decoder config `shouldSatisfy` decodeErrorMsg - [ "At: foo #0" - , " Unexpected node: asdf #0" + [ ":1:1:" + , " • Unexpected node: asdf #0" + , " │" + , "1 │ foo { asdf; bar; }" + , " │ ^^^" ] describe "ValueDecoder" $ do @@ -942,8 +1099,11 @@ _STMT_(KDL.argAtWith "foo" KDL.string) KDL.decodeWith decoder config `shouldSatisfy` decodeErrorMsg - [ "At: foo #0 > arg #0" - , " Expected string, got: 1" + [ ":1:5:" + , " • Expected string, got: 1" + , " │" + , "1 │ foo 1" + , " │ ^" ] describe "number" $ do @@ -959,8 +1119,11 @@ _STMT_(KDL.argAtWith "foo" KDL.number) KDL.decodeWith decoder config `shouldSatisfy` decodeErrorMsg - [ "At: foo #0 > arg #0" - , " Expected number, got: asdf" + [ ":1:5:" + , " • Expected number, got: asdf" + , " │" + , "1 │ foo asdf" + , " │ ^^^^" ] describe "bool" $ do @@ -976,8 +1139,11 @@ _STMT_(KDL.argAtWith "foo" KDL.bool) KDL.decodeWith decoder config `shouldSatisfy` decodeErrorMsg - [ "At: foo #0 > arg #0" - , " Expected bool, got: 1" + [ ":1:5:" + , " • Expected bool, got: 1" + , " │" + , "1 │ foo 1" + , " │ ^" ] describe "null" $ do @@ -993,8 +1159,11 @@ _STMT_(KDL.argAtWith "foo" KDL.null) KDL.decodeWith decoder config `shouldSatisfy` decodeErrorMsg - [ "At: foo #0 > arg #0" - , " Expected null, got: 1" + [ ":1:5:" + , " • Expected null, got: 1" + , " │" + , "1 │ foo 1" + , " │ ^" ] describe "Combinators" $ do @@ -1013,9 +1182,12 @@ _STMT_(KDL.nodeWith "foo" . KDL.many . KDL.argWith $ KDL.oneOf decodeVal) KDL.decodeWith decoder config `shouldSatisfy` decodeErrorMsg - [ "At: foo #0 > arg #1" - , " Expected bool, got: hello" - , " Expected number, got: hello" + [ ":1:9:" + , " • Expected number, got: hello" + , " • Expected bool, got: hello" + , " │" + , "1 │ foo 123 hello" + , " │ ^^^^^" ] describe "option" $ do @@ -1059,8 +1231,11 @@ _STMT_(KDL.node @MyNode "foo") KDL.decodeWith decoder config `shouldSatisfy` decodeErrorMsg - [ "At: foo #0" - , " Invalid argument: 100" + [ ":1:1:" + , " • Invalid argument: 100" + , " │" + , "1 │ foo 100" + , " │ ^^^^^^^" ] it "decodes valid type ann" $ do @@ -1075,8 +1250,11 @@ _STMT_(KDL.node @MyNode "foo") KDL.decodeWith decoder config `shouldSatisfy` decodeErrorMsg - [ "At: foo #0" - , " Expected annotation to be one of [\"MyNode\"], got: bad" + [ ":1:1:" + , " • Expected annotation to be one of [\"MyNode\"], got: bad" + , " │" + , "1 │ (bad)foo 1" + , " │ ^^^^^^^^^^" ] newtype MyVal = MyVal Double @@ -1104,8 +1282,11 @@ _STMT_(KDL.argAt @MyVal "foo") KDL.decodeWith decoder config `shouldSatisfy` decodeErrorMsg - [ "At: foo #0 > arg #0" - , " Invalid value: 100.0" + [ ":1:5:" + , " • Invalid value: 100.0" + , " │" + , "1 │ foo 100.0" + , " │ ^^^^^" ] it "decodes valid type ann" $ do @@ -1120,6 +1301,9 @@ _STMT_(KDL.argAt @MyVal "foo") KDL.decodeWith decoder config `shouldSatisfy` decodeErrorMsg - [ "At: foo #0 > arg #0" - , " Expected annotation to be one of [\"MyVal\"], got: bad" + [ ":1:5:" + , " • Expected annotation to be one of [\"MyVal\"], got: bad" + , " │" + , "1 │ foo (bad)1" + , " │ ^^^^^^" ] diff --git a/test/KDL/DecoderSpec.hs b/test/KDL/DecoderSpec.hs --- a/test/KDL/DecoderSpec.hs +++ b/test/KDL/DecoderSpec.hs @@ -2,10 +2,12 @@ module KDL.DecoderSpec (spec) where -import Control.Monad (when) +import Control.Monad (unless, when) +import Data.Char (isAlpha) import Data.Text (Text) import Data.Text qualified as Text import KDL qualified +import KDL.TestUtils.Error (decodeErrorMsg) import KDL.Types (Node) import Skeletest import Skeletest.Predicate qualified as P @@ -21,6 +23,14 @@ spec :: Spec spec = do + spec_decodeWith + spec_decodeFileWith + spec_decodeDocWith + spec_errorMessages + spec_regressionTests + +spec_decodeWith :: Spec +spec_decodeWith = do describe "decodeWith" $ do it "fails with helpful error if parsing fails" $ do let config = "foo 123=123" @@ -47,6 +57,8 @@ $ KDL.optional (KDL.prop @Text "a") KDL.decodeWith decoder config `shouldSatisfy` decodeErrorMsgSnapshot Nothing +spec_decodeFileWith :: Spec +spec_decodeFileWith = do describe "decodeFileWith" $ do it "fails with helpful error if parsing fails" $ do FixtureKdlFile file <- getFixture @@ -76,9 +88,78 @@ $ KDL.optional (KDL.prop @Text "a") KDL.decodeFileWith decoder file `shouldSatisfy` P.returns (decodeErrorMsgSnapshot (Just file)) +spec_decodeDocWith :: Spec +spec_decodeDocWith = do + describe "decodeDocWith" $ do + it "fails with user-defined error" $ do + let config = "foo -1" + decoder = + KDL.document . KDL.argAtWith "foo" $ + KDL.withDecoder KDL.number $ \x -> do + when (x < 0) $ do + KDL.failM $ "Got negative number: " <> (Text.pack . show) x + pure x + Right doc <- pure $ KDL.parseWith KDL.def config + KDL.decodeDocWith decoder doc + `shouldSatisfy` decodeErrorMsgSnapshot Nothing + + it "shows context in deeply nested error" $ do + let config = "foo; foo { bar { baz; baz; baz; baz a=1; }; }" + decoder = + KDL.document + . (KDL.many . KDL.nodeWith "foo" . KDL.children) + . (KDL.many . KDL.nodeWith "bar" . KDL.children) + . (KDL.many . KDL.nodeWith "baz") + $ KDL.optional (KDL.prop @Text "a") + Right doc <- pure $ KDL.parseWith KDL.def config + KDL.decodeDocWith decoder doc + `shouldSatisfy` decodeErrorMsgSnapshot Nothing + +spec_errorMessages :: Spec +spec_errorMessages = do + describe "Error messages" $ do + it "only shows first line when context spans multiple lines" $ do + let config = "foo \\\n 1" + decoder = + KDL.document . KDL.nodeWith "foo" $ do + _ <- KDL.arg @Int + _ <- KDL.children $ KDL.argAt @Int "bar" + pure () + KDL.decodeWith decoder config `shouldSatisfy` decodeErrorMsgSnapshot Nothing + newtype FixtureKdlFile = FixtureKdlFile FilePath instance Fixture FixtureKdlFile where fixtureAction = do FixtureTmpDir tmpdir <- getFixture pure . noCleanup $ FixtureKdlFile (tmpdir "kdl-hs-test.kdl") + +{----- Regression tests -----} + +spec_regressionTests :: Spec +spec_regressionTests = do + describe "Regression tests" $ do + it "fails with correct error when error occurs in another node after backtracking in a previous node" $ do + let config = "user a { foo { bar } }; user a1" + decoder = + KDL.document . KDL.many . KDL.nodeWith "user" $ do + _ <- + KDL.children . KDL.many . KDL.nodeWith "foo" $ do + KDL.children . KDL.nodeWith "bar" $ do + KDL.children $ + sequence + [ KDL.optional $ KDL.node @KDL.Node "opt1" + , KDL.optional $ KDL.node @KDL.Node "opt2" + ] + KDL.argWith $ do + s <- KDL.string + unless (Text.all isAlpha s) $ do + KDL.fail "Invalid username" + KDL.decodeWith decoder config + `shouldSatisfy` decodeErrorMsg + [ ":1:30:" + , " • Invalid username" + , " │" + , "1 │ user a { foo { bar } }; user a1" + , " │ ^^" + ] diff --git a/test/KDL/__snapshots__/DecoderSpec.snap.md b/test/KDL/__snapshots__/DecoderSpec.snap.md --- a/test/KDL/__snapshots__/DecoderSpec.snap.md +++ b/test/KDL/__snapshots__/DecoderSpec.snap.md @@ -1,9 +1,9 @@ # test/KDL/DecoderSpec.hs -## decodeFileWith / fails with helpful error if parsing fails +## decodeWith ≫ fails with helpful error if parsing fails ``` -test_config.kdl:1:8: +1:8: | 1 | foo 123=123 | ^ @@ -11,26 +11,30 @@ expecting children block, decimal point, end of node, exponent, or node prop or arg ``` -## decodeFileWith / fails with user-defined error +## decodeWith ≫ fails with user-defined error ``` -Failed to decode test_config.kdl: -At: foo #0 > arg #0 - Got negative number: -1.0 +:1:5: + • Got negative number: -1.0 + │ +1 │ foo -1 + │ ^^ ``` -## decodeFileWith / shows context in deeply nested error +## decodeWith ≫ shows context in deeply nested error ``` -Failed to decode test_config.kdl: -At: foo #1 > bar #0 > baz #3 > prop a - Expected string, got: 1 +:1:39: + • Expected string, got: 1 + │ +1 │ foo; foo { bar { baz; baz; baz; baz a=1; }; } + │ ^ ``` -## decodeWith / fails with helpful error if parsing fails +## decodeFileWith ≫ fails with helpful error if parsing fails ``` -1:8: +test_config.kdl:1:8: | 1 | foo 123=123 | ^ @@ -38,16 +42,46 @@ expecting children block, decimal point, end of node, exponent, or node prop or arg ``` -## decodeWith / fails with user-defined error +## decodeFileWith ≫ fails with user-defined error ``` +test_config.kdl:1:5: + • Got negative number: -1.0 + │ +1 │ foo -1 + │ ^^ +``` + +## decodeFileWith ≫ shows context in deeply nested error + +``` +test_config.kdl:1:39: + • Expected string, got: 1 + │ +1 │ foo; foo { bar { baz; baz; baz; baz a=1; }; } + │ ^ +``` + +## decodeDocWith ≫ fails with user-defined error + +``` At: foo #0 > arg #0 - Got negative number: -1.0 +└─ Got negative number: -1.0 ``` -## decodeWith / shows context in deeply nested error +## decodeDocWith ≫ shows context in deeply nested error ``` At: foo #1 > bar #0 > baz #3 > prop a - Expected string, got: 1 +└─ Expected string, got: 1 +``` + +## Error messages ≫ only shows first line when context spans multiple lines + +``` +:1:1: + • Expected node: bar + │ +1 │ foo \ + │ ^^^^^ ``` diff --git a/test/KDL/__snapshots__/ParserSpec.snap.md b/test/KDL/__snapshots__/ParserSpec.snap.md --- a/test/KDL/__snapshots__/ParserSpec.snap.md +++ b/test/KDL/__snapshots__/ParserSpec.snap.md @@ -1,17 +1,6 @@ # test/KDL/ParserSpec.hs -## parse / error messages / Unquoted numeric prop name - -``` -1:8: - | -1 | foo 123=123 - | ^ -unexpected '=' -expecting children block, decimal point, end of node, exponent, or node prop or arg -``` - -## parse / parses a KDL document +## parse ≫ parses a KDL document ```haskell NodeList @@ -157,7 +146,18 @@ } ``` -## parseWith / parses a KDL document with spans +## parse ≫ error messages ≫ Unquoted numeric prop name + +``` +1:8: + | +1 | foo 123=123 + | ^ +unexpected '=' +expecting children block, decimal point, end of node, exponent, or node prop or arg +``` + +## parseWith ≫ parses a KDL document with spans ```haskell NodeList diff --git a/test/KDL/__snapshots__/RenderSpec.snap.md b/test/KDL/__snapshots__/RenderSpec.snap.md --- a/test/KDL/__snapshots__/RenderSpec.snap.md +++ b/test/KDL/__snapshots__/RenderSpec.snap.md @@ -1,6 +1,6 @@ # test/KDL/RenderSpec.hs -## render / default formatting / renders correctly +## render ≫ default formatting ≫ renders correctly ``` (Foo)foo (Foo)123.0 a=(Foo)123.0 test b=test {