;; lib/prolog/parser.sx — tokens → Prolog AST
;;
;; Phase 4 grammar (with operator table):
;;   Program      := Clause* EOF
;;   Clause       := Term[999] "." | Term[999] ":-" Term[1200] "."
;;   Term[Pmax] uses precedence climbing on the operator table:
;;     primary = Atom | Var | Number | String | Compound | List | "(" Term[1200] ")"
;;     while next token is infix op `op` with prec(op) ≤ Pmax:
;;       consume op; parse rhs at right-prec(op); fold into compound(op-name,[lhs,rhs])
;;
;; Op type → right-prec for op at precedence P:
;;   xfx → P-1   strict-both
;;   xfy → P     right-associative
;;   yfx → P-1   left-associative
;;
;; AST shapes are unchanged — operators just become compound terms.

(define
  pp-peek
  (fn
    (st)
    (let
      ((i (get st :idx)) (tokens (get st :tokens)))
      (if (< i (len tokens)) (nth tokens i) {:pos 0 :value nil :type "eof"}))))

(define pp-advance! (fn (st) (dict-set! st :idx (+ (get st :idx) 1))))

(define
  pp-at?
  (fn
    (st type value)
    (let
      ((t (pp-peek st)))
      (and
        (= (get t :type) type)
        (or (= value nil) (= (get t :value) value))))))

(define
  pp-expect!
  (fn
    (st type value)
    (let
      ((t (pp-peek st)))
      (if
        (pp-at? st type value)
        (do (pp-advance! st) t)
        (error
          (str
            "Parse error at pos "
            (get t :pos)
            ": expected "
            type
            " '"
            (if (= value nil) "" value)
            "' got "
            (get t :type)
            " '"
            (if (= (get t :value) nil) "" (get t :value))
            "'"))))))

(define pl-mk-atom (fn (name) (list "atom" name)))
(define pl-mk-var (fn (name) (list "var" name)))
(define pl-mk-num (fn (n) (list "num" n)))
(define pl-mk-str (fn (s) (list "str" s)))
(define pl-mk-compound (fn (f args) (list "compound" f args)))
(define pl-mk-cut (fn () (list "cut")))

(define pl-term-tag (fn (t) (if (list? t) (first t) nil)))
(define pl-term-val (fn (t) (nth t 1)))
(define pl-compound-functor (fn (t) (nth t 1)))
(define pl-compound-args (fn (t) (nth t 2)))

(define pl-nil-term (fn () (pl-mk-atom "[]")))
(define pl-mk-cons (fn (h t) (pl-mk-compound "." (list h t))))

(define
  pl-mk-list-term
  (fn
    (items tail)
    (if
      (= (len items) 0)
      tail
      (pl-mk-cons (first items) (pl-mk-list-term (rest items) tail)))))

;; ── Operator table (Phase 4) ──────────────────────────────────────
;; Each entry: (name precedence type). Type ∈ "xfx" "xfy" "yfx".
(define
  pl-op-table
  (list
    (list "," 1000 "xfy")
    (list ";" 1100 "xfy")
    (list "->" 1050 "xfy")
    (list "=" 700 "xfx")
    (list "\\=" 700 "xfx")
    (list "is" 700 "xfx")
    (list "<" 700 "xfx")
    (list ">" 700 "xfx")
    (list "=<" 700 "xfx")
    (list ">=" 700 "xfx")
    (list "+" 500 "yfx")
    (list "-" 500 "yfx")
    (list "*" 400 "yfx")
    (list "/" 400 "yfx")
    (list "mod" 400 "yfx")))

(define
  pl-op-find
  (fn
    (name table)
    (cond
      ((empty? table) nil)
      ((= (first (first table)) name) (rest (first table)))
      (true (pl-op-find name (rest table))))))

(define pl-op-lookup (fn (name) (pl-op-find name pl-op-table)))

;; Token → (name prec type) for known infix ops, else nil.
(define
  pl-token-op
  (fn
    (t)
    (let
      ((ty (get t :type)) (vv (get t :value)))
      (cond
        ((and (= ty "punct") (= vv ","))
          (let
            ((info (pl-op-lookup ",")))
            (if (nil? info) nil (cons "," info))))
        ((= ty "atom")
          (let
            ((info (pl-op-lookup vv)))
            (if (nil? info) nil (cons vv info))))
        (true nil)))))

;; ── Term parser ─────────────────────────────────────────────────────
;; Primary term: atom, var, num, str, compound (atom + paren), list, cut, parens.
(define
  pp-parse-primary
  (fn
    (st)
    (let
      ((t (pp-peek st)))
      (let
        ((ty (get t :type)) (vv (get t :value)))
        (cond
          ((= ty "number") (do (pp-advance! st) (pl-mk-num vv)))
          ((= ty "string") (do (pp-advance! st) (pl-mk-str vv)))
          ((= ty "var") (do (pp-advance! st) (pl-mk-var vv)))
          ((and (= ty "op") (= vv "!"))
            (do (pp-advance! st) (pl-mk-cut)))
          ((and (= ty "punct") (= vv "[")) (pp-parse-list st))
          ((and (= ty "punct") (= vv "("))
            (do
              (pp-advance! st)
              (let
                ((inner (pp-parse-term-prec st 1200)))
                (do (pp-expect! st "punct" ")") inner))))
          ((= ty "atom")
            (do
              (pp-advance! st)
              (if
                (pp-at? st "punct" "(")
                (do
                  (pp-advance! st)
                  (let
                    ((args (pp-parse-arg-list st)))
                    (do (pp-expect! st "punct" ")") (pl-mk-compound vv args))))
                (pl-mk-atom vv))))
          (else
            (error
              (str
                "Parse error at pos "
                (get t :pos)
                ": unexpected "
                ty
                " '"
                (if (= vv nil) "" vv)
                "'"))))))))

;; Operator-aware term parser: precedence climbing.
(define
  pp-parse-term-prec
  (fn
    (st max-prec)
    (let ((left (pp-parse-primary st))) (pp-parse-op-rhs st left max-prec))))

(define
  pp-parse-op-rhs
  (fn
    (st left max-prec)
    (let
      ((op-info (pl-token-op (pp-peek st))))
      (cond
        ((nil? op-info) left)
        (true
          (let
            ((name (first op-info))
              (prec (nth op-info 1))
              (ty (nth op-info 2)))
            (cond
              ((> prec max-prec) left)
              (true
                (let
                  ((right-prec (if (= ty "xfy") prec (- prec 1))))
                  (do
                    (pp-advance! st)
                    (let
                      ((right (pp-parse-term-prec st right-prec)))
                      (pp-parse-op-rhs
                        st
                        (pl-mk-compound name (list left right))
                        max-prec))))))))))))

;; Backwards-compat alias.
(define pp-parse-term (fn (st) (pp-parse-term-prec st 999)))

;; Args inside parens: parse at prec 999 so comma-as-operator (1000)
;; is not consumed; the explicit comma loop handles separation.
(define
  pp-parse-arg-list
  (fn
    (st)
    (let
      ((first-arg (pp-parse-term-prec st 999)) (args (list)))
      (do
        (append! args first-arg)
        (define
          loop
          (fn
            ()
            (when
              (pp-at? st "punct" ",")
              (do
                (pp-advance! st)
                (append! args (pp-parse-term-prec st 999))
                (loop)))))
        (loop)
        args))))

;; List literal.
(define
  pp-parse-list
  (fn
    (st)
    (do
      (pp-expect! st "punct" "[")
      (if
        (pp-at? st "punct" "]")
        (do (pp-advance! st) (pl-nil-term))
        (let
          ((items (list)))
          (do
            (append! items (pp-parse-term-prec st 999))
            (define
              comma-loop
              (fn
                ()
                (when
                  (pp-at? st "punct" ",")
                  (do
                    (pp-advance! st)
                    (append! items (pp-parse-term-prec st 999))
                    (comma-loop)))))
            (comma-loop)
            (let
              ((tail (if (pp-at? st "punct" "|") (do (pp-advance! st) (pp-parse-term-prec st 999)) (pl-nil-term))))
              (do (pp-expect! st "punct" "]") (pl-mk-list-term items tail)))))))))

;; ── Body parsing ────────────────────────────────────────────────────
;; A body is a single term parsed at prec 1200 — operator parser folds
;; `,`, `;`, `->` automatically into right-associative compounds.
(define pp-parse-body (fn (st) (pp-parse-term-prec st 1200)))

;; ── Clause parsing ──────────────────────────────────────────────────
(define
  pp-parse-clause
  (fn
    (st)
    (let
      ((head (pp-parse-term-prec st 999)))
      (let
        ((body (if (pp-at? st "op" ":-") (do (pp-advance! st) (pp-parse-body st)) (pl-mk-atom "true"))))
        (do (pp-expect! st "punct" ".") (list "clause" head body))))))

(define
  pl-parse-program
  (fn
    (tokens)
    (let
      ((st {:idx 0 :tokens tokens}) (clauses (list)))
      (do
        (define
          ploop
          (fn
            ()
            (when
              (not (pp-at? st "eof" nil))
              (do (append! clauses (pp-parse-clause st)) (ploop)))))
        (ploop)
        clauses))))

(define
  pl-parse-query
  (fn (tokens) (let ((st {:idx 0 :tokens tokens})) (pp-parse-body st))))

(define pl-parse (fn (src) (pl-parse-program (pl-tokenize src))))
(define pl-parse-goal (fn (src) (pl-parse-query (pl-tokenize src))))