From abe929fda81c34c9ef3d310195485a710c1b67ef Mon Sep 17 00:00:00 2001
From: Ryan Culpepper <ryanc@racket-lang.org>
Date: Sat, 12 May 2007 23:55:17 +0000
Subject: [PATCH] Macro stepper:   added obsolete warning   added filename to
 frame label

svn: r6218
---
 collects/macro-debugger/tool.ss     | 25 +++++++++++-----
 collects/macro-debugger/view/gui.ss | 45 ++++++++++++++++++++++++-----
 2 files changed, 56 insertions(+), 14 deletions(-)

diff --git a/collects/macro-debugger/tool.ss b/collects/macro-debugger/tool.ss
index 2c24243eab..7dbf86f8a3 100644
--- a/collects/macro-debugger/tool.ss
+++ b/collects/macro-debugger/tool.ss
@@ -136,14 +136,21 @@
       (define (macro-debugger-interactions-text-mixin %)
         (class %
           (super-new)
-          (inherit run-in-evaluation-thread)
+          (inherit run-in-evaluation-thread
+                   get-top-level-window)
 
           (define debugging? #f)
+
+          (define current-stepper #f)
+          
           (define/public (enable-macro-debugging ?)
             (set! debugging? ?))
 
           (define/override (reset-console)
             (super reset-console)
+            (when current-stepper
+              (send current-stepper add-obsoleted-warning)
+              (set! current-stepper #f))
             (run-in-evaluation-thread
              (lambda ()
                (let-values ([(e mnr) 
@@ -152,13 +159,17 @@
                  (current-eval e)
                  (current-module-name-resolver mnr)))))
 
+          (define/private (make-stepper filename)
+            (let ([frame (new macro-stepper-frame% (filename filename))])
+              (set! current-stepper frame)
+              (send frame show #t)
+              (send frame get-widget)))
+
           (define/private (make-handlers original-eval-handler original-module-name-resolver)
-            (let ([stepper
-                   (delay 
-                     (let ([frame (new macro-stepper-frame%)])
-                       (send frame show #t)
-                       (send frame get-widget)))]
-                  [debugging? debugging?])
+            (let* ([filename (send (send (get-top-level-window) get-definitions-text)
+                                   get-filename/untitled-name)]
+                   [stepper (delay (make-stepper filename))]
+                   [debugging? debugging?])
               (values
                (lambda (expr)
                  (if (and debugging? (syntax? expr))
diff --git a/collects/macro-debugger/view/gui.ss b/collects/macro-debugger/view/gui.ss
index b971dda4af..e254486ccb 100644
--- a/collects/macro-debugger/view/gui.ss
+++ b/collects/macro-debugger/view/gui.ss
@@ -3,6 +3,7 @@
   (require (lib "class.ss")
            (lib "unit.ss")
            (lib "list.ss")
+           (lib "file.ss")
            (lib "plt-match.ss")
            (lib "mred.ss" "mred")
            (lib "framework.ss" "framework")
@@ -97,20 +98,33 @@
 
       (define macro-stepper-frame%
         (class base-frame%
+          (init-field (filename #f))
           (init (identifier=? (pref:identifier=?)))
           (init-field (config (new macro-stepper-config%)))
 
-          (inherit get-menu%
+          (define obsoleted? #f)
+          
+          (inherit get-area-container
+                   set-label
+                   get-menu%
                    get-menu-item%
                    get-menu-bar
                    get-file-menu
                    get-edit-menu
                    get-help-menu)
-
-          (super-new (label "Macro stepper")
+          
+          (super-new (label (make-label))
                      (width (send config get-width))
                      (height (send config get-height)))
 
+          (define/private (make-label)
+            (if filename
+                (string-append (path->string
+                                (file-name-from-path filename))
+                               (if obsoleted? " (old)" "")
+                               " - Macro stepper")
+                "Macro stepper"))
+
           (define/override (on-size w h)
             (send config set-width w)
             (send config set-height h)
@@ -142,13 +156,31 @@
             (new (get-menu%) (parent (get-menu-bar)) (label "Stepper")))
           (define help-menu (get-help-menu))
 
+          (define warning-panel
+            (new horizontal-panel%
+                 (parent (get-area-container))
+                 (stretchable-height #f)
+                 (style '(deleted))))
+          
           (define widget
             (new macro-stepper-widget%
-                 (parent (send this get-area-container))
+                 (parent (get-area-container))
                  (config config)))
 
           (define/public (get-widget) widget)
 
+          (define/public (add-obsoleted-warning)
+            (unless obsoleted?
+              (set! obsoleted? #t)
+              (new message%
+                   (label "Warning: This macro stepper session is obsolete. The program may have changed.")
+                   (parent warning-panel))
+              (set-label (make-label))
+              (send (get-area-container) change-children
+                    (lambda (children)
+                      (cons warning-panel
+                            (remq warning-panel children))))))
+          
           ;; Set up menus
 
           (menu-option/notify-box stepper-menu
@@ -483,9 +515,8 @@
                       "Internal error computing reductions. Original term:\n")
                 (send sbview add-syntax
                       (lift/deriv-e1 (trec-deriv (focused-term))))
-                (print-struct #t)
-                (send sbview add-text
-                      (format "~s~n" (focused-term))))))
+                #;(print-struct #t)
+                #;(send sbview add-text (format "~s~n" (focused-term))))))
 
           ;; update:show-lctx : Step -> void
           (define/private (update:show-lctx step)