Schema.hs

{- |
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
import JSONSchema.URIFragment (encodeURIFragment)

{- | 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 and URI-fragment 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/" <> encodeURIFragment (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])]