{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedLists #-}

-- This file is part of the Wire Server implementation.
--
-- Copyright (C) 2022 Wire Swiss GmbH <opensource@wire.com>
--
-- This program is free software: you can redistribute it and/or modify it under
-- the terms of the GNU Affero General Public License as published by the Free
-- Software Foundation, either version 3 of the License, or (at your option) any
-- later version.
--
-- This program is distributed in the hope that it will be useful, but WITHOUT
-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more
-- details.
--
-- You should have received a copy of the GNU Affero General Public License along
-- with this program. If not, see <https://www.gnu.org/licenses/>.

-- | Combinator library for defining bidirectional JSON encodings with
-- associated Swagger schemas.
--
-- Documentation on the organisation of this library and a tutorial
-- can be found in @README.md@.
module Data.Schema
  ( SchemaP,
    ValueSchema,
    ValueSchemaP,
    ObjectSchema,
    ObjectSchemaP,
    ToSchema (..),
    Schema (..),
    mkSchema,
    schemaDoc,
    schemaIn,
    schemaOut,
    HasDoc (..),
    doc',
    HasSchemaRef (..),
    HasObject (..),
    HasField (..),
    withParser,
    SwaggerDoc,
    swaggerDoc,
    NamedSwaggerDoc,
    WithDeclare,
    declareSwaggerSchema,
    getName,
    object,
    objectWithDocModifier,
    objectOver,
    jsonObject,
    jsonValue,
    FieldFunctor (..),
    field,
    fieldWithDocModifier,
    fieldOver,
    optField,
    optFieldWithDocModifier,
    fieldF,
    fieldOverF,
    fieldWithDocModifierF,
    array,
    set,
    nonEmptyArray,
    map_,
    mapWithKeys,
    enum,
    maybe_,
    maybeWithDefault,
    bind,
    dispatch,
    text,
    parsedText,
    null_,
    nullable,
    element,
    tag,
    unnamed,
    named,
    (.=),
    schemaToSwagger,
    schemaToJSON,
    schemaParseJSON,
    genericToSchema,
    S.description, -- re-export
  )
where

import Control.Applicative
import Control.Comonad
import Control.Lens hiding (element, enum, set, (.=))
import Control.Lens qualified as Lens
import Control.Monad.Trans.Cont
import Data.Aeson.Key qualified as Key
import Data.Aeson.Types qualified as A
import Data.Bifunctor.Joker
import Data.List.NonEmpty (NonEmpty)
import Data.List.NonEmpty qualified as NonEmpty
import Data.Map qualified as Map
import Data.Monoid hiding (Product)
import Data.OpenApi qualified as S
import Data.OpenApi.Declare qualified as S
import Data.Profunctor (Star (..))
import Data.Proxy (Proxy (..))
import Data.Set qualified as Set
import Data.Text qualified as T
import Data.Text.Lazy qualified as TL
import Data.Vector qualified as V
import Imports hiding (Product)
import Numeric.Natural

type Declare = S.Declare (S.Definitions S.Schema)

newtype SchemaIn v a b = SchemaIn (v -> A.Parser b)
  deriving ((forall a b. (a -> b) -> SchemaIn v a a -> SchemaIn v a b)
-> (forall a b. a -> SchemaIn v a b -> SchemaIn v a a)
-> Functor (SchemaIn v a)
forall a b. a -> SchemaIn v a b -> SchemaIn v a a
forall a b. (a -> b) -> SchemaIn v a a -> SchemaIn v a b
forall v k (a :: k) a b. a -> SchemaIn v a b -> SchemaIn v a a
forall v k (a :: k) a b.
(a -> b) -> SchemaIn v a a -> SchemaIn v a b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall v k (a :: k) a b.
(a -> b) -> SchemaIn v a a -> SchemaIn v a b
fmap :: forall a b. (a -> b) -> SchemaIn v a a -> SchemaIn v a b
$c<$ :: forall v k (a :: k) a b. a -> SchemaIn v a b -> SchemaIn v a a
<$ :: forall a b. a -> SchemaIn v a b -> SchemaIn v a a
Functor)
  deriving (Functor (SchemaIn v a)
Functor (SchemaIn v a) =>
(forall a. a -> SchemaIn v a a)
-> (forall a b.
    SchemaIn v a (a -> b) -> SchemaIn v a a -> SchemaIn v a b)
-> (forall a b c.
    (a -> b -> c)
    -> SchemaIn v a a -> SchemaIn v a b -> SchemaIn v a c)
-> (forall a b. SchemaIn v a a -> SchemaIn v a b -> SchemaIn v a b)
-> (forall a b. SchemaIn v a a -> SchemaIn v a b -> SchemaIn v a a)
-> Applicative (SchemaIn v a)
forall a. a -> SchemaIn v a a
forall k (a :: k) v. Functor (SchemaIn v a)
forall k (a :: k) v a. a -> SchemaIn v a a
forall k (a :: k) v a b.
SchemaIn v a a -> SchemaIn v a b -> SchemaIn v a a
forall k (a :: k) v a b.
SchemaIn v a a -> SchemaIn v a b -> SchemaIn v a b
forall k (a :: k) v a b.
SchemaIn v a (a -> b) -> SchemaIn v a a -> SchemaIn v a b
forall k (a :: k) v a b c.
(a -> b -> c) -> SchemaIn v a a -> SchemaIn v a b -> SchemaIn v a c
forall a b. SchemaIn v a a -> SchemaIn v a b -> SchemaIn v a a
forall a b. SchemaIn v a a -> SchemaIn v a b -> SchemaIn v a b
forall a b.
SchemaIn v a (a -> b) -> SchemaIn v a a -> SchemaIn v a b
forall a b c.
(a -> b -> c) -> SchemaIn v a a -> SchemaIn v a b -> SchemaIn v a c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall k (a :: k) v a. a -> SchemaIn v a a
pure :: forall a. a -> SchemaIn v a a
$c<*> :: forall k (a :: k) v a b.
SchemaIn v a (a -> b) -> SchemaIn v a a -> SchemaIn v a b
<*> :: forall a b.
SchemaIn v a (a -> b) -> SchemaIn v a a -> SchemaIn v a b
$cliftA2 :: forall k (a :: k) v a b c.
(a -> b -> c) -> SchemaIn v a a -> SchemaIn v a b -> SchemaIn v a c
liftA2 :: forall a b c.
(a -> b -> c) -> SchemaIn v a a -> SchemaIn v a b -> SchemaIn v a c
$c*> :: forall k (a :: k) v a b.
SchemaIn v a a -> SchemaIn v a b -> SchemaIn v a b
*> :: forall a b. SchemaIn v a a -> SchemaIn v a b -> SchemaIn v a b
$c<* :: forall k (a :: k) v a b.
SchemaIn v a a -> SchemaIn v a b -> SchemaIn v a a
<* :: forall a b. SchemaIn v a a -> SchemaIn v a b -> SchemaIn v a a
Applicative, Applicative (SchemaIn v a)
Applicative (SchemaIn v a) =>
(forall a. SchemaIn v a a)
-> (forall a. SchemaIn v a a -> SchemaIn v a a -> SchemaIn v a a)
-> (forall a. SchemaIn v a a -> SchemaIn v a [a])
-> (forall a. SchemaIn v a a -> SchemaIn v a [a])
-> Alternative (SchemaIn v a)
forall a. SchemaIn v a a
forall a. SchemaIn v a a -> SchemaIn v a [a]
forall a. SchemaIn v a a -> SchemaIn v a a -> SchemaIn v a a
forall k (a :: k) v. Applicative (SchemaIn v a)
forall k (a :: k) v a. SchemaIn v a a
forall k (a :: k) v a. SchemaIn v a a -> SchemaIn v a [a]
forall k (a :: k) v a.
SchemaIn v a a -> SchemaIn v a a -> SchemaIn v a a
forall (f :: * -> *).
Applicative f =>
(forall a. f a)
-> (forall a. f a -> f a -> f a)
-> (forall a. f a -> f [a])
-> (forall a. f a -> f [a])
-> Alternative f
$cempty :: forall k (a :: k) v a. SchemaIn v a a
empty :: forall a. SchemaIn v a a
$c<|> :: forall k (a :: k) v a.
SchemaIn v a a -> SchemaIn v a a -> SchemaIn v a a
<|> :: forall a. SchemaIn v a a -> SchemaIn v a a -> SchemaIn v a a
$csome :: forall k (a :: k) v a. SchemaIn v a a -> SchemaIn v a [a]
some :: forall a. SchemaIn v a a -> SchemaIn v a [a]
$cmany :: forall k (a :: k) v a. SchemaIn v a a -> SchemaIn v a [a]
many :: forall a. SchemaIn v a a -> SchemaIn v a [a]
Alternative) via (ReaderT v A.Parser)
  deriving ((forall a b c d.
 (a -> b) -> (c -> d) -> SchemaIn v b c -> SchemaIn v a d)
-> (forall a b c. (a -> b) -> SchemaIn v b c -> SchemaIn v a c)
-> (forall b c a. (b -> c) -> SchemaIn v a b -> SchemaIn v a c)
-> (forall a b c (q :: * -> * -> *).
    Coercible c b =>
    q b c -> SchemaIn v a b -> SchemaIn v a c)
-> (forall a b c (q :: * -> * -> *).
    Coercible b a =>
    SchemaIn v b c -> q a b -> SchemaIn v a c)
-> Profunctor (SchemaIn v)
forall a b c. (a -> b) -> SchemaIn v b c -> SchemaIn v a c
forall b c a. (b -> c) -> SchemaIn v a b -> SchemaIn v a c
forall a b c d.
(a -> b) -> (c -> d) -> SchemaIn v b c -> SchemaIn v a d
forall v a b c. (a -> b) -> SchemaIn v b c -> SchemaIn v a c
forall v b c a. (b -> c) -> SchemaIn v a b -> SchemaIn v a c
forall v a b c d.
(a -> b) -> (c -> d) -> SchemaIn v b c -> SchemaIn v a d
forall v a b c (q :: * -> * -> *).
Coercible b a =>
SchemaIn v b c -> q a b -> SchemaIn v a c
forall v a b c (q :: * -> * -> *).
Coercible c b =>
q b c -> SchemaIn v a b -> SchemaIn v a c
forall a b c (q :: * -> * -> *).
Coercible b a =>
SchemaIn v b c -> q a b -> SchemaIn v a c
forall a b c (q :: * -> * -> *).
Coercible c b =>
q b c -> SchemaIn v a b -> SchemaIn v a c
forall (p :: * -> * -> *).
(forall a b c d. (a -> b) -> (c -> d) -> p b c -> p a d)
-> (forall a b c. (a -> b) -> p b c -> p a c)
-> (forall b c a. (b -> c) -> p a b -> p a c)
-> (forall a b c (q :: * -> * -> *).
    Coercible c b =>
    q b c -> p a b -> p a c)
-> (forall a b c (q :: * -> * -> *).
    Coercible b a =>
    p b c -> q a b -> p a c)
-> Profunctor p
$cdimap :: forall v a b c d.
(a -> b) -> (c -> d) -> SchemaIn v b c -> SchemaIn v a d
dimap :: forall a b c d.
(a -> b) -> (c -> d) -> SchemaIn v b c -> SchemaIn v a d
$clmap :: forall v a b c. (a -> b) -> SchemaIn v b c -> SchemaIn v a c
lmap :: forall a b c. (a -> b) -> SchemaIn v b c -> SchemaIn v a c
$crmap :: forall v b c a. (b -> c) -> SchemaIn v a b -> SchemaIn v a c
rmap :: forall b c a. (b -> c) -> SchemaIn v a b -> SchemaIn v a c
$c#. :: forall v a b c (q :: * -> * -> *).
Coercible c b =>
q b c -> SchemaIn v a b -> SchemaIn v a c
#. :: forall a b c (q :: * -> * -> *).
Coercible c b =>
q b c -> SchemaIn v a b -> SchemaIn v a c
$c.# :: forall v a b c (q :: * -> * -> *).
Coercible b a =>
SchemaIn v b c -> q a b -> SchemaIn v a c
.# :: forall a b c (q :: * -> * -> *).
Coercible b a =>
SchemaIn v b c -> q a b -> SchemaIn v a c
Profunctor, Profunctor (SchemaIn v)
Profunctor (SchemaIn v) =>
(forall a b c.
 SchemaIn v a b -> SchemaIn v (Either a c) (Either b c))
-> (forall a b c.
    SchemaIn v a b -> SchemaIn v (Either c a) (Either c b))
-> Choice (SchemaIn v)
forall v. Profunctor (SchemaIn v)
forall a b c.
SchemaIn v a b -> SchemaIn v (Either a c) (Either b c)
forall a b c.
SchemaIn v a b -> SchemaIn v (Either c a) (Either c b)
forall v a b c.
SchemaIn v a b -> SchemaIn v (Either a c) (Either b c)
forall v a b c.
SchemaIn v a b -> SchemaIn v (Either c a) (Either c b)
forall (p :: * -> * -> *).
Profunctor p =>
(forall a b c. p a b -> p (Either a c) (Either b c))
-> (forall a b c. p a b -> p (Either c a) (Either c b)) -> Choice p
$cleft' :: forall v a b c.
SchemaIn v a b -> SchemaIn v (Either a c) (Either b c)
left' :: forall a b c.
SchemaIn v a b -> SchemaIn v (Either a c) (Either b c)
$cright' :: forall v a b c.
SchemaIn v a b -> SchemaIn v (Either c a) (Either c b)
right' :: forall a b c.
SchemaIn v a b -> SchemaIn v (Either c a) (Either c b)
Choice) via Joker (ReaderT v A.Parser)

instance Semigroup (SchemaIn v a b) where
  <> :: SchemaIn v a b -> SchemaIn v a b -> SchemaIn v a b
(<>) = SchemaIn v a b -> SchemaIn v a b -> SchemaIn v a b
forall b. SchemaIn v a b -> SchemaIn v a b -> SchemaIn v a b
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>)

instance Monoid (SchemaIn v a b) where
  mempty :: SchemaIn v a b
mempty = SchemaIn v a b
forall b. SchemaIn v a b
forall (f :: * -> *) a. Alternative f => f a
empty

newtype SchemaOut v a b = SchemaOut (a -> Maybe v)
  deriving ((forall a b. (a -> b) -> SchemaOut v a a -> SchemaOut v a b)
-> (forall a b. a -> SchemaOut v a b -> SchemaOut v a a)
-> Functor (SchemaOut v a)
forall a b. a -> SchemaOut v a b -> SchemaOut v a a
forall a b. (a -> b) -> SchemaOut v a a -> SchemaOut v a b
forall v a a b. a -> SchemaOut v a b -> SchemaOut v a a
forall v a a b. (a -> b) -> SchemaOut v a a -> SchemaOut v a b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall v a a b. (a -> b) -> SchemaOut v a a -> SchemaOut v a b
fmap :: forall a b. (a -> b) -> SchemaOut v a a -> SchemaOut v a b
$c<$ :: forall v a a b. a -> SchemaOut v a b -> SchemaOut v a a
<$ :: forall a b. a -> SchemaOut v a b -> SchemaOut v a a
Functor)
  deriving (Functor (SchemaOut v a)
Functor (SchemaOut v a) =>
(forall a. a -> SchemaOut v a a)
-> (forall a b.
    SchemaOut v a (a -> b) -> SchemaOut v a a -> SchemaOut v a b)
-> (forall a b c.
    (a -> b -> c)
    -> SchemaOut v a a -> SchemaOut v a b -> SchemaOut v a c)
-> (forall a b.
    SchemaOut v a a -> SchemaOut v a b -> SchemaOut v a b)
-> (forall a b.
    SchemaOut v a a -> SchemaOut v a b -> SchemaOut v a a)
-> Applicative (SchemaOut v a)
forall a. a -> SchemaOut v a a
forall a v. Monoid v => Functor (SchemaOut v a)
forall a v a. Monoid v => a -> SchemaOut v a a
forall a v a b.
Monoid v =>
SchemaOut v a a -> SchemaOut v a b -> SchemaOut v a a
forall a v a b.
Monoid v =>
SchemaOut v a a -> SchemaOut v a b -> SchemaOut v a b
forall a v a b.
Monoid v =>
SchemaOut v a (a -> b) -> SchemaOut v a a -> SchemaOut v a b
forall a v a b c.
Monoid v =>
(a -> b -> c)
-> SchemaOut v a a -> SchemaOut v a b -> SchemaOut v a c
forall a b. SchemaOut v a a -> SchemaOut v a b -> SchemaOut v a a
forall a b. SchemaOut v a a -> SchemaOut v a b -> SchemaOut v a b
forall a b.
SchemaOut v a (a -> b) -> SchemaOut v a a -> SchemaOut v a b
forall a b c.
(a -> b -> c)
-> SchemaOut v a a -> SchemaOut v a b -> SchemaOut v a c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a v a. Monoid v => a -> SchemaOut v a a
pure :: forall a. a -> SchemaOut v a a
$c<*> :: forall a v a b.
Monoid v =>
SchemaOut v a (a -> b) -> SchemaOut v a a -> SchemaOut v a b
<*> :: forall a b.
SchemaOut v a (a -> b) -> SchemaOut v a a -> SchemaOut v a b
$cliftA2 :: forall a v a b c.
Monoid v =>
(a -> b -> c)
-> SchemaOut v a a -> SchemaOut v a b -> SchemaOut v a c
liftA2 :: forall a b c.
(a -> b -> c)
-> SchemaOut v a a -> SchemaOut v a b -> SchemaOut v a c
$c*> :: forall a v a b.
Monoid v =>
SchemaOut v a a -> SchemaOut v a b -> SchemaOut v a b
*> :: forall a b. SchemaOut v a a -> SchemaOut v a b -> SchemaOut v a b
$c<* :: forall a v a b.
Monoid v =>
SchemaOut v a a -> SchemaOut v a b -> SchemaOut v a a
<* :: forall a b. SchemaOut v a a -> SchemaOut v a b -> SchemaOut v a a
Applicative) via (ReaderT a (Const (Ap Maybe v)))
  deriving ((forall a b c d.
 (a -> b) -> (c -> d) -> SchemaOut v b c -> SchemaOut v a d)
-> (forall a b c. (a -> b) -> SchemaOut v b c -> SchemaOut v a c)
-> (forall b c a. (b -> c) -> SchemaOut v a b -> SchemaOut v a c)
-> (forall a b c (q :: * -> * -> *).
    Coercible c b =>
    q b c -> SchemaOut v a b -> SchemaOut v a c)
-> (forall a b c (q :: * -> * -> *).
    Coercible b a =>
    SchemaOut v b c -> q a b -> SchemaOut v a c)
-> Profunctor (SchemaOut v)
forall a b c. (a -> b) -> SchemaOut v b c -> SchemaOut v a c
forall b c a. (b -> c) -> SchemaOut v a b -> SchemaOut v a c
forall a b c d.
(a -> b) -> (c -> d) -> SchemaOut v b c -> SchemaOut v a d
forall v a b c. (a -> b) -> SchemaOut v b c -> SchemaOut v a c
forall v b c a. (b -> c) -> SchemaOut v a b -> SchemaOut v a c
forall v a b c d.
(a -> b) -> (c -> d) -> SchemaOut v b c -> SchemaOut v a d
forall v a b c (q :: * -> * -> *).
Coercible b a =>
SchemaOut v b c -> q a b -> SchemaOut v a c
forall v a b c (q :: * -> * -> *).
Coercible c b =>
q b c -> SchemaOut v a b -> SchemaOut v a c
forall a b c (q :: * -> * -> *).
Coercible b a =>
SchemaOut v b c -> q a b -> SchemaOut v a c
forall a b c (q :: * -> * -> *).
Coercible c b =>
q b c -> SchemaOut v a b -> SchemaOut v a c
forall (p :: * -> * -> *).
(forall a b c d. (a -> b) -> (c -> d) -> p b c -> p a d)
-> (forall a b c. (a -> b) -> p b c -> p a c)
-> (forall b c a. (b -> c) -> p a b -> p a c)
-> (forall a b c (q :: * -> * -> *).
    Coercible c b =>
    q b c -> p a b -> p a c)
-> (forall a b c (q :: * -> * -> *).
    Coercible b a =>
    p b c -> q a b -> p a c)
-> Profunctor p
$cdimap :: forall v a b c d.
(a -> b) -> (c -> d) -> SchemaOut v b c -> SchemaOut v a d
dimap :: forall a b c d.
(a -> b) -> (c -> d) -> SchemaOut v b c -> SchemaOut v a d
$clmap :: forall v a b c. (a -> b) -> SchemaOut v b c -> SchemaOut v a c
lmap :: forall a b c. (a -> b) -> SchemaOut v b c -> SchemaOut v a c
$crmap :: forall v b c a. (b -> c) -> SchemaOut v a b -> SchemaOut v a c
rmap :: forall b c a. (b -> c) -> SchemaOut v a b -> SchemaOut v a c
$c#. :: forall v a b c (q :: * -> * -> *).
Coercible c b =>
q b c -> SchemaOut v a b -> SchemaOut v a c
#. :: forall a b c (q :: * -> * -> *).
Coercible c b =>
q b c -> SchemaOut v a b -> SchemaOut v a c
$c.# :: forall v a b c (q :: * -> * -> *).
Coercible b a =>
SchemaOut v b c -> q a b -> SchemaOut v a c
.# :: forall a b c (q :: * -> * -> *).
Coercible b a =>
SchemaOut v b c -> q a b -> SchemaOut v a c
Profunctor) via Star (Const (Maybe v))
  deriving (Profunctor (SchemaOut v)
Profunctor (SchemaOut v) =>
(forall a b c.
 SchemaOut v a b -> SchemaOut v (Either a c) (Either b c))
-> (forall a b c.
    SchemaOut v a b -> SchemaOut v (Either c a) (Either c b))
-> Choice (SchemaOut v)
forall v. Profunctor (SchemaOut v)
forall a b c.
SchemaOut v a b -> SchemaOut v (Either a c) (Either b c)
forall a b c.
SchemaOut v a b -> SchemaOut v (Either c a) (Either c b)
forall v a b c.
SchemaOut v a b -> SchemaOut v (Either a c) (Either b c)
forall v a b c.
SchemaOut v a b -> SchemaOut v (Either c a) (Either c b)
forall (p :: * -> * -> *).
Profunctor p =>
(forall a b c. p a b -> p (Either a c) (Either b c))
-> (forall a b c. p a b -> p (Either c a) (Either c b)) -> Choice p
$cleft' :: forall v a b c.
SchemaOut v a b -> SchemaOut v (Either a c) (Either b c)
left' :: forall a b c.
SchemaOut v a b -> SchemaOut v (Either a c) (Either b c)
$cright' :: forall v a b c.
SchemaOut v a b -> SchemaOut v (Either c a) (Either c b)
right' :: forall a b c.
SchemaOut v a b -> SchemaOut v (Either c a) (Either c b)
Choice) via Star (Const (Alt Maybe v))

-- /Note/: deriving Choice via Star (Const (Maybe v)) would also
-- type-check, but it would use the wrong Monoid structure of Maybe v:
-- here we want the monoid structure corresponding to the Alternative
-- instance of Maybe, instead of the one coming from a Semigroup
-- structure of v.

-- The following instance is correct because `Ap Maybe v` is a
-- near-semiring when v is a monoid
instance (Monoid v) => Alternative (SchemaOut v a) where
  empty :: forall a. SchemaOut v a a
empty = SchemaOut v a a
forall a. Monoid a => a
mempty
  <|> :: forall a. SchemaOut v a a -> SchemaOut v a a -> SchemaOut v a a
(<|>) = SchemaOut v a a -> SchemaOut v a a -> SchemaOut v a a
forall a. Semigroup a => a -> a -> a
(<>)

instance Semigroup (SchemaOut v a b) where
  SchemaOut a -> Maybe v
x1 <> :: SchemaOut v a b -> SchemaOut v a b -> SchemaOut v a b
<> SchemaOut a -> Maybe v
x2 = (a -> Maybe v) -> SchemaOut v a b
forall {k} v a (b :: k). (a -> Maybe v) -> SchemaOut v a b
SchemaOut ((a -> Maybe v) -> SchemaOut v a b)
-> (a -> Maybe v) -> SchemaOut v a b
forall a b. (a -> b) -> a -> b
$ \a
a ->
    a -> Maybe v
x1 a
a Maybe v -> Maybe v -> Maybe v
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> a -> Maybe v
x2 a
a

instance Monoid (SchemaOut v a b) where
  mempty :: SchemaOut v a b
mempty = (a -> Maybe v) -> SchemaOut v a b
forall {k} v a (b :: k). (a -> Maybe v) -> SchemaOut v a b
SchemaOut (Maybe v -> a -> Maybe v
forall a. a -> a -> a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe v
forall a. Maybe a
forall (f :: * -> *) a. Alternative f => f a
empty)

-- | A near-semiring (aka seminearring).
--
-- This is used for schema documentation types, to support different behaviours
-- for composing schemas sequentially vs alternatively.
class (Monoid m) => NearSemiRing m where
  zero :: m
  add :: m -> m -> m

newtype SchemaDoc doc a b = SchemaDoc {forall {k} {k} doc (a :: k) (b :: k). SchemaDoc doc a b -> doc
getDoc :: doc}
  deriving ((forall a b. (a -> b) -> SchemaDoc doc a a -> SchemaDoc doc a b)
-> (forall a b. a -> SchemaDoc doc a b -> SchemaDoc doc a a)
-> Functor (SchemaDoc doc a)
forall a b. a -> SchemaDoc doc a b -> SchemaDoc doc a a
forall a b. (a -> b) -> SchemaDoc doc a a -> SchemaDoc doc a b
forall doc k (a :: k) a b.
a -> SchemaDoc doc a b -> SchemaDoc doc a a
forall doc k (a :: k) a b.
(a -> b) -> SchemaDoc doc a a -> SchemaDoc doc a b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall doc k (a :: k) a b.
(a -> b) -> SchemaDoc doc a a -> SchemaDoc doc a b
fmap :: forall a b. (a -> b) -> SchemaDoc doc a a -> SchemaDoc doc a b
$c<$ :: forall doc k (a :: k) a b.
a -> SchemaDoc doc a b -> SchemaDoc doc a a
<$ :: forall a b. a -> SchemaDoc doc a b -> SchemaDoc doc a a
Functor, NonEmpty (SchemaDoc doc a b) -> SchemaDoc doc a b
SchemaDoc doc a b -> SchemaDoc doc a b -> SchemaDoc doc a b
(SchemaDoc doc a b -> SchemaDoc doc a b -> SchemaDoc doc a b)
-> (NonEmpty (SchemaDoc doc a b) -> SchemaDoc doc a b)
-> (forall b.
    Integral b =>
    b -> SchemaDoc doc a b -> SchemaDoc doc a b)
-> Semigroup (SchemaDoc doc a b)
forall b. Integral b => b -> SchemaDoc doc a b -> SchemaDoc doc a b
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
forall doc k (a :: k) k (b :: k).
Semigroup doc =>
NonEmpty (SchemaDoc doc a b) -> SchemaDoc doc a b
forall doc k (a :: k) k (b :: k).
Semigroup doc =>
SchemaDoc doc a b -> SchemaDoc doc a b -> SchemaDoc doc a b
forall doc k (a :: k) k (b :: k) b.
(Semigroup doc, Integral b) =>
b -> SchemaDoc doc a b -> SchemaDoc doc a b
$c<> :: forall doc k (a :: k) k (b :: k).
Semigroup doc =>
SchemaDoc doc a b -> SchemaDoc doc a b -> SchemaDoc doc a b
<> :: SchemaDoc doc a b -> SchemaDoc doc a b -> SchemaDoc doc a b
$csconcat :: forall doc k (a :: k) k (b :: k).
Semigroup doc =>
NonEmpty (SchemaDoc doc a b) -> SchemaDoc doc a b
sconcat :: NonEmpty (SchemaDoc doc a b) -> SchemaDoc doc a b
$cstimes :: forall doc k (a :: k) k (b :: k) b.
(Semigroup doc, Integral b) =>
b -> SchemaDoc doc a b -> SchemaDoc doc a b
stimes :: forall b. Integral b => b -> SchemaDoc doc a b -> SchemaDoc doc a b
Semigroup, Semigroup (SchemaDoc doc a b)
SchemaDoc doc a b
Semigroup (SchemaDoc doc a b) =>
SchemaDoc doc a b
-> (SchemaDoc doc a b -> SchemaDoc doc a b -> SchemaDoc doc a b)
-> ([SchemaDoc doc a b] -> SchemaDoc doc a b)
-> Monoid (SchemaDoc doc a b)
[SchemaDoc doc a b] -> SchemaDoc doc a b
SchemaDoc doc a b -> SchemaDoc doc a b -> SchemaDoc doc a b
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
forall doc k (a :: k) k (b :: k).
Monoid doc =>
Semigroup (SchemaDoc doc a b)
forall doc k (a :: k) k (b :: k). Monoid doc => SchemaDoc doc a b
forall doc k (a :: k) k (b :: k).
Monoid doc =>
[SchemaDoc doc a b] -> SchemaDoc doc a b
forall doc k (a :: k) k (b :: k).
Monoid doc =>
SchemaDoc doc a b -> SchemaDoc doc a b -> SchemaDoc doc a b
$cmempty :: forall doc k (a :: k) k (b :: k). Monoid doc => SchemaDoc doc a b
mempty :: SchemaDoc doc a b
$cmappend :: forall doc k (a :: k) k (b :: k).
Monoid doc =>
SchemaDoc doc a b -> SchemaDoc doc a b -> SchemaDoc doc a b
mappend :: SchemaDoc doc a b -> SchemaDoc doc a b -> SchemaDoc doc a b
$cmconcat :: forall doc k (a :: k) k (b :: k).
Monoid doc =>
[SchemaDoc doc a b] -> SchemaDoc doc a b
mconcat :: [SchemaDoc doc a b] -> SchemaDoc doc a b
Monoid, Monoid (SchemaDoc doc a b)
SchemaDoc doc a b
Monoid (SchemaDoc doc a b) =>
SchemaDoc doc a b
-> (SchemaDoc doc a b -> SchemaDoc doc a b -> SchemaDoc doc a b)
-> NearSemiRing (SchemaDoc doc a b)
SchemaDoc doc a b -> SchemaDoc doc a b -> SchemaDoc doc a b
forall m. Monoid m => m -> (m -> m -> m) -> NearSemiRing m
forall doc k (a :: k) k (b :: k).
NearSemiRing doc =>
Monoid (SchemaDoc doc a b)
forall doc k (a :: k) k (b :: k).
NearSemiRing doc =>
SchemaDoc doc a b
forall doc k (a :: k) k (b :: k).
NearSemiRing doc =>
SchemaDoc doc a b -> SchemaDoc doc a b -> SchemaDoc doc a b
$czero :: forall doc k (a :: k) k (b :: k).
NearSemiRing doc =>
SchemaDoc doc a b
zero :: SchemaDoc doc a b
$cadd :: forall doc k (a :: k) k (b :: k).
NearSemiRing doc =>
SchemaDoc doc a b -> SchemaDoc doc a b -> SchemaDoc doc a b
add :: SchemaDoc doc a b -> SchemaDoc doc a b -> SchemaDoc doc a b
NearSemiRing)
  deriving (Functor (SchemaDoc doc a)
Functor (SchemaDoc doc a) =>
(forall a. a -> SchemaDoc doc a a)
-> (forall a b.
    SchemaDoc doc a (a -> b) -> SchemaDoc doc a a -> SchemaDoc doc a b)
-> (forall a b c.
    (a -> b -> c)
    -> SchemaDoc doc a a -> SchemaDoc doc a b -> SchemaDoc doc a c)
-> (forall a b.
    SchemaDoc doc a a -> SchemaDoc doc a b -> SchemaDoc doc a b)
-> (forall a b.
    SchemaDoc doc a a -> SchemaDoc doc a b -> SchemaDoc doc a a)
-> Applicative (SchemaDoc doc a)
forall a. a -> SchemaDoc doc a a
forall k (a :: k) doc. Monoid doc => Functor (SchemaDoc doc a)
forall k (a :: k) doc a. Monoid doc => a -> SchemaDoc doc a a
forall k (a :: k) doc a b.
Monoid doc =>
SchemaDoc doc a a -> SchemaDoc doc a b -> SchemaDoc doc a a
forall k (a :: k) doc a b.
Monoid doc =>
SchemaDoc doc a a -> SchemaDoc doc a b -> SchemaDoc doc a b
forall k (a :: k) doc a b.
Monoid doc =>
SchemaDoc doc a (a -> b) -> SchemaDoc doc a a -> SchemaDoc doc a b
forall k (a :: k) doc a b c.
Monoid doc =>
(a -> b -> c)
-> SchemaDoc doc a a -> SchemaDoc doc a b -> SchemaDoc doc a c
forall a b.
SchemaDoc doc a a -> SchemaDoc doc a b -> SchemaDoc doc a a
forall a b.
SchemaDoc doc a a -> SchemaDoc doc a b -> SchemaDoc doc a b
forall a b.
SchemaDoc doc a (a -> b) -> SchemaDoc doc a a -> SchemaDoc doc a b
forall a b c.
(a -> b -> c)
-> SchemaDoc doc a a -> SchemaDoc doc a b -> SchemaDoc doc a c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall k (a :: k) doc a. Monoid doc => a -> SchemaDoc doc a a
pure :: forall a. a -> SchemaDoc doc a a
$c<*> :: forall k (a :: k) doc a b.
Monoid doc =>
SchemaDoc doc a (a -> b) -> SchemaDoc doc a a -> SchemaDoc doc a b
<*> :: forall a b.
SchemaDoc doc a (a -> b) -> SchemaDoc doc a a -> SchemaDoc doc a b
$cliftA2 :: forall k (a :: k) doc a b c.
Monoid doc =>
(a -> b -> c)
-> SchemaDoc doc a a -> SchemaDoc doc a b -> SchemaDoc doc a c
liftA2 :: forall a b c.
(a -> b -> c)
-> SchemaDoc doc a a -> SchemaDoc doc a b -> SchemaDoc doc a c
$c*> :: forall k (a :: k) doc a b.
Monoid doc =>
SchemaDoc doc a a -> SchemaDoc doc a b -> SchemaDoc doc a b
*> :: forall a b.
SchemaDoc doc a a -> SchemaDoc doc a b -> SchemaDoc doc a b
$c<* :: forall k (a :: k) doc a b.
Monoid doc =>
SchemaDoc doc a a -> SchemaDoc doc a b -> SchemaDoc doc a a
<* :: forall a b.
SchemaDoc doc a a -> SchemaDoc doc a b -> SchemaDoc doc a a
Applicative) via (Const doc)
  deriving ((forall a b c d.
 (a -> b) -> (c -> d) -> SchemaDoc doc b c -> SchemaDoc doc a d)
-> (forall a b c.
    (a -> b) -> SchemaDoc doc b c -> SchemaDoc doc a c)
-> (forall b c a.
    (b -> c) -> SchemaDoc doc a b -> SchemaDoc doc a c)
-> (forall a b c (q :: * -> * -> *).
    Coercible c b =>
    q b c -> SchemaDoc doc a b -> SchemaDoc doc a c)
-> (forall a b c (q :: * -> * -> *).
    Coercible b a =>
    SchemaDoc doc b c -> q a b -> SchemaDoc doc a c)
-> Profunctor (SchemaDoc doc)
forall a b c. (a -> b) -> SchemaDoc doc b c -> SchemaDoc doc a c
forall b c a. (b -> c) -> SchemaDoc doc a b -> SchemaDoc doc a c
forall a b c d.
(a -> b) -> (c -> d) -> SchemaDoc doc b c -> SchemaDoc doc a d
forall doc a b c.
(a -> b) -> SchemaDoc doc b c -> SchemaDoc doc a c
forall doc b c a.
(b -> c) -> SchemaDoc doc a b -> SchemaDoc doc a c
forall doc a b c d.
(a -> b) -> (c -> d) -> SchemaDoc doc b c -> SchemaDoc doc a d
forall doc a b c (q :: * -> * -> *).
Coercible b a =>
SchemaDoc doc b c -> q a b -> SchemaDoc doc a c
forall doc a b c (q :: * -> * -> *).
Coercible c b =>
q b c -> SchemaDoc doc a b -> SchemaDoc doc a c
forall a b c (q :: * -> * -> *).
Coercible b a =>
SchemaDoc doc b c -> q a b -> SchemaDoc doc a c
forall a b c (q :: * -> * -> *).
Coercible c b =>
q b c -> SchemaDoc doc a b -> SchemaDoc doc a c
forall (p :: * -> * -> *).
(forall a b c d. (a -> b) -> (c -> d) -> p b c -> p a d)
-> (forall a b c. (a -> b) -> p b c -> p a c)
-> (forall b c a. (b -> c) -> p a b -> p a c)
-> (forall a b c (q :: * -> * -> *).
    Coercible c b =>
    q b c -> p a b -> p a c)
-> (forall a b c (q :: * -> * -> *).
    Coercible b a =>
    p b c -> q a b -> p a c)
-> Profunctor p
$cdimap :: forall doc a b c d.
(a -> b) -> (c -> d) -> SchemaDoc doc b c -> SchemaDoc doc a d
dimap :: forall a b c d.
(a -> b) -> (c -> d) -> SchemaDoc doc b c -> SchemaDoc doc a d
$clmap :: forall doc a b c.
(a -> b) -> SchemaDoc doc b c -> SchemaDoc doc a c
lmap :: forall a b c. (a -> b) -> SchemaDoc doc b c -> SchemaDoc doc a c
$crmap :: forall doc b c a.
(b -> c) -> SchemaDoc doc a b -> SchemaDoc doc a c
rmap :: forall b c a. (b -> c) -> SchemaDoc doc a b -> SchemaDoc doc a c
$c#. :: forall doc a b c (q :: * -> * -> *).
Coercible c b =>
q b c -> SchemaDoc doc a b -> SchemaDoc doc a c
#. :: forall a b c (q :: * -> * -> *).
Coercible c b =>
q b c -> SchemaDoc doc a b -> SchemaDoc doc a c
$c.# :: forall doc a b c (q :: * -> * -> *).
Coercible b a =>
SchemaDoc doc b c -> q a b -> SchemaDoc doc a c
.# :: forall a b c (q :: * -> * -> *).
Coercible b a =>
SchemaDoc doc b c -> q a b -> SchemaDoc doc a c
Profunctor, Profunctor (SchemaDoc doc)
Profunctor (SchemaDoc doc) =>
(forall a b c.
 SchemaDoc doc a b -> SchemaDoc doc (Either a c) (Either b c))
-> (forall a b c.
    SchemaDoc doc a b -> SchemaDoc doc (Either c a) (Either c b))
-> Choice (SchemaDoc doc)
forall doc. Profunctor (SchemaDoc doc)
forall a b c.
SchemaDoc doc a b -> SchemaDoc doc (Either a c) (Either b c)
forall a b c.
SchemaDoc doc a b -> SchemaDoc doc (Either c a) (Either c b)
forall doc a b c.
SchemaDoc doc a b -> SchemaDoc doc (Either a c) (Either b c)
forall doc a b c.
SchemaDoc doc a b -> SchemaDoc doc (Either c a) (Either c b)
forall (p :: * -> * -> *).
Profunctor p =>
(forall a b c. p a b -> p (Either a c) (Either b c))
-> (forall a b c. p a b -> p (Either c a) (Either c b)) -> Choice p
$cleft' :: forall doc a b c.
SchemaDoc doc a b -> SchemaDoc doc (Either a c) (Either b c)
left' :: forall a b c.
SchemaDoc doc a b -> SchemaDoc doc (Either a c) (Either b c)
$cright' :: forall doc a b c.
SchemaDoc doc a b -> SchemaDoc doc (Either c a) (Either c b)
right' :: forall a b c.
SchemaDoc doc a b -> SchemaDoc doc (Either c a) (Either c b)
Choice) via Joker (Const doc)

instance (NearSemiRing doc) => Alternative (SchemaDoc doc a) where
  empty :: forall a. SchemaDoc doc a a
empty = SchemaDoc doc a a
forall m. NearSemiRing m => m
zero
  <|> :: forall a.
SchemaDoc doc a a -> SchemaDoc doc a a -> SchemaDoc doc a a
(<|>) = SchemaDoc doc a a -> SchemaDoc doc a a -> SchemaDoc doc a a
forall m. NearSemiRing m => m -> m -> m
add

class HasDoc a a' doc doc' | a a' -> doc doc' where
  doc :: Lens a a' doc doc'

instance HasDoc (SchemaDoc doc a b) (SchemaDoc doc' a b) doc doc' where
  doc :: Lens (SchemaDoc doc a b) (SchemaDoc doc' a b) doc doc'
doc = (SchemaDoc doc a b -> doc)
-> (SchemaDoc doc a b -> doc' -> SchemaDoc doc' a b)
-> Lens (SchemaDoc doc a b) (SchemaDoc doc' a b) doc doc'
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens SchemaDoc doc a b -> doc
forall {k} {k} doc (a :: k) (b :: k). SchemaDoc doc a b -> doc
getDoc ((SchemaDoc doc a b -> doc' -> SchemaDoc doc' a b)
 -> Lens (SchemaDoc doc a b) (SchemaDoc doc' a b) doc doc')
-> (SchemaDoc doc a b -> doc' -> SchemaDoc doc' a b)
-> Lens (SchemaDoc doc a b) (SchemaDoc doc' a b) doc doc'
forall a b. (a -> b) -> a -> b
$ \SchemaDoc doc a b
s doc'
d -> SchemaDoc doc a b
s {getDoc = d}

-- | A combined JSON encoder-decoder with associated documentation.
--
-- A value of type 'SchemaP d v w a b', which we will refer to as a
-- /schema/, contains both a JSON parser and a JSON serialiser,
-- together with documentation-like metadata, such as a JSON or
-- Swagger schema.
--
-- The type variables are as follows:
--
--   [@d@] documentation type, usually a 'Monoid'.
--   [@v@] type of JSON values being parsed (e.g. 'A.Value').
--   [@w@] type of JSON values being serialised (e.g. 'A.Value').
--   [@a@] input type
--   [@b@] output type
--
-- Input and output types deserve some more explanation. We can think
-- of a value @sch@ of type 'SchemaP d v w a b' as a kind of special
-- "function" from @a@ to @b@, but where @a@ and @b@ might potentially
-- live in different "languages". The parser portion of @sch@ takes a
-- JSON-encoded value of type @a@ and produces a value of type @b@,
-- while the serialiser portion of @sch@ takes a haskell value of type
-- @a@ and produces a JSON-encoding of something of type @b@.
--
-- In terms of composability, this way of representing schemas (based
-- on input and output types) is superior to the perhaps more natural
-- approach of using "bidirectional functions" or isomorphisms (based
-- on a single type parameter).
--
-- Although schemas cannot be composed as functions (i.e. they do not
-- form a 'Category'), they still admit a number of important and
-- useful instances, such as 'Profunctor' (and specifically 'Choice'),
-- which makes it possible to use prism quite effectively to build
-- schema values.
--
-- Using type variables to represent JSON types might seem like
-- excessive generality, but it is useful to represent "intermediate"
-- schemas arising when building complex ones. For example, a schema
-- which is able to work with fields of a JSON object (see 'field')
-- should not output full-blown objects, but only lists of pairs, so
-- that they can be combined correctly via the usual 'Monoid'
-- structure of lists when using the 'Applicative' interface of
-- 'SchemaP d v w a b'.
--
-- The idea of using the profunctor structure of 'SchemaP' is taken
-- from the [codec](https://github.com/chpatrick/codec) library.
data SchemaP doc v w a b
  = SchemaP
      (SchemaDoc doc a b)
      (SchemaIn v a b)
      (SchemaOut w a b)
  deriving ((forall a b.
 (a -> b) -> SchemaP doc v w a a -> SchemaP doc v w a b)
-> (forall a b. a -> SchemaP doc v w a b -> SchemaP doc v w a a)
-> Functor (SchemaP doc v w a)
forall a b. a -> SchemaP doc v w a b -> SchemaP doc v w a a
forall a b. (a -> b) -> SchemaP doc v w a a -> SchemaP doc v w a b
forall doc v w a a b.
a -> SchemaP doc v w a b -> SchemaP doc v w a a
forall doc v w a a b.
(a -> b) -> SchemaP doc v w a a -> SchemaP doc v w a b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall doc v w a a b.
(a -> b) -> SchemaP doc v w a a -> SchemaP doc v w a b
fmap :: forall a b. (a -> b) -> SchemaP doc v w a a -> SchemaP doc v w a b
$c<$ :: forall doc v w a a b.
a -> SchemaP doc v w a b -> SchemaP doc v w a a
<$ :: forall a b. a -> SchemaP doc v w a b -> SchemaP doc v w a a
Functor)

-- | Build a schema from documentation, parser and serialiser
mkSchema :: doc -> (v -> A.Parser b) -> (a -> Maybe w) -> SchemaP doc v w a b
mkSchema :: forall doc v b a w.
doc -> (v -> Parser b) -> (a -> Maybe w) -> SchemaP doc v w a b
mkSchema doc
d v -> Parser b
i a -> Maybe w
o = SchemaDoc doc a b
-> SchemaIn v a b -> SchemaOut w a b -> SchemaP doc v w a b
forall doc v w a b.
SchemaDoc doc a b
-> SchemaIn v a b -> SchemaOut w a b -> SchemaP doc v w a b
SchemaP (doc -> SchemaDoc doc a b
forall {k} {k} doc (a :: k) (b :: k). doc -> SchemaDoc doc a b
SchemaDoc doc
d) ((v -> Parser b) -> SchemaIn v a b
forall {k} v (a :: k) b. (v -> Parser b) -> SchemaIn v a b
SchemaIn v -> Parser b
i) ((a -> Maybe w) -> SchemaOut w a b
forall {k} v a (b :: k). (a -> Maybe v) -> SchemaOut v a b
SchemaOut a -> Maybe w
o)

instance (Monoid doc, Monoid v') => Applicative (SchemaP doc v v' a) where
  pure :: forall a. a -> SchemaP doc v v' a a
pure a
x = SchemaDoc doc a a
-> SchemaIn v a a -> SchemaOut v' a a -> SchemaP doc v v' a a
forall doc v w a b.
SchemaDoc doc a b
-> SchemaIn v a b -> SchemaOut w a b -> SchemaP doc v w a b
SchemaP (a -> SchemaDoc doc a a
forall a. a -> SchemaDoc doc a a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x) (a -> SchemaIn v a a
forall a. a -> SchemaIn v a a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x) (a -> SchemaOut v' a a
forall a. a -> SchemaOut v' a a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x)
  SchemaP SchemaDoc doc a (a -> b)
d1 SchemaIn v a (a -> b)
i1 SchemaOut v' a (a -> b)
o1 <*> :: forall a b.
SchemaP doc v v' a (a -> b)
-> SchemaP doc v v' a a -> SchemaP doc v v' a b
<*> SchemaP SchemaDoc doc a a
d2 SchemaIn v a a
i2 SchemaOut v' a a
o2 =
    SchemaDoc doc a b
-> SchemaIn v a b -> SchemaOut v' a b -> SchemaP doc v v' a b
forall doc v w a b.
SchemaDoc doc a b
-> SchemaIn v a b -> SchemaOut w a b -> SchemaP doc v w a b
SchemaP (SchemaDoc doc a (a -> b)
d1 SchemaDoc doc a (a -> b) -> SchemaDoc doc a a -> SchemaDoc doc a b
forall a b.
SchemaDoc doc a (a -> b) -> SchemaDoc doc a a -> SchemaDoc doc a b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SchemaDoc doc a a
d2) (SchemaIn v a (a -> b)
i1 SchemaIn v a (a -> b) -> SchemaIn v a a -> SchemaIn v a b
forall a b.
SchemaIn v a (a -> b) -> SchemaIn v a a -> SchemaIn v a b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SchemaIn v a a
i2) (SchemaOut v' a (a -> b)
o1 SchemaOut v' a (a -> b) -> SchemaOut v' a a -> SchemaOut v' a b
forall a b.
SchemaOut v' a (a -> b) -> SchemaOut v' a a -> SchemaOut v' a b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SchemaOut v' a a
o2)

instance (NearSemiRing doc, Monoid v') => Alternative (SchemaP doc v v' a) where
  empty :: forall a. SchemaP doc v v' a a
empty = SchemaDoc doc a a
-> SchemaIn v a a -> SchemaOut v' a a -> SchemaP doc v v' a a
forall doc v w a b.
SchemaDoc doc a b
-> SchemaIn v a b -> SchemaOut w a b -> SchemaP doc v w a b
SchemaP SchemaDoc doc a a
forall a. SchemaDoc doc a a
forall (f :: * -> *) a. Alternative f => f a
empty SchemaIn v a a
forall a. SchemaIn v a a
forall (f :: * -> *) a. Alternative f => f a
empty SchemaOut v' a a
forall a. SchemaOut v' a a
forall (f :: * -> *) a. Alternative f => f a
empty
  SchemaP SchemaDoc doc a a
d1 SchemaIn v a a
i1 SchemaOut v' a a
o1 <|> :: forall a.
SchemaP doc v v' a a
-> SchemaP doc v v' a a -> SchemaP doc v v' a a
<|> SchemaP SchemaDoc doc a a
d2 SchemaIn v a a
i2 SchemaOut v' a a
o2 =
    SchemaDoc doc a a
-> SchemaIn v a a -> SchemaOut v' a a -> SchemaP doc v v' a a
forall doc v w a b.
SchemaDoc doc a b
-> SchemaIn v a b -> SchemaOut w a b -> SchemaP doc v w a b
SchemaP (SchemaDoc doc a a
d1 SchemaDoc doc a a -> SchemaDoc doc a a -> SchemaDoc doc a a
forall a.
SchemaDoc doc a a -> SchemaDoc doc a a -> SchemaDoc doc a a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> SchemaDoc doc a a
d2) (SchemaIn v a a
i1 SchemaIn v a a -> SchemaIn v a a -> SchemaIn v a a
forall a. SchemaIn v a a -> SchemaIn v a a -> SchemaIn v a a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> SchemaIn v a a
i2) (SchemaOut v' a a
o1 SchemaOut v' a a -> SchemaOut v' a a -> SchemaOut v' a a
forall a. SchemaOut v' a a -> SchemaOut v' a a -> SchemaOut v' a a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> SchemaOut v' a a
o2)

-- /Note/: this is a more general instance than the 'Alternative' one,
-- since it works for arbitrary v'
instance (Semigroup doc) => Semigroup (SchemaP doc v v' a b) where
  SchemaP SchemaDoc doc a b
d1 SchemaIn v a b
i1 SchemaOut v' a b
o1 <> :: SchemaP doc v v' a b
-> SchemaP doc v v' a b -> SchemaP doc v v' a b
<> SchemaP SchemaDoc doc a b
d2 SchemaIn v a b
i2 SchemaOut v' a b
o2 =
    SchemaDoc doc a b
-> SchemaIn v a b -> SchemaOut v' a b -> SchemaP doc v v' a b
forall doc v w a b.
SchemaDoc doc a b
-> SchemaIn v a b -> SchemaOut w a b -> SchemaP doc v w a b
SchemaP (SchemaDoc doc a b
d1 SchemaDoc doc a b -> SchemaDoc doc a b -> SchemaDoc doc a b
forall a. Semigroup a => a -> a -> a
<> SchemaDoc doc a b
d2) (SchemaIn v a b
i1 SchemaIn v a b -> SchemaIn v a b -> SchemaIn v a b
forall a. Semigroup a => a -> a -> a
<> SchemaIn v a b
i2) (SchemaOut v' a b
o1 SchemaOut v' a b -> SchemaOut v' a b -> SchemaOut v' a b
forall a. Semigroup a => a -> a -> a
<> SchemaOut v' a b
o2)

instance (Monoid doc) => Monoid (SchemaP doc v v' a b) where
  mempty :: SchemaP doc v v' a b
mempty = SchemaDoc doc a b
-> SchemaIn v a b -> SchemaOut v' a b -> SchemaP doc v v' a b
forall doc v w a b.
SchemaDoc doc a b
-> SchemaIn v a b -> SchemaOut w a b -> SchemaP doc v w a b
SchemaP SchemaDoc doc a b
forall a. Monoid a => a
mempty SchemaIn v a b
forall a. Monoid a => a
mempty SchemaOut v' a b
forall a. Monoid a => a
mempty

instance Profunctor (SchemaP doc v v') where
  dimap :: forall a b c d.
(a -> b)
-> (c -> d) -> SchemaP doc v v' b c -> SchemaP doc v v' a d
dimap a -> b
f c -> d
g (SchemaP SchemaDoc doc b c
d SchemaIn v b c
i SchemaOut v' b c
o) =
    SchemaDoc doc a d
-> SchemaIn v a d -> SchemaOut v' a d -> SchemaP doc v v' a d
forall doc v w a b.
SchemaDoc doc a b
-> SchemaIn v a b -> SchemaOut w a b -> SchemaP doc v w a b
SchemaP ((a -> b) -> (c -> d) -> SchemaDoc doc b c -> SchemaDoc doc a d
forall a b c d.
(a -> b) -> (c -> d) -> SchemaDoc doc b c -> SchemaDoc doc a d
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap a -> b
f c -> d
g SchemaDoc doc b c
d) ((a -> b) -> (c -> d) -> SchemaIn v b c -> SchemaIn v a d
forall a b c d.
(a -> b) -> (c -> d) -> SchemaIn v b c -> SchemaIn v a d
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap a -> b
f c -> d
g SchemaIn v b c
i) ((a -> b) -> (c -> d) -> SchemaOut v' b c -> SchemaOut v' a d
forall a b c d.
(a -> b) -> (c -> d) -> SchemaOut v' b c -> SchemaOut v' a d
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap a -> b
f c -> d
g SchemaOut v' b c
o)

instance Choice (SchemaP doc v v') where
  left' :: forall a b c.
SchemaP doc v v' a b -> SchemaP doc v v' (Either a c) (Either b c)
left' (SchemaP SchemaDoc doc a b
d SchemaIn v a b
i SchemaOut v' a b
o) = SchemaDoc doc (Either a c) (Either b c)
-> SchemaIn v (Either a c) (Either b c)
-> SchemaOut v' (Either a c) (Either b c)
-> SchemaP doc v v' (Either a c) (Either b c)
forall doc v w a b.
SchemaDoc doc a b
-> SchemaIn v a b -> SchemaOut w a b -> SchemaP doc v w a b
SchemaP (SchemaDoc doc a b -> SchemaDoc doc (Either a c) (Either b c)
forall a b c.
SchemaDoc doc a b -> SchemaDoc doc (Either a c) (Either b c)
forall (p :: * -> * -> *) a b c.
Choice p =>
p a b -> p (Either a c) (Either b c)
left' SchemaDoc doc a b
d) (SchemaIn v a b -> SchemaIn v (Either a c) (Either b c)
forall a b c.
SchemaIn v a b -> SchemaIn v (Either a c) (Either b c)
forall (p :: * -> * -> *) a b c.
Choice p =>
p a b -> p (Either a c) (Either b c)
left' SchemaIn v a b
i) (SchemaOut v' a b -> SchemaOut v' (Either a c) (Either b c)
forall a b c.
SchemaOut v' a b -> SchemaOut v' (Either a c) (Either b c)
forall (p :: * -> * -> *) a b c.
Choice p =>
p a b -> p (Either a c) (Either b c)
left' SchemaOut v' a b
o)
  right' :: forall a b c.
SchemaP doc v v' a b -> SchemaP doc v v' (Either c a) (Either c b)
right' (SchemaP SchemaDoc doc a b
d SchemaIn v a b
i SchemaOut v' a b
o) = SchemaDoc doc (Either c a) (Either c b)
-> SchemaIn v (Either c a) (Either c b)
-> SchemaOut v' (Either c a) (Either c b)
-> SchemaP doc v v' (Either c a) (Either c b)
forall doc v w a b.
SchemaDoc doc a b
-> SchemaIn v a b -> SchemaOut w a b -> SchemaP doc v w a b
SchemaP (SchemaDoc doc a b -> SchemaDoc doc (Either c a) (Either c b)
forall a b c.
SchemaDoc doc a b -> SchemaDoc doc (Either c a) (Either c b)
forall (p :: * -> * -> *) a b c.
Choice p =>
p a b -> p (Either c a) (Either c b)
right' SchemaDoc doc a b
d) (SchemaIn v a b -> SchemaIn v (Either c a) (Either c b)
forall a b c.
SchemaIn v a b -> SchemaIn v (Either c a) (Either c b)
forall (p :: * -> * -> *) a b c.
Choice p =>
p a b -> p (Either c a) (Either c b)
right' SchemaIn v a b
i) (SchemaOut v' a b -> SchemaOut v' (Either c a) (Either c b)
forall a b c.
SchemaOut v' a b -> SchemaOut v' (Either c a) (Either c b)
forall (p :: * -> * -> *) a b c.
Choice p =>
p a b -> p (Either c a) (Either c b)
right' SchemaOut v' a b
o)

instance HasDoc (SchemaP doc v v' a b) (SchemaP doc' v v' a b) doc doc' where
  doc :: Lens (SchemaP doc v v' a b) (SchemaP doc' v v' a b) doc doc'
doc = (SchemaP doc v v' a b -> doc)
-> (SchemaP doc v v' a b -> doc' -> SchemaP doc' v v' a b)
-> Lens (SchemaP doc v v' a b) (SchemaP doc' v v' a b) doc doc'
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens SchemaP doc v v' a b -> doc
forall ss v m a b. SchemaP ss v m a b -> ss
schemaDoc ((SchemaP doc v v' a b -> doc' -> SchemaP doc' v v' a b)
 -> Lens (SchemaP doc v v' a b) (SchemaP doc' v v' a b) doc doc')
-> (SchemaP doc v v' a b -> doc' -> SchemaP doc' v v' a b)
-> Lens (SchemaP doc v v' a b) (SchemaP doc' v v' a b) doc doc'
forall a b. (a -> b) -> a -> b
$ \(SchemaP SchemaDoc doc a b
d SchemaIn v a b
i SchemaOut v' a b
o) doc'
d' -> SchemaDoc doc' a b
-> SchemaIn v a b -> SchemaOut v' a b -> SchemaP doc' v v' a b
forall doc v w a b.
SchemaDoc doc a b
-> SchemaIn v a b -> SchemaOut w a b -> SchemaP doc v w a b
SchemaP (ASetter (SchemaDoc doc a b) (SchemaDoc doc' a b) doc doc'
-> doc' -> SchemaDoc doc a b -> SchemaDoc doc' a b
forall s t a b. ASetter s t a b -> b -> s -> t
Lens.set ASetter (SchemaDoc doc a b) (SchemaDoc doc' a b) doc doc'
forall a a' doc doc'. HasDoc a a' doc doc' => Lens a a' doc doc'
Lens (SchemaDoc doc a b) (SchemaDoc doc' a b) doc doc'
doc doc'
d' SchemaDoc doc a b
d) SchemaIn v a b
i SchemaOut v' a b
o

doc' :: Lens' (SchemaP doc v w a b) doc
doc' :: forall doc v w a b (f :: * -> *).
Functor f =>
(doc -> f doc) -> SchemaP doc v w a b -> f (SchemaP doc v w a b)
doc' = (doc -> f doc) -> SchemaP doc v w a b -> f (SchemaP doc v w a b)
forall a a' doc doc'. HasDoc a a' doc doc' => Lens a a' doc doc'
Lens (SchemaP doc v w a b) (SchemaP doc v w a b) doc doc
doc

withParser :: SchemaP doc v w a b -> (b -> A.Parser b') -> SchemaP doc v w a b'
withParser :: forall doc v w a b b'.
SchemaP doc v w a b -> (b -> Parser b') -> SchemaP doc v w a b'
withParser (SchemaP (SchemaDoc doc
d) (SchemaIn v -> Parser b
p) (SchemaOut a -> Maybe w
o)) b -> Parser b'
q =
  SchemaDoc doc a b'
-> SchemaIn v a b' -> SchemaOut w a b' -> SchemaP doc v w a b'
forall doc v w a b.
SchemaDoc doc a b
-> SchemaIn v a b -> SchemaOut w a b -> SchemaP doc v w a b
SchemaP (doc -> SchemaDoc doc a b'
forall {k} {k} doc (a :: k) (b :: k). doc -> SchemaDoc doc a b
SchemaDoc doc
d) ((v -> Parser b') -> SchemaIn v a b'
forall {k} v (a :: k) b. (v -> Parser b) -> SchemaIn v a b
SchemaIn (v -> Parser b
p (v -> Parser b) -> (b -> Parser b') -> v -> Parser b'
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> b -> Parser b'
q)) ((a -> Maybe w) -> SchemaOut w a b'
forall {k} v a (b :: k). (a -> Maybe v) -> SchemaOut v a b
SchemaOut a -> Maybe w
o)

type ObjectSchemaP doc = SchemaP doc A.Object [A.Pair]

type ObjectSchema doc a = ObjectSchemaP doc a a

type ValueSchemaP doc = SchemaP doc A.Value A.Value

type ValueSchema doc a = ValueSchemaP doc a a

schemaDoc :: SchemaP ss v m a b -> ss
schemaDoc :: forall ss v m a b. SchemaP ss v m a b -> ss
schemaDoc (SchemaP (SchemaDoc ss
d) SchemaIn v a b
_ SchemaOut m a b
_) = ss
d

schemaIn :: SchemaP doc v v' a b -> v -> A.Parser b
schemaIn :: forall doc v v' a b. SchemaP doc v v' a b -> v -> Parser b
schemaIn (SchemaP SchemaDoc doc a b
_ (SchemaIn v -> Parser b
i) SchemaOut v' a b
_) = v -> Parser b
i

schemaOut :: SchemaP ss v m a b -> a -> Maybe m
schemaOut :: forall ss v m a b. SchemaP ss v m a b -> a -> Maybe m
schemaOut (SchemaP SchemaDoc ss a b
_ SchemaIn v a b
_ (SchemaOut a -> Maybe m
o)) = a -> Maybe m
o

class (Functor f) => FieldFunctor doc f where
  parseFieldF :: (A.Value -> A.Parser a) -> A.Object -> Text -> A.Parser (f a)
  mkDocF :: doc -> doc

instance FieldFunctor doc Identity where
  parseFieldF :: forall a.
(Value -> Parser a) -> Object -> Text -> Parser (Identity a)
parseFieldF Value -> Parser a
f Object
obj Text
key = a -> Identity a
forall a. a -> Identity a
Identity (a -> Identity a) -> Parser a -> Parser (Identity a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value -> Parser a) -> Object -> Key -> Parser a
forall a. (Value -> Parser a) -> Object -> Key -> Parser a
A.explicitParseField Value -> Parser a
f Object
obj (Text -> Key
Key.fromText Text
key)
  mkDocF :: doc -> doc
mkDocF = doc -> doc
forall doc. doc -> doc
id

instance (HasOpt doc) => FieldFunctor doc Maybe where
  parseFieldF :: forall a. (Value -> Parser a) -> Object -> Text -> Parser (Maybe a)
parseFieldF Value -> Parser a
f Object
obj Text
key = (Value -> Parser a) -> Object -> Key -> Parser (Maybe a)
forall a. (Value -> Parser a) -> Object -> Key -> Parser (Maybe a)
A.explicitParseFieldMaybe Value -> Parser a
f Object
obj (Text -> Key
Key.fromText Text
key)
  mkDocF :: doc -> doc
mkDocF = doc -> doc
forall doc. HasOpt doc => doc -> doc
mkOpt

-- | A schema for a one-field JSON object.
field ::
  forall doc' doc a b.
  (HasField doc' doc) =>
  Text ->
  SchemaP doc' A.Value A.Value a b ->
  SchemaP doc A.Object [A.Pair] a b
field :: forall doc' doc a b.
HasField doc' doc =>
Text
-> SchemaP doc' Value Value a b -> SchemaP doc Object [Pair] a b
field = Lens Object Value Object Value
-> Text
-> SchemaP doc' Value Value a b
-> SchemaP doc Object [Pair] a b
forall doc' doc v v' a b.
HasField doc' doc =>
Lens v v' Object Value
-> Text -> SchemaP doc' v' Value a b -> SchemaP doc v [Pair] a b
fieldOver (Object -> f Value) -> Object -> f Value
forall doc. doc -> doc
Lens Object Value Object Value
id

-- | A schema for a JSON object with a single optional field.
optField ::
  forall doc doc' a b.
  (HasOpt doc, HasField doc' doc) =>
  Text ->
  SchemaP doc' A.Value A.Value a b ->
  SchemaP doc A.Object [A.Pair] a (Maybe b)
optField :: forall doc doc' a b.
(HasOpt doc, HasField doc' doc) =>
Text
-> SchemaP doc' Value Value a b
-> SchemaP doc Object [Pair] a (Maybe b)
optField = Text
-> SchemaP doc' Value Value a b
-> SchemaP doc Object [Pair] a (Maybe b)
forall doc' doc (f :: * -> *) a b.
(HasField doc' doc, FieldFunctor doc f) =>
Text
-> SchemaP doc' Value Value a b
-> SchemaP doc Object [Pair] a (f b)
fieldF

-- | Generalization of 'optField' with 'FieldFunctor'.
fieldF ::
  forall doc' doc f a b.
  (HasField doc' doc, FieldFunctor doc f) =>
  Text ->
  SchemaP doc' A.Value A.Value a b ->
  SchemaP doc A.Object [A.Pair] a (f b)
fieldF :: forall doc' doc (f :: * -> *) a b.
(HasField doc' doc, FieldFunctor doc f) =>
Text
-> SchemaP doc' Value Value a b
-> SchemaP doc Object [Pair] a (f b)
fieldF = Lens Object Value Object Value
-> Text
-> SchemaP doc' Value Value a b
-> SchemaP doc Object [Pair] a (f b)
forall (f :: * -> *) doc' doc v v' a b.
(HasField doc' doc, FieldFunctor doc f) =>
Lens v v' Object Value
-> Text
-> SchemaP doc' v' Value a b
-> SchemaP doc v [Pair] a (f b)
fieldOverF (Object -> f Value) -> Object -> f Value
forall doc. doc -> doc
Lens Object Value Object Value
id

newtype Positive x y a = Positive {forall x y a. Positive x y a -> (a -> x) -> y
runPositive :: (a -> x) -> y}
  deriving ((forall a b. (a -> b) -> Positive x y a -> Positive x y b)
-> (forall a b. a -> Positive x y b -> Positive x y a)
-> Functor (Positive x y)
forall a b. a -> Positive x y b -> Positive x y a
forall a b. (a -> b) -> Positive x y a -> Positive x y b
forall x y a b. a -> Positive x y b -> Positive x y a
forall x y a b. (a -> b) -> Positive x y a -> Positive x y b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall x y a b. (a -> b) -> Positive x y a -> Positive x y b
fmap :: forall a b. (a -> b) -> Positive x y a -> Positive x y b
$c<$ :: forall x y a b. a -> Positive x y b -> Positive x y a
<$ :: forall a b. a -> Positive x y b -> Positive x y a
Functor)

-- | A version of 'field' for more general input values.
--
-- This can be used when the input type 'v' of the parser is not exactly a
-- 'A.Object', but it contains one. The first argument is a lens that can
-- extract the 'A.Object' contained in 'v'.
--
-- See 'bind' for use cases.
fieldOverF ::
  forall f doc' doc v v' a b.
  (HasField doc' doc, FieldFunctor doc f) =>
  Lens v v' A.Object A.Value ->
  Text ->
  SchemaP doc' v' A.Value a b ->
  SchemaP doc v [A.Pair] a (f b)
fieldOverF :: forall (f :: * -> *) doc' doc v v' a b.
(HasField doc' doc, FieldFunctor doc f) =>
Lens v v' Object Value
-> Text
-> SchemaP doc' v' Value a b
-> SchemaP doc v [Pair] a (f b)
fieldOverF Lens v v' Object Value
l Text
name SchemaP doc' v' Value a b
sch = SchemaDoc doc a (f b)
-> SchemaIn v a (f b)
-> SchemaOut [Pair] a (f b)
-> SchemaP doc v [Pair] a (f b)
forall doc v w a b.
SchemaDoc doc a b
-> SchemaIn v a b -> SchemaOut w a b -> SchemaP doc v w a b
SchemaP (doc -> SchemaDoc doc a (f b)
forall {k} {k} doc (a :: k) (b :: k). doc -> SchemaDoc doc a b
SchemaDoc doc
s) ((v -> Parser (f b)) -> SchemaIn v a (f b)
forall {k} v (a :: k) b. (v -> Parser b) -> SchemaIn v a b
SchemaIn v -> Parser (f b)
r) ((a -> Maybe [Pair]) -> SchemaOut [Pair] a (f b)
forall {k} v a (b :: k). (a -> Maybe v) -> SchemaOut v a b
SchemaOut a -> Maybe [Pair]
w)
  where
    parseField :: A.Object -> Positive (A.Parser b) (A.Parser (f b)) A.Value
    parseField :: Object -> Positive (Parser b) (Parser (f b)) Value
parseField Object
obj = ((Value -> Parser b) -> Parser (f b))
-> Positive (Parser b) (Parser (f b)) Value
forall x y a. ((a -> x) -> y) -> Positive x y a
Positive (((Value -> Parser b) -> Parser (f b))
 -> Positive (Parser b) (Parser (f b)) Value)
-> ((Value -> Parser b) -> Parser (f b))
-> Positive (Parser b) (Parser (f b)) Value
forall a b. (a -> b) -> a -> b
$ \Value -> Parser b
k -> forall doc (f :: * -> *) a.
FieldFunctor doc f =>
(Value -> Parser a) -> Object -> Text -> Parser (f a)
parseFieldF @doc Value -> Parser b
k Object
obj Text
name

    r :: v -> A.Parser (f b)
    r :: v -> Parser (f b)
r v
obj = Positive (Parser b) (Parser (f b)) v'
-> (v' -> Parser b) -> Parser (f b)
forall x y a. Positive x y a -> (a -> x) -> y
runPositive ((Object -> Positive (Parser b) (Parser (f b)) Value)
-> v -> Positive (Parser b) (Parser (f b)) v'
Lens v v' Object Value
l Object -> Positive (Parser b) (Parser (f b)) Value
parseField v
obj) (SchemaP doc' v' Value a b -> v' -> Parser b
forall doc v v' a b. SchemaP doc v v' a b -> v -> Parser b
schemaIn SchemaP doc' v' Value a b
sch)

    w :: a -> Maybe [Pair]
w a
x = do
      Value
v <- SchemaP doc' v' Value a b -> a -> Maybe Value
forall ss v m a b. SchemaP ss v m a b -> a -> Maybe m
schemaOut SchemaP doc' v' Value a b
sch a
x
      [Pair] -> Maybe [Pair]
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Text -> Key
Key.fromText Text
name Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
A..= Value
v]

    s :: doc
s = forall doc (f :: * -> *). FieldFunctor doc f => doc -> doc
mkDocF @doc @f (Text -> doc' -> doc
forall ndoc doc. HasField ndoc doc => Text -> ndoc -> doc
mkField Text
name (SchemaP doc' v' Value a b -> doc'
forall ss v m a b. SchemaP ss v m a b -> ss
schemaDoc SchemaP doc' v' Value a b
sch))

-- | Like 'fieldOverF', but specialised to the identity functor.
fieldOver ::
  forall doc' doc v v' a b.
  (HasField doc' doc) =>
  Lens v v' A.Object A.Value ->
  Text ->
  SchemaP doc' v' A.Value a b ->
  SchemaP doc v [A.Pair] a b
fieldOver :: forall doc' doc v v' a b.
HasField doc' doc =>
Lens v v' Object Value
-> Text -> SchemaP doc' v' Value a b -> SchemaP doc v [Pair] a b
fieldOver Lens v v' Object Value
l Text
name = (Identity b -> b)
-> SchemaP doc v [Pair] a (Identity b) -> SchemaP doc v [Pair] a b
forall a b.
(a -> b) -> SchemaP doc v [Pair] a a -> SchemaP doc v [Pair] a b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Identity b -> b
forall a. Identity a -> a
runIdentity (SchemaP doc v [Pair] a (Identity b) -> SchemaP doc v [Pair] a b)
-> (SchemaP doc' v' Value a b
    -> SchemaP doc v [Pair] a (Identity b))
-> SchemaP doc' v' Value a b
-> SchemaP doc v [Pair] a b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens v v' Object Value
-> Text
-> SchemaP doc' v' Value a b
-> SchemaP doc v [Pair] a (Identity b)
forall (f :: * -> *) doc' doc v v' a b.
(HasField doc' doc, FieldFunctor doc f) =>
Lens v v' Object Value
-> Text
-> SchemaP doc' v' Value a b
-> SchemaP doc v [Pair] a (f b)
fieldOverF (Object -> f Value) -> v -> f v'
Lens v v' Object Value
l Text
name

-- | Like 'field', but apply an arbitrary function to the
-- documentation of the field.
fieldWithDocModifier ::
  forall doc' doc a b.
  (HasField doc' doc) =>
  Text ->
  (doc' -> doc') ->
  SchemaP doc' A.Value A.Value a b ->
  SchemaP doc A.Object [A.Pair] a b
fieldWithDocModifier :: forall doc' doc a b.
HasField doc' doc =>
Text
-> (doc' -> doc')
-> SchemaP doc' Value Value a b
-> SchemaP doc Object [Pair] a b
fieldWithDocModifier Text
name doc' -> doc'
modify SchemaP doc' Value Value a b
sch = forall doc' doc a b.
HasField doc' doc =>
Text
-> SchemaP doc' Value Value a b -> SchemaP doc Object [Pair] a b
field @doc' @doc Text
name (ASetter
  (SchemaP doc' Value Value a b)
  (SchemaP doc' Value Value a b)
  doc'
  doc'
-> (doc' -> doc')
-> SchemaP doc' Value Value a b
-> SchemaP doc' Value Value a b
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter
  (SchemaP doc' Value Value a b)
  (SchemaP doc' Value Value a b)
  doc'
  doc'
forall a a' doc doc'. HasDoc a a' doc doc' => Lens a a' doc doc'
Lens
  (SchemaP doc' Value Value a b)
  (SchemaP doc' Value Value a b)
  doc'
  doc'
doc doc' -> doc'
modify SchemaP doc' Value Value a b
sch)

-- | Like 'optField', but apply an arbitrary function to the
-- documentation of the field.
optFieldWithDocModifier ::
  forall doc doc' a b.
  (HasOpt doc, HasField doc' doc) =>
  Text ->
  (doc' -> doc') ->
  SchemaP doc' A.Value A.Value a b ->
  SchemaP doc A.Object [A.Pair] a (Maybe b)
optFieldWithDocModifier :: forall doc doc' a b.
(HasOpt doc, HasField doc' doc) =>
Text
-> (doc' -> doc')
-> SchemaP doc' Value Value a b
-> SchemaP doc Object [Pair] a (Maybe b)
optFieldWithDocModifier Text
name doc' -> doc'
modify SchemaP doc' Value Value a b
sch = forall doc doc' a b.
(HasOpt doc, HasField doc' doc) =>
Text
-> SchemaP doc' Value Value a b
-> SchemaP doc Object [Pair] a (Maybe b)
optField @doc @doc' Text
name (ASetter
  (SchemaP doc' Value Value a b)
  (SchemaP doc' Value Value a b)
  doc'
  doc'
-> (doc' -> doc')
-> SchemaP doc' Value Value a b
-> SchemaP doc' Value Value a b
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter
  (SchemaP doc' Value Value a b)
  (SchemaP doc' Value Value a b)
  doc'
  doc'
forall a a' doc doc'. HasDoc a a' doc doc' => Lens a a' doc doc'
Lens
  (SchemaP doc' Value Value a b)
  (SchemaP doc' Value Value a b)
  doc'
  doc'
doc doc' -> doc'
modify SchemaP doc' Value Value a b
sch)

-- | Like 'fieldF', but apply an arbitrary function to the
-- documentation of the field.
fieldWithDocModifierF ::
  forall doc' doc f a b.
  (HasField doc' doc, FieldFunctor doc f) =>
  Text ->
  (doc' -> doc') ->
  SchemaP doc' A.Value A.Value a b ->
  SchemaP doc A.Object [A.Pair] a (f b)
fieldWithDocModifierF :: forall doc' doc (f :: * -> *) a b.
(HasField doc' doc, FieldFunctor doc f) =>
Text
-> (doc' -> doc')
-> SchemaP doc' Value Value a b
-> SchemaP doc Object [Pair] a (f b)
fieldWithDocModifierF Text
name doc' -> doc'
modify SchemaP doc' Value Value a b
sch = forall doc' doc (f :: * -> *) a b.
(HasField doc' doc, FieldFunctor doc f) =>
Text
-> SchemaP doc' Value Value a b
-> SchemaP doc Object [Pair] a (f b)
fieldF @doc' @doc Text
name (ASetter
  (SchemaP doc' Value Value a b)
  (SchemaP doc' Value Value a b)
  doc'
  doc'
-> (doc' -> doc')
-> SchemaP doc' Value Value a b
-> SchemaP doc' Value Value a b
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter
  (SchemaP doc' Value Value a b)
  (SchemaP doc' Value Value a b)
  doc'
  doc'
forall a a' doc doc'. HasDoc a a' doc doc' => Lens a a' doc doc'
Lens
  (SchemaP doc' Value Value a b)
  (SchemaP doc' Value Value a b)
  doc'
  doc'
doc doc' -> doc'
modify SchemaP doc' Value Value a b
sch)

-- | Change the input type of a schema.
(.=) :: (Profunctor p) => (a -> a') -> p a' b -> p a b
.= :: forall (p :: * -> * -> *) a a' b.
Profunctor p =>
(a -> a') -> p a' b -> p a b
(.=) = (a -> a') -> p a' b -> p a b
forall a b c. (a -> b) -> p b c -> p a c
forall (p :: * -> * -> *) a b c.
Profunctor p =>
(a -> b) -> p b c -> p a c
lmap

-- | Change the input and output types of a schema via a prism.
tag :: Prism b b' a a' -> SchemaP ss v m a a' -> SchemaP ss v m b b'
tag :: forall b b' a a' ss v m.
Prism b b' a a' -> SchemaP ss v m a a' -> SchemaP ss v m b b'
tag Prism b b' a a'
f = (Identity b' -> b')
-> SchemaP ss v m b (Identity b') -> SchemaP ss v m b b'
forall b c a. (b -> c) -> SchemaP ss v m a b -> SchemaP ss v m a c
forall (p :: * -> * -> *) b c a.
Profunctor p =>
(b -> c) -> p a b -> p a c
rmap Identity b' -> b'
forall a. Identity a -> a
runIdentity (SchemaP ss v m b (Identity b') -> SchemaP ss v m b b')
-> (SchemaP ss v m a a' -> SchemaP ss v m b (Identity b'))
-> SchemaP ss v m a a'
-> SchemaP ss v m b b'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SchemaP ss v m a (Identity a') -> SchemaP ss v m b (Identity b')
Prism b b' a a'
f (SchemaP ss v m a (Identity a') -> SchemaP ss v m b (Identity b'))
-> (SchemaP ss v m a a' -> SchemaP ss v m a (Identity a'))
-> SchemaP ss v m a a'
-> SchemaP ss v m b (Identity b')
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a' -> Identity a')
-> SchemaP ss v m a a' -> SchemaP ss v m a (Identity a')
forall b c a. (b -> c) -> SchemaP ss v m a b -> SchemaP ss v m a c
forall (p :: * -> * -> *) b c a.
Profunctor p =>
(b -> c) -> p a b -> p a c
rmap a' -> Identity a'
forall a. a -> Identity a
Identity

-- | A schema for a JSON object.
--
-- This can be used to convert a combination of schemas obtained using
-- 'field' into a single schema for a JSON object.
object ::
  (HasObject doc doc') =>
  Text ->
  SchemaP doc A.Object [A.Pair] a b ->
  SchemaP doc' A.Value A.Value a b
object :: forall doc doc' a b.
HasObject doc doc' =>
Text
-> SchemaP doc Object [Pair] a b -> SchemaP doc' Value Value a b
object = Lens Value Object Value Object
-> Text
-> SchemaP doc Object [Pair] a b
-> SchemaP doc' Value Value a b
forall doc doc' v v' a b.
HasObject doc doc' =>
Lens v v' Value Object
-> Text -> SchemaP doc v' [Pair] a b -> SchemaP doc' v Value a b
objectOver (Value -> f Object) -> Value -> f Object
forall doc. doc -> doc
Lens Value Object Value Object
id

-- | A version of 'object' for more general input values.
--
-- Just like 'fieldOver', but for 'object'.
objectOver ::
  (HasObject doc doc') =>
  Lens v v' A.Value A.Object ->
  Text ->
  SchemaP doc v' [A.Pair] a b ->
  SchemaP doc' v A.Value a b
objectOver :: forall doc doc' v v' a b.
HasObject doc doc' =>
Lens v v' Value Object
-> Text -> SchemaP doc v' [Pair] a b -> SchemaP doc' v Value a b
objectOver Lens v v' Value Object
l Text
name SchemaP doc v' [Pair] a b
sch = SchemaDoc doc' a b
-> SchemaIn v a b
-> SchemaOut Value a b
-> SchemaP doc' v Value a b
forall doc v w a b.
SchemaDoc doc a b
-> SchemaIn v a b -> SchemaOut w a b -> SchemaP doc v w a b
SchemaP (doc' -> SchemaDoc doc' a b
forall {k} {k} doc (a :: k) (b :: k). doc -> SchemaDoc doc a b
SchemaDoc doc'
s) ((v -> Parser b) -> SchemaIn v a b
forall {k} v (a :: k) b. (v -> Parser b) -> SchemaIn v a b
SchemaIn v -> Parser b
r) ((a -> Maybe Value) -> SchemaOut Value a b
forall {k} v a (b :: k). (a -> Maybe v) -> SchemaOut v a b
SchemaOut a -> Maybe Value
w)
  where
    parseObject :: Value -> ContT b Parser Object
parseObject Value
val = ((Object -> Parser b) -> Parser b) -> ContT b Parser Object
forall {k} (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT (((Object -> Parser b) -> Parser b) -> ContT b Parser Object)
-> ((Object -> Parser b) -> Parser b) -> ContT b Parser Object
forall a b. (a -> b) -> a -> b
$ \Object -> Parser b
k -> String -> (Object -> Parser b) -> Value -> Parser b
forall a. String -> (Object -> Parser a) -> Value -> Parser a
A.withObject (Text -> String
T.unpack Text
name) Object -> Parser b
k Value
val
    r :: v -> Parser b
r v
v = ContT b Parser v' -> (v' -> Parser b) -> Parser b
forall {k} (r :: k) (m :: k -> *) a.
ContT r m a -> (a -> m r) -> m r
runContT ((Value -> ContT b Parser Object) -> v -> ContT b Parser v'
Lens v v' Value Object
l Value -> ContT b Parser Object
parseObject v
v) (SchemaP doc v' [Pair] a b -> v' -> Parser b
forall doc v v' a b. SchemaP doc v v' a b -> v -> Parser b
schemaIn SchemaP doc v' [Pair] a b
sch)
    w :: a -> Maybe Value
w a
x = [Pair] -> Value
A.object ([Pair] -> Value) -> Maybe [Pair] -> Maybe Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SchemaP doc v' [Pair] a b -> a -> Maybe [Pair]
forall ss v m a b. SchemaP ss v m a b -> a -> Maybe m
schemaOut SchemaP doc v' [Pair] a b
sch a
x
    s :: doc'
s = Text -> doc -> doc'
forall doc ndoc. HasObject doc ndoc => Text -> doc -> ndoc
mkObject Text
name (SchemaP doc v' [Pair] a b -> doc
forall ss v m a b. SchemaP ss v m a b -> ss
schemaDoc SchemaP doc v' [Pair] a b
sch)

-- | Like 'object', but apply an arbitrary function to the
-- documentation of the resulting object.
objectWithDocModifier ::
  (HasObject doc doc') =>
  Text ->
  (doc' -> doc') ->
  ObjectSchema doc a ->
  ValueSchema doc' a
objectWithDocModifier :: forall doc doc' a.
HasObject doc doc' =>
Text -> (doc' -> doc') -> ObjectSchema doc a -> ValueSchema doc' a
objectWithDocModifier Text
name doc' -> doc'
modify ObjectSchema doc a
sch = ASetter
  (SchemaP doc' Value Value a a)
  (SchemaP doc' Value Value a a)
  doc'
  doc'
-> (doc' -> doc')
-> SchemaP doc' Value Value a a
-> SchemaP doc' Value Value a a
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter
  (SchemaP doc' Value Value a a)
  (SchemaP doc' Value Value a a)
  doc'
  doc'
forall a a' doc doc'. HasDoc a a' doc doc' => Lens a a' doc doc'
Lens
  (SchemaP doc' Value Value a a)
  (SchemaP doc' Value Value a a)
  doc'
  doc'
doc doc' -> doc'
modify (Text -> ObjectSchema doc a -> SchemaP doc' Value Value a a
forall doc doc' a b.
HasObject doc doc' =>
Text
-> SchemaP doc Object [Pair] a b -> SchemaP doc' Value Value a b
object Text
name ObjectSchema doc a
sch)

-- | Turn a named schema into an unnamed one.
--
-- This is mostly useful when using a schema as a field of a bigger
-- schema. If the inner schema is unnamed, it gets "inlined" in the
-- larger scheme definition, and otherwise it gets "referenced". This
-- combinator makes it possible to choose one of the two options.
unnamed :: (HasObject doc doc') => SchemaP doc' v m a b -> SchemaP doc v m a b
unnamed :: forall doc doc' v m a b.
HasObject doc doc' =>
SchemaP doc' v m a b -> SchemaP doc v m a b
unnamed = ASetter (SchemaP doc' v m a b) (SchemaP doc v m a b) doc' doc
-> (doc' -> doc) -> SchemaP doc' v m a b -> SchemaP doc v m a b
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter (SchemaP doc' v m a b) (SchemaP doc v m a b) doc' doc
forall a a' doc doc'. HasDoc a a' doc doc' => Lens a a' doc doc'
Lens (SchemaP doc' v m a b) (SchemaP doc v m a b) doc' doc
doc doc' -> doc
forall doc ndoc. HasObject doc ndoc => ndoc -> doc
unmkObject

-- | Attach a name to a schema.
--
-- This only affects the documentation portion of a schema, and not
-- the parsing or serialisation.
named :: (HasObject doc doc') => Text -> SchemaP doc v m a b -> SchemaP doc' v m a b
named :: forall doc doc' v m a b.
HasObject doc doc' =>
Text -> SchemaP doc v m a b -> SchemaP doc' v m a b
named Text
name = ASetter (SchemaP doc v m a b) (SchemaP doc' v m a b) doc doc'
-> (doc -> doc') -> SchemaP doc v m a b -> SchemaP doc' v m a b
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter (SchemaP doc v m a b) (SchemaP doc' v m a b) doc doc'
forall a a' doc doc'. HasDoc a a' doc doc' => Lens a a' doc doc'
Lens (SchemaP doc v m a b) (SchemaP doc' v m a b) doc doc'
doc (Text -> doc -> doc'
forall doc ndoc. HasObject doc ndoc => Text -> doc -> ndoc
mkObject Text
name)

-- | A schema for a JSON array.
array ::
  (HasArray ndoc doc, HasName ndoc) =>
  ValueSchema ndoc a ->
  ValueSchema doc [a]
array :: forall ndoc doc a.
(HasArray ndoc doc, HasName ndoc) =>
ValueSchema ndoc a -> ValueSchema doc [a]
array ValueSchema ndoc a
sch = SchemaDoc doc [a] [a]
-> SchemaIn Value [a] [a]
-> SchemaOut Value [a] [a]
-> SchemaP doc Value Value [a] [a]
forall doc v w a b.
SchemaDoc doc a b
-> SchemaIn v a b -> SchemaOut w a b -> SchemaP doc v w a b
SchemaP (doc -> SchemaDoc doc [a] [a]
forall {k} {k} doc (a :: k) (b :: k). doc -> SchemaDoc doc a b
SchemaDoc doc
s) ((Value -> Parser [a]) -> SchemaIn Value [a] [a]
forall {k} v (a :: k) b. (v -> Parser b) -> SchemaIn v a b
SchemaIn Value -> Parser [a]
r) (([a] -> Maybe Value) -> SchemaOut Value [a] [a]
forall {k} v a (b :: k). (a -> Maybe v) -> SchemaOut v a b
SchemaOut [a] -> Maybe Value
w)
  where
    name :: Text
name = Text -> (Text -> Text) -> Maybe Text -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"array" (Text
"array of " <>) (ndoc -> Maybe Text
forall doc. HasName doc => doc -> Maybe Text
getName (ValueSchema ndoc a -> ndoc
forall ss v m a b. SchemaP ss v m a b -> ss
schemaDoc ValueSchema ndoc a
sch))
    r :: Value -> Parser [a]
r = String -> (Array -> Parser [a]) -> Value -> Parser [a]
forall a. String -> (Array -> Parser a) -> Value -> Parser a
A.withArray (Text -> String
T.unpack Text
name) ((Array -> Parser [a]) -> Value -> Parser [a])
-> (Array -> Parser [a]) -> Value -> Parser [a]
forall a b. (a -> b) -> a -> b
$ \Array
arr -> (Value -> Parser a) -> [Value] -> Parser [a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (ValueSchema ndoc a -> Value -> Parser a
forall doc v v' a b. SchemaP doc v v' a b -> v -> Parser b
schemaIn ValueSchema ndoc a
sch) ([Value] -> Parser [a]) -> [Value] -> Parser [a]
forall a b. (a -> b) -> a -> b
$ Array -> [Value]
forall a. Vector a -> [a]
V.toList Array
arr
    s :: doc
s = ndoc -> doc
forall ndoc doc. HasArray ndoc doc => ndoc -> doc
mkArray (ValueSchema ndoc a -> ndoc
forall ss v m a b. SchemaP ss v m a b -> ss
schemaDoc ValueSchema ndoc a
sch)
    w :: [a] -> Maybe Value
w [a]
x = Array -> Value
A.Array (Array -> Value) -> ([Value] -> Array) -> [Value] -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Value] -> Array
forall a. [a] -> Vector a
V.fromList ([Value] -> Value) -> Maybe [Value] -> Maybe Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> Maybe Value) -> [a] -> Maybe [Value]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (ValueSchema ndoc a -> a -> Maybe Value
forall ss v m a b. SchemaP ss v m a b -> a -> Maybe m
schemaOut ValueSchema ndoc a
sch) [a]
x

set ::
  (HasArray ndoc doc, HasName ndoc, Ord a) =>
  ValueSchema ndoc a ->
  ValueSchema doc (Set a)
set :: forall ndoc doc a.
(HasArray ndoc doc, HasName ndoc, Ord a) =>
ValueSchema ndoc a -> ValueSchema doc (Set a)
set ValueSchema ndoc a
sch = SchemaDoc doc (Set a) (Set a)
-> SchemaIn Value (Set a) (Set a)
-> SchemaOut Value (Set a) (Set a)
-> SchemaP doc Value Value (Set a) (Set a)
forall doc v w a b.
SchemaDoc doc a b
-> SchemaIn v a b -> SchemaOut w a b -> SchemaP doc v w a b
SchemaP (doc -> SchemaDoc doc (Set a) (Set a)
forall {k} {k} doc (a :: k) (b :: k). doc -> SchemaDoc doc a b
SchemaDoc doc
s) ((Value -> Parser (Set a)) -> SchemaIn Value (Set a) (Set a)
forall {k} v (a :: k) b. (v -> Parser b) -> SchemaIn v a b
SchemaIn Value -> Parser (Set a)
r) ((Set a -> Maybe Value) -> SchemaOut Value (Set a) (Set a)
forall {k} v a (b :: k). (a -> Maybe v) -> SchemaOut v a b
SchemaOut Set a -> Maybe Value
w)
  where
    name :: Text
name = Text -> (Text -> Text) -> Maybe Text -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"set" (Text
"set of " <>) (ndoc -> Maybe Text
forall doc. HasName doc => doc -> Maybe Text
getName (ValueSchema ndoc a -> ndoc
forall ss v m a b. SchemaP ss v m a b -> ss
schemaDoc ValueSchema ndoc a
sch))
    r :: Value -> Parser (Set a)
r = String -> (Array -> Parser (Set a)) -> Value -> Parser (Set a)
forall a. String -> (Array -> Parser a) -> Value -> Parser a
A.withArray (Text -> String
T.unpack Text
name) ((Array -> Parser (Set a)) -> Value -> Parser (Set a))
-> (Array -> Parser (Set a)) -> Value -> Parser (Set a)
forall a b. (a -> b) -> a -> b
$ \Array
arr ->
      ([a] -> Set a) -> Parser [a] -> Parser (Set a)
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [a] -> Set a
forall a. Ord a => [a] -> Set a
Set.fromList (Parser [a] -> Parser (Set a))
-> ([Value] -> Parser [a]) -> [Value] -> Parser (Set a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Value -> Parser a) -> [Value] -> Parser [a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (ValueSchema ndoc a -> Value -> Parser a
forall doc v v' a b. SchemaP doc v v' a b -> v -> Parser b
schemaIn ValueSchema ndoc a
sch) ([Value] -> Parser (Set a)) -> [Value] -> Parser (Set a)
forall a b. (a -> b) -> a -> b
$ Array -> [Value]
forall a. Vector a -> [a]
V.toList Array
arr
    s :: doc
s = ndoc -> doc
forall ndoc doc. HasArray ndoc doc => ndoc -> doc
mkArray (ValueSchema ndoc a -> ndoc
forall ss v m a b. SchemaP ss v m a b -> ss
schemaDoc ValueSchema ndoc a
sch)
    w :: Set a -> Maybe Value
w Set a
x = Array -> Value
A.Array (Array -> Value) -> ([Value] -> Array) -> [Value] -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Value] -> Array
forall a. [a] -> Vector a
V.fromList ([Value] -> Value) -> Maybe [Value] -> Maybe Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> Maybe Value) -> [a] -> Maybe [Value]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (ValueSchema ndoc a -> a -> Maybe Value
forall ss v m a b. SchemaP ss v m a b -> a -> Maybe m
schemaOut ValueSchema ndoc a
sch) (Set a -> [a]
forall a. Set a -> [a]
Set.toList Set a
x)

nonEmptyArray ::
  (HasArray ndoc doc, HasName ndoc, HasMinItems doc (Maybe Integer)) =>
  ValueSchema ndoc a ->
  ValueSchema doc (NonEmpty a)
nonEmptyArray :: forall ndoc doc a.
(HasArray ndoc doc, HasName ndoc,
 HasMinItems doc (Maybe Integer)) =>
ValueSchema ndoc a -> ValueSchema doc (NonEmpty a)
nonEmptyArray ValueSchema ndoc a
sch = Integer
-> ValueSchema doc (NonEmpty a) -> ValueSchema doc (NonEmpty a)
forall doc a.
HasMinItems doc (Maybe Integer) =>
Integer -> ValueSchema doc a -> ValueSchema doc a
setMinItems Integer
1 (ValueSchema doc (NonEmpty a) -> ValueSchema doc (NonEmpty a))
-> ValueSchema doc (NonEmpty a) -> ValueSchema doc (NonEmpty a)
forall a b. (a -> b) -> a -> b
$ NonEmpty a -> [a]
forall a. NonEmpty a -> [a]
NonEmpty.toList (NonEmpty a -> [a])
-> SchemaP doc Value Value [a] [a]
-> SchemaP doc Value Value (NonEmpty a) [a]
forall (p :: * -> * -> *) a a' b.
Profunctor p =>
(a -> a') -> p a' b -> p a b
.= ValueSchema ndoc a -> SchemaP doc Value Value [a] [a]
forall ndoc doc a.
(HasArray ndoc doc, HasName ndoc) =>
ValueSchema ndoc a -> ValueSchema doc [a]
array ValueSchema ndoc a
sch SchemaP doc Value Value (NonEmpty a) [a]
-> ([a] -> Parser (NonEmpty a)) -> ValueSchema doc (NonEmpty a)
forall doc v w a b b'.
SchemaP doc v w a b -> (b -> Parser b') -> SchemaP doc v w a b'
`withParser` [a] -> Parser (NonEmpty a)
forall {a}. [a] -> Parser (NonEmpty a)
check
  where
    check :: [a] -> Parser (NonEmpty a)
check =
      Parser (NonEmpty a)
-> (NonEmpty a -> Parser (NonEmpty a))
-> Maybe (NonEmpty a)
-> Parser (NonEmpty a)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Parser (NonEmpty a)
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unexpected empty array found while parsing a NonEmpty") NonEmpty a -> Parser (NonEmpty a)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        (Maybe (NonEmpty a) -> Parser (NonEmpty a))
-> ([a] -> Maybe (NonEmpty a)) -> [a] -> Parser (NonEmpty a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> Maybe (NonEmpty a)
forall a. [a] -> Maybe (NonEmpty a)
NonEmpty.nonEmpty

-- | A schema for a JSON object with arbitrary keys of type 'k'. The type of
-- keys must have instances for 'A.FromJSONKey' and 'A.ToJSONKey'.
--
-- Use 'mapWithKeys' for key types that do not have such instances.
map_ ::
  forall ndoc doc k a.
  (HasMap ndoc doc, Ord k, A.FromJSONKey k, A.ToJSONKey k) =>
  ValueSchema ndoc a ->
  ValueSchema doc (Map k a)
map_ :: forall ndoc doc k a.
(HasMap ndoc doc, Ord k, FromJSONKey k, ToJSONKey k) =>
ValueSchema ndoc a -> ValueSchema doc (Map k a)
map_ ValueSchema ndoc a
sch = doc
-> (Value -> Parser (Map k a))
-> (Map k a -> Maybe Value)
-> SchemaP doc Value Value (Map k a) (Map k a)
forall doc v b a w.
doc -> (v -> Parser b) -> (a -> Maybe w) -> SchemaP doc v w a b
mkSchema doc
d Value -> Parser (Map k a)
i Map k a -> Maybe Value
o
  where
    d :: doc
d = ndoc -> doc
forall ndoc doc. HasMap ndoc doc => ndoc -> doc
mkMap (ValueSchema ndoc a -> ndoc
forall ss v m a b. SchemaP ss v m a b -> ss
schemaDoc ValueSchema ndoc a
sch)
    i :: A.Value -> A.Parser (Map k a)
    i :: Value -> Parser (Map k a)
i = Value -> Parser (Map k Value)
forall a. FromJSON a => Value -> Parser a
A.parseJSON (Value -> Parser (Map k Value))
-> (Map k Value -> Parser (Map k a)) -> Value -> Parser (Map k a)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (Value -> Parser a) -> Map k Value -> Parser (Map k a)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Map k a -> f (Map k b)
traverse (ValueSchema ndoc a -> Value -> Parser a
forall doc v v' a b. SchemaP doc v v' a b -> v -> Parser b
schemaIn ValueSchema ndoc a
sch)
    o :: Map k a -> Maybe Value
o = (Map k Value -> Value) -> Maybe (Map k Value) -> Maybe Value
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Map k Value -> Value
forall a. ToJSON a => a -> Value
A.toJSON (Maybe (Map k Value) -> Maybe Value)
-> (Map k a -> Maybe (Map k Value)) -> Map k a -> Maybe Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Maybe Value) -> Map k a -> Maybe (Map k Value)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Map k a -> f (Map k b)
traverse (ValueSchema ndoc a -> a -> Maybe Value
forall ss v m a b. SchemaP ss v m a b -> a -> Maybe m
schemaOut ValueSchema ndoc a
sch)

-- | A schema for a JSON object with arbitrary keys of type 'k', where 'k' can
-- be converted to and from 'Text'.
mapWithKeys ::
  forall ndoc doc k a.
  (HasMap ndoc doc, Ord k) =>
  (k -> Text) ->
  (Text -> k) ->
  ValueSchema ndoc a ->
  ValueSchema doc (Map k a)
mapWithKeys :: forall ndoc doc k a.
(HasMap ndoc doc, Ord k) =>
(k -> Text)
-> (Text -> k) -> ValueSchema ndoc a -> ValueSchema doc (Map k a)
mapWithKeys k -> Text
keyToText Text -> k
textToKey ValueSchema ndoc a
sch =
  (Text -> k) -> Map Text a -> Map k a
forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeys Text -> k
textToKey
    (Map Text a -> Map k a)
-> SchemaP doc Value Value (Map k a) (Map Text a)
-> SchemaP doc Value Value (Map k a) (Map k a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (k -> Text) -> Map k a -> Map Text a
forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeys k -> Text
keyToText (Map k a -> Map Text a)
-> SchemaP doc Value Value (Map Text a) (Map Text a)
-> SchemaP doc Value Value (Map k a) (Map Text a)
forall (p :: * -> * -> *) a a' b.
Profunctor p =>
(a -> a') -> p a' b -> p a b
.= ValueSchema ndoc a
-> SchemaP doc Value Value (Map Text a) (Map Text a)
forall ndoc doc k a.
(HasMap ndoc doc, Ord k, FromJSONKey k, ToJSONKey k) =>
ValueSchema ndoc a -> ValueSchema doc (Map k a)
map_ ValueSchema ndoc a
sch

-- Putting this in `where` clause causes compile error, maybe a bug in GHC?
setMinItems :: (HasMinItems doc (Maybe Integer)) => Integer -> ValueSchema doc a -> ValueSchema doc a
setMinItems :: forall doc a.
HasMinItems doc (Maybe Integer) =>
Integer -> ValueSchema doc a -> ValueSchema doc a
setMinItems Integer
m = (doc -> Identity doc)
-> ValueSchema doc a -> Identity (ValueSchema doc a)
forall a a' doc doc'. HasDoc a a' doc doc' => Lens a a' doc doc'
Lens (ValueSchema doc a) (ValueSchema doc a) doc doc
doc ((doc -> Identity doc)
 -> ValueSchema doc a -> Identity (ValueSchema doc a))
-> ((Maybe Integer -> Identity (Maybe Integer))
    -> doc -> Identity doc)
-> (Maybe Integer -> Identity (Maybe Integer))
-> ValueSchema doc a
-> Identity (ValueSchema doc a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Integer -> Identity (Maybe Integer)) -> doc -> Identity doc
forall s a. HasMinItems s a => Lens' s a
Lens' doc (Maybe Integer)
minItems ((Maybe Integer -> Identity (Maybe Integer))
 -> ValueSchema doc a -> Identity (ValueSchema doc a))
-> Integer -> ValueSchema doc a -> ValueSchema doc a
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Integer
m

-- | Ad-hoc class for types corresponding to JSON primitive types.
class (A.ToJSON a) => With a where
  with :: String -> (a -> A.Parser b) -> A.Value -> A.Parser b

instance With Text where
  with :: forall b. String -> (Text -> Parser b) -> Value -> Parser b
with = String -> (Text -> Parser b) -> Value -> Parser b
forall b. String -> (Text -> Parser b) -> Value -> Parser b
A.withText

instance With Integer where
  with :: forall b. String -> (Integer -> Parser b) -> Value -> Parser b
with String
_ = (Value -> Parser Integer
forall a. FromJSON a => Value -> Parser a
A.parseJSON >=>)

instance With Natural where
  with :: forall b. String -> (Natural -> Parser b) -> Value -> Parser b
with String
_ = (Value -> Parser Natural
forall a. FromJSON a => Value -> Parser a
A.parseJSON >=>)

instance With Bool where
  with :: forall b. String -> (Bool -> Parser b) -> Value -> Parser b
with = String -> (Bool -> Parser b) -> Value -> Parser b
forall b. String -> (Bool -> Parser b) -> Value -> Parser b
A.withBool

-- | A schema for a single value of an enumeration.
element ::
  forall a b.
  (A.ToJSON a, Eq a, Eq b) =>
  a ->
  b ->
  SchemaP [A.Value] a (Alt Maybe a) b b
element :: forall a b.
(ToJSON a, Eq a, Eq b) =>
a -> b -> SchemaP [Value] a (Alt Maybe a) b b
element a
label b
value = SchemaDoc [Value] b b
-> SchemaIn a b b
-> SchemaOut (Alt Maybe a) b b
-> SchemaP [Value] a (Alt Maybe a) b b
forall doc v w a b.
SchemaDoc doc a b
-> SchemaIn v a b -> SchemaOut w a b -> SchemaP doc v w a b
SchemaP ([Value] -> SchemaDoc [Value] b b
forall {k} {k} doc (a :: k) (b :: k). doc -> SchemaDoc doc a b
SchemaDoc [Value]
d) ((a -> Parser b) -> SchemaIn a b b
forall {k} v (a :: k) b. (v -> Parser b) -> SchemaIn v a b
SchemaIn a -> Parser b
i) ((b -> Maybe (Alt Maybe a)) -> SchemaOut (Alt Maybe a) b b
forall {k} v a (b :: k). (a -> Maybe v) -> SchemaOut v a b
SchemaOut b -> Maybe (Alt Maybe a)
o)
  where
    d :: [Value]
d = [a -> Value
forall a. ToJSON a => a -> Value
A.toJSON a
label]
    i :: a -> Parser b
i a
l = b
value b -> Parser () -> Parser b
forall a b. a -> Parser b -> Parser a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Bool -> Parser ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (a
label a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
l)
    o :: b -> Maybe (Alt Maybe a)
o b
v = Maybe a -> Alt Maybe a
forall {k} (f :: k -> *) (a :: k). f a -> Alt f a
Alt (a -> Maybe a
forall a. a -> Maybe a
Just a
label) Alt Maybe a -> Maybe () -> Maybe (Alt Maybe a)
forall a b. a -> Maybe b -> Maybe a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (b
value b -> b -> Bool
forall a. Eq a => a -> a -> Bool
== b
v)

-- | A schema for a JSON enumeration.
--
-- This is used to convert a combination of schemas obtained using
-- 'element' into a single schema for a JSON string.
enum ::
  forall v doc a b.
  (With v, HasEnum v doc) =>
  Text ->
  SchemaP [A.Value] v (Alt Maybe v) a b ->
  SchemaP doc A.Value A.Value a b
enum :: forall v doc a b.
(With v, HasEnum v doc) =>
Text
-> SchemaP [Value] v (Alt Maybe v) a b
-> SchemaP doc Value Value a b
enum Text
name SchemaP [Value] v (Alt Maybe v) a b
sch = SchemaDoc doc a b
-> SchemaIn Value a b
-> SchemaOut Value a b
-> SchemaP doc Value Value a b
forall doc v w a b.
SchemaDoc doc a b
-> SchemaIn v a b -> SchemaOut w a b -> SchemaP doc v w a b
SchemaP (doc -> SchemaDoc doc a b
forall {k} {k} doc (a :: k) (b :: k). doc -> SchemaDoc doc a b
SchemaDoc doc
d) ((Value -> Parser b) -> SchemaIn Value a b
forall {k} v (a :: k) b. (v -> Parser b) -> SchemaIn v a b
SchemaIn Value -> Parser b
i) ((a -> Maybe Value) -> SchemaOut Value a b
forall {k} v a (b :: k). (a -> Maybe v) -> SchemaOut v a b
SchemaOut a -> Maybe Value
o)
  where
    d :: doc
d = forall {k} (a :: k) doc. HasEnum a doc => Text -> [Value] -> doc
forall a doc. HasEnum a doc => Text -> [Value] -> doc
mkEnum @v Text
name (SchemaP [Value] v (Alt Maybe v) a b -> [Value]
forall ss v m a b. SchemaP ss v m a b -> ss
schemaDoc SchemaP [Value] v (Alt Maybe v) a b
sch)
    i :: Value -> Parser b
i Value
x =
      String -> (v -> Parser b) -> Value -> Parser b
forall b. String -> (v -> Parser b) -> Value -> Parser b
forall a b.
With a =>
String -> (a -> Parser b) -> Value -> Parser b
with (Text -> String
T.unpack Text
name) (SchemaP [Value] v (Alt Maybe v) a b -> v -> Parser b
forall doc v v' a b. SchemaP doc v v' a b -> v -> Parser b
schemaIn SchemaP [Value] v (Alt Maybe v) a b
sch) Value
x
        Parser b -> Parser b -> Parser b
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> Parser b
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Unexpected value for enum " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
name)
    o :: a -> Maybe Value
o = (v -> Value) -> Maybe v -> Maybe Value
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap v -> Value
forall a. ToJSON a => a -> Value
A.toJSON (Maybe v -> Maybe Value) -> (a -> Maybe v) -> a -> Maybe Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Alt Maybe v -> Maybe v
forall {k} (f :: k -> *) (a :: k). Alt f a -> f a
getAlt (Alt Maybe v -> Maybe v)
-> (a -> Maybe (Alt Maybe v)) -> a -> Maybe v
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< SchemaP [Value] v (Alt Maybe v) a b -> a -> Maybe (Alt Maybe v)
forall ss v m a b. SchemaP ss v m a b -> a -> Maybe m
schemaOut SchemaP [Value] v (Alt Maybe v) a b
sch)

-- | A schema for 'Maybe' that omits a field on serialisation.
--
-- This is most commonly used for optional fields, and it will cause the field
-- to be omitted from the output of the serialiser.
maybe_ :: (Monoid w) => SchemaP d v w a b -> SchemaP d v w (Maybe a) b
maybe_ :: forall w d v a b.
Monoid w =>
SchemaP d v w a b -> SchemaP d v w (Maybe a) b
maybe_ = w -> SchemaP d v w a b -> SchemaP d v w (Maybe a) b
forall w d v a b.
w -> SchemaP d v w a b -> SchemaP d v w (Maybe a) b
maybeWithDefault w
forall a. Monoid a => a
mempty

-- | A schema for 'Maybe', producing the given default value on serialisation.
maybeWithDefault :: w -> SchemaP d v w a b -> SchemaP d v w (Maybe a) b
maybeWithDefault :: forall w d v a b.
w -> SchemaP d v w a b -> SchemaP d v w (Maybe a) b
maybeWithDefault w
w0 (SchemaP (SchemaDoc d
d) (SchemaIn v -> Parser b
i) (SchemaOut a -> Maybe w
o)) =
  SchemaDoc d (Maybe a) b
-> SchemaIn v (Maybe a) b
-> SchemaOut w (Maybe a) b
-> SchemaP d v w (Maybe a) b
forall doc v w a b.
SchemaDoc doc a b
-> SchemaIn v a b -> SchemaOut w a b -> SchemaP doc v w a b
SchemaP (d -> SchemaDoc d (Maybe a) b
forall {k} {k} doc (a :: k) (b :: k). doc -> SchemaDoc doc a b
SchemaDoc d
d) ((v -> Parser b) -> SchemaIn v (Maybe a) b
forall {k} v (a :: k) b. (v -> Parser b) -> SchemaIn v a b
SchemaIn v -> Parser b
i) ((Maybe a -> Maybe w) -> SchemaOut w (Maybe a) b
forall {k} v a (b :: k). (a -> Maybe v) -> SchemaOut v a b
SchemaOut (Maybe w -> (a -> Maybe w) -> Maybe a -> Maybe w
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (w -> Maybe w
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure w
w0) a -> Maybe w
o))

-- | A schema depending on a parsed value.
--
-- Even though 'SchemaP' does not expose a monadic interface, it is possible to
-- make the parser of a schema depend on the values parsed by a previous
-- schema.
--
-- For example, a schema for an object containing a "type" field which
-- determines how the rest of the object is parsed. To construct the schema to
-- use as the second argument of 'bind', one can use 'dispatch'.
bind ::
  (Monoid d, Monoid w) =>
  SchemaP d v w a b ->
  SchemaP d (v, b) w a c ->
  SchemaP d v w a (b, c)
bind :: forall d w v a b c.
(Monoid d, Monoid w) =>
SchemaP d v w a b
-> SchemaP d (v, b) w a c -> SchemaP d v w a (b, c)
bind SchemaP d v w a b
sch1 SchemaP d (v, b) w a c
sch2 = d
-> (v -> Parser (b, c)) -> (a -> Maybe w) -> SchemaP d v w a (b, c)
forall doc v b a w.
doc -> (v -> Parser b) -> (a -> Maybe w) -> SchemaP doc v w a b
mkSchema d
d v -> Parser (b, c)
i a -> Maybe w
o
  where
    d :: d
d = SchemaP d v w a b -> d
forall ss v m a b. SchemaP ss v m a b -> ss
schemaDoc SchemaP d v w a b
sch1 d -> d -> d
forall a. Semigroup a => a -> a -> a
<> SchemaP d (v, b) w a c -> d
forall ss v m a b. SchemaP ss v m a b -> ss
schemaDoc SchemaP d (v, b) w a c
sch2
    i :: v -> Parser (b, c)
i v
v = do
      b
b <- SchemaP d v w a b -> v -> Parser b
forall doc v v' a b. SchemaP doc v v' a b -> v -> Parser b
schemaIn SchemaP d v w a b
sch1 v
v
      c
c <- SchemaP d (v, b) w a c -> (v, b) -> Parser c
forall doc v v' a b. SchemaP doc v v' a b -> v -> Parser b
schemaIn SchemaP d (v, b) w a c
sch2 (v
v, b
b)
      (b, c) -> Parser (b, c)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (b
b, c
c)
    o :: a -> Maybe w
o a
a = w -> w -> w
forall a. Semigroup a => a -> a -> a
(<>) (w -> w -> w) -> Maybe w -> Maybe (w -> w)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SchemaP d v w a b -> a -> Maybe w
forall ss v m a b. SchemaP ss v m a b -> a -> Maybe m
schemaOut SchemaP d v w a b
sch1 a
a Maybe (w -> w) -> Maybe w -> Maybe w
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SchemaP d (v, b) w a c -> a -> Maybe w
forall ss v m a b. SchemaP ss v m a b -> a -> Maybe m
schemaOut SchemaP d (v, b) w a c
sch2 a
a

-- | A union of schemas over a finite type of "tags".
--
-- Normally used together with 'bind' to construct schemas that depend on some
-- "tag" value.
dispatch ::
  (Bounded t, Enum t, Monoid d) =>
  (t -> SchemaP d v w a b) ->
  SchemaP d (v, t) w a b
dispatch :: forall t d v w a b.
(Bounded t, Enum t, Monoid d) =>
(t -> SchemaP d v w a b) -> SchemaP d (v, t) w a b
dispatch t -> SchemaP d v w a b
sch = d
-> ((v, t) -> Parser b) -> (a -> Maybe w) -> SchemaP d (v, t) w a b
forall doc v b a w.
doc -> (v -> Parser b) -> (a -> Maybe w) -> SchemaP doc v w a b
mkSchema d
d (v, t) -> Parser b
i a -> Maybe w
o
  where
    allSch :: SchemaP d v w a b
allSch = (t -> SchemaP d v w a b) -> [t] -> SchemaP d v w a b
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap t -> SchemaP d v w a b
sch (t -> t -> [t]
forall a. Enum a => a -> a -> [a]
enumFromTo t
forall a. Bounded a => a
minBound t
forall a. Bounded a => a
maxBound)
    d :: d
d = SchemaP d v w a b -> d
forall ss v m a b. SchemaP ss v m a b -> ss
schemaDoc SchemaP d v w a b
allSch
    o :: a -> Maybe w
o = SchemaP d v w a b -> a -> Maybe w
forall ss v m a b. SchemaP ss v m a b -> a -> Maybe m
schemaOut SchemaP d v w a b
allSch
    i :: (v, t) -> Parser b
i (v
v, t
t) = SchemaP d v w a b -> v -> Parser b
forall doc v v' a b. SchemaP doc v v' a b -> v -> Parser b
schemaIn (t -> SchemaP d v w a b
sch t
t) v
v

-- | A schema for a textual value.
text :: Text -> ValueSchema NamedSwaggerDoc Text
text :: Text -> ValueSchema NamedSwaggerDoc Text
text Text
name =
  Text
-> SchemaP (WithDeclare Schema) Value Value Text Text
-> ValueSchema NamedSwaggerDoc Text
forall doc doc' v m a b.
HasObject doc doc' =>
Text -> SchemaP doc v m a b -> SchemaP doc' v m a b
named Text
name (SchemaP (WithDeclare Schema) Value Value Text Text
 -> ValueSchema NamedSwaggerDoc Text)
-> SchemaP (WithDeclare Schema) Value Value Text Text
-> ValueSchema NamedSwaggerDoc Text
forall a b. (a -> b) -> a -> b
$
    WithDeclare Schema
-> (Value -> Parser Text)
-> (Text -> Maybe Value)
-> SchemaP (WithDeclare Schema) Value Value Text Text
forall doc v b a w.
doc -> (v -> Parser b) -> (a -> Maybe w) -> SchemaP doc v w a b
mkSchema
      (Schema -> WithDeclare Schema
forall a. a -> WithDeclare a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Schema
d)
      (String -> (Text -> Parser Text) -> Value -> Parser Text
forall b. String -> (Text -> Parser b) -> Value -> Parser b
A.withText (Text -> String
T.unpack Text
name) Text -> Parser Text
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure)
      (Value -> Maybe Value
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Maybe Value) -> (Text -> Value) -> Text -> Maybe Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Value
A.String)
  where
    d :: Schema
d = Schema
forall a. Monoid a => a
mempty Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe OpenApiType -> Identity (Maybe OpenApiType))
-> Schema -> Identity Schema
forall s a. HasType s a => Lens' s a
Lens' Schema (Maybe OpenApiType)
S.type_ ((Maybe OpenApiType -> Identity (Maybe OpenApiType))
 -> Schema -> Identity Schema)
-> OpenApiType -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ OpenApiType
S.OpenApiString

-- | A schema for a textual value with possible failure.
parsedText ::
  Text ->
  (Text -> Either String a) ->
  SchemaP NamedSwaggerDoc A.Value A.Value Text a
parsedText :: forall a.
Text
-> (Text -> Either String a)
-> SchemaP NamedSwaggerDoc Value Value Text a
parsedText Text
name Text -> Either String a
parser = Text -> ValueSchema NamedSwaggerDoc Text
text Text
name ValueSchema NamedSwaggerDoc Text
-> (Text -> Parser a) -> SchemaP NamedSwaggerDoc Value Value Text a
forall doc v w a b b'.
SchemaP doc v w a b -> (b -> Parser b') -> SchemaP doc v w a b'
`withParser` ((String -> Parser a)
-> (a -> Parser a) -> Either String a -> Parser a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Parser a
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail a -> Parser a
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String a -> Parser a)
-> (Text -> Either String a) -> Text -> Parser a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either String a
parser)

-- | A schema for an arbitrary JSON object.
jsonObject :: ValueSchema SwaggerDoc A.Object
jsonObject :: ValueSchema (WithDeclare Schema) Object
jsonObject =
  SchemaP NamedSwaggerDoc Value Value Object Object
-> ValueSchema (WithDeclare Schema) Object
forall doc doc' v m a b.
HasObject doc doc' =>
SchemaP doc' v m a b -> SchemaP doc v m a b
unnamed (SchemaP NamedSwaggerDoc Value Value Object Object
 -> ValueSchema (WithDeclare Schema) Object)
-> (SchemaP (WithDeclare Schema) Object [Pair] Object Object
    -> SchemaP NamedSwaggerDoc Value Value Object Object)
-> SchemaP (WithDeclare Schema) Object [Pair] Object Object
-> ValueSchema (WithDeclare Schema) Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text
-> SchemaP (WithDeclare Schema) Object [Pair] Object Object
-> SchemaP NamedSwaggerDoc Value Value Object Object
forall doc doc' a b.
HasObject doc doc' =>
Text
-> SchemaP doc Object [Pair] a b -> SchemaP doc' Value Value a b
object Text
"Object" (SchemaP (WithDeclare Schema) Object [Pair] Object Object
 -> ValueSchema (WithDeclare Schema) Object)
-> SchemaP (WithDeclare Schema) Object [Pair] Object Object
-> ValueSchema (WithDeclare Schema) Object
forall a b. (a -> b) -> a -> b
$
    WithDeclare Schema
-> (Object -> Parser Object)
-> (Object -> Maybe [Pair])
-> SchemaP (WithDeclare Schema) Object [Pair] Object Object
forall doc v b a w.
doc -> (v -> Parser b) -> (a -> Maybe w) -> SchemaP doc v w a b
mkSchema WithDeclare Schema
forall a. Monoid a => a
mempty Object -> Parser Object
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Pair] -> Maybe [Pair]
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Pair] -> Maybe [Pair])
-> (Object -> [Pair]) -> Object -> Maybe [Pair]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Object -> Getting (Endo [Pair]) Object Pair -> [Pair]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. Indexed Key Value (Const (Endo [Pair]) Value)
-> Object -> Const (Endo [Pair]) Object
forall i (f :: * -> *) a.
FoldableWithIndex i f =>
IndexedFold i (f a) a
IndexedFold Key Object Value
ifolded (Indexed Key Value (Const (Endo [Pair]) Value)
 -> Object -> Const (Endo [Pair]) Object)
-> ((Pair -> Const (Endo [Pair]) Pair)
    -> Indexed Key Value (Const (Endo [Pair]) Value))
-> Getting (Endo [Pair]) Object Pair
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Pair -> Const (Endo [Pair]) Pair)
-> Indexed Key Value (Const (Endo [Pair]) Value)
forall i (p :: * -> * -> *) (f :: * -> *) s j t.
(Indexable i p, Functor f) =>
p (i, s) (f (j, t)) -> Indexed i s (f t)
withIndex))

-- | A schema for an arbitrary JSON value.
jsonValue :: ValueSchema SwaggerDoc A.Value
jsonValue :: ValueSchema (WithDeclare Schema) Value
jsonValue = WithDeclare Schema
-> (Value -> Parser Value)
-> (Value -> Maybe Value)
-> ValueSchema (WithDeclare Schema) Value
forall doc v b a w.
doc -> (v -> Parser b) -> (a -> Maybe w) -> SchemaP doc v w a b
mkSchema WithDeclare Schema
forall a. Monoid a => a
mempty Value -> Parser Value
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value -> Maybe Value
forall a. a -> Maybe a
Just

-- | A schema for a null value.
null_ :: (Monoid d) => ValueSchemaP d () ()
null_ :: forall d. Monoid d => ValueSchemaP d () ()
null_ = d
-> (Value -> Parser ())
-> (() -> Maybe Value)
-> SchemaP d Value Value () ()
forall doc v b a w.
doc -> (v -> Parser b) -> (a -> Maybe w) -> SchemaP doc v w a b
mkSchema d
forall a. Monoid a => a
mempty Value -> Parser ()
forall {f :: * -> *}. Alternative f => Value -> f ()
i () -> Maybe Value
forall {f :: * -> *} {p}. Applicative f => p -> f Value
o
  where
    i :: Value -> f ()
i Value
x = Bool -> f ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Value
x Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value
A.Null)
    o :: p -> f Value
o p
_ = Value -> f Value
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
A.Null

-- | A schema for a nullable value.
--
-- The parser accepts a JSON null as a valid value, and converts it to
-- 'Nothing'. Any non-null value is parsed using the underlying schema.
--
-- The serialiser behaves similarly, but in the other direction.
nullable ::
  (Monoid d) =>
  ValueSchema d a ->
  ValueSchema d (Maybe a)
nullable :: forall d a. Monoid d => ValueSchema d a -> ValueSchema d (Maybe a)
nullable ValueSchema d a
s =
  [ValueSchema d (Maybe a)] -> ValueSchema d (Maybe a)
forall a. Monoid a => [a] -> a
mconcat
    [ Prism (Maybe a) (Maybe a) () ()
-> SchemaP d Value Value () () -> ValueSchema d (Maybe a)
forall b b' a a' ss v m.
Prism b b' a a' -> SchemaP ss v m a a' -> SchemaP ss v m b b'
tag p () (f ()) -> p (Maybe a) (f (Maybe a))
forall a (p :: * -> * -> *) (f :: * -> *).
(Choice p, Applicative f) =>
p () (f ()) -> p (Maybe a) (f (Maybe a))
Prism (Maybe a) (Maybe a) () ()
_Nothing SchemaP d Value Value () ()
forall d. Monoid d => ValueSchemaP d () ()
null_,
      Prism (Maybe a) (Maybe a) a a
-> ValueSchema d a -> ValueSchema d (Maybe a)
forall b b' a a' ss v m.
Prism b b' a a' -> SchemaP ss v m a a' -> SchemaP ss v m b b'
tag p a (f a) -> p (Maybe a) (f (Maybe a))
forall a b (p :: * -> * -> *) (f :: * -> *).
(Choice p, Applicative f) =>
p a (f b) -> p (Maybe a) (f (Maybe b))
Prism (Maybe a) (Maybe a) a a
_Just ValueSchema d a
s
    ]

data WithDeclare s = WithDeclare (Declare ()) s
  deriving ((forall a b. (a -> b) -> WithDeclare a -> WithDeclare b)
-> (forall a b. a -> WithDeclare b -> WithDeclare a)
-> Functor WithDeclare
forall a b. a -> WithDeclare b -> WithDeclare a
forall a b. (a -> b) -> WithDeclare a -> WithDeclare b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> WithDeclare a -> WithDeclare b
fmap :: forall a b. (a -> b) -> WithDeclare a -> WithDeclare b
$c<$ :: forall a b. a -> WithDeclare b -> WithDeclare a
<$ :: forall a b. a -> WithDeclare b -> WithDeclare a
Functor)

instance Comonad WithDeclare where
  extract :: forall a. WithDeclare a -> a
extract (WithDeclare Declare ()
_ a
s) = a
s
  duplicate :: forall a. WithDeclare a -> WithDeclare (WithDeclare a)
duplicate w :: WithDeclare a
w@(WithDeclare Declare ()
d a
_) = Declare () -> WithDeclare a -> WithDeclare (WithDeclare a)
forall s. Declare () -> s -> WithDeclare s
WithDeclare Declare ()
d WithDeclare a
w

declared :: Lens (WithDeclare s) (WithDeclare t) s t
declared :: forall s t (f :: * -> *).
Functor f =>
(s -> f t) -> WithDeclare s -> f (WithDeclare t)
declared = (WithDeclare s -> s)
-> (WithDeclare s -> t -> WithDeclare t)
-> forall {f :: * -> *}.
   Functor f =>
   (s -> f t) -> WithDeclare s -> f (WithDeclare t)
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens (\(WithDeclare Declare ()
_ s
s) -> s
s) ((WithDeclare s -> t -> WithDeclare t)
 -> forall {f :: * -> *}.
    Functor f =>
    (s -> f t) -> WithDeclare s -> f (WithDeclare t))
-> (WithDeclare s -> t -> WithDeclare t)
-> forall {f :: * -> *}.
   Functor f =>
   (s -> f t) -> WithDeclare s -> f (WithDeclare t)
forall a b. (a -> b) -> a -> b
$ \(WithDeclare Declare ()
decl s
_) t
s' ->
  Declare () -> t -> WithDeclare t
forall s. Declare () -> s -> WithDeclare s
WithDeclare Declare ()
decl t
s'

instance Applicative WithDeclare where
  pure :: forall a. a -> WithDeclare a
pure = Declare () -> a -> WithDeclare a
forall s. Declare () -> s -> WithDeclare s
WithDeclare (() -> Declare ()
forall a. a -> DeclareT (Definitions Schema) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
  WithDeclare Declare ()
d1 a -> b
s1 <*> :: forall a b. WithDeclare (a -> b) -> WithDeclare a -> WithDeclare b
<*> WithDeclare Declare ()
d2 a
s2 =
    Declare () -> b -> WithDeclare b
forall s. Declare () -> s -> WithDeclare s
WithDeclare (Declare ()
d1 Declare () -> Declare () -> Declare ()
forall a b.
DeclareT (Definitions Schema) Identity a
-> DeclareT (Definitions Schema) Identity b
-> DeclareT (Definitions Schema) Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Declare ()
d2) (a -> b
s1 a
s2)

instance (Semigroup s) => Semigroup (WithDeclare s) where
  WithDeclare Declare ()
d1 s
s1 <> :: WithDeclare s -> WithDeclare s -> WithDeclare s
<> WithDeclare Declare ()
d2 s
s2 =
    Declare () -> s -> WithDeclare s
forall s. Declare () -> s -> WithDeclare s
WithDeclare (Declare ()
d1 Declare () -> Declare () -> Declare ()
forall a b.
DeclareT (Definitions Schema) Identity a
-> DeclareT (Definitions Schema) Identity b
-> DeclareT (Definitions Schema) Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Declare ()
d2) (s
s1 s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
s2)

instance (Monoid s) => Monoid (WithDeclare s) where
  mempty :: WithDeclare s
mempty = Declare () -> s -> WithDeclare s
forall s. Declare () -> s -> WithDeclare s
WithDeclare (() -> Declare ()
forall a. a -> DeclareT (Definitions Schema) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) s
forall a. Monoid a => a
mempty

instance (NearSemiRing s) => NearSemiRing (WithDeclare s) where
  zero :: WithDeclare s
zero = Declare () -> s -> WithDeclare s
forall s. Declare () -> s -> WithDeclare s
WithDeclare (() -> Declare ()
forall a. a -> DeclareT (Definitions Schema) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) s
forall m. NearSemiRing m => m
zero
  add :: WithDeclare s -> WithDeclare s -> WithDeclare s
add (WithDeclare Declare ()
d1 s
s1) (WithDeclare Declare ()
d2 s
s2) =
    Declare () -> s -> WithDeclare s
forall s. Declare () -> s -> WithDeclare s
WithDeclare (Declare ()
d1 Declare () -> Declare () -> Declare ()
forall a b.
DeclareT (Definitions Schema) Identity a
-> DeclareT (Definitions Schema) Identity b
-> DeclareT (Definitions Schema) Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Declare ()
d2) (s -> s -> s
forall m. NearSemiRing m => m -> m -> m
add s
s1 s
s2)

runDeclare :: WithDeclare s -> Declare s
runDeclare :: forall s. WithDeclare s -> Declare s
runDeclare (WithDeclare Declare ()
m s
s) = s
s s -> Declare () -> DeclareT (Definitions Schema) Identity s
forall a b.
a
-> DeclareT (Definitions Schema) Identity b
-> DeclareT (Definitions Schema) Identity a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Declare ()
m

unrunDeclare :: Declare s -> WithDeclare s
unrunDeclare :: forall s. Declare s -> WithDeclare s
unrunDeclare Declare s
decl = case Declare s -> Definitions Schema -> (Definitions Schema, s)
forall d a. Declare d a -> d -> (d, a)
S.runDeclare Declare s
decl Definitions Schema
forall a. Monoid a => a
mempty of
  (Definitions Schema
defns, s
s) -> (Declare () -> s -> WithDeclare s
forall s. Declare () -> s -> WithDeclare s
`WithDeclare` s
s) (Declare () -> WithDeclare s) -> Declare () -> WithDeclare s
forall a b. (a -> b) -> a -> b
$ do
    Definitions Schema -> Declare ()
forall d (m :: * -> *). MonadDeclare d m => d -> m ()
S.declare Definitions Schema
defns

type SwaggerDoc = WithDeclare S.Schema

type NamedSwaggerDoc = WithDeclare S.NamedSchema

-- addition of schemas is used by the alternative instance, and it works like
-- multiplication (i.e. the Monoid instance), except that it intersects required
-- fields instead of concatenating them
instance NearSemiRing S.Schema where
  zero :: Schema
zero = Schema
forall a. Monoid a => a
mempty
  add :: Schema -> Schema -> Schema
add Schema
x Schema
y = (Schema
x Schema -> Schema -> Schema
forall a. Semigroup a => a -> a -> a
<> Schema
y) Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& ([Text] -> Identity [Text]) -> Schema -> Identity Schema
forall s a. HasRequired s a => Lens' s a
Lens' Schema [Text]
S.required (([Text] -> Identity [Text]) -> Schema -> Identity Schema)
-> [Text] -> Schema -> Schema
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Text] -> [Text] -> [Text]
forall a. Eq a => [a] -> [a] -> [a]
intersect (Schema
x Schema -> Getting [Text] Schema [Text] -> [Text]
forall s a. s -> Getting a s a -> a
^. Getting [Text] Schema [Text]
forall s a. HasRequired s a => Lens' s a
Lens' Schema [Text]
S.required) (Schema
y Schema -> Getting [Text] Schema [Text] -> [Text]
forall s a. s -> Getting a s a -> a
^. Getting [Text] Schema [Text]
forall s a. HasRequired s a => Lens' s a
Lens' Schema [Text]
S.required)

-- This class abstracts over SwaggerDoc and NamedSwaggerDoc
class HasSchemaRef doc where
  schemaRef :: doc -> WithDeclare (S.Referenced S.Schema)

instance HasSchemaRef SwaggerDoc where
  schemaRef :: WithDeclare Schema -> WithDeclare (Referenced Schema)
schemaRef = (Schema -> Referenced Schema)
-> WithDeclare Schema -> WithDeclare (Referenced Schema)
forall a b. (a -> b) -> WithDeclare a -> WithDeclare b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Schema -> Referenced Schema
forall a. a -> Referenced a
S.Inline

instance HasSchemaRef NamedSwaggerDoc where
  schemaRef :: NamedSwaggerDoc -> WithDeclare (Referenced Schema)
schemaRef (WithDeclare Declare ()
decl (S.NamedSchema Maybe Text
mn Schema
s)) =
    (Declare () -> Referenced Schema -> WithDeclare (Referenced Schema)
forall s. Declare () -> s -> WithDeclare s
`WithDeclare` Schema -> Maybe Text -> Referenced Schema
forall {a}. a -> Maybe Text -> Referenced a
mkRef Schema
s Maybe Text
mn) (Declare () -> WithDeclare (Referenced Schema))
-> Declare () -> WithDeclare (Referenced Schema)
forall a b. (a -> b) -> a -> b
$ do
      Declare ()
decl
      case Maybe Text
mn of
        Just Text
n -> Definitions Schema -> Declare ()
forall d (m :: * -> *). MonadDeclare d m => d -> m ()
S.declare [(Text
n, Schema
s)]
        Maybe Text
Nothing -> () -> Declare ()
forall a. a -> DeclareT (Definitions Schema) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    where
      mkRef :: a -> Maybe Text -> Referenced a
mkRef a
_ (Just Text
n) = Reference -> Referenced a
forall a. Reference -> Referenced a
S.Ref (Text -> Reference
S.Reference Text
n)
      mkRef a
x Maybe Text
Nothing = a -> Referenced a
forall a. a -> Referenced a
S.Inline a
x

class HasName doc where
  getName :: doc -> Maybe Text

instance HasName SwaggerDoc where
  getName :: WithDeclare Schema -> Maybe Text
getName = Maybe Text -> WithDeclare Schema -> Maybe Text
forall a b. a -> b -> a
const Maybe Text
forall a. Maybe a
Nothing

instance HasName NamedSwaggerDoc where
  getName :: NamedSwaggerDoc -> Maybe Text
getName = NamedSchema -> Maybe Text
S._namedSchemaName (NamedSchema -> Maybe Text)
-> (NamedSwaggerDoc -> NamedSchema)
-> NamedSwaggerDoc
-> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamedSwaggerDoc -> NamedSchema
forall a. WithDeclare a -> a
forall (w :: * -> *) a. Comonad w => w a -> a
extract

class (Monoid doc) => HasField ndoc doc | ndoc -> doc where
  mkField :: Text -> ndoc -> doc

class (Monoid doc) => HasObject doc ndoc | doc -> ndoc, ndoc -> doc where
  mkObject :: Text -> doc -> ndoc
  unmkObject :: ndoc -> doc

class (Monoid doc) => HasArray ndoc doc | ndoc -> doc where
  mkArray :: ndoc -> doc

class (Monoid doc) => HasMap ndoc doc | ndoc -> doc where
  mkMap :: ndoc -> doc

class HasOpt doc where
  mkOpt :: doc -> doc

class HasEnum a doc where
  mkEnum :: Text -> [A.Value] -> doc

instance (HasSchemaRef doc) => HasField doc SwaggerDoc where
  mkField :: Text -> doc -> WithDeclare Schema
mkField Text
name = (Referenced Schema -> Schema)
-> WithDeclare (Referenced Schema) -> WithDeclare Schema
forall a b. (a -> b) -> WithDeclare a -> WithDeclare b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Referenced Schema -> Schema
f (WithDeclare (Referenced Schema) -> WithDeclare Schema)
-> (doc -> WithDeclare (Referenced Schema))
-> doc
-> WithDeclare Schema
forall b c a. (b -> c) -> (a -> b) -> a -> c
. doc -> WithDeclare (Referenced Schema)
forall doc.
HasSchemaRef doc =>
doc -> WithDeclare (Referenced Schema)
schemaRef
    where
      f :: Referenced Schema -> Schema
f Referenced Schema
ref =
        Schema
forall a. Monoid a => a
mempty
          Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe OpenApiType -> Identity (Maybe OpenApiType))
-> Schema -> Identity Schema
forall s a. HasType s a => Lens' s a
Lens' Schema (Maybe OpenApiType)
S.type_ ((Maybe OpenApiType -> Identity (Maybe OpenApiType))
 -> Schema -> Identity Schema)
-> OpenApiType -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ OpenApiType
S.OpenApiObject
          Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (InsOrdHashMap Text (Referenced Schema)
 -> Identity (InsOrdHashMap Text (Referenced Schema)))
-> Schema -> Identity Schema
forall s a. HasProperties s a => Lens' s a
Lens' Schema (InsOrdHashMap Text (Referenced Schema))
S.properties ((InsOrdHashMap Text (Referenced Schema)
  -> Identity (InsOrdHashMap Text (Referenced Schema)))
 -> Schema -> Identity Schema)
-> ((Maybe (IxValue (InsOrdHashMap Text (Referenced Schema)))
     -> Identity (Maybe (Referenced Schema)))
    -> InsOrdHashMap Text (Referenced Schema)
    -> Identity (InsOrdHashMap Text (Referenced Schema)))
-> (Maybe (IxValue (InsOrdHashMap Text (Referenced Schema)))
    -> Identity (Maybe (Referenced Schema)))
-> Schema
-> Identity Schema
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 Text
Index (InsOrdHashMap Text (Referenced Schema))
name ((Maybe (IxValue (InsOrdHashMap Text (Referenced Schema)))
  -> Identity (Maybe (Referenced Schema)))
 -> Schema -> Identity Schema)
-> Referenced Schema -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Referenced Schema
ref
          Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& ([Text] -> Identity [Text]) -> Schema -> Identity Schema
forall s a. HasRequired s a => Lens' s a
Lens' Schema [Text]
S.required (([Text] -> Identity [Text]) -> Schema -> Identity Schema)
-> [Text] -> Schema -> Schema
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Text
Item [Text]
name]

instance HasObject SwaggerDoc NamedSwaggerDoc where
  mkObject :: Text -> WithDeclare Schema -> NamedSwaggerDoc
mkObject Text
name WithDeclare Schema
decl = Maybe Text -> Schema -> NamedSchema
S.NamedSchema (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
name) (Schema -> NamedSchema) -> WithDeclare Schema -> NamedSwaggerDoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WithDeclare Schema
decl
  unmkObject :: NamedSwaggerDoc -> WithDeclare Schema
unmkObject (WithDeclare Declare ()
d (S.NamedSchema Maybe Text
Nothing Schema
s)) = Declare () -> Schema -> WithDeclare Schema
forall s. Declare () -> s -> WithDeclare s
WithDeclare Declare ()
d Schema
s
  unmkObject (WithDeclare Declare ()
d (S.NamedSchema (Just Text
n) Schema
s)) =
    Declare () -> Schema -> WithDeclare Schema
forall s. Declare () -> s -> WithDeclare s
WithDeclare (Declare ()
d Declare () -> Declare () -> Declare ()
forall a b.
DeclareT (Definitions Schema) Identity a
-> DeclareT (Definitions Schema) Identity b
-> DeclareT (Definitions Schema) Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Definitions Schema -> Declare ()
forall d (m :: * -> *). MonadDeclare d m => d -> m ()
S.declare [(Text
n, Schema
s)]) Schema
s

instance (HasSchemaRef ndoc) => HasArray ndoc SwaggerDoc where
  mkArray :: ndoc -> WithDeclare Schema
mkArray = (Referenced Schema -> Schema)
-> WithDeclare (Referenced Schema) -> WithDeclare Schema
forall a b. (a -> b) -> WithDeclare a -> WithDeclare b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Referenced Schema -> Schema
f (WithDeclare (Referenced Schema) -> WithDeclare Schema)
-> (ndoc -> WithDeclare (Referenced Schema))
-> ndoc
-> WithDeclare Schema
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ndoc -> WithDeclare (Referenced Schema)
forall doc.
HasSchemaRef doc =>
doc -> WithDeclare (Referenced Schema)
schemaRef
    where
      f :: S.Referenced S.Schema -> S.Schema
      f :: Referenced Schema -> Schema
f Referenced Schema
ref =
        Schema
forall a. Monoid a => a
mempty
          Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe OpenApiType -> Identity (Maybe OpenApiType))
-> Schema -> Identity Schema
forall s a. HasType s a => Lens' s a
Lens' Schema (Maybe OpenApiType)
S.type_ ((Maybe OpenApiType -> Identity (Maybe OpenApiType))
 -> Schema -> Identity Schema)
-> OpenApiType -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ OpenApiType
S.OpenApiArray
          Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe OpenApiItems -> Identity (Maybe OpenApiItems))
-> Schema -> Identity Schema
forall s a. HasItems s a => Lens' s a
Lens' Schema (Maybe OpenApiItems)
S.items ((Maybe OpenApiItems -> Identity (Maybe OpenApiItems))
 -> Schema -> Identity Schema)
-> OpenApiItems -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Referenced Schema -> OpenApiItems
S.OpenApiItemsObject Referenced Schema
ref

instance (HasSchemaRef ndoc) => HasMap ndoc SwaggerDoc where
  mkMap :: ndoc -> WithDeclare Schema
mkMap = (Referenced Schema -> Schema)
-> WithDeclare (Referenced Schema) -> WithDeclare Schema
forall a b. (a -> b) -> WithDeclare a -> WithDeclare b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Referenced Schema -> Schema
f (WithDeclare (Referenced Schema) -> WithDeclare Schema)
-> (ndoc -> WithDeclare (Referenced Schema))
-> ndoc
-> WithDeclare Schema
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ndoc -> WithDeclare (Referenced Schema)
forall doc.
HasSchemaRef doc =>
doc -> WithDeclare (Referenced Schema)
schemaRef
    where
      f :: S.Referenced S.Schema -> S.Schema
      f :: Referenced Schema -> Schema
f Referenced Schema
ref =
        Schema
forall a. Monoid a => a
mempty
          Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe OpenApiType -> Identity (Maybe OpenApiType))
-> Schema -> Identity Schema
forall s a. HasType s a => Lens' s a
Lens' Schema (Maybe OpenApiType)
S.type_ ((Maybe OpenApiType -> Identity (Maybe OpenApiType))
 -> Schema -> Identity Schema)
-> OpenApiType -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ OpenApiType
S.OpenApiObject
          Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe AdditionalProperties
 -> Identity (Maybe AdditionalProperties))
-> Schema -> Identity Schema
forall s a. HasAdditionalProperties s a => Lens' s a
Lens' Schema (Maybe AdditionalProperties)
S.additionalProperties ((Maybe AdditionalProperties
  -> Identity (Maybe AdditionalProperties))
 -> Schema -> Identity Schema)
-> AdditionalProperties -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Referenced Schema -> AdditionalProperties
S.AdditionalPropertiesSchema Referenced Schema
ref

class HasMinItems s a where
  minItems :: Lens' s a

instance HasMinItems SwaggerDoc (Maybe Integer) where
  minItems :: Lens' (WithDeclare Schema) (Maybe Integer)
minItems = (Schema -> f Schema)
-> WithDeclare Schema -> f (WithDeclare Schema)
forall s t (f :: * -> *).
Functor f =>
(s -> f t) -> WithDeclare s -> f (WithDeclare t)
declared ((Schema -> f Schema)
 -> WithDeclare Schema -> f (WithDeclare Schema))
-> ((Maybe Integer -> f (Maybe Integer)) -> Schema -> f Schema)
-> (Maybe Integer -> f (Maybe Integer))
-> WithDeclare Schema
-> f (WithDeclare Schema)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Integer -> f (Maybe Integer)) -> Schema -> f Schema
forall s a. HasMinItems s a => Lens' s a
Lens' Schema (Maybe Integer)
S.minItems

instance HasEnum Text NamedSwaggerDoc where
  mkEnum :: Text -> [Value] -> NamedSwaggerDoc
mkEnum = OpenApiType -> Text -> [Value] -> NamedSwaggerDoc
mkSwaggerEnum OpenApiType
S.OpenApiString

instance HasEnum Integer NamedSwaggerDoc where
  mkEnum :: Text -> [Value] -> NamedSwaggerDoc
mkEnum = OpenApiType -> Text -> [Value] -> NamedSwaggerDoc
mkSwaggerEnum OpenApiType
S.OpenApiInteger

instance HasEnum Natural NamedSwaggerDoc where
  mkEnum :: Text -> [Value] -> NamedSwaggerDoc
mkEnum = OpenApiType -> Text -> [Value] -> NamedSwaggerDoc
mkSwaggerEnum OpenApiType
S.OpenApiInteger

instance HasEnum Bool NamedSwaggerDoc where
  mkEnum :: Text -> [Value] -> NamedSwaggerDoc
mkEnum = OpenApiType -> Text -> [Value] -> NamedSwaggerDoc
mkSwaggerEnum OpenApiType
S.OpenApiBoolean

mkSwaggerEnum ::
  S.OpenApiType ->
  Text ->
  [A.Value] ->
  NamedSwaggerDoc
mkSwaggerEnum :: OpenApiType -> Text -> [Value] -> NamedSwaggerDoc
mkSwaggerEnum OpenApiType
ty Text
name [Value]
labels =
  NamedSchema -> NamedSwaggerDoc
forall a. a -> WithDeclare a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NamedSchema -> NamedSwaggerDoc)
-> (Schema -> NamedSchema) -> Schema -> NamedSwaggerDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Text -> Schema -> NamedSchema
S.NamedSchema (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
name) (Schema -> NamedSwaggerDoc) -> Schema -> NamedSwaggerDoc
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
& (Maybe OpenApiType -> Identity (Maybe OpenApiType))
-> Schema -> Identity Schema
forall s a. HasType s a => Lens' s a
Lens' Schema (Maybe OpenApiType)
S.type_ ((Maybe OpenApiType -> Identity (Maybe OpenApiType))
 -> Schema -> Identity Schema)
-> OpenApiType -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ OpenApiType
ty
      Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe [Value] -> Identity (Maybe [Value]))
-> Schema -> Identity Schema
forall s a. HasEnum s a => Lens' s a
Lens' Schema (Maybe [Value])
S.enum_ ((Maybe [Value] -> Identity (Maybe [Value]))
 -> Schema -> Identity Schema)
-> [Value] -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ [Value]
labels

instance HasOpt SwaggerDoc where
  mkOpt :: WithDeclare Schema -> WithDeclare Schema
mkOpt = ((Schema -> Identity Schema)
-> WithDeclare Schema -> Identity (WithDeclare Schema)
forall s a. HasSchema s a => Lens' s a
Lens' (WithDeclare Schema) Schema
S.schema ((Schema -> Identity Schema)
 -> WithDeclare Schema -> Identity (WithDeclare Schema))
-> (([Text] -> Identity [Text]) -> Schema -> Identity Schema)
-> ([Text] -> Identity [Text])
-> WithDeclare Schema
-> Identity (WithDeclare Schema)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Text] -> Identity [Text]) -> Schema -> Identity Schema
forall s a. HasRequired s a => Lens' s a
Lens' Schema [Text]
S.required) (([Text] -> Identity [Text])
 -> WithDeclare Schema -> Identity (WithDeclare Schema))
-> [Text] -> WithDeclare Schema -> WithDeclare Schema
forall s t a b. ASetter s t a b -> b -> s -> t
.~ []

instance HasOpt NamedSwaggerDoc where
  mkOpt :: NamedSwaggerDoc -> NamedSwaggerDoc
mkOpt = ((Schema -> Identity Schema)
-> NamedSwaggerDoc -> Identity NamedSwaggerDoc
forall s a. HasSchema s a => Lens' s a
Lens' NamedSwaggerDoc Schema
S.schema ((Schema -> Identity Schema)
 -> NamedSwaggerDoc -> Identity NamedSwaggerDoc)
-> (([Text] -> Identity [Text]) -> Schema -> Identity Schema)
-> ([Text] -> Identity [Text])
-> NamedSwaggerDoc
-> Identity NamedSwaggerDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Text] -> Identity [Text]) -> Schema -> Identity Schema
forall s a. HasRequired s a => Lens' s a
Lens' Schema [Text]
S.required) (([Text] -> Identity [Text])
 -> NamedSwaggerDoc -> Identity NamedSwaggerDoc)
-> [Text] -> NamedSwaggerDoc -> NamedSwaggerDoc
forall s t a b. ASetter s t a b -> b -> s -> t
.~ []

-- | A type with a canonical typed schema definition.
--
-- Using ToSchema, one can split a complicated shema definition
-- into manageable parts by defining instances for the various types
-- involved, and using the 'schema' method to reuse the
-- previously-defined schema definitions for component types.
class ToSchema a where
  schema :: ValueSchema NamedSwaggerDoc a

-- Newtype wrappers for deriving via

newtype Schema a = Schema {forall a. Schema a -> a
getSchema :: a}
  deriving ((forall x. Schema a -> Rep (Schema a) x)
-> (forall x. Rep (Schema a) x -> Schema a) -> Generic (Schema a)
forall x. Rep (Schema a) x -> Schema a
forall x. Schema a -> Rep (Schema a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (Schema a) x -> Schema a
forall a x. Schema a -> Rep (Schema a) x
$cfrom :: forall a x. Schema a -> Rep (Schema a) x
from :: forall x. Schema a -> Rep (Schema a) x
$cto :: forall a x. Rep (Schema a) x -> Schema a
to :: forall x. Rep (Schema a) x -> Schema a
Generic)

schemaToSwagger :: forall a. (ToSchema a) => Proxy a -> Declare S.NamedSchema
schemaToSwagger :: forall a. ToSchema a => Proxy a -> Declare NamedSchema
schemaToSwagger Proxy a
_ = NamedSwaggerDoc -> Declare NamedSchema
forall s. WithDeclare s -> Declare s
runDeclare (SchemaP NamedSwaggerDoc Value Value a a -> NamedSwaggerDoc
forall ss v m a b. SchemaP ss v m a b -> ss
schemaDoc (forall a. ToSchema a => ValueSchema NamedSwaggerDoc a
schema @a))

instance (Typeable a, ToSchema a) => S.ToSchema (Schema a) where
  declareNamedSchema :: Proxy (Schema a) -> Declare NamedSchema
declareNamedSchema Proxy (Schema a)
_ = Proxy a -> Declare NamedSchema
forall a. ToSchema a => Proxy a -> Declare NamedSchema
schemaToSwagger (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a)

-- | JSON serialiser for an instance of 'ToSchema'.
schemaToJSON :: forall a. (ToSchema a) => a -> A.Value
schemaToJSON :: forall a. ToSchema a => a -> Value
schemaToJSON = Value -> Maybe Value -> Value
forall a. a -> Maybe a -> a
fromMaybe Value
A.Null (Maybe Value -> Value) -> (a -> Maybe Value) -> a -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SchemaP NamedSwaggerDoc Value Value a a -> a -> Maybe Value
forall ss v m a b. SchemaP ss v m a b -> a -> Maybe m
schemaOut (forall a. ToSchema a => ValueSchema NamedSwaggerDoc a
schema @a)

instance (ToSchema a) => A.ToJSON (Schema a) where
  toJSON :: Schema a -> Value
toJSON = a -> Value
forall a. ToSchema a => a -> Value
schemaToJSON (a -> Value) -> (Schema a -> a) -> Schema a -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Schema a -> a
forall a. Schema a -> a
getSchema

-- | JSON parser for an instance of 'ToSchema'.
schemaParseJSON :: forall a. (ToSchema a) => A.Value -> A.Parser a
schemaParseJSON :: forall a. ToSchema a => Value -> Parser a
schemaParseJSON = SchemaP NamedSwaggerDoc Value Value a a -> Value -> Parser a
forall doc v v' a b. SchemaP doc v v' a b -> v -> Parser b
schemaIn SchemaP NamedSwaggerDoc Value Value a a
forall a. ToSchema a => ValueSchema NamedSwaggerDoc a
schema

instance (ToSchema a) => A.FromJSON (Schema a) where
  parseJSON :: Value -> Parser (Schema a)
parseJSON = (a -> Schema a) -> Parser a -> Parser (Schema a)
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Schema a
forall a. a -> Schema a
Schema (Parser a -> Parser (Schema a))
-> (Value -> Parser a) -> Value -> Parser (Schema a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Parser a
forall a. ToSchema a => Value -> Parser a
schemaParseJSON

instance ToSchema Text where schema :: ValueSchema NamedSwaggerDoc Text
schema = ValueSchema NamedSwaggerDoc Text
forall a.
(ToSchema a, ToJSON a, FromJSON a) =>
ValueSchema NamedSwaggerDoc a
genericToSchema

instance ToSchema TL.Text where schema :: ValueSchema NamedSwaggerDoc Text
schema = ValueSchema NamedSwaggerDoc Text
forall a.
(ToSchema a, ToJSON a, FromJSON a) =>
ValueSchema NamedSwaggerDoc a
genericToSchema

instance ToSchema Int where schema :: ValueSchema NamedSwaggerDoc Int
schema = ValueSchema NamedSwaggerDoc Int
forall a.
(ToSchema a, ToJSON a, FromJSON a) =>
ValueSchema NamedSwaggerDoc a
genericToSchema

instance ToSchema Int32 where schema :: ValueSchema NamedSwaggerDoc Int32
schema = ValueSchema NamedSwaggerDoc Int32
forall a.
(ToSchema a, ToJSON a, FromJSON a) =>
ValueSchema NamedSwaggerDoc a
genericToSchema

instance ToSchema Int64 where schema :: ValueSchema NamedSwaggerDoc Int64
schema = ValueSchema NamedSwaggerDoc Int64
forall a.
(ToSchema a, ToJSON a, FromJSON a) =>
ValueSchema NamedSwaggerDoc a
genericToSchema

instance ToSchema Integer where schema :: ValueSchema NamedSwaggerDoc Integer
schema = ValueSchema NamedSwaggerDoc Integer
forall a.
(ToSchema a, ToJSON a, FromJSON a) =>
ValueSchema NamedSwaggerDoc a
genericToSchema

instance ToSchema Word where schema :: ValueSchema NamedSwaggerDoc Word
schema = ValueSchema NamedSwaggerDoc Word
forall a.
(ToSchema a, ToJSON a, FromJSON a) =>
ValueSchema NamedSwaggerDoc a
genericToSchema

instance ToSchema Word8 where schema :: ValueSchema NamedSwaggerDoc Word8
schema = ValueSchema NamedSwaggerDoc Word8
forall a.
(ToSchema a, ToJSON a, FromJSON a) =>
ValueSchema NamedSwaggerDoc a
genericToSchema

instance ToSchema Word16 where schema :: ValueSchema NamedSwaggerDoc Word16
schema = ValueSchema NamedSwaggerDoc Word16
forall a.
(ToSchema a, ToJSON a, FromJSON a) =>
ValueSchema NamedSwaggerDoc a
genericToSchema

instance ToSchema Word32 where schema :: ValueSchema NamedSwaggerDoc Word32
schema = ValueSchema NamedSwaggerDoc Word32
forall a.
(ToSchema a, ToJSON a, FromJSON a) =>
ValueSchema NamedSwaggerDoc a
genericToSchema

instance ToSchema Word64 where schema :: ValueSchema NamedSwaggerDoc Word64
schema = ValueSchema NamedSwaggerDoc Word64
forall a.
(ToSchema a, ToJSON a, FromJSON a) =>
ValueSchema NamedSwaggerDoc a
genericToSchema

instance ToSchema Char where schema :: ValueSchema NamedSwaggerDoc Char
schema = ValueSchema NamedSwaggerDoc Char
forall a.
(ToSchema a, ToJSON a, FromJSON a) =>
ValueSchema NamedSwaggerDoc a
genericToSchema

instance ToSchema String where schema :: ValueSchema NamedSwaggerDoc String
schema = ValueSchema NamedSwaggerDoc String
forall a.
(ToSchema a, ToJSON a, FromJSON a) =>
ValueSchema NamedSwaggerDoc a
genericToSchema

instance ToSchema Bool where schema :: ValueSchema NamedSwaggerDoc Bool
schema = ValueSchema NamedSwaggerDoc Bool
forall a.
(ToSchema a, ToJSON a, FromJSON a) =>
ValueSchema NamedSwaggerDoc a
genericToSchema

instance ToSchema Natural where schema :: ValueSchema NamedSwaggerDoc Natural
schema = ValueSchema NamedSwaggerDoc Natural
forall a.
(ToSchema a, ToJSON a, FromJSON a) =>
ValueSchema NamedSwaggerDoc a
genericToSchema

declareSwaggerSchema :: SchemaP (WithDeclare d) v w a b -> Declare d
declareSwaggerSchema :: forall d v w a b. SchemaP (WithDeclare d) v w a b -> Declare d
declareSwaggerSchema = WithDeclare d -> Declare d
forall s. WithDeclare s -> Declare s
runDeclare (WithDeclare d -> Declare d)
-> (SchemaP (WithDeclare d) v w a b -> WithDeclare d)
-> SchemaP (WithDeclare d) v w a b
-> Declare d
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SchemaP (WithDeclare d) v w a b -> WithDeclare d
forall ss v m a b. SchemaP ss v m a b -> ss
schemaDoc

swaggerDoc :: forall a. (S.ToSchema a) => NamedSwaggerDoc
swaggerDoc :: forall a. ToSchema a => NamedSwaggerDoc
swaggerDoc = Declare NamedSchema -> NamedSwaggerDoc
forall s. Declare s -> WithDeclare s
unrunDeclare (Proxy a -> Declare NamedSchema
forall a. ToSchema a => Proxy a -> Declare NamedSchema
S.declareNamedSchema (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a))

genericToSchema :: forall a. (S.ToSchema a, A.ToJSON a, A.FromJSON a) => ValueSchema NamedSwaggerDoc a
genericToSchema :: forall a.
(ToSchema a, ToJSON a, FromJSON a) =>
ValueSchema NamedSwaggerDoc a
genericToSchema =
  SchemaDoc NamedSwaggerDoc a a
-> SchemaIn Value a a
-> SchemaOut Value a a
-> SchemaP NamedSwaggerDoc Value Value a a
forall doc v w a b.
SchemaDoc doc a b
-> SchemaIn v a b -> SchemaOut w a b -> SchemaP doc v w a b
SchemaP
    (NamedSwaggerDoc -> SchemaDoc NamedSwaggerDoc a a
forall {k} {k} doc (a :: k) (b :: k). doc -> SchemaDoc doc a b
SchemaDoc (forall a. ToSchema a => NamedSwaggerDoc
swaggerDoc @a))
    ((Value -> Parser a) -> SchemaIn Value a a
forall {k} v (a :: k) b. (v -> Parser b) -> SchemaIn v a b
SchemaIn Value -> Parser a
r)
    ((a -> Maybe Value) -> SchemaOut Value a a
forall {k} v a (b :: k). (a -> Maybe v) -> SchemaOut v a b
SchemaOut a -> Maybe Value
w)
  where
    r :: Value -> Parser a
r = Value -> Parser a
forall a. FromJSON a => Value -> Parser a
A.parseJSON
    w :: a -> Maybe Value
w = Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Maybe Value) -> (a -> Value) -> a -> Maybe Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Value
forall a. ToJSON a => a -> Value
A.toJSON

-- Swagger lenses

instance S.HasSchema SwaggerDoc S.Schema where
  schema :: Lens' (WithDeclare Schema) Schema
schema = (Schema -> f Schema)
-> WithDeclare Schema -> f (WithDeclare Schema)
forall s t (f :: * -> *).
Functor f =>
(s -> f t) -> WithDeclare s -> f (WithDeclare t)
declared

instance S.HasSchema NamedSwaggerDoc S.Schema where
  schema :: Lens' NamedSwaggerDoc Schema
schema = (NamedSchema -> f NamedSchema)
-> NamedSwaggerDoc -> f NamedSwaggerDoc
forall s t (f :: * -> *).
Functor f =>
(s -> f t) -> WithDeclare s -> f (WithDeclare t)
declared ((NamedSchema -> f NamedSchema)
 -> NamedSwaggerDoc -> f NamedSwaggerDoc)
-> ((Schema -> f Schema) -> NamedSchema -> f NamedSchema)
-> (Schema -> f Schema)
-> NamedSwaggerDoc
-> f NamedSwaggerDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Schema -> f Schema) -> NamedSchema -> f NamedSchema
forall s a. HasSchema s a => Lens' s a
Lens' NamedSchema Schema
S.schema

instance (S.HasSchema d S.Schema) => S.HasSchema (SchemaP d v w a b) S.Schema where
  schema :: Lens' (SchemaP d v w a b) Schema
schema = (d -> f d) -> SchemaP d v w a b -> f (SchemaP d v w a b)
forall a a' doc doc'. HasDoc a a' doc doc' => Lens a a' doc doc'
Lens (SchemaP d v w a b) (SchemaP d v w a b) d d
doc ((d -> f d) -> SchemaP d v w a b -> f (SchemaP d v w a b))
-> ((Schema -> f Schema) -> d -> f d)
-> (Schema -> f Schema)
-> SchemaP d v w a b
-> f (SchemaP d v w a b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Schema -> f Schema) -> d -> f d
forall s a. HasSchema s a => Lens' s a
Lens' d Schema
S.schema

instance S.HasDescription NamedSwaggerDoc (Maybe Text) where
  description :: Lens' NamedSwaggerDoc (Maybe Text)
description = (NamedSchema -> f NamedSchema)
-> NamedSwaggerDoc -> f NamedSwaggerDoc
forall s t (f :: * -> *).
Functor f =>
(s -> f t) -> WithDeclare s -> f (WithDeclare t)
declared ((NamedSchema -> f NamedSchema)
 -> NamedSwaggerDoc -> f NamedSwaggerDoc)
-> ((Maybe Text -> f (Maybe Text)) -> NamedSchema -> f NamedSchema)
-> (Maybe Text -> f (Maybe Text))
-> NamedSwaggerDoc
-> f NamedSwaggerDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Schema -> f Schema) -> NamedSchema -> f NamedSchema
forall s a. HasSchema s a => Lens' s a
Lens' NamedSchema Schema
S.schema ((Schema -> f Schema) -> NamedSchema -> f NamedSchema)
-> ((Maybe Text -> f (Maybe Text)) -> Schema -> f Schema)
-> (Maybe Text -> f (Maybe Text))
-> NamedSchema
-> f NamedSchema
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Text -> f (Maybe Text)) -> Schema -> f Schema
forall s a. HasDescription s a => Lens' s a
Lens' Schema (Maybe Text)
S.description

instance S.HasDeprecated NamedSwaggerDoc (Maybe Bool) where
  deprecated :: Lens' NamedSwaggerDoc (Maybe Bool)
deprecated = (NamedSchema -> f NamedSchema)
-> NamedSwaggerDoc -> f NamedSwaggerDoc
forall s t (f :: * -> *).
Functor f =>
(s -> f t) -> WithDeclare s -> f (WithDeclare t)
declared ((NamedSchema -> f NamedSchema)
 -> NamedSwaggerDoc -> f NamedSwaggerDoc)
-> ((Maybe Bool -> f (Maybe Bool)) -> NamedSchema -> f NamedSchema)
-> (Maybe Bool -> f (Maybe Bool))
-> NamedSwaggerDoc
-> f NamedSwaggerDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Schema -> f Schema) -> NamedSchema -> f NamedSchema
forall s a. HasSchema s a => Lens' s a
Lens' NamedSchema Schema
S.schema ((Schema -> f Schema) -> NamedSchema -> f NamedSchema)
-> ((Maybe Bool -> f (Maybe Bool)) -> Schema -> f Schema)
-> (Maybe Bool -> f (Maybe Bool))
-> NamedSchema
-> f NamedSchema
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Bool -> f (Maybe Bool)) -> Schema -> f Schema
forall s a. HasDeprecated s a => Lens' s a
Lens' Schema (Maybe Bool)
S.deprecated

instance {-# OVERLAPPABLE #-} (S.HasDescription s a) => S.HasDescription (WithDeclare s) a where
  description :: Lens' (WithDeclare s) a
description = (s -> f s) -> WithDeclare s -> f (WithDeclare s)
forall s t (f :: * -> *).
Functor f =>
(s -> f t) -> WithDeclare s -> f (WithDeclare t)
declared ((s -> f s) -> WithDeclare s -> f (WithDeclare s))
-> ((a -> f a) -> s -> f s)
-> (a -> f a)
-> WithDeclare s
-> f (WithDeclare s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> f a) -> s -> f s
forall s a. HasDescription s a => Lens' s a
Lens' s a
S.description

instance {-# OVERLAPPABLE #-} (S.HasDeprecated s a) => S.HasDeprecated (WithDeclare s) a where
  deprecated :: Lens' (WithDeclare s) a
deprecated = (s -> f s) -> WithDeclare s -> f (WithDeclare s)
forall s t (f :: * -> *).
Functor f =>
(s -> f t) -> WithDeclare s -> f (WithDeclare t)
declared ((s -> f s) -> WithDeclare s -> f (WithDeclare s))
-> ((a -> f a) -> s -> f s)
-> (a -> f a)
-> WithDeclare s
-> f (WithDeclare s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> f a) -> s -> f s
forall s a. HasDeprecated s a => Lens' s a
Lens' s a
S.deprecated

instance {-# OVERLAPPABLE #-} (S.HasExample s a) => S.HasExample (WithDeclare s) a where
  example :: Lens' (WithDeclare s) a
example = (s -> f s) -> WithDeclare s -> f (WithDeclare s)
forall s t (f :: * -> *).
Functor f =>
(s -> f t) -> WithDeclare s -> f (WithDeclare t)
declared ((s -> f s) -> WithDeclare s -> f (WithDeclare s))
-> ((a -> f a) -> s -> f s)
-> (a -> f a)
-> WithDeclare s
-> f (WithDeclare s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> f a) -> s -> f s
forall s a. HasExample s a => Lens' s a
Lens' s a
S.example