test-structure-options.rkt (6647B)
1 #lang racket 2 3 (require extensible-parser-specifications 4 racket/require 5 syntax/parse 6 rackunit 7 racket/format 8 phc-toolkit/untyped 9 (for-syntax syntax/parse 10 racket/format)) 11 12 (provide structure-kw-instance-or-builder-mixin 13 structure-kw-predicate-mixin 14 structure-kw-fields-mixin 15 structure-kw-all-mixin 16 structure-kws) 17 18 (define-eh-alternative-mixin structure-kw-instance-or-builder-mixin 19 (pattern 20 {~optional {~and instance-or-builder 21 {~or {~global-or instance #:instance} 22 {~global-or builder #:builder}}} 23 #:name "either #:instance or #:builder"})) 24 25 (define-eh-alternative-mixin structure-kw-predicate-mixin 26 (pattern {~optional {~seq #:? predicate:id} 27 #:name "#:? predicate"})) 28 29 (define-and-for-syntax no-values-err 30 (~a "The #:instance keyword implies the use of [field value]," 31 " [field : type value] or [field value : type].")) 32 33 (define-and-for-syntax values-err 34 (~a "The #:builder keyword implies the use of [field], field" 35 " or [field : type].")) 36 37 (define-and-for-syntax empty-err 38 (~a "If no fields are specified, then either #:builder or #:instance" 39 " must be present")) 40 41 (define-eh-alternative-mixin structure-kw-fields-mixin 42 (pattern 43 {~optional/else 44 {~or {~seq {~or-bug [field:id] field:id} …+ 45 {~global-or builder} 46 {~global-or no-types} 47 {~post-fail no-values-err #:when (attribute instance)}} 48 {~seq [field:id : type] …+ 49 {~global-or builder} 50 {~global-or types} 51 {~post-fail no-values-err #:when (attribute instance)}} 52 {~seq [field:id value:expr] …+ 53 {~global-or instance} 54 {~global-or no-types} 55 {~post-fail values-err #:when (attribute builder)}} 56 {~seq {~or-bug [field:id value:expr : type] 57 [field:id : type value:expr]} 58 …+ 59 {~global-or instance} 60 {~global-or types} 61 {~post-fail values-err #:when (attribute builder)}}} 62 #:defaults ([(field 1) (list)] 63 [(value 1) (list)] 64 [(type 1) (list)]) 65 #:else-post-fail empty-err #:when (and (not (attribute builder)) 66 (not (attribute instance))) 67 #:name (~a "field or [field] or [field : type] for #:builder," 68 " [field value] or [field : type value]" 69 " or [field value : type] for #:instance")})) 70 71 (define-eh-alternative-mixin structure-kw-all-mixin 72 (pattern {~or {structure-kw-instance-or-builder-mixin} 73 {structure-kw-predicate-mixin} 74 {structure-kw-fields-mixin}})) 75 76 (define-splicing-syntax-class structure-kws 77 (pattern {~seq-no-order {structure-kw-all-mixin}})) 78 79 ;; --------- 80 81 (check-equal? (syntax-parse #'(#:instance #:? p) 82 [(:structure-kws) 83 (list* (attribute instance) 84 (syntax->datum 85 #'(instance-or-builder 86 predicate 87 [field ...] 88 [value ...])))]) 89 '(#t #:instance p [] [])) 90 91 (check-equal? (syntax-parse #'(#:builder) 92 [(k:structure-kws) 93 (list* (attribute k.builder) 94 (syntax->datum 95 #'(k.instance-or-builder [k.field ...])))]) 96 '(#t #:builder [])) 97 98 (test-exn 99 "Check that () is rejected, as it has neither #:instance nor #:builder" 100 (regexp (regexp-quote empty-err)) 101 (λ () 102 (syntax-parse #'() 103 [(:structure-kws) #'()]))) 104 105 (test-exn 106 "Check that (#:instance [f1] [f2]) is rejected, as #:instance conflicts with 107 builder-style field declarations" 108 (regexp (regexp-quote no-values-err)) 109 (λ () 110 (syntax-parse #'(#:instance [f1] [f2]) 111 [(:structure-kws) #'([field ...] instance)]))) 112 113 (check-equal? (syntax-parse #'(#:builder #:? p [f1] [f2]) 114 [(:structure-kws) (list* (attribute builder) 115 (syntax->datum #'([field ...])))]) 116 '(#t [f1 f2])) 117 118 (check-equal? (syntax-parse #'([f1] [f2] #:? p) 119 [(:structure-kws) (cons (attribute builder) 120 (syntax->datum #'([field ...])))]) 121 '(#t [f1 f2])) 122 123 ;; This one is appropriately rejected 124 (check-exn #px"unexpected term" 125 (λ () 126 (syntax-parse #'(#:instance #:a) 127 [(:structure-kws) 'err]))) 128 129 (define instance-or-builder? 130 (syntax-parser [(:structure-kws) (list (attr instance) (attr builder))])) 131 132 (check-equal? '(#t #f) (instance-or-builder? #'(#:instance))) 133 (check-equal? '(#f #t) (instance-or-builder? #'(#:builder))) 134 (check-equal? '(#f #t) (instance-or-builder? #'(f1))) 135 (check-equal? '(#f #t) (instance-or-builder? #'([f1]))) 136 (check-equal? '(#f #t) (instance-or-builder? #'([f1] f2))) 137 (check-equal? '(#f #t) (instance-or-builder? #'([f1 : type]))) 138 (check-equal? '(#t #f) (instance-or-builder? #'([f1 value]))) 139 (check-equal? '(#t #f) (instance-or-builder? #'([f1 : type value]))) 140 (check-equal? '(#t #f) (instance-or-builder? #'([f1 value : type]))) 141 (check-equal? '(#f #t) (instance-or-builder? #'(f1 #:builder))) 142 (check-equal? '(#f #t) (instance-or-builder? #'([f1] #:builder))) 143 (check-equal? '(#f #t) (instance-or-builder? #'([f1] f2 #:builder))) 144 (check-equal? '(#f #t) (instance-or-builder? #'([f1 : type] #:builder))) 145 (check-equal? '(#t #f) (instance-or-builder? #'([f1 value] #:instance))) 146 (check-equal? '(#t #f) (instance-or-builder? #'([f1 : type value] #:instance))) 147 (check-equal? '(#t #f) (instance-or-builder? #'([f1 value : type] #:instance))) 148 149 ;; TODO: use (reified-syntax-class-attributes r) to make a simplified version 150 ;; of a macro, which just accepts all the attributes. Another macro can 151 ;; then forward all the attributes at once, with minimal meta-level 1 cost 152 ;; (obviously, constructing the wrappers etx. will have some metal-level 2 cost) 153 ;; 154 ;; Wrapper: 155 ;; (define-syntax (real-macro-name stx) 156 ;; (syntax-parse stx 157 ;; [(~reflect whole some-reified-splicing-syntax-class) 158 ;; (simplified-macro-implementation (attribute attr0) ...)])) 159 ;; Implementation 160 ;; (define-for-syntax (simplified-macro-implementation val0 ...) 161 ;; (syntax-parse #'dummy 162 ;; [(~bind [(attr0 depth) val0] ...) 163 ;; body])) 164 ;; 165 ;; For speed, we could just copy the whole implementation in real-macro-name's 166 ;; definition, instead of calling simplified-macro-implementation.