reflect.rkt (6516B)
1 #lang racket/base 2 (require (for-syntax racket/base 3 racket/lazy-require 4 racket/syntax 5 syntax/parse/private/residual-ct) ;; keep abs.path 6 racket/contract/base 7 racket/contract/combinator 8 syntax/parse/private/minimatch 9 syntax/parse/private/keywords 10 "../private/runtime-reflect.rkt" 11 syntax/parse/private/kws) 12 (begin-for-syntax 13 (lazy-require 14 [syntax/parse/private/rep-data ;; keep abs. path 15 (get-stxclass)])) 16 ;; FIXME: workaround for phase>0 bug in racket/runtime-path (and thus lazy-require) 17 ;; Without this, dependencies don't get collected. 18 (require racket/runtime-path (for-meta 2 '#%kernel)) 19 (define-runtime-module-path-index _unused_ 'syntax/parse/private/rep-data) 20 21 (define-syntax (reify-syntax-class stx) 22 (if (eq? (syntax-local-context) 'expression) 23 (syntax-case stx () 24 [(rsc sc) 25 (with-disappeared-uses 26 (let* ([stxclass (get-stxclass #'sc)] 27 [splicing? (stxclass-splicing? stxclass)]) 28 (unless (scopts-delimit-cut? (stxclass-opts stxclass)) 29 (raise-syntax-error #f "cannot reify syntax class with #:no-delimit-cut option" 30 stx #'sc)) 31 (with-syntax ([name (stxclass-name stxclass)] 32 [parser (stxclass-parser stxclass)] 33 [arity (stxclass-arity stxclass)] 34 [(#s(attr aname adepth _) ...) (stxclass-attrs stxclass)] 35 [ctor 36 (if splicing? 37 #'reified-splicing-syntax-class 38 #'reified-syntax-class)]) 39 #'(ctor 'name parser 'arity '((aname adepth) ...)))))]) 40 #`(#%expression #,stx))) 41 42 (define (reified-syntax-class-arity r) 43 (match (reified-arity r) 44 [(arity minpos maxpos _ _) 45 (to-procedure-arity minpos maxpos)])) 46 47 (define (reified-syntax-class-keywords r) 48 (match (reified-arity r) 49 [(arity _ _ minkws maxkws) 50 (values minkws maxkws)])) 51 52 (define (reified-syntax-class-attributes r) 53 (reified-signature r)) 54 55 (define reified-syntax-class-curry 56 (make-keyword-procedure 57 (lambda (kws1 kwargs1 r . rest1) 58 (match r 59 [(reified name parser arity1 sig) 60 (let () 61 (check-curry arity1 (length rest1) kws1 62 (lambda (msg) 63 (raise-mismatch-error 'reified-syntax-class-curry 64 (string-append msg ": ") r))) 65 (let* ([curried-arity 66 (match arity1 67 [(arity minpos maxpos minkws maxkws) 68 (let* ([rest1-length (length rest1)] 69 [minpos* (- minpos rest1-length)] 70 [maxpos* (- maxpos rest1-length)] 71 [minkws* (sort (remq* kws1 minkws) keyword<?)] 72 [maxkws* (sort (remq* kws1 maxkws) keyword<?)]) 73 (arity minpos* maxpos* minkws* maxkws*))])] 74 [curried-parser 75 (make-keyword-procedure 76 (lambda (kws2 kwargs2 x cx pr es undos fh cp rl success . rest2) 77 (let-values ([(kws kwargs) (merge2 kws1 kws2 kwargs1 kwargs2)]) 78 (keyword-apply parser kws kwargs x cx pr es undos fh cp rl success 79 (append rest1 rest2)))))] 80 [ctor 81 (cond [(reified-syntax-class? r) 82 reified-syntax-class] 83 [(reified-splicing-syntax-class? r) 84 reified-splicing-syntax-class] 85 [else 86 (error 'curry-reified-syntax-class "INTERNAL ERROR: ~e" r)])]) 87 (ctor name curried-parser curried-arity sig)))])))) 88 89 (define (merge2 kws1 kws2 kwargs1 kwargs2) 90 (cond [(null? kws1) 91 (values kws2 kwargs2)] 92 [(null? kws2) 93 (values kws1 kwargs1)] 94 [(keyword<? (car kws1) (car kws2)) 95 (let-values ([(m-kws m-kwargs) 96 (merge2 (cdr kws1) kws2 (cdr kwargs1) kwargs2)]) 97 (values (cons (car kws1) m-kws) (cons (car kwargs1) m-kwargs)))] 98 [else 99 (let-values ([(m-kws m-kwargs) 100 (merge2 kws1 (cdr kws2) kwargs1 (cdr kwargs2))]) 101 (values (cons (car kws2) m-kws) (cons (car kwargs2) m-kwargs)))])) 102 103 ;; ---- 104 105 (provide reify-syntax-class 106 ~reflect 107 ~splicing-reflect) 108 109 (provide/contract 110 [reified-syntax-class? 111 (-> any/c boolean?)] 112 [reified-splicing-syntax-class? 113 (-> any/c boolean?)] 114 [reified-syntax-class-attributes 115 (-> (or/c reified-syntax-class? reified-splicing-syntax-class?) 116 (listof (list/c symbol? exact-nonnegative-integer?)))] 117 [reified-syntax-class-arity 118 (-> (or/c reified-syntax-class? reified-splicing-syntax-class?) 119 procedure-arity?)] 120 [reified-syntax-class-keywords 121 (-> (or/c reified-syntax-class? reified-splicing-syntax-class?) 122 (values (listof keyword?) 123 (listof keyword?)))] 124 [reified-syntax-class-curry 125 (make-contract #:name '(->* ((or/c reified-syntax-class? reified-splicing-syntax-class/c)) 126 (#:<kw> any/c ...) 127 #:rest list? 128 (or/c reified-syntax-class? reified-splicing-syntax-class/c)) 129 #:late-neg-projection 130 (lambda (blame) 131 (let ([check-reified 132 ((contract-late-neg-projection 133 (or/c reified-syntax-class? reified-splicing-syntax-class?)) 134 (blame-swap blame))]) 135 (lambda (f neg-party) 136 (if (and (procedure? f) 137 (procedure-arity-includes? f 1)) 138 (make-keyword-procedure 139 (lambda (kws kwargs r . args) 140 (keyword-apply f kws kwargs (check-reified r neg-party) args))) 141 (raise-blame-error 142 blame #:missing-party neg-party 143 f 144 "expected a procedure of at least one argument, given ~e" 145 f))))) 146 #:first-order 147 (lambda (f) 148 (and (procedure? f) (procedure-arity-includes? f))))]) 149