fix and update syntax/parse/debug

pkgs/racket-doc/syntax/scribblings/parse/debug.scrbl

@@ -54,3 +54,12 @@ that match computed terms or @racket[~fail] (@racket[#:fail-when],
 etc) clauses that allow a computed term to be pinpointed.
 
 }
+
+@defproc[(debug-syntax-parse!) void?]{
+
+Installs a @racket[syntax-parse] reporting handler that prints
+debugging information to the current error port when a
+@racket[syntax-parse] error occurs.
+
+@history[#:added "6.5.0.3"]
+}

racket/collects/syntax/parse/debug.rkt

@@ -5,6 +5,8 @@
                      "private/rep-data.rkt"
                      "private/rep.rkt"
                      "private/kws.rkt")
+         racket/list
+         racket/pretty
          "../parse.rkt"
          syntax/parse/private/residual
          "private/runtime.rkt"
@@ -21,7 +23,8 @@
 
          debug-rhs
          debug-pattern
-         debug-parse)
+         debug-parse
+         debug-syntax-parse!)
 
 (define-syntax (syntax-class-parse stx)
   (syntax-case stx ()
@@ -87,16 +90,35 @@
   (let/ec escape
     (parameterize ((current-failure-handler
                     (lambda (_ fs)
+                      (define-values (raw-fs-sexpr maximal-fs-sexpr) (fs->sexprs fs))
                       (escape
                        `(parse-failure
                          #:raw-failures
-                         ,(failureset->sexpr fs)
+                         ,raw-fs-sexpr
                          #:maximal-failures
-                         ,(let ([selected (map (lambda (fs)
+                         ,maximal-fs-sexpr)))))
-                                                 (cons 'equivalence-class
-                                                       (map failure->sexpr fs)))
-                                               (maximal-failures fs))])
-                            (if (= (length selected) 1)
-                                (car selected)
-                                (cons 'union selected))))))))
       (syntax-parse x [p 'success] ...))))
+
+(define (fs->sexprs fs)
+  (let* ([raw-fs (map invert-failure (reverse (flatten fs)))]
+         [selected-groups (maximal-failures raw-fs)])
+    (values (failureset->sexpr raw-fs)
+            (let ([selected (map (lambda (fs)
+                                   (cons 'progress-class
+                                         (map failure->sexpr fs)))
+                                 selected-groups)])
+              (if (= (length selected) 1)
+                  (car selected)
+                  (cons 'union selected))))))
+
+(define (debug-syntax-parse!)
+  (define old-failure-handler (current-failure-handler))
+  (current-failure-handler
+   (lambda (ctx fs)
+     (define-values (raw-fs-sexpr maximal-fs-sexpr) (fs->sexprs fs))
+     (eprintf "*** syntax-parse debug info ***\n")
+     (eprintf "Raw failures:\n")
+     (pretty-write raw-fs-sexpr (current-error-port))
+     (eprintf "Maximal failures:\n")
+     (pretty-write maximal-fs-sexpr (current-error-port))
+     (old-failure-handler ctx fs))))

racket/collects/syntax/parse/private/runtime-report.rkt

@@ -9,6 +9,7 @@
          "kws.rkt")
 (provide call-current-failure-handler
          current-failure-handler
+         invert-failure
          maximal-failures
          invert-ps
          ps->stx+index)
@@ -758,12 +759,12 @@ This suggests the following new algorithm based on (s):
                #:expected ,(expectstack->sexpr expectstack))]))
 
 (define (expectstack->sexpr es)
-  (map expect->sexpr (normalize-expectstack es #f)))
+  (map expect->sexpr es))
 
 (define (expect->sexpr e) e)
 
 (define (progress->sexpr ps)
-  (for/list ([pf (in-list (reverse ps))])
+  (for/list ([pf (in-list ps)])
     (match pf
       [(? syntax? stx) 'stx]
       [_ pf])))