rose-ash/lib/common-lisp/tests/lambda.sx

;; Lambda list parser tests

(define cl-test-pass 0)
(define cl-test-fail 0)
(define cl-test-fails (list))

;; Deep structural equality for dicts and lists
(define
  cl-deep=
  (fn
    (a b)
    (cond
      ((= a b) true)
      ((and (dict? a) (dict? b))
        (let
          ((ak (keys a)) (bk (keys b)))
          (if
            (not (= (len ak) (len bk)))
            false
            (every?
              (fn (k) (and (has-key? b k) (cl-deep= (get a k) (get b k))))
              ak))))
      ((and (list? a) (list? b))
        (if
          (not (= (len a) (len b)))
          false
          (let
            ((i 0) (ok true))
            (define
              chk
              (fn
                ()
                (when
                  (and ok (< i (len a)))
                  (do
                    (when
                      (not (cl-deep= (nth a i) (nth b i)))
                      (set! ok false))
                    (set! i (+ i 1))
                    (chk)))))
            (chk)
            ok)))
      (:else false))))

(define
  cl-test
  (fn
    (name actual expected)
    (if
      (cl-deep= actual expected)
      (set! cl-test-pass (+ cl-test-pass 1))
      (do
        (set! cl-test-fail (+ cl-test-fail 1))
        (append! cl-test-fails {:name name :expected expected :actual actual})))))

;; Helper: parse lambda list from string "(x y ...)"
(define ll (fn (src) (cl-parse-lambda-list-str src)))
(define ll-req  (fn (src) (get (ll src) "required")))
(define ll-opt  (fn (src) (get (ll src) "optional")))
(define ll-rest (fn (src) (get (ll src) "rest")))
(define ll-key  (fn (src) (get (ll src) "key")))
(define ll-aok  (fn (src) (get (ll src) "allow-other-keys")))
(define ll-aux  (fn (src) (get (ll src) "aux")))

;; ── required parameters ───────────────────────────────────────────

(cl-test "required: empty" (ll-req "()") (list))
(cl-test "required: one" (ll-req "(x)") (list "X"))
(cl-test "required: two" (ll-req "(x y)") (list "X" "Y"))
(cl-test "required: three" (ll-req "(a b c)") (list "A" "B" "C"))
(cl-test "required: upcased" (ll-req "(foo bar)") (list "FOO" "BAR"))

;; ── &optional ─────────────────────────────────────────────────────

(cl-test "optional: none" (ll-opt "(x)") (list))

(cl-test
  "optional: bare symbol"
  (ll-opt "(x &optional z)")
  (list {:name "Z" :default nil :supplied nil}))

(cl-test
  "optional: with default"
  (ll-opt "(x &optional (z 0))")
  (list {:name "Z" :default 0 :supplied nil}))

(cl-test
  "optional: with supplied-p"
  (ll-opt "(x &optional (z 0 z-p))")
  (list {:name "Z" :default 0 :supplied "Z-P"}))

(cl-test
  "optional: two params"
  (ll-opt "(&optional a (b 1))")
  (list {:name "A" :default nil :supplied nil} {:name "B" :default 1 :supplied nil}))

(cl-test
  "optional: string default"
  (ll-opt "(&optional (name \"world\"))")
  (list {:name "NAME" :default {:cl-type "string" :value "world"} :supplied nil}))

;; ── &rest ─────────────────────────────────────────────────────────

(cl-test "rest: none" (ll-rest "(x)") nil)
(cl-test "rest: present" (ll-rest "(x &rest args)") "ARGS")
(cl-test "rest: with required" (ll-rest "(a b &rest tail)") "TAIL")

;; &body is an alias for &rest
(cl-test "body: alias for rest" (ll-rest "(&body forms)") "FORMS")

;; rest doesn't consume required params
(cl-test "rest: required still there" (ll-req "(a b &rest rest)") (list "A" "B"))

;; ── &key ──────────────────────────────────────────────────────────

(cl-test "key: none" (ll-key "(x)") (list))

(cl-test
  "key: bare symbol"
  (ll-key "(&key x)")
  (list {:name "X" :keyword "X" :default nil :supplied nil}))

(cl-test
  "key: with default"
  (ll-key "(&key (x 42))")
  (list {:name "X" :keyword "X" :default 42 :supplied nil}))

(cl-test
  "key: with supplied-p"
  (ll-key "(&key (x 42 x-p))")
  (list {:name "X" :keyword "X" :default 42 :supplied "X-P"}))

(cl-test
  "key: two params"
  (ll-key "(&key a b)")
  (list
    {:name "A" :keyword "A" :default nil :supplied nil}
    {:name "B" :keyword "B" :default nil :supplied nil}))

;; ── &allow-other-keys ─────────────────────────────────────────────

(cl-test "aok: absent" (ll-aok "(x)") false)
(cl-test "aok: present" (ll-aok "(&key x &allow-other-keys)") true)

;; ── &aux ──────────────────────────────────────────────────────────

(cl-test "aux: none" (ll-aux "(x)") (list))

(cl-test
  "aux: bare symbol"
  (ll-aux "(&aux temp)")
  (list {:name "TEMP" :init nil}))

(cl-test
  "aux: with init"
  (ll-aux "(&aux (count 0))")
  (list {:name "COUNT" :init 0}))

(cl-test
  "aux: two vars"
  (ll-aux "(&aux a (b 1))")
  (list {:name "A" :init nil} {:name "B" :init 1}))

;; ── combined ──────────────────────────────────────────────────────

(cl-test
  "combined: full lambda list"
  (let
    ((parsed (ll "(x y &optional (z 0 z-p) &rest args &key a (b nil b-p) &aux temp)")))
    (list
      (get parsed "required")
      (get (nth (get parsed "optional") 0) "name")
      (get (nth (get parsed "optional") 0) "default")
      (get (nth (get parsed "optional") 0) "supplied")
      (get parsed "rest")
      (get (nth (get parsed "key") 0) "name")
      (get (nth (get parsed "key") 1) "supplied")
      (get (nth (get parsed "aux") 0) "name")))
  (list
    (list "X" "Y")
    "Z"
    0
    "Z-P"
    "ARGS"
    "A"
    "B-P"
    "TEMP"))

(cl-test
  "combined: required only stops before &"
  (ll-req "(a b &optional c)")
  (list "A" "B"))

(cl-test
  "combined: required only with &key"
  (ll-req "(x &key y)")
  (list "X"))

(cl-test
  "combined: &rest and &key together"
  (let
    ((parsed (ll "(&rest args &key verbose)")))
    (list (get parsed "rest") (get (nth (get parsed "key") 0) "name")))
  (list "ARGS" "VERBOSE"))