test-structure2.rkt (4708B)
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-tagged empty-tg) 12 13 ;; structure-get field 14 (begin 15 (check-equal?: 16 (uniform-get ((structure #:builder a b c d) 1 "b" 'val-c 4) c) 17 : 'val-c 18 'val-c)) 19 20 ;; match-expander 21 (begin 22 (let ([test-match 23 (λ ([val : Any]) 24 (match val 25 [(structure a b c y) (list a b c y)] 26 [(structure d 27 [a (? number?)] 28 [c (? symbol?) 'value-c] 29 [b bb (? string?)]) 30 (list a bb c d)] 31 [else 'other]))]) 32 (check-equal?: (test-match 33 ((structure #:builder a b c d) 1 34 "b" 35 'value-c 36 4)) 37 '(1 "b" value-c 4)) 38 (check-equal?: (test-match 39 ((structure #:builder a b c y) 1 2 3 4)) 40 '(1 2 3 4)) 41 (check-equal?: (test-match 'bad) 'other))) 42 43 ;; type-expander 44 (begin 45 (check-equal?: 46 (uniform-get (ann ((structure #:builder a b c) 1 "b" #t) 47 (structure [a Number] [c Boolean] [b String])) 48 b) 49 "b")) 50 51 ;; structure 52 (begin 53 (let () 54 (define-structure empty-st) 55 (define-structure stA [a Number]) 56 ;; BUG 137 (check-equal?: (empty-st) ((structure #:builder))) 57 (check-not-equal?: (empty-st) (structure [a 1])) 58 (check-not-equal?: (structure #:builder) (structure [a 1])) 59 (check-not-equal?: (empty-st) (stA 1)) 60 (check-not-equal?: (structure #:builder) (stA 1)) 61 (void)) 62 63 ;; TODO: uncomment these tests: 64 (let () 65 (define-structure st [a Number] [b String]) 66 (define-structure stA [a Number]) 67 (define-structure stABC [a Number] [b String] [c Number]) 68 (define st1 (st 1 "b")) 69 (define st2 (st 2 "b")) 70 (define sta (stA 1)) 71 (define st3 (stABC 1 "b" 3)) 72 73 (check-equal?-classes: 74 [#:name st1 75 st1 76 (structure [a 1] [b "b"]) 77 (structure [a : Number 1] [b : String "b"]) 78 ((structure [a : Number] [b : String]) 1 "b") 79 (structure [a : Any 1] [b : Any "b"]) 80 ((structure [a : Any] [b : Any]) 1 "b") 81 ((structure [a] [b]) 1 "b") 82 ((structure a b) 1 "b") 83 ((structure [a] b) 1 "b")] 84 [(structure [a "1"] [b 'b]) 85 (structure [a : String "1"] [b : Symbol 'b]) 86 (structure [a : Any "1"] [b : Any 'b])] 87 [st2] 88 [sta] 89 [st3]))) 90 91 ;; define-structure 92 (begin 93 (define-structure empty-st) 94 (define-structure st [a Number] [b String]) 95 (define-structure st2 [b String] [a Number] #:? custom-is-st2?) 96 (define-structure st3 [c String] [a Number] #:? custom-is-st3?)) 97 98 ;; Constructor: 99 (check-equal?: (empty-st) : empty-st (empty-st)) 100 (begin 101 (check-equal?: (uniform-get (st 1 "b") b) : String "b") 102 (check-equal?: (uniform-get (st2 "a" 2) b) : String "a")) 103 104 ;; Constructor, as id: 105 (begin 106 (check-equal?: (uniform-get (cadr (map st '(1 2 3) '("x" "y" "z"))) b) 107 : String 108 "y") 109 (check-equal?: (uniform-get (cadr (map st2 '("d" "e" "f") '(1 2 3))) b) 110 : String 111 "e")) 112 113 ;; type-expander 114 (begin 115 (check-equal?: (uniform-get (ann (st2 "g" 123) st2) b) "g")) 116 117 ;; match-expander 118 (begin 119 (check-equal?: (match (st2 "h" 7) [(st x y) (cons x y)]) 120 : (Pairof Number String) 121 '(7 . "h"))) 122 123 ;; Equality 124 (begin 125 (check-equal?: (ann (st 1 "i") st) (st 1 "i")) 126 (check-equal?: (ann (st2 "j" 2) st2) (st2 "j" 2)) 127 (check-equal?: (ann (st 1 "k") st) (st2 "k" 1))) 128 129 ;; Predicate 130 (begin 131 (check-equal?: (st? (ann (st 1 "i") (U st st2))) #t) 132 (check-equal?: (custom-is-st2? (ann (st 1 "i") (U st st2))) #t) 133 (check-equal?: (custom-is-st3? (ann (st 1 "i") (U st st2))) #f) 134 (check-equal?: (st? (ann (st 1 "i") (U Number st st2))) #t) 135 (check-equal?: (st? (ann 1 (U Number st st2))) #f) 136 ;; Occurrence typing won't work well, if only because fields could be of 137 ;; a type for which TR doesn't know how to make-predicate. 138 (define (check-occurrence-typing [x : (U Number st st3)]) 139 (if (st? x) 140 (match (ann x st) [(st the-a the-b) (cons the-b the-a)]) 141 'other)) 142 (check-equal?: 143 (check-occurrence-typing (ann (st 1 "i") (U Number st st3))) 144 '("i" . 1)) 145 (check-equal?: 146 (check-occurrence-typing (ann (st2 "j" 2) (U Number st st3))) 147 '("j" . 2)) 148 (check-equal?: 149 (check-occurrence-typing (ann 9 (U Number st st3))) 150 'other))