test-structure-low-level.rkt (3383B)
1 #lang typed/racket 2 3 (require phc-adt 4 phc-toolkit 5 type-expander 6 typed/rackunit 7 (lib "phc-adt/tagged-structure-low-level.hl.rkt") 8 (for-syntax phc-toolkit/untyped)) 9 (adt-init) 10 11 ;; TODO: test all these with unsorted fields too. 12 13 ;; Inferred type 14 (define-syntax (test-structure-infer-type stx) 15 (syntax-case stx () 16 [(_ name . fields) 17 (quasisyntax/top-loc stx 18 (define-type name #,(tagged-infer-type! #'(untagged . fields))))])) 19 20 (test-structure-infer-type test0 test-fa test-fb) 21 (test-structure-infer-type test1) 22 23 ;; Explicit type 24 (define-syntax (test-structure-type stx) 25 (syntax-case stx () 26 [(_ name [field _ type] …) 27 (quasisyntax/top-loc stx 28 (define-type name #,(tagged-type! #'(untagged [field type] …))))])) 29 30 (test-structure-type test2 [test-fa : Number] [test-fb : String]) 31 32 ;; Builders. Assigning them to a variable can fail at compile-time if TR does 33 ;; not see the type properly because it has the wrong scopes). 34 (define c3 (structure #:builder)) 35 (define c4 (structure #:builder [test-fa : Number] [test-fb : String])) 36 (define c6 (structure #:builder [test-fa : Number] [test-fc : Number])) 37 (define c5 (structure #:builder test-fa test-fb)) 38 39 ;; Call constructors, and check the return type 40 (check-not-exn (λ () (ann (c3) test1))) 41 (let ([i4 (c4 7 "ee")] 42 [i5 (c5 8 "ff")]) 43 (check-not-exn (λ () (ann i4 test2))) 44 (check-not-exn (λ () (ann i5 test2))) 45 (check-not-exn (λ () (ann i4 (test0 Number String)))) 46 (check-not-exn (λ () (ann i5 (test0 Number String))))) 47 48 ;; TODO: bug report because using directly (ann v #t) does not work, but 49 ;; wrapping it with a no-op if does work. 50 (define-syntax-rule (check-true-type v) 51 (check-equal?: (if (ann v Boolean) #t #f) 52 : #t 53 #t)) 54 55 (define-syntax-rule (check-false-type v) 56 (check-false (ann (if (ann v Boolean) #t #f) 57 #f))) 58 59 (let ([i4 (c4 7 "ee")] 60 [i5 (c5 8 "ff")]) 61 (check-true-type ((structure? test-fa test-fb) i4)) 62 (check-true-type ((structure? test-fa test-fb) i5)) 63 (check-false-type ((structure?) i4)) 64 (check-true-type ((structure?) (c3))) 65 (check-false-type ((structure? test-fa test-fb) (c3)))) 66 67 ;; Predicate 68 69 (check-equal?: (tagged-get-field (c4 7 "ee") test-fa 'else) 70 : Number 71 7) 72 (check-equal?: (tagged-get-field (c5 7 "ee") test-fb 'else) 73 : String 74 "ee") 75 (check-equal?: ((λ-tagged-get-field test-fa) (c4 7 "ee")) 76 : Number 77 7) 78 (check-equal?: ((λ-tagged-get-field test-fb) (c5 7 "ee")) 79 : String 80 "ee") 81 82 ;; Match-expander 83 (define-match-expander test-structure-match 84 (λ/syntax-case (_ [field pat …] …) () 85 (quasisyntax/loc stx 86 #,(tagged-match! #'(untagged [field (and pat …)] …))))) 87 88 (check-equal?: (match (c5 7 "ee") 89 [(test-structure-match [test-fa x] [test-fb y]) 90 (list y x)]) 91 : (List String Number) 92 '("ee" 7)) 93 94 ;; Supertypes 95 (define-syntax (test-supertypes stx) 96 (syntax-case stx () 97 [(_ . fields) 98 #`'#,(map cdr (has-fields #'fields))])) 99 100 (check-true (set=? 101 (list->set (test-supertypes test-fa)) 102 (set '(untagged test-fa test-fb) 103 '(untagged test-fa test-fc) 104 '(untagged test-fa test-fd))))