diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/kdl-hs.cabal b/kdl-hs.cabal --- a/kdl-hs.cabal +++ b/kdl-hs.cabal @@ -1,7 +1,7 @@ cabal-version: 3.0 name: kdl-hs -version: 1.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 diff --git a/src/KDL/Decoder/Arrow.hs b/src/KDL/Decoder/Arrow.hs --- a/src/KDL/Decoder/Arrow.hs +++ b/src/KDL/Decoder/Arrow.hs @@ -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. -- diff --git a/src/KDL/Decoder/Internal/DecodeM.hs b/src/KDL/Decoder/Internal/DecodeM.hs --- a/src/KDL/Decoder/Internal/DecodeM.hs +++ b/src/KDL/Decoder/Internal/DecodeM.hs @@ -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 "" + 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 :)) diff --git a/src/KDL/Decoder/Internal/Error.hs b/src/KDL/Decoder/Internal/Error.hs --- a/src/KDL/Decoder/Internal/Error.hs +++ b/src/KDL/Decoder/Internal/Error.hs @@ -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 diff --git a/test/KDL/ApplicativeSpec.hs b/test/KDL/ApplicativeSpec.hs --- a/test/KDL/ApplicativeSpec.hs +++ b/test/KDL/ApplicativeSpec.hs @@ -85,7 +85,7 @@ KDL.SchemaOne . KDL.NodeArg $ KDL.TypedValueSchema { typeHint = typeRep $ Proxy @Text - , validTypeAnns = ["text"] + , validTypeAnns = ["string"] , dataSchema = KDL.SchemaOne KDL.TextSchema } } diff --git a/test/KDL/Decoder/ArrowSpec.hs b/test/KDL/Decoder/ArrowSpec.hs --- a/test/KDL/Decoder/ArrowSpec.hs +++ b/test/KDL/Decoder/ArrowSpec.hs @@ -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: " - , " 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: " - , " 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 diff --git a/test/KDL/Decoder/MonadSpec.hs b/test/KDL/Decoder/MonadSpec.hs --- a/test/KDL/Decoder/MonadSpec.hs +++ b/test/KDL/Decoder/MonadSpec.hs @@ -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: " - , " 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: " - , " 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 diff --git a/test/KDL/Decoder/SharedSpec/Arrow.hs b/test/KDL/Decoder/SharedSpec/Arrow.hs new file mode 100644 --- /dev/null +++ b/test/KDL/Decoder/SharedSpec/Arrow.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE CPP #-} + +#define MODULE_NAME Arrow +#define IS_ARROW +#include "./Template.hs" diff --git a/test/KDL/Decoder/SharedSpec/Monad.hs b/test/KDL/Decoder/SharedSpec/Monad.hs new file mode 100644 --- /dev/null +++ b/test/KDL/Decoder/SharedSpec/Monad.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE CPP #-} + +#define MODULE_NAME Monad +#define IS_MONAD +#include "./Template.hs" diff --git a/test/KDL/__snapshots__/DecoderSpec.snap.md b/test/KDL/__snapshots__/DecoderSpec.snap.md --- a/test/KDL/__snapshots__/DecoderSpec.snap.md +++ b/test/KDL/__snapshots__/DecoderSpec.snap.md @@ -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 ```