diff --git a/morpheus-graphql-client.cabal b/morpheus-graphql-client.cabal --- a/morpheus-graphql-client.cabal +++ b/morpheus-graphql-client.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: morpheus-graphql-client -version: 0.26.0 +version: 0.27.0 synopsis: Morpheus GraphQL Client description: Build GraphQL APIs with your favorite functional language! category: web, graphql, client @@ -94,7 +94,7 @@ , file-embed >=0.0.10 && <1.0.0 , modern-uri >=0.1.0.0 && <1.0.0 , morpheus-graphql-code-gen-utils - , morpheus-graphql-core >=0.26.0 && <0.27.0 + , morpheus-graphql-core >=0.27.0 && <0.28.0 , morpheus-graphql-subscriptions , mtl >=2.0.0 && <3.0.0 , prettyprinter >=1.7.0 && <2.0.0 @@ -137,7 +137,7 @@ , modern-uri >=0.1.0.0 && <1.0.0 , morpheus-graphql-client , morpheus-graphql-code-gen-utils - , morpheus-graphql-core >=0.26.0 && <0.27.0 + , morpheus-graphql-core >=0.27.0 && <0.28.0 , morpheus-graphql-subscriptions , mtl >=2.0.0 && <3.0.0 , prettyprinter >=1.7.0 && <2.0.0 diff --git a/src/Data/Morpheus/Client/CodeGen/Declare.hs b/src/Data/Morpheus/Client/CodeGen/Declare.hs --- a/src/Data/Morpheus/Client/CodeGen/Declare.hs +++ b/src/Data/Morpheus/Client/CodeGen/Declare.hs @@ -36,6 +36,7 @@ import Data.Morpheus.CodeGen.TH ( PrintDec (printDec), ) +import Data.Morpheus.CodeGen.Utils import Data.Morpheus.Core (parseRequest) import Data.Morpheus.Internal.Ext (GQLResult) import Data.Morpheus.Types.IO (GQLRequest (..)) @@ -57,9 +58,9 @@ clientTypeDeclarations schemaText (Just query) globalTypeDeclarations :: SchemaSource -> (TypeName -> Bool) -> Q [Dec] -globalTypeDeclarations src f = handleResult (parseSchema src >>= toGlobalDefinitions f) printDeclarations +globalTypeDeclarations src f = handleResult (parseSchema src >>= fmap fst . toGlobalDefinitions f) printDeclarations -parseClientTypeDeclarations :: SchemaSource -> Maybe Text -> GQLResult [ClientDeclaration] +parseClientTypeDeclarations :: SchemaSource -> Maybe Text -> GQLResult ([ClientDeclaration], Flags) parseClientTypeDeclarations schemaText (Just query) = do schemaDoc <- parseSchema schemaText executableDoc <- @@ -78,7 +79,7 @@ SchemaSource -> Maybe ExecutableSource -> Q [Dec] -clientTypeDeclarations src x = handleResult (parseClientTypeDeclarations src x) printDeclarations +clientTypeDeclarations src x = handleResult (fmap fst (parseClientTypeDeclarations src x)) printDeclarations {- ORMOLU_DISABLE -} -- | declares input, enum and scalar types for specified schema diff --git a/src/Data/Morpheus/Client/CodeGen/Interpreting/Core.hs b/src/Data/Morpheus/Client/CodeGen/Interpreting/Core.hs --- a/src/Data/Morpheus/Client/CodeGen/Interpreting/Core.hs +++ b/src/Data/Morpheus/Client/CodeGen/Interpreting/Core.hs @@ -1,6 +1,5 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} @@ -9,7 +8,7 @@ {-# LANGUAGE NoImplicitPrelude #-} module Data.Morpheus.Client.CodeGen.Interpreting.Core - ( LocalM (..), + ( LocalM, compileError, getType, typeFrom, @@ -18,7 +17,6 @@ defaultDerivations, warning, LocalContext (..), - runLocalM, withPosition, getNameByPath, registerFragment, @@ -26,6 +24,7 @@ removeDuplicates, clientConfig, lookupField, + lookupType, ) where @@ -41,10 +40,12 @@ TypeClassInstance (..), fromTypeName, ) +import Data.Morpheus.CodeGen.Utils + ( CodeGenT, + ) import Data.Morpheus.Core (Config (..), VALIDATION_MODE (WITHOUT_VARIABLES)) import Data.Morpheus.Internal.Ext - ( GQLResult, - Result (..), + ( Result (..), ) import Data.Morpheus.Internal.Utils ( empty, @@ -70,11 +71,11 @@ VALID, VariableDefinitions, internal, + lookupDataType, lookupDeprecated, lookupDeprecatedReason, mkTypeRef, msg, - typeDefinitions, ) import Data.Set (insert, member) import Relude hiding (empty) @@ -107,34 +108,21 @@ existFragment :: FragmentName -> LocalM Bool existFragment name = (name `member`) <$> asks ctxFragments -runLocalM :: LocalContext -> LocalM a -> GQLResult a -runLocalM context = flip runReaderT context . _runLocalM - withPosition :: Position -> LocalM a -> LocalM a withPosition pos = local (\ctx -> ctx {ctxPosition = Just pos}) -newtype LocalM a = LocalM - { _runLocalM :: - ReaderT - LocalContext - GQLResult - a - } - deriving - ( Functor, - Applicative, - Monad, - MonadReader LocalContext, - MonadError GQLError - ) +type LocalM a = CodeGenT LocalContext (Result GQLError) a compileError :: GQLError -> GQLError compileError x = internal $ "Unhandled Compile Time Error: \"" <> x <> "\" ;" +lookupType :: TypeName -> LocalM (Maybe (TypeDefinition ANY VALID)) +lookupType name = asks (lookupDataType name . ctxSchema) + getType :: TypeName -> LocalM (TypeDefinition ANY VALID) -getType typename = - asks (typeDefinitions . ctxSchema) - >>= selectBy (compileError $ " can't find Type" <> msg typename) typename +getType name = do + x <- lookupType name + maybe (throwError $ compileError $ " can't find Type" <> msg name) pure x typeFrom :: [FieldName] -> TypeDefinition a VALID -> CodeGenTypeName typeFrom path TypeDefinition {typeName, typeContent} = __typeFrom typeContent @@ -153,7 +141,7 @@ deprecationWarning f = traverse_ warning . toList . fmap (f . lookupDeprecatedReason) . lookupDeprecated warning :: GQLError -> LocalM () -warning w = LocalM $ lift $ Success {result = (), warnings = [w]} +warning w = lift $ Success {result = (), warnings = [w]} defaultDerivations :: [DerivingClass] defaultDerivations = [GENERIC, SHOW, CLASS_EQ] diff --git a/src/Data/Morpheus/Client/CodeGen/Interpreting/Global.hs b/src/Data/Morpheus/Client/CodeGen/Interpreting/Global.hs --- a/src/Data/Morpheus/Client/CodeGen/Interpreting/Global.hs +++ b/src/Data/Morpheus/Client/CodeGen/Interpreting/Global.hs @@ -1,6 +1,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE NoImplicitPrelude #-} @@ -27,6 +28,7 @@ FIELD_TYPE_WRAPPER (..), fromTypeName, ) +import Data.Morpheus.CodeGen.Utils (Flag (FlagLanguageExtension), Flags) import Data.Morpheus.Internal.Ext (GQLResult) import Data.Morpheus.Types.Internal.AST ( ANY, @@ -48,18 +50,18 @@ toClientDeclarations :: ClientTypeDefinition -> [ClientPreDeclaration] toClientDeclarations def@ClientTypeDefinition {clientKind} - | KindScalar == clientKind = [FromJSONClass SCALAR_MODE cgType, ToJSONClass SCALAR_MODE cgType] - | KindEnum == clientKind = [ClientType cgType, FromJSONClass ENUM_MODE cgType, ToJSONClass ENUM_MODE cgType] + | KIND_SCALAR == clientKind = [FromJSONClass SCALAR_MODE cgType, ToJSONClass SCALAR_MODE cgType] + | KIND_ENUM == clientKind = [ClientType cgType, FromJSONClass ENUM_MODE cgType, ToJSONClass ENUM_MODE cgType] | otherwise = [ClientType cgType, ToJSONClass TYPE_MODE cgType] where cgType = printClientType def -toGlobalDefinitions :: (TypeName -> Bool) -> Schema VALID -> GQLResult [ClientDeclaration] -toGlobalDefinitions f Schema {types} = - traverse mapPreDeclarations $ - concatMap toClientDeclarations $ - mapMaybe generateGlobalType $ - filter shouldInclude (sortWith typeName $ toList types) +toGlobalDefinitions :: (TypeName -> Bool) -> Schema VALID -> GQLResult ([ClientDeclaration], Flags) +toGlobalDefinitions f Schema {types} = do + let tyDefs = mapMaybe generateGlobalType $ filter shouldInclude (sortWith typeName $ toList types) + decs <- traverse mapPreDeclarations $ concatMap toClientDeclarations tyDefs + let hasEnums = not $ null [x | x@ClientTypeDefinition {clientKind = KIND_ENUM} <- tyDefs] + pure (decs, [FlagLanguageExtension "LambdaCase" | hasEnums]) where shouldInclude t = not (isResolverType t) @@ -79,15 +81,15 @@ genContent :: TypeContent TRUE ANY VALID -> Maybe (TypeKind, [CodeGenConstructor]) genContent (DataInputObject inputFields) = pure - ( KindInputObject, + ( KIND_INPUT_OBJECT, [ CodeGenConstructor { constructorName = fromTypeName typeName, constructorFields = toCodeGenField <$> toList inputFields } ] ) - genContent (DataEnum enumTags) = pure (KindEnum, mkConsEnum typeName <$> enumTags) - genContent DataScalar {} = pure (KindScalar, []) + genContent (DataEnum enumTags) = pure (KIND_ENUM, mkConsEnum typeName <$> enumTags) + genContent DataScalar {} = pure (KIND_SCALAR, []) genContent _ = Nothing toCodeGenField :: FieldDefinition a b -> CodeGenField diff --git a/src/Data/Morpheus/Client/CodeGen/Interpreting/Local.hs b/src/Data/Morpheus/Client/CodeGen/Interpreting/Local.hs --- a/src/Data/Morpheus/Client/CodeGen/Interpreting/Local.hs +++ b/src/Data/Morpheus/Client/CodeGen/Interpreting/Local.hs @@ -21,7 +21,7 @@ import Data.Morpheus.Client.CodeGen.Interpreting.Arguments (genArguments) import Data.Morpheus.Client.CodeGen.Interpreting.Core ( LocalContext (..), - LocalM (..), + LocalM, clientConfig, defaultDerivations, deprecationWarning, @@ -29,16 +29,30 @@ getNameByPath, getType, lookupField, + lookupType, registerFragment, removeDuplicates, - runLocalM, typeFrom, warning, ) import Data.Morpheus.Client.CodeGen.Interpreting.PreDeclarations ( mapPreDeclarations, ) -import Data.Morpheus.CodeGen.Internal.AST (CodeGenConstructor (..), CodeGenField (..), CodeGenType (..), CodeGenTypeName (..), FIELD_TYPE_WRAPPER (..), fromTypeName, getFullName) +import Data.Morpheus.CodeGen.Internal.AST + ( CodeGenConstructor (..), + CodeGenField (..), + CodeGenType (..), + CodeGenTypeName (..), + FIELD_TYPE_WRAPPER (..), + fromTypeName, + getFullName, + ) +import Data.Morpheus.CodeGen.Utils + ( Flags, + langExtension, + requireExternal, + runCodeGenT, + ) import Data.Morpheus.Core (validateRequest) import Data.Morpheus.Error (deprecatedField) import Data.Morpheus.Internal.Ext @@ -62,6 +76,7 @@ SelectionContent (..), SelectionSet, TypeDefinition (..), + TypeKind (..), TypeName, TypeRef (..), UnionTag (..), @@ -70,6 +85,7 @@ getOperationDataType, getOperationName, isNullable, + kindOf, msg, toAny, unpackName, @@ -79,7 +95,7 @@ import qualified Data.Text as T import Relude hiding (empty, show) -toLocalDefinitions :: (Text, ExecutableDocument) -> Schema VALID -> GQLResult [ClientDeclaration] +toLocalDefinitions :: (Text, ExecutableDocument) -> Schema VALID -> GQLResult ([ClientDeclaration], Flags) toLocalDefinitions (query, request) ctxSchema = do validOperation <- validateRequest clientConfig ctxSchema request let context = @@ -89,8 +105,9 @@ ctxPosition = Nothing, ctxFragments = mempty } - x <- runLocalM context $ genLocalDeclarations query validOperation - removeDuplicates <$> traverse mapPreDeclarations x + (t, flags) <- runCodeGenT (genLocalDeclarations query validOperation) context + types <- removeDuplicates <$> traverse mapPreDeclarations t + pure (types, flags) genLocalDeclarations :: Text -> Operation VALID -> LocalM [ClientPreDeclaration] genLocalDeclarations query op@Operation {operationName, operationSelection, operationType} = do @@ -124,7 +141,11 @@ TypeDefinition ANY VALID -> Selection VALID -> LocalM (CodeGenTypeName, [ClientPreDeclaration]) -subTypesBySelection name _ _ Selection {selectionContent = SelectionField} = pure (fromTypeName name, []) +subTypesBySelection name _ _ Selection {selectionContent = SelectionField} = do + kind <- fmap kindOf <$> lookupType name + if null kind || kind == Just KIND_SCALAR + then requireExternal (unpackName name) $> (fromTypeName name, []) + else pure (fromTypeName name, []) subTypesBySelection _ path dType Selection {selectionContent = SelectionSet selectionSet} = genLocalTypes path (getFullName $ typeFrom [] dType) dType selectionSet subTypesBySelection _ namespace dType Selection {selectionPosition, selectionContent = UnionSelection interface unionSelections} = @@ -135,6 +156,7 @@ (cons, subTypes) <- unzip <$> traverse (getVariant namespace) variants (fallbackCons, fallBackTypes) <- maybe (getEmptyFallback cgTypeName) (getVariant namespace . UnionTag (typeName dType)) interface let typeDef = CodeGenType {cgTypeName, cgConstructors = map buildVariantConstructor (cons <> [fallbackCons]), cgDerivations = defaultDerivations} + langExtension "LambdaCase" pure (cgTypeName, [ClientType typeDef, FromJSONUnionClass cgTypeName (map tagConstructor cons <> [(UVar "_fallback", mapFallback fallbackCons)])] <> concat subTypes <> fallBackTypes) where tagConstructor (name, x) = (UString $ typename name, (name, fmap (const "v") x)) diff --git a/src/Data/Morpheus/Client/Fetch/RequestType.hs b/src/Data/Morpheus/Client/Fetch/RequestType.hs --- a/src/Data/Morpheus/Client/Fetch/RequestType.hs +++ b/src/Data/Morpheus/Client/Fetch/RequestType.hs @@ -40,7 +40,7 @@ ) import Data.Morpheus.Types.Internal.AST ( FieldName, - OperationType (Subscription), + OperationType (..), ) import Data.Text ( pack, @@ -80,4 +80,4 @@ newtype Request (a :: Type) = Request {requestArgs :: RequestArgs a} isSubscription :: RequestType a => Request a -> Bool -isSubscription x = __type x == Subscription +isSubscription x = __type x == OPERATION_SUBSCRIPTION diff --git a/src/Data/Morpheus/Client/Schema/JSON/Parse.hs b/src/Data/Morpheus/Client/Schema/JSON/Parse.hs --- a/src/Data/Morpheus/Client/Schema/JSON/Parse.hs +++ b/src/Data/Morpheus/Client/Schema/JSON/Parse.hs @@ -113,9 +113,9 @@ SchemaDefinition empty <$> fromElems ( catMaybes - [ Just (RootOperationTypeDefinition Query $ Ref.name queryType), - RootOperationTypeDefinition Mutation . Ref.name <$> mutationType, - RootOperationTypeDefinition Subscription . Ref.name <$> subscriptionType + [ Just (RootOperationTypeDefinition OPERATION_QUERY $ Ref.name queryType), + RootOperationTypeDefinition OPERATION_MUTATION . Ref.name <$> mutationType, + RootOperationTypeDefinition OPERATION_SUBSCRIPTION . Ref.name <$> subscriptionType ] )