(define-library (srfi 99 test)
  (export run-tests)
  (import (chibi)
          (srfi 99)
          (only (chibi test) test-begin test-assert test test-end))
  (begin
    (define (run-tests)
      (test-begin "srfi-99: records")

      (define-record-type organism
        (make-organism name)
        organism?
        (name name-of set-name-of!))

      ;; kingdom
      (define-record-type (animal organism)
        (make-animal name food)
        animal?
        ;; all animals eat
        (food food-of set-food-of!))

      ;; phylum
      (define-record-type (chordate animal)
        (make-chordate name food)
        chordate?)

      ;; class
      (define-record-type (mammal chordate)
        (make-mammal name food num-nipples)
        mammal?
        ;; all mammals have nipples
        (num-nipples num-nipples-of set-num-nipples-of!))

      ;; order
      (define-record-type (carnivore mammal)
        (make-carnivore name food num-nipples)
        carnivore?)

      (define-record-type (rodent mammal)
        (make-rodent name food num-nipples)
        rodent?)

      ;; family
      (define-record-type (felidae carnivore)
        (make-felidae name food num-nipples)
        felidae?)

      (define-record-type (muridae rodent)
        (make-muridae name food num-nipples)
        muridae?)

      ;; genus
      (define-record-type (felis felidae)
        (make-felis name food num-nipples)
        felis?)

      (define-record-type (mus muridae)
        (make-mus name food num-nipples)
        mus?)

      ;; species
      (define-record-type (cat felis)
        (make-cat name food num-nipples breed color)
        cat?
        (breed breed-of set-breed-of!)
        (color color-of set-color-of!))

      (define-record-type (mouse mus)
        (make-mouse name food num-nipples)
        mouse?)

      (define mickey (make-mouse "Mickey" "cheese" 10))
      (define felix (make-cat "Felix" mickey 8 'mixed '(and black white)))

      (test-assert (organism? mickey))
      (test-assert (animal? mickey))
      (test-assert (chordate? mickey))
      (test-assert (mammal? mickey))
      (test-assert (rodent? mickey))
      (test-assert (muridae? mickey))
      (test-assert (mus? mickey))
      (test-assert (mouse? mickey))

      (test-assert (not (carnivore? mickey)))
      (test-assert (not (felidae? mickey)))
      (test-assert (not (felis? mickey)))
      (test-assert (not (cat? mickey)))

      (test-assert (organism? felix))
      (test-assert (animal? felix))
      (test-assert (chordate? felix))
      (test-assert (mammal? felix))
      (test-assert (carnivore? felix))
      (test-assert (felidae? felix))
      (test-assert (felis? felix))
      (test-assert (cat? felix))

      (test-assert (not (rodent? felix)))
      (test-assert (not (muridae? felix)))
      (test-assert (not (mus? felix)))
      (test-assert (not (mouse? felix)))

      (test "Mickey" (name-of mickey))
      (test "cheese" (food-of mickey))
      (test 10 (num-nipples-of mickey))

      (test "Felix" (name-of felix))
      (test mickey (food-of felix))
      (test 8 (num-nipples-of felix))
      (test 'mixed (breed-of felix))
      (test '(and black white) (color-of felix))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

      (define-record-type person #t #t (name) (sex) (age))
      (define-record-type (employee person) #t #t (department) (salary))

      (define bob (make-employee "Bob" 'male 28 'hr 50000.0))
      (define alice (make-employee "Alice" 'female 32 'research 100000.0))

      (test-assert (person? bob))
      (test-assert (employee? bob))
      (test "Bob" (person-name bob))
      (test 'male (person-sex bob))
      (test 28 (person-age bob))
      (test 'hr (employee-department bob))
      (test 50000.0 (employee-salary bob))

      (test-assert (person? alice))
      (test-assert (employee? alice))
      (test "Alice" (person-name alice))
      (test 'female (person-sex alice))
      (test 32 (person-age alice))
      (test 'research (employee-department alice))
      (test 100000.0 (employee-salary alice))

      ;; After a trip to Thailand...
      (person-sex-set! bob 'female)
      (person-name-set! bob "Roberta")

      ;; Then Roberta quits!
      (employee-department-set! bob #f)
      (employee-salary-set! bob 0.0)

      (test "Roberta" (person-name bob))
      (test 'female (person-sex bob))
      (test 28 (person-age bob))
      (test #f (employee-department bob))
      (test 0.0 (employee-salary bob))

      ;; SRFI-99 forbids this, but we currently do it anyway.
      (test-assert (equal? (make-employee "Chuck" 'male 20 'janitorial 50000.0)
                           (make-employee "Chuck" 'male 20 'janitorial 50000.0)))

      (test-assert (record? alice))
      (test 'person (rtd-name person))
      (let* ((constructor (rtd-constructor person))
             (trent (constructor "Trent" 'male 44)))
        (test "Trent" (person-name trent))
        (test 'male (person-sex trent))
        (test 44 ((rtd-accessor person 'age) trent))
        ((rtd-mutator person 'age) trent 45)
        (test 45 (person-age trent)))

      (test-assert (rtd-field-mutable? employee 'department))

      ;; We do not retain mutability information ATM.
      ;; (define-record-type foo
      ;;   (make-foo x)
      ;;   foo?
      ;;   (x foo-x))
      ;;
      ;; (test-assert (not (rtd-field-mutable? foo 'x)))

      (define point (make-rtd "point" #(x y)))
      (define make-point (rtd-constructor point #(x y)))
      (define point-x (rtd-accessor point 'x))
      (test 3 (point-x (make-point 3 2)))

      ;; Name conflicts - make sure we rename 

      (define-record-type example make-example #t example)
      (test-assert (example? (make-example 3)))
      (test 3 (example-example (make-example 3)))

      ;; record types definitions with #f passed as either the constructor or
      ;; predicate argument should not create the corresponding function

      (define-record-type abstract
        #f #t)

      (test #f (memq 'make-abstract (env-exports (current-environment))))

      (define-record-type (derived abstract)
        #t #f)

      (define instance (make-derived))
      (test-assert (abstract? instance))
      (test #f (memq 'derived? (env-exports (current-environment))))

      (define-record-type container
        #t #t
        default-immutable
        (default-mutable)
        (named-immutable get-container-immutable)
        (named-mutable get-container-mutable set-container-mutable!))

      (define container-instance (make-container 1 2 3 4))

      (test 1 (container-default-immutable container-instance))
      (test 2 (container-default-mutable container-instance))
      (test 3 (get-container-immutable container-instance))
      (test 4 (get-container-mutable container-instance))

      (container-default-mutable-set! container-instance #t)
      (test #t (container-default-mutable container-instance))

      (set-container-mutable! container-instance #t)
      (test #t (get-container-mutable container-instance))

      (test-end))))