diff --git a/morpheus-graphql-server.cabal b/morpheus-graphql-server.cabal --- a/morpheus-graphql-server.cabal +++ b/morpheus-graphql-server.cabal @@ -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 diff --git a/src/Data/Morpheus/Generic.hs b/src/Data/Morpheus/Generic.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Generic.hs @@ -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 (..), + ) diff --git a/src/Data/Morpheus/Generic/Cons.hs b/src/Data/Morpheus/Generic/Cons.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Generic/Cons.hs @@ -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))] diff --git a/src/Data/Morpheus/Generic/Fields.hs b/src/Data/Morpheus/Generic/Fields.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Generic/Fields.hs @@ -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 diff --git a/src/Data/Morpheus/Generic/GRep.hs b/src/Data/Morpheus/Generic/GRep.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Generic/GRep.hs @@ -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 diff --git a/src/Data/Morpheus/Generic/GScan.hs b/src/Data/Morpheus/Generic/GScan.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Generic/GScan.hs @@ -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]} diff --git a/src/Data/Morpheus/Generic/Gmap.hs b/src/Data/Morpheus/Generic/Gmap.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Generic/Gmap.hs @@ -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 _ = [] diff --git a/src/Data/Morpheus/Generic/Proxy.hs b/src/Data/Morpheus/Generic/Proxy.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Generic/Proxy.hs @@ -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 diff --git a/src/Data/Morpheus/Generic/RefType.hs b/src/Data/Morpheus/Generic/RefType.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Generic/RefType.hs @@ -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 diff --git a/src/Data/Morpheus/Server.hs b/src/Data/Morpheus/Server.hs --- a/src/Data/Morpheus/Server.hs +++ b/src/Data/Morpheus/Server.hs @@ -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 = diff --git a/src/Data/Morpheus/Server/Deriving/Internal/Decode/Rep.hs b/src/Data/Morpheus/Server/Deriving/Internal/Decode/Rep.hs deleted file mode 100644 --- a/src/Data/Morpheus/Server/Deriving/Internal/Decode/Rep.hs +++ /dev/null @@ -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 diff --git a/src/Data/Morpheus/Server/Deriving/Internal/Decode/Utils.hs b/src/Data/Morpheus/Server/Deriving/Internal/Decode/Utils.hs deleted file mode 100644 --- a/src/Data/Morpheus/Server/Deriving/Internal/Decode/Utils.hs +++ /dev/null @@ -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 diff --git a/src/Data/Morpheus/Server/Deriving/Internal/Directive.hs b/src/Data/Morpheus/Server/Deriving/Internal/Directive.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Server/Deriving/Internal/Directive.hs @@ -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 diff --git a/src/Data/Morpheus/Server/Deriving/Internal/Resolve/Explore.hs b/src/Data/Morpheus/Server/Deriving/Internal/Resolve/Explore.hs deleted file mode 100644 --- a/src/Data/Morpheus/Server/Deriving/Internal/Resolve/Explore.hs +++ /dev/null @@ -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 - ) diff --git a/src/Data/Morpheus/Server/Deriving/Internal/Resolver.hs b/src/Data/Morpheus/Server/Deriving/Internal/Resolver.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Server/Deriving/Internal/Resolver.hs @@ -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 + ) diff --git a/src/Data/Morpheus/Server/Deriving/Internal/Schema/Directive.hs b/src/Data/Morpheus/Server/Deriving/Internal/Schema/Directive.hs deleted file mode 100644 --- a/src/Data/Morpheus/Server/Deriving/Internal/Schema/Directive.hs +++ /dev/null @@ -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 diff --git a/src/Data/Morpheus/Server/Deriving/Internal/Schema/Enum.hs b/src/Data/Morpheus/Server/Deriving/Internal/Schema/Enum.hs deleted file mode 100644 --- a/src/Data/Morpheus/Server/Deriving/Internal/Schema/Enum.hs +++ /dev/null @@ -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 - ) diff --git a/src/Data/Morpheus/Server/Deriving/Internal/Schema/Internal.hs b/src/Data/Morpheus/Server/Deriving/Internal/Schema/Internal.hs deleted file mode 100644 --- a/src/Data/Morpheus/Server/Deriving/Internal/Schema/Internal.hs +++ /dev/null @@ -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 - ) diff --git a/src/Data/Morpheus/Server/Deriving/Internal/Schema/Object.hs b/src/Data/Morpheus/Server/Deriving/Internal/Schema/Object.hs deleted file mode 100644 --- a/src/Data/Morpheus/Server/Deriving/Internal/Schema/Object.hs +++ /dev/null @@ -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, - .. - } diff --git a/src/Data/Morpheus/Server/Deriving/Internal/Schema/Type.hs b/src/Data/Morpheus/Server/Deriving/Internal/Schema/Type.hs deleted file mode 100644 --- a/src/Data/Morpheus/Server/Deriving/Internal/Schema/Type.hs +++ /dev/null @@ -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 diff --git a/src/Data/Morpheus/Server/Deriving/Internal/Schema/Union.hs b/src/Data/Morpheus/Server/Deriving/Internal/Schema/Union.hs deleted file mode 100644 --- a/src/Data/Morpheus/Server/Deriving/Internal/Schema/Union.hs +++ /dev/null @@ -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 diff --git a/src/Data/Morpheus/Server/Deriving/Internal/Type.hs b/src/Data/Morpheus/Server/Deriving/Internal/Type.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Server/Deriving/Internal/Type.hs @@ -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) + } diff --git a/src/Data/Morpheus/Server/Deriving/Internal/Value.hs b/src/Data/Morpheus/Server/Deriving/Internal/Value.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Server/Deriving/Internal/Value.hs @@ -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) diff --git a/src/Data/Morpheus/Server/Deriving/Kinded/Arguments.hs b/src/Data/Morpheus/Server/Deriving/Kinded/Arguments.hs --- a/src/Data/Morpheus/Server/Deriving/Kinded/Arguments.hs +++ b/src/Data/Morpheus/Server/Deriving/Kinded/Arguments.hs @@ -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 diff --git a/src/Data/Morpheus/Server/Deriving/Kinded/Channels.hs b/src/Data/Morpheus/Server/Deriving/Kinded/Channels.hs --- a/src/Data/Morpheus/Server/Deriving/Kinded/Channels.hs +++ b/src/Data/Morpheus/Server/Deriving/Kinded/Channels.hs @@ -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 diff --git a/src/Data/Morpheus/Server/Deriving/Kinded/NamedResolver.hs b/src/Data/Morpheus/Server/Deriving/Kinded/NamedResolver.hs --- a/src/Data/Morpheus/Server/Deriving/Kinded/NamedResolver.hs +++ b/src/Data/Morpheus/Server/Deriving/Kinded/NamedResolver.hs @@ -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) diff --git a/src/Data/Morpheus/Server/Deriving/Kinded/NamedResolverFun.hs b/src/Data/Morpheus/Server/Deriving/Kinded/NamedResolverFun.hs --- a/src/Data/Morpheus/Server/Deriving/Kinded/NamedResolverFun.hs +++ b/src/Data/Morpheus/Server/Deriving/Kinded/NamedResolverFun.hs @@ -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!" diff --git a/src/Data/Morpheus/Server/Deriving/Kinded/Resolver.hs b/src/Data/Morpheus/Server/Deriving/Kinded/Resolver.hs --- a/src/Data/Morpheus/Server/Deriving/Kinded/Resolver.hs +++ b/src/Data/Morpheus/Server/Deriving/Kinded/Resolver.hs @@ -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 diff --git a/src/Data/Morpheus/Server/Deriving/Kinded/Type.hs b/src/Data/Morpheus/Server/Deriving/Kinded/Type.hs --- a/src/Data/Morpheus/Server/Deriving/Kinded/Type.hs +++ b/src/Data/Morpheus/Server/Deriving/Kinded/Type.hs @@ -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) diff --git a/src/Data/Morpheus/Server/Deriving/Kinded/Value.hs b/src/Data/Morpheus/Server/Deriving/Kinded/Value.hs --- a/src/Data/Morpheus/Server/Deriving/Kinded/Value.hs +++ b/src/Data/Morpheus/Server/Deriving/Kinded/Value.hs @@ -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") diff --git a/src/Data/Morpheus/Server/Deriving/Resolvers.hs b/src/Data/Morpheus/Server/Deriving/Resolvers.hs --- a/src/Data/Morpheus/Server/Deriving/Resolvers.hs +++ b/src/Data/Morpheus/Server/Deriving/Resolvers.hs @@ -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 diff --git a/src/Data/Morpheus/Server/Deriving/Schema.hs b/src/Data/Morpheus/Server/Deriving/Schema.hs --- a/src/Data/Morpheus/Server/Deriving/Schema.hs +++ b/src/Data/Morpheus/Server/Deriving/Schema.hs @@ -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 diff --git a/src/Data/Morpheus/Server/Deriving/Utils/AST.hs b/src/Data/Morpheus/Server/Deriving/Utils/AST.hs deleted file mode 100644 --- a/src/Data/Morpheus/Server/Deriving/Utils/AST.hs +++ /dev/null @@ -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 diff --git a/src/Data/Morpheus/Server/Deriving/Utils/GRep.hs b/src/Data/Morpheus/Server/Deriving/Utils/GRep.hs deleted file mode 100644 --- a/src/Data/Morpheus/Server/Deriving/Utils/GRep.hs +++ /dev/null @@ -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 diff --git a/src/Data/Morpheus/Server/Deriving/Utils/GScan.hs b/src/Data/Morpheus/Server/Deriving/Utils/GScan.hs --- a/src/Data/Morpheus/Server/Deriving/Utils/GScan.hs +++ b/src/Data/Morpheus/Server/Deriving/Utils/GScan.hs @@ -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 diff --git a/src/Data/Morpheus/Server/Deriving/Utils/Gmap.hs b/src/Data/Morpheus/Server/Deriving/Utils/Gmap.hs deleted file mode 100644 --- a/src/Data/Morpheus/Server/Deriving/Utils/Gmap.hs +++ /dev/null @@ -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 diff --git a/src/Data/Morpheus/Server/Deriving/Utils/Kinded.hs b/src/Data/Morpheus/Server/Deriving/Utils/Kinded.hs --- a/src/Data/Morpheus/Server/Deriving/Utils/Kinded.hs +++ b/src/Data/Morpheus/Server/Deriving/Utils/Kinded.hs @@ -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} diff --git a/src/Data/Morpheus/Server/Deriving/Utils/Proxy.hs b/src/Data/Morpheus/Server/Deriving/Utils/Proxy.hs deleted file mode 100644 --- a/src/Data/Morpheus/Server/Deriving/Utils/Proxy.hs +++ /dev/null @@ -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 - } diff --git a/src/Data/Morpheus/Server/Deriving/Utils/Types.hs b/src/Data/Morpheus/Server/Deriving/Utils/Types.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Server/Deriving/Utils/Types.hs @@ -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 diff --git a/src/Data/Morpheus/Server/Deriving/Utils/Use.hs b/src/Data/Morpheus/Server/Deriving/Utils/Use.hs --- a/src/Data/Morpheus/Server/Deriving/Utils/Use.hs +++ b/src/Data/Morpheus/Server/Deriving/Utils/Use.hs @@ -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 diff --git a/src/Data/Morpheus/Server/Types.hs b/src/Data/Morpheus/Server/Types.hs --- a/src/Data/Morpheus/Server/Types.hs +++ b/src/Data/Morpheus/Server/Types.hs @@ -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, diff --git a/src/Data/Morpheus/Server/Types/DirectiveDefinitions.hs b/src/Data/Morpheus/Server/Types/DirectiveDefinitions.hs --- a/src/Data/Morpheus/Server/Types/DirectiveDefinitions.hs +++ b/src/Data/Morpheus/Server/Types/DirectiveDefinitions.hs @@ -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 diff --git a/src/Data/Morpheus/Server/Types/Directives.hs b/src/Data/Morpheus/Server/Types/Directives.hs --- a/src/Data/Morpheus/Server/Types/Directives.hs +++ b/src/Data/Morpheus/Server/Types/Directives.hs @@ -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) diff --git a/src/Data/Morpheus/Server/Types/GQLType.hs b/src/Data/Morpheus/Server/Types/GQLType.hs --- a/src/Data/Morpheus/Server/Types/GQLType.hs +++ b/src/Data/Morpheus/Server/Types/GQLType.hs @@ -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 = diff --git a/src/Data/Morpheus/Server/Types/Kind.hs b/src/Data/Morpheus/Server/Types/Kind.hs --- a/src/Data/Morpheus/Server/Types/Kind.hs +++ b/src/Data/Morpheus/Server/Types/Kind.hs @@ -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 diff --git a/src/Data/Morpheus/Server/Types/NamedResolvers.hs b/src/Data/Morpheus/Server/Types/NamedResolvers.hs --- a/src/Data/Morpheus/Server/Types/NamedResolvers.hs +++ b/src/Data/Morpheus/Server/Types/NamedResolvers.hs @@ -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 diff --git a/src/Data/Morpheus/Server/Types/SchemaT.hs b/src/Data/Morpheus/Server/Types/SchemaT.hs deleted file mode 100644 --- a/src/Data/Morpheus/Server/Types/SchemaT.hs +++ /dev/null @@ -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 []) diff --git a/src/Data/Morpheus/Server/Types/TypeName.hs b/src/Data/Morpheus/Server/Types/TypeName.hs --- a/src/Data/Morpheus/Server/Types/TypeName.hs +++ b/src/Data/Morpheus/Server/Types/TypeName.hs @@ -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 diff --git a/test/Feature/Directive/Definition.hs b/test/Feature/Directive/Definition.hs --- a/test/Feature/Directive/Definition.hs +++ b/test/Feature/Directive/Definition.hs @@ -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 diff --git a/test/Feature/Directive/definition/introspect-directive/response.json b/test/Feature/Directive/definition/introspect-directive/response.json --- a/test/Feature/Directive/definition/introspect-directive/response.json +++ b/test/Feature/Directive/definition/introspect-directive/response.json @@ -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 } } diff --git a/test/Feature/Inference/Names.hs b/test/Feature/Inference/Names.hs new file mode 100644 --- /dev/null +++ b/test/Feature/Inference/Names.hs @@ -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 diff --git a/test/Feature/Inference/TypeGuards.hs b/test/Feature/Inference/TypeGuards.hs --- a/test/Feature/Inference/TypeGuards.hs +++ b/test/Feature/Inference/TypeGuards.hs @@ -26,7 +26,7 @@ ) import GHC.Generics (Generic) -data Character = Hydra +data Character = Character { name :: Text, age :: Int } diff --git a/test/Feature/Inference/names/reserved-names-introspection/query.gql b/test/Feature/Inference/names/reserved-names-introspection/query.gql new file mode 100644 --- /dev/null +++ b/test/Feature/Inference/names/reserved-names-introspection/query.gql @@ -0,0 +1,16 @@ +{ + query: __type(name: "Query") { + fields { + name + args { + name + } + } + } + + input: __type(name: "Input") { + inputFields { + name + } + } +} diff --git a/test/Feature/Inference/names/reserved-names-introspection/response.json b/test/Feature/Inference/names/reserved-names-introspection/response.json new file mode 100644 --- /dev/null +++ b/test/Feature/Inference/names/reserved-names-introspection/response.json @@ -0,0 +1,8 @@ +{ + "data": { + "query": { + "fields": [{ "name": "type", "args": [{ "name": "in" }] }] + }, + "input": { "inputFields": [{ "name": "data" }] } + } +} diff --git a/test/Feature/Inference/names/reserved-names-resolving/query.gql b/test/Feature/Inference/names/reserved-names-resolving/query.gql new file mode 100644 --- /dev/null +++ b/test/Feature/Inference/names/reserved-names-resolving/query.gql @@ -0,0 +1,3 @@ +{ + type(in: { data: "some data" }) +} diff --git a/test/Feature/Inference/names/reserved-names-resolving/response.json b/test/Feature/Inference/names/reserved-names-resolving/response.json new file mode 100644 --- /dev/null +++ b/test/Feature/Inference/names/reserved-names-resolving/response.json @@ -0,0 +1,5 @@ +{ + "data": { + "type": "some data" + } +} diff --git a/test/Feature/Inference/tagged-arguments-fail/introspection/response.json b/test/Feature/Inference/tagged-arguments-fail/introspection/response.json --- a/test/Feature/Inference/tagged-arguments-fail/introspection/response.json +++ b/test/Feature/Inference/tagged-arguments-fail/introspection/response.json @@ -2,6 +2,9 @@ "errors": [ { "message": "There can Be only One argument Named \"a2\"" + }, + { + "message": "There can Be only One argument Named \"a2\"" } ] } diff --git a/test/Feature/Inference/tagged-arguments-fail/resolving/response.json b/test/Feature/Inference/tagged-arguments-fail/resolving/response.json --- a/test/Feature/Inference/tagged-arguments-fail/resolving/response.json +++ b/test/Feature/Inference/tagged-arguments-fail/resolving/response.json @@ -2,6 +2,9 @@ "errors": [ { "message": "There can Be only One argument Named \"a2\"" + }, + { + "message": "There can Be only One argument Named \"a2\"" } ] } diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -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"