no-order.rkt (13310B)
1 #lang racket/base 2 3 ;; TODO: it should be possible to specify a partial ordering and/or join the 4 ;; constraints for multiple occurrences of the same ~no-order clause. The goal 5 ;; is to be able to write a pattern for: 6 ;; (some-macro opts … name opts … field … opts …) 7 ;; where opts is a ~no-order, with some constraints like ~once, ~optional etc. 8 ;; I'd like to write something like: 9 ;; (some-macro (~no-order #:kw1 10 ;; (~seq #:kw2 opt2) 11 ;; name:id 12 ;; (~and fields 13 ;; (~seq field:id …) 14 ;; (~global-before name fields)))) 15 ;; However, the current implementation uses "(~or no-order-clauses) …" which 16 ;; does not permit a clause to see previously matched clauses. 17 ;; Maybe save this for the unified parser and generator library (see on github 18 ;; the repo jsmaniac/phc-toolkit, more specifically the file 19 ;; scribblings/template.scrbl within). 20 21 (require syntax/parse 22 ;syntax/parse/experimental/eh 23 generic-syntax-expanders 24 phc-toolkit/untyped 25 racket/list 26 racket/function 27 racket/format 28 (for-syntax racket/base 29 syntax/parse 30 racket/syntax 31 phc-toolkit/untyped 32 racket/list 33 racket/pretty) 34 "parameters.rkt" 35 "try-attribute.rkt") 36 37 (provide define-eh-alternative-mixin 38 ~seq-no-order 39 ~no-order 40 ~order-point 41 order-point< 42 order-point> 43 try-order-point< 44 try-order-point> 45 ~lift-rest 46 ~as-rest 47 ~omitable-lifted-rest ;; Private 48 (expander-out eh-mixin)) ;; Private 49 50 (define-expander-type eh-mixin) 51 52 (define-syntax define-eh-alternative-mixin 53 (syntax-parser 54 [(_ name 55 (~maybe #:define-splicing-syntax-class splicing-name) 56 (~maybe #:define-syntax-class class-name) 57 ((~literal pattern) pat) ...) 58 #`(begin 59 (define-eh-mixin-expander name 60 (λ (_) 61 (syntax-local-syntax-parse-pattern-introduce 62 (quote-syntax (~or pat ...))))) 63 #,@(if (attribute splicing-name) 64 #'((define-splicing-syntax-class splicing-name 65 (pattern {~seq-no-order {name}}))) 66 #'()) 67 #,@(if (attribute class-name) 68 #'((define-syntax-class class-name 69 (pattern {~no-order {name}}))) 70 #'()))])) 71 72 (define-for-syntax (inline-or stx) 73 (syntax-case stx () 74 [(o . rest) 75 (and (identifier? #'o) (free-identifier=? #'o #'~or)) 76 (apply append (stx-map inline-or #'rest))] 77 [x (list #'x)])) 78 79 (define-for-syntax parse-seq-order-sym-introducer (make-syntax-introducer)) 80 81 (define-for-syntax (fix-disappeared-uses) 82 ;; Fix for https://github.com/racket/racket/issues/1452 83 (let ([dis (current-recorded-disappeared-uses)]) 84 #`{~do #,(with-disappeared-uses* 85 (record-disappeared-uses dis) 86 #'(void))})) 87 88 ;; TODO: this does not work when there is a pattern expander which expands to 89 ;; an ~or^eh 90 (define-for-syntax (catch-omitable-lifted-rest stx) 91 (define caught '()) 92 (define (r stx) 93 ;(displayln (list r stx)) 94 (cond 95 [(syntax? stx) (datum->syntax stx (r (syntax-e stx)) stx stx)] 96 [(and (pair? stx) 97 (identifier? (car stx)) 98 (free-identifier=? (car stx) #'~or)) 99 (cons (car stx) (l (cdr stx)))] 100 [(and (pair? stx) 101 (identifier? (car stx)) 102 (free-identifier=? (car stx) #'~omitable-lifted-rest)) 103 (set! caught (cons stx caught)) 104 #'{~or}] ;; empty ~or with no eh alternatives 105 [else stx])) 106 (define (l stx) 107 ;(displayln (list l stx)) 108 (cond 109 [(syntax? stx) (datum->syntax stx (r (syntax-e stx)) stx stx)] 110 [(list? stx) (map r stx)] 111 [(pair? stx) (cons (r (car stx)) (l (cdr stx)))] 112 [else stx])) 113 (define cleaned (r stx)) 114 (values cleaned caught)) 115 116 ;; TODO: ~seq-no-order should also be a eh-mixin-expander, so that when there 117 ;; are nested ~seq-no-order, the ~post-fail is caught by the nearest 118 ;; ~seq-no-order. 119 120 121 (define-for-syntax ((no-order-ish seq?) stx) 122 (syntax-case stx () 123 [(self pat ...) 124 (with-disappeared-uses* 125 (define counter 0) 126 (define (increment-counter!) 127 (begin0 counter 128 (set! counter (add1 counter)))) 129 ;; first, pre and post-acc gather a-patterns which will be added after 130 ;; the (~seq (~or ) ...), before and after the ~! cut respectively 131 (define first-acc '()) 132 (define (add-to-first! v) (set! first-acc (cons v first-acc))) 133 (define pre-acc '()) 134 (define (add-to-pre! v) (set! pre-acc (cons v pre-acc))) 135 (define post-acc '()) 136 (define (add-to-post! v) (set! post-acc (cons v post-acc))) 137 ;; post-groups-acc gathers some attributes that have to be grouped 138 (define post-groups-acc '()) 139 (define (add-to-post-groups! . v) 140 (set! post-groups-acc (cons v post-groups-acc))) 141 (define lifted-rest '()) 142 (define (add-to-lift-rest! present-clause expanded-pat) 143 (define succeeded (get-new-clause!)) 144 (set! lifted-rest (cons (list present-clause 145 expanded-pat 146 succeeded) 147 lifted-rest))) 148 ;; expand EH alternatives: 149 (parameterize ([eh-first-accumulate add-to-first!] 150 [eh-pre-accumulate add-to-pre!] 151 [eh-post-group add-to-post-groups!] 152 [eh-post-accumulate add-to-post!] 153 [clause-counter increment-counter!] 154 [lift-rest add-to-lift-rest!]) 155 (define alts 156 (expand-all-eh-mixin-expanders #'(~or pat ...))) 157 ;; TODO: we can probably close the "parameterize" here. 158 159 160 161 162 ;; NOTE: this works only because eh-mixin-expanders are NOT pattern 163 ;; expanders. If these are merged later on, then this needs to be 164 ;; adjusted 165 (define-values (cleaned-alts caught-omitable-lifted-rest) 166 (catch-omitable-lifted-rest alts)) 167 (define post-group-bindings 168 (for/list ([group (group-by car 169 (reverse post-groups-acc) 170 free-identifier=?)]) 171 ;; each item in `group` is a four-element list: 172 ;; (list result-id aggregate-function attribute) 173 (define/with-syntax name (first (car group)) 174 #;(syntax-local-introduce 175 (datum->syntax #'here 176 (first (car group))))) 177 (define/with-syntax f (second (car group))) 178 #`[name (f . #,(map (λ (i) #`(attribute #,(third i))) 179 group))])) 180 (set! lifted-rest (reverse lifted-rest)) 181 (define/with-syntax whole-clause (get-new-clause!)) 182 (define/with-syntax rest-clause (get-new-clause!)) 183 (define/with-syntax parse-seq-order-sym-id 184 (datum->syntax (parse-seq-order-sym-introducer 185 (syntax-local-introduce #'here)) 186 'parse-seq-order-sym)) 187 (define/with-syntax whole-clause-pat 188 (if seq? 189 (begin 190 (when (not (null? lifted-rest)) 191 (raise-syntax-error 192 '~seq-no-order 193 (string-append "rest clause must be used within ~no-order," 194 " but was used within ~seq-no-order") 195 stx)) 196 #'{~seq whole-clause (… …) {~bind [(rest-clause 1) (list)]}}) 197 #'(whole-clause (… …) . {~and rest-clause {~not (_ . _)}}))) 198 (define rest-handlers 199 (if (null? lifted-rest) 200 #'() 201 (with-syntax ([[(present expanded-pat succeeded) …] lifted-rest]) 202 #'({~parse 203 {~or (_ {~parse #t 204 (ormap identity 205 (flatten (attribute present)))} 206 {~parse expanded-pat 207 #'rest-clause} 208 {~bind [succeeded #t]}) 209 … 210 (_ {~fail (~a "expected one of the rest patterns" 211 " to match")})} 212 #'(dummy)})))) 213 (define check-no-dup-rest-handlers 214 (if (null? lifted-rest) 215 #'() 216 (with-syntax ([([present expanded-pat succeeded] …) lifted-rest]) 217 #'({~fail #:when (or (and (not (attribute succeeded)) 218 (ormap identity 219 (flatten (attribute present))) 220 (syntax-parse #'rest-clause 221 [expanded-pat #t] 222 [_ #f])) 223 …) 224 (~a "more than one of the lifted rest patterns" 225 " matched")})))) 226 227 ((λ (x) #;(pretty-write (syntax->datum #`(syntax-parser [#,x 'ok]))) x) 228 #`(~delimit-cut 229 (~and #,(fix-disappeared-uses) 230 whole-clause-pat 231 {~do (define parse-seq-order-sym-id 232 (gensym 'parse-seq-order))} 233 {~parse ({~seq #,cleaned-alts (… …)}) 234 #`#,(for/list 235 ([xi (in-syntax #'(whole-clause (… …)))] 236 [i (in-naturals)]) 237 ;; Add a syntax property before parsing, 238 ;; to track the position of matched elements 239 ;; using ~order-point 240 (syntax-property xi 241 parse-seq-order-sym-id 242 i))} 243 #,@(reverse first-acc) 244 #,@(reverse pre-acc) 245 #,@caught-omitable-lifted-rest 246 #,@rest-handlers 247 ~! 248 #,@check-no-dup-rest-handlers 249 (~bind #,@post-group-bindings) 250 #,@(reverse post-acc))))))])) 251 252 (define-syntax ~seq-no-order (pattern-expander (no-order-ish #t))) 253 (define-syntax ~no-order (pattern-expander (no-order-ish #f))) 254 255 (define-eh-mixin-expander ~order-point 256 (λ (stx) 257 (define/with-syntax clause-point (get-new-clause!)) 258 (define/with-syntax parse-seq-order-sym-id 259 (datum->syntax (parse-seq-order-sym-introducer 260 (syntax-local-introduce #'here)) 261 'parse-seq-order-sym)) 262 (syntax-case stx () 263 [(_ point-name pat …) 264 #'{~and {~seq pat …} 265 {~either {~and {~seq clause-point _ (… …)} 266 {~bind 267 [point-name 268 (syntax-property #'clause-point 269 parse-seq-order-sym-id)]}} 270 {~and {~seq} 271 {~bind [point-name #f]}}}}]))) 272 273 (define-syntax-rule (order-point< a b) 274 (and (attribute a) (attribute b) 275 (< (attribute a) (attribute b)))) 276 277 (define-syntax-rule (order-point> a b) 278 (and (attribute a) (attribute b) 279 (> (attribute a) (attribute b)))) 280 281 (define-syntax-rule (try-order-point< a b) 282 (if-attribute a (if-attribute b (order-point< a b) #f) #f)) 283 284 (define-syntax-rule (try-order-point> a b) 285 (if-attribute a (if-attribute b (order-point> a b) #f) #f)) 286 287 (define-syntax ~omitable-lifted-rest 288 (pattern-expander 289 (λ (stx) 290 (syntax-case stx () 291 [(_ expanded-pats clause-present) 292 #'{~and 293 ;; TODO: copy the disappeared uses instead of this hack 294 {~do 'expanded-pats} 295 {~bind [clause-present #t]}}])))) 296 297 (define-eh-mixin-expander ~as-rest 298 (λ (stx) 299 (syntax-case stx () 300 [(_ pat ...) 301 (let () 302 (define/with-syntax clause-present (get-new-clause!)) 303 (define/with-syntax clause-seq (get-new-clause!)) 304 (define/with-syntax (expanded-pat ...) 305 ;; let the ~post, ~global etc. within pat … be recognized 306 (stx-map expand-all-eh-mixin-expanders #'(pat ...))) 307 (lift-rest! '~lift-rest 308 #'clause-present 309 #'({~parse (expanded-pat ...) 310 #'(clause-seq (... ...))})) 311 #'{~seq clause-seq (... ...) 312 {~bind [clause-present #t]}})]))) 313 314 (define-eh-mixin-expander ~lift-rest 315 (λ (stx) 316 (syntax-case stx () 317 [(_ pat) 318 (let () 319 (define/with-syntax clause-present (get-new-clause!)) 320 (define/with-syntax expanded-pat 321 ;; let the ~post, ~global etc. within pat … be recognized 322 (expand-all-eh-mixin-expanders #'pat)) 323 (lift-rest! '~lift-rest #'clause-present #'expanded-pat) 324 #'(~omitable-lifted-rest expanded-pat clause-present))])))