debug.rkt (5061B)
1 #lang racket/base 2 (require (for-syntax racket/base 3 syntax/stx 4 racket/syntax 5 syntax/parse/private/rep-data 6 "private/rep.rkt" 7 syntax/parse/private/kws) 8 racket/list 9 racket/pretty 10 "../parse.rkt" 11 (except-in stxparse-info/parse/private/residual 12 prop:syntax-class 13 prop:pattern-expander 14 syntax-local-syntax-parse-pattern-introduce) 15 "private/runtime.rkt" 16 "private/runtime-progress.rkt" 17 "private/runtime-report.rkt" 18 syntax/parse/private/kws) 19 20 ;; No lazy loading for this module's dependencies. 21 22 (provide syntax-class-parse 23 syntax-class-attributes 24 syntax-class-arity 25 syntax-class-keywords 26 27 debug-rhs 28 debug-pattern 29 debug-parse 30 debug-syntax-parse!) 31 32 (define-syntax (syntax-class-parse stx) 33 (syntax-case stx () 34 [(_ s x arg ...) 35 (parameterize ((current-syntax-context stx)) 36 (with-disappeared-uses 37 (let* ([argu (parse-argu (syntax->list #'(arg ...)) #:context stx)] 38 [stxclass 39 (get-stxclass/check-arity #'s stx 40 (length (arguments-pargs argu)) 41 (arguments-kws argu))] 42 [attrs (stxclass-attrs stxclass)]) 43 (with-syntax ([parser (stxclass-parser stxclass)] 44 [argu argu] 45 [(name ...) (map attr-name attrs)] 46 [(depth ...) (map attr-depth attrs)]) 47 #'(let ([fh (lambda (undos fs) fs)]) 48 (app-argu parser x x (ps-empty x x) #f null fh fh #f 49 (lambda (fh undos . attr-values) 50 (map vector '(name ...) '(depth ...) attr-values)) 51 argu))))))])) 52 53 (define-syntaxes (syntax-class-attributes 54 syntax-class-arity 55 syntax-class-keywords) 56 (let () 57 (define ((mk handler) stx) 58 (syntax-case stx () 59 [(_ s) 60 (parameterize ((current-syntax-context stx)) 61 (with-disappeared-uses 62 (handler (get-stxclass #'s))))])) 63 (values (mk (lambda (s) 64 (let ([attrs (stxclass-attrs s)]) 65 (with-syntax ([(a ...) (map attr-name attrs)] 66 [(d ...) (map attr-depth attrs)]) 67 #'(quote ((a d) ...)))))) 68 (mk (lambda (s) 69 (let ([a (stxclass-arity s)]) 70 #`(to-procedure-arity '#,(arity-minpos a) '#,(arity-maxpos a))))) 71 (mk (lambda (s) 72 (let ([a (stxclass-arity s)]) 73 #`(values '#,(arity-minkws a) '#,(arity-maxkws a)))))))) 74 75 (define-syntax (debug-rhs stx) 76 (syntax-case stx () 77 [(debug-rhs rhs) 78 (let ([rhs (parse-rhs #'rhs #f #:context stx)]) 79 #`(quote #,rhs))])) 80 81 (define-syntax (debug-pattern stx) 82 (syntax-case stx () 83 [(debug-pattern p . rest) 84 (let-values ([(rest pattern defs) 85 (parse-pattern+sides #'p #'rest 86 #:splicing? #f 87 #:decls (new-declenv null) 88 #:context stx)]) 89 (unless (stx-null? rest) 90 (raise-syntax-error #f "unexpected terms" stx rest)) 91 #`(quote ((definitions . #,defs) 92 (pattern #,pattern))))])) 93 94 (define-syntax-rule (debug-parse x p ...) 95 (let/ec escape 96 (parameterize ((current-failure-handler 97 (lambda (_ fs) 98 (define-values (raw-fs-sexpr maximal-fs-sexpr) (fs->sexprs fs)) 99 (escape 100 `(parse-failure 101 #:raw-failures 102 ,raw-fs-sexpr 103 #:maximal-failures 104 ,maximal-fs-sexpr))))) 105 (syntax-parse x [p 'success] ...)))) 106 107 (define (fs->sexprs fs) 108 (let* ([raw-fs (map invert-failure (reverse (flatten fs)))] 109 [selected-groups (maximal-failures raw-fs)]) 110 (values (failureset->sexpr raw-fs) 111 (let ([selected (map (lambda (fs) 112 (cons 'progress-class 113 (map failure->sexpr fs))) 114 selected-groups)]) 115 (if (= (length selected) 1) 116 (car selected) 117 (cons 'union selected)))))) 118 119 (define (debug-syntax-parse!) 120 (define old-failure-handler (current-failure-handler)) 121 (current-failure-handler 122 (lambda (ctx fs) 123 (define-values (raw-fs-sexpr maximal-fs-sexpr) (fs->sexprs fs)) 124 (eprintf "*** syntax-parse debug info ***\n") 125 (eprintf "Raw failures:\n") 126 (pretty-write raw-fs-sexpr (current-error-port)) 127 (eprintf "Maximal failures:\n") 128 (pretty-write maximal-fs-sexpr (current-error-port)) 129 (old-failure-handler ctx fs))))