{-# 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 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 t -> t -> t -> [DefName]
namer t
dname t
fnames 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 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 (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' p
"in"       = p
"in_"       -- keyword
    fixName' p
"type"     = p
"type_"     -- keyword
    fixName' p
"default"  = p
"default_"  -- keyword
    fixName' p
"minimum"  = p
"minimum_"  -- Prelude conflict
    fixName' p
"maximum"  = p
"maximum_"  -- Prelude conflict
    fixName' p
"enum"     = p
"enum_"     -- Control.Lens conflict
    fixName' p
"head"     = p
"head_"     -- Prelude conflict
    fixName' p
"not"      = p
"not_"      -- Prelude conflict
    fixName' 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 String
tname [a]
xs forall b r. Data b => c (b -> r) -> c r
_k forall r. r -> c r
z 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 [ConIndex
1..] [a]
xs) of
  Just a
x -> a -> c a
forall r. r -> c r
z a
x
  Maybe a
Nothing -> String -> c a
forall a. HasCallStack => String -> a
error (String -> c a) -> String -> c a
forall a b. (a -> b) -> a -> b
$ String
"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]
++ String
" is not of type " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
tname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"."

jsonPrefix :: String -> Options
jsonPrefix :: String -> Options
jsonPrefix 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 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 (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 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

parseOneOf :: ToJSON a => [a] -> Value -> Parser a
parseOneOf :: [a] -> Value -> Parser a
parseOneOf [a]
xs 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
    Maybe a
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
$ String
"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]
++ String
" (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]
++ String
")"
    Just 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 Object
x <+> :: Value -> Value -> Value
<+> Object Object
y = Object -> Value
Object (Object
x Object -> Object -> Object
forall a. Semigroup a => a -> a -> a
<> Object
y)
Value
_ <+> Value
_ = String -> Value
forall a. HasCallStack => String -> a
error String
"<+>: 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 a
x 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
_ U1 p
_ = 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 (f p
a :*: g p
x) (f p
b :*: 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 a
x) (K1 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 f p
x) (M1 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 (\v
_old 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 (\v
_old v
new -> v
new)

instance SwaggerMonoid Text where
  swaggerMempty :: Text
swaggerMempty = Text
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 = Maybe a
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 :: a -> ByteString
encodePretty = Config -> a -> ByteString
forall a. ToJSON a => Config -> a -> ByteString
P.encodePretty' (Config -> a -> ByteString) -> Config -> a -> ByteString
forall a b. (a -> b) -> a -> b
$ Config
P.defConfig { confCompare :: Text -> Text -> Ordering
P.confCompare = Text -> Text -> Ordering
forall a. Ord a => a -> a -> Ordering
P.compare }