path: root/kolam/parse.scm

;;; 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-28)
  #:use-module (srfi srfi-71)
  #:use-module (ice-9 match)
  #:use-module ((ice-9 textual-ports) #:select (unget-string))
  #:use-module (kolam utils)
  #:export (graphql->scm
            graphql-string->scm
            scm->graphql
            scm->graphql-string))


;;; 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))

(define (indent-level port level)
  "Emit whitespaces to PORT corresponding to nesting LEVEL."
  (display (make-string (* 2 level) #\space) port))

(define (serialize-arguments arguments)
  "Serialize ARGUMENTS, and return the serialized string."
  (string-join (map (match-lambda
                      ((key . value)
                       (format "~a: ~s"
                               (keyword->symbol key)
                               value)))
                    (pairify arguments))
               ", "))

(define (serialize-node node)
  "Serialize NODE, and return the serialized string."
  (match node
    (#((? symbol? name) (? symbol? alias) arguments ...)
     (format "~a: ~a(~a)" alias name (serialize-arguments arguments)))
    (#((? symbol? name) arguments ...)
     (format "~a(~a)" name (serialize-arguments arguments)))
    ((? symbol? name) name)
    (_ (error "Invalid GraphQL node" node))))

(define (serialize-selection selection port level)
  "Serialize SELECTION to PORT at indentation LEVEL."
  (indent-level port level)
  (match selection
    ((root selections ...)
     (display (format "~a {~%" (serialize-node root))
              port)
     (for-each (cut serialize-selection <> port (1+ level))
               selections)
     (indent-level port level)
     (display (format "}~%") port))
    (leaf
     (display (format "~a~%" (serialize-node leaf))
              port))))

(define* (scm->graphql document #:optional (port (current-output-port)) (level 0))
  "Serialize GraphQL DOCUMENT to PORT."
  (match document
    (('document queries ...)
     (for-each (match-lambda
                 (('query selections ...)
                  (display "query {" port)
                  (newline port)
                  (for-each (cut serialize-selection <> port (1+ level))
                            selections)
                  (display "}" port)
                  (newline port))
                 (operation (error "Invalid GraphQL operation" operation)))
               queries))
    (_ (error "Invalid GraphQL document" document))))

(define (scm->graphql-string document)
  "Serialize GraphQL DOCUMENT, and return the serialized string."
  (call-with-output-string
    (cut scm->graphql document <>)))