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>
This commit is contained in:
219
lib/graphql-exec.sx
Normal file
219
lib/graphql-exec.sx
Normal file
@@ -0,0 +1,219 @@
|
||||
|
||||
;; GraphQL executor — walks parsed AST, dispatches via IO suspension
|
||||
;;
|
||||
;; Maps GraphQL operations to the defquery/defaction system:
|
||||
;; query → (perform (list 'io-gql-resolve "gql-query" field-name args))
|
||||
;; mutation → (perform (list 'io-gql-resolve "gql-mutation" field-name args))
|
||||
;;
|
||||
;; Field selection projects results to only requested fields.
|
||||
;; Fragments are resolved by name lookup in the document.
|
||||
;; Variables are substituted from a provided bindings dict.
|
||||
;;
|
||||
;; Usage:
|
||||
;; (gql-execute (gql-parse "{ posts { title } }"))
|
||||
;; (gql-execute (gql-parse "query($id: ID!) { post(id: $id) { title } }") {:id 42})
|
||||
;; (gql-execute ast variables resolver) ;; custom resolver
|
||||
|
||||
;; ── Variable substitution ─────────────────────────────────────────
|
||||
|
||||
(define
|
||||
gql-substitute-vars
|
||||
(fn
|
||||
(value vars)
|
||||
"Recursively replace (gql-var name) nodes with values from vars dict."
|
||||
(cond
|
||||
((not (list? value)) value)
|
||||
((= (first value) (quote gql-var))
|
||||
(let
|
||||
((name (nth value 1)))
|
||||
(let
|
||||
((kw (make-keyword name)))
|
||||
(if
|
||||
(has-key? vars kw)
|
||||
(get vars kw)
|
||||
(error (str "GraphQL: undefined variable $" name))))))
|
||||
(true (map (fn (child) (gql-substitute-vars child vars)) value)))))
|
||||
|
||||
;; ── Fragment collection ───────────────────────────────────────────
|
||||
|
||||
(define
|
||||
gql-collect-fragments
|
||||
(fn
|
||||
(doc)
|
||||
"Build a dict of fragment-name → fragment-definition from a gql-doc."
|
||||
(reduce
|
||||
(fn
|
||||
(acc def)
|
||||
(if
|
||||
(and (list? def) (= (first def) (quote gql-fragment)))
|
||||
(assoc acc (make-keyword (nth def 1)) def)
|
||||
acc))
|
||||
{}
|
||||
(rest doc))))
|
||||
|
||||
;; ── Field selection (projection) ──────────────────────────────────
|
||||
|
||||
(define
|
||||
gql-project
|
||||
(fn
|
||||
(data selections fragments)
|
||||
"Project a result dict/list down to only the requested fields."
|
||||
(cond
|
||||
((nil? data) nil)
|
||||
((and (list? data) (not (dict? data)))
|
||||
(map (fn (item) (gql-project item selections fragments)) data))
|
||||
((dict? data)
|
||||
(if
|
||||
(= (length selections) 0)
|
||||
data
|
||||
(reduce
|
||||
(fn
|
||||
(acc sel)
|
||||
(cond
|
||||
((and (list? sel) (= (first sel) (quote gql-field)))
|
||||
(let
|
||||
((name (nth sel 1))
|
||||
(sub-sels (nth sel 4))
|
||||
(alias (if (> (length sel) 5) (nth sel 5) nil))
|
||||
(out-key (make-keyword (if alias alias name))))
|
||||
(let
|
||||
((field-val (get data (make-keyword name))))
|
||||
(if
|
||||
(> (length sub-sels) 0)
|
||||
(assoc
|
||||
acc
|
||||
out-key
|
||||
(gql-project field-val sub-sels fragments))
|
||||
(assoc acc out-key field-val)))))
|
||||
((and (list? sel) (= (first sel) (quote gql-fragment-spread)))
|
||||
(let
|
||||
((frag-name (nth sel 1))
|
||||
(frag (get fragments (make-keyword frag-name))))
|
||||
(if
|
||||
frag
|
||||
(let
|
||||
((frag-sels (nth frag 4)))
|
||||
(let
|
||||
((projected (gql-project data frag-sels fragments)))
|
||||
(reduce
|
||||
(fn (a k) (assoc a k (get projected k)))
|
||||
acc
|
||||
(keys projected))))
|
||||
acc)))
|
||||
((and (list? sel) (= (first sel) (quote gql-inline-fragment)))
|
||||
(let
|
||||
((sub-sels (nth sel 3)))
|
||||
(let
|
||||
((projected (gql-project data sub-sels fragments)))
|
||||
(reduce
|
||||
(fn (a k) (assoc a k (get projected k)))
|
||||
acc
|
||||
(keys projected)))))
|
||||
(true acc)))
|
||||
{}
|
||||
selections)))
|
||||
(true data))))
|
||||
|
||||
;; ── Default resolver ──────────────────────────────────────────────
|
||||
;; Dispatches root fields via IO suspension to the query/action registry.
|
||||
;; Platform provides io-gql-resolve handler.
|
||||
|
||||
(define
|
||||
gql-default-resolve
|
||||
(fn
|
||||
(field-name args op-type)
|
||||
"Default resolver: dispatches via perform to the platform's IO handler."
|
||||
(perform (list (quote io-gql-resolve) op-type field-name args))))
|
||||
|
||||
;; ── Execute a single operation ────────────────────────────────────
|
||||
|
||||
(define
|
||||
gql-execute-operation
|
||||
(fn
|
||||
(op vars fragments resolve-fn)
|
||||
"Execute one operation (query/mutation/subscription), return result dict."
|
||||
(let
|
||||
((op-type (first op))
|
||||
(selections (nth op 4))
|
||||
(substituted (gql-substitute-vars selections vars)))
|
||||
(let
|
||||
((result (reduce (fn (acc sel) (cond ((and (list? sel) (= (first sel) (quote gql-field))) (let ((name (nth sel 1)) (args-raw (nth sel 2)) (sub-sels (nth sel 4)) (alias (if (> (length sel) 5) (nth sel 5) nil)) (out-key (make-keyword (if alias alias name)))) (let ((args (map (fn (a) (list (first a) (gql-substitute-vars (nth a 1) vars))) args-raw))) (let ((args-dict (reduce (fn (d a) (assoc d (make-keyword (first a)) (nth a 1))) {} args))) (let ((raw (resolve-fn name args-dict op-type))) (if (> (length sub-sels) 0) (assoc acc out-key (gql-project raw sub-sels fragments)) (assoc acc out-key raw))))))) ((and (list? sel) (= (first sel) (quote gql-fragment-spread))) (let ((frag (get fragments (make-keyword (nth sel 1))))) (if frag (let ((merged (gql-execute-operation (list op-type nil (list) (list) (nth frag 4)) vars fragments resolve-fn))) (reduce (fn (a k) (assoc a k (get merged k))) acc (keys merged))) acc))) (true acc))) {} substituted)))
|
||||
result))))
|
||||
|
||||
;; ── Main entry point ──────────────────────────────────────────────
|
||||
|
||||
(define
|
||||
gql-execute
|
||||
(fn
|
||||
(doc &rest extra-args)
|
||||
"Execute a parsed GraphQL document.\n (gql-execute doc)\n (gql-execute doc variables)\n (gql-execute doc variables resolver-fn)\n Returns {:data result} or {:data result :errors errors}."
|
||||
(let
|
||||
((vars (if (> (length extra-args) 0) (first extra-args) {}))
|
||||
(resolve-fn
|
||||
(if
|
||||
(> (length extra-args) 1)
|
||||
(nth extra-args 1)
|
||||
gql-default-resolve))
|
||||
(fragments (gql-collect-fragments doc))
|
||||
(definitions (rest doc)))
|
||||
(let
|
||||
((ops (filter (fn (d) (and (list? d) (let ((t (first d))) (or (= t (quote gql-query)) (= t (quote gql-mutation)) (= t (quote gql-subscription)))))) definitions)))
|
||||
(if
|
||||
(= (length ops) 0)
|
||||
{:errors (list "No operation found in document") :data nil}
|
||||
(let
|
||||
((result (gql-execute-operation (first ops) vars fragments resolve-fn)))
|
||||
{:data result}))))))
|
||||
|
||||
;; ── Execute with named operation ──────────────────────────────────
|
||||
|
||||
(define
|
||||
gql-execute-named
|
||||
(fn
|
||||
(doc operation-name vars &rest extra-args)
|
||||
"Execute a specific named operation from a multi-operation document."
|
||||
(let
|
||||
((resolve-fn (if (> (length extra-args) 0) (first extra-args) gql-default-resolve))
|
||||
(fragments (gql-collect-fragments doc))
|
||||
(definitions (rest doc)))
|
||||
(let
|
||||
((op (first (filter (fn (d) (and (list? d) (> (length d) 1) (= (nth d 1) operation-name))) definitions))))
|
||||
(if
|
||||
(nil? op)
|
||||
{:errors (list (str "Operation '" operation-name "' not found")) :data nil}
|
||||
(let
|
||||
((result (gql-execute-operation op vars fragments resolve-fn)))
|
||||
{:data result}))))))
|
||||
|
||||
;; ── Introspection helpers ─────────────────────────────────────────
|
||||
|
||||
(define
|
||||
gql-operation-names
|
||||
(fn
|
||||
(doc)
|
||||
"List all operation names in a document."
|
||||
(filter
|
||||
(fn (x) (not (nil? x)))
|
||||
(map
|
||||
(fn (d) (if (and (list? d) (> (length d) 1)) (nth d 1) nil))
|
||||
(filter
|
||||
(fn
|
||||
(d)
|
||||
(and
|
||||
(list? d)
|
||||
(let
|
||||
((t (first d)))
|
||||
(or
|
||||
(= t (quote gql-query))
|
||||
(= t (quote gql-mutation))
|
||||
(= t (quote gql-subscription))))))
|
||||
(rest doc))))))
|
||||
|
||||
(define
|
||||
gql-extract-variables
|
||||
(fn
|
||||
(doc)
|
||||
"Extract variable definitions from the first operation."
|
||||
(let
|
||||
((ops (filter (fn (d) (and (list? d) (let ((t (first d))) (or (= t (quote gql-query)) (= t (quote gql-mutation)) (= t (quote gql-subscription)))))) (rest doc))))
|
||||
(if (> (length ops) 0) (nth (first ops) 2) (list)))))
|
||||
686
lib/graphql.sx
Normal file
686
lib/graphql.sx
Normal file
@@ -0,0 +1,686 @@
|
||||
|
||||
;; 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 "")))))))
|
||||
Reference in New Issue
Block a user