{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-|
Module      : Data.Aeson.WithField
Description : Provides utility to inject fields into aeson values.
Copyright   : (c) Anton Gushcha, 2016
License     : MIT
Maintainer  : ncrashed@gmail.com
Stability   : experimental
Portability : Portable

When builds a RESTful API one often faces the problem that some methods
need inbound data without unique identifier (for instance, a creation of
new resource) and some methods need the same outbound data with additional
fields attached to the response.

The module provides you with 'WithField' and 'WithFields' data types that
help you to solve the issue without code duplication.

It is small utility library that is intented to be used in RESTful APIs,
especially with <http://haskell-servant.readthedocs.io/en/stable/ servant>
and <http://swagger.io/ Swagger>. Its main purpose is simple injection of
fields into JSONs produced by <https://hackage.haskell.org/package/aeson aeson>
library.

Consider the following common data type in web service developing:

@
data News = News {
  title :: Text
, body :: Text
, author :: Text
, timestamp :: UTCTime
}

-- Consider we have simple 'ToJSON' and 'FromJSON' instances
$(deriveJSON defaultOptions ''News)
@

'ToJSON' instance produces JSON's like:

@
{
  "title": "Awesome piece of news!"
, "body": "Big chunk of text"
, "author": "Just Me"
, "timestamp": "2016-07-26T18:54:42.678999Z"
}
@

Now one can create a simple web server with servant DSL:

> type NewsId = Word
>
> type NewsAPI =
>        ReqBody '[JSON] News :> Post '[JSON] NewsId
>   :<|> Capture "news-id" NewsId :> Get '[JSON] News
>   :<|> "list" :> Get '[JSON] [News]


All seems legit, but, wait a second, an API user definitely would
like to know id of news in the "list" method. One way to do this is declare
new data type @NewsInfo@ with additional field, but it is bad solution as requires
to code duplication for each resource.

So, here @aeson-injector@ steps in, now you can write:

> type NewsAPI =
>        ReqBody '[JSON] News :> Post '[JSON] NewsId
>   :<|> Capture "news-id" NewsId :> Get '[JSON] News
>   :<|> "list" :> Get '[JSON] [WithField "id" NewsId News]

@'WithField' "id" NewsId News@ or simply @'WithId' NewsId News@ wraps you data type
and injects "id" field in produced JSON values:

>>> encode (WithField 42 myNews :: WithField "id" NewsId News)

> {
>   "id": 42
> , "title": "Awesome piece of news!"
> , "body": "Big chunk of text"
> , "author": "Just Me"
> , "timestamp": "2016-07-26T18:54:42.678999Z"
> }

'WithField' data type has `FromJSON` instance for seamless parsing of data with
injected fields and 'ToSchema' instance for <https://hackage.haskell.org/package/servant-swagger servant-swagger> support.

= Injecting multiple values

The library also has more general data type 'WithFields a b' that injects fields of 'toJSON a' into 'toJSON b'.

@ haskell
data NewsPatch = NewsPatch {
  taggs :: [Text]
, rating :: Double
}
$(deriveJSON defaultOptions ''NewsPatch)
@

@ haskell
let myNewsPatch = NewsPatch ["tag1", "tag2"] 42
in encode $ WithFields myNewsPatch myNews
@

> {
>   "title": "Awesome piece of news!"
> , "body": "Big chunk of text"
> , "author": "Just Me"
> , "timestamp": "2016-07-26T18:54:42.678999Z"
> , "tags": ["tag1", "tag2"]
> , "rating": 42.0
> }

= Corner cases

Unfortunately, we cannot inject in non object values of produced JSON,
so the library creates a wrapper object around non-object value:

@
encode (WithId 0 "non-object" :: WithId Int String)
@

@
{
  "id": 0
, "value": "non-object"
}
@

The same story is about 'WithFields' data type:

@
encode (WithFields 0 "non-object" :: WithFields Int String)
@

@
{
  "injected": 0
, "value": "non-object"
}
@

-}
module Data.Aeson.WithField(
  -- * Single field injector
    WithField(..)
  , WithId
  -- * Multiple fields injector
  , WithFields(..)
  -- * Single field wrapper
  , OnlyField(..)
  , OnlyId
  ) where

import Control.Applicative
import Control.DeepSeq
import Control.Lens hiding ((.=))
import Control.Monad
import Data.Aeson
import Data.Aeson.Types (typeMismatch)
import qualified Data.Aeson.Key as Key
import qualified Data.Aeson.KeyMap as KM
import Data.Aeson.WithField.Internal
import Data.Hashable
import Data.Monoid
import Data.Proxy
import Data.Swagger
import GHC.Generics
import GHC.TypeLits
import Servant.Docs

import qualified Data.Foldable as F
import qualified Data.List as L
import qualified Data.Text as T

-- | Injects field 'a' into 'b' with tag 's'. It has
-- special instances for 'ToJSON' and 'FromJSON' for
-- such injection and corresponding Swagger 'ToSchema'
-- instance.
--
-- For instance:
--
-- >>> encode (WithField "val" (Left 42) :: WithField "injected" String (Either Int Int))
-- "{\"Left\":42,\"id\":\"val\"}"
--
-- If the instance cannot inject field (in case of single values and arrays),
-- it wraps the result in the following way:
--
-- >>> encode (WithField "val" 42 :: WithField "injected" String Int)
-- "{\"value\":42,\"injected\":\"val\"}"
--
-- `WithField s a b` always overwites field `s` in JSON produced by `b`.
data WithField (s :: Symbol) a b = WithField !a !b
  deriving ((forall x. WithField s a b -> Rep (WithField s a b) x)
-> (forall x. Rep (WithField s a b) x -> WithField s a b)
-> Generic (WithField s a b)
forall x. Rep (WithField s a b) x -> WithField s a b
forall x. WithField s a b -> Rep (WithField s a b) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (s :: Symbol) a b x.
Rep (WithField s a b) x -> WithField s a b
forall (s :: Symbol) a b x.
WithField s a b -> Rep (WithField s a b) x
$cto :: forall (s :: Symbol) a b x.
Rep (WithField s a b) x -> WithField s a b
$cfrom :: forall (s :: Symbol) a b x.
WithField s a b -> Rep (WithField s a b) x
Generic, WithField s a b -> WithField s a b -> Bool
(WithField s a b -> WithField s a b -> Bool)
-> (WithField s a b -> WithField s a b -> Bool)
-> Eq (WithField s a b)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (s :: Symbol) a b.
(Eq a, Eq b) =>
WithField s a b -> WithField s a b -> Bool
/= :: WithField s a b -> WithField s a b -> Bool
$c/= :: forall (s :: Symbol) a b.
(Eq a, Eq b) =>
WithField s a b -> WithField s a b -> Bool
== :: WithField s a b -> WithField s a b -> Bool
$c== :: forall (s :: Symbol) a b.
(Eq a, Eq b) =>
WithField s a b -> WithField s a b -> Bool
Eq, Int -> WithField s a b -> ShowS
[WithField s a b] -> ShowS
WithField s a b -> String
(Int -> WithField s a b -> ShowS)
-> (WithField s a b -> String)
-> ([WithField s a b] -> ShowS)
-> Show (WithField s a b)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (s :: Symbol) a b.
(Show a, Show b) =>
Int -> WithField s a b -> ShowS
forall (s :: Symbol) a b.
(Show a, Show b) =>
[WithField s a b] -> ShowS
forall (s :: Symbol) a b.
(Show a, Show b) =>
WithField s a b -> String
showList :: [WithField s a b] -> ShowS
$cshowList :: forall (s :: Symbol) a b.
(Show a, Show b) =>
[WithField s a b] -> ShowS
show :: WithField s a b -> String
$cshow :: forall (s :: Symbol) a b.
(Show a, Show b) =>
WithField s a b -> String
showsPrec :: Int -> WithField s a b -> ShowS
$cshowsPrec :: forall (s :: Symbol) a b.
(Show a, Show b) =>
Int -> WithField s a b -> ShowS
Show, ReadPrec [WithField s a b]
ReadPrec (WithField s a b)
Int -> ReadS (WithField s a b)
ReadS [WithField s a b]
(Int -> ReadS (WithField s a b))
-> ReadS [WithField s a b]
-> ReadPrec (WithField s a b)
-> ReadPrec [WithField s a b]
-> Read (WithField s a b)
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
forall (s :: Symbol) a b.
(Read a, Read b) =>
ReadPrec [WithField s a b]
forall (s :: Symbol) a b.
(Read a, Read b) =>
ReadPrec (WithField s a b)
forall (s :: Symbol) a b.
(Read a, Read b) =>
Int -> ReadS (WithField s a b)
forall (s :: Symbol) a b.
(Read a, Read b) =>
ReadS [WithField s a b]
readListPrec :: ReadPrec [WithField s a b]
$creadListPrec :: forall (s :: Symbol) a b.
(Read a, Read b) =>
ReadPrec [WithField s a b]
readPrec :: ReadPrec (WithField s a b)
$creadPrec :: forall (s :: Symbol) a b.
(Read a, Read b) =>
ReadPrec (WithField s a b)
readList :: ReadS [WithField s a b]
$creadList :: forall (s :: Symbol) a b.
(Read a, Read b) =>
ReadS [WithField s a b]
readsPrec :: Int -> ReadS (WithField s a b)
$creadsPrec :: forall (s :: Symbol) a b.
(Read a, Read b) =>
Int -> ReadS (WithField s a b)
Read)

instance (NFData a, NFData b) => NFData (WithField s a b)

instance Functor (WithField s a) where
  fmap :: (a -> b) -> WithField s a a -> WithField s a b
fmap f :: a -> b
f (WithField a :: a
a b :: a
b) = a -> b -> WithField s a b
forall (s :: Symbol) a b. a -> b -> WithField s a b
WithField a
a (a -> b
f a
b)

instance Bifunctor (WithField s) where
  bimap :: (a -> b) -> (c -> d) -> WithField s a c -> WithField s b d
bimap fa :: a -> b
fa fb :: c -> d
fb (WithField a :: a
a b :: c
b) = b -> d -> WithField s b d
forall (s :: Symbol) a b. a -> b -> WithField s a b
WithField (a -> b
fa a
a) (c -> d
fb c
b)

-- | Workaround for a problem that is discribed as:
-- sometimes I need a id with the data, sometimes not.
--
-- The important note that 'ToJSON' and 'FromJSON' instances
-- behaves as it is 'a' but with additional 'id' field.
type WithId i a = WithField "id" i a

instance (ToSample a, ToSample b) => ToSample (WithField s a b) where
  toSamples :: Proxy (WithField s a b) -> [(Text, WithField s a b)]
toSamples _ = [WithField s a b] -> [(Text, WithField s a b)]
forall a. [a] -> [(Text, a)]
samples ([WithField s a b] -> [(Text, WithField s a b)])
-> [WithField s a b] -> [(Text, WithField s a b)]
forall a b. (a -> b) -> a -> b
$ a -> b -> WithField s a b
forall (s :: Symbol) a b. a -> b -> WithField s a b
WithField (a -> b -> WithField s a b) -> [a] -> [b -> WithField s a b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a]
as [b -> WithField s a b] -> [b] -> [WithField s a b]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [b]
bs
    where
    as :: [a]
as = (Text, a) -> a
forall a b. (a, b) -> b
snd ((Text, a) -> a) -> [(Text, a)] -> [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Proxy a -> [(Text, a)]
forall a. ToSample a => Proxy a -> [(Text, a)]
toSamples (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a)
    bs :: [b]
bs = (Text, b) -> b
forall a b. (a, b) -> b
snd ((Text, b) -> b) -> [(Text, b)] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Proxy b -> [(Text, b)]
forall a. ToSample a => Proxy a -> [(Text, a)]
toSamples (Proxy b
forall k (t :: k). Proxy t
Proxy :: Proxy b)

-- | Note: the instance injects field only in 'Object' case.
-- In other cases it forms a wrapper around the 'Value' produced
-- by 'toJSON' of inner 'b' body.
--
-- Example of wrapper:
--
-- > { "id": 0, "value": [1, 2, 3] }
instance (KnownSymbol s, ToJSON a, ToJSON b) => ToJSON (WithField s a b) where
  toJSON :: WithField s a b -> Value
toJSON (WithField a :: a
a b :: b
b) = let
    jsonb :: Value
jsonb = b -> Value
forall a. ToJSON a => a -> Value
toJSON b
b
    field :: Key
field = KnownSymbol s => Key
forall (s :: Symbol). KnownSymbol s => Key
mkFieldName @s
    in case b -> Value
forall a. ToJSON a => a -> Value
toJSON b
b of
      Object vs :: Object
vs -> Object -> Value
Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ Key -> Value -> Object -> Object
forall v. Key -> v -> KeyMap v -> KeyMap v
KM.insert Key
field (a -> Value
forall a. ToJSON a => a -> Value
toJSON a
a) Object
vs
      _ -> [Pair] -> Value
object [
          "value" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Value
jsonb
        , Key
field Key -> a -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= a
a
        ]

-- | Note: the instance tries to parse the json as object with
-- additional field value, if it fails it assumes that it is a
-- wrapper produced by corresponding 'ToJSON' instance.
--
-- Note: The instance tries to parse the `b` part without `s` field at first time.
-- If it fails, the instance retries with presence of the `s` field.
instance (KnownSymbol s, FromJSON a, FromJSON b) => FromJSON (WithField s a b) where
  parseJSON :: Value -> Parser (WithField s a b)
parseJSON val :: Value
val@(Object o :: Object
o) = Parser (WithField s a b)
injected Parser (WithField s a b)
-> Parser (WithField s a b) -> Parser (WithField s a b)
forall a. Parser a -> Parser a -> Parser a
`mplus0` Parser (WithField s a b)
wrapper
    where
    field :: Key
field = KnownSymbol s => Key
forall (s :: Symbol). KnownSymbol s => Key
mkFieldName @s
    injected :: Parser (WithField s a b)
injected = a -> b -> WithField s a b
forall (s :: Symbol) a b. a -> b -> WithField s a b
WithField
      (a -> b -> WithField s a b)
-> Parser a -> Parser (b -> WithField s a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser a
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
field
      Parser (b -> WithField s a b)
-> Parser b -> Parser (WithField s a b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Value -> Parser b
forall a. FromJSON a => Value -> Parser a
parseJSON (Object -> Value
Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ Key -> Object -> Object
forall v. Key -> KeyMap v -> KeyMap v
KM.delete Key
field Object
o) Parser b -> Parser b -> Parser b
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Value -> Parser b
forall a. FromJSON a => Value -> Parser a
parseJSON Value
val)
    wrapper :: Parser (WithField s a b)
wrapper = a -> b -> WithField s a b
forall (s :: Symbol) a b. a -> b -> WithField s a b
WithField
      (a -> b -> WithField s a b)
-> Parser a -> Parser (b -> WithField s a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser a
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
field
      Parser (b -> WithField s a b)
-> Parser b -> Parser (WithField s a b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser b
forall a. FromJSON a => Object -> Key -> Parser a
.: "value"
  parseJSON wat :: Value
wat = String -> Value -> Parser (WithField s a b)
forall a. String -> Value -> Parser a
typeMismatch "Expected JSON Object" Value
wat

-- | Note: the instance tries to generate schema of the json as object with
-- additional field value, if it fails it assumes that it is a
-- wrapper produced by corresponding 'ToJSON' instance.
instance (KnownSymbol s, ToSchema a, ToSchema b) => ToSchema (WithField s a b) where
  declareNamedSchema :: Proxy (WithField s a b) -> Declare (Definitions Schema) NamedSchema
declareNamedSchema _ = do
    NamedSchema n :: Maybe Text
n s :: Schema
s <- Proxy b -> Declare (Definitions Schema) NamedSchema
forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) NamedSchema
declareNamedSchema (Proxy b
forall k (t :: k). Proxy t
Proxy :: Proxy b)
    if Schema
s Schema
-> Getting
     (Maybe (SwaggerType 'SwaggerKindSchema))
     Schema
     (Maybe (SwaggerType 'SwaggerKindSchema))
-> Maybe (SwaggerType 'SwaggerKindSchema)
forall s a. s -> Getting a s a -> a
^. Getting
  (Maybe (SwaggerType 'SwaggerKindSchema))
  Schema
  (Maybe (SwaggerType 'SwaggerKindSchema))
forall s a. HasType s a => Lens' s a
type_ Maybe (SwaggerType 'SwaggerKindSchema)
-> Maybe (SwaggerType 'SwaggerKindSchema) -> Bool
forall a. Eq a => a -> a -> Bool
== SwaggerType 'SwaggerKindSchema
-> Maybe (SwaggerType 'SwaggerKindSchema)
forall a. a -> Maybe a
Just SwaggerType 'SwaggerKindSchema
SwaggerObject then Maybe Text -> Schema -> Declare (Definitions Schema) NamedSchema
inline Maybe Text
n Schema
s
      else Maybe Text -> Schema -> Declare (Definitions Schema) NamedSchema
wrapper Maybe Text
n Schema
s
    where
    field :: Text
field = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Proxy s -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy s
forall k (t :: k). Proxy t
Proxy :: Proxy s)
    namePrefix :: Text
namePrefix = "WithField '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
field Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "' "
    wrapper :: Maybe Text -> Schema -> Declare (Definitions Schema) NamedSchema
wrapper n :: Maybe Text
n s :: Schema
s = do
      Schema
indexSchema <- Proxy a -> Declare (Definitions Schema) Schema
forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) Schema
declareSchema (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a)
      NamedSchema -> Declare (Definitions Schema) NamedSchema
forall (m :: * -> *) a. Monad m => a -> m a
return (NamedSchema -> Declare (Definitions Schema) NamedSchema)
-> NamedSchema -> Declare (Definitions Schema) NamedSchema
forall a b. (a -> b) -> a -> b
$ Maybe Text -> Schema -> NamedSchema
NamedSchema ((Text -> Text) -> Maybe Text -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text
namePrefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) Maybe Text
n) (Schema -> NamedSchema) -> Schema -> NamedSchema
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 (SwaggerType 'SwaggerKindSchema)
 -> Identity (Maybe (SwaggerType 'SwaggerKindSchema)))
-> Schema -> Identity Schema
forall s a. HasType s a => Lens' s a
type_ ((Maybe (SwaggerType 'SwaggerKindSchema)
  -> Identity (Maybe (SwaggerType 'SwaggerKindSchema)))
 -> Schema -> Identity Schema)
-> Maybe (SwaggerType 'SwaggerKindSchema) -> Schema -> Schema
forall s t a b. ASetter s t a b -> b -> s -> t
.~ SwaggerType 'SwaggerKindSchema
-> Maybe (SwaggerType 'SwaggerKindSchema)
forall a. a -> Maybe a
Just SwaggerType 'SwaggerKindSchema
SwaggerObject
        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
properties ((InsOrdHashMap Text (Referenced Schema)
  -> Identity (InsOrdHashMap Text (Referenced Schema)))
 -> Schema -> Identity Schema)
-> InsOrdHashMap Text (Referenced Schema) -> Schema -> Schema
forall s t a b. ASetter s t a b -> b -> s -> t
.~
            [ ("value", Schema -> Referenced Schema
forall a. a -> Referenced a
Inline Schema
s)
            , (Text
field, Schema -> Referenced Schema
forall a. a -> Referenced a
Inline Schema
indexSchema)
            ]
        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
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]
forall a. Eq a => [a] -> [a]
L.nub [ "value", Text
Item [Text]
field ])
    inline :: Maybe Text -> Schema -> Declare (Definitions Schema) NamedSchema
inline n :: Maybe Text
n s :: Schema
s = do
      Schema
indexSchema <- Proxy a -> Declare (Definitions Schema) Schema
forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) Schema
declareSchema (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a)
      NamedSchema -> Declare (Definitions Schema) NamedSchema
forall (m :: * -> *) a. Monad m => a -> m a
return (NamedSchema -> Declare (Definitions Schema) NamedSchema)
-> NamedSchema -> Declare (Definitions Schema) NamedSchema
forall a b. (a -> b) -> a -> b
$ Maybe Text -> Schema -> NamedSchema
NamedSchema ((Text -> Text) -> Maybe Text -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text
namePrefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) Maybe Text
n) (Schema -> NamedSchema) -> Schema -> NamedSchema
forall a b. (a -> b) -> a -> b
$ Schema
s
        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
properties ((InsOrdHashMap Text (Referenced Schema)
  -> Identity (InsOrdHashMap Text (Referenced Schema)))
 -> Schema -> Identity Schema)
-> (InsOrdHashMap Text (Referenced Schema)
    -> InsOrdHashMap Text (Referenced Schema))
-> Schema
-> Schema
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ ([(Text
field, Schema -> Referenced Schema
forall a. a -> Referenced a
Inline Schema
indexSchema)] InsOrdHashMap Text (Referenced Schema)
-> InsOrdHashMap Text (Referenced Schema)
-> InsOrdHashMap Text (Referenced Schema)
forall a. Semigroup a => a -> a -> a
<>)
        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
required (([Text] -> Identity [Text]) -> Schema -> Identity Schema)
-> ([Text] -> [Text]) -> Schema -> Schema
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ ([Text
Item [Text]
field] [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<>)

-- | Merge fields of 'a' into 'b', more general version of 'WithField'.
--
-- The usual mode of the data type assumes that 'ToJSON' instances of 'a' and 'b'
-- produce 'Object' subtype of aeson 'Value'. If it is not true, a wrapper
-- layer is introduced.
--
-- If 'a' is not a 'Object', the wrapper contains 'injected' field with body of 'a'.
-- If 'b' is not a 'Object', the wrapper contains 'value' field with body of 'b'.
-- If both are not 'Object', the wrapper contains 'injected' and 'value' keys with
-- 'a' and 'b' respectively.
data WithFields a b = WithFields !a !b
  deriving ((forall x. WithFields a b -> Rep (WithFields a b) x)
-> (forall x. Rep (WithFields a b) x -> WithFields a b)
-> Generic (WithFields a b)
forall x. Rep (WithFields a b) x -> WithFields a b
forall x. WithFields a b -> Rep (WithFields a b) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a b x. Rep (WithFields a b) x -> WithFields a b
forall a b x. WithFields a b -> Rep (WithFields a b) x
$cto :: forall a b x. Rep (WithFields a b) x -> WithFields a b
$cfrom :: forall a b x. WithFields a b -> Rep (WithFields a b) x
Generic, WithFields a b -> WithFields a b -> Bool
(WithFields a b -> WithFields a b -> Bool)
-> (WithFields a b -> WithFields a b -> Bool)
-> Eq (WithFields a b)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall a b.
(Eq a, Eq b) =>
WithFields a b -> WithFields a b -> Bool
/= :: WithFields a b -> WithFields a b -> Bool
$c/= :: forall a b.
(Eq a, Eq b) =>
WithFields a b -> WithFields a b -> Bool
== :: WithFields a b -> WithFields a b -> Bool
$c== :: forall a b.
(Eq a, Eq b) =>
WithFields a b -> WithFields a b -> Bool
Eq, Int -> WithFields a b -> ShowS
[WithFields a b] -> ShowS
WithFields a b -> String
(Int -> WithFields a b -> ShowS)
-> (WithFields a b -> String)
-> ([WithFields a b] -> ShowS)
-> Show (WithFields a b)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall a b. (Show a, Show b) => Int -> WithFields a b -> ShowS
forall a b. (Show a, Show b) => [WithFields a b] -> ShowS
forall a b. (Show a, Show b) => WithFields a b -> String
showList :: [WithFields a b] -> ShowS
$cshowList :: forall a b. (Show a, Show b) => [WithFields a b] -> ShowS
show :: WithFields a b -> String
$cshow :: forall a b. (Show a, Show b) => WithFields a b -> String
showsPrec :: Int -> WithFields a b -> ShowS
$cshowsPrec :: forall a b. (Show a, Show b) => Int -> WithFields a b -> ShowS
Show, ReadPrec [WithFields a b]
ReadPrec (WithFields a b)
Int -> ReadS (WithFields a b)
ReadS [WithFields a b]
(Int -> ReadS (WithFields a b))
-> ReadS [WithFields a b]
-> ReadPrec (WithFields a b)
-> ReadPrec [WithFields a b]
-> Read (WithFields a b)
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
forall a b. (Read a, Read b) => ReadPrec [WithFields a b]
forall a b. (Read a, Read b) => ReadPrec (WithFields a b)
forall a b. (Read a, Read b) => Int -> ReadS (WithFields a b)
forall a b. (Read a, Read b) => ReadS [WithFields a b]
readListPrec :: ReadPrec [WithFields a b]
$creadListPrec :: forall a b. (Read a, Read b) => ReadPrec [WithFields a b]
readPrec :: ReadPrec (WithFields a b)
$creadPrec :: forall a b. (Read a, Read b) => ReadPrec (WithFields a b)
readList :: ReadS [WithFields a b]
$creadList :: forall a b. (Read a, Read b) => ReadS [WithFields a b]
readsPrec :: Int -> ReadS (WithFields a b)
$creadsPrec :: forall a b. (Read a, Read b) => Int -> ReadS (WithFields a b)
Read)

instance (NFData a, NFData b) => NFData (WithFields a b)

instance Functor (WithFields a) where
  fmap :: (a -> b) -> WithFields a a -> WithFields a b
fmap f :: a -> b
f (WithFields a :: a
a b :: a
b) = a -> b -> WithFields a b
forall a b. a -> b -> WithFields a b
WithFields a
a (a -> b
f a
b)

instance Bifunctor WithFields where
  bimap :: (a -> b) -> (c -> d) -> WithFields a c -> WithFields b d
bimap fa :: a -> b
fa fb :: c -> d
fb (WithFields a :: a
a b :: c
b) = b -> d -> WithFields b d
forall a b. a -> b -> WithFields a b
WithFields (a -> b
fa a
a) (c -> d
fb c
b)

instance (ToSample a, ToSample b) => ToSample (WithFields a b) where
  toSamples :: Proxy (WithFields a b) -> [(Text, WithFields a b)]
toSamples _ = [WithFields a b] -> [(Text, WithFields a b)]
forall a. [a] -> [(Text, a)]
samples ([WithFields a b] -> [(Text, WithFields a b)])
-> [WithFields a b] -> [(Text, WithFields a b)]
forall a b. (a -> b) -> a -> b
$ a -> b -> WithFields a b
forall a b. a -> b -> WithFields a b
WithFields (a -> b -> WithFields a b) -> [a] -> [b -> WithFields a b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a]
as [b -> WithFields a b] -> [b] -> [WithFields a b]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [b]
bs
    where
    as :: [a]
as = (Text, a) -> a
forall a b. (a, b) -> b
snd ((Text, a) -> a) -> [(Text, a)] -> [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Proxy a -> [(Text, a)]
forall a. ToSample a => Proxy a -> [(Text, a)]
toSamples (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a)
    bs :: [b]
bs = (Text, b) -> b
forall a b. (a, b) -> b
snd ((Text, b) -> b) -> [(Text, b)] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Proxy b -> [(Text, b)]
forall a. ToSample a => Proxy a -> [(Text, a)]
toSamples (Proxy b
forall k (t :: k). Proxy t
Proxy :: Proxy b)

-- | Note: the instance injects field only in 'Object' case.
-- In other cases it forms a wrapper around the 'Value' produced
-- by 'toJSON' of inner 'b' body.
--
-- Example of wrapper when 'b' is not a 'Object', 'b' goes into "value" field:
--
-- > { "field1": 0, "field2": "val", "value": [1, 2, 3] }
--
-- Example of wrapper when 'a' is not a 'Object', but 'b' is. 'a' goes into
-- "injected" field:
--
-- > { "field1": 0, "field2": "val", "injected": [1, 2, 3] }
--
-- Example of wrapper when as 'a' is not a 'Object', as 'b' is not. 'a' goes into
-- "injected" field, 'b' goes into "value" field:
--
-- > { "value": 42, "injected": [1, 2, 3] }
--
-- `WithFields a b` always overwites fields in JSON produced by `b` with fields from JSON
-- produced by `a`.
instance (ToJSON a, ToJSON b) => ToJSON (WithFields a b) where
  toJSON :: WithFields a b -> Value
toJSON (WithFields a :: a
a b :: b
b) = let
    jsonb :: Value
jsonb = b -> Value
forall a. ToJSON a => a -> Value
toJSON b
b
    jsona :: Value
jsona = a -> Value
forall a. ToJSON a => a -> Value
toJSON a
a
    in case Value
jsonb of
      Object bvs :: Object
bvs -> case Value
jsona of
        Object avs :: Object
avs -> Object -> Value
Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ Object -> Object -> Object
forall v. KeyMap v -> KeyMap v -> KeyMap v
KM.union Object
avs Object
bvs
        _ -> Object -> Value
Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ Key -> Value -> Object -> Object
forall v. Key -> v -> KeyMap v -> KeyMap v
KM.insert "injected" Value
jsona Object
bvs
      _ -> case Value
jsona of
        Object avs :: Object
avs -> Object -> Value
Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ case Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KM.lookup "value" Object
avs of
          Nothing -> Key -> Value -> Object -> Object
forall v. Key -> v -> KeyMap v -> KeyMap v
KM.insert "value" Value
jsonb Object
avs
          Just _ -> Object
avs
        _ -> [Pair] -> Value
object [
            "injected" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Value
jsona
          , "value" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Value
jsonb
          ]

-- | Note: the instance tries to parse the json as object with
-- additional field value, if it fails it assumes that it is a
-- wrapper produced by corresponding 'ToJSON' instance.
--
-- Note: The instance tries to parse the `b` part without fields of `a` at first time.
-- If it fails, the instance retries with presence of a's fields.
--
-- The implementation requires `ToJSON a` to catch fields of `a` and it is assumed
-- that `fromJSON . toJSON === id` for `a`.
instance (ToJSON a, FromJSON a, FromJSON b) => FromJSON (WithFields a b) where
  parseJSON :: Value -> Parser (WithFields a b)
parseJSON val :: Value
val@(Object o :: Object
o) = do
    (a :: a
a, isInjected :: Bool
isInjected) <- ((, Bool
False) (a -> (a, Bool)) -> Parser a -> Parser (a, Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser a
forall a. FromJSON a => Value -> Parser a
parseJSON Value
val) Parser (a, Bool) -> Parser (a, Bool) -> Parser (a, Bool)
forall a. Parser a -> Parser a -> Parser a
`mplus0` ((, Bool
True) (a -> (a, Bool)) -> Parser a -> Parser (a, Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Object
o Object -> Key -> Parser a
forall a. FromJSON a => Object -> Key -> Parser a
.: "injected"))
    let o' :: Object
o' = (if Bool
isInjected then Key -> Object -> Object
forall v. Key -> KeyMap v -> KeyMap v
KM.delete "injected" else [Key] -> Object -> Object
forall v. [Key] -> KeyMap v -> KeyMap v
deleteAll (a -> [Key]
ToJSON a => a -> [Key]
extractFields a
a)) Object
o
    b
b <-  ((Value -> Parser b
forall a. FromJSON a => Value -> Parser a
parseJSON (Object -> Value
Object Object
o')) Parser b -> Parser b -> Parser b
forall a. Parser a -> Parser a -> Parser a
`mplus0` (Object
o' Object -> Key -> Parser b
forall a. FromJSON a => Object -> Key -> Parser a
.: "value"))
      Parser b -> Parser b -> Parser b
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ((Value -> Parser b
forall a. FromJSON a => Value -> Parser a
parseJSON Value
val) Parser b -> Parser b -> Parser b
forall a. Parser a -> Parser a -> Parser a
`mplus0` (Object
o Object -> Key -> Parser b
forall a. FromJSON a => Object -> Key -> Parser a
.: "value"))
    WithFields a b -> Parser (WithFields a b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (WithFields a b -> Parser (WithFields a b))
-> WithFields a b -> Parser (WithFields a b)
forall a b. (a -> b) -> a -> b
$ a -> b -> WithFields a b
forall a b. a -> b -> WithFields a b
WithFields a
a b
b
    where
      deleteAll :: [Key.Key] -> KM.KeyMap v -> KM.KeyMap v
      deleteAll :: [Key] -> KeyMap v -> KeyMap v
deleteAll ks :: [Key]
ks m :: KeyMap v
m = (KeyMap v -> Key -> KeyMap v) -> KeyMap v -> [Key] -> KeyMap v
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
F.foldl' ((Key -> KeyMap v -> KeyMap v) -> KeyMap v -> Key -> KeyMap v
forall a b c. (a -> b -> c) -> b -> a -> c
flip Key -> KeyMap v -> KeyMap v
forall v. Key -> KeyMap v -> KeyMap v
KM.delete) KeyMap v
m [Key]
ks

      extractFields :: ToJSON a => a -> [Key.Key]
      extractFields :: a -> [Key]
extractFields a :: a
a = case a -> Value
forall a. ToJSON a => a -> Value
toJSON a
a of
        Object vs :: Object
vs -> Object -> [Key]
forall v. KeyMap v -> [Key]
KM.keys Object
vs
        _ -> []
  parseJSON wat :: Value
wat = String -> Value -> Parser (WithFields a b)
forall a. String -> Value -> Parser a
typeMismatch "Expected JSON Object" Value
wat

-- | Note: the instance tries to generate schema of the json as object with
-- additional field value, if it fails it assumes that it is a
-- wrapper produced by corresponding 'ToJSON' instance.
instance (ToSchema a, ToSchema b) => ToSchema (WithFields a b) where
  declareNamedSchema :: Proxy (WithFields a b) -> Declare (Definitions Schema) NamedSchema
declareNamedSchema _ = do
    NamedSchema nb :: Maybe Text
nb sb :: Schema
sb <- Proxy b -> Declare (Definitions Schema) NamedSchema
forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) NamedSchema
declareNamedSchema (Proxy b
forall k (t :: k). Proxy t
Proxy :: Proxy b)
    NamedSchema na :: Maybe Text
na sa :: Schema
sa <- Proxy a -> Declare (Definitions Schema) NamedSchema
forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) NamedSchema
declareNamedSchema (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a)
    let newName :: Maybe Text
newName = Text -> Text -> Text
forall a. (Semigroup a, IsString a) => a -> a -> a
combinedName (Text -> Text -> Text) -> Maybe Text -> Maybe (Text -> Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
na Maybe (Text -> Text) -> Maybe Text -> Maybe Text
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Text
nb
    NamedSchema -> Declare (Definitions Schema) NamedSchema
forall (m :: * -> *) a. Monad m => a -> m a
return (NamedSchema -> Declare (Definitions Schema) NamedSchema)
-> (Schema -> NamedSchema)
-> Schema
-> Declare (Definitions Schema) NamedSchema
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Text -> Schema -> NamedSchema
NamedSchema Maybe Text
newName (Schema -> Declare (Definitions Schema) NamedSchema)
-> Schema -> Declare (Definitions Schema) NamedSchema
forall a b. (a -> b) -> a -> b
$ case (Schema
sa Schema
-> Getting
     (Maybe (SwaggerType 'SwaggerKindSchema))
     Schema
     (Maybe (SwaggerType 'SwaggerKindSchema))
-> Maybe (SwaggerType 'SwaggerKindSchema)
forall s a. s -> Getting a s a -> a
^. Getting
  (Maybe (SwaggerType 'SwaggerKindSchema))
  Schema
  (Maybe (SwaggerType 'SwaggerKindSchema))
forall s a. HasType s a => Lens' s a
type_ , Schema
sb Schema
-> Getting
     (Maybe (SwaggerType 'SwaggerKindSchema))
     Schema
     (Maybe (SwaggerType 'SwaggerKindSchema))
-> Maybe (SwaggerType 'SwaggerKindSchema)
forall s a. s -> Getting a s a -> a
^. Getting
  (Maybe (SwaggerType 'SwaggerKindSchema))
  Schema
  (Maybe (SwaggerType 'SwaggerKindSchema))
forall s a. HasType s a => Lens' s a
type_) of
      (Just SwaggerObject, Just SwaggerObject) -> Schema
sb Schema -> Schema -> Schema
forall a. Semigroup a => a -> a -> a
<> Schema
sa
      (Just SwaggerObject, _) -> Schema -> Schema
forall b a a a a.
(Monoid b, HasType b (Maybe (SwaggerType 'SwaggerKindSchema)),
 HasProperties b a, HasRequired b a, IsList a, IsList a, IsString a,
 IsString (Item a), Item a ~ (a, Referenced a)) =>
a -> b
bwrapper Schema
sb Schema -> Schema -> Schema
forall a. Semigroup a => a -> a -> a
<> Schema
sa
      (_, Just SwaggerObject) -> Schema
sb Schema -> Schema -> Schema
forall a. Semigroup a => a -> a -> a
<> Schema -> Schema
forall b a a a a.
(Monoid b, HasType b (Maybe (SwaggerType 'SwaggerKindSchema)),
 HasProperties b a, HasRequired b a, IsList a, IsList a, IsString a,
 IsString (Item a), Item a ~ (a, Referenced a)) =>
a -> b
awrapper Schema
sa
      _ -> Schema -> Schema
forall b a a a a.
(Monoid b, HasType b (Maybe (SwaggerType 'SwaggerKindSchema)),
 HasProperties b a, HasRequired b a, IsList a, IsList a, IsString a,
 IsString (Item a), Item a ~ (a, Referenced a)) =>
a -> b
bwrapper Schema
sb Schema -> Schema -> Schema
forall a. Semigroup a => a -> a -> a
<> Schema -> Schema
forall b a a a a.
(Monoid b, HasType b (Maybe (SwaggerType 'SwaggerKindSchema)),
 HasProperties b a, HasRequired b a, IsList a, IsList a, IsString a,
 IsString (Item a), Item a ~ (a, Referenced a)) =>
a -> b
awrapper Schema
sa
    where
    combinedName :: a -> a -> a
combinedName a :: a
a b :: a
b = "WithFields_" a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
a a -> a -> a
forall a. Semigroup a => a -> a -> a
<> "_" a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
b
    awrapper :: a -> b
awrapper nas :: a
nas = b
forall a. Monoid a => a
mempty
      b -> (b -> b) -> b
forall a b. a -> (a -> b) -> b
& (Maybe (SwaggerType 'SwaggerKindSchema)
 -> Identity (Maybe (SwaggerType 'SwaggerKindSchema)))
-> b -> Identity b
forall s a. HasType s a => Lens' s a
type_ ((Maybe (SwaggerType 'SwaggerKindSchema)
  -> Identity (Maybe (SwaggerType 'SwaggerKindSchema)))
 -> b -> Identity b)
-> Maybe (SwaggerType 'SwaggerKindSchema) -> b -> b
forall s t a b. ASetter s t a b -> b -> s -> t
.~ SwaggerType 'SwaggerKindSchema
-> Maybe (SwaggerType 'SwaggerKindSchema)
forall a. a -> Maybe a
Just SwaggerType 'SwaggerKindSchema
SwaggerObject
      b -> (b -> b) -> b
forall a b. a -> (a -> b) -> b
& (a -> Identity a) -> b -> Identity b
forall s a. HasProperties s a => Lens' s a
properties ((a -> Identity a) -> b -> Identity b) -> a -> b -> b
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [ ("injected", a -> Referenced a
forall a. a -> Referenced a
Inline a
nas) ]
      b -> (b -> b) -> b
forall a b. a -> (a -> b) -> b
& (a -> Identity a) -> b -> Identity b
forall s a. HasRequired s a => Lens' s a
required ((a -> Identity a) -> b -> Identity b) -> a -> b -> b
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [ "injected" ]
    bwrapper :: a -> b
bwrapper nbs :: a
nbs = b
forall a. Monoid a => a
mempty
      b -> (b -> b) -> b
forall a b. a -> (a -> b) -> b
& (Maybe (SwaggerType 'SwaggerKindSchema)
 -> Identity (Maybe (SwaggerType 'SwaggerKindSchema)))
-> b -> Identity b
forall s a. HasType s a => Lens' s a
type_ ((Maybe (SwaggerType 'SwaggerKindSchema)
  -> Identity (Maybe (SwaggerType 'SwaggerKindSchema)))
 -> b -> Identity b)
-> Maybe (SwaggerType 'SwaggerKindSchema) -> b -> b
forall s t a b. ASetter s t a b -> b -> s -> t
.~ SwaggerType 'SwaggerKindSchema
-> Maybe (SwaggerType 'SwaggerKindSchema)
forall a. a -> Maybe a
Just SwaggerType 'SwaggerKindSchema
SwaggerObject
      b -> (b -> b) -> b
forall a b. a -> (a -> b) -> b
& (a -> Identity a) -> b -> Identity b
forall s a. HasProperties s a => Lens' s a
properties ((a -> Identity a) -> b -> Identity b) -> a -> b -> b
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [ ("value", a -> Referenced a
forall a. a -> Referenced a
Inline a
nbs) ]
      b -> (b -> b) -> b
forall a b. a -> (a -> b) -> b
& (a -> Identity a) -> b -> Identity b
forall s a. HasRequired s a => Lens' s a
required ((a -> Identity a) -> b -> Identity b) -> a -> b -> b
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [ "value" ]

-- | Special case, when you want to wrap your type @a@ in field with name @s@.
--
-- >>> encode (OnlyField 0 :: OnlyField "id" Int)
-- "{\"id\":0}"
--
-- >>> encode $ toSchema (Proxy :: Proxy (OnlyField "id" Int))
-- "{\"required\":[\"id\"],\"type\":\"object\",\"properties\":{\"id\":{\"maximum\":9223372036854775807,\"minimum\":-9223372036854775808,\"type\":\"integer\"}}}"
--
-- Also the type can be used as an endpoint for 'WithField':
--
-- >>> encode (WithField True (OnlyField 0) :: WithField "val" Bool (OnlyField "id" Int))
-- "{\"id\":0,\"val\":true}"
newtype OnlyField (s :: Symbol) a = OnlyField { OnlyField s a -> a
unOnlyField :: a }
  deriving ((forall x. OnlyField s a -> Rep (OnlyField s a) x)
-> (forall x. Rep (OnlyField s a) x -> OnlyField s a)
-> Generic (OnlyField s a)
forall x. Rep (OnlyField s a) x -> OnlyField s a
forall x. OnlyField s a -> Rep (OnlyField s a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (s :: Symbol) a x. Rep (OnlyField s a) x -> OnlyField s a
forall (s :: Symbol) a x. OnlyField s a -> Rep (OnlyField s a) x
$cto :: forall (s :: Symbol) a x. Rep (OnlyField s a) x -> OnlyField s a
$cfrom :: forall (s :: Symbol) a x. OnlyField s a -> Rep (OnlyField s a) x
Generic, Int -> OnlyField s a -> ShowS
[OnlyField s a] -> ShowS
OnlyField s a -> String
(Int -> OnlyField s a -> ShowS)
-> (OnlyField s a -> String)
-> ([OnlyField s a] -> ShowS)
-> Show (OnlyField s a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (s :: Symbol) a. Show a => Int -> OnlyField s a -> ShowS
forall (s :: Symbol) a. Show a => [OnlyField s a] -> ShowS
forall (s :: Symbol) a. Show a => OnlyField s a -> String
showList :: [OnlyField s a] -> ShowS
$cshowList :: forall (s :: Symbol) a. Show a => [OnlyField s a] -> ShowS
show :: OnlyField s a -> String
$cshow :: forall (s :: Symbol) a. Show a => OnlyField s a -> String
showsPrec :: Int -> OnlyField s a -> ShowS
$cshowsPrec :: forall (s :: Symbol) a. Show a => Int -> OnlyField s a -> ShowS
Show, ReadPrec [OnlyField s a]
ReadPrec (OnlyField s a)
Int -> ReadS (OnlyField s a)
ReadS [OnlyField s a]
(Int -> ReadS (OnlyField s a))
-> ReadS [OnlyField s a]
-> ReadPrec (OnlyField s a)
-> ReadPrec [OnlyField s a]
-> Read (OnlyField s a)
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
forall (s :: Symbol) a. Read a => ReadPrec [OnlyField s a]
forall (s :: Symbol) a. Read a => ReadPrec (OnlyField s a)
forall (s :: Symbol) a. Read a => Int -> ReadS (OnlyField s a)
forall (s :: Symbol) a. Read a => ReadS [OnlyField s a]
readListPrec :: ReadPrec [OnlyField s a]
$creadListPrec :: forall (s :: Symbol) a. Read a => ReadPrec [OnlyField s a]
readPrec :: ReadPrec (OnlyField s a)
$creadPrec :: forall (s :: Symbol) a. Read a => ReadPrec (OnlyField s a)
readList :: ReadS [OnlyField s a]
$creadList :: forall (s :: Symbol) a. Read a => ReadS [OnlyField s a]
readsPrec :: Int -> ReadS (OnlyField s a)
$creadsPrec :: forall (s :: Symbol) a. Read a => Int -> ReadS (OnlyField s a)
Read, OnlyField s a -> OnlyField s a -> Bool
(OnlyField s a -> OnlyField s a -> Bool)
-> (OnlyField s a -> OnlyField s a -> Bool) -> Eq (OnlyField s a)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (s :: Symbol) a.
Eq a =>
OnlyField s a -> OnlyField s a -> Bool
/= :: OnlyField s a -> OnlyField s a -> Bool
$c/= :: forall (s :: Symbol) a.
Eq a =>
OnlyField s a -> OnlyField s a -> Bool
== :: OnlyField s a -> OnlyField s a -> Bool
$c== :: forall (s :: Symbol) a.
Eq a =>
OnlyField s a -> OnlyField s a -> Bool
Eq)

-- | Special case for the most common "id" field
type OnlyId i = OnlyField "id" i

instance Functor (OnlyField s) where
  fmap :: (a -> b) -> OnlyField s a -> OnlyField s b
fmap f :: a -> b
f (OnlyField a :: a
a) = b -> OnlyField s b
forall (s :: Symbol) a. a -> OnlyField s a
OnlyField (a -> b
f a
a)

instance ToSample a => ToSample (OnlyField s a) where
  toSamples :: Proxy (OnlyField s a) -> [(Text, OnlyField s a)]
toSamples _ = [OnlyField s a] -> [(Text, OnlyField s a)]
forall a. [a] -> [(Text, a)]
samples ([OnlyField s a] -> [(Text, OnlyField s a)])
-> [OnlyField s a] -> [(Text, OnlyField s a)]
forall a b. (a -> b) -> a -> b
$ a -> OnlyField s a
forall (s :: Symbol) a. a -> OnlyField s a
OnlyField (a -> OnlyField s a) -> [a] -> [OnlyField s a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a]
as
    where
    as :: [a]
as = (Text, a) -> a
forall a b. (a, b) -> b
snd ((Text, a) -> a) -> [(Text, a)] -> [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Proxy a -> [(Text, a)]
forall a. ToSample a => Proxy a -> [(Text, a)]
toSamples (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a)

instance (KnownSymbol s, ToJSON a) => ToJSON (OnlyField s a) where
  toJSON :: OnlyField s a -> Value
toJSON (OnlyField a :: a
a) = [Pair] -> Value
object [ KnownSymbol s => Key
forall (s :: Symbol). KnownSymbol s => Key
mkFieldName @s Key -> a -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= a
a ]

instance (KnownSymbol s, FromJSON a) => FromJSON (OnlyField s a) where
  parseJSON :: Value -> Parser (OnlyField s a)
parseJSON (Object o :: Object
o) = a -> OnlyField s a
forall (s :: Symbol) a. a -> OnlyField s a
OnlyField (a -> OnlyField s a) -> Parser a -> Parser (OnlyField s a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser a
forall a. FromJSON a => Object -> Key -> Parser a
.: (KnownSymbol s => Key
forall (s :: Symbol). KnownSymbol s => Key
mkFieldName @s)
  parseJSON _ = Parser (OnlyField s a)
forall (m :: * -> *) a. MonadPlus m => m a
mzero

instance (KnownSymbol s, ToSchema a) => ToSchema (OnlyField s a) where
  declareNamedSchema :: Proxy (OnlyField s a) -> Declare (Definitions Schema) NamedSchema
declareNamedSchema _ = do
    NamedSchema an :: Maybe Text
an as :: Schema
as <- Proxy a -> Declare (Definitions Schema) NamedSchema
forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) NamedSchema
declareNamedSchema (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a)
    let namePrefix :: Text
namePrefix = "OnlyField '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Key -> Text
Key.toText Key
field Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "' "
    NamedSchema -> Declare (Definitions Schema) NamedSchema
forall (m :: * -> *) a. Monad m => a -> m a
return (NamedSchema -> Declare (Definitions Schema) NamedSchema)
-> NamedSchema -> Declare (Definitions Schema) NamedSchema
forall a b. (a -> b) -> a -> b
$ Maybe Text -> Schema -> NamedSchema
NamedSchema ((Text -> Text) -> Maybe Text -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text
namePrefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) Maybe Text
an) (Schema -> NamedSchema) -> Schema -> NamedSchema
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 (SwaggerType 'SwaggerKindSchema)
 -> Identity (Maybe (SwaggerType 'SwaggerKindSchema)))
-> Schema -> Identity Schema
forall s a. HasType s a => Lens' s a
type_ ((Maybe (SwaggerType 'SwaggerKindSchema)
  -> Identity (Maybe (SwaggerType 'SwaggerKindSchema)))
 -> Schema -> Identity Schema)
-> Maybe (SwaggerType 'SwaggerKindSchema) -> Schema -> Schema
forall s t a b. ASetter s t a b -> b -> s -> t
.~ SwaggerType 'SwaggerKindSchema
-> Maybe (SwaggerType 'SwaggerKindSchema)
forall a. a -> Maybe a
Just SwaggerType 'SwaggerKindSchema
SwaggerObject
      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
properties ((InsOrdHashMap Text (Referenced Schema)
  -> Identity (InsOrdHashMap Text (Referenced Schema)))
 -> Schema -> Identity Schema)
-> InsOrdHashMap Text (Referenced Schema) -> Schema -> Schema
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [(Key -> Text
Key.toText Key
field, Schema -> Referenced Schema
forall a. a -> Referenced a
Inline Schema
as)]
      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
required (([Text] -> Identity [Text]) -> Schema -> Identity Schema)
-> [Text] -> Schema -> Schema
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Key -> Text
Key.toText Key
field]
    where
    field :: Key
field = KnownSymbol s => Key
forall (s :: Symbol). KnownSymbol s => Key
mkFieldName @s

mkFieldName :: forall s . KnownSymbol s => Key.Key
mkFieldName :: Key
mkFieldName = String -> Key
Key.fromString (String -> Key) -> String -> Key
forall a b. (a -> b) -> a -> b
$ Proxy s -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy s
forall k (t :: k). Proxy t
Proxy :: Proxy s)