splicing.rkt (3941B)
1 #lang racket/base 2 (require (for-syntax racket/base 3 stxparse-info/parse 4 racket/lazy-require 5 syntax/parse/private/kws) 6 stxparse-info/parse/private/residual) ;; keep abs. path 7 (provide define-primitive-splicing-syntax-class) 8 9 (begin-for-syntax 10 (lazy-require 11 [syntax/parse/private/rep-attrs 12 (sort-sattrs)])) 13 ;; FIXME: workaround for phase>0 bug in racket/runtime-path (and thus lazy-require) 14 ;; Without this, dependencies don't get collected. 15 (require racket/runtime-path (for-meta 2 '#%kernel)) 16 (define-runtime-module-path-index _unused_ 'syntax/parse/private/rep-attrs) 17 18 (define-syntax (define-primitive-splicing-syntax-class stx) 19 20 (define-syntax-class attr 21 #:commit 22 (pattern name:id 23 #:with depth #'0) 24 (pattern [name:id depth:nat])) 25 26 (syntax-parse stx 27 [(dssp (name:id param:id ...) 28 (~or (~once (~seq #:attributes (a:attr ...)) 29 #:name "attributes declaration") 30 (~once (~seq #:description description) 31 #:name "description declaration")) ... 32 proc:expr) 33 #'(begin 34 (define (get-description param ...) 35 description) 36 (define parser 37 (let ([permute (mk-permute '(a.name ...))]) 38 (lambda (x cx pr es fh _cp rl success param ...) 39 (let ([stx (datum->syntax cx x cx)]) 40 (let ([result 41 (let/ec escape 42 (cons 'ok 43 (proc stx 44 (lambda ([msg #f] [stx #f]) 45 (escape (list 'error msg stx))))))]) 46 (case (car result) 47 ((ok) 48 (apply success 49 ((mk-check-result pr 'name (length '(a.name ...)) permute x cx fh) 50 (cdr result)))) 51 ((error) 52 (let ([es 53 (es-add-message (cadr result) 54 (es-add-thing pr (get-description param ...) #f rl es))]) 55 (fh (failure pr es)))))))))) 56 (define-syntax name 57 (stxclass 'name (arity (length '(param ...)) (length '(param ...)) '() '()) 58 (sort-sattrs '(#s(attr a.name a.depth #f) ...)) 59 (quote-syntax parser) 60 #t 61 (scopts (length '(a.name ...)) #t #t #f) 62 #f)))])) 63 64 (define (mk-permute unsorted-attrs) 65 (let ([sorted-attrs 66 (sort unsorted-attrs string<? #:key symbol->string #:cache-keys? #t)]) 67 (if (equal? unsorted-attrs sorted-attrs) 68 values 69 (let* ([pos-table 70 (for/hasheq ([a (in-list unsorted-attrs)] [i (in-naturals)]) 71 (values a i))] 72 [indexes 73 (for/vector ([a (in-list sorted-attrs)]) 74 (hash-ref pos-table a))]) 75 (lambda (result) 76 (for/list ([index (in-vector indexes)]) 77 (list-ref result index))))))) 78 79 (define (mk-check-result pr name attr-count permute x cx fh) 80 (lambda (result) 81 (unless (list? result) 82 (error name "parser returned non-list")) 83 (let ([rlength (length result)]) 84 (unless (= rlength (+ 1 attr-count)) 85 (error name "parser returned list of wrong length; expected length ~s, got ~e" 86 (+ 1 attr-count) 87 result)) 88 (let ([skip (car result)]) 89 ;; Compute rest-x & rest-cx from skip 90 (unless (exact-nonnegative-integer? skip) 91 (error name "expected exact nonnegative integer for first element of result list, got ~e" 92 skip)) 93 (let-values ([(rest-x rest-cx) (stx-list-drop/cx x cx skip)]) 94 (list* fh rest-x rest-cx (ps-add-cdr pr skip) 95 (permute (cdr result))))))))