{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.Server.Deriving.Internal.Schema.Internal
  ( CatType (..),
    fromSchema,
    withObject,
    deriveTypeAsArguments,
  )
where

-- MORPHEUS

import Control.Monad.Except (throwError)
import Data.Morpheus.Internal.Ext
  ( GQLResult,
    Result (Failure, Success, errors),
  )
import Data.Morpheus.Server.Deriving.Utils.Kinded
  ( CatType (..),
    inputType,
  )
import Data.Morpheus.Server.Deriving.Utils.Use (UseGQLType (..))
import Data.Morpheus.Server.Types.SchemaT (SchemaT)
import Data.Morpheus.Types.Internal.AST
  ( ArgumentsDefinition,
    CONST,
    FieldsDefinition,
    IN,
    Msg (..),
    Schema (..),
    TRUE,
    TypeContent (..),
    TypeDefinition (..),
    VALID,
    fieldsToArguments,
  )
import Language.Haskell.TH (Exp, Q)
import Relude hiding (empty)

fromSchema :: GQLResult (Schema VALID) -> Q Exp
fromSchema :: GQLResult (Schema VALID) -> Q Exp
fromSchema Success {} = [|()|]
fromSchema Failure {NonEmpty GQLError
errors :: NonEmpty GQLError
errors :: forall err a. Result err a -> NonEmpty err
errors} = forall (m :: * -> *) a. MonadFail m => String -> m a
fail (forall b a. (Show a, IsString b) => a -> b
show NonEmpty GQLError
errors)

withObject :: (gql a) => UseGQLType gql -> CatType c a -> TypeContent TRUE any s -> SchemaT c (FieldsDefinition c s)
withObject :: forall (gql :: * -> Constraint) a (c :: TypeCategory)
       (any :: TypeCategory) (s :: Stage).
gql a =>
UseGQLType gql
-> CatType c a
-> TypeContent TRUE any s
-> SchemaT c (FieldsDefinition c s)
withObject UseGQLType gql
_ CatType c a
InputType DataInputObject {FieldsDefinition 'IN s
inputObjectFields :: forall (s :: Stage) (a :: TypeCategory).
CondTypeContent INPUT_OBJECT a s -> FieldsDefinition 'IN s
inputObjectFields :: FieldsDefinition 'IN s
inputObjectFields} = forall (f :: * -> *) a. Applicative f => a -> f a
pure FieldsDefinition 'IN s
inputObjectFields
withObject UseGQLType gql
_ CatType c a
OutputType DataObject {FieldsDefinition 'OUT s
objectFields :: forall (s :: Stage) (a :: TypeCategory).
CondTypeContent OBJECT a s -> FieldsDefinition 'OUT s
objectFields :: FieldsDefinition 'OUT s
objectFields} = forall (f :: * -> *) a. Applicative f => a -> f a
pure FieldsDefinition 'OUT s
objectFields
withObject UseGQLType gql
gql CatType c a
x TypeContent TRUE any s
_ = forall (gql :: * -> Constraint) a (c :: TypeCategory) b.
gql a =>
UseGQLType gql -> CatType c a -> SchemaT c b
failureOnlyObject UseGQLType gql
gql CatType c a
x

failureOnlyObject :: (gql a) => UseGQLType gql -> CatType c a -> SchemaT c b
failureOnlyObject :: forall (gql :: * -> Constraint) a (c :: TypeCategory) b.
gql a =>
UseGQLType gql -> CatType c a -> SchemaT c b
failureOnlyObject UseGQLType gql
gql CatType c a
proxy = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ forall a. Msg a => a -> GQLError
msg (forall (gql :: * -> Constraint).
UseGQLType gql
-> forall (c :: TypeCategory) a. gql a => CatType c a -> TypeName
useTypename UseGQLType gql
gql CatType c a
proxy) forall a. Semigroup a => a -> a -> a
<> GQLError
" should have only one nonempty constructor"

deriveTypeAsArguments :: gql a => UseGQLType gql -> f a -> SchemaT IN (ArgumentsDefinition CONST)
deriveTypeAsArguments :: forall (gql :: * -> Constraint) a (f :: * -> *).
gql a =>
UseGQLType gql -> f a -> SchemaT 'IN (ArgumentsDefinition CONST)
deriveTypeAsArguments UseGQLType gql
gql f a
arg =
  forall (s :: Stage).
FieldsDefinition 'IN s -> ArgumentsDefinition s
fieldsToArguments
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ( forall (gql :: * -> Constraint).
UseGQLType gql
-> forall (c :: TypeCategory) a.
   gql a =>
   CatType c a -> SchemaT c (TypeDefinition c CONST)
useDeriveType UseGQLType gql
gql (forall {k} (f :: k -> *) (a :: k). f a -> CatType 'IN a
inputType f a
arg)
            forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (gql :: * -> Constraint) a (c :: TypeCategory)
       (any :: TypeCategory) (s :: Stage).
gql a =>
UseGQLType gql
-> CatType c a
-> TypeContent TRUE any s
-> SchemaT c (FieldsDefinition c s)
withObject UseGQLType gql
gql (forall {k} (f :: k -> *) (a :: k). f a -> CatType 'IN a
inputType f a
arg) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeContent TRUE a s
typeContent
        )