packages feed

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 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
+ test/KDL/Decoder/SharedSpec/Arrow.hs view
@@ -0,0 +1,5 @@+{-# LANGUAGE CPP #-}++#define MODULE_NAME Arrow+#define IS_ARROW+#include "./Template.hs"
+ test/KDL/Decoder/SharedSpec/Monad.hs view
@@ -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 ```