Update parser, implement a few more mappings

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 :: IO ()
-run = parseFile >=> (GraphQL.schemaDocument >>> traverse_ (prettyPrint >>> putStrLn))
+run = parseContents >>= (GraphQL.schemaDocument >>> traverse_ (prettyPrint >>> putStrLn))
 
-parseFile :: FilePath -> IO GraphQL.SchemaDocument
+parseContents :: IO GraphQL.SchemaDocument
-parseFile p = do
+parseContents = do
-  txt <- Text.readFile p
+  txt <- Text.getContents
   parse GraphQL.Parser.schemaDocument txt
 
 parse :: Parser a -> Text -> IO a

package.yaml

@@ -30,7 +30,7 @@ library:
   source-dirs: src
 
 executables:
-  gql2hs-exe:
+  gql2hs:
     main:                Main.hs
     source-dirs:         app
     ghc-options:
@@ -41,7 +41,7 @@ executables:
     - gql2hs
 
 tests:
-  gql2hs-test:
+  test:
     main:                Spec.hs
     source-dirs:         test
     ghc-options:

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 as GraphQL
-import GraphQL.Internal.Name
 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)
+fieldDefinition (FieldDefinition nm argumentsDefinition gType)
-  = FieldDecl () [Ident () (Text.unpack name)] (fieldType 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 :: NamedType -> Type ()
-namedType name = TyCon () (UnQual () (Ident () (Text.unpack name)))
+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 :: InterfaceTypeDefinition -> Haskell.Decl ()
-interfaceTypeDefinition = showDie
+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 :: UnionTypeDefinition -> Haskell.Decl ()
-unionTypeDefinition = showDie
+unionTypeDefinition (UnionTypeDefinition nm xs)
+  = DataDecl () (DataType ()) Nothing
+    (DHead () (Ident () (name nm)))
+    (fmap (unionVariant nm) (zip [0..] xs)) []
 
-scalarTypeDefinition :: ScalarTypeDefinition -> Haskell.Decl a
+unionVariant :: GraphQL.Name -> (Int, NamedType) -> QualConDecl ()
-scalarTypeDefinition = showDie
+unionVariant nm (n, namedTp) = QualConDecl () Nothing Nothing (ConDecl () (Ident () nm') [namedType namedTp])
+  where
+  nm' = name nm <> "__" <> show n
 
-enumTypeDefinition :: EnumTypeDefinition -> Haskell.Decl a
+-- [QualConDecl () Nothing Nothing (ConDecl () (Ident () "T") [TyCon () (UnQual () (Ident () "Int"))])]
-enumTypeDefinition = showDie
 
-inputObjectTypeDefinition :: InputObjectTypeDefinition -> Haskell.Decl a
+-- UnionTypeDefinition (Name {unName = "ArticleOwner"}) [NamedType (Name {unName = "Group"}),NamedType (Name {unName = "User"})]
-inputObjectTypeDefinition = showDie
 
-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

stack.yaml

@@ -4,4 +4,5 @@ packages:
   - .
 
 extra-deps:
-  - graphql-api-0.3.0
+  - git: git@github.com:fredefox/graphql-api.git
+    commit: 90a5d7b2071e8414948be80dc25120d1189b0674