From c017d5f2974172af9e09e516df4e59a51003455b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Wed, 31 Jul 2019 22:25:10 +0200 Subject: [PATCH] able to parse basic stuff --- app/Main.hs | 51 ++++++------- examples/greeting.gql | 7 ++ package.yaml | 47 +++++++++++- src/Language/GraphQL/Reflection.hs | 117 ++++++++++++++++++++++++----- stack.yaml | 2 +- 5 files changed, 173 insertions(+), 51 deletions(-) create mode 100644 examples/greeting.gql diff --git a/app/Main.hs b/app/Main.hs index 03f9478..d134db3 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,40 +1,31 @@ +{-# OPTIONS_GHC -Wall #-} module Main where -import qualified Language.GraphQL.Parser as GraphQL -import qualified Language.GraphQL.AST as GraphQL -import qualified Language.GraphQL.Reflection as GraphQL -import qualified Data.Text.IO as Text -import Text.Megaparsec (ParseErrorBundle) -import qualified Text.Megaparsec as Parsec -import qualified System.Environment as System -import qualified Language.Haskell.Exts.Syntax as Haskell -import Data.Foldable (traverse_) -import Control.Monad ((>=>)) import Control.Category ((>>>)) -import qualified Language.Haskell.Exts.Syntax as Haskell -import Data.List.NonEmpty (NonEmpty) -import Control.Exception +import Control.Monad ((>=>)) +import Control.Monad.Fail (fail) +import Data.Attoparsec.Text (Parser) +import Data.Foldable (traverse_) +import Data.Text (Text) +import Language.Haskell.Exts.Pretty +import Prelude hiding (fail) +import qualified Data.Attoparsec.Text as Parser +import qualified Data.Text.IO as Text +import qualified GraphQL.Internal.Syntax.AST as GraphQL +import qualified GraphQL.Internal.Syntax.Parser as GraphQL.Parser +import qualified Language.GraphQL.Reflection as GraphQL +import qualified System.Environment as System main :: IO () -main = print doc - where - doc :: GraphQL.Document - doc = Parsec.parseMaybe GraphQL.document "" --- main :: IO () --- main = System.getArgs >>= traverse_ run +main = System.getArgs >>= traverse_ run run :: FilePath -> IO () -run = parse >=> (GraphQL.toType >>> print @(NonEmpty (Haskell.Decl ()))) +run = parseFile >=> (GraphQL.schemaDocument >>> traverse_ (prettyPrint >>> putStrLn)) -parse :: FilePath -> IO GraphQL.Document -parse p = do +parseFile :: FilePath -> IO GraphQL.SchemaDocument +parseFile p = do txt <- Text.readFile p - either badFailureMechanism pure $ Parsec.parse GraphQL.document p txt - where - badFailureMechanism = fail . displayException + parse GraphQL.Parser.schemaDocument txt -getExample :: IO GraphQL.Document -getExample = parse p - where - p :: FilePath - p = "/Users/frederikhanghjiversen/git/zendesk/guide-graph/schema/schema.graphql" +parse :: Parser a -> Text -> IO a +parse p = Parser.parseOnly p >>> either fail pure diff --git a/examples/greeting.gql b/examples/greeting.gql new file mode 100644 index 0000000..285542c --- /dev/null +++ b/examples/greeting.gql @@ -0,0 +1,7 @@ +type Hello { + greeting(who: String!): String! +} + +data Hello = Hello + { greeting :: String -> String + } \ No newline at end of file diff --git a/package.yaml b/package.yaml index 6c86576..7482837 100644 --- a/package.yaml +++ b/package.yaml @@ -21,10 +21,10 @@ description: Please see the README on GitHub at = 4.7 && < 5 - - graphql + - graphql-api - haskell-src-exts - text - - megaparsec + - attoparsec library: source-dirs: src @@ -50,3 +50,46 @@ tests: - -with-rtsopts=-N dependencies: - gql2hs + +default-extensions: + - BangPatterns + - BinaryLiterals + - ConstraintKinds + - DefaultSignatures + - DeriveAnyClass + - DeriveDataTypeable + - DeriveFoldable + - DeriveFunctor + - DeriveGeneric + - DeriveLift + - DeriveTraversable + - DerivingStrategies + - DisambiguateRecordFields + - DuplicateRecordFields + - EmptyCase + - EmptyDataDecls + - ExistentialQuantification + - ExplicitForAll + - FlexibleContexts + - FlexibleInstances + - FunctionalDependencies + - GADTs + - GeneralisedNewtypeDeriving + - InstanceSigs + - LambdaCase + - MultiParamTypeClasses + - MultiWayIf + - NamedFieldPuns + - NamedWildCards + - NumDecimals + - PackageImports + - PartialTypeSignatures + - QuasiQuotes + - RankNTypes + - RecordWildCards + - ScopedTypeVariables + - StandaloneDeriving + - TypeApplications + - TypeFamilies + - UnicodeSyntax + - OverloadedStrings diff --git a/src/Language/GraphQL/Reflection.hs b/src/Language/GraphQL/Reflection.hs index 616e8b3..a81be68 100644 --- a/src/Language/GraphQL/Reflection.hs +++ b/src/Language/GraphQL/Reflection.hs @@ -1,27 +1,108 @@ -module Language.GraphQL.Reflection (toType) where +-- {-# OPTIONS_GHC -fdefer-type-errors -w #-} +{-# OPTIONS_GHC -Wall #-} +module Language.GraphQL.Reflection (document, schemaDocument) where -import Language.GraphQL.AST as GraphQL -import Data.List.NonEmpty (NonEmpty) -import qualified Language.Haskell.Exts.Syntax as Haskell +import Data.Text (Text) +import GraphQL.Internal.Name +import GraphQL.Internal.Syntax.AST +import Language.Haskell.Exts.Syntax as Haskell +import qualified Data.Text as Text -toType :: GraphQL.Document -> NonEmpty (Haskell.Decl a) -toType = document +import Debug.Trace -document :: GraphQL.Document -> NonEmpty (Haskell.Decl a) -document = fmap definition +document :: QueryDocument -> [Haskell.Decl ()] +document (QueryDocument defs) = fmap definition defs -definition :: GraphQL.Definition -> Haskell.Decl a +definition :: Definition -> Haskell.Decl () definition = \case - DefinitionOperation def -> definitionOperation def - DefinitionFragment def -> definitionFragment def + DefinitionOperation def -> operationDefinition def + DefinitionFragment def -> fragmentDefinition def -definitionOperation :: OperationDefinition -> Haskell.Decl a -definitionOperation = \case - OperationSelectionSet op -> selectionSet op - OperationDefinition{} -> undefined +operationDefinition :: OperationDefinition -> Haskell.Decl () +operationDefinition = \case + Query n -> node n + Mutation n -> node n + AnonymousQuery s -> selectionSet s -selectionSet :: SelectionSet -> Haskell.Decl a +node :: Node -> Haskell.Decl () +node = showDie + +selectionSet :: SelectionSet -> Haskell.Decl () selectionSet = undefined -definitionFragment :: FragmentDefinition -> Haskell.Decl a -definitionFragment (FragmentDefinition fragmentName typeCondition directive selectionSet) = _ +fragmentDefinition :: FragmentDefinition -> Haskell.Decl () +fragmentDefinition = undefined + +schemaDocument :: SchemaDocument -> [Haskell.Decl ()] +schemaDocument (SchemaDocument defs) = fmap typeDefinition defs + +typeDefinition :: TypeDefinition -> Haskell.Decl () +typeDefinition = \case + TypeDefinitionObject x -> objectTypeDefinition x + TypeDefinitionInterface x -> interfaceTypeDefinition x + TypeDefinitionUnion x -> unionTypeDefinition x + TypeDefinitionScalar x -> scalarTypeDefinition x + TypeDefinitionEnum x -> enumTypeDefinition x + TypeDefinitionInputObject x -> inputObjectTypeDefinition x + TypeDefinitionTypeExtension x -> typeExtensionDefinition x + +objectTypeDefinition :: ObjectTypeDefinition -> Haskell.Decl () +objectTypeDefinition (ObjectTypeDefinition (Name name) _interfaces fields) + = DataDecl () (DataType ()) Nothing (DHead () (Ident () name')) (pure qualConDecl) [] + where + name' = Text.unpack name + qualConDecl = QualConDecl () Nothing Nothing (RecDecl () (Ident () name') (fmap fieldDefinition fields)) + +fieldDefinition :: FieldDefinition -> FieldDecl () +fieldDefinition (FieldDefinition (Name name) argumentsDefinition gType) + = FieldDecl () [Ident () (Text.unpack name)] (fieldType argumentsDefinition gType) + +fieldType :: [InputValueDefinition] -> GType -> Type () +fieldType xs gType = foldr (TyFun () . inputValueDefinition) (baseType gType) xs + +inputValueDefinition :: InputValueDefinition -> Type () +inputValueDefinition (InputValueDefinition _name gType _maybeDefaultValue) + = baseType gType + +baseType :: GType -> Type () +baseType = \case + TypeNamed (NamedType (Name name)) -> maybeOf $ namedType name + TypeList (ListType listType) -> maybeOf $ listOf $ baseType listType + TypeNonNull gType -> nonNullType gType + +nonNullType :: NonNullType -> Type () +nonNullType = \case + NonNullTypeNamed (NamedType (Name name)) -> namedType name + NonNullTypeList (ListType listType) -> listOf $ baseType listType + +namedType :: Text -> Type () +namedType name = TyCon () (UnQual () (Ident () (Text.unpack name))) + +-- FIXME: Given a concrete type `t` it should create the type `[t]`. +listOf :: Type () -> Type () +listOf = id + +-- FIXME: Given a concrete type `t` it should create the type `Maybe t`. +maybeOf :: Type () -> Type () +maybeOf = id + +interfaceTypeDefinition :: InterfaceTypeDefinition -> Haskell.Decl a +interfaceTypeDefinition = showDie + +unionTypeDefinition :: UnionTypeDefinition -> Haskell.Decl a +unionTypeDefinition = showDie + +scalarTypeDefinition :: ScalarTypeDefinition -> Haskell.Decl a +scalarTypeDefinition = showDie + +enumTypeDefinition :: EnumTypeDefinition -> Haskell.Decl a +enumTypeDefinition = showDie + +inputObjectTypeDefinition :: InputObjectTypeDefinition -> Haskell.Decl a +inputObjectTypeDefinition = showDie + +typeExtensionDefinition :: TypeExtensionDefinition -> Haskell.Decl a +typeExtensionDefinition = showDie + +showDie :: Show a => a -> b +showDie a = traceShow a undefined diff --git a/stack.yaml b/stack.yaml index 6bc42f5..f014b90 100644 --- a/stack.yaml +++ b/stack.yaml @@ -4,4 +4,4 @@ packages: - . extra-deps: - - graphql-0.4.0.0 + - graphql-api-0.3.0