kdl-hs 1.0.1 → 1.1.0
raw patch · 11 files changed
+264/−2327 lines, 11 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
- KDL.Decoder.Arrow: text :: DecodeArrow Value a Text
- KDL.Decoder.Internal.DecodeM: DecodeM :: (forall r. () => (DecodeError -> r) -> (DecodeError -> r) -> (a -> r) -> r) -> DecodeM a
- KDL.Decoder.Internal.DecodeM: makeFatal :: DecodeM a -> DecodeM a
- KDL.Decoder.Internal.DecodeM: makeNonFatal :: DecodeM a -> DecodeM a
- KDL.Decoder.Internal.Error: data BaseDecodeError
- KDL.Decoder.Internal.Error: instance GHC.Base.Monoid KDL.Decoder.Internal.Error.DecodeError
- KDL.Decoder.Internal.Error: instance GHC.Base.Semigroup KDL.Decoder.Internal.Error.DecodeError
- KDL.Decoder.Internal.Error: instance GHC.Classes.Eq KDL.Decoder.Internal.Error.BaseDecodeError
- KDL.Decoder.Internal.Error: instance GHC.Show.Show KDL.Decoder.Internal.Error.BaseDecodeError
- KDL.Decoder.Monad: DecodeM :: (forall r. () => (DecodeError -> r) -> (DecodeError -> r) -> (a -> r) -> r) -> DecodeM a
- KDL.Decoder.Monad: addContext :: ContextItem -> DecodeM a -> DecodeM a
- KDL.Decoder.Monad: data BaseDecodeError
- KDL.Decoder.Monad: makeFatal :: DecodeM a -> DecodeM a
- KDL.Decoder.Monad: makeNonFatal :: DecodeM a -> DecodeM a
- KDL.Decoder.Monad: text :: DecodeArrow Value a Text
+ KDL.Decoder.Arrow: data DecodeM a
+ KDL.Decoder.Arrow: decodeThrow :: DecodeErrorKind -> DecodeM a
+ KDL.Decoder.Arrow: failM :: Text -> DecodeM a
+ KDL.Decoder.Arrow: liftDecodeM :: (a -> DecodeM b) -> DecodeArrow o a b
+ KDL.Decoder.Arrow: runDecodeM :: DecodeM a -> Either DecodeError a
+ KDL.Decoder.Arrow: string :: DecodeArrow Value a Text
+ KDL.Decoder.Internal.DecodeM: DecodeM_Fail :: NonEmpty BaseDecodeError -> DecodeM a
+ KDL.Decoder.Internal.DecodeM: DecodeM_Found :: a -> [BaseDecodeError] -> DecodeM a
+ KDL.Decoder.Internal.Error: data DecodeErrorKind
+ KDL.Decoder.Internal.Error: instance GHC.Classes.Eq KDL.Decoder.Internal.Error.DecodeErrorKind
+ KDL.Decoder.Internal.Error: instance GHC.Show.Show KDL.Decoder.Internal.Error.DecodeErrorKind
+ KDL.Decoder.Internal.Error: type BaseDecodeError = (Context, DecodeErrorKind)
+ KDL.Decoder.Monad: data DecodeErrorKind
+ KDL.Decoder.Monad: liftDecodeM :: (a -> DecodeM b) -> DecodeArrow o a b
+ KDL.Decoder.Monad: string :: DecodeArrow Value a Text
+ KDL.Decoder.Monad: type BaseDecodeError = (Context, DecodeErrorKind)
- KDL.Decoder.Internal.DecodeM: decodeThrow :: BaseDecodeError -> DecodeM a
+ KDL.Decoder.Internal.DecodeM: decodeThrow :: DecodeErrorKind -> DecodeM a
- KDL.Decoder.Internal.Error: DecodeError :: Maybe FilePath -> [(Context, BaseDecodeError)] -> DecodeError
+ KDL.Decoder.Internal.Error: DecodeError :: Maybe FilePath -> NonEmpty BaseDecodeError -> DecodeError
- KDL.Decoder.Internal.Error: DecodeError_Custom :: Text -> BaseDecodeError
+ KDL.Decoder.Internal.Error: DecodeError_Custom :: Text -> DecodeErrorKind
- KDL.Decoder.Internal.Error: DecodeError_ExpectedArg :: Int -> BaseDecodeError
+ KDL.Decoder.Internal.Error: DecodeError_ExpectedArg :: Int -> DecodeErrorKind
- KDL.Decoder.Internal.Error: DecodeError_ExpectedNode :: Text -> Int -> BaseDecodeError
+ KDL.Decoder.Internal.Error: DecodeError_ExpectedNode :: Text -> Int -> DecodeErrorKind
- KDL.Decoder.Internal.Error: DecodeError_ExpectedProp :: Text -> BaseDecodeError
+ KDL.Decoder.Internal.Error: DecodeError_ExpectedProp :: Text -> DecodeErrorKind
- KDL.Decoder.Internal.Error: DecodeError_MismatchedAnn :: Identifier -> [Text] -> BaseDecodeError
+ KDL.Decoder.Internal.Error: DecodeError_MismatchedAnn :: Identifier -> [Text] -> DecodeErrorKind
- KDL.Decoder.Internal.Error: DecodeError_ParseError :: Text -> BaseDecodeError
+ KDL.Decoder.Internal.Error: DecodeError_ParseError :: Text -> DecodeErrorKind
- KDL.Decoder.Internal.Error: DecodeError_UnexpectedArg :: Int -> Value -> BaseDecodeError
+ KDL.Decoder.Internal.Error: DecodeError_UnexpectedArg :: Int -> Value -> DecodeErrorKind
- KDL.Decoder.Internal.Error: DecodeError_UnexpectedNode :: Identifier -> Int -> BaseDecodeError
+ KDL.Decoder.Internal.Error: DecodeError_UnexpectedNode :: Identifier -> Int -> DecodeErrorKind
- KDL.Decoder.Internal.Error: DecodeError_UnexpectedProp :: Identifier -> Value -> BaseDecodeError
+ KDL.Decoder.Internal.Error: DecodeError_UnexpectedProp :: Identifier -> Value -> DecodeErrorKind
- KDL.Decoder.Internal.Error: DecodeError_ValueDecodeFail :: Text -> Value -> BaseDecodeError
+ KDL.Decoder.Internal.Error: DecodeError_ValueDecodeFail :: Text -> Value -> DecodeErrorKind
- KDL.Decoder.Internal.Error: [errors] :: DecodeError -> [(Context, BaseDecodeError)]
+ KDL.Decoder.Internal.Error: [errors] :: DecodeError -> NonEmpty BaseDecodeError
- KDL.Decoder.Internal.Error: [expectedType] :: BaseDecodeError -> Text
+ KDL.Decoder.Internal.Error: [expectedType] :: DecodeErrorKind -> Text
- KDL.Decoder.Internal.Error: [givenAnn] :: BaseDecodeError -> Identifier
+ KDL.Decoder.Internal.Error: [givenAnn] :: DecodeErrorKind -> Identifier
- KDL.Decoder.Internal.Error: [identifier] :: BaseDecodeError -> Identifier
+ KDL.Decoder.Internal.Error: [identifier] :: DecodeErrorKind -> Identifier
- KDL.Decoder.Internal.Error: [validAnns] :: BaseDecodeError -> [Text]
+ KDL.Decoder.Internal.Error: [validAnns] :: DecodeErrorKind -> [Text]
- KDL.Decoder.Internal.Error: [value] :: BaseDecodeError -> Value
+ KDL.Decoder.Internal.Error: [value] :: DecodeErrorKind -> Value
- KDL.Decoder.Monad: DecodeError :: Maybe FilePath -> [(Context, BaseDecodeError)] -> DecodeError
+ KDL.Decoder.Monad: DecodeError :: Maybe FilePath -> NonEmpty BaseDecodeError -> DecodeError
- KDL.Decoder.Monad: DecodeError_Custom :: Text -> BaseDecodeError
+ KDL.Decoder.Monad: DecodeError_Custom :: Text -> DecodeErrorKind
- KDL.Decoder.Monad: DecodeError_ExpectedArg :: Int -> BaseDecodeError
+ KDL.Decoder.Monad: DecodeError_ExpectedArg :: Int -> DecodeErrorKind
- KDL.Decoder.Monad: DecodeError_ExpectedNode :: Text -> Int -> BaseDecodeError
+ KDL.Decoder.Monad: DecodeError_ExpectedNode :: Text -> Int -> DecodeErrorKind
- KDL.Decoder.Monad: DecodeError_ExpectedProp :: Text -> BaseDecodeError
+ KDL.Decoder.Monad: DecodeError_ExpectedProp :: Text -> DecodeErrorKind
- KDL.Decoder.Monad: DecodeError_MismatchedAnn :: Identifier -> [Text] -> BaseDecodeError
+ KDL.Decoder.Monad: DecodeError_MismatchedAnn :: Identifier -> [Text] -> DecodeErrorKind
- KDL.Decoder.Monad: DecodeError_ParseError :: Text -> BaseDecodeError
+ KDL.Decoder.Monad: DecodeError_ParseError :: Text -> DecodeErrorKind
- KDL.Decoder.Monad: DecodeError_UnexpectedArg :: Int -> Value -> BaseDecodeError
+ KDL.Decoder.Monad: DecodeError_UnexpectedArg :: Int -> Value -> DecodeErrorKind
- KDL.Decoder.Monad: DecodeError_UnexpectedNode :: Identifier -> Int -> BaseDecodeError
+ KDL.Decoder.Monad: DecodeError_UnexpectedNode :: Identifier -> Int -> DecodeErrorKind
- KDL.Decoder.Monad: DecodeError_UnexpectedProp :: Identifier -> Value -> BaseDecodeError
+ KDL.Decoder.Monad: DecodeError_UnexpectedProp :: Identifier -> Value -> DecodeErrorKind
- KDL.Decoder.Monad: DecodeError_ValueDecodeFail :: Text -> Value -> BaseDecodeError
+ KDL.Decoder.Monad: DecodeError_ValueDecodeFail :: Text -> Value -> DecodeErrorKind
- KDL.Decoder.Monad: [errors] :: DecodeError -> [(Context, BaseDecodeError)]
+ KDL.Decoder.Monad: [errors] :: DecodeError -> NonEmpty BaseDecodeError
- KDL.Decoder.Monad: [expectedType] :: BaseDecodeError -> Text
+ KDL.Decoder.Monad: [expectedType] :: DecodeErrorKind -> Text
- KDL.Decoder.Monad: [givenAnn] :: BaseDecodeError -> Identifier
+ KDL.Decoder.Monad: [givenAnn] :: DecodeErrorKind -> Identifier
- KDL.Decoder.Monad: [identifier] :: BaseDecodeError -> Identifier
+ KDL.Decoder.Monad: [identifier] :: DecodeErrorKind -> Identifier
- KDL.Decoder.Monad: [index] :: BaseDecodeError -> Int
+ KDL.Decoder.Monad: [index] :: DecodeErrorKind -> Int
- KDL.Decoder.Monad: [name] :: BaseDecodeError -> Text
+ KDL.Decoder.Monad: [name] :: DecodeErrorKind -> Text
- KDL.Decoder.Monad: [validAnns] :: BaseDecodeError -> [Text]
+ KDL.Decoder.Monad: [validAnns] :: DecodeErrorKind -> [Text]
- KDL.Decoder.Monad: [value] :: BaseDecodeError -> Value
+ KDL.Decoder.Monad: [value] :: DecodeErrorKind -> Value
- KDL.Decoder.Monad: decodeThrow :: BaseDecodeError -> DecodeM a
+ KDL.Decoder.Monad: decodeThrow :: DecodeErrorKind -> DecodeM a
Files
- CHANGELOG.md +10/−0
- kdl-hs.cabal +3/−1
- src/KDL/Decoder/Arrow.hs +31/−17
- src/KDL/Decoder/Internal/DecodeM.hs +85/−51
- src/KDL/Decoder/Internal/Error.hs +12/−9
- test/KDL/ApplicativeSpec.hs +1/−1
- test/KDL/Decoder/ArrowSpec.hs +100/−1168
- test/KDL/Decoder/MonadSpec.hs +10/−1078
- test/KDL/Decoder/SharedSpec/Arrow.hs +5/−0
- test/KDL/Decoder/SharedSpec/Monad.hs +5/−0
- test/KDL/__snapshots__/DecoderSpec.snap.md +2/−2
CHANGELOG.md view
@@ -1,3 +1,13 @@+## v1.1.0++* Rename `KDL.text` to `KDL.string`+ * Matches the rename of the `Text` constructor to `String`+* Rename `BaseDecodeError` to `DecodeErrorKind`+* Create new `BaseDecodeError` alias+* Prune internal re-exports of `KDL.Decoder.Internal.DecodeM`+* Improve decoding error reporting ([#28](https://github.com/brandonchinn178/kdl-hs/issues/28))+ * Might cause slight performance regressions - please create a ticket if you notice any!+ ## v1.0.1 * Skip `kdl-test` tests if `dotslash` isn't installed
kdl-hs.cabal view
@@ -1,7 +1,7 @@ cabal-version: 3.0 name: kdl-hs-version: 1.0.1+version: 1.1.0 synopsis: KDL language parser and API description: KDL language parser and API. homepage: https://github.com/brandonchinn178/kdl-hs#readme@@ -79,6 +79,8 @@ KDL.DecoderSpec KDL.Decoder.ArrowSpec KDL.Decoder.MonadSpec+ KDL.Decoder.SharedSpec.Arrow+ KDL.Decoder.SharedSpec.Monad KDL.ParserSpec KDL.RenderSpec KDL.TestUtils.AST
src/KDL/Decoder/Arrow.hs view
@@ -12,11 +12,20 @@ -- * Decoder Decoder,- module KDL.Decoder.Internal.DecodeM,+ liftDecodeM, fail, withDecoder, debug, + -- ** DecodeM+ DecodeM,+ runDecodeM,+ decodeThrow,+ failM,++ -- ** Decode errors+ module KDL.Decoder.Internal.Error,+ -- * Document DocumentDecoder (..), document,@@ -71,7 +80,7 @@ ValueDecodeArrow, DecodeValue (..), any,- text,+ string, number, bool, null,@@ -111,6 +120,7 @@ import GHC.Int (Int16, Int32, Int8) import KDL.Decoder.Internal.DecodeM import KDL.Decoder.Internal.Decoder+import KDL.Decoder.Internal.Error import KDL.Decoder.Schema ( Schema (..), SchemaItem (..),@@ -283,7 +293,7 @@ index <- StateT.gets (getNodeIndex name.value) StateT.modify $ \s -> s{object = s.object{nodes = nodes'}} b <-- Trans.lift . makeFatal . addContext ContextNode{name = name, index = index} $+ Trans.lift . addContext ContextNode{name = name, index = index} $ decodeNode node_ StateT.modify $ \s -> s{history = s.history{nodesSeen = inc name.value s.history.nodesSeen}} pure $ Just (node_, b)@@ -424,7 +434,7 @@ -- email "a@example.com" "b@example.com" -- """ -- decoder = KDL.document $ proc () -> do--- KDL.argsAtWith "email" KDL.text -< ()+-- KDL.argsAtWith "email" KDL.string -< () -- KDL.decodeWith decoder config == Right ["a@example.com", "b@example.com"] -- @ argsAtWith :: forall a b. (Typeable b) => Text -> ValueDecodeArrow a b -> NodeListDecodeArrow a [b]@@ -470,7 +480,7 @@ -- } -- """ -- decoder = KDL.document $ proc () -> do--- KDL.dashChildrenAtWith "attendees" $ KDL.text -< ()+-- KDL.dashChildrenAtWith "attendees" $ KDL.string -< () -- KDL.decodeWith decoder config == Right [\"Alice", \"Bob"] -- @ dashChildrenAtWith :: forall a b. (Typeable b) => Text -> ValueDecodeArrow a b -> NodeListDecodeArrow a [b]@@ -665,7 +675,7 @@ -- decoder = KDL.document $ proc () -> do -- KDL.nodeWith "person" $ decodePerson -< () -- decodePerson = proc () -> do--- name \<- KDL.argWith $ Text.toUpper \<$> KDL.text -< ()+-- name \<- KDL.argWith $ Text.toUpper \<$> KDL.string -< () -- vals \<- KDL.many $ KDL.argWith $ show \<$> KDL.valueDecoder @Int -< () -- returnA -< (name, vals) -- KDL.decodeWith decoder config == Right (\"ALICE", ["1", "2", "3"])@@ -687,7 +697,7 @@ StateT.modify $ \s -> s{object = s.object{entries = entries'}} b <-- Trans.lift . makeFatal . addContext ContextArg{index = index} $+ Trans.lift . addContext ContextArg{index = index} $ decodeValue a entry.value StateT.modify $ \s -> s{history = s.history{argsSeen = s.history.argsSeen + 1}} pure b@@ -748,7 +758,7 @@ Just (name, prop_, entries') -> do StateT.modify $ \s -> s{object = s.object{entries = entries'}} b <-- Trans.lift . makeFatal . addContext ContextProp{name = name} $+ Trans.lift . addContext ContextProp{name = name} $ decodeValue prop_.value StateT.modify $ \s -> s{history = s.history{propsSeen = Set.insert name s.history.propsSeen}} pure $ Just (name, b)@@ -910,11 +920,11 @@ instance DecodeValue ValueData where valueDecoder = (.data_) <$> any instance DecodeValue Text where- validValueTypeAnns _ = ["text"]- valueDecoder = text+ validValueTypeAnns _ = ["string"]+ valueDecoder = string instance DecodeValue String where validValueTypeAnns _ = ["string"]- valueDecoder = Text.unpack <$> text+ valueDecoder = Text.unpack <$> string instance DecodeValue Bool where validValueTypeAnns _ = ["bool", "boolean"] valueDecoder = bool@@ -1018,11 +1028,11 @@ any :: DecodeArrow Value a Value any = valueDataDecoderPrim (SchemaOr $ map SchemaOne [minBound .. maxBound]) pure --- | Decode a KDL text value.-text :: DecodeArrow Value a Text-text = valueDataDecoderPrim (SchemaOne TextSchema) $ \case+-- | Decode a KDL string value.+string :: DecodeArrow Value a Text+string = valueDataDecoderPrim (SchemaOne TextSchema) $ \case Value{data_ = String s} -> pure s- v -> decodeThrow DecodeError_ValueDecodeFail{expectedType = "text", value = v}+ v -> decodeThrow DecodeError_ValueDecodeFail{expectedType = "string", value = v} -- | Decode a KDL number value. number :: DecodeArrow Value a Scientific@@ -1046,9 +1056,13 @@ -- | Return the first result that succeeds. ----- > oneOf [a, b, c] === a <|> b <|> c <|> empty+-- > oneOf [a, b, c] === a <|> b <|> c oneOf :: (Alternative f) => [f a] -> f a-oneOf = foldr (<|>) empty+oneOf ms =+ -- Avoid 'empty' if possible+ case NonEmpty.nonEmpty ms of+ Just ms' -> foldr1 (<|>) ms'+ Nothing -> empty -- | Return the given default value if the given action fails. --
src/KDL/Decoder/Internal/DecodeM.hs view
@@ -14,82 +14,116 @@ runDecodeM, decodeThrow, failM,- makeFatal,- makeNonFatal, addContext, ) where import Control.Applicative (Alternative (..))+import Data.Bifunctor (first)+import Data.List.NonEmpty (NonEmpty (..))+import Data.List.NonEmpty qualified as NonEmpty import Data.Text (Text) import KDL.Decoder.Internal.Error -- | The monad that returns either a 'DecodeError' or a result of type @a@. ----- To a first approximation, this monad is equivalent to the @Either DecodeError@--- monad, with the following changes:+-- The odd structure here is because of our backtracking semantics. We want to+-- collect all errors that may appear (even if a value is successfully parsed)+-- so that if we get a failure later on, we can return the deepest error, even+-- if it was in a successful branch. ----- * Uses continuation-passing style for performance--- * Has two error channels, one for fatal errors and one for non-fatal errors (see 'makeFatal')--- * Collects as many errors as possible, within an Applicative context+-- Take this motivating example: a node takes an arbitrary number of string+-- args. If you pass some strings then a number, it'll successfully parse up to+-- the number and return success, only for the node to fail later with+-- "unexpected argument: 123". But the true error was+-- "unexpected number, expected string". data DecodeM a- = DecodeM- ( forall r.- (DecodeError -> r) -> -- fatal error, not handled by <|>- (DecodeError -> r) -> -- non-fatal error, handled by <|>- (a -> r) ->- r- )+ = DecodeM_Found a [BaseDecodeError]+ | DecodeM_Fail (NonEmpty BaseDecodeError) instance Functor DecodeM where- fmap f (DecodeM k) = DecodeM $ \onFatal onFail onSuccess -> k onFatal onFail (onSuccess . f)+ fmap f = \case+ DecodeM_Found a es -> DecodeM_Found (f a) es+ DecodeM_Fail es -> DecodeM_Fail es instance Applicative DecodeM where- pure x = DecodeM $ \_ _ onSuccess -> onSuccess x- DecodeM kf <*> DecodeM ka = DecodeM $ \onFatal onFail onSuccess ->- -- Collect all errors- kf- (\e1 -> ka (\e2 -> onFatal $ e1 <> e2) (\e2 -> onFatal $ e1 <> e2) (\_ -> onFatal e1))- (\e1 -> ka (\e2 -> onFatal $ e1 <> e2) (\e2 -> onFail $ e1 <> e2) (\_ -> onFail e1))- (\f -> ka onFatal onFail (onSuccess . f))+ pure x = DecodeM_Found x []+ l <*> r =+ case (l, r) of+ (DecodeM_Found f es1, DecodeM_Found a es2) -> DecodeM_Found (f a) (mergeErrorsLR es1 es2)+ (DecodeM_Found _ es1, DecodeM_Fail es2) -> DecodeM_Fail (mergeErrorsL es1 es2)+ (DecodeM_Fail es1, DecodeM_Found _ es2) -> DecodeM_Fail (mergeErrorsR es1 es2)+ (DecodeM_Fail es1, DecodeM_Fail es2) -> DecodeM_Fail (mergeErrors es1 es2) instance Monad DecodeM where (>>) = (*>)- DecodeM ka >>= k = DecodeM $ \onFatal onFail onSuccess ->- ka onFatal onFail $ \a -> let DecodeM kb = k a in kb onFatal onFail onSuccess+ m >>= k =+ case m of+ DecodeM_Fail es1 -> DecodeM_Fail es1+ DecodeM_Found a es1 ->+ case k a of+ DecodeM_Found b es2 -> DecodeM_Found b (mergeErrorsLR es1 es2)+ DecodeM_Fail es2 -> DecodeM_Fail (mergeErrorsL es1 es2) instance Alternative DecodeM where- empty = DecodeM $ \_ onFail _ -> onFail mempty- DecodeM k1 <|> DecodeM k2 = DecodeM $ \onFatal onFail onSuccess ->- k1- onFatal- (\e1 -> k2 onFatal (\e2 -> onFail $ e1 <> e2) onSuccess)- onSuccess+ empty = failM "<empty>"+ l <|> r =+ case l of+ DecodeM_Found a es1 -> DecodeM_Found a es1+ DecodeM_Fail es1 ->+ case r of+ DecodeM_Found a es2 -> DecodeM_Found a (NonEmpty.toList $ mergeErrorsR es1 es2)+ DecodeM_Fail es2 -> DecodeM_Fail (mergeErrors es1 es2) --- | Run a 'DecodeM' action and return the result or the error.+-- | Run a 'DecodeM' action and return the result or the deepest error found. runDecodeM :: DecodeM a -> Either DecodeError a-runDecodeM (DecodeM f) = f Left Left Right+runDecodeM = \case+ DecodeM_Found a _ -> Right a+ DecodeM_Fail errors -> Left DecodeError{filepath = Nothing, errors} +mergeErrors ::+ NonEmpty BaseDecodeError ->+ NonEmpty BaseDecodeError ->+ NonEmpty BaseDecodeError+mergeErrors es1 es2 =+ case compare (key es1) (key es2) of+ LT -> es2+ EQ -> es1 <> es2+ GT -> es1+ where+ key = length . fst . NonEmpty.head++mergeErrorsL ::+ [BaseDecodeError] ->+ NonEmpty BaseDecodeError ->+ NonEmpty BaseDecodeError+mergeErrorsL l r = maybe r (\l' -> mergeErrors l' r) (NonEmpty.nonEmpty l)++mergeErrorsR ::+ NonEmpty BaseDecodeError ->+ [BaseDecodeError] ->+ NonEmpty BaseDecodeError+mergeErrorsR l r = maybe l (\r' -> mergeErrors l r') (NonEmpty.nonEmpty r)++mergeErrorsLR ::+ [BaseDecodeError] ->+ [BaseDecodeError] ->+ [BaseDecodeError]+mergeErrorsLR l r =+ case (l, r) of+ ([], _) -> r+ (_, []) -> l+ (x : xs, y : ys) -> NonEmpty.toList $ mergeErrors (x :| xs) (y :| ys)++mapErrors :: (BaseDecodeError -> BaseDecodeError) -> DecodeM a -> DecodeM a+mapErrors f = \case+ DecodeM_Found a es -> DecodeM_Found a (fmap f es)+ DecodeM_Fail es -> DecodeM_Fail (fmap f es)+ -- | Throw an error.------ This error is non-fatal and can be handled by '<|>'. See 'makeFatal'--- for more information.-decodeThrow :: BaseDecodeError -> DecodeM a-decodeThrow e = DecodeM $ \_ onFail _ -> onFail $ DecodeError Nothing [([], e)]+decodeThrow :: DecodeErrorKind -> DecodeM a+decodeThrow e = DecodeM_Fail . NonEmpty.singleton $ ([], e) -- | Throw a 'DecodeError_Custom' error. failM :: Text -> DecodeM a failM = decodeThrow . DecodeError_Custom --- | Make all errors in the given action fatal errors.------ A la standard parsing libraries like megaparsec, errors should be--- considered fatal when decoding has started consuming something.-makeFatal :: DecodeM a -> DecodeM a-makeFatal (DecodeM f) = DecodeM $ \onFatal _ onSuccess -> f onFatal onFatal onSuccess---- | Make all errors non-fatal errors.-makeNonFatal :: DecodeM a -> DecodeM a-makeNonFatal (DecodeM f) = DecodeM $ \_ onFail onSuccess -> f onFail onFail onSuccess- -- | Add context to all errors that occur in the given action. addContext :: ContextItem -> DecodeM a -> DecodeM a-addContext ctxItem (DecodeM f) = DecodeM $ \onFatal onFail onSuccess -> f (onFatal . addCtx) (onFail . addCtx) onSuccess- where- addCtx e = e{errors = [(ctxItem : ctx, msg) | (ctx, msg) <- e.errors]}+addContext ctxItem = mapErrors (first (ctxItem :))
src/KDL/Decoder/Internal/Error.hs view
@@ -7,13 +7,15 @@ module KDL.Decoder.Internal.Error ( DecodeError (..),- BaseDecodeError (..),+ BaseDecodeError,+ DecodeErrorKind (..), Context, ContextItem (..), renderDecodeError, ) where -import Control.Applicative ((<|>))+import Data.List.NonEmpty (NonEmpty)+import Data.List.NonEmpty qualified as NonEmpty import Data.Map qualified as Map import Data.Text (Text) import Data.Text qualified as Text@@ -28,14 +30,11 @@ data DecodeError = DecodeError { filepath :: Maybe FilePath- , errors :: [(Context, BaseDecodeError)]+ , errors :: NonEmpty BaseDecodeError } deriving (Show, Eq)-instance Semigroup DecodeError where- DecodeError fp1 e1 <> DecodeError fp2 e2 = DecodeError (fp1 <|> fp2) (e1 <> e2)-instance Monoid DecodeError where- mempty = DecodeError Nothing [] +type BaseDecodeError = (Context, DecodeErrorKind) type Context = [ContextItem] data ContextItem@@ -51,7 +50,7 @@ } deriving (Show, Eq, Ord) -data BaseDecodeError+data DecodeErrorKind = DecodeError_Custom Text | DecodeError_ParseError Text | DecodeError_ExpectedNode {name :: Text, index :: Int}@@ -72,7 +71,11 @@ $ decodeError.errors where -- Group errors with the same contexts together- groupCtxErrors es = Map.toAscList $ Map.fromListWith (<>) [(ctx, [e]) | (ctx, e) <- es]+ groupCtxErrors es =+ Map.toAscList . Map.fromListWith (<>) $+ [ (ctx, [e])+ | (ctx, e) <- NonEmpty.toList es+ ] addPath = case decodeError.filepath of
test/KDL/ApplicativeSpec.hs view
@@ -85,7 +85,7 @@ KDL.SchemaOne . KDL.NodeArg $ KDL.TypedValueSchema { typeHint = typeRep $ Proxy @Text- , validTypeAnns = ["text"]+ , validTypeAnns = ["string"] , dataSchema = KDL.SchemaOne KDL.TextSchema } }
test/KDL/Decoder/ArrowSpec.hs view
@@ -5,1171 +5,103 @@ module KDL.Decoder.ArrowSpec (spec) where import Control.Arrow (returnA)-import Control.Monad (forM_, unless)-import Data.Int (Int64)-import Data.Map qualified as Map-import Data.Proxy (Proxy (..))-import Data.Text (Text)-import Data.Text qualified as Text-import Data.Typeable (typeRep)-import KDL.Arrow qualified as KDL-import KDL.TestUtils.AST (scrubFormat)-import KDL.TestUtils.Error (decodeErrorMsg)-import KDL.Types (- Entry (..),- Identifier (..),- Node (..),- NodeList (..),- Value (..),- ValueData (..),- )-import Skeletest--spec :: Spec-spec = do- apiSpec- schemaSpec- decodeNodeSpec- decodeValueSpec--apiSpec :: Spec-apiSpec = do- describe "NodeListDecoder" $ do- describe "node" $ do- it "decodes a node" $ do- let config = "foo 1.0"- decoder = KDL.document $ proc () -> do- scrubFormat <$> KDL.node "foo" -< ()- expected =- Node- { ann = Nothing- , name = Identifier{value = "foo", ext = KDL.def}- , entries =- [ Entry- { name = Nothing- , value = Value{ann = Nothing, data_ = Number 1.0, ext = KDL.def}- , ext = KDL.def- }- ]- , children = Nothing- , ext = KDL.def- }- KDL.decodeWith decoder config `shouldBe` Right expected-- it "decodes multiple nodes" $ do- let config = "foo; foo"- decoder = KDL.document $ proc () -> do- fmap (map scrubFormat) . KDL.many $ KDL.node "foo" -< ()- expected = [fooNode, fooNode]- fooNode =- Node- { ann = Nothing- , name = Identifier{value = "foo", ext = KDL.def}- , entries = []- , children = Nothing- , ext = KDL.def- }- KDL.decodeWith decoder config `shouldBe` Right expected-- it "decodes nodes in any order" $ do- let config = "foo; bar"- decoder = KDL.document $ proc () -> do- bar <- scrubFormat <$> KDL.node "bar" -< ()- foo <- scrubFormat <$> KDL.node "foo" -< ()- returnA -< (bar, foo)- expected = (node "bar", node "foo")- node name =- Node- { ann = Nothing- , name = Identifier{value = name, ext = KDL.def}- , entries = []- , children = Nothing- , ext = KDL.def- }- KDL.decodeWith decoder config `shouldBe` Right expected-- it "fails when not enough nodes" $ do- let config = "foo"- decoder = KDL.document $ proc () -> do- foo1 <- scrubFormat <$> KDL.node @Node "foo" -< ()- foo2 <- scrubFormat <$> KDL.node @Node "foo" -< ()- returnA -< (foo1, foo2)- KDL.decodeWith decoder config- `shouldSatisfy` decodeErrorMsg- [ "At: <root>"- , " Expected another node: foo"- ]-- -- Most behaviors tested with `node`- describe "nodeWith" $ do- it "decodes a node" $ do- let config = "foo 1.0 { hello world; }"- decodeFoo = proc () -> do- arg <- KDL.arg @Int -< ()- child <- KDL.children $ KDL.argAt @Text "hello" -< ()- returnA -< (arg, child)- decoder = KDL.document $ proc () -> do- KDL.nodeWith "foo" decodeFoo -< ()- KDL.decodeWith decoder config `shouldBe` Right (1, "world")-- it "fails when node fails to parse" $ do- let config = "foo 1.0"- decodeFoo = proc () -> do- KDL.arg @Text -< ()- decoder = KDL.document $ proc () -> do- KDL.nodeWith "foo" decodeFoo -< ()- KDL.decodeWith decoder config- `shouldSatisfy` decodeErrorMsg- [ "At: foo #0 > arg #0"- , " Expected text, got: 1.0"- ]-- -- Most behaviors tested with `nodeWith`- describe "nodeWith'" $ do- it "decodes a node with an annotation" $ do- let testCases =- [ []- , ["test"]- , ["test", "other"]- ]- forM_ testCases $ \anns -> do- let config = "(test)foo 1"- decoder = KDL.document $ proc () -> do- KDL.nodeWith' "foo" anns $ KDL.arg @Int -< ()- KDL.decodeWith decoder config `shouldBe` Right 1-- it "decodes a node without an annotation" $ do- let testCases =- [ []- , ["test"]- , ["test", "other"]- ]- forM_ testCases $ \anns -> do- let config = "foo 1"- decoder = KDL.document $ proc () -> do- KDL.nodeWith' "foo" anns $ KDL.arg @Int -< ()- KDL.decodeWith decoder config `shouldBe` Right 1-- it "fails when node has unexpected annotation" $ do- let config = "(test)foo 2"- decoder = KDL.document $ proc () -> do- 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"- ]-- describe "remainingNodes" $ do- it "returns all remaining nodes" $ do- let config = "foo 1.0; foo 2.0; bar"- decoder = KDL.document $ proc () -> do- _ <- KDL.node @Node "foo" -< ()- fmap (map scrubFormat) <$> KDL.remainingNodes -< ()- expected =- Map.fromList- [ ("foo", [fooNode2])- , ("bar", [barNode])- ]- fooNode2 =- Node- { ann = Nothing- , name = Identifier{value = "foo", ext = KDL.def}- , entries =- [ Entry- { name = Nothing- , value = Value{ann = Nothing, data_ = Number 2.0, ext = KDL.def}- , ext = KDL.def- }- ]- , children = Nothing- , ext = KDL.def- }- barNode =- Node- { ann = Nothing- , name = Identifier{value = "bar", ext = KDL.def}- , entries = []- , children = Nothing- , ext = KDL.def- }- KDL.decodeWith decoder config `shouldBe` Right expected-- -- Most behaviors tested with `remainingNodes`- describe "remainingNodesWith" $ do- it "returns all remaining nodes" $ do- let config = "foo 1.0; foo 2.0; bar"- decodeNode = proc () -> do- KDL.optional $ KDL.arg @Int -< ()- decoder = KDL.document $ proc () -> do- _ <- KDL.node @Node "foo" -< ()- KDL.remainingNodesWith decodeNode -< ()- expected =- Map.fromList- [ ("foo", [Just 2])- , ("bar", [Nothing])- ]- KDL.decodeWith decoder config `shouldBe` Right expected-- it "fails when node fails to parse" $ do- let config = "foo 1; bar 1; bar hello"- decodeNode = proc () -> do- KDL.arg @Int -< ()- decoder = KDL.document $ proc () -> do- KDL.remainingNodesWith decodeNode -< ()- KDL.decodeWith decoder config- `shouldSatisfy` decodeErrorMsg- [ "At: bar #1 > arg #0"- , " Expected number, got: hello"- ]-- -- Most behaviors tested with `remainingNodesWith`- describe "remainingNodesWith'" $ do- it "decodes a node with an annotation" $ do- let testCases =- [ []- , ["test"]- , ["test", "other"]- ]- forM_ testCases $ \anns -> do- let config = "(test)foo 1"- decoder = KDL.document $ proc () -> do- KDL.remainingNodesWith' anns $ KDL.arg @Int -< ()- KDL.decodeWith decoder config- `shouldBe` (Right . Map.fromList) [("foo", [1])]-- it "decodes a node without an annotation" $ do- let testCases =- [ []- , ["test"]- , ["test", "other"]- ]- forM_ testCases $ \anns -> do- let config = "foo 1"- decoder = KDL.document $ proc () -> do- KDL.remainingNodesWith' anns $ KDL.arg @Int -< ()- KDL.decodeWith decoder config- `shouldBe` (Right . Map.fromList) [("foo", [1])]-- it "fails when node has unexpected annotation" $ do- let config = "(FOO)foo 1; (test)foo 2"- decoder = KDL.document $ proc () -> do- KDL.remainingNodesWith' ["FOO"] $ KDL.arg @Int -< ()- KDL.decodeWith decoder config- `shouldSatisfy` decodeErrorMsg- [ "At: foo #1"- , " Expected annotation to be one of [\"FOO\"], got: test"- ]-- describe "argAt" $ do- it "gets argument at a node" $ do- let config = "foo bar; hello world"- decoder = KDL.document $ proc () -> do- hello <- KDL.argAt @Text "hello" -< ()- foo <- KDL.argAt @Text "foo" -< ()- returnA -< (hello, foo)- KDL.decodeWith decoder config `shouldBe` Right ("world", "bar")-- it "fails if no node" $ do- let config = "other_node"- decoder = KDL.document $ proc () -> do- KDL.argAt @Int "foo" -< ()- KDL.decodeWith decoder config- `shouldSatisfy` decodeErrorMsg- [ "At: <root>"- , " Expected node: foo"- ]-- it "fails if node has no args" $ do- let config = "foo"- decoder = KDL.document $ proc () -> do- KDL.argAt @Int "foo" -< ()- KDL.decodeWith decoder config- `shouldSatisfy` decodeErrorMsg- [ "At: foo #0"- , " Expected arg #0"- ]-- it "fails if arg fails to parse" $ do- let config = "foo 1"- decoder = KDL.document $ proc () -> do- KDL.argAt @Text "foo" -< ()- KDL.decodeWith decoder config- `shouldSatisfy` decodeErrorMsg- [ "At: foo #0 > arg #0"- , " Expected text, got: 1"- ]-- -- Most behaviors tested with `argAt`- describe "argAtWith" $ do- it "gets argument at a node" $ do- let config = "foo 1"- decoder = KDL.document $ proc () -> do- KDL.argAtWith "foo" $ show . (* 10) <$> KDL.number -< ()- KDL.decodeWith decoder config `shouldBe` Right "10.0"-- -- Most behaviors tested with `argAtWith`- describe "argAtWith'" $ do- it "decodes argument with an annotation" $ do- let testCases =- [ []- , ["test"]- , ["test", "other"]- ]- forM_ testCases $ \anns -> do- let config = "foo (test)a"- decoder = KDL.document $ proc () -> do- KDL.argAtWith' "foo" anns KDL.text -< ()- KDL.decodeWith decoder config `shouldBe` Right "a"-- it "decodes argument without an annotation" $ do- let testCases =- [ []- , ["test"]- , ["test", "other"]- ]- forM_ testCases $ \anns -> do- let config = "foo a"- decoder = KDL.document $ proc () -> do- KDL.argAtWith' "foo" anns KDL.text -< ()- KDL.decodeWith decoder config `shouldBe` Right "a"-- it "fails when argument has unexpected annotation" $ do- let config = "foo (test)a"- decoder = KDL.document $ proc () -> do- KDL.argAtWith' "foo" ["VAL"] KDL.text -< ()- KDL.decodeWith decoder config- `shouldSatisfy` decodeErrorMsg- [ "At: foo #0 > arg #0"- , " Expected annotation to be one of [\"VAL\"], got: test"- ]-- describe "argsAt" $ do- it "gets arguments at a node" $ do- let config = "foo 1 2 3"- decoder = KDL.document $ proc () -> do- KDL.argsAt @Int "foo" -< ()- KDL.decodeWith decoder config `shouldBe` Right [1, 2, 3]-- it "returns empty list if no node" $ do- let config = ""- decoder = KDL.document $ proc () -> do- KDL.argsAt @Int "foo" -< ()- KDL.decodeWith decoder config `shouldBe` Right []-- it "returns empty list if node has no args" $ do- let config = "foo"- decoder = KDL.document $ proc () -> do- KDL.argsAt @Int "foo" -< ()- KDL.decodeWith decoder config `shouldBe` Right []-- it "fails if any arg fails to parse" $ do- let config = "foo 1 asdf"- decoder = KDL.document $ proc () -> do- KDL.argsAt @Int "foo" -< ()- KDL.decodeWith decoder config- `shouldSatisfy` decodeErrorMsg- [ "At: foo #0 > arg #1"- , " Expected number, got: asdf"- ]-- -- Most behaviors tested with `argsAt`- describe "argsAtWith" $ do- it "gets arguments at a node" $ do- let config = "foo 1 2"- decoder = KDL.document $ proc () -> do- KDL.argsAtWith "foo" $ show . (* 10) <$> KDL.number -< ()- KDL.decodeWith decoder config `shouldBe` Right ["10.0", "20.0"]-- -- Most behaviors tested with `argsAtWith`- describe "argsAtWith'" $ do- it "decodes arguments with an annotation" $ do- let testCases =- [ []- , ["test"]- , ["test", "other"]- ]- forM_ testCases $ \anns -> do- let config = "foo (test)a (test)b"- decoder = KDL.document $ proc () -> do- KDL.argsAtWith' "foo" anns KDL.text -< ()- KDL.decodeWith decoder config `shouldBe` Right ["a", "b"]-- it "decodes arguments without an annotation" $ do- let testCases =- [ []- , ["test"]- , ["test", "other"]- ]- forM_ testCases $ \anns -> do- let config = "foo a b"- decoder = KDL.document $ proc () -> do- KDL.argsAtWith' "foo" anns KDL.text -< ()- KDL.decodeWith decoder config `shouldBe` Right ["a", "b"]-- it "fails when argument has unexpected annotation" $ do- let config = "foo (VAL)a (test)b"- decoder = KDL.document $ proc () -> do- KDL.argsAtWith' "foo" ["VAL"] KDL.text -< ()- KDL.decodeWith decoder config- `shouldSatisfy` decodeErrorMsg- [ "At: foo #0 > arg #1"- , " Expected annotation to be one of [\"VAL\"], got: test"- ]-- describe "dashChildrenAt" $ do- it "gets dash children at a node" $ do- let config = "foo { - 1; - 2; - 3; }"- decoder = KDL.document $ proc () -> do- KDL.dashChildrenAt @Int "foo" -< ()- KDL.decodeWith decoder config `shouldBe` Right [1, 2, 3]-- it "returns empty list if no node" $ do- let config = ""- decoder = KDL.document $ proc () -> do- KDL.dashChildrenAt @Int "foo" -< ()- KDL.decodeWith decoder config `shouldBe` Right []-- it "returns empty list if node has no dash children" $ do- forM_ ["foo", "foo {}"] $ \config -> do- let decoder = KDL.document $ proc () -> do- KDL.dashChildrenAt @Int "foo" -< ()- KDL.decodeWith decoder config `shouldBe` Right []-- it "fails if dash children have multiple args" $ do- let config = "foo { - 1 2; - 3 4; }"- decoder = KDL.document $ proc () -> do- KDL.dashChildrenAt @Int "foo" -< ()- KDL.decodeWith decoder config- `shouldSatisfy` decodeErrorMsg- [ "At: foo #0 > - #0"- , " Unexpected arg #1: 2"- ]-- it "fails if node has non-dash children" $ do- let config = "foo { - 1; bar 1 2 3; }"- decoder = KDL.document $ proc () -> do- KDL.dashChildrenAt @Int "foo" -< ()- KDL.decodeWith decoder config- `shouldSatisfy` decodeErrorMsg- [ "At: foo #0"- , " Unexpected node: bar #0"- ]-- it "fails if any child fails to parse" $ do- let config = "foo { - 1; - asdf; }"- decoder = KDL.document $ proc () -> do- KDL.dashChildrenAt @Int "foo" -< ()- KDL.decodeWith decoder config- `shouldSatisfy` decodeErrorMsg- [ "At: foo #0 > - #1 > arg #0"- , " Expected number, got: asdf"- ]-- -- Most behaviors tested with `dashChildrenAt`- describe "dashChildrenAtWith" $ do- it "gets dash children at a node" $ do- let config = "foo { - 1; - 2; }"- decoder = KDL.document $ proc () -> do- KDL.dashChildrenAtWith "foo" $ show . (* 10) <$> KDL.number -< ()- KDL.decodeWith decoder config `shouldBe` Right ["10.0", "20.0"]-- -- Most behaviors tested with `dashChildrenAtWith`- describe "dashChildrenAtWith'" $ do- it "decodes dash children with an annotation" $ do- let testCases =- [ []- , ["test"]- , ["test", "other"]- ]- forM_ testCases $ \anns -> do- let config = "foo { - (test)a; - (test)b; }"- decoder = KDL.document $ proc () -> do- KDL.dashChildrenAtWith' "foo" anns KDL.text -< ()- KDL.decodeWith decoder config `shouldBe` Right ["a", "b"]-- it "decodes dash children without an annotation" $ do- let testCases =- [ []- , ["test"]- , ["test", "other"]- ]- forM_ testCases $ \anns -> do- let config = "foo { - a; - b; }"- decoder = KDL.document $ proc () -> do- KDL.dashChildrenAtWith' "foo" anns KDL.text -< ()- KDL.decodeWith decoder config `shouldBe` Right ["a", "b"]-- it "fails when child has unexpected annotation" $ do- let config = "foo { - (test)a; }"- decoder = KDL.document $ proc () -> do- KDL.dashChildrenAtWith' "foo" ["VAL"] KDL.text -< ()- KDL.decodeWith decoder config- `shouldSatisfy` decodeErrorMsg- [ "At: foo #0 > - #0 > arg #0"- , " Expected annotation to be one of [\"VAL\"], got: test"- ]-- describe "dashNodesAt" $ do- it "gets dash nodes at a node" $ do- let config = "foo { - { bar; }; - { baz; }; }"- decoder = KDL.document $ proc () -> do- map scrubFormat <$> KDL.dashNodesAt "foo" -< ()- expected = [node "-" [node "bar" []], node "-" [node "baz" []]]- node name children =- Node- { ann = Nothing- , name = Identifier{value = name, ext = KDL.def}- , entries = []- , children =- if null children- then Nothing- else Just NodeList{nodes = children, ext = KDL.def}- , ext = KDL.def- }- KDL.decodeWith decoder config `shouldBe` Right expected-- it "returns empty list if no node" $ do- let config = ""- decoder = KDL.document $ proc () -> do- KDL.dashNodesAt @Node "foo" -< ()- KDL.decodeWith decoder config `shouldBe` Right []-- it "returns empty list if node has no dash nodes" $ do- forM_ ["foo", "foo {}"] $ \config -> do- let decoder = KDL.document $ proc () -> do- KDL.dashNodesAt @Node "foo" -< ()- KDL.decodeWith decoder config `shouldBe` Right []-- it "fails if node has non-dash nodes" $ do- let config = "foo { - 1; bar 1 2 3; }"- decoder = KDL.document $ proc () -> do- KDL.dashNodesAt @Node "foo" -< ()- KDL.decodeWith decoder config- `shouldSatisfy` decodeErrorMsg- [ "At: foo #0"- , " Unexpected node: bar #0"- ]-- -- Most behaviors tested with `dashNodesAt`- describe "dashNodesAtWith" $ do- it "gets dash nodes at a node" $ do- let config = "foo { - 1 { bar hello; }; - 2 { bar world; }; }"- decodeChild = proc () -> do- arg <- KDL.arg @Int -< ()- child <- KDL.children $ KDL.nodeWith "bar" $ KDL.arg @Text -< ()- returnA -< (arg, child)- decoder = KDL.document $ proc () -> do- KDL.dashNodesAtWith "foo" decodeChild -< ()- KDL.decodeWith decoder config `shouldBe` Right [(1, "hello"), (2, "world")]-- it "fails if any child fails to parse" $ do- let config = "foo { - { bar 1; }; - { bar test; }; }"- decoder = KDL.document $ proc () -> do- 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"- ]-- describe "NodeDecoder" $ do- let decodeNode name decoder config =- KDL.decodeWith- ( KDL.document $ proc () -> do- KDL.nodeWith name decoder -< ()- )- config-- describe "arg" $ do- it "decodes an argument" $ do- let config = "foo 1 bar"- decoder = proc () -> do- arg1 <- KDL.arg @Int -< ()- arg2 <- KDL.arg @Text -< ()- returnA -< (arg1, arg2)- decodeNode "foo" decoder config `shouldBe` Right (1, "bar")-- it "decodes multiple arguments" $ do- let config = "foo 1 2 3"- decoder = proc () -> do- KDL.many $ KDL.arg @Int -< ()- decodeNode "foo" decoder config `shouldBe` Right [1, 2, 3]-- it "fails if argument doesn't exist" $ do- let config = "foo"- decoder = proc () -> do- KDL.arg @Int -< ()- decodeNode "foo" decoder config- `shouldSatisfy` decodeErrorMsg- [ "At: foo #0"- , " Expected arg #0"- ]-- it "fails if argument fails to parse" $ do- let config = "foo test"- decoder = proc () -> do- KDL.arg @Int -< ()- decodeNode "foo" decoder config- `shouldSatisfy` decodeErrorMsg- [ "At: foo #0 > arg #0"- , " Expected number, got: test"- ]-- it "fails if not all arguments are decoded" $ do- let config = "foo 1 2 3"- decoder = proc () -> do- KDL.arg @Int -< ()- decodeNode "foo" decoder config- `shouldSatisfy` decodeErrorMsg- [ "At: foo #0"- , " Unexpected arg #1: 2"- ]-- -- Most behaviors tested with `arg`- describe "argWith" $ do- it "decodes an argument" $ do- let config = "foo bar"- decoder = proc () -> do- KDL.argWith KDL.text -< ()- decodeNode "foo" decoder config `shouldBe` Right "bar"-- -- Most behaviors tested with `argWith`- describe "argWith'" $ do- it "decodes argument with an annotation" $ do- let testCases =- [ []- , ["test"]- , ["test", "other"]- ]- forM_ testCases $ \anns -> do- let config = "foo (test)a"- decoder = proc () -> do- KDL.argWith' anns KDL.text -< ()- decodeNode "foo" decoder config `shouldBe` Right "a"-- it "decodes argument without an annotation" $ do- let testCases =- [ []- , ["test"]- , ["test", "other"]- ]- forM_ testCases $ \anns -> do- let config = "foo a"- decoder = proc () -> do- KDL.argWith' anns KDL.text -< ()- decodeNode "foo" decoder config `shouldBe` Right "a"-- it "fails when argument has unexpected annotation" $ do- let config = "foo (test)a"- decoder = proc () -> do- KDL.argWith' ["VAL"] KDL.text -< ()- decodeNode "foo" decoder config- `shouldSatisfy` decodeErrorMsg- [ "At: foo #0 > arg #0"- , " Expected annotation to be one of [\"VAL\"], got: test"- ]-- describe "prop" $ do- it "decodes a prop" $ do- let config = "foo test1=1 test2=hello"- decoder = proc () -> do- prop1 <- KDL.prop @Text "test2" -< ()- prop2 <- KDL.prop @Int "test1" -< ()- returnA -< (prop1, prop2)- decodeNode "foo" decoder config `shouldBe` Right ("hello", 1)-- it "can optionally decode a prop" $ do- let config = "foo a=1"- decoder = proc () -> do- a <- KDL.optional $ KDL.prop @Int "a" -< ()- b <- KDL.optional $ KDL.prop @Int "b" -< ()- returnA -< (a, b)- decodeNode "foo" decoder config `shouldBe` Right (Just 1, Nothing)-- it "decodes last prop" $ do- let config = "foo test=1 test=2"- decoder = proc () -> do- KDL.prop @Int "test" -< ()- decodeNode "foo" decoder config `shouldBe` Right 2-- it "fails if prop doesn't exist" $ do- let config = "foo 123"- decoder = proc () -> do- KDL.prop @Int "test" -< ()- decodeNode "foo" decoder config- `shouldSatisfy` decodeErrorMsg- [ "At: foo #0"- , " Expected prop: test"- ]-- it "fails if prop fails to parse" $ do- let config = "foo hello=world"- decoder = proc () -> do- KDL.prop @Int "hello" -< ()- decodeNode "foo" decoder config- `shouldSatisfy` decodeErrorMsg- [ "At: foo #0 > prop hello"- , " Expected number, got: world"- ]-- it "fails if not all props are decoded" $ do- let config = "foo a=1 b=2"- decoder = proc () -> do- KDL.prop @Int "a" -< ()- decodeNode "foo" decoder config- `shouldSatisfy` decodeErrorMsg- [ "At: foo #0"- , " Unexpected prop: b=2"- ]-- -- Most behaviors tested with `prop`- describe "propWith" $ do- it "decodes a prop" $ do- let config = "foo a=1"- decoder = proc () -> do- KDL.propWith "a" KDL.number -< ()- decodeNode "foo" decoder config `shouldBe` Right 1-- -- Most behaviors tested with `propWith`- describe "propWith'" $ do- it "decodes prop with an annotation" $ do- let testCases =- [ []- , ["test"]- , ["test", "other"]- ]- forM_ testCases $ \anns -> do- let config = "foo a=(test)1"- decoder = proc () -> do- KDL.propWith' "a" anns KDL.number -< ()- decodeNode "foo" decoder config `shouldBe` Right 1-- it "decodes prop without an annotation" $ do- let testCases =- [ []- , ["test"]- , ["test", "other"]- ]- forM_ testCases $ \anns -> do- let config = "foo a=1"- decoder = proc () -> do- KDL.propWith' "a" anns KDL.number -< ()- decodeNode "foo" decoder config `shouldBe` Right 1-- it "fails when prop has unexpected annotation" $ do- let config = "foo a=(test)1"- decoder = proc () -> do- 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"- ]-- describe "remainingProps" $ do- it "decodes remaining props" $ do- let config = "foo a=1 b=2 c=3 b=4"- decoder = proc () -> do- _ <- KDL.prop @Int "a" -< ()- KDL.remainingProps @Int -< ()- decodeNode "foo" decoder config- `shouldBe` (Right . Map.fromList) [("b", 4), ("c", 3)]-- it "returns empty map if no props left" $ do- let config = "foo a=1"- decoder = proc () -> do- _ <- KDL.prop @Int "a" -< ()- KDL.remainingProps @Int -< ()- decodeNode "foo" decoder config `shouldBe` Right Map.empty-- it "fails if prop fails to parse" $ do- let config = "foo a=1 b=1 c=2 c=test"- decoder = proc () -> do- _ <- KDL.prop @Int "a" -< ()- KDL.remainingProps @Int -< ()- decodeNode "foo" decoder config- `shouldSatisfy` decodeErrorMsg- [ "At: foo #0 > prop c"- , " Expected number, got: test"- ]-- -- Most behaviors tested with `remainingProps`- describe "remainingPropsWith" $ do- it "decodes remaining props" $ do- let config = "foo a=1 b=2 c=3 b=4"- decoder = proc () -> do- _ <- KDL.prop @Int "a" -< ()- KDL.remainingPropsWith KDL.number -< ()- decodeNode "foo" decoder config- `shouldBe` (Right . Map.fromList) [("b", 4), ("c", 3)]-- -- Most behaviors tested with `remainingPropsWith`- describe "remainingPropsWith'" $ do- it "decodes props with an annotation" $ do- let testCases =- [ []- , ["test"]- , ["test", "other"]- ]- forM_ testCases $ \anns -> do- let config = "foo a=(test)1 b=(test)2"- decoder = proc () -> do- KDL.remainingPropsWith' anns KDL.number -< ()- decodeNode "foo" decoder config- `shouldBe` (Right . Map.fromList) [("a", 1), ("b", 2)]-- it "decodes props without an annotation" $ do- let testCases =- [ []- , ["test"]- , ["test", "other"]- ]- forM_ testCases $ \anns -> do- let config = "foo a=1 b=2"- decoder = proc () -> do- KDL.remainingPropsWith' anns KDL.number -< ()- decodeNode "foo" decoder config- `shouldBe` (Right . Map.fromList) [("a", 1), ("b", 2)]-- it "fails when prop has unexpected annotation" $ do- let config = "foo a=(VAL)1 b=(test)2"- decoder = proc () -> do- 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"- ]-- describe "children" $ do- it "decodes children" $ do- let config = "foo { bar test; }"- decoder = proc () -> do- fmap scrubFormat . KDL.children $ KDL.node @Node "bar" -< ()- expected =- Node- { ann = Nothing- , name = Identifier{value = "bar", ext = KDL.def}- , entries =- [ Entry- { name = Nothing- , value = Value{ann = Nothing, data_ = String "test", ext = KDL.def}- , ext = KDL.def- }- ]- , children = Nothing- , ext = KDL.def- }- decodeNode "foo" decoder config `shouldBe` Right expected-- it "can be re-entered" $ do- let config = "foo { bar a; baz b; }"- decoder = proc () -> do- arg1 <- KDL.children $ KDL.argAt @Text "bar" -< ()- arg2 <- KDL.children $ KDL.argAt @Text "baz" -< ()- returnA -< (arg1, arg2)- decodeNode "foo" decoder config `shouldBe` Right ("a", "b")-- it "fails if not all children are decoded" $ do- let config = "foo { asdf; bar; }"- decoder = proc () -> do- KDL.children $ KDL.node @Node "bar" -< ()- decodeNode "foo" decoder config- `shouldSatisfy` decodeErrorMsg- [ "At: foo #0"- , " Unexpected node: asdf #0"- ]-- describe "ValueDecoder" $ do- describe "any" $ do- it "decodes any value" $ do- let config = "foo 1.0 asdf #true"- decoder = KDL.document $ proc () -> do- map scrubFormat <$> KDL.argsAtWith "foo" KDL.any -< ()- val data_ =- Value- { ann = Nothing- , data_ = data_- , ext = KDL.def- }- KDL.decodeWith decoder config- `shouldBe` Right [val $ Number 1, val $ String "asdf", val $ Bool True]-- describe "text" $ do- it "decodes text value" $ do- let config = "foo asdf"- decoder = KDL.document $ proc () -> do- KDL.argAtWith "foo" KDL.text -< ()- KDL.decodeWith decoder config `shouldBe` Right "asdf"-- it "fails when value is not text" $ do- let config = "foo 1"- decoder = KDL.document $ proc () -> do- KDL.argAtWith "foo" KDL.text -< ()- KDL.decodeWith decoder config- `shouldSatisfy` decodeErrorMsg- [ "At: foo #0 > arg #0"- , " Expected text, got: 1"- ]-- describe "number" $ do- it "decodes number value" $ do- let config = "foo 1"- decoder = KDL.document $ proc () -> do- KDL.argAtWith "foo" KDL.number -< ()- KDL.decodeWith decoder config `shouldBe` Right 1-- it "fails when value is not number" $ do- let config = "foo asdf"- decoder = KDL.document $ proc () -> do- KDL.argAtWith "foo" KDL.number -< ()- KDL.decodeWith decoder config- `shouldSatisfy` decodeErrorMsg- [ "At: foo #0 > arg #0"- , " Expected number, got: asdf"- ]-- describe "bool" $ do- it "decodes bool value" $ do- let config = "foo #true"- decoder = KDL.document $ proc () -> do- KDL.argAtWith "foo" KDL.bool -< ()- KDL.decodeWith decoder config `shouldBe` Right True-- it "fails when value is not bool" $ do- let config = "foo 1"- decoder = KDL.document $ proc () -> do- KDL.argAtWith "foo" KDL.bool -< ()- KDL.decodeWith decoder config- `shouldSatisfy` decodeErrorMsg- [ "At: foo #0 > arg #0"- , " Expected bool, got: 1"- ]-- describe "null" $ do- it "decodes null value" $ do- let config = "foo #null"- decoder = KDL.document $ proc () -> do- KDL.argAtWith "foo" KDL.null -< ()- KDL.decodeWith decoder config `shouldBe` Right ()-- it "fails when value is not null" $ do- let config = "foo 1"- decoder = KDL.document $ proc () -> do- KDL.argAtWith "foo" KDL.null -< ()- KDL.decodeWith decoder config- `shouldSatisfy` decodeErrorMsg- [ "At: foo #0 > arg #0"- , " Expected null, got: 1"- ]-- describe "Combinators" $ do- describe "oneOf" $ do- it "decodes one of the options" $ do- let config = "foo 123 hello"- decoder = KDL.document $ proc () -> do- KDL.nodeWith "foo" . KDL.many . KDL.argWith $- KDL.oneOf [Left <$> KDL.number, Right <$> KDL.text]- -<- ()- KDL.decodeWith decoder config `shouldBe` Right [Left 123, Right "hello"]-- it "fails if none can be decoded" $ do- let config = "foo 123 hello"- decoder = KDL.document $ proc () -> do- KDL.nodeWith "foo" . KDL.many . KDL.argWith $- KDL.oneOf [Left <$> KDL.number, Right <$> KDL.bool]- -<- ()- KDL.decodeWith decoder config- `shouldSatisfy` decodeErrorMsg- [ "At: foo #0 > arg #1"- , " Expected bool, got: hello"- , " Expected number, got: hello"- ]-- describe "option" $ do- it "defaults to the given value" $ do- let config = "foo"- decoder = KDL.document $ proc () -> do- KDL.nodeWith "foo" $ KDL.option 123 $ KDL.arg @Int -< ()- KDL.decodeWith decoder config `shouldBe` Right 123--schemaSpec :: Spec-schemaSpec = do- describe "documentSchema" $ do- it "gets the schema of a decoder" $ do- let decoder = KDL.document $ proc () -> do- x <- KDL.nodeWith "foo" $ show <$> KDL.argWith decodeFoo -< ()- ys <- KDL.many $ KDL.nodeWith "bar" $ KDL.arg @String -< ()-- zType <- KDL.argAt @Text "baz_type" -< ()- z <- KDL.argAtWith "baz" decodeBaz -< zType-- returnA -< (x, ys, z)- decodeFoo =- KDL.oneOf- [ Left <$> KDL.valueDecoder @Bool- , Right <$> KDL.valueDecoder @Text- ]- decodeBaz = proc zType -> do- case zType of- "int" -> KDL.valueDecoder @Int64 -< ()- "bool" -> (\b -> if b then 1 else 0) <$> KDL.valueDecoder @Bool -< ()- _ -> KDL.fail -< "Invalid type: " <> zType- expected =- KDL.SchemaAnd- [ KDL.SchemaOne . KDL.NodeNamed "foo" $- KDL.TypedNodeSchema- { typeHint = typeRep $ Proxy @String- , validTypeAnns = []- , nodeSchema =- KDL.SchemaOne . KDL.NodeArg $- KDL.TypedValueSchema- { typeHint = typeRep $ Proxy @(Either Bool Text)- , validTypeAnns = []- , dataSchema =- KDL.SchemaOr- [ KDL.SchemaOne KDL.BoolSchema- , KDL.SchemaOne KDL.TextSchema- ]- }- }- , KDL.SchemaOr- [ KDL.SchemaSome . KDL.SchemaOne . KDL.NodeNamed "bar" $- KDL.TypedNodeSchema- { typeHint = typeRep $ Proxy @String- , validTypeAnns = []- , nodeSchema =- KDL.SchemaOne . KDL.NodeArg $- KDL.TypedValueSchema- { typeHint = typeRep $ Proxy @String- , validTypeAnns = ["string"]- , dataSchema = KDL.SchemaOne KDL.TextSchema- }- }- , KDL.SchemaAnd []- ]- , KDL.SchemaOne . KDL.NodeNamed "baz_type" $- KDL.TypedNodeSchema- { typeHint = typeRep $ Proxy @Text- , validTypeAnns = []- , nodeSchema =- KDL.SchemaOne . KDL.NodeArg $- KDL.TypedValueSchema- { typeHint = typeRep $ Proxy @Text- , validTypeAnns = ["text"]- , dataSchema = KDL.SchemaOne KDL.TextSchema- }- }- , KDL.SchemaOne . KDL.NodeNamed "baz" $- KDL.TypedNodeSchema- { typeHint = typeRep $ Proxy @Int64- , validTypeAnns = []- , nodeSchema =- KDL.SchemaOne . KDL.NodeArg $- KDL.TypedValueSchema- { typeHint = typeRep $ Proxy @Int64- , validTypeAnns = []- , dataSchema =- KDL.SchemaOr- [ KDL.SchemaOne KDL.NumberSchema- , KDL.SchemaOne KDL.BoolSchema- ]- }- }- ]- KDL.documentSchema decoder `shouldBe` expected--newtype MyNode = MyNode Int- deriving (Eq)--instance KDL.DecodeNode MyNode where- validNodeTypeAnns _ = ["MyNode"]- nodeDecoder = proc () -> do- x <- KDL.arg -< ()- if not (0 < x && x < 10)- then KDL.fail -< "Invalid argument: " <> (Text.pack . show) x- else returnA -< ()- returnA -< MyNode x--decodeNodeSpec :: Spec-decodeNodeSpec = do- describe "DecodeNode" $ do- it "decodes a custom node" $ do- let config = "foo 1"- decoder = KDL.document $ proc () -> do- KDL.node "foo" -< ()- KDL.decodeWith decoder config `shouldBe` Right (MyNode 1)-- it "throws user-specified error" $ do- let config = "foo 100"- decoder = KDL.document $ proc () -> do- KDL.node @MyNode "foo" -< ()- KDL.decodeWith decoder config- `shouldSatisfy` decodeErrorMsg- [ "At: foo #0"- , " Invalid argument: 100"- ]-- it "decodes valid type ann" $ do- let config = "(MyNode)foo 1"- decoder = KDL.document $ proc () -> do- KDL.node "foo" -< ()- KDL.decodeWith decoder config `shouldBe` Right (MyNode 1)-- it "fails on invalid type ann" $ do- let config = "(bad)foo 1"- decoder = KDL.document $ proc () -> do- KDL.node @MyNode "foo" -< ()- KDL.decodeWith decoder config- `shouldSatisfy` decodeErrorMsg- [ "At: foo #0"- , " Expected annotation to be one of [\"MyNode\"], got: bad"- ]--newtype MyVal = MyVal Double- deriving (Eq)--instance KDL.DecodeValue MyVal where- validValueTypeAnns _ = ["MyVal"]- valueDecoder = KDL.withDecoder KDL.number $ \x -> do- unless (0 < x && x < 10) $ do- KDL.failM $ "Invalid value: " <> (Text.pack . show) x- pure $ MyVal (realToFrac x)--decodeValueSpec :: Spec-decodeValueSpec = do- describe "DecodeValue" $ do- it "decodes a custom value" $ do- let config = "foo 1"- decoder = KDL.document $ proc () -> do- KDL.argAt "foo" -< ()- KDL.decodeWith decoder config `shouldBe` Right (MyVal 1)-- it "throws user-specified error" $ do- let config = "foo 100.0"- decoder = KDL.document $ proc () -> do- KDL.argAt @MyVal "foo" -< ()- KDL.decodeWith decoder config- `shouldSatisfy` decodeErrorMsg- [ "At: foo #0 > arg #0"- , " Invalid value: 100.0"- ]-- it "decodes valid type ann" $ do- let config = "foo (MyVal)1"- decoder = KDL.document $ proc () -> do- KDL.argAt "foo" -< ()- KDL.decodeWith decoder config `shouldBe` Right (MyVal 1)-- it "fails on invalid type ann" $ do- let config = "foo (bad)1"- decoder = KDL.document $ proc () -> do- KDL.argAt @MyVal "foo" -< ()- KDL.decodeWith decoder config- `shouldSatisfy` decodeErrorMsg- [ "At: foo #0 > arg #0"- , " Expected annotation to be one of [\"MyVal\"], got: bad"- ]+import Data.Int (Int64)+import Data.Proxy (Proxy (..))+import Data.Text (Text)+import Data.Typeable (typeRep)+import KDL.Arrow qualified as KDL+import KDL.Decoder.SharedSpec.Arrow+import Skeletest++spec :: Spec+spec = do+ apiSpec+ schemaSpec+ decodeNodeSpec+ decodeValueSpec++schemaSpec :: Spec+schemaSpec = do+ describe "documentSchema" $ do+ it "gets the schema of a decoder" $ do+ let decoder = KDL.document $ proc () -> do+ x <- KDL.nodeWith "foo" $ show <$> KDL.argWith decodeFoo -< ()+ ys <- KDL.many $ KDL.nodeWith "bar" $ KDL.arg @String -< ()++ zType <- KDL.argAt @Text "baz_type" -< ()+ z <- KDL.argAtWith "baz" decodeBaz -< zType++ returnA -< (x, ys, z)+ decodeFoo =+ KDL.oneOf+ [ Left <$> KDL.valueDecoder @Bool+ , Right <$> KDL.valueDecoder @Text+ ]+ decodeBaz = proc zType -> do+ case zType of+ "int" -> KDL.valueDecoder @Int64 -< ()+ "bool" -> (\b -> if b then 1 else 0) <$> KDL.valueDecoder @Bool -< ()+ _ -> KDL.fail -< "Invalid type: " <> zType+ expected =+ KDL.SchemaAnd+ [ KDL.SchemaOne . KDL.NodeNamed "foo" $+ KDL.TypedNodeSchema+ { typeHint = typeRep $ Proxy @String+ , validTypeAnns = []+ , nodeSchema =+ KDL.SchemaOne . KDL.NodeArg $+ KDL.TypedValueSchema+ { typeHint = typeRep $ Proxy @(Either Bool Text)+ , validTypeAnns = []+ , dataSchema =+ KDL.SchemaOr+ [ KDL.SchemaOne KDL.BoolSchema+ , KDL.SchemaOne KDL.TextSchema+ ]+ }+ }+ , KDL.SchemaOr+ [ KDL.SchemaSome . KDL.SchemaOne . KDL.NodeNamed "bar" $+ KDL.TypedNodeSchema+ { typeHint = typeRep $ Proxy @String+ , validTypeAnns = []+ , nodeSchema =+ KDL.SchemaOne . KDL.NodeArg $+ KDL.TypedValueSchema+ { typeHint = typeRep $ Proxy @String+ , validTypeAnns = ["string"]+ , dataSchema = KDL.SchemaOne KDL.TextSchema+ }+ }+ , KDL.SchemaAnd []+ ]+ , KDL.SchemaOne . KDL.NodeNamed "baz_type" $+ KDL.TypedNodeSchema+ { typeHint = typeRep $ Proxy @Text+ , validTypeAnns = []+ , nodeSchema =+ KDL.SchemaOne . KDL.NodeArg $+ KDL.TypedValueSchema+ { typeHint = typeRep $ Proxy @Text+ , validTypeAnns = ["string"]+ , dataSchema = KDL.SchemaOne KDL.TextSchema+ }+ }+ , KDL.SchemaOne . KDL.NodeNamed "baz" $+ KDL.TypedNodeSchema+ { typeHint = typeRep $ Proxy @Int64+ , validTypeAnns = []+ , nodeSchema =+ KDL.SchemaOne . KDL.NodeArg $+ KDL.TypedValueSchema+ { typeHint = typeRep $ Proxy @Int64+ , validTypeAnns = []+ , dataSchema =+ KDL.SchemaOr+ [ KDL.SchemaOne KDL.NumberSchema+ , KDL.SchemaOne KDL.BoolSchema+ ]+ }+ }+ ]+ KDL.documentSchema decoder `shouldBe` expected
test/KDL/Decoder/MonadSpec.hs view
@@ -1,1078 +1,10 @@-{-# LANGUAGE DisambiguateRecordFields #-}-{-# LANGUAGE OverloadedStrings #-}--module KDL.Decoder.MonadSpec (spec) where--import Control.Monad (forM_, unless)-import Data.Map qualified as Map-import Data.Text (Text)-import Data.Text qualified as Text-import KDL qualified-import KDL.TestUtils.AST (scrubFormat)-import KDL.TestUtils.Error (decodeErrorMsg)-import KDL.Types (- Entry (..),- Identifier (..),- Node (..),- NodeList (..),- Value (..),- ValueData (..),- )-import Skeletest--spec :: Spec-spec = do- apiSpec- decodeNodeSpec- decodeValueSpec--apiSpec :: Spec-apiSpec = do- describe "NodeListDecoder" $ do- describe "node" $ do- it "decodes a node" $ do- let config = "foo 1.0"- decoder = KDL.document $ do- scrubFormat <$> KDL.node "foo"- expected =- Node- { ann = Nothing- , name = Identifier{value = "foo", ext = KDL.def}- , entries =- [ Entry- { name = Nothing- , value = Value{ann = Nothing, data_ = Number 1.0, ext = KDL.def}- , ext = KDL.def- }- ]- , children = Nothing- , ext = KDL.def- }- KDL.decodeWith decoder config `shouldBe` Right expected-- it "decodes multiple nodes" $ do- let config = "foo; foo"- decoder = KDL.document $ do- fmap (map scrubFormat) . KDL.many $ KDL.node "foo"- expected = [fooNode, fooNode]- fooNode =- Node- { ann = Nothing- , name = Identifier{value = "foo", ext = KDL.def}- , entries = []- , children = Nothing- , ext = KDL.def- }- KDL.decodeWith decoder config `shouldBe` Right expected-- it "decodes nodes in any order" $ do- let config = "foo; bar"- decoder = KDL.document $ do- bar <- scrubFormat <$> KDL.node "bar"- foo <- scrubFormat <$> KDL.node "foo"- pure (bar, foo)- expected = (node "bar", node "foo")- node name =- Node- { ann = Nothing- , name = Identifier{value = name, ext = KDL.def}- , entries = []- , children = Nothing- , ext = KDL.def- }- KDL.decodeWith decoder config `shouldBe` Right expected-- it "fails when not enough nodes" $ do- let config = "foo"- decoder = KDL.document $ do- foo1 <- scrubFormat <$> KDL.node @Node "foo"- foo2 <- scrubFormat <$> KDL.node @Node "foo"- pure (foo1, foo2)- KDL.decodeWith decoder config- `shouldSatisfy` decodeErrorMsg- [ "At: <root>"- , " Expected another node: foo"- ]-- -- Most behaviors tested with `node`- describe "nodeWith" $ do- it "decodes a node" $ do- let config = "foo 1.0 { hello world; }"- decodeFoo = do- arg <- KDL.arg @Int- child <- KDL.children $ KDL.argAt @Text "hello"- pure (arg, child)- decoder = KDL.document $ do- KDL.nodeWith "foo" decodeFoo- KDL.decodeWith decoder config `shouldBe` Right (1, "world")-- it "fails when node fails to parse" $ do- let config = "foo 1.0"- decodeFoo = do- KDL.arg @Text- decoder = KDL.document $ do- KDL.nodeWith "foo" decodeFoo- KDL.decodeWith decoder config- `shouldSatisfy` decodeErrorMsg- [ "At: foo #0 > arg #0"- , " Expected text, got: 1.0"- ]-- -- Most behaviors tested with `nodeWith`- describe "nodeWith'" $ do- it "decodes a node with an annotation" $ do- let testCases =- [ []- , ["test"]- , ["test", "other"]- ]- forM_ testCases $ \anns -> do- let config = "(test)foo 1"- decoder = KDL.document $ do- KDL.nodeWith' "foo" anns $ KDL.arg @Int- KDL.decodeWith decoder config `shouldBe` Right 1-- it "decodes a node without an annotation" $ do- let testCases =- [ []- , ["test"]- , ["test", "other"]- ]- forM_ testCases $ \anns -> do- let config = "foo 1"- decoder = KDL.document $ do- KDL.nodeWith' "foo" anns $ KDL.arg @Int- KDL.decodeWith decoder config `shouldBe` Right 1-- it "fails when node has unexpected annotation" $ do- let config = "(test)foo 2"- decoder = KDL.document $ do- 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"- ]-- describe "remainingNodes" $ do- it "returns all remaining nodes" $ do- let config = "foo 1.0; foo 2.0; bar"- decoder = KDL.document $ do- _ <- KDL.node @Node "foo"- fmap (map scrubFormat) <$> KDL.remainingNodes- expected =- Map.fromList- [ ("foo", [fooNode2])- , ("bar", [barNode])- ]- fooNode2 =- Node- { ann = Nothing- , name = Identifier{value = "foo", ext = KDL.def}- , entries =- [ Entry- { name = Nothing- , value = Value{ann = Nothing, data_ = Number 2.0, ext = KDL.def}- , ext = KDL.def- }- ]- , children = Nothing- , ext = KDL.def- }- barNode =- Node- { ann = Nothing- , name = Identifier{value = "bar", ext = KDL.def}- , entries = []- , children = Nothing- , ext = KDL.def- }- KDL.decodeWith decoder config `shouldBe` Right expected-- -- Most behaviors tested with `remainingNodes`- describe "remainingNodesWith" $ do- it "returns all remaining nodes" $ do- let config = "foo 1.0; foo 2.0; bar"- decodeNode = do- KDL.optional $ KDL.arg @Int- decoder = KDL.document $ do- _ <- KDL.node @Node "foo"- KDL.remainingNodesWith decodeNode- expected =- Map.fromList- [ ("foo", [Just 2])- , ("bar", [Nothing])- ]- KDL.decodeWith decoder config `shouldBe` Right expected-- it "fails when node fails to parse" $ do- let config = "foo 1; bar 1; bar hello"- decodeNode = do- KDL.arg @Int- decoder = KDL.document $ do- KDL.remainingNodesWith decodeNode- KDL.decodeWith decoder config- `shouldSatisfy` decodeErrorMsg- [ "At: bar #1 > arg #0"- , " Expected number, got: hello"- ]-- -- Most behaviors tested with `remainingNodesWith`- describe "remainingNodesWith'" $ do- it "decodes a node with an annotation" $ do- let testCases =- [ []- , ["test"]- , ["test", "other"]- ]- forM_ testCases $ \anns -> do- let config = "(test)foo 1"- decoder = KDL.document $ do- KDL.remainingNodesWith' anns $ KDL.arg @Int- KDL.decodeWith decoder config- `shouldBe` (Right . Map.fromList) [("foo", [1])]-- it "decodes a node without an annotation" $ do- let testCases =- [ []- , ["test"]- , ["test", "other"]- ]- forM_ testCases $ \anns -> do- let config = "foo 1"- decoder = KDL.document $ do- KDL.remainingNodesWith' anns $ KDL.arg @Int- KDL.decodeWith decoder config- `shouldBe` (Right . Map.fromList) [("foo", [1])]-- it "fails when node has unexpected annotation" $ do- let config = "(FOO)foo 1; (test)foo 2"- decoder = KDL.document $ do- KDL.remainingNodesWith' ["FOO"] $ KDL.arg @Int- KDL.decodeWith decoder config- `shouldSatisfy` decodeErrorMsg- [ "At: foo #1"- , " Expected annotation to be one of [\"FOO\"], got: test"- ]-- describe "argAt" $ do- it "gets argument at a node" $ do- let config = "foo bar; hello world"- decoder = KDL.document $ do- hello <- KDL.argAt @Text "hello"- foo <- KDL.argAt @Text "foo"- pure (hello, foo)- KDL.decodeWith decoder config `shouldBe` Right ("world", "bar")-- it "fails if no node" $ do- let config = "other_node"- decoder = KDL.document $ do- KDL.argAt @Int "foo"- KDL.decodeWith decoder config- `shouldSatisfy` decodeErrorMsg- [ "At: <root>"- , " Expected node: foo"- ]-- it "fails if node has no args" $ do- let config = "foo"- decoder = KDL.document $ do- KDL.argAt @Int "foo"- KDL.decodeWith decoder config- `shouldSatisfy` decodeErrorMsg- [ "At: foo #0"- , " Expected arg #0"- ]-- it "fails if arg fails to parse" $ do- let config = "foo 1"- decoder = KDL.document $ do- KDL.argAt @Text "foo"- KDL.decodeWith decoder config- `shouldSatisfy` decodeErrorMsg- [ "At: foo #0 > arg #0"- , " Expected text, got: 1"- ]-- -- Most behaviors tested with `argAt`- describe "argAtWith" $ do- it "gets argument at a node" $ do- let config = "foo 1"- decoder = KDL.document $ do- KDL.argAtWith "foo" $ show . (* 10) <$> KDL.number- KDL.decodeWith decoder config `shouldBe` Right "10.0"-- -- Most behaviors tested with `argAtWith`- describe "argAtWith'" $ do- it "decodes argument with an annotation" $ do- let testCases =- [ []- , ["test"]- , ["test", "other"]- ]- forM_ testCases $ \anns -> do- let config = "foo (test)a"- decoder = KDL.document $ do- KDL.argAtWith' "foo" anns KDL.text- KDL.decodeWith decoder config `shouldBe` Right "a"-- it "decodes argument without an annotation" $ do- let testCases =- [ []- , ["test"]- , ["test", "other"]- ]- forM_ testCases $ \anns -> do- let config = "foo a"- decoder = KDL.document $ do- KDL.argAtWith' "foo" anns KDL.text- KDL.decodeWith decoder config `shouldBe` Right "a"-- it "fails when argument has unexpected annotation" $ do- let config = "foo (test)a"- decoder = KDL.document $ do- KDL.argAtWith' "foo" ["VAL"] KDL.text- KDL.decodeWith decoder config- `shouldSatisfy` decodeErrorMsg- [ "At: foo #0 > arg #0"- , " Expected annotation to be one of [\"VAL\"], got: test"- ]-- describe "argsAt" $ do- it "gets arguments at a node" $ do- let config = "foo 1 2 3"- decoder = KDL.document $ do- KDL.argsAt @Int "foo"- KDL.decodeWith decoder config `shouldBe` Right [1, 2, 3]-- it "returns empty list if no node" $ do- let config = ""- decoder = KDL.document $ do- KDL.argsAt @Int "foo"- KDL.decodeWith decoder config `shouldBe` Right []-- it "returns empty list if node has no args" $ do- let config = "foo"- decoder = KDL.document $ do- KDL.argsAt @Int "foo"- KDL.decodeWith decoder config `shouldBe` Right []-- it "fails if any arg fails to parse" $ do- let config = "foo 1 asdf"- decoder = KDL.document $ do- KDL.argsAt @Int "foo"- KDL.decodeWith decoder config- `shouldSatisfy` decodeErrorMsg- [ "At: foo #0 > arg #1"- , " Expected number, got: asdf"- ]-- -- Most behaviors tested with `argsAt`- describe "argsAtWith" $ do- it "gets arguments at a node" $ do- let config = "foo 1 2"- decoder = KDL.document $ do- KDL.argsAtWith "foo" $ show . (* 10) <$> KDL.number- KDL.decodeWith decoder config `shouldBe` Right ["10.0", "20.0"]-- -- Most behaviors tested with `argsAtWith`- describe "argsAtWith'" $ do- it "decodes arguments with an annotation" $ do- let testCases =- [ []- , ["test"]- , ["test", "other"]- ]- forM_ testCases $ \anns -> do- let config = "foo (test)a (test)b"- decoder = KDL.document $ do- KDL.argsAtWith' "foo" anns KDL.text- KDL.decodeWith decoder config `shouldBe` Right ["a", "b"]-- it "decodes arguments without an annotation" $ do- let testCases =- [ []- , ["test"]- , ["test", "other"]- ]- forM_ testCases $ \anns -> do- let config = "foo a b"- decoder = KDL.document $ do- KDL.argsAtWith' "foo" anns KDL.text- KDL.decodeWith decoder config `shouldBe` Right ["a", "b"]-- it "fails when argument has unexpected annotation" $ do- let config = "foo (VAL)a (test)b"- decoder = KDL.document $ do- KDL.argsAtWith' "foo" ["VAL"] KDL.text- KDL.decodeWith decoder config- `shouldSatisfy` decodeErrorMsg- [ "At: foo #0 > arg #1"- , " Expected annotation to be one of [\"VAL\"], got: test"- ]-- describe "dashChildrenAt" $ do- it "gets dash children at a node" $ do- let config = "foo { - 1; - 2; - 3; }"- decoder = KDL.document $ do- KDL.dashChildrenAt @Int "foo"- KDL.decodeWith decoder config `shouldBe` Right [1, 2, 3]-- it "returns empty list if no node" $ do- let config = ""- decoder = KDL.document $ do- KDL.dashChildrenAt @Int "foo"- KDL.decodeWith decoder config `shouldBe` Right []-- it "returns empty list if node has no dash children" $ do- forM_ ["foo", "foo {}"] $ \config -> do- let decoder = KDL.document $ do- KDL.dashChildrenAt @Int "foo"- KDL.decodeWith decoder config `shouldBe` Right []-- it "fails if dash children have multiple args" $ do- let config = "foo { - 1 2; - 3 4; }"- decoder = KDL.document $ do- KDL.dashChildrenAt @Int "foo"- KDL.decodeWith decoder config- `shouldSatisfy` decodeErrorMsg- [ "At: foo #0 > - #0"- , " Unexpected arg #1: 2"- ]-- it "fails if node has non-dash children" $ do- let config = "foo { - 1; bar 1 2 3; }"- decoder = KDL.document $ do- KDL.dashChildrenAt @Int "foo"- KDL.decodeWith decoder config- `shouldSatisfy` decodeErrorMsg- [ "At: foo #0"- , " Unexpected node: bar #0"- ]-- it "fails if any child fails to parse" $ do- let config = "foo { - 1; - asdf; }"- decoder = KDL.document $ do- KDL.dashChildrenAt @Int "foo"- KDL.decodeWith decoder config- `shouldSatisfy` decodeErrorMsg- [ "At: foo #0 > - #1 > arg #0"- , " Expected number, got: asdf"- ]-- -- Most behaviors tested with `dashChildrenAt`- describe "dashChildrenAtWith" $ do- it "gets dash children at a node" $ do- let config = "foo { - 1; - 2; }"- decoder = KDL.document $ do- KDL.dashChildrenAtWith "foo" $ show . (* 10) <$> KDL.number- KDL.decodeWith decoder config `shouldBe` Right ["10.0", "20.0"]-- -- Most behaviors tested with `dashChildrenAtWith`- describe "dashChildrenAtWith'" $ do- it "decodes dash children with an annotation" $ do- let testCases =- [ []- , ["test"]- , ["test", "other"]- ]- forM_ testCases $ \anns -> do- let config = "foo { - (test)a; - (test)b; }"- decoder = KDL.document $ do- KDL.dashChildrenAtWith' "foo" anns KDL.text- KDL.decodeWith decoder config `shouldBe` Right ["a", "b"]-- it "decodes dash children without an annotation" $ do- let testCases =- [ []- , ["test"]- , ["test", "other"]- ]- forM_ testCases $ \anns -> do- let config = "foo { - a; - b; }"- decoder = KDL.document $ do- KDL.dashChildrenAtWith' "foo" anns KDL.text- KDL.decodeWith decoder config `shouldBe` Right ["a", "b"]-- it "fails when child has unexpected annotation" $ do- let config = "foo { - (test)a; }"- decoder = KDL.document $ do- KDL.dashChildrenAtWith' "foo" ["VAL"] KDL.text- KDL.decodeWith decoder config- `shouldSatisfy` decodeErrorMsg- [ "At: foo #0 > - #0 > arg #0"- , " Expected annotation to be one of [\"VAL\"], got: test"- ]-- describe "dashNodesAt" $ do- it "gets dash nodes at a node" $ do- let config = "foo { - { bar; }; - { baz; }; }"- decoder = KDL.document $ do- map scrubFormat <$> KDL.dashNodesAt "foo"- expected = [node "-" [node "bar" []], node "-" [node "baz" []]]- node name children =- Node- { ann = Nothing- , name = Identifier{value = name, ext = KDL.def}- , entries = []- , children =- if null children- then Nothing- else Just NodeList{nodes = children, ext = KDL.def}- , ext = KDL.def- }- KDL.decodeWith decoder config `shouldBe` Right expected-- it "returns empty list if no node" $ do- let config = ""- decoder = KDL.document $ do- KDL.dashNodesAt @Node "foo"- KDL.decodeWith decoder config `shouldBe` Right []-- it "returns empty list if node has no dash nodes" $ do- forM_ ["foo", "foo {}"] $ \config -> do- let decoder = KDL.document $ do- KDL.dashNodesAt @Node "foo"- KDL.decodeWith decoder config `shouldBe` Right []-- it "fails if node has non-dash nodes" $ do- let config = "foo { - 1; bar 1 2 3; }"- decoder = KDL.document $ do- KDL.dashNodesAt @Node "foo"- KDL.decodeWith decoder config- `shouldSatisfy` decodeErrorMsg- [ "At: foo #0"- , " Unexpected node: bar #0"- ]-- -- Most behaviors tested with `dashNodesAt`- describe "dashNodesAtWith" $ do- it "gets dash nodes at a node" $ do- let config = "foo { - 1 { bar hello; }; - 2 { bar world; }; }"- decodeChild = do- arg <- KDL.arg @Int- child <- KDL.children $ KDL.nodeWith "bar" $ KDL.arg @Text- pure (arg, child)- decoder = KDL.document $ do- KDL.dashNodesAtWith "foo" decodeChild- KDL.decodeWith decoder config `shouldBe` Right [(1, "hello"), (2, "world")]-- it "fails if any child fails to parse" $ do- let config = "foo { - { bar 1; }; - { bar test; }; }"- decoder = KDL.document $ do- 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"- ]-- describe "NodeDecoder" $ do- let decodeNode name decoder config =- KDL.decodeWith- ( KDL.document $ do- KDL.nodeWith name decoder- )- config-- describe "arg" $ do- it "decodes an argument" $ do- let config = "foo 1 bar"- decoder = do- arg1 <- KDL.arg @Int- arg2 <- KDL.arg @Text- pure (arg1, arg2)- decodeNode "foo" decoder config `shouldBe` Right (1, "bar")-- it "decodes multiple arguments" $ do- let config = "foo 1 2 3"- decoder = do- KDL.many $ KDL.arg @Int- decodeNode "foo" decoder config `shouldBe` Right [1, 2, 3]-- it "fails if argument doesn't exist" $ do- let config = "foo"- decoder = do- KDL.arg @Int- decodeNode "foo" decoder config- `shouldSatisfy` decodeErrorMsg- [ "At: foo #0"- , " Expected arg #0"- ]-- it "fails if argument fails to parse" $ do- let config = "foo test"- decoder = do- KDL.arg @Int- decodeNode "foo" decoder config- `shouldSatisfy` decodeErrorMsg- [ "At: foo #0 > arg #0"- , " Expected number, got: test"- ]-- it "fails if not all arguments are decoded" $ do- let config = "foo 1 2 3"- decoder = do- KDL.arg @Int- decodeNode "foo" decoder config- `shouldSatisfy` decodeErrorMsg- [ "At: foo #0"- , " Unexpected arg #1: 2"- ]-- -- Most behaviors tested with `arg`- describe "argWith" $ do- it "decodes an argument" $ do- let config = "foo bar"- decoder = do- KDL.argWith KDL.text- decodeNode "foo" decoder config `shouldBe` Right "bar"-- -- Most behaviors tested with `argWith`- describe "argWith'" $ do- it "decodes argument with an annotation" $ do- let testCases =- [ []- , ["test"]- , ["test", "other"]- ]- forM_ testCases $ \anns -> do- let config = "foo (test)a"- decoder = do- KDL.argWith' anns KDL.text- decodeNode "foo" decoder config `shouldBe` Right "a"-- it "decodes argument without an annotation" $ do- let testCases =- [ []- , ["test"]- , ["test", "other"]- ]- forM_ testCases $ \anns -> do- let config = "foo a"- decoder = do- KDL.argWith' anns KDL.text- decodeNode "foo" decoder config `shouldBe` Right "a"-- it "fails when argument has unexpected annotation" $ do- let config = "foo (test)a"- decoder = do- KDL.argWith' ["VAL"] KDL.text- decodeNode "foo" decoder config- `shouldSatisfy` decodeErrorMsg- [ "At: foo #0 > arg #0"- , " Expected annotation to be one of [\"VAL\"], got: test"- ]-- describe "prop" $ do- it "decodes a prop" $ do- let config = "foo test1=1 test2=hello"- decoder = do- prop1 <- KDL.prop @Text "test2"- prop2 <- KDL.prop @Int "test1"- pure (prop1, prop2)- decodeNode "foo" decoder config `shouldBe` Right ("hello", 1)-- it "can optionally decode a prop" $ do- let config = "foo a=1"- decoder = do- a <- KDL.optional $ KDL.prop @Int "a"- b <- KDL.optional $ KDL.prop @Int "b"- pure (a, b)- decodeNode "foo" decoder config `shouldBe` Right (Just 1, Nothing)-- it "decodes last prop" $ do- let config = "foo test=1 test=2"- decoder = do- KDL.prop @Int "test"- decodeNode "foo" decoder config `shouldBe` Right 2-- it "fails if prop doesn't exist" $ do- let config = "foo 123"- decoder = do- KDL.prop @Int "test"- decodeNode "foo" decoder config- `shouldSatisfy` decodeErrorMsg- [ "At: foo #0"- , " Expected prop: test"- ]-- it "fails if prop fails to parse" $ do- let config = "foo hello=world"- decoder = do- KDL.prop @Int "hello"- decodeNode "foo" decoder config- `shouldSatisfy` decodeErrorMsg- [ "At: foo #0 > prop hello"- , " Expected number, got: world"- ]-- it "fails if not all props are decoded" $ do- let config = "foo a=1 b=2"- decoder = do- KDL.prop @Int "a"- decodeNode "foo" decoder config- `shouldSatisfy` decodeErrorMsg- [ "At: foo #0"- , " Unexpected prop: b=2"- ]-- -- Most behaviors tested with `prop`- describe "propWith" $ do- it "decodes a prop" $ do- let config = "foo a=1"- decoder = do- KDL.propWith "a" KDL.number- decodeNode "foo" decoder config `shouldBe` Right 1-- -- Most behaviors tested with `propWith`- describe "propWith'" $ do- it "decodes prop with an annotation" $ do- let testCases =- [ []- , ["test"]- , ["test", "other"]- ]- forM_ testCases $ \anns -> do- let config = "foo a=(test)1"- decoder = do- KDL.propWith' "a" anns KDL.number- decodeNode "foo" decoder config `shouldBe` Right 1-- it "decodes prop without an annotation" $ do- let testCases =- [ []- , ["test"]- , ["test", "other"]- ]- forM_ testCases $ \anns -> do- let config = "foo a=1"- decoder = do- KDL.propWith' "a" anns KDL.number- decodeNode "foo" decoder config `shouldBe` Right 1-- it "fails when prop has unexpected annotation" $ do- let config = "foo a=(test)1"- decoder = do- 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"- ]-- describe "remainingProps" $ do- it "decodes remaining props" $ do- let config = "foo a=1 b=2 c=3 b=4"- decoder = do- _ <- KDL.prop @Int "a"- KDL.remainingProps @Int- decodeNode "foo" decoder config- `shouldBe` (Right . Map.fromList) [("b", 4), ("c", 3)]-- it "returns empty map if no props left" $ do- let config = "foo a=1"- decoder = do- _ <- KDL.prop @Int "a"- KDL.remainingProps @Int- decodeNode "foo" decoder config `shouldBe` Right Map.empty-- it "fails if prop fails to parse" $ do- let config = "foo a=1 b=1 c=2 c=test"- decoder = do- _ <- KDL.prop @Int "a"- KDL.remainingProps @Int- decodeNode "foo" decoder config- `shouldSatisfy` decodeErrorMsg- [ "At: foo #0 > prop c"- , " Expected number, got: test"- ]-- -- Most behaviors tested with `remainingProps`- describe "remainingPropsWith" $ do- it "decodes remaining props" $ do- let config = "foo a=1 b=2 c=3 b=4"- decoder = do- _ <- KDL.prop @Int "a"- KDL.remainingPropsWith KDL.number- decodeNode "foo" decoder config- `shouldBe` (Right . Map.fromList) [("b", 4), ("c", 3)]-- -- Most behaviors tested with `remainingPropsWith`- describe "remainingPropsWith'" $ do- it "decodes props with an annotation" $ do- let testCases =- [ []- , ["test"]- , ["test", "other"]- ]- forM_ testCases $ \anns -> do- let config = "foo a=(test)1 b=(test)2"- decoder = do- KDL.remainingPropsWith' anns KDL.number- decodeNode "foo" decoder config- `shouldBe` (Right . Map.fromList) [("a", 1), ("b", 2)]-- it "decodes props without an annotation" $ do- let testCases =- [ []- , ["test"]- , ["test", "other"]- ]- forM_ testCases $ \anns -> do- let config = "foo a=1 b=2"- decoder = do- KDL.remainingPropsWith' anns KDL.number- decodeNode "foo" decoder config- `shouldBe` (Right . Map.fromList) [("a", 1), ("b", 2)]-- it "fails when prop has unexpected annotation" $ do- let config = "foo a=(VAL)1 b=(test)2"- decoder = do- 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"- ]-- describe "children" $ do- it "decodes children" $ do- let config = "foo { bar test; }"- decoder = do- fmap scrubFormat . KDL.children $ KDL.node @Node "bar"- expected =- Node- { ann = Nothing- , name = Identifier{value = "bar", ext = KDL.def}- , entries =- [ Entry- { name = Nothing- , value = Value{ann = Nothing, data_ = String "test", ext = KDL.def}- , ext = KDL.def- }- ]- , children = Nothing- , ext = KDL.def- }- decodeNode "foo" decoder config `shouldBe` Right expected-- it "can be re-entered" $ do- let config = "foo { bar a; baz b; }"- decoder = do- arg1 <- KDL.children $ KDL.argAt @Text "bar"- arg2 <- KDL.children $ KDL.argAt @Text "baz"- pure (arg1, arg2)- decodeNode "foo" decoder config `shouldBe` Right ("a", "b")-- it "fails if not all children are decoded" $ do- let config = "foo { asdf; bar; }"- decoder = do- KDL.children $ KDL.node @Node "bar"- decodeNode "foo" decoder config- `shouldSatisfy` decodeErrorMsg- [ "At: foo #0"- , " Unexpected node: asdf #0"- ]-- describe "ValueDecoder" $ do- describe "any" $ do- it "decodes any value" $ do- let config = "foo 1.0 asdf #true"- decoder = KDL.document $ do- map scrubFormat <$> KDL.argsAtWith "foo" KDL.any- val data_ =- Value- { ann = Nothing- , data_ = data_- , ext = KDL.def- }- KDL.decodeWith decoder config- `shouldBe` Right [val $ Number 1, val $ String "asdf", val $ Bool True]-- describe "text" $ do- it "decodes text value" $ do- let config = "foo asdf"- decoder = KDL.document $ do- KDL.argAtWith "foo" KDL.text- KDL.decodeWith decoder config `shouldBe` Right "asdf"-- it "fails when value is not text" $ do- let config = "foo 1"- decoder = KDL.document $ do- KDL.argAtWith "foo" KDL.text- KDL.decodeWith decoder config- `shouldSatisfy` decodeErrorMsg- [ "At: foo #0 > arg #0"- , " Expected text, got: 1"- ]-- describe "number" $ do- it "decodes number value" $ do- let config = "foo 1"- decoder = KDL.document $ do- KDL.argAtWith "foo" KDL.number- KDL.decodeWith decoder config `shouldBe` Right 1-- it "fails when value is not number" $ do- let config = "foo asdf"- decoder = KDL.document $ do- KDL.argAtWith "foo" KDL.number- KDL.decodeWith decoder config- `shouldSatisfy` decodeErrorMsg- [ "At: foo #0 > arg #0"- , " Expected number, got: asdf"- ]-- describe "bool" $ do- it "decodes bool value" $ do- let config = "foo #true"- decoder = KDL.document $ do- KDL.argAtWith "foo" KDL.bool- KDL.decodeWith decoder config `shouldBe` Right True-- it "fails when value is not bool" $ do- let config = "foo 1"- decoder = KDL.document $ do- KDL.argAtWith "foo" KDL.bool- KDL.decodeWith decoder config- `shouldSatisfy` decodeErrorMsg- [ "At: foo #0 > arg #0"- , " Expected bool, got: 1"- ]-- describe "null" $ do- it "decodes null value" $ do- let config = "foo #null"- decoder = KDL.document $ do- KDL.argAtWith "foo" KDL.null- KDL.decodeWith decoder config `shouldBe` Right ()-- it "fails when value is not null" $ do- let config = "foo 1"- decoder = KDL.document $ do- KDL.argAtWith "foo" KDL.null- KDL.decodeWith decoder config- `shouldSatisfy` decodeErrorMsg- [ "At: foo #0 > arg #0"- , " Expected null, got: 1"- ]-- describe "Combinators" $ do- describe "oneOf" $ do- it "decodes one of the options" $ do- let config = "foo 123 hello"- decoder = KDL.document $ do- KDL.nodeWith "foo" . KDL.many . KDL.argWith $- KDL.oneOf [Left <$> KDL.number, Right <$> KDL.text]- KDL.decodeWith decoder config `shouldBe` Right [Left 123, Right "hello"]-- it "fails if none can be decoded" $ do- let config = "foo 123 hello"- decoder = KDL.document $ do- KDL.nodeWith "foo" . KDL.many . KDL.argWith $- KDL.oneOf [Left <$> KDL.number, Right <$> KDL.bool]- KDL.decodeWith decoder config- `shouldSatisfy` decodeErrorMsg- [ "At: foo #0 > arg #1"- , " Expected bool, got: hello"- , " Expected number, got: hello"- ]-- describe "option" $ do- it "defaults to the given value" $ do- let config = "foo"- decoder = KDL.document $ do- KDL.nodeWith "foo" $ KDL.option 123 $ KDL.arg @Int- KDL.decodeWith decoder config `shouldBe` Right 123--newtype MyNode = MyNode Int- deriving (Eq)--instance KDL.DecodeNode MyNode where- validNodeTypeAnns _ = ["MyNode"]- nodeDecoder = do- x <- KDL.arg- unless (0 < x && x < 10) $ do- KDL.fail $ "Invalid argument: " <> (Text.pack . show) x- pure $ MyNode x--decodeNodeSpec :: Spec-decodeNodeSpec = do- describe "DecodeNode" $ do- it "decodes a custom node" $ do- let config = "foo 1"- decoder = KDL.document $ do- KDL.node "foo"- KDL.decodeWith decoder config `shouldBe` Right (MyNode 1)-- it "throws user-specified error" $ do- let config = "foo 100"- decoder = KDL.document $ do- KDL.node @MyNode "foo"- KDL.decodeWith decoder config- `shouldSatisfy` decodeErrorMsg- [ "At: foo #0"- , " Invalid argument: 100"- ]-- it "decodes valid type ann" $ do- let config = "(MyNode)foo 1"- decoder = KDL.document $ do- KDL.node "foo"- KDL.decodeWith decoder config `shouldBe` Right (MyNode 1)-- it "fails on invalid type ann" $ do- let config = "(bad)foo 1"- decoder = KDL.document $ do- KDL.node @MyNode "foo"- KDL.decodeWith decoder config- `shouldSatisfy` decodeErrorMsg- [ "At: foo #0"- , " Expected annotation to be one of [\"MyNode\"], got: bad"- ]--newtype MyVal = MyVal Double- deriving (Eq)--instance KDL.DecodeValue MyVal where- validValueTypeAnns _ = ["MyVal"]- valueDecoder = KDL.withDecoder KDL.number $ \x -> do- unless (0 < x && x < 10) $ do- KDL.failM $ "Invalid value: " <> (Text.pack . show) x- pure $ MyVal (realToFrac x)--decodeValueSpec :: Spec-decodeValueSpec = do- describe "DecodeValue" $ do- it "decodes a custom value" $ do- let config = "foo 1"- decoder = KDL.document $ do- KDL.argAt "foo"- KDL.decodeWith decoder config `shouldBe` Right (MyVal 1)-- it "throws user-specified error" $ do- let config = "foo 100.0"- decoder = KDL.document $ do- KDL.argAt @MyVal "foo"- KDL.decodeWith decoder config- `shouldSatisfy` decodeErrorMsg- [ "At: foo #0 > arg #0"- , " Invalid value: 100.0"- ]-- it "decodes valid type ann" $ do- let config = "foo (MyVal)1"- decoder = KDL.document $ do- KDL.argAt "foo"- KDL.decodeWith decoder config `shouldBe` Right (MyVal 1)-- it "fails on invalid type ann" $ do- let config = "foo (bad)1"- decoder = KDL.document $ do- KDL.argAt @MyVal "foo"- KDL.decodeWith decoder config- `shouldSatisfy` decodeErrorMsg- [ "At: foo #0 > arg #0"- , " Expected annotation to be one of [\"MyVal\"], got: bad"- ]+module KDL.Decoder.MonadSpec (spec) where++import KDL.Decoder.SharedSpec.Monad+import Skeletest++spec :: Spec+spec = do+ apiSpec+ decodeNodeSpec+ decodeValueSpec
@@ -0,0 +1,5 @@+{-# LANGUAGE CPP #-}++#define MODULE_NAME Arrow+#define IS_ARROW+#include "./Template.hs"
@@ -0,0 +1,5 @@+{-# LANGUAGE CPP #-}++#define MODULE_NAME Monad+#define IS_MONAD+#include "./Template.hs"
test/KDL/__snapshots__/DecoderSpec.snap.md view
@@ -24,7 +24,7 @@ ``` Failed to decode test_config.kdl: At: foo #1 > bar #0 > baz #3 > prop a- Expected text, got: 1+ Expected string, got: 1 ``` ## decodeWith / fails with helpful error if parsing fails@@ -49,5 +49,5 @@ ``` At: foo #1 > bar #0 > baz #3 > prop a- Expected text, got: 1+ Expected string, got: 1 ```