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

module Data.Morpheus.Server.TH.Utils
  ( constraintTypeable,
    typeNameStringE,
    withPure,
    mkTypeableConstraints,
    m',
    m_,
    funDProxy,
    ServerDec,
    renderTypeVars,
  )
where

import Data.Morpheus.CodeGen.Internal.AST
  ( CodeGenConfig,
  )
import Data.Morpheus.CodeGen.Internal.TH
  ( apply,
    funDSimple,
    vars,
    _',
  )
import Data.Morpheus.Types.Internal.AST
  ( TypeName,
    unpackName,
  )
import Data.Text (unpack)
import qualified Data.Text as T
import Language.Haskell.TH
  ( CxtQ,
    DecQ,
    Exp (..),
    ExpQ,
    Lit (..),
    Name,
    Q,
    Type (..),
    cxt,
    mkName,
  )
import Relude hiding (Type)

type ServerDec = ReaderT CodeGenConfig Q

m_ :: Name
m_ :: Name
m_ = String -> Name
mkName String
"m"

m' :: Type
m' :: Type
m' = Name -> Type
VarT Name
m_

renderTypeVars :: [Text] -> [Name]
renderTypeVars :: [Text] -> [Name]
renderTypeVars = (Text -> Name) -> [Text] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Name
mkName (String -> Name) -> (Text -> String) -> Text -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack)

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

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
forall a (t :: NAME). NamePacking a => Name t -> a
unpackName)

constraintTypeable :: Type -> Q Type
constraintTypeable :: Type -> Q Type
constraintTypeable Type
name = Type -> Q Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Q Type) -> Type -> Q Type
forall a b. (a -> b) -> a -> b
$ Name -> [Type] -> Type
forall a i. (Apply a, ToCon i a) => i -> [a] -> a
apply ''Typeable [Type
name]

mkTypeableConstraints :: [Name] -> CxtQ
mkTypeableConstraints :: [Name] -> CxtQ
mkTypeableConstraints = [Q Type] -> CxtQ
cxt ([Q Type] -> CxtQ) -> ([Name] -> [Q Type]) -> [Name] -> CxtQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type -> Q Type) -> [Type] -> [Q Type]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Q Type
constraintTypeable ([Type] -> [Q Type]) -> ([Name] -> [Type]) -> [Name] -> [Q Type]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Name] -> [Type]
forall a b. ToVar a b => [a] -> [b]
vars