From 8d9eb0534728888c286e7ae77ce82149bd1ef482 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Thu, 10 Sep 2015 21:16:49 -0400 Subject: [PATCH] syntax/parse: accept #:context (list symbol/#f syntax) The symbol is used as the "who" field in the error message. Also fix lazy-require of runtime-report.rkt in residual.rkt; don't load until syntax-parse actually needs to produce an error report. (Previously was loaded to create handler whenever syntax-parse code ran.) --- .../syntax/scribblings/parse/parsing.scrbl | 25 ++++++++++++--- pkgs/racket-test/tests/stxparse/test.rkt | 31 ++++++++++++++----- racket/collects/syntax/parse/debug.rkt | 3 +- .../collects/syntax/parse/private/parse.rkt | 10 ++++-- .../syntax/parse/private/residual.rkt | 26 +++++++++++++++- .../syntax/parse/private/runtime-report.rkt | 30 +++++++++--------- racket/collects/unstable/error.rkt | 1 + 7 files changed, 92 insertions(+), 34 deletions(-) diff --git a/pkgs/racket-doc/syntax/scribblings/parse/parsing.scrbl b/pkgs/racket-doc/syntax/scribblings/parse/parsing.scrbl index 41d253c7e8..5f3d7d22a8 100644 --- a/pkgs/racket-doc/syntax/scribblings/parse/parsing.scrbl +++ b/pkgs/racket-doc/syntax/scribblings/parse/parsing.scrbl @@ -40,7 +40,8 @@ Two parsing forms are provided: @racket[syntax-parse] and (code:line #:phase phase-expr)] [clause (syntax-pattern pattern-directive ... body ...+)]) #:contracts ([stx-expr syntax?] - [context-expr syntax?] + [context-expr (or/c syntax? symbol? #f + (list/c symbol? syntax?))] [phase-expr (or/c exact-integer? #f)])]{ Evaluates @racket[stx-expr], which should produce a syntax object, and @@ -60,18 +61,32 @@ error is raised. The following options are supported: @specsubform[(code:line #:context context-expr) - #:contracts ([context-expr syntax?])]{ + #:contracts + ([context-expr (or/c syntax? symbol? #f + (list/c symbol? syntax?))])]{ When present, @racket[context-expr] is used in reporting parse -failures; otherwise @racket[stx-expr] is used. The -@racket[current-syntax-context] parameter is also set to the value of -@racket[context-expr]. +failures; otherwise @racket[stx-expr] is used. If +@racket[context-expr] evaluates to @racket[(list _who _context-stx)], +then @racket[_who] appears in the error message as the form raising +the error, and @racket[_context-stx] is used as the term. If +@racket[context-expr] evaluates to a symbol, it is used as +@racket[_who] and @racket[stx-expr] (the syntax to be destructured) is +used as @racket[_context-stx]. If @racket[context-expr] evaluates to a +syntax object, it is used as @racket[_context-stx] and @racket[_who] +is inferred as with @racket[raise-syntax-error]. + +The @racket[current-syntax-context] parameter is also set to the +syntax object @racket[_context-stx]. @(myexamples (syntax-parse #'(a b 3) [(x:id ...) 'ok]) (syntax-parse #'(a b 3) #:context #'(lambda (a b 3) (+ a b)) + [(x:id ...) 'ok]) + (syntax-parse #'(a b 3) + #:context 'check-id-list [(x:id ...) 'ok])) } diff --git a/pkgs/racket-test/tests/stxparse/test.rkt b/pkgs/racket-test/tests/stxparse/test.rkt index a1efa55ad5..d2e94dffcc 100644 --- a/pkgs/racket-test/tests/stxparse/test.rkt +++ b/pkgs/racket-test/tests/stxparse/test.rkt @@ -268,14 +268,29 @@ ;; == syntax-parse: other feature tests -(test-case "syntax-parse: #:context" - (check-exn - (lambda (exn) - (regexp-match #rx"me: expected exact-nonnegative-integer" (exn-message exn))) - (lambda () - (syntax-parse #'(m x) #:context #'me - [(_ n:nat) 'ok]))) - (void)) +(test-case "syntax-parse: #:context w/ syntax" + (check-exn + #rx"me: expected exact-nonnegative-integer" + (lambda () + (syntax-parse #'(m x) + #:context #'me + [(_ n:nat) 'ok])))) + +(test-case "syntax-parse: #:context w/ symbol" + (check-exn + #rx"me: expected identifier" + (lambda () + (syntax-parse #'(m 1) + #:context 'me + [(_ x:id) 'ok])))) + +(test-case "syntax-parse: #:context w/ symbol+stx" + (check-exn + #rx"me: expected identifier.*in: \\(bigterm\\)" + (lambda () + (syntax-parse #'(m 1) + #:context (list 'me #'(bigterm)) + [(_ x:id) 'ok])))) (test-case "syntax-parse: #:literals" (syntax-parse #'(0 + 1 * 2) diff --git a/racket/collects/syntax/parse/debug.rkt b/racket/collects/syntax/parse/debug.rkt index f24074a9ec..3b161f8f34 100644 --- a/racket/collects/syntax/parse/debug.rkt +++ b/racket/collects/syntax/parse/debug.rkt @@ -9,8 +9,7 @@ syntax/parse/private/residual "private/runtime.rkt" "private/runtime-progress.rkt" - (except-in "private/runtime-report.rkt" - syntax-patterns-fail) + "private/runtime-report.rkt" "private/kws.rkt") ;; No lazy loading for this module's dependencies. diff --git a/racket/collects/syntax/parse/private/parse.rkt b/racket/collects/syntax/parse/private/parse.rkt index 807a670856..ce2fe42f5c 100644 --- a/racket/collects/syntax/parse/private/parse.rkt +++ b/racket/collects/syntax/parse/private/parse.rkt @@ -361,6 +361,10 @@ Conventions: (with-disappeared-uses (with-txlifts (lambda () + (define who + (syntax-case #'ctx () + [(m . _) (identifier? #'m) #'m] + [_ 'syntax-parse])) (define-values (chunks clauses-stx) (parse-keyword-options #'clauses parse-directive-table #:context #'ctx @@ -403,13 +407,13 @@ Conventions: (for/lists (patterns body-exprs defs2s) ([clause (in-list (stx->list clauses-stx))]) (for-clause clause))) (with-syntax ([(def ...) (apply append (get-txlifts-as-definitions) defs defs2s)]) - #`(let* ([ctx0 #,context] - [pr (ps-empty x ctx0)] + #`(let* ([ctx0 (normalize-context '#,who #,context x)] + [pr (ps-empty x (cadr ctx0))] [es #f] [cx x] [fh0 (syntax-patterns-fail ctx0)]) def ... - (parameterize ((current-syntax-context ctx0)) + (parameterize ((current-syntax-context (cadr ctx0))) (with ([fail-handler fh0] [cut-prompt fh0]) #,(cond [(pair? patterns) diff --git a/racket/collects/syntax/parse/private/residual.rkt b/racket/collects/syntax/parse/private/residual.rkt index 6f54d45e99..1f71d3097e 100644 --- a/racket/collects/syntax/parse/private/residual.rkt +++ b/racket/collects/syntax/parse/private/residual.rkt @@ -65,6 +65,7 @@ name->too-few/once name->too-few name->too-many + normalize-context syntax-patterns-fail) ;; == from runtime.rkt @@ -241,9 +242,32 @@ ;; == parse.rkt +;; normalize-context : Symbol Any Syntax -> (list Symbol/#f Syntax) +(define (normalize-context who ctx stx) + (cond [(syntax? ctx) + (list #f ctx)] + [(symbol? ctx) + (list ctx stx)] + [(eq? ctx #f) + (list #f stx)] + [(and (list? ctx) + (= (length ctx) 2) + (or (symbol? (car ctx)) (eq? #f (car ctx))) + (syntax? (cadr ctx))) + ctx] + [else (error who "bad #:context argument\n expected: ~s\n given: ~e" + '(or/c syntax? symbol? #f (list/c (or/c symbol? #f) syntax?)) + ctx)])) + +;; == parse.rkt + (lazy-require ["runtime-report.rkt" - (syntax-patterns-fail)]) + (call-current-failure-handler ctx fs)]) + +;; syntax-patterns-fail : (list Symbol/#f Syntax) -> FailureSet -> (escapes) +(define ((syntax-patterns-fail ctx) fs) + (call-current-failure-handler ctx fs)) ;; == specialized ellipsis parser ;; returns (values 'ok attr-values) or (values 'fail failure) diff --git a/racket/collects/syntax/parse/private/runtime-report.rkt b/racket/collects/syntax/parse/private/runtime-report.rkt index 22007719eb..f397f13457 100644 --- a/racket/collects/syntax/parse/private/runtime-report.rkt +++ b/racket/collects/syntax/parse/private/runtime-report.rkt @@ -6,16 +6,13 @@ unstable/error syntax/srcloc "minimatch.rkt" - (except-in syntax/parse/private/residual - syntax-patterns-fail) + syntax/parse/private/residual "kws.rkt") -(provide syntax-patterns-fail +(provide call-current-failure-handler current-failure-handler maximal-failures - invert-ps - ps->stx+index - ) + ps->stx+index) #| TODO: given (expect:thing _ D _ R) and (expect:thing _ D _ #f), @@ -28,8 +25,8 @@ Note: there is a cyclic dependence between residual.rkt and this module, broken by a lazy-require of this module into residual.rkt |# -(define ((syntax-patterns-fail stx0) fs) - (call-with-values (lambda () ((current-failure-handler) stx0 fs)) +(define (call-current-failure-handler ctx fs) + (call-with-values (lambda () ((current-failure-handler) ctx fs)) (lambda vals (error 'current-failure-handler "current-failure-handler: did not escape, produced ~e" @@ -37,8 +34,8 @@ broken by a lazy-require of this module into residual.rkt ((1) (car vals)) (else (cons 'values vals))))))) -(define (default-failure-handler stx0 fs) - (report-failureset stx0 fs)) +(define (default-failure-handler ctx fs) + (report-failureset ctx fs)) (define current-failure-handler (make-parameter default-failure-handler)) @@ -57,11 +54,11 @@ special handling of failures like "unexpected term" make things more complicated. |# -;; report-failureset : stx FailureSet -> escapes -(define (report-failureset stx0 fs) +;; report-failureset : (list Symbol/#f Syntax) FailureSet -> escapes +(define (report-failureset ctx fs) (let* ([classes (maximal-failures fs)] [reports (apply append (map report/class classes))]) - (raise-syntax-error/reports stx0 reports))) + (raise-syntax-error/reports ctx reports))) ;; A Report is ;; - (report string (listof string) stx stx) @@ -175,12 +172,15 @@ complicated. ;; == Do Report == -(define (raise-syntax-error/reports stx0 reports) +(define (raise-syntax-error/reports ctx reports) (let* ([report (car reports)] [more? (pair? (cdr reports))] [message0 (report-message report)] - [context (report-context report)]) + [context (report-context report)] + [who (car ctx)] + [stx0 (cadr ctx)]) (raise-syntax-error* message0 stx0 (report-stx report) + #:who who #:within (report-within-stx report) '("parsing context" multi maybe) context '("note" maybe) (and more? "additional errors omitted")))) diff --git a/racket/collects/unstable/error.rkt b/racket/collects/unstable/error.rkt index 07c76edfa7..1dcd11e62e 100644 --- a/racket/collects/unstable/error.rkt +++ b/racket/collects/unstable/error.rkt @@ -38,6 +38,7 @@ TODO [raise-syntax-error* (->* [string? (or/c syntax? #f) (or/c syntax? #f)] [#:continued (or/c string? (listof string)) + #:who (or/c symbol? #f) #:within (or/c #f syntax?)] #:rest details-list/c any)]