Macro stepper: moved warnings from separate frame to panel/term

svn: r7483

collects/macro-debugger/view/frame.ss

@@ -57,10 +57,6 @@
         (send config set-height h)
         (send widget update/preserve-view))
 
-      (define/augment (on-close)
-        (send widget shutdown)
-        (inner (void) on-close))
-
       (override/return-false file-menu:create-new?
                              file-menu:create-open?
                              file-menu:create-open-recent?

collects/macro-debugger/view/stepper.ss

@@ -33,11 +33,11 @@
 
   ;; TermRecords
 
-  (define-struct trec (deriv synth-deriv estx raw-steps steps definites) #f)
+  (define-struct trec (deriv synth-deriv estx raw-steps steps definites warnings) #f)
 
   (define (new-trec deriv)
-    (make-trec deriv #f #f #f #f #f))
+    (make-trec deriv #f #f #f #f #f null))
-
+  
   ;; trec:invalidate-synth! : TermRecord -> void
   ;; Invalidates cached parts that depend on macro-hiding policy
   (define (trec:invalidate-synth! trec)
@@ -45,6 +45,7 @@
     (set-trec-estx! trec #f)
     (set-trec-raw-steps! trec #f)
     (set-trec-definites! trec #f)
+    (set-trec-warnings! trec null)
     (trec:invalidate-steps! trec))
 
   ;; trec:invalidate-steps! : TermRecord -> void
@@ -130,7 +131,9 @@
              (stretchable-height #f)
              (alignment '(left center))
              (style '(deleted))))
-
+      
+      (define warnings (new stepper-warnings% (parent area)))
+      
       (define sbview (new stepper-syntax-widget% 
                           (parent area)
                           (macro-stepper this)))
@@ -143,8 +146,6 @@
              (stepper this)
              (config config)))
 
-      (define warnings-frame #f)
-
       (send config listen-show-syntax-properties?
             (lambda (show?) (send sbview show-props show?)))
       (send config listen-show-hiding-panel?
@@ -314,6 +315,34 @@
         (update)
         (send text scroll-to-position (unbox start-box) #f (unbox end-box)))
       
+      ;; update/save-position : -> void
+      (define/private (update/save-position)
+        (save-position)
+        (update))
+
+      ;; update : -> void
+      ;; Updates the terms in the syntax browser to the current step
+      (define/private (update)
+        (define text (send sbview get-text))
+        (define position-of-interest 0)
+        (define multiple-terms? (> (length (cursor->list terms)) 1))
+        (send text begin-edit-sequence)
+        (send sbview erase-all)
+        
+        (update:show-prefix)
+        (when multiple-terms? (send sbview add-separator))
+        (set! position-of-interest (send text last-position))
+        (update:show-current-step)
+        (when multiple-terms? (send sbview add-separator))
+        (update:show-suffix)
+        (send text end-edit-sequence)
+        (send text scroll-to-position
+              position-of-interest
+              #f
+              (send text last-position)
+              'start)
+        (enable/disable-buttons))
+      
       ;; update:show-prefix : -> void
       (define/private (update:show-prefix)
         ;; Show the final terms from the cached synth'd derivs
@@ -458,34 +487,6 @@
                               #:alpha-table alpha-table))
                       (cdr suffix0)))))
 
-      ;; update/save-position : -> void
-      (define/private (update/save-position)
-        (save-position)
-        (update))
-
-      ;; update : -> void
-      ;; Updates the terms in the syntax browser to the current step
-      (define/private (update)
-        (define text (send sbview get-text))
-        (define position-of-interest 0)
-        (define multiple-terms? (> (length (cursor->list terms)) 1))
-        (send text begin-edit-sequence)
-        (send sbview erase-all)
-
-        (update:show-prefix)
-        (when multiple-terms? (send sbview add-separator))
-        (set! position-of-interest (send text last-position))
-        (update:show-current-step)
-        (when multiple-terms? (send sbview add-separator))
-        (update:show-suffix)
-        (send text end-edit-sequence)
-        (send text scroll-to-position
-              position-of-interest
-              #f
-              (send text last-position)
-              'start)
-        (enable/disable-buttons))
-
       ;; insert-syntax/color : syntax syntaxes identifiers syntaxes string -> void
       (define/private (insert-syntax/color stx foci definites frontier hi-color)
         (send sbview add-syntax stx
@@ -515,41 +516,52 @@
         (send nav:down enable (cursor:has-next? terms)))
 
       ;; --
-
+      
       ;; refresh/resynth : -> void
       ;; Macro hiding policy has changed; invalidate cached parts of trec
       (define/public (refresh/resynth)
         (for-each trec:invalidate-synth! (cursor->list terms))
         (refresh))
-
+      
       ;; refresh/re-reduce : -> void
       ;; Reduction config has changed; invalidate cached parts of trec
       (define/private (refresh/re-reduce)
         (for-each trec:invalidate-steps! (cursor->list terms))
         (refresh))
-
+      
       ;; refresh/move : -> void
       ;; Moving between terms; clear the saved position
       (define/private (refresh/move)
         (clear-saved-position)
         (refresh))
-
+      
       ;; refresh : -> void
       (define/public (refresh)
         (restore-position)
+        (display-warnings (focused-term))
         (update))
-
+      
+      ;; display-warnings : TermRecord -> void
+      (define/private (display-warnings trec)
+        (send warnings clear)
+        (when trec
+          (unless (send config get-suppress-warnings?)
+            (for-each (lambda (tag+message)
+                        (let ([tag (car tag+message)]
+                              [message (cdr tag+message)])
+                          (send warnings add-warning tag message)))
+                      (trec-warnings trec)))))
+      
       ;; recache : TermRecord -> void
       (define/private (recache trec)
         (unless (trec-synth-deriv trec)
+          (set-trec-warnings! trec null)
           (with-handlers ([(lambda (e) #t)
                            (lambda (e)
                              (handle-recache-error e 'macro-hiding)
                              (set-trec-synth-deriv! trec 'error)
                              (set-trec-estx! trec (lift/deriv-e2 (trec-deriv trec))))])
-            (let-values ([(synth-deriv estx) (synthesize (trec-deriv trec))])
+            (recache-synth trec)))
-              (set-trec-synth-deriv! trec synth-deriv)
-              (set-trec-estx! trec estx))))
         (unless (trec-raw-steps trec)
           (with-handlers ([(lambda (e) #t)
                            (lambda (e)
@@ -656,22 +668,25 @@
            seq]
           [else #f]))
 
-      ;; synthesize : Derivation -> Derivation Syntax
+      ;; recache-synth : TermRecord -> void
-      (define/private (synthesize deriv)
+      (define/private (recache-synth trec)
-        (let ([show-macro? (get-show-macro?)])
+        (define deriv (trec-deriv trec))
-          (if show-macro?
+        (define-values (synth-deriv estx)
-              (parameterize ((current-hiding-warning-handler
+          (let ([show-macro? (get-show-macro?)])
-                              (lambda (tag message)
+            (if show-macro?
-                                (unless (send config get-suppress-warnings?)
+                (parameterize ((current-hiding-warning-handler
-                                  (unless warnings-frame
+                                (lambda (tag message)
-                                    (set! warnings-frame (new warnings-frame%)))
+                                  (set-trec-warnings!
-                                  (send warnings-frame add-warning tag message)
+                                   trec
-                                  (send warnings-frame show #t))))
+                                   (cons (cons tag message)
-                             (force-letrec-transformation
+                                         (trec-warnings trec)))))
-                              (send config get-force-letrec-transformation?)))
+                               (force-letrec-transformation
-                (hide/policy deriv show-macro?))
+                                (send config get-force-letrec-transformation?)))
-              (values deriv (lift/deriv-e2 deriv)))))
+                  (hide/policy deriv show-macro?))
-
+                (values deriv (lift/deriv-e2 deriv)))))
+        (set-trec-synth-deriv! trec synth-deriv)
+        (set-trec-estx! trec estx))
+      
       (define/private (reduce:one-by-one rs)
         (let loop ([rs rs])
           (match rs
@@ -685,19 +700,14 @@
                     (loop rs))]
             ['()
              null])))
-
+      
       (define/private (foci x) (if (list? x) x (list x)))
-
+      
       ;; Hiding policy
-
+      
       (define/private (get-show-macro?)
         (send macro-hiding-prefs get-policy))
-
+      
-      ;; --
-
-      (define/public (shutdown)
-        (when warnings-frame (send warnings-frame show #f)))
-
       ;; Initialization
       
       (super-new)

collects/macro-debugger/view/warning.ss

@@ -3,60 +3,105 @@
   (require (lib "class.ss")
            (lib "mred.ss" "mred")
            (lib "framework.ss" "framework"))
-  (provide warnings-frame%)
+  (provide warnings%
-
+           stepper-warnings%)
-  (define include-message? #f)
+  
-
+  ;; warnings%
-  ;; warnings-frame%
+  (define warnings%
-  (define warnings-frame%
+    (class object%
-    (class frame%
+      (init parent)
-      (super-new (label "Macro stepper warnings") (width 400) (height 300))
+      (super-new)
 
+      (define super-panel
+        (new vertical-panel%
+             (parent parent)
+             (stretchable-height #f)))
+      (define main-panel
+        (new horizontal-panel%
+             (parent super-panel)
+             (style '(deleted border))))
+      (define label (new message% (parent main-panel) (label "Warnings")))
       (define text (new text:hide-caret/selection% (auto-wrap #t)))
-      (define ec (new editor-canvas% (parent this) (editor text)))
+      (define ec
+        (new editor-canvas%
+             (parent main-panel)
+             (editor text)
+             (style '(auto-vscroll auto-hscroll))
+             (line-count 3)))
+      (define dismiss
+        (new button%
+             (parent main-panel)
+             (label "Hide")
+             (stretchable-height #t)
+             (callback (lambda _ (show #f)))))
+      (send text set-autowrap-bitmap #f)
       (send text lock #t)
-
-      (define -nonlinearity-text #f)
-      (define -localactions-text #f)
-      (define -lifts-text #f)
-
-      (define/private (add-nonlinearity-text)
-        (unless -nonlinearity-text
-          (set! -nonlinearity-text #t)
-          (add-text "An opaque macro duplicated one of its subterms. "
-                    "Macro hiding requires opaque macros to use their subterms linearly. "
-                    "The macro stepper is showing the expansion of that macro use.")))
-      (define/private (add-localactions-text)
-        (unless -localactions-text
-          (set! -localactions-text #t)
-          (add-text "An opaque macro called local-expand, syntax-local-lift-expression, "
-                    "etc. Macro hiding cannot currently handle local actions. "
-                    "The macro stepper is showing the expansion of that macro use.")))
-      (define/private (add-lifts-text)
-        (unless -lifts-text
-          (set! -lifts-text #t)
-          (add-text "A transparent macro called syntax-local-lift-expression or "
-                    "syntax-local-lift-module-end-declaration. "
-                    "The macro stepper is only hiding macro after the "
-                    "lifts are caught.")))
-
-      (define/public (add-text . strs)
-        (send text lock #f)
-        (for-each (lambda (s) (send text insert s)) strs)
-        (send text insert "\n\n")
-        (send text lock #t))
       
-      (define/public (add-warning tag message)
+      (define/public (get-text) text)
+      
+      (define/public (show ?)
+        (send super-panel change-children
+              (lambda _
+                (if ?
+                    (list main-panel)
+                    null))))
+      
+      ;; Warning management
+      (define keys null)
+      
+      ;; clear : -> void
+      (define/public (clear)
+        (set! keys null)
+        (send* text
+          (lock #f)
+          (erase)
+          (lock #t))
+        (show #f))
+      
+      ;; add : symbol string ... -> void
+      (define/public (add key . strs)
+        (unless (memq key keys)
+          (send text lock #f)
+          (for-each (lambda (s) (send text insert s)) strs)
+          (send text insert "\n\n")
+          (send text scroll-to-position 0)
+          (send text lock #t)
+          (show #t)))
+      
+      ))
+  
+  (define stepper-warnings%
+    (class warnings%
+      (super-new)
+      (inherit add)
+      
+      (define/private (add-nonlinearity-warning)
+        (add
+         'nonlinearity
+         "An opaque macro duplicated one of its subterms. "
+         "Macro hiding requires opaque macros to use their subterms linearly. "
+         "The macro stepper is showing the expansion of that macro use."))
+      (define/private (add-localactions-warning)
+        (add
+         'localactions
+         "An opaque macro called local-expand, syntax-local-lift-expression, "
+         "etc. Macro hiding cannot currently handle local actions. "
+         "The macro stepper is showing the expansion of that macro use."))
+      (define/private (add-lifts-warning)
+        (add
+         'lifts
+         "A transparent macro called syntax-local-lift-expression or "
+         "syntax-local-lift-module-end-declaration. "
+         "The macro stepper is only hiding macro after the "
+         "lifts are caught."))
+      
+      (define/public (add-warning tag _message)
         (case tag
           ((nonlinearity)
-           (add-nonlinearity-text))
+           (add-nonlinearity-warning))
           ((localactions)
-           (add-localactions-text))
+           (add-localactions-warning))
           ((lifts)
-           (add-lifts-text)))
+           (add-lifts-warning))))))
-        (when include-message?
-          (add-text message)))
-
-      (send this show #t)))
   
-  )
+  )