jsonschema 0.2.0.1 → 0.3.0.0

raw patch · 9 files changed

+2323/−1729 lines, 9 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +16/−0
• README.md +41/−5
• jsonschema.cabal +56/−39
• src/Data/JSON/JSONSchema.hs +53/−39
• src/Data/JSON/Schema.hs +242/−0
• src/Data/JSON/ToJSONSchema.hs +404/−375
• src/JSONSchema/Validation.hs +803/−786
• test/JSONSchema/Spec.hs +704/−481
• test/Main.hs +4/−4

@@ -1,5 +1,21 @@ # Changelog +## 0.3.0.0+- Add value-directed schema construction: a structured `Schema` type (with `Field`,+  `AdditionalProperties`, and `SchemaDocument`) plus `schemaToValue` /+  `schemaDocumentToValue` renderers, re-exported from `Data.JSON.JSONSchema`. Build a+  schema from runtime values when your "types" are data rather than Haskell types.+  The `SRaw` constructor is an escape hatch for embedding an arbitrary schema `Value`+  (any keyword outside the structured subset) at any node.+- Expose the detailed-error validation API through `Data.JSON.JSONSchema`:+  `validate`, `validateWithErrors`, and `ValidationError(..)` are now re-exported+  alongside `validateJSONSchema` (fixes the README's broken `JSONSchema.Validation`+  import; resolves #1).+- Fix derived schemas for non-record products (tuples): emit `minItems`/`maxItems`+  to pin the exact array length. Previously only `items: false` was emitted, which+  caps the upper bound but wrongly accepted arrays shorter than the constructor's+  arity. This changes the generated schema for such types (hence the major bump).+ ## 0.2.0.1 - Widen dependency bounds to support GHC 9.12.2. 

@@ -1,5 +1,7 @@ # jsonschema +[![Hackage](https://img.shields.io/hackage/v/jsonschema.svg)](https://hackage.haskell.org/package/jsonschema)+ Haskell library for deriving and validating JSON Schema (2020-12).  This library provides:@@ -15,7 +17,7 @@ ## Features  - Derive schemas with the `ToJSONSchema` type class; generic default handles most ADTs.-- Records become JSON objects with named properties, emit `"required"` for every field, and forbid extras via `additionalProperties: false`. Non-record products become arrays with `prefixItems` and `items: false`.+- Records become JSON objects with named properties, emit `"required"` for every field, and forbid extras via `additionalProperties: false`. Non-record products become fixed-length arrays with `prefixItems`, `items: false`, and `minItems`/`maxItems` pinning the exact length. - Sum types are modeled with discriminator tags:   - Record constructors: object with a required `tag` (constructor name) and the record fields.   - Non-record constructors: object `{ tag, contents }`, both required, where `contents` carries the constructor’s payload (array/object).@@ -39,8 +41,7 @@ import Data.Aeson (ToJSON, Value, object, (.=)) import Data.Proxy (Proxy(..)) import Data.Text (Text)-import Data.JSON.JSONSchema      -- ToJSONSchema(..), Proxy(..), validateJSONSchema-import JSONSchema.Validation     -- validate / validateWithErrors (optional)+import Data.JSON.JSONSchema      -- ToJSONSchema(..), Proxy(..), validateJSONSchema, validate, validateWithErrors, ValidationError(..) ```  ### 1) Derive a schema for your type@@ -111,7 +112,7 @@ Or collect all validation errors:  ```haskell-import JSONSchema.Validation (validate, validateWithErrors, ValidationError(..))+import Data.JSON.JSONSchema (validate, validateWithErrors, ValidationError(..))  case validate personSchema (toJSON (Person "Alice" 30)) of   Right ()   -> putStrLn "OK"@@ -130,7 +131,42 @@ ```  -### 3) Custom schemas for special types+### 3) Value-directed construction++When your "types" are runtime *values* rather than Haskell types — e.g. an+interpreter whose type AST is a single datatype — derivation via `ToJSONSchema`+does not apply. Instead, fold your value into a `Schema` and render it; the library+owns the JSON encoding:++```haskell+import Data.JSON.JSONSchema  -- Schema(..), Field(..), AdditionalProperties(..), SchemaDocument(..), schemaToValue, schemaDocumentToValue++userDoc :: SchemaDocument+userDoc = SchemaDocument+  { schemaDefs = [("Code", SString (Just "^[a-z]+$"))]   -- a named $def+  , schemaRoot = SObject+      [ Field "code"  True  (SRef "Code")                -- required, references the $def+      , Field "count" False SInteger                     -- optional+      ]+      APForbidden                                        -- additionalProperties: false+  }++userSchema :: Value+userSchema = schemaDocumentToValue userDoc++ok  = validateJSONSchema userSchema (object ["code" .= ("abc" :: Text), "count" .= (3 :: Int)])  -- True+bad = validateJSONSchema userSchema (object ["code" .= ("ABC" :: Text)])                         -- False (off-pattern)+```++A homogeneous map/dictionary is `SObject [] (APSchema valueSchema)`+(`additionalProperties: <schema>`). The `pattern` field is matched with TDFA+regexes (POSIX ERE), not the full ECMA-262 dialect, so keep patterns simple.++`Schema` covers the data-shape subset; for any keyword outside it (e.g.+`minLength`, numeric bounds, `title`), use the `SRaw` escape hatch to embed an+arbitrary schema `Value` at any node — e.g. `Field "name" True (SRaw (object ["type" .= ("string" :: Text), "minLength" .= (3 :: Int)]))`.++### 4) Custom schemas for special types  Provide an explicit instance when you need a specific schema shape: 

@@ -1,12 +1,14 @@-cabal-version:      2.2-name:               jsonschema-version:            0.2.0.1-license:            MPL-2.0-license-file:       LICENSE-author:             DPella AB-maintainer:         matti@dpella.io,-                    lobo@dpella.io-synopsis:           JSON Schema derivation and validation+cabal-version: 2.2+name: jsonschema+version: 0.3.0.0+license: MPL-2.0+license-file: LICENSE+author: DPella AB+maintainer:+  matti@dpella.io,+  lobo@dpella.io++synopsis: JSON Schema derivation and validation description:   Provides the `ToJSONSchema` type class and validation helpers for generating JSON   Schema 2020-12 documents from Haskell types and validating JSON values at runtime.@@ -14,58 +16,73 @@   sum-tag encoding, and refined handling of arrays and enumerations. Validation implements   the core and applicator vocabularies, including `$defs` and local `$ref` resolution,   pragmatic support for `unevaluated*` keywords, and detailed error traces.-extra-doc-files:    CHANGELOG.md, README.md-homepage:          https://github.com/DPella/jsonschema-bug-reports:       https://github.com/DPella/jsonschema/issues-category:          Data, JSON-tested-with:       GHC == 9.6, GHC == 9.12 +extra-doc-files:+  CHANGELOG.md+  README.md++homepage: https://github.com/DPella/jsonschema+bug-reports: https://github.com/DPella/jsonschema/issues+category: Data, JSON+tested-with:+  ghc ==9.6+  ghc ==9.12+ library   default-language:     Haskell2010+   default-extensions:-      DataKinds-    , FlexibleInstances-    , GADTs-    , GeneralizedNewtypeDeriving-    , ImportQualifiedPost-    , LambdaCase-    , OverloadedStrings-    , PolyKinds-    , RankNTypes-    , TypeApplications+    DataKinds+    FlexibleInstances+    GADTs+    GeneralizedNewtypeDeriving+    ImportQualifiedPost+    LambdaCase+    OverloadedStrings+    PolyKinds+    RankNTypes+    TypeApplications+   hs-source-dirs:     src+   exposed-modules:     Data.JSON.JSONSchema+   other-modules:+    Data.JSON.Schema     Data.JSON.ToJSONSchema     JSONSchema.Validation-  build-depends:-      base >=4.18 && <4.22-    , text >= 2.0 && <2.2-    , aeson >= 2.2 && <2.3-    , containers >= 0.6.7 && <0.9-    , vector >=0.13 && < 0.14-    , scientific >= 0.3.8 && <0.4-    , regex-tdfa >= 1.3.2 && <1.4 +  build-depends:+    aeson >=2.2 && <2.3,+    base >=4.18 && <4.22,+    containers >=0.6.7 && <0.9,+    regex-tdfa >=1.3.2 && <1.4,+    scientific >=0.3.8 && <0.4,+    text >=2.0 && <2.2,+    vector >=0.13 && <0.14,  test-suite test-jsonschema   type: exitcode-stdio-1.0   default-language:     Haskell2010+   hs-source-dirs:     test+   main-is:     Main.hs+   other-modules:     JSONSchema.Spec+   build-depends:-      base >=4.18 && <4.22-    , jsonschema-    , aeson-    , text-    , vector-    , tasty-    , tasty-hunit+    aeson,+    base >=4.18 && <4.22,+    jsonschema,+    tasty,+    tasty-hunit,+    text,+    vector,

@@ -1,44 +1,58 @@--- |--- Module:      Data.JSON.JSONSchema--- Copyright:   (c) DPella AB 2025--- License:     LicenseRef-AllRightsReserved--- Maintainer:  <matti@dpella.io>, <lobo@dpella.io>------ JSON Schema generation for Haskell types.------ This module provides a type class and generic implementation for--- automatically deriving JSON Schema descriptions from Haskell data types.--- The generated schemas follow the JSON Schema 2020-12 specification.------ = Usage------ Define instances using the default generic implementation:------ @--- data Person = Person---   { name :: Text---   , age :: Int---   } deriving (Generic)------ instance ToJSONSchema Person--- @------ Or provide custom instances for more control:------ @--- instance ToJSONSchema UUID where---   toJSONSchema _ = object---     [ "type" .= ("string" :: Text)---     , "minLength" .= 36---     , "maxLength" .= 36---     ]--- @+{- |+Module:      Data.JSON.JSONSchema+Copyright:   (c) DPella AB 2025+License:     LicenseRef-AllRightsReserved+Maintainer:  <matti@dpella.io>, <lobo@dpella.io>++JSON Schema generation for Haskell types.++This module provides a type class and generic implementation for+automatically deriving JSON Schema descriptions from Haskell data types.+The generated schemas follow the JSON Schema 2020-12 specification.++= Usage++Define instances using the default generic implementation:++@+data Person = Person+  { name :: Text+  , age :: Int+  } deriving (Generic)++instance ToJSONSchema Person+@++Or provide custom instances for more control:++@+instance ToJSONSchema UUID where+  toJSONSchema _ = object+    [ "type" .= ("string" :: Text)+    , "minLength" .= 36+    , "maxLength" .= 36+    ]+@+-} module Data.JSON.JSONSchema (-  ToJSONSchema (..),-  Proxy (..),-  validateJSONSchema,+    ToJSONSchema (..),+    Proxy (..),++    -- * Validation+    validateJSONSchema,+    validate,+    validateWithErrors,+    ValidationError (..),++    -- * Value-directed construction+    Schema (..),+    Field (..),+    AdditionalProperties (..),+    SchemaDocument (..),+    schemaToValue,+    schemaDocumentToValue, ) where -import Data.Proxy+import Data.JSON.Schema import Data.JSON.ToJSONSchema import JSONSchema.Validation

@@ -0,0 +1,242 @@+{- |+Module:      Data.JSON.Schema+Copyright:   (c) DPella AB 2025+License:     LicenseRef-AllRightsReserved+Maintainer:  <matti@dpella.io>, <lobo@dpella.io>++Value-directed JSON Schema construction.++A structured, value-level description of the data-shape subset of JSON Schema+2020-12, plus pure renderers to an Aeson 'Value'. This is the value-directed+complement to the type-directed 'Data.JSON.ToJSONSchema.ToJSONSchema': rather than+reflecting on a Haskell /type/, you build a 'Schema' from runtime data (e.g. an+interpreter folding over its own type AST) and let this module own the JSON+encoding.++The vocabulary is exactly the data-shape subset the generic derivation emits and+the bundled validator accepts (@properties@/@required@/@additionalProperties@,+@prefixItems@/@items@, @anyOf@/@allOf@, @$ref@/@$defs@, @pattern@, @uniqueItems@).+Validation-only keywords (@if@/@then@/@else@, @dependentSchemas@,+@patternProperties@, @not@, …) are intentionally absent: they are for validating+arbitrary schemas, not for generating a data shape.++This is deliberately narrower than the type-directed path, and that gap is by+design rather than an oversight: 'Schema' is the ergonomic DSL for the common+data-shape case, not a typed mirror of the whole specification. When you need a+keyword outside this subset (e.g. @minLength@, numeric bounds, @title@), embed it+with 'SRaw', which renders an arbitrary schema 'Value' verbatim and composes+anywhere a 'Schema' is expected (an object field, an array element, an @anyOf@+branch). The bundled validator accepts arbitrary schemas, so the embedded 'Value'+validates like any other.++= Usage++@+doc :: t'SchemaDocument'+doc = v'SchemaDocument'+  { 'schemaDefs' = [(\"Code\", 'SString' (Just \"^[a-z]+$\"))]+  , 'schemaRoot' =+      'SObject'+        [ v'Field' \"code\" True ('SRef' \"Code\")+        , v'Field' \"count\" False 'SInteger'+        ]+        'APForbidden'+  }++schema :: Value+schema = 'schemaDocumentToValue' doc+@+-}+module Data.JSON.Schema (+    -- * Schema description+    Schema (..),+    Field (..),+    AdditionalProperties (..),++    -- * Documents+    SchemaDocument (..),++    -- * Rendering+    schemaToValue,+    schemaDocumentToValue,+) where++import Data.Aeson+import Data.Aeson.Key qualified as K+import Data.Aeson.KeyMap qualified as KM+import Data.Text (Text)+import Data.Text qualified as T++{- | A value-level description of the data-shape subset of JSON Schema 2020-12 —+the value-directed complement to the type-directed+'Data.JSON.ToJSONSchema.ToJSONSchema'. Build a 'Schema' from runtime data, then+render it with 'schemaToValue'.+-}+data Schema+    = -- | @{"type":"null"}@+      SNull+    | -- | @{"type":"boolean"}@+      SBoolean+    | -- | @{"type":"integer"}@+      SInteger+    | -- | @{"type":"number"}@+      SNumber+    | -- | @{"type":"string"}@, with a @pattern@ when 'Just'.+      SString (Maybe Text)+    | -- | @{"const": v}@+      SConst Value+    | -- | @{"enum": [..]}@+      SEnum [Value]+    | -- | @{"type":"array","items": s}@+      SArray Schema+    | -- | Array with @uniqueItems: true@ (a set).+      SArrayUnique Schema+    | -- | Fixed-length tuple: @prefixItems@ + @items:false@ + @minItems@/@maxItems@.+      STuple [Schema]+    | {- | Object: each t'Field' carries its own requiredness, plus how additional+      properties are treated.+      -}+      SObject [Field] AdditionalProperties+    | -- | @{"anyOf": [s, {"type":"null"}]}@+      SNullable Schema+    | -- | @{"anyOf": [..]}@+      SAnyOf [Schema]+    | -- | @{"allOf": [..]}@+      SAllOf [Schema]+    | -- | @{"$ref": "#/$defs/<name>"}@ (the name is JSON-Pointer-escaped).+      SRef Text+    | -- | @{}@ (matches anything).+      SAny+    | {- | Escape hatch: render an arbitrary schema 'Value' verbatim, so a node+      outside this subset (e.g. a string with @minLength@, a number with+      @multipleOf@) can still be embedded inside an otherwise structured+      'Schema'. Unchecked — the 'Value' is emitted as-is.+      -}+      SRaw Value+    deriving (Eq, Show)++{- | A single property of an 'SObject'.++Pairing requiredness with the property's schema makes a "required but undeclared"+property unrepresentable — a contradiction (@required@ together with+@additionalProperties:false@) the validator would otherwise reject.++Duplicate 'fieldName's within one 'SObject' are caller error: they collapse to a+single JSON property (last wins).+-}+data Field = Field+    { fieldName :: Text+    -- ^ The property key.+    , fieldRequired :: Bool+    -- ^ Whether the property must be present.+    , fieldSchema :: Schema+    -- ^ The schema the property's value must satisfy.+    }+    deriving (Eq, Show)++-- | How an 'SObject' treats properties not declared in its t'Field's.+data AdditionalProperties+    = -- | @{"additionalProperties": false}@+      APForbidden+    | -- | @{"additionalProperties": true}@+      APAllowed+    | -- | @{"additionalProperties": s}@ — homogeneous maps/dictionaries.+      APSchema Schema+    deriving (Eq, Show)++{- | A self-contained schema document: a root schema plus local @$defs@ for named+subschemas (so every 'SRef' resolves within the document), tagged with the 2020-12+dialect.+-}+data SchemaDocument = SchemaDocument+    { schemaDefs :: [(Text, Schema)]+    -- ^ Named subschemas, exposed under @$defs@ for 'SRef' to resolve against.+    , schemaRoot :: Schema+    -- ^ The document's root schema.+    }+    deriving (Eq, Show)++-- | Render a 'Schema' to its Aeson 'Value'. A total, pure fold.+schemaToValue :: Schema -> Value+schemaToValue = \case+    SNull -> typed "null"+    SBoolean -> typed "boolean"+    SInteger -> typed "integer"+    SNumber -> typed "number"+    SString Nothing -> typed "string"+    SString (Just p) -> object ["type" .= ("string" :: Text), "pattern" .= p]+    SConst v -> object ["const" .= v]+    SEnum vs -> object ["enum" .= vs]+    SArray s -> object ["type" .= ("array" :: Text), "items" .= schemaToValue s]+    SArrayUnique s ->+        object+            [ "type" .= ("array" :: Text)+            , "items" .= schemaToValue s+            , "uniqueItems" .= True+            ]+    STuple ss ->+        object+            [ "type" .= ("array" :: Text)+            , "prefixItems" .= map schemaToValue ss+            , "items" .= False+            , "minItems" .= length ss+            , "maxItems" .= length ss+            ]+    SObject fields ap -> objectToValue fields ap+    SNullable s -> object ["anyOf" .= [schemaToValue s, typed "null"]]+    SAnyOf ss -> object ["anyOf" .= map schemaToValue ss]+    SAllOf ss -> object ["allOf" .= map schemaToValue ss]+    SRef name -> object ["$ref" .= ("#/$defs/" <> escapePointer name)]+    SAny -> object []+    SRaw v -> v+  where+    typed t = object ["type" .= (t :: Text)]++-- | Render an 'SObject', omitting @required@ when no field is required.+objectToValue :: [Field] -> AdditionalProperties -> Value+objectToValue fields ap =+    object $+        [ "type" .= ("object" :: Text)+        , "properties" .= object [K.fromText (fieldName f) .= schemaToValue (fieldSchema f) | f <- fields]+        , "additionalProperties" .= additionalPropertiesToValue ap+        ]+            ++ requiredPairs+  where+    requiredNames = [fieldName f | f <- fields, fieldRequired f]+    requiredPairs+        | null requiredNames = []+        | otherwise = ["required" .= requiredNames]++-- | Render the @additionalProperties@ value.+additionalPropertiesToValue :: AdditionalProperties -> Value+additionalPropertiesToValue = \case+    APForbidden -> Bool False+    APAllowed -> Bool True+    APSchema s -> schemaToValue s++{- | Escape a name for use as a JSON Pointer token (RFC 6901): @~@ becomes @~0@,+then @/@ becomes @~1@. Order matters — escaping @~@ first keeps a literal @/@ from+producing a spurious @~01@.+-}+escapePointer :: Text -> Text+escapePointer = T.replace "/" "~1" . T.replace "~" "~0"++{- | Render a t'SchemaDocument' to its Aeson 'Value': the root schema inline, with+a @$schema@ dialect header and (when non-empty) a sibling @$defs@ block.++The document owns @$schema@/@$defs@: should the root be an 'SRaw' object that also+carries those keys, the document's win. A non-object root — only reachable via+'SRaw' (e.g. a boolean schema) — is wrapped under @allOf@ so the header is still+emitted rather than silently dropped.+-}+schemaDocumentToValue :: SchemaDocument -> Value+schemaDocumentToValue (SchemaDocument defs root) =+    case schemaToValue root of+        Object rootObj -> Object (header `KM.union` rootObj)+        other -> Object (KM.insert "allOf" (toJSON [other]) header)+  where+    header = KM.fromList (("$schema", String dialect) : defsPair)+    dialect = "https://json-schema.org/draft/2020-12/schema"+    defsPair+        | null defs = []+        | otherwise = [("$defs", object [K.fromText n .= schemaToValue s | (n, s) <- defs])]

@@ -4,44 +4,45 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} --- |--- Module:      Data.JSON.ToJSONSchema--- Copyright:   (c) DPella AB 2025--- License:     LicenseRef-AllRightsReserved--- Maintainer:  <matti@dpella.io>, <lobo@dpella.io>------ Core machinery for deriving JSON Schema definitions from Haskell types.------ This module provides a type class and generic implementation for--- automatically deriving JSON Schema descriptions from Haskell data types.--- The generated schemas follow the JSON Schema 2020-12 specification.------ = Usage------ Define instances using the default generic implementation:------ @--- data Person = Person---   { name :: Text---   , age :: Int---   } deriving (Generic)------ instance ToJSONSchema Person--- @------ Or provide custom instances for more control:------ @--- instance ToJSONSchema UUID where---   toJSONSchema _ = object---     [ "type" .= ("string" :: Text)---     , "minLength" .= 36---     , "maxLength" .= 36---     ]--- @+{- |+Module:      Data.JSON.ToJSONSchema+Copyright:   (c) DPella AB 2025+License:     LicenseRef-AllRightsReserved+Maintainer:  <matti@dpella.io>, <lobo@dpella.io>++Core machinery for deriving JSON Schema definitions from Haskell types.++This module provides a type class and generic implementation for+automatically deriving JSON Schema descriptions from Haskell data types.+The generated schemas follow the JSON Schema 2020-12 specification.++= Usage++Define instances using the default generic implementation:++@+data Person = Person+  { name :: Text+  , age :: Int+  } deriving (Generic)++instance ToJSONSchema Person+@++Or provide custom instances for more control:++@+instance ToJSONSchema UUID where+  toJSONSchema _ = object+    [ "type" .= ("string" :: Text)+    , "minLength" .= 36+    , "maxLength" .= 36+    ]+@+-} module Data.JSON.ToJSONSchema (-  ToJSONSchema (..),-  Proxy (..),+    ToJSONSchema (..),+    Proxy (..), ) where  import Data.Aeson@@ -56,397 +57,425 @@ import GHC.Generics import GHC.TypeLits --- | Type class for converting Haskell types to JSON Schema.------ The class provides a default implementation using GHC generics,--- which works for most algebraic data types. Custom instances can--- be defined for types requiring special schema representations.+{- | Type class for converting Haskell types to JSON Schema.++The class provides a default implementation using GHC generics,+which works for most algebraic data types. Custom instances can+be defined for types requiring special schema representations.+-} class ToJSONSchema a where-  -- | Generate a JSON Schema for the given type.-  ---  -- The Proxy argument carries the type information without-  -- requiring an actual value of that type.-  ---  -- >>> toJSONSchema (Proxy :: Proxy Bool)-  -- {"type": "boolean"}-  toJSONSchema :: Proxy a -> Value-  default toJSONSchema-    :: ( Generic a-       , GToJSONSchema (Rep a)-       , Typeable a-       )-    => Proxy a-    -> Value-  -- We start with no root name; the D1 instance will set the root name-  -- and wrap the result with $defs and a top-level $ref. This allows-  -- recursive types to refer to themselves using $ref without infinite recursion.-  toJSONSchema _ = gToJSONSchema @(Rep a) False Nothing (Proxy :: Proxy (Rep a a))+    {- | Generate a JSON Schema for the given type. +    The Proxy argument carries the type information without+    requiring an actual value of that type.++    >>> toJSONSchema (Proxy :: Proxy Bool)+    {"type": "boolean"}+    -}+    toJSONSchema :: Proxy a -> Value+    default toJSONSchema ::+        ( Generic a+        , GToJSONSchema (Rep a)+        , Typeable a+        ) =>+        Proxy a ->+        Value+    -- We start with no root name; the D1 instance will set the root name+    -- and wrap the result with $defs and a top-level $ref. This allows+    -- recursive types to refer to themselves using $ref without infinite recursion.+    toJSONSchema _ = gToJSONSchema @(Rep a) False Nothing (Proxy :: Proxy (Rep a a))+ -- | String instance with overlapping to handle String as a special case, and not as [Char] instance {-# OVERLAPPING #-} ToJSONSchema String where-  toJSONSchema _ = object ["type" .= ("string" :: Text)]+    toJSONSchema _ = object ["type" .= ("string" :: Text)]  -- | Text instance. instance ToJSONSchema Text where-  toJSONSchema _ = object ["type" .= ("string" :: Text)]+    toJSONSchema _ = object ["type" .= ("string" :: Text)]  -- | Boolean schema instance. instance ToJSONSchema Bool where-  toJSONSchema _ = object ["type" .= ("boolean" :: Text)]+    toJSONSchema _ = object ["type" .= ("boolean" :: Text)]  -- | Machine integer schema instance. instance ToJSONSchema Int where-  toJSONSchema _ = object ["type" .= ("integer" :: Text)]+    toJSONSchema _ = object ["type" .= ("integer" :: Text)]  -- | Arbitrary precision integer schema instance. instance ToJSONSchema Integer where-  toJSONSchema _ = object ["type" .= ("integer" :: Text)]+    toJSONSchema _ = object ["type" .= ("integer" :: Text)]  -- | Single precision floating point schema instance. instance ToJSONSchema Float where-  toJSONSchema _ = object ["type" .= ("number" :: Text)]+    toJSONSchema _ = object ["type" .= ("number" :: Text)]  -- | Double precision floating point schema instance. instance ToJSONSchema Double where-  toJSONSchema _ = object ["type" .= ("number" :: Text)]+    toJSONSchema _ = object ["type" .= ("number" :: Text)]  -- | List schema instance for homogeneous arrays. instance (ToJSONSchema a) => ToJSONSchema [a] where-  toJSONSchema _ =-    object-      [ "type" .= ("array" :: Text)-      , "items" .= toJSONSchema (Proxy :: Proxy a)-      ]+    toJSONSchema _ =+        object+            [ "type" .= ("array" :: Text)+            , "items" .= toJSONSchema (Proxy :: Proxy a)+            ] --- | Either schema instance for tagged unions.------ Encodes as Aeson's default representation with Left/Right tags:--- @--- Left x  -> {\"Left\": x}--- Right y -> {\"Right\": y}--- @+{- | Either schema instance for tagged unions.++Encodes as Aeson's default representation with Left/Right tags:+@+Left x  -> {\"Left\": x}+Right y -> {\"Right\": y}+@+-} instance (ToJSONSchema a, ToJSONSchema b) => ToJSONSchema (Either a b) where-  toJSONSchema _ =-    object-      [ "anyOf"-          .= [ object-                [ "type" .= ("object" :: Text)-                , "properties"-                    .= object-                      [ "Left" .= toJSONSchema (Proxy :: Proxy a)-                      ]-                , "required" .= ([ "Left" ] :: [Text])-                , "additionalProperties" .= False-                ]-             , object-                [ "type" .= ("object" :: Text)-                , "properties"-                    .= object-                      [ "Right" .= toJSONSchema (Proxy :: Proxy b)-                      ]-                , "required" .= ([ "Right" ] :: [Text])-                , "additionalProperties" .= False-                ]-             ]-      ]+    toJSONSchema _ =+        object+            [ "anyOf"+                .= [ object+                        [ "type" .= ("object" :: Text)+                        , "properties"+                            .= object+                                [ "Left" .= toJSONSchema (Proxy :: Proxy a)+                                ]+                        , "required" .= (["Left"] :: [Text])+                        , "additionalProperties" .= False+                        ]+                   , object+                        [ "type" .= ("object" :: Text)+                        , "properties"+                            .= object+                                [ "Right" .= toJSONSchema (Proxy :: Proxy b)+                                ]+                        , "required" .= (["Right"] :: [Text])+                        , "additionalProperties" .= False+                        ]+                   ]+            ] --- | Maybe schema instance allowing null values.------ A Maybe value can be either the wrapped type or null:--- @--- Just x  -> x--- Nothing -> null--- @+{- | Maybe schema instance allowing null values.++A Maybe value can be either the wrapped type or null:+@+Just x  -> x+Nothing -> null+@+-} instance (ToJSONSchema a) => ToJSONSchema (Maybe a) where-  toJSONSchema _ =-    object-      [ "anyOf"-          .= [ toJSONSchema (Proxy :: Proxy a)-             , object ["type" .= ("null" :: Text)]-             ]-      ]+    toJSONSchema _ =+        object+            [ "anyOf"+                .= [ toJSONSchema (Proxy :: Proxy a)+                   , object ["type" .= ("null" :: Text)]+                   ]+            ] --- | Generic type class for deriving JSON schemas.------ This class handles the generic representation of data types--- and converts them to appropriate JSON Schema structures.------ The Bool parameter indicates whether we're inside a sum type--- that needs tagging for proper deserialization.+{- | Generic type class for deriving JSON schemas.++This class handles the generic representation of data types+and converts them to appropriate JSON Schema structures.++The Bool parameter indicates whether we're inside a sum type+that needs tagging for proper deserialization.+-} class GToJSONSchema f where-  -- | Generate schema from generic representation.-  ---  -- The Bool parameter controls tagged union representation:-  -- * True: Add "tag" field for sum type constructors-  -- * False: No tagging needed-  -- The Maybe Text carries the root datatype name, if any. When present,-  -- occurrences of the same datatype in fields will be rendered as-  -- {"$ref": "#/$defs/<root>"} to avoid infinite recursion.-  gToJSONSchema :: (ToJSONSchema a, Typeable a) => Bool -> Maybe Text -> Proxy (f a) -> Value+    {- | Generate schema from generic representation. --- | Instance for empty types (no constructors).------ Empty types are represented as JSON null since they--- can never have a value.+    The Bool parameter controls tagged union representation:+    * True: Add "tag" field for sum type constructors+    * False: No tagging needed+    The Maybe Text carries the root datatype name, if any. When present,+    occurrences of the same datatype in fields will be rendered as+    {"$ref": "#/$defs/<root>"} to avoid infinite recursion.+    -}+    gToJSONSchema :: (ToJSONSchema a, Typeable a) => Bool -> Maybe Text -> Proxy (f a) -> Value++{- | Instance for empty types (no constructors).++Empty types are represented as JSON null since they+can never have a value.+-} instance GToJSONSchema V1 where-  gToJSONSchema _ _ _ = Null+    gToJSONSchema _ _ _ = Null --- | Instance for unit types (constructors with no fields).------ Unit constructors are represented as null when untagged,--- or as objects with just a tag field when tagged.+{- | Instance for unit types (constructors with no fields).++Unit constructors are represented as null when untagged,+or as objects with just a tag field when tagged.+-} instance GToJSONSchema U1 where-  gToJSONSchema :: forall a. (ToJSONSchema a, Typeable a) => Bool -> Maybe Text -> Proxy (U1 a) -> Value-  gToJSONSchema _ _ _ = Null+    gToJSONSchema :: forall a. (ToJSONSchema a, Typeable a) => Bool -> Maybe Text -> Proxy (U1 a) -> Value+    gToJSONSchema _ _ _ = Null --- | Instance for sum types (multiple constructors).------ Sum types are encoded using JSON Schema's "anyOf" keyword,--- allowing the value to match any of the constructor schemas.------ Example:--- @--- data Color = Red | Green | Blue--- -- Generates: {"anyOf": [{...Red schema}, {...Green schema}, {...Blue schema}]}--- @+{- | Instance for sum types (multiple constructors).++Sum types are encoded using JSON Schema's "anyOf" keyword,+allowing the value to match any of the constructor schemas.++Example:+@+data Color = Red | Green | Blue+-- Generates: {"anyOf": [{...Red schema}, {...Green schema}, {...Blue schema}]}+@+-} instance (GToJSONSchema f1, GToJSONSchema f2) => GToJSONSchema (f1 :+: f2) where-  gToJSONSchema :: forall a. (ToJSONSchema a, Typeable a) => Bool -> Maybe Text -> Proxy ((:+:) f1 f2 a) -> Value-  gToJSONSchema _ root_name _ =-    let v1 = flattenKeys "anyOf" $ gToJSONSchema True root_name (Proxy :: Proxy (f1 a))-        v2 = flattenKeys "anyOf" $ gToJSONSchema True root_name (Proxy :: Proxy (f2 a))-    in  case (v1, v2) of-          (Object km1, Object km2)-            | Just (Array vec1) <- km1 KM.!? "anyOf"-            , Just (Array vec2) <- km2 KM.!? "anyOf" ->-                object ["anyOf" .= Array (vec1 <> vec2)]-          (Object km1, Object km2)-            | Just (Array vec) <- km1 KM.!? "anyOf"-            , Nothing <- km2 KM.!? "anyOf" ->-                object ["anyOf" .= Array (vec `V.snoc` v2)]-          (Object _, Object km2)-            | Just (Array vec) <- km2 KM.!? "anyOf" ->-                object ["anyOf" .= Array (v1 `V.cons` vec)]-          (_, _) -> object ["anyOf" .= [v1, v2]]+    gToJSONSchema :: forall a. (ToJSONSchema a, Typeable a) => Bool -> Maybe Text -> Proxy ((:+:) f1 f2 a) -> Value+    gToJSONSchema _ root_name _ =+        let v1 = flattenKeys "anyOf" $ gToJSONSchema True root_name (Proxy :: Proxy (f1 a))+            v2 = flattenKeys "anyOf" $ gToJSONSchema True root_name (Proxy :: Proxy (f2 a))+         in case (v1, v2) of+                (Object km1, Object km2)+                    | Just (Array vec1) <- km1 KM.!? "anyOf"+                    , Just (Array vec2) <- km2 KM.!? "anyOf" ->+                        object ["anyOf" .= Array (vec1 <> vec2)]+                (Object km1, Object km2)+                    | Just (Array vec) <- km1 KM.!? "anyOf"+                    , Nothing <- km2 KM.!? "anyOf" ->+                        object ["anyOf" .= Array (vec `V.snoc` v2)]+                (Object _, Object km2)+                    | Just (Array vec) <- km2 KM.!? "anyOf" ->+                        object ["anyOf" .= Array (v1 `V.cons` vec)]+                (_, _) -> object ["anyOf" .= [v1, v2]] --- | Instance for product types (multiple fields in a constructor).------ Non-record products are encoded as fixed-length arrays where--- each position has a specific type. The "items": false ensures--- no additional array elements are allowed.------ Example:--- @--- data Point = Point Double Double--- -- Generates: {"type": "array", "prefixItems": [{"type": "number"}, {"type": "number"}], "items": false}--- @+{- | Instance for product types (multiple fields in a constructor).++Non-record products are encoded as fixed-length arrays where each position has a+specific type, via "prefixItems" + "items": false. (The enclosing non-record+/constructor/ instance additionally pins the exact length with+"minItems"/"maxItems".)++Example:+@+data Point = Point Double Double+-- This instance emits: {"type": "array", "prefixItems": [{"type": "number"}, {"type": "number"}], "items": false}+@+-} instance (GToJSONSchema f1, GToJSONSchema f2) => GToJSONSchema (f1 :*: f2) where-  gToJSONSchema :: forall a. (ToJSONSchema a, Typeable a) => Bool -> Maybe Text -> Proxy ((:*:) f1 f2 a) -> Value-  gToJSONSchema _ root_name _ =-    object-      [ "type" .= ("array" :: Text)-      , "prefixItems"-          .= [ gToJSONSchema False root_name (Proxy :: Proxy (f1 a))-             , gToJSONSchema False root_name (Proxy :: Proxy (f2 a))-             ]-      , "items" .= False-      ]+    gToJSONSchema :: forall a. (ToJSONSchema a, Typeable a) => Bool -> Maybe Text -> Proxy ((:*:) f1 f2 a) -> Value+    gToJSONSchema _ root_name _ =+        object+            [ "type" .= ("array" :: Text)+            , "prefixItems"+                .= [ gToJSONSchema False root_name (Proxy :: Proxy (f1 a))+                   , gToJSONSchema False root_name (Proxy :: Proxy (f2 a))+                   ]+            , "items" .= False+            ] --- | Helper to flatten nested array structures in schemas.------ When building schemas for nested product types, we may get--- structures like prefixItems: [a, {prefixItems: [b, c]}].--- This function flattens them to prefixItems: [a, b, c] for--- consistency with how Aeson represents such types.+{- | Helper to flatten nested array structures in schemas.++When building schemas for nested product types, we may get+structures like prefixItems: [a, {prefixItems: [b, c]}].+This function flattens them to prefixItems: [a, b, c] for+consistency with how Aeson represents such types.+-} flattenKeys :: Key -> Value -> Value flattenKeys key (Object km)-  | Just (Array vec) <- km KM.!? key-  , length vec == 2-  , vf <- V.head vec-  , Object vlkm <- flattenKeys key (V.last vec)-  , Just (Array vec') <- vlkm KM.!? key =-      Object-        ( KM.singleton-            key-            (Array (V.cons vf vec'))-            `KM.union` km-        )+    | Just (Array vec) <- km KM.!? key+    , length vec == 2+    , vf <- V.head vec+    , Object vlkm <- flattenKeys key (V.last vec)+    , Just (Array vec') <- vlkm KM.!? key =+        Object+            ( KM.singleton+                key+                (Array (V.cons vf vec'))+                `KM.union` km+            ) flattenKeys _ o = o --- | Instance for datatype metadata.--- If this is the root, we output a $defs section with the type name and schema,--- and refer to that in $ref.+{- | Instance for datatype metadata.+If this is the root, we output a $defs section with the type name and schema,+and refer to that in $ref.+-} instance (KnownSymbol dtn, GToJSONSchema f) => GToJSONSchema (D1 (MetaData dtn m p nt) f) where-  gToJSONSchema-    :: forall a. (ToJSONSchema a, Typeable a) => Bool -> Maybe Text -> Proxy (D1 (MetaData dtn m p nt) f a) -> Value-  gToJSONSchema _ root_name _ =-    let dt_name = symbolVal (Proxy :: Proxy dtn)-        this_name = pack dt_name-        body = gToJSONSchema False (Just this_name) (Proxy :: Proxy (f a))-    in  case root_name of-          -- Top-level: wrap with $defs and $ref to support recursion-          Nothing ->-            object-              [ "$defs" .= object [fromString dt_name .= body]-              , "$ref" .= ("#/$defs/" <> this_name)-              ]-          -- Nested: just return the documented body-          Just _ -> body+    gToJSONSchema ::+        forall a. (ToJSONSchema a, Typeable a) => Bool -> Maybe Text -> Proxy (D1 (MetaData dtn m p nt) f a) -> Value+    gToJSONSchema _ root_name _ =+        let dt_name = symbolVal (Proxy :: Proxy dtn)+            this_name = pack dt_name+            body = gToJSONSchema False (Just this_name) (Proxy :: Proxy (f a))+         in case root_name of+                -- Top-level: wrap with $defs and $ref to support recursion+                Nothing ->+                    object+                        [ "$defs" .= object [fromString dt_name .= body]+                        , "$ref" .= ("#/$defs/" <> this_name)+                        ]+                -- Nested: just return the documented body+                Just _ -> body --- | Instance for type constants (actual field types).------ This delegates to the ToJSONSchema instance of the field type,--- allowing custom schemas for specific types.+{- | Instance for type constants (actual field types).++This delegates to the ToJSONSchema instance of the field type,+allowing custom schemas for specific types.+-} instance (ToJSONSchema c, Typeable c) => GToJSONSchema (K1 i c) where-  gToJSONSchema :: forall a. (ToJSONSchema a, Typeable a) => Bool -> Maybe Text -> Proxy (K1 i c a) -> Value-  gToJSONSchema _ root_name _ =-    case root_name of-      -- If we know the root type name and the field type equals the root-      -- type, emit a $ref to the root definition to avoid infinite recursion.-      Just nm ->-        if typeRep (Proxy :: Proxy a) == typeRep (Proxy :: Proxy c)-          then object ["$ref" .= ("#/$defs/" <> nm)]-          else toJSONSchema (Proxy :: Proxy c)-      Nothing -> toJSONSchema (Proxy :: Proxy c)+    gToJSONSchema :: forall a. (ToJSONSchema a, Typeable a) => Bool -> Maybe Text -> Proxy (K1 i c a) -> Value+    gToJSONSchema _ root_name _ =+        case root_name of+            -- If we know the root type name and the field type equals the root+            -- type, emit a $ref to the root definition to avoid infinite recursion.+            Just nm ->+                if typeRep (Proxy :: Proxy a) == typeRep (Proxy :: Proxy c)+                    then object ["$ref" .= ("#/$defs/" <> nm)]+                    else toJSONSchema (Proxy :: Proxy c)+            Nothing -> toJSONSchema (Proxy :: Proxy c) --- | Instance for record constructors.------ Record types are encoded as objects with named properties.--- When in a tagged sum type, adds a "tag" field with the--- constructor name for discrimination.------ Example:--- @--- data Person = Person {name :: Text, age :: Int}--- -- Generates: {--- --   "type": "object",--- --   "properties": {--- --     "name": {"type": "string"},--- --     "age": {"type": "integer"}--- --   },--- --   "additionalProperties": false--- -- }--- @-instance (KnownSymbol name, GToJSONSchema f) => GToJSONSchema (C1 (MetaCons name fixity True) f) where-  gToJSONSchema-    :: forall a. (ToJSONSchema a, Typeable a) => Bool -> Maybe Text -> Proxy (C1 (MetaCons name fixity True) f a) -> Value-  gToJSONSchema tagged root_name _ =-    let props_val = extractProperties $ gToJSONSchema tagged root_name (Proxy :: Proxy (f a))-        props_keys =-          case props_val of-            Object km -> fmap K.toText (KM.keys km)-            _ -> []-        requiredFields =-          (if tagged then ("tag" :) else id) props_keys-        requiredPairs =-          if null requiredFields-            then []-            else ["required" .= requiredFields]-    in  object-          ( [ "type" .= ("object" :: Text)-            , "properties" .= if tagged then addTag props_val else props_val-            , "additionalProperties" .= False-            ]-              ++ requiredPairs-          )-    where-      tag = object ["const" .= cn]-      addTag (Object km) = Object $ KM.singleton (fromString "tag") tag `KM.union` km-      addTag o = o-      xP (Object p) | Just (Object r) <- p KM.!? "properties" = Just r-      xP _ = Nothing-      cn = symbolVal (Proxy :: Proxy name)-      extractProperties :: Value -> Value-      extractProperties o@(Object _)-        | Object km <- flattenKeys "prefixItems" o-        , Just (Array vec) <- km KM.!? "prefixItems"-        , V.all (isJust . xP) vec =-            Object $ V.foldl KM.union KM.empty $ V.mapMaybe xP vec-      extractProperties (Object km) | Just p <- km KM.!? "properties" = p-      extractProperties o = o+{- | Instance for record constructors. --- | Instance for non-record constructors.------ Non-record constructors with multiple fields are encoded as arrays.--- When in a tagged sum type, wraps in an object with "tag" and "contents".------ Examples:--- @--- data Point = Point Double Double--- -- Untagged: {"type": "array", "prefixItems": [...], "items": false}------ data Shape = Circle Double | Rectangle Double Double--- -- Tagged: {--- --   "type": "object",--- --   "properties": {--- --     "tag": {"const": "Circle"},--- --     "contents": {"type": "number"}--- --   }--- -- }--- @-instance (KnownSymbol name, GToJSONSchema f) => GToJSONSchema (C1 (MetaCons name fixity False) f) where-  gToJSONSchema-    :: forall a. (ToJSONSchema a, Typeable a) => Bool -> Maybe Text -> Proxy (C1 (MetaCons name fixity False) f a) -> Value-  gToJSONSchema tagged root_name _ =-    let c_val = flattenKeys "prefixItems" $ gToJSONSchema False root_name (Proxy :: Proxy (f a))-        c_name = symbolVal (Proxy :: Proxy name)-        tag = object ["const" .= c_name]-    in  case c_val of-          o@(Object km) ->-            let obj = case km KM.!? "prefixItems" of-                  Just pfi@(Array _) -> object ["type" .= ("array" :: Text), "prefixItems" .= pfi, "items" .= False]-                  _ -> o-                basePairs =-                  [ "type" .= ("object" :: Text)-                  , "properties" .= object ["tag" .= tag, "contents" .= obj]+Record types are encoded as objects with named properties.+When in a tagged sum type, adds a "tag" field with the+constructor name for discrimination.++Example:+@+data Person = Person {name :: Text, age :: Int}+-- Generates: {+--   "type": "object",+--   "properties": {+--     "name": {"type": "string"},+--     "age": {"type": "integer"}+--   },+--   "additionalProperties": false+-- }+@+-}+instance (KnownSymbol name, GToJSONSchema f) => GToJSONSchema (C1 (MetaCons name fixity True) f) where+    gToJSONSchema ::+        forall a. (ToJSONSchema a, Typeable a) => Bool -> Maybe Text -> Proxy (C1 (MetaCons name fixity True) f a) -> Value+    gToJSONSchema tagged root_name _ =+        let props_val = extractProperties $ gToJSONSchema tagged root_name (Proxy :: Proxy (f a))+            props_keys =+                case props_val of+                    Object km -> fmap K.toText (KM.keys km)+                    _ -> []+            requiredFields =+                (if tagged then ("tag" :) else id) props_keys+            requiredPairs =+                if null requiredFields+                    then []+                    else ["required" .= requiredFields]+         in object+                ( [ "type" .= ("object" :: Text)+                  , "properties" .= if tagged then addTag props_val else props_val                   , "additionalProperties" .= False                   ]-                requiredPairs =-                  ["required" .= (["tag", "contents"] :: [Text])]-            in  if tagged-                  then-                    object (basePairs ++ requiredPairs)-                  else obj-          Null ->-            object-              [ "type" .= ("object" :: Text)-              , "properties" .= object ["tag" .= tag]-              , "additionalProperties" .= False-              , "required" .= ([ "tag" ] :: [Text])-              ]-          x -> x+                    ++ requiredPairs+                )+      where+        tag = object ["const" .= cn]+        addTag (Object km) = Object $ KM.singleton (fromString "tag") tag `KM.union` km+        addTag o = o+        xP (Object p) | Just (Object r) <- p KM.!? "properties" = Just r+        xP _ = Nothing+        cn = symbolVal (Proxy :: Proxy name)+        extractProperties :: Value -> Value+        extractProperties o@(Object _)+            | Object km <- flattenKeys "prefixItems" o+            , Just (Array vec) <- km KM.!? "prefixItems"+            , V.all (isJust . xP) vec =+                Object $ V.foldl KM.union KM.empty $ V.mapMaybe xP vec+        extractProperties (Object km) | Just p <- km KM.!? "properties" = p+        extractProperties o = o --- | Instance for unnamed fields (positional constructor arguments).------ Simply delegates to the field type's schema without wrapping.+{- | Instance for non-record constructors.++Non-record constructors with multiple fields are encoded as arrays.+When in a tagged sum type, wraps in an object with "tag" and "contents".++Examples:+@+data Point = Point Double Double+-- Untagged: {"type": "array", "prefixItems": [...], "items": false, "minItems": 2, "maxItems": 2}++data Shape = Circle Double | Rectangle Double Double+-- Tagged: {+--   "type": "object",+--   "properties": {+--     "tag": {"const": "Circle"},+--     "contents": {"type": "number"}+--   }+-- }+@+-}+instance (KnownSymbol name, GToJSONSchema f) => GToJSONSchema (C1 (MetaCons name fixity False) f) where+    gToJSONSchema ::+        forall a. (ToJSONSchema a, Typeable a) => Bool -> Maybe Text -> Proxy (C1 (MetaCons name fixity False) f a) -> Value+    gToJSONSchema tagged root_name _ =+        let c_val = flattenKeys "prefixItems" $ gToJSONSchema False root_name (Proxy :: Proxy (f a))+            c_name = symbolVal (Proxy :: Proxy name)+            tag = object ["const" .= c_name]+         in case c_val of+                o@(Object km) ->+                    let obj = case km KM.!? "prefixItems" of+                            -- A non-record product is a fixed-length tuple: pin the+                            -- length with minItems/maxItems so a short array is+                            -- rejected ("items": false only caps the upper end).+                            Just pfi@(Array vec) ->+                                object+                                    [ "type" .= ("array" :: Text)+                                    , "prefixItems" .= pfi+                                    , "items" .= False+                                    , "minItems" .= V.length vec+                                    , "maxItems" .= V.length vec+                                    ]+                            _ -> o+                        basePairs =+                            [ "type" .= ("object" :: Text)+                            , "properties" .= object ["tag" .= tag, "contents" .= obj]+                            , "additionalProperties" .= False+                            ]+                        requiredPairs =+                            ["required" .= (["tag", "contents"] :: [Text])]+                     in if tagged+                            then+                                object (basePairs ++ requiredPairs)+                            else obj+                Null ->+                    object+                        [ "type" .= ("object" :: Text)+                        , "properties" .= object ["tag" .= tag]+                        , "additionalProperties" .= False+                        , "required" .= (["tag"] :: [Text])+                        ]+                x -> x++{- | Instance for unnamed fields (positional constructor arguments).++Simply delegates to the field type's schema without wrapping.+-} instance (GToJSONSchema f) => GToJSONSchema (S1 (MetaSel Nothing su ss ds) f) where-  gToJSONSchema-    :: forall a. (ToJSONSchema a, Typeable a) => Bool -> Maybe Text -> Proxy (S1 (MetaSel Nothing su ss ds) f a) -> Value-  gToJSONSchema _ root_name _ = gToJSONSchema False root_name (Proxy :: Proxy (f a))+    gToJSONSchema ::+        forall a. (ToJSONSchema a, Typeable a) => Bool -> Maybe Text -> Proxy (S1 (MetaSel Nothing su ss ds) f a) -> Value+    gToJSONSchema _ root_name _ = gToJSONSchema False root_name (Proxy :: Proxy (f a)) --- | Instance for named record fields.------ Creates an object schema with a single property named after--- the field. These are combined by the record constructor instance.------ Example:--- @--- data Person = Person { name :: Text }--- -- For the 'name' field generates:--- -- {--- --   "type": "object",--- --   "properties": {--- --     "name": {"type": "string"}--- --   }--- -- }--- @+{- | Instance for named record fields.++Creates an object schema with a single property named after+the field. These are combined by the record constructor instance.++Example:+@+data Person = Person { name :: Text }+-- For the @name@ field generates:+-- {+--   "type": "object",+--   "properties": {+--     "name": {"type": "string"}+--   }+-- }+@+-} instance (KnownSymbol name, GToJSONSchema f) => GToJSONSchema (S1 (MetaSel (Just name) su ss ds) f) where-  gToJSONSchema-    :: forall a. (ToJSONSchema a, Typeable a) => Bool -> Maybe Text -> Proxy (S1 (MetaSel (Just name) su ss ds) f a) -> Value-  gToJSONSchema _ root_name _ =-    object-      [ "type" .= ("object" :: Text)-      , "properties"-          .= object-            [ fromString (symbolVal (Proxy :: Proxy name)) .= gToJSONSchema False root_name (Proxy :: Proxy (f a))+    gToJSONSchema ::+        forall a. (ToJSONSchema a, Typeable a) => Bool -> Maybe Text -> Proxy (S1 (MetaSel (Just name) su ss ds) f a) -> Value+    gToJSONSchema _ root_name _ =+        object+            [ "type" .= ("object" :: Text)+            , "properties"+                .= object+                    [ fromString (symbolVal (Proxy :: Proxy name)) .= gToJSONSchema False root_name (Proxy :: Proxy (f a))+                    ]             ]-      ]

@@ -3,789 +3,806 @@  {-# HLINT ignore "Use ++" #-} --- |--- Module:      JSONSchema.Validation--- Copyright:   (c) DPella AB 2025--- License:     LicenseRef-AllRightsReserved--- Maintainer:  <matti@dpella.io>, <lobo@dpella.io>------ JSON Schema validation according to JSON Schema 2020-12.------ This module provides validation functions that check if a JSON value--- conforms to a given JSON Schema. It supports the core 2020-12--- semantics for validation and applicator keywords ("type", "properties", "patternProperties",--- "additionalProperties", "items", "prefixItems", numeric and string--- constraints, combinators, and conditionals). Local $ref resolution to JSON Pointers--- within the same schema document (including paths under "$defs") is supported.--- The "unevaluatedProperties" and "unevaluatedItems" keywords are implemented--- with pragmatic semantics at the current instance location (covering properties/items--- handled by properties/patternProperties/prefixItems/items/contains). The full--- annotation-merging behavior across nested applicators is not implemented.--- The Format-Assertion vocabulary is not implemented; the "format" and "content*"--- keywords are treated as annotations only, per the 2020-12 specification.------ = Usage------ @--- let schema = toJSONSchema (Proxy :: Proxy Person)--- let value = object ["name" .= "Alice", "age" .= 30]--- validateJSONSchema schema value  -- Returns True if valid--- @-module JSONSchema.Validation (-  validateJSONSchema,-  ValidationError (..),-  validate,-  validateWithErrors,-) where--import Data.Aeson-import Data.Aeson.Key qualified as K-import Data.Aeson.KeyMap qualified as KM-import Data.Char (isDigit)-import Data.List (nub)-import Data.Maybe (fromMaybe, isJust, isNothing)-import Data.Ratio (denominator)-import Data.Scientific (Scientific)-import Data.Scientific qualified as Sci-import Data.Text (Text)-import Data.Text qualified as T-import Data.Vector qualified as V-import Text.Regex.TDFA ((=~))-import Text.Regex.TDFA.Text ()---- | Validation error with context about what failed-data ValidationError = ValidationError-  { error_path :: [Text]-  -- ^ Path to the failing value (e.g. ["users", "0", "name"])-  , error_message :: Text-  -- ^ Description of the validation failure-  }-  deriving (Show, Eq)---- | Simple validation that returns True if the value matches the schema-validateJSONSchema :: Value -> Value -> Bool-validateJSONSchema schema value = null $ validateWithErrors schema value---- | Validate with error collection-validate :: Value -> Value -> Either [ValidationError] ()-validate schema value =-  case validateWithErrors schema value of-    [] -> Right ()-    errs -> Left errs---- | Validate and return all errors found for an instance against a schema.--- This walks the instance and applies the validation vocabulary for 2020-12,--- returning every violation discovered (no short-circuit).-validateWithErrors :: Value -> Value -> [ValidationError]-validateWithErrors schema value = validateValue [] schema schema value maxRefDepth---- | Max recursion depth for $ref to avoid infinite loops-maxRefDepth :: Int-maxRefDepth = 256---- | Internal validator with context.------ Parameters:---  - path: JSON Pointer-like path to the current instance location---  - root: the root schema document (for resolving local $ref)---  - schema: the current subschema to apply---  - value: the current instance value---  - fuel: remaining recursion depth for $ref resolution-validateValue :: [Text] -> Value -> Value -> Value -> Int -> [ValidationError]-validateValue path root schema value fuel =-  case schema of-    Bool True -> [] -- true schema always validates-    Bool False -> [ValidationError path "Schema is false (always fails)"]-    Object km ->-      -- \$ref short-circuit: if present, ignore other keywords (per spec)-      case km KM.!? "$ref" of-        Just (String ref_path) ->-          if fuel <= 0-            then [ValidationError path "Exceeded $ref resolution depth"]-            else case resolveRef root ref_path of-              Just ref_schema -> validateValue path root ref_schema value (fuel - 1)-              Nothing -> [ValidationError path ("Unresolved $ref: " <> ref_path)]-        _ -> validateObject path root km value fuel-    _ -> [ValidationError path "Invalid schema: must be a boolean or object"]---- | Apply object schema keywords and dispatch to other validators.------ Covers:---  - type/const/enum---  - Object keywords: properties, patternProperties, additionalProperties,---    propertyNames, required, dependentSchemas, dependentRequired---  - Array keywords present at this location: prefixItems, items (when instance is array)---  - String/Number/Object count constraints---  - Combinators: anyOf, oneOf, allOf, not---  - Conditionals: if/then/else---  - unevaluatedProperties / unevaluatedItems (local, pragmatic semantics)-validateObject :: [Text] -> Value -> KM.KeyMap Value -> Value -> Int -> [ValidationError]-validateObject path root km value fuel =-  concat-    [ validateType path km value-    , validateConst path km value-    , validateEnum path km value-    , validateProperties path root km value fuel-    , validateItems path root km value fuel-    , validatePrefixItems path root km value fuel-    , validateArrayConstraints path root km value fuel-    , validateStringConstraints path km value-    , validateNumberConstraints path km value-    , validateObjectConstraints path km value-    , validateCombinators path root km value fuel-    , validateConditional path root km value fuel-    , validateUnevaluatedProperties path root km value fuel-    , validateUnevaluatedItems path root km value fuel-    ]---- | Validate the "type" keyword. Supports a single string or an array of types.--- Recognized types: null, boolean, string, number, integer, array, object.-validateType :: [Text] -> KM.KeyMap Value -> Value -> [ValidationError]-validateType path km value =-  case km KM.!? "type" of-    Nothing -> []-    Just (String type_str) ->-      [ ValidationError path $ "Expected type " <> type_str <> " but got " <> describeType value-      | not (checkType type_str value)-      ]-    Just (Array types) ->-      let type_strs = [t | String t <- V.toList types]-      in  [ ValidationError path $ "Expected one of types " <> T.intercalate ", " type_strs <> " but got " <> describeType value-          | not (any (`checkType` value) type_strs)-          ]-    Just _ -> [ValidationError path "Invalid 'type' field in schema"]---- | Check whether a JSON value is of the given JSON Schema type.-checkType :: Text -> Value -> Bool-checkType "null" Null = True-checkType "boolean" (Bool _) = True-checkType "string" (String _) = True-checkType "number" (Number _) = True--- Per JSON Schema, "integer" means the instance is a number with an integral value,--- not limited by machine-sized Int bounds.-checkType "integer" (Number n) = Sci.isInteger n-checkType "array" (Array _) = True-checkType "object" (Object _) = True-checkType _ _ = False---- | Derive the schema type name corresponding to a value (e.g., "integer").-describeType :: Value -> Text-describeType Null = "null"-describeType (Bool _) = "boolean"-describeType (String _) = "string"-describeType (Number n)-  | Sci.isInteger n = "integer"-  | otherwise = "number"-describeType (Array _) = "array"-describeType (Object _) = "object"---- | Validate the "const" keyword (instance must be exactly equal to the given value).-validateConst :: [Text] -> KM.KeyMap Value -> Value -> [ValidationError]-validateConst path km value =-  case km KM.!? "const" of-    Nothing -> []-    Just const_val ->-      [ ValidationError path $ "Expected constant value " <> showJSON const_val <> " but got " <> showJSON value-      | value /= const_val-      ]---- | Validate the "enum" keyword (instance must be a member of the given array).-validateEnum :: [Text] -> KM.KeyMap Value -> Value -> [ValidationError]-validateEnum path km value =-  case km KM.!? "enum" of-    Nothing -> []-    Just (Array values) ->-      [ValidationError path $ "Value not in enum: " <> showJSON value | not (value `V.elem` values)]-    Just _ -> [ValidationError path "Invalid 'enum' field in schema"]---- | Validate object-related keywords at this location.------ Implements:---  - properties: validate each defined property if present---  - patternProperties: validate properties whose names match regex patterns---  - additionalProperties: validate and/or forbid properties not matched above---  - propertyNames: validate each property name as a string instance---  - required: ensure listed properties exist---  - dependentSchemas: when a property exists, apply another schema to the whole object---  - dependentRequired: when a property exists, require additional properties-validateProperties :: [Text] -> Value -> KM.KeyMap Value -> Value -> Int -> [ValidationError]-validateProperties path root km value fuel =-  case value of-    Object obj ->-      let props_schema = km KM.!? "properties"-          pattern_props_schema = km KM.!? "patternProperties"-          additional_props_schema = km KM.!? "additionalProperties"-          property_names_schema = km KM.!? "propertyNames"-          required_props = case km KM.!? "required" of-            Just (Array arr) -> [t | String t <- V.toList arr]-            _ -> []--          -- Validate properties defined in 'properties'-          prop_errors = case props_schema of-            Just (Object schema_obj) ->-              concat-                [ case obj KM.!? key of-                  Just prop_value ->-                    validateValue (path <> [K.toText key]) root schema prop_value fuel-                  Nothing -> []-                | (key, schema) <- KM.toList schema_obj-                ]-            _ -> []--          -- Validate properties matching patterns in 'patternProperties'-          pattern_prop_errors = case pattern_props_schema of-            Just (Object patterns) ->-              concat-                [ concat-                  [ if K.toText obj_key =~ K.toText pattern_key-                    then validateValue (path <> [K.toText obj_key]) root pattern_schema obj_value fuel-                    else []-                  | (pattern_key, pattern_schema) <- KM.toList patterns-                  ]-                | (obj_key, obj_value) <- KM.toList obj-                ]-            _ -> []--          -- Determine which properties are handled by properties or patternProperties-          handled_by_props = case props_schema of-            Just (Object schema_obj) -> KM.keys schema_obj-            _ -> []-          handled_by_patterns = case pattern_props_schema of-            Just (Object patterns) ->-              [ obj_key-              | obj_key <- KM.keys obj-              , any (\pattern_key -> K.toText obj_key =~ K.toText pattern_key) (KM.keys patterns)-              ]-            _ -> []-          unhandled_keys = filter (\k -> k `notElem` handled_by_props && k `notElem` handled_by_patterns) (KM.keys obj)--          -- Validate additional properties-          additional_errors = case additional_props_schema of-            Just (Bool False) ->-              [ ValidationError path $-                "Additional property not allowed: " <> K.toText key-              | key <- unhandled_keys-              ]-            Just schema ->-              concat-                [ case obj KM.!? key of-                  Just prop_value ->-                    validateValue (path <> [K.toText key]) root schema prop_value fuel-                  Nothing -> []-                | key <- unhandled_keys-                ]-            Nothing -> []--          -- Validate property names-          property_name_errors = case property_names_schema of-            Just schema ->-              concat-                [ let key_value = String (K.toText key)-                  in  validateValue (path <> ["propertyName:" <> K.toText key]) root schema key_value fuel-                | key <- KM.keys obj-                ]-            _ -> []--          -- Validate required properties-          required_errors =-            [ ValidationError path $-              "Missing required property: " <> prop-            | prop <- required_props-            , isNothing (obj KM.!? K.fromText prop)-            ]--          -- Handle dependent schemas and required-          dependent_errors = validateDependencies path root km obj fuel-      in  concat [prop_errors, pattern_prop_errors, additional_errors, property_name_errors, required_errors, dependent_errors]-    _ -> []---- | Validate dependentSchemas and dependentRequired.------ - dependentSchemas: if key K present, validate the entire object against a schema S--- - dependentRequired: if key K present, require listed properties to also be present-validateDependencies :: [Text] -> Value -> KM.KeyMap Value -> KM.KeyMap Value -> Int -> [ValidationError]-validateDependencies path root km obj fuel =-  let dep_schemas_errors = case km KM.!? "dependentSchemas" of-        Just (Object dep_schemas) ->-          concat-            [ if isJust (obj KM.!? dep_key)-              then validateValue path root dep_schema (Object obj) fuel-              else []-            | (dep_key, dep_schema) <- KM.toList dep_schemas-            ]-        _ -> []--      dep_required_errors = case km KM.!? "dependentRequired" of-        Just (Object dep_required) ->-          concat-            [ if isJust (obj KM.!? dep_key)-              then-                ( case dep_value of-                    Array required_arr ->-                      [ ValidationError path $-                        "Property '" <> K.toText dep_key <> "' requires property: " <> req_prop-                      | String req_prop <- V.toList required_arr-                      , isNothing (obj KM.!? K.fromText req_prop)-                      ]-                    _ -> []-                )-              else []-            | (dep_key, dep_value) <- KM.toList dep_required-            ]-        _ -> []-  in  dep_schemas_errors <> dep_required_errors---- | Validate array items--- Implements 2020-12 array applicators semantics:---  - "prefixItems": array of schemas applied positionally to the first N items---  - "items": schema applied to all items with index >= N (N = prefixItems length, or 0 if absent)---  - "items": false forbids any items beyond N; if N == 0, array must be empty--- | Validate the "items" applicator for arrays in 2020-12.------ Semantics:---  - prefixItems: schemas applied positionally to first N items---  - items: schema for items at index >= N; items=false forbids any items beyond N-validateItems :: [Text] -> Value -> KM.KeyMap Value -> Value -> Int -> [ValidationError]-validateItems path root km value fuel =-  case value of-    Array arr ->-      let prefix_len = case km KM.!? "prefixItems" of-            Just (Array prefixes) -> Just (V.length prefixes)-            _ -> Just 0-          n = fromMaybe 0 prefix_len-          arr_len = V.length arr-          rest_indices = [n .. arr_len - 1]-      in  case km KM.!? "items" of-            Just (Bool False) ->-              [ ValidationError path $-                "Array has "-                  <> T.pack (show arr_len)-                  <> " items but only "-                  <> T.pack (show n)-                  <> " allowed"-              | arr_len > n-              ]-            Just item_schema ->-              concat-                [ validateValue (path <> [T.pack $ show i]) root item_schema (arr V.! i) fuel-                | i <- rest_indices-                ]-            Nothing -> []-    _ -> []---- | Validate the "prefixItems" applicator for arrays (positionally for the first N items).-validatePrefixItems :: [Text] -> Value -> KM.KeyMap Value -> Value -> Int -> [ValidationError]-validatePrefixItems path root km value fuel =-  case value of-    Array arr ->-      case km KM.!? "prefixItems" of-        Just (Array prefixes) ->-          let limit = min (V.length prefixes) (V.length arr)-          in  concat-                [ validateValue (path <> [T.pack $ show i]) root (prefixes V.! i) (arr V.! i) fuel-                | i <- [0 .. limit - 1]-                ]-        _ -> []-    _ -> []---- | Validate string constraints: minLength, maxLength, pattern.--- Note: "format" is treated as an annotation and not asserted.-validateStringConstraints :: [Text] -> KM.KeyMap Value -> Value -> [ValidationError]-validateStringConstraints path km value =-  case value of-    String str ->-      let l = unicodeLength str-      in  concat-            [ case km KM.!? "minLength" of-                Just (Number n)-                  | Just min_len <- Sci.toBoundedInteger n ->-                      [ ValidationError path $-                        "String length "-                          <> T.pack (show l)-                          <> " is less than minimum "-                          <> T.pack (show min_len)-                      | l < (min_len :: Int)-                      ]-                _ -> []-            , case km KM.!? "maxLength" of-                Just (Number n)-                  | Just max_len <- Sci.toBoundedInteger n ->-                      ( [ ValidationError path $-                          "String length "-                            <> T.pack (show l)-                            <> " exceeds maximum "-                            <> T.pack (show max_len)-                        | l > (max_len :: Int)-                        ]-                      )-                _ -> []-            , case km KM.!? "pattern" of-                Just (String pattern) ->-                  [ValidationError path $ "String does not match pattern: " <> pattern | not (str =~ pattern)]-                _ -> []-                -- format validation is optional and can be added later-            ]-    _ -> []---- | Validate numeric constraints: minimum, maximum, exclusiveMinimum, exclusiveMaximum, multipleOf.--- multipleOf is checked exactly using rationals to avoid floating point error.-validateNumberConstraints :: [Text] -> KM.KeyMap Value -> Value -> [ValidationError]-validateNumberConstraints path km value =-  case value of-    Number num ->-      let fmt :: Scientific -> Text-          fmt = T.pack . Sci.formatScientific Sci.Generic Nothing-      in  concat-            [ case km KM.!? "minimum" of-                Just (Number min_val) ->-                  [ ValidationError path $-                    "Value " <> fmt num <> " is less than minimum " <> fmt min_val-                  | num < min_val-                  ]-                _ -> []-            , case km KM.!? "exclusiveMinimum" of-                Just (Number min_val) ->-                  [ ValidationError path $-                    "Value " <> fmt num <> " is not greater than exclusiveMinimum " <> fmt min_val-                  | num <= min_val-                  ]-                _ -> []-            , case km KM.!? "maximum" of-                Just (Number max_val) ->-                  [ ValidationError path $-                    "Value " <> fmt num <> " exceeds maximum " <> fmt max_val-                  | num > max_val-                  ]-                _ -> []-            , case km KM.!? "exclusiveMaximum" of-                Just (Number max_val) ->-                  [ ValidationError path $-                    "Value " <> fmt num <> " is not less than exclusiveMaximum " <> fmt max_val-                  | num >= max_val-                  ]-                _ -> []-            , case km KM.!? "multipleOf" of-                Just (Number divisor) ->-                  ( [ ValidationError path $-                      "Value " <> fmt num <> " is not a multiple of " <> fmt divisor-                    | not (isMultipleOf num divisor)-                    ]-                  )-                _ -> []-            ]-    _ -> []---- | Validate logical combinators: anyOf, oneOf, allOf, not.-validateCombinators :: [Text] -> Value -> KM.KeyMap Value -> Value -> Int -> [ValidationError]-validateCombinators path root km value fuel =-  concat-    [ validateAnyOf path root km value fuel-    , validateOneOf path root km value fuel-    , validateAllOf path root km value fuel-    , validateNot path root km value fuel-    ]---- | anyOf: valid if at least one subschema validates (merges annotations of matching subschemas).-validateAnyOf :: [Text] -> Value -> KM.KeyMap Value -> Value -> Int -> [ValidationError]-validateAnyOf path root km value fuel =-  case km KM.!? "anyOf" of-    Just (Array schemas) ->-      let results = [validateValue path root schema value fuel | schema <- V.toList schemas]-      in  [ValidationError path "Value does not match any of the schemas in 'anyOf'" | not (any null results)]-    _ -> []---- | oneOf: valid if exactly one subschema validates.-validateOneOf :: [Text] -> Value -> KM.KeyMap Value -> Value -> Int -> [ValidationError]-validateOneOf path root km value fuel =-  case km KM.!? "oneOf" of-    Just (Array schemas) ->-      let results = [validateValue path root schema value fuel | schema <- V.toList schemas]-          valid_count = length $ filter null results-      in  case valid_count of-            0 -> [ValidationError path "Value does not match any schema in 'oneOf'"]-            1 -> []-            _ ->-              [ ValidationError path $ "Value matches " <> T.pack (show valid_count) <> " schemas in 'oneOf' but must match exactly one"-              ]-    _ -> []---- | allOf: valid only if all subschemas validate; accumulates all errors.-validateAllOf :: [Text] -> Value -> KM.KeyMap Value -> Value -> Int -> [ValidationError]-validateAllOf path root km value fuel =-  case km KM.!? "allOf" of-    Just (Array schemas) ->-      concat [validateValue path root schema value fuel | schema <- V.toList schemas]-    _ -> []---- | not: valid only if the subschema does not validate.-validateNot :: [Text] -> Value -> KM.KeyMap Value -> Value -> Int -> [ValidationError]-validateNot path root km value fuel =-  case km KM.!? "not" of-    Just not_schema ->-      [ValidationError path "Value matches schema in 'not'" | null (validateValue path root not_schema value fuel)]-    _ -> []---- | Validate array count/membership constraints: minItems, maxItems, uniqueItems, contains.-validateArrayConstraints :: [Text] -> Value -> KM.KeyMap Value -> Value -> Int -> [ValidationError]-validateArrayConstraints path root km value fuel =-  case value of-    Array arr ->-      concat-        [ case km KM.!? "minItems" of-            Just (Number n)-              | Just min_items <- Sci.toBoundedInteger n ->-                  [ ValidationError path $-                    "Array has "-                      <> T.pack (show $ V.length arr)-                      <> " items but minimum is "-                      <> T.pack (show min_items)-                  | V.length arr < min_items-                  ]-            _ -> []-        , case km KM.!? "maxItems" of-            Just (Number n)-              | Just max_items <- Sci.toBoundedInteger n ->-                  [ ValidationError path $-                    "Array has "-                      <> T.pack (show $ V.length arr)-                      <> " items but maximum is "-                      <> T.pack (show max_items)-                  | V.length arr > max_items-                  ]-            _ -> []-        , case km KM.!? "uniqueItems" of-            Just (Bool True) ->-              let items = V.toList arr-              in  [ValidationError path "Array items are not unique" | length items /= length (nub items)]-            _ -> []-        , validateContains path root km arr fuel-        ]-    _ -> []---- | Validate contains constraints--- | Validate contains/minContains/maxContains: counts items matching the subschema.--- Note: when "contains" is false, minContains defaults to 1, making any array invalid.-validateContains :: [Text] -> Value -> KM.KeyMap Value -> V.Vector Value -> Int -> [ValidationError]-validateContains path root km arr fuel =-  case km KM.!? "contains" of-    Nothing -> []-    Just contains_schema ->-      let matches = V.filter (\item -> null $ validateValue path root contains_schema item fuel) arr-          match_count = V.length matches-          min_contains = case km KM.!? "minContains" of-            Just (Number n) -> fromMaybe 1 (Sci.toBoundedInteger n)-            _ -> 1-          max_contains = case km KM.!? "maxContains" of-            Just (Number n) -> Sci.toBoundedInteger n-            _ -> Nothing-      in  concat-            [ [ ValidationError path $-                "Array has "-                  <> T.pack (show match_count)-                  <> " matching items but minContains is "-                  <> T.pack (show min_contains)-              | match_count < min_contains-              ]-            , case max_contains of-                Just max_cont ->-                  [ ValidationError path $-                    "Array has "-                      <> T.pack (show match_count)-                      <> " matching items but maxContains is "-                      <> T.pack (show max_cont)-                  | match_count > max_cont-                  ]-                Nothing -> []-            ]---- | Validate object constraints (minProperties, maxProperties)--- | Validate object property count constraints: minProperties and maxProperties.-validateObjectConstraints :: [Text] -> KM.KeyMap Value -> Value -> [ValidationError]-validateObjectConstraints path km value =-  case value of-    Object obj ->-      let prop_count = KM.size obj-      in  concat-            [ case km KM.!? "minProperties" of-                Just (Number n)-                  | Just min_props <- Sci.toBoundedInteger n ->-                      [ ValidationError path $-                        "Object has "-                          <> T.pack (show prop_count)-                          <> " properties but minimum is "-                          <> T.pack (show min_props)-                      | prop_count < min_props-                      ]-                _ -> []-            , case km KM.!? "maxProperties" of-                Just (Number n)-                  | Just max_props <- Sci.toBoundedInteger n ->-                      [ ValidationError path $-                        "Object has "-                          <> T.pack (show prop_count)-                          <> " properties but maximum is "-                          <> T.pack (show max_props)-                      | prop_count > max_props-                      ]-                _ -> []-            ]-    _ -> []---- | Validate conditional logic (if/then/else)--- | Validate conditional keywords: if/then/else.-validateConditional :: [Text] -> Value -> KM.KeyMap Value -> Value -> Int -> [ValidationError]-validateConditional path root km value fuel =-  case km KM.!? "if" of-    Nothing -> []-    Just if_schema ->-      let if_matches = null $ validateValue path root if_schema value fuel-      in  if if_matches-            then case km KM.!? "then" of-              Just then_schema -> validateValue path root then_schema value fuel-              Nothing -> []-            else case km KM.!? "else" of-              Just else_schema -> validateValue path root else_schema value fuel-              Nothing -> []---- | Check if a number is a multiple of another--- Exact multipleOf using rationals (avoids floating point error).--- | Exact multipleOf check using rationals (denominator must be 1).-isMultipleOf :: Scientific -> Scientific -> Bool-isMultipleOf value divisor =-  let q = toRational value / toRational divisor-  in  denominator q == 1---- Count Unicode code points (not UTF-16 code units)---- | Count Unicode code points (not UTF-16 code units) for string length.-unicodeLength :: Text -> Int-unicodeLength = T.foldl' (\n _ -> n + 1) 0---- | Helper to show JSON values as text-showJSON :: Value -> Text-showJSON = T.take 100 . T.pack . show---- | Resolve a local $ref against the root schema using JSON Pointer--- Supports only fragment starting with '#'. External URIs and anchors are not resolved.--- | Resolve a local $ref against the root schema using JSON Pointer.--- Supports only fragments starting with '#'; external URIs/anchors are not resolved.-resolveRef :: Value -> Text -> Maybe Value-resolveRef root ref_path =-  case T.uncons ref_path of-    Just ('#', rest) ->-      -- empty fragment or pointer-      if T.null rest-        then Just root-        else-          if T.head rest == '/'-            then jsonPointer root (T.tail rest)-            else Nothing -- unsupported non-pointer fragment-    _ -> Nothing -- unsupported non-fragment refs---- | Evaluate a JSON Pointer (RFC 6901) against a JSON value.-jsonPointer :: Value -> Text -> Maybe Value-jsonPointer v ptr =-  let tokens = map unescapePointer $ T.splitOn "/" ptr-  in  go v tokens-  where-    go :: Value -> [Text] -> Maybe Value-    go cur [] = Just cur-    go (Object km) (t : ts) =-      case KM.lookup (K.fromText t) km of-        Just nxt -> go nxt ts-        Nothing -> Nothing-    go (Array arr) (t : ts)-      | T.all isDigit t && not (T.null t) =-          let i = read (T.unpack t) :: Int-          in  if i >= 0 && i < V.length arr then go (arr V.! i) ts else Nothing-      | otherwise = Nothing-    go _ _ = Nothing--    unescapePointer :: Text -> Text-    unescapePointer = T.replace "~1" "/" . T.replace "~0" "~"---- | Validate "unevaluatedProperties":--- Forbids or constrains properties that were not covered by properties,--- patternProperties, or additionalProperties at the current schema location.--- This implementation approximates evaluated sets locally and does not--- perform full annotation merging across nested applicators.-validateUnevaluatedProperties :: [Text] -> Value -> KM.KeyMap Value -> Value -> Int -> [ValidationError]-validateUnevaluatedProperties path root km value fuel =-  case (value, km KM.!? "unevaluatedProperties") of-    (Object obj, Just uneval_schema) ->-      let props_schema = km KM.!? "properties"-          pattern_props_schema = km KM.!? "patternProperties"--          props_handled = case props_schema of-            Just (Object schema_obj) -> [k | (k, _) <- KM.toList schema_obj, KM.member k obj]-            _ -> []-          patterns_handled = case pattern_props_schema of-            Just (Object patterns) ->-              [ obj_key-              | obj_key <- KM.keys obj-              , any (\pattern_key -> K.toText obj_key =~ K.toText pattern_key) (KM.keys patterns)-              ]-            _ -> []-          extras = [k | k <- KM.keys obj, k `notElem` props_handled, k `notElem` patterns_handled]--          -- If additionalProperties is present, consider extras handled by it-          extras_handled_by_additional = case km KM.!? "additionalProperties" of-            Just _ -> extras-            Nothing -> []--          unevaluated_keys = [k | k <- extras, k `notElem` extras_handled_by_additional]--          applyUnevaluated (Bool False) =-            [ ValidationError path $-              "Unevaluated property not allowed: " <> K.toText k-            | k <- unevaluated_keys-            ]-          applyUnevaluated sch =-            concat-              [ case obj KM.!? k of-                Just v -> validateValue (path <> [K.toText k]) root sch v fuel-                Nothing -> []-              | k <- unevaluated_keys-              ]-      in  applyUnevaluated uneval_schema-    _ -> []---- | Validate "unevaluatedItems":--- Applies to array indices not covered by prefixItems, items, or contains When false, any such index is prohibited; when a schema, each such item--- is validated against it. This uses local evaluated-set approximation.-validateUnevaluatedItems :: [Text] -> Value -> KM.KeyMap Value -> Value -> Int -> [ValidationError]-validateUnevaluatedItems path root km value fuel =-  case (value, km KM.!? "unevaluatedItems") of-    (Array arr, Just uneval_schema) ->-      let arr_len = V.length arr-          -- prefix items coverage-          prefix_count = case km KM.!? "prefixItems" of-            Just (Array prefixes) -> min (V.length prefixes) arr_len-            _ -> 0-          prefix_idx = [0 .. prefix_count - 1]-          -- items coverage for rest if present-          rest_idx = case km KM.!? "items" of-            Just _ -> [prefix_count .. arr_len - 1]-            Nothing -> []-          -- contains matched indices (optional)-          contains_idx = case km KM.!? "contains" of-            Nothing -> []-            Just sch ->-              [ i-              | i <- [0 .. arr_len - 1]-              , null $ validateValue path root sch (arr V.! i) fuel-              ]-          evaluated = nub (prefix_idx <> rest_idx <> contains_idx)-          unevaluated = [i | i <- [0 .. arr_len - 1], i `notElem` evaluated]-          applyItems (Bool False) =-            [ ValidationError path $-              "Unevaluated item not allowed at index " <> T.pack (show i)-            | i <- unevaluated-            ]-          applyItems sch =-            concat-              [ validateValue (path <> [T.pack (show i)]) root sch (arr V.! i) fuel-              | i <- unevaluated-              ]-      in  applyItems uneval_schema-    _ -> []+{- |+Module:      JSONSchema.Validation+Copyright:   (c) DPella AB 2025+License:     LicenseRef-AllRightsReserved+Maintainer:  <matti@dpella.io>, <lobo@dpella.io>++JSON Schema validation according to JSON Schema 2020-12.++This module provides validation functions that check if a JSON value+conforms to a given JSON Schema. It supports the core 2020-12+semantics for validation and applicator keywords ("type", "properties", "patternProperties",+"additionalProperties", "items", "prefixItems", numeric and string+constraints, combinators, and conditionals). Local $ref resolution to JSON Pointers+within the same schema document (including paths under "$defs") is supported.+The "unevaluatedProperties" and "unevaluatedItems" keywords are implemented+with pragmatic semantics at the current instance location (covering properties/items+handled by properties/patternProperties/prefixItems/items/contains). The full+annotation-merging behavior across nested applicators is not implemented.+The Format-Assertion vocabulary is not implemented; the "format" and "content*"+keywords are treated as annotations only, per the 2020-12 specification.++= Usage++@+let schema = toJSONSchema (Proxy :: Proxy Person)+let value = object ["name" .= "Alice", "age" .= 30]+validateJSONSchema schema value  -- Returns True if valid+@+-}+module JSONSchema.Validation (+    validateJSONSchema,+    ValidationError (..),+    validate,+    validateWithErrors,+) where++import Data.Aeson+import Data.Aeson.Key qualified as K+import Data.Aeson.KeyMap qualified as KM+import Data.Char (isDigit)+import Data.List (nub)+import Data.Maybe (fromMaybe, isJust, isNothing)+import Data.Ratio (denominator)+import Data.Scientific (Scientific)+import Data.Scientific qualified as Sci+import Data.Text (Text)+import Data.Text qualified as T+import Data.Vector qualified as V+import Text.Regex.TDFA ((=~))+import Text.Regex.TDFA.Text ()++-- | Validation error with context about what failed+data ValidationError = ValidationError+    { error_path :: [Text]+    -- ^ Path to the failing value (e.g. ["users", "0", "name"])+    , error_message :: Text+    -- ^ Description of the validation failure+    }+    deriving (Show, Eq)++-- | Simple validation that returns True if the value matches the schema+validateJSONSchema :: Value -> Value -> Bool+validateJSONSchema schema value = null $ validateWithErrors schema value++-- | Validate with error collection+validate :: Value -> Value -> Either [ValidationError] ()+validate schema value =+    case validateWithErrors schema value of+        [] -> Right ()+        errs -> Left errs++{- | Validate and return all errors found for an instance against a schema.+This walks the instance and applies the validation vocabulary for 2020-12,+returning every violation discovered (no short-circuit).+-}+validateWithErrors :: Value -> Value -> [ValidationError]+validateWithErrors schema value = validateValue [] schema schema value maxRefDepth++-- | Max recursion depth for $ref to avoid infinite loops+maxRefDepth :: Int+maxRefDepth = 256++{- | Internal validator with context.++Parameters:+ - path: JSON Pointer-like path to the current instance location+ - root: the root schema document (for resolving local $ref)+ - schema: the current subschema to apply+ - value: the current instance value+ - fuel: remaining recursion depth for $ref resolution+-}+validateValue :: [Text] -> Value -> Value -> Value -> Int -> [ValidationError]+validateValue path root schema value fuel =+    case schema of+        Bool True -> [] -- true schema always validates+        Bool False -> [ValidationError path "Schema is false (always fails)"]+        Object km ->+            -- \$ref short-circuit: if present, ignore other keywords (per spec)+            case km KM.!? "$ref" of+                Just (String ref_path) ->+                    if fuel <= 0+                        then [ValidationError path "Exceeded $ref resolution depth"]+                        else case resolveRef root ref_path of+                            Just ref_schema -> validateValue path root ref_schema value (fuel - 1)+                            Nothing -> [ValidationError path ("Unresolved $ref: " <> ref_path)]+                _ -> validateObject path root km value fuel+        _ -> [ValidationError path "Invalid schema: must be a boolean or object"]++{- | Apply object schema keywords and dispatch to other validators.++Covers:+ - type/const/enum+ - Object keywords: properties, patternProperties, additionalProperties,+   propertyNames, required, dependentSchemas, dependentRequired+ - Array keywords present at this location: prefixItems, items (when instance is array)+ - String/Number/Object count constraints+ - Combinators: anyOf, oneOf, allOf, not+ - Conditionals: if/then/else+ - unevaluatedProperties / unevaluatedItems (local, pragmatic semantics)+-}+validateObject :: [Text] -> Value -> KM.KeyMap Value -> Value -> Int -> [ValidationError]+validateObject path root km value fuel =+    concat+        [ validateType path km value+        , validateConst path km value+        , validateEnum path km value+        , validateProperties path root km value fuel+        , validateItems path root km value fuel+        , validatePrefixItems path root km value fuel+        , validateArrayConstraints path root km value fuel+        , validateStringConstraints path km value+        , validateNumberConstraints path km value+        , validateObjectConstraints path km value+        , validateCombinators path root km value fuel+        , validateConditional path root km value fuel+        , validateUnevaluatedProperties path root km value fuel+        , validateUnevaluatedItems path root km value fuel+        ]++{- | Validate the "type" keyword. Supports a single string or an array of types.+Recognized types: null, boolean, string, number, integer, array, object.+-}+validateType :: [Text] -> KM.KeyMap Value -> Value -> [ValidationError]+validateType path km value =+    case km KM.!? "type" of+        Nothing -> []+        Just (String type_str) ->+            [ ValidationError path $ "Expected type " <> type_str <> " but got " <> describeType value+            | not (checkType type_str value)+            ]+        Just (Array types) ->+            let type_strs = [t | String t <- V.toList types]+             in [ ValidationError path $ "Expected one of types " <> T.intercalate ", " type_strs <> " but got " <> describeType value+                | not (any (`checkType` value) type_strs)+                ]+        Just _ -> [ValidationError path "Invalid 'type' field in schema"]++-- | Check whether a JSON value is of the given JSON Schema type.+checkType :: Text -> Value -> Bool+checkType "null" Null = True+checkType "boolean" (Bool _) = True+checkType "string" (String _) = True+checkType "number" (Number _) = True+-- Per JSON Schema, "integer" means the instance is a number with an integral value,+-- not limited by machine-sized Int bounds.+checkType "integer" (Number n) = Sci.isInteger n+checkType "array" (Array _) = True+checkType "object" (Object _) = True+checkType _ _ = False++-- | Derive the schema type name corresponding to a value (e.g., "integer").+describeType :: Value -> Text+describeType Null = "null"+describeType (Bool _) = "boolean"+describeType (String _) = "string"+describeType (Number n)+    | Sci.isInteger n = "integer"+    | otherwise = "number"+describeType (Array _) = "array"+describeType (Object _) = "object"++-- | Validate the "const" keyword (instance must be exactly equal to the given value).+validateConst :: [Text] -> KM.KeyMap Value -> Value -> [ValidationError]+validateConst path km value =+    case km KM.!? "const" of+        Nothing -> []+        Just const_val ->+            [ ValidationError path $ "Expected constant value " <> showJSON const_val <> " but got " <> showJSON value+            | value /= const_val+            ]++-- | Validate the "enum" keyword (instance must be a member of the given array).+validateEnum :: [Text] -> KM.KeyMap Value -> Value -> [ValidationError]+validateEnum path km value =+    case km KM.!? "enum" of+        Nothing -> []+        Just (Array values) ->+            [ValidationError path $ "Value not in enum: " <> showJSON value | not (value `V.elem` values)]+        Just _ -> [ValidationError path "Invalid 'enum' field in schema"]++{- | Validate object-related keywords at this location.++Implements:+ - properties: validate each defined property if present+ - patternProperties: validate properties whose names match regex patterns+ - additionalProperties: validate and/or forbid properties not matched above+ - propertyNames: validate each property name as a string instance+ - required: ensure listed properties exist+ - dependentSchemas: when a property exists, apply another schema to the whole object+ - dependentRequired: when a property exists, require additional properties+-}+validateProperties :: [Text] -> Value -> KM.KeyMap Value -> Value -> Int -> [ValidationError]+validateProperties path root km value fuel =+    case value of+        Object obj ->+            let props_schema = km KM.!? "properties"+                pattern_props_schema = km KM.!? "patternProperties"+                additional_props_schema = km KM.!? "additionalProperties"+                property_names_schema = km KM.!? "propertyNames"+                required_props = case km KM.!? "required" of+                    Just (Array arr) -> [t | String t <- V.toList arr]+                    _ -> []++                -- Validate properties defined in 'properties'+                prop_errors = case props_schema of+                    Just (Object schema_obj) ->+                        concat+                            [ case obj KM.!? key of+                                Just prop_value ->+                                    validateValue (path <> [K.toText key]) root schema prop_value fuel+                                Nothing -> []+                            | (key, schema) <- KM.toList schema_obj+                            ]+                    _ -> []++                -- Validate properties matching patterns in 'patternProperties'+                pattern_prop_errors = case pattern_props_schema of+                    Just (Object patterns) ->+                        concat+                            [ concat+                                [ if K.toText obj_key =~ K.toText pattern_key+                                    then validateValue (path <> [K.toText obj_key]) root pattern_schema obj_value fuel+                                    else []+                                | (pattern_key, pattern_schema) <- KM.toList patterns+                                ]+                            | (obj_key, obj_value) <- KM.toList obj+                            ]+                    _ -> []++                -- Determine which properties are handled by properties or patternProperties+                handled_by_props = case props_schema of+                    Just (Object schema_obj) -> KM.keys schema_obj+                    _ -> []+                handled_by_patterns = case pattern_props_schema of+                    Just (Object patterns) ->+                        [ obj_key+                        | obj_key <- KM.keys obj+                        , any (\pattern_key -> K.toText obj_key =~ K.toText pattern_key) (KM.keys patterns)+                        ]+                    _ -> []+                unhandled_keys = filter (\k -> k `notElem` handled_by_props && k `notElem` handled_by_patterns) (KM.keys obj)++                -- Validate additional properties+                additional_errors = case additional_props_schema of+                    Just (Bool False) ->+                        [ ValidationError path $+                            "Additional property not allowed: " <> K.toText key+                        | key <- unhandled_keys+                        ]+                    Just schema ->+                        concat+                            [ case obj KM.!? key of+                                Just prop_value ->+                                    validateValue (path <> [K.toText key]) root schema prop_value fuel+                                Nothing -> []+                            | key <- unhandled_keys+                            ]+                    Nothing -> []++                -- Validate property names+                property_name_errors = case property_names_schema of+                    Just schema ->+                        concat+                            [ let key_value = String (K.toText key)+                               in validateValue (path <> ["propertyName:" <> K.toText key]) root schema key_value fuel+                            | key <- KM.keys obj+                            ]+                    _ -> []++                -- Validate required properties+                required_errors =+                    [ ValidationError path $+                        "Missing required property: " <> prop+                    | prop <- required_props+                    , isNothing (obj KM.!? K.fromText prop)+                    ]++                -- Handle dependent schemas and required+                dependent_errors = validateDependencies path root km obj fuel+             in concat [prop_errors, pattern_prop_errors, additional_errors, property_name_errors, required_errors, dependent_errors]+        _ -> []++{- | Validate dependentSchemas and dependentRequired.++- dependentSchemas: if key K present, validate the entire object against a schema S+- dependentRequired: if key K present, require listed properties to also be present+-}+validateDependencies :: [Text] -> Value -> KM.KeyMap Value -> KM.KeyMap Value -> Int -> [ValidationError]+validateDependencies path root km obj fuel =+    let dep_schemas_errors = case km KM.!? "dependentSchemas" of+            Just (Object dep_schemas) ->+                concat+                    [ if isJust (obj KM.!? dep_key)+                        then validateValue path root dep_schema (Object obj) fuel+                        else []+                    | (dep_key, dep_schema) <- KM.toList dep_schemas+                    ]+            _ -> []++        dep_required_errors = case km KM.!? "dependentRequired" of+            Just (Object dep_required) ->+                concat+                    [ if isJust (obj KM.!? dep_key)+                        then+                            ( case dep_value of+                                Array required_arr ->+                                    [ ValidationError path $+                                        "Property '" <> K.toText dep_key <> "' requires property: " <> req_prop+                                    | String req_prop <- V.toList required_arr+                                    , isNothing (obj KM.!? K.fromText req_prop)+                                    ]+                                _ -> []+                            )+                        else []+                    | (dep_key, dep_value) <- KM.toList dep_required+                    ]+            _ -> []+     in dep_schemas_errors <> dep_required_errors++{- | Validate array items+Implements 2020-12 array applicators semantics:+ - "prefixItems": array of schemas applied positionally to the first N items+ - "items": schema applied to all items with index >= N (N = prefixItems length, or 0 if absent)+ - "items": false forbids any items beyond N; if N == 0, array must be empty+| Validate the "items" applicator for arrays in 2020-12.++Semantics:+ - prefixItems: schemas applied positionally to first N items+ - items: schema for items at index >= N; items=false forbids any items beyond N+-}+validateItems :: [Text] -> Value -> KM.KeyMap Value -> Value -> Int -> [ValidationError]+validateItems path root km value fuel =+    case value of+        Array arr ->+            let prefix_len = case km KM.!? "prefixItems" of+                    Just (Array prefixes) -> Just (V.length prefixes)+                    _ -> Just 0+                n = fromMaybe 0 prefix_len+                arr_len = V.length arr+                rest_indices = [n .. arr_len - 1]+             in case km KM.!? "items" of+                    Just (Bool False) ->+                        [ ValidationError path $+                            "Array has "+                                <> T.pack (show arr_len)+                                <> " items but only "+                                <> T.pack (show n)+                                <> " allowed"+                        | arr_len > n+                        ]+                    Just item_schema ->+                        concat+                            [ validateValue (path <> [T.pack $ show i]) root item_schema (arr V.! i) fuel+                            | i <- rest_indices+                            ]+                    Nothing -> []+        _ -> []++-- | Validate the "prefixItems" applicator for arrays (positionally for the first N items).+validatePrefixItems :: [Text] -> Value -> KM.KeyMap Value -> Value -> Int -> [ValidationError]+validatePrefixItems path root km value fuel =+    case value of+        Array arr ->+            case km KM.!? "prefixItems" of+                Just (Array prefixes) ->+                    let limit = min (V.length prefixes) (V.length arr)+                     in concat+                            [ validateValue (path <> [T.pack $ show i]) root (prefixes V.! i) (arr V.! i) fuel+                            | i <- [0 .. limit - 1]+                            ]+                _ -> []+        _ -> []++{- | Validate string constraints: minLength, maxLength, pattern.+Note: "format" is treated as an annotation and not asserted.+-}+validateStringConstraints :: [Text] -> KM.KeyMap Value -> Value -> [ValidationError]+validateStringConstraints path km value =+    case value of+        String str ->+            let l = unicodeLength str+             in concat+                    [ case km KM.!? "minLength" of+                        Just (Number n)+                            | Just min_len <- Sci.toBoundedInteger n ->+                                [ ValidationError path $+                                    "String length "+                                        <> T.pack (show l)+                                        <> " is less than minimum "+                                        <> T.pack (show min_len)+                                | l < (min_len :: Int)+                                ]+                        _ -> []+                    , case km KM.!? "maxLength" of+                        Just (Number n)+                            | Just max_len <- Sci.toBoundedInteger n ->+                                ( [ ValidationError path $+                                        "String length "+                                            <> T.pack (show l)+                                            <> " exceeds maximum "+                                            <> T.pack (show max_len)+                                  | l > (max_len :: Int)+                                  ]+                                )+                        _ -> []+                    , case km KM.!? "pattern" of+                        Just (String pattern) ->+                            [ValidationError path $ "String does not match pattern: " <> pattern | not (str =~ pattern)]+                        _ -> []+                        -- format validation is optional and can be added later+                    ]+        _ -> []++{- | Validate numeric constraints: minimum, maximum, exclusiveMinimum, exclusiveMaximum, multipleOf.+multipleOf is checked exactly using rationals to avoid floating point error.+-}+validateNumberConstraints :: [Text] -> KM.KeyMap Value -> Value -> [ValidationError]+validateNumberConstraints path km value =+    case value of+        Number num ->+            let fmt :: Scientific -> Text+                fmt = T.pack . Sci.formatScientific Sci.Generic Nothing+             in concat+                    [ case km KM.!? "minimum" of+                        Just (Number min_val) ->+                            [ ValidationError path $+                                "Value " <> fmt num <> " is less than minimum " <> fmt min_val+                            | num < min_val+                            ]+                        _ -> []+                    , case km KM.!? "exclusiveMinimum" of+                        Just (Number min_val) ->+                            [ ValidationError path $+                                "Value " <> fmt num <> " is not greater than exclusiveMinimum " <> fmt min_val+                            | num <= min_val+                            ]+                        _ -> []+                    , case km KM.!? "maximum" of+                        Just (Number max_val) ->+                            [ ValidationError path $+                                "Value " <> fmt num <> " exceeds maximum " <> fmt max_val+                            | num > max_val+                            ]+                        _ -> []+                    , case km KM.!? "exclusiveMaximum" of+                        Just (Number max_val) ->+                            [ ValidationError path $+                                "Value " <> fmt num <> " is not less than exclusiveMaximum " <> fmt max_val+                            | num >= max_val+                            ]+                        _ -> []+                    , case km KM.!? "multipleOf" of+                        Just (Number divisor) ->+                            ( [ ValidationError path $+                                    "Value " <> fmt num <> " is not a multiple of " <> fmt divisor+                              | not (isMultipleOf num divisor)+                              ]+                            )+                        _ -> []+                    ]+        _ -> []++-- | Validate logical combinators: anyOf, oneOf, allOf, not.+validateCombinators :: [Text] -> Value -> KM.KeyMap Value -> Value -> Int -> [ValidationError]+validateCombinators path root km value fuel =+    concat+        [ validateAnyOf path root km value fuel+        , validateOneOf path root km value fuel+        , validateAllOf path root km value fuel+        , validateNot path root km value fuel+        ]++-- | anyOf: valid if at least one subschema validates (merges annotations of matching subschemas).+validateAnyOf :: [Text] -> Value -> KM.KeyMap Value -> Value -> Int -> [ValidationError]+validateAnyOf path root km value fuel =+    case km KM.!? "anyOf" of+        Just (Array schemas) ->+            let results = [validateValue path root schema value fuel | schema <- V.toList schemas]+             in [ValidationError path "Value does not match any of the schemas in 'anyOf'" | not (any null results)]+        _ -> []++-- | oneOf: valid if exactly one subschema validates.+validateOneOf :: [Text] -> Value -> KM.KeyMap Value -> Value -> Int -> [ValidationError]+validateOneOf path root km value fuel =+    case km KM.!? "oneOf" of+        Just (Array schemas) ->+            let results = [validateValue path root schema value fuel | schema <- V.toList schemas]+                valid_count = length $ filter null results+             in case valid_count of+                    0 -> [ValidationError path "Value does not match any schema in 'oneOf'"]+                    1 -> []+                    _ ->+                        [ ValidationError path $ "Value matches " <> T.pack (show valid_count) <> " schemas in 'oneOf' but must match exactly one"+                        ]+        _ -> []++-- | allOf: valid only if all subschemas validate; accumulates all errors.+validateAllOf :: [Text] -> Value -> KM.KeyMap Value -> Value -> Int -> [ValidationError]+validateAllOf path root km value fuel =+    case km KM.!? "allOf" of+        Just (Array schemas) ->+            concat [validateValue path root schema value fuel | schema <- V.toList schemas]+        _ -> []++-- | not: valid only if the subschema does not validate.+validateNot :: [Text] -> Value -> KM.KeyMap Value -> Value -> Int -> [ValidationError]+validateNot path root km value fuel =+    case km KM.!? "not" of+        Just not_schema ->+            [ValidationError path "Value matches schema in 'not'" | null (validateValue path root not_schema value fuel)]+        _ -> []++-- | Validate array count/membership constraints: minItems, maxItems, uniqueItems, contains.+validateArrayConstraints :: [Text] -> Value -> KM.KeyMap Value -> Value -> Int -> [ValidationError]+validateArrayConstraints path root km value fuel =+    case value of+        Array arr ->+            concat+                [ case km KM.!? "minItems" of+                    Just (Number n)+                        | Just min_items <- Sci.toBoundedInteger n ->+                            [ ValidationError path $+                                "Array has "+                                    <> T.pack (show $ V.length arr)+                                    <> " items but minimum is "+                                    <> T.pack (show min_items)+                            | V.length arr < min_items+                            ]+                    _ -> []+                , case km KM.!? "maxItems" of+                    Just (Number n)+                        | Just max_items <- Sci.toBoundedInteger n ->+                            [ ValidationError path $+                                "Array has "+                                    <> T.pack (show $ V.length arr)+                                    <> " items but maximum is "+                                    <> T.pack (show max_items)+                            | V.length arr > max_items+                            ]+                    _ -> []+                , case km KM.!? "uniqueItems" of+                    Just (Bool True) ->+                        let items = V.toList arr+                         in [ValidationError path "Array items are not unique" | length items /= length (nub items)]+                    _ -> []+                , validateContains path root km arr fuel+                ]+        _ -> []++{- | Validate contains constraints+| Validate contains/minContains/maxContains: counts items matching the subschema.+Note: when "contains" is false, minContains defaults to 1, making any array invalid.+-}+validateContains :: [Text] -> Value -> KM.KeyMap Value -> V.Vector Value -> Int -> [ValidationError]+validateContains path root km arr fuel =+    case km KM.!? "contains" of+        Nothing -> []+        Just contains_schema ->+            let matches = V.filter (\item -> null $ validateValue path root contains_schema item fuel) arr+                match_count = V.length matches+                min_contains = case km KM.!? "minContains" of+                    Just (Number n) -> fromMaybe 1 (Sci.toBoundedInteger n)+                    _ -> 1+                max_contains = case km KM.!? "maxContains" of+                    Just (Number n) -> Sci.toBoundedInteger n+                    _ -> Nothing+             in concat+                    [ [ ValidationError path $+                            "Array has "+                                <> T.pack (show match_count)+                                <> " matching items but minContains is "+                                <> T.pack (show min_contains)+                      | match_count < min_contains+                      ]+                    , case max_contains of+                        Just max_cont ->+                            [ ValidationError path $+                                "Array has "+                                    <> T.pack (show match_count)+                                    <> " matching items but maxContains is "+                                    <> T.pack (show max_cont)+                            | match_count > max_cont+                            ]+                        Nothing -> []+                    ]++{- | Validate object constraints (minProperties, maxProperties)+| Validate object property count constraints: minProperties and maxProperties.+-}+validateObjectConstraints :: [Text] -> KM.KeyMap Value -> Value -> [ValidationError]+validateObjectConstraints path km value =+    case value of+        Object obj ->+            let prop_count = KM.size obj+             in concat+                    [ case km KM.!? "minProperties" of+                        Just (Number n)+                            | Just min_props <- Sci.toBoundedInteger n ->+                                [ ValidationError path $+                                    "Object has "+                                        <> T.pack (show prop_count)+                                        <> " properties but minimum is "+                                        <> T.pack (show min_props)+                                | prop_count < min_props+                                ]+                        _ -> []+                    , case km KM.!? "maxProperties" of+                        Just (Number n)+                            | Just max_props <- Sci.toBoundedInteger n ->+                                [ ValidationError path $+                                    "Object has "+                                        <> T.pack (show prop_count)+                                        <> " properties but maximum is "+                                        <> T.pack (show max_props)+                                | prop_count > max_props+                                ]+                        _ -> []+                    ]+        _ -> []++{- | Validate conditional logic (if/then/else)+| Validate conditional keywords: if/then/else.+-}+validateConditional :: [Text] -> Value -> KM.KeyMap Value -> Value -> Int -> [ValidationError]+validateConditional path root km value fuel =+    case km KM.!? "if" of+        Nothing -> []+        Just if_schema ->+            let if_matches = null $ validateValue path root if_schema value fuel+             in if if_matches+                    then case km KM.!? "then" of+                        Just then_schema -> validateValue path root then_schema value fuel+                        Nothing -> []+                    else case km KM.!? "else" of+                        Just else_schema -> validateValue path root else_schema value fuel+                        Nothing -> []++{- | Check if a number is a multiple of another+Exact multipleOf using rationals (avoids floating point error).+| Exact multipleOf check using rationals (denominator must be 1).+-}+isMultipleOf :: Scientific -> Scientific -> Bool+isMultipleOf value divisor =+    let q = toRational value / toRational divisor+     in denominator q == 1++-- Count Unicode code points (not UTF-16 code units)++-- | Count Unicode code points (not UTF-16 code units) for string length.+unicodeLength :: Text -> Int+unicodeLength = T.foldl' (\n _ -> n + 1) 0++-- | Helper to show JSON values as text+showJSON :: Value -> Text+showJSON = T.take 100 . T.pack . show++{- | Resolve a local $ref against the root schema using JSON Pointer+Supports only fragment starting with @#@. External URIs and anchors are not resolved.+| Resolve a local $ref against the root schema using JSON Pointer.+Supports only fragments starting with @#@; external URIs/anchors are not resolved.+-}+resolveRef :: Value -> Text -> Maybe Value+resolveRef root ref_path =+    case T.uncons ref_path of+        Just ('#', rest) ->+            -- empty fragment or pointer+            if T.null rest+                then Just root+                else+                    if T.head rest == '/'+                        then jsonPointer root (T.tail rest)+                        else Nothing -- unsupported non-pointer fragment+        _ -> Nothing -- unsupported non-fragment refs++-- | Evaluate a JSON Pointer (RFC 6901) against a JSON value.+jsonPointer :: Value -> Text -> Maybe Value+jsonPointer v ptr =+    let tokens = map unescapePointer $ T.splitOn "/" ptr+     in go v tokens+  where+    go :: Value -> [Text] -> Maybe Value+    go cur [] = Just cur+    go (Object km) (t : ts) =+        case KM.lookup (K.fromText t) km of+            Just nxt -> go nxt ts+            Nothing -> Nothing+    go (Array arr) (t : ts)+        | T.all isDigit t && not (T.null t) =+            let i = read (T.unpack t) :: Int+             in if i >= 0 && i < V.length arr then go (arr V.! i) ts else Nothing+        | otherwise = Nothing+    go _ _ = Nothing++    unescapePointer :: Text -> Text+    unescapePointer = T.replace "~1" "/" . T.replace "~0" "~"++{- | Validate "unevaluatedProperties":+Forbids or constrains properties that were not covered by properties,+patternProperties, or additionalProperties at the current schema location.+This implementation approximates evaluated sets locally and does not+perform full annotation merging across nested applicators.+-}+validateUnevaluatedProperties :: [Text] -> Value -> KM.KeyMap Value -> Value -> Int -> [ValidationError]+validateUnevaluatedProperties path root km value fuel =+    case (value, km KM.!? "unevaluatedProperties") of+        (Object obj, Just uneval_schema) ->+            let props_schema = km KM.!? "properties"+                pattern_props_schema = km KM.!? "patternProperties"++                props_handled = case props_schema of+                    Just (Object schema_obj) -> [k | (k, _) <- KM.toList schema_obj, KM.member k obj]+                    _ -> []+                patterns_handled = case pattern_props_schema of+                    Just (Object patterns) ->+                        [ obj_key+                        | obj_key <- KM.keys obj+                        , any (\pattern_key -> K.toText obj_key =~ K.toText pattern_key) (KM.keys patterns)+                        ]+                    _ -> []+                extras = [k | k <- KM.keys obj, k `notElem` props_handled, k `notElem` patterns_handled]++                -- If additionalProperties is present, consider extras handled by it+                extras_handled_by_additional = case km KM.!? "additionalProperties" of+                    Just _ -> extras+                    Nothing -> []++                unevaluated_keys = [k | k <- extras, k `notElem` extras_handled_by_additional]++                applyUnevaluated (Bool False) =+                    [ ValidationError path $+                        "Unevaluated property not allowed: " <> K.toText k+                    | k <- unevaluated_keys+                    ]+                applyUnevaluated sch =+                    concat+                        [ case obj KM.!? k of+                            Just v -> validateValue (path <> [K.toText k]) root sch v fuel+                            Nothing -> []+                        | k <- unevaluated_keys+                        ]+             in applyUnevaluated uneval_schema+        _ -> []++{- | Validate "unevaluatedItems":+Applies to array indices not covered by prefixItems, items, or contains When false, any such index is prohibited; when a schema, each such item+is validated against it. This uses local evaluated-set approximation.+-}+validateUnevaluatedItems :: [Text] -> Value -> KM.KeyMap Value -> Value -> Int -> [ValidationError]+validateUnevaluatedItems path root km value fuel =+    case (value, km KM.!? "unevaluatedItems") of+        (Array arr, Just uneval_schema) ->+            let arr_len = V.length arr+                -- prefix items coverage+                prefix_count = case km KM.!? "prefixItems" of+                    Just (Array prefixes) -> min (V.length prefixes) arr_len+                    _ -> 0+                prefix_idx = [0 .. prefix_count - 1]+                -- items coverage for rest if present+                rest_idx = case km KM.!? "items" of+                    Just _ -> [prefix_count .. arr_len - 1]+                    Nothing -> []+                -- contains matched indices (optional)+                contains_idx = case km KM.!? "contains" of+                    Nothing -> []+                    Just sch ->+                        [ i+                        | i <- [0 .. arr_len - 1]+                        , null $ validateValue path root sch (arr V.! i) fuel+                        ]+                evaluated = nub (prefix_idx <> rest_idx <> contains_idx)+                unevaluated = [i | i <- [0 .. arr_len - 1], i `notElem` evaluated]+                applyItems (Bool False) =+                    [ ValidationError path $+                        "Unevaluated item not allowed at index " <> T.pack (show i)+                    | i <- unevaluated+                    ]+                applyItems sch =+                    concat+                        [ validateValue (path <> [T.pack (show i)]) root sch (arr V.! i) fuel+                        | i <- unevaluated+                        ]+             in applyItems uneval_schema+        _ -> []

@@ -6,485 +6,708 @@  import Data.Aeson import Data.Aeson.KeyMap qualified as KM-import Data.String (fromString)-import Data.Text (Text)-import Data.Vector (fromList)-import Data.Vector qualified as V-import GHC.Generics (Generic)-import Data.JSON.JSONSchema-import Test.Tasty-import Test.Tasty.HUnit---- Simple product type (record)-data Person = Person-  { name :: Text-  , age :: Int-  }-  deriving (Show, Eq, Generic)--instance ToJSON Person--instance ToJSONSchema Person---- Sum type with non-record and product constructors-data Shape-  = Circle Double-  | Rectangle Double Double-  deriving (Show, Eq, Generic)--instance ToJSON Shape--instance ToJSONSchema Shape---- Sum type with record constructors (tests tagged record encoding)-data Animal-  = Dog {dogName :: Text, dogAge :: Int}-  | Cat {catName :: Text}-  deriving (Show, Eq, Generic)--instance ToJSON Animal--instance ToJSONSchema Animal---- Non-record product with 3 fields (tests prefixItems flattening)-data Triple = Triple Int Text Bool-  deriving (Show, Eq, Generic)--instance ToJSON Triple--instance ToJSONSchema Triple---- Recursive non-record sum type for ToJSON encoding test-data RTree-  = Leaf Int-  | Node RTree RTree-  deriving (Show, Eq, Generic)--instance ToJSON RTree--instance ToJSONSchema RTree--tests :: TestTree-tests =-  testGroup-    "JSON Schema"-    [ validationWorks-    , validationSpecCoverage-    , deriveWorks-    , schemaRecursiveWorks-    ]--validationWorks :: TestTree-validationWorks =-  testGroup-    "Validation Works"-    [ testCase "Valid object with required properties" $ do-        let schema =-              object-                [ "type" .= ("object" :: Text)-                , "properties"-                    .= object-                      [ "name" .= object ["type" .= ("string" :: Text)]-                      , "age" .= object ["type" .= ("integer" :: Text)]-                      ]-                , "required" .= (["name", "age"] :: [Text])-                , "additionalProperties" .= False-                ]-            value = object ["name" .= ("Alice" :: Text), "age" .= (30 :: Int)]-        assertBool "Expected valid JSON for schema" (validateJSONSchema schema value)-    , testCase "Missing required property fails" $ do-        let schema =-              object-                [ "type" .= ("object" :: Text)-                , "properties"-                    .= object-                      [ "name" .= object ["type" .= ("string" :: Text)]-                      , "age" .= object ["type" .= ("integer" :: Text)]-                      ]-                , "required" .= (["name", "age"] :: [Text])-                , "additionalProperties" .= False-                ]-            value = object ["name" .= ("Alice" :: Text)]-        assertBool "Expected invalid JSON for schema" (not $ validateJSONSchema schema value)-    , testCase "Wrong type fails" $ do-        let schema =-              object-                [ "type" .= ("object" :: Text)-                , "properties"-                    .= object-                      [ "name" .= object ["type" .= ("string" :: Text)]-                      , "age" .= object ["type" .= ("integer" :: Text)]-                      ]-                , "required" .= (["name", "age"] :: [Text])-                , "additionalProperties" .= False-                ]-            value = object ["name" .= ("Alice" :: Text), "age" .= ("30" :: Text)]-        assertBool "Expected invalid JSON for schema" (not $ validateJSONSchema schema value)-    , testCase "Additional property rejected when additionalProperties=false" $ do-        let schema =-              object-                [ "type" .= ("object" :: Text)-                , "properties"-                    .= object-                      [ "name" .= object ["type" .= ("string" :: Text)]-                      , "age" .= object ["type" .= ("integer" :: Text)]-                      ]-                , "required" .= (["name", "age"] :: [Text])-                , "additionalProperties" .= False-                ]-            value = object ["name" .= ("Alice" :: Text), "age" .= (30 :: Int), "extra" .= (True :: Bool)]-        assertBool "Expected invalid JSON for schema" (not $ validateJSONSchema schema value)-    , testCase "items=false with no prefixItems forbids any items" $ do-        let schema = object ["type" .= ("array" :: Text), "items" .= False]-        assertBool "[] should validate" (validateJSONSchema schema (Array mempty))-        assertBool "[1] should not validate" (not $ validateJSONSchema schema (toJSON ([1 :: Int] :: [Int])))-    , testCase "items applies only to items after prefixItems" $ do-        let schema =-              object-                [ "type" .= ("array" :: Text)-                , "prefixItems" .= [object ["type" .= ("integer" :: Text)]]-                , "items" .= object ["type" .= ("string" :: Text)]-                ]-            j1 = toJSON ([1 :: Int] :: [Int])-            j2 = Array (fromList [Number 1, String "x"])-            j3 = toJSON ([1 :: Int, 2] :: [Int])-        assertBool "[1] valid (no rest)" (validateJSONSchema schema j1)-        assertBool "[1, \"x\"] valid (rest string)" (validateJSONSchema schema j2)-        assertBool "[1, 2] invalid (rest not string)" (not $ validateJSONSchema schema j3)-    ]---- A comprehensive set of tests covering the 2020-12 validation vocabulary-validationSpecCoverage :: TestTree-validationSpecCoverage =-  testGroup-    "Validation Spec Coverage"-    [ -- type-      testCase "type: integer vs number" $ do-        let sInt = object ["type" .= ("integer" :: Text)]-        assertBool "3 integer" (validateJSONSchema sInt (Number 3))-        assertBool "3.5 not integer" (not $ validateJSONSchema sInt (Number 3.5))-    , testCase "type: array of types" $ do-        let s = object ["type" .= (["string", "null"] :: [Text])]-        assertBool "string ok" (validateJSONSchema s (String "x"))-        assertBool "null ok" (validateJSONSchema s Null)-        assertBool "bool not ok" (not $ validateJSONSchema s (Bool True))-    , -- const, enum-      testCase "const exact match" $ do-        let s = object ["const" .= object ["a" .= (1 :: Int)]]-        assertBool "match" (validateJSONSchema s (object ["a" .= (1 :: Int)]))-        assertBool "no match" (not $ validateJSONSchema s (object ["a" .= (2 :: Int)]))-    , testCase "enum membership" $ do-        let s = object ["enum" .= ([String "a", String "b"] :: [Value])]-        assertBool "a ok" (validateJSONSchema s (String "a"))-        assertBool "c not ok" (not $ validateJSONSchema s (String "c"))-    , -- string: minLength, maxLength, pattern-      testCase "string length counts code points" $ do-        let s = object ["type" .= ("string" :: Text), "minLength" .= (1 :: Int), "maxLength" .= (1 :: Int)]-        assertBool "emoji single code point ok" (validateJSONSchema s (String "😊"))-    , testCase "string pattern" $ do-        let s = object ["type" .= ("string" :: Text), "pattern" .= ("^[a-z]+$" :: Text)]-        assertBool "lowercase ok" (validateJSONSchema s (String "abc"))-        assertBool "uppercase not ok" (not $ validateJSONSchema s (String "Abc"))-    , -- number: minimum/maximum/exclusive*/multipleOf-      testCase "number bounds inclusive/exclusive" $ do-        let s =-              object-                [ "type" .= ("number" :: Text)-                , "minimum" .= (1 :: Int)-                , "exclusiveMaximum" .= (3 :: Int)-                ]-        assertBool "1 ok" (validateJSONSchema s (Number 1))-        assertBool "2.9 ok" (validateJSONSchema s (Number 2.9))-        assertBool "3 not ok" (not $ validateJSONSchema s (Number 3))-    , testCase "minimum respects large integers" $ do-        let s =-              object-                [ "type" .= ("integer" :: Text)-                , "minimum" .= Number 9007199254740993-                ]-        assertBool "just below fails" (not $ validateJSONSchema s (Number 9007199254740992))-        assertBool "threshold passes" (validateJSONSchema s (Number 9007199254740993))-    , testCase "exclusiveMaximum handles high precision decimals" $ do-        let bound = Number 0.12345678901234567890-            s =-              object-                [ "type" .= ("number" :: Text)-                , "exclusiveMaximum" .= bound-                ]-        assertBool "slightly smaller ok" (validateJSONSchema s (Number 0.12345678901234567889))-        assertBool "equal fails" (not $ validateJSONSchema s bound)-        assertBool "larger fails" (not $ validateJSONSchema s (Number 0.12345678901234567891))-    , testCase "multipleOf exact with rational" $ do-        let s = object ["type" .= ("number" :: Text), "multipleOf" .= (0.1 :: Double)]-        assertBool "0.3 ok" (validateJSONSchema s (Number 0.3))-        assertBool "0.31 not ok" (not $ validateJSONSchema s (Number 0.31))-    , -- array: minItems/maxItems/uniqueItems/contains/minContains/maxContains-      testCase "array min/max items" $ do-        let s = object ["type" .= ("array" :: Text), "minItems" .= (1 :: Int), "maxItems" .= (2 :: Int)]-        assertBool "[1] ok" (validateJSONSchema s (toJSON ([1 :: Int] :: [Int])))-        assertBool "[] not ok" (not $ validateJSONSchema s (toJSON ([] :: [Int])))-        assertBool "[1,2,3] not ok" (not $ validateJSONSchema s (toJSON ([1 :: Int, 2, 3] :: [Int])))-    , testCase "uniqueItems deep equality" $ do-        let s = object ["type" .= ("array" :: Text), "uniqueItems" .= True]-        assertBool-          "unique ok"-          (validateJSONSchema s (toJSON ([object ["a" .= (1 :: Int)], object ["a" .= (2 :: Int)]] :: [Value])))-        assertBool-          "duplicate not ok"-          (not $ validateJSONSchema s (toJSON ([object ["a" .= (1 :: Int)], object ["a" .= (1 :: Int)]] :: [Value])))-    , testCase "contains with min/maxContains" $ do-        let s =-              object-                [ "type" .= ("array" :: Text)-                , "contains" .= object ["type" .= ("integer" :: Text)]-                , "minContains" .= (2 :: Int)-                , "maxContains" .= (3 :: Int)-                ]-        assertBool "two ints ok" (validateJSONSchema s (toJSON ([Number 1, String "x", Number 2] :: [Value])))-        assertBool "one int not ok" (not $ validateJSONSchema s (toJSON ([Number 1, String "x"] :: [Value])))-        assertBool "four ints not ok" (not $ validateJSONSchema s (toJSON ([1 :: Int, 2, 3, 4] :: [Int])))-    , testCase "contains=false forbids any matches by minContains default" $ do-        let s = object ["type" .= ("array" :: Text), "contains" .= False]-        assertBool "[] not ok (minContains defaults to 1)" (not $ validateJSONSchema s (toJSON ([] :: [Int])))-        -- default minContains is 1 when contains is present, so any match is impossible-        assertBool "[1] not ok" (not $ validateJSONSchema s (toJSON ([1 :: Int] :: [Int])))-    , testCase "unevaluatedItems=false forbids trailing items not covered by prefix/items" $ do-        let s =-              object-                [ "type" .= ("array" :: Text)-                , "prefixItems" .= toJSON ([object ["type" .= ("integer" :: Text)]] :: [Value])-                , "unevaluatedItems" .= False-                ]-        assertBool "[1] ok" (validateJSONSchema s (toJSON ([1 :: Int] :: [Int])))-        assertBool "[1, \"x\"] not ok" (not $ validateJSONSchema s (toJSON ([Number 1, String "x"] :: [Value])))-    , -- object: required/properties/patternProperties/additionalProperties/propertyNames/min/max props-      testCase "required properties enforced" $ do-        let s =-              object-                [ "type" .= ("object" :: Text)-                , "properties" .= object ["a" .= object ["type" .= ("integer" :: Text)]]-                , "required" .= (["a"] :: [Text])-                ]-        assertBool "present ok" (validateJSONSchema s (object ["a" .= (1 :: Int)]))-        assertBool "missing not ok" (not $ validateJSONSchema s (object []))-    , testCase "patternProperties match" $ do-        let s =-              object-                [ "type" .= ("object" :: Text)-                , "patternProperties" .= object ["^x-" .= object ["type" .= ("string" :: Text)]]-                ]-        assertBool "x-foo ok" (validateJSONSchema s (object ["x-foo" .= ("bar" :: Text)]))-        assertBool "x-foo wrong type" (not $ validateJSONSchema s (object ["x-foo" .= (1 :: Int)]))-    , testCase "additionalProperties schema applies to extras" $ do-        let s =-              object-                [ "type" .= ("object" :: Text)-                , "properties" .= object ["a" .= object ["type" .= ("integer" :: Text)]]-                , "additionalProperties" .= object ["type" .= ("string" :: Text)]-                ]-        assertBool "extra string ok" (validateJSONSchema s (object ["a" .= (1 :: Int), "b" .= ("x" :: Text)]))-        assertBool "extra int not ok" (not $ validateJSONSchema s (object ["a" .= (1 :: Int), "b" .= (2 :: Int)]))-    , testCase "unevaluatedProperties=false forbids extras not covered by props/patterns" $ do-        let s =-              object-                [ "type" .= ("object" :: Text)-                , "properties" .= object ["a" .= object []]-                , "unevaluatedProperties" .= False-                ]-        assertBool "only a ok" (validateJSONSchema s (object ["a" .= (1 :: Int)]))-        assertBool "extra b not ok" (not $ validateJSONSchema s (object ["a" .= (1 :: Int), "b" .= (2 :: Int)]))-    , testCase "local $ref into $defs resolves and validates" $ do-        let s =-              object-                [ "$defs" .= object ["posInt" .= object ["type" .= ("integer" :: Text), "minimum" .= (0 :: Int)]]-                , "type" .= ("object" :: Text)-                , "properties" .= object ["age" .= object ["$ref" .= ("#/$defs/posInt" :: Text)]]-                , "required" .= (["age"] :: [Text])-                ]-        assertBool "age=5 ok" (validateJSONSchema s (object ["age" .= (5 :: Int)]))-        assertBool "age=-1 not ok" (not $ validateJSONSchema s (object ["age" .= (-1 :: Int)]))-    , testCase "unevaluatedItems with contains marks matches as evaluated; remainder must satisfy schema" $ do-        let s =-              object-                [ "type" .= ("array" :: Text)-                , "contains" .= object ["type" .= ("integer" :: Text)]-                , "minContains" .= (1 :: Int)-                , "unevaluatedItems" .= object ["type" .= ("string" :: Text)]-                ]-        assertBool "[1, \"x\", \"y\"] ok" (validateJSONSchema s (toJSON ([Number 1, String "x", String "y"] :: [Value])))-        assertBool-          "[1, false] not ok (false not string)"-          (not $ validateJSONSchema s (toJSON ([Number 1, Bool False] :: [Value])))-    , testCase "propertyNames constraint" $ do-        let s = object ["type" .= ("object" :: Text), "propertyNames" .= object ["pattern" .= ("^[a-z]+$" :: Text)]]-        assertBool "lowercase key ok" (validateJSONSchema s (object ["abc" .= (1 :: Int)]))-        assertBool "uppercase key not ok" (not $ validateJSONSchema s (object ["Abc" .= (1 :: Int)]))-    , testCase "min/max properties" $ do-        let s = object ["type" .= ("object" :: Text), "minProperties" .= (1 :: Int), "maxProperties" .= (2 :: Int)]-        assertBool "one ok" (validateJSONSchema s (object ["a" .= (1 :: Int)]))-        assertBool "none not ok" (not $ validateJSONSchema s (object []))-        assertBool-          "three not ok"-          (not $ validateJSONSchema s (object ["a" .= (1 :: Int), "b" .= (2 :: Int), "c" .= (3 :: Int)]))-    , -- dependentRequired / dependentSchemas-      testCase "dependentRequired enforces required when key present" $ do-        let s =-              object-                [ "type" .= ("object" :: Text)-                , "dependentRequired" .= object ["credit_card" .= (["billing_address"] :: [Text])]-                ]-        assertBool "missing credit_card ok" (validateJSONSchema s (object ["name" .= ("Bob" :: Text)]))-        assertBool "present without dependency not ok" (not $ validateJSONSchema s (object ["credit_card" .= ("123" :: Text)]))-        assertBool-          "present with dependency ok"-          (validateJSONSchema s (object ["credit_card" .= ("123" :: Text), "billing_address" .= ("A" :: Text)]))-    , testCase "dependentSchemas applies object schema when key present" $ do-        let dep = object ["properties" .= object ["a" .= object ["const" .= (1 :: Int)]], "required" .= (["a"] :: [Text])]-            s = object ["type" .= ("object" :: Text), "dependentSchemas" .= object ["flag" .= dep]]-        assertBool "no flag ok" (validateJSONSchema s (object ["a" .= (2 :: Int)]))-        assertBool "flag requires a=1" (validateJSONSchema s (object ["flag" .= True, "a" .= (1 :: Int)]))-        assertBool "flag with wrong a not ok" (not $ validateJSONSchema s (object ["flag" .= True, "a" .= (2 :: Int)]))-    , -- combinators-      testCase "anyOf passes if any schema matches" $ do-        let s = object ["anyOf" .= ([object ["type" .= ("string" :: Text)], object ["type" .= ("integer" :: Text)]] :: [Value])]-        assertBool "int ok" (validateJSONSchema s (Number 3))-    , testCase "oneOf exactly one" $ do-        let s = object ["oneOf" .= ([object ["type" .= ("number" :: Text)], object ["minimum" .= (0 :: Int)]] :: [Value])]-        -- number 3 matches both type=number and minimum=0; should fail-        assertBool "matches both not ok" (not $ validateJSONSchema s (Number 3))-    , testCase "allOf accumulates constraints" $ do-        let s = object ["allOf" .= ([object ["type" .= ("number" :: Text)], object ["maximum" .= (5 :: Int)]] :: [Value])]-        assertBool "6 not ok" (not $ validateJSONSchema s (Number 6))-    , testCase "not inverts" $ do-        let s = object ["not" .= object ["type" .= ("null" :: Text)]]-        assertBool "null not ok" (not $ validateJSONSchema s Null)-    , -- conditionals if/then/else-      testCase "if/then/else branching" $ do-        let s =-              object-                [ "if" .= object ["properties" .= object ["a" .= object ["const" .= True]]]-                , "then" .= object ["required" .= (["b"] :: [Text])]-                , "else" .= object ["required" .= (["c"] :: [Text])]-                ]-        assertBool "a=true requires b" (not $ validateJSONSchema s (object ["a" .= True]))-        assertBool "a=false requires c" (not $ validateJSONSchema s (object ["a" .= False]))-    , -- format and content keywords are annotations in 2020-12: do not assert by default-      testCase "format does not assert by default" $ do-        let s = object ["type" .= ("string" :: Text), "format" .= ("email" :: Text)]-        assertBool "non-email still valid (annotation only)" (validateJSONSchema s (String "not-an-email"))-    , testCase "content keywords are annotations only" $ do-        let s =-              object-                [ "type" .= ("string" :: Text)-                , "contentEncoding" .= ("base64" :: Text)-                , "contentMediaType" .= ("image/png" :: Text)-                ]-        -- we do not auto-decode/validate: annotation only-        assertBool "arbitrary string still valid" (validateJSONSchema s (String "@@not-base64@@"))-    ]--deriveWorks :: TestTree-deriveWorks =-  testGroup-    "Derive Works (Aeson JSON validates against derived schema)"-    [ testCase "Person record encodes and validates" $ do-        let schema = toJSONSchema (Proxy :: Proxy Person)-            jPerson = toJSON (Person "Bob" 42)-        assertBool "Person JSON should validate against derived schema" (validateJSONSchema schema jPerson)-        assertBool "Person schema should reject missing fields" (not $ validateJSONSchema schema (object []))-    , testCase "Shape sum (non-record) constructors validate" $ do-        let schema = toJSONSchema (Proxy :: Proxy Shape)-            j1 = toJSON (Circle 1.5)-            j2 = toJSON (Rectangle 2.3 4.5)-        assertBool "Circle JSON should validate" (validateJSONSchema schema j1)-        assertBool "Rectangle JSON should validate" (validateJSONSchema schema j2)-    , testCase "Animal sum (record) constructors validate" $ do-        let schema = toJSONSchema (Proxy :: Proxy Animal)-            j1 = toJSON (Dog "Fido" 5)-            j2 = toJSON (Cat "Whiskers")-        assertBool "Dog JSON should validate" (validateJSONSchema schema j1)-        assertBool "Cat JSON should validate" (validateJSONSchema schema j2)-        assertBool "Dog schema should reject missing required fields"-          (not $-            validateJSONSchema schema-              (object ["tag" .= ("Dog" :: Text)])-          )-        assertBool "Dog schema should reject missing tag"-          (not $-            validateJSONSchema schema-              (object ["dogName" .= ("Fido" :: Text), "dogAge" .= (5 :: Int)])-          )-    , testCase "Triple non-record product flattens and validates" $ do-        let schema = toJSONSchema (Proxy :: Proxy Triple)-            jTriple = toJSON (Triple 1 "a" True)-        assertBool "Triple JSON should validate" (validateJSONSchema schema jTriple)-    , testCase "Maybe and list instances validate via derived schema" $ do-        let maybeSchema = toJSONSchema (Proxy :: Proxy (Maybe Int))-            listSchema = toJSONSchema (Proxy :: Proxy [Text])-        assertBool "Just Int validates" (validateJSONSchema maybeSchema (toJSON (Just (3 :: Int))))-        assertBool "Nothing validates" (validateJSONSchema maybeSchema Null)-        assertBool "[Text] validates" (validateJSONSchema listSchema (toJSON (["x", "y"] :: [Text])))-    , testCase "Either schema enforces discriminator semantics" $ do-        let schema = toJSONSchema (Proxy :: Proxy (Either Int Text))-            leftVal = toJSON (Left (3 :: Int) :: Either Int Text)-            rightVal = toJSON (Right ("hi" :: Text) :: Either Int Text)-            emptyObj = object []-            bothObj =-              object-                [ "Left" .= (1 :: Int)-                , "Right" .= ("oops" :: Text)-                ]-        assertBool "Left JSON should validate" (validateJSONSchema schema leftVal)-        assertBool "Right JSON should validate" (validateJSONSchema schema rightVal)-        assertBool "Empty object should be rejected" (not $ validateJSONSchema schema emptyObj)-        assertBool "Object with both constructors should be rejected" (not $ validateJSONSchema schema bothObj)-    ]--schemaRecursiveWorks :: TestTree-schemaRecursiveWorks =-  testGroup-    "ToJSONSchema Works (recursive type emits $ref)"-    [ testCase "Derived schema uses $defs and $ref for recursion" $ do-        let s = toJSONSchema (Proxy :: Proxy RTree)-        -- Top-level must be an object with $defs (and ideally $ref)-        case s of-          Object km -> do-            -- \$defs contains RTree definition, and its Node constructor contains $ref back-            case km KM.!? "$defs" of-              Just (Object defs) -> case defs KM.!? fromString "RTree" of-                Just (Object rtreeDef) -> do-                  -- look for 'anyOf' containing Node/Leaf. In Node path, ensure children $ref-                  case rtreeDef KM.!? fromString "anyOf" of-                    Just (Array alts) -> do-                      -- At least one alternative should be the tagged Node object with contents array-                      let hasRefBack =-                            V.any-                              ( \v -> case v of-                                  Object km2 -> case km2 KM.!? fromString "properties" of-                                    Just (Object props) -> case props KM.!? fromString "contents" of-                                      Just (Object cont) -> case cont KM.!? fromString "prefixItems" of-                                        Just (Array pfi) ->-                                          V.all-                                            ( \piV -> case piV of-                                                Object o -> case o KM.!? fromString "$ref" of-                                                  Just (String r) -> r == "#/$defs/RTree"-                                                  _ -> False-                                                _ -> False-                                            )-                                            pfi-                                        _ -> False-                                      _ -> False-                                    _ -> False-                                  _ -> False-                              )-                              alts-                      assertBool "Node contents references back to RTree via $ref" hasRefBack-                    _ -> assertFailure "RTree def missing anyOf"-                _ -> assertFailure "$defs.RTree missing"-              _ -> assertFailure "$defs missing"-          _ -> assertFailure "Top-level schema should be object"-    , testCase "Recursive value validates against derived schema" $ do-        let s = toJSONSchema (Proxy :: Proxy RTree)-            j = toJSON (Node (Leaf 1) (Leaf 2))-        assertBool "recursive value should validate" (validateJSONSchema s j)+import Data.JSON.JSONSchema+import Data.String (fromString)+import Data.Text (Text)+import Data.Vector (fromList)+import Data.Vector qualified as V+import GHC.Generics (Generic)+import Test.Tasty+import Test.Tasty.HUnit++-- Simple product type (record)+data Person = Person+    { name :: Text+    , age :: Int+    }+    deriving (Show, Eq, Generic)++instance ToJSON Person++instance ToJSONSchema Person++-- Sum type with non-record and product constructors+data Shape+    = Circle Double+    | Rectangle Double Double+    deriving (Show, Eq, Generic)++instance ToJSON Shape++instance ToJSONSchema Shape++-- Sum type with record constructors (tests tagged record encoding)+data Animal+    = Dog {dogName :: Text, dogAge :: Int}+    | Cat {catName :: Text}+    deriving (Show, Eq, Generic)++instance ToJSON Animal++instance ToJSONSchema Animal++-- Non-record product with 3 fields (tests prefixItems flattening)+data Triple = Triple Int Text Bool+    deriving (Show, Eq, Generic)++instance ToJSON Triple++instance ToJSONSchema Triple++-- Recursive non-record sum type for ToJSON encoding test+data RTree+    = Leaf Int+    | Node RTree RTree+    deriving (Show, Eq, Generic)++instance ToJSON RTree++instance ToJSONSchema RTree++tests :: TestTree+tests =+    testGroup+        "JSON Schema"+        [ validationWorks+        , validationSpecCoverage+        , deriveWorks+        , schemaRecursiveWorks+        , valueDirectedWorks+        ]++validationWorks :: TestTree+validationWorks =+    testGroup+        "Validation Works"+        [ testCase "Valid object with required properties" $ do+            let schema =+                    object+                        [ "type" .= ("object" :: Text)+                        , "properties"+                            .= object+                                [ "name" .= object ["type" .= ("string" :: Text)]+                                , "age" .= object ["type" .= ("integer" :: Text)]+                                ]+                        , "required" .= (["name", "age"] :: [Text])+                        , "additionalProperties" .= False+                        ]+                value = object ["name" .= ("Alice" :: Text), "age" .= (30 :: Int)]+            assertBool "Expected valid JSON for schema" (validateJSONSchema schema value)+        , testCase "Missing required property fails" $ do+            let schema =+                    object+                        [ "type" .= ("object" :: Text)+                        , "properties"+                            .= object+                                [ "name" .= object ["type" .= ("string" :: Text)]+                                , "age" .= object ["type" .= ("integer" :: Text)]+                                ]+                        , "required" .= (["name", "age"] :: [Text])+                        , "additionalProperties" .= False+                        ]+                value = object ["name" .= ("Alice" :: Text)]+            assertBool "Expected invalid JSON for schema" (not $ validateJSONSchema schema value)+        , testCase "Wrong type fails" $ do+            let schema =+                    object+                        [ "type" .= ("object" :: Text)+                        , "properties"+                            .= object+                                [ "name" .= object ["type" .= ("string" :: Text)]+                                , "age" .= object ["type" .= ("integer" :: Text)]+                                ]+                        , "required" .= (["name", "age"] :: [Text])+                        , "additionalProperties" .= False+                        ]+                value = object ["name" .= ("Alice" :: Text), "age" .= ("30" :: Text)]+            assertBool "Expected invalid JSON for schema" (not $ validateJSONSchema schema value)+        , testCase "Additional property rejected when additionalProperties=false" $ do+            let schema =+                    object+                        [ "type" .= ("object" :: Text)+                        , "properties"+                            .= object+                                [ "name" .= object ["type" .= ("string" :: Text)]+                                , "age" .= object ["type" .= ("integer" :: Text)]+                                ]+                        , "required" .= (["name", "age"] :: [Text])+                        , "additionalProperties" .= False+                        ]+                value = object ["name" .= ("Alice" :: Text), "age" .= (30 :: Int), "extra" .= (True :: Bool)]+            assertBool "Expected invalid JSON for schema" (not $ validateJSONSchema schema value)+        , testCase "items=false with no prefixItems forbids any items" $ do+            let schema = object ["type" .= ("array" :: Text), "items" .= False]+            assertBool "[] should validate" (validateJSONSchema schema (Array mempty))+            assertBool "[1] should not validate" (not $ validateJSONSchema schema (toJSON ([1 :: Int] :: [Int])))+        , testCase "items applies only to items after prefixItems" $ do+            let schema =+                    object+                        [ "type" .= ("array" :: Text)+                        , "prefixItems" .= [object ["type" .= ("integer" :: Text)]]+                        , "items" .= object ["type" .= ("string" :: Text)]+                        ]+                j1 = toJSON ([1 :: Int] :: [Int])+                j2 = Array (fromList [Number 1, String "x"])+                j3 = toJSON ([1 :: Int, 2] :: [Int])+            assertBool "[1] valid (no rest)" (validateJSONSchema schema j1)+            assertBool "[1, \"x\"] valid (rest string)" (validateJSONSchema schema j2)+            assertBool "[1, 2] invalid (rest not string)" (not $ validateJSONSchema schema j3)+        , testCase "detailed-error API is reachable via the umbrella (#1)" $ do+            let schema = object ["type" .= ("integer" :: Text)]+            assertBool "validateWithErrors reports a violation" (not (null (validateWithErrors schema (String "x"))))+            case validate schema (String "x") of+                Left (ValidationError _ _ : _) -> pure ()+                Left [] -> assertFailure "expected at least one ValidationError"+                Right () -> assertFailure "expected validation to fail"+        ]++-- A comprehensive set of tests covering the 2020-12 validation vocabulary+validationSpecCoverage :: TestTree+validationSpecCoverage =+    testGroup+        "Validation Spec Coverage"+        [ -- type+          testCase "type: integer vs number" $ do+            let sInt = object ["type" .= ("integer" :: Text)]+            assertBool "3 integer" (validateJSONSchema sInt (Number 3))+            assertBool "3.5 not integer" (not $ validateJSONSchema sInt (Number 3.5))+        , testCase "type: array of types" $ do+            let s = object ["type" .= (["string", "null"] :: [Text])]+            assertBool "string ok" (validateJSONSchema s (String "x"))+            assertBool "null ok" (validateJSONSchema s Null)+            assertBool "bool not ok" (not $ validateJSONSchema s (Bool True))+        , -- const, enum+          testCase "const exact match" $ do+            let s = object ["const" .= object ["a" .= (1 :: Int)]]+            assertBool "match" (validateJSONSchema s (object ["a" .= (1 :: Int)]))+            assertBool "no match" (not $ validateJSONSchema s (object ["a" .= (2 :: Int)]))+        , testCase "enum membership" $ do+            let s = object ["enum" .= ([String "a", String "b"] :: [Value])]+            assertBool "a ok" (validateJSONSchema s (String "a"))+            assertBool "c not ok" (not $ validateJSONSchema s (String "c"))+        , -- string: minLength, maxLength, pattern+          testCase "string length counts code points" $ do+            let s = object ["type" .= ("string" :: Text), "minLength" .= (1 :: Int), "maxLength" .= (1 :: Int)]+            assertBool "emoji single code point ok" (validateJSONSchema s (String "😊"))+        , testCase "string pattern" $ do+            let s = object ["type" .= ("string" :: Text), "pattern" .= ("^[a-z]+$" :: Text)]+            assertBool "lowercase ok" (validateJSONSchema s (String "abc"))+            assertBool "uppercase not ok" (not $ validateJSONSchema s (String "Abc"))+        , -- number: minimum/maximum/exclusive*/multipleOf+          testCase "number bounds inclusive/exclusive" $ do+            let s =+                    object+                        [ "type" .= ("number" :: Text)+                        , "minimum" .= (1 :: Int)+                        , "exclusiveMaximum" .= (3 :: Int)+                        ]+            assertBool "1 ok" (validateJSONSchema s (Number 1))+            assertBool "2.9 ok" (validateJSONSchema s (Number 2.9))+            assertBool "3 not ok" (not $ validateJSONSchema s (Number 3))+        , testCase "minimum respects large integers" $ do+            let s =+                    object+                        [ "type" .= ("integer" :: Text)+                        , "minimum" .= Number 9007199254740993+                        ]+            assertBool "just below fails" (not $ validateJSONSchema s (Number 9007199254740992))+            assertBool "threshold passes" (validateJSONSchema s (Number 9007199254740993))+        , testCase "exclusiveMaximum handles high precision decimals" $ do+            let bound = Number 0.12345678901234567890+                s =+                    object+                        [ "type" .= ("number" :: Text)+                        , "exclusiveMaximum" .= bound+                        ]+            assertBool "slightly smaller ok" (validateJSONSchema s (Number 0.12345678901234567889))+            assertBool "equal fails" (not $ validateJSONSchema s bound)+            assertBool "larger fails" (not $ validateJSONSchema s (Number 0.12345678901234567891))+        , testCase "multipleOf exact with rational" $ do+            let s = object ["type" .= ("number" :: Text), "multipleOf" .= (0.1 :: Double)]+            assertBool "0.3 ok" (validateJSONSchema s (Number 0.3))+            assertBool "0.31 not ok" (not $ validateJSONSchema s (Number 0.31))+        , -- array: minItems/maxItems/uniqueItems/contains/minContains/maxContains+          testCase "array min/max items" $ do+            let s = object ["type" .= ("array" :: Text), "minItems" .= (1 :: Int), "maxItems" .= (2 :: Int)]+            assertBool "[1] ok" (validateJSONSchema s (toJSON ([1 :: Int] :: [Int])))+            assertBool "[] not ok" (not $ validateJSONSchema s (toJSON ([] :: [Int])))+            assertBool "[1,2,3] not ok" (not $ validateJSONSchema s (toJSON ([1 :: Int, 2, 3] :: [Int])))+        , testCase "uniqueItems deep equality" $ do+            let s = object ["type" .= ("array" :: Text), "uniqueItems" .= True]+            assertBool+                "unique ok"+                (validateJSONSchema s (toJSON ([object ["a" .= (1 :: Int)], object ["a" .= (2 :: Int)]] :: [Value])))+            assertBool+                "duplicate not ok"+                (not $ validateJSONSchema s (toJSON ([object ["a" .= (1 :: Int)], object ["a" .= (1 :: Int)]] :: [Value])))+        , testCase "contains with min/maxContains" $ do+            let s =+                    object+                        [ "type" .= ("array" :: Text)+                        , "contains" .= object ["type" .= ("integer" :: Text)]+                        , "minContains" .= (2 :: Int)+                        , "maxContains" .= (3 :: Int)+                        ]+            assertBool "two ints ok" (validateJSONSchema s (toJSON ([Number 1, String "x", Number 2] :: [Value])))+            assertBool "one int not ok" (not $ validateJSONSchema s (toJSON ([Number 1, String "x"] :: [Value])))+            assertBool "four ints not ok" (not $ validateJSONSchema s (toJSON ([1 :: Int, 2, 3, 4] :: [Int])))+        , testCase "contains=false forbids any matches by minContains default" $ do+            let s = object ["type" .= ("array" :: Text), "contains" .= False]+            assertBool "[] not ok (minContains defaults to 1)" (not $ validateJSONSchema s (toJSON ([] :: [Int])))+            -- default minContains is 1 when contains is present, so any match is impossible+            assertBool "[1] not ok" (not $ validateJSONSchema s (toJSON ([1 :: Int] :: [Int])))+        , testCase "unevaluatedItems=false forbids trailing items not covered by prefix/items" $ do+            let s =+                    object+                        [ "type" .= ("array" :: Text)+                        , "prefixItems" .= toJSON ([object ["type" .= ("integer" :: Text)]] :: [Value])+                        , "unevaluatedItems" .= False+                        ]+            assertBool "[1] ok" (validateJSONSchema s (toJSON ([1 :: Int] :: [Int])))+            assertBool "[1, \"x\"] not ok" (not $ validateJSONSchema s (toJSON ([Number 1, String "x"] :: [Value])))+        , -- object: required/properties/patternProperties/additionalProperties/propertyNames/min/max props+          testCase "required properties enforced" $ do+            let s =+                    object+                        [ "type" .= ("object" :: Text)+                        , "properties" .= object ["a" .= object ["type" .= ("integer" :: Text)]]+                        , "required" .= (["a"] :: [Text])+                        ]+            assertBool "present ok" (validateJSONSchema s (object ["a" .= (1 :: Int)]))+            assertBool "missing not ok" (not $ validateJSONSchema s (object []))+        , testCase "patternProperties match" $ do+            let s =+                    object+                        [ "type" .= ("object" :: Text)+                        , "patternProperties" .= object ["^x-" .= object ["type" .= ("string" :: Text)]]+                        ]+            assertBool "x-foo ok" (validateJSONSchema s (object ["x-foo" .= ("bar" :: Text)]))+            assertBool "x-foo wrong type" (not $ validateJSONSchema s (object ["x-foo" .= (1 :: Int)]))+        , testCase "additionalProperties schema applies to extras" $ do+            let s =+                    object+                        [ "type" .= ("object" :: Text)+                        , "properties" .= object ["a" .= object ["type" .= ("integer" :: Text)]]+                        , "additionalProperties" .= object ["type" .= ("string" :: Text)]+                        ]+            assertBool "extra string ok" (validateJSONSchema s (object ["a" .= (1 :: Int), "b" .= ("x" :: Text)]))+            assertBool "extra int not ok" (not $ validateJSONSchema s (object ["a" .= (1 :: Int), "b" .= (2 :: Int)]))+        , testCase "unevaluatedProperties=false forbids extras not covered by props/patterns" $ do+            let s =+                    object+                        [ "type" .= ("object" :: Text)+                        , "properties" .= object ["a" .= object []]+                        , "unevaluatedProperties" .= False+                        ]+            assertBool "only a ok" (validateJSONSchema s (object ["a" .= (1 :: Int)]))+            assertBool "extra b not ok" (not $ validateJSONSchema s (object ["a" .= (1 :: Int), "b" .= (2 :: Int)]))+        , testCase "local $ref into $defs resolves and validates" $ do+            let s =+                    object+                        [ "$defs" .= object ["posInt" .= object ["type" .= ("integer" :: Text), "minimum" .= (0 :: Int)]]+                        , "type" .= ("object" :: Text)+                        , "properties" .= object ["age" .= object ["$ref" .= ("#/$defs/posInt" :: Text)]]+                        , "required" .= (["age"] :: [Text])+                        ]+            assertBool "age=5 ok" (validateJSONSchema s (object ["age" .= (5 :: Int)]))+            assertBool "age=-1 not ok" (not $ validateJSONSchema s (object ["age" .= (-1 :: Int)]))+        , testCase "unevaluatedItems with contains marks matches as evaluated; remainder must satisfy schema" $ do+            let s =+                    object+                        [ "type" .= ("array" :: Text)+                        , "contains" .= object ["type" .= ("integer" :: Text)]+                        , "minContains" .= (1 :: Int)+                        , "unevaluatedItems" .= object ["type" .= ("string" :: Text)]+                        ]+            assertBool "[1, \"x\", \"y\"] ok" (validateJSONSchema s (toJSON ([Number 1, String "x", String "y"] :: [Value])))+            assertBool+                "[1, false] not ok (false not string)"+                (not $ validateJSONSchema s (toJSON ([Number 1, Bool False] :: [Value])))+        , testCase "propertyNames constraint" $ do+            let s = object ["type" .= ("object" :: Text), "propertyNames" .= object ["pattern" .= ("^[a-z]+$" :: Text)]]+            assertBool "lowercase key ok" (validateJSONSchema s (object ["abc" .= (1 :: Int)]))+            assertBool "uppercase key not ok" (not $ validateJSONSchema s (object ["Abc" .= (1 :: Int)]))+        , testCase "min/max properties" $ do+            let s = object ["type" .= ("object" :: Text), "minProperties" .= (1 :: Int), "maxProperties" .= (2 :: Int)]+            assertBool "one ok" (validateJSONSchema s (object ["a" .= (1 :: Int)]))+            assertBool "none not ok" (not $ validateJSONSchema s (object []))+            assertBool+                "three not ok"+                (not $ validateJSONSchema s (object ["a" .= (1 :: Int), "b" .= (2 :: Int), "c" .= (3 :: Int)]))+        , -- dependentRequired / dependentSchemas+          testCase "dependentRequired enforces required when key present" $ do+            let s =+                    object+                        [ "type" .= ("object" :: Text)+                        , "dependentRequired" .= object ["credit_card" .= (["billing_address"] :: [Text])]+                        ]+            assertBool "missing credit_card ok" (validateJSONSchema s (object ["name" .= ("Bob" :: Text)]))+            assertBool "present without dependency not ok" (not $ validateJSONSchema s (object ["credit_card" .= ("123" :: Text)]))+            assertBool+                "present with dependency ok"+                (validateJSONSchema s (object ["credit_card" .= ("123" :: Text), "billing_address" .= ("A" :: Text)]))+        , testCase "dependentSchemas applies object schema when key present" $ do+            let dep = object ["properties" .= object ["a" .= object ["const" .= (1 :: Int)]], "required" .= (["a"] :: [Text])]+                s = object ["type" .= ("object" :: Text), "dependentSchemas" .= object ["flag" .= dep]]+            assertBool "no flag ok" (validateJSONSchema s (object ["a" .= (2 :: Int)]))+            assertBool "flag requires a=1" (validateJSONSchema s (object ["flag" .= True, "a" .= (1 :: Int)]))+            assertBool "flag with wrong a not ok" (not $ validateJSONSchema s (object ["flag" .= True, "a" .= (2 :: Int)]))+        , -- combinators+          testCase "anyOf passes if any schema matches" $ do+            let s = object ["anyOf" .= ([object ["type" .= ("string" :: Text)], object ["type" .= ("integer" :: Text)]] :: [Value])]+            assertBool "int ok" (validateJSONSchema s (Number 3))+        , testCase "oneOf exactly one" $ do+            let s = object ["oneOf" .= ([object ["type" .= ("number" :: Text)], object ["minimum" .= (0 :: Int)]] :: [Value])]+            -- number 3 matches both type=number and minimum=0; should fail+            assertBool "matches both not ok" (not $ validateJSONSchema s (Number 3))+        , testCase "allOf accumulates constraints" $ do+            let s = object ["allOf" .= ([object ["type" .= ("number" :: Text)], object ["maximum" .= (5 :: Int)]] :: [Value])]+            assertBool "6 not ok" (not $ validateJSONSchema s (Number 6))+        , testCase "not inverts" $ do+            let s = object ["not" .= object ["type" .= ("null" :: Text)]]+            assertBool "null not ok" (not $ validateJSONSchema s Null)+        , -- conditionals if/then/else+          testCase "if/then/else branching" $ do+            let s =+                    object+                        [ "if" .= object ["properties" .= object ["a" .= object ["const" .= True]]]+                        , "then" .= object ["required" .= (["b"] :: [Text])]+                        , "else" .= object ["required" .= (["c"] :: [Text])]+                        ]+            assertBool "a=true requires b" (not $ validateJSONSchema s (object ["a" .= True]))+            assertBool "a=false requires c" (not $ validateJSONSchema s (object ["a" .= False]))+        , -- format and content keywords are annotations in 2020-12: do not assert by default+          testCase "format does not assert by default" $ do+            let s = object ["type" .= ("string" :: Text), "format" .= ("email" :: Text)]+            assertBool "non-email still valid (annotation only)" (validateJSONSchema s (String "not-an-email"))+        , testCase "content keywords are annotations only" $ do+            let s =+                    object+                        [ "type" .= ("string" :: Text)+                        , "contentEncoding" .= ("base64" :: Text)+                        , "contentMediaType" .= ("image/png" :: Text)+                        ]+            -- we do not auto-decode/validate: annotation only+            assertBool "arbitrary string still valid" (validateJSONSchema s (String "@@not-base64@@"))+        ]++deriveWorks :: TestTree+deriveWorks =+    testGroup+        "Derive Works (Aeson JSON validates against derived schema)"+        [ testCase "Person record encodes and validates" $ do+            let schema = toJSONSchema (Proxy :: Proxy Person)+                jPerson = toJSON (Person "Bob" 42)+            assertBool "Person JSON should validate against derived schema" (validateJSONSchema schema jPerson)+            assertBool "Person schema should reject missing fields" (not $ validateJSONSchema schema (object []))+        , testCase "Shape sum (non-record) constructors validate" $ do+            let schema = toJSONSchema (Proxy :: Proxy Shape)+                j1 = toJSON (Circle 1.5)+                j2 = toJSON (Rectangle 2.3 4.5)+            assertBool "Circle JSON should validate" (validateJSONSchema schema j1)+            assertBool "Rectangle JSON should validate" (validateJSONSchema schema j2)+        , testCase "Animal sum (record) constructors validate" $ do+            let schema = toJSONSchema (Proxy :: Proxy Animal)+                j1 = toJSON (Dog "Fido" 5)+                j2 = toJSON (Cat "Whiskers")+            assertBool "Dog JSON should validate" (validateJSONSchema schema j1)+            assertBool "Cat JSON should validate" (validateJSONSchema schema j2)+            assertBool+                "Dog schema should reject missing required fields"+                ( not $+                    validateJSONSchema+                        schema+                        (object ["tag" .= ("Dog" :: Text)])+                )+            assertBool+                "Dog schema should reject missing tag"+                ( not $+                    validateJSONSchema+                        schema+                        (object ["dogName" .= ("Fido" :: Text), "dogAge" .= (5 :: Int)])+                )+        , testCase "Triple non-record product flattens and validates" $ do+            let schema = toJSONSchema (Proxy :: Proxy Triple)+                jTriple = toJSON (Triple 1 "a" True)+            assertBool "Triple JSON should validate" (validateJSONSchema schema jTriple)+            -- The tuple length is pinned: a short array must be rejected.+            assertBool+                "short array rejected"+                (not (validateJSONSchema schema (Array (fromList [Number 1, String "a"]))))+        , testCase "Maybe and list instances validate via derived schema" $ do+            let maybeSchema = toJSONSchema (Proxy :: Proxy (Maybe Int))+                listSchema = toJSONSchema (Proxy :: Proxy [Text])+            assertBool "Just Int validates" (validateJSONSchema maybeSchema (toJSON (Just (3 :: Int))))+            assertBool "Nothing validates" (validateJSONSchema maybeSchema Null)+            assertBool "[Text] validates" (validateJSONSchema listSchema (toJSON (["x", "y"] :: [Text])))+        , testCase "Either schema enforces discriminator semantics" $ do+            let schema = toJSONSchema (Proxy :: Proxy (Either Int Text))+                leftVal = toJSON (Left (3 :: Int) :: Either Int Text)+                rightVal = toJSON (Right ("hi" :: Text) :: Either Int Text)+                emptyObj = object []+                bothObj =+                    object+                        [ "Left" .= (1 :: Int)+                        , "Right" .= ("oops" :: Text)+                        ]+            assertBool "Left JSON should validate" (validateJSONSchema schema leftVal)+            assertBool "Right JSON should validate" (validateJSONSchema schema rightVal)+            assertBool "Empty object should be rejected" (not $ validateJSONSchema schema emptyObj)+            assertBool "Object with both constructors should be rejected" (not $ validateJSONSchema schema bothObj)+        ]++schemaRecursiveWorks :: TestTree+schemaRecursiveWorks =+    testGroup+        "ToJSONSchema Works (recursive type emits $ref)"+        [ testCase "Derived schema uses $defs and $ref for recursion" $ do+            let s = toJSONSchema (Proxy :: Proxy RTree)+            -- Top-level must be an object with $defs (and ideally $ref)+            case s of+                Object km -> do+                    -- \$defs contains RTree definition, and its Node constructor contains $ref back+                    case km KM.!? "$defs" of+                        Just (Object defs) -> case defs KM.!? fromString "RTree" of+                            Just (Object rtreeDef) -> do+                                -- look for 'anyOf' containing Node/Leaf. In Node path, ensure children $ref+                                case rtreeDef KM.!? fromString "anyOf" of+                                    Just (Array alts) -> do+                                        -- At least one alternative should be the tagged Node object with contents array+                                        let hasRefBack =+                                                V.any+                                                    ( \v -> case v of+                                                        Object km2 -> case km2 KM.!? fromString "properties" of+                                                            Just (Object props) -> case props KM.!? fromString "contents" of+                                                                Just (Object cont) -> case cont KM.!? fromString "prefixItems" of+                                                                    Just (Array pfi) ->+                                                                        V.all+                                                                            ( \piV -> case piV of+                                                                                Object o -> case o KM.!? fromString "$ref" of+                                                                                    Just (String r) -> r == "#/$defs/RTree"+                                                                                    _ -> False+                                                                                _ -> False+                                                                            )+                                                                            pfi+                                                                    _ -> False+                                                                _ -> False+                                                            _ -> False+                                                        _ -> False+                                                    )+                                                    alts+                                        assertBool "Node contents references back to RTree via $ref" hasRefBack+                                    _ -> assertFailure "RTree def missing anyOf"+                            _ -> assertFailure "$defs.RTree missing"+                        _ -> assertFailure "$defs missing"+                _ -> assertFailure "Top-level schema should be object"+        , testCase "Recursive value validates against derived schema" $ do+            let s = toJSONSchema (Proxy :: Proxy RTree)+                j = toJSON (Node (Leaf 1) (Leaf 2))+            assertBool "recursive value should validate" (validateJSONSchema s j)+        ]++-- A document dogfooded by the generate-then-validate tests: a root object that+-- references a named, patterned $def and carries a required + an optional field.+sampleDoc :: SchemaDocument+sampleDoc =+    SchemaDocument+        { schemaDefs = [("Code", SString (Just "^[a-z]+$"))]+        , schemaRoot =+            SObject+                [ Field "code" True (SRef "Code")+                , Field "count" False SInteger+                ]+                APForbidden+        }++sampleSchema :: Value+sampleSchema = schemaDocumentToValue sampleDoc++{- | Value-directed construction: render with 'schemaToValue' /+'schemaDocumentToValue' and dogfood the result through the validator.+-}+valueDirectedWorks :: TestTree+valueDirectedWorks =+    testGroup+        "Value-directed construction"+        [ testGroup "Per-constructor rendering" perConstructorRendering+        , testGroup "Generate-then-validate" generateThenValidate+        , testGroup "Edge cases" valueDirectedEdgeCases+        ]++perConstructorRendering :: [TestTree]+perConstructorRendering =+    [ testCase "SNull" $ schemaToValue SNull @?= object ["type" .= ("null" :: Text)]+    , testCase "SBoolean" $ schemaToValue SBoolean @?= object ["type" .= ("boolean" :: Text)]+    , testCase "SInteger" $ schemaToValue SInteger @?= object ["type" .= ("integer" :: Text)]+    , testCase "SNumber" $ schemaToValue SNumber @?= object ["type" .= ("number" :: Text)]+    , testCase "SString Nothing" $+        schemaToValue (SString Nothing) @?= object ["type" .= ("string" :: Text)]+    , testCase "SString (Just pattern)" $+        schemaToValue (SString (Just "^[a-z]+$"))+            @?= object ["type" .= ("string" :: Text), "pattern" .= ("^[a-z]+$" :: Text)]+    , testCase "SConst" $+        schemaToValue (SConst (String "x")) @?= object ["const" .= ("x" :: Text)]+    , testCase "SEnum" $+        schemaToValue (SEnum [Number 1, Number 2]) @?= object ["enum" .= [Number 1, Number 2]]+    , testCase "SArray" $+        schemaToValue (SArray SInteger)+            @?= object ["type" .= ("array" :: Text), "items" .= integerSchema]+    , testCase "SArrayUnique" $+        schemaToValue (SArrayUnique SInteger)+            @?= object+                [ "type" .= ("array" :: Text)+                , "items" .= integerSchema+                , "uniqueItems" .= True+                ]+    , testCase "STuple pins length with minItems/maxItems" $+        schemaToValue (STuple [SInteger, SString Nothing])+            @?= object+                [ "type" .= ("array" :: Text)+                , "prefixItems" .= [integerSchema, object ["type" .= ("string" :: Text)]]+                , "items" .= False+                , "minItems" .= (2 :: Int)+                , "maxItems" .= (2 :: Int)+                ]+    , testCase "SObject omits required when none required" $+        schemaToValue (SObject [Field "x" False SInteger] APForbidden)+            @?= object+                [ "type" .= ("object" :: Text)+                , "properties" .= object ["x" .= integerSchema]+                , "additionalProperties" .= False+                ]+    , testCase "SObject lists required fields" $+        schemaToValue (SObject [Field "x" True SInteger] APForbidden)+            @?= object+                [ "type" .= ("object" :: Text)+                , "properties" .= object ["x" .= integerSchema]+                , "additionalProperties" .= False+                , "required" .= (["x"] :: [Text])+                ]+    , testCase "SObject APAllowed" $+        schemaToValue (SObject [] APAllowed)+            @?= object+                [ "type" .= ("object" :: Text)+                , "properties" .= object []+                , "additionalProperties" .= True+                ]+    , testCase "SObject APSchema (open map)" $+        schemaToValue (SObject [] (APSchema SInteger))+            @?= object+                [ "type" .= ("object" :: Text)+                , "properties" .= object []+                , "additionalProperties" .= integerSchema+                ]+    , testCase "SNullable" $+        schemaToValue (SNullable SInteger)+            @?= object ["anyOf" .= [integerSchema, object ["type" .= ("null" :: Text)]]]+    , testCase "SAnyOf" $+        schemaToValue (SAnyOf [SInteger, SBoolean])+            @?= object ["anyOf" .= [integerSchema, object ["type" .= ("boolean" :: Text)]]]+    , testCase "SAllOf" $+        schemaToValue (SAllOf [SInteger]) @?= object ["allOf" .= [integerSchema]]+    , testCase "SRef simple name" $+        schemaToValue (SRef "Foo") @?= object ["$ref" .= ("#/$defs/Foo" :: Text)]+    , testCase "SRef escapes JSON Pointer characters" $+        schemaToValue (SRef "a/b~c") @?= object ["$ref" .= ("#/$defs/a~1b~0c" :: Text)]+    , testCase "SAny" $ schemaToValue SAny @?= object []+    , testCase "SRaw renders the Value verbatim" $+        schemaToValue (SRaw (object ["type" .= ("string" :: Text), "minLength" .= (3 :: Int)]))+            @?= object ["type" .= ("string" :: Text), "minLength" .= (3 :: Int)]+    ]+  where+    integerSchema = object ["type" .= ("integer" :: Text)]++generateThenValidate :: [TestTree]+generateThenValidate =+    [ testCase "conforming instance validates" $+        assertBool "should be valid" $+            validateJSONSchema sampleSchema (object ["code" .= ("abc" :: Text), "count" .= (3 :: Int)])+    , testCase "optional field may be omitted" $+        assertBool "should be valid" $+            validateJSONSchema sampleSchema (object ["code" .= ("abc" :: Text)])+    , testCase "missing required field rejected" $+        assertBool "should be invalid" $+            not (validateJSONSchema sampleSchema (object ["count" .= (3 :: Int)]))+    , testCase "wrong type rejected" $+        assertBool "should be invalid" $+            not (validateJSONSchema sampleSchema (object ["code" .= (1 :: Int)]))+    , testCase "extra field rejected under additionalProperties:false" $+        assertBool "should be invalid" $+            not (validateJSONSchema sampleSchema (object ["code" .= ("abc" :: Text), "extra" .= True]))+    , testCase "off-pattern string rejected" $+        assertBool "should be invalid" $+            not (validateJSONSchema sampleSchema (object ["code" .= ("ABC" :: Text)]))+    , testCase "root-is-$ref document resolves" $ do+        let doc = SchemaDocument [("Code", SString (Just "^[a-z]+$"))] (SRef "Code")+            v = schemaDocumentToValue doc+        assertBool "conforming valid" (validateJSONSchema v (String "abc"))+        assertBool "off-pattern invalid" (not (validateJSONSchema v (String "ABC")))+    ]++valueDirectedEdgeCases :: [TestTree]+valueDirectedEdgeCases =+    [ testCase "SAnyOf [] rejects everything" $+        assertBool "should be invalid" $+            not (validateJSONSchema (schemaToValue (SAnyOf [])) (Number 1))+    , testCase "SAllOf [] accepts everything" $+        assertBool "should be valid" $+            validateJSONSchema (schemaToValue (SAllOf [])) (Number 1)+    , testCase "SEnum [] rejects everything" $+        assertBool "should be invalid" $+            not (validateJSONSchema (schemaToValue (SEnum [])) (Number 1))+    , testCase "STuple rejects short and long arrays" $ do+        let s = schemaToValue (STuple [SInteger, SString Nothing])+        assertBool "empty invalid" (not (validateJSONSchema s (Array (fromList []))))+        assertBool "short invalid" (not (validateJSONSchema s (Array (fromList [Number 1]))))+        assertBool "exact valid" (validateJSONSchema s (Array (fromList [Number 1, String "x"])))+        assertBool "long invalid" (not (validateJSONSchema s (Array (fromList [Number 1, String "x", Bool True]))))+    , testCase "SObject APSchema validates open-map values" $ do+        let s = schemaToValue (SObject [] (APSchema SInteger))+        assertBool "homogeneous ints valid" (validateJSONSchema s (object ["a" .= (1 :: Int), "b" .= (2 :: Int)]))+        assertBool "wrong value type invalid" (not (validateJSONSchema s (object ["a" .= ("x" :: Text)])))+    , testCase "SConst carrying a non-primitive Value" $ do+        let s = schemaToValue (SConst (object ["k" .= (1 :: Int)]))+        assertBool "structural match valid" (validateJSONSchema s (object ["k" .= (1 :: Int)]))+        assertBool "different object invalid" (not (validateJSONSchema s (object ["k" .= (2 :: Int)])))+    , testCase "SRef with escaped $defs name resolves" $ do+        let doc = SchemaDocument [("a/b~c", SInteger)] (SRef "a/b~c")+            v = schemaDocumentToValue doc+        assertBool "integer valid" (validateJSONSchema v (Number 1))+        assertBool "string invalid" (not (validateJSONSchema v (String "x")))+    , testCase "SRaw embeds an out-of-subset keyword inside a Schema" $ do+        -- minLength is not in the Schema vocabulary; SRaw splices it into a field.+        let s =+                schemaToValue+                    ( SObject+                        [Field "name" True (SRaw (object ["type" .= ("string" :: Text), "minLength" .= (3 :: Int)]))]+                        APForbidden+                    )+        assertBool "long enough valid" (validateJSONSchema s (object ["name" .= ("abcd" :: Text)]))+        assertBool "too short invalid" (not (validateJSONSchema s (object ["name" .= ("ab" :: Text)])))+    , testCase "SchemaDocument merges the header into an SRaw object root" $ do+        let v = schemaDocumentToValue (SchemaDocument [] (SRaw (object ["type" .= ("string" :: Text)])))+        case v of+            Object km -> do+                assertBool "$schema present" (KM.member "$schema" km)+                assertBool "root keys preserved" (KM.lookup "type" km == Just (String "string"))+            _ -> assertFailure "expected an object document"+    , testCase "SchemaDocument wraps a non-object SRaw root under allOf" $ do+        let v = schemaDocumentToValue (SchemaDocument [("X", SInteger)] (SRaw (Bool True)))+        case v of+            Object km -> do+                assertBool "$schema present" (KM.member "$schema" km)+                assertBool "$defs present" (KM.member "$defs" km)+                assertBool "allOf wrapper present" (KM.member "allOf" km)+            _ -> assertFailure "expected an object document"+        assertBool "allOf:[true] accepts anything" (validateJSONSchema v (Number 5))+    , testCase "SchemaDocument $defs win over an SRaw root's own $defs" $ do+        let rootWithDefs = SRaw (object ["$defs" .= object ["Y" .= object ["type" .= ("boolean" :: Text)]]])+            v = schemaDocumentToValue (SchemaDocument [("X", SInteger)] rootWithDefs)+        case v of+            Object km -> case KM.lookup "$defs" km of+                Just (Object defsKm) -> do+                    assertBool "document def X kept" (KM.member "X" defsKm)+                    assertBool "root def Y dropped" (not (KM.member "Y" defsKm))+                _ -> assertFailure "expected a $defs object"+            _ -> assertFailure "expected an object document"     ]

@@ -8,7 +8,7 @@  tests :: TestTree tests =-  testGroup-    "JSONSchema Tests"-    [ JSONSchema.tests-    ]+    testGroup+        "JSONSchema Tests"+        [ JSONSchema.tests+        ]