{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE NoImplicitPrelude #-} module Data.Morpheus.Server.Deriving.Kinded.Arguments ( DeriveFieldArguments (..), HasArguments, ) where import Data.Morpheus.Internal.Ext ((<:>)) import Data.Morpheus.Server.Deriving.Internal.Schema.Internal ( CatType, deriveTypeAsArguments, ) import Data.Morpheus.Server.Deriving.Utils.Kinded ( CatType (..), ) import Data.Morpheus.Server.Deriving.Utils.Use ( UseDeriving (..), UseGQLType (..), ) import Data.Morpheus.Server.Types.SchemaT ( SchemaT, withInput, ) import Data.Morpheus.Types.Internal.AST ( ArgumentsDefinition, CONST, OUT, ) import Relude type family HasArguments a where HasArguments (a -> b) = (a -> b) HasArguments a = () class DeriveFieldArguments gql a where deriveFieldArguments :: UseDeriving gql val -> f a -> SchemaT OUT (Maybe (ArgumentsDefinition CONST)) instance DeriveFieldArguments gql () where deriveFieldArguments :: forall (val :: * -> Constraint) (f :: * -> *). UseDeriving gql val -> f () -> SchemaT OUT (Maybe (ArgumentsDefinition CONST)) deriveFieldArguments UseDeriving gql val _ f () _ = forall (f :: * -> *) a. Applicative f => a -> f a pure forall a. Maybe a Nothing instance (gql b, gql a) => DeriveFieldArguments gql (a -> b) where deriveFieldArguments :: forall (val :: * -> Constraint) (f :: * -> *). UseDeriving gql val -> f (a -> b) -> SchemaT OUT (Maybe (ArgumentsDefinition CONST)) deriveFieldArguments UseDeriving {UseValue val UseGQLType gql forall (f :: * -> *) a. gql a => f a -> GDirectiveUsages gql val dirGQL :: forall (gql :: * -> Constraint) (val :: * -> Constraint). UseDeriving gql val -> UseGQLType gql dirArgs :: forall (gql :: * -> Constraint) (val :: * -> Constraint). UseDeriving gql val -> UseValue val __directives :: forall (gql :: * -> Constraint) (val :: * -> Constraint). UseDeriving gql val -> forall (f :: * -> *) a. gql a => f a -> GDirectiveUsages gql val dirGQL :: UseGQLType gql dirArgs :: UseValue val __directives :: forall (f :: * -> *) a. gql a => f a -> GDirectiveUsages gql val ..} f (a -> b) _ = do ArgumentsDefinition CONST a <- forall a. SchemaT IN a -> SchemaT OUT a withInput forall a b. (a -> b) -> a -> b $ forall (gql :: * -> Constraint) a (f :: * -> *). gql a => UseGQLType gql -> f a -> SchemaT IN (ArgumentsDefinition CONST) deriveTypeAsArguments UseGQLType gql dirGQL (forall {k} (t :: k). Proxy t Proxy @a) Maybe (ArgumentsDefinition CONST) b <- forall (gql :: * -> Constraint). UseGQLType gql -> forall (c :: TypeCategory) a. gql a => CatType c a -> SchemaT c (Maybe (ArgumentsDefinition CONST)) useDeriveFieldArguments UseGQLType gql dirGQL (forall {k} (a :: k). CatType OUT a OutputType :: CatType OUT b) case Maybe (ArgumentsDefinition CONST) b of Just ArgumentsDefinition CONST x -> forall a. a -> Maybe a Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> (ArgumentsDefinition CONST a forall (m :: * -> *) a. (Merge (HistoryT m) a, Monad m) => a -> a -> m a <:> ArgumentsDefinition CONST x) Maybe (ArgumentsDefinition CONST) Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a pure forall a b. (a -> b) -> a -> b $ forall a. a -> Maybe a Just ArgumentsDefinition CONST a