{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Data.Morpheus.Server.TH.Declare
( declare,
)
where
import Control.Applicative (pure)
import Control.Monad.Reader (runReader)
import Data.Foldable (concat)
import Data.Functor (fmap)
import Data.Morpheus.Server.Internal.TH.Types
( ServerDecContext (..),
ServerTypeDefinition (..),
)
import Data.Morpheus.Server.TH.Declare.GQLType
( deriveGQLType,
)
import Data.Morpheus.Server.TH.Declare.Type
( declareType,
)
import Data.Morpheus.Server.TH.Transform
import Data.Semigroup ((<>))
import Data.Traversable (traverse)
import Language.Haskell.TH
import Prelude
( ($),
(.),
)
class Declare a where
declare :: ServerDecContext -> a -> Q [Dec]
instance Declare a => Declare [a] where
declare :: ServerDecContext -> [a] -> Q [Dec]
declare ServerDecContext
namespace = ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[Dec]] -> Q [Dec]) -> ([a] -> Q [[Dec]]) -> [a] -> Q [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Q [Dec]) -> [a] -> Q [[Dec]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (ServerDecContext -> a -> Q [Dec]
forall a. Declare a => ServerDecContext -> a -> Q [Dec]
declare ServerDecContext
namespace)
instance Declare (TypeDec s) where
declare :: ServerDecContext -> TypeDec s -> Q [Dec]
declare ServerDecContext
namespace (InputType ServerTypeDefinition IN s
typeD) = ServerDecContext -> ServerTypeDefinition IN s -> Q [Dec]
forall a. Declare a => ServerDecContext -> a -> Q [Dec]
declare ServerDecContext
namespace ServerTypeDefinition IN s
typeD
declare ServerDecContext
namespace (OutputType ServerTypeDefinition OUT s
typeD) = ServerDecContext -> ServerTypeDefinition OUT s -> Q [Dec]
forall a. Declare a => ServerDecContext -> a -> Q [Dec]
declare ServerDecContext
namespace ServerTypeDefinition OUT s
typeD
instance Declare (ServerTypeDefinition cat s) where
declare :: ServerDecContext -> ServerTypeDefinition cat s -> Q [Dec]
declare ServerDecContext
ctx typeD :: ServerTypeDefinition cat s
typeD@ServerTypeDefinition {[ServerTypeDefinition IN s]
typeArgD :: forall (cat :: TypeCategory) (s :: Stage).
ServerTypeDefinition cat s -> [ServerTypeDefinition IN s]
typeArgD :: [ServerTypeDefinition IN s]
typeArgD} =
do
[Dec]
typeDef <- ServerDecContext -> ServerTypeDefinition cat s -> Q [Dec]
forall (cat :: TypeCategory) (s :: Stage).
ServerDecContext -> ServerTypeDefinition cat s -> Q [Dec]
declareServerType ServerDecContext
ctx ServerTypeDefinition cat s
typeD
[[Dec]]
argTypes <- (ServerTypeDefinition IN s -> Q [Dec])
-> [ServerTypeDefinition IN s] -> Q [[Dec]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (ServerDecContext -> ServerTypeDefinition IN s -> Q [Dec]
forall (cat :: TypeCategory) (s :: Stage).
ServerDecContext -> ServerTypeDefinition cat s -> Q [Dec]
declareServerType ServerDecContext
ctx) [ServerTypeDefinition IN s]
typeArgD
[Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [Dec]
typeDef [Dec] -> [Dec] -> [Dec]
forall a. Semigroup a => a -> a -> a
<> [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Dec]]
argTypes
declareServerType :: ServerDecContext -> ServerTypeDefinition cat s -> Q [Dec]
declareServerType :: ServerDecContext -> ServerTypeDefinition cat s -> Q [Dec]
declareServerType ServerDecContext
ctx ServerTypeDefinition cat s
argType = do
[Dec]
typeClasses <- ServerDecContext -> ServerTypeDefinition cat s -> Q [Dec]
forall (cat :: TypeCategory) (s :: Stage).
ServerDecContext -> ServerTypeDefinition cat s -> Q [Dec]
deriveGQLType ServerDecContext
ctx ServerTypeDefinition cat s
argType
let defs :: [Dec]
defs = Reader ServerDecContext [Dec] -> ServerDecContext -> [Dec]
forall r a. Reader r a -> r -> a
runReader (ServerTypeDefinition cat s -> Reader ServerDecContext [Dec]
forall (cat :: TypeCategory) (s :: Stage).
ServerTypeDefinition cat s -> Reader ServerDecContext [Dec]
declareType ServerTypeDefinition cat s
argType) ServerDecContext
ctx
[Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Dec]
defs [Dec] -> [Dec] -> [Dec]
forall a. Semigroup a => a -> a -> a
<> [Dec]
typeClasses)