From 63bb66a579cb563d76c96bf69711f422e7f37a1c Mon Sep 17 00:00:00 2001
From: Arun Isaac
Date: Tue, 28 Dec 2021 00:14:53 +0530
Subject: Initial commit

---
 README.org        |   3 +
 kolam/graphql.scm | 190 ++++++++++++++++++
 kolam/parse.scm   | 568 ++++++++++++++++++++++++++++++++++++++++++++++++++++++
 3 files changed, 761 insertions(+)
 create mode 100644 README.org
 create mode 100644 kolam/graphql.scm
 create mode 100644 kolam/parse.scm

diff --git a/README.org b/README.org
new file mode 100644
index 0000000..326ec08
--- /dev/null
+++ b/README.org
@@ -0,0 +1,3 @@
+#+TITLE: kolam
+
+kolam is a [[https://graphql.org/][GraphQL]] implementation for Scheme.
diff --git a/kolam/graphql.scm b/kolam/graphql.scm
new file mode 100644
index 0000000..676caa4
--- /dev/null
+++ b/kolam/graphql.scm
@@ -0,0 +1,190 @@
+;;; kolam --- GraphQL implementation
+;;; Copyright © 2021 Arun Isaac <arunisaac@systemreboot.net>
+;;;
+;;; This file is part of kolam.
+;;;
+;;; kolam is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU Affero General Public License as
+;;; published by the Free Software Foundation; either version 3 of the
+;;; License, or (at your option) any later version.
+;;;
+;;; kolam is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Affero General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Affero General Public
+;;; License along with kolam.  If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+(define-module (kolam graphql)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-19)
+  #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-71)
+  #:use-module (ice-9 match)
+  #:export (graphql-evaluator
+            graphql-schema
+            define-object-type
+            define-scalar-type
+            define-enum-type
+            non-nullable-type
+            list-type
+            <integer>
+            <float>
+            <string>
+            <boolean>
+            <id>
+            <date>))
+
+(define-record-type <schema>
+  (make-schema query mutation)
+  schema?
+  (query schema-query)
+  (mutation schema-mutation))
+
+(define* (graphql-schema #:key query mutation)
+  (make-schema query mutation))
+
+(define-record-type <field>
+  (make-field name type resolver)
+  field?
+  (name field-name)
+  (type delayed-field-type)
+  (resolver field-resolver))
+
+(define field-type (compose force delayed-field-type))
+
+(define-record-type <object-type>
+  (make-object-type identifier fields)
+  object-type?
+  (identifier object-type-identifier)
+  (fields object-type-fields))
+
+(define-syntax-rule (define-object-type identifier (name type resolver) ...)
+  (define identifier
+    (make-object-type 'identifier
+                      (list (make-field 'name (delay type) resolver) ...))))
+
+(define-record-type <scalar-type>
+  (make-scalar-type identifier predicate serializer)
+  scalar-type?
+  (identifier scalar-type-identifier)
+  (predicate scalar-type-predicate)
+  (serializer scalar-type-serializer))
+
+(define-syntax-rule (define-scalar-type identifier predicate serializer)
+  (define identifier
+    (make-scalar-type 'identifier predicate serializer)))
+
+(define-scalar-type <integer> integer? identity)
+(define-scalar-type <float>
+  (lambda (x)
+    (and (real? x)
+         (not (rational? x))))
+  identity)
+(define-scalar-type <string> string? identity)
+(define-scalar-type <boolean> boolean? identity)
+(define-scalar-type <id> string? identity)
+(define-scalar-type <date> date? (cut date->string <> "~4"))
+
+(define-record-type <non-nullable-type>
+  (non-nullable-type subtype)
+  non-nullable-type?
+  (subtype non-nullable-type-subtype))
+
+(define-record-type <list-type>
+  (list-type subtype)
+  list-type?
+  (subtype list-type-subtype))
+
+(define-record-type <enum-type>
+  (make-enum-type enumerators)
+  enum-type?
+  (enumerators enum-type-enumerators))
+
+(define-syntax-rule (define-enum-type identifier enumerators ...)
+  (define identifier
+    (make-enum-type (list enumerators ...))))
+
+(define (find-field type field)
+  "Find field named FIELD in TYPE."
+  (find (lambda (root-type-field)
+          (eq? (field-name root-type-field)
+               field))
+        (object-type-fields type)))
+
+(define (correct-type? value type)
+  "Return non-#f if VALUE is of GraphQL TYPE. Else, return #f."
+  (cond
+   ((scalar-type? type)
+    ((scalar-type-predicate type) value))
+   ((enum-type? type)
+    (member value
+            (enum-type-enumerators type)))
+   ((non-nullable-type? type)
+    (and (not (eq? value 'null))
+         (correct-type? value (non-nullable-type-subtype type))))
+   ((list-type? type)
+    (and (list? value)
+         (every (cut correct-type? <> (list-type-subtype type))
+                value)))
+   ((object-type? type) #t)
+   (else (error "Unknown type:" type))))
+
+(define (graphql-evaluator schema)
+  (match-lambda
+    (('query tree)
+     (eval-graphql tree (schema-query schema)))
+    (operation (error "Invalid GraphQL operation:" operation))))
+
+(define* (eval-graphql tree parent-type #:optional parent)
+  (let* ((root args children (match tree
+                               ((#(root args ...) children ...) (values root args children))
+                               ((root children ...) (values root '() children))
+                               (#(leaf args ...) (values leaf args #f))
+                               (leaf (values leaf '() #f))))
+         ;; TODO: Check if required args are present.
+         (root-field (or (find-field parent-type root)
+                         (error "Unknown field:" root)))
+         (root-type (field-type root-field))
+         (underlying-type (if (non-nullable-type? root-type)
+                              (non-nullable-type-subtype root-type)
+                              root-type))
+         (next-parent (apply (field-resolver root-field)
+                             parent #f #f args)))
+    (unless (correct-type? next-parent root-type)
+      (error "Return value of resolver is of unexpected GraphQL type:"
+             next-parent root-type))
+    (when (and (not children)
+               (not (or (scalar-type? underlying-type)
+                        (enum-type? underlying-type))))
+      (error "Leaf node must be scalar or enum type:" root-field underlying-type))
+    (cons root
+          (cond
+           ((eq? next-parent 'null) 'null)
+           ;; List of non-object types
+           ((and (list-type? underlying-type)
+                 (not (object-type? (list-type-subtype underlying-type))))
+            (list->vector next-parent))
+           ;; List of object types
+           ((list-type? underlying-type)
+            (list->vector
+             (map (lambda (next-parent-element)
+                    (map (cut eval-graphql
+                              <>
+                              (list-type-subtype underlying-type)
+                              next-parent-element)
+                         children))
+                  next-parent)))
+           ;; Non-leaf node
+           (children
+            (map (cut eval-graphql <> underlying-type next-parent)
+                 children))
+           ;; Leaf node of a scalar type
+           ((scalar-type? underlying-type)
+            ((scalar-type-serializer underlying-type) next-parent))
+           ;; Leaf node of enum type
+           ((enum-type? underlying-type) next-parent)
+           (else (error "eval-graphql bug: Unknown underlying-type:" underlying-type))))))
diff --git a/kolam/parse.scm b/kolam/parse.scm
new file mode 100644
index 0000000..fa05148
--- /dev/null
+++ b/kolam/parse.scm
@@ -0,0 +1,568 @@
+;;; kolam --- GraphQL implementation
+;;; Copyright © 2021 Arun Isaac <arunisaac@systemreboot.net>
+;;;
+;;; This file is part of kolam.
+;;;
+;;; kolam is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU Affero General Public License as
+;;; published by the Free Software Foundation; either version 3 of the
+;;; License, or (at your option) any later version.
+;;;
+;;; kolam is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Affero General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Affero General Public
+;;; License along with kolam.  If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+(define-module (kolam parse)
+  #:use-module (rnrs io ports)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-71)
+  #:use-module (ice-9 match)
+  #:use-module ((ice-9 textual-ports) #:select (unget-string))
+  #:export (graphql->scm
+            graphql-string->scm))
+
+
+;;; Lexer
+
+;; FIXME: Error out all readers on unexpected end of input.
+(define (read-name port)
+  (call-with-output-string
+    (lambda (out)
+      (put-char out (get-char port))
+      (let loop ()
+        (let ((c (lookahead-char port)))
+          (when (and (not (eof-object? c))
+                     (char-set-contains? (char-set-union
+                                          (char-set #\_)
+                                          (char-set-intersection char-set:letter+digit
+                                                                 char-set:ascii))
+                                         c))
+            (put-char out (get-char port))
+            (loop)))))))
+
+(define (read-digit-sequence port)
+  (call-with-output-string
+    (lambda (out)
+      (let loop ()
+        (let ((c (lookahead-char port)))
+          (when (and (not (eof-object? c))
+                     (char-set-contains? (char-set-intersection char-set:digit
+                                                                char-set:ascii)
+                                         c))
+            (put-char out (get-char port))
+            (loop)))))))
+
+(define (read-integer-part port)
+  ;; FIXME: 00 is apparently not a valid int-value.
+  (string-append (string (get-char port))
+                 (read-digit-sequence port)))
+
+(define (read-escaped-character port)
+  "Read an escaped character from PORT. The port position should be
+after the backslash character that initiated the escaped character."
+  (let ((c (get-char port)))
+    (string-ref
+     (call-with-input-string
+         (string-append (string #\")
+                        (case c
+                          ;; The forward slash needs to be escaped in
+                          ;; GraphQL, but not in Scheme.
+                          ((#\/) (string #\/))
+                          ;; Usual escape sequences
+                          ((#\" #\\ #\b #\f #\n #\r #\t)
+                           (string #\\ c))
+                          ;; Unicode character
+                          ((#\u)
+                           (string-append (string #\\ #\u)
+                                          (get-string-n port 4)))
+                          (else (error "Invalid escape sequence character" c)))
+                        (string #\"))
+       read)
+     0)))
+
+(define (lookahead-string-n port count)
+  (let ((str (get-string-n port count)))
+    (unless (eof-object? str)
+      (unget-string port str))
+    str))
+
+(define (read-string port)
+  (get-char port)
+  (call-with-output-string
+    (lambda (out)
+      (let loop ()
+        (let ((c (get-char port)))
+          (unless (eof-object? c)
+            (cond
+             ((char-set-contains? (char-set #\newline #\return)
+                                  c)
+              (error "Unexpected line terminator in string"))
+             ((char=? c #\\)
+              (put-char out (read-escaped-character port))
+              (loop))
+             ((not (char=? c #\"))
+              (put-char out c)
+              (loop)))))))))
+
+(define (string-blank? str)
+  "Return non-#f if STR contains only whitespace characters. Else,
+return #f."
+  (string-every char-set:whitespace str))
+
+(define (drop-right-while pred lst)
+  "Drop the longest suffix of LST whose elements all satisfy PRED."
+  (reverse (drop-while pred (reverse lst))))
+
+(define (block-string-value str)
+  (let* ((trimmed-lines (drop-right-while string-blank?
+                                          (drop-while string-blank?
+                                                      (string-split str #\newline))))
+         (common-indent
+          (match trimmed-lines
+            ((first-line other-lines ...)
+             (fold (lambda (line result)
+                     (if (string-blank? line)
+                         result
+                         (min result (string-index line
+                                                   (char-set-complement char-set:whitespace)))))
+                   (string-index first-line (char-set-complement char-set:whitespace))
+                   other-lines)))))
+    (string-join (map (lambda (line)
+                        (if (string-blank? line)
+                            line
+                            (substring line common-indent)))
+                      trimmed-lines)
+                 "\n")))
+
+(define (read-block-string port)
+  (get-string-n port 3)
+  (call-with-output-string
+    (lambda (out)
+      (let loop ()
+        (cond
+         ;; End of blockstring
+         ((or (eof-object? (lookahead-string-n port 3))
+              (string=? (lookahead-string-n port 3)
+                        "\"\"\""))
+          (get-string-n port 3))
+         ;; Escaped triple quote
+         ((string=? (lookahead-string-n port 4)
+                    "\\\"\"\"")
+          (get-string-n port 4)
+          (put-string out "\"\"\"")
+          (loop))
+         (else
+          (put-char out (get-char port))
+          (loop)))))))
+
+(define (make-lexer port)
+  (lambda ()
+    (let loop ()
+      (let ((c (lookahead-char port)))
+        (cond
+         ((eof-object? c) c)
+         ;; Ignored
+         ((char-set-contains? (char-set (integer->char #xFEFF)
+                                        #\tab #\space #\newline #\return #\,)
+                              c)
+          (get-char port)
+          (loop))
+         ;; Comments
+         ((char=? c #\#)
+          (get-line port)
+          (when (eq? (lookahead-char port) #\return)
+            (get-char port))
+          (loop))
+         ;; Punctuator
+         ((char-set-contains? (char-set #\! #\$ #\& #\( #\)
+                                        #\… #\: #\= #\@ #\[ #\]
+                                        #\{ #\| #\})
+                              c)
+          (cons 'punctuator (get-char port)))
+         ;; Name
+         ((char-set-contains? (char-set-union
+                               (char-set #\_)
+                               (char-set-intersection char-set:letter
+                                                      char-set:ascii))
+                              c)
+          (cons 'name (read-name port)))
+         ;; Numbers
+         ((char-set-contains? (char-set-union
+                               (char-set #\-)
+                               (char-set-intersection char-set:digit
+                                                      char-set:ascii))
+                              c)
+          (let ((integer-part (read-integer-part port))
+                (fractional-part (case (lookahead-char port)
+                                   ((#\.)
+                                    (get-char port)
+                                    (read-digit-sequence port))
+                                   (else #f)))
+                (exponential-part (case (lookahead-char port)
+                                    ((#\e #\E)
+                                     (get-char port)
+                                     (read-integer-part port))
+                                    (else #f))))
+            (cond
+             ((and (not fractional-part)
+                   (not exponential-part))
+              (cons 'int-value integer-part))
+             (else
+              (cons 'float-value
+                    (string-append integer-part
+                                   (if fractional-part
+                                       (string-append "." fractional-part)
+                                       "")
+                                   (if exponential-part
+                                       (string-append "e" exponential-part)
+                                       "")))))))
+         ;; String value
+         ((eq? c #\")
+          (cons 'string-value
+                (if (string=? (lookahead-string-n port 3)
+                              "\"\"\"")
+                    (block-string-value
+                     (read-block-string port))
+                    (read-string port))))
+         (else (error "kolam lexer bug, unidentified token at character:" c)))))))
+
+
+;;; Parser
+;;;
+;;; Every parser function (*-pattern functions) is a procedure that
+;;; takes a list of tokens as an argument and returns the result of the
+;;; match and the remaining tokens. The result of the match must be #f
+;;; or a pair.
+;;;
+;;; If the match was unsuccessful, the result of the match must be
+;;; #f. Else, it must be a pair, with the first element being the
+;;; symbol identifying the matched object, and the second element being
+;;; the object itself.
+
+(define-record-type <optional>
+  (make-optional)
+  optional?)
+
+(define %optional (make-optional))
+
+(define-syntax pattern-optional
+  (syntax-rules ()
+    ((_ proc pattern)
+     (pattern-optional-function (delay pattern) proc))
+    ((_ pattern)
+     (pattern-optional-function (delay pattern)))))
+
+(define* (pattern-optional-function pattern #:optional proc)
+  (lambda (tokens)
+    (let ((matched remaining-tokens ((force pattern) tokens)))
+      (if matched
+          (values (if proc
+                      (proc (strip-token-id matched))
+                      matched)
+                  remaining-tokens)
+          (values (cons 'optional %optional)
+                  tokens)))))
+
+(define* (many-collect pattern tokens #:optional (result '()))
+  (if (null? tokens)
+      (values (reverse result) tokens)
+      (let ((matched remaining-tokens (pattern tokens)))
+        (if matched
+            (many-collect pattern remaining-tokens (cons matched result))
+            (values (reverse result) tokens)))))
+
+(define strip-token-id
+  (match-lambda
+    ((_ . token-value) token-value)
+    (token (error "Invalid token:" token))))
+
+(define-syntax-rule (pattern-many proc pattern)
+  (pattern-many-function proc (delay pattern)))
+
+(define* (pattern-many-function proc pattern)
+  (lambda (tokens)
+    (let ((matched remaining-tokens (many-collect (force pattern) tokens)))
+      (values (proc (map strip-token-id matched))
+              remaining-tokens))))
+
+(define* (and-collect patterns tokens #:optional (result '()))
+  (match patterns
+    (() (values (reverse result) tokens))
+    ((pattern remaining-patterns ...)
+     (let ((matched remaining-tokens (pattern tokens)))
+       (if matched
+           (and-collect remaining-patterns remaining-tokens (cons matched result))
+           (values #f tokens))))))
+
+(define-syntax-rule (pattern-and proc patterns ...)
+  (pattern-and-function proc (delay patterns) ...))
+
+(define (pattern-and-function proc . patterns)
+  (lambda (tokens)
+    (let ((matched remaining-tokens (and-collect (map force patterns)
+                                                 tokens)))
+      (if matched
+          (values (apply proc (map strip-token-id matched))
+                  remaining-tokens)
+          (values #f tokens)))))
+
+(define* (or-collect patterns tokens #:optional (result '()))
+  (match patterns
+    (() (values #f tokens))
+    ((pattern remaining-patterns ...)
+     (let ((matched remaining-tokens (pattern tokens)))
+       (if matched
+           (values matched remaining-tokens)
+           (or-collect remaining-patterns tokens (cons matched result)))))))
+
+(define-syntax-rule (pattern-or proc patterns ...)
+  (pattern-or-function proc (delay patterns) ...))
+
+(define (pattern-or-function proc . patterns)
+  (lambda (tokens)
+    (let ((matched remaining-tokens (or-collect (map force patterns) tokens)))
+      (if matched
+          (values (proc matched)
+                  remaining-tokens)
+          (values #f tokens)))))
+
+(define-syntax-rule (pattern-not pattern)
+  (pattern-not-function (delay pattern)))
+
+(define (pattern-not-function pattern)
+  (lambda (tokens)
+    (let ((matched remaining-tokens ((force pattern) tokens)))
+      (values (and (not matched)
+                   (cons 'negation 'null))
+              tokens))))
+
+(define (token-pattern token)
+  (lambda (tokens)
+    (match tokens
+      (((head-id . head-value) tail ...)
+       (if (eq? head-id token)
+           (values (cons head-id head-value)
+                   tail)
+           (values #f tokens)))
+      (() (values #f tokens)))))
+
+(define (token-value-pattern token-id token-value)
+  (lambda (tokens)
+    (match tokens
+      ((head tail ...)
+       (if (equal? head (cons token-id token-value))
+           (values head tail)
+           (values #f tokens)))
+      (() (values #f tokens)))))
+
+(define variable-pattern
+  (pattern-and (lambda (dollar name)
+                 (cons 'variable name))
+               (token-value-pattern 'punctuator #\$)
+               (token-pattern 'name)))
+
+(define alias-pattern
+  (pattern-and (lambda (name colon)
+                 (cons 'alias (string->symbol name)))
+               (token-pattern 'name)
+               (token-value-pattern 'punctuator #\:)))
+
+(define operation-type-pattern
+  (pattern-or (match-lambda
+                (('name . value)
+                 (cons 'operation-type (string->symbol value))))
+              (token-value-pattern 'name "query")
+              (token-value-pattern 'name "mutation")
+              (token-value-pattern 'name "subscription")))
+
+(define selection-set-pattern
+  (pattern-and (lambda (open selections close)
+                 (cons 'selection-set selections))
+               (token-value-pattern 'punctuator #\{)
+               (pattern-many (cut cons 'selections <>) selection-pattern)
+               (token-value-pattern 'punctuator #\})))
+
+(define selection-pattern
+  (pattern-or (match-lambda
+                (('field . field)
+                 (cons 'selection field)))
+              field-pattern
+              ;; TODO: Implement fragments.
+              ;; fragment-spread-pattern
+              ;; inline-fragment-pattern
+              ))
+
+(define field-pattern
+  (pattern-and (lambda (alias name arguments selection-set)
+                 (let* ((name (string->symbol name))
+                        (arguments (if (optional? arguments)
+                                       (list)
+                                       arguments))
+                        (main-node
+                         (match (if (optional? alias)
+                                    arguments
+                                    (cons alias arguments))
+                           (() name)
+                           (alias-and-arguments (apply vector name alias-and-arguments)))))
+                   (cons 'field
+                         (if (optional? selection-set)
+                             main-node
+                             (cons main-node selection-set)))))
+               (pattern-optional alias-pattern)
+               (token-pattern 'name)
+               (pattern-optional arguments-pattern)
+               ;; TODO: Implement directives.
+               ;; (pattern-optional directives-pattern)
+               (pattern-optional selection-set-pattern)))
+
+(define arguments-pattern
+  (pattern-and (lambda (open arguments close)
+                 (cons 'arguments (apply append arguments)))
+               (token-value-pattern 'punctuator #\()
+               (pattern-many (cut cons 'arguments <>) argument-pattern)
+               (token-value-pattern 'punctuator #\))))
+
+(define argument-pattern
+  (pattern-and (lambda (name colon value)
+                 (cons 'argument (list (symbol->keyword (string->symbol name))
+                                       value)))
+               (token-pattern 'name)
+               (token-value-pattern 'punctuator #\:)
+               value-pattern))
+
+(define boolean-value-pattern
+  (pattern-or (match-lambda
+                (('name . value)
+                 (cons 'boolean-value value)))
+              (token-value-pattern 'name "true")
+              (token-value-pattern 'name "false")))
+
+(define null-value-pattern
+  (pattern-or (match-lambda
+                (('name . "null")
+                 (cons 'null-value "null")))
+              (token-value-pattern 'name "null")))
+
+(define enum-value-pattern
+  (pattern-and (lambda (not1 not2 name)
+                 (cons 'enum-value name))
+               (pattern-not boolean-value-pattern)
+               (pattern-not null-value-pattern)
+               (token-pattern 'name)))
+
+(define list-value-pattern
+  (pattern-or identity
+              (pattern-and (lambda _
+                             (cons 'list-value (list)))
+                           (token-value-pattern 'punctuator #\[)
+                           (token-value-pattern 'punctuator #\]))
+              (pattern-and (lambda (open values close)
+                             (cons 'list-value values))
+                           (token-value-pattern 'punctuator #\[)
+                           (pattern-many (cut cons 'values <>) value-pattern)
+                           (token-value-pattern 'punctuator #\]))))
+
+(define object-value-pattern
+  (pattern-or identity
+              (pattern-and (lambda _
+                             (cons 'object-value (list)))
+                           (token-value-pattern 'punctuator #\{)
+                           (token-value-pattern 'punctuator #\}))
+              (pattern-and (lambda (open object-fields close)
+                             (cons 'object-value object-fields))
+                           (token-value-pattern 'punctuator #\{)
+                           (pattern-many (cut cons 'object-fields <>) object-field-pattern)
+                           (token-value-pattern 'punctuator #\}))))
+
+(define object-field-pattern
+  (pattern-and (lambda (name colon value)
+                 (list 'object-field name value))
+               (token-pattern 'name)
+               (token-value-pattern 'punctuator #\:)
+               (token-pattern 'value)))
+
+(define value-pattern
+  (pattern-or (match-lambda
+                (((or 'int-value 'float-value) . value)
+                 (cons 'value (string->number value)))
+                ((_ . value)
+                 (cons 'value value)))
+              variable-pattern
+              (token-pattern 'int-value)
+              (token-pattern 'float-value)
+              (token-pattern 'string-value)
+              boolean-value-pattern
+              null-value-pattern
+              enum-value-pattern
+              list-value-pattern
+              object-value-pattern))
+
+(define operation-definition-pattern
+  (pattern-or (match-lambda
+                (('operation-definition . operation-definition)
+                 (cons 'operation-definition operation-definition))
+                (('selection-set . selection-set)
+                 (cons 'operation-definition
+                       (cons 'query selection-set))))
+              (pattern-and (lambda (operation-type name selection-set)
+                             ;; TODO: Use name.
+                             (cons 'operation-definition
+                                   (cons operation-type selection-set)))
+                           operation-type-pattern
+                           (pattern-optional (token-pattern 'name))
+                           ;; TODO: Implement variables and directives.
+                           ;; (pattern-optional variable-definitions-pattern)
+                           ;; (pattern-optional directives-pattern)
+                           selection-set-pattern)
+              selection-set-pattern))
+
+(define executable-definition-pattern
+  (pattern-or (match-lambda
+                (('operation-definition . operation-definition)
+                 (cons 'executable-definition operation-definition)))
+              operation-definition-pattern
+              ;; TODO: Implement fragments.
+              ;; fragment-definition-pattern
+              ))
+
+(define executable-document-pattern
+  (pattern-many (lambda (executable-definitions)
+                  (cons 'executable-document executable-definitions))
+                executable-definition-pattern))
+
+(define definition-pattern
+  (pattern-or (match-lambda
+                (('executable-definition . executable-definition)
+                 (cons 'definition executable-definition)))
+              executable-definition-pattern))
+
+(define document-pattern
+  (pattern-many (lambda (definitions)
+                  (cons 'document definitions))
+                definition-pattern))
+
+
+;;; Public interface and other functions
+
+(define (drain-lexer lexer)
+  (let ((token (lexer)))
+    (if (eof-object? token)
+        '()
+        (cons token (drain-lexer lexer)))))
+
+(define (graphql->scm port)
+  (let ((matched remaining-tokens (document-pattern (drain-lexer (make-lexer port)))))
+    (if (null? remaining-tokens)
+        matched
+        (error "Expected end of GraphQL document"))))
+
+(define (graphql-string->scm str)
+  (call-with-input-string str
+    graphql->scm))
-- 
cgit v1.2.3