239 lines
8.3 KiB
Racket
239 lines
8.3 KiB
Racket
#lang racket/base
|
|
(require racket/contract/base
|
|
racket/list
|
|
"minimatch.ss"
|
|
racket/stxparam
|
|
syntax/stx
|
|
(for-syntax racket/base)
|
|
(for-syntax syntax/stx)
|
|
(for-syntax racket/private/sc)
|
|
(for-syntax "rep-data.ss")
|
|
(for-syntax "../util.ss")
|
|
"runtime.ss")
|
|
(provide syntax-patterns-fail
|
|
current-failure-handler
|
|
simplify-failure)
|
|
|
|
;; Failure reporting parameter & default
|
|
|
|
(define (default-failure-handler stx0 f)
|
|
(match (simplify-failure f)
|
|
[(make failure x frontier expectation)
|
|
(report-failure stx0 x (dfc->index frontier) (dfc->stx frontier) expectation)]))
|
|
|
|
(define current-failure-handler
|
|
(make-parameter default-failure-handler))
|
|
|
|
(define ((syntax-patterns-fail stx0) f)
|
|
(call-with-values (lambda () ((current-failure-handler) stx0 f))
|
|
(lambda vals
|
|
(error 'current-failure-handler
|
|
"current-failure-handler: did not escape, produced ~e"
|
|
(case (length vals)
|
|
((1) (car vals))
|
|
(else (cons 'values vals)))))))
|
|
|
|
;; report-failure : stx stx number stx Expectation -> (escapes)
|
|
(define (report-failure stx0 x index frontier-stx expected)
|
|
(define (err msg stx0 stx)
|
|
(raise-syntax-error #f msg stx0 stx))
|
|
(cond [(expectation-of-null? expected)
|
|
;; FIXME: "extra term(s) after <pattern>"
|
|
(syntax-case x ()
|
|
[(one)
|
|
(err "unexpected term" stx0 #'one)]
|
|
[(first . more)
|
|
;; TODO: report error with all elements (use improper-stx->list)
|
|
(err "unexpected terms starting here" stx0 #'first)]
|
|
[_
|
|
(err "unexpected term" stx0 x)])]
|
|
[(and expected (prose-for-expectation expected index x))
|
|
=>
|
|
(lambda (msg)
|
|
(err (format "~a~a"
|
|
msg
|
|
(cond [(zero? index) ""]
|
|
[else (format " after ~s ~a"
|
|
index
|
|
(if (= 1 index) "term" "terms"))]))
|
|
stx0
|
|
frontier-stx))]
|
|
[else
|
|
(err "bad syntax" stx0 stx0)]))
|
|
|
|
;; simplify-failure : Failure -> SimpleFailure
|
|
(define (simplify-failure f)
|
|
(simplify* f))
|
|
|
|
;; simplify* : Failure -> SimpleFailure
|
|
(define (simplify* f)
|
|
(match f
|
|
[(make join-failures f1 f2)
|
|
(choose-error (simplify* f1) (simplify* f2))]
|
|
[(make failure x frontier expectation)
|
|
(match expectation
|
|
[(make expect:thing description '#t chained)
|
|
(let ([chained* (simplify* chained)])
|
|
(match chained*
|
|
[(make failure _ chained*-frontier chained*-expectation)
|
|
(cond [(ineffable? chained*-expectation)
|
|
;; If simplified chained failure is ineffable,
|
|
;; keep (& adjust) its frontier
|
|
;; and attach enclosing description
|
|
(adjust-failure
|
|
(make-failure x chained*-frontier
|
|
(make-expect:thing description #f #f))
|
|
frontier)]
|
|
[else
|
|
;; Otherwise, "expose" the chained failure and
|
|
;; adjust its frontier
|
|
(adjust-failure chained* frontier)])]))]
|
|
[_ f])]))
|
|
|
|
;; FIXME: try different selection/simplification algorithms/heuristics
|
|
(define (simplify-failure0 f)
|
|
(match f
|
|
[(make join-failures f1 f2)
|
|
(choose-error (simplify-failure0 f1) (simplify-failure0 f2))]
|
|
[(make failure x frontier expectation)
|
|
(match expectation
|
|
[(make expect:thing description '#t chained)
|
|
(let ([chained* (simplify-failure0 chained)])
|
|
(match chained*
|
|
[(make failure _ _ chained*-expectation)
|
|
(cond [(ineffable? chained*-expectation)
|
|
;; If simplified chained failure is ineffable, ignore it
|
|
;; and stick to the one with the description
|
|
f]
|
|
[else
|
|
;; Otherwise, "expose" the chained failure
|
|
;; and adjust its frontier
|
|
(adjust-failure chained* frontier)])]))]
|
|
[_ f])]))
|
|
|
|
(define (adjust-failure f base-frontier)
|
|
(match f
|
|
[(make failure x frontier expectation)
|
|
(let ([frontier (dfc-append base-frontier frontier)])
|
|
(make-failure x frontier expectation))]))
|
|
|
|
;; choose-error : Failure Failure -> Failure
|
|
(define (choose-error f1 f2)
|
|
(case (compare-idfcs (invert-dfc (failure-frontier f1))
|
|
(invert-dfc (failure-frontier f2)))
|
|
[(>) f1]
|
|
[(<) f2]
|
|
[(=) (merge-failures f1 f2)]))
|
|
|
|
;; merge-failures : failure failure -> failure
|
|
(define (merge-failures f1 f2)
|
|
(make-failure (failure-stx f1)
|
|
(failure-frontier f1)
|
|
(merge-expectations (failure-expectation f1)
|
|
(failure-expectation f2))))
|
|
|
|
;; ----
|
|
|
|
;; prose-for-expectation : Expectation syntax -> string/#f
|
|
(define (prose-for-expectation e index stx)
|
|
(cond [(expect? e)
|
|
(let ([alts (expect->alternatives e)])
|
|
(and alts
|
|
(join-sep (for/list ([alt alts])
|
|
(for-alternative alt index stx))
|
|
";" "or")))]
|
|
[(eq? e 'ineffable)
|
|
#f]
|
|
[else (error 'prose-for-expectation "unexpected: ~e" e)]))
|
|
|
|
(define (for-alternative e index stx)
|
|
(match e
|
|
[(make expect:thing description transparent? chained)
|
|
(format "expected ~a" description)]
|
|
[(make expect:atom atom)
|
|
(format "expected the literal ~s" atom)]
|
|
[(make expect:literal literal)
|
|
(format "expected the literal identifier ~s" (syntax-e literal))]
|
|
[(make expect:message message)
|
|
(format "~a" message)]
|
|
[(make expect:pair)
|
|
(cond [(= index 0)
|
|
"expected sequence of terms"]
|
|
[else
|
|
(if (stx-null? stx)
|
|
"expected more terms in sequence"
|
|
"expected sequence of terms")])]))
|
|
|
|
(define (comma-list items)
|
|
(join-sep items "," "or"))
|
|
|
|
(define (join-sep items sep0 ult0 [prefix ""])
|
|
(define sep (string-append sep0 " "))
|
|
(define ult (string-append ult0 " "))
|
|
(define (loop items)
|
|
(cond [(null? items)
|
|
null]
|
|
[(null? (cdr items))
|
|
(list sep ult (car items))]
|
|
[else
|
|
(list* sep (car items) (loop (cdr items)))]))
|
|
(case (length items)
|
|
[(0) #f]
|
|
[(1) (string-append prefix (car items))]
|
|
[(2) (format "~a~a ~a~a" prefix (car items) ult (cadr items))]
|
|
[else (let ([strings (list* (car items) (loop (cdr items)))])
|
|
(apply string-append prefix strings))]))
|
|
|
|
(define (improper-stx->list stx)
|
|
(syntax-case stx ()
|
|
[(a . b) (cons #'a (improper-stx->list #'b))]
|
|
[() null]
|
|
[rest (list #'rest)]))
|
|
|
|
|
|
;; Ad-hoc interpretation of error message expressions
|
|
(provide interpret-error-expression)
|
|
|
|
;; Recognize application of 'format' procedure
|
|
(define (interpret-error-expression e)
|
|
(define vars '(X Y Z))
|
|
|
|
;; minieval : syntax -> (or syntax datum)
|
|
;; Returns syntax on NON-evalable stuff, datum otherwise
|
|
(define (minieval x)
|
|
(syntax-case x (format quote datum literal)
|
|
[(format str arg ...)
|
|
(string? (syntax-e #'str))
|
|
(let ([args (map minieval (syntax->list #'(arg ...)))])
|
|
(define args*
|
|
(cond [(<= (length (filter syntax? args)) (length vars))
|
|
(for/list ([arg args])
|
|
(if (syntax? arg)
|
|
(begin0 (car vars) (set! vars (cdr vars)))
|
|
arg))]
|
|
[else
|
|
(let ([counter 1])
|
|
(for/list ([arg args])
|
|
(if (syntax? arg)
|
|
(begin0 (format "Q~a" counter)
|
|
(set! counter (add1 counter)))
|
|
arg)))]))
|
|
(apply format (syntax-e #'str) args*))]
|
|
[(quote (datum d))
|
|
(format "expected the literal ~a" (syntax->datum #'d))]
|
|
[(quote (literal lit))
|
|
(format "expected the literal identifier ~s" (syntax-e #'lit))]
|
|
[(quote thing)
|
|
(syntax->datum #'thing)]
|
|
[d
|
|
(let ([d (syntax->datum #'d)])
|
|
(or (string? d) (number? d) (boolean? d)))
|
|
(syntax->datum #'d)]
|
|
[_
|
|
x]))
|
|
(let ([ie (minieval e)])
|
|
(if (syntax? ie)
|
|
(syntax->datum ie)
|
|
ie)))
|
|
|