{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Data.Morpheus.Server.Deriving.Schema.Directive
( deriveFieldDirectives,
deriveTypeDirectives,
deriveEnumDirectives,
visitEnumValueDescription,
visitFieldDescription,
visitTypeDescription,
visitEnumName,
visitFieldName,
toFieldRes,
)
where
import Control.Monad.Except (throwError)
import qualified Data.HashMap.Lazy as HM
import Data.Morpheus.Internal.Ext (resultOr, unsafeFromList)
import Data.Morpheus.Internal.Utils (Empty (..), fromElems)
import Data.Morpheus.Server.Deriving.Utils.Kinded
( KindedProxy (..),
)
import Data.Morpheus.Server.Deriving.Utils.Types (FieldRep (..))
import Data.Morpheus.Server.Types.Directives
( GQLDirective (..),
ToLocations,
getLocations,
)
import Data.Morpheus.Server.Types.GQLType
( DeriveArguments (..),
DirectiveUsage (..),
DirectiveUsages (..),
GQLType (..),
applyEnumDescription,
applyEnumName,
applyFieldDescription,
applyFieldName,
applyTypeDescription,
applyTypeEnumNames,
applyTypeFieldNames,
deriveFingerprint,
deriveTypename,
encodeArguments,
)
import Data.Morpheus.Server.Types.Internal
import Data.Morpheus.Server.Types.SchemaT
( SchemaT,
insertDirectiveDefinition,
outToAny,
)
import Data.Morpheus.Types.Internal.AST
( Argument (..),
CONST,
Description,
Directive (..),
DirectiveDefinition (..),
Directives,
FieldName,
IN,
Position (Position),
TypeName,
)
import GHC.Generics ()
import GHC.TypeLits ()
import Relude hiding (empty)
type DirectiveDefinitionConstraint a =
( GQLDirective a,
GQLType a,
DeriveArguments (KIND a) a,
ToLocations (DIRECTIVE_LOCATIONS a)
)
deriveDirectiveDefinition ::
forall a b kind.
(DirectiveDefinitionConstraint a) =>
a ->
b ->
SchemaT kind (DirectiveDefinition CONST)
deriveDirectiveDefinition :: forall a b (kind :: TypeCategory).
DirectiveDefinitionConstraint a =>
a -> b -> SchemaT kind (DirectiveDefinition CONST)
deriveDirectiveDefinition a
_ b
_ = do
ArgumentsDefinition CONST
directiveDefinitionArgs <- forall a (k' :: TypeCategory). SchemaT OUT a -> SchemaT k' a
outToAny (forall (k :: DerivingKind) a (f :: DerivingKind -> * -> *).
DeriveArguments k a =>
f k a -> SchemaT OUT (ArgumentsDefinition CONST)
deriveArgumentsDefinition (forall {k} {k} (k :: k) (a :: k). KindedProxy k a
KindedProxy :: KindedProxy (KIND a) a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure
( DirectiveDefinition
{ directiveDefinitionName :: FieldName
directiveDefinitionName = forall (f :: * -> *) a. GQLType a => f a -> FieldName
deriveDirectiveName Proxy a
proxy,
directiveDefinitionDescription :: Maybe Description
directiveDefinitionDescription = forall a (f :: * -> *). GQLType a => f a -> Maybe Description
description Proxy a
proxy,
ArgumentsDefinition CONST
directiveDefinitionArgs :: ArgumentsDefinition CONST
directiveDefinitionArgs :: ArgumentsDefinition CONST
directiveDefinitionArgs,
directiveDefinitionLocations :: [DirectiveLocation]
directiveDefinitionLocations = forall (f :: * -> *) a.
ToLocations (DIRECTIVE_LOCATIONS a) =>
f a -> [DirectiveLocation]
getLocations Proxy a
proxy
}
)
where
proxy :: Proxy a
proxy = forall {k} (t :: k). Proxy t
Proxy @a
deriveDirectiveUsages :: [DirectiveUsage] -> SchemaT c (Directives CONST)
deriveDirectiveUsages :: forall (c :: TypeCategory).
[DirectiveUsage] -> SchemaT c (Directives CONST)
deriveDirectiveUsages = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall k (m :: * -> *) a. IsMap k m => [(k, a)] -> m a
unsafeFromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall (c :: TypeCategory).
DirectiveUsage -> SchemaT c (FieldName, Directive CONST)
toDirectiveTuple
deriveDirectiveName :: forall f a. GQLType a => f a -> FieldName
deriveDirectiveName :: forall (f :: * -> *) a. GQLType a => f a -> FieldName
deriveDirectiveName f a
_ = coerce :: forall a b. Coercible a b => a -> b
coerce forall a b. (a -> b) -> a -> b
$ forall a (kind :: TypeCategory) (kinded :: TypeCategory -> * -> *).
(GQLType a, CategoryValue kind) =>
kinded kind a -> TypeName
deriveTypename (forall {k} {k} (k :: k) (a :: k). KindedProxy k a
KindedProxy :: KindedProxy IN a)
toDirectiveTuple :: DirectiveUsage -> SchemaT c (FieldName, Directive CONST)
toDirectiveTuple :: forall (c :: TypeCategory).
DirectiveUsage -> SchemaT c (FieldName, Directive CONST)
toDirectiveTuple (DirectiveUsage a
x) = do
forall a (c :: TypeCategory).
GQLType a =>
(KindedProxy IN a -> SchemaT c (DirectiveDefinition CONST))
-> a -> SchemaT c ()
insertDirective (forall a b (kind :: TypeCategory).
DirectiveDefinitionConstraint a =>
a -> b -> SchemaT kind (DirectiveDefinition CONST)
deriveDirectiveDefinition a
x) a
x
let directiveName :: FieldName
directiveName = forall (f :: * -> *) a. GQLType a => f a -> FieldName
deriveDirectiveName (forall a. a -> Identity a
Identity a
x)
[Argument CONST]
args <- forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall err a' a.
(NonEmpty err -> a') -> (a -> a') -> Result err a -> a'
resultOr (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError GQLError
"TODO: fix me") forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a.
Decode a =>
a -> GQLResult (OrdMap FieldName (Argument CONST))
encodeArguments a
x)
OrdMap FieldName (Argument CONST)
directiveArgs <- forall (m :: * -> *) k a (map :: * -> * -> *).
(Monad m, KeyOf k a, FromList m map k a) =>
[a] -> m (map k a)
fromElems (forall a b. (a -> b) -> [a] -> [b]
map Argument CONST -> Argument CONST
editArg [Argument CONST]
args)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
( FieldName
directiveName,
Directive
{ directivePosition :: Position
directivePosition = Int -> Int -> Position
Position Int
0 Int
0,
FieldName
directiveName :: FieldName
directiveName :: FieldName
directiveName,
OrdMap FieldName (Argument CONST)
directiveArgs :: OrdMap FieldName (Argument CONST)
directiveArgs :: OrdMap FieldName (Argument CONST)
directiveArgs
}
)
where
editArg :: Argument CONST -> Argument CONST
editArg Argument {Value CONST
FieldName
Position
argumentPosition :: forall (valid :: Stage). Argument valid -> Position
argumentName :: forall (valid :: Stage). Argument valid -> FieldName
argumentValue :: forall (valid :: Stage). Argument valid -> Value valid
argumentValue :: Value CONST
argumentName :: FieldName
argumentPosition :: Position
..} = Argument {argumentName :: FieldName
argumentName = forall a (f :: * -> *). GQLType a => f a -> FieldName -> FieldName
applyGQLFieldOptions (forall a. a -> Identity a
Identity a
x) FieldName
argumentName, Value CONST
Position
argumentPosition :: Position
argumentValue :: Value CONST
argumentValue :: Value CONST
argumentPosition :: Position
..}
insertDirective ::
forall a c.
(GQLType a) =>
(KindedProxy IN a -> SchemaT c (DirectiveDefinition CONST)) ->
a ->
SchemaT c ()
insertDirective :: forall a (c :: TypeCategory).
GQLType a =>
(KindedProxy IN a -> SchemaT c (DirectiveDefinition CONST))
-> a -> SchemaT c ()
insertDirective KindedProxy IN a -> SchemaT c (DirectiveDefinition CONST)
f a
_ = forall a (cat' :: TypeCategory).
TypeFingerprint
-> (a -> SchemaT cat' (DirectiveDefinition CONST))
-> a
-> SchemaT cat' ()
insertDirectiveDefinition (forall a (kind :: TypeCategory) (kinded :: TypeCategory -> * -> *).
(GQLType a, CategoryValue kind) =>
kinded kind a -> TypeFingerprint
deriveFingerprint KindedProxy IN a
proxy) KindedProxy IN a -> SchemaT c (DirectiveDefinition CONST)
f KindedProxy IN a
proxy
where
proxy :: KindedProxy IN a
proxy = forall {k} {k} (k :: k) (a :: k). KindedProxy k a
KindedProxy :: KindedProxy IN a
getDirHM :: (Ord k, Hashable k, Empty a) => k -> HashMap k a -> a
getDirHM :: forall k a. (Ord k, Hashable k, Empty a) => k -> HashMap k a -> a
getDirHM k
name HashMap k a
xs = forall a. a -> Maybe a -> a
fromMaybe forall coll. Empty coll => coll
empty forall a b. (a -> b) -> a -> b
$ k
name forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
`HM.lookup` HashMap k a
xs
isIncluded :: DirectiveUsage -> Bool
isIncluded :: DirectiveUsage -> Bool
isIncluded (DirectiveUsage a
x) = Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall a (f :: * -> *). GQLDirective a => f a -> Bool
excludeFromSchema (forall a. a -> Identity a
Identity a
x)
getEnumDirectiveUsages :: GQLType a => f a -> TypeName -> [DirectiveUsage]
getEnumDirectiveUsages :: forall a (f :: * -> *).
GQLType a =>
f a -> TypeName -> [DirectiveUsage]
getEnumDirectiveUsages f a
proxy TypeName
name = forall k a. (Ord k, Hashable k, Empty a) => k -> HashMap k a -> a
getDirHM TypeName
name forall a b. (a -> b) -> a -> b
$ DirectiveUsages -> HashMap TypeName [DirectiveUsage]
enumValueDirectives forall a b. (a -> b) -> a -> b
$ forall a (f :: * -> *). GQLType a => f a -> DirectiveUsages
directives f a
proxy
getFieldDirectiveUsages :: GQLType a => FieldName -> f a -> [DirectiveUsage]
getFieldDirectiveUsages :: forall a (f :: * -> *).
GQLType a =>
FieldName -> f a -> [DirectiveUsage]
getFieldDirectiveUsages FieldName
name f a
proxy = forall k a. (Ord k, Hashable k, Empty a) => k -> HashMap k a -> a
getDirHM FieldName
name forall a b. (a -> b) -> a -> b
$ DirectiveUsages -> HashMap FieldName [DirectiveUsage]
fieldDirectives forall a b. (a -> b) -> a -> b
$ forall a (f :: * -> *). GQLType a => f a -> DirectiveUsages
directives f a
proxy
getOptions :: GQLType a => f a -> GQLTypeOptions
getOptions :: forall a (f :: * -> *). GQLType a => f a -> GQLTypeOptions
getOptions f a
proxy = forall a (f :: * -> *).
GQLType a =>
f a -> GQLTypeOptions -> GQLTypeOptions
typeOptions f a
proxy GQLTypeOptions
defaultTypeOptions
deriveEnumDirectives :: GQLType a => f a -> TypeName -> SchemaT c (Directives CONST)
deriveEnumDirectives :: forall a (f :: * -> *) (c :: TypeCategory).
GQLType a =>
f a -> TypeName -> SchemaT c (Directives CONST)
deriveEnumDirectives f a
proxy TypeName
name = forall (c :: TypeCategory).
[DirectiveUsage] -> SchemaT c (Directives CONST)
deriveDirectiveUsages forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter DirectiveUsage -> Bool
isIncluded forall a b. (a -> b) -> a -> b
$ forall a (f :: * -> *).
GQLType a =>
f a -> TypeName -> [DirectiveUsage]
getEnumDirectiveUsages f a
proxy TypeName
name
deriveFieldDirectives :: GQLType a => f a -> FieldName -> SchemaT c (Directives CONST)
deriveFieldDirectives :: forall a (f :: * -> *) (c :: TypeCategory).
GQLType a =>
f a -> FieldName -> SchemaT c (Directives CONST)
deriveFieldDirectives f a
proxy FieldName
name = forall (c :: TypeCategory).
[DirectiveUsage] -> SchemaT c (Directives CONST)
deriveDirectiveUsages forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter DirectiveUsage -> Bool
isIncluded forall a b. (a -> b) -> a -> b
$ forall a (f :: * -> *).
GQLType a =>
FieldName -> f a -> [DirectiveUsage]
getFieldDirectiveUsages FieldName
name f a
proxy
deriveTypeDirectives :: forall c f a. GQLType a => f a -> SchemaT c (Directives CONST)
deriveTypeDirectives :: forall (c :: TypeCategory) (f :: * -> *) a.
GQLType a =>
f a -> SchemaT c (Directives CONST)
deriveTypeDirectives f a
proxy = forall (c :: TypeCategory).
[DirectiveUsage] -> SchemaT c (Directives CONST)
deriveDirectiveUsages forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter DirectiveUsage -> Bool
isIncluded forall a b. (a -> b) -> a -> b
$ DirectiveUsages -> [DirectiveUsage]
typeDirectives forall a b. (a -> b) -> a -> b
$ forall a (f :: * -> *). GQLType a => f a -> DirectiveUsages
directives f a
proxy
visitEnumValueDescription :: GQLType a => f a -> TypeName -> Maybe Description -> Maybe Description
visitEnumValueDescription :: forall a (f :: * -> *).
GQLType a =>
f a -> TypeName -> Maybe Description -> Maybe Description
visitEnumValueDescription f a
proxy TypeName
name Maybe Description
desc = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr DirectiveUsage -> Maybe Description -> Maybe Description
applyEnumDescription Maybe Description
desc (forall a (f :: * -> *).
GQLType a =>
f a -> TypeName -> [DirectiveUsage]
getEnumDirectiveUsages f a
proxy TypeName
name)
visitEnumName :: GQLType a => f a -> TypeName -> TypeName
visitEnumName :: forall a (f :: * -> *). GQLType a => f a -> TypeName -> TypeName
visitEnumName f a
proxy TypeName
name = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr DirectiveUsage -> TypeName -> TypeName
applyEnumName (TypeName -> TypeName
withTypeDirectives forall a b. (a -> b) -> a -> b
$ TypeName -> TypeName
withOptions TypeName
name) (forall a (f :: * -> *).
GQLType a =>
f a -> TypeName -> [DirectiveUsage]
getEnumDirectiveUsages f a
proxy TypeName
name)
where
withOptions :: TypeName -> TypeName
withOptions = forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. GQLTypeOptions -> String -> String
constructorTagModifier (forall a (f :: * -> *). GQLType a => f a -> GQLTypeOptions
getOptions f a
proxy) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToString a => a -> String
toString
withTypeDirectives :: TypeName -> TypeName
withTypeDirectives TypeName
dirName = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr DirectiveUsage -> TypeName -> TypeName
applyTypeEnumNames TypeName
dirName (DirectiveUsages -> [DirectiveUsage]
typeDirectives forall a b. (a -> b) -> a -> b
$ forall a (f :: * -> *). GQLType a => f a -> DirectiveUsages
directives f a
proxy)
visitFieldDescription :: GQLType a => f a -> FieldName -> Maybe Description -> Maybe Description
visitFieldDescription :: forall a (f :: * -> *).
GQLType a =>
f a -> FieldName -> Maybe Description -> Maybe Description
visitFieldDescription f a
proxy FieldName
name Maybe Description
desc = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr DirectiveUsage -> Maybe Description -> Maybe Description
applyFieldDescription Maybe Description
desc (forall a (f :: * -> *).
GQLType a =>
FieldName -> f a -> [DirectiveUsage]
getFieldDirectiveUsages FieldName
name f a
proxy)
applyGQLFieldOptions :: (GQLType a) => f a -> FieldName -> FieldName
applyGQLFieldOptions :: forall a (f :: * -> *). GQLType a => f a -> FieldName -> FieldName
applyGQLFieldOptions f a
proxy = FieldName -> FieldName
withTypeDirectives forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldName -> FieldName
withOptions
where
withOptions :: FieldName -> FieldName
withOptions = forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. GQLTypeOptions -> String -> String
fieldLabelModifier (forall a (f :: * -> *). GQLType a => f a -> GQLTypeOptions
getOptions f a
proxy) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToString a => a -> String
toString
withTypeDirectives :: FieldName -> FieldName
withTypeDirectives FieldName
name = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr DirectiveUsage -> FieldName -> FieldName
applyTypeFieldNames FieldName
name (DirectiveUsages -> [DirectiveUsage]
typeDirectives forall a b. (a -> b) -> a -> b
$ forall a (f :: * -> *). GQLType a => f a -> DirectiveUsages
directives f a
proxy)
visitFieldName :: GQLType a => f a -> FieldName -> FieldName
visitFieldName :: forall a (f :: * -> *). GQLType a => f a -> FieldName -> FieldName
visitFieldName f a
proxy FieldName
name = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr DirectiveUsage -> FieldName -> FieldName
applyFieldName (forall a (f :: * -> *). GQLType a => f a -> FieldName -> FieldName
applyGQLFieldOptions f a
proxy FieldName
name) (forall a (f :: * -> *).
GQLType a =>
FieldName -> f a -> [DirectiveUsage]
getFieldDirectiveUsages FieldName
name f a
proxy)
visitTypeDescription :: GQLType a => f a -> Maybe Description -> Maybe Description
visitTypeDescription :: forall a (f :: * -> *).
GQLType a =>
f a -> Maybe Description -> Maybe Description
visitTypeDescription f a
proxy Maybe Description
desc = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr DirectiveUsage -> Maybe Description -> Maybe Description
applyTypeDescription Maybe Description
desc (DirectiveUsages -> [DirectiveUsage]
typeDirectives forall a b. (a -> b) -> a -> b
$ forall a (f :: * -> *). GQLType a => f a -> DirectiveUsages
directives f a
proxy)
toFieldRes :: GQLType a => f a -> FieldRep v -> (FieldName, v)
toFieldRes :: forall a (f :: * -> *) v.
GQLType a =>
f a -> FieldRep v -> (FieldName, v)
toFieldRes f a
proxy FieldRep {v
TypeRef
FieldName
fieldValue :: forall a. FieldRep a -> a
fieldTypeRef :: forall a. FieldRep a -> TypeRef
fieldSelector :: forall a. FieldRep a -> FieldName
fieldValue :: v
fieldTypeRef :: TypeRef
fieldSelector :: FieldName
..} = (forall a (f :: * -> *). GQLType a => f a -> FieldName -> FieldName
visitFieldName f a
proxy FieldName
fieldSelector, v
fieldValue)