{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UndecidableSuperClasses #-}
module Data.OpenApi.Internal.AesonUtils (
    -- * Generic functions
    AesonDefaultValue(..),
    sopSwaggerGenericToJSON,
    sopSwaggerGenericToEncoding,
    sopSwaggerGenericToJSONWithOpts,
    sopSwaggerGenericParseJSON,
    -- * Options
    HasSwaggerAesonOptions(..),
    SwaggerAesonOptions,
    mkSwaggerAesonOptions,
    saoPrefix,
    saoAdditionalPairs,
    saoSubObject,
    ) where

import Prelude ()
import Prelude.Compat

import Control.Applicative ((<|>))
import Control.Lens     (makeLenses, (^.))
import Control.Monad    (unless)
import Data.Aeson       (ToJSON(..), FromJSON(..), Value(..), Object, object, (.:), (.:?), (.!=), withObject, Encoding, pairs, (.=), Series)
import Data.Aeson.Types (Parser, Pair)
import Data.Char        (toLower, isUpper)
import Data.Foldable    (traverse_)
import Data.Text        (Text)

import Generics.SOP

import qualified Data.Text as T
import qualified Data.Set as Set
import qualified Data.HashMap.Strict.InsOrd as InsOrd
import qualified Data.HashSet.InsOrd as InsOrdHS

import Data.OpenApi.Aeson.Compat (keyToString, objectToList, stringToKey)

-------------------------------------------------------------------------------
-- SwaggerAesonOptions
-------------------------------------------------------------------------------

data SwaggerAesonOptions = SwaggerAesonOptions
    { SwaggerAesonOptions -> String
_saoPrefix          :: String
    , SwaggerAesonOptions -> [Pair]
_saoAdditionalPairs :: [Pair]
    , SwaggerAesonOptions -> Maybe String
_saoSubObject       :: Maybe String
    }

mkSwaggerAesonOptions
    :: String  -- ^ prefix
    -> SwaggerAesonOptions
mkSwaggerAesonOptions :: String -> SwaggerAesonOptions
mkSwaggerAesonOptions String
pfx = String -> [Pair] -> Maybe String -> SwaggerAesonOptions
SwaggerAesonOptions String
pfx [] Maybe String
forall a. Maybe a
Nothing

makeLenses ''SwaggerAesonOptions

class (Generic a, All2 AesonDefaultValue (Code a)) => HasSwaggerAesonOptions a where
    swaggerAesonOptions :: Proxy a -> SwaggerAesonOptions

    -- So far we use only default definitions
    aesonDefaults :: Proxy a -> POP Maybe (Code a)
    aesonDefaults Proxy a
_ = Proxy AesonDefaultValue
-> (forall a. AesonDefaultValue a => Maybe a) -> POP Maybe (Code a)
forall k l (h :: (k -> *) -> l -> *) (c :: k -> Constraint)
       (xs :: l) (proxy :: (k -> Constraint) -> *) (f :: k -> *).
(HPure h, AllN h c xs) =>
proxy c -> (forall (a :: k). c a => f a) -> h f xs
hcpure (Proxy AesonDefaultValue
forall k (t :: k). Proxy t
Proxy :: Proxy AesonDefaultValue) forall a. AesonDefaultValue a => Maybe a
defaultValue

-------------------------------------------------------------------------------
-- Generics
-------------------------------------------------------------------------------

class AesonDefaultValue a where
    defaultValue :: Maybe a
    defaultValue = Maybe a
forall a. Maybe a
Nothing

instance AesonDefaultValue Text where defaultValue :: Maybe Text
defaultValue = Maybe Text
forall a. Maybe a
Nothing
instance AesonDefaultValue (Maybe a) where defaultValue :: Maybe (Maybe a)
defaultValue = Maybe a -> Maybe (Maybe a)
forall a. a -> Maybe a
Just Maybe a
forall a. Maybe a
Nothing
instance AesonDefaultValue [a] where defaultValue :: Maybe [a]
defaultValue = [a] -> Maybe [a]
forall a. a -> Maybe a
Just []
instance AesonDefaultValue (Set.Set a) where defaultValue :: Maybe (Set a)
defaultValue = Set a -> Maybe (Set a)
forall a. a -> Maybe a
Just Set a
forall a. Set a
Set.empty
instance AesonDefaultValue (InsOrdHS.InsOrdHashSet k) where defaultValue :: Maybe (InsOrdHashSet k)
defaultValue = InsOrdHashSet k -> Maybe (InsOrdHashSet k)
forall a. a -> Maybe a
Just InsOrdHashSet k
forall k. InsOrdHashSet k
InsOrdHS.empty
instance AesonDefaultValue (InsOrd.InsOrdHashMap k v) where defaultValue :: Maybe (InsOrdHashMap k v)
defaultValue = InsOrdHashMap k v -> Maybe (InsOrdHashMap k v)
forall a. a -> Maybe a
Just InsOrdHashMap k v
forall k v. InsOrdHashMap k v
InsOrd.empty

-------------------------------------------------------------------------------
-- ToJSON
-------------------------------------------------------------------------------

-- | Generic serialisation for swagger records.
--
-- Features
--
-- * omits nulls, empty objects and empty arrays (configurable)
-- * possible to add fields
-- * possible to merge sub-object
sopSwaggerGenericToJSON
    :: forall a xs.
        ( HasDatatypeInfo a
        , HasSwaggerAesonOptions a
        , All2 ToJSON (Code a)
        , All2 Eq (Code a)
        , Code a ~ '[xs]
        )
    => a
    -> Value
sopSwaggerGenericToJSON :: a -> Value
sopSwaggerGenericToJSON a
x =
    let ps :: [Pair]
ps = SwaggerAesonOptions
-> SOP I '[xs] -> DatatypeInfo '[xs] -> POP Maybe '[xs] -> [Pair]
forall (xs :: [*]).
(All2 ToJSON '[xs], All2 Eq '[xs]) =>
SwaggerAesonOptions
-> SOP I '[xs] -> DatatypeInfo '[xs] -> POP Maybe '[xs] -> [Pair]
sopSwaggerGenericToJSON' SwaggerAesonOptions
opts (a -> Rep a
forall a. Generic a => a -> Rep a
from a
x) (Proxy a -> DatatypeInfo (Code a)
forall a (proxy :: * -> *).
HasDatatypeInfo a =>
proxy a -> DatatypeInfo (Code a)
datatypeInfo Proxy a
proxy) (Proxy a -> POP Maybe (Code a)
forall a. HasSwaggerAesonOptions a => Proxy a -> POP Maybe (Code a)
aesonDefaults Proxy a
proxy)
    in [Pair] -> Value
object (SwaggerAesonOptions
opts SwaggerAesonOptions
-> Getting [Pair] SwaggerAesonOptions [Pair] -> [Pair]
forall s a. s -> Getting a s a -> a
^. Getting [Pair] SwaggerAesonOptions [Pair]
Lens' SwaggerAesonOptions [Pair]
saoAdditionalPairs [Pair] -> [Pair] -> [Pair]
forall a. [a] -> [a] -> [a]
++ [Pair]
ps)
  where
    proxy :: Proxy a
proxy = Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a
    opts :: SwaggerAesonOptions
opts  = Proxy a -> SwaggerAesonOptions
forall a.
HasSwaggerAesonOptions a =>
Proxy a -> SwaggerAesonOptions
swaggerAesonOptions Proxy a
proxy

-- | *TODO:* This is only used by ToJSON (ParamSchema SwaggerKindSchema)
--
-- Also uses default `aesonDefaults`
sopSwaggerGenericToJSONWithOpts
    :: forall a xs.
        ( Generic a
        , All2 AesonDefaultValue (Code a)
        , HasDatatypeInfo a
        , All2 ToJSON (Code a)
        , All2 Eq (Code a)
        , Code a ~ '[xs]
        )
    => SwaggerAesonOptions
    -> a
    -> Value
sopSwaggerGenericToJSONWithOpts :: SwaggerAesonOptions -> a -> Value
sopSwaggerGenericToJSONWithOpts SwaggerAesonOptions
opts a
x =
    let ps :: [Pair]
ps = SwaggerAesonOptions
-> SOP I '[xs] -> DatatypeInfo '[xs] -> POP Maybe '[xs] -> [Pair]
forall (xs :: [*]).
(All2 ToJSON '[xs], All2 Eq '[xs]) =>
SwaggerAesonOptions
-> SOP I '[xs] -> DatatypeInfo '[xs] -> POP Maybe '[xs] -> [Pair]
sopSwaggerGenericToJSON' SwaggerAesonOptions
opts (a -> Rep a
forall a. Generic a => a -> Rep a
from a
x) (Proxy a -> DatatypeInfo (Code a)
forall a (proxy :: * -> *).
HasDatatypeInfo a =>
proxy a -> DatatypeInfo (Code a)
datatypeInfo Proxy a
proxy) POP Maybe '[xs]
defs
    in [Pair] -> Value
object (SwaggerAesonOptions
opts SwaggerAesonOptions
-> Getting [Pair] SwaggerAesonOptions [Pair] -> [Pair]
forall s a. s -> Getting a s a -> a
^. Getting [Pair] SwaggerAesonOptions [Pair]
Lens' SwaggerAesonOptions [Pair]
saoAdditionalPairs [Pair] -> [Pair] -> [Pair]
forall a. [a] -> [a] -> [a]
++ [Pair]
ps)
  where
    proxy :: Proxy a
proxy = Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a
    defs :: POP Maybe '[xs]
defs = Proxy AesonDefaultValue
-> (forall a. AesonDefaultValue a => Maybe a) -> POP Maybe '[xs]
forall k l (h :: (k -> *) -> l -> *) (c :: k -> Constraint)
       (xs :: l) (proxy :: (k -> Constraint) -> *) (f :: k -> *).
(HPure h, AllN h c xs) =>
proxy c -> (forall (a :: k). c a => f a) -> h f xs
hcpure (Proxy AesonDefaultValue
forall k (t :: k). Proxy t
Proxy :: Proxy AesonDefaultValue) forall a. AesonDefaultValue a => Maybe a
defaultValue

sopSwaggerGenericToJSON'
    :: (All2 ToJSON '[xs], All2 Eq '[xs])
    => SwaggerAesonOptions
    -> SOP I '[xs]
    -> DatatypeInfo '[xs]
    -> POP Maybe '[xs]
    -> [Pair]
sopSwaggerGenericToJSON' :: SwaggerAesonOptions
-> SOP I '[xs] -> DatatypeInfo '[xs] -> POP Maybe '[xs] -> [Pair]
sopSwaggerGenericToJSON' SwaggerAesonOptions
opts (SOP (Z NP I x
fields)) (ADT String
_ String
_ (Record String
_ NP FieldInfo x
fieldsInfo :* NP ConstructorInfo xs
Nil) POP StrictnessInfo '[xs]
_) (POP (NP Maybe x
defs :* NP (NP Maybe) xs
Nil)) =
    SwaggerAesonOptions
-> NP I x -> NP FieldInfo x -> NP Maybe x -> [Pair]
forall (xs :: [*]).
(All ToJSON xs, All Eq xs) =>
SwaggerAesonOptions
-> NP I xs -> NP FieldInfo xs -> NP Maybe xs -> [Pair]
sopSwaggerGenericToJSON'' SwaggerAesonOptions
opts NP I x
fields NP FieldInfo x
NP FieldInfo x
fieldsInfo NP Maybe x
NP Maybe x
defs
sopSwaggerGenericToJSON' SwaggerAesonOptions
_ SOP I '[xs]
_ DatatypeInfo '[xs]
_ POP Maybe '[xs]
_ = String -> [Pair]
forall a. HasCallStack => String -> a
error String
"sopSwaggerGenericToJSON: unsupported type"

sopSwaggerGenericToJSON''
    :: (All ToJSON xs, All Eq xs)
    => SwaggerAesonOptions
    -> NP I xs
    -> NP FieldInfo xs
    -> NP Maybe xs
    -> [Pair]
sopSwaggerGenericToJSON'' :: SwaggerAesonOptions
-> NP I xs -> NP FieldInfo xs -> NP Maybe xs -> [Pair]
sopSwaggerGenericToJSON'' (SwaggerAesonOptions String
prefix [Pair]
_ Maybe String
sub) = NP I xs -> NP FieldInfo xs -> NP Maybe xs -> [Pair]
forall (ys :: [*]).
(All ToJSON ys, All Eq ys) =>
NP I ys -> NP FieldInfo ys -> NP Maybe ys -> [Pair]
go
  where
    go :: (All ToJSON ys, All Eq ys) => NP I ys -> NP FieldInfo ys -> NP Maybe ys -> [Pair]
    go :: NP I ys -> NP FieldInfo ys -> NP Maybe ys -> [Pair]
go  NP I ys
Nil NP FieldInfo ys
Nil NP Maybe ys
Nil = []
    go (I x
x :* NP I xs
xs) (FieldInfo String
name :* NP FieldInfo xs
names) (Maybe x
def :* NP Maybe xs
defs)
        | String -> Maybe String
forall a. a -> Maybe a
Just String
name' Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe String
sub = case Value
json of
              Object Object
m -> Object -> [Pair]
forall v. KeyMap v -> [(Key, v)]
objectToList Object
m [Pair] -> [Pair] -> [Pair]
forall a. [a] -> [a] -> [a]
++ [Pair]
rest
              Value
Null     -> [Pair]
rest
              Value
_        -> String -> [Pair]
forall a. HasCallStack => String -> a
error (String -> [Pair]) -> String -> [Pair]
forall a b. (a -> b) -> a -> b
$ String
"sopSwaggerGenericToJSON: subjson is not an object: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Value -> String
forall a. Show a => a -> String
show Value
json
        -- If default value: omit it.
        | x -> Maybe x
forall a. a -> Maybe a
Just x
x Maybe x -> Maybe x -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe x
Maybe x
def =
            [Pair]
rest
        | Bool
otherwise =
            (String -> Key
stringToKey String
name', Value
json) Pair -> [Pair] -> [Pair]
forall a. a -> [a] -> [a]
: [Pair]
rest
      where
        json :: Value
json  = x -> Value
forall a. ToJSON a => a -> Value
toJSON x
x
        name' :: String
name' = String -> String
fieldNameModifier String
name
        rest :: [Pair]
rest  = NP I xs -> NP FieldInfo xs -> NP Maybe xs -> [Pair]
forall (ys :: [*]).
(All ToJSON ys, All Eq ys) =>
NP I ys -> NP FieldInfo ys -> NP Maybe ys -> [Pair]
go NP I xs
xs NP FieldInfo xs
NP FieldInfo xs
names NP Maybe xs
NP Maybe xs
defs

    fieldNameModifier :: String -> String
fieldNameModifier = String -> String
modifier (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
1
    modifier :: String -> String
modifier = String -> String
lowerFirstUppers (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> String
forall a. Int -> [a] -> [a]
drop (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
prefix)
    lowerFirstUppers :: String -> String
lowerFirstUppers String
s = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
y
      where (String
x, String
y) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isUpper String
s

-------------------------------------------------------------------------------
-- FromJSON
-------------------------------------------------------------------------------

sopSwaggerGenericParseJSON
    :: forall a xs.
        ( HasDatatypeInfo a
        , HasSwaggerAesonOptions a
        , All2 FromJSON (Code a)
        , All2 Eq (Code a)
        , Code a ~ '[xs]
        )
    => Value
    -> Parser a
sopSwaggerGenericParseJSON :: Value -> Parser a
sopSwaggerGenericParseJSON = String -> (Object -> Parser a) -> Value -> Parser a
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Swagger Record Object" ((Object -> Parser a) -> Value -> Parser a)
-> (Object -> Parser a) -> Value -> Parser a
forall a b. (a -> b) -> a -> b
$ \Object
obj ->
    let ps :: Parser (SOP I '[xs])
ps = SwaggerAesonOptions
-> Object
-> DatatypeInfo '[xs]
-> POP Maybe '[xs]
-> Parser (SOP I '[xs])
forall (xs :: [*]).
(All2 FromJSON '[xs], All2 Eq '[xs]) =>
SwaggerAesonOptions
-> Object
-> DatatypeInfo '[xs]
-> POP Maybe '[xs]
-> Parser (SOP I '[xs])
sopSwaggerGenericParseJSON' SwaggerAesonOptions
opts Object
obj (Proxy a -> DatatypeInfo (Code a)
forall a (proxy :: * -> *).
HasDatatypeInfo a =>
proxy a -> DatatypeInfo (Code a)
datatypeInfo Proxy a
proxy) (Proxy a -> POP Maybe (Code a)
forall a. HasSwaggerAesonOptions a => Proxy a -> POP Maybe (Code a)
aesonDefaults Proxy a
proxy)
    in do
        (Pair -> Parser ()) -> [Pair] -> Parser ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Object -> Pair -> Parser ()
parseAdditionalField Object
obj) (SwaggerAesonOptions
opts SwaggerAesonOptions
-> Getting [Pair] SwaggerAesonOptions [Pair] -> [Pair]
forall s a. s -> Getting a s a -> a
^. Getting [Pair] SwaggerAesonOptions [Pair]
Lens' SwaggerAesonOptions [Pair]
saoAdditionalPairs)
        SOP I '[xs] -> a
forall a. Generic a => Rep a -> a
to (SOP I '[xs] -> a) -> Parser (SOP I '[xs]) -> Parser a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (SOP I '[xs])
ps
  where
    proxy :: Proxy a
proxy = Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a
    opts :: SwaggerAesonOptions
opts  = Proxy a -> SwaggerAesonOptions
forall a.
HasSwaggerAesonOptions a =>
Proxy a -> SwaggerAesonOptions
swaggerAesonOptions Proxy a
proxy

    parseAdditionalField :: Object -> Pair -> Parser ()
    parseAdditionalField :: Object -> Pair -> Parser ()
parseAdditionalField Object
obj (Key
k, Value
v) = do
        Value
v' <- Object
obj Object -> Key -> Parser Value
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
k
        Bool -> Parser () -> Parser ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Value
v Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value
v') (Parser () -> Parser ()) -> Parser () -> Parser ()
forall a b. (a -> b) -> a -> b
$ String -> Parser ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser ()) -> String -> Parser ()
forall a b. (a -> b) -> a -> b
$
            String
"Additonal field don't match for key " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Key -> String
keyToString Key
k
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Value -> String
forall a. Show a => a -> String
show Value
v
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" /= " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Value -> String
forall a. Show a => a -> String
show Value
v'

sopSwaggerGenericParseJSON'
    :: (All2 FromJSON '[xs], All2 Eq '[xs])
    => SwaggerAesonOptions
    -> Object
    -> DatatypeInfo '[xs]
    -> POP Maybe '[xs]
    -> Parser (SOP I '[xs])
sopSwaggerGenericParseJSON' :: SwaggerAesonOptions
-> Object
-> DatatypeInfo '[xs]
-> POP Maybe '[xs]
-> Parser (SOP I '[xs])
sopSwaggerGenericParseJSON' SwaggerAesonOptions
opts Object
obj (ADT String
_ String
_ (Record String
_ NP FieldInfo x
fieldsInfo :* NP ConstructorInfo xs
Nil) POP StrictnessInfo '[xs]
_) (POP (NP Maybe x
defs :* NP (NP Maybe) xs
Nil)) =
    NS (NP I) '[x] -> SOP I '[x]
forall k (f :: k -> *) (xss :: [[k]]). NS (NP f) xss -> SOP f xss
SOP (NS (NP I) '[x] -> SOP I '[x])
-> (NP I x -> NS (NP I) '[x]) -> NP I x -> SOP I '[x]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NP I x -> NS (NP I) '[x]
forall k (a :: k -> *) (x :: k) (xs :: [k]). a x -> NS a (x : xs)
Z (NP I x -> SOP I '[x]) -> Parser (NP I x) -> Parser (SOP I '[x])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SwaggerAesonOptions
-> Object -> NP FieldInfo x -> NP Maybe x -> Parser (NP I x)
forall (xs :: [*]).
(All FromJSON xs, All Eq xs) =>
SwaggerAesonOptions
-> Object -> NP FieldInfo xs -> NP Maybe xs -> Parser (NP I xs)
sopSwaggerGenericParseJSON'' SwaggerAesonOptions
opts Object
obj NP FieldInfo x
fieldsInfo NP Maybe x
NP Maybe x
defs
sopSwaggerGenericParseJSON' SwaggerAesonOptions
_ Object
_ DatatypeInfo '[xs]
_ POP Maybe '[xs]
_ = String -> Parser (SOP I '[xs])
forall a. HasCallStack => String -> a
error String
"sopSwaggerGenericParseJSON: unsupported type"

sopSwaggerGenericParseJSON''
    :: (All FromJSON xs, All Eq xs)
    => SwaggerAesonOptions
    -> Object
    -> NP FieldInfo xs
    -> NP Maybe xs
    -> Parser (NP I xs)
sopSwaggerGenericParseJSON'' :: SwaggerAesonOptions
-> Object -> NP FieldInfo xs -> NP Maybe xs -> Parser (NP I xs)
sopSwaggerGenericParseJSON'' (SwaggerAesonOptions String
prefix [Pair]
_ Maybe String
sub) Object
obj = NP FieldInfo xs -> NP Maybe xs -> Parser (NP I xs)
forall (ys :: [*]).
(All FromJSON ys, All Eq ys) =>
NP FieldInfo ys -> NP Maybe ys -> Parser (NP I ys)
go
  where
    go :: (All FromJSON ys, All Eq ys) => NP FieldInfo ys -> NP Maybe ys -> Parser (NP I ys)
    go :: NP FieldInfo ys -> NP Maybe ys -> Parser (NP I ys)
go  NP FieldInfo ys
Nil NP Maybe ys
Nil = NP I '[] -> Parser (NP I '[])
forall (f :: * -> *) a. Applicative f => a -> f a
pure NP I '[]
forall k (a :: k -> *). NP a '[]
Nil
    go (FieldInfo String
name :* NP FieldInfo xs
names) (Maybe x
def :* NP Maybe xs
defs)
        | String -> Maybe String
forall a. a -> Maybe a
Just String
name' Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe String
sub =
            -- Note: we might strip fields of outer structure.
            x -> NP I xs -> NP I (x : xs)
forall x (xs :: [*]). x -> NP I xs -> NP I (x : xs)
cons (x -> NP I xs -> NP I (x : xs))
-> Parser x -> Parser (NP I xs -> NP I (x : xs))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Parser x -> Parser x
withDef (Parser x -> Parser x) -> Parser x -> Parser x
forall a b. (a -> b) -> a -> b
$ Value -> Parser x
forall a. FromJSON a => Value -> Parser a
parseJSON (Value -> Parser x) -> Value -> Parser x
forall a b. (a -> b) -> a -> b
$ Object -> Value
Object Object
obj) Parser (NP I xs -> NP I (x : xs))
-> Parser (NP I xs) -> Parser (NP I (x : xs))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (NP I xs)
rest
        | Bool
otherwise = case Maybe x
def of
            Just x
def' -> x -> NP I xs -> NP I (x : xs)
forall x (xs :: [*]). x -> NP I xs -> NP I (x : xs)
cons (x -> NP I xs -> NP I (x : xs))
-> Parser x -> Parser (NP I xs -> NP I (x : xs))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
obj Object -> Key -> Parser (Maybe x)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? String -> Key
stringToKey String
name' Parser (Maybe x) -> x -> Parser x
forall a. Parser (Maybe a) -> a -> Parser a
.!= x
def' Parser (NP I xs -> NP I (x : xs))
-> Parser (NP I xs) -> Parser (NP I (x : xs))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (NP I xs)
rest
            Maybe x
Nothing  ->  x -> NP I xs -> NP I (x : xs)
forall x (xs :: [*]). x -> NP I xs -> NP I (x : xs)
cons (x -> NP I xs -> NP I (x : xs))
-> Parser x -> Parser (NP I xs -> NP I (x : xs))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
obj Object -> Key -> Parser x
forall a. FromJSON a => Object -> Key -> Parser a
.: String -> Key
stringToKey String
name' Parser (NP I xs -> NP I (x : xs))
-> Parser (NP I xs) -> Parser (NP I (x : xs))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (NP I xs)
rest
      where
        cons :: x -> NP I xs -> NP I (x : xs)
cons x
h NP I xs
t = x -> I x
forall a. a -> I a
I x
h I x -> NP I xs -> NP I (x : xs)
forall k (a :: k -> *) (x :: k) (xs :: [k]).
a x -> NP a xs -> NP a (x : xs)
:* NP I xs
t
        name' :: String
name' = String -> String
fieldNameModifier String
name
        rest :: Parser (NP I xs)
rest  = NP FieldInfo xs -> NP Maybe xs -> Parser (NP I xs)
forall (ys :: [*]).
(All FromJSON ys, All Eq ys) =>
NP FieldInfo ys -> NP Maybe ys -> Parser (NP I ys)
go NP FieldInfo xs
names NP Maybe xs
NP Maybe xs
defs

        withDef :: Parser x -> Parser x
withDef = case Maybe x
def of
            Just x
def' -> (Parser x -> Parser x -> Parser x
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> x -> Parser x
forall (f :: * -> *) a. Applicative f => a -> f a
pure x
def')
            Maybe x
Nothing   -> Parser x -> Parser x
forall a. a -> a
id

    fieldNameModifier :: String -> String
fieldNameModifier = String -> String
modifier (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
1
    modifier :: String -> String
modifier = String -> String
lowerFirstUppers (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> String
forall a. Int -> [a] -> [a]
drop (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
prefix)
    lowerFirstUppers :: String -> String
lowerFirstUppers String
s = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
y
      where (String
x, String
y) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isUpper String
s

-------------------------------------------------------------------------------
-- ToEncoding
-------------------------------------------------------------------------------

sopSwaggerGenericToEncoding
    :: forall a xs.
        ( HasDatatypeInfo a
        , HasSwaggerAesonOptions a
        , All2 ToJSON (Code a)
        , All2 Eq (Code a)
        , Code a ~ '[xs]
        )
    => a
    -> Encoding
sopSwaggerGenericToEncoding :: a -> Encoding
sopSwaggerGenericToEncoding a
x =
    let ps :: Series
ps = SwaggerAesonOptions
-> SOP I '[xs] -> DatatypeInfo '[xs] -> POP Maybe '[xs] -> Series
forall (xs :: [*]).
(All2 ToJSON '[xs], All2 Eq '[xs]) =>
SwaggerAesonOptions
-> SOP I '[xs] -> DatatypeInfo '[xs] -> POP Maybe '[xs] -> Series
sopSwaggerGenericToEncoding' SwaggerAesonOptions
opts (a -> Rep a
forall a. Generic a => a -> Rep a
from a
x) (Proxy a -> DatatypeInfo (Code a)
forall a (proxy :: * -> *).
HasDatatypeInfo a =>
proxy a -> DatatypeInfo (Code a)
datatypeInfo Proxy a
proxy) (Proxy a -> POP Maybe (Code a)
forall a. HasSwaggerAesonOptions a => Proxy a -> POP Maybe (Code a)
aesonDefaults Proxy a
proxy)
    in Series -> Encoding
pairs ([Pair] -> Series
pairsToSeries (SwaggerAesonOptions
opts SwaggerAesonOptions
-> Getting [Pair] SwaggerAesonOptions [Pair] -> [Pair]
forall s a. s -> Getting a s a -> a
^. Getting [Pair] SwaggerAesonOptions [Pair]
Lens' SwaggerAesonOptions [Pair]
saoAdditionalPairs) Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> Series
ps)
  where
    proxy :: Proxy a
proxy = Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a
    opts :: SwaggerAesonOptions
opts  = Proxy a -> SwaggerAesonOptions
forall a.
HasSwaggerAesonOptions a =>
Proxy a -> SwaggerAesonOptions
swaggerAesonOptions Proxy a
proxy

pairsToSeries :: [Pair] -> Series
pairsToSeries :: [Pair] -> Series
pairsToSeries = (Pair -> Series) -> [Pair] -> Series
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\(Key
k, Value
v) -> (Key
k Key -> Value -> Series
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Value
v))

sopSwaggerGenericToEncoding'
    :: (All2 ToJSON '[xs], All2 Eq '[xs])
    => SwaggerAesonOptions
    -> SOP I '[xs]
    -> DatatypeInfo '[xs]
    -> POP Maybe '[xs]
    -> Series
sopSwaggerGenericToEncoding' :: SwaggerAesonOptions
-> SOP I '[xs] -> DatatypeInfo '[xs] -> POP Maybe '[xs] -> Series
sopSwaggerGenericToEncoding' SwaggerAesonOptions
opts (SOP (Z NP I x
fields)) (ADT String
_ String
_ (Record String
_ NP FieldInfo x
fieldsInfo :* NP ConstructorInfo xs
Nil) POP StrictnessInfo '[xs]
_) (POP (NP Maybe x
defs :* NP (NP Maybe) xs
Nil)) =
    SwaggerAesonOptions
-> NP I x -> NP FieldInfo x -> NP Maybe x -> Series
forall (xs :: [*]).
(All ToJSON xs, All Eq xs) =>
SwaggerAesonOptions
-> NP I xs -> NP FieldInfo xs -> NP Maybe xs -> Series
sopSwaggerGenericToEncoding'' SwaggerAesonOptions
opts NP I x
fields NP FieldInfo x
NP FieldInfo x
fieldsInfo NP Maybe x
NP Maybe x
defs
sopSwaggerGenericToEncoding' SwaggerAesonOptions
_ SOP I '[xs]
_ DatatypeInfo '[xs]
_ POP Maybe '[xs]
_ = String -> Series
forall a. HasCallStack => String -> a
error String
"sopSwaggerGenericToEncoding: unsupported type"

sopSwaggerGenericToEncoding''
    :: (All ToJSON xs, All Eq xs)
    => SwaggerAesonOptions
    -> NP I xs
    -> NP FieldInfo xs
    -> NP Maybe xs
    -> Series
sopSwaggerGenericToEncoding'' :: SwaggerAesonOptions
-> NP I xs -> NP FieldInfo xs -> NP Maybe xs -> Series
sopSwaggerGenericToEncoding'' (SwaggerAesonOptions String
prefix [Pair]
_ Maybe String
sub) = NP I xs -> NP FieldInfo xs -> NP Maybe xs -> Series
forall (ys :: [*]).
(All ToJSON ys, All Eq ys) =>
NP I ys -> NP FieldInfo ys -> NP Maybe ys -> Series
go
  where
    go :: (All ToJSON ys, All Eq ys) => NP I ys -> NP FieldInfo ys -> NP Maybe ys -> Series
    go :: NP I ys -> NP FieldInfo ys -> NP Maybe ys -> Series
go  NP I ys
Nil NP FieldInfo ys
Nil NP Maybe ys
Nil = Series
forall a. Monoid a => a
mempty
    go (I x
x :* NP I xs
xs) (FieldInfo String
name :* NP FieldInfo xs
names) (Maybe x
def :* NP Maybe xs
defs)
        | String -> Maybe String
forall a. a -> Maybe a
Just String
name' Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe String
sub = case x -> Value
forall a. ToJSON a => a -> Value
toJSON x
x of
              Object Object
m -> [Pair] -> Series
pairsToSeries (Object -> [Pair]
forall v. KeyMap v -> [(Key, v)]
objectToList Object
m) Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> Series
rest
              Value
Null     -> Series
rest
              Value
_        -> String -> Series
forall a. HasCallStack => String -> a
error (String -> Series) -> String -> Series
forall a b. (a -> b) -> a -> b
$ String
"sopSwaggerGenericToJSON: subjson is not an object: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Value -> String
forall a. Show a => a -> String
show (x -> Value
forall a. ToJSON a => a -> Value
toJSON x
x)
        -- If default value: omit it.
        | x -> Maybe x
forall a. a -> Maybe a
Just x
x Maybe x -> Maybe x -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe x
Maybe x
def =
            Series
rest
        | Bool
otherwise =
            (String -> Key
stringToKey String
name' Key -> x -> Series
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= x
x) Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> Series
rest
      where
        name' :: String
name' = String -> String
fieldNameModifier String
name
        rest :: Series
rest  = NP I xs -> NP FieldInfo xs -> NP Maybe xs -> Series
forall (ys :: [*]).
(All ToJSON ys, All Eq ys) =>
NP I ys -> NP FieldInfo ys -> NP Maybe ys -> Series
go NP I xs
xs NP FieldInfo xs
NP FieldInfo xs
names NP Maybe xs
NP Maybe xs
defs

    fieldNameModifier :: String -> String
fieldNameModifier = String -> String
modifier (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
1
    modifier :: String -> String
modifier = String -> String
lowerFirstUppers (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> String
forall a. Int -> [a] -> [a]
drop (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
prefix)
    lowerFirstUppers :: String -> String
lowerFirstUppers String
s = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
y
      where (String
x, String
y) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isUpper String
s