
(import (oop goops)
        (th-scheme-utilities hrecord))


(define (do-report-test x-expr x-result x-correct)
  (write x-expr)
  (display " = ")
  (write x-result)
  (display "  ")
  (if (equal? x-result x-correct)
   	(display "OK\n")
   	(display "FAIL\n")))


(define-syntax report-test
  (syntax-rules ()
    ((_ test x-correct)
     (do-report-test (quote test) test x-correct))))


(define-hrecord-type <widget> () i-x i-y i-width i-height)

(define-hrecord-type <label> (<widget>) str-label)


(define (main args)
  (let ((widget (make-hrecord <widget> 10 10 200 100))
        (label (make-hrecord <label> 0 0 50 20 "Hello"))
        (pred1 (get-hrecord-type-predicate0 <widget>))
        (pred2 (get-hrecord-type-predicate <label>)))
    (report-test (hrecord? widget) #t)
    (report-test (hrecord? label) #t)
    (report-test (hrecord? #t) #f)
    (report-test (hrecord-type-get-name <widget>) '<widget>)
    (report-test (hrecord-type-get-field-count <label>) 5)
    (report-test (hrecord-type-get-fields <label>) '(str-label))
    (report-test (hrecord-type-get-all-fields <label>)
                 '(i-x i-y i-width i-height str-label))
    (report-test (%get-field-index label 'str-label) 4)
    (report-test (hfield-ref widget 'i-width) 200)
    (report-test (hfield-ref label 'str-label) "Hello")
    (hfield-set! widget 'i-height 150)
    (report-test (hfield-ref widget 'i-height) 150)
    (hfield-set! label 'str-label "Bye")
    (report-test (hfield-ref label 'str-label) "Bye")
    (report-test (hrecord-type-of widget) <widget>)
    (report-test (hrecord=? widget label) #f)
    (report-test (hrecord=? widget widget) #t)
    (report-test (hrecord-is-direct-instance? label <label>) #t)
    (report-test (hrecord-is-direct-instance? label <widget>) #f)
    (report-test (hrecord-is-instance? label <widget>) #t)
    (report-test (hrecord-is-instance? widget <label>) #f)
    (report-test (hrecord-type-is-subtype? <label> <widget>) #t)
    (report-test (hrecord-type-is-subtype? <widget> <label>) #f)
    (report-test (hrecord-type-name-of widget) '<widget>)
    (report-test (hrecord-type-name-of label) '<label>)
    (report-test (pred1 widget) #t)
    (report-test (pred2 widget) #f)))

