app/Main.hs

@@ -2,6 +2,7 @@
 module Main where
 
 import Control.Category ((>>>))
+import Control.Monad ((>=>))
 import Control.Monad.Fail (fail)
 import Data.Attoparsec.Text (Parser)
 import Data.Foldable (traverse_)
@@ -13,16 +14,17 @@ 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 = run
+main = System.getArgs >>= traverse_ run
 
-run :: IO ()
+run :: FilePath -> IO ()
-run = parseContents >>= (GraphQL.schemaDocument >>> traverse_ (prettyPrint >>> putStrLn))
+run = parseFile >=> (GraphQL.schemaDocument >>> traverse_ (prettyPrint >>> putStrLn))
 
-parseContents :: IO GraphQL.SchemaDocument
+parseFile :: FilePath -> IO GraphQL.SchemaDocument
-parseContents = do
+parseFile p = do
-  txt <- Text.getContents
+  txt <- Text.readFile p
   parse GraphQL.Parser.schemaDocument txt
 
 parse :: Parser a -> Text -> IO a

package.yaml

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

src/Language/GraphQL/Reflection.hs

@@ -2,7 +2,8 @@
 {-# OPTIONS_GHC -Wall #-}
 module Language.GraphQL.Reflection (document, schemaDocument) where
 
-import GraphQL.Internal.Name as GraphQL
+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
@@ -46,18 +47,15 @@ typeDefinition = \case
   TypeDefinitionTypeExtension x -> typeExtensionDefinition x
 
 objectTypeDefinition :: ObjectTypeDefinition -> Haskell.Decl ()
-objectTypeDefinition (ObjectTypeDefinition nm _interfaces fields)
+objectTypeDefinition (ObjectTypeDefinition (Name name) _interfaces fields)
   = DataDecl () (DataType ()) Nothing (DHead () (Ident () name')) (pure qualConDecl) []
   where
-  name' = name nm
+  name' = Text.unpack name
   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 nm argumentsDefinition gType)
+fieldDefinition (FieldDefinition (Name name) argumentsDefinition gType)
-  = FieldDecl () [Ident () (name nm)] (fieldType argumentsDefinition gType)
+  = FieldDecl () [Ident () (Text.unpack name)] (fieldType argumentsDefinition gType)
 
 fieldType :: [InputValueDefinition] -> GType -> Type ()
 fieldType xs gType = foldr (TyFun () . inputValueDefinition) (baseType gType) xs
@@ -68,17 +66,17 @@ inputValueDefinition (InputValueDefinition _name gType _maybeDefaultValue)
 
 baseType :: GType -> Type ()
 baseType = \case
-  TypeNamed nm                      -> maybeOf $ namedType nm
+  TypeNamed (NamedType (Name name)) -> maybeOf $ namedType name
   TypeList (ListType listType)      -> maybeOf $ listOf $ baseType listType
   TypeNonNull gType                 -> nonNullType gType
 
 nonNullType :: NonNullType -> Type ()
 nonNullType = \case
-  NonNullTypeNamed nm                 -> namedType nm
+  NonNullTypeNamed (NamedType (Name name)) -> namedType name
   NonNullTypeList (ListType listType) -> listOf $ baseType listType
 
-namedType :: NamedType -> Type ()
+namedType :: Text -> Type ()
-namedType (NamedType nm) = TyCon () (UnQual () (Ident () (name nm)))
+namedType name = TyCon () (UnQual () (Ident () (Text.unpack name)))
 
 -- FIXME: Given a concrete type `t` it should create the type `[t]`.
 listOf :: Type () -> Type ()
@@ -88,68 +86,22 @@ listOf = id
 maybeOf :: Type () -> Type ()
 maybeOf = id
 
-interfaceTypeDefinition :: InterfaceTypeDefinition -> Haskell.Decl ()
+interfaceTypeDefinition :: InterfaceTypeDefinition -> Haskell.Decl a
-interfaceTypeDefinition (InterfaceTypeDefinition nm fields)
+interfaceTypeDefinition = showDie
-  = 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 ()
+unionTypeDefinition :: UnionTypeDefinition -> Haskell.Decl a
-unionTypeDefinition (UnionTypeDefinition nm xs)
+unionTypeDefinition = showDie
-  = DataDecl () (DataType ()) Nothing
-    (DHead () (Ident () (name nm)))
-    (fmap (unionVariant nm) (zip [0..] xs)) []
 
-unionVariant :: GraphQL.Name -> (Int, NamedType) -> QualConDecl ()
+scalarTypeDefinition :: ScalarTypeDefinition -> Haskell.Decl a
-unionVariant nm (n, namedTp) = QualConDecl () Nothing Nothing (ConDecl () (Ident () nm') [namedType namedTp])
+scalarTypeDefinition = showDie
-  where
-  nm' = name nm <> "__" <> show n
 
--- [QualConDecl () Nothing Nothing (ConDecl () (Ident () "T") [TyCon () (UnQual () (Ident () "Int"))])]
+enumTypeDefinition :: EnumTypeDefinition -> Haskell.Decl a
+enumTypeDefinition = showDie
 
--- UnionTypeDefinition (Name {unName = "ArticleOwner"}) [NamedType (Name {unName = "Group"}),NamedType (Name {unName = "User"})]
+inputObjectTypeDefinition :: InputObjectTypeDefinition -> Haskell.Decl a
+inputObjectTypeDefinition = showDie
 
--- TODO: Figure out what type the scalar should map to.  Currently we just translate a scalar `R` to:
+typeExtensionDefinition :: TypeExtensionDefinition -> Haskell.Decl a
--- 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,5 +4,4 @@ packages:
   - .
 
 extra-deps:
-  - git: git@github.com:fredefox/graphql-api.git
+  - graphql-api-0.3.0
-    commit: 90a5d7b2071e8414948be80dc25120d1189b0674