{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.Server.TH.Declare
  ( declare,
  )
where

-- MORPHEUS
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)