commit 2c1a36f55f45489e5a02682403e7c879d80461aa
parent 2de80c8091829e66365dd52bc2e45a0963bec801
Author: Ryan Culpepper <ryanc@racket-lang.org>
Date: Wed, 1 Feb 2017 20:47:27 -0500
syntax/parse: clean up "at"/"within"-term handling
Added comments and examples about "at" and "within" terms
Fixed ps->stx+index bugs related to struct and vector patterns
Diffstat:
1 file changed, 53 insertions(+), 23 deletions(-)
diff --git a/parse/private/runtime-report.rkt b/parse/private/runtime-report.rkt
@@ -78,6 +78,23 @@ deals with the fact that they might not be talking about the same terms.
;; A Report is (report String (Listof String) Syntax/#f Syntax/#f)
(define-struct report (message context stx within-stx) #:prefab)
+;; Sometimes the point where an error occurred does not correspond to
+;; a syntax object within the original term being matched. We use one
+;; or two syntax objects to identify where an error occurred:
+;; - the "at" term is the specific point of error, coerced to a syntax
+;; object if it isn't already
+;; - the "within" term is the closest enclosing original syntax object,
+;; dropped (#f) if same as "at" term
+
+;; Examples (AT is pre-coercion):
+;; TERM PATTERN => AT WITHIN
+;; #'(1) (a:id) #'1 -- ;; the happy case
+;; #'(1) (a b) () #'(1) ;; tail of syntax list, too short
+;; #'(1 . ()) (a b) #'() -- ;; tail is already syntax
+;; #'#(1) #(a b) () #'#(1) ;; "tail" of syntax vector
+;; #'#s(X 1) #s(X a b) () #'#s(X 1) ;; "tail" of syntax prefab
+;; #'(1 2) (a) (#'2) #'(1 2) ;; tail of syntax list, too long
+
;; ============================================================
;; Progress
@@ -240,34 +257,39 @@ ie (ps->stx+index ps1) = (ps->stx+index ps2).
(cond [(= (car ips) ncdrs) (cons (cdr ips) a)]
[else (cons (cons (- (car ips) ncdrs) (cdr ips)) a)])))
-;; ps->stx+index : Progress -> (cons Syntax Nat)
+;; StxIdx = (cons Syntax Nat), the "within" term and offset (#cdrs) of "at" subterm
+
+;; ps->stx+index : Progress -> StxIdx
;; Gets the innermost stx that should have a real srcloc, and the offset
;; (number of cdrs) within that where the progress ends.
(define (ps->stx+index ps)
- (define (interp ps)
+ (define (interp ps top?)
+ ;; if top?: first frame is 'car, must return Syntax, don't unwrap vector/struct
(match ps
[(cons (? syntax? stx) _) stx]
[(cons 'car parent)
- (let* ([d (interp parent)]
- [d (if (syntax? d) (syntax-e d) d)])
+ (let* ([x (interp parent #f)]
+ [d (if (syntax? x) (syntax-e x) x)])
(cond [(pair? d) (car d)]
- [(vector? d) (vector->list d)]
+ [(vector? d)
+ (if top? x (vector->list d))]
[(box? d) (unbox d)]
- [(prefab-struct-key d) (struct->list d)]
+ [(prefab-struct-key d)
+ (if top? x (struct->list d))]
[else (error 'ps->stx+index "INTERNAL ERROR: unexpected: ~e" d)]))]
[(cons (? exact-positive-integer? n) parent)
- (for/fold ([stx (interp parent)]) ([i (in-range n)])
+ (for/fold ([stx (interp parent #f)]) ([i (in-range n)])
(stx-cdr stx))]
[(cons (? ord?) parent)
- (interp parent)]
+ (interp parent top?)]
[(cons 'post parent)
- (interp parent)]))
+ (interp parent top?)]))
(let loop ([ps (ps-truncate-opaque ps)])
(match ps
[(cons (? syntax? stx) _)
(cons stx 0)]
[(cons 'car _)
- (cons (interp ps) 0)]
+ (cons (interp ps #t) 0)]
[(cons (? exact-positive-integer? n) parent)
(match (loop parent)
[(cons stx m) (cons stx (+ m n))])]
@@ -276,6 +298,22 @@ ie (ps->stx+index ps1) = (ps->stx+index ps2).
[(cons 'post parent)
(loop parent)])))
+;; stx+index->at+within : StxIdx -> (values Syntax Syntax/#f)
+(define (stx+index->at+within stx+index)
+ (define within-stx (car stx+index))
+ (define index (cdr stx+index))
+ (cond [(zero? index)
+ (values within-stx #f)]
+ [else
+ (define d (syntax-e within-stx))
+ (define stx*
+ (cond [(vector? d) (vector->list d)]
+ [(prefab-struct-key d) (struct->list d)]
+ [else within-stx]))
+ (define at-stx*
+ (for/fold ([x stx*]) ([_i (in-range index)]) (stx-cdr x)))
+ (values (datum->syntax within-stx at-stx* within-stx)
+ within-stx)]))
;; ============================================================
;; Expectation simplification
@@ -420,7 +458,7 @@ This suggests the following new algorithm based on (s):
[else ;; found point of divergence
(append (handle-divergence groups) acc)])])))
(define stx+index (if (pair? es) (expect->stxidx (car es)) (cons #f 0)))
- (report/expectstack (clean-up es) (car stx+index) (cdr stx+index)))
+ (report/expectstack (clean-up es) stx+index))
;; clean-up : ExpectList -> ExpectList
;; Remove leading and collapse adjacent '... markers
@@ -574,17 +612,15 @@ This suggests the following new algorithm based on (s):
;; ============================================================
;; Reporting
-;; report/expectstack : ExpectList Syntax Nat -> Report
-(define (report/expectstack es stx index)
+;; report/expectstack : ExpectList StxIdx -> Report
+(define (report/expectstack es stx+index)
(define frame-expect (and (pair? es) (car es)))
(define context-frames (if (pair? es) (cdr es) null))
(define context (append* (map context-prose-for-expect context-frames)))
(cond [(not frame-expect)
(report "bad syntax" context #f #f)]
[else
- (define-values (x cx) (stx-list-drop/cx stx stx index))
- (define frame-stx (datum->syntax cx x cx))
- (define within-stx (if (syntax? x) #f cx))
+ (define-values (frame-stx within-stx) (stx+index->at+within stx+index))
(cond [(and (match frame-expect [(expect:atom '() _) #t] [_ #f])
(stx-pair? frame-stx))
(report "unexpected term" context (stx-car frame-stx) #f)]
@@ -675,7 +711,7 @@ This suggests the following new algorithm based on (s):
['...
(list "while parsing different things...")]
[(expect:thing '#f description transparent? role stx+index)
- (let ([stx (stx+index->stx stx+index)])
+ (let-values ([(stx _within-stx) (stx+index->at+within stx+index)])
(cons (~a "while parsing " description
(if role (~a " for " role) ""))
(if (error-print-source-location)
@@ -687,12 +723,6 @@ This suggests the following new algorithm based on (s):
(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)))
-
;; ============================================================
;; Raise exception
