Updates json-fleece to latest version

src/Orb/Handler/Handler.hs

@@ -106,7 +106,7 @@ data NoRequestBody
 data RequestBody body tags where
   SchemaRequestBody ::
     Response.Has422Response tags =>
-    (forall schema. FC.Fleece schema => schema body) ->
+    (forall t. FC.Fleece t => FC.Schema t body) ->
     RequestBody body tags
   RawRequestBody ::
     Response.HasResponseCodeWithType tags "422" err =>
@@ -320,7 +320,7 @@ parseBodyRequestSchema ::
   , HasRequest.HasRequest m
   , MIO.MonadIO m
   ) =>
-  (forall schema. FC.Fleece schema => schema request) ->
+  (forall t. FC.Fleece t => FC.Schema t request) ->
   m (Either (S.TaggedUnion tags) request)
 parseBodyRequestSchema schema = do
   req <- HasRequest.request

src/Orb/OpenApi.hs

@@ -4,7 +4,6 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
 
 module Orb.OpenApi
   ( mkOpenApi
@@ -559,7 +558,7 @@ mkRequestBody ::
   Either OpenApiError (Maybe (OpenApi.Referenced OpenApi.RequestBody, Map.Map T.Text SchemaInfo))
 mkRequestBody handler =
   case Handler.requestBody handler of
-    Handler.SchemaRequestBody (FleeceOpenApi mkErrOrSchemaInfo) -> do
+    Handler.SchemaRequestBody (FC.Schema _ (FleeceOpenApi mkErrOrSchemaInfo)) -> do
       schemaInfo <- mkErrOrSchemaInfo []
 
       let
@@ -687,7 +686,7 @@ mkResponses handler =
       mbSchemaInfo <-
         case responseSchema of
           Response.NoSchemaResponseBody _mbContentType -> pure Nothing
-          Response.SchemaResponseBody (FleeceOpenApi mkInfo) -> fmap Just (mkInfo [])
+          Response.SchemaResponseBody (FC.Schema _ (FleeceOpenApi mkInfo)) -> fmap Just (mkInfo [])
           Response.EmptyResponseBody -> pure Nothing
       let
         mkResponseContent schemaRef =
@@ -833,7 +832,7 @@ data SchemaWithComponents = SchemaWithComponents
   Fleece schema. If an error occurs during construction (e.g. conflicting
   definitions of the same component), an error will be returned.
 -}
-schemaWithComponents :: FleeceOpenApi a -> Either OpenApiError SchemaWithComponents
+schemaWithComponents :: FC.Schema FleeceOpenApi a -> Either OpenApiError SchemaWithComponents
 schemaWithComponents =
   fmap
     ( \schemaInfo ->
@@ -847,6 +846,7 @@ schemaWithComponents =
     )
     . ($ [])
     . unFleeceOpenApi
+    . FC.schemaInterpreter
 
 data PathEntry
   = PathSchema FC.Name
@@ -996,13 +996,13 @@ mkSchemaRef schema =
       OpenApi.Inline . openApiSchema $ schema
 
 mkPrimitiveSchema ::
-  String ->
+  FC.Name ->
   OpenApi.OpenApiType ->
   Path ->
   SchemaInfo
 mkPrimitiveSchema name openApiType path =
   SchemaInfo
-    { fleeceName = FC.unqualifiedName name
+    { fleeceName = name
     , schemaPath = path
     , schemaIsPrimitive = True
     , openApiKey = Nothing
@@ -1036,39 +1036,22 @@ instance FC.Fleece FleeceOpenApi where
   data TaggedUnionMembers FleeceOpenApi _allTags _handledTags
     = TaggedUnionMembers (Path -> FieldInfo -> String -> Either OpenApiError [(T.Text, SchemaInfo)])
 
-  schemaName (FleeceOpenApi mkErrOrSchemaInfo) =
-    -- We might not be able to make a name here because 'mkErrOrSchemaInfo' might
-    -- return an error. 'schemaName' cannot return an error, however, so we are
-    -- forced to reflect the error in the name of the schema. This is not ideal,
-    -- but the error raised by the schema will almost certainly be raised elsewhere
-    -- as part of the OpenApi spec generation, so it will get reported as an error
-    -- elsewhere in addition to in the name of this schema.
-    case mkErrOrSchemaInfo [] of
-      Left err ->
-        let
-          shortErr =
-            takeWhile (/= '\n') (renderOpenApiError err)
-        in
-          FC.unqualifiedName ("Unable to get schema name:" <> shortErr)
-      Right schemaInfo -> fleeceName schemaInfo
-
-  format formatString (FleeceOpenApi mkErrOrSchemaInfo) =
-    FleeceOpenApi $ \path ->
-      fmap (setSchemaInfoFormat (T.pack formatString)) (mkErrOrSchemaInfo path)
+  interpretFormat formatString (FC.Schema _name (FleeceOpenApi mkErrOrSchemaInfo)) =
+    FleeceOpenApi $ fmap (setSchemaInfoFormat (T.pack formatString)) . mkErrOrSchemaInfo
 
-  number =
-    FleeceOpenApi $ Right . mkPrimitiveSchema "number" OpenApi.OpenApiNumber
+  interpretNumber name =
+    FleeceOpenApi $ Right . mkPrimitiveSchema name OpenApi.OpenApiNumber
 
-  text =
-    FleeceOpenApi $ Right . mkPrimitiveSchema "text" OpenApi.OpenApiString
+  interpretText name =
+    FleeceOpenApi $ Right . mkPrimitiveSchema name OpenApi.OpenApiString
 
-  boolean =
-    FleeceOpenApi $ Right . mkPrimitiveSchema "boolean" OpenApi.OpenApiBoolean
+  interpretBoolean name =
+    FleeceOpenApi $ Right . mkPrimitiveSchema name OpenApi.OpenApiBoolean
 
-  null =
-    FleeceOpenApi $ Right . mkPrimitiveSchema "null" OpenApi.OpenApiNull
+  interpretNull name =
+    FleeceOpenApi $ Right . mkPrimitiveSchema name OpenApi.OpenApiNull
 
-  array (FleeceOpenApi mkErrOrItemSchemaInfo) =
+  interpretArray arrayName (FC.Schema _itemName (FleeceOpenApi mkErrOrItemSchemaInfo)) =
     FleeceOpenApi $ \path -> do
       itemSchemaInfo <- mkErrOrItemSchemaInfo path
       components <- collectComponents [itemSchemaInfo]
@@ -1079,7 +1062,7 @@ instance FC.Fleece FleeceOpenApi where
 
       pure $
         SchemaInfo
-          { fleeceName = FC.annotateName (fleeceName itemSchemaInfo) "array"
+          { fleeceName = arrayName
           , schemaPath = path
           , schemaIsPrimitive = False
           , openApiKey = Nothing
@@ -1092,7 +1075,7 @@ instance FC.Fleece FleeceOpenApi where
           , schemaComponents = components
           }
 
-  nullable (FleeceOpenApi mkErrOrSchemaInfo) =
+  interpretNullable _nullableName (FC.Schema _name (FleeceOpenApi mkErrOrSchemaInfo)) =
     FleeceOpenApi $ \path -> do
       schemaInfo <- mkErrOrSchemaInfo path
       let
@@ -1117,7 +1100,7 @@ instance FC.Fleece FleeceOpenApi where
           , schemaComponents = schemaComponents schemaInfo
           }
 
-  required name _accessor (FleeceOpenApi mkErrOrSchemaInfo) =
+  required name _accessor (FC.Schema _schemaName (FleeceOpenApi mkErrOrSchemaInfo)) =
     Field $ \path -> do
       schemaInfo <- mkErrOrSchemaInfo (addFieldToPath name path)
       pure $
@@ -1127,7 +1110,7 @@ instance FC.Fleece FleeceOpenApi where
           , fieldSchemaInfo = schemaInfo
           }
 
-  optional name _accessor (FleeceOpenApi mkErrOrSchemaInfo) =
+  optional name _accessor (FC.Schema _schemaName (FleeceOpenApi mkErrOrSchemaInfo)) =
     Field $ \path -> do
       schemaInfo <- mkErrOrSchemaInfo (addFieldToPath name path)
       pure $
@@ -1143,7 +1126,7 @@ instance FC.Fleece FleeceOpenApi where
   additionalFields _accessor _schema =
     AdditionalFields
 
-  objectNamed name (Object mkErrOrFieldsInReverse) =
+  interpretObjectNamed name (Object mkErrOrFieldsInReverse) =
     FleeceOpenApi $ \path ->
       mkObjectForFields path name =<< mkErrOrFieldsInReverse (addSchemaToPath name path)
 
@@ -1157,7 +1140,7 @@ instance FC.Fleece FleeceOpenApi where
     Object . const . Left . InternalError $
       "Fleece additional fields not currently support for OpenAPI"
 
-  validateNamed name _uncheck _check (FleeceOpenApi mkErrOrSchemaInfo) = do
+  interpretValidateNamed name _uncheck _check (FC.Schema _unvalidatedName (FleeceOpenApi mkErrOrSchemaInfo)) = do
     FleeceOpenApi $ \path -> do
       schemaInfo <- mkErrOrSchemaInfo (addSchemaToPath name path)
 
@@ -1178,10 +1161,10 @@ instance FC.Fleece FleeceOpenApi where
               , openApiKey = Just . fleeceNameToOpenApiKey $ name
               }
 
-  validateAnonymous _uncheck _check (FleeceOpenApi errOrSchemaInfo) = do
+  interpretValidateAnonymous _uncheck _check (FC.Schema _name (FleeceOpenApi errOrSchemaInfo)) = do
     FleeceOpenApi errOrSchemaInfo
 
-  boundedEnumNamed name toText =
+  interpretBoundedEnumNamed name toText =
     let
       enumValues =
         fmap
@@ -1204,7 +1187,7 @@ instance FC.Fleece FleeceOpenApi where
             , schemaComponents = Map.empty
             }
 
-  unionNamed name (UnionMembers mkErrOrMembers) =
+  interpretUnionNamed name (UnionMembers mkErrOrMembers) =
     FleeceOpenApi $ \path -> do
       let
         key = Just $ fleeceNameToOpenApiKey name
@@ -1230,7 +1213,7 @@ instance FC.Fleece FleeceOpenApi where
           , schemaComponents = components
           }
 
-  unionMemberWithIndex _idx (FleeceOpenApi mkErrOrSchemaInfo) =
+  unionMemberWithIndex _idx (FC.Schema _name (FleeceOpenApi mkErrOrSchemaInfo)) =
     UnionMembers $ \path -> do
       schemaInfo <- mkErrOrSchemaInfo path
       pure [schemaInfo]
@@ -1240,7 +1223,7 @@ instance FC.Fleece FleeceOpenApi where
     -- polymorphism
     UnionMembers $ \path -> liftA2 (++) (left path) (right path)
 
-  taggedUnionNamed name tagPropertyString (TaggedUnionMembers mkMembers) =
+  interpretTaggedUnionNamed name tagPropertyString (TaggedUnionMembers mkMembers) =
     FleeceOpenApi $ \path -> do
       let
         tagProperty =
@@ -1250,7 +1233,7 @@ instance FC.Fleece FleeceOpenApi where
           FC.nameUnqualified name <> "."
 
         errOrStringSchema =
-          unFleeceOpenApi FC.text (PathSchema name : path)
+          unFleeceOpenApi (FC.schemaInterpreter FC.text) (PathSchema name : path)
 
         mkTagField tagSchema =
           FieldInfo
@@ -1333,7 +1316,7 @@ instance FC.Fleece FleeceOpenApi where
       -- polymorphism
       pure (left ++ right)
 
-  jsonString (FleeceOpenApi _schemaInfo) =
+  interpretJsonString _schema =
     FleeceOpenApi
       . const
       . Left
@@ -1347,25 +1330,35 @@ instance FC.Fleece FleeceOpenApi where
   -- we have no way to access and call the defaults.
   --
 
-  int = setOpenApiType OpenApi.OpenApiInteger $ FC.boundedIntegralNumberAnonymous
+  interpretInt _name =
+    setOpenApiType OpenApi.OpenApiInteger (FC.schemaInterpreter FC.boundedIntegralNumberAnonymous)
 
-  int8 = setOpenApiType OpenApi.OpenApiInteger $ FC.format "int8" FC.boundedIntegralNumberAnonymous
+  interpretInt8 _name =
+    setOpenApiType OpenApi.OpenApiInteger (FC.schemaInterpreter $ FC.format "int8" FC.boundedIntegralNumberAnonymous)
 
-  int16 = setOpenApiType OpenApi.OpenApiInteger $ FC.format "int16" FC.boundedIntegralNumberAnonymous
+  interpretInt16 _name =
+    setOpenApiType OpenApi.OpenApiInteger (FC.schemaInterpreter $ FC.format "int16" FC.boundedIntegralNumberAnonymous)
 
-  int32 = setOpenApiType OpenApi.OpenApiInteger $ FC.format "int32" FC.boundedIntegralNumberAnonymous
+  interpretInt32 _name =
+    setOpenApiType OpenApi.OpenApiInteger (FC.schemaInterpreter $ FC.format "int32" FC.boundedIntegralNumberAnonymous)
 
-  int64 = setOpenApiType OpenApi.OpenApiInteger $ FC.format "int64" FC.boundedIntegralNumberAnonymous
+  interpretInt64 _name =
+    setOpenApiType OpenApi.OpenApiInteger (FC.schemaInterpreter $ FC.format "int64" FC.boundedIntegralNumberAnonymous)
 
-  word = setOpenApiType OpenApi.OpenApiInteger $ FC.format "word" FC.boundedIntegralNumberAnonymous
+  interpretWord _name =
+    setOpenApiType OpenApi.OpenApiInteger (FC.schemaInterpreter $ FC.format "word" FC.boundedIntegralNumberAnonymous)
 
-  word8 = setOpenApiType OpenApi.OpenApiInteger $ FC.format "word8" FC.boundedIntegralNumberAnonymous
+  interpretWord8 _name =
+    setOpenApiType OpenApi.OpenApiInteger (FC.schemaInterpreter $ FC.format "word8" FC.boundedIntegralNumberAnonymous)
 
-  word16 = setOpenApiType OpenApi.OpenApiInteger $ FC.format "word16" FC.boundedIntegralNumberAnonymous
+  interpretWord16 _name =
+    setOpenApiType OpenApi.OpenApiInteger (FC.schemaInterpreter $ FC.format "word16" FC.boundedIntegralNumberAnonymous)
 
-  word32 = setOpenApiType OpenApi.OpenApiInteger $ FC.format "word32" FC.boundedIntegralNumberAnonymous
+  interpretWord32 _name =
+    setOpenApiType OpenApi.OpenApiInteger (FC.schemaInterpreter $ FC.format "word32" FC.boundedIntegralNumberAnonymous)
 
-  word64 = setOpenApiType OpenApi.OpenApiInteger $ FC.format "word64" FC.boundedIntegralNumberAnonymous
+  interpretWord64 _name =
+    setOpenApiType OpenApi.OpenApiInteger (FC.schemaInterpreter $ FC.format "word64" FC.boundedIntegralNumberAnonymous)
 
 mkObjectForFields ::
   Path ->

src/Orb/Response/Response.hs

@@ -45,7 +45,7 @@ data ResponseBody where
   NoSchemaResponseBody ::
     Maybe ContentType -> ResponseBody
   SchemaResponseBody ::
-    (forall schema. FC.Fleece schema => schema body) -> ResponseBody
+    (forall t. FC.Fleece t => FC.Schema t body) -> ResponseBody
   EmptyResponseBody ::
     ResponseBody
 

src/Orb/Response/Schemas.hs

@@ -28,7 +28,7 @@ import Fleece.Core qualified as FC
 newtype BadRequestMessage = BadRequestMessage
   {badRequestMessage :: T.Text}
 
-badRequestMessageSchema :: FC.Fleece schema => schema BadRequestMessage
+badRequestMessageSchema :: FC.Fleece t => FC.Schema t BadRequestMessage
 badRequestMessageSchema =
   FC.object $
     FC.constructor BadRequestMessage
@@ -37,15 +37,15 @@ badRequestMessageSchema =
 newtype ConflictMessage = ConflictMessage
   {conflictMessage :: T.Text}
 
-conflictMessageSchema :: FC.Fleece schema => schema ConflictMessage
+conflictMessageSchema :: FC.Fleece t => FC.Schema t ConflictMessage
 conflictMessageSchema =
   FC.object $
     FC.constructor ConflictMessage
       #+ FC.required "conflict" conflictMessage FC.text
 
 data InternalServerError = InternalServerError
 
-internalServerErrorSchema :: FC.Fleece schema => schema InternalServerError
+internalServerErrorSchema :: FC.Fleece t => FC.Schema t InternalServerError
 internalServerErrorSchema =
   FC.object $
     FC.constructor (const InternalServerError)
@@ -56,7 +56,7 @@ data NoContent = NoContent
 newtype NotFoundMessage = NotFoundMessage
   {notFoundMessage :: T.Text}
 
-notFoundMessageSchema :: FC.Fleece schema => schema NotFoundMessage
+notFoundMessageSchema :: FC.Fleece t => FC.Schema t NotFoundMessage
 notFoundMessageSchema =
   FC.object $
     FC.constructor NotFoundMessage
@@ -65,7 +65,7 @@ notFoundMessageSchema =
 newtype ServiceUnavailableError = ServiceUnavailableError
   {serviceUnavailableText :: T.Text}
 
-serviceUnavailableErrorSchema :: FC.Fleece schema => schema ServiceUnavailableError
+serviceUnavailableErrorSchema :: FC.Fleece t => FC.Schema t ServiceUnavailableError
 serviceUnavailableErrorSchema =
   FC.object $
     FC.constructor ServiceUnavailableError
@@ -74,7 +74,7 @@ serviceUnavailableErrorSchema =
 newtype SuccessMessage = SuccessMessage
   {successMessage :: T.Text}
 
-successMessageSchema :: FC.Fleece schema => schema SuccessMessage
+successMessageSchema :: FC.Fleece t => FC.Schema t SuccessMessage
 successMessageSchema =
   FC.object $
     FC.constructor SuccessMessage
@@ -83,7 +83,7 @@ successMessageSchema =
 newtype UnauthorizedMessage = UnauthorizedMessage
   {unauthorizedMessage :: T.Text}
 
-unauthorizedMessageSchema :: FC.Fleece schema => schema UnauthorizedMessage
+unauthorizedMessageSchema :: FC.Fleece t => FC.Schema t UnauthorizedMessage
 unauthorizedMessageSchema =
   FC.object $
     FC.constructor UnauthorizedMessage
@@ -92,7 +92,7 @@ unauthorizedMessageSchema =
 newtype UnprocessableContentMessage = UnprocessableContentMessage
   {unprocessableContentText :: T.Text}
 
-unprocessableContentSchema :: FC.Fleece schema => schema UnprocessableContentMessage
+unprocessableContentSchema :: FC.Fleece t => FC.Schema t UnprocessableContentMessage
 unprocessableContentSchema =
   FC.object $
     FC.constructor UnprocessableContentMessage