From 9d9a1cd054981bb2dedc63e4c4585760ff1748f8 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Fri, 18 Apr 2014 06:36:58 -0500
Subject: [PATCH] add some debugging information into the module language test
 suite

specifically, when tests fail and there is an error icon in the REPL,
then go find the stack associated with it and print it out
---
 .../private/module-lang-test-utils.rkt        | 23 ++++++++++++++++++-
 .../drracket/drracket/private/debug.rkt       |  6 +++++
 2 files changed, 28 insertions(+), 1 deletion(-)

diff --git a/pkgs/drracket-pkgs/drracket-test/tests/drracket/private/module-lang-test-utils.rkt b/pkgs/drracket-pkgs/drracket-test/tests/drracket/private/module-lang-test-utils.rkt
index 13814eb476..1ba6d5f786 100644
--- a/pkgs/drracket-pkgs/drracket-test/tests/drracket/private/module-lang-test-utils.rkt
+++ b/pkgs/drracket-pkgs/drracket-test/tests/drracket/private/module-lang-test-utils.rkt
@@ -115,6 +115,19 @@
                    get-text
                    (send interactions-text paragraph-start-position output-start-paragraph)
                    (send interactions-text paragraph-end-position para-before-prompt))))))
+    (define stacks
+      (queue-callback/res 
+       (λ ()
+         (let loop ([snip (send interactions-text find-first-snip)])
+           (cond
+             [(not snip) '()]
+             [else
+              (cond
+                [(method-in-interface? 'get-stacks (object-interface snip))
+                 (define-values (s1 s2) (send snip get-stacks))
+                 (list* s1 s2 (loop (send snip next)))]
+                [else
+                 (loop (send snip next))])])))))
     (define output-passed?
       (let ([r (test-result test)])
         ((cond [(string? r) string=?]
@@ -127,7 +140,15 @@
                (test-definitions test)
                (or (test-interactions test) 'no-interactions)
                (test-result test)
-               text))
+               text)
+      (unless (null? stacks)
+        (eprintf "stacks from error message:")
+        (for ([stack (in-list stacks)])
+          (when stack
+            (eprintf "\n----\n")
+            (for ([frame (in-list stack)])
+              (eprintf "  ~s\n" frame))
+            (eprintf "---\n")))))
     (cond
       [(eq? (test-error-ranges test) 'dont-test)
        (void)]
diff --git a/pkgs/drracket-pkgs/drracket/drracket/private/debug.rkt b/pkgs/drracket-pkgs/drracket/drracket/private/debug.rkt
index 41455c7474..d1da582943 100644
--- a/pkgs/drracket-pkgs/drracket/drracket/private/debug.rkt
+++ b/pkgs/drracket-pkgs/drracket/drracket/private/debug.rkt
@@ -208,9 +208,14 @@ profile todo:
                    (class clickable-image-snip%
                      (inherit get-callback)
                      (define/public (get-image-name) filename)
+                     (define stack1 #f)
+                     (define stack2 #f)
+                     (define/public (set-stacks s1 s2) (set! stack1 s1) (set! stack2 s2))
+                     (define/public (get-stacks) (values stack1 stack2))
                      (define/override (copy) 
                        (let ([n (new note%)])
                          (send n set-callback (get-callback))
+                         (send n set-stacks stack1 stack2)
                          n))
                      (super-make-object bitmap))])
            note%)))
@@ -492,6 +497,7 @@ profile todo:
       (let ([note% (if (mf-bday?) mf-note% bug-note%)])
         (when note%
           (let ([note (new note%)])
+            (send note set-stacks cms1 cms2)
             (send note set-callback (λ (snp) (show-backtrace-window/edition-pairs/two msg cms1 editions1 cms2 editions2 defs ints)))
             (write-special note (current-error-port))
             (display #\space (current-error-port)))))))