Files
rose-ash/lib/graphql.sx
giles fc24cc704d GraphQL: query/mutation/fragments/vars/executor + parser spec + tests
New graphql application. 676-line test-graphql.sx covers parser, executor,
fetch-gql integration. lib/graphql.sx (686L) is the core parser/AST;
lib/graphql-exec.sx (219L) runs resolvers. applications/graphql/spec.sx
declares the application. sx/sx/applications/graphql/ provides the doc
pages (parser, queries, mutation, fragments, vars, fetch-gql, executor).

Includes rebuilt sx_browser.bc.js / sx_browser.bc.wasm.js bundles.

Co-Authored-By: Claude Opus 4.7 (1M context) <noreply@anthropic.com>
2026-04-22 09:08:00 +00:00

687 lines
24 KiB
Plaintext

;; GraphQL parser — tokenizer + recursive descent → SX AST
;;
;; Parses the GraphQL query language (queries, mutations, subscriptions,
;; fragments, variables, directives) into s-expression AST.
;;
;; Usage:
;; (gql-parse "{ user(id: 1) { name email } }")
;;
;; AST node types:
;; (gql-doc definitions...)
;; (gql-query name vars directives selections)
;; (gql-mutation name vars directives selections)
;; (gql-subscription name vars directives selections)
;; (gql-field name args directives selections [alias])
;; (gql-fragment name on-type directives selections)
;; (gql-fragment-spread name directives)
;; (gql-inline-fragment on-type directives selections)
;; (gql-var name) — $variableName reference
;; (gql-var-def name type default) — variable definition
;; (gql-type name) — named type
;; (gql-list-type inner) — [Type]
;; (gql-non-null inner) — Type!
;; (gql-directive name args) — @directive(args)
;; ── Character helpers (shared) ────────────────────────────────────
(define
gql-ws?
(fn (c) (or (= c " ") (= c "\t") (= c "\n") (= c "\r") (= c ","))))
(define gql-digit? (fn (c) (and c (>= c "0") (<= c "9"))))
(define
gql-letter?
(fn
(c)
(and c (or (and (>= c "a") (<= c "z")) (and (>= c "A") (<= c "Z"))))))
(define gql-name-start? (fn (c) (or (gql-letter? c) (= c "_"))))
(define gql-name-char? (fn (c) (or (gql-name-start? c) (gql-digit? c))))
;; ── Tokenizer ─────────────────────────────────────────────────────
;; Returns {:tokens list :pos int} — state-passing style to avoid
;; multiple define closures over the same mutable variable.
(define
gql-char-at
(fn (src len i) (if (< i len) (substring src i (+ i 1)) nil)))
(define
gql-skip-ws
(fn
(src len pos)
"Skip whitespace, commas, and # comments. Returns new pos."
(if
(>= pos len)
pos
(let
((c (gql-char-at src len pos)))
(cond
((gql-ws? c) (gql-skip-ws src len (+ pos 1)))
((= c "#")
(let
((eol-pos (gql-skip-to-eol src len (+ pos 1))))
(gql-skip-ws src len eol-pos)))
(true pos))))))
(define
gql-skip-to-eol
(fn
(src len pos)
(if
(>= pos len)
pos
(if
(= (gql-char-at src len pos) "\n")
pos
(gql-skip-to-eol src len (+ pos 1))))))
(define
gql-read-name
(fn
(src len pos)
"Read [_A-Za-z][_A-Za-z0-9]*. Returns {:value name :pos new-pos}."
(let
((start pos))
(define
loop
(fn
(p)
(if
(and (< p len) (gql-name-char? (gql-char-at src len p)))
(loop (+ p 1))
{:pos p :value (substring src start p)})))
(loop pos))))
(define
gql-read-number
(fn
(src len pos)
"Read number. Returns {:value num :pos new-pos}."
(let
((start pos) (p pos))
(when (= (gql-char-at src len p) "-") (set! p (+ p 1)))
(define
dloop
(fn
(p has-dot)
(if
(>= p len)
{:pos p :value (parse-number (substring src start p))}
(let
((c (gql-char-at src len p)))
(cond
((gql-digit? c) (dloop (+ p 1) has-dot))
((and (= c ".") (not has-dot)) (dloop (+ p 1) true))
((or (= c "e") (= c "E"))
(let
((p2 (+ p 1)))
(when
(or
(= (gql-char-at src len p2) "+")
(= (gql-char-at src len p2) "-"))
(set! p2 (+ p2 1)))
(dloop p2 has-dot)))
(true {:pos p :value (parse-number (substring src start p))}))))))
(dloop p false))))
(define
gql-read-string
(fn
(src len pos)
"Read double-quoted string. pos is ON the opening quote. Returns {:value str :pos new-pos}."
(let
((p (+ pos 1)))
(if
(and
(< (+ p 1) len)
(= (gql-char-at src len p) "\"")
(= (gql-char-at src len (+ p 1)) "\""))
(let
((p2 (+ p 2)))
(define
bloop
(fn
(bp)
(if
(and
(< (+ bp 2) len)
(= (gql-char-at src len bp) "\"")
(= (gql-char-at src len (+ bp 1)) "\"")
(= (gql-char-at src len (+ bp 2)) "\""))
{:pos (+ bp 3) :value (substring src p2 bp)}
(bloop (+ bp 1)))))
(bloop p2))
(do
(define
sloop
(fn
(sp parts)
(if
(>= sp len)
{:pos sp :value (join "" parts)}
(let
((c (gql-char-at src len sp)))
(cond
((= c "\"") {:pos (+ sp 1) :value (join "" parts)})
((= c "\\")
(let
((esc (gql-char-at src len (+ sp 1)))
(sp2 (+ sp 2)))
(sloop
sp2
(append
parts
(list
(cond
((= esc "n") "\n")
((= esc "t") "\t")
((= esc "r") "\r")
((= esc "\\") "\\")
((= esc "\"") "\"")
((= esc "/") "/")
(true (str "\\" esc))))))))
(true (sloop (+ sp 1) (append parts (list c)))))))))
(sloop p (list)))))))
(define
gql-tokenize
(fn
(src)
(let
((len (string-length src)))
(define
tok-loop
(fn
(pos acc)
(let
((pos (gql-skip-ws src len pos)))
(if
(>= pos len)
(append acc (list {:pos pos :value nil :type "eof"}))
(let
((c (gql-char-at src len pos)))
(cond
((= c "{")
(tok-loop (+ pos 1) (append acc (list {:pos pos :value "{" :type "brace-open"}))))
((= c "}")
(tok-loop (+ pos 1) (append acc (list {:pos pos :value "}" :type "brace-close"}))))
((= c "(")
(tok-loop (+ pos 1) (append acc (list {:pos pos :value "(" :type "paren-open"}))))
((= c ")")
(tok-loop (+ pos 1) (append acc (list {:pos pos :value ")" :type "paren-close"}))))
((= c "[")
(tok-loop (+ pos 1) (append acc (list {:pos pos :value "[" :type "bracket-open"}))))
((= c "]")
(tok-loop (+ pos 1) (append acc (list {:pos pos :value "]" :type "bracket-close"}))))
((= c ":")
(tok-loop (+ pos 1) (append acc (list {:pos pos :value ":" :type "colon"}))))
((= c "!")
(tok-loop (+ pos 1) (append acc (list {:pos pos :value "!" :type "bang"}))))
((= c "$")
(tok-loop (+ pos 1) (append acc (list {:pos pos :value "$" :type "dollar"}))))
((= c "@")
(tok-loop (+ pos 1) (append acc (list {:pos pos :value "@" :type "at"}))))
((= c "=")
(tok-loop (+ pos 1) (append acc (list {:pos pos :value "=" :type "equals"}))))
((= c "|")
(tok-loop (+ pos 1) (append acc (list {:pos pos :value "|" :type "pipe"}))))
((and (= c ".") (< (+ pos 2) len) (= (gql-char-at src len (+ pos 1)) ".") (= (gql-char-at src len (+ pos 2)) "."))
(tok-loop (+ pos 3) (append acc (list {:pos pos :value "..." :type "spread"}))))
((= c "\"")
(let
((r (gql-read-string src len pos)))
(tok-loop (get r :pos) (append acc (list {:pos pos :value (get r :value) :type "string"})))))
((or (gql-digit? c) (and (= c "-") (< (+ pos 1) len) (gql-digit? (gql-char-at src len (+ pos 1)))))
(let
((r (gql-read-number src len pos)))
(tok-loop (get r :pos) (append acc (list {:pos pos :value (get r :value) :type "number"})))))
((gql-name-start? c)
(let
((r (gql-read-name src len pos)))
(tok-loop (get r :pos) (append acc (list {:pos pos :value (get r :value) :type "name"})))))
(true (tok-loop (+ pos 1) acc))))))))
(tok-loop 0 (list)))))
;; ── Parser ────────────────────────────────────────────────────────
(define
gql-parse-tokens
(fn
(tokens)
(let
((p 0) (tlen (length tokens)))
(define cur (fn () (if (< p tlen) (nth tokens p) {:value nil :type "eof"})))
(define cur-type (fn () (get (cur) :type)))
(define cur-val (fn () (get (cur) :value)))
(define adv! (fn () (set! p (+ p 1))))
(define at-end? (fn () (= (cur-type) "eof")))
(define
expect!
(fn
(type)
(if
(= (cur-type) type)
(let ((v (cur-val))) (adv!) v)
(error
(str "GraphQL parse error: expected " type " got " (cur-type))))))
(define expect-name! (fn () (expect! "name")))
(define
parse-value
(fn
()
(let
((typ (cur-type)) (val (cur-val)))
(cond
((= typ "dollar")
(do (adv!) (list (quote gql-var) (expect-name!))))
((= typ "number") (do (adv!) val))
((= typ "string") (do (adv!) val))
((and (= typ "name") (= val "true")) (do (adv!) true))
((and (= typ "name") (= val "false")) (do (adv!) false))
((and (= typ "name") (= val "null")) (do (adv!) nil))
((= typ "bracket-open") (parse-list-value))
((= typ "brace-open") (parse-object-value))
((= typ "name") (do (adv!) val))
(true
(error
(str "GraphQL parse error: unexpected " typ " in value")))))))
(define
parse-list-value
(fn
()
(do
(expect! "bracket-open")
(define
collect
(fn
(acc)
(if
(or (at-end?) (= (cur-type) "bracket-close"))
(do (expect! "bracket-close") acc)
(collect (append acc (list (parse-value)))))))
(collect (list)))))
(define
parse-object-value
(fn
()
(do
(expect! "brace-open")
(define
collect
(fn
(acc)
(if
(or (at-end?) (= (cur-type) "brace-close"))
(do (expect! "brace-close") acc)
(let
((k (expect-name!)))
(expect! "colon")
(let
((v (parse-value)))
(collect (assoc acc (make-keyword k) v)))))))
(collect {}))))
(define
parse-arguments
(fn
()
(if
(not (= (cur-type) "paren-open"))
(list)
(do
(adv!)
(define
collect
(fn
(acc)
(if
(or (at-end?) (= (cur-type) "paren-close"))
(do (adv!) acc)
(let
((name (expect-name!)))
(expect! "colon")
(let
((val (parse-value)))
(collect (append acc (list (list name val)))))))))
(collect (list))))))
(define
parse-directives
(fn
()
(define
collect
(fn
(acc)
(if
(and (= (cur-type) "at") (not (at-end?)))
(do
(adv!)
(let
((name (expect-name!)) (args (parse-arguments)))
(collect
(append
acc
(list (list (quote gql-directive) name args))))))
acc)))
(collect (list))))
(define
parse-type
(fn
()
(let
((base (cond ((= (cur-type) "bracket-open") (do (adv!) (let ((inner (parse-type))) (expect! "bracket-close") (list (quote gql-list-type) inner)))) (true (list (quote gql-type) (expect-name!))))))
(if
(= (cur-type) "bang")
(do (adv!) (list (quote gql-non-null) base))
base))))
(define
parse-variable-defs
(fn
()
(if
(not (= (cur-type) "paren-open"))
(list)
(do
(adv!)
(define
collect
(fn
(acc)
(if
(or (at-end?) (= (cur-type) "paren-close"))
(do (adv!) acc)
(do
(expect! "dollar")
(let
((name (expect-name!)))
(expect! "colon")
(let
((typ (parse-type))
(default
(if
(= (cur-type) "equals")
(do (adv!) (parse-value))
nil)))
(collect
(append
acc
(list
(list (quote gql-var-def) name typ default))))))))))
(collect (list))))))
(define
parse-selection-set
(fn
()
(if
(not (= (cur-type) "brace-open"))
(list)
(do
(adv!)
(define
collect
(fn
(acc)
(if
(or (at-end?) (= (cur-type) "brace-close"))
(do (adv!) acc)
(collect (append acc (list (parse-selection)))))))
(collect (list))))))
(define
parse-selection
(fn
()
(cond
((= (cur-type) "spread")
(do
(adv!)
(if
(and (= (cur-type) "name") (not (= (cur-val) "on")))
(let
((name (expect-name!)) (dirs (parse-directives)))
(list (quote gql-fragment-spread) name dirs))
(let
((on-type (if (and (= (cur-type) "name") (= (cur-val) "on")) (do (adv!) (expect-name!)) nil))
(dirs (parse-directives))
(sels (parse-selection-set)))
(list (quote gql-inline-fragment) on-type dirs sels)))))
(true (parse-field)))))
(define
parse-field
(fn
()
(let
((name1 (expect-name!)))
(let
((actual-name (if (= (cur-type) "colon") (do (adv!) (expect-name!)) nil))
(alias (if actual-name name1 nil))
(field-name (if actual-name actual-name name1)))
(let
((args (parse-arguments))
(dirs (parse-directives))
(sels (parse-selection-set)))
(if
alias
(list (quote gql-field) field-name args dirs sels alias)
(list (quote gql-field) field-name args dirs sels)))))))
(define
parse-operation
(fn
(op-type)
(let
((name (if (and (= (cur-type) "name") (not (= (cur-val) "query")) (not (= (cur-val) "mutation")) (not (= (cur-val) "subscription")) (not (= (cur-val) "fragment"))) (expect-name!) nil))
(vars (parse-variable-defs))
(dirs (parse-directives))
(sels (parse-selection-set)))
(list op-type name vars dirs sels))))
(define
parse-fragment-def
(fn
()
(let
((name (expect-name!)))
(when (and (= (cur-type) "name") (= (cur-val) "on")) (adv!))
(let
((on-type (expect-name!))
(dirs (parse-directives))
(sels (parse-selection-set)))
(list (quote gql-fragment) name on-type dirs sels)))))
(define
parse-definition
(fn
()
(let
((typ (cur-type)) (val (cur-val)))
(cond
((= typ "brace-open")
(let
((sels (parse-selection-set)))
(list (quote gql-query) nil (list) (list) sels)))
((and (= typ "name") (= val "query"))
(do (adv!) (parse-operation (quote gql-query))))
((and (= typ "name") (= val "mutation"))
(do (adv!) (parse-operation (quote gql-mutation))))
((and (= typ "name") (= val "subscription"))
(do (adv!) (parse-operation (quote gql-subscription))))
((and (= typ "name") (= val "fragment"))
(do (adv!) (parse-fragment-def)))
(true
(error
(str
"GraphQL parse error: unexpected "
typ
" "
(if val val ""))))))))
(define
parse-document
(fn
()
(define
collect
(fn
(acc)
(if
(at-end?)
(cons (quote gql-doc) acc)
(collect (append acc (list (parse-definition)))))))
(collect (list))))
(parse-document))))
;; ── Convenience: source → AST ─────────────────────────────────────
(define gql-parse (fn (source) (gql-parse-tokens (gql-tokenize source))))
;; ── AST accessors ─────────────────────────────────────────────────
(define gql-node-type (fn (node) (if (list? node) (first node) nil)))
(define gql-doc? (fn (node) (= (gql-node-type node) (quote gql-doc))))
(define gql-query? (fn (node) (= (gql-node-type node) (quote gql-query))))
(define
gql-mutation?
(fn (node) (= (gql-node-type node) (quote gql-mutation))))
(define
gql-subscription?
(fn (node) (= (gql-node-type node) (quote gql-subscription))))
(define gql-field? (fn (node) (= (gql-node-type node) (quote gql-field))))
(define
gql-fragment?
(fn (node) (= (gql-node-type node) (quote gql-fragment))))
(define
gql-fragment-spread?
(fn (node) (= (gql-node-type node) (quote gql-fragment-spread))))
(define gql-var? (fn (node) (= (gql-node-type node) (quote gql-var))))
;; Field accessors: (gql-field name args directives selections [alias])
(define gql-field-name (fn (f) (nth f 1)))
(define gql-field-args (fn (f) (nth f 2)))
(define gql-field-directives (fn (f) (nth f 3)))
(define gql-field-selections (fn (f) (nth f 4)))
(define gql-field-alias (fn (f) (if (> (length f) 5) (nth f 5) nil)))
;; Operation accessors: (gql-query/mutation/subscription name vars directives selections)
(define gql-op-name (fn (op) (nth op 1)))
(define gql-op-vars (fn (op) (nth op 2)))
(define gql-op-directives (fn (op) (nth op 3)))
(define gql-op-selections (fn (op) (nth op 4)))
;; Fragment accessors: (gql-fragment name on-type directives selections)
(define gql-frag-name (fn (f) (nth f 1)))
(define gql-frag-type (fn (f) (nth f 2)))
(define gql-frag-directives (fn (f) (nth f 3)))
(define gql-frag-selections (fn (f) (nth f 4)))
;; Document: (gql-doc def1 def2 ...)
(define gql-doc-definitions (fn (doc) (rest doc)))
;; ── Serializer: AST → GraphQL source ─────────────────────────────
(define
serialize-selection-set
(fn (sels) (str "{ " (join " " (map gql-serialize sels)) " }")))
(define
serialize-args
(fn
(args)
(str
"("
(join
", "
(map
(fn (a) (str (first a) ": " (gql-serialize (nth a 1))))
args))
")")))
(define
serialize-var-defs
(fn
(vars)
(str
"("
(join
", "
(map
(fn
(v)
(let
((name (nth v 1))
(typ (serialize-type (nth v 2)))
(default (nth v 3)))
(str
"$"
name
": "
typ
(if default (str " = " (gql-serialize default)) ""))))
vars))
")")))
(define
serialize-type
(fn
(t)
(let
((typ (first t)))
(cond
((= typ (quote gql-type)) (nth t 1))
((= typ (quote gql-list-type))
(str "[" (serialize-type (nth t 1)) "]"))
((= typ (quote gql-non-null))
(str (serialize-type (nth t 1)) "!"))
(true "Unknown")))))
(define
gql-serialize
(fn
(node)
(cond
((not (list? node))
(cond
((string? node) (str "\"" node "\""))
((number? node) (str node))
((= node true) "true")
((= node false) "false")
((nil? node) "null")
(true (str node))))
(true
(let
((typ (gql-node-type node)))
(cond
((= typ (quote gql-doc))
(join "\n\n" (map gql-serialize (gql-doc-definitions node))))
((or (= typ (quote gql-query)) (= typ (quote gql-mutation)) (= typ (quote gql-subscription)))
(let
((op-word (cond ((= typ (quote gql-query)) "query") ((= typ (quote gql-mutation)) "mutation") ((= typ (quote gql-subscription)) "subscription")))
(name (gql-op-name node))
(vars (gql-op-vars node))
(sels (gql-op-selections node)))
(str
op-word
(if name (str " " name) "")
(if (> (length vars) 0) (serialize-var-defs vars) "")
" "
(serialize-selection-set sels))))
((= typ (quote gql-field))
(let
((name (gql-field-name node))
(alias (gql-field-alias node))
(args (gql-field-args node))
(sels (gql-field-selections node)))
(str
(if alias (str alias ": ") "")
name
(if (> (length args) 0) (serialize-args args) "")
(if
(> (length sels) 0)
(str " " (serialize-selection-set sels))
""))))
((= typ (quote gql-fragment))
(str
"fragment "
(gql-frag-name node)
" on "
(gql-frag-type node)
" "
(serialize-selection-set (gql-frag-selections node))))
((= typ (quote gql-fragment-spread)) (str "..." (nth node 1)))
((= typ (quote gql-var)) (str "$" (nth node 1)))
(true "")))))))