Support for schemas with OpenAPI 3 validators

The new `Validator` associated type and `FleeceValidator` superclass
constraint on the `Fleece` class allow extensions to validation beyond
lifting Haskell functions.

I added a class called `OpenApi3Validator` to the `json-fleece-openapi3`
package that captures most of the OpenAPI 3 validations. `Fleece`
instances can implement the `OpenApi3Validator` class on their
associated `Validator` type to gain access to static information
associated with the validations.

The intent is that downstream users will leverage the additional
information to generate richer OpenAPI schemas based on their Fleece
schemas.

There is a new constraint called `FleeceOpenApi3` that includes the
`OpenApi3Validator` constraint on the `Fleece` instance's `Validator`.
It is exported by the `json-fleece-openapi3` package, along with
associated schemas that use the constraint.

The schemas serve as a drop-in replacement for those in
`Fleece.Core.Schemas`. They use the methods on `OpenApi3Validator` to
implement their validations.

I didn't add support for the `pattern` validation because I don't have
good sense of what regex library to use.

json-fleece-aeson-beeline/json-fleece-aeson-beeline.cabal

@@ -37,7 +37,7 @@ library
     , beeline-http-client >=0.2 && <0.9
     , bytestring ==0.11.*
     , http-client ==0.7.*
-    , json-fleece-aeson >=0.1 && <0.4
+    , json-fleece-aeson >=0.1 && <0.5
   default-language: Haskell2010
   if flag(strict)
     ghc-options: -Weverything -Werror -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-missing-kind-signatures -Wno-prepositive-qualified-module -Wno-implicit-prelude -Wno-safe -Wno-unsafe -Wno-missing-safe-haskell-mode -Wno-missing-deriving-strategies -Wno-all-missed-specialisations -Wno-missed-specialisations -Wno-unticked-promoted-constructors

json-fleece-aeson-beeline/package.yaml

@@ -49,10 +49,10 @@ when:
 library:
   source-dirs: src
   dependencies:
-    - json-fleece-aeson >= 0.1 && < 0.4
     - beeline-http-client >= 0.2 && < 0.9
     - bytestring >= 0.11 && < 0.12
     - http-client >= 0.7 && < 0.8
+    - json-fleece-aeson >= 0.1 && < 0.5
   exposed-modules:
     - Fleece.Aeson.Beeline
 

json-fleece-aeson/json-fleece-aeson.cabal

@@ -5,7 +5,7 @@ cabal-version: 1.12
 -- see: https://github.com/sol/hpack
 
 name:           json-fleece-aeson
-version:        0.3.5.0
+version:        0.4.0.0
 description:    Please see the README on GitHub at <https://github.com/githubuser/json-fleece-aeson#readme>
 homepage:       https://github.com/flipstone/json-fleece#readme
 bug-reports:    https://github.com/flipstone/json-fleece/issues
@@ -41,7 +41,8 @@ library
     , base >=4.7 && <5
     , bytestring ==0.11.*
     , containers ==0.6.*
-    , json-fleece-core ==0.7.*
+    , json-fleece-core ==0.8.*
+    , json-fleece-openapi3 ==0.5.*
     , shrubbery ==0.2.*
     , text >=1.2 && <2.1
     , vector >=0.12 && <0.14
@@ -66,7 +67,7 @@ test-suite json-fleece-aeson-test
     , containers ==0.6.*
     , hedgehog
     , json-fleece-aeson
-    , json-fleece-core ==0.7.*
+    , json-fleece-core ==0.8.*
     , json-fleece-examples
     , scientific >=0.3.7 && <0.4
     , shrubbery ==0.2.*

json-fleece-aeson/package.yaml

@@ -1,5 +1,5 @@
 name:                json-fleece-aeson
-version:             0.3.5.0
+version:             0.4.0.0
 github:              "flipstone/json-fleece/json-fleece-aeson"
 license:             BSD3
 author:              "Author name here"
@@ -16,14 +16,14 @@ copyright:           "2023 Author name here"
 description:         Please see the README on GitHub at <https://github.com/githubuser/json-fleece-aeson#readme>
 
 dependencies:
-- base >= 4.7 && < 5
 - aeson >= 2.0 && < 2.2
+- base >= 4.7 && < 5
 - bytestring >= 0.11 && < 0.12
 - containers >= 0.6 && < 0.7
-- json-fleece-core >= 0.7 && < 0.8
+- json-fleece-core >= 0.8 && < 0.9
+- shrubbery >= 0.2 && < 0.3
 - text >= 1.2 && < 2.1
 - vector >= 0.12 && < 0.14
-- shrubbery >= 0.2 && < 0.3
 
 flags:
   strict:
@@ -58,6 +58,8 @@ library:
     - Fleece.Aeson
     - Fleece.Aeson.Decoder
     - Fleece.Aeson.Encoder
+  dependencies:
+    - json-fleece-openapi3 >= 0.5 && < 0.6
 
 tests:
   json-fleece-aeson-test:

json-fleece-aeson/src/Fleece/Aeson/AnyJSON.hs

@@ -14,7 +14,7 @@ import qualified Fleece.Core as FC
 
 aesonValue :: FC.Fleece schema => schema Aeson.Value
 aesonValue =
-  FC.transform valueToAnyJSON anyJSONToValue FC.anyJSON
+  FC.validate (FC.transform valueToAnyJSON anyJSONToValue) FC.anyJSON
 
 anyJSONToValue :: FC.AnyJSON -> Aeson.Value
 anyJSONToValue =

json-fleece-aeson/src/Fleece/Aeson/Decoder.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE InstanceSigs #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -8,6 +9,7 @@
 
 module Fleece.Aeson.Decoder
   ( Decoder (..)
+  , FC.Validator (DecoderValidator)
   , decode
   , decodeStrict
   , fromValue
@@ -30,6 +32,7 @@ import Shrubbery (type (@=))
 import qualified Shrubbery
 
 import qualified Fleece.Core as FC
+import qualified Fleece.OpenApi3 as FleeceOpenApi3
 
 data Decoder a
   = Decoder FC.Name (Aeson.Value -> AesonTypes.Parser a)
@@ -71,6 +74,9 @@ instance FC.Fleece Decoder where
   newtype TaggedUnionMembers Decoder allTags _handledTags
     = TaggedUnionMembers (Map.Map T.Text (Aeson.Object -> AesonTypes.Parser (Shrubbery.TaggedUnion allTags)))
 
+  newtype Validator Decoder a b = DecoderValidator (FC.StandardValidator a b)
+    deriving (FC.FleeceValidator, FleeceOpenApi3.OpenApi3Validator)
+
   schemaName (Decoder name _parseValue) =
     name
 
@@ -172,10 +178,10 @@ instance FC.Fleece Decoder where
                   <> " enum: "
                   <> show textValue
 
-  validateNamed name _uncheck check (Decoder _unvalidatedName parseValue) =
+  validateNamed name validator (Decoder _unvalidatedName parseValue) =
     Decoder name $ \jsonValue -> do
       uncheckedValue <- parseValue jsonValue
-      case check uncheckedValue of
+      case FC.check validator uncheckedValue of
         Right checkedValue -> pure checkedValue
         Left err -> fail $ "Error validating " <> FC.nameToString name <> ": " <> err
 

json-fleece-aeson/src/Fleece/Aeson/Encoder.hs

@@ -1,4 +1,6 @@
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE InstanceSigs #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -8,6 +10,7 @@
 
 module Fleece.Aeson.Encoder
   ( Encoder (..)
+  , FC.Validator (EncoderValidator)
   , encode
   , encodeStrict
   ) where
@@ -28,6 +31,7 @@ import Shrubbery (type (@=))
 import qualified Shrubbery
 
 import qualified Fleece.Core as FC
+import qualified Fleece.OpenApi3 as FleeceOpenApi3
 
 data Encoder a
   = Encoder FC.Name (a -> Aeson.Encoding)
@@ -56,6 +60,9 @@ instance FC.Fleece Encoder where
   newtype TaggedUnionMembers Encoder _allTags handledTags
     = TaggedUnionMembers (Shrubbery.TaggedBranchBuilder handledTags (T.Text, Aeson.Series))
 
+  newtype Validator Encoder a b = EncoderValidator (FC.StandardValidator a b)
+    deriving (FC.FleeceValidator, FleeceOpenApi3.OpenApi3Validator)
+
   schemaName (Encoder name _toEncoding) =
     name
 
@@ -128,8 +135,8 @@ instance FC.Fleece Encoder where
   boundedEnumNamed name toText =
     Encoder name (Aeson.toEncoding . toText)
 
-  validateNamed name uncheck _check (Encoder _unvalidatedName toEncoding) =
-    Encoder name (toEncoding . uncheck)
+  validateNamed name validator (Encoder _unvalidatedName toEncoding) =
+    Encoder name (toEncoding . FC.uncheck validator)
 
   unionNamed name (UnionMembers builder) =
     let

json-fleece-aeson/src/Fleece/Aeson/EncoderDecoder.hs

@@ -1,12 +1,14 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE TypeFamilies #-}
 
 module Fleece.Aeson.EncoderDecoder
   ( EncoderDecoder (..)
   ) where
 
-import Fleece.Aeson.Decoder (Decoder)
-import Fleece.Aeson.Encoder (Encoder)
+import Fleece.Aeson.Decoder (Decoder, Validator (DecoderValidator))
+import Fleece.Aeson.Encoder (Encoder, Validator (EncoderValidator))
 import qualified Fleece.Core as FC
+import qualified Fleece.OpenApi3 as FleeceOpenApi3
 
 data EncoderDecoder a = EncoderDecoder
   { encoder :: Encoder a
@@ -39,6 +41,9 @@ instance FC.Fleece EncoderDecoder where
     , taggedUnionMembersDecoder :: FC.TaggedUnionMembers Decoder allTags handledTags
     }
 
+  newtype Validator EncoderDecoder a b = EncoderDecoderValidator (FC.StandardValidator a b)
+    deriving (FC.FleeceValidator, FleeceOpenApi3.OpenApi3Validator)
+
   schemaName = FC.schemaName . encoder
 
   number =
@@ -127,10 +132,10 @@ instance FC.Fleece EncoderDecoder where
           FC.additional (objectDecoder object) (additionalFieldsDecoder addFields)
       }
 
-  validateNamed name uncheck check itemEncoderDecoder =
+  validateNamed name (EncoderDecoderValidator validator) itemEncoderDecoder =
     EncoderDecoder
-      { encoder = FC.validateNamed name uncheck check $ encoder itemEncoderDecoder
-      , decoder = FC.validateNamed name uncheck check $ decoder itemEncoderDecoder
+      { encoder = FC.validateNamed name (EncoderValidator validator) $ encoder itemEncoderDecoder
+      , decoder = FC.validateNamed name (DecoderValidator validator) $ decoder itemEncoderDecoder
       }
 
   boundedEnumNamed name toText =

json-fleece-core/json-fleece-core.cabal

@@ -5,7 +5,7 @@ cabal-version: 1.12
 -- see: https://github.com/sol/hpack
 
 name:           json-fleece-core
-version:        0.7.0.0
+version:        0.8.0.0
 description:    Please see the README on GitHub at <https://github.com/flipstone/json-fleece-core#readme>
 homepage:       https://github.com/flipstone/json-fleece#readme
 bug-reports:    https://github.com/flipstone/json-fleece/issues
@@ -33,6 +33,7 @@ library
       Fleece.Core.Name
       Fleece.Core.Schemas
   other-modules:
+      Fleece.Core.Validator
       Paths_json_fleece_core
   hs-source-dirs:
       src

json-fleece-core/package.yaml

@@ -1,5 +1,5 @@
 name:                json-fleece-core
-version:             0.7.0.0
+version:             0.8.0.0
 github:              "flipstone/json-fleece/json-fleece-core"
 license:             BSD3
 author:              "Author name here"

json-fleece-core/src/Fleece/Core.hs

@@ -37,8 +37,6 @@ module Fleece.Core
   , nullable
   , validate
   , validateNamed
-  , transform
-  , transformNamed
   , coerceSchema
   , coerceSchemaNamed
 
@@ -129,9 +127,26 @@ module Fleece.Core
   , autoQualifiedName
   , nameToString
   , annotateName
+  , defaultSchemaName
+
+    -- * Validators
+  , Validator
+  , FleeceValidator
+  , mkValidator
+  , check
+  , uncheck
+  , mapUncheck
+  , mapCheck
+  , compose
+  , coercion
+  , transform
+  , identity
+  , StandardValidator
+  , NoOpValidator (..)
   ) where
 
 import Fleece.Core.AnyJSON
 import Fleece.Core.Class
 import Fleece.Core.Name
 import Fleece.Core.Schemas
+import Fleece.Core.Validator

json-fleece-core/src/Fleece/Core/AnyJSON.hs

@@ -38,7 +38,8 @@ import Fleece.Core.Class
   , (#|)
   )
 import Fleece.Core.Name (unqualifiedName)
-import Fleece.Core.Schemas (list, transform, unionMember)
+import Fleece.Core.Schemas (list, unionMember, validate)
+import Fleece.Core.Validator (transform)
 
 newtype AnyJSON
   = AnyJSON
@@ -150,7 +151,7 @@ handleAnyJSON handleText handleBool handleNumber handleArray handleObject handle
 
 anyJSON :: Fleece schema => schema AnyJSON
 anyJSON =
-  transform (\(AnyJSON u) -> u) AnyJSON $
+  validate (transform (\(AnyJSON u) -> u) AnyJSON) $
     unionNamed (unqualifiedName "AnyJSON") $
       unionMember text
         #| unionMember boolean

json-fleece-core/src/Fleece/Core/Class.hs

@@ -11,6 +11,7 @@ module Fleece.Core.Class
       , Object
       , UnionMembers
       , TaggedUnionMembers
+      , Validator
       , schemaName
       , text
       , number
@@ -53,13 +54,15 @@ import Shrubbery (BranchIndex, Tag, TagIndex, TagType, TaggedTypes, TaggedUnion,
 import Shrubbery.TypeList (Append, Length)
 
 import Fleece.Core.Name (Name)
+import Fleece.Core.Validator (FleeceValidator)
 
-class Fleece schema where
+class FleeceValidator (Validator schema) => Fleece schema where
   data Object schema :: Type -> Type -> Type
   data Field schema :: Type -> Type -> Type
   data AdditionalFields schema :: Type -> Type -> Type
   data UnionMembers schema :: [Type] -> [Type] -> Type
   data TaggedUnionMembers schema :: [Tag] -> [Tag] -> Type
+  data Validator schema :: Type -> Type -> Type
 
   schemaName :: schema a -> Name
 
@@ -118,10 +121,9 @@ class Fleece schema where
 
   validateNamed ::
     Name ->
-    (a -> b) ->
-    (b -> Either String a) ->
-    (schema b) ->
-    (schema a)
+    Validator schema a b ->
+    schema a ->
+    schema b
 
   boundedEnumNamed ::
     (Bounded a, Enum a) =>