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