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