{-# LANGUAGE RankNTypes #-}

-- This file is part of the Wire Server implementation.
--
-- Copyright (C) 2022 Wire Swiss GmbH <opensource@wire.com>
--
-- This program is free software: you can redistribute it and/or modify it under
-- the terms of the GNU Affero General Public License as published by the Free
-- Software Foundation, either version 3 of the License, or (at your option) any
-- later version.
--
-- This program is distributed in the hope that it will be useful, but WITHOUT
-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more
-- details.
--
-- You should have received a copy of the GNU Affero General Public License along
-- with this program. If not, see <https://www.gnu.org/licenses/>.

-- | Type-directed ToSchema instances. Heavily inspired by
-- [deriving-aeson](https://hackage.haskell.org/package/deriving-aeson).
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

-- * How to use this library

-- $usage
-- This library provides types which can be used with @deriving via@ like this:
--
-- @
-- data Person = Person { personName :: Text
--                      , personAge :: Int
--                      , personBirthCity :: Text
--                      }
--  deriving (Generic)
--  deriving (ToSchema) via (CustomSwagger '[FieldLabelModifier (StripPrefix "person", CamelToSnake)] Person)
-- @
--
-- This will produce swagger schema with fields @name@, @age@ and @birth_city@.
--
-- Similarly constructor tags of sum types can also be modified like this:
--
-- @
-- data AssetSize = AssetComplete | AssetPreview
--   deriving (Generic)
--   deriving (ToSchema) via (CustomSwagger '[ConstructorTagModifier (StripPrefix \"Asset\", CamelToSnake)] AssetSize)
-- @
--
-- This will produce a swagger schema with enums limited to @complete@ and
-- @preview@
--
-- Sometimes life isn't as easy and some exceptions need to be specified to
-- neatly laid out rules. For example, if in the first example we wanted to map
-- @personBirthCity@ to @city_of_birth@, we can specify this exception using
-- @'LabelMappings'@ like this:
--
-- @
--   deriving via (ToSchema)
--   via (CustomSwagger '[ FieldLabelModifier ( StripPrefix "person"
--                                            , CamelToSnake
--                                            , LabelMappings '["birth_city" ':-> "city_of_birth"]
--                                            )
--                                            Person
--                       ]
--       )
-- @
--
-- Note that here we map the camel-cased version @birth_city@ to @city_of_birth@
-- because @'CamelToSnake'@ is used before @'LabelMappings'@.

-- * Types

-- | A newtype wrapper which gives ToSchema instances with modified options.
-- 't' has to have an instance of the 'SwaggerOptions' class.
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)

-- ** Specify __what__ to modify

-- | Modifies field labels only. Most likely 't' should be anything that
-- implments 'StringModifier'
data FieldLabelModifier t

-- | Modifies constructor tags only. Most likely 't' should be anything that
-- implements 'StringModifier'.
data ConstructorTagModifier t

-- ** Specify __how__ to modify

-- | Typeclass to specify the modifications
class StringModifier t where
  getStringModifier :: String -> String

-- | Left-to-right (@'flip' '.'@) composition
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

-- | Left-to-right (@'flip' '.'@) composition
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

-- | Left-to-right (@'flip' '.'@) composition
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

-- | Strips the given prefix, has no effect if the prefix doesn't exist
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))

-- | Strips the given suffix, has no effect if the suffix doesn't exist
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 _ = ()

-- | Copied from Data.Aeson.Types.Internal
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