{-# LANGUAGE RankNTypes #-}
module Deriving.Swagger where
import Data.Char qualified as Char
import Data.Kind (Constraint)
import Data.List.Extra (stripSuffix)
import Data.OpenApi.Internal.Schema (GToSchema)
import Data.OpenApi.Internal.TypeShape
import Data.OpenApi.Schema
import Data.Proxy (Proxy (..))
import GHC.Generics (Generic (Rep))
import GHC.TypeLits (ErrorMessage (Text), KnownSymbol, Symbol, TypeError, symbolVal)
import Imports
newtype CustomSwagger t a = CustomSwagger {forall {k} (t :: k) a. CustomSwagger t a -> a
unCustomSwagger :: a}
deriving ((forall x. CustomSwagger t a -> Rep (CustomSwagger t a) x)
-> (forall x. Rep (CustomSwagger t a) x -> CustomSwagger t a)
-> Generic (CustomSwagger t a)
forall x. Rep (CustomSwagger t a) x -> CustomSwagger t a
forall x. CustomSwagger t a -> Rep (CustomSwagger t a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall k (t :: k) a x.
Rep (CustomSwagger t a) x -> CustomSwagger t a
forall k (t :: k) a x.
CustomSwagger t a -> Rep (CustomSwagger t a) x
$cfrom :: forall k (t :: k) a x.
CustomSwagger t a -> Rep (CustomSwagger t a) x
from :: forall x. CustomSwagger t a -> Rep (CustomSwagger t a) x
$cto :: forall k (t :: k) a x.
Rep (CustomSwagger t a) x -> CustomSwagger t a
to :: forall x. Rep (CustomSwagger t a) x -> CustomSwagger t a
Generic, Typeable)
class SwaggerOptions xs where
swaggerOptions :: SchemaOptions
instance SwaggerOptions '[] where
swaggerOptions :: SchemaOptions
swaggerOptions = SchemaOptions
defaultSchemaOptions
instance (StringModifier f, SwaggerOptions xs) => SwaggerOptions (FieldLabelModifier f ': xs) where
swaggerOptions :: SchemaOptions
swaggerOptions = (forall (xs :: [*]). SwaggerOptions xs => SchemaOptions
forall {k} (xs :: k). SwaggerOptions xs => SchemaOptions
swaggerOptions @xs) {fieldLabelModifier = getStringModifier @f}
instance (StringModifier f, SwaggerOptions xs) => SwaggerOptions (ConstructorTagModifier f ': xs) where
swaggerOptions :: SchemaOptions
swaggerOptions = (forall (xs :: [*]). SwaggerOptions xs => SchemaOptions
forall {k} (xs :: k). SwaggerOptions xs => SchemaOptions
swaggerOptions @xs) {constructorTagModifier = getStringModifier @f}
instance (SwaggerOptions t, Generic a, Typeable a, GToSchema (Rep a), Typeable (CustomSwagger t a), TypeHasSimpleShape a "genericDeclareNamedSchemaUnrestricted") => ToSchema (CustomSwagger t a) where
declareNamedSchema :: Proxy (CustomSwagger t a)
-> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy (CustomSwagger t a)
_ = SchemaOptions
-> Proxy a -> Declare (Definitions Schema) NamedSchema
forall a.
(Generic a, GToSchema (Rep a), Typeable a) =>
SchemaOptions
-> Proxy a -> Declare (Definitions Schema) NamedSchema
genericDeclareNamedSchema (forall (xs :: k). SwaggerOptions xs => SchemaOptions
forall {k} (xs :: k). SwaggerOptions xs => SchemaOptions
swaggerOptions @t) (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a)
data FieldLabelModifier t
data ConstructorTagModifier t
class StringModifier t where
getStringModifier :: String -> String
instance (StringModifier a, StringModifier b) => StringModifier (a, b) where
getStringModifier :: [Char] -> [Char]
getStringModifier = forall t. StringModifier t => [Char] -> [Char]
forall {k} (t :: k). StringModifier t => [Char] -> [Char]
getStringModifier @b ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. StringModifier t => [Char] -> [Char]
forall {k} (t :: k). StringModifier t => [Char] -> [Char]
getStringModifier @a
instance (StringModifier a, StringModifier b, StringModifier c) => StringModifier (a, b, c) where
getStringModifier :: [Char] -> [Char]
getStringModifier = forall t. StringModifier t => [Char] -> [Char]
forall {k} (t :: k). StringModifier t => [Char] -> [Char]
getStringModifier @c ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. StringModifier t => [Char] -> [Char]
forall {k} (t :: k). StringModifier t => [Char] -> [Char]
getStringModifier @b ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. StringModifier t => [Char] -> [Char]
forall {k} (t :: k). StringModifier t => [Char] -> [Char]
getStringModifier @a
instance (StringModifier a, StringModifier b, StringModifier c, StringModifier d) => StringModifier (a, b, c, d) where
getStringModifier :: [Char] -> [Char]
getStringModifier = forall t. StringModifier t => [Char] -> [Char]
forall {k} (t :: k). StringModifier t => [Char] -> [Char]
getStringModifier @d ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. StringModifier t => [Char] -> [Char]
forall {k} (t :: k). StringModifier t => [Char] -> [Char]
getStringModifier @c ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. StringModifier t => [Char] -> [Char]
forall {k} (t :: k). StringModifier t => [Char] -> [Char]
getStringModifier @b ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. StringModifier t => [Char] -> [Char]
forall {k} (t :: k). StringModifier t => [Char] -> [Char]
getStringModifier @a
data StripPrefix t
instance (KnownSymbol prefix) => StringModifier (StripPrefix prefix) where
getStringModifier :: [Char] -> [Char]
getStringModifier = [Char] -> Maybe [Char] -> [Char]
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> Maybe [Char] -> [Char])
-> ([Char] -> Maybe [Char]) -> [Char] -> [Char]
forall a b. ([Char] -> a -> b) -> ([Char] -> a) -> [Char] -> b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Char] -> [Char] -> Maybe [Char]
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix (Proxy prefix -> [Char]
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> [Char]
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @prefix))
data StripSuffix t
instance (KnownSymbol suffix) => StringModifier (StripSuffix suffix) where
getStringModifier :: [Char] -> [Char]
getStringModifier = [Char] -> Maybe [Char] -> [Char]
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> Maybe [Char] -> [Char])
-> ([Char] -> Maybe [Char]) -> [Char] -> [Char]
forall a b. ([Char] -> a -> b) -> ([Char] -> a) -> [Char] -> b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Char] -> [Char] -> Maybe [Char]
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripSuffix (Proxy suffix -> [Char]
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> [Char]
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @suffix))
data CamelTo (separator :: Symbol)
instance (KnownSymbol separator, NonEmptyString separator) => StringModifier (CamelTo separator) where
getStringModifier :: [Char] -> [Char]
getStringModifier =
case Proxy separator -> [Char]
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> [Char]
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @separator) of
(Char
char : [Char]
_) -> Char -> [Char] -> [Char]
camelTo2 Char
char
[Char]
_ -> [Char] -> [Char] -> [Char]
forall a. HasCallStack => [Char] -> a
error [Char]
"Impossible case for 'NonEmptyString'"
type family NonEmptyString (xs :: Symbol) :: Constraint where
NonEmptyString "" = TypeError ('Text "Empty string separator provided for camelTo separator")
NonEmptyString _ = ()
camelTo2 :: Char -> String -> String
camelTo2 :: Char -> [Char] -> [Char]
camelTo2 Char
c = (Char -> Char) -> [Char] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
go2 ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
go1
where
go1 :: [Char] -> [Char]
go1 [Char]
"" = [Char]
""
go1 (Char
x : Char
u : Char
l : [Char]
xs) | Char -> Bool
isUpper Char
u Bool -> Bool -> Bool
&& Char -> Bool
isLower Char
l = Char
x Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: Char
c Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: Char
u Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: Char
l Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char] -> [Char]
go1 [Char]
xs
go1 (Char
x : [Char]
xs) = Char
x Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char] -> [Char]
go1 [Char]
xs
go2 :: [Char] -> [Char]
go2 [Char]
"" = [Char]
""
go2 (Char
l : Char
u : [Char]
xs) | Char -> Bool
isLower Char
l Bool -> Bool -> Bool
&& Char -> Bool
isUpper Char
u = Char
l Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: Char
c Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: Char
u Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char] -> [Char]
go2 [Char]
xs
go2 (Char
x : [Char]
xs) = Char
x Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char] -> [Char]
go2 [Char]
xs
type CamelToSnake = CamelTo "_"
type CamelToKebab = CamelTo "-"
data LowerCase
instance StringModifier LowerCase where
getStringModifier :: [Char] -> [Char]
getStringModifier = (Char -> Char) -> [Char] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
Char.toLower
data LabelMapping a b = a :-> b
data LabelMappings (lmap :: [LabelMapping Symbol Symbol])
instance StringModifier (LabelMappings '[]) where
getStringModifier :: [Char] -> [Char]
getStringModifier = [Char] -> [Char]
forall a. a -> a
id
instance (KnownSymbol orig, KnownSymbol new, StringModifier (LabelMappings xs)) => StringModifier (LabelMappings ((orig ':-> new) ': xs)) where
getStringModifier :: [Char] -> [Char]
getStringModifier [Char]
input =
if [Char]
input [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== Proxy orig -> [Char]
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> [Char]
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @orig)
then Proxy new -> [Char]
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> [Char]
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @new)
else forall t. StringModifier t => [Char] -> [Char]
forall {k} (t :: k). StringModifier t => [Char] -> [Char]
getStringModifier @(LabelMappings xs) [Char]
input