# HG changeset patch # User Theodor Thornhill # Date 1639572396 -3600 # Wed Dec 15 13:46:36 2021 +0100 # Node ID 3db33b44bdd233d6bc5f8468014ec1a5cc9f9a02 # Parent 8d04ecfa067072554059a9f20ed159497ac50059 Hash-tablify type-definitions At least start to. It should be way easier to find things when they are maps. Not really concerned about performance, but it might be slower/faster. Who knows. diff --git a/src/debugger-utils.lisp b/src/debugger-utils.lisp --- a/src/debugger-utils.lisp +++ b/src/debugger-utils.lisp @@ -12,6 +12,14 @@ (print-unreadable-object (obj stream :type t :identity t) (princ (nameof obj) stream))) +(defmethod print-object ((obj enum-type-definition) stream) + (print-unreadable-object (obj stream :type t :identity t) + (princ (nameof obj) stream))) + +(defmethod print-object ((obj interface-type-definition) stream) + (print-unreadable-object (obj stream :type t :identity t) + (princ (nameof obj) stream))) + (defmethod print-object ((obj named-type) stream) (print-unreadable-object (obj stream :type t :identity t) (princ (nameof obj) stream))) diff --git a/src/execution.lisp b/src/execution.lisp --- a/src/execution.lisp +++ b/src/execution.lisp @@ -2,17 +2,6 @@ (declaim (optimize (debug 3))) -(defgeneric resolve (object-type object-value field-name arg-values) - (:documentation "A function to resolve arbitrary values.")) - -(defmethod resolve (object-type object-value field-name arg-values) - ;; TODO: Ok, so now we get the corresponding type in the hash table, then - ;; funcall the function mapped to by field name. - (let ((resolvers (gethash (nameof object-type) *resolvers*))) - (if (> (hash-table-count arg-values) 0) - (funcall (gethash field-name resolvers) object-value arg-values) - (funcall (gethash field-name resolvers) object-value)))) - (defun fragment-type-applies-p (object-type fragment-type) ;; TODO: https://spec.graphql.org/draft/#DoesFragmentTypeApply() (let ((type-definition (gethash object-type (type-map *schema*)))) @@ -295,8 +284,7 @@ (etypecase abstract-type (interface-type-definition (gethash type-name (type-map *schema*))) (union-type-definition - (let ((union-member - (find type-name (union-members abstract-type) :key #'nameof :test #'string=))) + (let ((union-member (gethash type-name (union-members abstract-type)))) (gethash (nameof union-member) (type-map *schema*))))))) (defun execute-field (object-type object-value field-definition fields variable-values) diff --git a/src/schema.lisp b/src/schema.lisp --- a/src/schema.lisp +++ b/src/schema.lisp @@ -51,14 +51,15 @@ (dolist (type initial-types) ;; TODO: Error handling - (type-map-reducer schema type-map type)) + (type-map-reducer schema type-map type) + (mapify-type-definitions type)) (setf (type-map schema) type-map) schema)) (defun type-map-reducer (schema type-map object-type) ;; TODO: Return errors as well? - (when (or (null object-type) (equal (name object-type) "")) + (when (or (null object-type) (equal (nameof object-type) "")) (return-from type-map-reducer type-map)) (typecase object-type @@ -73,12 +74,39 @@ ;; ;; TODO: return an error here because the type already exists? ;; ) - (if (name object-type) - (setf (gethash (nameof object-type) type-map) object-type) - ;; TODO: Probably an idiotic check. Are we operation-definition for sure - ;; here? - (setf (gethash (operation-type object-type) type-map) object-type)) + (setf (gethash (nameof object-type) type-map) object-type) ;; TODO: Lots more to do here type-map) + +(defun mapify-type-definitions (object-type) + (let ((table (make-hash-table :test #'equal))) + (typecase object-type + ;; TODO: Do we need to map more things here? + (object-type-definition + (let ((interface-map (make-hash-table :test #'equal))) + (when (listp (fields object-type)) + (dolist (field (fields object-type)) + (setf (gethash (nameof field) table) field)) + (setf (fields object-type) table)) + (when (listp (interfaces object-type)) + (dolist (interface (interfaces object-type)) + (setf (gethash (nameof interface) interface-map) interface)) + (setf (interfaces object-type) interface-map)))) + (interface-type-definition + (when (listp (fields object-type)) + (dolist (field (fields object-type)) + (setf (gethash (nameof field) table) field)) + (setf (fields object-type) table))) + (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 (enum-values object-type) table))) + (union-type-definition + (when (listp (union-members object-type)) + (dolist (union-member (union-members object-type)) + (setf (gethash (nameof union-member) table) union-member)) + (setf (union-members object-type) table)))) + object-type)) diff --git a/src/utils.lisp b/src/utils.lisp --- a/src/utils.lisp +++ b/src/utils.lisp @@ -110,9 +110,8 @@ ((string= "__schema" field-name) *__schema-field-definition*) ((string= "__type" field-name) *__type-field-definition*) (t - (find-if (lambda (obj) (string= (nameof obj) field-name)) - ;; (fields (gethash (nameof object-type) *all-types*)) - (fields (gethash (nameof object-type) (type-map *schema*)))))))) + (let ((object (gethash (nameof object-type) (type-map *schema*)))) + (gethash field-name (fields object))))))) (defclass gql-object () ((type-name @@ -197,6 +196,8 @@ (defun set-resolver (type-name field-name fn) (declare (optimize (debug 3))) (let ((field-definition - (find-if (lambda (f) (string= (nameof f) field-name)) - (fields (gethash type-name (type-map *schema*)))))) + (gethash field-name (fields (gethash type-name (type-map *schema*)))) + ;; (find-if (lambda (f) (string= (nameof f) field-name)) + ;; ) + )) (setf (resolver field-definition) fn))) diff --git a/t/execution-tests.lisp b/t/execution-tests.lisp --- a/t/execution-tests.lisp +++ b/t/execution-tests.lisp @@ -3,9 +3,9 @@ (deftest execution (testing "collect-fields returns the correct fields" (let* ((definitions (gql::definitions - (build-schema "query { a { subfield1 } ...ExampleFragment } fragment ExampleFragment on Query { a { subfield2 } b }"))) + (build-schema "{ a { subfield1 } ...ExampleFragment } fragment ExampleFragment on Query { a { subfield2 } b }"))) (query-type (gql::object :name "Query"))) - (with-schema (gql::make-schema :query query-type :types definitions) + (with-schema (gql::make-schema :query query-type :types (cdr definitions)) (let* ((operation (find-if (lambda (x) (string= (gql::operation-type x) "Query")) definitions)) (operation-type (gql::operation-type operation)) (selection-set (gql::selection-set operation)) diff --git a/t/type-system-tests.lisp b/t/type-system-tests.lisp --- a/t/type-system-tests.lisp +++ b/t/type-system-tests.lisp @@ -130,32 +130,32 @@ (query-type (find-if (lambda (x) (string= (gql::nameof x) "Query")) definitions))) (with-schema (gql::make-schema :query query-type :types definitions) (let ((dog (gethash "Dog" (gql::type-map gql::*schema*)))) - (ok (gql::input-type-p (gql::ty (car (gql::fields dog))))) - (ok (gql::input-type-p (gql::ty (cadr (gql::fields dog))))) - (ok (gql::output-type-p (gql::ty (car (gql::fields dog))))) - (ok (gql::output-type-p (gql::ty (cadr (gql::fields dog))))))))) - (testing "enum" + (ok (gql::input-type-p (gql::ty (gethash "name" (gql::fields dog))))) + (ok (gql::input-type-p (gql::ty (gethash "nickname" (gql::fields dog))))) + (ok (gql::output-type-p (gql::ty (gethash "barkVolume" (gql::fields dog))))) + (ok (gql::output-type-p (gql::ty (gethash "name" (gql::fields dog))))))))) + (testing "union" (let* ((definitions (gql::definitions (build-schema (asdf:system-relative-pathname 'gql-tests #p"t/test-files/validation-schema.graphql")))) (query-type (find-if (lambda (x) (string= (gql::nameof x) "Query")) definitions))) (with-schema (gql::make-schema :query query-type :types definitions) (let ((human-or-alien (gethash "HumanOrAlien" (gql::type-map gql::*schema*)))) - (ng (gql::input-type-p (car (gql::union-members human-or-alien)))) - (ng (gql::input-type-p (cadr (gql::union-members human-or-alien)))) - (ok (gql::output-type-p (car (gql::union-members human-or-alien)))) - (ok (gql::output-type-p (cadr (gql::union-members human-or-alien)))))))) + (ng (gql::input-type-p (gethash "Human" (gql::union-members human-or-alien)))) + (ng (gql::input-type-p (gethash "Alien" (gql::union-members human-or-alien)))) + (ok (gql::output-type-p (gethash "Human" (gql::union-members human-or-alien)))) + (ok (gql::output-type-p (gethash "Alien" (gql::union-members human-or-alien)))))))) (testing "object" (let* ((definitions (gql::definitions (build-schema (asdf:system-relative-pathname 'gql-tests #p"t/test-files/validation-schema.graphql")))) (query-type (find-if (lambda (x) (string= (gql::nameof x) "Query")) definitions))) (with-schema (gql::make-schema :query query-type :types definitions) (let ((dog-or-human (gethash "DogOrHuman" (gql::type-map gql::*schema*)))) - (ng (gql::input-type-p (car (gql::union-members dog-or-human)))) - (ng (gql::input-type-p (cadr (gql::union-members dog-or-human)))) - (ok (gql::output-type-p (car (gql::union-members dog-or-human)))) - (ok (gql::output-type-p (cadr (gql::union-members dog-or-human)))))))) + (ng (gql::input-type-p (gethash "Dog" (gql::union-members dog-or-human)))) + (ng (gql::input-type-p (gethash "Human" (gql::union-members dog-or-human)))) + (ok (gql::output-type-p (gethash "Dog" (gql::union-members dog-or-human)))) + (ok (gql::output-type-p (gethash "Human" (gql::union-members dog-or-human)))))))) (testing "interface" (let* ((definitions (gql::definitions (build-schema (asdf:system-relative-pathname 'gql-tests #p"t/test-files/validation-schema.graphql")))) (query-type (find-if (lambda (x) (string= (gql::nameof x) "Query")) definitions))) (with-schema (gql::make-schema :query query-type :types definitions) (let ((cat (gethash "Cat" (gql::type-map gql::*schema*)))) - (ng (gql::input-type-p (car (gql::interfaces cat)))) - (ok (gql::output-type-p (car (gql::interfaces cat))))))))) + (ng (gql::input-type-p (gethash "Pet" (gql::interfaces cat)))) + (ok (gql::output-type-p (gethash "Pet" (gql::interfaces cat)))))))))