able to parse basic stuff

2019-07-31 22:25:10 +02:00 · 2019-07-31 22:25:10 +02:00 · c017d5f297
parent 40dea5111a
commit c017d5f297
5 changed files with 173 additions and 51 deletions
--- 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 "<nothing>" 
-- 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
--- a/examples/greeting.gql
+++ b/examples/greeting.gql
@ -0,0 +1,7 @@
+type Hello {
+  greeting(who: String!): String!
+}
+
+data Hello = Hello
+  { greeting :: String -> String
+  }
--- a/package.yaml
+++ b/package.yaml
@ -21,10 +21,10 @@ description:         Please see the README on GitHub at <https://github.com/fred

 dependencies:
  - base >= 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
--- 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
--- a/stack.yaml
+++ b/stack.yaml
@ -4,4 +4,4 @@ packages:
  - .

 extra-deps:
-  - graphql-0.4.0.0
+  - graphql-api-0.3.0