128 lines
4.1 KiB
Racket
128 lines
4.1 KiB
Racket
#lang racket/base
|
|
(require racket/list
|
|
"minimatch.rkt"
|
|
"runtime.rkt"
|
|
"kws.rkt")
|
|
(provide syntax-patterns-fail
|
|
current-failure-handler)
|
|
|
|
(define ((syntax-patterns-fail stx0) fs)
|
|
(call-with-values (lambda () ((current-failure-handler) stx0 fs))
|
|
(lambda vals
|
|
(error 'current-failure-handler
|
|
"current-failure-handler: did not escape, produced ~e"
|
|
(case (length vals)
|
|
((1) (car vals))
|
|
(else (cons 'values vals)))))))
|
|
|
|
(define (default-failure-handler stx0 fs)
|
|
(report-failureset stx0 fs))
|
|
|
|
(define current-failure-handler
|
|
(make-parameter default-failure-handler))
|
|
|
|
;; ----
|
|
|
|
#|
|
|
Reporting
|
|
---------
|
|
|
|
First, failures with maximal (normalized) progresses are selected and
|
|
grouped into equivalence classes. In principle, each failure in an
|
|
equivalence class complains about the same term, but in practice,
|
|
special handling of failures like "unexpected term" make things more
|
|
complicated.
|
|
|
|
|#
|
|
|
|
;; report-failureset : stx FailureSet -> escapes
|
|
(define (report-failureset stx0 fs)
|
|
(let* ([classes (maximal-failures fs)]
|
|
[reports (apply append (map report/class classes))])
|
|
(raise-syntax-error/reports stx0 reports)))
|
|
|
|
;; A Report is
|
|
;; - (report string stx)
|
|
(define-struct report (message stx) #:prefab)
|
|
|
|
;; report/class : (non-empty-listof Failure) -> (listof Report)
|
|
(define (report/class fs)
|
|
(let* ([ess (map failure-expectstack fs)]
|
|
[ess (map normalize-expectstack ess)]
|
|
[ess (remove-duplicates ess)]
|
|
[ess (simplify-common-expectstacks ess)])
|
|
(let-values ([(stx index) (ps->stx+index (failure-progress (car fs)))])
|
|
(for/list ([es (in-list ess)])
|
|
(report/expectstack es stx index)))))
|
|
|
|
;; report/expectstack : ExpectStack syntax nat -> Report
|
|
(define (report/expectstack es stx index)
|
|
(let ([frame-expect (and (pair? es) (car es))])
|
|
(cond [(not frame-expect)
|
|
(report "bad syntax" #f)]
|
|
[else
|
|
(let ([frame-stx
|
|
(let-values ([(x cx) (stx-list-drop/cx stx stx index)])
|
|
(datum->syntax cx x cx))])
|
|
(cond [(equal? frame-expect (expect:atom '()))
|
|
(syntax-case frame-stx ()
|
|
[(one . more)
|
|
(report "unexpected term" #'one)]
|
|
[_
|
|
(report/expects (list frame-expect) frame-stx)])]
|
|
[(expect:disj? frame-expect)
|
|
(report/expects (expect:disj-expects frame-expect) frame-stx)]
|
|
[else
|
|
(report/expects (list frame-expect) frame-stx)]))])))
|
|
|
|
;; report/expects : (listof Expect) syntax -> Report
|
|
(define (report/expects expects frame-stx)
|
|
(report (join-sep (for/list ([expect expects])
|
|
(prose-for-expect expect))
|
|
";" "or")
|
|
frame-stx))
|
|
|
|
;; prose-for-expect : Expect -> string
|
|
(define (prose-for-expect e)
|
|
(match e
|
|
[(expect:thing description transparent?)
|
|
(format "expected ~a" description)]
|
|
[(expect:atom atom)
|
|
(format "expected the literal ~a~s~a"
|
|
(if (symbol? atom) "symbol `" "")
|
|
atom
|
|
(if (symbol? atom) "'" ""))]
|
|
[(expect:literal literal)
|
|
(format "expected the identifier `~s'" (syntax-e literal))]
|
|
[(expect:message message)
|
|
(format "~a" message)]))
|
|
|
|
;; == Do Report ==
|
|
|
|
(define (raise-syntax-error/reports stx0 reports)
|
|
(cond [(= (length reports) 1)
|
|
(raise-syntax-error/report stx0 (car reports))]
|
|
[else
|
|
(raise-syntax-error/report* stx0 (car reports))]))
|
|
|
|
(define (raise-syntax-error/report stx0 report)
|
|
(raise-syntax-error #f (report-message report) stx0 (report-stx report)))
|
|
|
|
(define (raise-syntax-error/report* stx0 report)
|
|
(let ([message
|
|
(string-append
|
|
"There were multiple syntax errors. The first error follows:\n"
|
|
(report-message report))])
|
|
(raise-syntax-error #f message stx0 (report-stx report))))
|
|
|
|
;; ====
|
|
|
|
(define (comma-list items)
|
|
(join-sep items "," "or"))
|
|
|
|
(define (improper-stx->list stx)
|
|
(syntax-case stx ()
|
|
[(a . b) (cons #'a (improper-stx->list #'b))]
|
|
[() null]
|
|
[rest (list #'rest)]))
|