test-structure.rkt (5524B)
1 #lang typed/racket 2 3 (require phc-adt 4 phc-toolkit 5 type-expander 6 typed/rackunit 7 (only-in (lib "phc-adt/tagged-structure-low-level.hl.rkt") 8 λ-tagged-get-field)) 9 (adt-init) 10 11 ;; define-structure 12 (define-structure named1 test-fa test-fb) 13 (define-structure named2 test-fb test-fa) 14 (define-structure named3 test-fa test-fc) 15 16 (check-equal?-classes: 17 [#:name "named1 ∪ named2" 18 : (named1 'a 'b) 19 (ann (named1 (ann 'a 'a) (ann 'b 'b)) (named1 'a 'b)) 20 (ann (named1 (ann 'a 'a) (ann 'b 'b)) (structure [test-fa 'a] [test-fb 'b])) 21 (ann (named1 (ann 'a 'a) (ann 'b 'b)) ((structure [test-fa] test-fb) 'a 'b)) 22 (ann (named2 (ann 'b 'b) (ann 'a 'a)) (named2 'b 'a)) 23 (ann (named2 (ann 'b 'b) (ann 'a 'a)) (structure [test-fa 'a] [test-fb 'b])) 24 (ann (named2 (ann 'b 'b) (ann 'a 'a)) ((structure [test-fa] test-fb) 'a 'b))] 25 [#:name "named3" 26 : (named3 'a 'b) 27 (ann (named3 (ann 'a 'a) (ann 'b 'b)) (named3 'a 'b)) 28 (ann (named3 (ann 'a 'a) (ann 'b 'b)) (structure [test-fa 'a] [test-fc 'b])) 29 (ann (named3 (ann 'a 'a) (ann 'b 'b)) ((structure [test-fa] test-fc) 'a 'b))]) 30 31 (check-equal?: (match (named1 (ann 'a 'a) (ann 'b 'b)) 32 [(named1 fa fb) (list fb fa)]) 33 : (List 'b 'a) 34 '(b a)) 35 36 ;; Types 37 (define-type t0 (structure [test-fa Number] [test-fb String])) 38 (define-type t1 (structure)) 39 40 (define i2 (structure [test-fa 1] [test-fb "a"])) 41 (define i3 (structure #:instance)) 42 43 (check-not-exn (λ () (ann i2 t0))) 44 (check-not-exn (λ () (ann i3 t1))) 45 46 (check-not-exn (λ () (ann i2 StructureTop))) 47 (check-not-exn (λ () (ann i3 StructureTop))) 48 49 (check-true (StructureTop? i2)) 50 (check-true (StructureTop? i3)) 51 52 ;; Instance and make-instance 53 (define c4 (structure test-fa test-fb)) 54 (define c5 (structure [test-fa : Number] [test-fb : String])) 55 (define-type test-fa+test-fb (structure [test-fa Number] [test-fb String])) 56 (check-equal?-classes: 57 [#:name "test-fa+test-fb" 58 : test-fa+test-fb 59 ((structure test-fa test-fb) 2 "b") 60 ((structure [test-fa] test-fb) 2 "b") 61 ((structure test-fa [test-fb]) 2 "b") 62 ((structure [test-fa] [test-fb]) 2 "b") 63 64 (structure [test-fa 2] [test-fb "b"]) 65 66 ((structure [test-fa : Number] [test-fb : String]) 2 "b") 67 68 (structure [test-fa 2 : Number] [test-fb "b" : String]) 69 70 ((structure test-fb test-fa) "b" 2) 71 ((structure test-fb [test-fa]) "b" 2) 72 ((structure [test-fb] test-fa) "b" 2) 73 ((structure [test-fb] [test-fa]) "b" 2) 74 75 (structure [test-fb "b"] [test-fa 2]) 76 77 ((structure [test-fb : String] [test-fa : Number]) "b" 2) 78 79 (structure [test-fb "b" : String] [test-fa 2 : Number])]) 80 81 ;; Accessor 82 (check-equal?: ((λ-tagged-get-field test-fb) (c4 7 "ee")) 83 : String 84 "ee") 85 (check-equal?: ((λ-tagged-get-field test-fb) (c5 7 "ee")) 86 : String 87 "ee") 88 89 ;; Match 90 ((inst check-equal?-classes (List String Number)) 91 (cons 92 "match" 93 (list 94 ;; Simple 95 (match (c4 7 "ee") [(structure [test-fa fa] [test-fb fb]) (list fb fa)]) 96 ;; Change order in the struct definition 97 (match (c4 7 "ee") [(structure [test-fb fb] [test-fa fa]) (list fb fa)]) 98 ;; No patterns 99 (match (c4 7 "ee") [(structure [test-fb] [test-fa]) (list test-fb test-fa)]) 100 (match (c4 7 "ee") [(structure test-fb test-fa) (list test-fb test-fa)])))) 101 102 ;; supertypes: 103 104 (define fn1 (ann (λ (x) x) 105 (→ (structure-supertype [test-fa Number]) 106 (structure-supertype [test-fa Number])))) 107 (check-not-exn 108 (λ () 109 (ann fn1 110 (→ (U (structure-supertype [test-fa Number] [test-fb Any]) 111 (structure-supertype [test-fa Number] [test-fc Any]) 112 (structure-supertype [test-fa Number] [test-fd Any])) 113 (U (structure-supertype [test-fa Number] [test-fb Any]) 114 (structure-supertype [test-fa Number] [test-fc Any]) 115 (structure-supertype [test-fa Number] [test-fd Any])))))) 116 117 (define fn2 (ann (λ (x) x) 118 (→ ((structure-supertype test-fa) Number) 119 ((structure-supertype test-fa) Number)))) 120 (check-not-exn 121 (λ () 122 (ann fn2 123 (→ (U (structure-supertype [test-fa Number] [test-fb Any]) 124 (structure-supertype [test-fa Number] [test-fc Any]) 125 (structure-supertype [test-fa Number] [test-fd Any])) 126 (U (structure-supertype [test-fa Number] [test-fb Any]) 127 (structure-supertype [test-fa Number] [test-fc Any]) 128 (structure-supertype [test-fa Number] [test-fd Any])))))) 129 130 (check-not-exn (λ () (ann (structure [test-fa 7] [test-fb 'x]) 131 (structure-supertype [test-fa Number])))) 132 133 (check-not-exn (λ () (ann (structure [test-fa 8] [test-fc 42]) 134 ((structure-supertype [test-fa]) Number)))) 135 136 (check-not-exn (λ () (ann (structure [test-fa 8] [test-fd "blob"]) 137 ((structure-supertype test-fa) Number)))) 138 139 (check-equal?: (match (structure [test-fa 8] [test-fc 'y]) 140 [(structure-supertype [test-fa x]) (+ x 1)]) 141 : Number 142 9) 143 144 ;; Exchange structures across files (values, types …) 145 (require "test-structure-other.rkt") 146 147 (check-equal? (ann i-other (structure [test-fa String] [test-fb 'b])) 148 (structure [test-fa "a"] [test-fb (ann 'b 'b)])) 149 150 (check-not-exn (λ () (ann (structure [test-fa 1] [test-fc 'c]) t-other))) 151 152 (check-equal? (c-other 7 'd) 153 (structure [test-fa 7 : Number] [test-fd 'd : 'd]))