From 454234cfc9313cab29bd01dac93197a331b1cf4b Mon Sep 17 00:00:00 2001
From: Ryan Culpepper <ryanc@racket-lang.org>
Date: Thu, 10 Oct 2013 23:50:06 -0400
Subject: [PATCH] add "within:" line for stxparse errors   related to PR 13806

---
 .../syntax/parse/private/runtime-report.rkt   | 22 ++++++++++---------
 racket/collects/unstable/error.rkt            | 12 +++++++---
 2 files changed, 21 insertions(+), 13 deletions(-)

diff --git a/racket/collects/syntax/parse/private/runtime-report.rkt b/racket/collects/syntax/parse/private/runtime-report.rkt
index 515cc0eb79..8a9724f5ce 100644
--- a/racket/collects/syntax/parse/private/runtime-report.rkt
+++ b/racket/collects/syntax/parse/private/runtime-report.rkt
@@ -64,8 +64,8 @@ complicated.
     (raise-syntax-error/reports stx0 reports)))
 
 ;; A Report is
-;;   - (report string (listof string) stx)
-(define-struct report (message context stx) #:prefab)
+;;   - (report string (listof string) stx stx)
+(define-struct report (message context stx within-stx) #:prefab)
 
 ;; report/class : (non-empty-listof Failure) -> (listof Report)
 (define (report/class fs)
@@ -82,22 +82,23 @@ complicated.
   (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)
-           (report "bad syntax" context #f)]
+           (report "bad syntax" context #f #f)]
           [else
-           (let ([frame-stx
-                  (let-values ([(x cx) (stx-list-drop/cx stx stx index)])
-                    (datum->syntax cx x cx))])
+           (let-values ([(frame-stx within-stx)
+                         (let-values ([(x cx) (stx-list-drop/cx stx stx index)])
+                           (values (datum->syntax cx x cx)
+                                   (if (syntax? x) #f cx)))])
              (cond [(equal? frame-expect (expect:atom '() #f))
                     (syntax-case frame-stx ()
                       [(one . more)
-                       (report "unexpected term" context #'one)]
+                       (report "unexpected term" context #'one #f)]
                       [_
-                       (report (prose-for-expect frame-expect) context frame-stx)])]
+                       (report (prose-for-expect frame-expect) context frame-stx within-stx)])]
                    [(expect:disj? frame-expect)
                     (report (prose-for-expects (expect:disj-expects frame-expect))
-                            context frame-stx)]
+                            context frame-stx within-stx)]
                    [else
-                    (report (prose-for-expect frame-expect) context frame-stx)]))])))
+                    (report (prose-for-expect frame-expect) context frame-stx within-stx)]))])))
 
 ;; prose-for-expects : (listof Expect) -> string
 ;; FIXME: partition by role first?
@@ -161,6 +162,7 @@ complicated.
          [message0 (report-message report)]
          [context (report-context report)])
     (raise-syntax-error* message0 stx0 (report-stx report)
+                         #: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 e5dc3a1dfc..e50313280f 100644
--- a/racket/collects/unstable/error.rkt
+++ b/racket/collects/unstable/error.rkt
@@ -37,7 +37,8 @@ TODO
        any)]
  [raise-syntax-error*
   (->* [string? (or/c syntax? #f) (or/c syntax? #f)]
-       [#:continued (or/c string? (listof string))]
+       [#:continued (or/c string? (listof string))
+        #:within (or/c #f syntax?)]
        #:rest details-list/c
        any)]
  [compose-error-message
@@ -63,10 +64,11 @@ TODO
 
 (define (raise-syntax-error* message0 stx sub-stx
                              #:who [who #f]
+                             #:within [within-stx #f]
                              #:continued [continued-message null]
                              #:extra-sources [extra-stxs null]
                              . field+detail-list)
-  (let* ([source-stx (or stx sub-stx)]
+  (let* ([source-stx (or stx sub-stx within-stx)]
          [who (or who
                   (let* ([maybe-id (if (stx-pair? stx) (stx-car stx) stx)])
                     (if (identifier? maybe-id) (syntax-e maybe-id) '?)))]
@@ -76,6 +78,9 @@ TODO
                  '("at" maybe) (and sub-stx
                                     (error-print-source-location)
                                     (format "~.s" (syntax->datum sub-stx)))
+                 '("within" maybe) (and within-stx
+                                        (error-print-source-location)
+                                        (format "~.s" (syntax->datum within-stx)))
                  '("in" maybe) (and stx
                                     (error-print-source-location)
                                     (format "~.s" (syntax->datum stx)))
@@ -87,7 +92,8 @@ TODO
     (raise
      (exn:fail:syntax message
                       (current-continuation-marks)
-                      (cond [sub-stx (cons sub-stx extra-stxs)]
+                      (cond [within-stx (cons within-stx extra-stxs)]
+                            [sub-stx (cons sub-stx extra-stxs)]
                             [stx (cons stx extra-stxs)]
                             [else extra-stxs])))))