kdl-hs 1.1.1 → 1.2.1
raw patch · 13 files changed
Files
- CHANGELOG.md +12/−0
- kdl-hs.cabal +7/−3
- src/KDL/Decoder/Arrow.hs +134/−47
- src/KDL/Decoder/Internal/DecodeM.hs +53/−35
- src/KDL/Decoder/Internal/Error.hs +119/−26
- src/KDL/Decoder/Schema.hs +25/−1
- test/KDL/ApplicativeSpec.hs +3/−3
- test/KDL/Decoder/ArrowSpec.hs +3/−3
- test/KDL/Decoder/SharedSpec/Template.hs +262/−78
- test/KDL/DecoderSpec.hs +82/−1
- test/KDL/__snapshots__/DecoderSpec.snap.md +50/−16
- test/KDL/__snapshots__/ParserSpec.snap.md +13/−13
- test/KDL/__snapshots__/RenderSpec.snap.md +1/−1
CHANGELOG.md view
@@ -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
kdl-hs.cabal view
@@ -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
src/KDL/Decoder/Arrow.hs view
@@ -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 -----}
src/KDL/Decoder/Internal/DecodeM.hs view
@@ -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 "<empty>" 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
src/KDL/Decoder/Internal/Error.hs view
@@ -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 = "<root>"- | 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 "<input>" 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
src/KDL/Decoder/Schema.hs view
@@ -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"
test/KDL/ApplicativeSpec.hs view
@@ -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" $
test/KDL/Decoder/ArrowSpec.hs view
@@ -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" $
@@ -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: <root>"- , " 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"+ [ "<input>: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"+ [ "<input>: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"+ [ "<input>: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"+ [ "<input>: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: <root>"- , " 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"+ [ "<input>: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"+ [ "<input>: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+ [ "<input>: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+ [ "<input>: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"+ [ "<input>: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"+ [ "<input>: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"+ [ "<input>: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"+ [ "<input>: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: -"+ [ "<input>: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"+ [ "<input>: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"+ [ "<input>: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: -"+ [ "<input>: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"+ [ "<input>: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"+ [ "<input>: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"+ [ "<input>: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"+ [ "<input>: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+ [ "<input>: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+ [ "<input>: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+ [ "<input>: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"+ [ "<input>: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"+ [ "<input>: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"+ [ "<input>: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"+ [ "<input>: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+ [ "<input>: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"+ [ "<input>: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"+ [ "<input>: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"+ [ "<input>: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"+ [ "<input>: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"+ [ "<input>: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"+ [ "<input>: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"+ [ "<input>: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"+ [ "<input>: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"+ [ "<input>: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"+ [ "<input>: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"+ [ "<input>: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"+ [ "<input>: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"+ [ "<input>:1:5:"+ , " • Expected annotation to be one of [\"MyVal\"], got: bad"+ , " │"+ , "1 │ foo (bad)1"+ , " │ ^^^^^^" ]
test/KDL/DecoderSpec.hs view
@@ -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+ [ "<input>:1:30:"+ , " • Invalid username"+ , " │"+ , "1 │ user a { foo { bar } }; user a1"+ , " │ ^^"+ ]
test/KDL/__snapshots__/DecoderSpec.snap.md view
@@ -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+<input>: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+<input>: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++```+<input>:1:1:+ • Expected node: bar+ │+1 │ foo \+ │ ^^^^^ ```
test/KDL/__snapshots__/ParserSpec.snap.md view
@@ -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
test/KDL/__snapshots__/RenderSpec.snap.md view
@@ -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 {