;; lib/scheme/tests/records.sx — define-record-type.

(define scm-rec-pass 0)
(define scm-rec-fail 0)
(define scm-rec-fails (list))

(define
  scm-rec-test
  (fn
    (name actual expected)
    (if
      (= actual expected)
      (set! scm-rec-pass (+ scm-rec-pass 1))
      (begin
        (set! scm-rec-fail (+ scm-rec-fail 1))
        (append! scm-rec-fails {:name name :actual actual :expected expected})))))

(define
  scm-rec
  (fn (src) (scheme-eval (scheme-parse src) (scheme-standard-env))))

(define
  scm-rec-all
  (fn
    (src)
    (scheme-eval-program (scheme-parse-all src) (scheme-standard-env))))

;; ── Basic record: point ─────────────────────────────────────────

(scm-rec-test
  "point: constructor + predicate"
  (scm-rec-all
    "(define-record-type point\n       (make-point x y) point?\n       (x point-x) (y point-y))\n     (point? (make-point 3 4))")
  true)
(scm-rec-test
  "point: accessor x"
  (scm-rec-all
    "(define-record-type point\n       (make-point x y) point?\n       (x point-x) (y point-y))\n     (point-x (make-point 3 4))")
  3)
(scm-rec-test
  "point: accessor y"
  (scm-rec-all
    "(define-record-type point\n       (make-point x y) point?\n       (x point-x) (y point-y))\n     (point-y (make-point 3 4))")
  4)
(scm-rec-test
  "point: predicate false on number"
  (scm-rec-all
    "(define-record-type point\n       (make-point x y) point?\n       (x point-x) (y point-y))\n     (point? 42)")
  false)

;; ── Mutator ─────────────────────────────────────────────────────

(scm-rec-test
  "point: mutator"
  (scm-rec-all
    "(define-record-type point\n       (make-point x y) point?\n       (x point-x) (y point-y set-point-y!))\n     (define p (make-point 3 4))\n     (set-point-y! p 99)\n     (point-y p)")
  99)

;; ── Multiple record types are distinct ──────────────────────────

(scm-rec-test
  "distinct types: point? false on circle"
  (scm-rec-all
    "(define-record-type point\n       (make-point x y) point? (x point-x) (y point-y))\n     (define-record-type circle\n       (make-circle r) circle? (r circle-r))\n     (point? (make-circle 5))")
  false)
(scm-rec-test
  "distinct types: circle? true on circle"
  (scm-rec-all
    "(define-record-type point\n       (make-point x y) point? (x point-x) (y point-y))\n     (define-record-type circle\n       (make-circle r) circle? (r circle-r))\n     (circle? (make-circle 5))")
  true)

;; ── Records as first-class values ───────────────────────────────

(scm-rec-test
  "record in a list"
  (scm-rec-all
    "(define-record-type box\n       (make-box v) box? (v box-v))\n     (map box-v (list (make-box 1) (make-box 2) (make-box 3)))")
  (list 1 2 3))

;; ── Records via map/filter ──────────────────────────────────────

(scm-rec-test
  "filter records by predicate"
  (scm-rec-all
    "(define-record-type box\n       (make-box v) box? (v box-v))\n     (length\n       (filter (lambda (b) (> (box-v b) 5))\n               (list (make-box 1) (make-box 7) (make-box 3) (make-box 10)))))")
  2)

;; ── Constructor arity errors ────────────────────────────────────

(scm-rec-test
  "ctor: wrong arity errors"
  (scm-rec-all
    "(define-record-type point (make-point x y) point? (x point-x) (y point-y))\n     (guard (e (else 'arity-err)) (make-point 1))")
  "arity-err")

(define scm-rec-tests-run! (fn () {:total (+ scm-rec-pass scm-rec-fail) :passed scm-rec-pass :failed scm-rec-fail :fails scm-rec-fails}))