suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

syntax/parse: reformat, add more info to errors

Browse Source
This commit is contained in:
Ryan Culpepper 2013-07-31 19:00:57 -04:00
parent e20b5a1539
commit ed5b0afbac
1 changed files with 71 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

98
racket/collects/syntax/parse/private/runtime-report.rkt
View File

@ -1,7 +1,10 @@
#lang racket/base #lang racket/base
(require racket/list (require racket/list
racket/format
syntax/stx syntax/stx
unstable/struct unstable/struct
unstable/error
syntax/srcloc
"minimatch.rkt" "minimatch.rkt"
(except-in syntax/parse/private/residual (except-in syntax/parse/private/residual
syntax-patterns-fail) syntax-patterns-fail)
@ -61,8 +64,8 @@ complicated.
(raise-syntax-error/reports stx0 reports))) (raise-syntax-error/reports stx0 reports)))
;; A Report is ;; A Report is
;; - (report string stx) ;; - (report string (listof string) stx)
(define-struct report (message stx) #:prefab) (define-struct report (message context stx) #:prefab)
;; report/class : (non-empty-listof Failure) -> (listof Report) ;; report/class : (non-empty-listof Failure) -> (listof Report)
(define (report/class fs) (define (report/class fs)
@ -76,9 +79,10 @@ complicated.
;; report/expectstack : ExpectStack syntax nat -> Report ;; report/expectstack : ExpectStack syntax nat -> Report
(define (report/expectstack es stx index) (define (report/expectstack es stx index)
(let ([frame-expect (and (pair? es) (car es))]) (let ([frame-expect (and (pair? es) (car es))]
[context (append* (map context-prose-for-expect (if (pair? es) (cdr es) null)))])
(cond [(not frame-expect) (cond [(not frame-expect)
(report "bad syntax" #f)] (report "bad syntax" context #f)]
[else [else
(let ([frame-stx (let ([frame-stx
(let-values ([(x cx) (stx-list-drop/cx stx stx index)]) (let-values ([(x cx) (stx-list-drop/cx stx stx index)])
@ -86,21 +90,21 @@ complicated.
(cond [(equal? frame-expect (expect:atom '() #f)) (cond [(equal? frame-expect (expect:atom '() #f))
(syntax-case frame-stx () (syntax-case frame-stx ()
[(one . more) [(one . more)
(report "unexpected term" #'one)] (report "unexpected term" context #'one)]
[_ [_
(report/expects (list frame-expect) frame-stx)])] (report (prose-for-expect frame-expect) context frame-stx)])]
[(expect:disj? frame-expect) [(expect:disj? frame-expect)
(report/expects (expect:disj-expects frame-expect) frame-stx)] (report (prose-for-expects (expect:disj-expects frame-expect))
context frame-stx)]
[else [else
(report/expects (list frame-expect) frame-stx)]))]))) (report (prose-for-expect frame-expect) context frame-stx)]))])))
;; report/expects : (listof Expect) syntax -> Report ;; prose-for-expects : (listof Expect) -> string
;; FIXME: partition by role first? ;; FIXME: partition by role first?
(define (report/expects expects frame-stx) (define (prose-for-expects expects)
(report (join-sep (for/list ([expect expects]) (join-sep (for/list ([expect expects])
(prose-for-expect expect)) (prose-for-expect expect))
";" "or") ";" "or"))
frame-stx))
;; prose-for-expect : Expect -> string ;; prose-for-expect : Expect -> string
(define (prose-for-expect e) (define (prose-for-expect e)
@ -121,23 +125,63 @@ complicated.
[(expect:proper-pair _) [(expect:proper-pair _)
"expected more terms"])) "expected more terms"]))
(define (context-prose-for-expect e)
(match e
[(expect:thing stx+index description transparent? role _)
(let ([stx (stx+index->stx stx+index)])
(cons (~a "while parsing " description
(if role (~a " for " role) ""))
(if (error-print-source-location)
(list (~a " term: "
(~s (syntax->datum stx)
#:limit-marker "..."
#:max-width 50))
(~a " location: "
(or (source-location->string stx) "not available")))
null)))]))
(define (stx+index->stx stx+index)
(let*-values ([(stx) (car stx+index)]
[(index) (cdr stx+index)]
[(x cx) (stx-list-drop/cx stx stx index)])
(datum->syntax cx x cx)))
;; == Do Report == ;; == Do Report ==
(define (raise-syntax-error/reports stx0 reports) (define (raise-syntax-error/reports stx0 reports)
(cond [(= (length reports) 1) (let* ([report (car reports)]
(raise-syntax-error/report stx0 (car reports))] [more? (pair? (cdr reports))]
[else [message0 (report-message report)]
(raise-syntax-error/report* stx0 (car reports))])) [context (report-context report)])
(raise-syntax-error* message0 stx0 (report-stx report)
'("parsing context" multi maybe) context
'("note" maybe) (and more? "additional errors omitted"))))
(define (raise-syntax-error/report stx0 report) (define (raise-syntax-error* message0 stx sub-stx
(raise-syntax-error #f (report-message report) stx0 (report-stx report))) #:who [who #f]
#:continued [continued-message null]
(define (raise-syntax-error/report* stx0 report) #:extra-sources [extra-stxs null]
(let ([message . field+detail-list)
(string-append (let* ([source-stx (or stx sub-stx)]
"There were multiple syntax errors. The first error follows:\n" [who (or who
(report-message report))]) (let* ([maybe-id (if (stx-pair? stx) (stx-car stx) stx)])
(raise-syntax-error #f message stx0 (report-stx report)))) (if (identifier? maybe-id) (syntax-e maybe-id) '?)))]
[message
(apply compose-error-message who message0
#:continued continued-message
'("at" maybe) (and sub-stx
(error-print-source-location)
(format "~.s" (syntax->datum sub-stx)))
'("in" maybe) (and stx
(error-print-source-location)
(format "~.s" (syntax->datum stx)))
field+detail-list)]
[message
(if (error-print-source-location)
(string-append (source-location->prefix source-stx) message)
message)])
(raise (exn:fail:syntax message (current-continuation-marks)
(filter values (list* stx sub-stx extra-stxs))))))
;; ==== ;; ====