able to parse basic stuff
This commit is contained in:
parent
40dea5111a
commit
c017d5f297
51
app/Main.hs
51
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
|
||||
|
|
|
|||
7
examples/greeting.gql
Normal file
7
examples/greeting.gql
Normal file
|
|
@ -0,0 +1,7 @@
|
|||
type Hello {
|
||||
greeting(who: String!): String!
|
||||
}
|
||||
|
||||
data Hello = Hello
|
||||
{ greeting :: String -> String
|
||||
}
|
||||
47
package.yaml
47
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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -4,4 +4,4 @@ packages:
|
|||
- .
|
||||
|
||||
extra-deps:
|
||||
- graphql-0.4.0.0
|
||||
- graphql-api-0.3.0
|
||||
|
|
|
|||
Loading…
Reference in a new issue