mdoc-0.4.1.2: test/Autodocodec/Schema/MdocSpec.hs
-- |
--
-- Module : Autodocodec.Schema.MdocSpec
-- Copyright : (c) 2026 Patrick Brisbin
-- License : AGPL-3
-- Maintainer : pbrisbin@gmail.com
-- Stability : experimental
-- Portability : POSIX
module Autodocodec.Schema.MdocSpec
( spec
) where
import Mdoc.Prelude
import Autodocodec.Schema
import Autodocodec.Schema.Mdoc
import Data.Aeson (Result (..), Value, fromJSON, object, (.=))
import Mdoc.Test.Render
import Test.Hspec
t :: Text -> Text
t = id
spec :: Spec
spec = do
it "primitive" $ do
assertSchemaRenders
(object ["type" .= t "boolean"])
[".It : Ar boolean"]
it "primitive with comment" $ do
assertSchemaAtRenders
(pure "name")
( object
[ "$comment" .= t "The person's name"
, "type" .= t "string"
]
)
[ ".It Cm name : Ar string"
, "The person's name"
]
it "array of primitive" $ do
assertSchemaRenders
( object
[ "type" .= t "array"
, "items" .= object ["type" .= t "boolean"]
]
)
[".It : Ar boolean Ns []"]
it "array of any-of" $ do
assertSchemaRenders
( object
[ "type" .= t "array"
, "items"
.= object
[ "anyOf"
.= [ object ["type" .= t "string"]
, object ["type" .= t "boolean"]
]
]
]
)
[".It : ( Ar string Ns | Ns Ar boolean ) Ns []"]
it "any-of with array" $ do
assertSchemaRenders
( object
[ "anyOf"
.= [ object ["type" .= t "string"]
, object
[ "type" .= t "array"
, "items" .= object ["type" .= t "boolean"]
]
]
]
)
[".It : Ar string Ns | Ns Ar boolean Ns []"]
it "log-level example" $ do
assertSchemaAtRenders
("log" :| ["level"])
( object
[ "anyOf"
.= [ object ["const" .= t "info"]
, object ["const" .= t "warn"]
, object ["const" .= t "error"]
]
]
)
[".It Cm log.level : Ar info Ns | Ns Ar warn Ns | Ns Ar error"]
context "objects" $ do
it "special case, any" $ do
assertSchemaRenders
(object ["type" .= t "object"])
[".It : Ar any"]
it "one-level" $ do
assertSchemaRenders
( object
[ "type" .= t "object"
, "properties"
.= object
[ "foo" .= object ["type" .= t "string"]
, "bar" .= object ["type" .= t "boolean"]
, "baz" .= object ["$ref" .= t "#/$defs/custom"]
]
]
)
[ ".It Cm bar : Ar boolean"
, ".It Cm baz : Ar custom"
, ".It Cm foo : Ar string"
]
it "multi-level" $ do
assertSchemaRenders
( object
[ "type" .= t "object"
, "properties"
.= object
[ "foo"
.= object
[ "type" .= t "object"
, "properties"
.= object
[ "bar"
.= object
[ "type" .= t "object"
, "properties"
.= object
[ "baz"
.= object
[ "type" .= t "string"
]
]
]
]
]
]
]
)
[ ".It Cm foo : Ar object"
, ".It Cm foo.bar : Ar object"
, ".It Cm foo.bar.baz : Ar string"
]
it "list of object at key" $ do
assertSchemaRenders
( object
[ "type" .= t "array"
, "items"
.= object
[ "type" .= t "object"
, "properties"
.= object
[ "name"
.= object
[ "type" .= t "string"
]
, "admin"
.= object
[ "$comment" .= t "Admin?"
, "type" .= t "boolean"
]
]
]
]
)
[ ".It Cm [].admin : Ar boolean"
, "Admin?"
, ".It Cm [].name : Ar string"
]
it "list of object at key" $ do
assertSchemaAtRenders
(pure "people")
( object
[ "type" .= t "array"
, "items"
.= object
[ "type" .= t "object"
, "properties"
.= object
[ "name"
.= object
[ "type" .= t "string"
]
, "admin"
.= object
[ "$comment" .= t "Admin?"
, "type" .= t "boolean"
]
]
]
]
)
[ ".It Cm people : Ar object Ns []"
, ".It Cm people[].admin : Ar boolean"
, "Admin?"
, ".It Cm people[].name : Ar string"
]
assertSchemaRenders :: HasCallStack => Value -> [Text] -> Expectation
assertSchemaRenders bs x = do
js <- case fromJSON @JSONSchema bs of
Error err -> do
expectationFailure err
error "unreachable"
Success js -> pure js
prettyDescribeds (getConfigs Nothing js) `shouldRender` x
assertSchemaAtRenders
:: HasCallStack => NonEmpty String -> Value -> [Text] -> Expectation
assertSchemaAtRenders keys bs x = do
js <- case fromJSON @JSONSchema bs of
Error err -> do
expectationFailure err
error "unreachable"
Success js -> pure js
prettyDescribeds (getConfigs (Just keys) js) `shouldRender` x