{-# 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 = forall a b. (a -> b) -> [a] -> [b]
map (String -> Name
mkName forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack)

funDProxy :: [(Name, ExpQ)] -> [DecQ]
funDProxy :: [(Name, ExpQ)] -> [DecQ]
funDProxy = 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Lit
StringL forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> String
unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (t :: NAME). NamePacking a => Name t -> a
unpackName)

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

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