{-# 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_"       -- keyword
    fixName' "type"     = "type_"     -- keyword
    fixName' "default"  = "default_"  -- keyword
    fixName' "minimum"  = "minimum_"  -- Prelude conflict
    fixName' "maximum"  = "maximum_"  -- Prelude conflict
    fixName' "enum"     = "enum_"     -- Control.Lens conflict
    fixName' "head"     = "head_"     -- Prelude conflict
    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