era-test.ss
(module era-test mzscheme
  
  (require (lib "cut.ss" "srfi" "26"))
  
  (require (planet "hash-table.ss" ("untyped" "unlib.plt" 2)))
  
  (require (file "era.ss")
           (file "persistent-struct.ss")
           (file "test-base.ss")
           (file "test-data.ss")
           (file "type.ss"))
  
  (provide era-tests)
  
  ; Tests ----------------------------------------
  
  ; Test data:
  
  ;; unsaved : course
  ;; saved : course
  (define unsaved (make-course 'UNSAVED "Unsaved" 1 1.5 #f time1))
  (define saved   (make-course 'SAVED   "Saved"   2 2.5 #t time2))
  (set-id! saved 0)
  (set-revision! saved 1000)
  
  (define unsaved-alist
    `((id       . #f)
      (revision . #f)
      (code     . UNSAVED)
      (name     . "Unsaved")
      (value    . 1)
      (rating   . 1.5)
      (active   . #f)
      (start    . ,time1)))
  
  (define saved-alist
    `((id       . 0)
      (revision . 1000)
      (code     . SAVED)
      (name     . "Saved")
      (value    . 2)
      (rating   . 2.5)
      (active   . #t)
      (start    . ,time2)))
  
  ; TODO: 2007-10-10: Commented out for removal:
  ; (define unsaved-hash-table
  ;   (apply make-hash-table/pairs unsaved-alist))
  
  ; TODO: 2007-10-10: Commented out for removal:
  ; (define saved-hash-table
  ;   (apply make-hash-table/pairs saved-alist))
  
  ;; syntax update-store! : (list-of (list-of any)) any ...
  ;;
  ;; Uesd in tests for for-each/entity and for-each/struct to
  ;; record the data passed to the iterated function... see these
  ;; tests for more information.
  (define-syntax (store-mutator stx)
    (syntax-case stx ()
      [(_ store)
       #'(lambda args
           (set! store `(,@store ,args)))]))
  
  (define era-tests
    (test-suite
     "era.ss"
     
     (test-case
      "get-id returns correct id"
      (check-equal? (get-id unsaved) #f)
      (check-equal? (get-id saved) 0))
     
     (test-case
      "set-id! changes the id"
      (let ([s (make-course 'FOO "Foo" 999 333.3 #t time1)])
        (check-equal? (get-id s) #f)
        (set-id! s 1)
        (check-equal? (get-id s) 1)))
     
     (test-case
      "get-revision returns correct revision"
      (check-equal? (get-revision unsaved) #f)
      (check-equal? (get-revision saved) 1000))
     
     (test-case
      "set-revision! changes the revision"
      (let ([s (make-course 'FOO "Foo" 999 333.3 #t time1)])
        (check-equal? (get-revision s) #f)
        (set-revision! s 1000)
        (check-equal? (get-revision s) 1000)))
     
     (test-eq?
      "struct-entity returns the correct entity"
      (struct-entity unsaved)
      entity:course)
     
     (test-exn
      "struct-entity throws exn:fail:contract when argument isn't a persistent struct"
      exn:fail:contract?
      (lambda ()
        (define-struct test (a b c))
        (struct-entity (make-test 1 2 3))))
     
     (test-case
      "has-attribute? works as expected"
      (check-true  (has-attribute? entity:course 'code) #t)
      (check-true  (has-attribute? entity:course 'name) #t)
      (check-true  (has-attribute? entity:course 'value) #t)
      (check-true  (has-attribute? entity:course 'active) #t)
      (check-false (has-attribute? entity:course 'fake) #f))
     
     (test-case
      "get-attribute returns the expected attribute"
      (let ([attrib (get-attribute entity:course 'id)])
        (check-equal? (attribute-name attrib) 'id)
        (check-equal? (attribute-type attrib) type:id))
      (let ([attrib (get-attribute entity:course 'revision)])
        (check-equal? (attribute-name attrib) 'revision)
        (check-equal? (attribute-type attrib) type:revision))
      (let ([attrib (get-attribute entity:course 'code)])
        (check-equal? (attribute-name attrib) 'code)
        (check-equal? (attribute-type attrib) type:symbol))
      (let ([attrib (get-attribute entity:course 'name)])
        (check-equal? (attribute-name attrib) 'name)
        (check-equal? (attribute-type attrib) type:text))
      (let ([attrib (get-attribute entity:course 'value)])
        (check-equal? (attribute-name attrib) 'value)
        (check-equal? (attribute-type attrib) type:integer/1))
      (let ([attrib (get-attribute entity:course 'rating)])
        (check-equal? (attribute-name attrib) 'rating)
        (check-equal? (attribute-type attrib) type:real))
      (let ([attrib (get-attribute entity:course 'active)])
        (check-equal? (attribute-name attrib) 'active)
        (check-equal? (attribute-type attrib) type:boolean/t))
      (let ([attrib (get-attribute entity:course 'start)])
        (check-equal? (attribute-name attrib) 'start)
        (check-equal? (attribute-type attrib) type:time-tai)))
     
     (test-case
      "get-attribute-index returns the expected index"
      ; ID has index 0
      (check-equal? (get-attribute-index entity:course 'id)       0)
      (check-equal? (get-attribute-index entity:course 'revision) 1)
      (check-equal? (get-attribute-index entity:course 'code)     2)
      (check-equal? (get-attribute-index entity:course 'name)     3)
      (check-equal? (get-attribute-index entity:course 'value)    4)
      (check-equal? (get-attribute-index entity:course 'rating)   5)
      (check-equal? (get-attribute-index entity:course 'active)   6)
      (check-equal? (get-attribute-index entity:course 'start)    7))
     
     (test-case
      "get-attribute-value returns the expected value"
      (check-equal? (get-attribute-value unsaved 'id)       #f)
      (check-equal? (get-attribute-value unsaved 'revision) #f)
      (check-equal? (get-attribute-value unsaved 'code)     'UNSAVED)
      (check-equal? (get-attribute-value unsaved 'name)     "Unsaved")
      (check-equal? (get-attribute-value unsaved 'value)    1)
      (check-equal? (get-attribute-value unsaved 'rating)   1.5)
      (check-equal? (get-attribute-value unsaved 'active)   #f)
      (check-equal? (get-attribute-value unsaved 'start)    time1)
      (check-equal? (get-attribute-value saved   'id)       0)
      (check-equal? (get-attribute-value saved   'revision) 1000)
      (check-equal? (get-attribute-value saved   'code)     'SAVED)
      (check-equal? (get-attribute-value saved   'name)     "Saved")
      (check-equal? (get-attribute-value saved   'value)    2)
      (check-equal? (get-attribute-value saved   'rating)    2.5)
      (check-equal? (get-attribute-value saved   'active)   #t)
      (check-equal? (get-attribute-value saved   'start)    time2))
     
     (test-equal?
      "get-attribute-values returns the expected values"
      (get-attribute-values saved)
      (list 0 1000 'SAVED "Saved" 2 2.5 #t time2))
     
     (test-case
      "get-attribute-xxx functions all throw an exception when applied to a non-existant field name"
      (let ()
        (check-exn exn:fail:snooze? (lambda () (get-attribute       entity:course 'a)) "get-attribute test failed")
        (check-exn exn:fail:snooze? (lambda () (get-attribute-index entity:course 'a)) "get-attribute-index test failed")
        (check-exn exn:fail:snooze? (lambda () (get-attribute-value saved 'a))         "get-attribute-value test failed")))
     
     (test-case
      "get-attribute-xxx functions all throw an exception when applied to a non-persistent struct"
      (let ()
        (define-struct test-struct (a b c))
        (define test (make-test-struct 1 2 3))
        (check-exn exn:fail:contract? (lambda () (get-attribute       struct:test-struct 'a)) "get-attribute test failed")
        (check-exn exn:fail:contract? (lambda () (get-attribute-index struct:test-struct 'a)) "get-attribute-index test failed")
        (check-exn exn:fail:contract? (lambda () (get-attribute-value test 'a))               "get-attribute-value test failed")))
     
     ; TODO: 2007-10-10: Commented out for removal:
     ; (test-case
     ;  "map-attributes/entity iterates through all attributes except id and revision"
     ;  (check-equal?
     ;   (map-attributes/entity (cut list <> <>) entity:course)
     ;   `((code   ,type:symbol)
     ;     (name   ,type:text)
     ;     (value  ,type:integer/1)
     ;     (rating ,type:real)
     ;     (active ,type:boolean/t)
     ;     (start  ,type:time-tai))))
     
     ; TODO: 2007-10-10: Commented out for removal:
     ; (test-case
     ;  "map-attributes/struct iterates through all attributes except id and revision"
     ;  (check-equal?
     ;   (map-attributes/struct (cut list <> <> <>) unsaved)
     ;   `((code   ,type:symbol    UNSAVED)
     ;     (name   ,type:text      "Unsaved")
     ;     (value  ,type:integer/1 1)
     ;     (rating ,type:real      1.5)
     ;     (active ,type:boolean/t #f)
     ;     (start  ,type:time-tai  ,time1)))
     ;  (check-equal?
     ;   (map-attributes/struct (cut list <> <> <>) saved)
     ;   `((code   ,type:symbol    SAVED)
     ;     (name   ,type:text      "Saved")
     ;     (value  ,type:integer/1 2)
     ;     (rating ,type:real      2.5)
     ;     (active ,type:boolean/t #t)
     ;     (start  ,type:time-tai  ,time2))))
     
     ; TODO: 2007-10-10: Commented out for removal:
     ; (test-case
     ;  "for-each-attribute/entity iterates through all attributes except id and revision"
     ;  (let* ([store null]
     ;         [update! (store-mutator store)]) ; function that appends argument list to store
     ;    (for-each-attribute/entity update! entity:course)
     ;    (check-equal?
     ;     store
     ;     `((code   ,type:symbol)
     ;       (name   ,type:text)
     ;       (value  ,type:integer/1)
     ;       (rating ,type:real)
     ;       (active ,type:boolean/t)
     ;       (start  ,type:time-tai)))))
     
     ; TODO: 2007-10-10: Commented out for removal:
     ; (test-case
     ;  "for-each-attribute/struct iterates through all attributes except id and revision"
     ;  (let* ([store1 null]
     ;         [store2 null]
     ;         [update-store1! (store-mutator store1)]  ; function that appends argument list to store1
     ;         [update-store2! (store-mutator store2)]) ; function that appends argument list to store2
     ;    (for-each-attribute/struct update-store1! unsaved)
     ;    (for-each-attribute/struct update-store2! saved)
     ;    (check-equal?
     ;     store1
     ;     `((code   ,type:symbol    UNSAVED)
     ;       (name   ,type:text      "Unsaved")
     ;       (value  ,type:integer/1 1)
     ;       (rating ,type:real      1.5)
     ;       (active ,type:boolean/t #f)
     ;       (start  ,type:time-tai  ,time1)))
     ;    (check-equal?
     ;     store2
     ;     `((code   ,type:symbol    SAVED)
     ;       (name   ,type:text      "Saved")
     ;       (value  ,type:integer/1 2)
     ;       (rating ,type:real      2.5)
     ;       (active ,type:boolean/t #t)
     ;       (start  ,type:time-tai  ,time2)))))
     
     ; TODO: 2007-10-10: Commented out for removal:
     ; (test-case
     ;  "persistent-struct->hash-table works as expected"
     ;  (check-equal? (persistent-struct->hash-table unsaved) unsaved-hash-table)
     ;  (check-equal? (persistent-struct->hash-table saved)   saved-hash-table))
     
     (test-case
      "persistent-struct->alist works as expected"
      (check-equal? (persistent-struct->alist unsaved) unsaved-alist)
      (check-equal? (persistent-struct->alist saved)   saved-alist))
     
     (test-case
      "make-persistent-struct/defaults works as expected"
      (check-equal? (make-persistent-struct/defaults entity:course)
                    (make-course #f #f 1 #f #t #f)
                    "all defaults failed")
      (check-equal? (make-persistent-struct/defaults entity:course #:rating 1.5 #:active #f)
                    (make-course #f #f 1 1.5 #f #f)
                    "some keywords failed")
      (check-exn
       exn:fail:contract?
       (cut make-persistent-struct/defaults entity:course #:active? #f)
       "bad keyword failed"))
     
     (test-case
      "copy-persistent-struct works as expected"
      (let ([struct1 (make-course 'CODE "Name" 123 123.4 #t time1)])
        (set-id! struct1 100)
        (set-revision! struct1 200)
        (check-pred integer? (get-id struct1) "check 1")
        (let ([struct2 (copy-persistent-struct struct1)])
          ; Check struct1 and struct2 are different structures:
          (check (lambda (a b) (not (eq? a b))) struct2 struct1 "check 2")
          ; Check struct1 and struct2 have the same ID, revision and attributes:
          (check-equal? (get-id struct2)        (get-id struct1)        "check 3")
          (check-equal? (get-revision struct2)  (get-revision struct1)  "check 4")
          (check-equal? (course-code struct2)   (course-code struct1)   "check 5")
          (check-equal? (course-name struct2)   (course-name struct1)   "check 6")
          (check-equal? (course-value struct2)  (course-value struct1)  "check 7")
          (check-equal? (course-rating struct2) (course-rating struct1) "check 8")
          (check-equal? (course-active struct2) (course-active struct1) "check 9")
          (check-equal? (course-start struct2)  (course-start struct1)  "check 10")
          ; Check equal? correctly compares structs:
          (check-equal? struct2 struct1 "check 11"))
        (let ([struct2 (copy-persistent-struct struct1 #:code 'CODE2 #:active #f)])
          ; Check struct1 and struct2 are different structures:
          (check (lambda (a b) (not (eq? a b))) struct2 struct1 "check 12")
          ; Check struct1 and struct2 have the same ID, revision and attributes:
          (check-equal? (get-id struct2)        (get-id struct1)        "check 13")
          (check-equal? (get-revision struct2)  (get-revision struct1)  "check 14")
          (check-equal? (course-code struct2)   'CODE2                  "check 15")
          (check-equal? (course-name struct2)   (course-name struct1)   "check 16")
          (check-equal? (course-value struct2)  (course-value struct1)  "check 17")
          (check-equal? (course-rating struct2) (course-rating struct1) "check 18")
          (check-equal? (course-active struct2) #f                      "check 19")
          (check-equal? (course-start struct2)  (course-start struct1)  "check 20")
          ; Check equal? correctly compares structs:
          (check (lambda (a b) (not (equal? a b))) struct2 struct1 "check 21"))))
     
     ; TODO: 2007-10-10: Commented out for removal:
     ; (test-case
     ;  "hash-table->persistent-struct works as expected"
     ;  (let* ([foo1 (hash-table->persistent-struct
     ;                entity:course
     ;                (make-hash-table/pairs
     ;                 (cons 'id       9876) ; Shouldn't be added to the struct
     ;                 (cons 'revision 8765) ; Shouldn't be added to the struct
     ;                 (cons 'code     'CODE)
     ;                 (cons 'name     "Name")
     ;                 (cons 'value    123)
     ;                 (cons 'rating   123.4)
     ;                 (cons 'active   #t)
     ;                 (cons 'start    time1)))]
     ;         [foo2 (make-course 'CODE' "Name" 123 123.4 #t time1)])
     ;    (check equal? foo1 foo2 "Basic equality check failed")
     ;    (check equal? (get-id foo1) #f "ID check failed")
     ;    (check equal? (get-revision foo1) #f "Revision check failed")))
     
     ; TODO: 2007-10-10: Commented out for removal:
     ; (test-case
     ;  "set-attributes/hash-table! overwrites attributes appropriately"
     ;  (let ([foo   (make-course 'CODE' "Name" 123 123.4 #t time1)]
     ;        [table (make-hash-table/pairs
     ;                (cons 'code   'CODE2)
     ;                (cons 'name   "Name2")
     ;                (cons 'value  321)
     ;                (cons 'rating 432.1)
     ;                (cons 'active #f)
     ;                (cons 'start time2))])
     ;    (set-attributes/hash-table! foo table)
     ;    (check-equal? (course-code foo)   'CODE2  "Code failed")
     ;    (check-equal? (course-name foo)   "Name2" "Name failed")
     ;    (check-equal? (course-value foo)  321     "Value failed")
     ;    (check-equal? (course-rating foo) 432.1   "Rating failed")
     ;    (check-equal? (course-active foo) #f      "Active failed")
     ;    (check-equal? (course-start foo)  time2   "Start failed")))
     
     ; TODO: 2007-10-10: Commented out for removal:
     ; (test-case
     ;  "set-attributes/hash-table! does not overwrite ID or revision"
     ;  (let ([foo   (make-course 'CODE' "Name" 123 123.4 #t time1)]
     ;        [table (make-hash-table/pairs
     ;                (cons 'id 12345)
     ;                (cons 'revision 23456))])
     ;    (set-attributes/hash-table! foo table)
     ;    (check-equal? (get-id foo) #f)
     ;    (check-equal? (get-revision foo) #f)))
     
     ; TODO: 2007-10-10: Commented out for removal:
     ; (test-case
     ;  "set-attributes/hash-table! ignores attributes that aren't in the entity"
     ;  (let ([foo   (make-course 'CODE' "Name" 123 123.4 #t time1)]
     ;        [table (make-hash-table/pairs
     ;                (cons 'code 'CODE2)
     ;                (cons 'cøde 'CODE3)
     ;                (cons 'name "Name2")
     ;                (cons 'n "Name3")
     ;                (cons 'value 321)
     ;                (cons 'val 4321)
     ;                (cons 'active #f)
     ;                (cons 'active2 #t)
     ;                (cons 'start time2))])
     ;    (set-attributes/hash-table! foo table)
     ;    (check-equal? (course-code foo)   'CODE2  "Code failed")
     ;    (check-equal? (course-name foo)   "Name2" "Name failed")
     ;    (check-equal? (course-value foo)  321     "Value failed")
     ;    (check-equal? (course-rating foo) 123.4   "Rating failed")
     ;    (check-equal? (course-active foo) #f      "Active failed")
     ;    (check-equal? (course-start foo)  time2   "Start failed")))
     
     (test-case
      "set-attributes/alist! overwrites attributes appropriately"
      (let ([foo    (make-course 'CODE' "Name" 123 123.4 #t time1)]
            [fields (list (cons 'code 'CODE2)
                          (cons 'name "Name2")
                          (cons 'value 321)
                          (cons 'rating 432.1)
                          (cons 'active #f)
                          (cons 'start time2))])
        (set-attributes/alist! foo fields)
        (check-equal? (course-code foo)   'CODE2  "Code failed")
        (check-equal? (course-name foo)   "Name2" "Name failed")
        (check-equal? (course-value foo)  321     "Value failed")
        (check-equal? (course-rating foo) 432.1   "Rating failed")
        (check-equal? (course-active foo) #f      "Active failed")
        (check-equal? (course-start foo)  time2   "Start failed")))
     
     (test-case
      "set-attributes/alist! does not overwrite ID or revision"
      (let ([foo    (make-course 'CODE' "Name" 123 123.4 #t time1)]
            [fields (list (cons 'id 12345)
                          (cons 'revision 23456))])
        (set-attributes/alist! foo fields)
        (check-equal? (get-id foo) #f)
        (check-equal? (get-revision foo) #f)))
     
     (test-case
      "set-attributes/alist! ignores attributes that aren't in the entity"
      (let ([foo    (make-course 'CODE' "Name" 123 123.4 #t time1)]
            [fields (list (cons 'code 'CODE2)
                          (cons 'cøde 'CODE3)
                          (cons 'name "Name2")
                          (cons 'n "Name3")
                          (cons 'value 321)
                          (cons 'val 4321)
                          (cons 'active #f)
                          (cons 'active2 #t)
                          (cons 'start time2))])
        (set-attributes/alist! foo fields)
        (check-equal? (course-code foo)   'CODE2  "Code failed")
        (check-equal? (course-name foo)   "Name2" "Name failed")
        (check-equal? (course-value foo)  321     "Value failed")
        (check-equal? (course-rating foo) 123.4   "Rating failed")
        (check-equal? (course-active foo) #f      "Active failed")
        (check-equal? (course-start foo)  time2   "Start failed")))
     
     ))
  
  )