{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

{-|
  This module provides tools for integrating the type-level JSON
  'Specification' with the "openapi" package.

  You can use 'toOpenApiSchema' as a low-level tool to transform @json-spec@
  'Specification's into @openapi3@ 'Schema's directly, irrespective of any
  particular business data type.

  More likely you will want to use @-XDerivingVia@ along with 'EncodingSchema'
  or 'DecodingSchema' to derive 'ToSchema' instances for your data types.

  Example, given this data type:

  > data User = User
  >   {      name :: Text
  >   , lastLogin :: Maybe UTCTime
  >   }
  >   deriving ToSchema via (EncodingSchema User) -- <-- ToSchema instance defined here
  > instance HasJsonEncodingSpec User where
  >   type EncodingSpec User =
  >     JsonObject
  >       '[ Required "name" JsonString
  >        , Optional "last-login" JsonDateTime
  >        ]
  >   toJSONStructure user =
  >     (Field @"name" (name user),
  >     (fmap (Field @"last-login") (lastLogin user),
  >     ()))

  Calling @'Data.Aeson.encode' ('Data.OpenApi3.toSchema' ('Proxy' :: 'Proxy' User))@
  will produce the following Schema:

  > {
  >   "additionalProperties": false,
  >   "properties": {
  >     "last-login": {
  >       "format": "date-time",
  >       "type": "string"
  >     },
  >     "name": {
  >       "type": "string"
  >     }
  >   },
  >   "required": [
  >     "name"
  >   ],
  >   "type": "object"
  > }

  If you needed more control over the content of the schema you might also
  consider doing something like this, e.g. in the case where you would like to
  allow additional properties:

  > data User = User
  >   {      name :: Text
  >   , lastLogin :: Maybe UTCTime
  >   }
  > instance HasJsonEncodingSpec User where
  >   type EncodingSpec User =
  >     JsonObject
  >       '[ Required "name" JsonString
  >        , Optional "last-login" JsonDateTime
  >        ]
  >   toJSONStructure user =
  >     (Field @"name" (name user),
  >     (fmap (Field @"last-login") (lastLogin user),
  >     ()))
  > instance ToSchema User where
  >   declareNamedSchema _proxy =
  >       pure $
  >         NamedSchema
  >           Nothing
  >           (
  >             toOpenApiSchema (EncodingSpec User)
  >               & set
  >                   additionalProperties
  >                   (Just (AdditionalPropertiesAllowed True))
  >           )

-}
module Data.JsonSpec.OpenApi (
  toOpenApiSchema,
  Schemaable,
  EncodingSchema(..),
  DecodingSchema(..),
) where


import Control.Lens (At(at), (&), over, set)
import Data.Aeson (ToJSON(toJSON))
import Data.Functor.Identity (Identity(runIdentity))
import Data.JsonSpec (FieldSpec(Optional, Required),
  HasJsonDecodingSpec(DecodingSpec), HasJsonEncodingSpec(EncodingSpec),
  Specification(JsonArray, JsonBool, JsonDateTime, JsonEither, JsonInt,
  JsonLet, JsonNullable, JsonNum, JsonObject, JsonRef, JsonString,
  JsonTag))
import Data.OpenApi (AdditionalProperties(AdditionalPropertiesAllowed),
  HasAdditionalProperties(additionalProperties), HasEnum(enum_),
  HasFormat(format), HasItems(items), HasOneOf(oneOf),
  HasProperties(properties), HasRequired(required), HasType(type_),
  NamedSchema(NamedSchema), OpenApiItems(OpenApiItemsObject),
  OpenApiType(OpenApiArray, OpenApiBoolean, OpenApiInteger, OpenApiNull,
  OpenApiNumber, OpenApiObject, OpenApiString), Reference(Reference),
  Referenced(Inline, Ref), ToSchema(declareNamedSchema), Definitions,
  Schema)
import Data.OpenApi.Declare (DeclareT(runDeclareT), MonadDeclare(declare))
import Data.String (IsString(fromString))
import Data.Text (Text)
import Data.Typeable (Proxy(Proxy), Typeable)
import GHC.TypeError (ErrorMessage((:$$:), (:<>:)), Unsatisfiable,
  unsatisfiable)
import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)
import Prelude (Applicative(pure), Bool(False), Functor(fmap), Maybe(Just,
  Nothing), Monoid(mempty), ($), (.))
import qualified Data.HashMap.Strict.InsOrd as HMI
import qualified GHC.TypeError as TE


{-|
  Convert a 'Specification' into an OpenApi 'Schema'. The type class
  'Schemaable' is an internal and opaque implementation detail and not
  something you should have to worry about.

  It should already have an instance for every 'Specification' that can
  be turned into a 'Schema'. If it does not, then that is a bug. Please
  report it! :-)

  The limitations of this function are:

  * It behaves in a possibly unexpected way when given a top level schema
    of the form:

      > JsonLet '[
      >   '("foo", ...)
      > ] (
      >   JsonRef "foo"
      > )

      'toOpenApiSchema' returns a 'Schema', not a @'Referenced' 'Schema'@.
      Therefore, if the \"top level\" of the 'Specification' is a 'JsonRef',
      then we will try to dereference and inline the referenced schema. In
      other words,

      > toOpenApiSchema (Proxy @(
      >     JsonLet
      >       '[ '("foo", JsonString) ]
      >       (JsonRef "foo")
      >   ))

      will behave as if you had called

      > toOpenApiSchema (Proxy @(
      >     JsonLet
      >       '[ '("foo", JsonString) ]
      >       JsonString
      >   ))

      However, if the reference is undefined, then you will get a custom
      type error explaining what the problem is.

  * With the exception of the above point, we do not check to make sure
    that every referenced used in the returned 'Schema' actually contains
    a definition. So for instance this will \"work\":

      > let
      >   (defs, schema) =
      >     toOpenApiSchema
      >       (Proxy @(
      >         JsonObject '[
      >           ("bar", JsonRef "not-defined")
      >         ]
      >       ))
      > in
      >   ...

      This will compile, and will not throw any runtime errors directly,
      but depending on how you /use/ @defs@ and @schema@ (like, for
      instance, generating an OpenApi specification) you will probably
      encounter a runtime error complaining that "not-defined" hasn't
      been defined.
-}
toOpenApiSchema
  :: (Schemaable spec)
  => Proxy (spec :: Specification)
  -> (Definitions Schema, Schema)
toOpenApiSchema :: forall (spec :: Specification).
Schemaable spec =>
Proxy spec -> (Definitions Schema, Schema)
toOpenApiSchema Proxy spec
spec =
  Identity (Definitions Schema, Schema)
-> (Definitions Schema, Schema)
forall a. Identity a -> a
runIdentity (DeclareT (Definitions Schema) Identity Schema
-> Definitions Schema -> Identity (Definitions Schema, Schema)
forall d (m :: * -> *) a. DeclareT d m a -> d -> m (d, a)
runDeclareT (Proxy spec -> DeclareT (Definitions Schema) Identity Schema
forall (spec :: Specification) (m :: * -> *).
(Schemaable spec, MonadDeclare (Definitions Schema) m) =>
Proxy spec -> m Schema
forall (m :: * -> *).
MonadDeclare (Definitions Schema) m =>
Proxy spec -> m Schema
schemaable Proxy spec
spec) Definitions Schema
forall a. Monoid a => a
mempty)


{-|
  Specifications that can be turned into OpenApi Schemas or a reference
  to a schema.
-}
class Refable (spec :: Specification) where
  refable
    :: (MonadDeclare (Definitions Schema) m)
    => Proxy spec
    -> m (Referenced Schema)
instance (KnownSymbol name) => Refable (JsonRef name) where
  refable :: forall (m :: * -> *).
MonadDeclare (Definitions Schema) m =>
Proxy ('JsonRef name) -> m (Referenced Schema)
refable Proxy ('JsonRef name)
Proxy =
    Referenced Schema -> m (Referenced Schema)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Referenced Schema
forall a. Text -> Referenced a
ref (forall (a :: Symbol) b. (IsString b, KnownSymbol a) => b
sym @name))
instance
    ( Defs defs
    , KnownSymbol name
    )
  =>
    Refable (JsonLet defs (JsonRef name))
  where
    refable :: forall (m :: * -> *).
MonadDeclare (Definitions Schema) m =>
Proxy ('JsonLet defs ('JsonRef name)) -> m (Referenced Schema)
refable Proxy ('JsonLet defs ('JsonRef name))
Proxy = do
      Proxy defs -> m ()
forall (defs :: [(Symbol, Specification)]) (m :: * -> *).
(Defs defs, MonadDeclare (Definitions Schema) m) =>
Proxy defs -> m ()
forall (m :: * -> *).
MonadDeclare (Definitions Schema) m =>
Proxy defs -> m ()
mkDefs (forall (t :: [(Symbol, Specification)]). Proxy t
forall {k} (t :: k). Proxy t
Proxy @defs)
      Proxy ('JsonRef name) -> m (Referenced Schema)
forall (spec :: Specification) (m :: * -> *).
(Refable spec, MonadDeclare (Definitions Schema) m) =>
Proxy spec -> m (Referenced Schema)
forall (m :: * -> *).
MonadDeclare (Definitions Schema) m =>
Proxy ('JsonRef name) -> m (Referenced Schema)
refable (forall {k} (t :: k). Proxy t
forall (t :: Specification). Proxy t
Proxy @(JsonRef name))
instance {-# overlaps #-} (Schemaable a) => Refable a where
  refable :: forall (m :: * -> *).
MonadDeclare (Definitions Schema) m =>
Proxy a -> m (Referenced Schema)
refable = (Schema -> Referenced Schema) -> m Schema -> m (Referenced Schema)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Schema -> Referenced Schema
forall a. a -> Referenced a
Inline (m Schema -> m (Referenced Schema))
-> (Proxy a -> m Schema) -> Proxy a -> m (Referenced Schema)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy a -> m Schema
forall (spec :: Specification) (m :: * -> *).
(Schemaable spec, MonadDeclare (Definitions Schema) m) =>
Proxy spec -> m Schema
forall (m :: * -> *).
MonadDeclare (Definitions Schema) m =>
Proxy a -> m Schema
schemaable


{-|
  Specifications that can be turned into OpenApi 'Schema's.

  This is intended to be an opaque implementation detail. The only
  reason it is exported is because there are some cases where you might
  need to be able to spell this constraint in code that builds off of
  this package.
-}
class Schemaable (spec :: Specification) where
  schemaable
    :: (MonadDeclare (Definitions Schema) m)
    => Proxy spec
    -> m Schema
instance (KnownSymbol tag) => Schemaable ('JsonTag tag) where
  schemaable :: forall (m :: * -> *).
MonadDeclare (Definitions Schema) m =>
Proxy ('JsonTag tag) -> m Schema
schemaable Proxy ('JsonTag tag)
Proxy =
    Schema -> m Schema
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Schema -> m Schema) -> Schema -> m Schema
forall a b. (a -> b) -> a -> b
$
      Schema
forall a. Monoid a => a
mempty Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& ASetter Schema Schema (Maybe [Value]) (Maybe [Value])
-> Maybe [Value] -> Schema -> Schema
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter Schema Schema (Maybe [Value]) (Maybe [Value])
forall s a. HasEnum s a => Lens' s a
Lens' Schema (Maybe [Value])
enum_ ([Value] -> Maybe [Value]
forall a. a -> Maybe a
Just [Text -> Value
forall a. ToJSON a => a -> Value
toJSON (forall (a :: Symbol) b. (IsString b, KnownSymbol a) => b
sym @tag :: Text)])
instance Schemaable 'JsonString where
  schemaable :: forall (m :: * -> *).
MonadDeclare (Definitions Schema) m =>
Proxy 'JsonString -> m Schema
schemaable Proxy 'JsonString
Proxy =
    Schema -> m Schema
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Schema -> m Schema) -> Schema -> m Schema
forall a b. (a -> b) -> a -> b
$
      Schema
forall a. Monoid a => a
mempty Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& ASetter Schema Schema (Maybe OpenApiType) (Maybe OpenApiType)
-> Maybe OpenApiType -> Schema -> Schema
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter Schema Schema (Maybe OpenApiType) (Maybe OpenApiType)
forall s a. HasType s a => Lens' s a
Lens' Schema (Maybe OpenApiType)
type_ (OpenApiType -> Maybe OpenApiType
forall a. a -> Maybe a
Just OpenApiType
OpenApiString)
instance {- Schemaable ('JsonEither left right) -}
    ( Schemaable left
    , Schemaable right
    )
  =>
    Schemaable ('JsonEither left right)
  where
    schemaable :: forall (m :: * -> *).
MonadDeclare (Definitions Schema) m =>
Proxy ('JsonEither left right) -> m Schema
schemaable Proxy ('JsonEither left right)
Proxy = do
      Schema
schemaLeft <- Proxy left -> m Schema
forall (spec :: Specification) (m :: * -> *).
(Schemaable spec, MonadDeclare (Definitions Schema) m) =>
Proxy spec -> m Schema
forall (m :: * -> *).
MonadDeclare (Definitions Schema) m =>
Proxy left -> m Schema
schemaable (forall {k} (t :: k). Proxy t
forall (t :: Specification). Proxy t
Proxy @left)
      Schema
schemaRight <- Proxy right -> m Schema
forall (spec :: Specification) (m :: * -> *).
(Schemaable spec, MonadDeclare (Definitions Schema) m) =>
Proxy spec -> m Schema
forall (m :: * -> *).
MonadDeclare (Definitions Schema) m =>
Proxy right -> m Schema
schemaable (forall {k} (t :: k). Proxy t
forall (t :: Specification). Proxy t
Proxy @right)
      Schema -> m Schema
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Schema -> m Schema) -> Schema -> m Schema
forall a b. (a -> b) -> a -> b
$
        Schema
forall a. Monoid a => a
mempty
          Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& ASetter
  Schema
  Schema
  (Maybe [Referenced Schema])
  (Maybe [Referenced Schema])
-> Maybe [Referenced Schema] -> Schema -> Schema
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter
  Schema
  Schema
  (Maybe [Referenced Schema])
  (Maybe [Referenced Schema])
forall s a. HasOneOf s a => Lens' s a
Lens' Schema (Maybe [Referenced Schema])
oneOf ([Referenced Schema] -> Maybe [Referenced Schema]
forall a. a -> Maybe a
Just
              [ Schema -> Referenced Schema
forall a. a -> Referenced a
Inline Schema
schemaLeft
              , Schema -> Referenced Schema
forall a. a -> Referenced a
Inline Schema
schemaRight
              ]
          )
instance Schemaable 'JsonNum where
  schemaable :: forall (m :: * -> *).
MonadDeclare (Definitions Schema) m =>
Proxy 'JsonNum -> m Schema
schemaable Proxy 'JsonNum
Proxy =
    Schema -> m Schema
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Schema -> m Schema) -> Schema -> m Schema
forall a b. (a -> b) -> a -> b
$
      Schema
forall a. Monoid a => a
mempty Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& ASetter Schema Schema (Maybe OpenApiType) (Maybe OpenApiType)
-> Maybe OpenApiType -> Schema -> Schema
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter Schema Schema (Maybe OpenApiType) (Maybe OpenApiType)
forall s a. HasType s a => Lens' s a
Lens' Schema (Maybe OpenApiType)
type_ (OpenApiType -> Maybe OpenApiType
forall a. a -> Maybe a
Just OpenApiType
OpenApiNumber)
instance Schemaable 'JsonInt where
  schemaable :: forall (m :: * -> *).
MonadDeclare (Definitions Schema) m =>
Proxy 'JsonInt -> m Schema
schemaable Proxy 'JsonInt
Proxy =
    Schema -> m Schema
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Schema -> m Schema) -> Schema -> m Schema
forall a b. (a -> b) -> a -> b
$
      Schema
forall a. Monoid a => a
mempty Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& ASetter Schema Schema (Maybe OpenApiType) (Maybe OpenApiType)
-> Maybe OpenApiType -> Schema -> Schema
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter Schema Schema (Maybe OpenApiType) (Maybe OpenApiType)
forall s a. HasType s a => Lens' s a
Lens' Schema (Maybe OpenApiType)
type_ (OpenApiType -> Maybe OpenApiType
forall a. a -> Maybe a
Just OpenApiType
OpenApiInteger)
instance Schemaable ('JsonObject '[]) where
  schemaable :: forall (m :: * -> *).
MonadDeclare (Definitions Schema) m =>
Proxy ('JsonObject '[]) -> m Schema
schemaable Proxy ('JsonObject '[])
Proxy =
    Schema -> m Schema
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Schema -> m Schema) -> Schema -> m Schema
forall a b. (a -> b) -> a -> b
$
      Schema
forall a. Monoid a => a
mempty
        Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& ASetter Schema Schema (Maybe OpenApiType) (Maybe OpenApiType)
-> Maybe OpenApiType -> Schema -> Schema
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter Schema Schema (Maybe OpenApiType) (Maybe OpenApiType)
forall s a. HasType s a => Lens' s a
Lens' Schema (Maybe OpenApiType)
type_ (OpenApiType -> Maybe OpenApiType
forall a. a -> Maybe a
Just OpenApiType
OpenApiObject)
        Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& ASetter
  Schema
  Schema
  (Maybe AdditionalProperties)
  (Maybe AdditionalProperties)
-> Maybe AdditionalProperties -> Schema -> Schema
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter
  Schema
  Schema
  (Maybe AdditionalProperties)
  (Maybe AdditionalProperties)
forall s a. HasAdditionalProperties s a => Lens' s a
Lens' Schema (Maybe AdditionalProperties)
additionalProperties (AdditionalProperties -> Maybe AdditionalProperties
forall a. a -> Maybe a
Just (Bool -> AdditionalProperties
AdditionalPropertiesAllowed Bool
False))
instance {- Schemaable ('JsonObject ( Optional key spec : more )) -}
    ( Schemaable ('JsonObject more)
    , Refable spec
    , KnownSymbol key
    )
  =>
    Schemaable ('JsonObject ( Optional key spec : more ))
  where
    schemaable :: forall (m :: * -> *).
MonadDeclare (Definitions Schema) m =>
Proxy ('JsonObject ('Optional key spec : more)) -> m Schema
schemaable Proxy ('JsonObject ('Optional key spec : more))
Proxy = do
      Referenced Schema
propertySchema <- Proxy spec -> m (Referenced Schema)
forall (spec :: Specification) (m :: * -> *).
(Refable spec, MonadDeclare (Definitions Schema) m) =>
Proxy spec -> m (Referenced Schema)
forall (m :: * -> *).
MonadDeclare (Definitions Schema) m =>
Proxy spec -> m (Referenced Schema)
refable (forall {k} (t :: k). Proxy t
forall (t :: Specification). Proxy t
Proxy @spec)
      Schema
more <- Proxy ('JsonObject more) -> m Schema
forall (spec :: Specification) (m :: * -> *).
(Schemaable spec, MonadDeclare (Definitions Schema) m) =>
Proxy spec -> m Schema
forall (m :: * -> *).
MonadDeclare (Definitions Schema) m =>
Proxy ('JsonObject more) -> m Schema
schemaable (forall {k} (t :: k). Proxy t
forall (t :: Specification). Proxy t
Proxy @('JsonObject more))
      Schema -> m Schema
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Schema -> m Schema) -> Schema -> m Schema
forall a b. (a -> b) -> a -> b
$
        Schema
more
          Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& ASetter
  Schema
  Schema
  (InsOrdHashMap Text (Referenced Schema))
  (InsOrdHashMap Text (Referenced Schema))
-> (InsOrdHashMap Text (Referenced Schema)
    -> InsOrdHashMap Text (Referenced Schema))
-> Schema
-> Schema
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over
              ASetter
  Schema
  Schema
  (InsOrdHashMap Text (Referenced Schema))
  (InsOrdHashMap Text (Referenced Schema))
forall s a. HasProperties s a => Lens' s a
Lens' Schema (InsOrdHashMap Text (Referenced Schema))
properties
              (ASetter
  (InsOrdHashMap Text (Referenced Schema))
  (InsOrdHashMap Text (Referenced Schema))
  (Maybe (IxValue (InsOrdHashMap Text (Referenced Schema))))
  (Maybe (Referenced Schema))
-> Maybe (Referenced Schema)
-> InsOrdHashMap Text (Referenced Schema)
-> InsOrdHashMap Text (Referenced Schema)
forall s t a b. ASetter s t a b -> b -> s -> t
set (Index (InsOrdHashMap Text (Referenced Schema))
-> Lens'
     (InsOrdHashMap Text (Referenced Schema))
     (Maybe (IxValue (InsOrdHashMap Text (Referenced Schema))))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at (forall (a :: Symbol) b. (IsString b, KnownSymbol a) => b
sym @key)) (Referenced Schema -> Maybe (Referenced Schema)
forall a. a -> Maybe a
Just Referenced Schema
propertySchema))
instance {- Schemaable ('JsonObject ( Required key spec : more )) -}
    ( Schemaable ('JsonObject more)
    , Refable spec
    , KnownSymbol key
    )
  =>
    Schemaable (JsonObject ( Required key spec : more ))
  where
    schemaable :: forall (m :: * -> *).
MonadDeclare (Definitions Schema) m =>
Proxy ('JsonObject ('Required key spec : more)) -> m Schema
schemaable Proxy ('JsonObject ('Required key spec : more))
Proxy = do
      Schema
schema <- Proxy ('JsonObject ('Optional key spec : more)) -> m Schema
forall (spec :: Specification) (m :: * -> *).
(Schemaable spec, MonadDeclare (Definitions Schema) m) =>
Proxy spec -> m Schema
forall (m :: * -> *).
MonadDeclare (Definitions Schema) m =>
Proxy ('JsonObject ('Optional key spec : more)) -> m Schema
schemaable (forall {k} (t :: k). Proxy t
forall (t :: Specification). Proxy t
Proxy @(JsonObject ( Optional key spec : more )))
      Schema -> m Schema
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Schema -> m Schema) -> Schema -> m Schema
forall a b. (a -> b) -> a -> b
$
        Schema
schema
          Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& ASetter Schema Schema [Text] [Text]
-> ([Text] -> [Text]) -> Schema -> Schema
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter Schema Schema [Text] [Text]
forall s a. HasRequired s a => Lens' s a
Lens' Schema [Text]
required (forall (a :: Symbol) b. (IsString b, KnownSymbol a) => b
sym @keyText -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:)

instance (Schemaable spec) => Schemaable ('JsonArray spec) where
  schemaable :: forall (m :: * -> *).
MonadDeclare (Definitions Schema) m =>
Proxy ('JsonArray spec) -> m Schema
schemaable Proxy ('JsonArray spec)
Proxy = do
    Schema
elementSchema <- Proxy spec -> m Schema
forall (spec :: Specification) (m :: * -> *).
(Schemaable spec, MonadDeclare (Definitions Schema) m) =>
Proxy spec -> m Schema
forall (m :: * -> *).
MonadDeclare (Definitions Schema) m =>
Proxy spec -> m Schema
schemaable (forall {k} (t :: k). Proxy t
forall (t :: Specification). Proxy t
Proxy @spec)
    Schema -> m Schema
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Schema -> m Schema) -> Schema -> m Schema
forall a b. (a -> b) -> a -> b
$
      Schema
forall a. Monoid a => a
mempty
        Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& ASetter Schema Schema (Maybe OpenApiType) (Maybe OpenApiType)
-> Maybe OpenApiType -> Schema -> Schema
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter Schema Schema (Maybe OpenApiType) (Maybe OpenApiType)
forall s a. HasType s a => Lens' s a
Lens' Schema (Maybe OpenApiType)
type_ (OpenApiType -> Maybe OpenApiType
forall a. a -> Maybe a
Just OpenApiType
OpenApiArray)
        Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& ASetter Schema Schema (Maybe OpenApiItems) (Maybe OpenApiItems)
-> Maybe OpenApiItems -> Schema -> Schema
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter Schema Schema (Maybe OpenApiItems) (Maybe OpenApiItems)
forall s a. HasItems s a => Lens' s a
Lens' Schema (Maybe OpenApiItems)
items (OpenApiItems -> Maybe OpenApiItems
forall a. a -> Maybe a
Just (Referenced Schema -> OpenApiItems
OpenApiItemsObject (Schema -> Referenced Schema
forall a. a -> Referenced a
Inline Schema
elementSchema)))
instance Schemaable 'JsonBool where
  schemaable :: forall (m :: * -> *).
MonadDeclare (Definitions Schema) m =>
Proxy 'JsonBool -> m Schema
schemaable Proxy 'JsonBool
Proxy =
    Schema -> m Schema
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Schema -> m Schema) -> Schema -> m Schema
forall a b. (a -> b) -> a -> b
$
      Schema
forall a. Monoid a => a
mempty Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& ASetter Schema Schema (Maybe OpenApiType) (Maybe OpenApiType)
-> Maybe OpenApiType -> Schema -> Schema
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter Schema Schema (Maybe OpenApiType) (Maybe OpenApiType)
forall s a. HasType s a => Lens' s a
Lens' Schema (Maybe OpenApiType)
type_ (OpenApiType -> Maybe OpenApiType
forall a. a -> Maybe a
Just OpenApiType
OpenApiBoolean)
instance Schemaable 'JsonDateTime where
  schemaable :: forall (m :: * -> *).
MonadDeclare (Definitions Schema) m =>
Proxy 'JsonDateTime -> m Schema
schemaable Proxy 'JsonDateTime
Proxy =
    Schema -> m Schema
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Schema -> m Schema) -> Schema -> m Schema
forall a b. (a -> b) -> a -> b
$
      Schema
forall a. Monoid a => a
mempty
        Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& ASetter Schema Schema (Maybe OpenApiType) (Maybe OpenApiType)
-> Maybe OpenApiType -> Schema -> Schema
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter Schema Schema (Maybe OpenApiType) (Maybe OpenApiType)
forall s a. HasType s a => Lens' s a
Lens' Schema (Maybe OpenApiType)
type_ (OpenApiType -> Maybe OpenApiType
forall a. a -> Maybe a
Just OpenApiType
OpenApiString)
        Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& ASetter Schema Schema (Maybe Text) (Maybe Text)
-> Maybe Text -> Schema -> Schema
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter Schema Schema (Maybe Text) (Maybe Text)
forall s a. HasFormat s a => Lens' s a
Lens' Schema (Maybe Text)
format (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"date-time")
instance {- Undefined Let -}
    Unsatisfiable (
      T "`JsonRef \"" :<>: T target :<>: T "\"` is not defined.\n"
      :$$: T "You are trying to use a JsonRef as the \"top level\" "
      :$$: T "schema. We try to satisfy this request by looking up "
      :$$: T "the reference and inlining it.  However in this case you "
      :$$: T "are trying to reference a schema which is not defined, "
      :$$: T "so this won't work.\n"
    )
  =>
    Schemaable (JsonLet '[] (JsonRef target))
  where
    schemaable :: forall (m :: * -> *).
MonadDeclare (Definitions Schema) m =>
Proxy ('JsonLet '[] ('JsonRef target)) -> m Schema
schemaable = Proxy ('JsonLet '[] ('JsonRef target)) -> m Schema
forall (msg :: ErrorMessage) a. Unsatisfiable msg => a
unsatisfiable
instance {- Schemaable (JsonLet ( '(target, def) ': more) (JsonRef target)) -}
    {-# overlaps #-}
    ( KnownSymbol target
    , Schemaable def
    , Schemaable (JsonLet more def)
    )
  =>
    Schemaable (JsonLet ( '(target, def) ': more) (JsonRef target))
  where
    schemaable :: forall (m :: * -> *).
MonadDeclare (Definitions Schema) m =>
Proxy ('JsonLet ('(target, def) : more) ('JsonRef target))
-> m Schema
schemaable Proxy ('JsonLet ('(target, def) : more) ('JsonRef target))
Proxy = do
      Schema
defSchema <- Proxy def -> m Schema
forall (spec :: Specification) (m :: * -> *).
(Schemaable spec, MonadDeclare (Definitions Schema) m) =>
Proxy spec -> m Schema
forall (m :: * -> *).
MonadDeclare (Definitions Schema) m =>
Proxy def -> m Schema
schemaable (forall {k} (t :: k). Proxy t
forall (t :: Specification). Proxy t
Proxy @def)
      Definitions Schema -> m ()
forall d (m :: * -> *). MonadDeclare d m => d -> m ()
declare (Text -> Schema -> Definitions Schema
forall k v. Hashable k => k -> v -> InsOrdHashMap k v
HMI.singleton (forall (a :: Symbol) b. (IsString b, KnownSymbol a) => b
sym @target) Schema
defSchema)
      Proxy ('JsonLet more def) -> m Schema
forall (spec :: Specification) (m :: * -> *).
(Schemaable spec, MonadDeclare (Definitions Schema) m) =>
Proxy spec -> m Schema
forall (m :: * -> *).
MonadDeclare (Definitions Schema) m =>
Proxy ('JsonLet more def) -> m Schema
schemaable (forall {k} (t :: k). Proxy t
forall (t :: Specification). Proxy t
Proxy @(JsonLet more def))
instance {- Schemaable (JsonLet ( '(name, def) ': more) (JsonRef target)) -}
    {-# overlaps #-}
    ( KnownSymbol name
    , Schemaable def
    , Schemaable (JsonLet more (JsonRef target))
    )
  =>
    Schemaable (JsonLet ( '(name, def) ': more) (JsonRef target))
  where
    schemaable :: forall (m :: * -> *).
MonadDeclare (Definitions Schema) m =>
Proxy ('JsonLet ('(name, def) : more) ('JsonRef target))
-> m Schema
schemaable Proxy ('JsonLet ('(name, def) : more) ('JsonRef target))
Proxy = do
      Schema
defSchema <- Proxy def -> m Schema
forall (spec :: Specification) (m :: * -> *).
(Schemaable spec, MonadDeclare (Definitions Schema) m) =>
Proxy spec -> m Schema
forall (m :: * -> *).
MonadDeclare (Definitions Schema) m =>
Proxy def -> m Schema
schemaable (forall {k} (t :: k). Proxy t
forall (t :: Specification). Proxy t
Proxy @def)
      Definitions Schema -> m ()
forall d (m :: * -> *). MonadDeclare d m => d -> m ()
declare (Text -> Schema -> Definitions Schema
forall k v. Hashable k => k -> v -> InsOrdHashMap k v
HMI.singleton (forall (a :: Symbol) b. (IsString b, KnownSymbol a) => b
sym @name) Schema
defSchema)
      Proxy ('JsonLet more ('JsonRef target)) -> m Schema
forall (spec :: Specification) (m :: * -> *).
(Schemaable spec, MonadDeclare (Definitions Schema) m) =>
Proxy spec -> m Schema
forall (m :: * -> *).
MonadDeclare (Definitions Schema) m =>
Proxy ('JsonLet more ('JsonRef target)) -> m Schema
schemaable (forall {k} (t :: k). Proxy t
forall (t :: Specification). Proxy t
Proxy @(JsonLet more (JsonRef target)))
instance {- Schemaable (JsonLet defs spec) -}
    {-# overlaps #-}
    ( Defs defs
    , Schemaable spec
    )
  =>
    Schemaable (JsonLet defs spec)
  where
    schemaable :: forall (m :: * -> *).
MonadDeclare (Definitions Schema) m =>
Proxy ('JsonLet defs spec) -> m Schema
schemaable Proxy ('JsonLet defs spec)
Proxy = do
      Proxy defs -> m ()
forall (defs :: [(Symbol, Specification)]) (m :: * -> *).
(Defs defs, MonadDeclare (Definitions Schema) m) =>
Proxy defs -> m ()
forall (m :: * -> *).
MonadDeclare (Definitions Schema) m =>
Proxy defs -> m ()
mkDefs (forall (t :: [(Symbol, Specification)]). Proxy t
forall {k} (t :: k). Proxy t
Proxy @defs)
      Proxy spec -> m Schema
forall (spec :: Specification) (m :: * -> *).
(Schemaable spec, MonadDeclare (Definitions Schema) m) =>
Proxy spec -> m Schema
forall (m :: * -> *).
MonadDeclare (Definitions Schema) m =>
Proxy spec -> m Schema
schemaable (forall {k} (t :: k). Proxy t
forall (t :: Specification). Proxy t
Proxy @spec)
instance (Schemaable spec) => Schemaable (JsonNullable spec) where
  schemaable :: forall (m :: * -> *).
MonadDeclare (Definitions Schema) m =>
Proxy ('JsonNullable spec) -> m Schema
schemaable Proxy ('JsonNullable spec)
Proxy = do
    Schema
schema <- Proxy spec -> m Schema
forall (spec :: Specification) (m :: * -> *).
(Schemaable spec, MonadDeclare (Definitions Schema) m) =>
Proxy spec -> m Schema
forall (m :: * -> *).
MonadDeclare (Definitions Schema) m =>
Proxy spec -> m Schema
schemaable (forall {k} (t :: k). Proxy t
forall (t :: Specification). Proxy t
Proxy @spec)
    Schema -> m Schema
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Schema -> m Schema) -> Schema -> m Schema
forall a b. (a -> b) -> a -> b
$
      Schema
forall a. Monoid a => a
mempty
        Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& ASetter
  Schema
  Schema
  (Maybe [Referenced Schema])
  (Maybe [Referenced Schema])
-> Maybe [Referenced Schema] -> Schema -> Schema
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter
  Schema
  Schema
  (Maybe [Referenced Schema])
  (Maybe [Referenced Schema])
forall s a. HasOneOf s a => Lens' s a
Lens' Schema (Maybe [Referenced Schema])
oneOf ([Referenced Schema] -> Maybe [Referenced Schema]
forall a. a -> Maybe a
Just
            [ Schema -> Referenced Schema
forall a. a -> Referenced a
Inline (Schema
forall a. Monoid a => a
mempty Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& ASetter Schema Schema (Maybe OpenApiType) (Maybe OpenApiType)
-> Maybe OpenApiType -> Schema -> Schema
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter Schema Schema (Maybe OpenApiType) (Maybe OpenApiType)
forall s a. HasType s a => Lens' s a
Lens' Schema (Maybe OpenApiType)
type_ (OpenApiType -> Maybe OpenApiType
forall a. a -> Maybe a
Just OpenApiType
OpenApiNull))
            , Schema -> Referenced Schema
forall a. a -> Referenced a
Inline Schema
schema
            ]
        )


{-| Go through and make a declaration for each item in a JsonLet.  -}
class Defs (defs :: [(Symbol, Specification)]) where
  mkDefs
    :: (MonadDeclare (Definitions Schema) m)
    => Proxy defs
    -> m ()
instance Defs '[] where
  mkDefs :: forall (m :: * -> *).
MonadDeclare (Definitions Schema) m =>
Proxy '[] -> m ()
mkDefs Proxy '[]
Proxy = () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
instance
    ( Defs more
    , Schemaable spec
    , KnownSymbol name
    )
  =>
    Defs ( '(name, spec) ': more)
  where
    mkDefs :: forall (m :: * -> *).
MonadDeclare (Definitions Schema) m =>
Proxy ('(name, spec) : more) -> m ()
mkDefs Proxy ('(name, spec) : more)
Proxy = do
      Schema
schema <- Proxy spec -> m Schema
forall (spec :: Specification) (m :: * -> *).
(Schemaable spec, MonadDeclare (Definitions Schema) m) =>
Proxy spec -> m Schema
forall (m :: * -> *).
MonadDeclare (Definitions Schema) m =>
Proxy spec -> m Schema
schemaable (forall {k} (t :: k). Proxy t
forall (t :: Specification). Proxy t
Proxy @spec)
      Definitions Schema -> m ()
forall d (m :: * -> *). MonadDeclare d m => d -> m ()
declare (Text -> Schema -> Definitions Schema
forall k v. Hashable k => k -> v -> InsOrdHashMap k v
HMI.singleton (forall (a :: Symbol) b. (IsString b, KnownSymbol a) => b
sym @name) Schema
schema)
      Proxy more -> m ()
forall (defs :: [(Symbol, Specification)]) (m :: * -> *).
(Defs defs, MonadDeclare (Definitions Schema) m) =>
Proxy defs -> m ()
forall (m :: * -> *).
MonadDeclare (Definitions Schema) m =>
Proxy more -> m ()
mkDefs (forall (t :: [(Symbol, Specification)]). Proxy t
forall {k} (t :: k). Proxy t
Proxy @more)


{-|
  Helper for defining `ToSchema` instances based on `HasJsonEncodingSpec`
  using @deriving via@.

  Example:

  > data MyType = ...
  >   deriving ToSchema via (EncodingSchema MyType)
  > instance HasJsonEncodingSchema MyType where
  >   ...
-}
newtype EncodingSchema a =
  EncodingSchema {forall a. EncodingSchema a -> a
unEncodingSchema :: a}
instance
    ( Schemaable (EncodingSpec a)
    , Typeable a
    )
  =>
    ToSchema (EncodingSchema a)
  where
    declareNamedSchema :: Proxy (EncodingSchema a)
-> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy (EncodingSchema a)
_ = do
      let (Definitions Schema
declarations, Schema
schema) = Proxy (EncodingSpec a) -> (Definitions Schema, Schema)
forall (spec :: Specification).
Schemaable spec =>
Proxy spec -> (Definitions Schema, Schema)
toOpenApiSchema (forall {k} (t :: k). Proxy t
forall (t :: Specification). Proxy t
Proxy @(EncodingSpec a))
      Definitions Schema -> DeclareT (Definitions Schema) Identity ()
forall d (m :: * -> *). MonadDeclare d m => d -> m ()
declare Definitions Schema
declarations
      NamedSchema -> Declare (Definitions Schema) NamedSchema
forall a. a -> DeclareT (Definitions Schema) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Text -> Schema -> NamedSchema
NamedSchema Maybe Text
forall a. Maybe a
Nothing Schema
schema)


{-|
  Helper for defining `ToSchema` instances based on `HasJsonDecodingSpec`
  using @deriving via@.

  Example:

  > data MyType = ...
  >   deriving ToSchema via (DecodingSchema MyType)
  > instance HasJsonDecodingSchema MyType where
  >   ...
-}
newtype DecodingSchema a =
  DecodingSchema {forall a. DecodingSchema a -> a
unDecodingSchema :: a}
instance
    ( Schemaable (DecodingSpec a)
    , Typeable a
    )
  =>
    ToSchema (DecodingSchema a)
  where
    declareNamedSchema :: Proxy (DecodingSchema a)
-> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy (DecodingSchema a)
_ = do
      let (Definitions Schema
declarations, Schema
schema) = Proxy (DecodingSpec a) -> (Definitions Schema, Schema)
forall (spec :: Specification).
Schemaable spec =>
Proxy spec -> (Definitions Schema, Schema)
toOpenApiSchema (forall {k} (t :: k). Proxy t
forall (t :: Specification). Proxy t
Proxy @(DecodingSpec a))
      Definitions Schema -> DeclareT (Definitions Schema) Identity ()
forall d (m :: * -> *). MonadDeclare d m => d -> m ()
declare Definitions Schema
declarations
      NamedSchema -> Declare (Definitions Schema) NamedSchema
forall a. a -> DeclareT (Definitions Schema) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Text -> Schema -> NamedSchema
NamedSchema Maybe Text
forall a. Maybe a
Nothing Schema
schema)


{- | Shorthand for demoting type-level strings.  -}
sym
  :: forall a b.
     ( IsString b
     , KnownSymbol a
     )
  => b
sym :: forall (a :: Symbol) b. (IsString b, KnownSymbol a) => b
sym = String -> b
forall a. IsString a => String -> a
fromString (String -> b) -> String -> b
forall a b. (a -> b) -> a -> b
$ Proxy a -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @a)


ref :: Text -> Referenced a
ref :: forall a. Text -> Referenced a
ref = Reference -> Referenced a
forall a. Reference -> Referenced a
Ref (Reference -> Referenced a)
-> (Text -> Reference) -> Text -> Referenced a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Reference
Reference


{-| Shorthand for building custom type errors.  -}
type T (msg :: Symbol) = TE.Text msg