{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeOperators #-}
module Data.Swagger.Internal.Utils where
import Prelude ()
import Prelude.Compat
import Control.Lens ((&), (%~))
import Control.Lens.TH
import Data.Aeson
import Data.Aeson.Types
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 LensRules -> (LensRules -> LensRules) -> LensRules
forall a b. a -> (a -> b) -> b
& (FieldNamer -> Identity FieldNamer)
-> LensRules -> Identity LensRules
Lens' LensRules FieldNamer
lensField ((FieldNamer -> Identity FieldNamer)
-> LensRules -> Identity LensRules)
-> (FieldNamer -> FieldNamer) -> LensRules -> LensRules
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ FieldNamer -> FieldNamer
forall t t t.
(t -> t -> t -> [DefName]) -> t -> t -> t -> [DefName]
swaggerFieldNamer
where
swaggerFieldNamer :: (t -> t -> t -> [DefName]) -> t -> t -> t -> [DefName]
swaggerFieldNamer namer :: t -> t -> t -> [DefName]
namer dname :: t
dname fnames :: t
fnames fname :: t
fname =
(DefName -> DefName) -> [DefName] -> [DefName]
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 cname :: Name
cname mname :: Name
mname) = Name -> Name -> DefName
MethodName Name
cname (Name -> Name
fixName Name
mname)
fixDefName (TopName name :: Name
name) = Name -> DefName
TopName (Name -> Name
fixName Name
name)
fixName :: Name -> Name
fixName = String -> Name
mkName (String -> Name) -> (Name -> String) -> Name -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall p. (Eq p, IsString p) => p -> p
fixName' (String -> String) -> (Name -> String) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
forall a. Show a => a -> String
show
fixName' :: p -> p
fixName' "in" = "in_"
fixName' "type" = "type_"
fixName' "default" = "default_"
fixName' "minimum" = "minimum_"
fixName' "maximum" = "maximum_"
fixName' "enum" = "enum_"
fixName' "head" = "head_"
fixName' n :: p
n = p
n
gunfoldEnum :: String -> [a] -> (forall b r. Data b => c (b -> r) -> c r) -> (forall r. r -> c r) -> Constr -> c a
gunfoldEnum :: String
-> [a]
-> (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r)
-> Constr
-> c a
gunfoldEnum tname :: String
tname xs :: [a]
xs _k :: forall b r. Data b => c (b -> r) -> c r
_k z :: forall r. r -> c r
z c :: Constr
c = case ConIndex -> [(ConIndex, a)] -> Maybe a
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (Constr -> ConIndex
constrIndex Constr
c) ([ConIndex] -> [a] -> [(ConIndex, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [1..] [a]
xs) of
Just x :: a
x -> a -> c a
forall r. r -> c r
z a
x
Nothing -> String -> c a
forall a. HasCallStack => String -> a
error (String -> c a) -> String -> c a
forall a b. (a -> b) -> a -> b
$ "Data.Data.gunfold: Constructor " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Constr -> String
forall a. Show a => a -> String
show Constr
c String -> String -> String
forall a. [a] -> [a] -> [a]
++ " is not of type " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
tname String -> String -> String
forall a. [a] -> [a] -> [a]
++ "."
jsonPrefix :: String -> Options
jsonPrefix :: String -> Options
jsonPrefix prefix :: String
prefix = Options
defaultOptions
{ fieldLabelModifier :: String -> String
fieldLabelModifier = String -> String
modifier (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConIndex -> String -> String
forall a. ConIndex -> [a] -> [a]
drop 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 (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConIndex -> String -> String
forall a. ConIndex -> [a] -> [a]
drop (String -> ConIndex
forall (t :: * -> *) a. Foldable t => t a -> ConIndex
length String
prefix)
lowerFirstUppers :: String -> String
lowerFirstUppers s :: 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 (x :: String
x, y :: String
y) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isUpper String
s
parseOneOf :: ToJSON a => [a] -> Value -> Parser a
parseOneOf :: [a] -> Value -> Parser a
parseOneOf xs :: [a]
xs js :: Value
js =
case Value -> [(Value, a)] -> Maybe a
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Value
js [(Value, a)]
ys of
Nothing -> String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser a) -> String -> Parser a
forall a b. (a -> b) -> a -> b
$ "invalid json: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Value -> String
forall a. Show a => a -> String
show Value
js String -> String -> String
forall a. [a] -> [a] -> [a]
++ " (expected one of " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Value] -> String
forall a. Show a => a -> String
show (((Value, a) -> Value) -> [(Value, a)] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map (Value, a) -> Value
forall a b. (a, b) -> a
fst [(Value, a)]
ys) String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
Just x :: a
x -> a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
where
ys :: [(Value, a)]
ys = [Value] -> [a] -> [(Value, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((a -> Value) -> [a] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map a -> Value
forall a. ToJSON a => a -> Value
toJSON [a]
xs) [a]
xs
(<+>) :: Value -> Value -> Value
Object x :: Object
x <+> :: Value -> Value -> Value
<+> Object y :: Object
y = Object -> Value
Object (Object
x Object -> Object -> Object
forall a. Semigroup a => a -> a -> a
<> Object
y)
_ <+> _ = String -> Value
forall a. HasCallStack => String -> a
error "<+>: merging non-objects"
genericMempty :: (Generic a, GMonoid (Rep a)) => a
genericMempty :: a
genericMempty = Rep a Any -> a
forall a x. Generic a => Rep a x -> a
to Rep a Any
forall (f :: * -> *) p. GMonoid f => f p
gmempty
genericMappend :: (Generic a, GMonoid (Rep a)) => a -> a -> a
genericMappend :: a -> a -> a
genericMappend x :: a
x y :: a
y = Rep a Any -> a
forall a x. Generic a => Rep a x -> a
to (Rep a Any -> Rep a Any -> Rep a Any
forall (f :: * -> *) p. GMonoid f => f p -> f p -> f p
gmappend (a -> Rep a Any
forall a x. Generic a => a -> Rep a x
from a
x) (a -> Rep a Any
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 :: U1 p
gmempty = U1 p
forall k (p :: k). U1 p
U1
gmappend :: U1 p -> U1 p -> U1 p
gmappend _ _ = U1 p
forall k (p :: k). U1 p
U1
instance (GMonoid f, GMonoid g) => GMonoid (f :*: g) where
gmempty :: (:*:) f g p
gmempty = f p
forall (f :: * -> *) p. GMonoid f => f p
gmempty f p -> g p -> (:*:) f g p
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: g p
forall (f :: * -> *) p. GMonoid f => f p
gmempty
gmappend :: (:*:) f g p -> (:*:) f g p -> (:*:) f g p
gmappend (a :: f p
a :*: x :: g p
x) (b :: f p
b :*: y :: g p
y) = f p -> f p -> f p
forall (f :: * -> *) p. GMonoid f => f p -> f p -> f p
gmappend f p
a f p
b f p -> g p -> (:*:) f g p
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: g p -> g p -> 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 :: K1 i a p
gmempty = a -> K1 i a p
forall k i c (p :: k). c -> K1 i c p
K1 a
forall m. SwaggerMonoid m => m
swaggerMempty
gmappend :: K1 i a p -> K1 i a p -> K1 i a p
gmappend (K1 x :: a
x) (K1 y :: a
y) = a -> K1 i a p
forall k i c (p :: k). c -> K1 i c p
K1 (a -> a -> a
forall m. SwaggerMonoid m => m -> m -> m
swaggerMappend a
x a
y)
instance GMonoid f => GMonoid (M1 i t f) where
gmempty :: M1 i t f p
gmempty = f p -> M1 i t f p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 f p
forall (f :: * -> *) p. GMonoid f => f p
gmempty
gmappend :: M1 i t f p -> M1 i t f p -> M1 i t f p
gmappend (M1 x :: f p
x) (M1 y :: f p
y) = f p -> M1 i t f p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f p -> f p -> f p
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 = m
forall a. Monoid a => a
mempty
default swaggerMappend :: Monoid m => m -> m -> m
swaggerMappend = m -> m -> m
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 = HashMap k v
forall a. Monoid a => a
mempty
swaggerMappend :: HashMap k v -> HashMap k v -> HashMap k v
swaggerMappend = (v -> v -> v) -> HashMap k v -> HashMap k v -> HashMap k v
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> HashMap k v -> HashMap k v -> HashMap k v
HashMap.unionWith (\_old :: v
_old new :: v
new -> v
new)
instance (Eq k, Hashable k) => SwaggerMonoid (InsOrdHashMap k v) where
swaggerMempty :: InsOrdHashMap k v
swaggerMempty = InsOrdHashMap k v
forall a. Monoid a => a
mempty
swaggerMappend :: InsOrdHashMap k v -> InsOrdHashMap k v -> InsOrdHashMap k v
swaggerMappend = (v -> v -> v)
-> InsOrdHashMap k v -> InsOrdHashMap k v -> InsOrdHashMap k v
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v)
-> InsOrdHashMap k v -> InsOrdHashMap k v -> InsOrdHashMap k v
InsOrdHashMap.unionWith (\_old :: v
_old new :: v
new -> v
new)
instance SwaggerMonoid Text where
swaggerMempty :: Text
swaggerMempty = Text
forall a. Monoid a => a
mempty
swaggerMappend :: Text -> Text -> Text
swaggerMappend x :: Text
x "" = Text
x
swaggerMappend _ y :: Text
y = Text
y
instance SwaggerMonoid (Maybe a) where
swaggerMempty :: Maybe a
swaggerMempty = Maybe a
forall a. Maybe a
Nothing
swaggerMappend :: Maybe a -> Maybe a -> Maybe a
swaggerMappend x :: Maybe a
x Nothing = Maybe a
x
swaggerMappend _ y :: Maybe a
y = Maybe a
y