rose-ash/lib/common-lisp/tests/programs/mop-trace.sx

;; mop-trace.sx — :before/:after method tracing with CLOS
;;
;; Classic CLOS pattern: instrument generic functions with :before and :after
;; qualifiers to print call/return traces without modifying the primary method.
;;
;; Depends on: lib/common-lisp/runtime.sx, lib/common-lisp/clos.sx

;; ── trace log (mutable accumulator) ───────────────────────────────────────

(define trace-log (list))

(define
  trace-push
  (fn (msg) (set! trace-log (append trace-log (list msg)))))

(define trace-clear (fn () (set! trace-log (list))))

;; ── domain classes ─────────────────────────────────────────────────────────

(clos-defclass "shape" (list "t") (list {:initform "white" :initarg ":color" :reader nil :writer nil :accessor nil :name "color"}))

(clos-defclass "circle" (list "shape") (list {:initform 1 :initarg ":radius" :reader nil :writer nil :accessor nil :name "radius"}))

(clos-defclass "rect" (list "shape") (list {:initform 1 :initarg ":width" :reader nil :writer nil :accessor nil :name "width"} {:initform 1 :initarg ":height" :reader nil :writer nil :accessor nil :name "height"}))

;; ── generic function: area ─────────────────────────────────────────────────

(clos-defgeneric "area" {})

;; primary methods
(clos-defmethod
  "area"
  (list)
  (list "circle")
  (fn
    (args next-fn)
    (let
      ((c (first args)))
      (let ((r (clos-slot-value c "radius"))) (* r r)))))

(clos-defmethod
  "area"
  (list)
  (list "rect")
  (fn
    (args next-fn)
    (let
      ((r (first args)))
      (* (clos-slot-value r "width") (clos-slot-value r "height")))))

;; :before tracing
(clos-defmethod
  "area"
  (list "before")
  (list "shape")
  (fn
    (args next-fn)
    (trace-push (str "BEFORE area(" (clos-class-of (first args)) ")"))))

;; :after tracing
(clos-defmethod
  "area"
  (list "after")
  (list "shape")
  (fn
    (args next-fn)
    (trace-push (str "AFTER area(" (clos-class-of (first args)) ")"))))

;; ── generic function: describe-shape ──────────────────────────────────────

(clos-defgeneric "describe-shape" {})

(clos-defmethod
  "describe-shape"
  (list)
  (list "shape")
  (fn
    (args next-fn)
    (let
      ((s (first args)))
      (str "shape[" (clos-slot-value s "color") "]"))))

(clos-defmethod
  "describe-shape"
  (list)
  (list "circle")
  (fn
    (args next-fn)
    (let
      ((c (first args)))
      (str
        "circle[r="
        (clos-slot-value c "radius")
        " "
        (clos-call-next-method next-fn)
        "]"))))

(clos-defmethod
  "describe-shape"
  (list)
  (list "rect")
  (fn
    (args next-fn)
    (let
      ((r (first args)))
      (str
        "rect["
        (clos-slot-value r "width")
        "x"
        (clos-slot-value r "height")
        " "
        (clos-call-next-method next-fn)
        "]"))))

;; :before on base shape (fires for all subclasses too)
(clos-defmethod
  "describe-shape"
  (list "before")
  (list "shape")
  (fn
    (args next-fn)
    (trace-push
      (str "BEFORE describe-shape(" (clos-class-of (first args)) ")"))))

;; ── tests ─────────────────────────────────────────────────────────────────

(define passed 0)
(define failed 0)
(define failures (list))

(define
  check
  (fn
    (label got expected)
    (if
      (= got expected)
      (set! passed (+ passed 1))
      (begin
        (set! failed (+ failed 1))
        (set!
          failures
          (append
            failures
            (list
              (str
                "FAIL ["
                label
                "]: got="
                (inspect got)
                " expected="
                (inspect expected)))))))))

;; ── area tests ────────────────────────────────────────────────────────────

;; circle area = r*r (no pi — integer arithmetic for predictability)
(let
  ((c (clos-make-instance "circle" ":radius" 5 ":color" "red")))
  (do
    (trace-clear)
    (check "circle area" (clos-call-generic "area" (list c)) 25)
    (check
      ":before fired for circle"
      (= (first trace-log) "BEFORE area(circle)")
      true)
    (check
      ":after fired for circle"
      (= (first (rest trace-log)) "AFTER area(circle)")
      true)
    (check "trace length 2" (len trace-log) 2)))

;; rect area = w*h
(let
  ((r (clos-make-instance "rect" ":width" 4 ":height" 6 ":color" "blue")))
  (do
    (trace-clear)
    (check "rect area" (clos-call-generic "area" (list r)) 24)
    (check
      ":before fired for rect"
      (= (first trace-log) "BEFORE area(rect)")
      true)
    (check
      ":after fired for rect"
      (= (first (rest trace-log)) "AFTER area(rect)")
      true)
    (check "trace length 2 (rect)" (len trace-log) 2)))

;; ── describe-shape tests ───────────────────────────────────────────────────

(let
  ((c (clos-make-instance "circle" ":radius" 3 ":color" "green")))
  (do
    (trace-clear)
    (check
      "circle describe"
      (clos-call-generic "describe-shape" (list c))
      "circle[r=3 shape[green]]")
    (check
      ":before fired for describe circle"
      (= (first trace-log) "BEFORE describe-shape(circle)")
      true)))

(let
  ((r (clos-make-instance "rect" ":width" 2 ":height" 7 ":color" "black")))
  (do
    (trace-clear)
    (check
      "rect describe"
      (clos-call-generic "describe-shape" (list r))
      "rect[2x7 shape[black]]")
    (check
      ":before fired for describe rect"
      (= (first trace-log) "BEFORE describe-shape(rect)")
      true)))

;; ── call-next-method: circle -> shape ─────────────────────────────────────

(let
  ((c (clos-make-instance "circle" ":radius" 1 ":color" "purple")))
  (check
    "call-next-method result in describe"
    (clos-call-generic "describe-shape" (list c))
    "circle[r=1 shape[purple]]"))

;; ── summary ────────────────────────────────────────────────────────────────

(define mop-passed passed)
(define mop-failed failed)
(define mop-failures failures)