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