diff --git a/CLI/Main.hs b/CLI/Main.hs deleted file mode 100644 --- a/CLI/Main.hs +++ /dev/null @@ -1,73 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} - -module Main - ( main - ) where - -import qualified Data.ByteString.Lazy as L (readFile, writeFile) -import Data.Semigroup ((<>)) -import Data.Version (showVersion) -import Options.Applicative (Parser, command, customExecParser, fullDesc, help, helper, info, long, metavar, - prefs, progDesc, short, showHelpOnError, strArgument, subparser, switch) -import qualified Options.Applicative as OA -import Paths_morpheus_graphql (version) -import System.FilePath.Posix (takeBaseName) - --- MORPHEUS -import Data.Morpheus.Document (toMorpheusHaskellAPi) - -morpheusVersion :: String -morpheusVersion = showVersion version - -main :: IO () -main = defaultParser >>= buildHaskellApi - where - buildHaskellApi Options {optionCommand} = executeCommand optionCommand - where - executeCommand About = putStrLn $ "Morpheus GraphQL CLI, version " <> morpheusVersion - executeCommand Build {source, target} = - toMorpheusHaskellAPi (takeBaseName target) <$> L.readFile source >>= saveDocument - where - saveDocument (Left errors) = print errors - saveDocument (Right doc) = L.writeFile target doc - -data Command - = Build { source :: FilePath - , target :: FilePath } - | About - deriving (Show) - -data Options = Options - { optionVerbose :: Bool - , optionCommand :: Command - } deriving (Show) - -data Behavior = Behavior - { bName :: String - , bValue :: Parser Command - , bDesc :: String - } - -defaultParser :: IO Options -defaultParser = customExecParser (prefs showHelpOnError) (info (helper <*> optionParser) morpheusDescription) - where - morpheusDescription = fullDesc <> progDesc "Morpheus GraphQL CLI - haskell Api Generator" - ----------------------------------------------------- - optionParser :: OA.Parser Options - optionParser = Options <$> versionParser <*> commandParser - where - versionParser = switch (long "version" <> short 'v' <> help "show Version number") - ---------------------------------------------------------------------------------------------- - commandParser = subparser $ foldr ((<>) . produceCommand) mempty commands - where - pathParser label = strArgument $ metavar label <> help (label <> " file") - produceCommand Behavior {bName, bValue, bDesc} = - command bName (info (helper <*> bValue) (fullDesc <> progDesc bDesc)) - commands = - [ Behavior - { bName = "build" - , bValue = pure Build <*> pathParser "Source.gql" <*> pathParser "Target.hs" - , bDesc = "builds haskell API from from GhraphQL schema \"*.gql\" " - } - , Behavior {bName = "about", bValue = pure About, bDesc = "api information"} - ] diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -29,7 +29,7 @@ resolver: lts-14.8 extra-deps: - - morpheus-graphql-0.5.0 + - morpheus-graphql-0.6.0 ``` As Morpheus is quite new, make sure stack can find morpheus-graphql by running `stack upgrade` and `stack update` @@ -80,7 +80,7 @@ GQLRootResolver { queryResolver = Query {queryDeity}, - mutationResolver = Undefined, + mutationResolver = Undefined, subscriptionResolver = Undefined } where @@ -137,8 +137,8 @@ The field name in the final request will be `type` instead of `type'`. The Morpheus request parser converts each of the reserved identities in Haskell 2010 to their corresponding names internally. This also applies to selections. ```haskell -resolveDeity :: DeityArgs -> IORes Deity -resolveDeity args = QueryResolver $ ExceptT $ askDB (name args) (mythology args) +resolveDeity :: DeityArgs -> IORes e Deity +resolveDeity DeityArgs { name, mythology } = liftEitherM $ dbDeity name mythology askDB :: Text -> Maybe Text -> IO (Either String Deity) askDB = ... @@ -201,7 +201,7 @@ Mythology API is deployed on : [_api.morpheusgraphql.com_](https://api.morpheusgraphql.com) where you can test it with `GraphiQL` -![Mythology Api](./assets/img/mythology-api.png "mythology-api") +![Mythology Api](https://morpheusgraphql.com/assets/img/mythology-api.png "mythology-api") ## Advanced topics @@ -274,9 +274,9 @@ screenshots from `Insomnia` -![alt text](./assets/img/introspection/spelling.png "spelling") -![alt text](./assets/img/introspection/autocomplete.png "autocomplete") -![alt text](./assets/img/introspection/type.png "type") +![alt text](https://morpheusgraphql.com/assets/img/introspection/spelling.png "spelling") +![alt text](https://morpheusgraphql.com/assets/img/introspection/autocomplete.png "autocomplete") +![alt text](https://morpheusgraphql.com/assets/img/introspection/type.png "type") ### Mutations @@ -344,7 +344,7 @@ } where createDeity _args = MutResolver events updateDeity - where + where events = [Event {channels = [ChannelA], content = ContentA 1}] updateDeity = updateDBDeity newDeity _args = SubResolver [ChannelA] subResolver @@ -437,14 +437,7 @@ ## Morpheus CLI for Code Generating -Generating dummy Morpheus Api from `schema.gql` - -``` -morpheus build src/schem.gql src/GQLApi.hs -``` - -this command will generate Haskell API and resolvers, -resolvers will resolve default values for every object +you should use [morpheus-graphql-cli](https://github.com/morpheusgraphql/morpheus-graphql-cli) # About diff --git a/assets/introspection.json b/assets/introspection.json deleted file mode 100644 --- a/assets/introspection.json +++ /dev/null @@ -1,1829 +0,0 @@ -{ - "data": { - "__schema": { - "queryType": { - "name": "Query" - }, - "mutationType": { - "name": "Mutation" - }, - "subscriptionType": { - "name": "Subscription" - }, - "types": [ - { - "kind": "OBJECT", - "name": "Query", - "description": "", - "fields": [ - { - "name": "user", - "description": null, - "args": [], - "type": { - "kind": "NON_NULL", - "name": null, - "ofType": { - "kind": "OBJECT", - "name": "User", - "ofType": null - } - }, - "isDeprecated": false, - "deprecationReason": null - }, - { - "name": "wrappedA1", - "description": null, - "args": [], - "type": { - "kind": "NON_NULL", - "name": null, - "ofType": { - "kind": "OBJECT", - "name": "A_Pair_Int_Text", - "ofType": null - } - }, - "isDeprecated": false, - "deprecationReason": null - }, - { - "name": "setAnimal", - "description": null, - "args": [ - { - "name": "animal", - "description": null, - "type": { - "kind": "NON_NULL", - "name": null, - "ofType": { - "kind": "INPUT_OBJECT", - "name": "Animal", - "ofType": null - } - }, - "defaultValue": null - } - ], - "type": { - "kind": "NON_NULL", - "name": null, - "ofType": { - "kind": "SCALAR", - "name": "String", - "ofType": null - } - }, - "isDeprecated": false, - "deprecationReason": null - }, - { - "name": "wrappedA2", - "description": null, - "args": [], - "type": { - "kind": "NON_NULL", - "name": null, - "ofType": { - "kind": "OBJECT", - "name": "A_Text", - "ofType": null - } - }, - "isDeprecated": false, - "deprecationReason": null - }, - { - "name": "integerSet", - "description": null, - "args": [], - "type": { - "kind": "NON_NULL", - "name": null, - "ofType": { - "kind": "LIST", - "name": null, - "ofType": { - "kind": "NON_NULL", - "name": null, - "ofType": { - "kind": "SCALAR", - "name": "Int", - "ofType": null - } - } - } - }, - "isDeprecated": false, - "deprecationReason": null - }, - { - "name": "textIntMap", - "description": null, - "args": [], - "type": { - "kind": "NON_NULL", - "name": null, - "ofType": { - "kind": "OBJECT", - "name": "MapKind_Text_Int", - "ofType": null - } - }, - "isDeprecated": false, - "deprecationReason": null - } - ], - "inputFields": null, - "interfaces": [], - "enumValues": null, - "possibleTypes": null - }, - { - "kind": "OBJECT", - "name": "Mutation", - "description": "", - "fields": [ - { - "name": "createUser", - "description": null, - "args": [], - "type": { - "kind": "NON_NULL", - "name": null, - "ofType": { - "kind": "OBJECT", - "name": "User", - "ofType": null - } - }, - "isDeprecated": false, - "deprecationReason": null - }, - { - "name": "createAddress", - "description": null, - "args": [], - "type": { - "kind": "NON_NULL", - "name": null, - "ofType": { - "kind": "OBJECT", - "name": "Address", - "ofType": null - } - }, - "isDeprecated": false, - "deprecationReason": null - } - ], - "inputFields": null, - "interfaces": [], - "enumValues": null, - "possibleTypes": null - }, - { - "kind": "OBJECT", - "name": "Subscription", - "description": "", - "fields": [ - { - "name": "newAddress", - "description": null, - "args": [], - "type": { - "kind": "NON_NULL", - "name": null, - "ofType": { - "kind": "OBJECT", - "name": "Address", - "ofType": null - } - }, - "isDeprecated": false, - "deprecationReason": null - }, - { - "name": "newUser", - "description": null, - "args": [], - "type": { - "kind": "NON_NULL", - "name": null, - "ofType": { - "kind": "OBJECT", - "name": "User", - "ofType": null - } - }, - "isDeprecated": false, - "deprecationReason": null - } - ], - "inputFields": null, - "interfaces": [], - "enumValues": null, - "possibleTypes": null - }, - { - "kind": "ENUM", - "name": "AnimalTags", - "description": "", - "fields": null, - "inputFields": null, - "interfaces": null, - "enumValues": [ - { - "name": "Cat", - "description": null, - "isDeprecated": false, - "deprecationReason": null - }, - { - "name": "Dog", - "description": null, - "isDeprecated": false, - "deprecationReason": null - }, - { - "name": "Bird", - "description": null, - "isDeprecated": false, - "deprecationReason": null - } - ], - "possibleTypes": null - }, - { - "kind": "ENUM", - "name": "CityID", - "description": "", - "fields": null, - "inputFields": null, - "interfaces": null, - "enumValues": [ - { - "name": "Paris", - "description": null, - "isDeprecated": false, - "deprecationReason": null - }, - { - "name": "BLN", - "description": null, - "isDeprecated": false, - "deprecationReason": null - }, - { - "name": "HH", - "description": null, - "isDeprecated": false, - "deprecationReason": null - } - ], - "possibleTypes": null - }, - { - "kind": "SCALAR", - "name": "Euro", - "description": "", - "fields": null, - "inputFields": null, - "interfaces": null, - "enumValues": null, - "possibleTypes": null - }, - { - "kind": "ENUM", - "name": "__DirectiveLocation", - "description": "", - "fields": null, - "inputFields": null, - "interfaces": null, - "enumValues": [ - { - "name": "QUERY", - "description": null, - "isDeprecated": false, - "deprecationReason": null - }, - { - "name": "MUTATION", - "description": null, - "isDeprecated": false, - "deprecationReason": null - }, - { - "name": "SUBSCRIPTION", - "description": null, - "isDeprecated": false, - "deprecationReason": null - }, - { - "name": "FIELD", - "description": null, - "isDeprecated": false, - "deprecationReason": null - }, - { - "name": "FRAGMENT_DEFINITION", - "description": null, - "isDeprecated": false, - "deprecationReason": null - }, - { - "name": "FRAGMENT_SPREAD", - "description": null, - "isDeprecated": false, - "deprecationReason": null - }, - { - "name": "INLINE_FRAGMENT", - "description": null, - "isDeprecated": false, - "deprecationReason": null - }, - { - "name": "VARIABLE_DEFINITION", - "description": null, - "isDeprecated": false, - "deprecationReason": null - }, - { - "name": "SCHEMA", - "description": null, - "isDeprecated": false, - "deprecationReason": null - }, - { - "name": "SCALAR", - "description": null, - "isDeprecated": false, - "deprecationReason": null - }, - { - "name": "OBJECT", - "description": null, - "isDeprecated": false, - "deprecationReason": null - }, - { - "name": "FIELD_DEFINITION", - "description": null, - "isDeprecated": false, - "deprecationReason": null - }, - { - "name": "ARGUMENT_DEFINITION", - "description": null, - "isDeprecated": false, - "deprecationReason": null - }, - { - "name": "INTERFACE", - "description": null, - "isDeprecated": false, - "deprecationReason": null - }, - { - "name": "UNION", - "description": null, - "isDeprecated": false, - "deprecationReason": null - }, - { - "name": "ENUM", - "description": null, - "isDeprecated": false, - "deprecationReason": null - }, - { - "name": "ENUM_VALUE", - "description": null, - "isDeprecated": false, - "deprecationReason": null - }, - { - "name": "INPUT_OBJECT", - "description": null, - "isDeprecated": false, - "deprecationReason": null - }, - { - "name": "INPUT_FIELD_DEFINITION", - "description": null, - "isDeprecated": false, - "deprecationReason": null - } - ], - "possibleTypes": null - }, - { - "kind": "ENUM", - "name": "__TypeKind", - "description": "", - "fields": null, - "inputFields": null, - "interfaces": null, - "enumValues": [ - { - "name": "SCALAR", - "description": null, - "isDeprecated": false, - "deprecationReason": null - }, - { - "name": "OBJECT", - "description": null, - "isDeprecated": false, - "deprecationReason": null - }, - { - "name": "INTERFACE", - "description": null, - "isDeprecated": false, - "deprecationReason": null - }, - { - "name": "UNION", - "description": null, - "isDeprecated": false, - "deprecationReason": null - }, - { - "name": "ENUM", - "description": null, - "isDeprecated": false, - "deprecationReason": null - }, - { - "name": "INPUT_OBJECT", - "description": null, - "isDeprecated": false, - "deprecationReason": null - }, - { - "name": "LIST", - "description": null, - "isDeprecated": false, - "deprecationReason": null - }, - { - "name": "NON_NULL", - "description": null, - "isDeprecated": false, - "deprecationReason": null - } - ], - "possibleTypes": null - }, - { - "kind": "SCALAR", - "name": "ID", - "description": "", - "fields": null, - "inputFields": null, - "interfaces": null, - "enumValues": null, - "possibleTypes": null - }, - { - "kind": "SCALAR", - "name": "String", - "description": "", - "fields": null, - "inputFields": null, - "interfaces": null, - "enumValues": null, - "possibleTypes": null - }, - { - "kind": "SCALAR", - "name": "Float", - "description": "", - "fields": null, - "inputFields": null, - "interfaces": null, - "enumValues": null, - "possibleTypes": null - }, - { - "kind": "SCALAR", - "name": "Int", - "description": "", - "fields": null, - "inputFields": null, - "interfaces": null, - "enumValues": null, - "possibleTypes": null - }, - { - "kind": "SCALAR", - "name": "Boolean", - "description": "", - "fields": null, - "inputFields": null, - "interfaces": null, - "enumValues": null, - "possibleTypes": null - }, - { - "kind": "INPUT_OBJECT", - "name": "Bird", - "description": "", - "fields": null, - "inputFields": [ - { - "name": "birdName", - "description": null, - "type": { - "kind": "NON_NULL", - "name": null, - "ofType": { - "kind": "SCALAR", - "name": "String", - "ofType": null - } - }, - "defaultValue": null - } - ], - "interfaces": null, - "enumValues": null, - "possibleTypes": null - }, - { - "kind": "INPUT_OBJECT", - "name": "Dog", - "description": "", - "fields": null, - "inputFields": [ - { - "name": "dogName", - "description": null, - "type": { - "kind": "NON_NULL", - "name": null, - "ofType": { - "kind": "SCALAR", - "name": "String", - "ofType": null - } - }, - "defaultValue": null - } - ], - "interfaces": null, - "enumValues": null, - "possibleTypes": null - }, - { - "kind": "INPUT_OBJECT", - "name": "Cat", - "description": "", - "fields": null, - "inputFields": [ - { - "name": "catName", - "description": null, - "type": { - "kind": "NON_NULL", - "name": null, - "ofType": { - "kind": "SCALAR", - "name": "String", - "ofType": null - } - }, - "defaultValue": null - } - ], - "interfaces": null, - "enumValues": null, - "possibleTypes": null - }, - { - "kind": "INPUT_OBJECT", - "name": "UniqueID", - "description": "", - "fields": null, - "inputFields": [ - { - "name": "uid", - "description": null, - "type": { - "kind": "NON_NULL", - "name": null, - "ofType": { - "kind": "SCALAR", - "name": "String", - "ofType": null - } - }, - "defaultValue": null - } - ], - "interfaces": null, - "enumValues": null, - "possibleTypes": null - }, - { - "kind": "INPUT_OBJECT", - "name": "Coordinates", - "description": "just random latitude and longitude", - "fields": null, - "inputFields": [ - { - "name": "latitude", - "description": null, - "type": { - "kind": "NON_NULL", - "name": null, - "ofType": { - "kind": "SCALAR", - "name": "Euro", - "ofType": null - } - }, - "defaultValue": null - }, - { - "name": "longitude", - "description": null, - "type": { - "kind": "NON_NULL", - "name": null, - "ofType": { - "kind": "LIST", - "name": null, - "ofType": { - "kind": "LIST", - "name": null, - "ofType": { - "kind": "NON_NULL", - "name": null, - "ofType": { - "kind": "LIST", - "name": null, - "ofType": { - "kind": "NON_NULL", - "name": null, - "ofType": { - "kind": "INPUT_OBJECT", - "name": "UniqueID", - "ofType": null - } - } - } - } - } - } - }, - "defaultValue": null - } - ], - "interfaces": null, - "enumValues": null, - "possibleTypes": null - }, - { - "kind": "INPUT_OBJECT", - "name": "Animal", - "description": "", - "fields": null, - "inputFields": [ - { - "name": "tag", - "description": null, - "type": { - "kind": "NON_NULL", - "name": null, - "ofType": { - "kind": "ENUM", - "name": "AnimalTags", - "ofType": null - } - }, - "defaultValue": null - }, - { - "name": "Cat", - "description": null, - "type": { - "kind": "INPUT_OBJECT", - "name": "Cat", - "ofType": null - }, - "defaultValue": null - }, - { - "name": "Dog", - "description": null, - "type": { - "kind": "INPUT_OBJECT", - "name": "Dog", - "ofType": null - }, - "defaultValue": null - }, - { - "name": "Bird", - "description": null, - "type": { - "kind": "INPUT_OBJECT", - "name": "Bird", - "ofType": null - }, - "defaultValue": null - } - ], - "interfaces": null, - "enumValues": null, - "possibleTypes": null - }, - { - "kind": "OBJECT", - "name": "Pair_Text_Int", - "description": "", - "fields": [ - { - "name": "key", - "description": null, - "args": [], - "type": { - "kind": "NON_NULL", - "name": null, - "ofType": { - "kind": "SCALAR", - "name": "String", - "ofType": null - } - }, - "isDeprecated": false, - "deprecationReason": null - }, - { - "name": "value", - "description": null, - "args": [], - "type": { - "kind": "NON_NULL", - "name": null, - "ofType": { - "kind": "SCALAR", - "name": "Int", - "ofType": null - } - }, - "isDeprecated": false, - "deprecationReason": null - } - ], - "inputFields": null, - "interfaces": [], - "enumValues": null, - "possibleTypes": null - }, - { - "kind": "OBJECT", - "name": "MapKind_Text_Int", - "description": "", - "fields": [ - { - "name": "size", - "description": null, - "args": [], - "type": { - "kind": "NON_NULL", - "name": null, - "ofType": { - "kind": "SCALAR", - "name": "Int", - "ofType": null - } - }, - "isDeprecated": false, - "deprecationReason": null - }, - { - "name": "pairs", - "description": null, - "args": [ - { - "name": "oneOf", - "description": null, - "type": { - "kind": "LIST", - "name": null, - "ofType": { - "kind": "NON_NULL", - "name": null, - "ofType": { - "kind": "SCALAR", - "name": "String", - "ofType": null - } - } - }, - "defaultValue": null - } - ], - "type": { - "kind": "NON_NULL", - "name": null, - "ofType": { - "kind": "LIST", - "name": null, - "ofType": { - "kind": "NON_NULL", - "name": null, - "ofType": { - "kind": "OBJECT", - "name": "Pair_Text_Int", - "ofType": null - } - } - } - }, - "isDeprecated": false, - "deprecationReason": null - } - ], - "inputFields": null, - "interfaces": [], - "enumValues": null, - "possibleTypes": null - }, - { - "kind": "OBJECT", - "name": "A_Text", - "description": "", - "fields": [ - { - "name": "wrappedA", - "description": null, - "args": [], - "type": { - "kind": "NON_NULL", - "name": null, - "ofType": { - "kind": "SCALAR", - "name": "String", - "ofType": null - } - }, - "isDeprecated": false, - "deprecationReason": null - } - ], - "inputFields": null, - "interfaces": [], - "enumValues": null, - "possibleTypes": null - }, - { - "kind": "OBJECT", - "name": "Pair_Int_Text", - "description": "", - "fields": [ - { - "name": "key", - "description": null, - "args": [], - "type": { - "kind": "NON_NULL", - "name": null, - "ofType": { - "kind": "SCALAR", - "name": "Int", - "ofType": null - } - }, - "isDeprecated": false, - "deprecationReason": null - }, - { - "name": "value", - "description": null, - "args": [], - "type": { - "kind": "NON_NULL", - "name": null, - "ofType": { - "kind": "SCALAR", - "name": "String", - "ofType": null - } - }, - "isDeprecated": false, - "deprecationReason": null - } - ], - "inputFields": null, - "interfaces": [], - "enumValues": null, - "possibleTypes": null - }, - { - "kind": "OBJECT", - "name": "A_Pair_Int_Text", - "description": "", - "fields": [ - { - "name": "wrappedA", - "description": null, - "args": [], - "type": { - "kind": "NON_NULL", - "name": null, - "ofType": { - "kind": "OBJECT", - "name": "Pair_Int_Text", - "ofType": null - } - }, - "isDeprecated": false, - "deprecationReason": null - } - ], - "inputFields": null, - "interfaces": [], - "enumValues": null, - "possibleTypes": null - }, - { - "kind": "OBJECT", - "name": "Address", - "description": "", - "fields": [ - { - "name": "city", - "description": null, - "args": [], - "type": { - "kind": "NON_NULL", - "name": null, - "ofType": { - "kind": "SCALAR", - "name": "String", - "ofType": null - } - }, - "isDeprecated": false, - "deprecationReason": null - }, - { - "name": "street", - "description": null, - "args": [], - "type": { - "kind": "NON_NULL", - "name": null, - "ofType": { - "kind": "SCALAR", - "name": "String", - "ofType": null - } - }, - "isDeprecated": false, - "deprecationReason": null - }, - { - "name": "houseNumber", - "description": null, - "args": [], - "type": { - "kind": "NON_NULL", - "name": null, - "ofType": { - "kind": "SCALAR", - "name": "Int", - "ofType": null - } - }, - "isDeprecated": false, - "deprecationReason": null - } - ], - "inputFields": null, - "interfaces": [], - "enumValues": null, - "possibleTypes": null - }, - { - "kind": "OBJECT", - "name": "User", - "description": "Custom Description for Client Defined User Type", - "fields": [ - { - "name": "name", - "description": null, - "args": [], - "type": { - "kind": "NON_NULL", - "name": null, - "ofType": { - "kind": "SCALAR", - "name": "String", - "ofType": null - } - }, - "isDeprecated": false, - "deprecationReason": null - }, - { - "name": "email", - "description": null, - "args": [], - "type": { - "kind": "NON_NULL", - "name": null, - "ofType": { - "kind": "SCALAR", - "name": "String", - "ofType": null - } - }, - "isDeprecated": false, - "deprecationReason": null - }, - { - "name": "address", - "description": null, - "args": [ - { - "name": "coordinates", - "description": null, - "type": { - "kind": "NON_NULL", - "name": null, - "ofType": { - "kind": "INPUT_OBJECT", - "name": "Coordinates", - "ofType": null - } - }, - "defaultValue": null - }, - { - "name": "comment", - "description": null, - "type": { - "kind": "SCALAR", - "name": "String", - "ofType": null - }, - "defaultValue": null - } - ], - "type": { - "kind": "NON_NULL", - "name": null, - "ofType": { - "kind": "OBJECT", - "name": "Address", - "ofType": null - } - }, - "isDeprecated": false, - "deprecationReason": null - }, - { - "name": "office", - "description": null, - "args": [ - { - "name": "zipCode", - "description": null, - "type": { - "kind": "LIST", - "name": null, - "ofType": { - "kind": "NON_NULL", - "name": null, - "ofType": { - "kind": "LIST", - "name": null, - "ofType": { - "kind": "LIST", - "name": null, - "ofType": { - "kind": "NON_NULL", - "name": null, - "ofType": { - "kind": "SCALAR", - "name": "ID", - "ofType": null - } - } - } - } - } - }, - "defaultValue": null - }, - { - "name": "cityID", - "description": null, - "type": { - "kind": "NON_NULL", - "name": null, - "ofType": { - "kind": "ENUM", - "name": "CityID", - "ofType": null - } - }, - "defaultValue": null - } - ], - "type": { - "kind": "NON_NULL", - "name": null, - "ofType": { - "kind": "OBJECT", - "name": "Address", - "ofType": null - } - }, - "isDeprecated": false, - "deprecationReason": null - }, - { - "name": "myUnion", - "description": null, - "args": [], - "type": { - "kind": "NON_NULL", - "name": null, - "ofType": { - "kind": "UNION", - "name": "MyUnion", - "ofType": null - } - }, - "isDeprecated": false, - "deprecationReason": null - }, - { - "name": "home", - "description": null, - "args": [], - "type": { - "kind": "NON_NULL", - "name": null, - "ofType": { - "kind": "ENUM", - "name": "CityID", - "ofType": null - } - }, - "isDeprecated": false, - "deprecationReason": null - } - ], - "inputFields": null, - "interfaces": [], - "enumValues": null, - "possibleTypes": null - }, - { - "kind": "OBJECT", - "name": "__Directive", - "description": "", - "fields": [ - { - "name": "name", - "description": null, - "args": [], - "type": { - "kind": "NON_NULL", - "name": null, - "ofType": { - "kind": "SCALAR", - "name": "String", - "ofType": null - } - }, - "isDeprecated": false, - "deprecationReason": null - }, - { - "name": "description", - "description": null, - "args": [], - "type": { - "kind": "SCALAR", - "name": "String", - "ofType": null - }, - "isDeprecated": false, - "deprecationReason": null - }, - { - "name": "locations", - "description": null, - "args": [], - "type": { - "kind": "NON_NULL", - "name": null, - "ofType": { - "kind": "LIST", - "name": null, - "ofType": { - "kind": "NON_NULL", - "name": null, - "ofType": { - "kind": "ENUM", - "name": "__DirectiveLocation", - "ofType": null - } - } - } - }, - "isDeprecated": false, - "deprecationReason": null - }, - { - "name": "args", - "description": null, - "args": [], - "type": { - "kind": "NON_NULL", - "name": null, - "ofType": { - "kind": "LIST", - "name": null, - "ofType": { - "kind": "NON_NULL", - "name": null, - "ofType": { - "kind": "OBJECT", - "name": "__InputValue", - "ofType": null - } - } - } - }, - "isDeprecated": false, - "deprecationReason": null - } - ], - "inputFields": null, - "interfaces": [], - "enumValues": null, - "possibleTypes": null - }, - { - "kind": "OBJECT", - "name": "__EnumValue", - "description": "", - "fields": [ - { - "name": "name", - "description": null, - "args": [], - "type": { - "kind": "NON_NULL", - "name": null, - "ofType": { - "kind": "SCALAR", - "name": "String", - "ofType": null - } - }, - "isDeprecated": false, - "deprecationReason": null - }, - { - "name": "description", - "description": null, - "args": [], - "type": { - "kind": "SCALAR", - "name": "String", - "ofType": null - }, - "isDeprecated": false, - "deprecationReason": null - }, - { - "name": "isDeprecated", - "description": null, - "args": [], - "type": { - "kind": "NON_NULL", - "name": null, - "ofType": { - "kind": "SCALAR", - "name": "Boolean", - "ofType": null - } - }, - "isDeprecated": false, - "deprecationReason": null - }, - { - "name": "deprecationReason", - "description": null, - "args": [], - "type": { - "kind": "SCALAR", - "name": "String", - "ofType": null - }, - "isDeprecated": false, - "deprecationReason": null - } - ], - "inputFields": null, - "interfaces": [], - "enumValues": null, - "possibleTypes": null - }, - { - "kind": "OBJECT", - "name": "__InputValue", - "description": "", - "fields": [ - { - "name": "name", - "description": null, - "args": [], - "type": { - "kind": "NON_NULL", - "name": null, - "ofType": { - "kind": "SCALAR", - "name": "String", - "ofType": null - } - }, - "isDeprecated": false, - "deprecationReason": null - }, - { - "name": "description", - "description": null, - "args": [], - "type": { - "kind": "SCALAR", - "name": "String", - "ofType": null - }, - "isDeprecated": false, - "deprecationReason": null - }, - { - "name": "type", - "description": null, - "args": [], - "type": { - "kind": "NON_NULL", - "name": null, - "ofType": { - "kind": "OBJECT", - "name": "__Type", - "ofType": null - } - }, - "isDeprecated": false, - "deprecationReason": null - }, - { - "name": "defaultValue", - "description": null, - "args": [], - "type": { - "kind": "SCALAR", - "name": "String", - "ofType": null - }, - "isDeprecated": false, - "deprecationReason": null - } - ], - "inputFields": null, - "interfaces": [], - "enumValues": null, - "possibleTypes": null - }, - { - "kind": "OBJECT", - "name": "__Field", - "description": "", - "fields": [ - { - "name": "name", - "description": null, - "args": [], - "type": { - "kind": "NON_NULL", - "name": null, - "ofType": { - "kind": "SCALAR", - "name": "String", - "ofType": null - } - }, - "isDeprecated": false, - "deprecationReason": null - }, - { - "name": "description", - "description": null, - "args": [], - "type": { - "kind": "SCALAR", - "name": "String", - "ofType": null - }, - "isDeprecated": false, - "deprecationReason": null - }, - { - "name": "args", - "description": null, - "args": [], - "type": { - "kind": "NON_NULL", - "name": null, - "ofType": { - "kind": "LIST", - "name": null, - "ofType": { - "kind": "NON_NULL", - "name": null, - "ofType": { - "kind": "OBJECT", - "name": "__InputValue", - "ofType": null - } - } - } - }, - "isDeprecated": false, - "deprecationReason": null - }, - { - "name": "type", - "description": null, - "args": [], - "type": { - "kind": "NON_NULL", - "name": null, - "ofType": { - "kind": "OBJECT", - "name": "__Type", - "ofType": null - } - }, - "isDeprecated": false, - "deprecationReason": null - }, - { - "name": "isDeprecated", - "description": null, - "args": [], - "type": { - "kind": "NON_NULL", - "name": null, - "ofType": { - "kind": "SCALAR", - "name": "Boolean", - "ofType": null - } - }, - "isDeprecated": false, - "deprecationReason": null - }, - { - "name": "deprecationReason", - "description": null, - "args": [], - "type": { - "kind": "SCALAR", - "name": "String", - "ofType": null - }, - "isDeprecated": false, - "deprecationReason": null - } - ], - "inputFields": null, - "interfaces": [], - "enumValues": null, - "possibleTypes": null - }, - { - "kind": "OBJECT", - "name": "__Type", - "description": "", - "fields": [ - { - "name": "kind", - "description": null, - "args": [], - "type": { - "kind": "NON_NULL", - "name": null, - "ofType": { - "kind": "ENUM", - "name": "__TypeKind", - "ofType": null - } - }, - "isDeprecated": false, - "deprecationReason": null - }, - { - "name": "name", - "description": null, - "args": [], - "type": { - "kind": "SCALAR", - "name": "String", - "ofType": null - }, - "isDeprecated": false, - "deprecationReason": null - }, - { - "name": "description", - "description": null, - "args": [], - "type": { - "kind": "SCALAR", - "name": "String", - "ofType": null - }, - "isDeprecated": false, - "deprecationReason": null - }, - { - "name": "fields", - "description": null, - "args": [ - { - "name": "includeDeprecated", - "description": null, - "type": { - "kind": "SCALAR", - "name": "Boolean", - "ofType": null - }, - "defaultValue": null - } - ], - "type": { - "kind": "LIST", - "name": null, - "ofType": { - "kind": "NON_NULL", - "name": null, - "ofType": { - "kind": "OBJECT", - "name": "__Field", - "ofType": null - } - } - }, - "isDeprecated": false, - "deprecationReason": null - }, - { - "name": "interfaces", - "description": null, - "args": [], - "type": { - "kind": "LIST", - "name": null, - "ofType": { - "kind": "NON_NULL", - "name": null, - "ofType": { - "kind": "OBJECT", - "name": "__Type", - "ofType": null - } - } - }, - "isDeprecated": false, - "deprecationReason": null - }, - { - "name": "possibleTypes", - "description": null, - "args": [], - "type": { - "kind": "LIST", - "name": null, - "ofType": { - "kind": "NON_NULL", - "name": null, - "ofType": { - "kind": "OBJECT", - "name": "__Type", - "ofType": null - } - } - }, - "isDeprecated": false, - "deprecationReason": null - }, - { - "name": "enumValues", - "description": null, - "args": [ - { - "name": "includeDeprecated", - "description": null, - "type": { - "kind": "SCALAR", - "name": "Boolean", - "ofType": null - }, - "defaultValue": null - } - ], - "type": { - "kind": "LIST", - "name": null, - "ofType": { - "kind": "NON_NULL", - "name": null, - "ofType": { - "kind": "OBJECT", - "name": "__EnumValue", - "ofType": null - } - } - }, - "isDeprecated": false, - "deprecationReason": null - }, - { - "name": "inputFields", - "description": null, - "args": [], - "type": { - "kind": "LIST", - "name": null, - "ofType": { - "kind": "NON_NULL", - "name": null, - "ofType": { - "kind": "OBJECT", - "name": "__InputValue", - "ofType": null - } - } - }, - "isDeprecated": false, - "deprecationReason": null - }, - { - "name": "ofType", - "description": null, - "args": [], - "type": { - "kind": "OBJECT", - "name": "__Type", - "ofType": null - }, - "isDeprecated": false, - "deprecationReason": null - } - ], - "inputFields": null, - "interfaces": [], - "enumValues": null, - "possibleTypes": null - }, - { - "kind": "OBJECT", - "name": "__Schema", - "description": "", - "fields": [ - { - "name": "types", - "description": null, - "args": [], - "type": { - "kind": "NON_NULL", - "name": null, - "ofType": { - "kind": "LIST", - "name": null, - "ofType": { - "kind": "NON_NULL", - "name": null, - "ofType": { - "kind": "OBJECT", - "name": "__Type", - "ofType": null - } - } - } - }, - "isDeprecated": false, - "deprecationReason": null - }, - { - "name": "queryType", - "description": null, - "args": [], - "type": { - "kind": "NON_NULL", - "name": null, - "ofType": { - "kind": "OBJECT", - "name": "__Type", - "ofType": null - } - }, - "isDeprecated": false, - "deprecationReason": null - }, - { - "name": "mutationType", - "description": null, - "args": [], - "type": { - "kind": "OBJECT", - "name": "__Type", - "ofType": null - }, - "isDeprecated": false, - "deprecationReason": null - }, - { - "name": "subscriptionType", - "description": null, - "args": [], - "type": { - "kind": "OBJECT", - "name": "__Type", - "ofType": null - }, - "isDeprecated": false, - "deprecationReason": null - }, - { - "name": "directives", - "description": null, - "args": [], - "type": { - "kind": "NON_NULL", - "name": null, - "ofType": { - "kind": "LIST", - "name": null, - "ofType": { - "kind": "NON_NULL", - "name": null, - "ofType": { - "kind": "OBJECT", - "name": "__Directive", - "ofType": null - } - } - } - }, - "isDeprecated": false, - "deprecationReason": null - } - ], - "inputFields": null, - "interfaces": [], - "enumValues": null, - "possibleTypes": null - }, - { - "kind": "UNION", - "name": "MyUnion", - "description": "", - "fields": null, - "inputFields": null, - "interfaces": null, - "enumValues": null, - "possibleTypes": [ - { - "kind": "OBJECT", - "name": "User", - "ofType": null - }, - { - "kind": "OBJECT", - "name": "Address", - "ofType": null - } - ] - } - ], - "directives": [] - } - } -} diff --git a/assets/mut.gql b/assets/mut.gql deleted file mode 100644 --- a/assets/mut.gql +++ /dev/null @@ -1,40 +0,0 @@ -type Query { - deity (name: [[[[[String!]]!]]], mythology: String): Deity! - character (characterID: String! , age: Int ): Character! - hero: Human! -} - -type Mutation { - createDeity (deityName: [[[[[String!]]!]]], deityMythology: String): Deity! - createCharacter (charRealm: Realm! , charMutID: String! ): Character! -} - -union Character = Creature | Deity | Human - -type Deity { - fullName: String! - power: Power! -} - -type Creature { - creatureName: String! - realm: City! -} - -type Human { - humanName: String! - profession: String -} - -input Realm { - owner: String! - place: Int -} - -enum City { - Athens - Ithaca - Sparta Troy -} - -scalar Power diff --git a/assets/pubsub.gql b/assets/pubsub.gql deleted file mode 100644 --- a/assets/pubsub.gql +++ /dev/null @@ -1,46 +0,0 @@ -type Query { - deity (name: [[[[[String!]]!]]], mythology: String): Deity! - character (characterID: String! , age: Int ): Character! - hero: Human! -} - -type Mutation { - createDeity (deityName: [[[[[String!]]!]]], deityMythology: String): Deity! - createCharacter (charRealm: Realm! , charMutID: String! ): Character! -} - -type Subscription { - newDeity : Deity! - newCharacter : Character! -} - - -union Character = Creature | Deity | Human - -type Deity { - fullName: String! - power: Power! -} - -type Creature { - creatureName: String! - realm: City! -} - -type Human { - humanName: String! - profession: String -} - -input Realm { - owner: String! - place: Int -} - -enum City { - Athens - Ithaca - Sparta Troy -} - -scalar Power diff --git a/assets/simple.gql b/assets/simple.gql deleted file mode 100644 --- a/assets/simple.gql +++ /dev/null @@ -1,88 +0,0 @@ -""" -my interface description -""" -type Query { - deity (name: [[[[[String!]]!]]], mythology: Realm): Deity! - character (characterID: String! , age: Int ): Character! - hero: Human! -} - -""" -my interface description -""" -interface MyInterface { - """ - interface field description - """ - name: String -} - - -type Mutation { - createDeity (name: [[[[[String!]]!]]], mythology: String): Deity! - createCharacter (realm: Realm! , id: String! ): Character! -} - -""" -my unon description -""" -union Character = Creature | Deity | Human - -"my mutation description" -type Deity { - fullName: String! - power: Power -} - -""" -my mutation description -some creature -""" -type Creature { - name: String! - realm: City! - immortality: Boolean! -} - -""" -human - -ewrw -""" -type Human { - humanName: String! - lifetime: Lifetime! - profession: Profession -} - - -enum Profession { - Priest - Farmer - Artist -} - -""" -human -ew jso -ewrw -""" -input Realm { - owner: String! - age: Int - realm: Realm - profession: Profession -} - -"ancient city" -enum City { - Athens - Ithaca - Sparta Troy -} - -""" lifespan of mortal creatures """ -scalar Lifetime - - -scalar Power diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,22 @@ +## [0.6.0] - *.11.2019 + +### Removed + +- removed `morpheus` cli for code generating, if you need cli you should use +[morpheus-graphql-cli](https://github.com/morpheusgraphql/morpheus-graphql-cli/) + +- example `API` executable is removed from Production build + +## Added + +- helper functions: `liftEitherM` , `liftM` + + ```haskell + liftM :: m a -> Resolver o m e a + liftEitherM :: m (Either String a) -> Resolver o m e a + ``` + + ## [0.5.0] - 31.10.2019 ### Added diff --git a/examples/Client/Client.hs b/examples/Client/Client.hs deleted file mode 100644 --- a/examples/Client/Client.hs +++ /dev/null @@ -1,99 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} - -module Client.Client - ( fetchHero - , fetUser - ) where - -import Data.ByteString.Lazy.Char8 (ByteString) -import Data.Morpheus.Client (Fetch (..), defineByDocumentFile, defineByIntrospectionFile, gql) -import Data.Morpheus.Types (ScalarValue (..)) -import Data.Text (Text) - -defineByIntrospectionFile - "./assets/introspection.json" - [gql| - - # Query Hero with Compile time Validation - query GetUser ($coordinates: Coordinates!) - { - myUser: user { - boo3: name - myUserEmail: email - address (coordinates: $coordinates ){ - city - } - customAdress: address (coordinates: $coordinates ){ - customCity: city - } - } - user { - email - } - } - |] - - -defineByDocumentFile - "./assets/simple.gql" - [gql| - # Query Hero with Compile time Validation - query GetHero ($god: Realm, $id: String!) - { - deity (mythology:$god) { - power - fullName - } - character(characterID: $id ) { - ...on Creature { - name - immortality - } - ...on Human { - lifetime - profession - } - } - char2: character(characterID: $id ) { - ...on Creature { - cName: name - } - ...on Human { - lTime: lifetime - prof: profession - } - } - } - |] - - -ioRes :: ByteString -> IO ByteString -ioRes req = do - print req - return - "{\"data\":{\"deity\":{ \"fullName\": \"name\" }, \"character\":{ \"__typename\":\"Human\", \"lifetime\": \"Lifetime\", \"profession\": \"Artist\" } , \"char2\":{ \"__typename\":\"Human\", \"lTime\": \"time\", \"prof\": \"Artist\" } }}" - -fetchHero :: IO (Either String GetHero) -fetchHero = - fetch - ioRes - GetHeroArgs - { getHeroArgsGod = - Just Realm {realmOwner = "Zeus", realmAge = Just 10, realmRealm = Nothing, realmProfession = Just Artist} - , getHeroArgsId = "Hercules" - } - -fetUser :: (ByteString -> IO ByteString) -> IO (Either String GetUser) -fetUser api = fetch api userArgs - where - userArgs :: Args GetUser - userArgs = - GetUserArgs {getUserArgsCoordinates = Coordinates {coordinatesLongitude = [], coordinatesLatitude = String "1"}} diff --git a/examples/Files.hs b/examples/Files.hs deleted file mode 100644 --- a/examples/Files.hs +++ /dev/null @@ -1,12 +0,0 @@ -module Files - ( getJson - ) where - -import Data.Aeson (FromJSON, eitherDecode) -import qualified Data.ByteString.Lazy as L (readFile) - -jsonPath :: String -> String -jsonPath name = "examples/db/" ++ name ++ ".json" - -getJson :: FromJSON a => FilePath -> IO (Either String a) -getJson path = eitherDecode <$> L.readFile (jsonPath path) diff --git a/examples/Main.hs b/examples/Main.hs deleted file mode 100644 --- a/examples/Main.hs +++ /dev/null @@ -1,45 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} - -module Main - ( main - ) where - -import Client.Client (fetUser, fetchHero) -import Control.Monad.IO.Class (liftIO) -import Data.Functor.Identity (Identity (..)) -import Data.Morpheus (Interpreter (..)) -import Data.Morpheus.Document (toGraphQLDocument) -import Data.Morpheus.Server (GQLState, gqlSocketApp, initGQLState) -import Mythology.API (mythologyApi) -import qualified Network.Wai as Wai -import qualified Network.Wai.Handler.Warp as Warp -import qualified Network.Wai.Handler.WebSockets as WaiWs -import Network.WebSockets (defaultConnectionOptions) -import Sophisticated.API (APIEvent, gqlRoot) -import TH.Simple (thSimpleApi) -import Web.Scotty (body, file, get, post, raw, scottyApp) - -main :: IO () -main = do - state <- initGQLState - httpApp <- httpServer state - fetchHero >>= print - fetUser (interpreter gqlRoot state) >>= print - Warp.runSettings settings $ WaiWs.websocketsOr defaultConnectionOptions (wsApp state) httpApp - where - settings = Warp.setPort 3000 Warp.defaultSettings - wsApp = gqlSocketApp gqlRoot - httpServer :: GQLState IO APIEvent -> IO Wai.Application - httpServer state = - scottyApp $ do - post "/" $ raw =<< (liftIO . interpreter gqlRoot state =<< body) - get "/" $ file "examples/index.html" - get "/schema.gql" $ raw $ toGraphQLDocument $ Identity gqlRoot - post "/mythology" $ raw =<< (liftIO . mythologyApi =<< body) - get "/mythology" $ file "examples/index.html" - post "/th" $ raw =<< (liftIO . thSimpleApi =<< body) - get "/th" $ file "examples/index.html" diff --git a/examples/Mythology/API.hs b/examples/Mythology/API.hs deleted file mode 100644 --- a/examples/Mythology/API.hs +++ /dev/null @@ -1,37 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} - -module Mythology.API - ( mythologyApi - ) where - -import Control.Monad.Except (ExceptT (..)) -import qualified Data.ByteString.Lazy.Char8 as B -import Data.Morpheus (interpreter) -import Data.Morpheus.Types (Resolver (..), IORes, GQLRootResolver (..), GQLType, Undefined (..)) -import Data.Text (Text) -import GHC.Generics (Generic) -import Mythology.Character.Deity (Deity (..), dbDeity) - -newtype Query m = Query - { deity :: DeityArgs -> m Deity - } deriving (Generic, GQLType) - -data DeityArgs = DeityArgs - { name :: Text -- Required Argument - , mythology :: Maybe Text -- Optional Argument - } deriving (Generic) - -resolveDeity :: DeityArgs -> IORes e Deity -resolveDeity args = QueryResolver $ ExceptT $ dbDeity (name args) (mythology args) - -rootResolver :: GQLRootResolver IO () Query Undefined Undefined -rootResolver = - GQLRootResolver - { queryResolver = Query {deity = resolveDeity} - , mutationResolver = Undefined - , subscriptionResolver = Undefined - } - -mythologyApi :: B.ByteString -> IO B.ByteString -mythologyApi = interpreter rootResolver diff --git a/examples/Mythology/Character/Deity.hs b/examples/Mythology/Character/Deity.hs deleted file mode 100644 --- a/examples/Mythology/Character/Deity.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} - -module Mythology.Character.Deity - ( Deity(..) - , dbDeity - ) where - -import Data.Morpheus.Kind (OBJECT) -import Data.Morpheus.Types (GQLType (..)) -import Data.Text (Text) -import GHC.Generics (Generic) -import Mythology.Place.Places (Realm (..)) - -data Deity = Deity - { fullName :: Text -- Non-Nullable Field - , power :: Maybe Text -- Nullable Field - , realm :: Realm - } deriving (Generic) - -instance GQLType Deity where - type KIND Deity = OBJECT - description _ = Just "Custom Description for Client Defined User Type" - -dbDeity :: Text -> Maybe Text -> IO (Either String Deity) -dbDeity _ _ = return $ Right $ Deity {fullName = "Morpheus", power = Just "Shapeshifting", realm = Dream} diff --git a/examples/Mythology/Character/Human.hs b/examples/Mythology/Character/Human.hs deleted file mode 100644 --- a/examples/Mythology/Character/Human.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} - -module Mythology.Character.Human - ( Human(..) - ) where - -import Data.Morpheus.Kind (OBJECT) -import Data.Morpheus.Types (GQLType (..)) -import Data.Text (Text) -import GHC.Generics (Generic) -import Mythology.Place.Places (City (..)) - -data Human = Human - { name :: Text - , home :: City - } deriving (Generic) - -instance GQLType Human where - type KIND Human = OBJECT diff --git a/examples/Mythology/Place/Places.hs b/examples/Mythology/Place/Places.hs deleted file mode 100644 --- a/examples/Mythology/Place/Places.hs +++ /dev/null @@ -1,34 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TypeFamilies #-} - -module Mythology.Place.Places - ( Realm(..) - , City(..) - ) where - -import Data.Morpheus.Kind (ENUM) -import Data.Morpheus.Types (GQLType (..)) -import GHC.Generics (Generic) - -data Realm - = MountOlympus - | Sky - | Sea - | Underworld - | Dream - deriving (Generic) - -instance GQLType Realm where - type KIND Realm = ENUM - -data City - = Athens - | Colchis - | Delphi - | Ithaca - | Sparta - | Troy - -instance GQLType City where - type KIND City = ENUM diff --git a/examples/Sophisticated/API.hs b/examples/Sophisticated/API.hs deleted file mode 100644 --- a/examples/Sophisticated/API.hs +++ /dev/null @@ -1,136 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} - -module Sophisticated.API - ( gqlRoot - , APIEvent - ) where - -import Data.Map (Map) -import qualified Data.Map as M (fromList) -import Data.Set (Set) -import qualified Data.Set as S (fromList) -import Data.Text (Text, pack) -import Data.Typeable (Typeable) -import GHC.Generics (Generic) - --- MORPHEUS -import Data.Morpheus.Document (importGQLDocumentWithNamespace) -import Data.Morpheus.Kind (INPUT_UNION, OBJECT, SCALAR) -import Data.Morpheus.Types (Event (..), GQLRootResolver (..), GQLScalar (..), GQLType (..), ID, QUERY, - Resolver (..), ScalarValue (..), constRes) - - -$(importGQLDocumentWithNamespace "examples/Sophisticated/api.gql") - -type AIntText = A (Int, Text) - -type AText = A Text - -type SetInt = Set Int - -type MapTextInt = Map Text Int - -data Animal - = CAT Cat - | DOG Dog - | BIRD Bird - deriving (Show, Generic) - -instance GQLType Animal where - type KIND Animal = INPUT_UNION - -data Euro = - Euro Int - Int - deriving (Show, Generic) - -instance GQLType Euro where - type KIND Euro = SCALAR - -instance GQLScalar Euro where - parseValue _ = pure (Euro 1 0) - serialize (Euro x y) = Int (x * 100 + y) - -instance Typeable a => GQLType (A a) where - type KIND (A a) = OBJECT - -newtype A a = A - { wrappedA :: a - } deriving (Generic) - -data Channel - = UPDATE_USER - | UPDATE_ADDRESS - deriving (Show, Eq, Ord) - -data Content = Update - { contentID :: Int - , contentMessage :: Text - } - -type APIEvent = (Event Channel Content) - - -gqlRoot :: GQLRootResolver IO APIEvent Query Mutation Subscription -gqlRoot = GQLRootResolver {queryResolver, mutationResolver, subscriptionResolver} - where - queryResolver = Query - { queryUser = const fetchUser - , queryAnimal = \QueryAnimalArgs {queryAnimalArgsAnimal} -> pure (pack $ show queryAnimalArgsAnimal) - , querySet = constRes $ S.fromList [1, 2] - , queryMap = constRes $ M.fromList [("robin", 1), ("carl", 2)] - , queryWrapped1 = constRes $ A (0, "") - , queryWrapped2 = constRes $ A "" - } - ------------------------------------------------------------- - mutationResolver = Mutation { mutationCreateUser , mutationCreateAddress } - where - mutationCreateUser _ = - MutResolver - [Event [UPDATE_USER] (Update {contentID = 12, contentMessage = "some message for user"})] - (pure User - { userName = constRes "George" - , userEmail = constRes "George@email.com" - , userAddress = constRes mutationAddress - , userOffice = constRes Nothing - , userHome = constRes HH - , userEntity = constRes Nothing - }) - ------------------------- - mutationCreateAddress _ = - MutResolver - [Event [UPDATE_ADDRESS] (Update {contentID = 10, contentMessage = "message for address"})] (pure mutationAddress) - ---------------------------------------------------------------- - subscriptionResolver = Subscription {subscriptionNewAddress, subscriptionNewUser} - where - subscriptionNewUser () = SubResolver [UPDATE_USER] subResolver - where - subResolver (Event _ Update {}) = fetchUser - subscriptionNewAddress () = SubResolver [UPDATE_ADDRESS] subResolver - where - subResolver (Event _ Update {contentID}) = fetchAddress - ---------------------------------------------------------------------------------------------- - fetchAddress = pure Address {addressCity = constRes "", addressStreet = constRes "", addressHouseNumber = constRes 0} - fetchUser :: Resolver QUERY IO (Event Channel Content) (User (Resolver QUERY IO (Event Channel Content))) - fetchUser = pure User { userName = constRes "George" - , userEmail = constRes "George@email.com" - , userAddress = const fetchAddress - , userOffice = constRes Nothing - , userHome = constRes HH - , userEntity = constRes Nothing - } - mutationAddress = Address { - addressCity = constRes "", - addressStreet = constRes "", - addressHouseNumber = constRes 0 - } diff --git a/examples/Sophisticated/Model.hs b/examples/Sophisticated/Model.hs deleted file mode 100644 --- a/examples/Sophisticated/Model.hs +++ /dev/null @@ -1,33 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeOperators #-} - -module Sophisticated.Model - ( jsonAddress - , jsonUser - , JSONUser(..) - , JSONAddress(..) - ) where - -import Data.Aeson (FromJSON) -import Data.Text (Text) -import Files (getJson) -import GHC.Generics (Generic) - -data JSONUser = JSONUser - { name :: Text - , email :: Text - } deriving (Show, Generic, FromJSON) - -data JSONAddress = JSONAddress - { city :: Text - , street :: Text - , houseNumber :: Int - } deriving (Generic, Show, FromJSON) - -jsonUser :: IO (Either String JSONUser) -jsonUser = getJson "deprecated/user" - -jsonAddress :: IO (Either String JSONAddress) -jsonAddress = getJson "deprecated/address" diff --git a/examples/Sophisticated/api.gql b/examples/Sophisticated/api.gql deleted file mode 100644 --- a/examples/Sophisticated/api.gql +++ /dev/null @@ -1,94 +0,0 @@ -# for Input Union - -input Cat @testDir { - name: String! -} - -input Dog { - name: String! @testDirective(testName:"") -} - -input Bird { - name: String! -} - -# Main APi - -enum CityID @enumDir { - """ - temporary multiline Test for Enum field descripions - - """ - Paris - BLN @testDirective(testName:"") - "temporary singleline Test for Enum field descripions" - HH @enumFieldDir -} - -input Coordinates { - latitude: Euro! @testDirective(testName:"") - "temporary singleline Test for input object field descripions" - longitude: [[[UniqueID!]!]]! -} - -input UniqueID { - """ - temporary multiline Test for Enum field descripions - - """ - type: String = "test default value" - id: String! -} - -type Address @typeDirective(id:1) { - """ - temporary multiline Test for Enum field descripions - - """ - city: String! @deprecated(testName:"",testName2: 123) - street: String! - "temporary singleline Test for input object field descripions" - houseNumber: Int! -} - -""" -my custom description for user -""" -type User { - name: String! - email: String! - address( - """ - temporary multiline Test for - arguments - descripions - """ - coordinates: Coordinates! @argsDirective(id:1) , - "temporary singleline Test for input object field descripions" - comment: String = "test default value" - ): Address! - home: CityID! - office(zipCode: [[[ID!]]!], id: CityID!): Address - entity: MyUnion -} - -union MyUnion = User | Address - -type Query { - user: User! - animal(animal: Animal): String! - wrapped1(type: UniqueID): AIntText! - wrapped2: AText! - set: SetInt! - map: MapTextInt! -} - -type Mutation { - createUser: User! - createAddress: Address! -} - -type Subscription { - newAddress: Address! - newUser: User! -} diff --git a/examples/Subscription/SimpleSubscription.hs b/examples/Subscription/SimpleSubscription.hs deleted file mode 100644 --- a/examples/Subscription/SimpleSubscription.hs +++ /dev/null @@ -1,67 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Subscription.SimpleSubscription where - -import Data.Morpheus.Types (Event (..), Resolver (..), GQLRootResolver (..)) -import Data.Text (Text) -import GHC.Generics (Generic) -import Mythology.Character.Deity (Deity (..)) -import Mythology.Place.Places (Realm (..)) - --- TODO: importGQLDocument "examples/Subscription/api.gql" --- -data Channel - = ChannelA - | ChannelB - -data Content - = ContentA Int - | ContentB Text - -type MyEvent = Event Channel Content - -newtype Query m = Query - { deity :: () -> m Deity - } deriving (Generic) - -newtype Mutation m = Mutation - { createDeity :: () -> m Deity - } deriving (Generic) - -newtype Subscription (m :: * -> * ) = Subscription - { newDeity :: () -> m Deity - } deriving (Generic) - -type APIEvent = Event Channel Content - -rootResolver :: GQLRootResolver IO APIEvent Query Mutation Subscription -rootResolver = - GQLRootResolver - { queryResolver = Query {deity = const fetchDeity} - , mutationResolver = Mutation {createDeity} - , subscriptionResolver = Subscription {newDeity} - } - where - -- TODO: resolver $ dbDeity "" Nothing - createDeity _args = MutResolver [Event {channels = [ChannelA], content = ContentA 1}] - (pure Deity { - fullName = "" - , power = Nothing - , realm = Sky - }) - newDeity _args = SubResolver [ChannelA] subResolver - where - subResolver (Event [ChannelA] (ContentA _value)) = fetchDeity -- resolve New State - subResolver (Event [ChannelA] (ContentB _value)) = fetchDeity -- resolve New State - subResolver _ = fetchDeity -- Resolve Old State - --------------------------------------------------------- - fetchDeity = pure Deity { - fullName = "" - , power = Nothing - , realm = Sky - } diff --git a/examples/Subscription/api.gql b/examples/Subscription/api.gql deleted file mode 100644 --- a/examples/Subscription/api.gql +++ /dev/null @@ -1,11 +0,0 @@ -type Query { - deity: Deity -} - -type Mutation { - createDeity: Deity -} - -type Subscription { - newDeity: Deity -} diff --git a/examples/TH/Simple.hs b/examples/TH/Simple.hs deleted file mode 100644 --- a/examples/TH/Simple.hs +++ /dev/null @@ -1,39 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} - -module TH.Simple - ( thSimpleApi - ) where - -import qualified Data.ByteString.Lazy.Char8 as B - -import Data.Morpheus (interpreter) -import Data.Morpheus.Document (importGQLDocumentWithNamespace) -import Data.Morpheus.Types (GQLRootResolver (..), Undefined (..)) -import Data.Text (Text) - -importGQLDocumentWithNamespace "examples/TH/simple.gql" - -rootResolver :: GQLRootResolver IO () Query Undefined Undefined -rootResolver = - GQLRootResolver - { - queryResolver = Query {queryDeity}, - mutationResolver = Undefined, - subscriptionResolver = Undefined - } - where - queryDeity QueryDeityArgs {queryDeityArgsName} = pure Deity {deityName, deityPower} - where - deityName _ = pure "Morpheus" - deityPower _ = pure (Just "Shapeshifting") - -thSimpleApi :: B.ByteString -> IO B.ByteString -thSimpleApi = interpreter rootResolver diff --git a/examples/TH/simple.gql b/examples/TH/simple.gql deleted file mode 100644 --- a/examples/TH/simple.gql +++ /dev/null @@ -1,8 +0,0 @@ -type Query { - deity(name: String!): Deity! -} - -type Deity { - name: String! - power: String -} diff --git a/morpheus-graphql.cabal b/morpheus-graphql.cabal --- a/morpheus-graphql.cabal +++ b/morpheus-graphql.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 4915b5eb44b1d86031d2ea36b172b06b8f2e91862755d5e1df90e3d17542368c +-- hash: 31270ea6ec92f02d87e2706e3e58eb784159f13809d7558c20c648f62557da8e name: morpheus-graphql -version: 0.5.0 +version: 0.6.0 synopsis: Morpheus GraphQL description: Build GraphQL APIs with your favourite functional language! category: web, graphql @@ -16,19 +16,12 @@ author: Daviti Nalchevanidze maintainer: d.nalchevanidze@gmail.com copyright: (c) 2019 Daviti Nalchevanidze -license: BSD3 +license: MIT license-file: LICENSE build-type: Simple extra-source-files: changelog.md README.md - examples/Sophisticated/api.gql - examples/Subscription/api.gql - examples/TH/simple.gql - assets/introspection.json - assets/mut.gql - assets/pubsub.gql - assets/simple.gql data-files: test/Feature/Holistic/API.gql test/Feature/Holistic/arguments/nameConflict/query.gql @@ -300,7 +293,6 @@ Data.Morpheus.Parsing.Request.Parser Data.Morpheus.Parsing.Request.Selection Data.Morpheus.Rendering.Haskell.Render - Data.Morpheus.Rendering.Haskell.RenderHS Data.Morpheus.Rendering.Haskell.Terms Data.Morpheus.Rendering.Haskell.Types Data.Morpheus.Rendering.Haskell.Values @@ -346,81 +338,15 @@ , bytestring >=0.10.4 && <0.11 , containers >=0.4.2.1 && <0.7 , megaparsec >=7.0.0 && <8.0 - , mtl >=2.0 && <=2.2.2 + , mtl >=2.0 && <=2.3 , scientific >=0.3.6.2 && <0.4 - , template-haskell + , template-haskell >=2.0 && <=2.14.0.0 , text >=1.2.3.0 && <1.3 , transformers >=0.3.0.0 && <0.6 , unordered-containers >=0.2.8.0 && <0.3 , uuid >=1.0 && <=1.4 , vector >=0.12.0.1 && <0.13 - , websockets >=0.11.0 && <=0.12.5.3 - default-language: Haskell2010 - -executable api - main-is: Main.hs - other-modules: - Client.Client - Files - Mythology.API - Mythology.Character.Deity - Mythology.Character.Human - Mythology.Place.Places - Sophisticated.API - Sophisticated.Model - Subscription.SimpleSubscription - TH.Simple - Paths_morpheus_graphql - hs-source-dirs: - examples - ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall - build-depends: - aeson - , base >=4.7 && <5 - , bytestring - , containers >=0.4.2.1 && <0.7 - , megaparsec >=7.0.0 && <8.0 - , morpheus-graphql - , mtl - , scientific >=0.3.6.2 && <0.4 - , scotty - , template-haskell - , text - , transformers >=0.3.0.0 && <0.6 - , unordered-containers >=0.2.8.0 && <0.3 - , uuid >=1.0 && <=1.4 - , vector >=0.12.0.1 && <0.13 - , wai - , wai-websockets >=1.0 && <=3.5 - , warp - , websockets >=0.11.0 && <=0.12.5.3 - default-language: Haskell2010 - -executable morpheus - main-is: Main.hs - other-modules: - Paths_morpheus_graphql - hs-source-dirs: - CLI - ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall - build-depends: - aeson - , base >=4.7 && <5 - , bytestring - , containers >=0.4.2.1 && <0.7 - , filepath >=1.1 && <1.5 - , megaparsec >=7.0.0 && <8.0 - , morpheus-graphql - , mtl - , optparse-applicative >=0.12 && <0.15 - , scientific >=0.3.6.2 && <0.4 - , template-haskell - , text - , transformers >=0.3.0.0 && <0.6 - , unordered-containers >=0.2.8.0 && <0.3 - , uuid >=1.0 && <=1.4 - , vector >=0.12.0.1 && <0.13 - , websockets >=0.11.0 && <=0.12.5.3 + , websockets >=0.11.0 && <=0.13 default-language: Haskell2010 test-suite morpheus-test @@ -449,15 +375,15 @@ , containers >=0.4.2.1 && <0.7 , megaparsec >=7.0.0 && <8.0 , morpheus-graphql - , mtl >=2.0 && <=2.2.2 + , mtl >=2.0 && <=2.3 , scientific >=0.3.6.2 && <0.4 , tasty , tasty-hunit - , template-haskell + , template-haskell >=2.0 && <=2.14.0.0 , text >=1.2.3.0 && <1.3 , transformers >=0.3.0.0 && <0.6 , unordered-containers >=0.2.8.0 && <0.3 , uuid >=1.0 && <=1.4 , vector >=0.12.0.1 && <0.13 - , websockets >=0.11.0 && <=0.12.5.3 + , websockets >=0.11.0 && <=0.13 default-language: Haskell2010 diff --git a/src/Data/Morpheus/Error/Internal.hs b/src/Data/Morpheus/Error/Internal.hs --- a/src/Data/Morpheus/Error/Internal.hs +++ b/src/Data/Morpheus/Error/Internal.hs @@ -5,7 +5,6 @@ , internalArgumentError , internalUnknownTypeMessage , internalError - , internalErrorT ) where import Data.Text (Text) @@ -13,7 +12,6 @@ -- MORPHEUS import Data.Morpheus.Error.Utils (globalErrorMessage) -import Data.Morpheus.Types.Internal.Resolver (ResolveT, failResolveT) import Data.Morpheus.Types.Internal.Validation (GQLErrors) import Data.Morpheus.Types.Internal.Value (Value (..)) @@ -22,10 +20,6 @@ -- all kind internal error in development internalError :: Text -> Either GQLErrors b internalError x = Left $ globalErrorMessage $ T.concat ["INTERNAL ERROR: ", x] - -internalErrorT :: Monad m => Text -> ResolveT m b -internalErrorT x = - failResolveT $ globalErrorMessage $ T.concat ["INTERNAL ERROR: ", x] -- if type did not not found, but was defined by Schema internalUnknownTypeMessage :: Text -> GQLErrors diff --git a/src/Data/Morpheus/Execution/Client/Fetch.hs b/src/Data/Morpheus/Execution/Client/Fetch.hs --- a/src/Data/Morpheus/Execution/Client/Fetch.hs +++ b/src/Data/Morpheus/Execution/Client/Fetch.hs @@ -16,12 +16,13 @@ import Data.Text (pack) import Language.Haskell.TH -import qualified Data.Aeson as A -import qualified Data.Aeson.Types as A +import qualified Data.Aeson as A +import qualified Data.Aeson.Types as A + -- -- MORPHEUS -import Data.Morpheus.Types.Internal.TH (instanceHeadT) +import Data.Morpheus.Types.Internal.TH (instanceHeadT, typeInstanceDec) import Data.Morpheus.Types.IO (GQLRequest (..), JSONResponse (..)) fixVars :: A.Value -> Maybe A.Value @@ -42,15 +43,15 @@ where gqlReq = GQLRequest {operationName = Just (pack opName), query = pack strQuery, variables = fixVars (toJSON vars)} ------------------------------------------------------------- - processResponse JSONResponse {responseData = Just x} = pure x - processResponse invalidResponse = fail $ show invalidResponse + processResponse JSONResponse {responseData = Just x} = Right x + processResponse invalidResponse = Left (show invalidResponse) fetch :: (Monad m, FromJSON a) => (ByteString -> m ByteString) -> Args a -> m (Either String a) deriveFetch :: Type -> String -> String -> Q [Dec] -deriveFetch argDatatype typeName query = pure <$> instanceD (cxt []) iHead methods +deriveFetch resultType typeName query = pure <$> instanceD (cxt []) iHead methods where iHead = instanceHeadT ''Fetch typeName [] methods = [ funD 'fetch [clause [] (normalB [|__fetch query typeName|]) []] - , pure $ TySynInstD ''Args (TySynEqn [ConT $ mkName typeName] argDatatype) + , pure $ typeInstanceDec ''Args (ConT $ mkName typeName) resultType ] diff --git a/src/Data/Morpheus/Execution/Client/Selection.hs b/src/Data/Morpheus/Execution/Client/Selection.hs --- a/src/Data/Morpheus/Execution/Client/Selection.hs +++ b/src/Data/Morpheus/Execution/Client/Selection.hs @@ -20,9 +20,9 @@ Variable (..), VariableDefinitions, getOperationName) import Data.Morpheus.Types.Internal.AST.Selection (Selection (..), SelectionRec (..), SelectionSet, ValidSelection) -import Data.Morpheus.Types.Internal.Data (DataField (..), DataFullType (..), DataLeaf (..), - DataTyCon (..), DataTypeKind (..), DataTypeLib (..), - Key, TypeAlias (..), allDataTypes) +import Data.Morpheus.Types.Internal.Data (DataField (..), DataType (..), DataTyCon (..), + DataTypeKind (..), DataTypeLib (..), Key, + TypeAlias (..), allDataTypes) import Data.Morpheus.Types.Internal.DataD (ConsD (..), GQLTypeD (..), TypeD (..)) import Data.Morpheus.Types.Internal.Validation (GQLErrors, Validation) import Data.Morpheus.Validation.Internal.Utils (lookupType) @@ -43,7 +43,7 @@ inputTypesAndEnums <- buildListedTypes (inputTypeRequests <> enums) pure (rootArguments (getOperationName operationName <> "Args"), queryTypes <> inputTypesAndEnums) where - queryDataType = OutputObject $ snd $ query lib + queryDataType = DataObject $ snd $ query lib ------------------------------------------------------------------------- buildListedTypes = fmap concat . traverse (buildInputType lib) . removeDuplicates ------------------------------------------------------------------------- @@ -74,7 +74,7 @@ } --------------------------------------------------------- -- generates selection Object Types - genRecordType :: [Key] -> Key -> DataFullType -> SelectionSet -> Validation ([GQLTypeD], [Text]) + genRecordType :: [Key] -> Key -> DataType -> SelectionSet -> Validation ([GQLTypeD], [Text]) genRecordType path name dataType recordSelSet = do (con, subTypes, requests) <- genConsD (unpack name) dataType recordSelSet pure @@ -87,7 +87,7 @@ , requests) where tName = unpack name - genConsD :: String -> DataFullType -> SelectionSet -> Validation (ConsD, [GQLTypeD], [Text]) + genConsD :: String -> DataType -> SelectionSet -> Validation (ConsD, [GQLTypeD], [Text]) genConsD cName datatype selSet = do cFields <- traverse genField selSet (subTypes, requests) <- newFieldTypes datatype selSet @@ -106,7 +106,7 @@ fieldType <- snd <$> lookupFieldType lib fieldPath datatype fieldName pure $ DataField {fieldName, fieldArgs = [], fieldArgsType = Nothing, fieldType, fieldHidden = False} ------------------------------------------------------------------------------------------------------------ - newFieldTypes :: DataFullType -> SelectionSet -> Validation ([[GQLTypeD]], [[Text]]) + newFieldTypes :: DataType -> SelectionSet -> Validation ([[GQLTypeD]], [[Text]]) newFieldTypes parentType seSet = unzip <$> mapM valSelection seSet where valSelection (key, selection@Selection { selectionAlias }) = do @@ -116,10 +116,8 @@ where fieldPath = path <> [fromMaybe key selectionAlias] -------------------------------------------------------------------- - validateSelection :: DataFullType -> ValidSelection -> Validation ([GQLTypeD], [Text]) - validateSelection dType Selection {selectionRec = SelectionField} = do - lName <- withLeaf (pure . leafName) dType - pure ([], lName) + validateSelection :: DataType -> ValidSelection -> Validation ([GQLTypeD], [Text]) + validateSelection dType Selection {selectionRec = SelectionField} = leafType dType --withLeaf buildLeaf dType validateSelection dType Selection {selectionRec = SelectionSet selectionSet} = genRecordType fieldPath (typeFrom [] dType) dType selectionSet @@ -145,17 +143,17 @@ | name `elem` collected = pure collected | otherwise = getType lib name >>= scanType where - scanType (InputObject DataTyCon {typeData}) = resolveUpdates (name : collected) (map toInputTypeD typeData) + scanType (DataInputObject DataTyCon {typeData}) = resolveUpdates (name : collected) (map toInputTypeD typeData) where toInputTypeD :: (Text, DataField) -> LibUpdater [Key] toInputTypeD (_, DataField {fieldType = TypeAlias {aliasTyCon}}) = scanInputTypes lib aliasTyCon - scanType (Leaf leaf) = pure (collected <> leafName leaf) + scanType (DataEnum DataTyCon {typeName}) = pure (collected <> [typeName]) scanType _ = pure collected buildInputType :: DataTypeLib -> Text -> Validation [GQLTypeD] buildInputType lib name = getType lib name >>= subTypes where - subTypes (InputObject DataTyCon {typeName, typeData}) = do + subTypes (DataInputObject DataTyCon {typeName, typeData}) = do fields <- traverse toFieldD typeData pure [ GQLTypeD @@ -175,7 +173,7 @@ toFieldD (_, field@DataField {fieldType}) = do aliasTyCon <- typeFrom [] <$> getType lib (aliasTyCon fieldType) pure $ field {fieldType = fieldType {aliasTyCon}} - subTypes (Leaf (LeafEnum DataTyCon {typeName, typeData})) = + subTypes (DataEnum DataTyCon {typeName, typeData}) = pure [ GQLTypeD { typeD = TypeD {tName = unpack typeName, tNamespace = [], tCons = map enumOption typeData} @@ -187,23 +185,21 @@ enumOption eName = ConsD {cName = unpack eName, cFields = []} subTypes _ = pure [] -lookupFieldType :: DataTypeLib -> [Key] -> DataFullType -> Text -> Validation (DataFullType, TypeAlias) -lookupFieldType lib path (OutputObject DataTyCon {typeData}) key = +lookupFieldType :: DataTypeLib -> [Key] -> DataType -> Text -> Validation (DataType, TypeAlias) +lookupFieldType lib path (DataObject DataTyCon {typeData}) key = case lookup key typeData of Just DataField {fieldType = alias@TypeAlias {aliasTyCon}} -> trans <$> getType lib aliasTyCon where trans x = (x, alias {aliasTyCon = typeFrom path x, aliasArgs = Nothing}) Nothing -> Left (compileError $ "cant find field \""<> key<>"\"") lookupFieldType _ _ dt _ = Left (compileError $ "Type should be output Object \"" <> pack (show dt)) -withLeaf :: (DataLeaf -> Validation b) -> DataFullType -> Validation b -withLeaf f (Leaf x) = f x -withLeaf _ _ = Left $ compileError "Invalid schema Expected scalar" -leafName :: DataLeaf -> [Text] -leafName (LeafEnum DataTyCon {typeName}) = [typeName] -leafName _ = [] +leafType :: DataType -> Validation ([GQLTypeD], [Text]) +leafType (DataEnum DataTyCon {typeName}) = pure ([],[typeName]) +leafType DataScalar {} = pure ([],[]) +leafType _ = Left $ compileError "Invalid schema Expected scalar" -getType :: DataTypeLib -> Text -> Validation DataFullType +getType :: DataTypeLib -> Text -> Validation DataType getType lib typename = lookupType (compileError typename) (allDataTypes lib) typename typeFromScalar :: Text -> Text @@ -214,11 +210,10 @@ typeFromScalar "ID" = "ID" typeFromScalar _ = "ScalarValue" -typeFrom :: [Key] -> DataFullType -> Text -typeFrom _ (Leaf (BaseScalar x)) = typeName x -typeFrom _ (Leaf (CustomScalar DataTyCon {typeName})) = typeFromScalar typeName -typeFrom _ (Leaf (LeafEnum x)) = typeName x -typeFrom _ (InputObject x) = typeName x -typeFrom path (OutputObject x) = pack $ nameSpaceType path $ typeName x -typeFrom path (Union x) = pack $ nameSpaceType path $ typeName x -typeFrom _ (InputUnion x) = typeName x +typeFrom :: [Key] -> DataType -> Text +typeFrom _ (DataScalar DataTyCon {typeName}) = typeFromScalar typeName +typeFrom _ (DataEnum x) = typeName x +typeFrom _ (DataInputObject x) = typeName x +typeFrom path (DataObject x) = pack $ nameSpaceType path $ typeName x +typeFrom path (DataUnion x) = pack $ nameSpaceType path $ typeName x +typeFrom _ (DataInputUnion x) = typeName x diff --git a/src/Data/Morpheus/Execution/Document/Convert.hs b/src/Data/Morpheus/Execution/Document/Convert.hs --- a/src/Data/Morpheus/Execution/Document/Convert.hs +++ b/src/Data/Morpheus/Execution/Document/Convert.hs @@ -15,17 +15,16 @@ -- MORPHEUS import Data.Morpheus.Error.Internal (internalError) import Data.Morpheus.Execution.Internal.Utils (capital) -import Data.Morpheus.Types.Internal.Data (ArgsType (..), DataField (..), DataField, DataFullType (..), - DataLeaf (..), DataTyCon (..), DataTypeKind (..), - DataTypeKind (..), OperationType (..), ResolverKind (..), - TypeAlias (..), sysTypes) +import Data.Morpheus.Types.Internal.Data (ArgsType (..), DataField (..), DataType (..), + DataTyCon (..), DataTypeKind (..), OperationType (..), + ResolverKind (..), TypeAlias (..), sysTypes) import Data.Morpheus.Types.Internal.DataD (ConsD (..), GQLTypeD (..), TypeD (..)) import Data.Morpheus.Types.Internal.Validation (Validation) -renderTHTypes :: Bool -> [(Text, DataFullType)] -> Validation [GQLTypeD] +renderTHTypes :: Bool -> [(Text, DataType)] -> Validation [GQLTypeD] renderTHTypes namespace lib = traverse renderTHType lib where - renderTHType :: (Text, DataFullType) -> Validation GQLTypeD + renderTHType :: (Text, DataType) -> Validation GQLTypeD renderTHType (tyConName, x) = genType x where genArgsTypeName fieldName @@ -69,9 +68,9 @@ --------------------------------------- aliasArgs = case lookup aliasTyCon lib of - Just OutputObject {} -> Just "m" - Just Union {} -> Just "m" - _ -> Nothing + Just DataObject {} -> Just "m" + Just DataUnion {} -> Just "m" + _ -> Nothing ----------------------------------- fieldArgsType = Just $ ArgsType {argsTypeName, resKind = getFieldType ftName} where @@ -81,12 +80,12 @@ -------------------------------------- getFieldType key = case lookup key lib of - Nothing -> ExternalResolver - Just OutputObject {} -> TypeVarResolver - Just Union {} -> TypeVarResolver - Just _ -> PlainResolver + Nothing -> ExternalResolver + Just DataObject {} -> TypeVarResolver + Just DataUnion {} -> TypeVarResolver + Just _ -> PlainResolver -------------------------------------------- - genType (Leaf (LeafEnum DataTyCon {typeName, typeData})) = + genType (DataEnum DataTyCon {typeName, typeData}) = pure GQLTypeD { typeD = TypeD {tName = sysName typeName, tNamespace = [], tCons = map enumOption typeData} @@ -95,9 +94,9 @@ } where enumOption name = ConsD {cName = sysName name, cFields = []} - genType (Leaf _) = internalError "Scalar Types should defined By Native Haskell Types" - genType (InputUnion _) = internalError "Input Unions not Supported" - genType (InputObject DataTyCon {typeName, typeData}) = + genType (DataScalar _) = internalError "Scalar Types should defined By Native Haskell Types" + genType (DataInputUnion _) = internalError "Input Unions not Supported" + genType (DataInputObject DataTyCon {typeName, typeData}) = pure GQLTypeD { typeD = @@ -109,7 +108,7 @@ , typeKindD = KindInputObject , typeArgD = [] } - genType (OutputObject DataTyCon {typeName, typeData}) = do + genType (DataObject DataTyCon {typeName, typeData}) = do typeArgD <- concat <$> traverse genArgumentType typeData pure GQLTypeD @@ -125,7 +124,7 @@ else KindObject Nothing , typeArgD } - genType (Union DataTyCon {typeName, typeData}) = do + genType (DataUnion DataTyCon {typeName, typeData}) = do let tCons = map unionCon typeData pure GQLTypeD diff --git a/src/Data/Morpheus/Execution/Document/GQLType.hs b/src/Data/Morpheus/Execution/Document/GQLType.hs --- a/src/Data/Morpheus/Execution/Document/GQLType.hs +++ b/src/Data/Morpheus/Execution/Document/GQLType.hs @@ -19,7 +19,7 @@ import Data.Morpheus.Types.GQLType (GQLType (..), TRUE) import Data.Morpheus.Types.Internal.Data (DataTypeKind (..), isObject, isSchemaTypeName) import Data.Morpheus.Types.Internal.DataD (GQLTypeD (..), TypeD (..)) -import Data.Morpheus.Types.Internal.TH (instanceHeadT, typeT) +import Data.Morpheus.Types.Internal.TH (instanceHeadT, typeT, typeInstanceDec) import Data.Typeable (Typeable) genTypeName :: String -> String @@ -27,6 +27,8 @@ | isSchemaTypeName (pack name) = name genTypeName name = name + + deriveGQLType :: GQLTypeD -> Q [Dec] deriveGQLType GQLTypeD {typeD = TypeD {tName}, typeKindD} = pure <$> instanceD (cxt constrains) iHead (def__typeName : typeFamilies) @@ -54,11 +56,11 @@ where deriveCUSTOM = do typeN <- headSig - pure $ TySynInstD ''CUSTOM (TySynEqn [typeN] (ConT ''TRUE)) + pure $ typeInstanceDec ''CUSTOM typeN (ConT ''TRUE) --------------------------------------------------------------- deriveKind = do typeN <- headSig - pure $ TySynInstD ''KIND (TySynEqn [typeN] (ConT $ toKIND typeKindD)) + pure $ typeInstanceDec ''KIND typeN (ConT $ toKIND typeKindD) --------------------------------- toKIND KindScalar = ''SCALAR toKIND KindEnum = ''ENUM diff --git a/src/Data/Morpheus/Execution/Internal/Declare.hs b/src/Data/Morpheus/Execution/Internal/Declare.hs --- a/src/Data/Morpheus/Execution/Internal/Declare.hs +++ b/src/Data/Morpheus/Execution/Internal/Declare.hs @@ -25,7 +25,7 @@ import Data.Morpheus.Types.Internal.DataD (ConsD (..), TypeD (..)) import Data.Morpheus.Types.Internal.Resolver (UnSubResolver) -type FUNC = (->) +type Arrow = (->) declareTypeAlias :: Bool -> TypeAlias -> Type declareTypeAlias isSub TypeAlias {aliasTyCon, aliasWrappers, aliasArgs} = wrappedT aliasWrappers @@ -73,7 +73,7 @@ genFieldT (Just ArgsType {argsTypeName}) = AppT (AppT arrowType argType) (fType True) where argType = ConT $ mkName (unpack argsTypeName) - arrowType = ConT ''FUNC + arrowType = ConT ''Arrow ------------------------------------------------ fType isResolver | maybe False isSubscription kindD = AppT monadVar result diff --git a/src/Data/Morpheus/Execution/Server/Introspect.hs b/src/Data/Morpheus/Execution/Server/Introspect.hs --- a/src/Data/Morpheus/Execution/Server/Introspect.hs +++ b/src/Data/Morpheus/Execution/Server/Introspect.hs @@ -39,11 +39,12 @@ import Data.Morpheus.Types.Custom (MapKind, Pair) import Data.Morpheus.Types.GQLScalar (GQLScalar (..)) import Data.Morpheus.Types.GQLType (GQLType (..)) -import Data.Morpheus.Types.Internal.Data (DataArguments, DataField (..), DataFullType (..), - DataLeaf (..), DataTyCon (..), DataTypeLib, - TypeAlias (..), defineType, isTypeDefined, - toListField, toNullableField) +import Data.Morpheus.Types.Internal.Data (DataArguments, DataField (..), DataType (..), + DataTyCon (..), DataTypeLib, TypeAlias (..), + defineType, isTypeDefined, toListField, + toNullableField) + type IntroCon a = (GQLType a, ObjectFields (CUSTOM a) a) -- | Generates internal GraphQL Schema for query validation and introspection rendering @@ -99,23 +100,23 @@ instance (GQLType a, GQLScalar a) => IntrospectKind SCALAR a where introspectKind _ = updateLib scalarType [] (Proxy @a) where - scalarType = Leaf . CustomScalar . buildType (scalarValidator (Proxy @a)) + scalarType = DataScalar . buildType (scalarValidator (Proxy @a)) -- ENUM instance (GQL_TYPE a, EnumRep (Rep a)) => IntrospectKind ENUM a where introspectKind _ = updateLib enumType [] (Proxy @a) where - enumType = Leaf . LeafEnum . buildType (enumTags (Proxy @(Rep a))) + enumType = DataEnum . buildType (enumTags (Proxy @(Rep a))) -- INPUT_OBJECT instance (GQL_TYPE a, ObjectFields (CUSTOM a) a) => IntrospectKind INPUT_OBJECT a where - introspectKind _ = updateLib (InputObject . buildType fields) types (Proxy @a) + introspectKind _ = updateLib (DataInputObject . buildType fields) types (Proxy @a) where (fields, types) = objectFields (Proxy @(CUSTOM a)) (Proxy @a) -- OBJECTS instance (GQL_TYPE a, ObjectFields (CUSTOM a) a) => IntrospectKind OBJECT a where - introspectKind _ = updateLib (OutputObject . buildType (__typename : fields)) types (Proxy @a) + introspectKind _ = updateLib (DataObject . buildType (__typename : fields)) types (Proxy @a) where __typename = ( "__typename" @@ -130,19 +131,19 @@ -- UNION instance (GQL_TYPE a, GQLRep UNION (Rep a)) => IntrospectKind UNION a where - introspectKind _ = updateLib (Union . buildType fields) stack (Proxy @a) + introspectKind _ = updateLib (DataUnion . buildType fields) stack (Proxy @a) where (fields, stack) = unzip $ gqlRep (Context :: Context UNION (Rep a)) -- INPUT_UNION instance (GQL_TYPE a, GQLRep UNION (Rep a)) => IntrospectKind INPUT_UNION a where - introspectKind _ = updateLib (InputUnion . buildType (fieldTag : fields)) (tagsEnumType : stack) (Proxy @a) + introspectKind _ = updateLib (DataInputUnion . buildType (fieldTag : fields)) (tagsEnumType : stack) (Proxy @a) where (inputUnions, stack) = unzip $ gqlRep (Context :: Context UNION (Rep a)) fields = map toNullableField inputUnions -- for every input Union 'User' adds enum type of possible TypeNames 'UserTags' tagsEnumType :: TypeUpdater - tagsEnumType x = pure $ defineType (typeName, Leaf $ LeafEnum tagsEnum) x + tagsEnumType x = pure $ defineType (typeName, DataEnum tagsEnum) x where tagsEnum = DataTyCon @@ -226,7 +227,7 @@ , typeData } -updateLib :: GQLType a => (Proxy a -> DataFullType) -> [TypeUpdater] -> Proxy a -> TypeUpdater +updateLib :: GQLType a => (Proxy a -> DataType) -> [TypeUpdater] -> Proxy a -> TypeUpdater updateLib typeBuilder stack proxy lib' = case isTypeDefined (__typeName proxy) lib' of Nothing -> resolveUpdates (defineType (__typeName proxy, typeBuilder proxy) lib') stack diff --git a/src/Data/Morpheus/Parsing/Document/TypeSystem.hs b/src/Data/Morpheus/Parsing/Document/TypeSystem.hs --- a/src/Data/Morpheus/Parsing/Document/TypeSystem.hs +++ b/src/Data/Morpheus/Parsing/Document/TypeSystem.hs @@ -15,9 +15,8 @@ typDeclaration) import Data.Morpheus.Parsing.Internal.Terms (keyword, operator, optDescription, parseName, pipeLiteral, sepByAnd, setOf) -import Data.Morpheus.Types.Internal.Data (DataField, DataFingerprint (..), DataFullType (..), - DataLeaf (..), DataTyCon (..), DataValidator (..), Key, - RawDataType (..)) +import Data.Morpheus.Types.Internal.Data (DataField, DataFingerprint (..), DataType (..), + DataTyCon (..), DataValidator (..), Key, RawDataType (..)) -- Scalars : https://graphql.github.io/graphql-spec/June2018/#sec-Scalars @@ -25,7 +24,7 @@ -- ScalarTypeDefinition: -- Description(opt) scalar Name Directives(Const)(opt) -- -scalarTypeDefinition :: Maybe Text -> Parser (Text, DataFullType) +scalarTypeDefinition :: Maybe Text -> Parser (Text, DataType) scalarTypeDefinition typeDescription = label "ScalarTypeDefinition" $ do typeName <- typDeclaration "scalar" @@ -33,7 +32,7 @@ _ <- optionalDirectives pure ( typeName, - Leaf $ CustomScalar DataTyCon { + DataScalar DataTyCon { typeName, typeDescription, typeFingerprint = SystemFingerprint typeName, @@ -111,7 +110,7 @@ -- = |(opt) NamedType -- UnionMemberTypes | NamedType -- -unionTypeDefinition :: Maybe Text -> Parser (Text, DataFullType) +unionTypeDefinition :: Maybe Text -> Parser (Text, DataType) unionTypeDefinition typeDescription = label "UnionTypeDefinition" $ do typeName <- typDeclaration "union" @@ -120,7 +119,7 @@ memberTypes <- unionMemberTypes pure ( typeName, - Union DataTyCon { + DataUnion DataTyCon { typeName, typeDescription, typeFingerprint = SystemFingerprint typeName, @@ -142,7 +141,7 @@ -- EnumValueDefinition -- Description(opt) EnumValue Directives(Const)(opt) -- -enumTypeDefinition :: Maybe Text -> Parser (Text, DataFullType) +enumTypeDefinition :: Maybe Text -> Parser (Text, DataType) enumTypeDefinition typeDescription = label "EnumTypeDefinition" $ do typeName <- typDeclaration "enum" @@ -150,8 +149,8 @@ _directives <- optionalDirectives enumValuesDefinition <- setOf enumValueDefinition pure ( - typeName, - Leaf $ LeafEnum DataTyCon { + typeName, + DataEnum DataTyCon { typeName, typeDescription, typeFingerprint = SystemFingerprint typeName, @@ -175,7 +174,7 @@ -- InputFieldsDefinition: -- { InputValueDefinition(list) } -- -inputObjectTypeDefinition :: Maybe Text -> Parser (Text, DataFullType) +inputObjectTypeDefinition :: Maybe Text -> Parser (Text, DataType) inputObjectTypeDefinition typeDescription = label "InputObjectTypeDefinition" $ do typeName <- typDeclaration "input" @@ -185,7 +184,7 @@ pure ( typeName, - InputObject DataTyCon { + DataInputObject DataTyCon { typeName, typeDescription, typeFingerprint = SystemFingerprint typeName, @@ -197,7 +196,7 @@ inputFieldsDefinition = label "InputFieldsDefinition" $ setOf inputValueDefinition -parseFinalDataType :: Maybe Text -> Parser (Text, DataFullType) +parseFinalDataType :: Maybe Text -> Parser (Text, DataType) parseFinalDataType description = label "TypeDefinition" $ inputObjectTypeDefinition description <|> unionTypeDefinition description diff --git a/src/Data/Morpheus/Parsing/Internal/Create.hs b/src/Data/Morpheus/Parsing/Internal/Create.hs --- a/src/Data/Morpheus/Parsing/Internal/Create.hs +++ b/src/Data/Morpheus/Parsing/Internal/Create.hs @@ -11,12 +11,17 @@ , createDataTypeLib ) where -import Data.Morpheus.Types.Internal.Data (DataArguments, DataField (..), DataFingerprint (..), - DataFullType (..), DataLeaf (..), DataTyCon (..), DataTypeLib (..), - DataValidator (..), TypeAlias (..), WrapperD, defineType, - initTypeLib) -import Data.Text (Text) +import Data.Text (Text) +-- MORPHEUS +import Data.Morpheus.Error.Internal (internalError) +import Data.Morpheus.Types.Internal.Data (DataArguments, DataField (..), DataFingerprint (..), + DataTyCon (..), DataType (..), DataTypeLib (..), + DataValidator (..), TypeAlias (..), WrapperD, defineType, + initTypeLib) +import Data.Morpheus.Types.Internal.Validation (Validation) + + createField :: DataArguments -> Text -> ([WrapperD], Text) -> DataField createField fieldArgs fieldName (aliasWrappers, aliasTyCon) = DataField @@ -34,18 +39,18 @@ createType typeName typeData = DataTyCon {typeName, typeDescription = Nothing, typeFingerprint = SystemFingerprint "", typeData} -createScalarType :: Text -> (Text, DataFullType) -createScalarType typeName = (typeName, Leaf $ CustomScalar $ createType typeName (DataValidator pure)) +createScalarType :: Text -> (Text, DataType) +createScalarType typeName = (typeName, DataScalar $ createType typeName (DataValidator pure)) -createEnumType :: Text -> [Text] -> (Text, DataFullType) -createEnumType typeName typeData = (typeName, Leaf $ LeafEnum $ createType typeName typeData) +createEnumType :: Text -> [Text] -> (Text, DataType) +createEnumType typeName typeData = (typeName, DataEnum $ createType typeName typeData) -createUnionType :: Text -> [Text] -> (Text, DataFullType) -createUnionType typeName typeData = (typeName, Union $ createType typeName $ map unionField typeData) +createUnionType :: Text -> [Text] -> (Text, DataType) +createUnionType typeName typeData = (typeName, DataUnion $ createType typeName $ map unionField typeData) where unionField fieldType = createField [] "" ([], fieldType) -createDataTypeLib :: Monad m => [(Text, DataFullType)] -> m DataTypeLib +createDataTypeLib :: [(Text, DataType)] -> Validation DataTypeLib createDataTypeLib types = case takeByKey "Query" types of (Just query, lib1) -> @@ -53,10 +58,10 @@ (mutation, lib2) -> case takeByKey "Subscription" lib2 of (subscription, lib3) -> pure ((foldr defineType (initTypeLib query) lib3) {mutation, subscription}) - _ -> fail "Query Not Defined" + _ -> internalError "Query Not Defined" ---------------------------------------------------------------------------- where takeByKey key lib = case lookup key lib of - Just (OutputObject value) -> (Just (key, value), filter ((/= key) . fst) lib) - _ -> (Nothing, lib) + Just (DataObject value) -> (Just (key, value), filter ((/= key) . fst) lib) + _ -> (Nothing, lib) diff --git a/src/Data/Morpheus/Parsing/JSONSchema/Parse.hs b/src/Data/Morpheus/Parsing/JSONSchema/Parse.hs --- a/src/Data/Morpheus/Parsing/JSONSchema/Parse.hs +++ b/src/Data/Morpheus/Parsing/JSONSchema/Parse.hs @@ -16,7 +16,7 @@ import Data.Morpheus.Parsing.JSONSchema.Types (EnumValue (..), Field (..), InputValue (..), Introspection (..), Schema (..), Type (..)) import Data.Morpheus.Schema.TypeKind (TypeKind (..)) -import Data.Morpheus.Types.Internal.Data (DataField, DataFullType (..), DataTypeLib, +import Data.Morpheus.Types.Internal.Data (DataField, DataType (..), DataTypeLib, DataTypeWrapper (..), Key, WrapperD, toHSWrappers) import Data.Morpheus.Types.Internal.Validation (Validation) import Data.Morpheus.Types.IO (JSONResponse (..)) @@ -29,7 +29,7 @@ Left errors -> internalError $ pack errors Right JSONResponse {responseData = Just Introspection {__schema = Schema {types}}} -> traverse parse types >>= createDataTypeLib - Right res -> fail $ show res + Right res -> internalError (pack $ show res) where jsonSchema :: Either String (JSONResponse Introspection) jsonSchema = eitherDecode jsonDoc @@ -37,20 +37,20 @@ class ParseJSONSchema a b where parse :: a -> Validation (Key, b) -instance ParseJSONSchema Type DataFullType where +instance ParseJSONSchema Type DataType where parse Type {name = Just typeName, kind = SCALAR} = pure $ createScalarType typeName parse Type {name = Just typeName, kind = ENUM, enumValues = Just enums} = pure $ createEnumType typeName (map enumName enums) parse Type {name = Just typeName, kind = UNION, possibleTypes = Just unions} = case traverse name unions of - Nothing -> fail "ERROR: GQL ERROR" + Nothing -> internalError "ERROR: GQL ERROR" Just uni -> pure $ createUnionType typeName uni parse Type {name = Just typeName, kind = INPUT_OBJECT, inputFields = Just iFields} = do fields <- traverse parse iFields - pure (typeName, InputObject $ createType typeName fields) + pure (typeName, DataInputObject $ createType typeName fields) parse Type {name = Just typeName, kind = OBJECT, fields = Just oFields} = do fields <- traverse parse oFields - pure (typeName, OutputObject $ createType typeName fields) + pure (typeName, DataObject $ createType typeName fields) parse x = internalError $ "Unsuported type" <> pack (show x) instance ParseJSONSchema Field DataField where diff --git a/src/Data/Morpheus/Rendering/Haskell/RenderHS.hs b/src/Data/Morpheus/Rendering/Haskell/RenderHS.hs deleted file mode 100644 --- a/src/Data/Morpheus/Rendering/Haskell/RenderHS.hs +++ /dev/null @@ -1,35 +0,0 @@ -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeSynonymInstances #-} - -module Data.Morpheus.Rendering.Haskell.RenderHS - ( RenderHS(..) - ) where - -import Data.Semigroup ((<>)) - --- MORPHEUS -import Data.Morpheus.Types.Internal.Data - -class RenderHS a where - render :: a -> Key - renderWrapped :: a -> [WrapperD] -> Key - default renderWrapped :: a -> [WrapperD] -> Key - renderWrapped x wrappers = showGQLWrapper (toGQLWrapper wrappers) - where - showGQLWrapper [] = render x - showGQLWrapper (ListType:xs) = "[" <> showGQLWrapper xs <> "]" - showGQLWrapper (NonNullType:xs) = showGQLWrapper xs <> "!" - -instance RenderHS Key where - render = id - -instance RenderHS TypeAlias where - render TypeAlias {aliasTyCon, aliasWrappers} = renderWrapped aliasTyCon aliasWrappers - -instance RenderHS DataKind where - render (ScalarKind x) = typeName x - render (EnumKind x) = typeName x - render (ObjectKind x) = typeName x - render (UnionKind x) = typeName x diff --git a/src/Data/Morpheus/Rendering/Haskell/Types.hs b/src/Data/Morpheus/Rendering/Haskell/Types.hs --- a/src/Data/Morpheus/Rendering/Haskell/Types.hs +++ b/src/Data/Morpheus/Rendering/Haskell/Types.hs @@ -14,20 +14,19 @@ import Data.Morpheus.Rendering.Haskell.Terms (Context (..), Scope (..), indent, renderAssignment, renderCon, renderData, renderSet, renderTuple, renderUnionCon, renderWrapped) -import Data.Morpheus.Types.Internal.Data (DataArgument, DataField (..), DataFullType (..), DataLeaf (..), - DataTyCon (..), TypeAlias (..), isNullable) +import Data.Morpheus.Types.Internal.Data (DataArgument, DataField (..), DataType (..), DataTyCon (..), + TypeAlias (..), isNullable) -renderType :: Context -> (Text, DataFullType) -> Text +renderType :: Context -> (Text, DataType) -> Text renderType context (name, dataType) = typeIntro <> renderData name <> renderT dataType where - renderT (Leaf (BaseScalar _)) = renderCon name <> "Int Int" <> defineTypeClass "SCALAR" <> renderGQLScalar name - renderT (Leaf (CustomScalar _)) = renderCon name <> "Int Int" <> defineTypeClass "SCALAR" <> renderGQLScalar name - renderT (Leaf (LeafEnum DataTyCon {typeData})) = unionType typeData <> defineTypeClass "ENUM" - renderT (Union DataTyCon {typeData}) = renderUnion name typeData <> defineTypeClass "UNION" - renderT (InputObject DataTyCon {typeData}) = + renderT (DataScalar _) = renderCon name <> "Int Int" <> defineTypeClass "SCALAR" <> renderGQLScalar name + renderT (DataEnum DataTyCon {typeData}) = unionType typeData <> defineTypeClass "ENUM" + renderT (DataUnion DataTyCon {typeData}) = renderUnion name typeData <> defineTypeClass "UNION" + renderT (DataInputObject DataTyCon {typeData}) = renderCon name <> renderObject renderInputField typeData <> defineTypeClass "INPUT_OBJECT" - renderT (InputUnion _) = "\n -- Error: Input Union Not Supported" - renderT (OutputObject DataTyCon {typeData}) = + renderT (DataInputUnion _) = "\n -- Error: Input Union Not Supported" + renderT (DataObject DataTyCon {typeData}) = renderCon name <> renderObject (renderField context) typeData <> defineTypeClass "OBJECT" ---------------------------------------------------------------------------------------------------------- typeIntro = "\n\n---- GQL " <> name <> " ------------------------------- \n" diff --git a/src/Data/Morpheus/Rendering/Haskell/Values.hs b/src/Data/Morpheus/Rendering/Haskell/Values.hs --- a/src/Data/Morpheus/Rendering/Haskell/Values.hs +++ b/src/Data/Morpheus/Rendering/Haskell/Values.hs @@ -13,8 +13,8 @@ -- MORPHEUS import Data.Morpheus.Rendering.Haskell.Terms (Context (..), Scope (..), renderAssignment, renderCon, renderEqual, renderReturn, renderSet, renderUnionCon) -import Data.Morpheus.Types.Internal.Data (DataField (..), DataFullType (..), DataLeaf (..), - DataTyCon (..), DataTypeLib (..), TypeAlias (..), WrapperD (..)) +import Data.Morpheus.Types.Internal.Data (DataField (..), DataType (..), DataTyCon (..), + DataTypeLib (..), TypeAlias (..), WrapperD (..)) renderRootResolver :: Context -> DataTypeLib -> Text renderRootResolver _ DataTypeLib {mutation, subscription} = renderSignature <> renderBody <> "\n\n" @@ -37,16 +37,15 @@ maybeRes (Just (name, _)) = "resolve" <> name maybeRes Nothing = "return ()" -renderResolver :: Context -> (Text, DataFullType) -> Text +renderResolver :: Context -> (Text, DataType) -> Text renderResolver Context {scope, pubSub = (channel, content)} (name, dataType) = renderSig dataType where - renderSig (Leaf BaseScalar {}) = defFunc <> renderReturn <> "$ " <> renderCon name <> "0 0" - renderSig (Leaf CustomScalar {}) = defFunc <> renderReturn <> "$ " <> renderCon name <> "0 0" - renderSig (Leaf (LeafEnum DataTyCon {typeData})) = defFunc <> renderReturn <> renderCon (head typeData) - renderSig (Union DataTyCon {typeData}) = defFunc <> renderUnionCon name typeCon <> " <$> " <> "resolve" <> typeCon + renderSig DataScalar {} = defFunc <> renderReturn <> "$ " <> renderCon name <> "0 0" + renderSig (DataEnum DataTyCon {typeData}) = defFunc <> renderReturn <> renderCon (head typeData) + renderSig (DataUnion DataTyCon {typeData}) = defFunc <> renderUnionCon name typeCon <> " <$> " <> "resolve" <> typeCon where typeCon = aliasTyCon $ fieldType $ head typeData - renderSig (OutputObject DataTyCon {typeData}) = defFunc <> renderReturn <> renderCon name <> renderObjFields + renderSig (DataObject DataTyCon {typeData}) = defFunc <> renderReturn <> renderCon name <> renderObjFields where renderObjFields = renderResObject (map renderFieldRes typeData) renderFieldRes (key, DataField {fieldType = TypeAlias {aliasWrappers, aliasTyCon}}) = diff --git a/src/Data/Morpheus/Rendering/RenderGQL.hs b/src/Data/Morpheus/Rendering/RenderGQL.hs --- a/src/Data/Morpheus/Rendering/RenderGQL.hs +++ b/src/Data/Morpheus/Rendering/RenderGQL.hs @@ -16,10 +16,9 @@ import Data.Text.Lazy.Encoding (encodeUtf8) -- MORPHEUS -import Data.Morpheus.Types.Internal.Data (DataField (..), DataFullType (..), DataKind (..), DataLeaf (..), - DataTyCon (..), DataTypeLib, DataTypeWrapper (..), Key, - TypeAlias (..), WrapperD (..), allDataTypes, isDefaultTypeName, - toGQLWrapper) +import Data.Morpheus.Types.Internal.Data (DataField (..), DataTyCon (..), DataType (..), DataTypeLib, + DataTypeWrapper (..), Key, TypeAlias (..), WrapperD (..), + allDataTypes, isDefaultTypeName, toGQLWrapper) import Data.Morpheus.Types.Internal.Value (convertToJSONName) renderGraphQLDocument :: DataTypeLib -> ByteString @@ -43,21 +42,22 @@ instance RenderGQL TypeAlias where render TypeAlias {aliasTyCon, aliasWrappers} = renderWrapped aliasTyCon aliasWrappers -instance RenderGQL DataKind where - render (ScalarKind x) = typeName x - render (EnumKind x) = typeName x - render (ObjectKind x) = typeName x - render (UnionKind x) = typeName x +instance RenderGQL DataType where + render (DataScalar x) = typeName x + render (DataEnum x) = typeName x + render (DataUnion x) = typeName x + render (DataInputObject x) = typeName x + render (DataInputUnion x) = typeName x + render ( DataObject x) = typeName x -instance RenderGQL (Key, DataFullType) where - render (name, Leaf (BaseScalar _)) = "scalar " <> name - render (name, Leaf (CustomScalar _)) = "scalar " <> name - render (name, Leaf (LeafEnum DataTyCon {typeData})) = "enum " <> name <> renderObject id typeData - render (name, Union DataTyCon {typeData}) = +instance RenderGQL (Key, DataType) where + render (name, DataScalar {}) = "scalar " <> name + render (name, DataEnum DataTyCon {typeData}) = "enum " <> name <> renderObject id typeData + render (name, DataUnion DataTyCon {typeData}) = "union " <> name <> " =\n " <> intercalate ("\n" <> renderIndent <> "| ") (map (render . fieldType) typeData) - render (name, InputObject DataTyCon {typeData}) = "input " <> name <> render typeData - render (name, InputUnion DataTyCon {typeData}) = "input " <> name <> render (mapKeys typeData) - render (name, OutputObject DataTyCon {typeData}) = "type " <> name <> render typeData + render (name, DataInputObject DataTyCon {typeData}) = "input " <> name <> render typeData + render (name, DataInputUnion DataTyCon {typeData}) = "input " <> name <> render (mapKeys typeData) + render (name, DataObject DataTyCon {typeData}) = "type " <> name <> render typeData mapKeys :: [DataField] -> [(Text, DataField)] mapKeys = map (\x -> (fieldName x, x)) diff --git a/src/Data/Morpheus/Rendering/RenderIntrospection.hs b/src/Data/Morpheus/Rendering/RenderIntrospection.hs --- a/src/Data/Morpheus/Rendering/RenderIntrospection.hs +++ b/src/Data/Morpheus/Rendering/RenderIntrospection.hs @@ -8,6 +8,7 @@ , createObjectType ) where +import Control.Monad.Fail (MonadFail) import Data.Semigroup ((<>)) import Data.Text (Text, unpack) @@ -15,10 +16,9 @@ -- Morpheus import Data.Morpheus.Schema.TypeKind (TypeKind (..)) -import Data.Morpheus.Types.Internal.Data (DataField (..), DataField, DataFullType (..), DataLeaf (..), - DataObject, DataTyCon (..), DataTypeKind (..), DataTypeLib, - DataTypeWrapper (..), DataUnion, TypeAlias (..), kindOf, - lookupDataType, toGQLWrapper) +import Data.Morpheus.Types.Internal.Data (DataField (..), DataObject, DataTyCon (..), DataType (..), + DataTypeKind (..), DataTypeLib, DataTypeWrapper (..), DataUnion, + TypeAlias (..), kindOf, lookupDataType, toGQLWrapper) import Data.Morpheus.Types.Internal.Value (convertToJSONName) constRes :: Applicative m => a -> b -> m a @@ -27,24 +27,21 @@ type Result m a = DataTypeLib -> m a class RenderSchema a b where - render :: Monad m => (Text, a) -> DataTypeLib -> m (b m) + render :: (Monad m, MonadFail m) => (Text, a) -> DataTypeLib -> m (b m) -instance RenderSchema DataFullType S__Type where - render (name, Leaf leaf) = render (name, leaf) - render (name, InputObject iObject) = renderInputObject (name, iObject) - render (name, OutputObject object') = typeFromObject (name, object') +instance RenderSchema DataType S__Type where + render (key, DataScalar DataTyCon {typeDescription}) = + constRes $ createLeafType SCALAR key typeDescription Nothing + render (key, DataEnum DataTyCon {typeDescription, typeData}) = + constRes $ createLeafType ENUM key typeDescription (Just $ map createEnumValue typeData) + render (name, DataInputObject iObject) = renderInputObject (name, iObject) + render (name, DataObject object') = typeFromObject (name, object') where typeFromObject (key, DataTyCon {typeData, typeDescription}) lib = createObjectType key typeDescription <$> (Just <$> traverse (`render` lib) (filter (not . fieldHidden . snd) typeData)) - render (name, Union union') = const $ pure $ typeFromUnion (name, union') - render (name, InputUnion inpUnion') = renderInputUnion (name, inpUnion') - -instance RenderSchema DataLeaf S__Type where - render (key, BaseScalar DataTyCon {typeDescription}) _ = pure $ createLeafType SCALAR key typeDescription Nothing - render (key, CustomScalar DataTyCon {typeDescription}) _ = pure $ createLeafType SCALAR key typeDescription Nothing - render (key, LeafEnum DataTyCon {typeDescription, typeData}) _ = - pure $ createLeafType ENUM key typeDescription (Just $ map createEnumValue typeData) + render (name, DataUnion union') = const $ pure $ typeFromUnion (name, union') + render (name, DataInputUnion inpUnion') = renderInputUnion (name, inpUnion') instance RenderSchema DataField S__Field where render (key, field@DataField {fieldType = TypeAlias {aliasTyCon}, fieldArgs}) lib = do @@ -69,26 +66,26 @@ wrapByTypeWrapper ListType = wrapAs LIST wrapByTypeWrapper NonNullType = wrapAs NON_NULL -lookupKind :: Monad m => Text -> Result m DataTypeKind +lookupKind :: (Monad m, MonadFail m) => Text -> Result m DataTypeKind lookupKind name lib = case lookupDataType name lib of Nothing -> fail $ unpack ("Kind Not Found: " <> name) Just value -> pure (kindOf value) -inputValueFromArg :: Monad m => (Text, DataField) -> Result m (S__InputValue m) +inputValueFromArg :: (Monad m,MonadFail m) => (Text, DataField) -> Result m (S__InputValue m) inputValueFromArg (key, input) = fmap (createInputValueWith key) . createInputObjectType input -createInputObjectType :: Monad m => DataField -> Result m (S__Type m) +createInputObjectType :: (Monad m, MonadFail m) => DataField -> Result m (S__Type m) createInputObjectType field@DataField {fieldType = TypeAlias {aliasTyCon}} lib = do kind <- renderTypeKind <$> lookupKind aliasTyCon lib pure $ wrap field $ createType kind aliasTyCon Nothing $ Just [] -renderInputObject :: Monad m => (Text, DataObject) -> Result m (S__Type m) +renderInputObject :: (Monad m, MonadFail m) => (Text, DataObject) -> Result m (S__Type m) renderInputObject (key, DataTyCon {typeData, typeDescription}) lib = do fields <- traverse (`inputValueFromArg` lib) typeData pure $ createInputObject key typeDescription fields -renderInputUnion :: Monad m => (Text, DataUnion) -> Result m (S__Type m) +renderInputUnion :: (Monad m, MonadFail m) => (Text, DataUnion) -> Result m (S__Type m) renderInputUnion (key', DataTyCon {typeData, typeDescription}) lib = createInputObject key' typeDescription <$> traverse createField typeData where diff --git a/src/Data/Morpheus/Types.hs b/src/Data/Morpheus/Types.hs --- a/src/Data/Morpheus/Types.hs +++ b/src/Data/Morpheus/Types.hs @@ -24,13 +24,16 @@ , QUERY , MUTATION , SUBSCRIPTION + , liftEitherM + , liftM ) where import Data.Morpheus.Types.GQLScalar (GQLScalar (parseValue, serialize)) import Data.Morpheus.Types.GQLType (GQLType (KIND, description)) import Data.Morpheus.Types.ID (ID (..)) import Data.Morpheus.Types.Internal.Data (MUTATION, QUERY, SUBSCRIPTION) -import Data.Morpheus.Types.Internal.Resolver (Event (..), GQLRootResolver (..), PureOperation, Resolver (..)) +import Data.Morpheus.Types.Internal.Resolver (Event (..), GQLRootResolver (..), PureOperation, Resolver (..), + liftEitherM, liftM) import Data.Morpheus.Types.Internal.Value (ScalarValue (..)) import Data.Morpheus.Types.IO (GQLRequest (..), GQLResponse (..)) import Data.Morpheus.Types.Types (Undefined (..)) diff --git a/src/Data/Morpheus/Types/Internal/Data.hs b/src/Data/Morpheus/Types/Internal/Data.hs --- a/src/Data/Morpheus/Types/Internal/Data.hs +++ b/src/Data/Morpheus/Types/Internal/Data.hs @@ -21,9 +21,7 @@ , DataArguments , DataField(..) , DataTyCon(..) - , DataLeaf(..) - , DataKind(..) - , DataFullType(..) + , DataType(..) , DataTypeLib(..) , DataTypeWrapper(..) , DataValidator(..) @@ -61,6 +59,7 @@ , SUBSCRIPTION , Name , Description + , isEntNode ) where import Data.Semigroup ((<>)) @@ -234,42 +233,35 @@ , typeData :: a } deriving (Show) -data DataLeaf - = BaseScalar DataScalar - | CustomScalar DataScalar - | LeafEnum DataEnum - deriving (Show) - --- DATA KIND -data DataKind - = ScalarKind DataScalar - | EnumKind DataEnum - | ObjectKind DataObject - | UnionKind DataUnion - deriving (Show) - data RawDataType - = FinalDataType DataFullType + = FinalDataType DataType | Interface DataObject | Implements { implementsInterfaces :: [Key] , unImplements :: DataObject } deriving (Show) -data DataFullType - = Leaf DataLeaf - | InputObject DataObject - | OutputObject DataObject - | Union DataUnion - | InputUnion DataUnion +isEntNode :: DataType -> Bool +isEntNode DataScalar {} = True +isEntNode DataEnum {} = True +isEntNode _ = False + +data DataType + = DataScalar DataScalar + | DataEnum DataEnum + | DataInputObject DataObject + | DataObject DataObject + | DataUnion DataUnion + | DataInputUnion DataUnion deriving (Show) data DataTypeLib = DataTypeLib - { leaf :: [(Key, DataLeaf)] + { scalar :: [(Key, DataScalar)] + , enum :: [(Key, DataEnum)] , inputObject :: [(Key, DataObject)] , object :: [(Key, DataObject)] , union :: [(Key, DataUnion)] , inputUnion :: [(Key, DataUnion)] - , query :: (Key, DataObject) + , query :: (Key, DataObject) , mutation :: Maybe (Key, DataObject) , subscription :: Maybe (Key, DataObject) } deriving (Show) @@ -277,7 +269,8 @@ initTypeLib :: (Key, DataObject) -> DataTypeLib initTypeLib query = DataTypeLib - { leaf = [] + { scalar = [] + , enum = [] , inputObject = [] , query = query , object = [] @@ -287,50 +280,50 @@ , subscription = Nothing } -allDataTypes :: DataTypeLib -> [(Key, DataFullType)] -allDataTypes (DataTypeLib leaf' inputObject' object' union' inputUnion' query' mutation' subscription') = - packType OutputObject query' : - fromMaybeType mutation' ++ - fromMaybeType subscription' ++ - map (packType Leaf) leaf' ++ - map (packType InputObject) inputObject' ++ - map (packType InputUnion) inputUnion' ++ map (packType OutputObject) object' ++ map (packType Union) union' +allDataTypes :: DataTypeLib -> [(Key, DataType)] +allDataTypes DataTypeLib { scalar, enum , inputObject, object, union, inputUnion, query, mutation, subscription } = + packType DataObject query : + fromMaybeType mutation ++ + fromMaybeType subscription ++ + map (packType DataScalar) scalar ++ + map (packType DataEnum) enum ++ + map (packType DataInputObject) inputObject ++ + map (packType DataInputUnion) inputUnion ++ map (packType DataObject) object ++ map (packType DataUnion) union where packType f (x, y) = (x, f y) - fromMaybeType :: Maybe (Key, DataObject) -> [(Key, DataFullType)] - fromMaybeType (Just (key', dataType')) = [(key', OutputObject dataType')] + fromMaybeType :: Maybe (Key, DataObject) -> [(Key, DataType)] + fromMaybeType (Just (key', dataType')) = [(key', DataObject dataType')] fromMaybeType Nothing = [] -lookupDataType :: Key -> DataTypeLib -> Maybe DataFullType +lookupDataType :: Key -> DataTypeLib -> Maybe DataType lookupDataType name lib = name `lookup` allDataTypes lib -kindOf :: DataFullType -> DataTypeKind -kindOf (Leaf (BaseScalar _)) = KindScalar -kindOf (Leaf (CustomScalar _)) = KindScalar -kindOf (Leaf (LeafEnum _)) = KindEnum -kindOf (InputObject _) = KindInputObject -kindOf (OutputObject _) = KindObject Nothing -kindOf (Union _) = KindUnion -kindOf (InputUnion _) = KindInputUnion +kindOf :: DataType -> DataTypeKind +kindOf (DataScalar _) = KindScalar +kindOf (DataEnum _) = KindEnum +kindOf (DataInputObject _) = KindInputObject +kindOf (DataObject _) = KindObject Nothing +kindOf (DataUnion _) = KindUnion +kindOf (DataInputUnion _) = KindInputUnion -fromDataType :: (DataTyCon () -> v) -> DataFullType -> v -fromDataType f (Leaf (BaseScalar dt)) = f dt {typeData = ()} -fromDataType f (Leaf (CustomScalar dt)) = f dt {typeData = ()} -fromDataType f (Leaf (LeafEnum dt)) = f dt {typeData = ()} -fromDataType f (Union dt) = f dt {typeData = ()} -fromDataType f (InputObject dt) = f dt {typeData = ()} -fromDataType f (InputUnion dt) = f dt {typeData = ()} -fromDataType f (OutputObject dt) = f dt {typeData = ()} +fromDataType :: (DataTyCon () -> v) -> DataType -> v +fromDataType f (DataScalar dt) = f dt {typeData = ()} +fromDataType f (DataEnum dt) = f dt {typeData = ()} +fromDataType f (DataUnion dt) = f dt {typeData = ()} +fromDataType f (DataInputObject dt) = f dt {typeData = ()} +fromDataType f (DataInputUnion dt) = f dt {typeData = ()} +fromDataType f (DataObject dt) = f dt {typeData = ()} isTypeDefined :: Key -> DataTypeLib -> Maybe DataFingerprint isTypeDefined name lib = fromDataType typeFingerprint <$> lookupDataType name lib -defineType :: (Key, DataFullType) -> DataTypeLib -> DataTypeLib -defineType (key', Leaf type') lib = lib {leaf = (key', type') : leaf lib} -defineType (key', InputObject type') lib = lib {inputObject = (key', type') : inputObject lib} -defineType (key', OutputObject type') lib = lib {object = (key', type') : object lib} -defineType (key', Union type') lib = lib {union = (key', type') : union lib} -defineType (key', InputUnion type') lib = lib {inputUnion = (key', type') : inputUnion lib} +defineType :: (Key, DataType) -> DataTypeLib -> DataTypeLib +defineType (key', DataScalar type') lib = lib {scalar = (key', type') : scalar lib} +defineType (key', DataEnum type') lib = lib {enum = (key', type') : enum lib} +defineType (key', DataInputObject type') lib = lib {inputObject = (key', type') : inputObject lib} +defineType (key', DataObject type') lib = lib {object = (key', type') : object lib} +defineType (key', DataUnion type') lib = lib {union = (key', type') : union lib} +defineType (key', DataInputUnion type') lib = lib {inputUnion = (key', type') : inputUnion lib} toNullableField :: DataField -> DataField toNullableField dataField diff --git a/src/Data/Morpheus/Types/Internal/Resolver.hs b/src/Data/Morpheus/Types/Internal/Resolver.hs --- a/src/Data/Morpheus/Types/Internal/Resolver.hs +++ b/src/Data/Morpheus/Types/Internal/Resolver.hs @@ -17,9 +17,7 @@ , Event(..) , GQLRootResolver(..) , UnSubResolver - , GQLFail(..) , ResponseT - , failResolveT , Resolver(..) , ResolvingStrategy(..) , MapGraphQLT(..) @@ -28,18 +26,19 @@ , toResponseRes , withObject , Resolving(..) + , liftM + , liftEitherM ) where +import Control.Monad.Fail (MonadFail (..)) import Control.Monad.Trans.Except (ExceptT (..), runExceptT, withExceptT) import Data.Maybe (fromMaybe) import Data.Semigroup ((<>)) -import Data.Text (pack, unpack) -- MORPHEUS import Data.Morpheus.Error.Selection (resolverError, subfieldsNotSelected) import Data.Morpheus.Types.Internal.AST.Selection (Selection (..), SelectionRec (..), SelectionSet, ValidSelection) -import Data.Morpheus.Types.Internal.Base (Message) import Data.Morpheus.Types.Internal.Data (Key, MUTATION, OperationType, QUERY, SUBSCRIPTION) import Data.Morpheus.Types.Internal.Stream (Channel (..), Event (..), ResponseEvent (..), ResponseStream, StreamChannel, StreamState (..), @@ -52,26 +51,20 @@ withObject f (_, Selection {selectionRec = SelectionSet selection}) = f selection withObject _ (key, Selection {selectionPosition}) = Fail $ subfieldsNotSelected key "" selectionPosition -class Monad m => - GQLFail (t :: (* -> *) -> * -> *) m - where - gqlFail :: Monad m => Message -> t m a - toSuccess :: Monad m => (Message -> b) -> (a -> b) -> t m a -> t m b - -instance Monad m => GQLFail (ExceptT String) m where - gqlFail = ExceptT . pure . Left . unpack - toSuccess fFail fSuc (ExceptT value) = ExceptT $ pure . mapCases <$> value - where - mapCases (Right x) = fSuc x - mapCases (Left x) = fFail $ pack $ show x +liftM :: (PureOperation o, Monad m) => m a -> Resolver o m e a +liftM = liftEither . fmap pure +liftEitherM :: (PureOperation o, Monad m) => m (Either String a) -> Resolver o m e a +liftEitherM = liftEither ---------------------------------------------------------------------------------------- type ResolveT = ExceptT GQLErrors type ResponseT m e = ResolveT (ResponseStream m e) +instance Monad m => MonadFail (Resolver QUERY m e) where + fail = FailedResolver + -- -- Recursive Resolver - newtype RecResolver m a b = RecResolver { unRecResolver :: a -> ResolveT m b } @@ -126,6 +119,7 @@ pure (f1 <*> res1) -- GADTResolver +--------------------------------------------------------------- data Resolver (o::OperationType) (m :: * -> * ) event value where FailedResolver :: { unFailedResolver :: String } -> Resolver o m event value QueryResolver:: { unQueryResolver :: ExceptT String m value } -> Resolver QUERY m event value @@ -149,7 +143,7 @@ -- GADTResolver Applicative instance (PureOperation o ,Monad m) => Applicative (Resolver o m e) where - pure = pureRes + pure = liftEither . pure . pure ------------------------------------- _ <*> (FailedResolver mErrors) = FailedResolver mErrors (FailedResolver mErrors) <*> _ = FailedResolver mErrors @@ -170,22 +164,22 @@ -- Pure Operation class PureOperation (o::OperationType) where - pureRes :: Monad m => a -> Resolver o m event a + liftEither :: Monad m => m (Either String a) -> Resolver o m event a pureGraphQLT :: Monad m => a -> ResolvingStrategy o m event a eitherGraphQLT :: Monad m => Validation a -> ResolvingStrategy o m event a instance PureOperation QUERY where - pureRes = QueryResolver . pure + liftEither = QueryResolver . ExceptT pureGraphQLT = QueryResolving . pure eitherGraphQLT = QueryResolving . ExceptT . pure instance PureOperation MUTATION where - pureRes = MutResolver [] . pure + liftEither = MutResolver [] . ExceptT pureGraphQLT = MutationResolving . pure eitherGraphQLT = MutationResolving . ExceptT . pure instance PureOperation SUBSCRIPTION where - pureRes = SubResolver [] . const . pure + liftEither = SubResolver [] . const . liftEither pureGraphQLT = SubscriptionResolving . pure . pure eitherGraphQLT = SubscriptionResolving . fmap pure . ExceptT . pure @@ -257,10 +251,6 @@ type family UnSubResolver (a :: * -> *) :: (* -> *) type instance UnSubResolver (Resolver SUBSCRIPTION m e) = Resolver QUERY m e - -------------------------------------------------------------------- -failResolveT :: Monad m => GQLErrors -> ResolveT m a -failResolveT = ExceptT . pure . Left ------------------------------------------------------------------- -- | GraphQL Root resolver, also the interpreter generates a GQL schema from it. diff --git a/src/Data/Morpheus/Types/Internal/TH.hs b/src/Data/Morpheus/Types/Internal/TH.hs --- a/src/Data/Morpheus/Types/Internal/TH.hs +++ b/src/Data/Morpheus/Types/Internal/TH.hs @@ -8,7 +8,7 @@ liftMaybeText :: Maybe Text -> ExpQ liftMaybeText (Just x) = appE (conE 'Just) (liftText x) -liftMaybeText Nothing = conE 'Nothing +liftMaybeText Nothing = conE 'Nothing liftText :: Text -> ExpQ liftText x = appE (varE 'pack) (lift (unpack x)) @@ -40,3 +40,8 @@ -- "User" -> ["name","id"] -> (User name id) destructRecord :: String -> [String] -> PatQ destructRecord conName fields = conP (mkName conName) (map (varP . mkName) fields) + +typeInstanceDec :: Name -> Type -> Type -> Dec +typeInstanceDec typeFamily arg res = TySynInstD typeFamily (TySynEqn [arg] res) +-- : TODO after th 2.15.0.0 +-- typeInstanceDec typeFamily arg res = TySynInstD (TySynEqn Nothing (AppT (ConT typeFamily) arg) res) diff --git a/src/Data/Morpheus/Validation/Document/Validation.hs b/src/Data/Morpheus/Validation/Document/Validation.hs --- a/src/Data/Morpheus/Validation/Document/Validation.hs +++ b/src/Data/Morpheus/Validation/Document/Validation.hs @@ -10,25 +10,25 @@ -- Morpheus import Data.Morpheus.Error.Document.Interface (ImplementsError (..), partialImplements, unknownInterface) import Data.Morpheus.Rendering.RenderGQL (RenderGQL (..)) -import Data.Morpheus.Types.Internal.Data (DataField (..), DataFullType (..), DataObject, DataTyCon (..), +import Data.Morpheus.Types.Internal.Data (DataField (..), DataType (..), DataObject, DataTyCon (..), Key, RawDataType (..), TypeAlias (..), isWeaker, isWeaker) import Data.Morpheus.Types.Internal.Validation (Validation) -validatePartialDocument :: [(Key, RawDataType)] -> Validation [(Key, DataFullType)] +validatePartialDocument :: [(Key, RawDataType)] -> Validation [(Key, DataType)] validatePartialDocument lib = catMaybes <$> traverse validateType lib where - validateType :: (Key, RawDataType) -> Validation (Maybe (Key, DataFullType)) + validateType :: (Key, RawDataType) -> Validation (Maybe (Key, DataType)) validateType (name, FinalDataType x) = pure $ Just (name, x) validateType (name, Implements interfaces object) = asTuple name <$> object `mustImplement` interfaces validateType _ = pure Nothing ----------------------------------- asTuple name x = Just (name, x) ----------------------------------- - mustImplement :: DataObject -> [Key] -> Validation DataFullType + mustImplement :: DataObject -> [Key] -> Validation DataType mustImplement object interfaceKey = do interface <- traverse getInterfaceByKey interfaceKey case concatMap (mustBeSubset object) interface of - [] -> pure $ OutputObject object + [] -> pure $ DataObject object errors -> Left $ partialImplements (typeName object) errors ------------------------------- mustBeSubset :: DataObject -> DataObject -> [(Key, Key, ImplementsError)] diff --git a/src/Data/Morpheus/Validation/Internal/Utils.hs b/src/Data/Morpheus/Validation/Internal/Utils.hs --- a/src/Data/Morpheus/Validation/Internal/Utils.hs +++ b/src/Data/Morpheus/Validation/Internal/Utils.hs @@ -12,7 +12,7 @@ import Data.List ((\\)) import Data.Morpheus.Error.Variable (unknownType) import Data.Morpheus.Types.Internal.Base (EnhancedKey (..), Key, Position, enhanceKeyWithNull) -import Data.Morpheus.Types.Internal.Data (DataKind (..), DataLeaf (..), DataObject, DataTypeLib (..)) +import Data.Morpheus.Types.Internal.Data (DataObject, DataType (..), DataTypeLib (..)) import Data.Morpheus.Types.Internal.Validation (Validation) import qualified Data.Set as S import Data.Text (Text) @@ -36,19 +36,19 @@ Nothing -> Left error' Just field -> pure field -getInputType :: Text -> DataTypeLib -> GenError error DataKind -getInputType typeName' lib error' = - case lookup typeName' (inputObject lib) of - Just x -> pure (ObjectKind x) +getInputType :: Text -> DataTypeLib -> GenError error DataType +getInputType name lib gqlError = + case lookup name (inputObject lib) of + Just x -> pure (DataInputObject x) Nothing -> - case lookup typeName' (inputUnion lib) of - Just x -> pure (UnionKind x) + case lookup name (inputUnion lib) of + Just x -> pure (DataInputUnion x) Nothing -> - case lookup typeName' (leaf lib) of - Nothing -> Left error' - Just (BaseScalar x) -> pure (ScalarKind x) - Just (CustomScalar x) -> pure (ScalarKind x) - Just (LeafEnum x) -> pure (EnumKind x) + case lookup name (scalar lib) of + Just x -> pure (DataScalar x) + Nothing -> case lookup name (enum lib) of + Just x -> pure (DataEnum x) + Nothing -> Left gqlError existsObjectType :: Position -> Text -> DataTypeLib -> Validation DataObject existsObjectType position' typeName' lib = lookupType error' (object lib) typeName' diff --git a/src/Data/Morpheus/Validation/Internal/Value.hs b/src/Data/Morpheus/Validation/Internal/Value.hs --- a/src/Data/Morpheus/Validation/Internal/Value.hs +++ b/src/Data/Morpheus/Validation/Internal/Value.hs @@ -11,20 +11,20 @@ -- MORPHEUS import Data.Morpheus.Error.Input (InputError (..), InputValidation, Prop (..)) import Data.Morpheus.Rendering.RenderGQL (renderWrapped) -import Data.Morpheus.Types.Internal.Data (DataField (..), DataKind (..), DataTyCon (..), +import Data.Morpheus.Types.Internal.Data (DataField (..), DataTyCon (..), DataType (..), DataTypeLib (..), DataValidator (..), Key, TypeAlias (..), WrapperD (..), isNullable) import Data.Morpheus.Types.Internal.Value (Value (..)) import Data.Morpheus.Validation.Internal.Utils (getInputType, lookupField) -- Validate Variable Argument or all Possible input Values -validateInputValue :: DataTypeLib -> [Prop] -> [WrapperD] -> DataKind -> (Key, Value) -> InputValidation Value +validateInputValue :: DataTypeLib -> [Prop] -> [WrapperD] -> DataType -> (Key, Value) -> InputValidation Value validateInputValue lib prop' = validate where - throwError :: [WrapperD] -> DataKind -> Value -> InputValidation Value - throwError wrappers type' value' = Left $ UnexpectedType prop' (renderWrapped type' wrappers) value' Nothing + throwError :: [WrapperD] -> DataType -> Value -> InputValidation Value + throwError wrappers datatype value = Left $ UnexpectedType prop' (renderWrapped datatype wrappers) value Nothing -- VALIDATION - validate :: [WrapperD] -> DataKind -> (Key, Value) -> InputValidation Value + validate :: [WrapperD] -> DataType -> (Key, Value) -> InputValidation Value -- Validate Null. value = null ? validate wrappers tName (_, Null) | isNullable wrappers = return Null @@ -36,7 +36,7 @@ validateElement element' = validateInputValue lib prop' wrappers type' (key', element') {-- 2. VALIDATE TYPES, all wrappers are already Processed --} {-- VALIDATE OBJECT--} - validate [] (ObjectKind DataTyCon {typeData = parentFields'}) (_, Object fields) = + validate [] (DataInputObject DataTyCon {typeData = parentFields'}) (_, Object fields) = Object <$> mapM validateField fields where validateField (_name, value) = do @@ -53,18 +53,18 @@ getField = lookupField _name parentFields' (UnknownField prop' _name) -- VALIDATE INPUT UNION -- TODO: Validate Union - validate [] (UnionKind DataTyCon {typeData}) (_, Object fields) = return (Object fields) + validate [] (DataInputUnion DataTyCon {typeData}) (_, Object fields) = return (Object fields) {-- VALIDATE SCALAR --} - validate [] (EnumKind DataTyCon {typeData = tags', typeName = name'}) (_, value') = + validate [] (DataEnum DataTyCon {typeData = tags', typeName = name'}) (_, value') = validateEnum (UnexpectedType prop' name' value' Nothing) tags' value' {-- VALIDATE ENUM --} - validate [] (ScalarKind DataTyCon {typeName = name', typeData = DataValidator {validateValue = validator'}}) (_, value') = + validate [] (DataScalar DataTyCon {typeName = name', typeData = DataValidator {validateValue = validator'}}) (_, value') = case validator' value' of Right _ -> return value' Left "" -> Left $ UnexpectedType prop' name' value' Nothing Left errorMessage -> Left $ UnexpectedType prop' name' value' (Just errorMessage) {-- 3. THROW ERROR: on invalid values --} - validate wrappers' type' (_, value') = throwError wrappers' type' value' + validate wrappers datatype (_, value) = throwError wrappers datatype value validateEnum :: error -> [Key] -> Value -> Either error Value validateEnum error' tags' (Enum enumValue) = diff --git a/src/Data/Morpheus/Validation/Query/Selection.hs b/src/Data/Morpheus/Validation/Query/Selection.hs --- a/src/Data/Morpheus/Validation/Query/Selection.hs +++ b/src/Data/Morpheus/Validation/Query/Selection.hs @@ -21,9 +21,9 @@ RawSelectionSet) import Data.Morpheus.Types.Internal.AST.Selection (Selection (..), SelectionRec (..), SelectionSet) import Data.Morpheus.Types.Internal.Base (EnhancedKey (..)) -import Data.Morpheus.Types.Internal.Data (DataField (..), DataFullType (..), DataObject, +import Data.Morpheus.Types.Internal.Data (DataField (..), DataType (..), DataObject, DataTyCon (..), DataTypeLib (..), TypeAlias (..), - allDataTypes) + allDataTypes, isEntNode) import Data.Morpheus.Types.Internal.Validation (Validation) import Data.Morpheus.Validation.Internal.Utils (checkNameCollision, lookupType) import Data.Morpheus.Validation.Query.Arguments (validateArguments) @@ -119,7 +119,7 @@ validateSelection (key', RawSelectionSet fullRawSelection@Selection { selectionRec = rawSelection, selectionPosition }) = do (dataField, dataType, arguments) <- getValidationData key' fullRawSelection case dataType of - Union _ -> do + DataUnion _ -> do (categories, __typename) <- clusterTypes mapM (validateCluster __typename) categories >>= returnSelection arguments . UnionSelection where clusterTypes = do @@ -133,7 +133,7 @@ validateCluster sysSelection' (type', frags') = do selection' <- __validate type' (concatMap fragmentSelection frags') return (typeName type', sysSelection' ++ selection') - OutputObject _ -> do + DataObject _ -> do fieldType' <- lookupFieldAsSelectionSet selectionPosition key' lib dataField __validate fieldType' rawSelection >>= returnSelection arguments . SelectionSet _ -> Left $ hasNoSubfields key' (aliasTyCon $fieldType dataField) selectionPosition @@ -152,9 +152,9 @@ isLeaf datatype dataField pure [( key , rawSelection { selectionArguments , selectionRec = SelectionField })] where - isLeaf (Leaf _) _ = Right () - isLeaf _ DataField {fieldType = TypeAlias {aliasTyCon}} = - Left $ subfieldsNotSelected key aliasTyCon selectionPosition + isLeaf dataType DataField {fieldType = TypeAlias {aliasTyCon}} + | isEntNode dataType = Right () + | otherwise = Left $ subfieldsNotSelected key aliasTyCon selectionPosition validateSelection (_, Spread reference') = resolveSpread fragments' [typeName'] reference' >>= validateFragment validateSelection (_, InlineFragment fragment') = castFragmentType Nothing (fragmentPosition fragment') [typeName'] fragment' >>= validateFragment diff --git a/src/Data/Morpheus/Validation/Query/Variable.hs b/src/Data/Morpheus/Validation/Query/Variable.hs --- a/src/Data/Morpheus/Validation/Query/Variable.hs +++ b/src/Data/Morpheus/Validation/Query/Variable.hs @@ -20,7 +20,7 @@ RawSelection (..), RawSelectionSet, Reference (..), Selection (..)) import Data.Morpheus.Types.Internal.Base (EnhancedKey (..), Position) -import Data.Morpheus.Types.Internal.Data (DataKind, DataTypeLib) +import Data.Morpheus.Types.Internal.Data (DataType, DataTypeLib) import Data.Morpheus.Types.Internal.Validation (Validation) import Data.Morpheus.Types.Internal.Value (Value (..)) import Data.Morpheus.Types.Types (Variables) @@ -28,7 +28,7 @@ import Data.Morpheus.Validation.Internal.Value (validateInputValue) import Data.Morpheus.Validation.Query.Fragment (getFragment) -getVariableType :: Text -> Position -> DataTypeLib -> Validation DataKind +getVariableType :: Text -> Position -> DataTypeLib -> Validation DataType getVariableType type' position' lib' = getInputType type' lib' error' where error' = unknownType type' position' diff --git a/test/Rendering/TestSchemaRendering.hs b/test/Rendering/TestSchemaRendering.hs --- a/test/Rendering/TestSchemaRendering.hs +++ b/test/Rendering/TestSchemaRendering.hs @@ -12,8 +12,8 @@ -- TODO: better Test testSchemaRendering :: TestTree -testSchemaRendering = testCase "Test Rendering" $ assertEqual "test schema Rendering" schema expected +testSchemaRendering = testCase "Test Rendering" $ assertEqual "test schema Rendering" expected schema where schema = toGraphQLDocument schemaProxy expected = - "type Query { \n user: User!\n testUnion: TestUnion\n}\n\nenum TestEnum { \n EnumA\n EnumB\n EnumC\n}\n\nscalar TestScalar\n\ninput Coordinates { \n latitude: TestScalar!\n longitude: Int!\n}\n\ntype Address { \n street: [[[[String!]!]!]]\n}\n\ntype User { \n type: String!\n address(coordinates: Coordinates!, type: String): Int!\n friend(id: ID!, cityID: TestEnum): User!\n}\n\nunion TestUnion =\n User!\n | Address!" + "type Query { \n user: User!\n testUnion: TestUnion\n}\n\nscalar TestScalar\n\nenum TestEnum { \n EnumA\n EnumB\n EnumC\n}\n\ninput Coordinates { \n latitude: TestScalar!\n longitude: Int!\n}\n\ntype Address { \n street: [[[[String!]!]!]]\n}\n\ntype User { \n type: String!\n address(coordinates: Coordinates!, type: String): Int!\n friend(id: ID!, cityID: TestEnum): User!\n}\n\nunion TestUnion =\n User!\n | Address!"