{-# 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 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
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
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)
ReadS [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 :: forall a b. (a -> b) -> WithField s a a -> WithField s a b
fmap a -> b
f (WithField a
a 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 :: forall a b c d.
(a -> b) -> (c -> d) -> WithField s a c -> WithField s b d
bimap a -> b
fa c -> d
fb (WithField a
a c
b) = 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 Proxy (WithField s a b)
_ = forall a. [a] -> [(Text, a)]
samples forall a b. (a -> b) -> a -> b
$ forall (s :: Symbol) a b. a -> b -> WithField s a b
WithField forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a]
as forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [b]
bs
    where
    as :: [a]
as = forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. ToSample a => Proxy a -> [(Text, a)]
toSamples (forall {k} (t :: k). Proxy t
Proxy :: Proxy a)
    bs :: [b]
bs = forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. ToSample a => Proxy a -> [(Text, a)]
toSamples (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 b
b) = let
    jsonb :: Value
jsonb = forall a. ToJSON a => a -> Value
toJSON b
b
    field :: Key
field = forall (s :: Symbol). KnownSymbol s => Key
mkFieldName @s
    in case forall a. ToJSON a => a -> Value
toJSON b
b of
      Object Object
vs -> Object -> Value
Object forall a b. (a -> b) -> a -> b
$ forall v. Key -> v -> KeyMap v -> KeyMap v
KM.insert Key
field (forall a. ToJSON a => a -> Value
toJSON a
a) Object
vs
      Value
_ -> [Pair] -> Value
object [
          Key
"value" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Value
jsonb
        , Key
field 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 Object
o) = Parser (WithField s a b)
injected forall a. Parser a -> Parser a -> Parser a
`mplus0` Parser (WithField s a b)
wrapper
    where
    field :: Key
field = forall (s :: Symbol). KnownSymbol s => Key
mkFieldName @s
    injected :: Parser (WithField s a b)
injected = forall (s :: Symbol) a b. a -> b -> WithField s a b
WithField
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
field
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall a. FromJSON a => Value -> Parser a
parseJSON (Object -> Value
Object forall a b. (a -> b) -> a -> b
$ forall v. Key -> KeyMap v -> KeyMap v
KM.delete Key
field Object
o) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a. FromJSON a => Value -> Parser a
parseJSON Value
val)
    wrapper :: Parser (WithField s a b)
wrapper = forall (s :: Symbol) a b. a -> b -> WithField s a b
WithField
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
field
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"value"
  parseJSON Value
wat = forall a. String -> Value -> Parser a
typeMismatch String
"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 Proxy (WithField s a b)
_ = do
    NamedSchema Maybe Text
n Schema
s <- forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) NamedSchema
declareNamedSchema (forall {k} (t :: k). Proxy t
Proxy :: Proxy b)
    if Schema
s forall s a. s -> Getting a s a -> a
^. forall s a. HasType s a => Lens' s a
type_ forall a. Eq a => a -> a -> Bool
== 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 forall a b. (a -> b) -> a -> b
$ forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
Proxy :: Proxy s)
    namePrefix :: Text
namePrefix = Text
"WithField '" forall a. Semigroup a => a -> a -> a
<> Text
field forall a. Semigroup a => a -> a -> a
<> Text
"' "
    wrapper :: Maybe Text -> Schema -> Declare (Definitions Schema) NamedSchema
wrapper Maybe Text
n Schema
s = do
      Schema
indexSchema <- forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) Schema
declareSchema (forall {k} (t :: k). Proxy t
Proxy :: Proxy a)
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Maybe Text -> Schema -> NamedSchema
NamedSchema (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text
namePrefix forall a. Semigroup a => a -> a -> a
<>) Maybe Text
n) forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => a
mempty
        forall a b. a -> (a -> b) -> b
& forall s a. HasType s a => Lens' s a
type_ forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> Maybe a
Just SwaggerType 'SwaggerKindSchema
SwaggerObject
        forall a b. a -> (a -> b) -> b
& forall s a. HasProperties s a => Lens' s a
properties forall s t a b. ASetter s t a b -> b -> s -> t
.~
            [ (Text
"value", forall a. a -> Referenced a
Inline Schema
s)
            , (Text
field, forall a. a -> Referenced a
Inline Schema
indexSchema)
            ]
        forall a b. a -> (a -> b) -> b
& forall s a. HasRequired s a => Lens' s a
required forall s t a b. ASetter s t a b -> b -> s -> t
.~ (forall a. Eq a => [a] -> [a]
L.nub [ Text
"value", Text
field ])
    inline :: Maybe Text -> Schema -> Declare (Definitions Schema) NamedSchema
inline Maybe Text
n Schema
s = do
      Schema
indexSchema <- forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) Schema
declareSchema (forall {k} (t :: k). Proxy t
Proxy :: Proxy a)
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Maybe Text -> Schema -> NamedSchema
NamedSchema (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text
namePrefix forall a. Semigroup a => a -> a -> a
<>) Maybe Text
n) forall a b. (a -> b) -> a -> b
$ Schema
s
        forall a b. a -> (a -> b) -> b
& forall s a. HasProperties s a => Lens' s a
properties forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ ([(Text
field, forall a. a -> Referenced a
Inline Schema
indexSchema)] forall a. Semigroup a => a -> a -> a
<>)
        forall a b. a -> (a -> b) -> b
& forall s a. HasRequired s a => Lens' s a
required forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ ([Text
field] 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 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
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
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)
ReadS [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 :: forall a b. (a -> b) -> WithFields a a -> WithFields a b
fmap a -> b
f (WithFields a
a a
b) = forall a b. a -> b -> WithFields a b
WithFields a
a (a -> b
f a
b)

instance Bifunctor WithFields where
  bimap :: forall a b c d.
(a -> b) -> (c -> d) -> WithFields a c -> WithFields b d
bimap a -> b
fa c -> d
fb (WithFields a
a c
b) = 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 Proxy (WithFields a b)
_ = forall a. [a] -> [(Text, a)]
samples forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> WithFields a b
WithFields forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a]
as forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [b]
bs
    where
    as :: [a]
as = forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. ToSample a => Proxy a -> [(Text, a)]
toSamples (forall {k} (t :: k). Proxy t
Proxy :: Proxy a)
    bs :: [b]
bs = forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. ToSample a => Proxy a -> [(Text, a)]
toSamples (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 b
b) = let
    jsonb :: Value
jsonb = forall a. ToJSON a => a -> Value
toJSON b
b
    jsona :: Value
jsona = forall a. ToJSON a => a -> Value
toJSON a
a
    in case Value
jsonb of
      Object Object
bvs -> case Value
jsona of
        Object Object
avs -> Object -> Value
Object forall a b. (a -> b) -> a -> b
$ forall v. KeyMap v -> KeyMap v -> KeyMap v
KM.union Object
avs Object
bvs
        Value
_ -> Object -> Value
Object forall a b. (a -> b) -> a -> b
$ forall v. Key -> v -> KeyMap v -> KeyMap v
KM.insert Key
"injected" Value
jsona Object
bvs
      Value
_ -> case Value
jsona of
        Object Object
avs -> Object -> Value
Object forall a b. (a -> b) -> a -> b
$ case forall v. Key -> KeyMap v -> Maybe v
KM.lookup Key
"value" Object
avs of
          Maybe Value
Nothing -> forall v. Key -> v -> KeyMap v -> KeyMap v
KM.insert Key
"value" Value
jsonb Object
avs
          Just Value
_ -> Object
avs
        Value
_ -> [Pair] -> Value
object [
            Key
"injected" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Value
jsona
          , Key
"value" 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 Object
o) = do
    (a
a, Bool
isInjected) <- ((, Bool
False) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromJSON a => Value -> Parser a
parseJSON Value
val) forall a. Parser a -> Parser a -> Parser a
`mplus0` ((, Bool
True) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"injected"))
    let o' :: Object
o' = (if Bool
isInjected then forall v. Key -> KeyMap v -> KeyMap v
KM.delete Key
"injected" else forall v. [Key] -> KeyMap v -> KeyMap v
deleteAll (ToJSON a => a -> [Key]
extractFields a
a)) Object
o
    b
b <-  ((forall a. FromJSON a => Value -> Parser a
parseJSON (Object -> Value
Object Object
o')) forall a. Parser a -> Parser a -> Parser a
`mplus0` (Object
o' forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"value"))
      forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ((forall a. FromJSON a => Value -> Parser a
parseJSON Value
val) forall a. Parser a -> Parser a -> Parser a
`mplus0` (Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"value"))
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> 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 :: forall v. [Key] -> KeyMap v -> KeyMap v
deleteAll [Key]
ks KeyMap v
m = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
F.foldl' (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall v. Key -> KeyMap v -> KeyMap v
KM.delete) KeyMap v
m [Key]
ks

      extractFields :: ToJSON a => a -> [Key.Key]
      extractFields :: ToJSON a => a -> [Key]
extractFields a
a = case forall a. ToJSON a => a -> Value
toJSON a
a of
        Object Object
vs -> forall v. KeyMap v -> [Key]
KM.keys Object
vs
        Value
_ -> []
  parseJSON Value
wat = forall a. String -> Value -> Parser a
typeMismatch String
"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 Proxy (WithFields a b)
_ = do
    NamedSchema Maybe Text
nb Schema
sb <- forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) NamedSchema
declareNamedSchema (forall {k} (t :: k). Proxy t
Proxy :: Proxy b)
    NamedSchema Maybe Text
na Schema
sa <- forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) NamedSchema
declareNamedSchema (forall {k} (t :: k). Proxy t
Proxy :: Proxy a)
    let newName :: Maybe Text
newName = forall {a}. (Semigroup a, IsString a) => a -> a -> a
combinedName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
na forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Text
nb
    forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Text -> Schema -> NamedSchema
NamedSchema Maybe Text
newName forall a b. (a -> b) -> a -> b
$ case (Schema
sa forall s a. s -> Getting a s a -> a
^. forall s a. HasType s a => Lens' s a
type_ , Schema
sb forall s a. s -> Getting a s a -> a
^. forall s a. HasType s a => Lens' s a
type_) of
      (Just SwaggerType 'SwaggerKindSchema
SwaggerObject, Just SwaggerType 'SwaggerKindSchema
SwaggerObject) -> Schema
sb forall a. Semigroup a => a -> a -> a
<> Schema
sa
      (Just SwaggerType 'SwaggerKindSchema
SwaggerObject, Maybe (SwaggerType 'SwaggerKindSchema)
_) -> forall {b} {a} {a} {b} {b}.
(Item b ~ (a, Referenced a), Monoid b,
 HasType b (Maybe (SwaggerType 'SwaggerKindSchema)),
 HasProperties b b, HasRequired b b, IsList b, IsList b, IsString a,
 IsString (Item b)) =>
a -> b
bwrapper Schema
sb forall a. Semigroup a => a -> a -> a
<> Schema
sa
      (Maybe (SwaggerType 'SwaggerKindSchema)
_, Just SwaggerType 'SwaggerKindSchema
SwaggerObject) -> Schema
sb forall a. Semigroup a => a -> a -> a
<> forall {b} {a} {a} {b} {b}.
(Item b ~ (a, Referenced a), Monoid b,
 HasType b (Maybe (SwaggerType 'SwaggerKindSchema)),
 HasProperties b b, HasRequired b b, IsList b, IsList b, IsString a,
 IsString (Item b)) =>
a -> b
awrapper Schema
sa
      (Maybe (SwaggerType 'SwaggerKindSchema),
 Maybe (SwaggerType 'SwaggerKindSchema))
_ -> forall {b} {a} {a} {b} {b}.
(Item b ~ (a, Referenced a), Monoid b,
 HasType b (Maybe (SwaggerType 'SwaggerKindSchema)),
 HasProperties b b, HasRequired b b, IsList b, IsList b, IsString a,
 IsString (Item b)) =>
a -> b
bwrapper Schema
sb forall a. Semigroup a => a -> a -> a
<> forall {b} {a} {a} {b} {b}.
(Item b ~ (a, Referenced a), Monoid b,
 HasType b (Maybe (SwaggerType 'SwaggerKindSchema)),
 HasProperties b b, HasRequired b b, IsList b, IsList b, IsString a,
 IsString (Item b)) =>
a -> b
awrapper Schema
sa
    where
    combinedName :: a -> a -> a
combinedName a
a a
b = a
"WithFields_" forall a. Semigroup a => a -> a -> a
<> a
a forall a. Semigroup a => a -> a -> a
<> a
"_" forall a. Semigroup a => a -> a -> a
<> a
b
    awrapper :: a -> b
awrapper a
nas = forall a. Monoid a => a
mempty
      forall a b. a -> (a -> b) -> b
& forall s a. HasType s a => Lens' s a
type_ forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> Maybe a
Just SwaggerType 'SwaggerKindSchema
SwaggerObject
      forall a b. a -> (a -> b) -> b
& forall s a. HasProperties s a => Lens' s a
properties forall s t a b. ASetter s t a b -> b -> s -> t
.~ [ (a
"injected", forall a. a -> Referenced a
Inline a
nas) ]
      forall a b. a -> (a -> b) -> b
& forall s a. HasRequired s a => Lens' s a
required forall s t a b. ASetter s t a b -> b -> s -> t
.~ [ Item b
"injected" ]
    bwrapper :: a -> b
bwrapper a
nbs = forall a. Monoid a => a
mempty
      forall a b. a -> (a -> b) -> b
& forall s a. HasType s a => Lens' s a
type_ forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> Maybe a
Just SwaggerType 'SwaggerKindSchema
SwaggerObject
      forall a b. a -> (a -> b) -> b
& forall s a. HasProperties s a => Lens' s a
properties forall s t a b. ASetter s t a b -> b -> s -> t
.~ [ (a
"value", forall a. a -> Referenced a
Inline a
nbs) ]
      forall a b. a -> (a -> b) -> b
& forall s a. HasRequired s a => Lens' s a
required forall s t a b. ASetter s t a b -> b -> s -> t
.~ [ Item b
"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 { forall (s :: Symbol) a. OnlyField s a -> a
unOnlyField :: a }
  deriving (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
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)
ReadS [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
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 :: forall a b. (a -> b) -> OnlyField s a -> OnlyField s b
fmap a -> b
f (OnlyField a
a) = 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 Proxy (OnlyField s a)
_ = forall a. [a] -> [(Text, a)]
samples forall a b. (a -> b) -> a -> b
$ forall (s :: Symbol) a. a -> OnlyField s a
OnlyField forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a]
as
    where
    as :: [a]
as = forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. ToSample a => Proxy a -> [(Text, a)]
toSamples (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) = [Pair] -> Value
object [ forall (s :: Symbol). KnownSymbol s => Key
mkFieldName @s 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 Object
o) = forall (s :: Symbol) a. a -> OnlyField s a
OnlyField forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: (forall (s :: Symbol). KnownSymbol s => Key
mkFieldName @s)
  parseJSON Value
_ = 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 Proxy (OnlyField s a)
_ = do
    NamedSchema Maybe Text
an Schema
as <- forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) NamedSchema
declareNamedSchema (forall {k} (t :: k). Proxy t
Proxy :: Proxy a)
    let namePrefix :: Text
namePrefix = Text
"OnlyField '" forall a. Semigroup a => a -> a -> a
<> Key -> Text
Key.toText Key
field forall a. Semigroup a => a -> a -> a
<> Text
"' "
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Maybe Text -> Schema -> NamedSchema
NamedSchema (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text
namePrefix forall a. Semigroup a => a -> a -> a
<>) Maybe Text
an) forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => a
mempty
      forall a b. a -> (a -> b) -> b
& forall s a. HasType s a => Lens' s a
type_ forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> Maybe a
Just SwaggerType 'SwaggerKindSchema
SwaggerObject
      forall a b. a -> (a -> b) -> b
& forall s a. HasProperties s a => Lens' s a
properties forall s t a b. ASetter s t a b -> b -> s -> t
.~ [(Key -> Text
Key.toText Key
field, forall a. a -> Referenced a
Inline Schema
as)]
      forall a b. a -> (a -> b) -> b
& forall s a. HasRequired s a => Lens' s a
required forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Key -> Text
Key.toText Key
field]
    where
    field :: Key
field = forall (s :: Symbol). KnownSymbol s => Key
mkFieldName @s

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