Add crazy type functions

Bad idea?  Probably
M example/example1.lisp +12 -13
@@ 8,30 8,29 @@ 
 
 (defparameter *fields*
   (list
-   (gql::field :name "name"
-               :type (make-instance 'gql::named-type :name (make-instance 'gql::name :name "String"))
+   (field :name "name"
+               :type *string*
                :resolver (constantly "Theodor Thornhill"))
-   (gql::field :name "age"
-               :type (make-instance 'gql::named-type :name (make-instance 'gql::name :name "Int"))
+   (field :name "age"
+               :type *int*
                :resolver (constantly 31))))
 
+(defparameter *query*
+  (gql::object :name "Query" :fields *fields*))
+
+
 (defvar *example-schema*
-  (build-schema `(,(gql::object :name "Query" :fields *fields*))))
+  (make-schema :query *query*))
 
 (defvar *variable-values* (make-hash-table :test #'equal))
 
 (hunchentoot:define-easy-handler (home :uri "/home") (item)
   (setf (hunchentoot:content-type*) "text/plain")
   (when item
-    (with-schema *example-schema*
-      (let ((result (execute (build-schema (format nil "{ __type(name: Query) { name } }"))
-                             nil
-                             *variable-values* nil)))
-        (format nil "~a~%" (cl-json:encode-json-to-string result))))))
+    (with-context (:schema *example-schema*
+                   :document (build-document "{ __type(name: Query) { name } }"))
+      (format nil "~a~%" (cl-json:encode-json-to-string (execute))))))
 
 (defvar *server* (make-instance 'hunchentoot:easy-acceptor :port 3000))
 
-(defun query (item)
-  (build-schema (format nil "query { __type(name: Query) { name } }" item)))
-
 ;; Eval this when you want to run the app (hunchentoot:start *server*)

          
M example/example2.lisp +2 -6
@@ 63,11 63,6 @@ 
                                       :type (gql::list-type (gql::non-null-type (gql::named "Pet")))))))
 
 
-;; (defun example2 (query)
-;;   (with-schema (build-schema (asdf:system-relative-pathname 'gql-tests #p"t/test-files/validation-schema.graphql"))
-;;     (let* ((res (gql::execute (build-schema query) nil (make-hash-table :test #'equal) nil)))
-;;       (format t "~%~a" (cl-json:encode-json-to-string res)))))
-
 (defun example2 (query)
   (with-context (:schema (gql::make-schema :query *query* :types (list *dog* *human*))
                  :document (build-document query))

          
@@ 75,7 70,8 @@ 
       (format t "~%~a" (cl-json:encode-json-to-string res)))))
 
 ;; (example2 "{ __schema { types { name ofType { name } } } }")
-(example2 "{ __type(name: \"Dog\") { name fields { name type { name } } } }")
+(example2 "{ __schema { queryType { name } } }")
+;; (example2 "{ __type(name: \"Dog\") { name fields { name type { name } } } }")
 ;; (example2 "query { dog { name owner { name pets { name } } } }")
 ;; (example2 "query { dog { name owner { name } } }")
 ;; (example2 "query { dog { name owner: wingle { name pets: dogs { name } } } }")

          
M gql.asd +1 -0
@@ 13,6 13,7 @@ 
                  (:file "utils")
                  (:file "lexer")
                  (:file "language")
+                 (:file "types")
                  (:file "schema")
                  (:file "introspection")
                  (:file "conditions")

          
M src/execution.lisp +11 -13
@@ 59,19 59,17 @@ 
 
 (defun get-operation (document &optional operation-name)
   ;; TODO: https://spec.graphql.org/draft/#GetOperation()
-  (cond
-    ((null operation-name)
-     (let ((operation
-             (remove-if-not (lambda (x) (typep x 'operation-definition))
-                            (definitions document))))
-       (if (= 1 (length operation))
-           (car operation)
-           (gql-error "Need to raise a request error: https://spec.graphql.org/draft/#GetOperation()"))))
-    (t
-     (let ((operation
-             (gethash operation-name (get-types 'operation-definition document))))
-       (if operation operation
-           (gql-error "Need to raise a request error: https://spec.graphql.org/draft/#GetOperation()"))))))
+  (if (null operation-name)
+      (let ((operation
+              (remove-if-not (lambda (x) (typep x 'operation-definition))
+                             (definitions document))))
+        (if (= 1 (length operation))
+            (car operation)
+            (gql-error "Need to raise a request error: https://spec.graphql.org/draft/#GetOperation()")))
+      (let ((operation
+              (gethash operation-name (get-types 'operation-definition document))))
+        (if operation operation
+            (gql-error "Need to raise a request error: https://spec.graphql.org/draft/#GetOperation()")))))
 
 (defun input-type-p (type)
   ;; TODO: https://spec.graphql.org/draft/#IsInputType()

          
M src/introspection.lisp +76 -72
@@ 5,21 5,22 @@ 
           :description "A GraphQL Schema defines the capabilities of a GraphQL server."
           :fields `(,(field :name "description"
                             :description "A description of the current schema."
-                            :type (named "String")
+                            :type *string*
                             :resolver (lambda () (description (schema *context*))))
                     ,(field :name "types"
                             :description "A list of all types supported by this server."
-                            :type (non-null-type (list-type (non-null-type (named "__Type"))))
+                            :type ([!]! "__Type")
                             :resolver (lambda ()
                                         (let ((types nil))
-                                          (maphash (lambda (k v)
-                                                     (unless (uiop:string-prefix-p "__" k)
-                                                       (push v types)))
-                                                   (type-map (schema *context*)))
+                                          (with-slots (type-map) (schema *context*)
+                                            (maphash (lambda (k v)
+                                                       (unless (uiop:string-prefix-p "__" k)
+                                                         (push v types)))
+                                                     type-map))
                                           types)))
                     ,(field :name "queryType"
                             :description "The type that query operations will be rooted at."
-                            :type (non-null-type (named "__Type"))
+                            :type (! "__Type")
                             :resolver (lambda () (query-type (schema *context*))))
                     ,(field :name "mutationType"
                             :description "If this server supports mutation, the type that mutation operations will be rooted at."

          
@@ 30,7 31,7 @@ 
                             :type (named "__Type")
                             :resolver (lambda () (subscription-type (schema *context*))))
                     ,(field :name "directives"
-                            :type (non-null-type (list-type (non-null-type "__Directive")))
+                            :type ([!]! "__Directive")
                             :resolver (lambda () (directives (schema *context*)))))))
 
 (defvar *__type*

          
@@ 38,123 39,126 @@ 
           :fields `(,(field :name "kind"
                             :type (non-null-type "__TypeKind"))
                     ,(field :name "name"
-                            :type (named "String")
+                            :type *string*
                             :resolver (lambda () (name (object-value (execution-context *context*)))))
                     ,(field :name "description"
-                            :type (named "String")
+                            :type *string*
                             :resolver (lambda () (description (object-value (execution-context *context*)))))
                     ,(field :name "fields"
-                            :type (list-type (non-null-type (named "__Field")))
+                            :type ([!] "__Field")
                             :resolver (lambda ()
-                                        (let ((fields nil))
-                                          (maphash (lambda (k v) (declare (ignore k))
-                                                     (push v fields))
-                                                   (fields (object-value (execution-context *context*))))
-                                          fields)))
+                                        (with-slots (fields) (object-value (execution-context *context*))
+                                          (let ((result nil))
+                                            (maphash (lambda (k v) (declare (ignore k))
+                                                       (push v fields))
+                                                     fields)
+                                            result))))
                     ,(field :name "interfaces"
-                            :type (list-type (non-null-type (named "__Type"))))
+                            :type ([!] "__Type"))
                     ,(field :name "possibleTypes"
-                            :type (list-type (non-null-type (named "__Type"))))
+                            :type ([!] "__Type"))
                     ,(field :name "enumValues"
-                            :type (list-type (non-null-type (named "__EnumValue"))))
+                            :type ([!] "__EnumValue"))
                     ,(field :name "inputFields"
-                            :type (list-type (non-null-type (named "__InputValue"))))
+                            :type ([!] "__InputValue"))
                     ,(field :name "ofType"
                             :type (named "__Type")
                             :resolver (lambda () *__type*))
                     ,(field :name "specifiedByUrl"
-                            :type (named "String")
+                            :type *string*
                             :resolver (lambda () "Hello")))))
 
 (defvar *__type-kind*
   (enum :name "__TypeKind"
         :description "An enum describing what kind of type a given `__Type` is"
-        :enum-values `(,(enum-val :enum-value "SCALAR")
-                       ,(enum-val :enum-value "OBJECT")
-                       ,(enum-val :enum-value "INTERFACE")
-                       ,(enum-val :enum-value "UNION")
-                       ,(enum-val :enum-value "ENUM")
-                       ,(enum-val :enum-value "INPUT_OBJECT")
-                       ,(enum-val :enum-value "LIST")
-                       ,(enum-val :enum-value "NON_NULL"))))
+        :enum-values `(,(enum-val :enum-value (make-name "SCALAR"))
+                       ,(enum-val :enum-value (make-name "OBJECT"))
+                       ,(enum-val :enum-value (make-name "INTERFACE"))
+                       ,(enum-val :enum-value (make-name "UNION"))
+                       ,(enum-val :enum-value (make-name "ENUM"))
+                       ,(enum-val :enum-value (make-name "INPUT_OBJECT"))
+                       ,(enum-val :enum-value (make-name "LIST"))
+                       ,(enum-val :enum-value (make-name "NON_NULL")))))
 
 (defvar *__field*
   (object :name "__Field"
           :description "Object and Interface types are described by a list of Fields, each of which has a name, potentially a list of arguments, and a return type."
           :fields `(,(field :name "name"
-                            :type (non-null-type (named "String"))
+                            :type (! *string*)
                             :resolver (lambda () (name (object-value (execution-context *context*)))))
                     ,(field :name "description"
-                            :type (named "String"))
+                            :type *string*)
                     ,(field :name "args"
-                            :type (non-null-type (list-type (non-null-type (named "__InputValue")))))
+                            :type ([!]! "__InputValue"))
                     ,(field :name "type"
-                            :type (non-null-type (named "__Type"))
-                            :resolver (lambda () (ty (object-value (execution-context *context*)))))
+                            :type (! "__Type")
+                            :resolver (lambda ()
+                                        (with-slots (object-value) (execution-context *context*)
+                                          (ty object-value))))
                     ,(field :name "isDeprecated"
-                            :type (non-null-type (named "Boolean")))
+                            :type (! *boolean*))
                     ,(field :name "deprecationReason"
-                            :type (named "String")))))
+                            :type *string*))))
 
 (defvar *__input-value*
   (object :name "__InputValue"
           :fields `(,(field :name "name"
-                            :type (non-null-type (named "String")))
+                            :type (! *string*))
                     ,(field :name "description"
-                            :type (named "String"))
+                            :type *string*)
                     ,(field :name "type"
-                            :type (non-null-type (named "Type")))
+                            :type (! "Type"))
                     ,(field :name "defaultValue"
-                            :type (named "String")))))
+                            :type *string*))))
 
 (defvar *__enum-value*
   (object :name "__EnumValue"
           :fields `(,(field :name "name"
-                            :type (non-null-type (named "String")))
+                            :type (! *string*))
                     ,(field :name "description"
-                            :type (named "String"))
+                            :type *string*)
                     ,(field :name "isDeprecated"
-                            :type (non-null-type (named "Boolean")))
+                            :type (! *boolean*))
                     ,(field :name "deprecationReason"
-                            :type (named "String")))))
+                            :type *string*))))
 
 (defvar *__directive*
   (object :name "__Directive"
           :fields `(,(field :name "name"
-                            :type (non-null-type (named "String")))
+                            :type (! *string*))
                     ,(field :name "description"
-                            :type (named "String"))
+                            :type *string*)
                     ,(field :name "location"
-                            :type (non-null-type (list-type (non-null-type (named "__DirectiveLocation")))))
+                            :type ([!]! "__DirectiveLocation"))
                     ,(field :name "args"
-                            :type (non-null-type (named "Boolean"))))))
+                            :type (! *boolean*)))))
 
 (defvar *__directive-location*
   (enum :name "__DirectiveLocation"
-        :enum-values `(,(enum-val :enum-value "QUERY")
-                       ,(enum-val :enum-value "MUTATION")
-                       ,(enum-val :enum-value "SUBSCRIPTION")
-                       ,(enum-val :enum-value "FIELD")
-                       ,(enum-val :enum-value "FRAGMENT_DEFINITION")
-                       ,(enum-val :enum-value "FRAGMENT_SPREAD")
-                       ,(enum-val :enum-value "INLINE_FRAGMENT")
-                       ,(enum-val :enum-value "SCHEMA")
-                       ,(enum-val :enum-value "SCALAR")
-                       ,(enum-val :enum-value "OBJECT")
-                       ,(enum-val :enum-value "FIELD_DEFINITION")
-                       ,(enum-val :enum-value "ARGUMENT_DEFINITION")
-                       ,(enum-val :enum-value "INTERFACE")
-                       ,(enum-val :enum-value "UNION")
-                       ,(enum-val :enum-value "ENUM")
-                       ,(enum-val :enum-value "ENUM_VALUE")
-                       ,(enum-val :enum-value "INPUT_OBJECT")
-                       ,(enum-val :enum-value "INPUT_FIELD_DEFINITION"))))
+        :enum-values `(,(enum-val :enum-value (make-name "QUERY"))
+                       ,(enum-val :enum-value (make-name "MUTATION"))
+                       ,(enum-val :enum-value (make-name "SUBSCRIPTION"))
+                       ,(enum-val :enum-value (make-name "FIELD"))
+                       ,(enum-val :enum-value (make-name "FRAGMENT_DEFINITION"))
+                       ,(enum-val :enum-value (make-name "FRAGMENT_SPREAD"))
+                       ,(enum-val :enum-value (make-name "INLINE_FRAGMENT"))
+                       ,(enum-val :enum-value (make-name "SCHEMA"))
+                       ,(enum-val :enum-value (make-name "SCALAR"))
+                       ,(enum-val :enum-value (make-name "OBJECT"))
+                       ,(enum-val :enum-value (make-name "FIELD_DEFINITION"))
+                       ,(enum-val :enum-value (make-name "ARGUMENT_DEFINITION"))
+                       ,(enum-val :enum-value (make-name "INTERFACE"))
+                       ,(enum-val :enum-value (make-name "UNION"))
+                       ,(enum-val :enum-value (make-name "ENUM"))
+                       ,(enum-val :enum-value (make-name "ENUM_VALUE"))
+                       ,(enum-val :enum-value (make-name "INPUT_OBJECT"))
+                       ,(enum-val :enum-value (make-name "INPUT_FIELD_DEFINITION")))))
 
 (defvar *__schema-field-definition*
   (field :description "Request the schema information."
          :name "__schema"
          :args nil
-         :type (non-null-type (named "__Schema"))
+         :type (! "__Schema")
          :resolver (lambda () (schema *context*))))
 
 (defvar *__type-field-definition*

          
@@ 163,16 167,16 @@ 
          :args `(,(make-instance 'input-value-definition
                                  :name (make-name "name")
                                  :description nil
-                                 :ty (non-null-type (named "String"))))
+                                 :ty (! "String")))
          :type (named "__Type")
          :resolver (lambda ()
-                     (let* ((args (arg-values (execution-context *context*)))
-                            (name (gethash "name" args)))
-                       (gethash name (type-map (schema *context*)))))))
+                     (with-slots (schema execution-context) *context*
+                       (let* ((name (gethash "name" (arg-values execution-context))))
+                         (gethash name (type-map schema)))))))
 
 (defvar *__typename-field-definition*
   (field :description "The name of the current Object type at runtime."
          :name "__typename"
          :args nil
-         :type (non-null-type (named "String"))
+         :type (! "String")
          :resolver (lambda () (name (object-type (execution-context *context*))))))

          
M src/package.lisp +21 -1
@@ 6,6 6,7 @@ 
    #:gql
    #:build-schema
    #:build-document
+   #:make-schema
    #:generate
    #:with-context
    #:execute

          
@@ 14,4 15,23 @@ 
    #:true
    #:false
    #:gql-object
-   #:make-resolvers))
+   #:make-name
+   #:named
+   #:list-type
+   #:non-null-type
+   #:field
+   #:object
+   #:interface
+   #:enum
+   #:enum-val
+   #:set-resolver
+
+   #:*int*
+   #:*float*
+   #:*string*
+   #:*boolean*
+   #:*id*
+   #:!
+   #:[]
+   #:[!]
+   #:[!]!))

          
M src/schema.lisp +1 -1
@@ 102,7 102,7 @@ 
       (enum-type-definition
        (when (listp (enum-values object-type))
          (dolist (enum-val (enum-values object-type))
-           (setf (gethash (enum-value enum-val) table) enum-val))
+           (setf (gethash (name (enum-value enum-val)) table) enum-val))
          (setf (enum-values object-type) table)))
       (union-type-definition
        (when (listp (union-members object-type))

          
M src/specials.lisp +0 -26
@@ 43,29 43,3 @@ ensure we have initialized the schema.")
    (arg-values :initarg :arg-values :accessor arg-values)))
 
 (defvar *execution-context* nil)
-
-(defun built-in-scalar-p (scalar)
-  (member scalar '("Int" "Float" "String" "Boolean" "ID") :test #'string=))
-
-(deftype built-in-scalar ()
-  '(and string (satisfies built-in-scalar-p)))
-
-(deftype wrapper-type ()
-  '(member non-null-type list-type))
-
-(deftype input-types ()
-  '(member
-    scalar-type-definition
-    input-object-type-definition
-    enum-type-definition))
-
-(deftype output-types ()
-  '(member
-    scalar-type-definition
-    object-type-definition
-    enum-type-definition
-    interface-type-definition
-    union-type-definition))
-
-(deftype bool ()
-  '(member true false))

          
A => src/types.lisp +111 -0
@@ 0,0 1,111 @@ 
+(in-package #:gql)
+
+(defun built-in-scalar-p (scalar)
+  (member scalar '("Int" "Float" "String" "Boolean" "ID") :test #'string=))
+
+(deftype built-in-scalar ()
+  '(and string (satisfies built-in-scalar-p)))
+
+(deftype wrapper-type ()
+  '(member non-null-type list-type))
+
+(deftype input-types ()
+  '(member
+    scalar-type-definition
+    input-object-type-definition
+    enum-type-definition))
+
+(deftype output-types ()
+  '(member
+    scalar-type-definition
+    object-type-definition
+    enum-type-definition
+    interface-type-definition
+    union-type-definition))
+
+(deftype bool ()
+  '(member true false))
+
+(defun make-name (type)
+  (check-type type string)
+  (make-instance 'name :name type :kind 'name))
+
+(defun named (type)
+  (check-type type string)
+  (make-instance 'named-type
+                 :kind 'named-type
+                 :name (make-name type)))
+
+(defun list-type (type)
+  (make-instance 'list-type
+                 :ty type
+                 :kind 'list-type))
+
+(defun non-null-type (type)
+  (make-instance 'non-null-type
+                 :ty type
+                 :kind 'non-null-type))
+
+(defun maybe-named (type)
+  (if (stringp type) (named type) type))
+
+(defun ! (type)
+  (non-null-type (maybe-named type)))
+
+(defun [] (type)
+  (list-type (maybe-named type)))
+
+(defun [!] (type)
+  ([] (! type)))
+
+(defun [!]! (type)
+  (! ([!] type)))
+
+(defvar *int*     (named "Int"))
+(defvar *float*   (named "Float"))
+(defvar *string*  (named "String"))
+(defvar *boolean* (named "Boolean"))
+(defvar *id*      (named "ID"))
+
+(defun field (&key name type resolver description args)
+  (make-instance 'field-definition
+                 :kind 'field-definition
+                 :description description
+                 :args args
+                 :ty type ;; TODO: Make sure we can use type instead of ty
+                 :name (make-name name)
+                 :resolver resolver))
+
+(defun object (&key name fields interfaces description)
+  (make-instance 'object-type-definition
+                 :kind 'object-type-definition
+                 :description description
+                 :name (make-name name)
+                 :fields fields
+                 :interfaces interfaces))
+
+(defun interface (&key name fields directives description)
+  (make-instance 'interface-type-definition
+                 :kind 'interface-type-definition
+                 :description description
+                 :name (make-name name)
+                 :fields fields
+                 :directives directives))
+
+(defun enum (&key name enum-values description)
+  (make-instance 'enum-type-definition
+                 :kind 'enum-type-definition
+                 :enum-values enum-values
+                 :description description
+                 :name (make-name name)))
+
+(defun enum-val (&key enum-value)
+  (make-instance 'enum-value-definition
+                 :kind 'enum-value
+                 :enum-value enum-value))
+
+(defun set-resolver (type-name field-name fn)
+  (let ((field-definition
+          (with-slots (type-map) (schema *context*)
+            (gethash field-name (fields (gethash type-name type-map ))))))
+    (setf (resolver field-definition) fn)))

          
M src/utils.lisp +0 -74
@@ 124,77 124,3 @@ 
     :accessor resolver
     :initform nil ;;(gql-error "Need to supply resolver for gql types")
     )))
-
-(defmacro make-resolvers (&body body)
-  `(let ((ht (make-hash-table :test #'equal)))
-     ,@(mapcar
-        (lambda (resolver)
-          `(setf (gethash ,(car resolver) ht) ,(cdr resolver)))
-        body)
-     ht))
-
-;;; Type system things
-
-(defun make-name (type)
-  (check-type type string)
-  (make-instance 'name :name type :kind 'name))
-
-(defun named (type)
-  (check-type type string)
-  (make-instance 'named-type
-                 :kind 'named-type
-                 :name (make-name type)))
-
-(defun list-type (type)
-  ;; TODO: Not done.  What type goes here?
-  (make-instance 'list-type
-                 :ty type
-                 :kind 'list-type))
-
-(defun non-null-type (type)
-  (make-instance 'non-null-type
-                 :ty type
-                 :kind 'non-null-type))
-
-(defun field (&key name type resolver description args)
-  (make-instance 'field-definition
-                 :kind 'field-definition
-                 :description description
-                 :args args
-                 :ty type ;; TODO: Make sure we can use type instead of ty
-                 :name (make-name name)
-                 :resolver resolver))
-
-(defun object (&key name fields interfaces description)
-  (make-instance 'object-type-definition
-                 :kind 'object-type-definition
-                 :description description
-                 :name (make-name name)
-                 :fields fields
-                 :interfaces interfaces))
-
-(defun interface (&key name fields directives description)
-  (make-instance 'interface-type-definition
-                 :kind 'interface-type-definition
-                 :description description
-                 :name (make-name name)
-                 :fields fields
-                 :directives directives))
-
-(defun enum (&key name enum-values description)
-  (make-instance 'enum-type-definition
-                 :kind 'enum-type-definition
-                 :enum-values enum-values
-                 :description description
-                 :name (make-name name)))
-
-(defun enum-val (&key enum-value)
-  (make-instance 'enum-value-definition
-                 :kind 'enum-value
-                 :enum-value enum-value))
-
-(defun set-resolver (type-name field-name fn)
-  (declare (optimize (debug 3)))
-  (let ((field-definition
-          (gethash field-name (fields (gethash type-name (type-map (schema *context*)))))))
-    (setf (resolver field-definition) fn)))