{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeOperators #-}
module Data.OpenApi.Internal.Utils where

import Prelude ()
import Prelude.Compat

import Control.Lens ((&), (%~))
import Control.Lens.TH
import Data.Aeson
import Data.Aeson.Types
import qualified Data.Aeson.Encode.Pretty as P
import qualified Data.ByteString.Lazy as BSL
import Data.Char
import Data.Data
import Data.Hashable (Hashable)
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.HashMap.Strict.InsOrd (InsOrdHashMap)
import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
import Data.Map (Map)
import Data.Set (Set)
import Data.Text (Text)
import GHC.Generics
import Language.Haskell.TH (mkName)

swaggerFieldRules :: LensRules
swaggerFieldRules :: LensRules
swaggerFieldRules = LensRules
defaultFieldRules forall a b. a -> (a -> b) -> b
& Lens' LensRules FieldNamer
lensField forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall {t} {t} {t}.
(t -> t -> t -> [DefName]) -> t -> t -> t -> [DefName]
swaggerFieldNamer
  where
    swaggerFieldNamer :: (t -> t -> t -> [DefName]) -> t -> t -> t -> [DefName]
swaggerFieldNamer t -> t -> t -> [DefName]
namer t
dname t
fnames t
fname =
      forall a b. (a -> b) -> [a] -> [b]
map DefName -> DefName
fixDefName (t -> t -> t -> [DefName]
namer t
dname t
fnames t
fname)

    fixDefName :: DefName -> DefName
fixDefName (MethodName Name
cname Name
mname) = Name -> Name -> DefName
MethodName Name
cname (Name -> Name
fixName Name
mname)
    fixDefName (TopName Name
name) = Name -> DefName
TopName (Name -> Name
fixName Name
name)

    fixName :: Name -> Name
fixName = String -> Name
mkName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. (Eq a, IsString a) => a -> a
fixName' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show

    fixName' :: a -> a
fixName' a
"in"       = a
"in_"       -- keyword
    fixName' a
"type"     = a
"type_"     -- keyword
    fixName' a
"default"  = a
"default_"  -- keyword
    fixName' a
"minimum"  = a
"minimum_"  -- Prelude conflict
    fixName' a
"maximum"  = a
"maximum_"  -- Prelude conflict
    fixName' a
"enum"     = a
"enum_"     -- Control.Lens conflict
    fixName' a
"head"     = a
"head_"     -- Prelude conflict
    fixName' a
"not"      = a
"not_"      -- Prelude conflict
    fixName' a
n = a
n

gunfoldEnum :: String -> [a] -> (forall b r. Data b => c (b -> r) -> c r) -> (forall r. r -> c r) -> Constr -> c a
gunfoldEnum :: forall a (c :: * -> *).
String
-> [a]
-> (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r)
-> Constr
-> c a
gunfoldEnum String
tname [a]
xs forall b r. Data b => c (b -> r) -> c r
_k forall r. r -> c r
z Constr
c = case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (Constr -> ConIndex
constrIndex Constr
c) (forall a b. [a] -> [b] -> [(a, b)]
zip [ConIndex
1..] [a]
xs) of
  Just a
x -> forall r. r -> c r
z a
x
  Maybe a
Nothing -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Data.Data.gunfold: Constructor " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Constr
c forall a. [a] -> [a] -> [a]
++ String
" is not of type " forall a. [a] -> [a] -> [a]
++ String
tname forall a. [a] -> [a] -> [a]
++ String
"."

jsonPrefix :: String -> Options
jsonPrefix :: String -> Options
jsonPrefix String
prefix = Options
defaultOptions
  { fieldLabelModifier :: String -> String
fieldLabelModifier      = String -> String
modifier forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ConIndex -> [a] -> [a]
drop ConIndex
1
  , constructorTagModifier :: String -> String
constructorTagModifier  = String -> String
modifier
  , sumEncoding :: SumEncoding
sumEncoding             = SumEncoding
ObjectWithSingleField
  , omitNothingFields :: Bool
omitNothingFields       = Bool
True
  }
  where
    modifier :: String -> String
modifier = String -> String
lowerFirstUppers forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ConIndex -> [a] -> [a]
drop (forall (t :: * -> *) a. Foldable t => t a -> ConIndex
length String
prefix)

    lowerFirstUppers :: String -> String
lowerFirstUppers String
s = forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
x forall a. [a] -> [a] -> [a]
++ String
y
      where (String
x, String
y) = forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isUpper String
s

parseOneOf :: ToJSON a => [a] -> Value -> Parser a
parseOneOf :: forall a. ToJSON a => [a] -> Value -> Parser a
parseOneOf [a]
xs Value
js =
  case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Value
js [(Value, a)]
ys of
    Maybe a
Nothing -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"invalid json: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Value
js forall a. [a] -> [a] -> [a]
++ String
" (expected one of " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Value, a)]
ys) forall a. [a] -> [a] -> [a]
++ String
")"
    Just a
x  -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
  where
    ys :: [(Value, a)]
ys = forall a b. [a] -> [b] -> [(a, b)]
zip (forall a b. (a -> b) -> [a] -> [b]
map forall a. ToJSON a => a -> Value
toJSON [a]
xs) [a]
xs

(<+>) :: Value -> Value -> Value
Object Object
x <+> :: Value -> Value -> Value
<+> Object Object
y = Object -> Value
Object (Object
x forall a. Semigroup a => a -> a -> a
<> Object
y)
Value
_ <+> Value
_ = forall a. HasCallStack => String -> a
error String
"<+>: merging non-objects"

genericMempty :: (Generic a, GMonoid (Rep a)) => a
genericMempty :: forall a. (Generic a, GMonoid (Rep a)) => a
genericMempty = forall a x. Generic a => Rep a x -> a
to forall (f :: * -> *) p. GMonoid f => f p
gmempty

genericMappend :: (Generic a, GMonoid (Rep a)) => a -> a -> a
genericMappend :: forall a. (Generic a, GMonoid (Rep a)) => a -> a -> a
genericMappend a
x a
y = forall a x. Generic a => Rep a x -> a
to (forall (f :: * -> *) p. GMonoid f => f p -> f p -> f p
gmappend (forall a x. Generic a => a -> Rep a x
from a
x) (forall a x. Generic a => a -> Rep a x
from a
y))

class GMonoid f where
  gmempty :: f p
  gmappend :: f p -> f p -> f p

instance GMonoid U1 where
  gmempty :: forall p. U1 p
gmempty = forall k (p :: k). U1 p
U1
  gmappend :: forall p. U1 p -> U1 p -> U1 p
gmappend U1 p
_ U1 p
_ = forall k (p :: k). U1 p
U1

instance (GMonoid f, GMonoid g) => GMonoid (f :*: g) where
  gmempty :: forall p. (:*:) f g p
gmempty = forall (f :: * -> *) p. GMonoid f => f p
gmempty forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: forall (f :: * -> *) p. GMonoid f => f p
gmempty
  gmappend :: forall p. (:*:) f g p -> (:*:) f g p -> (:*:) f g p
gmappend (f p
a :*: g p
x) (f p
b :*: g p
y) = forall (f :: * -> *) p. GMonoid f => f p -> f p -> f p
gmappend f p
a f p
b forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: forall (f :: * -> *) p. GMonoid f => f p -> f p -> f p
gmappend g p
x g p
y

instance SwaggerMonoid a => GMonoid (K1 i a) where
  gmempty :: forall p. K1 i a p
gmempty = forall k i c (p :: k). c -> K1 i c p
K1 forall m. SwaggerMonoid m => m
swaggerMempty
  gmappend :: forall p. K1 i a p -> K1 i a p -> K1 i a p
gmappend (K1 a
x) (K1 a
y) = forall k i c (p :: k). c -> K1 i c p
K1 (forall m. SwaggerMonoid m => m -> m -> m
swaggerMappend a
x a
y)

instance GMonoid f => GMonoid (M1 i t f) where
  gmempty :: forall p. M1 i t f p
gmempty = forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall (f :: * -> *) p. GMonoid f => f p
gmempty
  gmappend :: forall p. M1 i t f p -> M1 i t f p -> M1 i t f p
gmappend (M1 f p
x) (M1 f p
y) = forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (forall (f :: * -> *) p. GMonoid f => f p -> f p -> f p
gmappend f p
x f p
y)

class SwaggerMonoid m where
  swaggerMempty :: m
  swaggerMappend :: m -> m -> m
  default swaggerMempty :: Monoid m => m
  swaggerMempty = forall a. Monoid a => a
mempty
  default swaggerMappend :: Monoid m => m -> m -> m
  swaggerMappend = forall a. Monoid a => a -> a -> a
mappend

instance SwaggerMonoid [a]
instance Ord a => SwaggerMonoid (Set a)
instance Ord k => SwaggerMonoid (Map k v)

instance (Eq k, Hashable k) => SwaggerMonoid (HashMap k v) where
  swaggerMempty :: HashMap k v
swaggerMempty = forall a. Monoid a => a
mempty
  swaggerMappend :: HashMap k v -> HashMap k v -> HashMap k v
swaggerMappend = forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> HashMap k v -> HashMap k v -> HashMap k v
HashMap.unionWith (\v
_old v
new -> v
new)

instance (Eq k, Hashable k) => SwaggerMonoid (InsOrdHashMap k v) where
  swaggerMempty :: InsOrdHashMap k v
swaggerMempty = forall a. Monoid a => a
mempty
  swaggerMappend :: InsOrdHashMap k v -> InsOrdHashMap k v -> InsOrdHashMap k v
swaggerMappend = forall k v.
(Eq k, Hashable k) =>
(v -> v -> v)
-> InsOrdHashMap k v -> InsOrdHashMap k v -> InsOrdHashMap k v
InsOrdHashMap.unionWith (\v
_old v
new -> v
new)

instance SwaggerMonoid Text where
  swaggerMempty :: Text
swaggerMempty = forall a. Monoid a => a
mempty
  swaggerMappend :: Text -> Text -> Text
swaggerMappend Text
x Text
"" = Text
x
  swaggerMappend Text
_ Text
y = Text
y

instance SwaggerMonoid (Maybe a) where
  swaggerMempty :: Maybe a
swaggerMempty = forall a. Maybe a
Nothing
  swaggerMappend :: Maybe a -> Maybe a -> Maybe a
swaggerMappend Maybe a
x Maybe a
Nothing = Maybe a
x
  swaggerMappend Maybe a
_ Maybe a
y = Maybe a
y

encodePretty :: ToJSON a => a -> BSL.ByteString
encodePretty :: forall a. ToJSON a => a -> ByteString
encodePretty = forall a. ToJSON a => Config -> a -> ByteString
P.encodePretty' forall a b. (a -> b) -> a -> b
$ Config
P.defConfig { confCompare :: Text -> Text -> Ordering
P.confCompare = forall a. Ord a => a -> a -> Ordering
P.compare }