packages feed

morpheus-graphql-server 0.27.3 → 0.28.0

raw patch · 59 files changed

+2479/−2378 lines, 59 filesdep ~bytestringdep ~containersdep ~morpheus-graphql-app

Dependency ranges changed: bytestring, containers, morpheus-graphql-app, morpheus-graphql-core, morpheus-graphql-server, morpheus-graphql-subscriptions, morpheus-graphql-tests, tasty

Files

morpheus-graphql-server.cabal view
@@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.35.0.+-- This file has been generated from package.yaml by hpack version 0.36.0. -- -- see: https://github.com/sol/hpack  name:           morpheus-graphql-server-version:        0.27.3+version:        0.28.0 synopsis:       Morpheus GraphQL description:    Build GraphQL APIs with your favourite functional language! category:       web, graphql@@ -36,6 +36,8 @@     test/Feature/Directive/field-visitor/name-encode/query.gql     test/Feature/Directive/field-visitor/name-introspection/query.gql     test/Feature/Directive/type-visitor/description/query.gql+    test/Feature/Inference/names/reserved-names-introspection/query.gql+    test/Feature/Inference/names/reserved-names-resolving/query.gql     test/Feature/Inference/object-and-enum/introspection/query.gql     test/Feature/Inference/object-and-enum/resolving/query.gql     test/Feature/Inference/tagged-arguments-fail/introspection/query.gql@@ -168,6 +170,8 @@     test/Feature/Directive/field-visitor/name-encode/response.json     test/Feature/Directive/field-visitor/name-introspection/response.json     test/Feature/Directive/type-visitor/description/response.json+    test/Feature/Inference/names/reserved-names-introspection/response.json+    test/Feature/Inference/names/reserved-names-resolving/response.json     test/Feature/Inference/object-and-enum/introspection/response.json     test/Feature/Inference/object-and-enum/resolving/response.json     test/Feature/Inference/tagged-arguments-fail/introspection/response.json@@ -311,16 +315,19 @@       Data.Morpheus.Server.Resolvers       Data.Morpheus.Server.Types   other-modules:+      Data.Morpheus.Generic+      Data.Morpheus.Generic.Cons+      Data.Morpheus.Generic.Fields+      Data.Morpheus.Generic.Gmap+      Data.Morpheus.Generic.GRep+      Data.Morpheus.Generic.GScan+      Data.Morpheus.Generic.Proxy+      Data.Morpheus.Generic.RefType       Data.Morpheus.Server.Deriving.App-      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.Internal.Directive+      Data.Morpheus.Server.Deriving.Internal.Resolver+      Data.Morpheus.Server.Deriving.Internal.Type+      Data.Morpheus.Server.Deriving.Internal.Value       Data.Morpheus.Server.Deriving.Kinded.Arguments       Data.Morpheus.Server.Deriving.Kinded.Channels       Data.Morpheus.Server.Deriving.Kinded.NamedResolver@@ -330,12 +337,9 @@       Data.Morpheus.Server.Deriving.Kinded.Value       Data.Morpheus.Server.Deriving.Resolvers       Data.Morpheus.Server.Deriving.Schema-      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.Playground       Data.Morpheus.Server.Types.DirectiveDefinitions@@ -344,7 +348,6 @@       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       Data.Morpheus.Server.Types.Visitors@@ -355,10 +358,10 @@   build-depends:       aeson >=1.4.4 && <3.0.0     , base >=4.7.0 && <5.0.0-    , bytestring >=0.10.4 && <0.12.0-    , containers >=0.4.2.1 && <0.7.0-    , morpheus-graphql-app >=0.27.0 && <0.28.0-    , morpheus-graphql-core >=0.27.0 && <0.28.0+    , bytestring >=0.10.4 && <0.15.0+    , containers >=0.4.2.1 && <=0.7+    , morpheus-graphql-app >=0.28.0 && <0.29.0+    , morpheus-graphql-core >=0.28.0 && <0.29.0     , mtl >=2.0.0 && <3.0.0     , relude >=0.3.0 && <2.0.0     , template-haskell >=2.0.0 && <3.0.0@@ -380,6 +383,7 @@       Feature.Directive.EnumVisitor       Feature.Directive.FieldVisitor       Feature.Directive.TypeVisitor+      Feature.Inference.Names       Feature.Inference.ObjectAndEnum       Feature.Inference.TaggedArguments       Feature.Inference.TaggedArgumentsFail@@ -408,17 +412,17 @@   build-depends:       aeson >=1.4.4 && <3.0.0     , base >=4.7.0 && <5.0.0-    , bytestring >=0.10.4 && <0.12.0-    , containers >=0.4.2.1 && <0.7.0+    , bytestring >=0.10.4 && <0.15.0+    , containers >=0.4.2.1 && <=0.7     , file-embed >=0.0.10 && <1.0.0-    , morpheus-graphql-app >=0.27.0 && <0.28.0-    , morpheus-graphql-core >=0.27.0 && <0.28.0-    , morpheus-graphql-server-    , morpheus-graphql-subscriptions >=0.27.0 && <0.28.0-    , morpheus-graphql-tests >=0.27.0 && <0.28.0+    , morpheus-graphql-app >=0.28.0 && <0.29.0+    , morpheus-graphql-core >=0.28.0 && <0.29.0+    , morpheus-graphql-server >=0.28.0 && <0.29.0+    , morpheus-graphql-subscriptions >=0.28.0 && <0.29.0+    , morpheus-graphql-tests >=0.28.0 && <0.29.0     , mtl >=2.0.0 && <3.0.0     , relude >=0.3.0 && <2.0.0-    , tasty >=0.1.0 && <1.5.0+    , tasty >=0.1.0 && <=1.5     , tasty-hunit >=0.1.0 && <1.0.0     , template-haskell >=2.0.0 && <3.0.0     , text >=1.2.3 && <3.0.0
+ src/Data/Morpheus/Generic.hs view
@@ -0,0 +1,66 @@+module Data.Morpheus.Generic+  ( Gmap,+    gmap,+    -- GRep+    GRep,+    GRepCons (..),+    GRepFun (..),+    GRepField (..),+    GRepType (..),+    GRepValue (..),+    deriveType,+    deriveValue,+    -- fields+    DecoderFun (..),+    DecodeFields,+    decodeFields,+    CountFields (..),+    RefType (..),+    DescribeCons (..),+    CProxy (..),+    symbolName,+    CBox,+    -- x+    ScanRef (..),+    ProxyMap (..),+    useProxies,+    scan,+    scanNode,+    scanLeaf,+    runCBox,+  )+where++import Data.Morpheus.Generic.Cons+  ( DescribeCons (..),+  )+import Data.Morpheus.Generic.Fields+  ( CountFields (..),+    DecodeFields,+    DecoderFun (..),+    decodeFields,+  )+import Data.Morpheus.Generic.GRep+  ( GRep,+    GRepCons (..),+    GRepField (..),+    GRepFun (..),+    GRepType (..),+    GRepValue (..),+    deriveType,+    deriveValue,+  )+import Data.Morpheus.Generic.GScan+import Data.Morpheus.Generic.Gmap+  ( Gmap,+    gmap,+  )+import Data.Morpheus.Generic.Proxy+  ( CBox,+    CProxy (..),+    runCBox,+    symbolName,+  )+import Data.Morpheus.Generic.RefType+  ( RefType (..),+  )
+ src/Data/Morpheus/Generic/Cons.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.Generic.Cons+  ( RefType (..),+    DescribeCons (..),+  )+where++import Data.Morpheus.Generic.Fields (CountFields)+import Data.Morpheus.Generic.Proxy (CProxy, conNameP)+import Data.Morpheus.Generic.RefType (RefType (..))+import GHC.Generics+import Relude++class DescribeCons con (f :: Type -> Type) where+  describeCons :: (IsString t) => Proxy f -> [(t, Maybe (CProxy con))]++instance (DescribeCons gql f) => DescribeCons gql (M1 D d f) where+  describeCons _ = describeCons (Proxy @f)++instance (DescribeCons con a, DescribeCons con b) => DescribeCons con (a :+: b) where+  describeCons _ = describeCons (Proxy @a) <> describeCons (Proxy @b)++instance (Constructor c, CountFields a, RefType con a) => DescribeCons con (M1 C c a) where+  describeCons _ = [(conNameP (Proxy @c), refType (Proxy @a))]
+ src/Data/Morpheus/Generic/Fields.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.Generic.Fields+  ( DecoderFun (..),+    DecodeFields,+    decodeFields,+    CountFields (..),+  )+where++import Data.Morpheus.Generic.Proxy+  ( selNameP,+  )+import Data.Morpheus.Types.Internal.AST (FieldName)+import GHC.Generics+import Relude++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++newtype DecoderFun con m = DecoderFun {decoderFun :: forall a. (con a) => FieldName -> m a}++decodeFields :: (Monad m, DecodeFields con f) => DecoderFun con m -> m (f a)+decodeFields ctx = decodeFieldsWith ctx 0++class DecodeFields con (f :: Type -> Type) where+  decodeFieldsWith :: (Monad m) => DecoderFun con m -> Int -> m (f a)++instance (DecodeFields val f, DecodeFields val g, CountFields g) => DecodeFields val (f :*: g) where+  decodeFieldsWith ctx index =+    (:*:)+      <$> decodeFieldsWith ctx index+      <*> decodeFieldsWith ctx (index + countFields (Proxy @g))++instance (Selector s, con a) => DecodeFields con (M1 S s (K1 i a)) where+  decodeFieldsWith ctx index = M1 . K1 <$> decoderFun ctx (getFieldName (selNameP (Proxy @s)) index)++instance DecodeFields val U1 where+  decodeFieldsWith _ _ = pure U1++getFieldName :: FieldName -> Int -> FieldName+getFieldName "" index = "_" <> show index+getFieldName label _ = label
+ src/Data/Morpheus/Generic/GRep.hs view
@@ -0,0 +1,237 @@+{-# 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.Generic.GRep+  ( GRep (..),+    GRepFun (..),+    GRepCons (..),+    GRepField (..),+    GRepValue (..),+    GRepType (..),+    deriveValue,+    deriveType,+  )+where++import Data.List (partition)+import Data.Morpheus.Generic.Proxy+  ( conNameP,+    isRecordP,+    selNameP,+  )+import Data.Morpheus.Types.Internal.AST+  ( FieldName,+    TypeName,+    TypeRef (..),+    TypeWrapper,+    packName,+  )+import Data.Text (pack)+import GHC.Generics+  ( C,+    Constructor,+    D,+    Datatype,+    Generic (..),+    K1 (..),+    M1 (..),+    Meta,+    Rec0,+    S,+    Selector,+    U1 (..),+    (:*:) (..),+    (:+:) (..),+  )+import Relude hiding (undefined)++data GRepFun gql fun f result = GRepFun+  { grepFun :: forall a. (fun a) => f a -> result,+    grepTypename :: forall proxy a. (gql a) => proxy a -> TypeName,+    grepWrappers :: forall proxy a. (gql a) => proxy a -> TypeWrapper+  }++deriveValue ::+  (Generic a, GRep gql constraint value (Rep a), gql a) =>+  GRepFun gql constraint Identity value ->+  a ->+  GRepValue value+deriveValue options value+  | null cons = GRepValueEnum typename (consName cons)+  | isUnion = case (isUnionRef typename cons, consFields cons) of+      (True, [GRepField {..}]) -> GRepValueUnionRef (typeConName fieldTypeRef) fieldValue+      _ -> GRepValueUnion typename (consName cons) (consFields cons)+  | otherwise = GRepValueObject typename (consFields cons)+  where+    (isUnion, cons) = deriveTypeValue options (from value)+    typename = grepTypename options (Identity value)++toRep :: f a -> Proxy (Rep a)+toRep _ = Proxy++deriveType ::+  forall kind gql c v kinded m a.+  (GRep gql c (m v) (Rep a), Monad m, gql a) =>+  GRepFun gql c Proxy (m v) ->+  kinded kind a ->+  m (GRepType v)+deriveType ctx x = toType <$> unpackMonad (deriveTypeDefinition ctx (toRep x))+  where+    toType cons | all null cons = GRepTypeEnum (consName <$> cons)+    toType [GRepCons {consFields}] = GRepTypeObject consFields+    toType cons = GRepTypeUnion unionRef unionCons+      where+        unionRef = toVer <$> concatMap consFields unionRefRep+          where+            toVer GRepField {..} = (typeConName fieldTypeRef, fieldValue)+        --+        (unionRefRep, unionCons) = partition (isUnionRef typename) cons+        typename = grepTypename ctx x++--  GENERIC UNION+class GRep (gql :: Type -> Constraint) (c :: Type -> Constraint) (v :: Type) f where+  deriveTypeValue :: GRepFun gql c Identity v -> f a -> (Bool, GRepCons v)+  deriveTypeDefinition :: GRepFun gql c Proxy v -> proxy f -> [GRepCons 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) = (True, snd (deriveTypeValue f x))+  deriveTypeValue f (R1 x) = (True, snd (deriveTypeValue f x))+  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) = (False, deriveConsRep (Proxy @c) (toFieldRep options src))+  deriveTypeDefinition options _ = [deriveConsRep (Proxy @c) (conRep options (Proxy @f))]++deriveConsRep ::+  (Constructor (c :: Meta)) =>+  f c ->+  [GRepField v] ->+  GRepCons v+deriveConsRep proxy fields = GRepCons {..}+  where+    consName = conNameP proxy+    consFields+      | isRecordP proxy = fields+      | otherwise = enumerate fields++class DeriveFieldRep (gql :: Type -> Constraint) (c :: Type -> Constraint) (v :: Type) f where+  toFieldRep :: GRepFun gql c Identity v -> f a -> [GRepField v]+  conRep :: GRepFun gql c Proxy v -> proxy f -> [GRepField v]+  scanRec :: GRepFun gql c Proxy v -> proxy f -> [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)+  scanRec ctx _ = scanRec ctx (Proxy @a) <> scanRec ctx (Proxy @b)++instance (Selector s, gql a, c a) => DeriveFieldRep gql c v (M1 S s (Rec0 a)) where+  toFieldRep GRepFun {..} (M1 (K1 src)) =+    [ GRepField+        { fieldSelector = selNameP (Proxy @s),+          fieldTypeRef = TypeRef (grepTypename (Proxy @a)) (grepWrappers (Proxy @a)),+          fieldValue = grepFun (Identity src)+        }+    ]++  conRep GRepFun {..} _ =+    [ GRepField+        { fieldSelector = selNameP (Proxy @s),+          fieldTypeRef = TypeRef (grepTypename (Proxy @a)) (grepWrappers (Proxy @a)),+          fieldValue = grepFun (Proxy @a)+        }+    ]+  scanRec GRepFun {..} _ = [grepFun (Proxy @a)]++instance DeriveFieldRep gql c v U1 where+  toFieldRep _ _ = []+  conRep _ _ = []+  scanRec _ _ = []++data GRepType v+  = GRepTypeEnum [TypeName]+  | GRepTypeObject [GRepField v]+  | GRepTypeUnion+      { variantRefs :: [(TypeName, v)],+        inlineVariants :: [GRepCons v]+      }++instance Foldable GRepType where+  foldr _ res GRepTypeEnum {} = res+  foldr f res (GRepTypeObject fields) = foldr f res (map fieldValue fields)+  foldr f res GRepTypeUnion {inlineVariants, variantRefs} = foldr f res (concatMap toList inlineVariants <> map snd variantRefs)++data GRepValue v+  = GRepValueUnionRef+      { unionRefTypeName :: TypeName,+        unionRefValue :: v+      }+  | GRepValueUnion+      { unionTypeName :: TypeName,+        unionVariantName :: TypeName,+        unionFields :: [GRepField v]+      }+  | GRepValueObject+      { objectTypeName :: TypeName,+        objectFields :: [GRepField v]+      }+  | GRepValueEnum+      { enumTypeName :: TypeName,+        enumVariantName :: TypeName+      }+  deriving (Functor)++data GRepCons (a :: Type) = GRepCons+  { consName :: TypeName,+    consFields :: [GRepField a]+  }+  deriving (Functor)++instance Foldable GRepCons where+  foldMap f GRepCons {..} = foldMap f (map fieldValue consFields)++data GRepField (a :: Type) = GRepField+  { fieldSelector :: FieldName,+    fieldTypeRef :: TypeRef,+    fieldValue :: a+  }+  deriving (Functor)++-- setFieldNames ::  Power Int Text -> Power { _1 :: Int, _2 :: Text }+enumerate :: [GRepField a] -> [GRepField a]+enumerate = zipWith setFieldName ([0 ..] :: [Int])+  where+    setFieldName i field = field {fieldSelector = packName $ "_" <> pack (show i)}++isUnionRef :: TypeName -> GRepCons k -> Bool+isUnionRef baseName GRepCons {consName, consFields = [fieldRep]} =+  consName == baseName <> typeConName (fieldTypeRef fieldRep)+isUnionRef _ _ = False++unpackMonad :: (Monad m) => [GRepCons (m a)] -> m [GRepCons a]+unpackMonad = traverse unpackMonadFromCons++unpackMonadFromField :: (Monad m) => GRepField (m a) -> m (GRepField a)+unpackMonadFromField GRepField {..} = do+  cont <- fieldValue+  pure (GRepField {fieldValue = cont, ..})++unpackMonadFromCons :: (Monad m) => GRepCons (m a) -> m (GRepCons a)+unpackMonadFromCons GRepCons {..} = GRepCons consName <$> traverse unpackMonadFromField consFields
+ src/Data/Morpheus/Generic/GScan.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.Generic.GScan+  ( ScanRef (..),+    ProxyMap (..),+    useProxies,+    scan,+    scanNode,+    scanLeaf,+  )+where++import Data.HashMap.Strict (fromList, insert, member)+import Data.Morpheus.Generic.Gmap (Gmap, gmap)+import Data.Morpheus.Generic.Proxy+  ( CBox (..),+    CProxy (..),+  )+import GHC.Generics (Generic (Rep))+import Relude hiding (fromList)++--  GENERIC+type Fingerprint = Text++useProxies :: (Hashable k, Eq k) => (CBox f c -> [v]) -> (v -> k) -> [CBox f c] -> HashMap k v+useProxies toValue toKey = fromList . map (\x -> (toKey x, x)) . concatMap toValue++scan :: (c a, ProxyMap f) => (forall a'. (c a') => f a' -> [ScanRef f c]) -> f a -> [CBox f c]+scan f = toList . scanRefs (Scanner f) mempty . f++type ScannerMap f c = HashMap Fingerprint (CBox f c)++class ProxyMap p where+  proxyMap :: f b -> p a -> p b++instance ProxyMap Proxy where+  proxyMap p _ = toProxy p+    where+      toProxy :: f a -> Proxy a+      toProxy _ = Proxy++runProxy :: (ProxyMap f) => f a -> Scanner f c -> CProxy c -> [ScanRef f c]+runProxy cat scanner (CProxy prx) = runScanner scanner (proxyMap prx cat)++fieldRefs :: (ProxyMap f) => Scanner f c -> ScanRef f c -> [ScanRef f c]+fieldRefs scanner (ScanNode _ _ prx) = concatMap (runProxy prx scanner) (gmap prx)+fieldRefs _ ScanLeaf {} = []++visited :: HashMap Fingerprint v -> ScanRef f c -> Bool+visited lib (ScanNode _ fp _) = member fp lib+visited lib (ScanLeaf fp _) = member fp lib++getFingerprint :: ScanRef f c -> Fingerprint+getFingerprint (ScanNode _ fp _) = fp+getFingerprint (ScanLeaf fp _) = fp++scanRefs :: (ProxyMap f) => Scanner f c -> ScannerMap f c -> [ScanRef f c] -> ScannerMap f c+scanRefs _ lib [] = lib+scanRefs ctx lib (x : xs) = do+  let values = runRef x+  let newLib = foldr (insert (getFingerprint x)) lib values+  let refs = filter (not . visited newLib) (xs <> fieldRefs ctx x)+  scanRefs ctx newLib refs++runRef :: ScanRef f c -> [CBox f c]+runRef (ScanNode visible _ p) = [CBox p | visible]+runRef (ScanLeaf _ p) = [CBox p]++scanLeaf :: (c a, Show fp) => fp -> f a -> ScanRef f c+scanLeaf fp = ScanLeaf (show fp)++scanNode :: (Gmap c (Rep a), c a, Show fp) => Bool -> fp -> f a -> ScanRef f c+scanNode visible fp = ScanNode visible (show fp)++data ScanRef f (c :: Type -> Constraint) where+  ScanNode :: forall a f c. (Gmap c (Rep a), c a) => Bool -> Fingerprint -> f a -> ScanRef f c+  ScanLeaf :: forall a f c. (c a) => Fingerprint -> f a -> ScanRef f c++newtype Scanner f (c :: Type -> Constraint) = Scanner+  {runScanner :: forall a. (c a) => f a -> [ScanRef f c]}
+ src/Data/Morpheus/Generic/Gmap.hs view
@@ -0,0 +1,65 @@+{-# 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 NoImplicitPrelude #-}++module Data.Morpheus.Generic.Gmap+  ( Gmap,+    gmap,+  )+where++import Data.Morpheus.Generic.Proxy+  ( CProxy (..),+    rep,+  )+import GHC.Generics+  ( C,+    D,+    Datatype,+    Generic (..),+    K1,+    M1,+    S,+    U1,+    type (:*:),+    type (:+:),+  )+import Relude++-- newtype GmapFun (fun :: Type -> Constraint) (v :: Type) = GmapFun+--   { gmapFun :: forall f a. (fun a) => f a -> v+--   }++gmap :: (Gmap c (Rep a)) => f a -> [CProxy c]+gmap p = gfmap (rep p)++class Gmap (c :: Type -> Constraint) a where+  gfmap :: f a -> [CProxy c]++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 _ = gfmap (Proxy @a) <> gfmap (Proxy @b)++instance (Gmap c a, Gmap c b) => Gmap c (a :*: b) where+  gfmap _ = gfmap (Proxy @a) <> gfmap (Proxy @b)++instance (c a) => Gmap c (M1 S s (K1 x a)) where+  gfmap _ = [CProxy (Proxy @a)]++instance Gmap c U1 where+  gfmap _ = []
+ src/Data/Morpheus/Generic/Proxy.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.Generic.Proxy+  ( conNameP,+    isRecordP,+    selNameP,+    symbolName,+    CProxy (..),+    CBox (..),+    rep,+    foldProxy,+    runCBox,+  )+where++import Data.List (init, last)+import GHC.Generics+  ( C,+    Constructor,+    Generic (..),+    M1 (..),+    Meta,+    S,+    Selector (..),+    U1 (..),+    conIsRecord,+    conName,+  )+import GHC.TypeLits+import Relude hiding (init, last, undefined)+import Prelude (undefined)++conNameP :: forall f t (c :: Meta). (Constructor c, IsString t) => f c -> t+conNameP _ = fromString $ conName (undefined :: M1 C c U1 a)++dropLiterals :: String -> String+dropLiterals name+  | not (null name) && (last name == '\'') = init name+  | otherwise = name+{-# INLINE dropLiterals #-}++isRecordP :: forall f (c :: Meta). (Constructor c) => f c -> Bool+isRecordP _ = conIsRecord (undefined :: (M1 C c f a))++selNameP :: forall f t (s :: Meta). (Selector s, IsString t) => f s -> t+selNameP _ = fromString $ dropLiterals $ selName (undefined :: M1 S s f a)++symbolName :: (KnownSymbol a, IsString t) => f a -> t+symbolName = fromString . symbolVal++-- | constrained proxy+data CProxy constraint where+  CProxy :: forall f constraint a. (constraint a) => f a -> CProxy constraint++foldProxy :: (forall f a. (c a) => f a -> b) -> CProxy c -> b+foldProxy f (CProxy x) = f x++data CBox box constraint where+  CBox :: forall constraint box a. (constraint a) => box a -> CBox box constraint++runCBox :: (forall a. (c a) => f a -> b) -> CBox f c -> b+runCBox f (CBox x) = f x++rep :: f a -> Proxy (Rep a)+rep _ = Proxy
+ src/Data/Morpheus/Generic/RefType.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.Generic.RefType+  ( RefType (..),+  )+where++import Data.Morpheus.Generic.Proxy (CProxy (..))+import GHC.Generics+  ( K1 (..),+    M1 (..),+    S,+    U1 (..),+    (:*:) (..),+  )+import Relude hiding (undefined)++class RefType con (f :: Type -> Type) where+  refType :: Proxy f -> Maybe (CProxy con)++instance RefType con (f :*: g) where+  refType _ = Nothing++instance (con a) => RefType con (M1 S s (K1 i a)) where+  refType _ = Just $ CProxy $ Proxy @a++instance RefType gql U1 where+  refType _ = Nothing
src/Data/Morpheus/Server.hs view
@@ -21,6 +21,7 @@     deriveApp,     runApp,     withDebugger,+    disableIntrospection,   ) where @@ -31,6 +32,7 @@ import Data.Morpheus.App   ( App (..),     MapAPI,+    disableIntrospection,     runApp,     withDebugger,   )@@ -56,7 +58,7 @@  -- | Generates schema.gql file from 'RootResolver' printSchema ::-  RootResolverConstraint m event query mut sub =>+  (RootResolverConstraint m event query mut sub) =>   proxy (RootResolver m event query mut sub) ->   ByteString printSchema =
− src/Data/Morpheus/Server/Deriving/Internal/Decode/Rep.hs 
@@ -1,121 +0,0 @@-{-# 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 
@@ -1,239 +0,0 @@-{-# 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/Directive.hs view
@@ -0,0 +1,183 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.Server.Deriving.Internal.Directive+  ( getFieldDirectives,+    getTypeDirectives,+    getEnumDirectives,+    visitEnumValueDescription,+    visitFieldDescription,+    visitTypeDescription,+    visitFieldDefaultValue,+    visitFieldContent,+    visitEnumName,+    visitFieldName,+    toFieldRes,+    UseDeriving (..),+    deriveDirectiveDefinition,+    serializeDirectives,+  )+where++import Control.Monad.Except+import Data.Morpheus.Generic+  ( GRepField (..),+  )+import Data.Morpheus.Internal.Ext (GQLResult, unsafeFromList)+import Data.Morpheus.Internal.Utils (Empty (..), fromElems, lookup)+import Data.Morpheus.Server.Deriving.Utils.Kinded+  ( CatType (..),+    inputType,+  )+import Data.Morpheus.Server.Deriving.Utils.Types+  ( coerceArguments,+    typeToArguments,+  )+import Data.Morpheus.Server.Deriving.Utils.Use+  ( UseDeriving (..),+    UseGQLType (..),+    UseGQLValue (..),+  )+import Data.Morpheus.Server.Types.Directives+  ( GDirectiveUsage (..),+    GDirectiveUsages (..),+    GQLDirective (..),+    applyEnumDescription,+    applyEnumName,+    applyFieldDefaultValue,+    applyFieldDescription,+    applyFieldName,+    applyTypeDescription,+    applyTypeEnumNames,+    applyTypeFieldNames,+    getLocations,+  )+import Data.Morpheus.Types.Internal.AST+  ( Argument (..),+    CONST,+    Description,+    Directive (..),+    DirectiveDefinition (..),+    Directives,+    FieldContent (..),+    FieldName,+    GQLError,+    IN,+    Position (..),+    TRUE,+    TypeDefinition,+    TypeName,+    Value (..),+  )+import GHC.Generics ()+import GHC.TypeLits ()+import Relude hiding (empty)++-- DERIVE+deriveDirectiveDefinition :: (MonadError GQLError m, gql a, GQLDirective a, val a) => UseDeriving gql val -> f a -> TypeDefinition IN CONST -> m (DirectiveDefinition CONST)+deriveDirectiveDefinition ctx proxy t = do+  directiveDefinitionArgs <- typeToArguments t+  pure+    ( DirectiveDefinition+        { directiveDefinitionName = deriveDirectiveName ctx proxy,+          directiveDefinitionDescription = visitTypeDescription ctx proxy Nothing,+          directiveDefinitionArgs,+          directiveDefinitionLocations = getLocations proxy+        }+    )++serializeDirectives :: UseDeriving gql args -> [GDirectiveUsage gql args] -> GQLResult (Directives CONST)+serializeDirectives options = fmap unsafeFromList . traverse (serializeDirective options) . filter isIncluded++-- others+serializeDirective ::+  UseDeriving gql args ->+  GDirectiveUsage gql args ->+  GQLResult (FieldName, Directive CONST)+serializeDirective ctx (GDirectiveUsage x) = do+  args <- useEncodeValue ctx x >>= coerceArguments+  directiveArgs <- fromElems (map (visitArgument ctx x) (toList args))+  pure+    ( directiveName,+      Directive+        { directivePosition = Position 0 0,+          directiveName,+          directiveArgs+        }+    )+  where+    directiveName = deriveDirectiveName ctx (Identity x)++-- GET+getEnumDirectives :: (gql a) => UseDeriving gql args -> f a -> TypeName -> [GDirectiveUsage gql args]+getEnumDirectives UseDeriving {..} proxy name = lookupDirective name $ enumValueDirectives $ useDirectives proxy++getFieldDirectives :: (gql a) => UseDeriving gql args -> f a -> FieldName -> [GDirectiveUsage gql args]+getFieldDirectives UseDeriving {..} proxy name = lookupDirective name $ fieldDirectives $ useDirectives proxy++getTypeDirectives :: (gql a) => UseDeriving gql args -> f a -> [GDirectiveUsage gql args]+getTypeDirectives ctx = typeDirectives . useDirectives ctx++lookupDirective :: (Ord k, Hashable k, Empty a) => k -> HashMap k a -> a+lookupDirective name xs = fromMaybe empty $ name `lookup` xs++isIncluded :: GDirectiveUsage gql args -> Bool+isIncluded (GDirectiveUsage x) = not $ excludeFromSchema (Identity x)++-- VISIT++visitEnumValueDescription :: (gql a) => UseDeriving gql args -> f a -> TypeName -> Maybe Description -> Maybe Description+visitEnumValueDescription options proxy name desc = foldr applyEnumDescription desc (getEnumDirectives options proxy name)++visitEnumName :: (gql a) => UseDeriving gql args -> f a -> TypeName -> TypeName+visitEnumName options proxy name = foldr applyEnumName (withTypeDirectives name) (getEnumDirectives options proxy name)+  where+    withTypeDirectives dirName = foldr applyTypeEnumNames dirName (getTypeDirectives options proxy)++visitFieldDescription :: (gql a) => UseDeriving gql args -> f a -> FieldName -> Maybe Description -> Maybe Description+visitFieldDescription options proxy name desc = foldr applyFieldDescription desc (getFieldDirectives options proxy name)++visitFieldDefaultValue :: (gql a) => UseDeriving gql args -> f a -> FieldName -> Maybe (Value CONST) -> Maybe (Value CONST)+visitFieldDefaultValue options proxy name desc = foldr applyFieldDefaultValue desc (getFieldDirectives options proxy name)++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++visitArgument :: (gql a) => UseDeriving gql args -> a -> Argument valid -> Argument valid+visitArgument ctx x Argument {..} = Argument {argumentName = visitFieldName ctx (Identity x) argumentName, ..}++visitFieldName :: (gql a) => UseDeriving gql args -> f a -> FieldName -> FieldName+visitFieldName options proxy name = foldr applyFieldName (visitTypeFieldNames options proxy name) (getFieldDirectives options proxy name)++visitTypeFieldNames :: (gql a) => UseDeriving gql args -> f a -> FieldName -> FieldName+visitTypeFieldNames ctx proxy name = foldr applyTypeFieldNames name (getTypeDirectives ctx proxy)++visitTypeDescription :: (gql a) => UseDeriving gql args -> f a -> Maybe Description -> Maybe Description+visitTypeDescription options proxy desc = foldr applyTypeDescription desc (getTypeDirectives options proxy)++toFieldRes :: (gql a) => UseDeriving gql args -> f a -> GRepField v -> (FieldName, v)+toFieldRes options proxy GRepField {..} = (visitFieldName options proxy fieldSelector, fieldValue)++deriveDirectiveName :: (UseGQLType ctx gql, gql a) => ctx -> f a -> FieldName+deriveDirectiveName options = coerce . useTypename options . inputType
− src/Data/Morpheus/Server/Deriving/Internal/Resolve/Explore.hs 
@@ -1,112 +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 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/Resolver.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.Server.Deriving.Internal.Resolver+  ( 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.Generic+  ( GRep,+    GRepFun (..),+    GRepValue (..),+    deriveValue,+  )+import Data.Morpheus.Server.Deriving.Internal.Directive+  ( toFieldRes,+    visitEnumName,+  )+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,+  )+import GHC.Generics (Generic (Rep))+import Relude++fromGRep :: (MonadError GQLError m, gql a) => UseDeriving gql val -> f a -> GRepValue (m (ResolverValue m)) -> ResolverValue m+fromGRep ctx prx GRepValueEnum {..} = mkEnum (visitEnumName ctx prx enumVariantName)+fromGRep ctx prx GRepValueObject {..} = mkObject objectTypeName (toFieldRes ctx prx <$> objectFields)+fromGRep ctx prx GRepValueUnion {..} = mkUnion unionVariantName (toFieldRes ctx prx <$> unionFields)+fromGRep _ _ GRepValueUnionRef {..} = ResLazy (ResObject (Just unionRefTypeName) <$> (unionRefValue >>= requireObject))++toOptions :: UseResolver res gql val -> GRepFun gql (res m) Identity (m (ResolverValue m))+toOptions ctx =+  GRepFun+    { grepFun = useEncodeResolver ctx . runIdentity,+      grepTypename = useTypename ctx . inputType,+      grepWrappers = useWrappers ctx . inputType+    }++useExploreResolvers ::+  (MonadError GQLError m, EXPLORE gql res m a) =>+  UseResolver res gql val ->+  a ->+  ResolverValue m+useExploreResolvers res v = fromGRep (resDrv res) (Identity v) (deriveValue (toOptions res) 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 
@@ -1,220 +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 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 
@@ -1,56 +0,0 @@-{-# 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 
@@ -1,75 +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.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 
@@ -1,102 +0,0 @@-{-# 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 
@@ -1,166 +0,0 @@-{-# 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 
@@ -1,82 +0,0 @@-{-# 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/Internal/Type.hs view
@@ -0,0 +1,226 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}++module Data.Morpheus.Server.Deriving.Internal.Type+  ( toTypeDefinition,+    deriveTypeDefinition,+    deriveScalarDefinition,+    deriveInterfaceDefinition,+    deriveTypeGuardUnions,+    DERIVE_TYPE,+  )+where++import Control.Monad.Except+  ( MonadError (..),+  )+import Data.Foldable+import Data.List (partition)+import Data.Morpheus.Generic+  ( GRep,+    GRepCons (..),+    GRepField (..),+    GRepFun (..),+    GRepType (..),+    deriveType,+  )+import Data.Morpheus.Internal.Ext (GQLResult)+import Data.Morpheus.Internal.Utils (Empty (..), fromElems)+import Data.Morpheus.Server.Deriving.Internal.Directive+  ( UseDeriving (..),+    getEnumDirectives,+    getFieldDirectives,+    getTypeDirectives,+    serializeDirectives,+    visitEnumName,+    visitEnumValueDescription,+    visitFieldContent,+    visitFieldDescription,+    visitFieldName,+    visitTypeDescription,+  )+import Data.Morpheus.Server.Deriving.Utils.Kinded+  ( mapCat,+    mkEnum,+    mkObject,+    mkScalar,+  )+import Data.Morpheus.Server.Deriving.Utils.Types+  ( CatType (..),+    GQLTypeNode (..),+    GQLTypeNodeExtension (..),+    NodeTypeVariant (..),+    toFieldContent,+    withObject,+  )+import Data.Morpheus.Server.Deriving.Utils.Use+  ( UseGQLType (..),+  )+import Data.Morpheus.Types.Internal.AST+  ( ArgumentsDefinition,+    CONST,+    DataEnumValue (..),+    FieldDefinition (..),+    OUT,+    ScalarDefinition,+    TRUE,+    TypeContent (..),+    TypeDefinition (..),+    TypeName,+    UnionMember (..),+    mkField,+    mkNullaryMember,+    mkTypeRef,+    mkUnionMember,+    toAny,+    unitFieldName,+    unitTypeName,+  )+import GHC.Generics (Rep)+import Relude hiding (empty)++type DERIVE_TYPE gql a =+  ( gql a,+    GRep gql gql (GQLResult (ArgumentsDefinition CONST)) (Rep a)+  )++toEnumValue :: (gql a) => UseDeriving gql args -> f a -> TypeName -> GQLResult (DataEnumValue CONST)+toEnumValue ctx proxy enumName = do+  enumDirectives <- serializeDirectives ctx (getEnumDirectives ctx proxy enumName)+  pure+    DataEnumValue+      { enumName = visitEnumName ctx proxy enumName,+        enumDescription = visitEnumValueDescription ctx proxy enumName Nothing,+        ..+      }++repToField ::+  CatType c a ->+  GRepField (ArgumentsDefinition CONST) ->+  FieldDefinition c CONST+repToField proxy GRepField {..} =+  FieldDefinition+    { fieldDescription = mempty,+      fieldDirectives = empty,+      fieldContent = toFieldContent proxy fieldValue,+      fieldName = fieldSelector,+      fieldType = fieldTypeRef+    }++visitField :: (gql a) => UseDeriving gql args -> CatType kind a -> FieldDefinition kind CONST -> GQLResult (FieldDefinition kind CONST)+visitField ctx proxy FieldDefinition {..} = do+  dirs <- serializeDirectives ctx (getFieldDirectives ctx proxy fieldName)+  pure+    FieldDefinition+      { fieldName = visitFieldName ctx proxy fieldName,+        fieldDescription = visitFieldDescription ctx proxy fieldName Nothing,+        fieldContent = visitFieldContent ctx proxy fieldName fieldContent,+        fieldDirectives = dirs,+        ..+      }++toUnion ::+  CatType kind a ->+  [TypeName] ->+  [GRepCons (ArgumentsDefinition CONST)] ->+  GQLResult (TypeContent TRUE kind CONST, [GQLTypeNodeExtension])+toUnion prx@InputType variantRefs inlineVariants = do+  let nodes = [UnionVariantsExtension ([NodeUnitType | not (null nullaryVariants)] <> concat (traverse (toTypeVariants prx) objectVariants))]+  variants <- fromElems members+  pure (DataInputUnion variants, nodes)+  where+    (nullaryVariants, objectVariants) = partition null inlineVariants+    members =+      map mkUnionMember (variantRefs <> map consName objectVariants)+        <> fmap (mkNullaryMember . consName) nullaryVariants+toUnion prx@OutputType unionRef unionCons = do+  variants <- fromElems (map mkUnionMember (unionRef <> map consName unionCons))+  pure (DataUnion variants, [UnionVariantsExtension (concat $ traverse (toTypeVariants prx) unionCons)])++toTypeVariants :: CatType kind a -> GRepCons (ArgumentsDefinition CONST) -> [NodeTypeVariant]+toTypeVariants proxy GRepCons {consName, consFields} =+  [NodeTypeVariant consName (toAny (mkObject proxy fields))] <> [NodeUnitType | null consFields]+  where+    fields+      | null consFields = [mkField Nothing unitFieldName (mkTypeRef unitTypeName)]+      | otherwise = map (repToField proxy) consFields++toTypeContent ::+  (gql a) =>+  UseDeriving gql args ->+  CatType kind a ->+  GRepType (ArgumentsDefinition CONST) ->+  GQLResult (TypeContent TRUE kind CONST, [GQLTypeNodeExtension])+toTypeContent ctx prx (GRepTypeEnum variants) = (,[]) . mkEnum prx <$> traverse (toEnumValue ctx prx) variants+toTypeContent ctx prx (GRepTypeObject fields) = (,[]) . mkObject prx <$> traverse (visitField ctx prx . repToField prx) fields+toTypeContent _ prx GRepTypeUnion {..} = toUnion prx (map fst variantRefs) inlineVariants++type TypeProxy gql args kind a = (UseDeriving gql args, CatType kind a)++deriveTypeContent :: (DERIVE_TYPE gql a) => TypeProxy gql args kind a -> GQLResult (TypeContent TRUE kind CONST, [GQLTypeNodeExtension])+deriveTypeContent (cxt, prx) = deriveType (fieldGRep prx cxt) prx >>= toTypeContent cxt prx++deriveTypeGuardUnions :: (DERIVE_TYPE gql a) => TypeProxy gql args OUT a -> GQLResult [TypeName]+deriveTypeGuardUnions prx = deriveTypeContent prx >>= getUnionNames prx . fst++getUnionNames :: (DERIVE_TYPE gql a) => TypeProxy gql args kind a -> TypeContent TRUE OUT CONST -> GQLResult [TypeName]+getUnionNames _ DataUnion {unionMembers} = pure $ toList $ memberName <$> unionMembers+getUnionNames (ctx, prx) DataObject {} = pure [useTypename ctx prx]+getUnionNames _ _ = throwError "guarded type must be an union or object"++deriveScalarDefinition ::+  (gql a) =>+  (CatType cat a -> ScalarDefinition) ->+  UseDeriving gql args ->+  CatType cat a ->+  GQLResult (GQLTypeNode cat)+deriveScalarDefinition f ctx p = (`GQLTypeNode` []) <$> toTypeDefinition ctx p (mkScalar p (f p))++deriveTypeDefinition ::+  (DERIVE_TYPE gql a) =>+  UseDeriving gql args ->+  CatType c a ->+  GQLResult (TypeDefinition c CONST, [GQLTypeNodeExtension])+deriveTypeDefinition ctx proxy = do+  (content, ext) <- deriveTypeContent (ctx, proxy)+  (,ext) <$> toTypeDefinition ctx proxy content++deriveInterfaceDefinition ::+  (DERIVE_TYPE gql a) =>+  UseDeriving gql args ->+  CatType OUT a ->+  GQLResult (TypeDefinition OUT CONST, [GQLTypeNodeExtension])+deriveInterfaceDefinition ctx proxy = do+  (content, ext) <- deriveTypeContent (ctx, proxy)+  fields <- withObject (useTypename ctx proxy) content+  (,ext) <$> toTypeDefinition ctx proxy (DataInterface fields)++toTypeDefinition ::+  (gql a) =>+  UseDeriving gql args ->+  CatType c a ->+  TypeContent TRUE cat CONST ->+  GQLResult (TypeDefinition cat CONST)+toTypeDefinition ctx proxy content = do+  dirs <- serializeDirectives ctx (getTypeDirectives ctx proxy)+  pure $+    TypeDefinition+      (visitTypeDescription ctx proxy Nothing)+      (useTypename ctx proxy)+      dirs+      content++fieldGRep :: (UseGQLType ctx gql) => CatType cat a -> ctx -> GRepFun gql gql Proxy (GQLResult (ArgumentsDefinition CONST))+fieldGRep cat gql =+  GRepFun+    { grepTypename = useTypename gql . (`mapCat` cat),+      grepWrappers = useWrappers gql . (`mapCat` cat),+      grepFun = useDeriveFieldArgs gql . (`mapCat` cat)+    }
+ src/Data/Morpheus/Server/Deriving/Internal/Value.hs view
@@ -0,0 +1,134 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.Server.Deriving.Internal.Value+  ( DecodeRep (..),+    Context (..),+  )+where++import Control.Monad.Except (MonadError (throwError))+import Data.Morpheus.App.Internal.Resolving (ResolverState)+import Data.Morpheus.Generic+  ( CProxy (..),+    DecodeFields,+    DecoderFun (..),+    DescribeCons,+    decodeFields,+    describeCons,+  )+import Data.Morpheus.Server.Deriving.Utils.Kinded (inputType)+import Data.Morpheus.Server.Deriving.Utils.Types (coerceInputObject, getField)+import Data.Morpheus.Server.Deriving.Utils.Use+  ( UseDeriving (..),+    UseGQLType (..),+    UseGQLValue (..),+  )+import Data.Morpheus.Types.Internal.AST+  ( FieldName,+    TypeName,+    ValidValue,+    Value (..),+    getInputUnionValue,+    internal,+    msg,+  )+import GHC.Generics+import Relude++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})++decideUnion ::+  (DecodeRep ctx f, DecodeRep ctx g) =>+  ctx ->+  ([TypeName], [TypeName]) ->+  TypeName ->+  ValidValue ->+  DecoderT ((f :+: g) a)+decideUnion drv (left, right) name value+  | name `elem` left = L1 <$> decodeRep drv value+  | name `elem` right = R1 <$> decodeRep drv value+  | otherwise =+      throwError $+        internal $+          "Constructor \""+            <> msg name+            <> "\" could not find in Union"++class DecodeRep ctx (f :: Type -> Type) where+  decodeRep :: ctx -> ValidValue -> DecoderT (f a)++instance (Datatype d, DecodeRep ctx f) => DecodeRep ctx (M1 D d f) where+  decodeRep drv value = M1 <$> decodeRep drv value++instance (UseGQLType ctx gql, DescribeCons gql a, DescribeCons gql b, DecodeRep ctx a, DecodeRep ctx b) => DecodeRep ctx (a :+: b) where+  decodeRep ctx input =+    do+      typename <- asks typeName+      let (kind, (left, right)) = getUnionTags ctx typename (Proxy @(a :+: b))+      (lr, name, value) <-+        case input of+          (Object obj) -> do+            (name, value) <- getInputUnionValue obj+            variant <- coerceInputObject value+            let isDone = [name] == left || [name] == left+            pure ((left, right), name, if isDone then Object variant else input)+          (Enum name) -> do+            visitor <- asks enumVisitor+            pure ((map visitor left, map visitor right), name, Enum name)+          _ -> throwError (internal "lists and scalars are not allowed in Union")+      setVariantRef kind (decideUnion ctx lr name value)++instance (Constructor c, UseDeriving gql val ~ ctx, DecodeFields val a) => DecodeRep ctx (M1 C c a) where+  decodeRep ctx value = fmap M1 (decodeFields (decoder ctx value))++decoder :: (UseGQLValue ctx con) => ctx -> ValidValue -> DecoderFun con DecoderT+decoder ctx input =+  DecoderFun+    ( \name ->+        do+          Context {isVariantRef, fieldVisitor} <- ask+          value <- if isVariantRef then pure input else getField (fieldVisitor name) <$> coerceInputObject input+          lift (useDecodeValue ctx value)+    )++getUnionTags ::+  forall ctx f a b gql.+  (UseGQLType ctx gql, DescribeCons gql a, DescribeCons gql b) =>+  ctx ->+  TypeName ->+  f (a :+: b) ->+  (Bool, ([TypeName], [TypeName]))+getUnionTags ctx typename _ = do+  let left = map toInfo (describeCons (Proxy @a))+  let right = map toInfo (describeCons (Proxy @b))+  let varRef = find snd (left <> right)+  (isJust varRef, (map fst left, map fst right))+  where+    toInfo :: (TypeName, Maybe (CProxy gql)) -> (TypeName, Bool)+    toInfo (consName, Just (CProxy p))+      | consName == typename <> typeVariant = (typeVariant, True)+      | otherwise = (consName, False)+      where+        typeVariant = useTypename ctx (inputType p)+    toInfo (consName, Nothing) = (consName, False)
src/Data/Morpheus/Server/Deriving/Kinded/Arguments.hs view
@@ -6,7 +6,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-}@@ -19,43 +18,33 @@   ) where -import Data.Morpheus.Internal.Ext ((<:>))-import Data.Morpheus.Server.Deriving.Internal.Schema.Internal-  ( CatType,-    deriveTypeAsArguments,-  )+import Data.Morpheus.Internal.Ext (GQLResult, (<:>))+import Data.Morpheus.Internal.Utils (empty) 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,+    inputType,   )+import Data.Morpheus.Server.Deriving.Utils.Types (nodeToType, typeToArguments)+import Data.Morpheus.Server.Deriving.Utils.Use (UseGQLType (..)) import Data.Morpheus.Types.Internal.AST   ( ArgumentsDefinition,     CONST,     OUT,   )-import Relude+import Relude hiding (empty)  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))+class DeriveFieldArguments ctx a where+  deriveFieldArguments :: ctx -> f a -> GQLResult (ArgumentsDefinition CONST) -instance DeriveFieldArguments gql () where-  deriveFieldArguments _ _ = pure Nothing+instance DeriveFieldArguments ctx () where+  deriveFieldArguments _ _ = pure empty -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+instance (UseGQLType ctx gql, gql b, gql a) => DeriveFieldArguments ctx (a -> b) where+  deriveFieldArguments gql _ = do+    a <- useDeriveNode gql (inputType (Proxy @a)) >>= nodeToType >>= typeToArguments+    b <- useDeriveFieldArgs gql (OutputType :: CatType OUT b)+    a <:> b
src/Data/Morpheus/Server/Deriving/Kinded/Channels.hs view
@@ -5,9 +5,11 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE NoImplicitPrelude #-} @@ -18,27 +20,25 @@ 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.Generic+  ( GRep,+    GRepField,+    GRepFun (..),+    GRepValue (..),+    deriveValue,+  ) 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.Internal.Directive (UseDeriving (..), toFieldRes) import Data.Morpheus.Server.Deriving.Utils.Kinded (outputType)-import Data.Morpheus.Server.Deriving.Utils.Use (UseGQLType (useTypeData))+import Data.Morpheus.Server.Deriving.Utils.Use (UseGQLType (..), useDecodeArguments) import Data.Morpheus.Server.Types.Types (Undefined) import Data.Morpheus.Types.Internal.AST   ( FALSE,@@ -62,12 +62,12 @@ type CHANNELS gql val (subs :: (Type -> Type) -> Type) m =   ( MonadResolver m,     MonadOperation m ~ SUBSCRIPTION,-    ExploreChannels gql val (IsUndefined (subs m)) (MonadEvent m) (subs m)+    ExploreChannels (UseDeriving gql val) (IsUndefined (subs m)) (MonadEvent m) (subs m)   )  resolverChannels ::   forall m subs gql val.-  CHANNELS gql val subs m =>+  (CHANNELS gql val subs m) =>   UseDeriving gql val ->   subs m ->   Selection VALID ->@@ -118,22 +118,26 @@   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)+class ExploreChannels ctx (t :: Bool) e a where+  exploreChannels :: (UseDeriving gql val ~ ctx) => ctx -> 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+instance (UseDeriving gql val ~ ctx, gql a, Generic a, GRep gql (GetChannel val e) (ChannelRes e) (Rep a)) => ExploreChannels ctx FALSE e a where+  exploreChannels ctx _ =+    fromList+      . map (toFieldRes ctx (Proxy @a))+      . toFields       . deriveValue-        ( RepContext-            { optApply = getChannel drv . runIdentity,-              optTypeData = useTypeData (dirGQL drv) . outputType+        ( GRepFun+            { grepFun = getChannel ctx . runIdentity,+              grepTypename = useTypename ctx . outputType,+              grepWrappers = useWrappers ctx . outputType             } ::-            RepContext gql (GetChannel val e) Identity (ChannelRes e)+            GRepFun gql (GetChannel val e) Identity (ChannelRes e)         ) -instance ExploreChannels drv val TRUE e (Undefined m) where-  exploreChannels _ _ = pure HM.empty+toFields :: GRepValue (ChannelRes e) -> [GRepField (ChannelRes e)]+toFields GRepValueObject {..} = objectFields+toFields _ = []++instance ExploreChannels ctx TRUE e (Undefined m) where+  exploreChannels _ _ = pure mempty
src/Data/Morpheus/Server/Deriving/Kinded/NamedResolver.hs view
@@ -8,6 +8,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE NoImplicitPrelude #-} @@ -22,14 +23,23 @@     NamedResolverResult (..),     ResolverValue,   )+import Data.Morpheus.Generic+  ( GRep,+    Gmap,+    ScanRef,+    scanLeaf,+    scanNode,+  ) 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.Deriving.Utils.Use+  ( UseDeriving (..),+    UseGQLType (..),+    UseGQLValue (..),+    UseNamedResolver (..),+  ) import Data.Morpheus.Server.Types.Kind   ( CUSTOM,     DerivingKind,@@ -47,36 +57,38 @@  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+decodeValues :: (DECODE_VALUES val m a) => UseDeriving gql val -> Proxy a -> [ValidValue] -> m [Maybe a]+decodeValues ctx _ xs = traverse (liftState . useDecodeValue 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)]+class KindedNamedResolver ctx (k :: DerivingKind) (m :: Type -> Type) a where+  kindedNamedResolver :: (UseNamedResolver namedRes resFun gql val ~ ctx) => ctx -> p (f k a) -> [NamedResolver m]+  kindedNamedRefs :: (UseNamedResolver namedRes resFun gql val ~ ctx) => ctx -> p (f k a) -> [ScanRef Proxy (namedRes m)]  instance-  ( DECODE_VALUES val m a,+  ( UseNamedResolver namedRes resFun gql val ~ ctx,+    DECODE_VALUES val m a,     gql a,     namedRes m a,     EncodeScalar a   ) =>-  KindedNamedResolver namedRes resFun gql val m SCALAR a+  KindedNamedResolver ctx SCALAR m a   where   kindedNamedResolver ctx _ =     [ NamedResolver-        { resolverName = useTypename (dirGQL $ namedDrv ctx) (outputType proxy),+        { resolverName = useTypename ctx (outputType proxy),           resolverFun = decodeValues (namedDrv ctx) proxy >=> pure . map (maybe NamedNullResolver (NamedScalarResolver . encodeScalar))         }     ]     where       proxy = Proxy @a-  kindedNamedRefs ctx _ = [ScanType fp proxy]+  kindedNamedRefs ctx _ = [scanLeaf fp proxy]     where-      fp = useFingerprint (dirGQL $ namedDrv ctx) (outputType proxy)+      fp = useFingerprint ctx (outputType proxy)       proxy = Proxy @a  instance-  ( DECODE_VALUES val m a,+  ( UseNamedResolver namedRes resFun gql val ~ ctx,+    DECODE_VALUES val m a,     gql a,     namedRes m a,     Generic a,@@ -84,29 +96,29 @@     GRep gql (resFun m) (m (ResolverValue m)) (Rep a),     Gmap (namedRes m) (Rep a)   ) =>-  KindedNamedResolver namedRes resFun gql val m TYPE (a :: Type)+  KindedNamedResolver ctx TYPE m (a :: Type)   where   kindedNamedResolver ctx _ =     [ NamedResolver-        { resolverName = useTypename (dirGQL $ namedDrv ctx) (outputType proxy),+        { resolverName = useTypename ctx (outputType proxy),           resolverFun = decodeValues (namedDrv ctx) proxy >=> deriveNamedResolverFun ctx         }     ]     where       proxy = Proxy @a -  kindedNamedRefs ctx _ = [ScanObject (useFingerprint (dirGQL $ namedDrv ctx) (outputType proxy)) proxy]+  kindedNamedRefs ctx _ = [scanNode True (useFingerprint ctx (outputType proxy)) proxy]     where       proxy = Proxy @a -instance namedRes m a => KindedNamedResolver namedRes resFun gql val m CUSTOM (NamedResolverT m a) where+instance (UseNamedResolver namedRes resFun gql val ~ ctx, namedRes m a) => KindedNamedResolver ctx CUSTOM m (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+instance (UseNamedResolver namedRes resFun gql val ~ ctx, namedRes m a) => KindedNamedResolver ctx CUSTOM m (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+instance (UseNamedResolver namedRes resFun gql val ~ ctx, namedRes m a) => KindedNamedResolver ctx WRAPPER m (f a) where   kindedNamedResolver ctx _ = useDeriveNamedResolvers ctx (Proxy @a)   kindedNamedRefs ctx _ = useDeriveNamedRefs ctx (Proxy @a)
src/Data/Morpheus/Server/Deriving/Kinded/NamedResolverFun.hs view
@@ -4,12 +4,12 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE NoImplicitPrelude #-} @@ -31,27 +31,25 @@     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 (..),+import Data.Morpheus.Generic+  ( GRep,+    GRepFun (..),+    GRepValue (..),     deriveValue,   )+import Data.Morpheus.Server.Deriving.Internal.Directive+  ( UseDeriving,+    toFieldRes,+  ) import Data.Morpheus.Server.Deriving.Utils.Kinded   ( CatType (..),+    Kinded (..),     outputType,   )-import Data.Morpheus.Server.Deriving.Utils.Proxy-  ( ContextValue (..),-  ) import Data.Morpheus.Server.Deriving.Utils.Use-  ( UseDeriving (..),-    UseGQLType (..),+  ( UseGQLType (..),     UseNamedResolver (..),+    useDecodeArguments,   ) import Data.Morpheus.Server.Types.Kind   ( CUSTOM,@@ -76,7 +74,6 @@     internal,     replaceValue,   )-import qualified GHC.Exts as HM import GHC.Generics   ( Generic (..),   )@@ -97,76 +94,62 @@     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)+class KindedNamedFunValue ctx (k :: DerivingKind) (m :: Type -> Type) (a :: Type) where+  kindedNamedFunValue :: (UseNamedResolver namedRes res gql val ~ ctx) => ctx -> Kinded k a -> m (ResolverValue m) -instance (EncodeScalar a, Monad m) => KindedNamedFunValue res gql val SCALAR m a where-  kindedNamedFunValue _ = pure . ResScalar . encodeScalar . unContextValue+instance (EncodeScalar a, Monad m) => KindedNamedFunValue ctx SCALAR m a where+  kindedNamedFunValue _ = pure . ResScalar . encodeScalar . unkind -instance (MonadError GQLError m) => KindedNamedFunValue res gql val TYPE m a where-  kindedNamedFunValue _ (ContextValue _) = throwError (internal "types are resolved by Refs")+instance (MonadError GQLError m) => KindedNamedFunValue ctx TYPE m a where+  kindedNamedFunValue _ _ = 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 (UseNamedResolver namedRes res gql val ~ ctx, Applicative m, res m a) => KindedNamedFunValue ctx WRAPPER m [a] where+  kindedNamedFunValue ctx = fmap ResList . traverse (useNamedFieldResolver ctx) . unkind -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 (UseNamedResolver namedRes res gql val ~ ctx, gql a, res m a, Applicative m) => KindedNamedFunValue ctx WRAPPER m (Maybe a) where+  kindedNamedFunValue ctx (Kinded (Just x)) = useNamedFieldResolver ctx x+  kindedNamedFunValue _ (Kinded 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+instance (UseNamedResolver namedRes res gql val ~ ctx, Monad m, gql a, ToJSON (NamedRef a)) => KindedNamedFunValue ctx CUSTOM m (NamedResolverT m a) where+  kindedNamedFunValue ctx = encodeRef . unkind     where       name :: TypeName-      name = useTypename (dirGQL (namedDrv ctx)) (OutputType :: CatType OUT a)-      encodeRef :: Monad m => NamedResolverT m a -> m (ResolverValue m)+      name = useTypename 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 :: (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) =+instance (UseNamedResolver namedRes res gql val ~ ctx, Monad m, val a, MonadResolver m, res m b) => KindedNamedFunValue ctx CUSTOM m (a -> b) where+  kindedNamedFunValue ctx (Kinded 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+getOptions :: UseNamedResolver namedRes res gql val -> GRepFun gql (res m) Identity (m (ResolverValue m))+getOptions ctx =+  GRepFun+    { grepFun = useNamedFieldResolver ctx . runIdentity,+      grepTypename = useTypename ctx . outputType,+      grepWrappers = useWrappers ctx . outputType     }  convertNamedNode ::-  (gql a, MonadError GQLError m) =>+  (MonadError GQLError m, gql a) =>   UseDeriving gql val ->   f a ->-  TypeRep (m (ResolverValue m)) ->+  GRepValue (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!"+convertNamedNode _ _ GRepValueEnum {..} = pure $ NamedEnumResolver enumVariantName+convertNamedNode drv proxy GRepValueObject {..} = pure $ NamedObjectResolver $ ObjectTypeResolver $ fromList (toFieldRes drv proxy <$> objectFields)+convertNamedNode _ _ GRepValueUnionRef {..} = NamedUnionResolver <$> (unionRefValue >>= getRef)+convertNamedNode _ _ GRepValueUnion {} = throwError "only union references are supported!" -getRef :: MonadError GQLError m => ResolverValue m -> m NamedResolverRef+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
@@ -7,6 +7,7 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE NoImplicitPrelude #-} @@ -15,22 +16,23 @@   ) 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.Internal.Utils (toAssoc)+import Data.Morpheus.Server.Deriving.Internal.Resolver+  ( EXPLORE,+    useExploreResolvers,   )+import Data.Morpheus.Server.Deriving.Utils.Kinded+  ( Kinded (..),+  )+import Data.Morpheus.Server.Deriving.Utils.Types import Data.Morpheus.Server.Deriving.Utils.Use-  ( UseDeriving (dirArgs),+  ( UseGQLValue (useDecodeValue),     UseResolver (..),-    UseValue (useDecodeValue),   ) import Data.Morpheus.Server.Types.Kind   ( CUSTOM,@@ -46,38 +48,35 @@   ( 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)+class KindedResolver ctx (k :: DerivingKind) (m :: Type -> Type) (a :: Type) where+  kindedResolver :: (MonadResolver m, UseResolver res gql val ~ ctx) => ctx -> Kinded k 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 (UseResolver res gql val ~ ctx, EncodeWrapper f, res m a) => KindedResolver ctx WRAPPER m (f a) where+  kindedResolver res = encodeWrapper (useEncodeResolver res) . unkind -instance (EncodeScalar a, Monad m) => KindedResolver gql res val SCALAR m a where-  kindedResolver _ = pure . ResScalar . encodeScalar . unContextValue+instance (EncodeScalar a) => KindedResolver ctx SCALAR m a where+  kindedResolver _ = pure . ResScalar . encodeScalar . unkind -instance (MonadError GQLError m, EXPLORE gql res m a) => KindedResolver gql res val TYPE m a where-  kindedResolver ctx = pure . useExploreResolvers ctx . unContextValue+instance (UseResolver res gql val ~ ctx, EXPLORE gql res m a) => KindedResolver ctx TYPE m a where+  kindedResolver ctx = pure . useExploreResolvers ctx . unkind  --  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+instance (UseResolver res gql val ~ ctx, res m [(k, v)], Ord k) => KindedResolver ctx CUSTOM m (Map k v) where+  kindedResolver res = useEncodeResolver res . toAssoc . unkind  --  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 (UseResolver res gql val ~ ctx, EXPLORE gql res m guard, EXPLORE gql res m union) => KindedResolver ctx CUSTOM m (TypeGuard guard union) where+  kindedResolver ctx (Kinded (ResolveType value)) = pure (useExploreResolvers ctx value)+  kindedResolver ctx (Kinded (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) =+instance (UseResolver res gql val ~ ctx, Generic a, res m b, val a) => KindedResolver ctx CUSTOM m (a -> b) where+  kindedResolver res (Kinded f) =     getArguments-      >>= liftState . useDecodeValue (dirArgs $ resDrv res) . argumentsToObject+      >>= liftState . useDecodeValue 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+instance (UseResolver res gql val ~ ctx, res m a) => KindedResolver ctx CUSTOM m (m a) where+  kindedResolver res (Kinded value) = value >>= useEncodeResolver res
src/Data/Morpheus/Server/Deriving/Kinded/Type.hs view
@@ -6,73 +6,92 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.Server.Deriving.Kinded.Type   ( DeriveKindedType (..),     DERIVE_TYPE,-    deriveInterfaceDefinition,     deriveScalarDefinition,     deriveTypeGuardUnions,+    scanNode,   ) where -import Data.Morpheus.Server.Deriving.Internal.Schema.Type-  ( deriveInterfaceDefinition,+import Data.Morpheus.Generic+  ( Gmap,+  )+import Data.Morpheus.Internal.Ext (GQLResult)+import Data.Morpheus.Server.Deriving.Internal.Directive (deriveDirectiveDefinition)+import Data.Morpheus.Server.Deriving.Internal.Type+  ( DERIVE_TYPE,     deriveScalarDefinition,     deriveTypeDefinition,     deriveTypeGuardUnions,   )-import Data.Morpheus.Server.Deriving.Utils.GRep-  ( GRep,+import Data.Morpheus.Server.Deriving.Utils.GScan+  ( FreeCatType,+    ScanRef,+    freeLeaf,+    freeNode,   ) import Data.Morpheus.Server.Deriving.Utils.Kinded-  ( CatType,-    catMap,+  ( CatType (..),+    inputType,+    mapCat,     unliftKind,   )+import Data.Morpheus.Server.Deriving.Utils.Types (GQLTypeNode (..)) import Data.Morpheus.Server.Deriving.Utils.Use   ( UseDeriving (..),     UseGQLType (..),   )+import Data.Morpheus.Server.Types.Directives (GQLDirective (..)) import Data.Morpheus.Server.Types.Kind-  ( DerivingKind,+  ( DIRECTIVE,+    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 GHC.Generics (Generic (Rep)) 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)+class DeriveKindedType ctx (k :: DerivingKind) a where+  deriveKindedType :: (ctx ~ UseDeriving gql v) => ctx -> CatType cat (f k a) -> GQLResult (GQLTypeNode cat)+  exploreKindedRefs :: (ctx ~ UseDeriving gql v) => ctx -> CatType cat (f k a) -> [ScanRef FreeCatType gql] -instance (gql a) => DeriveKindedType gql val cat WRAPPER (f a) where-  deriveKindedType UseDeriving {..} = useDeriveType dirGQL . catMap (Proxy @a)+instance (gql a, ctx ~ UseDeriving gql v) => DeriveKindedType ctx WRAPPER (f a) where+  deriveKindedType ctx = useDeriveNode ctx . mapCat (Proxy @a)+  exploreKindedRefs ctx = useExploreRef ctx . mapCat (Proxy @a) -instance (DecodeScalar a, gql a) => DeriveKindedType gql val cat SCALAR a where-  deriveKindedType drv = deriveScalarDefinition scalarValidator drv . unliftKind+scanLeaf :: (c a, UseGQLType ctx gql, gql a) => ctx -> CatType k a -> [ScanRef FreeCatType c]+scanLeaf gql p = [freeLeaf (useFingerprint gql p) p] -instance DERIVE_TYPE gql cat a => DeriveKindedType gql val cat TYPE a where-  deriveKindedType drv = deriveTypeDefinition drv . unliftKind+scanNode :: (c a, gql a, UseGQLType ctx gql, Gmap c (Rep a)) => Bool -> ctx -> CatType k a -> [ScanRef FreeCatType c]+scanNode visible gql p = [freeNode visible (useFingerprint gql p) p]++instance (DecodeScalar a, gql a, ctx ~ UseDeriving gql v) => DeriveKindedType ctx SCALAR a where+  deriveKindedType ctx = deriveScalarDefinition scalarValidator ctx . unliftKind+  exploreKindedRefs ctx proxy = scanLeaf ctx (mapCat (Proxy @a) proxy)++instance (DERIVE_TYPE gql a, Gmap gql (Rep a), ctx ~ UseDeriving gql v) => DeriveKindedType ctx TYPE a where+  deriveKindedType ctx = fmap (uncurry GQLTypeNode) . deriveTypeDefinition ctx . unliftKind+  exploreKindedRefs ctx proxy = scanNode True ctx (mapCat (Proxy @a) proxy)++instance (DERIVE_TYPE gql a, Gmap gql (Rep a), ctx ~ UseDeriving gql v, GQLDirective a, v a) => DeriveKindedType ctx DIRECTIVE a where+  deriveKindedType drv _ = GQLDirectiveNode <$> (deriveTypeDefinition drv proxy >>= deriveDirectiveDefinition drv proxy . fst)+    where+      proxy = inputType (Proxy @a)+  exploreKindedRefs ctx proxy+    | excludeFromSchema (Proxy @a) = []+    | otherwise = scanNode True ctx (mapCat (Proxy @a) proxy)
src/Data/Morpheus/Server/Deriving/Kinded/Value.hs view
@@ -9,6 +9,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE NoImplicitPrelude #-} @@ -17,52 +18,50 @@   ) where -import Control.Monad.Except-  ( MonadError (throwError),-  )-import qualified Data.Map as M+import Control.Monad.Except (MonadError (throwError)) 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.Generic+  ( GRep,+    GRepField (..),+    GRepFun (..),+    GRepValue (..),+    deriveValue,+    symbolName,   )-import Data.Morpheus.Server.Deriving.Internal.Decode.Utils-  ( Context (..),-    decodeFieldWith,-    handleEither,-    repValue,-    withInputObject,-    withScalar,+import Data.Morpheus.Internal.Ext (GQLResult, unsafeFromList)+import Data.Morpheus.Internal.Utils+  ( IsMap (toAssoc),+    fromElems,   )-import Data.Morpheus.Server.Deriving.Internal.Schema.Directive+import Data.Morpheus.Server.Deriving.Internal.Directive   ( visitEnumName,     visitFieldName,   )-import Data.Morpheus.Server.Deriving.Utils.GRep-  ( GRep,-    RepContext (..),-    deriveValue,+import Data.Morpheus.Server.Deriving.Internal.Value+  ( Context (..),+    DecodeRep (..),   ) import Data.Morpheus.Server.Deriving.Utils.Kinded   ( CatType (..),+    Kinded (..),     inputType,   )-import Data.Morpheus.Server.Deriving.Utils.Proxy-  ( ContextValue,-    symbolName,-    unContextValue,+import Data.Morpheus.Server.Deriving.Utils.Types+  ( coerceInputObject,+    coerceScalar,+    getField,+    handleEither,   ) import Data.Morpheus.Server.Deriving.Utils.Use   ( UseDeriving (..),     UseGQLType (..),-    UseValue (..),+    UseGQLValue (..),   ) import Data.Morpheus.Server.Types.Kind   ( CUSTOM,+    DIRECTIVE,     DerivingKind,     SCALAR,     TYPE,@@ -85,50 +84,76 @@     VALID,     ValidValue,     Value (..),+    internal,   ) 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+class KindedValue ctx (k :: DerivingKind) (a :: Type) where+  encodeKindedValue :: (UseDeriving gql args ~ ctx) => ctx -> Kinded k a -> GQLResult (Value CONST)+  decodeKindedValue :: (UseDeriving gql args ~ ctx) => ctx -> Proxy k -> 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 (EncodeScalar a, DecodeScalar a, ctx ~ UseDeriving gql args, gql a) => KindedValue ctx SCALAR a where+  encodeKindedValue _ = pure . Scalar . encodeScalar . unkind+  decodeKindedValue ctx _ = coerceScalar (useTypename ctx (InputType :: CatType IN a)) >=> handleEither . 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)+instance (ctx ~ UseDeriving gql args, DecodeWrapperConstraint f a, DecodeWrapper f, EncodeWrapperValue f, args a) => KindedValue ctx WRAPPER (f a) where+  encodeKindedValue ctx = encodeWrapperValue (useEncodeValue ctx) . unkind+  decodeKindedValue ctx _ value =+    runExceptT (decodeWrapper (useDecodeValue ctx) 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+instance (ctx ~ UseDeriving gql args, gql a, Generic a, DecodeRep ctx (Rep a), GRep gql args (GQLResult (Value CONST)) (Rep a)) => KindedValue ctx TYPE a where+  encodeKindedValue ctx =+    repToValue       . deriveValue-        ( RepContext-            { optApply = useEncodeValue dirArgs . runIdentity,-              optTypeData = useTypeData dirGQL . inputType+        ( GRepFun+            { grepFun = useEncodeValue ctx . runIdentity,+              grepTypename = useTypename ctx . inputType,+              grepWrappers = useWrappers ctx . inputType             } ::-            RepContext gql args Identity (GQLResult (Value CONST))+            GRepFun gql args Identity (GQLResult (Value CONST))         )-      . unContextValue-  decodeKindedValue dir _ = fmap to . (`runReaderT` context) . decodeRep dir+      . unkind+  decodeKindedValue ctx _ = fmap to . (`runReaderT` context) . decodeRep ctx     where       context =         Context           { isVariantRef = False,-            typeName = useTypename (dirGQL dir) (InputType :: CatType IN a),-            enumVisitor = visitEnumName dir proxy,-            fieldVisitor = visitFieldName dir proxy+            typeName = useTypename ctx (InputType :: CatType IN a),+            enumVisitor = visitEnumName ctx proxy,+            fieldVisitor = visitFieldName ctx proxy           }         where           proxy = Proxy @a -instance KindedValue gql args CUSTOM (Value CONST) where-  encodeKindedValue _ = pure . unContextValue+instance (ctx ~ UseDeriving gql args, gql a, Generic a, DecodeRep ctx (Rep a), GRep gql args (GQLResult (Value CONST)) (Rep a)) => KindedValue ctx DIRECTIVE a where+  encodeKindedValue ctx =+    repToValue+      . deriveValue+        ( GRepFun+            { grepFun = useEncodeValue ctx . runIdentity,+              grepTypename = useTypename ctx . inputType,+              grepWrappers = useWrappers ctx . inputType+            } ::+            GRepFun gql args Identity (GQLResult (Value CONST))+        )+      . unkind+  decodeKindedValue ctx _ = fmap to . (`runReaderT` context) . decodeRep ctx+    where+      context =+        Context+          { isVariantRef = False,+            typeName = useTypename ctx (InputType :: CatType IN a),+            enumVisitor = visitEnumName ctx proxy,+            fieldVisitor = visitFieldName ctx proxy+          }+        where+          proxy = Proxy @a++instance KindedValue ctx CUSTOM (Value CONST) where+  encodeKindedValue _ = pure . unkind   decodeKindedValue _ _ = pure . toConstValue  toConstValue :: ValidValue -> Value CONST@@ -141,14 +166,24 @@     toEntry :: ObjectEntry VALID -> ObjectEntry CONST     toEntry ObjectEntry {..} = ObjectEntry {entryValue = toConstValue entryValue, ..} -instance (KnownSymbol name, args a) => KindedValue gql args CUSTOM (Arg name a) where+instance (ctx ~ UseDeriving gql args, KnownSymbol name, args a) => KindedValue ctx CUSTOM (Arg name a) where   encodeKindedValue _ _ = throwError "directives cant be tagged arguments"-  decodeKindedValue UseDeriving {dirArgs} _ value = Arg <$> withInputObject fieldDecoder value+  decodeKindedValue ctx _ value = Arg <$> (coerceInputObject value >>= fieldDecoder)     where-      fieldDecoder = decodeFieldWith (useDecodeValue dirArgs) fieldName+      fieldDecoder = useDecodeValue ctx . getField 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+instance (ctx ~ UseDeriving gql args, Ord k, args [(k, v)]) => KindedValue ctx CUSTOM (Map k v) where+  decodeKindedValue ctx _ v = unsafeFromList <$> (useDecodeValue ctx v :: ResolverState [(k, v)])+  encodeKindedValue ctx = useEncodeValue ctx . toAssoc . unkind++--+repToValue :: GRepValue (GQLResult (Value CONST)) -> GQLResult (Value CONST)+repToValue GRepValueEnum {..} = pure $ Enum enumVariantName+repToValue GRepValueObject {..} = Object <$> (traverse fromField objectFields >>= fromElems)+  where+    fromField GRepField {fieldSelector, fieldValue} = do+      entryValue <- fieldValue+      pure ObjectEntry {entryName = fieldSelector, entryValue}+repToValue _ = throwError (internal "input unions are not supported")
src/Data/Morpheus/Server/Deriving/Resolvers.hs view
@@ -7,7 +7,6 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE NoImplicitPrelude #-} @@ -26,8 +25,14 @@     ResolverValue,     RootResolverValue (..),   )+import Data.Morpheus.Generic (CBox, runCBox)+import Data.Morpheus.Generic.GScan+  ( ScanRef,+    scan,+    useProxies,+  ) import Data.Morpheus.Internal.Ext (GQLResult)-import Data.Morpheus.Server.Deriving.Internal.Resolve.Explore+import Data.Morpheus.Server.Deriving.Internal.Resolver   ( EXPLORE,     useObjectResolvers,   )@@ -39,14 +44,7 @@   ( 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.Kinded (Kinded (..)) import Data.Morpheus.Server.Deriving.Utils.Use (UseNamedResolver (..)) import Data.Morpheus.Server.Resolvers   ( NamedResolverT (..),@@ -70,21 +68,20 @@ class GQLNamedResolverFun (m :: Type -> Type) a where   deriveNamedResFun :: a -> m (ResolverValue m) -class GQLType a => GQLNamedResolver (m :: Type -> Type) a where+type NAMED = UseNamedResolver GQLNamedResolver GQLNamedResolverFun GQLType GQLValue++class (GQLType a) => GQLNamedResolver (m :: Type -> Type) a where   deriveNamedRes :: f a -> [NamedResolver m]-  deriveNamedRefs :: f a -> [ScanRef (GQLNamedResolver m)]+  deriveNamedRefs :: f a -> [ScanRef Proxy (GQLNamedResolver m)] -instance-  (GQLType a, KindedNamedResolver GQLNamedResolver GQLNamedResolverFun GQLType GQLValue m (KIND a) a) =>-  GQLNamedResolver m a-  where+instance (GQLType a, KindedNamedResolver NAMED (KIND a) m 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)+instance (KindedNamedFunValue NAMED (KIND a) m a) => GQLNamedResolverFun m a where+  deriveNamedResFun resolver = kindedNamedFunValue withNamed (Kinded resolver :: Kinded (KIND a) a) -withNamed :: UseNamedResolver GQLNamedResolver GQLNamedResolverFun GQLType GQLValue+withNamed :: NAMED withNamed =   UseNamedResolver     { namedDrv = withDir,@@ -93,9 +90,6 @@       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 =@@ -107,14 +101,7 @@  type DERIVE_NAMED_RESOLVERS m query =   ( GQLType (query (NamedResolverT m)),-    KindedNamedResolver-      GQLNamedResolver-      GQLNamedResolverFun-      GQLType-      GQLValue-      m-      (KIND (query (NamedResolverT m)))-      (query (NamedResolverT m))+    KindedNamedResolver NAMED (KIND (query (NamedResolverT m))) m (query (NamedResolverT m))   )  deriveResolvers ::@@ -132,14 +119,18 @@             $> resolverChannels withDir subscriptionResolver       } +runProxy :: CBox Proxy (GQLNamedResolver m) -> [NamedResolver m]+runProxy = runCBox deriveNamedRes++queryProxy :: NamedResolvers m e query mut sub -> Proxy (query (NamedResolverT (Resolver QUERY e m)))+queryProxy _ = Proxy+ 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)))))+deriveNamedResolvers =+  NamedResolversValue+    . useProxies runProxy resolverName+    . scan deriveNamedRefs+    . queryProxy
src/Data/Morpheus/Server/Deriving/Schema.hs view
@@ -4,12 +4,13 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.Server.Deriving.Schema@@ -19,13 +20,20 @@   ) where +import Control.Monad.Except (MonadError (..))+import Data.Map (alter, findWithDefault, insert) import Data.Morpheus.Core (defaultConfig, validateSchema)+import Data.Morpheus.Generic (CBox, runCBox) import Data.Morpheus.Internal.Ext (GQLResult)-import Data.Morpheus.Server.Deriving.Internal.Schema.Internal-  ( fromSchema,+import Data.Morpheus.Internal.Utils (IsMap (..), toAssoc)+import Data.Morpheus.Server.Deriving.Utils.GScan+  ( FreeCatType (..),+    scanFree,   )-import Data.Morpheus.Server.Deriving.Internal.Schema.Type-  ( useDeriveObject,+import Data.Morpheus.Server.Deriving.Utils.Kinded (outputType)+import Data.Morpheus.Server.Deriving.Utils.Types (CatType (OutputType), GQLTypeNode (..), GQLTypeNodeExtension (..), NodeTypeVariant (..), coerceObject, fromSchema, nodeToType)+import Data.Morpheus.Server.Deriving.Utils.Use+  ( UseGQLType (useDeriveNode, useExploreRef, useFingerprint),   ) import Data.Morpheus.Server.Types.GQLType   ( GQLType (..),@@ -33,28 +41,130 @@     ignoreUndefined,     withGQL,   )-import Data.Morpheus.Server.Types.SchemaT-  ( toSchema,-  )+import Data.Morpheus.Server.Types.TypeName (TypeFingerprint (..)) import Data.Morpheus.Types.Internal.AST-  ( CONST,-    Schema (..),+  ( ANY,+    CONST,+    DirectiveDefinition,+    OBJECT,+    OUT,+    Schema,+    TypeCategory (..),+    TypeContent (..),+    TypeDefinition (..),+    TypeName,+    defineDirective,+    defineSchemaWith,+    mkEnumContent,+    mkType,+    msg,+    toAny,+    unitTypeName,   ) import Language.Haskell.TH (Exp, Q)-import Relude+import Relude hiding (empty) -type SCHEMA qu mu su = (GQLType (qu IgnoredResolver), GQLType (mu IgnoredResolver), GQLType (su IgnoredResolver))+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 :: (SCHEMA qu mu su) => proxy (root m event qu mu su) -> Q Exp compileTimeSchemaValidation = fromSchema . (deriveSchema >=> validateSchema True defaultConfig) -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)))-    )+explore :: forall f (a :: (Type -> Type) -> Type). (GQLType (a IgnoredResolver)) => f a -> [CBox FreeCatType GQLType]+explore _ = scanFree (useExploreRef withGQL) (OutputType :: CatType OUT (a IgnoredResolver))++toDerivation :: TypeFingerprint -> GQLTypeNode c -> (TypeFingerprint, GQLTypeNode ANY)+toDerivation fp (GQLTypeNode node xs) = (fp, GQLTypeNode (toAny node) xs)+toDerivation fp (GQLDirectiveNode node) = (fp, GQLDirectiveNode node)++resolveNode :: (GQLType a) => FreeCatType a -> GQLResult (TypeFingerprint, GQLTypeNode ANY)+resolveNode (FreeCatType proxy) = toDerivation (useFingerprint withGQL proxy) <$> useDeriveNode withGQL proxy++deriveRoot :: (GQLType a) => f a -> GQLResult (TypeDefinition OBJECT CONST)+deriveRoot prx = useDeriveNode withGQL (outputType prx) >>= nodeToType >>= coerceObject++data SchemaState where+  SchemaState ::+    { typeDefinitions :: Map TypeFingerprint (TypeDefinition ANY CONST),+      implements :: Map TypeName [TypeName],+      directiveDefinitions :: Map TypeFingerprint (DirectiveDefinition CONST)+    } ->+    SchemaState++instance Semigroup SchemaState where+  SchemaState t1 i1 d1 <> SchemaState t2 i2 d2 = SchemaState (t1 <> t2) (i1 <> i2) (d1 <> d2)++instance Monoid SchemaState where+  mempty = SchemaState mempty mempty mempty++insertImplements :: Map TypeName [TypeName] -> TypeDefinition c CONST -> TypeDefinition c CONST+insertImplements implementsMap TypeDefinition {typeContent = DataObject {..}, ..} = TypeDefinition {..}+  where+    typeContent = DataObject {objectImplements = objectImplements <> implements, ..}+    implements = findWithDefault [] typeName implementsMap+insertImplements _ t = t++checkTypeCollisions :: [(TypeFingerprint, TypeDefinition k a)] -> GQLResult [TypeDefinition k a]+checkTypeCollisions = fmap toList . foldlM collectTypes mempty+  where+    collectTypes :: Map (TypeName, TypeFingerprint) (TypeDefinition k a) -> (TypeFingerprint, TypeDefinition k a) -> GQLResult (Map (TypeName, TypeFingerprint) (TypeDefinition k a))+    collectTypes accum (fp, typ) = maybe addType (handleCollision typ) (key `lookup` accum)+      where+        addType = pure $ insert key typ accum+        key = (typeName typ, withSameCategory fp)+        handleCollision t1@TypeDefinition {typeContent = DataEnum {}} t2 | t1 == t2 = pure accum+        handleCollision TypeDefinition {typeContent = DataScalar {}} TypeDefinition {typeContent = DataScalar {}} = pure accum+        handleCollision TypeDefinition {typeName = name1} _ = failureRequirePrefix name1++failureRequirePrefix :: TypeName -> GQLResult b+failureRequirePrefix typename =+  throwError $+    "It appears that the Haskell type "+      <> msg typename+      <> " was used as both input and output type, which is not allowed by GraphQL specifications."+      <> "\n\n "+      <> "If you use \"InputTypeNamespace\" directive, "+      <> "you can override the default type names for "+      <> msg typename+      <> " to solve this problem."++withSameCategory :: TypeFingerprint -> TypeFingerprint+withSameCategory (TypeableFingerprint _ xs) = TypeableFingerprint OUT xs+withSameCategory x = x++execNode :: (TypeFingerprint, GQLTypeNode ANY) -> SchemaState -> SchemaState+execNode (InternalFingerprint {}, _) s = s+execNode (fp, GQLTypeNode t xs) s = foldr execExtension (s {typeDefinitions = insert fp t (typeDefinitions s)}) xs+execNode (fp, GQLDirectiveNode d) s = s {directiveDefinitions = insert fp d (directiveDefinitions s)}++execExtension :: GQLTypeNodeExtension -> SchemaState -> SchemaState+execExtension (ImplementsExtension interface types) s = s {implements = foldr insertInterface (implements s) types}+  where+    insertInterface = alter (Just . (interface :) . fromMaybe [])+execExtension (UnionVariantsExtension nodes) s = foldr execNodeTypeVariant s nodes++execNodeTypeVariant :: NodeTypeVariant -> SchemaState -> SchemaState+execNodeTypeVariant (NodeTypeVariant consName fields) s = s {typeDefinitions = insert fp t (typeDefinitions s)}+  where+    fp = CustomFingerprint consName+    t = mkType consName fields+execNodeTypeVariant NodeUnitType s = s {typeDefinitions = insert fp t (typeDefinitions s)}+  where+    fp = CustomFingerprint unitTypeName+    t = mkType unitTypeName (mkEnumContent [unitTypeName])++deriveSchema :: forall root f m e qu mu su. (SCHEMA qu mu su) => f (root m e qu mu su) -> GQLResult (Schema CONST)+deriveSchema _ = do+  query <- deriveRoot (Proxy @(qu IgnoredResolver))+  mutation <- traverse deriveRoot (ignoreUndefined (Proxy @(mu IgnoredResolver)))+  subscription <- traverse deriveRoot (ignoreUndefined (Proxy @(su IgnoredResolver)))+  typeNodes <- traverse (runCBox resolveNode) (explore (Proxy @qu) <> explore (Proxy @mu) <> explore (Proxy @su))+  let SchemaState {..} = foldr execNode mempty typeNodes+  types <- map (insertImplements implements) <$> checkTypeCollisions (toAssoc typeDefinitions)+  schema <- defineSchemaWith types (Just query, mutation, subscription)+  foldlM defineDirective schema directiveDefinitions
− src/Data/Morpheus/Server/Deriving/Utils/AST.hs 
@@ -1,19 +0,0 @@-{-# 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/GRep.hs 
@@ -1,198 +0,0 @@-{-# 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
@@ -7,67 +7,43 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.Server.Deriving.Utils.GScan-  ( Scanner (..),-    ScanRef (..),-    scan,+  ( scanFree,+    FreeCatType (..),+    freeLeaf,+    freeNode,+    ScanRef,   ) 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.Generic+  ( CBox,+    Gmap,+    ProxyMap (..),+    ScanRef (..),+    scan,   )-import Data.Morpheus.Server.Types.TypeName (TypeFingerprint)+import Data.Morpheus.Server.Deriving.Utils.Kinded (mapCat)+import Data.Morpheus.Server.Deriving.Utils.Types (CatType (..))+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+import Relude hiding (fromList) -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+instance ProxyMap FreeCatType where+  proxyMap prx (FreeCatType cat) = FreeCatType (mapCat prx cat) -runRef :: Scanner c v -> ScanRef c -> [v]-runRef Scanner {..} (ScanObject _ t) = scannerFun t-runRef Scanner {..} (ScanType _ t) = scannerFun t+data FreeCatType a where+  FreeCatType :: forall c a. CatType c a -> FreeCatType a -mapContext :: Scanner c v -> GmapContext c [ScanRef c]-mapContext (Scanner _ f) = GmapContext f+freeLeaf :: (c1 a) => TypeFingerprint -> CatType c2 a -> ScanRef FreeCatType c1+freeLeaf fp p = ScanLeaf (show fp) (FreeCatType p) -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+freeNode :: (c a, Gmap c (Rep a)) => Bool -> TypeFingerprint -> CatType c2 a -> ScanRef FreeCatType c+freeNode visible fp p = ScanNode visible (show fp) (FreeCatType p) -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]-  }+scanFree :: (c a) => (forall k' a'. (c a') => CatType k' a' -> [ScanRef FreeCatType c]) -> CatType k a -> [CBox FreeCatType c]+scanFree f = scan (\(FreeCatType x) -> f x) . FreeCatType
− src/Data/Morpheus/Server/Deriving/Utils/Gmap.hs 
@@ -1,65 +0,0 @@-{-# 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
@@ -8,46 +8,32 @@ {-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.Server.Deriving.Utils.Kinded-  ( KindedProxy (..),-    setType,-    CatType (..),+  ( CatType (..),     inputType,     outputType,-    CatContext (..),     unliftKind,-    catMap,-    addContext,-    getCatContext,+    mapCat,     mkScalar,     isIN,-    ForAll (..),-    unForAll,+    Kinded (..),+    mkEnum,+    mkObject,   ) where +import Data.Morpheus.Server.Types.Kind (DerivingKind) import Data.Morpheus.Types.Internal.AST-  ( IN,+  ( DataEnumValue,+    FieldDefinition,+    IN,     OUT,     ScalarDefinition,     TRUE,     TypeCategory (..),     TypeContent (..),+    unsafeFromFields,   )-import Data.Proxy (Proxy (..))-import Prelude (Bool (..), Show)---- | context , like Proxy with multiple parameters--- * 'kind': object, scalar, enum ...--- * 'a': actual gql type-data KindedProxy k a-  = KindedProxy--setType :: f a -> kinded (k :: t) a' -> KindedProxy k a-setType _ _ = KindedProxy--data CatContext (cat :: TypeCategory) where-  InputContext :: CatContext IN-  OutputContext :: CatContext OUT+import Prelude  data CatType (cat :: TypeCategory) a where   InputType :: CatType IN a@@ -65,27 +51,24 @@ unliftKind InputType = InputType unliftKind OutputType = OutputType -catMap :: f a -> CatType cat b -> CatType cat a-catMap _ InputType = InputType-catMap _ OutputType = OutputType--addContext :: CatContext c -> f a -> CatType c a-addContext InputContext _ = InputType-addContext OutputContext _ = OutputType--getCatContext :: CatType c a -> CatContext c-getCatContext InputType = InputContext-getCatContext OutputType = OutputContext+mapCat :: f a -> CatType cat b -> CatType cat a+mapCat _ InputType = InputType+mapCat _ OutputType = OutputType  mkScalar :: CatType c a -> ScalarDefinition -> TypeContent TRUE c s mkScalar InputType f = DataScalar f mkScalar OutputType f = DataScalar f +mkEnum :: CatType c a -> [DataEnumValue s] -> TypeContent TRUE c s+mkEnum InputType x = DataEnum x+mkEnum OutputType x = DataEnum x++mkObject :: CatType kind a -> [FieldDefinition kind s] -> TypeContent TRUE kind s+mkObject InputType = DataInputObject . unsafeFromFields+mkObject OutputType = DataObject [] . unsafeFromFields+ isIN :: CatType c a -> Bool isIN InputType = True isIN _ = False -newtype ForAll a = ForAll a--unForAll :: f (ForAll a) -> Proxy a-unForAll _ = Proxy+newtype Kinded (kind :: DerivingKind) a = Kinded {unkind :: a}
− src/Data/Morpheus/Server/Deriving/Utils/Proxy.hs 
@@ -1,65 +0,0 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE NoImplicitPrelude #-}--module Data.Morpheus.Server.Deriving.Utils.Proxy-  ( conNameProxy,-    isRecordProxy,-    selNameProxy,-    symbolName,-    ContextValue (..),-  )-where--import Data.Morpheus.Server.Types.Kind (DerivingKind)-import Data.Morpheus.Types.Internal.AST-  ( FieldName,-    TypeName,-    packName,-  )-import qualified Data.Text as T-import GHC.Generics-  ( C,-    Constructor,-    M1 (..),-    Meta,-    S,-    Selector,-    U1 (..),-    conIsRecord,-    conName,-    selName,-  )-import GHC.TypeLits-import Relude hiding (undefined)-import Prelude (undefined)--conNameProxy :: forall f (c :: Meta). Constructor c => f c -> TypeName-conNameProxy _ = fromString $ conName (undefined :: M1 C c U1 a)--selNameProxy :: forall f (s :: Meta). Selector s => f s -> FieldName-selNameProxy _ = fromHaskellName $ selName (undefined :: M1 S s f a)--fromHaskellName :: String -> FieldName-fromHaskellName hsName-  | not (null hsName) && (T.last name == '\'') = packName (T.init name)-  | otherwise = packName name-  where-    name = T.pack hsName-{-# INLINE fromHaskellName #-}--isRecordProxy :: forall f (c :: Meta). Constructor c => f c -> Bool-isRecordProxy _ = conIsRecord (undefined :: (M1 C c f a))--symbolName :: KnownSymbol a => f a -> FieldName-symbolName = fromString . symbolVal--newtype ContextValue (kind :: DerivingKind) a = ContextValue-  { unContextValue :: a-  }
+ src/Data/Morpheus/Server/Deriving/Utils/Types.hs view
@@ -0,0 +1,153 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskellQuotes #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.Server.Deriving.Utils.Types+  ( argumentsToObject,+    nodeToType,+    GQLTypeNode (..),+    DerivingMonad,+    fromSchema,+    withObject,+    typeToArguments,+    CatType (..),+    NodeTypeVariant (..),+    GQLTypeNodeExtension (..),+    coerceInputObject,+    coerceScalar,+    getField,+    handleEither,+    coerceArguments,+    coerceObject,+    toFieldContent,+  )+where++import Control.Monad.Except (MonadError (..), throwError)+import Data.Morpheus.Internal.Ext+  ( GQLResult,+    Result (Failure, Success, errors),+  )+import Data.Morpheus.Internal.Utils (selectOr)+import Data.Morpheus.Server.Deriving.Utils.Kinded+  ( CatType (..),+  )+import Data.Morpheus.Types.GQLScalar+import Data.Morpheus.Types.Internal.AST+  ( ANY,+    Argument (..),+    Arguments,+    ArgumentsDefinition,+    CONST,+    DirectiveDefinition (..),+    FieldContent (..),+    FieldName,+    FieldsDefinition,+    GQLError,+    IN,+    Msg (..),+    OBJECT,+    OUT,+    ObjectEntry (..),+    Position (..),+    ScalarValue,+    Schema (..),+    TRUE,+    TypeContent (..),+    TypeDefinition (..),+    TypeName,+    VALID,+    ValidObject,+    ValidValue,+    Value (..),+    fieldsToArguments,+    internal,+  )+import Language.Haskell.TH (Exp, Q)+import Relude hiding (empty)++type DerivingMonad m = (MonadError GQLError m)++fromSchema :: GQLResult (Schema VALID) -> Q Exp+fromSchema Success {} = [|()|]+fromSchema Failure {errors} = fail (show errors)++withObject :: (DerivingMonad m) => TypeName -> TypeContent TRUE any s -> m (FieldsDefinition OUT s)+withObject _ DataObject {objectFields} = pure objectFields+withObject name _ = failureOnlyObject name++failureOnlyObject :: (DerivingMonad m) => TypeName -> m b+failureOnlyObject name = throwError $ msg name <> " should have only one nonempty constructor"++getField :: FieldName -> ValidObject -> ValidValue+getField = selectOr Null entryValue++handleEither :: (MonadError GQLError m, Msg t) => Either t a -> m a+handleEither = either (throwError . msg) pure++typeToArguments :: (DerivingMonad m) => TypeDefinition IN CONST -> m (ArgumentsDefinition CONST)+typeToArguments TypeDefinition {typeContent = DataInputObject {inputObjectFields}} = pure $ fieldsToArguments inputObjectFields+typeToArguments TypeDefinition {typeName} = failureOnlyObject typeName++toFieldContent :: CatType c a -> ArgumentsDefinition CONST -> Maybe (FieldContent TRUE c CONST)+toFieldContent OutputType x | not (null x) = Just (FieldArgs x)+toFieldContent _ _ = Nothing++-- 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++coerceInputObject :: (MonadError GQLError m) => ValidValue -> m ValidObject+coerceInputObject (Object object) = pure object+coerceInputObject isType = throwError (typeMismatch "InputObject" isType)++coerceScalar :: (MonadError GQLError m) => TypeName -> Value VALID -> m ScalarValue+coerceScalar typename value = case toScalar value of+  Right scalar -> pure scalar+  Left message ->+    throwError+      ( typeMismatch+          ("SCALAR(" <> msg typename <> ")" <> msg message)+          value+      )++coerceArguments :: (MonadError GQLError m) => Value s -> m (Arguments s)+coerceArguments (Object v) = pure $ fmap (\ObjectEntry {..} -> Argument (Position 0 0) entryName entryValue) v+coerceArguments _ = throwError $ internal "could not encode arguments. Arguments should be an object like type!"++argumentsToObject :: Arguments VALID -> Value VALID+argumentsToObject = Object . fmap toEntry+  where+    toEntry Argument {..} = ObjectEntry argumentName argumentValue++data GQLTypeNodeExtension+  = ImplementsExtension TypeName [TypeName]+  | UnionVariantsExtension [NodeTypeVariant]++data GQLTypeNode c+  = GQLTypeNode (TypeDefinition c CONST) [GQLTypeNodeExtension]+  | GQLDirectiveNode (DirectiveDefinition CONST)++nodeToType :: (DerivingMonad m) => GQLTypeNode c -> m (TypeDefinition c CONST)+nodeToType node = case node of+  GQLTypeNode x _ -> pure x+  GQLDirectiveNode dir -> throwError $ "expected " <> msg (directiveDefinitionName dir) <> " to be a type but its directive!"++coerceObject :: (DerivingMonad m) => TypeDefinition c CONST -> m (TypeDefinition OBJECT CONST)+coerceObject TypeDefinition {..} = do+  x <- withObject typeName typeContent+  pure (TypeDefinition {typeContent = DataObject [] x, ..})++data NodeTypeVariant+  = NodeTypeVariant TypeName (TypeContent TRUE ANY CONST)+  | NodeUnitType
src/Data/Morpheus/Server/Deriving/Utils/Use.hs view
@@ -1,68 +1,140 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GADTs #-}-{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}  module Data.Morpheus.Server.Deriving.Utils.Use   ( UseDeriving (..),-    UseGQLType (..),-    UseValue (..),+    GQLTypeCTX (..),+    UseGQLValue (..),     UseResolver (..),     UseNamedResolver (..),+    UseRef (..),+    UseGQLType (..),+    GQLValueCTX (..),+    useDecodeArguments,   ) where  import Data.Morpheus.App.Internal.Resolving (NamedResolver (..), ResolverState, ResolverValue)+import Data.Morpheus.Generic (ScanRef) 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.Deriving.Utils.GScan (FreeCatType)+import Data.Morpheus.Server.Deriving.Utils.Types import Data.Morpheus.Server.Types.Directives   ( GDirectiveUsages (..),   ) import Data.Morpheus.Server.Types.Internal-import Data.Morpheus.Server.Types.SchemaT-  ( SchemaT,-  ) import Data.Morpheus.Server.Types.TypeName   ( TypeFingerprint,   ) import Data.Morpheus.Types.Internal.AST-  ( ArgumentsDefinition,+  ( Arguments,+    ArgumentsDefinition,     CONST,-    TypeDefinition (..),     TypeName,+    TypeWrapper,+    VALID,     ValidValue,     Value,   )+import Relude -data UseGQLType gql = UseGQLType-  { 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 UseRef (c :: Type -> Constraint) where+  UseRef :: (c a) => CatType t a -> UseRef c++class UseGQLType ctx con | ctx -> con where+  useFingerprint :: (con a) => ctx -> CatType c a -> TypeFingerprint+  useTypename :: (con a) => ctx -> CatType c a -> TypeName+  useWrappers :: (con a) => ctx -> CatType c a -> TypeWrapper+  useDeriveNode :: (con a) => ctx -> CatType c a -> GQLResult (GQLTypeNode c)+  useDeriveFieldArgs :: (con a) => ctx -> CatType c a -> GQLResult (ArgumentsDefinition CONST)+  useExploreRef :: (con a) => ctx -> CatType c a -> [ScanRef FreeCatType con]++data GQLTypeCTX gql = GQLTypeCTX+  { __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,+    __useDeriveNode :: forall c a. (gql a) => CatType c a -> GQLResult (GQLTypeNode c),+    __useDeriveFieldArgs :: forall c a. (gql a) => CatType c a -> GQLResult (ArgumentsDefinition CONST),+    __useExploreRef :: forall c a. (gql a) => CatType c a -> [ScanRef FreeCatType gql]   } -data UseValue val = UseValue-  { useEncodeValue :: forall a. val a => a -> GQLResult (Value CONST),-    useDecodeValue :: forall a. val a => ValidValue -> ResolverState a+instance UseGQLType (GQLTypeCTX gql) gql where+  useFingerprint GQLTypeCTX {__useFingerprint} = __useFingerprint+  useTypename GQLTypeCTX {__useTypename} = __useTypename+  useWrappers GQLTypeCTX {__useTypeData} = gqlWrappers . __useTypeData+  useDeriveNode GQLTypeCTX {__useDeriveNode} = __useDeriveNode+  useDeriveFieldArgs GQLTypeCTX {__useDeriveFieldArgs} = __useDeriveFieldArgs+  useExploreRef GQLTypeCTX {__useExploreRef} = __useExploreRef++data GQLValueCTX val = GQLValueCTX+  { __useEncodeValue :: forall a. (val a) => a -> GQLResult (Value CONST),+    __useDecodeValue :: forall a. (val a) => ValidValue -> ResolverState a   } +class UseGQLValue ctx con | ctx -> con where+  useEncodeValue :: (con a) => ctx -> a -> GQLResult (Value CONST)+  useDecodeValue :: (con a) => ctx -> ValidValue -> ResolverState a++instance UseGQLValue (GQLValueCTX val) val where+  useEncodeValue GQLValueCTX {__useEncodeValue} = __useEncodeValue+  useDecodeValue GQLValueCTX {__useDecodeValue} = __useDecodeValue++data UseDeriving gql val = UseDeriving+  { useDirectives :: forall f a. (gql a) => f a -> GDirectiveUsages gql val,+    __useValue :: GQLValueCTX val,+    __useGQL :: GQLTypeCTX gql+  }++instance UseGQLType (UseDeriving gql val) gql where+  useFingerprint = useFingerprint . __useGQL+  useTypename = useTypename . __useGQL+  useWrappers = useWrappers . __useGQL+  useDeriveNode = useDeriveNode . __useGQL+  useDeriveFieldArgs = useDeriveFieldArgs . __useGQL+  useExploreRef = useExploreRef . __useGQL++instance UseGQLValue (UseDeriving gql val) val where+  useEncodeValue = useEncodeValue . __useValue+  useDecodeValue = useDecodeValue . __useValue+ data UseResolver res gql val = UseResolver-  { useEncodeResolver :: forall a m. res m a => a -> m (ResolverValue m),+  { 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-  }+instance UseGQLType (UseResolver res gql val) gql where+  useFingerprint = useFingerprint . resDrv+  useTypename = useTypename . resDrv+  useWrappers = useWrappers . resDrv+  useDeriveNode = useDeriveNode . resDrv+  useDeriveFieldArgs = useDeriveFieldArgs . resDrv+  useExploreRef = useExploreRef . resDrv +instance UseGQLValue (UseResolver res gql val) val where+  useEncodeValue = useEncodeValue . resDrv+  useDecodeValue = useDecodeValue . resDrv+ 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)],+  { 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 Proxy (named m)],     namedDrv :: UseDeriving gql val   }++instance UseGQLType (UseNamedResolver named res gql val) gql where+  useFingerprint = useFingerprint . namedDrv+  useTypename = useTypename . namedDrv+  useWrappers = useWrappers . namedDrv+  useDeriveNode = useDeriveNode . namedDrv+  useDeriveFieldArgs = useDeriveFieldArgs . namedDrv+  useExploreRef = useExploreRef . namedDrv++useDecodeArguments :: (val a) => UseDeriving gql val -> Arguments VALID -> ResolverState a+useDecodeArguments ctx = useDecodeValue ctx . argumentsToObject
src/Data/Morpheus/Server/Types.hs view
@@ -41,6 +41,7 @@      -- * GQL directives API     Prefixes (..),+    Suffixes (..),     VisitType (..),     VisitField (..),     VisitEnum (..),@@ -59,6 +60,7 @@     TYPE,     CUSTOM,     WRAPPER,+    DIRECTIVE,     RootResolver (..),     defaultRootResolver,     Rename (..),@@ -102,21 +104,23 @@     DropNamespace (..),     Prefixes (..),     Rename (..),+    Suffixes (..),   ) import Data.Morpheus.Server.Types.Directives   ( GQLDirective (..),+  )+import Data.Morpheus.Server.Types.GQLType+  ( GQLType (..),+    InputTypeNamespace (..),     enumDirective,     enumDirective',     fieldDirective,     fieldDirective',     typeDirective,   )-import Data.Morpheus.Server.Types.GQLType-  ( GQLType (..),-    InputTypeNamespace (..),-  ) import Data.Morpheus.Server.Types.Kind   ( CUSTOM,+    DIRECTIVE,     DerivingKind,     SCALAR,     TYPE,
src/Data/Morpheus/Server/Types/DirectiveDefinitions.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-}@@ -9,6 +10,7 @@  module Data.Morpheus.Server.Types.DirectiveDefinitions   ( Prefixes (..),+    Suffixes (..),     Deprecated (..),     Describe (..),     Rename (..),@@ -18,20 +20,21 @@ where  import Data.Morpheus.Server.Types.Directives (GQLDirective (..))-import Data.Morpheus.Server.Types.GQLType (GQLType (__type))+import Data.Morpheus.Server.Types.GQLType (GQLType (..)) import Data.Morpheus.Server.Types.Internal   ( mkTypeData,     stripConstructorNamespace,     stripFieldNamespace,   )+import Data.Morpheus.Server.Types.Kind (DIRECTIVE) import Data.Morpheus.Server.Types.Visitors   ( VisitEnum (..),     VisitField (..),     VisitType (..),   ) import Data.Morpheus.Types.Internal.AST (CONST, DirectiveLocation (..), Value)-import Data.Text (drop, length, pack, unpack)-import Relude hiding (drop, length)+import Data.Text (drop, length, pack, take, unpack)+import Relude hiding (drop, length, take)  -- | a custom GraphQL directive for adding or removing -- of prefixes@@ -39,8 +42,11 @@   { addPrefix :: Text,     removePrefix :: Text   }-  deriving (Generic, GQLType)+  deriving (Generic) +instance GQLType Prefixes where+  type KIND Prefixes = DIRECTIVE+ instance GQLDirective Prefixes where   type     DIRECTIVE_LOCATIONS Prefixes =@@ -51,6 +57,7 @@          'LOCATION_SCALAR,          'LOCATION_INTERFACE        ]+  excludeFromSchema _ = True  instance VisitType Prefixes where   visitTypeName Prefixes {addPrefix, removePrefix} _ name = addPrefix <> drop (length removePrefix) name@@ -61,13 +68,14 @@ newtype Deprecated = Deprecated   { reason :: Maybe Text   }-  deriving-    ( Generic,-      VisitEnum,+  deriving (Generic)+  deriving anyclass+    ( VisitEnum,       VisitField     )  instance GQLType Deprecated where+  type KIND Deprecated = DIRECTIVE   __type = mkTypeData "deprecated"  instance GQLDirective Deprecated where@@ -79,10 +87,12 @@  newtype Describe = Describe {text :: Text}   deriving-    ( GQLType,-      Generic+    ( Generic     ) +instance GQLType Describe where+  type KIND Describe = DIRECTIVE+ instance GQLDirective Describe where   type     DIRECTIVE_LOCATIONS Describe =@@ -111,10 +121,12 @@ -- of prefixes newtype Rename = Rename {newName :: Text}   deriving-    ( Generic,-      GQLType+    ( Generic     ) +instance GQLType Rename where+  type KIND Rename = DIRECTIVE+ instance GQLDirective Rename where   excludeFromSchema _ = True   type@@ -145,10 +157,12 @@   { dropNamespace :: Text   }   deriving-    ( Generic,-      GQLType+    ( Generic     ) +instance GQLType DropNamespace where+  type KIND DropNamespace = DIRECTIVE+ instance GQLDirective DropNamespace where   type     DIRECTIVE_LOCATIONS DropNamespace =@@ -168,14 +182,42 @@ newtype DefaultValue = DefaultValue   { defaultValue :: Value CONST   }-  deriving-    ( Generic,-      GQLType-    )+  deriving (Generic) +instance GQLType DefaultValue where+  type KIND DefaultValue = DIRECTIVE+ instance GQLDirective DefaultValue where   type DIRECTIVE_LOCATIONS DefaultValue = '[ 'LOCATION_INPUT_FIELD_DEFINITION]   excludeFromSchema _ = True  instance VisitField DefaultValue where   visitFieldDefaultValue DefaultValue {defaultValue} _ = Just defaultValue++-- | a custom GraphQL directive for adding or removing+-- of suffixes+data Suffixes = Suffixes+  { addSuffix :: Text,+    removeSuffix :: Text+  }+  deriving (Generic)++instance GQLType Suffixes where+  type KIND Suffixes = DIRECTIVE++instance GQLDirective Suffixes where+  type+    DIRECTIVE_LOCATIONS Suffixes =+      '[ 'LOCATION_OBJECT,+         'LOCATION_ENUM,+         'LOCATION_INPUT_OBJECT,+         'LOCATION_UNION,+         'LOCATION_SCALAR,+         'LOCATION_INTERFACE+       ]+  excludeFromSchema _ = True++instance VisitType Suffixes where+  visitTypeName Suffixes {addSuffix, removeSuffix} _ name =+    take (length name - length removeSuffix) name <> addSuffix+  visitTypeDescription _ = id
src/Data/Morpheus/Server/Types/Directives.hs view
@@ -5,6 +5,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-}@@ -27,16 +28,15 @@     applyFieldDefaultValue,     applyTypeFieldNames,     applyTypeEnumNames,-    typeDirective,-    fieldDirective,-    fieldDirective',-    enumDirective,-    enumDirective',+    allUsages,   ) where +{- ORMOLU_DISABLE -} import qualified Data.HashMap.Strict as M import qualified Data.Morpheus.Server.Types.Visitors as Visitors+{- ORMOLU_ENABLE -}+ import Data.Morpheus.Types.Internal.AST   ( CONST,     Description,@@ -49,7 +49,6 @@     packName,     unpackName,   )-import qualified Language.Haskell.TH as TH import Relude  type family OR (a :: Bool) (b :: Bool) where@@ -255,6 +254,12 @@     enumValueDirectives :: M.HashMap TypeName [GDirectiveUsage gql args]   } +allUsages :: GDirectiveUsages gql args -> [GDirectiveUsage gql args]+allUsages GDirectiveUsages {..} =+  join (toList enumValueDirectives)+    <> join (toList fieldDirectives)+    <> typeDirectives+ instance Monoid (GDirectiveUsages gql args) where   mempty = GDirectiveUsages mempty mempty mempty @@ -270,18 +275,3 @@  upsert :: (Eq k, Hashable k, Semigroup v) => (k, v) -> HashMap k v -> HashMap k v upsert (k, v) = M.alter (Just . maybe v (v <>)) k--typeDirective :: (GQLDirective a, gql a, args a) => a -> GDirectiveUsages gql args-typeDirective x = GDirectiveUsages [GDirectiveUsage x] mempty mempty--fieldDirective :: (GQLDirective a, gql a, args a) => FieldName -> a -> GDirectiveUsages gql args-fieldDirective name x = GDirectiveUsages mempty (M.singleton name [GDirectiveUsage x]) mempty--fieldDirective' :: (GQLDirective a, gql a, args a) => TH.Name -> a -> GDirectiveUsages gql args-fieldDirective' name = fieldDirective (packName name)--enumDirective :: (GQLDirective a, gql a, args a) => TypeName -> a -> GDirectiveUsages gql args-enumDirective name x = GDirectiveUsages mempty mempty (M.singleton name [GDirectiveUsage x])--enumDirective' :: (GQLDirective a, gql a, args a) => TH.Name -> a -> GDirectiveUsages gql args-enumDirective' name = enumDirective (packName name)
src/Data/Morpheus/Server/Types/GQLType.hs view
@@ -1,7 +1,6 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-}@@ -13,11 +12,12 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.Server.Types.GQLType-  ( GQLType (KIND, directives, __type),+  ( GQLType (..),     GQLValue (..),     InputTypeNamespace (..),     GQLResolver (..),@@ -28,23 +28,38 @@     withRes,     kindedProxy,     IgnoredResolver,+    enumDirective,+    enumDirective',+    fieldDirective,+    fieldDirective',+    typeDirective,   ) where  -- MORPHEUS +{- ORMOLU_DISABLE -}+import qualified Data.HashMap.Strict as M+import qualified Language.Haskell.TH as TH+{- ORMOLU_ENABLE -}+ import Control.Monad.Except (MonadError (throwError)) import Data.Morpheus.App.Internal.Resolving-  ( Resolver,+  ( MonadResolver,+    Resolver,     ResolverState,     ResolverValue,     SubscriptionField,   )+import Data.Morpheus.Generic+  ( Gmap,+    symbolName,+  ) 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.Internal.Utils (empty, singleton)+import Data.Morpheus.Server.Deriving.Internal.Type+  ( deriveInterfaceDefinition,+    toTypeDefinition,   ) import Data.Morpheus.Server.Deriving.Kinded.Arguments   ( DeriveFieldArguments (..),@@ -54,19 +69,37 @@ import Data.Morpheus.Server.Deriving.Kinded.Type   ( DERIVE_TYPE,     DeriveKindedType (..),-    deriveInterfaceDefinition,     deriveScalarDefinition,     deriveTypeGuardUnions,+    scanNode,   ) 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.Deriving.Utils.GScan+  ( FreeCatType,+    ScanRef,+    freeLeaf,+  )+import Data.Morpheus.Server.Deriving.Utils.Kinded+  ( CatType (..),+    Kinded (..),+    inputType,+    isIN,+    mapCat,+  )+import Data.Morpheus.Server.Deriving.Utils.Types (GQLTypeNode (..), GQLTypeNodeExtension (..))+import Data.Morpheus.Server.Deriving.Utils.Use+  ( GQLTypeCTX (..),+    GQLValueCTX (..),+    UseDeriving (..),+    UseGQLType (..),+    UseResolver (..),+  ) import Data.Morpheus.Server.Types.Directives-  ( GDirectiveUsages (..),+  ( GDirectiveUsage (..),+    GDirectiveUsages (..),     GQLDirective (..),+    allUsages,     applyTypeName,-    typeDirective,   ) import Data.Morpheus.Server.Types.Internal   ( TypeData (..),@@ -74,13 +107,13 @@   ) import Data.Morpheus.Server.Types.Kind   ( CUSTOM,+    DIRECTIVE,     DerivingKind,     SCALAR,     TYPE,     WRAPPER,   ) import Data.Morpheus.Server.Types.NamedResolvers (NamedResolverT (..))-import Data.Morpheus.Server.Types.SchemaT (SchemaT, extendImplements) import Data.Morpheus.Server.Types.TypeName   ( TypeFingerprint (..),     typeableFingerprint,@@ -100,6 +133,7 @@     CONST,     DirectiveLocation (..),     FieldDefinition,+    FieldName,     GQLError,     IN,     Msg (msg),@@ -108,7 +142,7 @@     ScalarDefinition (..),     TRUE,     TypeContent (..),-    TypeDefinition (..),+    TypeName,     TypeRef (..),     TypeWrapper (..),     VALID,@@ -116,6 +150,7 @@     internal,     mkBaseType,     mkField,+    packName,     toNullable,     unitTypeName,   )@@ -123,16 +158,16 @@ import Data.Vector (Vector) import GHC.Generics import GHC.TypeLits (KnownSymbol)-import Relude hiding (Seq, Undefined, fromList, intercalate)+import Relude hiding (Seq, Undefined, empty, fromList, intercalate) -ignoreUndefined :: forall f a. GQLType a => f a -> Maybe (f a)+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 =>+  (Typeable a) =>   CatType c a ->   DirectiveUsages ->   TypeData@@ -151,12 +186,12 @@  type Lifted a = (PARAM (KIND a) a) -kindedProxy :: f a -> KindedProxy (KIND a) a-kindedProxy _ = KindedProxy+kindedProxy :: f a -> Proxy (f' (KIND a) a)+kindedProxy _ = Proxy -lifted :: CatType cat a -> CatType cat (f (KIND a) (Lifted a))-lifted InputType = InputType-lifted OutputType = OutputType+kindedCatType :: CatType cat a -> CatType cat (f (KIND a) (Lifted a))+kindedCatType InputType = InputType+kindedCatType OutputType = OutputType  type IgnoredResolver = (Resolver QUERY () Identity) @@ -165,7 +200,7 @@   PARAM TYPE (t m) = t IgnoredResolver   PARAM k a = a -type DERIVE_T c a = (DeriveKindedType GQLType GQLValue c (KIND a) (Lifted a))+type DERIVE_T a = (DeriveKindedType WITH_DERIVING (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"@@ -192,21 +227,22 @@   directives _ = mempty    __type :: CatType cat a -> TypeData-  default __type :: Typeable a => 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+  __deriveType :: CatType c a -> GQLResult (GQLTypeNode c)+  default __deriveType :: (DERIVE_T a) => CatType c a -> GQLResult (GQLTypeNode c)+  __deriveType = deriveKindedType withDir . kindedCatType -  __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+  __exploreRef :: CatType c a -> [ScanRef FreeCatType GQLType]+  default __exploreRef :: (DERIVE_T a) => CatType c a -> [ScanRef FreeCatType GQLType]+  __exploreRef = exploreKindedRefs withDir . kindedCatType +  __deriveFieldArguments :: CatType c a -> GQLResult (ArgumentsDefinition CONST)+  default __deriveFieldArguments :: (DeriveFieldArguments WITH_GQL (HasArguments a)) => CatType c a -> GQLResult (ArgumentsDefinition CONST)+  __deriveFieldArguments OutputType = deriveFieldArguments withGQL (Proxy @(HasArguments a))+  __deriveFieldArguments InputType = pure empty+ instance GQLType Int where   type KIND Int = SCALAR   __type = mkTypeData "Int"@@ -235,108 +271,131 @@   type KIND (Value CONST) = CUSTOM   __type = mkTypeData "INTERNAL_VALUE"   __deriveType = deriveScalarDefinition (const $ ScalarDefinition pure) withDir+  __exploreRef _ = []  -- WRAPPERS instance GQLType () where   __type = mkTypeData unitTypeName -instance Typeable m => GQLType (Undefined m) where+instance (Typeable m) => GQLType (Undefined m) where   __type = mkTypeData __typenameUndefined -instance GQLType a => GQLType (Maybe a) where+instance (GQLType a) => GQLType (Maybe a) where   type KIND (Maybe a) = WRAPPER-  __type = wrapper toNullable . __type . catMap (Proxy @a)+  __type = wrapper toNullable . __type . mapCat (Proxy @a) -instance GQLType a => GQLType [a] where+instance (GQLType a) => GQLType [a] where   type KIND [a] = WRAPPER-  __type = wrapper list . __type . catMap (Proxy @a)+  __type = wrapper list . __type . mapCat (Proxy @a) -instance GQLType a => GQLType (Set a) where+instance (GQLType a) => GQLType (Set a) where   type KIND (Set a) = WRAPPER-  __type = __type . catMap (Proxy @[a])+  __type = __type . mapCat (Proxy @[a]) -instance GQLType a => GQLType (NonEmpty a) where+instance (GQLType a) => GQLType (NonEmpty a) where   type KIND (NonEmpty a) = WRAPPER-  __type = __type . catMap (Proxy @[a])+  __type = __type . mapCat (Proxy @[a])  instance (GQLType a) => GQLType (Seq a) where   type KIND (Seq a) = WRAPPER-  __type = __type . catMap (Proxy @[a])+  __type = __type . mapCat (Proxy @[a]) -instance GQLType a => GQLType (Vector a) where+instance (GQLType a) => GQLType (Vector a) where   type KIND (Vector a) = WRAPPER-  __type = __type . catMap (Proxy @[a])+  __type = __type . mapCat (Proxy @[a]) -instance GQLType a => GQLType (SubscriptionField a) where+instance (GQLType a) => GQLType (SubscriptionField a) where   type KIND (SubscriptionField a) = WRAPPER-  __type = __type . catMap (Proxy @a)+  __type = __type . mapCat (Proxy @a)+  __exploreRef = __exploreRef . mapCat (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) => GQLType (a -> b) where+instance (GQLType b, GQLType a, Gmap GQLType (Rep a)) => GQLType (a -> b) where   type KIND (a -> b) = CUSTOM-  __type = __type . catMap (Proxy @b)+  __type = __type . mapCat (Proxy @b)   __deriveType OutputType = __deriveType (OutputType :: CatType OUT b)   __deriveType proxy = cantBeInputType proxy+  __exploreRef _ =+    scanNode False withGQL (InputType :: CatType IN a)+      <> __exploreRef (OutputType :: CatType OUT b)  instance (GQLType k, GQLType v, Typeable k, Typeable v) => GQLType (Map k v) where   type KIND (Map k v) = CUSTOM-  __type = __type . catMap (Proxy @[Pair k v])-  __deriveType = __deriveType . catMap (Proxy @[(k, v)])+  __type = __type . mapCat (Proxy @[Pair k v])+  __deriveType = __deriveType . mapCat (Proxy @[(k, v)])+  __exploreRef = __exploreRef . mapCat (Proxy @(Pair k v)) -instance GQLType a => GQLType (Resolver o e m a) where+instance (GQLType a) => GQLType (Resolver o e m a) where   type KIND (Resolver o e m a) = CUSTOM-  __type = __type . catMap (Proxy @a)-  __deriveType = __deriveType . catMap (Proxy @a)+  __type = __type . mapCat (Proxy @a)+  __deriveType = __deriveType . mapCat (Proxy @a)+  __exploreRef = __exploreRef . mapCat (Proxy @a) -instance (Typeable a, Typeable b, GQLType a, GQLType b) => GQLType (a, b) where-  __type = __type . catMap (Proxy @(Pair a b))+instance (Typeable k, Typeable v, GQLType k, GQLType v) => GQLType (k, v) where+  __type = __type . mapCat (Proxy @(Pair k v))   directives _ = typeDirective InputTypeNamespace {inputTypeNamespace = "Input"}+  __exploreRef = __exploreRef . mapCat (Proxy @(Pair k v))  instance (KnownSymbol name, GQLType value) => GQLType (Arg name value) where   type KIND (Arg name value) = CUSTOM-  __type = __type . catMap (Proxy @value)+  __type = __type . mapCat (Proxy @value)   __deriveType OutputType = cantBeInputType (OutputType :: CatType OUT (Arg name value))-  __deriveType p@InputType = do-    injectType withDir proxy-    fillTypeContent withDir p content+  __deriveType p@InputType = (`GQLTypeNode` []) <$> toTypeDefinition 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+      TypeData {gqlTypeName, gqlWrappers} = __type (InputType :: CatType IN value) -instance (DERIVE_TYPE GQLType OUT i, DERIVE_TYPE GQLType OUT u) => GQLType (TypeGuard i u) where+  __exploreRef OutputType = []+  __exploreRef InputType = __exploreRef (InputType :: CatType IN value)++instance (DERIVE_TYPE GQLType i, DERIVE_TYPE GQLType u) => GQLType (TypeGuard i u) where   type KIND (TypeGuard i u) = CUSTOM-  __type = __type . catMap (Proxy @i)+  __type = __type . mapCat (Proxy @i)   __deriveType OutputType = do-    unions <- deriveTypeGuardUnions withDir union-    extendImplements (useTypename withGQL interface) unions-    deriveInterfaceDefinition withDir interface+    unions <- deriveTypeGuardUnions (withDir, union)+    let imp = ImplementsExtension (useTypename withGQL interface) unions+    (cont, ext) <- deriveInterfaceDefinition withDir interface+    pure $ GQLTypeNode cont (imp : ext)     where       interface = OutputType :: CatType OUT i       union = OutputType :: CatType OUT u   __deriveType proxy = cantBeInputType proxy+  __exploreRef InputType = []+  __exploreRef ref@OutputType =+    [freeLeaf (useFingerprint withGQL ref) ref]+      <> __exploreRef union+      <> __exploreRef interface+    where+      interface = OutputType :: CatType OUT i+      union = OutputType :: CatType OUT u  instance (GQLType a) => GQLType (NamedResolverT m a) where   type KIND (NamedResolverT m a) = CUSTOM-  __type = __type . catMap (Proxy :: Proxy a)-  __deriveType = __deriveType . catMap (Proxy @a)-  __deriveFieldArguments = __deriveFieldArguments . catMap (Proxy @a)+  __type = __type . mapCat (Proxy :: Proxy a)+  __deriveType = __deriveType . mapCat (Proxy @a)+  __deriveFieldArguments = __deriveFieldArguments . mapCat (Proxy @a)+  __exploreRef = __exploreRef . mapCat (Proxy :: Proxy a)  type DirectiveUsages = GDirectiveUsages GQLType GQLValue +type DirectiveConstraint a = (GQLDirective a, GQLType a, KIND a ~ DIRECTIVE, GQLValue a)++type DirectiveUsage = GDirectiveUsage GQLType GQLValue+ newtype InputTypeNamespace = InputTypeNamespace {inputTypeNamespace :: Text}   deriving (Generic)-  deriving anyclass-    (GQLType) +instance GQLType InputTypeNamespace where+  type KIND InputTypeNamespace = DIRECTIVE+ instance GQLDirective InputTypeNamespace where   excludeFromSchema _ = True   type@@ -354,44 +413,69 @@     | isInput = inputTypeNamespace <> name     | otherwise = name -withValue :: UseValue GQLValue+withValue :: GQLValueCTX GQLValue withValue =-  UseValue-    { useDecodeValue = decodeValue,-      useEncodeValue = encodeValue+  GQLValueCTX+    { __useDecodeValue = decodeValue,+      __useEncodeValue = encodeValue     } -withGQL :: UseGQLType GQLType+withGQL :: WITH_GQL withGQL =-  UseGQLType-    { useFingerprint = gqlFingerprint . __type,-      useTypename = gqlTypeName . __type,-      useTypeData = __type,-      useDeriveType = __deriveType,-      useDeriveFieldArguments = __deriveFieldArguments+  GQLTypeCTX+    { __useFingerprint = gqlFingerprint . __type,+      __useTypename = gqlTypeName . __type,+      __useTypeData = __type,+      __useDeriveNode = __deriveType,+      __useExploreRef = \p -> __exploreRef p <> concatMap exploreDirective (allUsages (directives p)),+      __useDeriveFieldArgs = __deriveFieldArguments     } -withDir :: UseDeriving GQLType GQLValue+typeDirective :: (DirectiveConstraint a) => a -> DirectiveUsages+typeDirective x = GDirectiveUsages [GDirectiveUsage x] mempty mempty++fieldDirective :: (DirectiveConstraint a) => FieldName -> a -> DirectiveUsages+fieldDirective name x = GDirectiveUsages mempty (M.singleton name [GDirectiveUsage x]) mempty++fieldDirective' :: (DirectiveConstraint a) => TH.Name -> a -> DirectiveUsages+fieldDirective' name = fieldDirective (packName name)++enumDirective :: (DirectiveConstraint a) => TypeName -> a -> DirectiveUsages+enumDirective name x = GDirectiveUsages mempty mempty (M.singleton name [GDirectiveUsage x])++enumDirective' :: (DirectiveConstraint a) => TH.Name -> a -> DirectiveUsages+enumDirective' name = enumDirective (packName name)++exploreDirective :: DirectiveUsage -> [ScanRef FreeCatType GQLType]+exploreDirective (GDirectiveUsage x) = __exploreRef $ inputType $ Identity x++withDir :: WITH_DERIVING withDir =   UseDeriving-    { __directives = directives,-      dirGQL = withGQL,-      dirArgs = withValue+    { useDirectives = directives,+      __useGQL = withGQL,+      __useValue = withValue     } -class GQLType a => GQLValue a where+type WITH_GQL = GQLTypeCTX GQLType++type WITH_DERIVING = UseDeriving GQLType GQLValue++type WITH_RESOLVER = UseResolver GQLResolver GQLType GQLValue++class (GQLType a) => GQLValue a where   decodeValue :: Value VALID -> ResolverState a   encodeValue :: a -> GQLResult (Value CONST) -instance (GQLType a, KindedValue GQLType GQLValue (KIND a) a) => GQLValue a where-  encodeValue value = encodeKindedValue withDir (ContextValue value :: ContextValue (KIND a) a)+instance (GQLType a, KindedValue WITH_DERIVING (KIND a) a) => GQLValue a where+  encodeValue value = encodeKindedValue withDir (Kinded value :: Kinded (KIND a) a)   decodeValue = decodeKindedValue withDir (Proxy @(KIND a)) -class GQLResolver (m :: Type -> Type) resolver where+class (MonadResolver m) => GQLResolver (m :: Type -> Type) resolver where   deriveResolver :: resolver -> m (ResolverValue m) -instance (KindedResolver GQLType GQLResolver GQLValue (KIND a) m a) => GQLResolver m a where-  deriveResolver resolver = kindedResolver withRes (ContextValue resolver :: ContextValue (KIND a) a)+instance (MonadResolver m, KindedResolver WITH_RESOLVER (KIND a) m a) => GQLResolver m a where+  deriveResolver resolver = kindedResolver withRes (Kinded resolver :: Kinded (KIND a) a)  withRes :: UseResolver GQLResolver GQLType GQLValue withRes =
src/Data/Morpheus/Server/Types/Kind.hs view
@@ -10,6 +10,7 @@     TYPE,     CUSTOM,     WRAPPER,+    DIRECTIVE,   ) where @@ -20,6 +21,7 @@   | DERIVING_TYPE   | DERIVING_WRAPPER   | DERIVING_CUSTOM+  | DERIVING_DIRECTIVE   deriving (Show)  -- | GraphQL Scalar: Int, Float, String, Boolean or any user defined custom Scalar type@@ -31,4 +33,8 @@ -- | GraphQL Arrays , Resolvers and NonNull fields type WRAPPER = 'DERIVING_WRAPPER +-- | GraphQL Arrays , Resolvers and NonNull fields+type DIRECTIVE = 'DERIVING_DIRECTIVE++-- | GraphQL Custom Types type CUSTOM = 'DERIVING_CUSTOM
src/Data/Morpheus/Server/Types/NamedResolvers.hs view
@@ -6,6 +6,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE NoImplicitPrelude #-} @@ -86,15 +87,15 @@   type Dep ID = ID   resolveBatched = forward -class ToJSON (Dependency a) => ResolveNamed (m :: Type -> Type) (a :: Type) where+class (ToJSON (Dependency a)) => ResolveNamed (m :: Type -> Type) (a :: Type) where   type Dep a :: Type-  resolveBatched :: MonadError GQLError m => [Dependency a] -> m [Maybe a]+  resolveBatched :: (MonadError GQLError m) => [Dependency a] -> m [Maybe a] -  resolveNamed :: MonadError GQLError m => Dependency a -> m 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+  NamedResolverT :: (ResolveNamed m (Target a)) => m (NamedRef a) -> NamedResolverT m a  type family NamedRef a :: Type where   NamedRef [a] = [Dependency a]@@ -104,5 +105,5 @@   NamedRef (Vector a) = [Dependency a]   NamedRef a = Dependency a -resolve :: ResolveNamed m (Target a) => m (NamedRef a) -> NamedResolverT m a+resolve :: (ResolveNamed m (Target a)) => m (NamedRef a) -> NamedResolverT m a resolve = NamedResolverT
− src/Data/Morpheus/Server/Types/SchemaT.hs 
@@ -1,214 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE NoImplicitPrelude #-}--module Data.Morpheus.Server.Types.SchemaT-  ( SchemaT,-    updateSchema,-    insertType,-    TypeFingerprint (..),-    toSchema,-    withInput,-    extendImplements,-    insertDirectiveDefinition,-    outToAny,-  )-where--import Control.Monad.Except (MonadError (..))-import qualified Data.Map as Map-import Data.Morpheus.Internal.Ext (GQLResult)-import Data.Morpheus.Server.Types.TypeName-import Data.Morpheus.Types.Internal.AST-  ( ANY,-    CONST,-    DirectiveDefinition,-    GQLError,-    IN,-    OBJECT,-    OUT,-    Schema,-    TypeCategory (..),-    TypeContent (..),-    TypeDefinition (..),-    TypeName,-    defineDirective,-    defineSchemaWith,-    msg,-    toAny,-  )-import Relude hiding (empty)--data SchemaState where-  SchemaState ::-    { typeDefinitions :: Map TypeFingerprint (TypeDefinition ANY CONST),-      implements :: Map TypeName [TypeName],-      directiveDefinitions :: Map TypeFingerprint (DirectiveDefinition CONST)-    } ->-    SchemaState--emptyMyMap :: SchemaState-emptyMyMap =-  SchemaState-    { typeDefinitions = Map.empty,-      implements = Map.empty,-      directiveDefinitions = Map.empty-    }---- Helper Functions-newtype SchemaT (cat :: TypeCategory) a = SchemaT-  { runSchemaT ::-      GQLResult-        ( a,-          [SchemaState -> GQLResult SchemaState]-        )-  }-  deriving (Functor)--instance MonadError GQLError (SchemaT c) where-  throwError = SchemaT . throwError-  catchError (SchemaT mx) f = SchemaT (catchError mx (runSchemaT . f))--instance Applicative (SchemaT c) where-  pure = SchemaT . pure . (,[])-  (SchemaT v1) <*> (SchemaT v2) = SchemaT $ do-    (f, u1) <- v1-    (a, u2) <- v2-    pure (f a, u1 <> u2)--instance Monad (SchemaT c) where-  return = pure-  (SchemaT v1) >>= f =-    SchemaT $ do-      (x, up1) <- v1-      (y, up2) <- runSchemaT (f x)-      pure (y, up1 <> up2)--toSchema ::-  SchemaT-    c-    ( TypeDefinition OBJECT CONST,-      Maybe (TypeDefinition OBJECT CONST),-      Maybe (TypeDefinition OBJECT CONST)-    ) ->-  GQLResult (Schema CONST)-toSchema (SchemaT v) = do-  ((q, m, s), typeDefs) <- v-  SchemaState {typeDefinitions, implements, directiveDefinitions} <- execUpdates emptyMyMap typeDefs-  types <- map (insertImplements implements) <$> checkTypeCollisions (Map.toList typeDefinitions)-  schema <- defineSchemaWith types (Just q, m, s)-  foldlM defineDirective schema directiveDefinitions--insertImplements :: Map TypeName [TypeName] -> TypeDefinition c CONST -> TypeDefinition c CONST-insertImplements x TypeDefinition {typeContent = DataObject {..}, ..} =-  TypeDefinition-    { typeContent =-        DataObject-          { objectImplements = objectImplements <> implements,-            ..-          },-      ..-    }-  where-    implements :: [TypeName]-    implements = Map.findWithDefault [] typeName x-insertImplements _ t = t--withInput :: SchemaT IN a -> SchemaT OUT a-withInput (SchemaT x) = SchemaT x--outToAny :: SchemaT OUT a -> SchemaT k' a-outToAny (SchemaT x) = SchemaT x--checkTypeCollisions :: [(TypeFingerprint, TypeDefinition k a)] -> GQLResult [TypeDefinition k a]-checkTypeCollisions = fmap Map.elems . foldlM collectTypes Map.empty-  where-    collectTypes :: Map (TypeName, TypeFingerprint) (TypeDefinition k a) -> (TypeFingerprint, TypeDefinition k a) -> GQLResult (Map (TypeName, TypeFingerprint) (TypeDefinition k a))-    collectTypes accum (fp, typ) = maybe addType (handleCollision typ) (key `Map.lookup` accum)-      where-        addType = pure $ Map.insert key typ accum-        key = (typeName typ, withSameCategory fp)-        handleCollision t1@TypeDefinition {typeContent = DataEnum {}} t2 | t1 == t2 = pure accum-        handleCollision TypeDefinition {typeContent = DataScalar {}} TypeDefinition {typeContent = DataScalar {}} = pure accum-        handleCollision TypeDefinition {typeName = name1} _ = failureRequirePrefix name1--failureRequirePrefix :: TypeName -> GQLResult b-failureRequirePrefix typename =-  throwError $-    "It appears that the Haskell type "-      <> msg typename-      <> " was used as both input and output type, which is not allowed by GraphQL specifications."-      <> "\n\n "-      <> "If you use \"InputTypeNamespace\" directive, "-      <> "you can override the default type names for "-      <> msg typename-      <> " to solve this problem."--withSameCategory :: TypeFingerprint -> TypeFingerprint-withSameCategory (TypeableFingerprint _ xs) = TypeableFingerprint OUT xs-withSameCategory x = x--execUpdates :: Monad m => a -> [a -> m a] -> m a-execUpdates = foldlM (&)--insertType :: TypeDefinition cat CONST -> SchemaT cat' ()-insertType dt = updateSchema (CustomFingerprint (typeName dt)) (const $ pure dt) ()--updateSchema ::-  TypeFingerprint ->-  (a -> SchemaT cat' (TypeDefinition cat CONST)) ->-  a ->-  SchemaT cat' ()-updateSchema InternalFingerprint {} _ _ = SchemaT $ pure ((), [])-updateSchema fingerprint f x =-  SchemaT $ pure ((), [upLib])-  where-    upLib :: SchemaState -> GQLResult SchemaState-    upLib schema-      | Map.member fingerprint (typeDefinitions schema) = pure schema-      | otherwise = do-          (type', updates) <- runSchemaT (f x)-          execUpdates schema (update type' : updates)-      where-        update t schemaState =-          pure-            schemaState-              { typeDefinitions = Map.insert fingerprint (toAny t) (typeDefinitions schemaState)-              }--insertDirectiveDefinition ::-  TypeFingerprint ->-  (a -> SchemaT cat' (DirectiveDefinition CONST)) ->-  a ->-  SchemaT cat' ()-insertDirectiveDefinition InternalFingerprint {} _ _ = SchemaT $ pure ((), [])-insertDirectiveDefinition fingerprint f x =-  SchemaT $ pure ((), [upLib])-  where-    upLib :: SchemaState -> GQLResult SchemaState-    upLib schema-      | Map.member fingerprint (typeDefinitions schema) = pure schema-      | otherwise = do-          (type', updates) <- runSchemaT (f x)-          execUpdates schema (update type' : updates)-      where-        update t schemaState =-          pure-            schemaState-              { directiveDefinitions = Map.insert fingerprint t (directiveDefinitions schemaState)-              }--extendImplements :: TypeName -> [TypeName] -> SchemaT cat' ()-extendImplements interface types = SchemaT $ pure ((), [upLib])-  where-    upLib :: SchemaState -> GQLResult SchemaState-    upLib schema = pure schema {implements = foldr insertInterface (implements schema) types}-    insertInterface :: TypeName -> Map TypeName [TypeName] -> Map TypeName [TypeName]-    insertInterface = Map.alter (Just . (interface :) . fromMaybe [])
src/Data/Morpheus/Server/Types/TypeName.hs view
@@ -5,6 +5,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE Rank2Types #-}+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-}@@ -32,10 +33,12 @@   ( TypeCategory (..),     TypeName,     packName,+    unpackName,   ) import Data.Text   ( intercalate,     pack,+    unpack,   ) import Data.Typeable   ( TyCon,@@ -46,30 +49,50 @@     typeRepTyCon,   ) import GHC.Fingerprint-import Relude hiding (Seq, Undefined, intercalate)+import Relude hiding (Seq, Show, Undefined, intercalate, show)+import Prelude (Show (..))  data TypeFingerprint-  = TypeableFingerprint TypeCategory [Fingerprint]+  = TypeableFingerprint+      { category :: TypeCategory,+        fingerprints :: [Fingerprint]+      }   | InternalFingerprint TypeName   | CustomFingerprint TypeName   deriving     ( Generic,-      Show,       Eq,       Ord     ) -typeableTypename :: Typeable a => f a -> TypeName+instance Show TypeFingerprint where+  show TypeableFingerprint {..} = "TYPEABLE:" <> unpack (intercalate ":" (pack (show category) : map (pack . show) fingerprints))+  show (InternalFingerprint name) = "INTERNAL:" <> unpack (unpackName name)+  show (CustomFingerprint name) = "CUSTOM:" <> unpack (unpackName name)++instance Hashable TypeFingerprint where+  hashWithSalt s TypeableFingerprint {..} = hashWithSalt s (1 :: Int, category, map show fingerprints)+  hashWithSalt s (InternalFingerprint x) = hashWithSalt s (2 :: Int, x)+  hashWithSalt s (CustomFingerprint x) = hashWithSalt s (3 :: Int, x)++typeableTypename :: (Typeable a) => f a -> TypeName typeableTypename = packName . intercalate "" . 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+toCategory :: CatType c a -> TypeCategory+toCategory InputType = IN+toCategory OutputType = OUT -getTypeConstructors :: Typeable a => f a -> [TyCon]+typeableFingerprint :: (Typeable a) => CatType c a -> TypeFingerprint+typeableFingerprint p =+  TypeableFingerprint+    { category = toCategory p,+      fingerprints = 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 :: forall k (a :: k) f. (Typeable a) => f a -> TyCon rep = typeRepTyCon . typeRep  -- | replaces typeName (A,B) with Pair_A_B
test/Feature/Directive/Definition.hs view
@@ -14,7 +14,8 @@ import Data.Kind (Type) import Data.Morpheus.Server (interpreter) import Data.Morpheus.Server.Types-  ( Deprecated (..),+  ( DIRECTIVE,+    Deprecated (..),     DirectiveLocation (..),     GQLDirective (..),     GQLRequest,@@ -22,6 +23,7 @@     GQLType (..),     Prefixes (..),     RootResolver (..),+    Suffixes (..),     Undefined,     VisitType (..),     defaultRootResolver,@@ -32,7 +34,7 @@ import Data.Text (Text) import GHC.Generics (Generic) -data MythologyDeity = MythologyDeity+data MythologyDeity' = MythologyDeity'   { deityName :: Text,     deprecatedField :: Maybe Text,     deprecatedFieldWithReason :: Bool@@ -43,18 +45,22 @@   { name :: Text,     isLimited :: Bool   }-  deriving (GQLType, Generic)+  deriving (Generic) +instance GQLType Power where+  type KIND Power = DIRECTIVE+ instance GQLDirective Power where   type DIRECTIVE_LOCATIONS Power = '[ 'LOCATION_OBJECT]  instance VisitType Power where   visitTypeName _ _ = id -instance GQLType MythologyDeity where+instance GQLType MythologyDeity' where   directives _ =     typeDirective Power {name = "Lightning bolts", isLimited = False}       <> typeDirective Prefixes {addPrefix = "", removePrefix = "Mythology"}+      <> typeDirective Suffixes {addSuffix = "", removeSuffix = "'"}       <> fieldDirective' 'deprecatedField Deprecated {reason = Nothing}       <> fieldDirective' 'deprecatedFieldWithReason Deprecated {reason = Just "this should be deprecated"} @@ -74,7 +80,7 @@       <> enumDirective' 'Argos Deprecated {reason = Just "for some reason"}  data Query (m :: Type -> Type) = Query-  { deity :: MythologyDeity,+  { deity :: MythologyDeity',     city :: City   }   deriving (Generic, GQLType)@@ -85,7 +91,7 @@     { queryResolver =         Query           { deity =-              MythologyDeity+              MythologyDeity'                 { deityName = "morpheus",                   deprecatedField = Nothing,                   deprecatedFieldWithReason = False
test/Feature/Directive/definition/introspect-directive/response.json view
@@ -35,38 +35,6 @@           "args": [             {               "defaultValue": null,-              "name": "addPrefix",-              "type": {-                "kind": "NON_NULL",-                "name": null,-                "ofType": { "kind": "SCALAR", "name": "String", "ofType": null }-              }-            },-            {-              "defaultValue": null,-              "name": "removePrefix",-              "type": {-                "kind": "NON_NULL",-                "name": null,-                "ofType": { "kind": "SCALAR", "name": "String", "ofType": null }-              }-            }-          ],-          "description": null,-          "locations": [-            "OBJECT",-            "ENUM",-            "INPUT_OBJECT",-            "UNION",-            "SCALAR",-            "INTERFACE"-          ],-          "name": "Prefixes"-        },-        {-          "args": [-            {-              "defaultValue": null,               "name": "reason",               "type": { "kind": "SCALAR", "name": "String", "ofType": null }             }
+ test/Feature/Inference/Names.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Feature.Inference.Names+  ( api,+  )+where++import Data.Morpheus.Server (interpreter)+import Data.Morpheus.Server.Types+  ( Arg (..),+    GQLRequest,+    GQLResponse,+    GQLType (..),+    RootResolver (..),+    Undefined,+    defaultRootResolver,+  )+import Relude hiding (Undefined)++data MyEnum = MyEnum deriving (Generic, GQLType)++newtype Input = Input {data' :: Text}+  deriving (Generic)+  deriving anyclass (GQLType)++newtype Query (m :: Type -> Type) = Query+  { type' ::+      Arg "in" Input ->+      Text+  }+  deriving (Generic)+  deriving anyclass (GQLType)++root :: RootResolver IO () Query Undefined Undefined+root =+  defaultRootResolver+    { queryResolver = Query {type' = \(Arg Input {data'}) -> data'}+    }++api :: GQLRequest -> IO GQLResponse+api = interpreter root
test/Feature/Inference/TypeGuards.hs view
@@ -26,7 +26,7 @@   ) import GHC.Generics (Generic) -data Character = Hydra+data Character = Character   { name :: Text,     age :: Int   }
+ test/Feature/Inference/names/reserved-names-introspection/query.gql view
@@ -0,0 +1,16 @@+{+  query: __type(name: "Query") {+    fields {+      name+      args {+        name+      }+    }+  }++  input: __type(name: "Input") {+    inputFields {+      name+    }+  }+}
+ test/Feature/Inference/names/reserved-names-introspection/response.json view
@@ -0,0 +1,8 @@+{+  "data": {+    "query": {+      "fields": [{ "name": "type", "args": [{ "name": "in" }] }]+    },+    "input": { "inputFields": [{ "name": "data" }] }+  }+}
+ test/Feature/Inference/names/reserved-names-resolving/query.gql view
@@ -0,0 +1,3 @@+{+  type(in: { data: "some data" })+}
+ test/Feature/Inference/names/reserved-names-resolving/response.json view
@@ -0,0 +1,5 @@+{+  "data": {+    "type": "some data"+  }+}
test/Feature/Inference/tagged-arguments-fail/introspection/response.json view
@@ -2,6 +2,9 @@   "errors": [     {       "message": "There can Be only One argument Named \"a2\""+    },+    {+      "message": "There can Be only One argument Named \"a2\""     }   ] }
test/Feature/Inference/tagged-arguments-fail/resolving/response.json view
@@ -2,6 +2,9 @@   "errors": [     {       "message": "There can Be only One argument Named \"a2\""+    },+    {+      "message": "There can Be only One argument Named \"a2\""     }   ] }
test/Spec.hs view
@@ -6,6 +6,7 @@   ) where +import Data.Aeson (FromJSON, ToJSON) import Data.Morpheus.Server.Types (GQLRequest (..), GQLResponse (..)) import qualified Feature.Collision.CategoryCollisionFail as TypeCategoryCollisionFail import qualified Feature.Collision.CategoryCollisionSuccess as TypeCategoryCollisionSuccess@@ -14,6 +15,7 @@ import qualified Feature.Directive.EnumVisitor as EnumVisitor import qualified Feature.Directive.FieldVisitor as FieldVisitor import qualified Feature.Directive.TypeVisitor as TypeVisitor+import qualified Feature.Inference.Names as Names import qualified Feature.Inference.ObjectAndEnum as ObjectAndEnum import qualified Feature.Inference.TaggedArguments as TaggedArguments import qualified Feature.Inference.TaggedArgumentsFail as TaggedArgumentsFail@@ -44,10 +46,10 @@ mkFeatureUrl :: FilePath -> FilePath -> FileUrl mkFeatureUrl groupName = cd (cd (mkUrl "Feature") groupName) -testFeature :: FilePath -> (GQLRequest -> IO GQLResponse, FilePath) -> IO TestTree+testFeature :: (FromJSON a, ToJSON b) => FilePath -> (a -> IO b, FilePath) -> IO TestTree testFeature groupName (api, name) = scan (testApi api) (mkFeatureUrl groupName name) -testFeatures :: FilePath -> [(GQLRequest -> IO GQLResponse, FilePath)] -> IO TestTree+testFeatures :: (FromJSON a, ToJSON b) => FilePath -> [(a -> IO b, FilePath)] -> IO TestTree testFeatures name cases =   testGroup name     <$> traverse@@ -80,7 +82,8 @@           (TypeInference.api, "type-inference"),           (TaggedArguments.api, "tagged-arguments"),           (TaggedArgumentsFail.api, "tagged-arguments-fail"),-          (ObjectAndEnum.api, "object-and-enum")+          (ObjectAndEnum.api, "object-and-enum"),+          (Names.api, "names")         ],       testFeatures         "Directive"