{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.Server.TH.Declare.GQLType
  ( deriveGQLType,
  )
where

import Data.Char (toLower)
import Data.Morpheus.CodeGen.Internal.AST
  ( CodeGenConfig (..),
    GQLTypeDefinition (..),
    Kind (..),
    ServerTypeDefinition (..),
  )
import Data.Morpheus.CodeGen.Internal.TH
  ( apply,
    applyVars,
    typeInstanceDec,
  )
import Data.Morpheus.Kind
  ( SCALAR,
    TYPE,
  )
import Data.Morpheus.Server.TH.Utils
  ( ServerDec,
    funDProxy,
    mkTypeableConstraints,
    renderTypeVars,
  )
import Data.Morpheus.Types
  ( GQLType (..),
    GQLTypeOptions (..),
  )
import Data.Morpheus.Types.Internal.AST
  ( TypeKind (..),
  )
import qualified Data.Text as T
import Language.Haskell.TH
  ( Dec,
    DecQ,
    Name,
    Q,
    Type (ConT),
    instanceD,
  )
import Relude

dropPrefix :: Text -> String -> String
dropPrefix :: Text -> String -> String
dropPrefix Text
name = forall a. Int -> [a] -> [a]
drop (Text -> Int
T.length Text
name)

stripConstructorNamespace :: Text -> String -> String
stripConstructorNamespace :: Text -> String -> String
stripConstructorNamespace = Text -> String -> String
dropPrefix

stripFieldNamespace :: Text -> String -> String
stripFieldNamespace :: Text -> String -> String
stripFieldNamespace Text
prefix = String -> String
__uncapitalize forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String -> String
dropPrefix Text
prefix
  where
    __uncapitalize :: String -> String
__uncapitalize [] = []
    __uncapitalize (Char
x : String
xs) = Char -> Char
toLower Char
x forall a. a -> [a] -> [a]
: String
xs

dropNamespaceOptions :: TypeKind -> Text -> GQLTypeOptions -> GQLTypeOptions
dropNamespaceOptions :: TypeKind -> Text -> GQLTypeOptions -> GQLTypeOptions
dropNamespaceOptions TypeKind
KindInterface Text
tName GQLTypeOptions
opt =
  GQLTypeOptions
opt
    { typeNameModifier :: Bool -> String -> String
typeNameModifier = forall a b. a -> b -> a
const (Text -> String -> String
stripConstructorNamespace Text
"Interface"),
      fieldLabelModifier :: String -> String
fieldLabelModifier = Text -> String -> String
stripFieldNamespace Text
tName
    }
dropNamespaceOptions TypeKind
KindEnum Text
tName GQLTypeOptions
opt = GQLTypeOptions
opt {constructorTagModifier :: String -> String
constructorTagModifier = Text -> String -> String
stripConstructorNamespace Text
tName}
dropNamespaceOptions TypeKind
_ Text
tName GQLTypeOptions
opt = GQLTypeOptions
opt {fieldLabelModifier :: String -> String
fieldLabelModifier = Text -> String -> String
stripFieldNamespace Text
tName}

deriveGQLType :: ServerTypeDefinition -> ServerDec [Dec]
deriveGQLType :: ServerTypeDefinition -> ServerDec [Dec]
deriveGQLType ServerInterfaceDefinition {} = forall (f :: * -> *) a. Applicative f => a -> f a
pure []
deriveGQLType
  ServerTypeDefinition
    { Text
tName :: ServerTypeDefinition -> Text
tName :: Text
tName,
      TypeKind
tKind :: ServerTypeDefinition -> TypeKind
tKind :: TypeKind
tKind,
      [Text]
typeParameters :: ServerTypeDefinition -> [Text]
typeParameters :: [Text]
typeParameters,
      Maybe GQLTypeDefinition
gql :: ServerTypeDefinition -> Maybe GQLTypeDefinition
gql :: Maybe GQLTypeDefinition
gql
    } = do
    let typeVars :: [Name]
typeVars = [Text] -> [Name]
renderTypeVars [Text]
typeParameters
    let constrains :: CxtQ
constrains = [Name] -> CxtQ
mkTypeableConstraints [Name]
typeVars
    let typeSignature :: Q Type
typeSignature = forall a i. (Apply a, ToCon i a) => i -> [a] -> a
apply ''GQLType [forall con var res.
(ToName con, ToName var, Apply res, ToCon con res,
 ToVar var res) =>
con -> [var] -> res
applyVars Text
tName [Name]
typeVars]
    [Q Dec]
methods <- Text
-> TypeKind
-> [Name]
-> Maybe GQLTypeDefinition
-> ServerDec [Q Dec]
defineMethods Text
tName TypeKind
tKind [Name]
typeVars Maybe GQLTypeDefinition
gql
    Dec
gqlTypeDeclaration <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD CxtQ
constrains Q Type
typeSignature [Q Dec]
methods)
    forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec
gqlTypeDeclaration]

defineTypeOptions :: Text -> TypeKind -> ServerDec [DecQ]
defineTypeOptions :: Text -> TypeKind -> ServerDec [Q Dec]
defineTypeOptions Text
tName TypeKind
kind = do
  CodeGenConfig {Bool
namespace :: CodeGenConfig -> Bool
namespace :: Bool
namespace} <- forall r (m :: * -> *). MonadReader r m => m r
ask
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [(Name, ExpQ)] -> [Q Dec]
funDProxy [('typeOptions, [|dropNamespaceOptions kind tName|]) | Bool
namespace]

defineMethods ::
  Text ->
  TypeKind ->
  [Name] ->
  Maybe GQLTypeDefinition ->
  ServerDec [Q Dec]
defineMethods :: Text
-> TypeKind
-> [Name]
-> Maybe GQLTypeDefinition
-> ServerDec [Q Dec]
defineMethods Text
tName TypeKind
kind [Name]
_ Maybe GQLTypeDefinition
Nothing = Text -> TypeKind -> ServerDec [Q Dec]
defineTypeOptions Text
tName TypeKind
kind
defineMethods
  Text
tName
  TypeKind
kind
  [Name]
typeParameters
  ( Just
      GQLTypeDefinition
        { Maybe Text
gqlTypeDescription :: GQLTypeDefinition -> Maybe Text
gqlTypeDescription :: Maybe Text
gqlTypeDescription,
          Map Text Text
gqlTypeDescriptions :: GQLTypeDefinition -> Map Text Text
gqlTypeDescriptions :: Map Text Text
gqlTypeDescriptions,
          Map Text (Directives CONST)
gqlTypeDirectives :: GQLTypeDefinition -> Map Text (Directives CONST)
gqlTypeDirectives :: Map Text (Directives CONST)
gqlTypeDirectives,
          Map Text (Value CONST)
gqlTypeDefaultValues :: GQLTypeDefinition -> Map Text (Value CONST)
gqlTypeDefaultValues :: Map Text (Value CONST)
gqlTypeDefaultValues,
          Kind
gqlKind :: GQLTypeDefinition -> Kind
gqlKind :: Kind
gqlKind
        }
    ) = do
    [Q Dec]
options <- Text -> TypeKind -> ServerDec [Q Dec]
defineTypeOptions Text
tName TypeKind
kind
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (Q Dec
typeFamilies forall a. a -> [a] -> [a]
: [Q Dec]
functions forall a. Semigroup a => a -> a -> a
<> [Q Dec]
options)
    where
      functions :: [Q Dec]
functions =
        [(Name, ExpQ)] -> [Q Dec]
funDProxy
          [ ('description, [|gqlTypeDescription|]),
            ('getDescriptions, [|gqlTypeDescriptions|]),
            ('getDirectives, [|gqlTypeDirectives|]),
            ('defaultValues, [|gqlTypeDefaultValues|])
          ]
      typeFamilies :: Q Dec
typeFamilies = do
        Type
currentType <- forall con var res.
(ToName con, ToName var, Apply res, ToCon con res,
 ToVar var res) =>
con -> [var] -> res
applyVars Text
tName [Name]
typeParameters
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Name -> Type -> Type -> Dec
typeInstanceDec ''KIND Type
currentType (Name -> Type
ConT (Kind -> Name
kindName Kind
gqlKind))

kindName :: Kind -> Name
kindName :: Kind -> Name
kindName Kind
Scalar = ''SCALAR
kindName Kind
Type = ''TYPE