diff options
author | Arun Isaac | 2021-12-28 00:14:53 +0530 |
---|---|---|
committer | Arun Isaac | 2021-12-28 17:51:20 +0530 |
commit | 63bb66a579cb563d76c96bf69711f422e7f37a1c (patch) | |
tree | f16e80d4947897e638d4d4f0336fa1bcf82d52fc /kolam/parse.scm | |
download | kolam-63bb66a579cb563d76c96bf69711f422e7f37a1c.tar.gz kolam-63bb66a579cb563d76c96bf69711f422e7f37a1c.tar.lz kolam-63bb66a579cb563d76c96bf69711f422e7f37a1c.zip |
Initial commit
Diffstat (limited to 'kolam/parse.scm')
-rw-r--r-- | kolam/parse.scm | 568 |
1 files changed, 568 insertions, 0 deletions
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)) |