From d6eee432c36d7ec9941d2a89ef0563ca3619f805 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Thu, 8 Aug 2019 16:40:05 +0200 Subject: [PATCH] Update parser, implement a few more mappings --- app/Main.hs | 14 ++--- src/Language/GraphQL/Reflection.hs | 90 +++++++++++++++++++++++------- stack.yaml | 3 +- 3 files changed, 77 insertions(+), 30 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index d134db3..0a3edf9 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -2,7 +2,6 @@ module Main where import Control.Category ((>>>)) -import Control.Monad ((>=>)) import Control.Monad.Fail (fail) import Data.Attoparsec.Text (Parser) import Data.Foldable (traverse_) @@ -14,17 +13,16 @@ 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 = System.getArgs >>= traverse_ run +main = run -run :: FilePath -> IO () -run = parseFile >=> (GraphQL.schemaDocument >>> traverse_ (prettyPrint >>> putStrLn)) +run :: IO () +run = parseContents >>= (GraphQL.schemaDocument >>> traverse_ (prettyPrint >>> putStrLn)) -parseFile :: FilePath -> IO GraphQL.SchemaDocument -parseFile p = do - txt <- Text.readFile p +parseContents :: IO GraphQL.SchemaDocument +parseContents = do + txt <- Text.getContents parse GraphQL.Parser.schemaDocument txt parse :: Parser a -> Text -> IO a diff --git a/src/Language/GraphQL/Reflection.hs b/src/Language/GraphQL/Reflection.hs index a81be68..d60abe0 100644 --- a/src/Language/GraphQL/Reflection.hs +++ b/src/Language/GraphQL/Reflection.hs @@ -2,8 +2,7 @@ {-# OPTIONS_GHC -Wall #-} module Language.GraphQL.Reflection (document, schemaDocument) where -import Data.Text (Text) -import GraphQL.Internal.Name +import GraphQL.Internal.Name as GraphQL import GraphQL.Internal.Syntax.AST import Language.Haskell.Exts.Syntax as Haskell import qualified Data.Text as Text @@ -47,15 +46,18 @@ typeDefinition = \case TypeDefinitionTypeExtension x -> typeExtensionDefinition x objectTypeDefinition :: ObjectTypeDefinition -> Haskell.Decl () -objectTypeDefinition (ObjectTypeDefinition (Name name) _interfaces fields) +objectTypeDefinition (ObjectTypeDefinition nm _interfaces fields) = DataDecl () (DataType ()) Nothing (DHead () (Ident () name')) (pure qualConDecl) [] where - name' = Text.unpack name + name' = name nm qualConDecl = QualConDecl () Nothing Nothing (RecDecl () (Ident () name') (fmap fieldDefinition fields)) +name :: GraphQL.Name -> String +name (Name nm) = Text.unpack nm + fieldDefinition :: FieldDefinition -> FieldDecl () -fieldDefinition (FieldDefinition (Name name) argumentsDefinition gType) - = FieldDecl () [Ident () (Text.unpack name)] (fieldType argumentsDefinition gType) +fieldDefinition (FieldDefinition nm argumentsDefinition gType) + = FieldDecl () [Ident () (name nm)] (fieldType argumentsDefinition gType) fieldType :: [InputValueDefinition] -> GType -> Type () fieldType xs gType = foldr (TyFun () . inputValueDefinition) (baseType gType) xs @@ -66,17 +68,17 @@ inputValueDefinition (InputValueDefinition _name gType _maybeDefaultValue) baseType :: GType -> Type () baseType = \case - TypeNamed (NamedType (Name name)) -> maybeOf $ namedType name + TypeNamed nm -> maybeOf $ namedType nm TypeList (ListType listType) -> maybeOf $ listOf $ baseType listType TypeNonNull gType -> nonNullType gType nonNullType :: NonNullType -> Type () nonNullType = \case - NonNullTypeNamed (NamedType (Name name)) -> namedType name + NonNullTypeNamed nm -> namedType nm NonNullTypeList (ListType listType) -> listOf $ baseType listType -namedType :: Text -> Type () -namedType name = TyCon () (UnQual () (Ident () (Text.unpack name))) +namedType :: NamedType -> Type () +namedType (NamedType nm) = TyCon () (UnQual () (Ident () (name nm))) -- FIXME: Given a concrete type `t` it should create the type `[t]`. listOf :: Type () -> Type () @@ -86,22 +88,68 @@ listOf = id maybeOf :: Type () -> Type () maybeOf = id -interfaceTypeDefinition :: InterfaceTypeDefinition -> Haskell.Decl a -interfaceTypeDefinition = showDie +interfaceTypeDefinition :: InterfaceTypeDefinition -> Haskell.Decl () +interfaceTypeDefinition (InterfaceTypeDefinition nm fields) + = DataDecl () (DataType ()) Nothing (DHead () (Ident () name')) (pure qualConDecl) [] + where + name' = name nm + qualConDecl = QualConDecl () Nothing Nothing (RecDecl () (Ident () name') (fmap fieldDefinition fields)) +-- objectTypeDefinition (ObjectTypeDefinition nm _interfaces fields) +-- = DataDecl () (DataType ()) Nothing (DHead () (Ident () name')) (pure qualConDecl) [] +-- where +-- name' = name nm +-- qualConDecl = QualConDecl () Nothing Nothing (RecDecl () (Ident () name') (fmap fieldDefinition fields)) -unionTypeDefinition :: UnionTypeDefinition -> Haskell.Decl a -unionTypeDefinition = showDie +unionTypeDefinition :: UnionTypeDefinition -> Haskell.Decl () +unionTypeDefinition (UnionTypeDefinition nm xs) + = DataDecl () (DataType ()) Nothing + (DHead () (Ident () (name nm))) + (fmap (unionVariant nm) (zip [0..] xs)) [] -scalarTypeDefinition :: ScalarTypeDefinition -> Haskell.Decl a -scalarTypeDefinition = showDie +unionVariant :: GraphQL.Name -> (Int, NamedType) -> QualConDecl () +unionVariant nm (n, namedTp) = QualConDecl () Nothing Nothing (ConDecl () (Ident () nm') [namedType namedTp]) + where + nm' = name nm <> "__" <> show n -enumTypeDefinition :: EnumTypeDefinition -> Haskell.Decl a -enumTypeDefinition = showDie +-- [QualConDecl () Nothing Nothing (ConDecl () (Ident () "T") [TyCon () (UnQual () (Ident () "Int"))])] -inputObjectTypeDefinition :: InputObjectTypeDefinition -> Haskell.Decl a -inputObjectTypeDefinition = showDie +-- UnionTypeDefinition (Name {unName = "ArticleOwner"}) [NamedType (Name {unName = "Group"}),NamedType (Name {unName = "User"})] -typeExtensionDefinition :: TypeExtensionDefinition -> Haskell.Decl a +-- TODO: Figure out what type the scalar should map to. Currently we just translate a scalar `R` to: +-- type R = () +scalarTypeDefinition :: ScalarTypeDefinition -> Haskell.Decl () +scalarTypeDefinition (ScalarTypeDefinition nm) + = TypeDecl () (DHead () (Ident () name')) (TyCon () (UnQual () (Ident () "()"))) + where + name' = name nm + +enumTypeDefinition :: EnumTypeDefinition -> Haskell.Decl () +enumTypeDefinition (EnumTypeDefinition nm xs) + = DataDecl () (DataType ()) Nothing + (DHead () (Ident () (name nm))) + (fmap enumValueDefinition xs) [] + +-- [QualConDecl () Nothing Nothing (ConDecl () (Ident () "False") []),QualConDecl () Nothing Nothing (ConDecl () (Ident () "True") [])] +enumValueDefinition :: EnumValueDefinition -> QualConDecl () +enumValueDefinition (EnumValueDefinition nm) + = QualConDecl () Nothing Nothing (ConDecl () (Ident () (name nm)) []) + +-- DataDecl () (DataType ()) Nothing (DHead () (Ident () "Bool")) [QualConDecl () Nothing Nothing (ConDecl () (Ident () "False") []),QualConDecl () Nothing Nothing (ConDecl () (Ident () "True") [])] [] + +inputObjectTypeDefinition :: InputObjectTypeDefinition -> Haskell.Decl () +inputObjectTypeDefinition (InputObjectTypeDefinition nm xs) +-- objectTypeDefinition (ObjectTypeDefinition nm _interfaces fields) + = DataDecl () (DataType ()) Nothing (DHead () (Ident () nm')) (pure qualConDecl) [] + where + nm' = name nm + qualConDecl = QualConDecl () Nothing Nothing (RecDecl () (Ident () nm') (fmap step xs)) + step :: InputValueDefinition -> FieldDecl () + step (InputValueDefinition fieldName gType _mDefault) = FieldDecl () [Ident () (name fieldName)] (baseType gType) + +-- inputValueDefinition :: InputValueDefinition -> () +-- inputValueDefinition = _ + +typeExtensionDefinition :: TypeExtensionDefinition -> Haskell.Decl () typeExtensionDefinition = showDie showDie :: Show a => a -> b diff --git a/stack.yaml b/stack.yaml index f014b90..61b1d5b 100644 --- a/stack.yaml +++ b/stack.yaml @@ -4,4 +4,5 @@ packages: - . extra-deps: - - graphql-api-0.3.0 + - git: git@github.com:fredefox/graphql-api.git + commit: 90a5d7b2071e8414948be80dc25120d1189b0674