{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE NoImplicitPrelude #-} module Data.Morpheus.Server.Deriving.Schema.Directive ( deriveFieldDirectives, deriveTypeDirectives, deriveEnumDirectives, ) where import Control.Monad.Except (throwError) import qualified Data.HashMap.Lazy as HM import qualified Data.Map as M import Data.Morpheus.CodeGen.Internal.AST (CONST, TypeName) import Data.Morpheus.Internal.Ext (resultOr, unsafeFromList) import Data.Morpheus.Internal.Utils (Empty (..), (<:>)) import Data.Morpheus.Server.Deriving.Utils.Kinded ( KindedProxy (..), ) import Data.Morpheus.Server.Types.Directives ( GQLDirective (..), ToLocations, getLocations, ) import Data.Morpheus.Server.Types.GQLType ( DeriveArguments (..), DirectiveUsage (..), DirectiveUsages (..), GQLType (..), deriveFingerprint, deriveTypename, encodeArguments, ) import Data.Morpheus.Server.Types.SchemaT ( SchemaT, insertDirectiveDefinition, outToAny, ) import Data.Morpheus.Types.Internal.AST ( Directive (..), DirectiveDefinition (..), Directives, FieldName, IN, Position (Position), unpackName, ) 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} {k1} (k2 :: k) (a :: k1). KindedProxy k2 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 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 (DirectiveUsages -> [DirectiveUsage] typeDirectives forall a b. (a -> b) -> a -> b $ forall a (f :: * -> *). GQLType a => f a -> DirectiveUsages directives f a proxy) 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} {k1} (k2 :: k) (a :: k1). KindedProxy k2 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) Arguments CONST directiveArgs <- 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 (Arguments CONST) encodeArguments a x) 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, Arguments CONST directiveArgs :: Arguments CONST directiveArgs :: Arguments CONST directiveArgs } ) 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} {k1} (k2 :: k) (a :: k1). KindedProxy k2 a KindedProxy :: KindedProxy IN a getDir :: (Ord k, Empty a) => k -> Map k a -> a getDir :: forall k a. (Ord k, Empty a) => k -> Map k a -> a getDir k name Map 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 a. Ord k => k -> Map k a -> Maybe a `M.lookup` Map k a xs 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 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 = do Directives CONST dirs <- forall (c :: TypeCategory). [DirectiveUsage] -> SchemaT c (Directives CONST) deriveDirectiveUsages forall a b. (a -> b) -> a -> b $ 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 forall k a. (Ord k, Empty a) => k -> Map k a -> a getDir (forall a (t :: NAME). NamePacking a => Name t -> a unpackName FieldName name) (forall a (f :: * -> *). GQLType a => f a -> Map Description (Directives CONST) getDirectives f a proxy) forall (m :: * -> *) a. (Merge (HistoryT m) a, Monad m) => a -> a -> m a <:> Directives CONST dirs 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 = do Directives CONST dirs <- forall (c :: TypeCategory). [DirectiveUsage] -> SchemaT c (Directives CONST) deriveDirectiveUsages forall a b. (a -> b) -> a -> b $ 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 forall k a. (Ord k, Empty a) => k -> Map k a -> a getDir (forall a (t :: NAME). NamePacking a => Name t -> a unpackName TypeName name) (forall a (f :: * -> *). GQLType a => f a -> Map Description (Directives CONST) getDirectives f a proxy) forall (m :: * -> *) a. (Merge (HistoryT m) a, Monad m) => a -> a -> m a <:> Directives CONST dirs