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

module Data.Morpheus.Server.Internal.TH.Utils
  ( kindName,
    constraintTypeable,
    typeNameStringE,
    withPure,
    o',
    e',
    mkTypeableConstraints,
  )
where

import Data.Morpheus.Internal.TH
  ( apply,
    toName,
    vars,
  )
import Data.Morpheus.Kind
  ( ENUM,
    INPUT,
    INTERFACE,
    OUTPUT,
    SCALAR,
    WRAPPER,
  )
import Data.Morpheus.Types.Internal.AST
  ( TypeKind (..),
    TypeName (..),
  )
import Data.Text (unpack)
import Data.Typeable (Typeable)
import Language.Haskell.TH
  ( CxtQ,
    Exp (..),
    Lit (..),
    Name,
    Type (..),
    cxt,
  )
import Prelude
  ( ($),
    (.),
    String,
    map,
    pure,
  )

o' :: Type
o' :: Type
o' = Name -> Type
VarT (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ TypeName -> Name
forall a. ToName a => a -> Name
toName (TypeName
"operation" :: TypeName)

e' :: Type
e' :: Type
e' = Name -> Type
VarT (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ TypeName -> Name
forall a. ToName a => a -> Name
toName (TypeName
"encodeEvent" :: TypeName)

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 -> [Type] -> 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) -> [Type] -> [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] -> [Type]
forall a b. ToVar a b => [a] -> [b]
vars [String]
args)

kindName :: TypeKind -> Name
kindName :: TypeKind -> Name
kindName KindObject {} = ''OUTPUT
kindName TypeKind
KindScalar = ''SCALAR
kindName TypeKind
KindEnum = ''ENUM
kindName TypeKind
KindUnion = ''OUTPUT
kindName TypeKind
KindInputObject = ''INPUT
kindName TypeKind
KindList = ''WRAPPER
kindName TypeKind
KindNonNull = ''WRAPPER
kindName TypeKind
KindInputUnion = ''INPUT
kindName TypeKind
KindInterface = ''INTERFACE