157 lines
6.3 KiB
Haskell
157 lines
6.3 KiB
Haskell
-- {-# OPTIONS_GHC -fdefer-type-errors -w #-}
|
|
{-# OPTIONS_GHC -Wall #-}
|
|
module Language.GraphQL.Reflection (document, schemaDocument) where
|
|
|
|
import GraphQL.Internal.Name as GraphQL
|
|
import GraphQL.Internal.Syntax.AST
|
|
import Language.Haskell.Exts.Syntax as Haskell
|
|
import qualified Data.Text as Text
|
|
|
|
import Debug.Trace
|
|
|
|
document :: QueryDocument -> [Haskell.Decl ()]
|
|
document (QueryDocument defs) = fmap definition defs
|
|
|
|
definition :: Definition -> Haskell.Decl ()
|
|
definition = \case
|
|
DefinitionOperation def -> operationDefinition def
|
|
DefinitionFragment def -> fragmentDefinition def
|
|
|
|
operationDefinition :: OperationDefinition -> Haskell.Decl ()
|
|
operationDefinition = \case
|
|
Query n -> node n
|
|
Mutation n -> node n
|
|
AnonymousQuery s -> selectionSet s
|
|
|
|
node :: Node -> Haskell.Decl ()
|
|
node = showDie
|
|
|
|
selectionSet :: SelectionSet -> Haskell.Decl ()
|
|
selectionSet = undefined
|
|
|
|
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 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))
|
|
|
|
name :: GraphQL.Name -> String
|
|
name (Name nm) = Text.unpack nm
|
|
|
|
fieldDefinition :: FieldDefinition -> FieldDecl ()
|
|
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
|
|
|
|
inputValueDefinition :: InputValueDefinition -> Type ()
|
|
inputValueDefinition (InputValueDefinition _name gType _maybeDefaultValue)
|
|
= baseType gType
|
|
|
|
baseType :: GType -> Type ()
|
|
baseType = \case
|
|
TypeNamed nm -> maybeOf $ namedType nm
|
|
TypeList (ListType listType) -> maybeOf $ listOf $ baseType listType
|
|
TypeNonNull gType -> nonNullType gType
|
|
|
|
nonNullType :: NonNullType -> Type ()
|
|
nonNullType = \case
|
|
NonNullTypeNamed nm -> namedType nm
|
|
NonNullTypeList (ListType listType) -> listOf $ baseType listType
|
|
|
|
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 ()
|
|
listOf = id
|
|
|
|
-- FIXME: Given a concrete type `t` it should create the type `Maybe t`.
|
|
maybeOf :: Type () -> Type ()
|
|
maybeOf = id
|
|
|
|
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 ()
|
|
unionTypeDefinition (UnionTypeDefinition nm xs)
|
|
= DataDecl () (DataType ()) Nothing
|
|
(DHead () (Ident () (name nm)))
|
|
(fmap (unionVariant nm) (zip [0..] xs)) []
|
|
|
|
unionVariant :: GraphQL.Name -> (Int, NamedType) -> QualConDecl ()
|
|
unionVariant nm (n, namedTp) = QualConDecl () Nothing Nothing (ConDecl () (Ident () nm') [namedType namedTp])
|
|
where
|
|
nm' = name nm <> "__" <> show n
|
|
|
|
-- [QualConDecl () Nothing Nothing (ConDecl () (Ident () "T") [TyCon () (UnQual () (Ident () "Int"))])]
|
|
|
|
-- UnionTypeDefinition (Name {unName = "ArticleOwner"}) [NamedType (Name {unName = "Group"}),NamedType (Name {unName = "User"})]
|
|
|
|
-- 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
|
|
showDie a = traceShow a undefined
|