packages feed

morpheus-graphql-server 0.27.0 → 0.27.1

raw patch · 52 files changed

+2911/−2914 lines, 52 filesdep ~textPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: text

API changes (from Hackage documentation)

- Data.Morpheus.Server.Resolvers: publish :: Monad m => [e] -> Resolver MUTATION e m ()
+ Data.Morpheus.Server.Resolvers: type Composed (m :: Type -> Type) f a :: Type
+ Data.Morpheus.Server.Resolvers: type Flexible (m :: Type -> Type) a :: Type
+ Data.Morpheus.Server.Types: class (MonadResolver m, MonadIO m) => MonadIOResolver (m :: Type -> Type)
+ Data.Morpheus.Server.Types: class (Monad m, MonadReader ResolverContext m, MonadFail m, MonadError GQLError m, Monad MonadParam m) => MonadResolver (m :: Type -> Type) where {
+ Data.Morpheus.Server.Types: getArguments :: MonadResolver m => m (Arguments VALID)
+ Data.Morpheus.Server.Types: liftState :: MonadResolver m => ResolverState a -> m a
+ Data.Morpheus.Server.Types: publish :: MonadResolver m => [MonadEvent m] -> m ()
+ Data.Morpheus.Server.Types: runResolver :: MonadResolver m => Maybe (Selection VALID -> ResolverState (Channel (MonadEvent m))) -> m ValidValue -> ResolverContext -> ResponseStream (MonadEvent m) (MonadParam m) ValidValue
+ Data.Morpheus.Server.Types: type Composed (m :: Type -> Type) f a :: Type
+ Data.Morpheus.Server.Types: type Flexible (m :: Type -> Type) a :: Type
+ Data.Morpheus.Server.Types: type family MonadParam (m :: Type -> Type) :: Type -> Type;
- Data.Morpheus.Server: compileTimeSchemaValidation :: SchemaConstraints event m qu mu su => proxy (root m event qu mu su) -> Q Exp
+ Data.Morpheus.Server: compileTimeSchemaValidation :: SCHEMA qu mu su => proxy (root m event qu mu su) -> Q Exp
- Data.Morpheus.Server: type RootResolverConstraint m e query mutation subscription = (EncodeConstraints e m query mutation subscription, SchemaConstraints e m query mutation subscription, Monad m)
+ Data.Morpheus.Server: type RootResolverConstraint m e query mutation subscription = (DERIVE_RESOLVERS (Resolver QUERY e m) query mutation subscription, SCHEMA query mutation subscription, Monad m)
- Data.Morpheus.Server.Resolvers: constRes :: (WithOperation o, Monad m) => b -> a -> Resolver o e m b
+ Data.Morpheus.Server.Resolvers: constRes :: MonadResolver m => b -> a -> m b
- Data.Morpheus.Server.Resolvers: type ResolverM e m a = Flexible (Resolver MUTATION e m) a
+ Data.Morpheus.Server.Resolvers: type ResolverM e m a = ResolverO MUTATION e m a
- Data.Morpheus.Server.Resolvers: type ResolverQ e m a = Flexible (Resolver QUERY e m) a
+ Data.Morpheus.Server.Resolvers: type ResolverQ e m a = ResolverO QUERY e m a
- Data.Morpheus.Server.Resolvers: type ResolverS e m a = Flexible (Resolver SUBSCRIPTION e m) a
+ Data.Morpheus.Server.Resolvers: type ResolverS e m a = ResolverO SUBSCRIPTION e m a
- Data.Morpheus.Server.Types: subscribe :: forall (m :: Type -> Type) e a. Monad m => Channel e -> Resolver QUERY e m (e -> Resolver SUBSCRIPTION e m a) -> SubscriptionField (Resolver SUBSCRIPTION e m a)
+ Data.Morpheus.Server.Types: subscribe :: (MonadResolver m, MonadOperation m ~ SUBSCRIPTION) => Channel (MonadEvent m) -> MonadQuery m (MonadEvent m -> m a) -> SubscriptionField (m a)

Files

morpheus-graphql-server.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           morpheus-graphql-server-version:        0.27.0+version:        0.27.1 synopsis:       Morpheus GraphQL description:    Build GraphQL APIs with your favourite functional language! category:       web, graphql@@ -312,35 +312,38 @@       Data.Morpheus.Server.Types   other-modules:       Data.Morpheus.Server.Deriving.App-      Data.Morpheus.Server.Deriving.Channels-      Data.Morpheus.Server.Deriving.Decode-      Data.Morpheus.Server.Deriving.Encode-      Data.Morpheus.Server.Deriving.Named.Encode-      Data.Morpheus.Server.Deriving.Named.EncodeType-      Data.Morpheus.Server.Deriving.Named.EncodeValue+      Data.Morpheus.Server.Deriving.Internal.Decode.Rep+      Data.Morpheus.Server.Deriving.Internal.Decode.Utils+      Data.Morpheus.Server.Deriving.Internal.Resolve.Explore+      Data.Morpheus.Server.Deriving.Internal.Schema.Directive+      Data.Morpheus.Server.Deriving.Internal.Schema.Enum+      Data.Morpheus.Server.Deriving.Internal.Schema.Internal+      Data.Morpheus.Server.Deriving.Internal.Schema.Object+      Data.Morpheus.Server.Deriving.Internal.Schema.Type+      Data.Morpheus.Server.Deriving.Internal.Schema.Union+      Data.Morpheus.Server.Deriving.Kinded.Arguments+      Data.Morpheus.Server.Deriving.Kinded.Channels+      Data.Morpheus.Server.Deriving.Kinded.NamedResolver+      Data.Morpheus.Server.Deriving.Kinded.NamedResolverFun+      Data.Morpheus.Server.Deriving.Kinded.Resolver+      Data.Morpheus.Server.Deriving.Kinded.Type+      Data.Morpheus.Server.Deriving.Kinded.Value+      Data.Morpheus.Server.Deriving.Resolvers       Data.Morpheus.Server.Deriving.Schema-      Data.Morpheus.Server.Deriving.Schema.DeriveKinded-      Data.Morpheus.Server.Deriving.Schema.Directive-      Data.Morpheus.Server.Deriving.Schema.Enum-      Data.Morpheus.Server.Deriving.Schema.Internal-      Data.Morpheus.Server.Deriving.Schema.Object-      Data.Morpheus.Server.Deriving.Schema.TypeContent-      Data.Morpheus.Server.Deriving.Schema.Union-      Data.Morpheus.Server.Deriving.Utils-      Data.Morpheus.Server.Deriving.Utils.Decode-      Data.Morpheus.Server.Deriving.Utils.DeriveGType-      Data.Morpheus.Server.Deriving.Utils.GTraversable+      Data.Morpheus.Server.Deriving.Utils.AST+      Data.Morpheus.Server.Deriving.Utils.Gmap+      Data.Morpheus.Server.Deriving.Utils.GRep+      Data.Morpheus.Server.Deriving.Utils.GScan       Data.Morpheus.Server.Deriving.Utils.Kinded       Data.Morpheus.Server.Deriving.Utils.Proxy-      Data.Morpheus.Server.Deriving.Utils.Types       Data.Morpheus.Server.Deriving.Utils.Use-      Data.Morpheus.Server.NamedResolvers       Data.Morpheus.Server.Playground       Data.Morpheus.Server.Types.DirectiveDefinitions       Data.Morpheus.Server.Types.Directives       Data.Morpheus.Server.Types.GQLType       Data.Morpheus.Server.Types.Internal       Data.Morpheus.Server.Types.Kind+      Data.Morpheus.Server.Types.NamedResolvers       Data.Morpheus.Server.Types.SchemaT       Data.Morpheus.Server.Types.TypeName       Data.Morpheus.Server.Types.Types@@ -359,7 +362,7 @@     , mtl >=2.0.0 && <3.0.0     , relude >=0.3.0 && <2.0.0     , template-haskell >=2.0.0 && <3.0.0-    , text >=1.2.3 && <1.3.0+    , text >=1.2.3 && <2.1.0     , transformers >=0.3.0 && <0.6.0     , unordered-containers >=0.2.8 && <0.3.0     , vector >=0.12.0.1 && <0.13.0@@ -418,7 +421,7 @@     , tasty >=0.1.0 && <1.5.0     , tasty-hunit >=0.1.0 && <1.0.0     , template-haskell >=2.0.0 && <3.0.0-    , text >=1.2.3 && <1.3.0+    , text >=1.2.3 && <2.1.0     , transformers >=0.3.0 && <0.6.0     , unordered-containers >=0.2.8 && <0.3.0     , vector >=0.12.0.1 && <0.13.0
src/Data/Morpheus/Server/Deriving/App.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TupleSections #-}@@ -22,33 +23,31 @@ import Data.Morpheus.App.Internal.Resolving   ( resultOr,   )-import Data.Morpheus.Server.Deriving.Encode-  ( EncodeConstraints,-    deriveModel,-  )-import Data.Morpheus.Server.Deriving.Named.Encode-  ( EncodeNamedConstraints,-    deriveNamedModel,+import Data.Morpheus.Server.Deriving.Resolvers+  ( DERIVE_NAMED_RESOLVERS,+    DERIVE_RESOLVERS,+    deriveNamedResolvers,+    deriveResolvers,   ) import Data.Morpheus.Server.Deriving.Schema-  ( SchemaConstraints,+  ( SCHEMA,     deriveSchema,   ) import Data.Morpheus.Server.Resolvers   ( NamedResolvers,-    RootResolver (..),   )+import Data.Morpheus.Server.Types import Relude  type RootResolverConstraint m e query mutation subscription =-  ( EncodeConstraints e m query mutation subscription,-    SchemaConstraints e m query mutation subscription,+  ( DERIVE_RESOLVERS (Resolver QUERY e m) query mutation subscription,+    SCHEMA query mutation subscription,     Monad m   )  type NamedResolversConstraint m e query mutation subscription =-  ( EncodeNamedConstraints e m query mutation subscription,-    SchemaConstraints e m query mutation subscription,+  ( DERIVE_NAMED_RESOLVERS (Resolver QUERY e m) query,+    SCHEMA query mutation subscription,     Monad m   ) @@ -65,10 +64,8 @@  instance RootResolverConstraint m e query mut sub => DeriveApp RootResolver m e query mut sub where   deriveApp root =-    resultOr FailApp (uncurry mkApp) $-      (,) <$> deriveSchema (Identity root) <*> deriveModel root+    resultOr FailApp (uncurry mkApp) $ (,) <$> deriveSchema (Identity root) <*> deriveResolvers root  instance NamedResolversConstraint m e query mut sub => DeriveApp NamedResolvers m e query mut sub where   deriveApp root =-    resultOr FailApp (uncurry mkApp) $-      (,deriveNamedModel root) <$> deriveSchema (Identity root)+    resultOr FailApp (uncurry mkApp) $ (,deriveNamedResolvers root) <$> deriveSchema (Identity root)
− src/Data/Morpheus/Server/Deriving/Channels.hs 
@@ -1,151 +0,0 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE NoImplicitPrelude #-}--module Data.Morpheus.Server.Deriving.Channels-  ( channelResolver,-    ChannelsConstraint,-  )-where--import Control.Monad.Except (throwError)-import qualified Data.HashMap.Lazy as HM-import Data.Morpheus.App.Internal.Resolving-  ( Channel,-    Resolver,-    ResolverState,-    SubscriptionField (..),-  )-import Data.Morpheus.Internal.Utils-  ( selectBy,-  )-import Data.Morpheus.Server.Deriving.Decode-  ( Decode,-    decodeArguments,-  )-import Data.Morpheus.Server.Deriving.Schema.Directive (toFieldRes)-import Data.Morpheus.Server.Deriving.Utils-  ( ConsRep (..),-    DataType (..),-  )-import Data.Morpheus.Server.Deriving.Utils.DeriveGType-  ( DeriveValueOptions (..),-    DeriveWith,-    deriveValue,-  )-import Data.Morpheus.Server.Deriving.Utils.Kinded (CatType (..), outputType)-import Data.Morpheus.Server.Types.GQLType (GQLType, deriveTypename, withDir, __typeData)-import Data.Morpheus.Server.Types.Types (Undefined)-import Data.Morpheus.Types.Internal.AST-  ( FieldName,-    OUT,-    SUBSCRIPTION,-    Selection (..),-    SelectionContent (..),-    VALID,-    internal,-  )-import GHC.Generics-import Relude hiding (Undefined)--newtype DerivedChannel e = DerivedChannel-  { _unpackChannel :: Channel e-  }--type ChannelRes (e :: Type) = Selection VALID -> ResolverState (DerivedChannel e)--type ChannelsConstraint e m (subs :: (Type -> Type) -> Type) =-  ExploreChannels (IsUndefined (subs (Resolver SUBSCRIPTION e m))) e (subs (Resolver SUBSCRIPTION e m))--channelResolver ::-  forall e m subs.-  ChannelsConstraint e m subs =>-  subs (Resolver SUBSCRIPTION e m) ->-  Selection VALID ->-  ResolverState (Channel e)-channelResolver value = fmap _unpackChannel . channelSelector-  where-    channelSelector ::-      Selection VALID ->-      ResolverState (DerivedChannel e)-    channelSelector =-      selectBySelection-        ( exploreChannels-            (Proxy @(IsUndefined (subs (Resolver SUBSCRIPTION e m))))-            value-        )--selectBySelection ::-  HashMap FieldName (ChannelRes e) ->-  Selection VALID ->-  ResolverState (DerivedChannel e)-selectBySelection channels = withSubscriptionSelection >=> selectSubscription channels--selectSubscription ::-  HashMap FieldName (ChannelRes e) ->-  Selection VALID ->-  ResolverState (DerivedChannel e)-selectSubscription channels sel@Selection {selectionName} =-  selectBy-    (internal "invalid subscription: no channel is selected.")-    selectionName-    channels-    >>= (sel &)--withSubscriptionSelection :: Selection VALID -> ResolverState (Selection VALID)-withSubscriptionSelection Selection {selectionContent = SelectionSet selSet} =-  case toList selSet of-    [sel] -> pure sel-    _ -> throwError (internal "invalid subscription: there can be only one top level selection")-withSubscriptionSelection _ = throwError (internal "invalid subscription: expected selectionSet")--class GetChannel e a | a -> e where-  getChannel :: a -> ChannelRes e--instance GetChannel e (SubscriptionField (Resolver SUBSCRIPTION e m a)) where-  getChannel x = const $ pure $ DerivedChannel $ channel x--instance-  Decode arg =>-  GetChannel e (arg -> SubscriptionField (Resolver SUBSCRIPTION e m a))-  where-  getChannel f sel@Selection {selectionArguments} =-    decodeArguments selectionArguments-      >>= (`getChannel` sel)-        . f----------------------------------------------------------type family IsUndefined a :: Bool where-  IsUndefined (Undefined m) = 'True-  IsUndefined a = 'False--class ExploreChannels (t :: Bool) e a where-  exploreChannels :: f t -> a -> HashMap FieldName (ChannelRes e)--instance (GQLType a, Generic a, DeriveWith GQLType (GetChannel e) (ChannelRes e) (Rep a)) => ExploreChannels 'False e a where-  exploreChannels _ =-    HM.fromList-      . map (toFieldRes withDir (Proxy @a))-      . consFields-      . tyCons-      . deriveValue-        ( DeriveValueOptions-            { __valueApply = getChannel,-              __valueTypeName = deriveTypename (OutputType :: CatType OUT a),-              __valueGetType = __typeData . outputType-            } ::-            DeriveValueOptions OUT GQLType (GetChannel e) (ChannelRes e)-        )--instance ExploreChannels 'True e (Undefined m) where-  exploreChannels _ = pure HM.empty
− src/Data/Morpheus/Server/Deriving/Decode.hs 
@@ -1,205 +0,0 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE NoImplicitPrelude #-}--module Data.Morpheus.Server.Deriving.Decode-  ( decodeArguments,-    Decode,-    decode,-  )-where--import Control.Monad.Except (MonadError (throwError))-import qualified Data.Map as M-import Data.Morpheus.App.Internal.Resolving-  ( ResolverState,-  )-import Data.Morpheus.Server.Deriving.Schema.Directive (visitEnumName, visitFieldName)-import Data.Morpheus.Server.Deriving.Utils-  ( selNameProxy,-    symbolName,-  )-import Data.Morpheus.Server.Deriving.Utils.Decode-  ( Context (..),-    DecoderT,-    DescribeCons,-    DescribeFields (countFields),-    decodeFieldWith,-    getFieldName,-    getUnionInfos,-    handleEither,-    setVariantRef,-    withInputObject,-    withInputUnion,-    withScalar,-  )-import Data.Morpheus.Server.Deriving.Utils.Kinded-  ( CatType (..),-  )-import Data.Morpheus.Server.Types.GQLType-  ( GQLType (..),-    deriveTypename,-    withDir,-  )-import Data.Morpheus.Server.Types.Kind-  ( CUSTOM,-    DerivingKind,-    SCALAR,-    TYPE,-    WRAPPER,-  )-import Data.Morpheus.Server.Types.Types (Arg (Arg))-import Data.Morpheus.Types.GQLScalar-  ( DecodeScalar (..),-  )-import Data.Morpheus.Types.GQLWrapper-  ( DecodeWrapper (..),-    DecodeWrapperConstraint,-  )-import Data.Morpheus.Types.Internal.AST-  ( Argument (..),-    Arguments,-    IN,-    Object,-    ObjectEntry (..),-    TypeName,-    VALID,-    ValidObject,-    ValidValue,-    Value (..),-    internal,-    msg,-  )-import GHC.Generics-import GHC.TypeLits (KnownSymbol)-import Relude---- GENERIC-decodeArguments :: forall a. Decode a => Arguments VALID -> ResolverState a-decodeArguments = decode . Object . fmap toEntry-  where-    toEntry Argument {..} = ObjectEntry argumentName argumentValue--type Decode a = (DecodeKind (KIND a) a)--decode :: forall a. Decode a => ValidValue -> ResolverState a-decode = decodeKind (Proxy @(KIND a))---- | Decode GraphQL type with Specific Kind-class DecodeKind (kind :: DerivingKind) a where-  decodeKind :: Proxy kind -> ValidValue -> ResolverState a---- SCALAR-instance (DecodeScalar a, GQLType a) => DecodeKind SCALAR a where-  decodeKind _ = withScalar (deriveTypename (InputType :: CatType IN a)) decodeScalar---- INPUT_OBJECT and  INPUT_UNION-instance (Generic a, GQLType a, DecodeRep (Rep a)) => DecodeKind TYPE a where-  decodeKind _ = fmap to . (`runReaderT` context) . decodeRep-    where-      context =-        Context-          { isVariantRef = False,-            typeName = deriveTypename (InputType :: CatType IN a),-            enumVisitor = visitEnumName withDir proxy,-            fieldVisitor = visitFieldName withDir proxy-          }-        where-          proxy = Proxy @a--instance (Decode a, DecodeWrapperConstraint f a, DecodeWrapper f) => DecodeKind WRAPPER (f a) where-  decodeKind _ value =-    runExceptT (decodeWrapper decode value)-      >>= handleEither--instance (Decode a, KnownSymbol name) => DecodeKind CUSTOM (Arg name a) where-  decodeKind _ value = Arg <$> withInputObject fieldDecoder value-    where-      fieldDecoder = decodeFieldWith decode fieldName-      fieldName = symbolName (Proxy @name)----  Map-instance (Ord k, Decode (k, v)) => DecodeKind CUSTOM (Map k v) where-  decodeKind _ v = M.fromList <$> (decode v :: ResolverState [(k, v)])--decideEither ::-  (DecodeRep f, DecodeRep g) =>-  ([TypeName], [TypeName]) ->-  TypeName ->-  ValidValue ->-  DecoderT ((f :+: g) a)-decideEither (left, right) name value-  | name `elem` left = L1 <$> decodeRep value-  | name `elem` right = R1 <$> decodeRep value-  | otherwise =-      throwError $-        internal $-          "Constructor \""-            <> msg name-            <> "\" could not find in Union"--decodeInputUnionObject ::-  (DecodeRep f, DecodeRep g) =>-  ([TypeName], [TypeName]) ->-  TypeName ->-  Object VALID ->-  ValidObject ->-  DecoderT ((f :+: g) a)-decodeInputUnionObject (l, r) name unions object-  | [name] == l = L1 <$> decodeRep (Object object)-  | [name] == r = R1 <$> decodeRep (Object object)-  | otherwise = decideEither (l, r) name (Object unions)--class DecodeRep (f :: Type -> Type) where-  decodeRep :: ValidValue -> DecoderT (f a)--instance (Datatype d, DecodeRep f) => DecodeRep (M1 D d f) where-  decodeRep value = M1 <$> decodeRep value--instance (DescribeCons a, DescribeCons b, DecodeRep a, DecodeRep b) => DecodeRep (a :+: b) where-  decodeRep (Object obj) =-    do-      (kind, lr) <- getUnionInfos (Proxy @(a :+: b))-      setVariantRef kind $ withInputUnion (decodeInputUnionObject lr) obj-  decodeRep (Enum name) = do-    (_, (l, r)) <- getUnionInfos (Proxy @(a :+: b))-    visitor <- asks enumVisitor-    decideEither (map visitor l, map visitor r) name (Enum name)-  decodeRep _ = throwError (internal "lists and scalars are not allowed in Union")--instance (Constructor c, DecodeFields a) => DecodeRep (M1 C c a) where-  decodeRep = fmap M1 . decodeFields 0--class DecodeFields (f :: Type -> Type) where-  decodeFields :: Int -> ValidValue -> DecoderT (f a)--instance (DecodeFields f, DecodeFields g, DescribeFields g) => DecodeFields (f :*: g) where-  decodeFields index gql =-    (:*:)-      <$> decodeFields index gql-      <*> decodeFields (index + countFields (Proxy @g)) gql--instance (Selector s, GQLType a, Decode a) => DecodeFields (M1 S s (K1 i a)) where-  decodeFields index value =-    M1 . K1 <$> do-      Context {isVariantRef, fieldVisitor} <- ask-      if isVariantRef-        then lift (decode value)-        else-          let fieldName = fieldVisitor $ getFieldName (selNameProxy (Proxy @s)) index-              fieldDecoder = decodeFieldWith (lift . decode) fieldName-           in withInputObject fieldDecoder value--instance DecodeFields U1 where-  decodeFields _ _ = pure U1
− src/Data/Morpheus/Server/Deriving/Encode.hs 
@@ -1,261 +0,0 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE NoImplicitPrelude #-}--module Data.Morpheus.Server.Deriving.Encode-  ( deriveModel,-    EncodeConstraints,-    ContextValue (..),-  )-where--import Control.Monad.Except (MonadError)-import qualified Data.Map as M-import Data.Morpheus.App.Internal.Resolving-  ( LiftOperation,-    ObjectTypeResolver,-    Resolver,-    ResolverState,-    ResolverValue (..),-    RootResolverValue (..),-    getArguments,-    liftResolverState,-    mkEnum,-    mkObject,-    mkUnion,-    requireObject,-  )-import Data.Morpheus.Internal.Ext (GQLResult)-import Data.Morpheus.Server.Deriving.Channels-  ( ChannelsConstraint,-    channelResolver,-  )-import Data.Morpheus.Server.Deriving.Decode-  ( Decode,-    decodeArguments,-  )-import Data.Morpheus.Server.Deriving.Schema.Directive (toFieldRes, visitEnumName)-import Data.Morpheus.Server.Deriving.Utils-  ( ConsRep (..),-    DataType (..),-    FieldRep (..),-    isUnionRef,-  )-import Data.Morpheus.Server.Deriving.Utils.DeriveGType-  ( DeriveValueOptions (..),-    DeriveWith,-    deriveValue,-  )-import Data.Morpheus.Server.Deriving.Utils.Kinded-  ( CatType (..),-    inputType,-  )-import Data.Morpheus.Server.Resolvers-  ( RootResolver (..),-  )-import Data.Morpheus.Server.Types.GQLType-  ( GQLType,-    KIND,-    deriveTypename,-    withDir,-    __isEmptyType,-    __typeData,-  )-import Data.Morpheus.Server.Types.Kind-  ( CUSTOM,-    DerivingKind,-    SCALAR,-    TYPE,-    WRAPPER,-  )-import Data.Morpheus.Server.Types.Types-  ( TypeGuard (..),-  )-import Data.Morpheus.Types.GQLScalar-  ( EncodeScalar (..),-  )-import Data.Morpheus.Types.GQLWrapper (EncodeWrapper (..))-import Data.Morpheus.Types.Internal.AST-  ( GQLError,-    IN,-    MUTATION,-    OperationType,-    QUERY,-    SUBSCRIPTION,-    TypeRef (..),-  )-import GHC.Generics-  ( Generic (..),-  )-import Relude--newtype ContextValue (kind :: DerivingKind) a = ContextValue-  { unContextValue :: a-  }--class Encode (m :: Type -> Type) resolver where-  encode :: resolver -> m (ResolverValue m)--instance (EncodeKind (KIND a) m a) => Encode m a where-  encode resolver = encodeKind (ContextValue resolver :: ContextValue (KIND a) a)---- ENCODE GQL KIND-class EncodeKind (kind :: DerivingKind) (m :: Type -> Type) (a :: Type) where-  encodeKind :: ContextValue kind a -> m (ResolverValue m)--instance-  ( EncodeWrapper f,-    Encode m a,-    Monad m-  ) =>-  EncodeKind WRAPPER m (f a)-  where-  encodeKind = encodeWrapper encode . unContextValue--instance-  ( EncodeScalar a,-    Monad m-  ) =>-  EncodeKind SCALAR m a-  where-  encodeKind = pure . ResScalar . encodeScalar . unContextValue--instance-  ( EncodeConstraint m a,-    MonadError GQLError m-  ) =>-  EncodeKind TYPE m a-  where-  encodeKind = pure . exploreResolvers . unContextValue----  Map-instance (Monad m, Encode m [(k, v)]) => EncodeKind CUSTOM m (Map k v) where-  encodeKind = encode . M.toList . unContextValue----  INTERFACE Types-instance (MonadError GQLError m, EncodeConstraint m guard, EncodeConstraint m union) => EncodeKind CUSTOM m (TypeGuard guard union) where-  encodeKind (ContextValue (ResolveType value)) = pure (exploreResolvers value)-  encodeKind (ContextValue (ResolveInterface value)) = pure (exploreResolvers value)----  GQL a -> Resolver b, MUTATION, SUBSCRIPTION, QUERY-instance-  ( Decode a,-    Generic a,-    Monad m,-    Encode (Resolver o e m) b,-    LiftOperation o-  ) =>-  EncodeKind CUSTOM (Resolver o e m) (a -> b)-  where-  encodeKind (ContextValue f) =-    getArguments-      >>= liftResolverState . decodeArguments-      >>= encode . f----  GQL a -> Resolver b, MUTATION, SUBSCRIPTION, QUERY-instance-  (Monad m, Encode (Resolver o e m) b, LiftOperation o) =>-  EncodeKind CUSTOM (Resolver o e m) (Resolver o e m b)-  where-  encodeKind (ContextValue value) = value >>= encode--convertNode ::-  forall m f a.-  (MonadError GQLError m, GQLType a) =>-  f a ->-  DataType (m (ResolverValue m)) ->-  ResolverValue m-convertNode-  proxy-  DataType-    { dataTypeName,-      tyIsUnion,-      tyCons = cons@ConsRep {consFields, consName}-    } = encodeTypeFields consFields-    where-      -- ENUM-      encodeTypeFields ::-        [FieldRep (m (ResolverValue m))] ->-        ResolverValue m-      encodeTypeFields [] = mkEnum (visitEnumName withDir proxy consName)-      encodeTypeFields fields-        | not tyIsUnion = mkObject dataTypeName (toFieldRes withDir proxy <$> fields)-      -- Type References ---------------------------------------------------------------      encodeTypeFields [FieldRep {fieldTypeRef, fieldValue}]-        | isUnionRef dataTypeName cons = ResLazy (ResObject (Just (typeConName fieldTypeRef)) <$> (fieldValue >>= requireObject))-      -- Inline Union Types -----------------------------------------------------------------------------      encodeTypeFields fields = mkUnion consName (toFieldRes withDir proxy <$> fields)---- Types & Constrains ---------------------------------------------------------exploreResolvers ::-  forall m a.-  ( EncodeConstraint m a,-    MonadError GQLError m-  ) =>-  a ->-  ResolverValue m-exploreResolvers =-  convertNode (Proxy @a)-    . deriveValue-      ( DeriveValueOptions-          { __valueApply = encode,-            __valueTypeName = deriveTypename (InputType :: CatType IN a),-            __valueGetType = __typeData . inputType-          } ::-          DeriveValueOptions IN GQLType (Encode m) (m (ResolverValue m))-      )------- HELPERS -----------------------------objectResolvers ::-  ( EncodeConstraint m a,-    MonadError GQLError m-  ) =>-  a ->-  ResolverState (ObjectTypeResolver m)-objectResolvers value = requireObject (exploreResolvers value)--type EncodeConstraint (m :: Type -> Type) a =-  ( GQLType a,-    Generic a,-    DeriveWith GQLType (Encode m) (m (ResolverValue m)) (Rep a)-  )--type EncodeObjectConstraint (o :: OperationType) e (m :: Type -> Type) a =-  EncodeConstraint (Resolver o e m) (a (Resolver o e m))--type EncodeConstraints e m query mut sub =-  ( ChannelsConstraint e m sub,-    EncodeObjectConstraint QUERY e m query,-    EncodeObjectConstraint MUTATION e m mut,-    EncodeObjectConstraint SUBSCRIPTION e m sub-  )--deriveModel ::-  forall e m query mut sub.-  (Monad m, EncodeConstraints e m query mut sub) =>-  RootResolver m e query mut sub ->-  GQLResult (RootResolverValue e m)-deriveModel RootResolver {..} =-  pure-    RootResolverValue-      { queryResolver = objectResolvers queryResolver,-        mutationResolver = objectResolvers mutationResolver,-        subscriptionResolver = objectResolvers subscriptionResolver,-        channelMap-      }-  where-    channelMap-      | __isEmptyType (Proxy :: Proxy (sub (Resolver SUBSCRIPTION e m))) = Nothing-      | otherwise = Just (channelResolver subscriptionResolver)
+ src/Data/Morpheus/Server/Deriving/Internal/Decode/Rep.hs view
@@ -0,0 +1,121 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.Server.Deriving.Internal.Decode.Rep+  ( DecodeRep (..),+  )+where++import Control.Monad.Except (MonadError (throwError))+import Data.Morpheus.Server.Deriving.Internal.Decode.Utils+  ( Context (..),+    CountFields (..),+    DecoderT,+    DescribeCons,+    decodeFieldWith,+    getFieldName,+    getUnionInfos,+    setVariantRef,+    withInputObject,+    withInputUnion,+  )+import Data.Morpheus.Server.Deriving.Utils.Proxy+  ( selNameProxy,+  )+import Data.Morpheus.Server.Deriving.Utils.Use+  ( UseDeriving (..),+    UseValue (..),+  )+import Data.Morpheus.Types.Internal.AST+  ( Object,+    TypeName,+    VALID,+    ValidObject,+    ValidValue,+    Value (..),+    internal,+    msg,+  )+import GHC.Generics+import Relude++decideEither ::+  (DecodeRep gql args f, DecodeRep gql args g) =>+  UseDeriving gql args ->+  ([TypeName], [TypeName]) ->+  TypeName ->+  ValidValue ->+  DecoderT ((f :+: g) a)+decideEither dir (left, right) name value+  | name `elem` left = L1 <$> decodeRep dir value+  | name `elem` right = R1 <$> decodeRep dir value+  | otherwise =+      throwError $+        internal $+          "Constructor \""+            <> msg name+            <> "\" could not find in Union"++decodeInputUnionObject ::+  (DecodeRep gql args f, DecodeRep gql args g) =>+  UseDeriving gql args ->+  ([TypeName], [TypeName]) ->+  TypeName ->+  Object VALID ->+  ValidObject ->+  DecoderT ((f :+: g) a)+decodeInputUnionObject dir (l, r) name unions object+  | [name] == l = L1 <$> decodeRep dir (Object object)+  | [name] == r = R1 <$> decodeRep dir (Object object)+  | otherwise = decideEither dir (l, r) name (Object unions)++class DecodeRep gql args (f :: Type -> Type) where+  decodeRep :: UseDeriving gql args -> ValidValue -> DecoderT (f a)++instance (Datatype d, DecodeRep gql args f) => DecodeRep gql args (M1 D d f) where+  decodeRep dir value = M1 <$> decodeRep dir value++instance (DescribeCons gql a, DescribeCons gql b, DecodeRep gql args a, DecodeRep gql args b) => DecodeRep gql args (a :+: b) where+  decodeRep dir (Object obj) =+    do+      (kind, lr) <- getUnionInfos (dirGQL dir) (Proxy @(a :+: b))+      setVariantRef kind $ withInputUnion (decodeInputUnionObject dir lr) obj+  decodeRep dir (Enum name) = do+    (_, (l, r)) <- getUnionInfos (dirGQL dir) (Proxy @(a :+: b))+    visitor <- asks enumVisitor+    decideEither dir (map visitor l, map visitor r) name (Enum name)+  decodeRep _ _ = throwError (internal "lists and scalars are not allowed in Union")++instance (Constructor c, DecodeFields gql args a) => DecodeRep gql args (M1 C c a) where+  decodeRep dir = fmap M1 . decodeFields dir 0++class DecodeFields gql args (f :: Type -> Type) where+  decodeFields :: UseDeriving gql args -> Int -> ValidValue -> DecoderT (f a)++instance (DecodeFields gql args f, DecodeFields gql args g, CountFields g) => DecodeFields gql args (f :*: g) where+  decodeFields dir index gql =+    (:*:)+      <$> decodeFields dir index gql+      <*> decodeFields dir (index + countFields (Proxy @g)) gql++instance (Selector s, args a) => DecodeFields gql args (M1 S s (K1 i a)) where+  decodeFields UseDeriving {dirArgs} index value =+    M1 . K1 <$> do+      Context {isVariantRef, fieldVisitor} <- ask+      if isVariantRef+        then lift (useDecodeValue dirArgs value)+        else+          let fieldName = fieldVisitor $ getFieldName (selNameProxy (Proxy @s)) index+              fieldDecoder = decodeFieldWith (lift . useDecodeValue dirArgs) fieldName+           in withInputObject fieldDecoder value++instance DecodeFields gql args U1 where+  decodeFields _ _ _ = pure U1
+ src/Data/Morpheus/Server/Deriving/Internal/Decode/Utils.hs view
@@ -0,0 +1,239 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.Server.Deriving.Internal.Decode.Utils+  ( withInputObject,+    withEnum,+    withInputUnion,+    decodeFieldWith,+    withScalar,+    handleEither,+    getFieldName,+    DecoderT,+    setVariantRef,+    Context (..),+    getUnionInfos,+    DescribeCons,+    CountFields (..),+    RefType (..),+    repValue,+    useDecodeArguments,+  )+where++import Control.Monad.Except (MonadError (throwError))+import Data.Morpheus.App.Internal.Resolving (ResolverState)+import Data.Morpheus.Internal.Ext (GQLResult)+import Data.Morpheus.Internal.Utils+  ( fromElems,+    selectOr,+  )+import Data.Morpheus.Server.Deriving.Utils.AST (argumentsToObject)+import Data.Morpheus.Server.Deriving.Utils.GRep+  ( ConsRep (..),+    FieldRep (..),+    TypeRep (..),+  )+import Data.Morpheus.Server.Deriving.Utils.Kinded+  ( CatType (..),+  )+import Data.Morpheus.Server.Deriving.Utils.Proxy+  ( conNameProxy,+  )+import Data.Morpheus.Server.Deriving.Utils.Use (UseDeriving, UseGQLType (useTypename), UseValue (..), dirArgs)+import Data.Morpheus.Types.GQLScalar+  ( toScalar,+  )+import Data.Morpheus.Types.Internal.AST+  ( Arguments,+    CONST,+    FieldName,+    GQLError,+    IN,+    Msg (msg),+    ObjectEntry (..),+    ScalarValue,+    Token,+    TypeName,+    VALID,+    ValidObject,+    ValidValue,+    Value (..),+    getInputUnionValue,+    internal,+  )+import GHC.Generics+import Relude++repValue ::+  TypeRep (GQLResult (Value CONST)) ->+  GQLResult (Value CONST)+repValue+  TypeRep+    { tyIsUnion,+      tyCons = ConsRep {consFields, consName}+    } = encodeTypeFields consFields+    where+      encodeTypeFields ::+        [FieldRep (GQLResult (Value CONST))] -> GQLResult (Value CONST)+      encodeTypeFields [] = pure $ Enum consName+      encodeTypeFields fields | not tyIsUnion = Object <$> (traverse fromField fields >>= fromElems)+        where+          fromField FieldRep {fieldSelector, fieldValue} = do+            entryValue <- fieldValue+            pure ObjectEntry {entryName = fieldSelector, entryValue}+      -- Type References --------------------------------------------------------------+      encodeTypeFields _ = throwError (internal "input unions are not supported")++withInputObject ::+  MonadError GQLError m =>+  (ValidObject -> m a) ->+  ValidValue ->+  m a+withInputObject f (Object object) = f object+withInputObject _ isType = throwError (typeMismatch "InputObject" isType)++-- | Useful for more restrictive instances of lists (non empty, size indexed etc)+withEnum :: MonadError GQLError m => (TypeName -> m a) -> Value VALID -> m a+withEnum decode (Enum value) = decode value+withEnum _ isType = throwError (typeMismatch "Enum" isType)++withInputUnion ::+  (MonadError GQLError m, Monad m) =>+  (TypeName -> ValidObject -> ValidObject -> m a) ->+  ValidObject ->+  m a+withInputUnion decoder unions =+  either onFail onSuccess (getInputUnionValue unions)+  where+    onSuccess (name, value) = withInputObject (decoder name unions) value+    onFail = throwError . internal . msg++withScalar ::+  (Applicative m, MonadError GQLError m) =>+  TypeName ->+  (ScalarValue -> Either Token a) ->+  Value VALID ->+  m a+withScalar typename decodeScalar value = case toScalar value >>= decodeScalar of+  Right scalar -> pure scalar+  Left message ->+    throwError+      ( typeMismatch+          ("SCALAR(" <> msg typename <> ")" <> msg message)+          value+      )++decodeFieldWith :: (Value VALID -> m a) -> FieldName -> ValidObject -> m a+decodeFieldWith decoder = selectOr (decoder Null) (decoder . entryValue)++handleEither :: MonadError GQLError m => Either GQLError a -> m a+handleEither = either throwError pure++-- if value is already validated but value has different type+typeMismatch :: GQLError -> Value s -> GQLError+typeMismatch text jsType =+  internal $+    "Type mismatch! expected:"+      <> text+      <> ", got: "+      <> msg jsType++getFieldName :: FieldName -> Int -> FieldName+getFieldName "" index = "_" <> show index+getFieldName label _ = label++data VariantKind = InlineVariant | VariantRef deriving (Eq, Ord)++data Info = Info+  { kind :: VariantKind,+    tagName :: [TypeName]+  }++instance Semigroup Info where+  Info VariantRef t1 <> Info _ t2 = Info VariantRef (t1 <> t2)+  Info _ t1 <> Info VariantRef t2 = Info VariantRef (t1 <> t2)+  Info InlineVariant t1 <> Info InlineVariant t2 = Info InlineVariant (t1 <> t2)++data Context = Context+  { isVariantRef :: Bool,+    typeName :: TypeName,+    enumVisitor :: TypeName -> TypeName,+    fieldVisitor :: FieldName -> FieldName+  }++type DecoderT = ReaderT Context ResolverState++setVariantRef :: Bool -> DecoderT a -> DecoderT a+setVariantRef isVariantRef = local (\ctx -> ctx {isVariantRef})++class DescribeCons gql (f :: Type -> Type) where+  tags :: UseGQLType gql -> Proxy f -> Context -> Info++instance (Datatype d, DescribeCons gql f) => DescribeCons gql (M1 D d f) where+  tags ctx _ = tags ctx (Proxy @f)++instance (DescribeCons gql a, DescribeCons gql b) => DescribeCons gql (a :+: b) where+  tags ctx _ = tags ctx (Proxy @a) <> tags ctx (Proxy @b)++instance (Constructor c, CountFields a, RefType gql a) => DescribeCons gql (M1 C c a) where+  tags ctx _ Context {typeName} = getTag (refType ctx (Proxy @a))+    where+      getTag (Just memberRef)+        | isUnionRef memberRef = Info {kind = VariantRef, tagName = [memberRef]}+        | otherwise = Info {kind = InlineVariant, tagName = [consName]}+      getTag Nothing = Info {kind = InlineVariant, tagName = [consName]}+      --------+      consName = conNameProxy (Proxy @c)+      ----------+      isUnionRef x = typeName <> x == consName++getUnionInfos ::+  forall f a b gql.+  (DescribeCons gql a, DescribeCons gql b) =>+  UseGQLType gql ->+  f (a :+: b) ->+  DecoderT (Bool, ([TypeName], [TypeName]))+getUnionInfos ctx _ = do+  context <- ask+  let l = tags ctx (Proxy @a) context+  let r = tags ctx (Proxy @b) context+  let k = kind (l <> r)+  pure (k == VariantRef, (tagName l, tagName r))++class RefType gql (f :: Type -> Type) where+  refType :: UseGQLType gql -> Proxy f -> Maybe TypeName++instance (RefType gql f, RefType gql g) => RefType gql (f :*: g) where+  refType _ _ = Nothing++instance (Selector s, gql a) => RefType gql (M1 S s (K1 i a)) where+  refType dir _ = Just $ useTypename dir (InputType :: CatType IN a)++instance RefType gql U1 where+  refType _ _ = Nothing++class CountFields (f :: Type -> Type) where+  countFields :: Proxy f -> Int++instance (CountFields f, CountFields g) => CountFields (f :*: g) where+  countFields _ = countFields (Proxy @f) + countFields (Proxy @g)++instance (Selector s) => CountFields (M1 S s (K1 i a)) where+  countFields _ = 1++instance CountFields U1 where+  countFields _ = 0++useDecodeArguments :: val a => UseDeriving gql val -> Arguments VALID -> ResolverState a+useDecodeArguments drv = useDecodeValue (dirArgs drv) . argumentsToObject
+ src/Data/Morpheus/Server/Deriving/Internal/Resolve/Explore.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.Server.Deriving.Internal.Resolve.Explore+  ( useExploreResolvers,+    useObjectResolvers,+    EXPLORE,+  )+where++import Control.Monad.Except (MonadError)+import Data.Morpheus.App.Internal.Resolving+  ( ObjectTypeResolver (..),+    ResolverState,+    ResolverValue (..),+    mkEnum,+    mkObject,+    mkUnion,+    requireObject,+  )+import Data.Morpheus.Server.Deriving.Internal.Schema.Directive+  ( toFieldRes,+    visitEnumName,+  )+import Data.Morpheus.Server.Deriving.Utils.GRep+  ( ConsRep (..),+    FieldRep (..),+    GRep,+    RepContext (..),+    TypeRep (..),+    deriveValue,+    isUnionRef,+  )+import Data.Morpheus.Server.Deriving.Utils.Kinded (inputType)+import Data.Morpheus.Server.Deriving.Utils.Use+  ( UseDeriving (..),+    UseGQLType (..),+    UseResolver (..),+  )+import Data.Morpheus.Types.Internal.AST+  ( GQLError,+    TypeRef (..),+  )+import GHC.Generics (Generic (Rep))+import Relude++convertNode ::+  gql a =>+  (MonadError GQLError m) =>+  UseDeriving gql val ->+  f a ->+  TypeRep (m (ResolverValue m)) ->+  ResolverValue m+convertNode+  drv+  proxy+  TypeRep+    { dataTypeName,+      tyIsUnion,+      tyCons = cons@ConsRep {consFields, consName}+    } = encodeTypeFields consFields+    where+      -- ENUM+      encodeTypeFields :: (MonadError GQLError m) => [FieldRep (m (ResolverValue m))] -> ResolverValue m+      encodeTypeFields [] = mkEnum (visitEnumName drv proxy consName)+      encodeTypeFields fields+        | not tyIsUnion = mkObject dataTypeName (toFieldRes drv proxy <$> fields)+      -- Type References --------------------------------------------------------------+      encodeTypeFields [FieldRep {fieldTypeRef, fieldValue}]+        | isUnionRef dataTypeName cons = ResLazy (ResObject (Just (typeConName fieldTypeRef)) <$> (fieldValue >>= requireObject))+      -- Inline Union Types ----------------------------------------------------------------------------+      encodeTypeFields fields = mkUnion consName (toFieldRes drv proxy <$> fields)++toOptions :: UseResolver res gql val -> RepContext gql (res m) Identity (m (ResolverValue m))+toOptions UseResolver {..} =+  RepContext+    { optApply = useEncodeResolver . runIdentity,+      optTypeData = useTypeData (dirGQL resDrv) . inputType+    }++useExploreResolvers ::+  (MonadError GQLError m, EXPLORE gql res m a) =>+  UseResolver res gql val ->+  a ->+  ResolverValue m+useExploreResolvers res v = convertNode (resDrv res) proxy (deriveValue (toOptions res) v)+  where+    proxy = Identity v++useObjectResolvers ::+  (MonadError GQLError m, EXPLORE gql res m a) =>+  UseResolver res gql val ->+  a ->+  ResolverState (ObjectTypeResolver m)+useObjectResolvers ctx value = requireObject (useExploreResolvers ctx value)++type EXPLORE gql res (m :: Type -> Type) a =+  ( Generic a,+    GRep gql (res m) (m (ResolverValue m)) (Rep a),+    gql a+  )
+ src/Data/Morpheus/Server/Deriving/Internal/Schema/Directive.hs view
@@ -0,0 +1,220 @@+{-# 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 TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.Server.Deriving.Internal.Schema.Directive+  ( deriveFieldDirectives,+    deriveTypeDirectives,+    deriveEnumDirectives,+    visitEnumValueDescription,+    visitFieldDescription,+    visitTypeDescription,+    visitFieldDefaultValue,+    visitFieldContent,+    visitEnumName,+    visitFieldName,+    toFieldRes,+    UseDeriving (..),+  )+where++import Control.Monad.Except+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.Internal.Schema.Internal+  ( CatType,+    deriveTypeAsArguments,+  )+import Data.Morpheus.Server.Deriving.Utils.GRep (FieldRep (..))+import Data.Morpheus.Server.Deriving.Utils.Kinded+  ( CatType (..),+    inputType,+  )+import Data.Morpheus.Server.Deriving.Utils.Use+  ( UseDeriving (..),+    UseGQLType (..),+    UseValue (..),+  )+import Data.Morpheus.Server.Types.Directives+  ( GDirectiveUsage (..),+    GDirectiveUsages (..),+    GQLDirective (..),+    applyEnumDescription,+    applyEnumName,+    applyFieldDefaultValue,+    applyFieldDescription,+    applyFieldName,+    applyTypeDescription,+    applyTypeEnumNames,+    applyTypeFieldNames,+    getLocations,+  )+import Data.Morpheus.Server.Types.SchemaT+  ( SchemaT,+    insertDirectiveDefinition,+    outToAny,+    withInput,+  )+import Data.Morpheus.Types.Internal.AST+  ( Argument (..),+    Arguments,+    CONST,+    Description,+    Directive (..),+    DirectiveDefinition (..),+    Directives,+    FieldContent (..),+    FieldName,+    IN,+    OUT,+    ObjectEntry (..),+    Position (Position),+    TRUE,+    TypeName,+    Value (..),+    internal,+  )+import GHC.Generics ()+import GHC.TypeLits ()+import Relude hiding (empty)++deriveDirectiveDefinition ::+  (gql a, GQLDirective a, args a) =>+  UseDeriving gql args ->+  a ->+  b ->+  SchemaT kind (DirectiveDefinition CONST)+deriveDirectiveDefinition options arg _ = do+  directiveDefinitionArgs <- outToAny (withInput $ deriveTypeAsArguments (dirGQL options) proxy)+  pure+    ( DirectiveDefinition+        { directiveDefinitionName = deriveDirectiveName (dirGQL options) proxy,+          directiveDefinitionDescription = visitTypeDescription options proxy Nothing,+          directiveDefinitionArgs,+          directiveDefinitionLocations = getLocations proxy+        }+    )+  where+    proxy = Identity arg++deriveDirectiveUsages :: UseDeriving gql args -> [GDirectiveUsage gql args] -> SchemaT kind (Directives CONST)+deriveDirectiveUsages options = fmap unsafeFromList . traverse (toDirectiveTuple options)++encodeDirectiveArguments :: val a => UseValue val -> a -> SchemaT OUT (Arguments CONST)+encodeDirectiveArguments val x = resultOr (const $ throwError err) pure (useEncodeValue val x) >>= unpackValue+  where+    err = internal "could not encode arguments. Arguments should be an object like type!"+    unpackValue (Object v) = pure $ fmap toArgument v+    unpackValue _ = throwError err+    toArgument ObjectEntry {..} = Argument (Position 0 0) entryName entryValue++toDirectiveTuple ::+  UseDeriving gql args ->+  GDirectiveUsage gql args ->+  SchemaT kind (FieldName, Directive CONST)+toDirectiveTuple options (GDirectiveUsage x) = do+  insertDirective options (deriveDirectiveDefinition options x) x+  let directiveName = deriveDirectiveName (dirGQL options) (Identity x)+  args <- toList <$> outToAny (encodeDirectiveArguments (dirArgs options) x)+  directiveArgs <- fromElems (map editArg args)+  pure+    ( directiveName,+      Directive+        { directivePosition = Position 0 0,+          directiveName,+          directiveArgs+        }+    )+  where+    editArg Argument {..} = Argument {argumentName = applyGQLFieldOptions options (Identity x) argumentName, ..}++insertDirective ::+  forall gql args a k.+  gql a =>+  UseDeriving gql args ->+  (CatType IN a -> SchemaT k (DirectiveDefinition CONST)) ->+  a ->+  SchemaT k ()+insertDirective ops f _ = insertDirectiveDefinition (useFingerprint (dirGQL ops) proxy) f proxy+  where+    proxy = InputType :: CatType IN a++getDirHM :: (Ord k, Hashable k, Empty a) => k -> HashMap k a -> a+getDirHM name xs = fromMaybe empty $ name `HM.lookup` xs++isIncluded :: GDirectiveUsage gql args -> Bool+isIncluded (GDirectiveUsage x) = not $ excludeFromSchema (Identity x)++getEnumDirectiveUsages :: gql a => UseDeriving gql args -> f a -> TypeName -> [GDirectiveUsage gql args]+getEnumDirectiveUsages UseDeriving {..} proxy name = getDirHM name $ enumValueDirectives $ __directives proxy++getFieldDirectiveUsages :: gql a => UseDeriving gql args -> FieldName -> f a -> [GDirectiveUsage gql args]+getFieldDirectiveUsages UseDeriving {..} name proxy = getDirHM name $ fieldDirectives $ __directives proxy++-- derive directives+deriveEnumDirectives :: gql a => UseDeriving gql args -> f a -> TypeName -> SchemaT k (Directives CONST)+deriveEnumDirectives options proxy name = deriveDirectiveUsages options $ filter isIncluded $ getEnumDirectiveUsages options proxy name++deriveFieldDirectives :: gql a => UseDeriving gql args -> f a -> FieldName -> SchemaT kind (Directives CONST)+deriveFieldDirectives options proxy name = deriveDirectiveUsages options $ filter isIncluded $ getFieldDirectiveUsages options name proxy++deriveTypeDirectives :: gql a => UseDeriving gql args -> f a -> SchemaT kind (Directives CONST)+deriveTypeDirectives options proxy = deriveDirectiveUsages options $ filter isIncluded $ typeDirectives $ __directives options proxy++-- visit++visitEnumValueDescription :: gql a => UseDeriving gql args -> f a -> TypeName -> Maybe Description -> Maybe Description+visitEnumValueDescription options proxy name desc = foldr applyEnumDescription desc (getEnumDirectiveUsages options proxy name)++visitEnumName :: gql a => UseDeriving gql args -> f a -> TypeName -> TypeName+visitEnumName options proxy name = foldr applyEnumName (withTypeDirectives name) (getEnumDirectiveUsages options proxy name)+  where+    withTypeDirectives dirName = foldr applyTypeEnumNames dirName (typeDirectives $ __directives options proxy)++visitFieldDescription :: gql a => UseDeriving gql args -> f a -> FieldName -> Maybe Description -> Maybe Description+visitFieldDescription options proxy name desc = foldr applyFieldDescription desc (getFieldDirectiveUsages options name proxy)++visitFieldDefaultValue :: gql a => UseDeriving gql args -> f a -> FieldName -> Maybe (Value CONST) -> Maybe (Value CONST)+visitFieldDefaultValue options proxy name desc = foldr applyFieldDefaultValue desc (getFieldDirectiveUsages options name proxy)++visitFieldContent ::+  gql a =>+  UseDeriving gql args ->+  CatType kind a ->+  FieldName ->+  Maybe (FieldContent TRUE kind CONST) ->+  Maybe (FieldContent TRUE kind CONST)+visitFieldContent options proxy@InputType name x =+  DefaultInputValue+    <$> visitFieldDefaultValue options proxy name (defaultInputValue <$> x)+visitFieldContent _ OutputType _ x = x++applyGQLFieldOptions :: gql a => UseDeriving gql args -> f a -> FieldName -> FieldName+applyGQLFieldOptions options proxy = withTypeDirectives+  where+    withTypeDirectives name = foldr applyTypeFieldNames name (typeDirectives $ __directives options proxy)++visitFieldName :: gql a => UseDeriving gql args -> f a -> FieldName -> FieldName+visitFieldName options proxy name = foldr applyFieldName (applyGQLFieldOptions options proxy name) (getFieldDirectiveUsages options name proxy)++visitTypeDescription :: gql a => UseDeriving gql args -> f a -> Maybe Description -> Maybe Description+visitTypeDescription options proxy desc = foldr applyTypeDescription desc (typeDirectives $ __directives options proxy)++toFieldRes :: gql a => UseDeriving gql args -> f a -> FieldRep v -> (FieldName, v)+toFieldRes options proxy FieldRep {..} = (visitFieldName options proxy fieldSelector, fieldValue)++deriveDirectiveName :: gql a => UseGQLType gql -> f a -> FieldName+deriveDirectiveName options = coerce . useTypename options . inputType
+ src/Data/Morpheus/Server/Deriving/Internal/Schema/Enum.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RecordWildCards #-}++module Data.Morpheus.Server.Deriving.Internal.Schema.Enum+  ( buildEnumTypeContent,+    defineEnumUnit,+  )+where++import Data.Morpheus.Server.Deriving.Internal.Schema.Directive+  ( UseDeriving,+    deriveEnumDirectives,+    visitEnumName,+    visitEnumValueDescription,+  )+import Data.Morpheus.Server.Deriving.Utils.Kinded+  ( CatType (..),+  )+import Data.Morpheus.Server.Types.SchemaT+  ( SchemaT,+    insertType,+  )+import Data.Morpheus.Types.Internal.AST+  ( CONST,+    DataEnumValue (..),+    LEAF,+    TRUE,+    TypeContent (..),+    TypeDefinition,+    TypeName,+    mkEnumContent,+    mkType,+    unitTypeName,+  )++buildEnumTypeContent :: gql a => UseDeriving gql args -> CatType kind a -> [TypeName] -> SchemaT k (TypeContent TRUE kind CONST)+buildEnumTypeContent options p@InputType enumCons = DataEnum <$> traverse (mkEnumValue options p) enumCons+buildEnumTypeContent options p@OutputType enumCons = DataEnum <$> traverse (mkEnumValue options p) enumCons++mkEnumValue :: gql a => UseDeriving gql args -> f a -> TypeName -> SchemaT k (DataEnumValue CONST)+mkEnumValue options proxy enumName = do+  enumDirectives <- deriveEnumDirectives options proxy enumName+  pure+    DataEnumValue+      { enumName = visitEnumName options proxy enumName,+        enumDescription = visitEnumValueDescription options proxy enumName Nothing,+        ..+      }++defineEnumUnit :: SchemaT cat ()+defineEnumUnit =+  insertType+    ( mkType unitTypeName (mkEnumContent [unitTypeName]) ::+        TypeDefinition LEAF CONST+    )
+ src/Data/Morpheus/Server/Deriving/Internal/Schema/Internal.hs view
@@ -0,0 +1,75 @@+{-# 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 Success {} = [|()|]+fromSchema Failure {errors} = fail (show errors)++withObject :: (gql a) => UseGQLType gql -> CatType c a -> TypeContent TRUE any s -> SchemaT c (FieldsDefinition c s)+withObject _ InputType DataInputObject {inputObjectFields} = pure inputObjectFields+withObject _ OutputType DataObject {objectFields} = pure objectFields+withObject gql x _ = failureOnlyObject gql x++failureOnlyObject :: (gql a) => UseGQLType gql -> CatType c a -> SchemaT c b+failureOnlyObject gql proxy = throwError $ msg (useTypename gql proxy) <> " should have only one nonempty constructor"++deriveTypeAsArguments :: gql a => UseGQLType gql -> f a -> SchemaT IN (ArgumentsDefinition CONST)+deriveTypeAsArguments gql arg =+  fieldsToArguments+    <$> ( useDeriveType gql (inputType arg)+            >>= withObject gql (inputType arg) . typeContent+        )
+ src/Data/Morpheus/Server/Deriving/Internal/Schema/Object.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}++module Data.Morpheus.Server.Deriving.Internal.Schema.Object+  ( buildObjectTypeContent,+    defineObjectType,+  )+where++import Data.Morpheus.Internal.Utils+  ( empty,+    singleton,+  )+import Data.Morpheus.Server.Deriving.Internal.Schema.Directive+  ( UseDeriving,+    deriveFieldDirectives,+    visitFieldContent,+    visitFieldDescription,+    visitFieldName,+  )+import Data.Morpheus.Server.Deriving.Internal.Schema.Enum+  ( defineEnumUnit,+  )+import Data.Morpheus.Server.Deriving.Utils.GRep+  ( ConsRep (..),+    FieldRep (..),+  )+import Data.Morpheus.Server.Deriving.Utils.Kinded+  ( CatType (..),+  )+import Data.Morpheus.Server.Types.SchemaT+  ( SchemaT,+    insertType,+  )+import Data.Morpheus.Types.Internal.AST (ArgumentsDefinition, CONST, FieldContent (..), FieldDefinition (..), FieldsDefinition, TRUE, TypeContent (..), mkField, mkType, mkTypeRef, unitFieldName, unitTypeName, unsafeFromFields)+import Relude hiding (empty)++defineObjectType ::+  CatType kind a ->+  ConsRep (Maybe (ArgumentsDefinition CONST)) ->+  SchemaT cat ()+defineObjectType proxy ConsRep {consName, consFields} = insertType . mkType consName . mkObjectTypeContent proxy =<< fields+  where+    fields+      | null consFields = defineEnumUnit $> singleton unitFieldName mkFieldUnit+      | otherwise = pure $ unsafeFromFields $ map (repToFieldDefinition proxy) consFields++mkFieldUnit :: FieldDefinition cat s+mkFieldUnit = mkField Nothing unitFieldName (mkTypeRef unitTypeName)++buildObjectTypeContent ::+  gql a =>+  UseDeriving gql args ->+  CatType cat a ->+  [FieldRep (Maybe (ArgumentsDefinition CONST))] ->+  SchemaT k (TypeContent TRUE cat CONST)+buildObjectTypeContent options scope consFields = do+  xs <- traverse (setGQLTypeProps options scope . repToFieldDefinition scope) consFields+  pure $ mkObjectTypeContent scope $ unsafeFromFields xs++repToFieldDefinition ::+  CatType c a ->+  FieldRep (Maybe (ArgumentsDefinition CONST)) ->+  FieldDefinition c CONST+repToFieldDefinition+  x+  FieldRep+    { fieldSelector = fieldName,+      fieldTypeRef = fieldType,+      fieldValue+    } =+    FieldDefinition+      { fieldDescription = mempty,+        fieldDirectives = empty,+        fieldContent = toFieldContent x fieldValue,+        ..+      }++toFieldContent :: CatType c a -> Maybe (ArgumentsDefinition CONST) -> Maybe (FieldContent TRUE c CONST)+toFieldContent OutputType (Just x) = Just (FieldArgs x)+toFieldContent _ _ = Nothing++mkObjectTypeContent :: CatType kind a -> FieldsDefinition kind CONST -> TypeContent TRUE kind CONST+mkObjectTypeContent InputType = DataInputObject+mkObjectTypeContent OutputType = DataObject []++setGQLTypeProps :: gql a => UseDeriving gql args -> CatType kind a -> FieldDefinition kind CONST -> SchemaT k (FieldDefinition kind CONST)+setGQLTypeProps options proxy FieldDefinition {..} = do+  dirs <- deriveFieldDirectives options proxy fieldName+  pure+    FieldDefinition+      { fieldName = visitFieldName options proxy fieldName,+        fieldDescription = visitFieldDescription options proxy fieldName Nothing,+        fieldContent = visitFieldContent options proxy fieldName fieldContent,+        fieldDirectives = dirs,+        ..+      }
+ src/Data/Morpheus/Server/Deriving/Internal/Schema/Type.hs view
@@ -0,0 +1,166 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Data.Morpheus.Server.Deriving.Internal.Schema.Type+  ( fillTypeContent,+    deriveTypeDefinition,+    deriveScalarDefinition,+    deriveInterfaceDefinition,+    deriveTypeGuardUnions,+    useDeriveObject,+    injectType,+  )+where++import Control.Monad.Except+import Data.Foldable+import Data.Morpheus.Server.Deriving.Internal.Schema.Directive+  ( UseDeriving (..),+    deriveTypeDirectives,+    visitTypeDescription,+  )+import Data.Morpheus.Server.Deriving.Internal.Schema.Enum+  ( buildEnumTypeContent,+  )+import Data.Morpheus.Server.Deriving.Internal.Schema.Internal+  ( CatType,+    withObject,+  )+import Data.Morpheus.Server.Deriving.Internal.Schema.Object+  ( buildObjectTypeContent,+  )+import Data.Morpheus.Server.Deriving.Internal.Schema.Union (buildUnionTypeContent)+import Data.Morpheus.Server.Deriving.Utils.GRep+  ( ConsRep (..),+    GRep,+    RepContext (..),+    deriveTypeWith,+    isEmptyConstraint,+    unpackMonad,+  )+import Data.Morpheus.Server.Deriving.Utils.Kinded (CatContext, addContext, getCatContext, mkScalar, outputType)+import Data.Morpheus.Server.Deriving.Utils.Use+  ( UseGQLType (..),+  )+import Data.Morpheus.Server.Types.SchemaT+  ( SchemaT,+    updateSchema,+  )+import Data.Morpheus.Types.Internal.AST+import GHC.Generics (Rep)+import Relude++buildTypeContent ::+  (gql a) =>+  UseDeriving gql args ->+  CatType kind a ->+  [ConsRep (Maybe (ArgumentsDefinition CONST))] ->+  SchemaT kind (TypeContent TRUE kind CONST)+buildTypeContent options scope cons | all isEmptyConstraint cons = buildEnumTypeContent options scope (consName <$> cons)+buildTypeContent options scope [ConsRep {consFields}] = buildObjectTypeContent options scope consFields+buildTypeContent options scope cons = buildUnionTypeContent (dirGQL options) scope cons++deriveTypeContentWith ::+  (gql a, GRep gql gql (SchemaT kind (Maybe (ArgumentsDefinition CONST))) (Rep a)) =>+  UseDeriving gql args ->+  CatType kind a ->+  SchemaT kind (TypeContent TRUE kind CONST)+deriveTypeContentWith dir proxy =+  unpackMonad (deriveTypeWith (toFieldContent (getCatContext proxy) dir) proxy)+    >>= buildTypeContent dir proxy++deriveTypeGuardUnions ::+  ( gql a,+    GRep gql gql (SchemaT OUT (Maybe (ArgumentsDefinition CONST))) (Rep a)+  ) =>+  UseDeriving gql args ->+  CatType OUT a ->+  SchemaT OUT [TypeName]+deriveTypeGuardUnions dir proxy = do+  content <- deriveTypeContentWith dir proxy+  getUnionNames content+  where+    getUnionNames :: TypeContent TRUE OUT CONST -> SchemaT OUT [TypeName]+    getUnionNames DataUnion {unionMembers} = pure $ toList $ memberName <$> unionMembers+    getUnionNames DataObject {} = pure [useTypename (dirGQL dir) proxy]+    getUnionNames _ = throwError "guarded type must be an union or object"++insertType ::+  forall c gql a args.+  (gql a) =>+  UseDeriving gql args ->+  (UseDeriving gql args -> CatType c a -> SchemaT c (TypeDefinition c CONST)) ->+  CatType c a ->+  SchemaT c ()+insertType dir f proxy = updateSchema (useFingerprint (dirGQL dir) proxy) (f dir) proxy++deriveScalarDefinition ::+  gql a =>+  (CatType cat a -> ScalarDefinition) ->+  UseDeriving gql args ->+  CatType cat a ->+  SchemaT kind (TypeDefinition cat CONST)+deriveScalarDefinition f dir p = fillTypeContent dir p (mkScalar p (f p))++deriveTypeDefinition ::+  (gql a, GRep gql gql (SchemaT c (Maybe (ArgumentsDefinition CONST))) (Rep a)) =>+  UseDeriving gql args ->+  CatType c a ->+  SchemaT c (TypeDefinition c CONST)+deriveTypeDefinition dir proxy = deriveTypeContentWith dir proxy >>= fillTypeContent dir proxy++deriveInterfaceDefinition ::+  (gql a, GRep gql gql (SchemaT OUT (Maybe (ArgumentsDefinition CONST))) (Rep a)) =>+  UseDeriving gql args ->+  CatType OUT a ->+  SchemaT OUT (TypeDefinition OUT CONST)+deriveInterfaceDefinition dir proxy = do+  fields <- deriveFields dir proxy+  fillTypeContent dir proxy (DataInterface fields)++fillTypeContent ::+  gql a =>+  UseDeriving gql args ->+  CatType c a ->+  TypeContent TRUE cat CONST ->+  SchemaT kind (TypeDefinition cat CONST)+fillTypeContent options@UseDeriving {dirGQL = UseGQLType {..}} proxy content = do+  dirs <- deriveTypeDirectives options proxy+  pure $+    TypeDefinition+      (visitTypeDescription options proxy Nothing)+      (useTypename proxy)+      dirs+      content++deriveFields ::+  ( gql a,+    GRep gql gql (SchemaT cat (Maybe (ArgumentsDefinition CONST))) (Rep a)+  ) =>+  UseDeriving gql args ->+  CatType cat a ->+  SchemaT cat (FieldsDefinition cat CONST)+deriveFields dirs kindedType = deriveTypeContentWith dirs kindedType >>= withObject (dirGQL dirs) kindedType++toFieldContent :: CatContext cat -> UseDeriving gql dir -> RepContext gql gql Proxy (SchemaT cat (Maybe (ArgumentsDefinition CONST)))+toFieldContent ctx dir@UseDeriving {..} =+  RepContext+    { optTypeData = useTypeData dirGQL . addContext ctx,+      optApply = \proxy -> injectType dir (addContext ctx proxy) *> useDeriveFieldArguments dirGQL (addContext ctx proxy)+    }++injectType :: gql a => UseDeriving gql args -> CatType c a -> SchemaT c ()+injectType dir = insertType dir (\_ y -> useDeriveType (dirGQL dir) y)++useDeriveObject :: gql a => UseGQLType gql -> f a -> SchemaT OUT (TypeDefinition OBJECT CONST)+useDeriveObject gql pr = do+  fields <- useDeriveType gql proxy >>= withObject gql proxy . typeContent+  pure $ mkType (useTypename gql (outputType proxy)) (DataObject [] fields)+  where+    proxy = outputType pr
+ src/Data/Morpheus/Server/Deriving/Internal/Schema/Union.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE GADTs #-}++module Data.Morpheus.Server.Deriving.Internal.Schema.Union+  ( buildUnionTypeContent,+  )+where++import Data.List (partition)+import Data.Morpheus.Internal.Utils (fromElems)+import Data.Morpheus.Server.Deriving.Internal.Schema.Enum+  ( defineEnumUnit,+  )+import Data.Morpheus.Server.Deriving.Internal.Schema.Object+  ( defineObjectType,+  )+import Data.Morpheus.Server.Deriving.Utils.GRep+  ( ConsRep (..),+    FieldRep (fieldTypeRef),+    isEmptyConstraint,+    isUnionRef,+  )+import Data.Morpheus.Server.Deriving.Utils.Kinded+  ( CatType (..),+  )+import Data.Morpheus.Server.Deriving.Utils.Use (UseGQLType (..), useTypename)+import Data.Morpheus.Server.Types.SchemaT+  ( SchemaT,+  )+import Data.Morpheus.Types.Internal.AST+  ( ArgumentsDefinition,+    CONST,+    IN,+    TRUE,+    TypeContent (..),+    TypeName,+    TypeRef (..),+    UnionMember (..),+    mkNullaryMember,+    mkUnionMember,+  )+import Relude++buildUnionTypeContent ::+  (gql a) =>+  UseGQLType gql ->+  CatType kind a ->+  [ConsRep (Maybe (ArgumentsDefinition CONST))] ->+  SchemaT k (TypeContent TRUE kind CONST)+buildUnionTypeContent gql scope cons = mkUnionType scope unionRef unionCons+  where+    unionRef = typeConName . fieldTypeRef <$> concatMap consFields unionRefRep+    (unionRefRep, unionCons) = partition (isUnionRef (useTypename gql scope)) cons++mkUnionType ::+  CatType kind a ->+  [TypeName] ->+  [ConsRep (Maybe (ArgumentsDefinition CONST))] ->+  SchemaT c (TypeContent TRUE kind CONST)+mkUnionType p@InputType unionRef unionCons = DataInputUnion <$> (typeMembers >>= fromElems)+  where+    (nullaryCons, cons) = partition isEmptyConstraint unionCons+    nullaryMembers :: [UnionMember IN CONST]+    nullaryMembers = mkNullaryMember . consName <$> nullaryCons+    defineEnumEmpty+      | null nullaryCons = pure ()+      | otherwise = defineEnumUnit+    typeMembers =+      (<> nullaryMembers) . withRefs+        <$> ( defineEnumEmpty *> buildUnions p cons+            )+      where+        withRefs = fmap mkUnionMember . (unionRef <>)+mkUnionType p@OutputType unionRef unionCons =+  DataUnion <$> (buildUnions p unionCons >>= fromElems . map mkUnionMember . (unionRef <>))++buildUnions ::+  CatType kind a ->+  [ConsRep (Maybe (ArgumentsDefinition CONST))] ->+  SchemaT c [TypeName]+buildUnions proxy cons =+  traverse_ (defineObjectType proxy) cons $> fmap consName cons
+ src/Data/Morpheus/Server/Deriving/Kinded/Arguments.hs view
@@ -0,0 +1,61 @@+{-# 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 _ _ = pure Nothing++instance (gql b, gql a) => DeriveFieldArguments gql (a -> b) where+  deriveFieldArguments UseDeriving {..} _ = do+    a <- withInput $ deriveTypeAsArguments dirGQL (Proxy @a)+    b <- useDeriveFieldArguments dirGQL (OutputType :: CatType OUT b)+    case b of+      Just x -> Just <$> (a <:> x)+      Nothing -> pure $ Just a
+ src/Data/Morpheus/Server/Deriving/Kinded/Channels.hs view
@@ -0,0 +1,139 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.Server.Deriving.Kinded.Channels+  ( resolverChannels,+    CHANNELS,+  )+where++import Control.Monad.Except (throwError)+import qualified Data.HashMap.Lazy as HM+import Data.Morpheus.App.Internal.Resolving+  ( Channel,+    MonadResolver (..),+    ResolverState,+    SubscriptionField (..),+  )+import Data.Morpheus.Internal.Utils+  ( selectBy,+  )+import Data.Morpheus.Server.Deriving.Internal.Decode.Utils (useDecodeArguments)+import Data.Morpheus.Server.Deriving.Internal.Schema.Directive (UseDeriving (..), toFieldRes)+import Data.Morpheus.Server.Deriving.Utils.GRep+  ( ConsRep (..),+    GRep,+    RepContext (..),+    TypeRep (..),+    deriveValue,+  )+import Data.Morpheus.Server.Deriving.Utils.Kinded (outputType)+import Data.Morpheus.Server.Deriving.Utils.Use (UseGQLType (useTypeData))+import Data.Morpheus.Server.Types.Types (Undefined)+import Data.Morpheus.Types.Internal.AST+  ( FALSE,+    FieldName,+    SUBSCRIPTION,+    Selection (..),+    SelectionContent (..),+    TRUE,+    VALID,+    internal,+  )+import GHC.Generics (Rep)+import Relude hiding (Undefined)++newtype DerivedChannel e = DerivedChannel+  { _unpackChannel :: Channel e+  }++type ChannelRes (e :: Type) = Selection VALID -> ResolverState (DerivedChannel e)++type CHANNELS gql val (subs :: (Type -> Type) -> Type) m =+  ( MonadResolver m,+    MonadOperation m ~ SUBSCRIPTION,+    ExploreChannels gql val (IsUndefined (subs m)) (MonadEvent m) (subs m)+  )++resolverChannels ::+  forall m subs gql val.+  CHANNELS gql val subs m =>+  UseDeriving gql val ->+  subs m ->+  Selection VALID ->+  ResolverState (Channel (MonadEvent m))+resolverChannels drv value = fmap _unpackChannel . channelSelector+  where+    channelSelector :: Selection VALID -> ResolverState (DerivedChannel (MonadEvent m))+    channelSelector = selectBySelection (exploreChannels drv (Proxy @(IsUndefined (subs m))) value)++selectBySelection ::+  HashMap FieldName (ChannelRes e) ->+  Selection VALID ->+  ResolverState (DerivedChannel e)+selectBySelection channels = withSubscriptionSelection >=> selectSubscription channels++selectSubscription ::+  HashMap FieldName (ChannelRes e) ->+  Selection VALID ->+  ResolverState (DerivedChannel e)+selectSubscription channels sel@Selection {selectionName} =+  selectBy+    (internal "invalid subscription: no channel is selected.")+    selectionName+    channels+    >>= (sel &)++withSubscriptionSelection :: Selection VALID -> ResolverState (Selection VALID)+withSubscriptionSelection Selection {selectionContent = SelectionSet selSet} =+  case toList selSet of+    [sel] -> pure sel+    _ -> throwError (internal "invalid subscription: there can be only one top level selection")+withSubscriptionSelection _ = throwError (internal "invalid subscription: expected selectionSet")++class GetChannel val e a where+  getChannel :: UseDeriving gql val -> a -> ChannelRes e++instance (MonadResolver m, MonadOperation m ~ SUBSCRIPTION, MonadEvent m ~ e) => GetChannel val e (SubscriptionField (m a)) where+  getChannel _ x = const $ pure $ DerivedChannel $ channel x++instance (MonadResolver m, MonadOperation m ~ SUBSCRIPTION, MonadEvent m ~ e, val arg) => GetChannel val e (arg -> SubscriptionField (m a)) where+  getChannel drv f sel@Selection {selectionArguments} =+    useDecodeArguments drv selectionArguments+      >>= flip (getChannel drv) sel . f++------------------------------------------------------++type family IsUndefined a :: Bool where+  IsUndefined (Undefined m) = TRUE+  IsUndefined a = FALSE++class ExploreChannels gql val (t :: Bool) e a where+  exploreChannels :: UseDeriving gql val -> f t -> a -> HashMap FieldName (ChannelRes e)++instance (gql a, Generic a, GRep gql (GetChannel val e) (ChannelRes e) (Rep a)) => ExploreChannels gql val FALSE e a where+  exploreChannels drv _ =+    HM.fromList+      . map (toFieldRes drv (Proxy @a))+      . consFields+      . tyCons+      . deriveValue+        ( RepContext+            { optApply = getChannel drv . runIdentity,+              optTypeData = useTypeData (dirGQL drv) . outputType+            } ::+            RepContext gql (GetChannel val e) Identity (ChannelRes e)+        )++instance ExploreChannels drv val TRUE e (Undefined m) where+  exploreChannels _ _ = pure HM.empty
+ src/Data/Morpheus/Server/Deriving/Kinded/NamedResolver.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.Server.Deriving.Kinded.NamedResolver+  ( KindedNamedResolver (..),+  )+where++import Data.Morpheus.App.Internal.Resolving+  ( MonadResolver (..),+    NamedResolver (..),+    NamedResolverResult (..),+    ResolverValue,+  )+import Data.Morpheus.Server.Deriving.Kinded.NamedResolverFun+  ( deriveNamedResolverFun,+  )+import Data.Morpheus.Server.Deriving.Utils.GRep (GRep)+import Data.Morpheus.Server.Deriving.Utils.GScan (ScanRef (..))+import Data.Morpheus.Server.Deriving.Utils.Gmap (Gmap)+import Data.Morpheus.Server.Deriving.Utils.Kinded (outputType)+import Data.Morpheus.Server.Deriving.Utils.Use (UseDeriving (..), UseGQLType (useFingerprint, useTypename), UseNamedResolver (..), UseValue (useDecodeValue))+import Data.Morpheus.Server.Types.Kind+  ( CUSTOM,+    DerivingKind,+    SCALAR,+    TYPE,+    WRAPPER,+  )+import Data.Morpheus.Server.Types.NamedResolvers (Dependency, NamedResolverT (..), ResolveNamed (..))+import Data.Morpheus.Types.GQLScalar (EncodeScalar (..))+import Data.Morpheus.Types.Internal.AST+  ( ValidValue,+  )+import GHC.Generics (Rep)+import Relude++type DECODE_VALUES val m a = (ResolveNamed m a, val (Dependency a), MonadResolver m)++decodeValues :: DECODE_VALUES val m a => UseDeriving gql val -> Proxy a -> [ValidValue] -> m [Maybe a]+decodeValues ctx _ xs = traverse (liftState . useDecodeValue (dirArgs ctx)) xs >>= resolveBatched++class KindedNamedResolver namedRes resFun gql val (m :: Type -> Type) (k :: DerivingKind) a where+  kindedNamedResolver :: UseNamedResolver namedRes resFun gql val -> f k a -> [NamedResolver m]+  kindedNamedRefs :: UseNamedResolver namedRes resFun gql val -> f k a -> [ScanRef (namedRes m)]++instance+  ( DECODE_VALUES val m a,+    gql a,+    namedRes m a,+    EncodeScalar a+  ) =>+  KindedNamedResolver namedRes resFun gql val m SCALAR a+  where+  kindedNamedResolver ctx _ =+    [ NamedResolver+        { resolverName = useTypename (dirGQL $ namedDrv ctx) (outputType proxy),+          resolverFun = decodeValues (namedDrv ctx) proxy >=> pure . map (maybe NamedNullResolver (NamedScalarResolver . encodeScalar))+        }+    ]+    where+      proxy = Proxy @a+  kindedNamedRefs ctx _ = [ScanType fp proxy]+    where+      fp = useFingerprint (dirGQL $ namedDrv ctx) (outputType proxy)+      proxy = Proxy @a++instance+  ( DECODE_VALUES val m a,+    gql a,+    namedRes m a,+    Generic a,+    gql [Maybe a],+    GRep gql (resFun m) (m (ResolverValue m)) (Rep a),+    Gmap (namedRes m) (Rep a)+  ) =>+  KindedNamedResolver namedRes resFun gql val m TYPE (a :: Type)+  where+  kindedNamedResolver ctx _ =+    [ NamedResolver+        { resolverName = useTypename (dirGQL $ namedDrv ctx) (outputType proxy),+          resolverFun = decodeValues (namedDrv ctx) proxy >=> deriveNamedResolverFun ctx+        }+    ]+    where+      proxy = Proxy @a++  kindedNamedRefs ctx _ = [ScanObject (useFingerprint (dirGQL $ namedDrv ctx) (outputType proxy)) proxy]+    where+      proxy = Proxy @a++instance namedRes m a => KindedNamedResolver namedRes resFun gql val m CUSTOM (NamedResolverT m a) where+  kindedNamedResolver ctx _ = useDeriveNamedResolvers ctx (Proxy @a)+  kindedNamedRefs ctx _ = useDeriveNamedRefs ctx (Proxy @a)++instance namedRes m a => KindedNamedResolver namedRes resFun gql val m CUSTOM (input -> a) where+  kindedNamedResolver ctx _ = useDeriveNamedResolvers ctx (Proxy @a)+  kindedNamedRefs ctx _ = useDeriveNamedRefs ctx (Proxy @a)++instance namedRes m a => KindedNamedResolver namedRes resFun gql val m WRAPPER (f a) where+  kindedNamedResolver ctx _ = useDeriveNamedResolvers ctx (Proxy @a)+  kindedNamedRefs ctx _ = useDeriveNamedRefs ctx (Proxy @a)
+ src/Data/Morpheus/Server/Deriving/Kinded/NamedResolverFun.hs view
@@ -0,0 +1,172 @@+{-# 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 UndecidableInstances #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.Server.Deriving.Kinded.NamedResolverFun+  ( deriveNamedResolverFun,+    KindedNamedFunValue (..),+  )+where++import Control.Monad.Except (MonadError (..))+import Data.Aeson (ToJSON (..))+import Data.Morpheus.App.Internal.Resolving+  ( MonadResolver (..),+    NamedResolverRef (..),+    NamedResolverResult (..),+    ObjectTypeResolver (..),+    ResolverValue (..),+    getArguments,+    mkList,+    mkNull,+  )+import Data.Morpheus.Server.Deriving.Internal.Decode.Utils (useDecodeArguments)+import Data.Morpheus.Server.Deriving.Internal.Schema.Directive (UseDeriving, toFieldRes)+import Data.Morpheus.Server.Deriving.Utils.GRep+  ( ConsRep (..),+    FieldRep (..),+    GRep,+    RepContext (..),+    TypeRep (..),+    deriveValue,+  )+import Data.Morpheus.Server.Deriving.Utils.Kinded+  ( CatType (..),+    outputType,+  )+import Data.Morpheus.Server.Deriving.Utils.Proxy+  ( ContextValue (..),+  )+import Data.Morpheus.Server.Deriving.Utils.Use+  ( UseDeriving (..),+    UseGQLType (..),+    UseNamedResolver (..),+  )+import Data.Morpheus.Server.Types.Kind+  ( CUSTOM,+    DerivingKind,+    SCALAR,+    TYPE,+    WRAPPER,+  )+import Data.Morpheus.Server.Types.NamedResolvers+  ( NamedRef,+    NamedResolverT (..),+  )+import Data.Morpheus.Types.GQLScalar+  ( EncodeScalar (..),+  )+import Data.Morpheus.Types.Internal.AST+  ( GQLError,+    OUT,+    TypeName,+    ValidValue,+    Value (List),+    internal,+    replaceValue,+  )+import qualified GHC.Exts as HM+import GHC.Generics+  ( Generic (..),+  )+import Relude hiding (empty)++deriveNamedResolverFun ::+  ( Generic a,+    gql [Maybe a],+    gql a,+    MonadError GQLError m,+    GRep gql (res m) (m (ResolverValue m)) (Rep a)+  ) =>+  UseNamedResolver namedRes res gql val ->+  [Maybe a] ->+  m [NamedResolverResult m]+deriveNamedResolverFun ctx x = traverse encodeNode x+  where+    encodeNode (Just v) = convertNamedNode (namedDrv ctx) (Identity x) (deriveValue (getOptions ctx) v)+    encodeNode Nothing = pure NamedNullResolver++class KindedNamedFunValue res gql val (k :: DerivingKind) (m :: Type -> Type) (a :: Type) where+  kindedNamedFunValue :: UseNamedResolver namedRes res gql val -> ContextValue k a -> m (ResolverValue m)++instance (EncodeScalar a, Monad m) => KindedNamedFunValue res gql val SCALAR m a where+  kindedNamedFunValue _ = pure . ResScalar . encodeScalar . unContextValue++instance (MonadError GQLError m) => KindedNamedFunValue res gql val TYPE m a where+  kindedNamedFunValue _ (ContextValue _) = throwError (internal "types are resolved by Refs")++instance (Applicative m, res m a) => KindedNamedFunValue res gql val WRAPPER m [a] where+  kindedNamedFunValue ctx = fmap ResList . traverse (useNamedFieldResolver ctx) . unContextValue++instance (gql a, res m a, Applicative m) => KindedNamedFunValue res gql val WRAPPER m (Maybe a) where+  kindedNamedFunValue ctx (ContextValue (Just x)) = useNamedFieldResolver ctx x+  kindedNamedFunValue _ (ContextValue Nothing) = pure mkNull++instance (Monad m, gql a, ToJSON (NamedRef a)) => KindedNamedFunValue res gql val CUSTOM m (NamedResolverT m a) where+  kindedNamedFunValue ctx = encodeRef . unContextValue+    where+      name :: TypeName+      name = useTypename (dirGQL (namedDrv ctx)) (OutputType :: CatType OUT a)+      encodeRef :: Monad m => NamedResolverT m a -> m (ResolverValue m)+      encodeRef (NamedResolverT ref) = do+        value <- replaceValue . toJSON <$> ref+        case value of+          (List ls) -> pure $ mkList $ map (packRef name) ls+          _ -> pure $ packRef name value++packRef :: Applicative m => TypeName -> ValidValue -> ResolverValue m+packRef name v = ResRef $ pure $ NamedResolverRef name [v]++instance (Monad m, val a, MonadResolver m, res m b) => KindedNamedFunValue res gql val CUSTOM m (a -> b) where+  kindedNamedFunValue ctx (ContextValue f) =+    getArguments+      >>= liftState . useDecodeArguments (namedDrv ctx)+      >>= useNamedFieldResolver ctx . f++getOptions :: UseNamedResolver namedRes res gql val -> RepContext gql (res m) Identity (m (ResolverValue m))+getOptions UseNamedResolver {..} =+  RepContext+    { optApply = useNamedFieldResolver . runIdentity,+      optTypeData = useTypeData (dirGQL namedDrv) . outputType+    }++convertNamedNode ::+  (gql a, MonadError GQLError m) =>+  UseDeriving gql val ->+  f a ->+  TypeRep (m (ResolverValue m)) ->+  m (NamedResolverResult m)+convertNamedNode+  drv+  proxy+  TypeRep+    { tyIsUnion,+      tyCons = ConsRep {consFields, consName}+    }+    | null consFields = pure $ NamedEnumResolver consName+    | tyIsUnion = deriveUnion consFields+    | otherwise =+        pure $+          NamedObjectResolver+            ObjectTypeResolver+              { objectFields = HM.fromList (toFieldRes drv proxy <$> consFields)+              }++deriveUnion :: (MonadError GQLError m) => [FieldRep (m (ResolverValue m))] -> m (NamedResolverResult m)+deriveUnion [FieldRep {..}] = NamedUnionResolver <$> (fieldValue >>= getRef)+deriveUnion _ = throwError "only union references are supported!"++getRef :: MonadError GQLError m => ResolverValue m -> m NamedResolverRef+getRef (ResRef x) = x+getRef _ = throwError "only resolver references are supported!"
+ src/Data/Morpheus/Server/Deriving/Kinded/Resolver.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.Server.Deriving.Kinded.Resolver+  ( KindedResolver (..),+  )+where++import Control.Monad.Except (MonadError)+import qualified Data.Map as M+import Data.Morpheus.App.Internal.Resolving+  ( MonadResolver (..),+    ResolverValue (..),+    getArguments,+  )+import Data.Morpheus.Server.Deriving.Internal.Resolve.Explore+import Data.Morpheus.Server.Deriving.Utils.AST+import Data.Morpheus.Server.Deriving.Utils.Proxy+  ( ContextValue (..),+  )+import Data.Morpheus.Server.Deriving.Utils.Use+  ( UseDeriving (dirArgs),+    UseResolver (..),+    UseValue (useDecodeValue),+  )+import Data.Morpheus.Server.Types.Kind+  ( CUSTOM,+    DerivingKind,+    SCALAR,+    TYPE,+    WRAPPER,+  )+import Data.Morpheus.Server.Types.Types+  ( TypeGuard (..),+  )+import Data.Morpheus.Types.GQLScalar+  ( EncodeScalar (..),+  )+import Data.Morpheus.Types.GQLWrapper (EncodeWrapper (..))+import Data.Morpheus.Types.Internal.AST+  ( GQLError,+  )+import Relude++-- ENCODE GQL KIND+class KindedResolver gql res val (kind :: DerivingKind) (m :: Type -> Type) (a :: Type) where+  kindedResolver :: UseResolver res gql val -> ContextValue kind a -> m (ResolverValue m)++instance (EncodeWrapper f, Monad m, res m a) => KindedResolver gql res val WRAPPER m (f a) where+  kindedResolver res = encodeWrapper (useEncodeResolver res) . unContextValue++instance (EncodeScalar a, Monad m) => KindedResolver gql res val SCALAR m a where+  kindedResolver _ = pure . ResScalar . encodeScalar . unContextValue++instance (MonadError GQLError m, EXPLORE gql res m a) => KindedResolver gql res val TYPE m a where+  kindedResolver ctx = pure . useExploreResolvers ctx . unContextValue++--  Map+instance (Monad m, res m [(k, v)]) => KindedResolver gql res val CUSTOM m (Map k v) where+  kindedResolver res = useEncodeResolver res . M.toList . unContextValue++--  INTERFACE Types+instance (MonadError GQLError m, EXPLORE gql res m guard, EXPLORE gql res m union) => KindedResolver gql res val CUSTOM m (TypeGuard guard union) where+  kindedResolver ctx (ContextValue (ResolveType value)) = pure (useExploreResolvers ctx value)+  kindedResolver ctx (ContextValue (ResolveInterface value)) = pure (useExploreResolvers ctx value)++instance (Generic a, res m b, MonadResolver m, val a) => KindedResolver gql res val CUSTOM m (a -> b) where+  kindedResolver res (ContextValue f) =+    getArguments+      >>= liftState . useDecodeValue (dirArgs $ resDrv res) . argumentsToObject+      >>= useEncodeResolver res . f++instance (MonadResolver m, res m a) => KindedResolver gql res val CUSTOM m (m a) where+  kindedResolver res (ContextValue value) = value >>= useEncodeResolver res
+ src/Data/Morpheus/Server/Deriving/Kinded/Type.hs view
@@ -0,0 +1,78 @@+{-# 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.Type+  ( DeriveKindedType (..),+    DERIVE_TYPE,+    deriveInterfaceDefinition,+    deriveScalarDefinition,+    deriveTypeGuardUnions,+  )+where++import Data.Morpheus.Server.Deriving.Internal.Schema.Type+  ( deriveInterfaceDefinition,+    deriveScalarDefinition,+    deriveTypeDefinition,+    deriveTypeGuardUnions,+  )+import Data.Morpheus.Server.Deriving.Utils.GRep+  ( GRep,+  )+import Data.Morpheus.Server.Deriving.Utils.Kinded+  ( CatType,+    catMap,+    unliftKind,+  )+import Data.Morpheus.Server.Deriving.Utils.Use+  ( UseDeriving (..),+    UseGQLType (..),+  )+import Data.Morpheus.Server.Types.Kind+  ( DerivingKind,+    SCALAR,+    TYPE,+    WRAPPER,+  )+import Data.Morpheus.Server.Types.SchemaT+  ( SchemaT,+  )+import Data.Morpheus.Types.GQLScalar+  ( DecodeScalar (..),+    scalarValidator,+  )+import Data.Morpheus.Types.Internal.AST+  ( ArgumentsDefinition,+    CONST,+    TypeCategory,+    TypeDefinition (..),+  )+import GHC.Generics+import Relude++type DERIVE_TYPE gql c a = (gql a, GRep gql gql (SchemaT c (Maybe (ArgumentsDefinition CONST))) (Rep a))++-- | DeriveType With specific Kind: 'kind': object, scalar, enum ...+class DeriveKindedType gql val (cat :: TypeCategory) (kind :: DerivingKind) a where+  deriveKindedType :: UseDeriving gql val -> CatType cat (f kind a) -> SchemaT cat (TypeDefinition cat CONST)++instance (gql a) => DeriveKindedType gql val cat WRAPPER (f a) where+  deriveKindedType UseDeriving {..} = useDeriveType dirGQL . catMap (Proxy @a)++instance (DecodeScalar a, gql a) => DeriveKindedType gql val cat SCALAR a where+  deriveKindedType drv = deriveScalarDefinition scalarValidator drv . unliftKind++instance DERIVE_TYPE gql cat a => DeriveKindedType gql val cat TYPE a where+  deriveKindedType drv = deriveTypeDefinition drv . unliftKind
+ src/Data/Morpheus/Server/Deriving/Kinded/Value.hs view
@@ -0,0 +1,154 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.Server.Deriving.Kinded.Value+  ( KindedValue (..),+  )+where++import Control.Monad.Except+  ( MonadError (throwError),+  )+import qualified Data.Map as M+import Data.Morpheus.App.Internal.Resolving+  ( ResolverState,+  )+import Data.Morpheus.Internal.Ext+  ( GQLResult,+  )+import Data.Morpheus.Server.Deriving.Internal.Decode.Rep+  ( DecodeRep (..),+  )+import Data.Morpheus.Server.Deriving.Internal.Decode.Utils+  ( Context (..),+    decodeFieldWith,+    handleEither,+    repValue,+    withInputObject,+    withScalar,+  )+import Data.Morpheus.Server.Deriving.Internal.Schema.Directive+  ( visitEnumName,+    visitFieldName,+  )+import Data.Morpheus.Server.Deriving.Utils.GRep+  ( GRep,+    RepContext (..),+    deriveValue,+  )+import Data.Morpheus.Server.Deriving.Utils.Kinded+  ( CatType (..),+    inputType,+  )+import Data.Morpheus.Server.Deriving.Utils.Proxy+  ( ContextValue,+    symbolName,+    unContextValue,+  )+import Data.Morpheus.Server.Deriving.Utils.Use+  ( UseDeriving (..),+    UseGQLType (..),+    UseValue (..),+  )+import Data.Morpheus.Server.Types.Kind+  ( CUSTOM,+    DerivingKind,+    SCALAR,+    TYPE,+    WRAPPER,+  )+import Data.Morpheus.Server.Types.Types (Arg (Arg))+import Data.Morpheus.Types.GQLScalar+  ( DecodeScalar (..),+    EncodeScalar (..),+  )+import Data.Morpheus.Types.GQLWrapper+  ( DecodeWrapper (..),+    DecodeWrapperConstraint,+    EncodeWrapperValue (encodeWrapperValue),+  )+import Data.Morpheus.Types.Internal.AST+  ( CONST,+    IN,+    ObjectEntry (..),+    VALID,+    ValidValue,+    Value (..),+  )+import GHC.Generics+import GHC.TypeLits (KnownSymbol)+import Relude++class KindedValue gql args (kind :: DerivingKind) (a :: Type) where+  encodeKindedValue :: UseDeriving gql args -> ContextValue kind a -> GQLResult (Value CONST)+  decodeKindedValue :: UseDeriving gql args -> Proxy kind -> ValidValue -> ResolverState a++instance (EncodeScalar a, DecodeScalar a, gql a) => KindedValue gql args SCALAR a where+  encodeKindedValue _ = pure . Scalar . encodeScalar . unContextValue+  decodeKindedValue dir _ = withScalar (useTypename (dirGQL dir) (InputType :: CatType IN a)) decodeScalar++instance (DecodeWrapperConstraint f a, DecodeWrapper f, EncodeWrapperValue f, args a) => KindedValue gql args WRAPPER (f a) where+  encodeKindedValue dir = encodeWrapperValue (useEncodeValue (dirArgs dir)) . unContextValue+  decodeKindedValue dir _ value =+    runExceptT (decodeWrapper (useDecodeValue (dirArgs dir)) value)+      >>= handleEither++instance (gql a, Generic a, DecodeRep gql args (Rep a), GRep gql args (GQLResult (Value CONST)) (Rep a)) => KindedValue gql args TYPE a where+  encodeKindedValue UseDeriving {..} =+    repValue+      . deriveValue+        ( RepContext+            { optApply = useEncodeValue dirArgs . runIdentity,+              optTypeData = useTypeData dirGQL . inputType+            } ::+            RepContext gql args Identity (GQLResult (Value CONST))+        )+      . unContextValue+  decodeKindedValue dir _ = fmap to . (`runReaderT` context) . decodeRep dir+    where+      context =+        Context+          { isVariantRef = False,+            typeName = useTypename (dirGQL dir) (InputType :: CatType IN a),+            enumVisitor = visitEnumName dir proxy,+            fieldVisitor = visitFieldName dir proxy+          }+        where+          proxy = Proxy @a++instance KindedValue gql args CUSTOM (Value CONST) where+  encodeKindedValue _ = pure . unContextValue+  decodeKindedValue _ _ = pure . toConstValue++toConstValue :: ValidValue -> Value CONST+toConstValue Null = Null+toConstValue (Enum x) = Enum x+toConstValue (Scalar x) = Scalar x+toConstValue (List xs) = List (map toConstValue xs)+toConstValue (Object fields) = Object (fmap toEntry fields)+  where+    toEntry :: ObjectEntry VALID -> ObjectEntry CONST+    toEntry ObjectEntry {..} = ObjectEntry {entryValue = toConstValue entryValue, ..}++instance (KnownSymbol name, args a) => KindedValue gql args CUSTOM (Arg name a) where+  encodeKindedValue _ _ = throwError "directives cant be tagged arguments"+  decodeKindedValue UseDeriving {dirArgs} _ value = Arg <$> withInputObject fieldDecoder value+    where+      fieldDecoder = decodeFieldWith (useDecodeValue dirArgs) fieldName+      fieldName = symbolName (Proxy @name)++--  Map+instance (Ord k, val [(k, v)]) => KindedValue gql val CUSTOM (Map k v) where+  decodeKindedValue dir _ v = M.fromList <$> (useDecodeValue (dirArgs dir) v :: ResolverState [(k, v)])+  encodeKindedValue dir = useEncodeValue (dirArgs dir) . M.toList . unContextValue
− src/Data/Morpheus/Server/Deriving/Named/Encode.hs 
@@ -1,56 +0,0 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE NoImplicitPrelude #-}--module Data.Morpheus.Server.Deriving.Named.Encode-  ( deriveNamedModel,-    EncodeNamedConstraints,-  )-where--import Data.Morpheus.App.Internal.Resolving-  ( NamedResolver (..),-    Resolver,-    RootResolverValue (..),-  )-import Data.Morpheus.Server.Deriving.Named.EncodeType-  ( EncodeTypeConstraint,-    deriveResolver,-  )-import Data.Morpheus.Server.Deriving.Utils.GTraversable-  ( traverseTypes,-  )-import Data.Morpheus.Server.NamedResolvers (NamedResolverT (..))-import Data.Morpheus.Server.Resolvers-  ( NamedResolvers (..),-  )-import Data.Morpheus.Types.Internal.AST-  ( QUERY,-  )-import qualified GHC.Exts as HM-import Relude--type EncodeNamedConstraints e m query mut sub =-  (EncodeTypeConstraint (Resolver QUERY e m) query)--deriveNamedModel ::-  forall e m query mut sub.-  (Monad m, EncodeNamedConstraints e m query mut sub) =>-  NamedResolvers m e query mut sub ->-  RootResolverValue e m-deriveNamedModel NamedResolvers =-  NamedResolversValue $-    HM.fromList $-      map (\x -> (resolverName x, x)) $-        join $-          toList $-            traverseTypes deriveResolver (Proxy @(query (NamedResolverT (Resolver QUERY e m))))
− src/Data/Morpheus/Server/Deriving/Named/EncodeType.hs 
@@ -1,129 +0,0 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE NoImplicitPrelude #-}--module Data.Morpheus.Server.Deriving.Named.EncodeType-  ( deriveResolver,-    EncodeTypeConstraint,-    DeriveNamedResolver (..),-  )-where--import Data.Morpheus.App.Internal.Resolving-  ( LiftOperation,-    NamedResolver (..),-    NamedResolverResult (..),-    Resolver,-    liftResolverState,-  )-import Data.Morpheus.Server.Deriving.Decode-  ( Decode,-    decode,-  )-import Data.Morpheus.Server.Deriving.Named.EncodeValue-  ( EncodeFieldKind,-    FieldConstraint,-    encodeResolverValue,-    getTypeName,-  )-import Data.Morpheus.Server.Deriving.Utils.GTraversable-import Data.Morpheus.Server.Deriving.Utils.Kinded (KindedProxy (KindedProxy))-import Data.Morpheus.Server.NamedResolvers (Dependency, NamedResolverT (..), ResolveNamed (..))-import Data.Morpheus.Server.Types.GQLType-  ( GQLType,-    KIND,-  )-import Data.Morpheus.Server.Types.Kind-  ( CUSTOM,-    DerivingKind,-    SCALAR,-    TYPE,-    WRAPPER,-  )-import Data.Morpheus.Types.GQLScalar (EncodeScalar (..))-import Data.Morpheus.Types.Internal.AST-  ( ValidValue,-  )-import Relude--deriveResolver :: Mappable (DeriveNamedResolver m) [NamedResolver m] KindedProxy-deriveResolver = Mappable deriveNamedResolver--type EncodeTypeConstraint m a =-  ( GFmap-      (ScanConstraint (DeriveNamedResolver m))-      (KIND (a (NamedResolverT m)))-      (a (NamedResolverT m)),-    DeriveNamedResolver-      m-      (KIND (a (NamedResolverT m)))-      (a (NamedResolverT m)),-    GQLType (a (NamedResolverT m))-  )--class DeriveNamedResolver (m :: Type -> Type) (k :: DerivingKind) a where-  deriveNamedResolver :: f k a -> [NamedResolver m]--instance-  ( GQLType a,-    DecodeValuesConstraint o e m a,-    EncodeScalar a-  ) =>-  DeriveNamedResolver (Resolver o e m) SCALAR a-  where-  deriveNamedResolver _ =-    [ NamedResolver-        { resolverName = getTypeName proxy,-          resolverFun = decodeValues proxy >=> pure . map (maybe NamedNullResolver (NamedScalarResolver . encodeScalar))-        }-    ]-    where-      proxy = Proxy @a--type DecodeValuesConstraint o e m a =-  ( LiftOperation o,-    ResolveNamed (Resolver o e m) a,-    Monad m,-    Decode (Dependency a)-  )--decodeValues :: forall o e m a. DecodeValuesConstraint o e m a => Proxy a -> [ValidValue] -> Resolver o e m [Maybe a]-decodeValues _ xs = traverse decodeArg xs >>= resolveBatched-  where-    decodeArg :: ValidValue -> Resolver o e m (Dependency a)-    decodeArg = liftResolverState . decode--instance-  ( GQLType a,-    DecodeValuesConstraint o e m a,-    EncodeFieldKind (KIND a) (Resolver o e m) a,-    FieldConstraint (Resolver o e m) a-  ) =>-  DeriveNamedResolver (Resolver o e m) TYPE (a :: Type)-  where-  deriveNamedResolver _ =-    [ NamedResolver-        { resolverName = getTypeName proxy,-          resolverFun = decodeValues proxy >=> encodeResolverValue-        }-    ]-    where-      proxy = Proxy @a--instance DeriveNamedResolver m (KIND a) a => DeriveNamedResolver m CUSTOM (NamedResolverT m a) where-  deriveNamedResolver _ = deriveNamedResolver (KindedProxy :: KindedProxy (KIND a) a)--instance DeriveNamedResolver m (KIND a) a => DeriveNamedResolver m CUSTOM (input -> a) where-  deriveNamedResolver _ = deriveNamedResolver (KindedProxy :: KindedProxy (KIND a) a)--instance DeriveNamedResolver m (KIND a) a => DeriveNamedResolver m WRAPPER (f a) where-  deriveNamedResolver _ = deriveNamedResolver (KindedProxy :: KindedProxy (KIND a) a)
− src/Data/Morpheus/Server/Deriving/Named/EncodeValue.hs 
@@ -1,209 +0,0 @@-{-# 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 UndecidableInstances #-}-{-# LANGUAGE NoImplicitPrelude #-}--module Data.Morpheus.Server.Deriving.Named.EncodeValue-  ( EncodeFieldKind,-    Encode,-    getTypeName,-    encodeResolverValue,-    FieldConstraint,-  )-where--import Control.Monad.Except (MonadError (..))-import Data.Aeson (ToJSON (..))-import Data.Morpheus.App.Internal.Resolving-  ( LiftOperation,-    NamedResolverRef (..),-    NamedResolverResult (..),-    ObjectTypeResolver (..),-    Resolver,-    ResolverValue (..),-    getArguments,-    liftResolverState,-    mkList,-    mkNull,-  )-import Data.Morpheus.Server.Deriving.Decode-  ( Decode,-    decodeArguments,-  )-import Data.Morpheus.Server.Deriving.Encode-  ( ContextValue (..),-  )-import Data.Morpheus.Server.Deriving.Schema.Directive (toFieldRes)-import Data.Morpheus.Server.Deriving.Utils-  ( ConsRep (..),-    DataType (..),-    FieldRep (..),-  )-import Data.Morpheus.Server.Deriving.Utils.DeriveGType-  ( DeriveValueOptions (..),-    DeriveWith,-    deriveValue,-  )-import Data.Morpheus.Server.Deriving.Utils.Kinded-import Data.Morpheus.Server.NamedResolvers-  ( NamedRef,-    NamedResolverT (..),-  )-import Data.Morpheus.Server.Types.GQLType-  ( GQLType (__type),-    KIND,-    deriveTypename,-    withDir,-    __typeData,-  )-import Data.Morpheus.Server.Types.Internal-  ( TypeData (gqlTypeName),-  )-import Data.Morpheus.Server.Types.Kind-  ( CUSTOM,-    DerivingKind,-    SCALAR,-    TYPE,-    WRAPPER,-  )-import Data.Morpheus.Types.GQLScalar-  ( EncodeScalar (..),-  )-import Data.Morpheus.Types.Internal.AST-  ( GQLError,-    OUT,-    TypeCategory (OUT),-    TypeName,-    ValidValue,-    Value (List),-    internal,-    replaceValue,-  )-import qualified GHC.Exts as HM-import GHC.Generics-  ( Generic (..),-  )-import Relude hiding (empty)--encodeResolverValue :: (MonadError GQLError m, FieldConstraint m a) => [Maybe a] -> m [NamedResolverResult m]-encodeResolverValue x = traverse encodeNode x-  where-    encodeNode (Just v) = convertNamedNode (Identity x) (getFieldValues v)-    encodeNode Nothing = pure NamedNullResolver--type FieldConstraint m a =-  ( GQLType a,-    Generic a,-    DeriveWith GQLType (Encode m) (m (ResolverValue m)) (Rep a)-  )--class Encode (m :: Type -> Type) res where-  encodeField :: res -> m (ResolverValue m)--instance (EncodeFieldKind (KIND a) m a) => Encode m a where-  encodeField resolver = encodeFieldKind (ContextValue resolver :: ContextValue (KIND a) a)--class EncodeFieldKind (k :: DerivingKind) (m :: Type -> Type) (a :: Type) where-  encodeFieldKind :: ContextValue k a -> m (ResolverValue m)--instance (EncodeScalar a, Monad m) => EncodeFieldKind SCALAR m a where-  encodeFieldKind = pure . ResScalar . encodeScalar . unContextValue--instance (FieldConstraint m a, MonadError GQLError m) => EncodeFieldKind TYPE m a where-  encodeFieldKind (ContextValue _) = throwError (internal "types are resolved by Refs")--instance (GQLType a, Applicative m, EncodeFieldKind (KIND a) m a) => EncodeFieldKind WRAPPER m [a] where-  encodeFieldKind = fmap ResList . traverse encodeField . unContextValue--instance (GQLType a, EncodeFieldKind (KIND a) m a, Applicative m) => EncodeFieldKind WRAPPER m (Maybe a) where-  encodeFieldKind (ContextValue (Just x)) = encodeField x-  encodeFieldKind (ContextValue Nothing) = pure mkNull--instance-  ( Monad m,-    GQLType a,-    EncodeFieldKind (KIND a) m a,-    ToJSON (NamedRef a)-  ) =>-  EncodeFieldKind CUSTOM m (NamedResolverT m a)-  where-  encodeFieldKind = encodeRef . unContextValue-    where-      name :: TypeName-      name = getTypeName (Proxy @a)-      encodeRef :: Monad m => NamedResolverT m a -> m (ResolverValue m)-      encodeRef (NamedResolverT ref) = do-        value <- replaceValue . toJSON <$> ref-        case value of-          (List ls) -> pure $ mkList $ map (packRef name) ls-          _ -> pure $ packRef name value--packRef :: Applicative m => TypeName -> ValidValue -> ResolverValue m-packRef name v = ResRef $ pure $ NamedResolverRef name [v]--instance-  ( Decode a,-    Monad m,-    Encode (Resolver o e m) b,-    LiftOperation o-  ) =>-  EncodeFieldKind CUSTOM (Resolver o e m) (a -> b)-  where-  encodeFieldKind (ContextValue f) =-    getArguments-      >>= liftResolverState . decodeArguments-      >>= encodeField . f--getFieldValues :: forall m a. FieldConstraint m a => a -> DataType (m (ResolverValue m))-getFieldValues =-  deriveValue-    ( DeriveValueOptions-        { __valueApply = encodeField,-          __valueTypeName = deriveTypename (OutputType :: CatType OUT a),-          __valueGetType = __typeData . outputType-        } ::-        DeriveValueOptions OUT GQLType (Encode m) (m (ResolverValue m))-    )--convertNamedNode ::-  (GQLType a, MonadError GQLError m) =>-  f a ->-  DataType (m (ResolverValue m)) ->-  m (NamedResolverResult m)-convertNamedNode-  proxy-  DataType-    { tyIsUnion,-      tyCons = ConsRep {consFields, consName}-    }-    | null consFields = pure $ NamedEnumResolver consName-    | tyIsUnion = deriveUnion consFields-    | otherwise =-        pure $-          NamedObjectResolver-            ObjectTypeResolver-              { objectFields = HM.fromList (toFieldRes withDir proxy <$> consFields)-              }--deriveUnion :: (MonadError GQLError m) => [FieldRep (m (ResolverValue m))] -> m (NamedResolverResult m)-deriveUnion [FieldRep {..}] =-  NamedUnionResolver <$> (fieldValue >>= getRef)-deriveUnion _ = throwError "only union references are supported!"--getRef :: MonadError GQLError m => ResolverValue m -> m NamedResolverRef-getRef (ResRef x) = x-getRef _ = throwError "only resolver references are supported!"--getTypeName :: GQLType a => f a -> TypeName-getTypeName proxy = gqlTypeName $ __type proxy OUT
+ src/Data/Morpheus/Server/Deriving/Resolvers.hs view
@@ -0,0 +1,145 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.Server.Deriving.Resolvers+  ( deriveResolvers,+    deriveNamedResolvers,+    DERIVE_RESOLVERS,+    DERIVE_NAMED_RESOLVERS,+  )+where++import Data.Morpheus.App.Internal.Resolving+  ( MonadResolver (MonadMutation, MonadQuery, MonadSubscription),+    NamedResolver (..),+    Resolver,+    ResolverValue,+    RootResolverValue (..),+  )+import Data.Morpheus.Internal.Ext (GQLResult)+import Data.Morpheus.Server.Deriving.Internal.Resolve.Explore+  ( EXPLORE,+    useObjectResolvers,+  )+import Data.Morpheus.Server.Deriving.Kinded.Channels+  ( CHANNELS,+    resolverChannels,+  )+import Data.Morpheus.Server.Deriving.Kinded.NamedResolver+  ( KindedNamedResolver (..),+  )+import Data.Morpheus.Server.Deriving.Kinded.NamedResolverFun (KindedNamedFunValue (..))+import Data.Morpheus.Server.Deriving.Utils.GScan+  ( ScanRef,+    Scanner (..),+    scan,+  )+import Data.Morpheus.Server.Deriving.Utils.Proxy+  ( ContextValue (..),+  )+import Data.Morpheus.Server.Deriving.Utils.Use (UseNamedResolver (..))+import Data.Morpheus.Server.Resolvers+  ( NamedResolverT (..),+    NamedResolvers (..),+    RootResolver (..),+  )+import Data.Morpheus.Server.Types.GQLType+  ( GQLResolver,+    GQLType (..),+    GQLValue,+    ignoreUndefined,+    kindedProxy,+    withDir,+    withRes,+  )+import Data.Morpheus.Types.Internal.AST+  ( QUERY,+  )+import Relude++class GQLNamedResolverFun (m :: Type -> Type) a where+  deriveNamedResFun :: a -> m (ResolverValue m)++class GQLType a => GQLNamedResolver (m :: Type -> Type) a where+  deriveNamedRes :: f a -> [NamedResolver m]+  deriveNamedRefs :: f a -> [ScanRef (GQLNamedResolver m)]++instance+  (GQLType a, KindedNamedResolver GQLNamedResolver GQLNamedResolverFun GQLType GQLValue m (KIND a) a) =>+  GQLNamedResolver m a+  where+  deriveNamedRes = kindedNamedResolver withNamed . kindedProxy+  deriveNamedRefs = kindedNamedRefs withNamed . kindedProxy++instance KindedNamedFunValue GQLNamedResolverFun GQLType GQLValue (KIND a) m a => GQLNamedResolverFun m a where+  deriveNamedResFun resolver = kindedNamedFunValue withNamed (ContextValue resolver :: ContextValue (KIND a) a)++withNamed :: UseNamedResolver GQLNamedResolver GQLNamedResolverFun GQLType GQLValue+withNamed =+  UseNamedResolver+    { namedDrv = withDir,+      useNamedFieldResolver = deriveNamedResFun,+      useDeriveNamedResolvers = deriveNamedRes,+      useDeriveNamedRefs = deriveNamedRefs+    }++deriveNamedResolver :: Scanner (GQLNamedResolver m) (NamedResolver m)+deriveNamedResolver = Scanner {scannerFun = deriveNamedRes, scannerRefs = deriveNamedRefs}++type ROOT (m :: Type -> Type) a = EXPLORE GQLType GQLResolver m (a m)++type DERIVE_RESOLVERS m query mut sub =+  ( CHANNELS GQLType GQLValue sub (MonadSubscription m),+    ROOT (MonadQuery m) query,+    ROOT (MonadMutation m) mut,+    ROOT (MonadSubscription m) sub+  )++type DERIVE_NAMED_RESOLVERS m query =+  ( GQLType (query (NamedResolverT m)),+    KindedNamedResolver+      GQLNamedResolver+      GQLNamedResolverFun+      GQLType+      GQLValue+      m+      (KIND (query (NamedResolverT m)))+      (query (NamedResolverT m))+  )++deriveResolvers ::+  (Monad m, DERIVE_RESOLVERS (Resolver QUERY e m) query mut sub) =>+  RootResolver m e query mut sub ->+  GQLResult (RootResolverValue e m)+deriveResolvers RootResolver {..} =+  pure+    RootResolverValue+      { queryResolver = useObjectResolvers withRes queryResolver,+        mutationResolver = useObjectResolvers withRes mutationResolver,+        subscriptionResolver = useObjectResolvers withRes subscriptionResolver,+        channelMap =+          ignoreUndefined (Identity subscriptionResolver)+            $> resolverChannels withDir subscriptionResolver+      }++deriveNamedResolvers ::+  forall e m query mut sub.+  (Monad m, DERIVE_NAMED_RESOLVERS (Resolver QUERY e m) query) =>+  NamedResolvers m e query mut sub ->+  RootResolverValue e m+deriveNamedResolvers NamedResolvers =+  NamedResolversValue $+    scan+      resolverName+      deriveNamedResolver+      (deriveNamedRefs (Proxy @(query (NamedResolverT (Resolver QUERY e m)))))
src/Data/Morpheus/Server/Deriving/Schema.hs view
@@ -14,107 +14,47 @@  module Data.Morpheus.Server.Deriving.Schema   ( compileTimeSchemaValidation,-    DeriveType,     deriveSchema,-    SchemaConstraints,-    SchemaT,+    SCHEMA,   ) where -import Data.Morpheus.App.Internal.Resolving-  ( Resolver,-  ) import Data.Morpheus.Core (defaultConfig, validateSchema)-import Data.Morpheus.Internal.Ext-import Data.Morpheus.Server.Deriving.Schema.DeriveKinded-  ( DERIVE_TYPE,-    toFieldContent,-  )-import Data.Morpheus.Server.Deriving.Schema.Internal+import Data.Morpheus.Internal.Ext (GQLResult)+import Data.Morpheus.Server.Deriving.Internal.Schema.Internal   ( fromSchema,   )-import Data.Morpheus.Server.Deriving.Schema.Object-  ( asObjectType,-  )-import Data.Morpheus.Server.Deriving.Schema.TypeContent-import Data.Morpheus.Server.Deriving.Utils.Kinded-  ( CatContext (OutputContext),-    outputType,+import Data.Morpheus.Server.Deriving.Internal.Schema.Type+  ( useDeriveObject,   ) import Data.Morpheus.Server.Types.GQLType-  ( DeriveType,-    GQLType (..),-    withDeriveType,-    withDir,+  ( GQLType (..),+    IgnoredResolver,+    ignoreUndefined,     withGQL,-    __isEmptyType,   ) import Data.Morpheus.Server.Types.SchemaT-  ( SchemaT,-    toSchema,+  ( toSchema,   ) import Data.Morpheus.Types.Internal.AST   ( CONST,-    MUTATION,-    OBJECT,-    OUT,-    QUERY,-    SUBSCRIPTION,     Schema (..),-    TypeDefinition (..),   ) import Language.Haskell.TH (Exp, Q) import Relude -type SchemaConstraints event (m :: Type -> Type) query mutation subscription =-  ( DERIVE_TYPE GQLType DeriveType OUT (query (Resolver QUERY event m)),-    DERIVE_TYPE GQLType DeriveType OUT (mutation (Resolver MUTATION event m)),-    DERIVE_TYPE GQLType DeriveType OUT (subscription (Resolver SUBSCRIPTION event m))-  )+type SCHEMA qu mu su = (GQLType (qu IgnoredResolver), GQLType (mu IgnoredResolver), GQLType (su IgnoredResolver))  -- | normal morpheus server validates schema at runtime (after the schema derivation). --   this method allows you to validate it at compile time.-compileTimeSchemaValidation ::-  (SchemaConstraints event m qu mu su) =>-  proxy (root m event qu mu su) ->-  Q Exp-compileTimeSchemaValidation =-  fromSchema . (deriveSchema >=> validateSchema True defaultConfig)--deriveSchema ::-  forall-    root-    proxy-    m-    e-    query-    mut-    subs.-  ( SchemaConstraints e m query mut subs-  ) =>-  proxy (root m e query mut subs) ->-  GQLResult (Schema CONST)-deriveSchema _ = toSchema schemaT-  where-    schemaT ::-      SchemaT-        OUT-        ( TypeDefinition OBJECT CONST,-          Maybe (TypeDefinition OBJECT CONST),-          Maybe (TypeDefinition OBJECT CONST)-        )-    schemaT =-      (,,)-        <$> deriveRoot (Proxy @(query (Resolver QUERY e m)))-        <*> deriveMaybeRoot (Proxy @(mut (Resolver MUTATION e m)))-        <*> deriveMaybeRoot (Proxy @(subs (Resolver SUBSCRIPTION e m)))------deriveMaybeRoot :: DERIVE_TYPE GQLType DeriveType OUT a => f a -> SchemaT OUT (Maybe (TypeDefinition OBJECT CONST))-deriveMaybeRoot proxy-  | __isEmptyType proxy = pure Nothing-  | otherwise = Just <$> asObjectType withGQL (deriveFieldsWith withDir (toFieldContent OutputContext withDir withDeriveType) . outputType) proxy+compileTimeSchemaValidation :: (SCHEMA qu mu su) => proxy (root m event qu mu su) -> Q Exp+compileTimeSchemaValidation = fromSchema . (deriveSchema >=> validateSchema True defaultConfig) -deriveRoot :: DERIVE_TYPE GQLType DeriveType OUT a => f a -> SchemaT OUT (TypeDefinition OBJECT CONST)-deriveRoot = asObjectType withGQL (deriveFieldsWith withDir (toFieldContent OutputContext withDir withDeriveType) . outputType)+deriveSchema :: forall root f m e qu mu su. SCHEMA qu mu su => f (root m e qu mu su) -> GQLResult (Schema CONST)+deriveSchema _ =+  toSchema+    ( (,,)+        <$> useDeriveObject withGQL (Proxy @(qu IgnoredResolver))+        <*> traverse (useDeriveObject withGQL) (ignoreUndefined (Proxy @(mu IgnoredResolver)))+        <*> traverse (useDeriveObject withGQL) (ignoreUndefined (Proxy @(su IgnoredResolver)))+    )
− src/Data/Morpheus/Server/Deriving/Schema/DeriveKinded.hs 
@@ -1,176 +0,0 @@-{-# 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.DeriveKinded-  ( DeriveKindedType (..),-    DeriveArgs (..),-    toFieldContent,-    DERIVE_TYPE,-  )-where--import Control.Monad.Except (throwError)-import Data.Morpheus.App.Internal.Resolving-  ( Resolver,-  )-import Data.Morpheus.Internal.Ext-import Data.Morpheus.Internal.Utils (singleton)-import Data.Morpheus.Server.Deriving.Schema.Internal-  ( CatType,-    TyContentM,-  )-import Data.Morpheus.Server.Deriving.Schema.TypeContent-import Data.Morpheus.Server.Deriving.Utils-  ( DeriveTypeOptions (..),-    DeriveWith,-    symbolName,-  )-import Data.Morpheus.Server.Deriving.Utils.Kinded-  ( CatContext (..),-    CatType (..),-    addContext,-    catMap,-    getCat,-    getCatContext,-    inputType,-    mkScalar,-    outputType,-    unliftKind,-  )-import Data.Morpheus.Server.Deriving.Utils.Use-import Data.Morpheus.Server.Types.Internal (TypeData (..))-import Data.Morpheus.Server.Types.Kind-  ( CUSTOM,-    DerivingKind,-    SCALAR,-    TYPE,-    WRAPPER,-  )-import Data.Morpheus.Server.Types.SchemaT-  ( SchemaT,-    extendImplements,-  )-import Data.Morpheus.Server.Types.Types-  ( Arg (..),-    TypeGuard,-  )-import Data.Morpheus.Types.GQLScalar-  ( DecodeScalar (..),-    scalarValidator,-  )-import Data.Morpheus.Types.Internal.AST-  ( ArgumentsDefinition,-    CONST,-    FieldContent (..),-    IN,-    OUT,-    ScalarDefinition (..),-    TRUE,-    TypeCategory (IN),-    TypeContent (..),-    TypeName,-    TypeRef (..),-    UnionMember (memberName),-    Value,-    fieldsToArguments,-    mkField,-  )-import GHC.Generics-import GHC.TypeLits-import Relude--type DERIVE_TYPE gql derive k a = (gql a, DeriveWith gql (derive k) (TyContentM k) (Rep a))--toFieldContent :: CatContext kind -> UseDirective gql dir -> UseDeriveType derive -> DeriveTypeOptions kind gql (derive kind) (TyContentM kind)-toFieldContent catCtx UseDirective {..} ops =-  DeriveTypeOptions-    { __typeGetType = \x -> __useTypeData dirGQL x (getCat catCtx),-      __typeApply = \proxy -> useDeriveType ops (addContext catCtx proxy) *> useDeriveContent ops (addContext catCtx proxy)-    }---- | DeriveType With specific Kind: 'kind': object, scalar, enum ...-class DeriveKindedType gql derive dir (cat :: TypeCategory) (kind :: DerivingKind) a where-  deriveKindedType :: UseDirective gql dir -> UseDeriveType derive -> CatType cat (f kind a) -> SchemaT cat ()-  deriveKindedContent :: UseDirective gql dir -> UseDeriveType derive -> CatType cat (f kind a) -> TyContentM cat-  deriveKindedContent _ _ _ = pure Nothing--instance (derive cat a) => DeriveKindedType gql derive dir cat WRAPPER (f a) where-  deriveKindedType _ UseDeriveType {..} = useDeriveType . catMap (Proxy @a)--instance (DecodeScalar a, gql a) => DeriveKindedType gql derive dir cat SCALAR a where-  deriveKindedType dirs _ proxy = insertTypeContent dirs (pure . mkScalar proxy . scalarValidator) (unliftKind proxy)--instance DERIVE_TYPE gql derive cat a => DeriveKindedType gql derive dir cat TYPE a where-  deriveKindedType dirs ops proxy = insertTypeContent dirs (deriveTypeContentWith dirs (toFieldContent (getCatContext proxy) dirs ops)) (unliftKind proxy)--instance (derive cat a) => DeriveKindedType gql derive dir cat CUSTOM (Resolver o e m a) where-  deriveKindedType _ UseDeriveType {..} = useDeriveType . catMap (Proxy @a)--instance (gql (Value CONST)) => DeriveKindedType gql derive dir cat CUSTOM (Value CONST) where-  deriveKindedType dirs _ proxy = insertTypeContent dirs (const $ pure $ mkScalar proxy $ ScalarDefinition pure) (unliftKind proxy)--instance (derive cat [(k, v)]) => DeriveKindedType gql derive dir cat CUSTOM (Map k v) where-  deriveKindedType _ UseDeriveType {..} = useDeriveType . catMap (Proxy @[(k, v)])--instance-  ( DERIVE_TYPE gql derive OUT interface,-    DERIVE_TYPE gql derive OUT union-  ) =>-  DeriveKindedType gql derive dir OUT CUSTOM (TypeGuard interface union)-  where-  deriveKindedType dir ops OutputType = do-    insertTypeContent dir (fmap DataInterface . deriveFieldsWith dir (toFieldContent OutputContext dir ops) . outputType) interfaceProxy-    content <- deriveTypeContentWith dir (toFieldContent OutputContext dir ops) (OutputType :: CatType OUT union)-    unionNames <- getUnionNames content-    extendImplements interfaceName unionNames-    where-      interfaceName :: TypeName-      interfaceName = useTypename (dirGQL dir) interfaceProxy-      interfaceProxy :: CatType OUT interface-      interfaceProxy = OutputType-      unionProxy :: CatType OUT union-      unionProxy = OutputType-      getUnionNames :: TypeContent TRUE OUT CONST -> SchemaT OUT [TypeName]-      getUnionNames DataUnion {unionMembers} = pure $ toList $ memberName <$> unionMembers-      getUnionNames DataObject {} = pure [useTypename (dirGQL dir) unionProxy]-      getUnionNames _ = throwError "guarded type must be an union or object"--instance (derive OUT b, dir a) => DeriveKindedType gql derive dir OUT CUSTOM (a -> b) where-  deriveKindedContent dir UseDeriveType {..} OutputType = do-    a <- useDeriveArguments (dirArgs dir) (Proxy @a)-    b <- useDeriveContent (OutputType :: CatType OUT b)-    case b of-      Just (FieldArgs x) -> Just . FieldArgs <$> (a <:> x)-      Nothing -> pure $ Just (FieldArgs a)-  deriveKindedType _ UseDeriveType {..} OutputType = useDeriveType (outputType $ Proxy @b)--class DeriveArgs gql derive (k :: DerivingKind) a where-  deriveArgs :: UseDirective gql dir -> UseDeriveType derive -> f k a -> SchemaT IN (ArgumentsDefinition CONST)--instance (DERIVE_TYPE gql derive IN a) => DeriveArgs gql derive TYPE a where-  deriveArgs dir ops = fmap fieldsToArguments . deriveFieldsWith dir (toFieldContent InputContext dir ops) . inputType--instance (KnownSymbol name, derive IN a, gql a) => DeriveArgs gql derive CUSTOM (Arg name a) where-  deriveArgs dir ops _ = do-    useDeriveType ops proxy-    pure $ fieldsToArguments $ singleton argName $ mkField Nothing argName argTypeRef-    where-      proxy :: CatType IN a-      proxy = InputType-      argName = symbolName (Proxy @name)-      argTypeRef = TypeRef {typeConName = gqlTypeName, typeWrappers = gqlWrappers}-      TypeData {gqlTypeName, gqlWrappers} = __useTypeData (dirGQL dir) proxy IN
− src/Data/Morpheus/Server/Deriving/Schema/Directive.hs 
@@ -1,204 +0,0 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# 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,-    visitFieldDefaultValue,-    visitFieldContent,-    visitEnumName,-    visitFieldName,-    toFieldRes,-    UseDirective (..),-  )-where--import qualified Data.HashMap.Lazy as HM-import Data.Morpheus.Internal.Ext (unsafeFromList)-import Data.Morpheus.Internal.Utils (Empty (..), fromElems)-import Data.Morpheus.Server.Deriving.Utils.Kinded-  ( CatType (..),-    KindedProxy (..),-  )-import Data.Morpheus.Server.Deriving.Utils.Types (FieldRep (..))-import Data.Morpheus.Server.Deriving.Utils.Use-  ( UseArguments (..),-    UseDirective (..),-    UseGQLType (..),-  )-import Data.Morpheus.Server.Types.Directives-  ( GDirectiveUsage (..),-    GDirectiveUsages (..),-    GQLDirective (..),-    applyEnumDescription,-    applyEnumName,-    applyFieldDefaultValue,-    applyFieldDescription,-    applyFieldName,-    applyTypeDescription,-    applyTypeEnumNames,-    applyTypeFieldNames,-    getLocations,-  )-import Data.Morpheus.Server.Types.SchemaT-  ( SchemaT,-    insertDirectiveDefinition,-    outToAny,-  )-import Data.Morpheus.Types.Internal.AST-  ( Argument (..),-    CONST,-    Description,-    Directive (..),-    DirectiveDefinition (..),-    Directives,-    FieldContent (..),-    FieldName,-    IN,-    Position (Position),-    TRUE,-    TypeCategory (..),-    TypeName,-    Value,-  )-import GHC.Generics ()-import GHC.TypeLits ()-import Relude hiding (empty)--deriveDirectiveDefinition ::-  forall a b kind gql args.-  (gql a, GQLDirective a, args a) =>-  UseDirective gql args ->-  a ->-  b ->-  SchemaT kind (DirectiveDefinition CONST)-deriveDirectiveDefinition options _ _ = do-  directiveDefinitionArgs <- outToAny (useDeriveArguments (dirArgs options) (Proxy @a))-  pure-    ( DirectiveDefinition-        { directiveDefinitionName = deriveDirectiveName (dirGQL options) proxy,-          directiveDefinitionDescription = visitTypeDescription options proxy Nothing,-          directiveDefinitionArgs,-          directiveDefinitionLocations = getLocations proxy-        }-    )-  where-    proxy = Proxy @a--deriveDirectiveUsages :: UseDirective gql args -> [GDirectiveUsage gql args] -> SchemaT kind (Directives CONST)-deriveDirectiveUsages options = fmap unsafeFromList . traverse (toDirectiveTuple options)--toDirectiveTuple ::-  UseDirective gql args ->-  GDirectiveUsage gql args ->-  SchemaT kind (FieldName, Directive CONST)-toDirectiveTuple options (GDirectiveUsage x) = do-  insertDirective options (deriveDirectiveDefinition options x) x-  let directiveName = deriveDirectiveName (dirGQL options) (Identity x)-  args <- toList <$> useEncodeArguments (dirArgs options) x-  directiveArgs <- fromElems (map editArg args)-  pure-    ( directiveName,-      Directive-        { directivePosition = Position 0 0,-          directiveName,-          directiveArgs-        }-    )-  where-    editArg Argument {..} = Argument {argumentName = applyGQLFieldOptions options (Identity x) argumentName, ..}--insertDirective ::-  forall gql args a k.-  gql a =>-  UseDirective gql args ->-  (KindedProxy IN a -> SchemaT k (DirectiveDefinition CONST)) ->-  a ->-  SchemaT k ()-insertDirective ops f _ = insertDirectiveDefinition (__useFingerprint (dirGQL ops) IN (Proxy :: Proxy a)) f proxy-  where-    proxy = KindedProxy :: KindedProxy IN a--getDirHM :: (Ord k, Hashable k, Empty a) => k -> HashMap k a -> a-getDirHM name xs = fromMaybe empty $ name `HM.lookup` xs--isIncluded :: GDirectiveUsage gql args -> Bool-isIncluded (GDirectiveUsage x) = not $ excludeFromSchema (Identity x)--getEnumDirectiveUsages :: gql a => UseDirective gql args -> f a -> TypeName -> [GDirectiveUsage gql args]-getEnumDirectiveUsages UseDirective {..} proxy name = getDirHM name $ enumValueDirectives $ __directives proxy--getFieldDirectiveUsages :: gql a => UseDirective gql args -> FieldName -> f a -> [GDirectiveUsage gql args]-getFieldDirectiveUsages UseDirective {..} name proxy = getDirHM name $ fieldDirectives $ __directives proxy---- derive directives-deriveEnumDirectives :: gql a => UseDirective gql args -> f a -> TypeName -> SchemaT k (Directives CONST)-deriveEnumDirectives options proxy name = deriveDirectiveUsages options $ filter isIncluded $ getEnumDirectiveUsages options proxy name--deriveFieldDirectives :: gql a => UseDirective gql args -> f a -> FieldName -> SchemaT kind (Directives CONST)-deriveFieldDirectives options proxy name = deriveDirectiveUsages options $ filter isIncluded $ getFieldDirectiveUsages options name proxy--deriveTypeDirectives :: gql a => UseDirective gql args -> f a -> SchemaT kind (Directives CONST)-deriveTypeDirectives options proxy = deriveDirectiveUsages options $ filter isIncluded $ typeDirectives $ __directives options proxy---- visit--visitEnumValueDescription :: gql a => UseDirective gql args -> f a -> TypeName -> Maybe Description -> Maybe Description-visitEnumValueDescription options proxy name desc = foldr applyEnumDescription desc (getEnumDirectiveUsages options proxy name)--visitEnumName :: gql a => UseDirective gql args -> f a -> TypeName -> TypeName-visitEnumName options proxy name = foldr applyEnumName (withTypeDirectives name) (getEnumDirectiveUsages options proxy name)-  where-    withTypeDirectives dirName = foldr applyTypeEnumNames dirName (typeDirectives $ __directives options proxy)--visitFieldDescription :: gql a => UseDirective gql args -> f a -> FieldName -> Maybe Description -> Maybe Description-visitFieldDescription options proxy name desc = foldr applyFieldDescription desc (getFieldDirectiveUsages options name proxy)--visitFieldDefaultValue :: gql a => UseDirective gql args -> f a -> FieldName -> Maybe (Value CONST) -> Maybe (Value CONST)-visitFieldDefaultValue options proxy name desc = foldr applyFieldDefaultValue desc (getFieldDirectiveUsages options name proxy)--visitFieldContent ::-  gql a =>-  UseDirective gql args ->-  CatType kind a ->-  FieldName ->-  Maybe (FieldContent TRUE kind CONST) ->-  Maybe (FieldContent TRUE kind CONST)-visitFieldContent options proxy@InputType name x =-  DefaultInputValue-    <$> visitFieldDefaultValue options proxy name (defaultInputValue <$> x)-visitFieldContent _ OutputType _ x = x--applyGQLFieldOptions :: gql a => UseDirective gql args -> f a -> FieldName -> FieldName-applyGQLFieldOptions options proxy = withTypeDirectives-  where-    withTypeDirectives name = foldr applyTypeFieldNames name (typeDirectives $ __directives options proxy)--visitFieldName :: gql a => UseDirective gql args -> f a -> FieldName -> FieldName-visitFieldName options proxy name = foldr applyFieldName (applyGQLFieldOptions options proxy name) (getFieldDirectiveUsages options name proxy)--visitTypeDescription :: gql a => UseDirective gql args -> f a -> Maybe Description -> Maybe Description-visitTypeDescription options proxy desc = foldr applyTypeDescription desc (typeDirectives $ __directives options proxy)--toFieldRes :: gql a => UseDirective gql args -> f a -> FieldRep v -> (FieldName, v)-toFieldRes options proxy FieldRep {..} = (visitFieldName options proxy fieldSelector, fieldValue)--deriveDirectiveName :: gql a => UseGQLType gql -> f a -> FieldName-deriveDirectiveName options proxy = coerce $ __useTypename options IN proxy
− src/Data/Morpheus/Server/Deriving/Schema/Enum.hs 
@@ -1,56 +0,0 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE RecordWildCards #-}--module Data.Morpheus.Server.Deriving.Schema.Enum-  ( buildEnumTypeContent,-    defineEnumUnit,-  )-where--import Data.Morpheus.Server.Deriving.Schema.Directive-  ( UseDirective,-    deriveEnumDirectives,-    visitEnumName,-    visitEnumValueDescription,-  )-import Data.Morpheus.Server.Deriving.Utils.Kinded-  ( CatType (..),-  )-import Data.Morpheus.Server.Types.SchemaT-  ( SchemaT,-    insertType,-  )-import Data.Morpheus.Types.Internal.AST-  ( CONST,-    DataEnumValue (..),-    LEAF,-    TRUE,-    TypeContent (..),-    TypeDefinition,-    TypeName,-    mkEnumContent,-    mkType,-    unitTypeName,-  )--buildEnumTypeContent :: gql a => UseDirective gql args -> CatType kind a -> [TypeName] -> SchemaT k (TypeContent TRUE kind CONST)-buildEnumTypeContent options p@InputType enumCons = DataEnum <$> traverse (mkEnumValue options p) enumCons-buildEnumTypeContent options p@OutputType enumCons = DataEnum <$> traverse (mkEnumValue options p) enumCons--mkEnumValue :: gql a => UseDirective gql args -> f a -> TypeName -> SchemaT k (DataEnumValue CONST)-mkEnumValue options proxy enumName = do-  enumDirectives <- deriveEnumDirectives options proxy enumName-  pure-    DataEnumValue-      { enumName = visitEnumName options proxy enumName,-        enumDescription = visitEnumValueDescription options proxy enumName Nothing,-        ..-      }--defineEnumUnit :: SchemaT cat ()-defineEnumUnit =-  insertType-    ( mkType unitTypeName (mkEnumContent [unitTypeName]) ::-        TypeDefinition LEAF CONST-    )
− src/Data/Morpheus/Server/Deriving/Schema/Internal.hs 
@@ -1,57 +0,0 @@-{-# 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.Schema.Internal-  ( CatType (..),-    TyContentM,-    TyContent,-    fromSchema,-  )-where---- MORPHEUS--import Data.Morpheus.Internal.Ext-  ( GQLResult,-    Result (Failure, Success, errors),-  )-import Data.Morpheus.Server.Deriving.Utils.Kinded-  ( CatType (..),-  )-import Data.Morpheus.Server.Types.SchemaT-  ( SchemaT,-  )-import Data.Morpheus.Types.Internal.AST-  ( CONST,-    FieldContent (..),-    Schema (..),-    TRUE,-    VALID,-  )-import Language.Haskell.TH (Exp, Q)-import Relude hiding (empty)--fromSchema :: GQLResult (Schema VALID) -> Q Exp-fromSchema Success {} = [|()|]-fromSchema Failure {errors} = fail (show errors)--type TyContentM kind = SchemaT kind (TyContent kind)--type TyContent kind = Maybe (FieldContent TRUE kind CONST)
− src/Data/Morpheus/Server/Deriving/Schema/Object.hs 
@@ -1,137 +0,0 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RecordWildCards #-}--module Data.Morpheus.Server.Deriving.Schema.Object-  ( asObjectType,-    withObject,-    buildObjectTypeContent,-    defineObjectType,-  )-where--import Control.Monad.Except (throwError)-import Data.Morpheus.Internal.Utils-  ( empty,-    singleton,-  )-import Data.Morpheus.Server.Deriving.Schema.Directive-  ( UseDirective,-    deriveFieldDirectives,-    visitFieldContent,-    visitFieldDescription,-    visitFieldName,-  )-import Data.Morpheus.Server.Deriving.Schema.Enum (defineEnumUnit)-import Data.Morpheus.Server.Deriving.Utils-  ( ConsRep (..),-    FieldRep (..),-  )-import Data.Morpheus.Server.Deriving.Utils.Kinded-  ( CatType (..),-    outputType,-  )-import Data.Morpheus.Server.Deriving.Utils.Use (UseGQLType, useTypename)-import Data.Morpheus.Server.Types.SchemaT-  ( SchemaT,-    insertType,-  )-import Data.Morpheus.Types.Internal.AST-  ( CONST,-    FieldContent (..),-    FieldDefinition (..),-    FieldsDefinition,-    OBJECT,-    OUT,-    TRUE,-    TypeContent (..),-    TypeDefinition,-    mkField,-    mkType,-    mkTypeRef,-    msg,-    unitFieldName,-    unitTypeName,-    unsafeFromFields,-  )-import Relude hiding (empty)--defineObjectType ::-  CatType kind a ->-  ConsRep (Maybe (FieldContent TRUE kind CONST)) ->-  SchemaT cat ()-defineObjectType proxy ConsRep {consName, consFields} = insertType . mkType consName . mkObjectTypeContent proxy =<< fields-  where-    fields-      | null consFields = defineEnumUnit $> singleton unitFieldName mkFieldUnit-      | otherwise = pure $ unsafeFromFields $ map repToFieldDefinition consFields--mkFieldUnit :: FieldDefinition cat s-mkFieldUnit = mkField Nothing unitFieldName (mkTypeRef unitTypeName)--buildObjectTypeContent ::-  gql a =>-  UseDirective gql args ->-  CatType cat a ->-  [FieldRep (Maybe (FieldContent TRUE cat CONST))] ->-  SchemaT k (TypeContent TRUE cat CONST)-buildObjectTypeContent options scope consFields = do-  xs <- traverse (setGQLTypeProps options scope . repToFieldDefinition) consFields-  pure $ mkObjectTypeContent scope $ unsafeFromFields xs--repToFieldDefinition ::-  FieldRep (Maybe (FieldContent TRUE kind CONST)) ->-  FieldDefinition kind CONST-repToFieldDefinition-  FieldRep-    { fieldSelector = fieldName,-      fieldTypeRef = fieldType,-      fieldValue-    } =-    FieldDefinition-      { fieldDescription = mempty,-        fieldDirectives = empty,-        fieldContent = fieldValue,-        ..-      }--asObjectType ::-  (gql a) =>-  UseGQLType gql ->-  (f a -> SchemaT kind (FieldsDefinition OUT CONST)) ->-  f a ->-  SchemaT kind (TypeDefinition OBJECT CONST)-asObjectType gql f proxy =-  mkType-    (useTypename gql (outputType proxy))-    . DataObject []-    <$> f proxy--withObject :: (gql a) => UseGQLType gql -> CatType c a -> TypeContent TRUE any s -> SchemaT c (FieldsDefinition c s)-withObject _ InputType DataInputObject {inputObjectFields} = pure inputObjectFields-withObject _ OutputType DataObject {objectFields} = pure objectFields-withObject gql x _ = failureOnlyObject gql x--failureOnlyObject :: (gql a) => UseGQLType gql -> CatType c a -> SchemaT c b-failureOnlyObject gql proxy = throwError $ msg (useTypename gql proxy) <> " should have only one nonempty constructor"--mkObjectTypeContent :: CatType kind a -> FieldsDefinition kind CONST -> TypeContent TRUE kind CONST-mkObjectTypeContent InputType = DataInputObject-mkObjectTypeContent OutputType = DataObject []--setGQLTypeProps :: gql a => UseDirective gql args -> CatType kind a -> FieldDefinition kind CONST -> SchemaT k (FieldDefinition kind CONST)-setGQLTypeProps options proxy FieldDefinition {..} = do-  dirs <- deriveFieldDirectives options proxy fieldName-  pure-    FieldDefinition-      { fieldName = visitFieldName options proxy fieldName,-        fieldDescription = visitFieldDescription options proxy fieldName Nothing,-        fieldContent = visitFieldContent options proxy fieldName fieldContent,-        fieldDirectives = dirs,-        ..-      }
− src/Data/Morpheus/Server/Deriving/Schema/TypeContent.hs 
@@ -1,104 +0,0 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Data.Morpheus.Server.Deriving.Schema.TypeContent-  ( buildTypeContent,-    insertTypeContent,-    deriveTypeContentWith,-    deriveFieldsWith,-  )-where--import Data.Morpheus.Server.Deriving.Schema.Directive (UseDirective (..), deriveTypeDirectives, visitTypeDescription)-import Data.Morpheus.Server.Deriving.Schema.Enum-  ( buildEnumTypeContent,-  )-import Data.Morpheus.Server.Deriving.Schema.Internal-  ( CatType,-    TyContent,-  )-import Data.Morpheus.Server.Deriving.Schema.Object-  ( buildObjectTypeContent,-    withObject,-  )-import Data.Morpheus.Server.Deriving.Schema.Union (buildUnionTypeContent)-import Data.Morpheus.Server.Deriving.Utils-  ( ConsRep (..),-    DeriveTypeOptions,-    DeriveWith,-    deriveTypeWith,-    isEmptyConstraint,-    unpackMonad,-  )-import Data.Morpheus.Server.Deriving.Utils.Kinded (typeCat)-import Data.Morpheus.Server.Deriving.Utils.Use-  ( UseGQLType (..),-  )-import Data.Morpheus.Server.Types.SchemaT-  ( SchemaT,-    updateSchema,-  )-import Data.Morpheus.Types.Internal.AST-import GHC.Generics (Rep)--buildTypeContent ::-  (gql a) =>-  UseDirective gql args ->-  CatType kind a ->-  [ConsRep (TyContent kind)] ->-  SchemaT kind (TypeContent TRUE kind CONST)-buildTypeContent options scope cons | all isEmptyConstraint cons = buildEnumTypeContent options scope (consName <$> cons)-buildTypeContent options scope [ConsRep {consFields}] = buildObjectTypeContent options scope consFields-buildTypeContent options scope cons = buildUnionTypeContent (dirGQL options) scope cons--insertTypeContent ::-  forall k gql args a.-  (gql a) =>-  UseDirective gql args ->-  (CatType k a -> SchemaT k (TypeContent TRUE k CONST)) ->-  CatType k a ->-  SchemaT k ()-insertTypeContent options@UseDirective {dirGQL = UseGQLType {..}} f proxy =-  updateSchema-    (__useFingerprint category proxy)-    deriveD-    proxy-  where-    category = typeCat proxy-    deriveD x = do-      content <- f x-      dirs <- deriveTypeDirectives options proxy-      pure $-        TypeDefinition-          (visitTypeDescription options proxy Nothing)-          (__useTypename category proxy)-          dirs-          content--deriveTypeContentWith ::-  ( DeriveWith gql derive (SchemaT kind (TyContent kind)) (Rep a),-    gql a-  ) =>-  UseDirective gql args ->-  DeriveTypeOptions kind gql derive (SchemaT kind (TyContent kind)) ->-  CatType kind a ->-  SchemaT kind (TypeContent TRUE kind CONST)-deriveTypeContentWith options x kindedProxy =-  unpackMonad-    ( deriveTypeWith x kindedProxy-    )-    >>= buildTypeContent options kindedProxy--deriveFieldsWith ::-  ( gql a,-    DeriveWith gql derive (SchemaT cat (TyContent cat)) (Rep a)-  ) =>-  UseDirective gql args ->-  DeriveTypeOptions cat gql derive (SchemaT cat (TyContent cat)) ->-  CatType cat a ->-  SchemaT cat (FieldsDefinition cat CONST)-deriveFieldsWith dirs cont kindedType = deriveTypeContentWith dirs cont kindedType >>= withObject (dirGQL dirs) kindedType
− src/Data/Morpheus/Server/Deriving/Schema/Union.hs 
@@ -1,81 +0,0 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE GADTs #-}--module Data.Morpheus.Server.Deriving.Schema.Union-  ( buildUnionTypeContent,-  )-where--import Data.List (partition)-import Data.Morpheus.Internal.Utils (fromElems)-import Data.Morpheus.Server.Deriving.Schema.Enum-  ( defineEnumUnit,-  )-import Data.Morpheus.Server.Deriving.Schema.Object-  ( defineObjectType,-  )-import Data.Morpheus.Server.Deriving.Utils-  ( ConsRep (..),-    fieldTypeName,-    isEmptyConstraint,-    isUnionRef,-  )-import Data.Morpheus.Server.Deriving.Utils.Kinded-  ( CatType (..),-  )-import Data.Morpheus.Server.Deriving.Utils.Use (UseGQLType (..), useTypename)-import Data.Morpheus.Server.Types.SchemaT-  ( SchemaT,-  )-import Data.Morpheus.Types.Internal.AST-  ( CONST,-    FieldContent (..),-    IN,-    TRUE,-    TypeContent (..),-    TypeName,-    UnionMember (..),-    mkNullaryMember,-    mkUnionMember,-  )-import Relude--buildUnionTypeContent ::-  (gql a) =>-  UseGQLType gql ->-  CatType kind a ->-  [ConsRep (Maybe (FieldContent TRUE kind CONST))] ->-  SchemaT k (TypeContent TRUE kind CONST)-buildUnionTypeContent gql scope cons = mkUnionType scope unionRef unionCons-  where-    unionRef = fieldTypeName <$> concatMap consFields unionRefRep-    (unionRefRep, unionCons) = partition (isUnionRef (useTypename gql scope)) cons--mkUnionType ::-  CatType kind a ->-  [TypeName] ->-  [ConsRep (Maybe (FieldContent TRUE kind CONST))] ->-  SchemaT c (TypeContent TRUE kind CONST)-mkUnionType p@InputType unionRef unionCons = DataInputUnion <$> (typeMembers >>= fromElems)-  where-    (nullaryCons, cons) = partition isEmptyConstraint unionCons-    nullaryMembers :: [UnionMember IN CONST]-    nullaryMembers = mkNullaryMember . consName <$> nullaryCons-    defineEnumEmpty-      | null nullaryCons = pure ()-      | otherwise = defineEnumUnit-    typeMembers =-      (<> nullaryMembers) . withRefs-        <$> ( defineEnumEmpty *> buildUnions p cons-            )-      where-        withRefs = fmap mkUnionMember . (unionRef <>)-mkUnionType p@OutputType unionRef unionCons =-  DataUnion <$> (buildUnions p unionCons >>= fromElems . map mkUnionMember . (unionRef <>))--buildUnions ::-  CatType kind a ->-  [ConsRep (Maybe (FieldContent TRUE kind CONST))] ->-  SchemaT c [TypeName]-buildUnions proxy cons =-  traverse_ (defineObjectType proxy) cons $> fmap consName cons
− src/Data/Morpheus/Server/Deriving/Utils.hs 
@@ -1,40 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}--module Data.Morpheus.Server.Deriving.Utils-  ( conNameProxy,-    isRecordProxy,-    selNameProxy,-    ConsRep (..),-    FieldRep (..),-    isEmptyConstraint,-    isUnionRef,-    fieldTypeName,-    unpackMonad,-    symbolName,-    DataType (..),-    DeriveWith (..),-    DeriveTypeOptions (..),-    deriveTypeWith,-  )-where--import Data.Morpheus.Server.Deriving.Utils.DeriveGType-  ( DeriveTypeOptions (..),-    DeriveWith (..),-    deriveTypeWith,-  )-import Data.Morpheus.Server.Deriving.Utils.Proxy-  ( conNameProxy,-    isRecordProxy,-    selNameProxy,-    symbolName,-  )-import Data.Morpheus.Server.Deriving.Utils.Types-  ( ConsRep (..),-    DataType (..),-    FieldRep (..),-    fieldTypeName,-    isEmptyConstraint,-    isUnionRef,-    unpackMonad,-  )
+ src/Data/Morpheus/Server/Deriving/Utils/AST.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE RecordWildCards #-}++module Data.Morpheus.Server.Deriving.Utils.AST+  ( argumentsToObject,+  )+where++import Data.Morpheus.Types.Internal.AST+  ( Argument (..),+    Arguments,+    ObjectEntry (..),+    VALID,+    Value (..),+  )++argumentsToObject :: Arguments VALID -> Value VALID+argumentsToObject = Object . fmap toEntry+  where+    toEntry Argument {..} = ObjectEntry argumentName argumentValue
− src/Data/Morpheus/Server/Deriving/Utils/Decode.hs 
@@ -1,191 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE NoImplicitPrelude #-}--module Data.Morpheus.Server.Deriving.Utils.Decode-  ( withInputObject,-    withEnum,-    withInputUnion,-    decodeFieldWith,-    withScalar,-    handleEither,-    getFieldName,-    DecoderT,-    setVariantRef,-    Context (..),-    getUnionInfos,-    DescribeCons,-    DescribeFields (countFields),-  )-where--import Control.Monad.Except (MonadError (throwError))-import Data.Morpheus.App.Internal.Resolving (ResolverState)-import Data.Morpheus.Internal.Utils-  ( selectOr,-  )-import Data.Morpheus.Server.Deriving.Utils (conNameProxy)-import Data.Morpheus.Server.Deriving.Utils.Kinded (CatType (..))-import Data.Morpheus.Server.Types.GQLType-  ( GQLType,-    deriveTypename,-  )-import Data.Morpheus.Types.GQLScalar-  ( toScalar,-  )-import Data.Morpheus.Types.Internal.AST-  ( FieldName,-    GQLError,-    IN,-    Msg (msg),-    ObjectEntry (..),-    ScalarValue,-    Token,-    TypeName,-    VALID,-    ValidObject,-    ValidValue,-    Value (..),-    getInputUnionValue,-    internal,-  )-import GHC.Generics-import Relude--withInputObject ::-  MonadError GQLError m =>-  (ValidObject -> m a) ->-  ValidValue ->-  m a-withInputObject f (Object object) = f object-withInputObject _ isType = throwError (typeMismatch "InputObject" isType)---- | Useful for more restrictive instances of lists (non empty, size indexed etc)-withEnum :: MonadError GQLError m => (TypeName -> m a) -> Value VALID -> m a-withEnum decode (Enum value) = decode value-withEnum _ isType = throwError (typeMismatch "Enum" isType)--withInputUnion ::-  (MonadError GQLError m, Monad m) =>-  (TypeName -> ValidObject -> ValidObject -> m a) ->-  ValidObject ->-  m a-withInputUnion decoder unions =-  either onFail onSuccess (getInputUnionValue unions)-  where-    onSuccess (name, value) = withInputObject (decoder name unions) value-    onFail = throwError . internal . msg--withScalar ::-  (Applicative m, MonadError GQLError m) =>-  TypeName ->-  (ScalarValue -> Either Token a) ->-  Value VALID ->-  m a-withScalar typename decodeScalar value = case toScalar value >>= decodeScalar of-  Right scalar -> pure scalar-  Left message ->-    throwError-      ( typeMismatch-          ("SCALAR(" <> msg typename <> ")" <> msg message)-          value-      )--decodeFieldWith :: (Value VALID -> m a) -> FieldName -> ValidObject -> m a-decodeFieldWith decoder = selectOr (decoder Null) (decoder . entryValue)--handleEither :: MonadError GQLError m => Either GQLError a -> m a-handleEither = either throwError pure---- if value is already validated but value has different type-typeMismatch :: GQLError -> Value s -> GQLError-typeMismatch text jsType =-  internal $-    "Type mismatch! expected:"-      <> text-      <> ", got: "-      <> msg jsType--getFieldName :: FieldName -> Int -> FieldName-getFieldName "" index = "_" <> show index-getFieldName label _ = label--data VariantKind = InlineVariant | VariantRef deriving (Eq, Ord)--data Info = Info-  { kind :: VariantKind,-    tagName :: [TypeName]-  }--instance Semigroup Info where-  Info VariantRef t1 <> Info _ t2 = Info VariantRef (t1 <> t2)-  Info _ t1 <> Info VariantRef t2 = Info VariantRef (t1 <> t2)-  Info InlineVariant t1 <> Info InlineVariant t2 = Info InlineVariant (t1 <> t2)--data Context = Context-  { isVariantRef :: Bool,-    typeName :: TypeName,-    enumVisitor :: TypeName -> TypeName,-    fieldVisitor :: FieldName -> FieldName-  }--type DecoderT = ReaderT Context ResolverState--setVariantRef :: Bool -> DecoderT a -> DecoderT a-setVariantRef isVariantRef = local (\ctx -> ctx {isVariantRef})--class DescribeCons (f :: Type -> Type) where-  tags :: Proxy f -> Context -> Info--instance (Datatype d, DescribeCons f) => DescribeCons (M1 D d f) where-  tags _ = tags (Proxy @f)--instance (DescribeCons a, DescribeCons b) => DescribeCons (a :+: b) where-  tags _ = tags (Proxy @a) <> tags (Proxy @b)--instance (Constructor c, DescribeFields a) => DescribeCons (M1 C c a) where-  tags _ Context {typeName} = getTag (refType (Proxy @a))-    where-      getTag (Just memberRef)-        | isUnionRef memberRef = Info {kind = VariantRef, tagName = [memberRef]}-        | otherwise = Info {kind = InlineVariant, tagName = [consName]}-      getTag Nothing = Info {kind = InlineVariant, tagName = [consName]}-      ---------      consName = conNameProxy (Proxy @c)-      -----------      isUnionRef x = typeName <> x == consName--getUnionInfos ::-  forall f a b.-  (DescribeCons a, DescribeCons b) =>-  f (a :+: b) ->-  DecoderT (Bool, ([TypeName], [TypeName]))-getUnionInfos _ = do-  context <- ask-  let l = tags (Proxy @a) context-  let r = tags (Proxy @b) context-  let k = kind (l <> r)-  pure (k == VariantRef, (tagName l, tagName r))--class DescribeFields (f :: Type -> Type) where-  refType :: Proxy f -> Maybe TypeName-  countFields :: Proxy f -> Int--instance (DescribeFields f, DescribeFields g) => DescribeFields (f :*: g) where-  refType _ = Nothing-  countFields _ = countFields (Proxy @f) + countFields (Proxy @g)--instance (Selector s, GQLType a) => DescribeFields (M1 S s (K1 i a)) where-  refType _ = Just $ deriveTypename (InputType :: CatType IN a)-  countFields _ = 1--instance DescribeFields U1 where-  refType _ = Nothing-  countFields _ = 0
− src/Data/Morpheus/Server/Deriving/Utils/DeriveGType.hs 
@@ -1,148 +0,0 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE NoImplicitPrelude #-}--module Data.Morpheus.Server.Deriving.Utils.DeriveGType-  ( DeriveWith (..),-    DeriveValueOptions (..),-    DeriveTypeOptions (..),-    deriveValue,-    deriveTypeWith,-  )-where--import Data.Morpheus.Server.Deriving.Utils.Proxy-  ( conNameProxy,-    isRecordProxy,-    selNameProxy,-  )-import Data.Morpheus.Server.Deriving.Utils.Types-import Data.Morpheus.Server.Types.Internal-  ( TypeData (..),-  )-import Data.Morpheus.Types.Internal.AST-  ( TypeName,-    TypeRef (..),-  )-import GHC.Generics-  ( C,-    Constructor,-    D,-    Datatype,-    Generic (..),-    K1 (..),-    M1 (..),-    Meta,-    Rec0,-    S,-    Selector,-    U1 (..),-    (:*:) (..),-    (:+:) (..),-  )-import Relude hiding (undefined)--data DeriveValueOptions kind gql c v = DeriveValueOptions-  { __valueTypeName :: TypeName,-    __valueApply :: forall a. c a => a -> v,-    __valueGetType :: forall f a. gql a => f a -> TypeData-  }--data DeriveTypeOptions kind gql derive v = DeriveTypeOptions-  { __typeApply :: forall f a. derive a => f a -> v,-    __typeGetType :: forall f a. gql a => f a -> TypeData-  }--deriveValue ::-  (Generic a, DeriveWith gql constraint value (Rep a)) =>-  DeriveValueOptions kind gql constraint value ->-  a ->-  DataType value-deriveValue options = deriveTypeValue options . from--deriveTypeWith ::-  forall kind gql c v kinded a.-  (DeriveWith gql c v (Rep a)) =>-  DeriveTypeOptions kind gql c v ->-  kinded kind a ->-  [ConsRep v]-deriveTypeWith options _ = deriveTypeDefinition options (Proxy @(Rep a))----  GENERIC UNION-class DeriveWith (gql :: Type -> Constraint) (c :: Type -> Constraint) (v :: Type) f where-  deriveTypeValue :: DeriveValueOptions kind gql c v -> f a -> DataType v-  deriveTypeDefinition :: DeriveTypeOptions kind gql c v -> proxy f -> [ConsRep v]--instance (Datatype d, DeriveWith gql c v f) => DeriveWith gql c v (M1 D d f) where-  deriveTypeValue options (M1 src) = (deriveTypeValue options src) {dataTypeName = __valueTypeName options}-  deriveTypeDefinition options _ = deriveTypeDefinition options (Proxy @f)---- | recursion for Object types, both of them : 'INPUT_OBJECT' and 'OBJECT'-instance (DeriveWith gql c v a, DeriveWith gql c v b) => DeriveWith gql c v (a :+: b) where-  deriveTypeValue f (L1 x) = (deriveTypeValue f x) {tyIsUnion = True}-  deriveTypeValue f (R1 x) = (deriveTypeValue f x) {tyIsUnion = True}-  deriveTypeDefinition options _ = deriveTypeDefinition options (Proxy @a) <> deriveTypeDefinition options (Proxy @b)--instance (DeriveFieldRep gql con v f, Constructor c) => DeriveWith gql con v (M1 C c f) where-  deriveTypeValue options (M1 src) =-    DataType-      { dataTypeName = "",-        tyIsUnion = False,-        tyCons = deriveConsRep (Proxy @c) (toFieldRep options src)-      }-  deriveTypeDefinition options _ = [deriveConsRep (Proxy @c) (conRep options (Proxy @f))]--deriveConsRep ::-  Constructor (c :: Meta) =>-  f c ->-  [FieldRep v] ->-  ConsRep v-deriveConsRep proxy fields = ConsRep {..}-  where-    consName = conNameProxy proxy-    consFields-      | isRecordProxy proxy = fields-      | otherwise = enumerate fields--class DeriveFieldRep (gql :: Type -> Constraint) (c :: Type -> Constraint) (v :: Type) f where-  toFieldRep :: DeriveValueOptions kind gql c v -> f a -> [FieldRep v]-  conRep :: DeriveTypeOptions kind gql c v -> proxy f -> [FieldRep v]--instance (DeriveFieldRep gql c v a, DeriveFieldRep gql c v b) => DeriveFieldRep gql c v (a :*: b) where-  toFieldRep options (a :*: b) = toFieldRep options a <> toFieldRep options b-  conRep options _ = conRep options (Proxy @a) <> conRep options (Proxy @b)--instance (Selector s, gql a, c a) => DeriveFieldRep gql c v (M1 S s (Rec0 a)) where-  toFieldRep DeriveValueOptions {..} (M1 (K1 src)) =-    [ FieldRep-        { fieldSelector = selNameProxy (Proxy @s),-          fieldTypeRef = TypeRef gqlTypeName gqlWrappers,-          fieldValue = __valueApply src-        }-    ]-    where-      TypeData {gqlTypeName, gqlWrappers} = __valueGetType (Proxy @a)-  conRep DeriveTypeOptions {..} _ =-    [ FieldRep-        { fieldSelector = selNameProxy (Proxy @s),-          fieldTypeRef = TypeRef gqlTypeName gqlWrappers,-          fieldValue = __typeApply (Proxy @a)-        }-    ]-    where-      TypeData {gqlTypeName, gqlWrappers} = __typeGetType (Proxy @a)--instance DeriveFieldRep gql c v U1 where-  toFieldRep _ _ = []-  conRep _ _ = []
+ src/Data/Morpheus/Server/Deriving/Utils/GRep.hs view
@@ -0,0 +1,198 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.Server.Deriving.Utils.GRep+  ( GRep (..),+    RepContext (..),+    ConsRep (..),+    FieldRep (..),+    TypeRep (..),+    deriveValue,+    deriveTypeWith,+    isEmptyConstraint,+    isUnionRef,+    unpackMonad,+  )+where++import Data.Morpheus.Server.Deriving.Utils.Proxy+  ( conNameProxy,+    isRecordProxy,+    selNameProxy,+  )+import Data.Morpheus.Server.Types.Internal+  ( TypeData (..),+  )+import Data.Morpheus.Types.Internal.AST+  ( FieldName,+    TypeName,+    TypeRef (..),+    packName,+  )+import qualified Data.Text as T+import GHC.Generics+  ( C,+    Constructor,+    D,+    Datatype,+    Generic (..),+    K1 (..),+    M1 (..),+    Meta,+    Rec0,+    S,+    Selector,+    U1 (..),+    (:*:) (..),+    (:+:) (..),+  )+import Relude hiding (undefined)++data RepContext gql fun f result = RepContext+  { optApply :: forall a. fun a => f a -> result,+    optTypeData :: forall proxy a. gql a => proxy a -> TypeData+  }++deriveValue ::+  (Generic a, GRep gql constraint value (Rep a), gql a) =>+  RepContext gql constraint Identity value ->+  a ->+  TypeRep value+deriveValue options value = (deriveTypeValue options (from value)) {dataTypeName}+  where+    dataTypeName = gqlTypeName (optTypeData options (Identity value))++deriveTypeWith ::+  forall kind gql c v kinded a.+  (GRep gql c v (Rep a)) =>+  RepContext gql c Proxy v ->+  kinded kind a ->+  [ConsRep v]+deriveTypeWith options _ = deriveTypeDefinition options (Proxy @(Rep a))++--  GENERIC UNION+class GRep (gql :: Type -> Constraint) (c :: Type -> Constraint) (v :: Type) f where+  deriveTypeValue :: RepContext gql c Identity v -> f a -> TypeRep v+  deriveTypeDefinition :: RepContext gql c Proxy v -> proxy f -> [ConsRep v]++instance (Datatype d, GRep gql c v f) => GRep gql c v (M1 D d f) where+  deriveTypeValue options (M1 src) = deriveTypeValue options src+  deriveTypeDefinition options _ = deriveTypeDefinition options (Proxy @f)++-- | recursion for Object types, both of them : 'INPUT_OBJECT' and 'OBJECT'+instance (GRep gql c v a, GRep gql c v b) => GRep gql c v (a :+: b) where+  deriveTypeValue f (L1 x) = (deriveTypeValue f x) {tyIsUnion = True}+  deriveTypeValue f (R1 x) = (deriveTypeValue f x) {tyIsUnion = True}+  deriveTypeDefinition options _ = deriveTypeDefinition options (Proxy @a) <> deriveTypeDefinition options (Proxy @b)++instance (DeriveFieldRep gql con v f, Constructor c) => GRep gql con v (M1 C c f) where+  deriveTypeValue options (M1 src) =+    TypeRep+      { dataTypeName = "",+        tyIsUnion = False,+        tyCons = deriveConsRep (Proxy @c) (toFieldRep options src)+      }+  deriveTypeDefinition options _ = [deriveConsRep (Proxy @c) (conRep options (Proxy @f))]++deriveConsRep ::+  Constructor (c :: Meta) =>+  f c ->+  [FieldRep v] ->+  ConsRep v+deriveConsRep proxy fields = ConsRep {..}+  where+    consName = conNameProxy proxy+    consFields+      | isRecordProxy proxy = fields+      | otherwise = enumerate fields++class DeriveFieldRep (gql :: Type -> Constraint) (c :: Type -> Constraint) (v :: Type) f where+  toFieldRep :: RepContext gql c Identity v -> f a -> [FieldRep v]+  conRep :: RepContext gql c Proxy v -> proxy f -> [FieldRep v]++instance (DeriveFieldRep gql c v a, DeriveFieldRep gql c v b) => DeriveFieldRep gql c v (a :*: b) where+  toFieldRep options (a :*: b) = toFieldRep options a <> toFieldRep options b+  conRep options _ = conRep options (Proxy @a) <> conRep options (Proxy @b)++instance (Selector s, gql a, c a) => DeriveFieldRep gql c v (M1 S s (Rec0 a)) where+  toFieldRep RepContext {..} (M1 (K1 src)) =+    [ FieldRep+        { fieldSelector = selNameProxy (Proxy @s),+          fieldTypeRef = TypeRef gqlTypeName gqlWrappers,+          fieldValue = optApply (Identity src)+        }+    ]+    where+      TypeData {gqlTypeName, gqlWrappers} = optTypeData (Proxy @a)+  conRep RepContext {..} _ =+    [ FieldRep+        { fieldSelector = selNameProxy (Proxy @s),+          fieldTypeRef = TypeRef gqlTypeName gqlWrappers,+          fieldValue = optApply (Proxy @a)+        }+    ]+    where+      TypeData {gqlTypeName, gqlWrappers} = optTypeData (Proxy @a)++instance DeriveFieldRep gql c v U1 where+  toFieldRep _ _ = []+  conRep _ _ = []++data TypeRep (v :: Type) = TypeRep+  { dataTypeName :: TypeName,+    tyIsUnion :: Bool,+    tyCons :: ConsRep v+  }+  deriving (Functor)++data ConsRep (v :: Type) = ConsRep+  { consName :: TypeName,+    consFields :: [FieldRep v]+  }+  deriving (Functor)++data FieldRep (a :: Type) = FieldRep+  { fieldSelector :: FieldName,+    fieldTypeRef :: TypeRef,+    fieldValue :: a+  }+  deriving (Functor)++-- setFieldNames ::  Power Int Text -> Power { _1 :: Int, _2 :: Text }+enumerate :: [FieldRep a] -> [FieldRep a]+enumerate = zipWith setFieldName ([0 ..] :: [Int])+  where+    setFieldName i field = field {fieldSelector = packName $ "_" <> T.pack (show i)}++isEmptyConstraint :: ConsRep a -> Bool+isEmptyConstraint ConsRep {consFields = []} = True+isEmptyConstraint _ = False++isUnionRef :: TypeName -> ConsRep k -> Bool+isUnionRef baseName ConsRep {consName, consFields = [fieldRep]} =+  consName == baseName <> typeConName (fieldTypeRef fieldRep)+isUnionRef _ _ = False++unpackMonad :: Monad m => [ConsRep (m a)] -> m [ConsRep a]+unpackMonad = traverse unpackMonadFromCons++unpackMonadFromField :: Monad m => FieldRep (m a) -> m (FieldRep a)+unpackMonadFromField FieldRep {..} = do+  cont <- fieldValue+  pure (FieldRep {fieldValue = cont, ..})++unpackMonadFromCons :: Monad m => ConsRep (m a) -> m (ConsRep a)+unpackMonadFromCons ConsRep {..} = ConsRep consName <$> traverse unpackMonadFromField consFields
+ src/Data/Morpheus/Server/Deriving/Utils/GScan.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.Server.Deriving.Utils.GScan+  ( Scanner (..),+    ScanRef (..),+    scan,+  )+where++import qualified Data.HashMap.Strict as HM+import qualified Data.Map as M+import Data.Morpheus.Server.Deriving.Utils.Gmap+  ( Gmap,+    GmapContext (..),+    useGmap,+  )+import Data.Morpheus.Server.Types.TypeName (TypeFingerprint)+import GHC.Generics (Generic (Rep))+import Relude++scan :: (Hashable k, Eq k) => (b -> k) -> Scanner c b -> [ScanRef c] -> HashMap k b+scan toKey ctx = HM.fromList . map (\x -> (toKey x, x)) . toList . scanRefs ctx mempty++fieldRefs :: Scanner c v -> ScanRef c -> [ScanRef c]+fieldRefs ctx (ScanObject _ x) = useGmap (rep x) (mapContext ctx)+fieldRefs _ ScanType {} = []++rep :: f a -> Proxy (Rep a)+rep _ = Proxy++visited :: Map TypeFingerprint v -> ScanRef c -> Bool+visited lib (ScanObject fp _) = M.member fp lib+visited lib (ScanType fp _) = M.member fp lib++getFingerprint :: ScanRef c -> TypeFingerprint+getFingerprint (ScanObject fp _) = fp+getFingerprint (ScanType fp _) = fp++scanRefs :: Scanner c v -> Map TypeFingerprint v -> [ScanRef c] -> Map TypeFingerprint v+scanRefs _ lib [] = lib+scanRefs ctx lib (x : xs) = do+  let values = runRef ctx x+  let newLib = foldr (M.insert (getFingerprint x)) lib values+  let refs = filter (not . visited newLib) (xs <> fieldRefs ctx x)+  scanRefs ctx newLib refs++runRef :: Scanner c v -> ScanRef c -> [v]+runRef Scanner {..} (ScanObject _ t) = scannerFun t+runRef Scanner {..} (ScanType _ t) = scannerFun t++mapContext :: Scanner c v -> GmapContext c [ScanRef c]+mapContext (Scanner _ f) = GmapContext f++data ScanRef (c :: Type -> Constraint) where+  ScanObject :: forall f a c. (Gmap c (Rep a), c a) => TypeFingerprint -> f a -> ScanRef c+  ScanType :: forall f a c. (c a) => TypeFingerprint -> f a -> ScanRef c++data Scanner (c :: Type -> Constraint) (v :: Type) = Scanner+  { scannerFun :: forall f a. (c a) => f a -> [v],+    scannerRefs :: forall f a. (c a) => f a -> [ScanRef c]+  }
− src/Data/Morpheus/Server/Deriving/Utils/GTraversable.hs 
@@ -1,115 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE UndecidableSuperClasses #-}-{-# LANGUAGE NoImplicitPrelude #-}--module Data.Morpheus.Server.Deriving.Utils.GTraversable where--import qualified Data.Map as M-import Data.Morpheus.Server.Deriving.Utils.Kinded-import Data.Morpheus.Server.NamedResolvers (NamedResolverT)-import Data.Morpheus.Server.Types.GQLType (GQLType (KIND, __type))-import Data.Morpheus.Server.Types.Internal-  ( TypeData (gqlFingerprint),-  )-import Data.Morpheus.Server.Types.Kind-import Data.Morpheus.Server.Types.SchemaT (TypeFingerprint)-import Data.Morpheus.Types.Internal.AST-import GHC.Generics-import Relude hiding (Undefined)--traverseTypes ::-  (GFmap (ScanConstraint c) (KIND a) a, c (KIND a) a, GQLType a) =>-  Mappable c v KindedProxy ->-  Proxy a ->-  Map TypeFingerprint v-traverseTypes f = runMappable (scanner f mempty) . withDerivable--class-  (GFmap (ScanConstraint c) (KIND a) a, c (KIND a) a) =>-  ScanConstraint-    (c :: DerivingKind -> Type -> Constraint)-    (k :: DerivingKind)-    (a :: Type)--instance (GFmap (ScanConstraint c) (KIND a) a, c (KIND a) a) => ScanConstraint c k a--scanner ::-  Mappable c v KindedProxy ->-  Map TypeFingerprint v ->-  Mappable (ScanConstraint c) (Map TypeFingerprint v) KindedProxy-scanner c@(Mappable f) lib =-  Mappable-    ( \proxy -> do-        let typeInfo = __type proxy OUT-        let fingerprint = gqlFingerprint typeInfo-        if M.member fingerprint lib-          then lib-          else do-            let newLib = M.insert fingerprint (f proxy) lib-            gfmap (scanner c newLib) proxy-    )--withDerivable :: proxy a -> KindedProxy (KIND a) a-withDerivable _ = KindedProxy--newtype Mappable (c :: DerivingKind -> Type -> Constraint) (v :: Type) (f :: DerivingKind -> Type -> Type) = Mappable-  { runMappable :: forall a. (GQLType a, c (KIND a) a) => KindedProxy (KIND a) a -> v-  }---- Map-class GFmap (c :: DerivingKind -> Type -> Constraint) (t :: DerivingKind) a where-  gfmap :: (Monoid v, Semigroup v) => Mappable c v KindedProxy -> kinded t a -> v--instance (GQLType a, c (KIND a) a) => GFmap c SCALAR a where-  gfmap (Mappable f) _ = f (KindedProxy :: KindedProxy (KIND a) a)--instance (GQLType a, c (KIND a) a, GFunctor c (Rep a)) => GFmap c TYPE a where-  gfmap f@(Mappable fx) _ = fx (KindedProxy :: KindedProxy (KIND a) a) <> genericMap f (Proxy @(Rep a))--instance GFmap c (KIND a) a => GFmap c WRAPPER (f a) where-  gfmap f _ = gfmap f (KindedProxy :: KindedProxy (KIND a) a)--instance GFmap c (KIND a) a => GFmap c CUSTOM (input -> a) where-  gfmap f _ = gfmap f (KindedProxy :: KindedProxy (KIND a) a)--instance GFmap c (KIND a) a => GFmap c CUSTOM (NamedResolverT m a) where-  gfmap f _ = gfmap f (KindedProxy :: KindedProxy (KIND a) a)---------- GFunctor-------class GFunctor (c :: DerivingKind -> Type -> Constraint) a where-  genericMap :: (Monoid v, Semigroup v) => Mappable c v p -> proxy a -> v--instance (Datatype d, GFunctor c a) => GFunctor c (M1 D d a) where-  genericMap fun _ = genericMap fun (Proxy @a)--instance (GFunctor con a) => GFunctor con (M1 C c a) where-  genericMap f _ = genericMap f (Proxy @a)--instance (GFunctor c a, GFunctor c b) => GFunctor c (a :+: b) where-  genericMap fun _ = genericMap fun (Proxy @a) <> genericMap fun (Proxy @b)--instance (GFunctor c a, GFunctor c b) => GFunctor c (a :*: b) where-  genericMap fun _ = genericMap fun (Proxy @a) <> genericMap fun (Proxy @b)--instance (GQLType a, c (KIND a) a) => GFunctor c (M1 S s (K1 x a)) where-  genericMap (Mappable f) _ = f (KindedProxy :: KindedProxy (KIND a) a)--instance GFunctor c U1 where-  genericMap _ _ = mempty
+ src/Data/Morpheus/Server/Deriving/Utils/Gmap.hs view
@@ -0,0 +1,65 @@+{-# 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 TypeOperators #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.Server.Deriving.Utils.Gmap+  ( GmapContext (..),+    useGmap,+    Gmap (..),+  )+where++import GHC.Generics+  ( C,+    D,+    Datatype,+    K1,+    M1,+    S,+    U1,+    type (:*:),+    type (:+:),+  )+import Relude++newtype GmapContext (fun :: Type -> Constraint) (v :: Type) = GmapContext+  { gmapFun :: forall f a. (fun a) => f a -> v+  }++useGmap :: (Gmap c a, Monoid b) => f a -> GmapContext c b -> b+useGmap x = runReader (gfmap x)++class Gmap (c :: Type -> Constraint) a where+  gfmap :: (Monoid v) => proxy a -> Reader (GmapContext c v) v++instance (Datatype d, Gmap c a) => Gmap c (M1 D d a) where+  gfmap _ = gfmap (Proxy @a)++instance (Gmap con a) => Gmap con (M1 C c a) where+  gfmap _ = gfmap (Proxy @a)++instance (Gmap c a, Gmap c b) => Gmap c (a :+: b) where+  gfmap _ = liftA2 (<>) (gfmap (Proxy @a)) (gfmap (Proxy @b))++instance (Gmap c a, Gmap c b) => Gmap c (a :*: b) where+  gfmap _ = liftA2 (<>) (gfmap (Proxy @a)) (gfmap (Proxy @b))++instance (c a) => Gmap c (M1 S s (K1 x a)) where+  gfmap _ = runFun <$> ask+    where+      runFun :: GmapContext c v -> v+      runFun GmapContext {..} = gmapFun (Proxy @a)++instance Gmap c U1 where+  gfmap _ = pure mempty
src/Data/Morpheus/Server/Deriving/Utils/Kinded.hs view
@@ -10,19 +10,18 @@ module Data.Morpheus.Server.Deriving.Utils.Kinded   ( KindedProxy (..),     setType,-    setKind,-    kinded,     CatType (..),     inputType,     outputType,     CatContext (..),-    getCat,-    typeCat,     unliftKind,     catMap,     addContext,     getCatContext,     mkScalar,+    isIN,+    ForAll (..),+    unForAll,   ) where @@ -34,7 +33,8 @@     TypeCategory (..),     TypeContent (..),   )-import Prelude (Show)+import Data.Proxy (Proxy (..))+import Prelude (Bool (..), Show)  -- | context , like Proxy with multiple parameters -- * 'kind': object, scalar, enum ...@@ -45,12 +45,6 @@ setType :: f a -> kinded (k :: t) a' -> KindedProxy k a setType _ _ = KindedProxy -setKind :: f k -> kinded (k' :: t) a -> KindedProxy k a-setKind _ _ = KindedProxy--kinded :: f k -> f' a -> KindedProxy k a-kinded _ _ = KindedProxy- data CatContext (cat :: TypeCategory) where   InputContext :: CatContext IN   OutputContext :: CatContext OUT@@ -59,16 +53,8 @@   InputType :: CatType IN a   OutputType :: CatType OUT a --- liftKind :: CatType cat a -> CatType cat (f k a)--- liftKind InputType = InputType--- liftKind OutputType = OutputType- deriving instance Show (CatType cat a) --- converts:---   f a -> KindedType IN a--- or---  f k a -> KindedType IN a inputType :: f a -> CatType IN a inputType _ = InputType @@ -83,14 +69,6 @@ catMap _ InputType = InputType catMap _ OutputType = OutputType -getCat :: CatContext c -> TypeCategory-getCat InputContext = IN-getCat OutputContext = OUT--typeCat :: CatType c a -> TypeCategory-typeCat InputType = IN-typeCat OutputType = OUT- addContext :: CatContext c -> f a -> CatType c a addContext InputContext _ = InputType addContext OutputContext _ = OutputType@@ -102,3 +80,12 @@ mkScalar :: CatType c a -> ScalarDefinition -> TypeContent TRUE c s mkScalar InputType f = DataScalar f mkScalar OutputType f = DataScalar f++isIN :: CatType c a -> Bool+isIN InputType = True+isIN _ = False++newtype ForAll a = ForAll a++unForAll :: f (ForAll a) -> Proxy a+unForAll _ = Proxy
− src/Data/Morpheus/Server/Deriving/Utils/Types.hs 
@@ -1,72 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE NoImplicitPrelude #-}--module Data.Morpheus.Server.Deriving.Utils.Types-  ( ConsRep (..),-    FieldRep (..),-    DataType (..),-    enumerate,-    isEmptyConstraint,-    fieldTypeName,-    isUnionRef,-    unpackMonad,-  )-where--import Data.Morpheus.Types.Internal.AST-import qualified Data.Text as T-import Relude--data DataType (v :: Type) = DataType-  { dataTypeName :: TypeName,-    tyIsUnion :: Bool,-    tyCons :: ConsRep v-  }-  deriving (Functor)--data ConsRep (v :: Type) = ConsRep-  { consName :: TypeName,-    consFields :: [FieldRep v]-  }-  deriving (Functor)--data FieldRep (a :: Type) = FieldRep-  { fieldSelector :: FieldName,-    fieldTypeRef :: TypeRef,-    fieldValue :: a-  }-  deriving (Functor)---- setFieldNames ::  Power Int Text -> Power { _1 :: Int, _2 :: Text }-enumerate :: [FieldRep a] -> [FieldRep a]-enumerate = zipWith setFieldName ([0 ..] :: [Int])-  where-    setFieldName i field = field {fieldSelector = packName $ "_" <> T.pack (show i)}--isEmptyConstraint :: ConsRep a -> Bool-isEmptyConstraint ConsRep {consFields = []} = True-isEmptyConstraint _ = False--fieldTypeName :: FieldRep k -> TypeName-fieldTypeName = typeConName . fieldTypeRef--isUnionRef :: TypeName -> ConsRep k -> Bool-isUnionRef baseName ConsRep {consName, consFields = [fieldRep]} =-  consName == baseName <> fieldTypeName fieldRep-isUnionRef _ _ = False--unpackMonad :: Monad m => [ConsRep (m a)] -> m [ConsRep a]-unpackMonad = traverse unpackMonadFromCons--unpackMonadFromField :: Monad m => FieldRep (m a) -> m (FieldRep a)-unpackMonadFromField FieldRep {..} = do-  cont <- fieldValue-  pure (FieldRep {fieldValue = cont, ..})--unpackMonadFromCons :: Monad m => ConsRep (m a) -> m (ConsRep a)-unpackMonadFromCons ConsRep {..} = ConsRep consName <$> traverse unpackMonadFromField consFields
src/Data/Morpheus/Server/Deriving/Utils/Use.hs view
@@ -5,15 +5,18 @@ {-# LANGUAGE RankNTypes #-}  module Data.Morpheus.Server.Deriving.Utils.Use-  ( UseDirective (..),-    UseDeriveType (..),-    UseArguments (..),+  ( UseDeriving (..),     UseGQLType (..),-    useTypename,+    UseValue (..),+    UseResolver (..),+    UseNamedResolver (..),   ) where -import Data.Morpheus.Server.Deriving.Schema.Internal+import Data.Morpheus.App.Internal.Resolving (NamedResolver (..), ResolverState, ResolverValue)+import Data.Morpheus.Internal.Ext (GQLResult)+import Data.Morpheus.Server.Deriving.Utils.GScan (ScanRef)+import Data.Morpheus.Server.Deriving.Utils.Kinded (CatType) import Data.Morpheus.Server.Types.Directives   ( GDirectiveUsages (..),   )@@ -25,36 +28,41 @@   ( TypeFingerprint,   ) import Data.Morpheus.Types.Internal.AST-  ( Arguments,-    ArgumentsDefinition,+  ( ArgumentsDefinition,     CONST,-    OUT,-    TypeCategory (..),+    TypeDefinition (..),     TypeName,+    ValidValue,+    Value,   ) -useTypename :: (gqlType a) => UseGQLType gqlType -> CatType c a -> TypeName-useTypename gql proxy@InputType = __useTypename gql IN proxy-useTypename gql proxy@OutputType = __useTypename gql OUT proxy- data UseGQLType gql = UseGQLType-  { __useFingerprint :: forall f a. gql a => TypeCategory -> f a -> TypeFingerprint,-    __useTypename :: forall f a. gql a => TypeCategory -> f a -> TypeName,-    __useTypeData :: forall f a. gql a => f a -> TypeCategory -> TypeData+  { useFingerprint :: forall c a. gql a => CatType c a -> TypeFingerprint,+    useTypename :: forall c a. gql a => CatType c a -> TypeName,+    useTypeData :: forall c a. gql a => CatType c a -> TypeData,+    useDeriveType :: forall c a. gql a => CatType c a -> SchemaT c (TypeDefinition c CONST),+    useDeriveFieldArguments :: forall c a. gql a => CatType c a -> SchemaT c (Maybe (ArgumentsDefinition CONST))   } -data UseArguments args = UseArguments-  { useDeriveArguments :: forall f a. args a => f a -> SchemaT OUT (ArgumentsDefinition CONST),-    useEncodeArguments :: forall k a. args a => a -> SchemaT k (Arguments CONST)+data UseValue val = UseValue+  { useEncodeValue :: forall a. val a => a -> GQLResult (Value CONST),+    useDecodeValue :: forall a. val a => ValidValue -> ResolverState a   } -data UseDirective gql args = UseDirective-  { __directives :: forall f a. gql a => f a -> GDirectiveUsages gql args,-    dirArgs :: UseArguments args,+data UseResolver res gql val = UseResolver+  { useEncodeResolver :: forall a m. res m a => a -> m (ResolverValue m),+    resDrv :: UseDeriving gql val+  }++data UseDeriving gql val = UseDeriving+  { __directives :: forall f a. gql a => f a -> GDirectiveUsages gql val,+    dirArgs :: UseValue val,     dirGQL :: UseGQLType gql   } -data UseDeriveType derive = UseDeriveType-  { useDeriveType :: forall c a. derive c a => CatType c a -> SchemaT c (),-    useDeriveContent :: forall c a. derive c a => CatType c a -> TyContentM c+data UseNamedResolver named fun gql val = UseNamedResolver+  { useNamedFieldResolver :: forall a m. fun m a => a -> m (ResolverValue m),+    useDeriveNamedResolvers :: forall f a m. named m a => f a -> [NamedResolver m],+    useDeriveNamedRefs :: forall f a m. named m a => f a -> [ScanRef (named m)],+    namedDrv :: UseDeriving gql val   }
− src/Data/Morpheus/Server/NamedResolvers.hs 
@@ -1,108 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE NoImplicitPrelude #-}--module Data.Morpheus.Server.NamedResolvers-  ( ResolveNamed (..),-    NamedResolverT (..),-    resolve,-    useBatched,-    Dependency,-    ignoreBatching,-    NamedRef,-  )-where--import Control.Monad.Except-import Data.Aeson (ToJSON)-import Data.Morpheus.Types.ID (ID)-import Data.Morpheus.Types.Internal.AST (GQLError, internal)-import Data.Vector (Vector)-import Relude--type family Target a :: Type where-  Target (Maybe a) = a-  Target [a] = a-  Target (Set a) = a-  Target (NonEmpty a) = a-  Target (Seq a) = a-  Target (Vector a) = a-  Target a = a--type family Dependency a :: Type where-  -- wrappers-  Dependency (Maybe a) = Dependency a-  Dependency [a] = Dependency a-  Dependency (Set a) = Dependency a-  Dependency (NonEmpty a) = Dependency a-  Dependency (Seq a) = Dependency a-  Dependency (Vector a) = Dependency a-  -- custom-  Dependency a = Dep a--ignoreBatching :: (Monad m) => (a -> m b) -> [a] -> m [Maybe b]-ignoreBatching f = traverse (fmap Just . f)--forward :: (Monad m, Dependency a ~ a) => [Dependency a] -> m [Maybe a]-forward = pure . map Just--{-# DEPRECATED useBatched " this function is obsolete" #-}-useBatched :: (ResolveNamed m a, MonadError GQLError m) => Dependency a -> m a-useBatched x = resolveBatched [x] >>= res-  where-    res [Just v] = pure v-    res _ = throwError (internal "named resolver should return single value for single argument")--{-# DEPRECATED resolveNamed "use: resolveBatched" #-}--instance ResolveNamed m Int where-  type Dep Int = Int-  resolveBatched = forward--instance ResolveNamed m Float where-  type Dep Float = Float-  resolveBatched = forward--instance ResolveNamed m Double where-  type Dep Double = Double-  resolveBatched = forward--instance ResolveNamed m Text where-  type Dep Text = Text-  resolveBatched = forward--instance ResolveNamed m Bool where-  type Dep Bool = Bool-  resolveBatched = forward--instance ResolveNamed m ID where-  type Dep ID = ID-  resolveBatched = forward--class ToJSON (Dependency a) => ResolveNamed (m :: Type -> Type) (a :: Type) where-  type Dep a :: Type-  resolveBatched :: MonadError GQLError m => [Dependency a] -> m [Maybe a]--  resolveNamed :: MonadError GQLError m => Dependency a -> m a-  resolveNamed = useBatched--data NamedResolverT (m :: Type -> Type) a where-  NamedResolverT :: ResolveNamed m (Target a) => m (NamedRef a) -> NamedResolverT m a--type family NamedRef a :: Type where-  NamedRef [a] = [Dependency a]-  NamedRef (Set a) = [Dependency a]-  NamedRef (NonEmpty a) = [Dependency a]-  NamedRef (Seq a) = [Dependency a]-  NamedRef (Vector a) = [Dependency a]-  NamedRef a = Dependency a--resolve :: ResolveNamed m (Target a) => m (NamedRef a) -> NamedResolverT m a-resolve = NamedResolverT
src/Data/Morpheus/Server/Resolvers.hs view
@@ -18,18 +18,22 @@     defaultRootResolver,     ResolverO,     ComposedResolver,-    publish,     constRes,     ResolverQ,     ResolverM,     ResolverS,     useBatched,     ignoreBatching,+    Flexible,+    Composed,   ) where -import Data.Morpheus.App.Internal.Resolving (PushEvents (pushEvents), Resolver, WithOperation)-import Data.Morpheus.Server.NamedResolvers+import Data.Morpheus.App.Internal.Resolving+  ( MonadResolver (..),+    Resolver,+  )+import Data.Morpheus.Server.Types.NamedResolvers   ( NamedResolverT (..),     ResolveNamed (..),     ignoreBatching,@@ -94,14 +98,11 @@  type ResolverO o e m a = Flexible (Resolver o e m) a -type ResolverQ e m a = Flexible (Resolver QUERY e m) a--type ResolverM e m a = Flexible (Resolver MUTATION e m) a+type ResolverQ e m a = ResolverO QUERY e m a -type ResolverS e m a = Flexible (Resolver SUBSCRIPTION e m) a+type ResolverM e m a = ResolverO MUTATION e m a -publish :: Monad m => [e] -> Resolver MUTATION e m ()-publish = pushEvents+type ResolverS e m a = ResolverO SUBSCRIPTION e m a -constRes :: (WithOperation o, Monad m) => b -> a -> Resolver o e m b+constRes :: (MonadResolver m) => b -> a -> m b constRes = const . pure
src/Data/Morpheus/Server/Types.hs view
@@ -30,7 +30,6 @@     SUBSCRIPTION,     lift,     WithOperation,-    subscribe,     ResolverContext (..),     SubscriptionField,     App,@@ -68,6 +67,10 @@     DefaultValue (..),     Value (..),     DirectiveLocation (..),+    MonadResolver (..),+    MonadIOResolver,+    Flexible,+    Composed,   ) where @@ -75,19 +78,21 @@   ( App,   ) import Data.Morpheus.App.Internal.Resolving-  ( Resolver,+  ( MonadIOResolver,+    MonadResolver (..),+    Resolver,     ResolverContext (..),     SubscriptionField,     WithOperation,-    subscribe,   ) import Data.Morpheus.Core   ( RenderGQL,     render,   )-import Data.Morpheus.Server.Deriving.Encode () import Data.Morpheus.Server.Resolvers-  ( RootResolver (..),+  ( Composed,+    Flexible,+    RootResolver (..),     defaultRootResolver,   ) import Data.Morpheus.Server.Types.DirectiveDefinitions
src/Data/Morpheus/Server/Types/DirectiveDefinitions.hs view
@@ -68,7 +68,7 @@     )  instance GQLType Deprecated where-  __type _ = mkTypeData "deprecated"+  __type = mkTypeData "deprecated"  instance GQLDirective Deprecated where   type
src/Data/Morpheus/Server/Types/Directives.hs view
@@ -36,7 +36,6 @@ where  import qualified Data.HashMap.Strict as M-import Data.Morpheus.Server.Types.TypeName (getTypename) import qualified Data.Morpheus.Server.Types.Visitors as Visitors import Data.Morpheus.Types.Internal.AST   ( CONST,@@ -126,9 +125,6 @@ type FIELD_VISITOR_KIND = '[ 'LOCATION_INPUT_FIELD_DEFINITION, 'LOCATION_FIELD_DEFINITION]  type ENUM_VISITOR_KIND = '[ 'LOCATION_ENUM_VALUE]--__directiveName :: GQLDirective a => f a -> FieldName-__directiveName = coerce . getTypename  class   ( ToLocations (DIRECTIVE_LOCATIONS a),
src/Data/Morpheus/Server/Types/GQLType.hs view
@@ -6,11 +6,9 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE Rank2Types #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-}@@ -19,18 +17,17 @@ {-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.Server.Types.GQLType-  ( DeriveDirective,-    GQLType (KIND, directives, __type),+  ( GQLType (KIND, directives, __type),+    GQLValue (..),     InputTypeNamespace (..),-    deriveFingerprint,-    deriveTypename,-    encodeArguments,-    __isEmptyType,-    __typeData,+    GQLResolver (..),+    ignoreUndefined,     withGQL,     withDir,-    withDeriveType,-    DeriveType,+    withValue,+    withRes,+    kindedProxy,+    IgnoredResolver,   ) where @@ -39,19 +36,32 @@ import Control.Monad.Except (MonadError (throwError)) import Data.Morpheus.App.Internal.Resolving   ( Resolver,+    ResolverState,+    ResolverValue,     SubscriptionField,   )-import Data.Morpheus.Internal.Ext-import Data.Morpheus.Internal.Utils-import Data.Morpheus.Server.Deriving.Schema.DeriveKinded-import Data.Morpheus.Server.Deriving.Schema.Directive (UseDirective (..))-import Data.Morpheus.Server.Deriving.Schema.Internal-import Data.Morpheus.Server.Deriving.Utils (ConsRep (..), DataType (..), DeriveWith, FieldRep (..))-import Data.Morpheus.Server.Deriving.Utils.DeriveGType (DeriveValueOptions (..), deriveValue)-import Data.Morpheus.Server.Deriving.Utils.Kinded (KindedProxy (KindedProxy), inputType)-import Data.Morpheus.Server.Deriving.Utils.Proxy (ContextValue (..))-import Data.Morpheus.Server.Deriving.Utils.Use (UseArguments (..), UseDeriveType (..), UseGQLType (..))-import Data.Morpheus.Server.NamedResolvers (NamedResolverT (..))+import Data.Morpheus.Internal.Ext (GQLResult)+import Data.Morpheus.Internal.Utils (singleton)+import Data.Morpheus.Server.Deriving.Internal.Schema.Type+  ( fillTypeContent,+    injectType,+  )+import Data.Morpheus.Server.Deriving.Kinded.Arguments+  ( DeriveFieldArguments (..),+    HasArguments,+  )+import Data.Morpheus.Server.Deriving.Kinded.Resolver (KindedResolver (..))+import Data.Morpheus.Server.Deriving.Kinded.Type+  ( DERIVE_TYPE,+    DeriveKindedType (..),+    deriveInterfaceDefinition,+    deriveScalarDefinition,+    deriveTypeGuardUnions,+  )+import Data.Morpheus.Server.Deriving.Kinded.Value (KindedValue (..))+import Data.Morpheus.Server.Deriving.Utils.Kinded (CatType (..), KindedProxy (KindedProxy), catMap, isIN)+import Data.Morpheus.Server.Deriving.Utils.Proxy (ContextValue (..), symbolName)+import Data.Morpheus.Server.Deriving.Utils.Use (UseDeriving (..), UseGQLType (..), UseResolver (..), UseValue (..)) import Data.Morpheus.Server.Types.Directives   ( GDirectiveUsages (..),     GQLDirective (..),@@ -69,8 +79,13 @@     TYPE,     WRAPPER,   )-import Data.Morpheus.Server.Types.SchemaT (SchemaT, withInput)-import Data.Morpheus.Server.Types.TypeName (TypeFingerprint (..), getFingerprint, getTypename)+import Data.Morpheus.Server.Types.NamedResolvers (NamedResolverT (..))+import Data.Morpheus.Server.Types.SchemaT (SchemaT, extendImplements)+import Data.Morpheus.Server.Types.TypeName+  ( TypeFingerprint (..),+    typeableFingerprint,+    typeableTypename,+  ) import Data.Morpheus.Server.Types.Types   ( Arg,     Pair,@@ -79,26 +94,28 @@     __typenameUndefined,   ) import Data.Morpheus.Server.Types.Visitors (VisitType (..))-import Data.Morpheus.Types.GQLScalar (EncodeScalar (..))-import Data.Morpheus.Types.GQLWrapper (EncodeWrapperValue (..)) import Data.Morpheus.Types.ID (ID) import Data.Morpheus.Types.Internal.AST-  ( Argument (..),-    Arguments,-    ArgumentsDefinition,+  ( ArgumentsDefinition,     CONST,     DirectiveLocation (..),+    FieldDefinition,     GQLError,     IN,+    Msg (msg),     OUT,-    ObjectEntry (..),-    Position (..),-    TypeCategory (..),-    TypeName,+    QUERY,+    ScalarDefinition (..),+    TRUE,+    TypeContent (..),+    TypeDefinition (..),+    TypeRef (..),     TypeWrapper (..),+    VALID,     Value (..),     internal,     mkBaseType,+    mkField,     toNullable,     unitTypeName,   )@@ -108,30 +125,22 @@ import GHC.TypeLits (KnownSymbol) import Relude hiding (Seq, Undefined, fromList, intercalate) -__isEmptyType :: forall f a. GQLType a => f a -> Bool-__isEmptyType _ = deriveFingerprint (OutputType :: CatType OUT a) == InternalFingerprint __typenameUndefined--__typeData :: (GQLType a) => CatType cat a -> TypeData-__typeData proxy@InputType = __type proxy IN-__typeData proxy@OutputType = __type proxy OUT--deriveTypename :: (GQLType a) => CatType cat a -> TypeName-deriveTypename proxy = gqlTypeName $ __typeData proxy--deriveFingerprint :: (GQLType a) => CatType cat a -> TypeFingerprint-deriveFingerprint proxy = gqlFingerprint $ __typeData proxy+ignoreUndefined :: forall f a. GQLType a => f a -> Maybe (f a)+ignoreUndefined proxy+  | gqlFingerprint (__type (OutputType :: CatType OUT a)) == InternalFingerprint __typenameUndefined = Nothing+  | otherwise = Just proxy  deriveTypeData ::+  forall c (a :: Type).   Typeable a =>-  f a ->+  CatType c a ->   DirectiveUsages ->-  TypeCategory ->   TypeData-deriveTypeData proxy GDirectiveUsages {typeDirectives} cat =+deriveTypeData proxy GDirectiveUsages {typeDirectives} =   TypeData-    { gqlTypeName = foldr (`applyTypeName` (cat == IN)) (getTypename proxy) typeDirectives,+    { gqlTypeName = foldr (`applyTypeName` isIN proxy) (typeableTypename (Proxy @a)) typeDirectives,       gqlWrappers = mkBaseType,-      gqlFingerprint = getFingerprint cat proxy+      gqlFingerprint = typeableFingerprint proxy     }  list :: TypeWrapper -> TypeWrapper@@ -140,6 +149,27 @@ wrapper :: (TypeWrapper -> TypeWrapper) -> TypeData -> TypeData wrapper f TypeData {..} = TypeData {gqlWrappers = f gqlWrappers, ..} +type Lifted a = (PARAM (KIND a) a)++kindedProxy :: f a -> KindedProxy (KIND a) a+kindedProxy _ = KindedProxy++lifted :: CatType cat a -> CatType cat (f (KIND a) (Lifted a))+lifted InputType = InputType+lifted OutputType = OutputType++type IgnoredResolver = (Resolver QUERY () Identity)++-- lifts monadic object types with specific monad+type family PARAM k a where+  PARAM TYPE (t m) = t IgnoredResolver+  PARAM k a = a++type DERIVE_T c a = (DeriveKindedType GQLType GQLValue c (KIND a) (Lifted a))++cantBeInputType :: (MonadError GQLError m, GQLType a) => CatType cat a -> m b+cantBeInputType proxy = throwError $ internal $ "type " <> msg (gqlTypeName $ __type proxy) <> "can't be a input type"+ -- | GraphQL type, every graphQL type should have an instance of 'GHC.Generics.Generic' and 'GQLType'. -- --  @@@ -161,197 +191,146 @@   directives :: f a -> DirectiveUsages   directives _ = mempty -  __type :: f a -> TypeCategory -> TypeData-  default __type :: Typeable a => f a -> TypeCategory -> TypeData+  __type :: CatType cat a -> TypeData+  default __type :: Typeable a => CatType cat a -> TypeData   __type proxy = deriveTypeData proxy (directives proxy) +  __deriveType :: CatType c a -> SchemaT c (TypeDefinition c CONST)+  default __deriveType :: DERIVE_T c a => CatType c a -> SchemaT c (TypeDefinition c CONST)+  __deriveType = deriveKindedType withDir . lifted++  __deriveFieldArguments :: CatType c a -> SchemaT c (Maybe (ArgumentsDefinition CONST))+  default __deriveFieldArguments ::+    DeriveFieldArguments GQLType (HasArguments a) =>+    CatType c a ->+    SchemaT c (Maybe (ArgumentsDefinition CONST))+  __deriveFieldArguments OutputType = deriveFieldArguments withDir (Proxy @(HasArguments a))+  __deriveFieldArguments InputType = pure Nothing+ instance GQLType Int where   type KIND Int = SCALAR-  __type _ = mkTypeData "Int"+  __type = mkTypeData "Int"  instance GQLType Double where   type KIND Double = SCALAR-  __type _ = mkTypeData "Float"+  __type = mkTypeData "Float"  instance GQLType Float where   type KIND Float = SCALAR-  __type _ = mkTypeData "Float32"+  __type = mkTypeData "Float32"  instance GQLType Text where   type KIND Text = SCALAR-  __type _ = mkTypeData "String"+  __type = mkTypeData "String"  instance GQLType Bool where   type KIND Bool = SCALAR-  __type _ = mkTypeData "Boolean"+  __type = mkTypeData "Boolean"  instance GQLType ID where   type KIND ID = SCALAR-  __type _ = mkTypeData "ID"+  __type = mkTypeData "ID"  instance GQLType (Value CONST) where   type KIND (Value CONST) = CUSTOM-  __type _ = mkTypeData "INTERNAL_VALUE"+  __type = mkTypeData "INTERNAL_VALUE"+  __deriveType = deriveScalarDefinition (const $ ScalarDefinition pure) withDir  -- WRAPPERS instance GQLType () where-  __type _ = mkTypeData unitTypeName+  __type = mkTypeData unitTypeName  instance Typeable m => GQLType (Undefined m) where-  type KIND (Undefined m) = CUSTOM-  __type _ = mkTypeData __typenameUndefined+  __type = mkTypeData __typenameUndefined  instance GQLType a => GQLType (Maybe a) where   type KIND (Maybe a) = WRAPPER-  __type _ = wrapper toNullable . __type (Proxy @a)+  __type = wrapper toNullable . __type . catMap (Proxy @a)  instance GQLType a => GQLType [a] where   type KIND [a] = WRAPPER-  __type _ = wrapper list . __type (Proxy @a)+  __type = wrapper list . __type . catMap (Proxy @a)  instance GQLType a => GQLType (Set a) where   type KIND (Set a) = WRAPPER-  __type _ = __type $ Proxy @[a]+  __type = __type . catMap (Proxy @[a])  instance GQLType a => GQLType (NonEmpty a) where   type KIND (NonEmpty a) = WRAPPER-  __type _ = __type $ Proxy @[a]+  __type = __type . catMap (Proxy @[a]) -instance GQLType a => GQLType (Seq a) where+instance (GQLType a) => GQLType (Seq a) where   type KIND (Seq a) = WRAPPER-  __type _ = __type $ Proxy @[a]+  __type = __type . catMap (Proxy @[a])  instance GQLType a => GQLType (Vector a) where   type KIND (Vector a) = WRAPPER-  __type _ = __type $ Proxy @[a]+  __type = __type . catMap (Proxy @[a])  instance GQLType a => GQLType (SubscriptionField a) where   type KIND (SubscriptionField a) = WRAPPER-  __type _ = __type $ Proxy @a+  __type = __type . catMap (Proxy @a)  instance (Typeable a, Typeable b, GQLType a, GQLType b) => GQLType (Pair a b) where   directives _ = typeDirective InputTypeNamespace {inputTypeNamespace = "Input"}  -- Manual -instance GQLType b => GQLType (a -> b) where+instance (GQLType b, GQLType a) => GQLType (a -> b) where   type KIND (a -> b) = CUSTOM-  __type _ = __type $ Proxy @b+  __type = __type . catMap (Proxy @b)+  __deriveType OutputType = __deriveType (OutputType :: CatType OUT b)+  __deriveType proxy = cantBeInputType proxy  instance (GQLType k, GQLType v, Typeable k, Typeable v) => GQLType (Map k v) where   type KIND (Map k v) = CUSTOM-  __type _ = __type $ Proxy @[Pair k v]+  __type = __type . catMap (Proxy @[Pair k v])+  __deriveType = __deriveType . catMap (Proxy @[(k, v)])  instance GQLType a => GQLType (Resolver o e m a) where   type KIND (Resolver o e m a) = CUSTOM-  __type _ = __type $ Proxy @a+  __type = __type . catMap (Proxy @a)+  __deriveType = __deriveType . catMap (Proxy @a)  instance (Typeable a, Typeable b, GQLType a, GQLType b) => GQLType (a, b) where-  __type _ = __type $ Proxy @(Pair a b)+  __type = __type . catMap (Proxy @(Pair a b))   directives _ = typeDirective InputTypeNamespace {inputTypeNamespace = "Input"} -instance (GQLType value) => GQLType (Arg name value) where+instance (KnownSymbol name, GQLType value) => GQLType (Arg name value) where   type KIND (Arg name value) = CUSTOM-  __type _ = __type (Proxy @value)--instance (GQLType interface) => GQLType (TypeGuard interface possibleTypes) where-  type KIND (TypeGuard interface possibleTypes) = CUSTOM-  __type _ = __type (Proxy @interface)+  __type = __type . catMap (Proxy @value)+  __deriveType OutputType = cantBeInputType (OutputType :: CatType OUT (Arg name value))+  __deriveType p@InputType = do+    injectType withDir proxy+    fillTypeContent withDir p content+    where+      content :: TypeContent TRUE IN CONST+      content = DataInputObject (singleton argName field)+      proxy = InputType :: CatType IN value+      argName = symbolName (Proxy @name)+      field :: FieldDefinition IN CONST+      field = mkField Nothing argName (TypeRef gqlTypeName gqlWrappers)+      TypeData {gqlTypeName, gqlWrappers} = useTypeData withGQL proxy -instance (GQLType a) => GQLType (Proxy a) where-  type KIND (Proxy a) = KIND a-  __type _ = __type (Proxy @a)+instance (DERIVE_TYPE GQLType OUT i, DERIVE_TYPE GQLType OUT u) => GQLType (TypeGuard i u) where+  type KIND (TypeGuard i u) = CUSTOM+  __type = __type . catMap (Proxy @i)+  __deriveType OutputType = do+    unions <- deriveTypeGuardUnions withDir union+    extendImplements (useTypename withGQL interface) unions+    deriveInterfaceDefinition withDir interface+    where+      interface = OutputType :: CatType OUT i+      union = OutputType :: CatType OUT u+  __deriveType proxy = cantBeInputType proxy  instance (GQLType a) => GQLType (NamedResolverT m a) where   type KIND (NamedResolverT m a) = CUSTOM-  __type _ = __type (Proxy :: Proxy a)--type EncodeValue a = EncodeKind (KIND a) a--encodeArguments :: forall m a. (MonadError GQLError m, EncodeValue a) => a -> m (Arguments CONST)-encodeArguments x = resultOr (const $ throwError err) pure (encode x) >>= unpackValue-  where-    err = internal "could not encode arguments. Arguments should be an object like type!"-    unpackValue (Object v) = pure $ fmap toArgument v-    unpackValue _ = throwError err-    toArgument ObjectEntry {..} = Argument (Position 0 0) entryName entryValue--encode :: forall a. EncodeValue a => a -> GQLResult (Value CONST)-encode x = encodeKind (ContextValue x :: ContextValue (KIND a) a)--class EncodeKind (kind :: DerivingKind) (a :: Type) where-  encodeKind :: ContextValue kind a -> GQLResult (Value CONST)--instance (EncodeWrapperValue f, EncodeValue a) => EncodeKind WRAPPER (f a) where-  encodeKind = encodeWrapperValue encode . unContextValue--instance (EncodeScalar a) => EncodeKind SCALAR a where-  encodeKind = pure . Scalar . encodeScalar . unContextValue--instance (EncodeConstraint a) => EncodeKind TYPE a where-  encodeKind = exploreResolvers . unContextValue--instance EncodeKind CUSTOM (Value CONST) where-  encodeKind = pure . unContextValue---- TODO: remove me-instance (KnownSymbol name) => EncodeKind CUSTOM (Arg name a) where-  encodeKind _ = throwError "directives cant be tagged arguments"--convertNode ::-  DataType (GQLResult (Value CONST)) ->-  GQLResult (Value CONST)-convertNode-  DataType-    { tyIsUnion,-      tyCons = ConsRep {consFields, consName}-    } = encodeTypeFields consFields-    where-      encodeTypeFields ::-        [FieldRep (GQLResult (Value CONST))] -> GQLResult (Value CONST)-      encodeTypeFields [] = pure $ Enum consName-      encodeTypeFields fields | not tyIsUnion = Object <$> (traverse fromField fields >>= fromElems)-        where-          fromField FieldRep {fieldSelector, fieldValue} = do-            entryValue <- fieldValue-            pure ObjectEntry {entryName = fieldSelector, entryValue}-      -- Type References ---------------------------------------------------------------      encodeTypeFields _ = throwError (internal "input unions are not supported")---- Types & Constrains --------------------------------------------------------class (EncodeKind (KIND a) a) => ExplorerConstraint a--instance (EncodeKind (KIND a) a) => ExplorerConstraint a--exploreResolvers :: forall a. EncodeConstraint a => a -> GQLResult (Value CONST)-exploreResolvers =-  convertNode-    . deriveValue-      ( DeriveValueOptions-          { __valueApply = encode,-            __valueTypeName = deriveTypename (InputType :: CatType IN a),-            __valueGetType = __typeData . inputType-          } ::-          DeriveValueOptions IN GQLType ExplorerConstraint (GQLResult (Value CONST))-      )--type EncodeConstraint a =-  ( Generic a,-    GQLType a,-    DeriveWith GQLType ExplorerConstraint (GQLResult (Value CONST)) (Rep a)-  )---- DIRECTIVES-type DeriveArguments a = DeriveArgs GQLType DeriveType (KIND a) a--type DirectiveUsages = GDirectiveUsages GQLType DeriveDirective--deriveArguments :: DeriveArgs GQLType DeriveType k a => f k a -> SchemaT OUT (ArgumentsDefinition CONST)-deriveArguments = withInput . deriveArgs withDir withDeriveType--class (EncodeValue a, DeriveArguments a) => DeriveDirective a+  __type = __type . catMap (Proxy :: Proxy a)+  __deriveType = __deriveType . catMap (Proxy @a)+  __deriveFieldArguments = __deriveFieldArguments . catMap (Proxy @a) -instance (EncodeValue a, DeriveArguments a) => DeriveDirective a+type DirectiveUsages = GDirectiveUsages GQLType GQLValue  newtype InputTypeNamespace = InputTypeNamespace {inputTypeNamespace :: Text}   deriving (Generic)@@ -375,50 +354,48 @@     | isInput = inputTypeNamespace <> name     | otherwise = name -withArgs :: UseArguments DeriveDirective-withArgs =-  UseArguments-    { useDeriveArguments = deriveArguments . withKind,-      useEncodeArguments = encodeArguments+withValue :: UseValue GQLValue+withValue =+  UseValue+    { useDecodeValue = decodeValue,+      useEncodeValue = encodeValue     }  withGQL :: UseGQLType GQLType withGQL =   UseGQLType-    { __useFingerprint = \c v -> gqlFingerprint (__type v c),-      __useTypename = \c v -> gqlTypeName (__type v c),-      __useTypeData = __type+    { useFingerprint = gqlFingerprint . __type,+      useTypename = gqlTypeName . __type,+      useTypeData = __type,+      useDeriveType = __deriveType,+      useDeriveFieldArguments = __deriveFieldArguments     } -withDir :: UseDirective GQLType DeriveDirective+withDir :: UseDeriving GQLType GQLValue withDir =-  UseDirective+  UseDeriving     { __directives = directives,       dirGQL = withGQL,-      dirArgs = withArgs+      dirArgs = withValue     } -withKind :: f a -> KindedProxy (KIND a) a-withKind _ = KindedProxy--withDeriveType :: UseDeriveType DeriveType-withDeriveType =-  UseDeriveType-    { useDeriveType = deriveType,-      useDeriveContent = deriveContent-    }+class GQLType a => GQLValue a where+  decodeValue :: Value VALID -> ResolverState a+  encodeValue :: a -> GQLResult (Value CONST) --- DERIVE TYPE+instance (GQLType a, KindedValue GQLType GQLValue (KIND a) a) => GQLValue a where+  encodeValue value = encodeKindedValue withDir (ContextValue value :: ContextValue (KIND a) a)+  decodeValue = decodeKindedValue withDir (Proxy @(KIND a)) --- |  Generates internal GraphQL Schema for query validation and introspection rendering-class DeriveType (c :: TypeCategory) (a :: Type) where-  deriveType :: CatType c a -> SchemaT c ()-  deriveContent :: CatType c a -> TyContentM c+class GQLResolver (m :: Type -> Type) resolver where+  deriveResolver :: resolver -> m (ResolverValue m) -instance (GQLType a, DeriveKindedType GQLType DeriveType DeriveDirective cat (KIND a) a) => DeriveType cat a where-  deriveType = deriveKindedType withDir withDeriveType . liftKind-  deriveContent = deriveKindedContent withDir withDeriveType . liftKind+instance (KindedResolver GQLType GQLResolver GQLValue (KIND a) m a) => GQLResolver m a where+  deriveResolver resolver = kindedResolver withRes (ContextValue resolver :: ContextValue (KIND a) a) -liftKind :: CatType cat a -> CatType cat (f (KIND a) a)-liftKind InputType = InputType-liftKind OutputType = OutputType+withRes :: UseResolver GQLResolver GQLType GQLValue+withRes =+  UseResolver+    { useEncodeResolver = deriveResolver,+      resDrv = withDir+    }
+ src/Data/Morpheus/Server/Types/NamedResolvers.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.Server.Types.NamedResolvers+  ( ResolveNamed (..),+    NamedResolverT (..),+    resolve,+    useBatched,+    Dependency,+    ignoreBatching,+    NamedRef,+  )+where++import Control.Monad.Except+import Data.Aeson (ToJSON)+import Data.Morpheus.Types.ID (ID)+import Data.Morpheus.Types.Internal.AST (GQLError, internal)+import Data.Vector (Vector)+import Relude++type family Target a :: Type where+  Target (Maybe a) = a+  Target [a] = a+  Target (Set a) = a+  Target (NonEmpty a) = a+  Target (Seq a) = a+  Target (Vector a) = a+  Target a = a++type family Dependency a :: Type where+  -- wrappers+  Dependency (Maybe a) = Dependency a+  Dependency [a] = Dependency a+  Dependency (Set a) = Dependency a+  Dependency (NonEmpty a) = Dependency a+  Dependency (Seq a) = Dependency a+  Dependency (Vector a) = Dependency a+  -- custom+  Dependency a = Dep a++ignoreBatching :: (Monad m) => (a -> m b) -> [a] -> m [Maybe b]+ignoreBatching f = traverse (fmap Just . f)++forward :: (Monad m, Dependency a ~ a) => [Dependency a] -> m [Maybe a]+forward = pure . map Just++{-# DEPRECATED useBatched " this function is obsolete" #-}+useBatched :: (ResolveNamed m a, MonadError GQLError m) => Dependency a -> m a+useBatched x = resolveBatched [x] >>= res+  where+    res [Just v] = pure v+    res _ = throwError (internal "named resolver should return single value for single argument")++{-# DEPRECATED resolveNamed "use: resolveBatched" #-}++instance ResolveNamed m Int where+  type Dep Int = Int+  resolveBatched = forward++instance ResolveNamed m Float where+  type Dep Float = Float+  resolveBatched = forward++instance ResolveNamed m Double where+  type Dep Double = Double+  resolveBatched = forward++instance ResolveNamed m Text where+  type Dep Text = Text+  resolveBatched = forward++instance ResolveNamed m Bool where+  type Dep Bool = Bool+  resolveBatched = forward++instance ResolveNamed m ID where+  type Dep ID = ID+  resolveBatched = forward++class ToJSON (Dependency a) => ResolveNamed (m :: Type -> Type) (a :: Type) where+  type Dep a :: Type+  resolveBatched :: MonadError GQLError m => [Dependency a] -> m [Maybe a]++  resolveNamed :: MonadError GQLError m => Dependency a -> m a+  resolveNamed = useBatched++data NamedResolverT (m :: Type -> Type) a where+  NamedResolverT :: ResolveNamed m (Target a) => m (NamedRef a) -> NamedResolverT m a++type family NamedRef a :: Type where+  NamedRef [a] = [Dependency a]+  NamedRef (Set a) = [Dependency a]+  NamedRef (NonEmpty a) = [Dependency a]+  NamedRef (Seq a) = [Dependency a]+  NamedRef (Vector a) = [Dependency a]+  NamedRef a = Dependency a++resolve :: ResolveNamed m (Target a) => m (NamedRef a) -> NamedResolverT m a+resolve = NamedResolverT
src/Data/Morpheus/Server/Types/TypeName.hs view
@@ -3,6 +3,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-}@@ -10,9 +11,8 @@ {-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.Server.Types.TypeName-  ( getTypename,-    getTypeConstructorNames,-    getFingerprint,+  ( typeableTypename,+    typeableFingerprint,     TypeFingerprint (..),   ) where@@ -23,12 +23,13 @@ import Data.Morpheus.App.Internal.Resolving   ( Resolver,   )-import Data.Morpheus.Server.NamedResolvers (NamedResolverT (..))+import Data.Morpheus.Server.Deriving.Utils.Kinded (CatType (..))+import Data.Morpheus.Server.Types.NamedResolvers (NamedResolverT (..)) import Data.Morpheus.Server.Types.Types   ( Pair,   ) import Data.Morpheus.Types.Internal.AST-  ( TypeCategory,+  ( TypeCategory (..),     TypeName,     packName,   )@@ -58,29 +59,31 @@       Ord     ) -getTypename :: Typeable a => f a -> TypeName-getTypename = packName . intercalate "" . getTypeConstructorNames+typeableTypename :: Typeable a => f a -> TypeName+typeableTypename = packName . intercalate "" . fmap (pack . tyConName . replacePairCon) . getTypeConstructors -getTypeConstructorNames :: Typeable a => f a -> [Text]-getTypeConstructorNames = fmap (pack . tyConName . replacePairCon) . getTypeConstructors+typeableFingerprint :: Typeable a => CatType c a -> TypeFingerprint+typeableFingerprint p@InputType = TypeableFingerprint IN $ tyConFingerprint <$> getTypeConstructors p+typeableFingerprint p@OutputType = TypeableFingerprint OUT $ tyConFingerprint <$> getTypeConstructors p  getTypeConstructors :: Typeable a => f a -> [TyCon] getTypeConstructors = ignoreResolver . splitTyConApp . typeRep +rep :: forall k (a :: k) f. Typeable a => f a -> TyCon+rep = typeRepTyCon . typeRep+ -- | replaces typeName (A,B) with Pair_A_B replacePairCon :: TyCon -> TyCon-replacePairCon x | hsPair == x = gqlPair-  where-    hsPair = typeRepTyCon $ typeRep $ Proxy @(Int, Int)-    gqlPair = typeRepTyCon $ typeRep $ Proxy @(Pair Int Int)+replacePairCon x | rep (Proxy @(Int, Int)) == x = rep (Proxy @(Pair Int Int)) replacePairCon x = x --- Ignores Resolver name  from typeName-ignoreResolver :: (TyCon, [TypeRep]) -> [TyCon]-ignoreResolver (con, _) | con == typeRepTyCon (typeRep $ Proxy @Resolver) = []-ignoreResolver (con, _) | con == typeRepTyCon (typeRep $ Proxy @NamedResolverT) = []-ignoreResolver (con, args) =-  con : concatMap (ignoreResolver . splitTyConApp) args+ignoredTypes :: [TyCon]+ignoredTypes =+  [ rep (Proxy @Resolver),+    rep (Proxy @NamedResolverT)+  ] -getFingerprint :: Typeable a => TypeCategory -> f a -> TypeFingerprint-getFingerprint category = TypeableFingerprint category . fmap tyConFingerprint . getTypeConstructors+-- ignores resolver names from typename+ignoreResolver :: (TyCon, [TypeRep]) -> [TyCon]+ignoreResolver (con, _) | con `elem` ignoredTypes = []+ignoreResolver (con, args) = con : concatMap (ignoreResolver . splitTyConApp) args