{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.Server.Internal.TH.Utils
  ( kindName,
    constraintTypeable,
    typeNameStringE,
    withPure,
    mkTypeableConstraints,
    m',
    m_,
    tyConArgs,
    funDProxy,
    isParametrizedResolverType,
    isSubscription,
  )
where

import Data.Morpheus.Internal.TH
  ( _',
    apply,
    funDSimple,
    toName,
    vars,
  )
import Data.Morpheus.Kind
  ( INTERFACE,
    SCALAR,
    TYPE,
    WRAPPER,
  )
import Data.Morpheus.Types.Internal.AST
  ( ANY,
    OperationType (..),
    TypeDefinition (..),
    TypeKind (..),
    TypeName (..),
    isResolverType,
    lookupWith,
  )
import Data.Text (unpack)
import Language.Haskell.TH
  ( CxtQ,
    Dec (..),
    DecQ,
    Exp (..),
    ExpQ,
    Info (..),
    Lit (..),
    Name,
    Q,
    TyVarBndr,
    Type (..),
    cxt,
    mkName,
    reify,
  )
import Relude hiding (Type)

m_ :: String
m_ :: String
m_ = String
"m"

m' :: Type
m' :: Type
m' = Name -> Type
VarT (String -> Name
mkName String
m_)

isParametrizedResolverType :: TypeName -> [TypeDefinition ANY s] -> Q Bool
isParametrizedResolverType :: TypeName -> [TypeDefinition ANY s] -> Q Bool
isParametrizedResolverType TypeName
"__TypeKind" [TypeDefinition ANY s]
_ = Bool -> Q Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
isParametrizedResolverType TypeName
"Boolean" [TypeDefinition ANY s]
_ = Bool -> Q Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
isParametrizedResolverType TypeName
"String" [TypeDefinition ANY s]
_ = Bool -> Q Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
isParametrizedResolverType TypeName
"Int" [TypeDefinition ANY s]
_ = Bool -> Q Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
isParametrizedResolverType TypeName
"Float" [TypeDefinition ANY s]
_ = Bool -> Q Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
isParametrizedResolverType TypeName
key [TypeDefinition ANY s]
lib = case (TypeDefinition ANY s -> TypeName)
-> TypeName
-> [TypeDefinition ANY s]
-> Maybe (TypeDefinition ANY s)
forall k a. Eq k => (a -> k) -> k -> [a] -> Maybe a
lookupWith TypeDefinition ANY s -> TypeName
forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeName TypeName
key [TypeDefinition ANY s]
lib of
  Just TypeDefinition ANY s
x -> Bool -> Q Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeDefinition ANY s -> Bool
forall t. Strictness t => t -> Bool
isResolverType TypeDefinition ANY s
x)
  Maybe (TypeDefinition ANY s)
Nothing -> Info -> Bool
isParametrizedType (Info -> Bool) -> Q Info -> Q Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Q Info
reify (TypeName -> Name
forall a. ToName a => a -> Name
toName TypeName
key)

isParametrizedType :: Info -> Bool
isParametrizedType :: Info -> Bool
isParametrizedType (TyConI Dec
x) = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [TyVarBndr] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([TyVarBndr] -> Bool) -> [TyVarBndr] -> Bool
forall a b. (a -> b) -> a -> b
$ Dec -> [TyVarBndr]
getTypeVariables Dec
x
isParametrizedType Info
_ = Bool
False

getTypeVariables :: Dec -> [TyVarBndr]
getTypeVariables :: Dec -> [TyVarBndr]
getTypeVariables (DataD Cxt
_ Name
_ [TyVarBndr]
args Maybe Type
_ [Con]
_ [DerivClause]
_) = [TyVarBndr]
args
getTypeVariables (NewtypeD Cxt
_ Name
_ [TyVarBndr]
args Maybe Type
_ Con
_ [DerivClause]
_) = [TyVarBndr]
args
getTypeVariables (TySynD Name
_ [TyVarBndr]
args Type
_) = [TyVarBndr]
args
getTypeVariables Dec
_ = []

funDProxy :: [(Name, ExpQ)] -> [DecQ]
funDProxy :: [(Name, ExpQ)] -> [DecQ]
funDProxy = ((Name, ExpQ) -> DecQ) -> [(Name, ExpQ)] -> [DecQ]
forall a b. (a -> b) -> [a] -> [b]
map (Name, ExpQ) -> DecQ
fun
  where
    fun :: (Name, ExpQ) -> DecQ
fun (Name
name, ExpQ
body) = Name -> [PatQ] -> ExpQ -> DecQ
funDSimple Name
name [PatQ
_'] ExpQ
body

tyConArgs :: TypeKind -> [String]
tyConArgs :: TypeKind -> [String]
tyConArgs TypeKind
kind
  | TypeKind -> Bool
forall t. Strictness t => t -> Bool
isResolverType TypeKind
kind = [String
m_]
  | Bool
otherwise = []

withPure :: Exp -> Exp
withPure :: Exp -> Exp
withPure = Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'pure)

typeNameStringE :: TypeName -> Exp
typeNameStringE :: TypeName -> Exp
typeNameStringE = Lit -> Exp
LitE (Lit -> Exp) -> (TypeName -> Lit) -> TypeName -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Lit
StringL (String -> Lit) -> (TypeName -> String) -> TypeName -> Lit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> String
unpack (Text -> String) -> (TypeName -> Text) -> TypeName -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeName -> Text
readTypeName)

constraintTypeable :: Type -> Type
constraintTypeable :: Type -> Type
constraintTypeable Type
name = Name -> Cxt -> Type
forall a i. (Apply a, ToCon i a) => i -> [a] -> a
apply ''Typeable [Type
name]

mkTypeableConstraints :: [String] -> CxtQ
mkTypeableConstraints :: [String] -> CxtQ
mkTypeableConstraints [String]
args = [PredQ] -> CxtQ
cxt ([PredQ] -> CxtQ) -> [PredQ] -> CxtQ
forall a b. (a -> b) -> a -> b
$ (Type -> PredQ) -> Cxt -> [PredQ]
forall a b. (a -> b) -> [a] -> [b]
map (Type -> PredQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> PredQ) -> (Type -> Type) -> Type -> PredQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type
constraintTypeable) ([String] -> Cxt
forall a b. ToVar a b => [a] -> [b]
vars [String]
args)

kindName :: TypeKind -> Name
kindName :: TypeKind -> Name
kindName TypeKind
KindScalar = ''SCALAR
kindName TypeKind
KindList = ''WRAPPER
kindName TypeKind
KindNonNull = ''WRAPPER
kindName TypeKind
KindInterface = ''INTERFACE
kindName TypeKind
_ = ''TYPE

isSubscription :: TypeKind -> Bool
isSubscription :: TypeKind -> Bool
isSubscription (KindObject (Just OperationType
Subscription)) = Bool
True
isSubscription TypeKind
_ = Bool
False