runtime-reflect.rkt (4268B)
1 #lang racket/base 2 (require stxparse-info/parse/private/residual ;; keep abs. path 3 (only-in syntax/parse/private/residual-ct ;; keep abs. path 4 attr-name attr-depth) 5 syntax/parse/private/kws) 6 (provide reflect-parser 7 (struct-out reified) 8 (struct-out reified-syntax-class) 9 (struct-out reified-splicing-syntax-class)) 10 11 #| 12 A Reified is 13 (reified symbol ParserFunction nat (listof (list symbol nat))) 14 |# 15 (require (only-in syntax/parse/private/runtime-reflect 16 reified 17 reified? 18 reified-parser 19 reified-arity 20 reified-signature 21 make-reified 22 struct:reified 23 24 reified-syntax-class 25 reified-syntax-class? 26 make-reified-syntax-class 27 struct:reified-syntax-class 28 29 reified-splicing-syntax-class 30 reified-splicing-syntax-class? 31 make-reified-splicing-syntax-class 32 struct:reified-splicing-syntax-class)) 33 #;(define-struct reified-base (name) #:transparent) 34 #;(define-struct (reified reified-base) (parser arity signature)) 35 #;(define-struct (reified-syntax-class reified) ()) 36 #;(define-struct (reified-splicing-syntax-class reified) ()) 37 38 (define (reflect-parser obj e-arity e-attrs splicing?) 39 ;; e-arity represents single call; min and max are same 40 (define who (if splicing? 'reflect-splicing-syntax-class 'reflect-syntax-class)) 41 (if splicing? 42 (unless (reified-splicing-syntax-class? obj) 43 (raise-type-error who "reified splicing-syntax-class" obj)) 44 (unless (reified-syntax-class? obj) 45 (raise-type-error who "reified syntax-class" obj))) 46 (check-params who e-arity (reified-arity obj) obj) 47 (adapt-parser who 48 (for/list ([a (in-list e-attrs)]) 49 (list (attr-name a) (attr-depth a))) 50 (reified-signature obj) 51 (reified-parser obj) 52 splicing?)) 53 54 (define (check-params who e-arity r-arity obj) 55 (let ([e-pos (arity-minpos e-arity)] 56 [e-kws (arity-minkws e-arity)]) 57 (check-arity r-arity e-pos e-kws (lambda (msg) (error who "~a" msg))))) 58 59 (define (adapt-parser who esig0 rsig0 parser splicing?) 60 (if (equal? esig0 rsig0) 61 parser 62 (let ([indexes 63 (let loop ([esig esig0] [rsig rsig0] [index 0]) 64 (cond [(null? esig) 65 null] 66 [(and (pair? rsig) (eq? (caar esig) (caar rsig))) 67 (unless (= (cadar esig) (cadar rsig)) 68 (wrong-depth who (car esig) (car rsig))) 69 (cons index (loop (cdr esig) (cdr rsig) (add1 index)))] 70 [(and (pair? rsig) 71 (string>? (symbol->string (caar esig)) 72 (symbol->string (caar rsig)))) 73 (loop esig (cdr rsig) (add1 index))] 74 [else 75 (error who "reified syntax-class is missing declared attribute `~s'" 76 (caar esig))]))]) 77 (define (take-indexes result indexes) 78 (let loop ([result result] [indexes indexes] [i 0]) 79 (cond [(null? indexes) null] 80 [(= (car indexes) i) 81 (cons (car result) (loop (cdr result) (cdr indexes) (add1 i)))] 82 [else 83 (loop (cdr result) indexes (add1 i))]))) 84 (make-keyword-procedure 85 (lambda (kws kwargs x cx pr es fh cp rl success . rest) 86 (keyword-apply parser kws kwargs x cx pr es fh cp rl 87 (if splicing? 88 (lambda (fh x cx pr . result) 89 (apply success fh x cx pr (take-indexes result indexes))) 90 (lambda (fh . result) 91 (apply success fh (take-indexes result indexes)))) 92 rest)))))) 93 94 (define (wrong-depth who a b) 95 (error who 96 "reified syntax-class has wrong depth for attribute `~s'; expected ~s, got ~s instead" 97 (car a) (cadr a) (cadr b)))