;; lib/datalog/parser.sx — Datalog tokens → AST
;;
;; Output shapes:
;;   Literal (positive)  := (relname arg ... arg)        — SX list
;;   Literal (negative)  := {:neg (relname arg ... arg)} — dict
;;   Argument            := var-symbol | atom-symbol | number | string
;;                        | (op-name arg ... arg)        — arithmetic compound
;;   Fact                := {:head literal :body ()}
;;   Rule                := {:head literal :body (lit ... lit)}
;;   Query               := {:query (lit ... lit)}
;;   Program             := list of facts / rules / queries
;;
;; Variables and constants are both SX symbols; the evaluator dispatches
;; on first-char case ('A'..'Z' or '_' = variable, otherwise constant).
;;
;; The parser permits nested compounds in arg position to support
;; arithmetic (e.g. (is Z (+ X Y))). Safety analysis at rule-load time
;; rejects compounds whose head is not an arithmetic operator.

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

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

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

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

(define
  dl-pp-error
  (fn
    (st msg)
    (let
      ((t (dl-pp-peek st)))
      (error
        (str
          "Parse error at pos "
          (get t :pos)
          ": "
          msg
          " (got "
          (get t :type)
          " '"
          (if (= (get t :value) nil) "" (get t :value))
          "')")))))

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

;; Argument: variable, atom, number, string, or compound (relname/op + parens).
(define
  dl-pp-parse-arg
  (fn
    (st)
    (let
      ((t (dl-pp-peek st)))
      (let
        ((ty (get t :type)) (vv (get t :value)))
        (cond
          ((= ty "number") (do (dl-pp-advance! st) vv))
          ((= ty "string") (do (dl-pp-advance! st) vv))
          ((= ty "var") (do (dl-pp-advance! st) (string->symbol vv)))
          ((or (= ty "atom") (= ty "op"))
            (do
              (dl-pp-advance! st)
              (if
                (dl-pp-at? st "punct" "(")
                (do
                  (dl-pp-advance! st)
                  (let
                    ((args (dl-pp-parse-arg-list st)))
                    (do
                      (dl-pp-expect! st "punct" ")")
                      (cons (string->symbol vv) args))))
                (string->symbol vv))))
          (else (dl-pp-error st "expected term")))))))

;; Comma-separated args inside parens.
(define
  dl-pp-parse-arg-list
  (fn
    (st)
    (let
      ((args (list)))
      (do
        (append! args (dl-pp-parse-arg st))
        (define
          dl-pp-arg-loop
          (fn
            ()
            (when
              (dl-pp-at? st "punct" ",")
              (do
                (dl-pp-advance! st)
                (append! args (dl-pp-parse-arg st))
                (dl-pp-arg-loop)))))
        (dl-pp-arg-loop)
        args))))

;; A positive literal: relname (atom or op) followed by optional (args).
(define
  dl-pp-parse-positive
  (fn
    (st)
    (let
      ((t (dl-pp-peek st)))
      (let
        ((ty (get t :type)) (vv (get t :value)))
        (if
          (or (= ty "atom") (= ty "op"))
          (do
            (dl-pp-advance! st)
            (if
              (dl-pp-at? st "punct" "(")
              (do
                (dl-pp-advance! st)
                (let
                  ((args (dl-pp-parse-arg-list st)))
                  (do
                    (dl-pp-expect! st "punct" ")")
                    (cons (string->symbol vv) args))))
              (list (string->symbol vv))))
          (dl-pp-error st "expected literal head"))))))

;; A body literal: positive, or not(positive).
(define
  dl-pp-parse-body-lit
  (fn
    (st)
    (let
      ((t1 (dl-pp-peek st)) (t2 (dl-pp-peek2 st)))
      (if
        (and
          (= (get t1 :type) "atom")
          (= (get t1 :value) "not")
          (= (get t2 :type) "punct")
          (= (get t2 :value) "("))
        (do
          (dl-pp-advance! st)
          (dl-pp-advance! st)
          (let
            ((inner (dl-pp-parse-positive st)))
            (do (dl-pp-expect! st "punct" ")") {:neg inner})))
        (dl-pp-parse-positive st)))))

;; Comma-separated body literals.
(define
  dl-pp-parse-body
  (fn
    (st)
    (let
      ((lits (list)))
      (do
        (append! lits (dl-pp-parse-body-lit st))
        (define
          dl-pp-body-loop
          (fn
            ()
            (when
              (dl-pp-at? st "punct" ",")
              (do
                (dl-pp-advance! st)
                (append! lits (dl-pp-parse-body-lit st))
                (dl-pp-body-loop)))))
        (dl-pp-body-loop)
        lits))))

;; Single clause: fact, rule, or query. Consumes trailing dot.
(define
  dl-pp-parse-clause
  (fn
    (st)
    (cond
      ((dl-pp-at? st "op" "?-")
        (do
          (dl-pp-advance! st)
          (let
            ((body (dl-pp-parse-body st)))
            (do (dl-pp-expect! st "punct" ".") {:query body}))))
      (else
        (let
          ((head (dl-pp-parse-positive st)))
          (cond
            ((dl-pp-at? st "op" ":-")
              (do
                (dl-pp-advance! st)
                (let
                  ((body (dl-pp-parse-body st)))
                  (do (dl-pp-expect! st "punct" ".") {:body body :head head}))))
            (else (do (dl-pp-expect! st "punct" ".") {:body (list) :head head}))))))))

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

(define dl-parse (fn (src) (dl-parse-program (dl-tokenize src))))