Macro stepper: added new options, new command (show in new frame)

svn: r5933

collects/macro-debugger/view/gui.ss

@@ -12,6 +12,7 @@
            "warning.ss"
            "hiding-panel.ss"
            (prefix sb: "../syntax-browser/embed.ss")
+           (prefix sb: "../syntax-browser/params.ss")
            "../model/deriv.ss"
            "../model/deriv-util.ss"
            "../model/trace.ss"
@@ -78,6 +79,8 @@
                         (notify-box/pref pref:hide-libs?))
           (field/notify highlight-foci?
                         (notify-box/pref pref:highlight-foci?))
+          (field/notify highlight-frontier?
+                        (notify-box/pref pref:highlight-frontier?))
           (field/notify show-rename-steps?
                         (notify-box/pref pref:show-rename-steps?))
           (field/notify suppress-warnings?
@@ -88,6 +91,8 @@
                         (notify-box/pref pref:extra-navigation?))
           (field/notify debug-catch-errors?
                         (notify-box/pref pref:debug-catch-errors?))
+          (field/notify force-letrec-transformation?
+                        (notify-box/pref pref:force-letrec-transformation?))
           (super-new)))
 
       (define macro-stepper-frame%
@@ -189,13 +194,28 @@
           (menu-option/notify-box stepper-menu
                                   "Show macro hiding panel"
                                   (get-field show-hiding-panel? config))
+          (new (get-menu-item%) (label "Show in new frame") (parent stepper-menu)
+               (callback (lambda _ (send widget show-in-new-frame))))
           (let ([extras-menu
                  (new (get-menu%)
                       (label "Extra options")
                       (parent stepper-menu))])
+            (new checkable-menu-item%
+                 (label "Always suffix marked identifiers")
+                 (parent extras-menu)
+                 (callback
+                  (lambda (i e)
+                    (sb:current-suffix-option
+                     (if (send i is-checked?)
+                         'always
+                         'over-limit))
+                    (send widget update/preserve-view))))
             (menu-option/notify-box extras-menu
                                     "Highlight redex/contractum"
                                     (get-field highlight-foci? config))
+            (menu-option/notify-box extras-menu
+                                    "Highlight frontier"
+                                    (get-field highlight-frontier? config))
             (menu-option/notify-box extras-menu
                                     "Include renaming steps"
                                     (get-field show-rename-steps? config))
@@ -208,6 +228,9 @@
             (menu-option/notify-box extras-menu
                                     "Extra navigation"
                                     (get-field extra-navigation? config))
+            (menu-option/notify-box extras-menu
+                                    "Force block->letrec transformation"
+                                    (get-field force-letrec-transformation? config))
             (menu-option/notify-box extras-menu
                                     "(Debug) Catch internal errors?"
                                     (get-field debug-catch-errors? config)))
@@ -252,6 +275,7 @@
               (for-each (lambda (id) (module-identifier-mapping-put! alpha-table id id))
                         (extract-all-fresh-names d))
               (cursor:add-to-end! terms (list (new-trec d)))
+              (trim-navigator)
               (if needs-display?
                   (refresh/move)
                   (update))))
@@ -297,22 +321,20 @@
 
           (send config listen-show-syntax-properties?
                 (lambda (show?) (send sbview show-props show?)))
-
           (send config listen-show-hiding-panel?
                 (lambda (show?) (show-macro-hiding-prefs show?)))
-
           (send sbc add-selection-listener
                 (lambda (stx) (send macro-hiding-prefs set-syntax stx)))
-
           (send config listen-highlight-foci?
                 (lambda (_) (update/preserve-view)))
-
+          (send config listen-highlight-frontier?
+                (lambda (_) (update/preserve-view)))
           (send config listen-show-rename-steps?
                 (lambda (_) (refresh/re-reduce)))
-
           (send config listen-one-by-one?
                 (lambda (_) (refresh/re-reduce)))
-
+          (send config listen-force-letrec-transformation?
+                (lambda (_) (refresh/resynth)))
           (send config listen-extra-navigation?
                 (lambda (show?) (show-extra-navigation show?)))
 
@@ -335,6 +357,23 @@
             (new button% (label "Next term") (parent navigator)
                  (callback (lambda (b e) (navigate-down)))))
 
+          (define/private (trim-navigator)
+            (if (> (length (cursor->list terms)) 1)
+                (send navigator change-children
+                      (lambda _
+                        (list nav:up
+                              nav:start
+                              nav:previous
+                              nav:next
+                              nav:end
+                              nav:down)))
+                (send navigator change-children
+                      (lambda _
+                        (list nav:start
+                              nav:previous
+                              nav:next
+                              nav:end)))))
+
           (define/public (show-macro-hiding-prefs show?)
             (send area change-children
                   (lambda (children)
@@ -342,6 +381,10 @@
                         (append (remq control-pane children) (list control-pane))
                         (remq control-pane children)))))
 
+          (define/public (show-in-new-frame)
+            (when (cursor:next terms)
+              (go/deriv (trec-deriv (cursor:next terms)))))
+
           (define/private (show-extra-navigation show?)
             (send supernavigator change-children
                   (lambda (children)
@@ -563,29 +606,23 @@
                   '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
+                  #:definites definites
+                  #:alpha-table alpha-table
+                  #:hi-color hi-color
+                  #:hi-stxs (if (send config get-highlight-foci?) foci null)
+                  #:hi2-color "WhiteSmoke"
+                  #:hi2-stxs (if (send config get-highlight-frontier?) frontier null)))
+
           ;; insert-syntax/redex : syntax syntaxes identifiers syntaxes -> void
           (define/private (insert-syntax/redex stx foci definites frontier)
-            (if (send config get-highlight-foci?)
+            (insert-syntax/color stx foci definites frontier "MistyRose"))
-                (send sbview add-syntax stx
-                      #:hi-stxs foci #:hi-color "MistyRose"
-                      #:alpha-table alpha-table
-                      #:definites definites
-                      #:hi2-stxs frontier #:hi2-color "WhiteSmoke")
-                (send sbview add-syntax stx
-                      #:alpha-table alpha-table
-                      #:definites definites)))
 
           ;; insert-syntax/contractum : syntax syntaxes identifiers syntaxes -> void
           (define/private (insert-syntax/contractum stx foci definites frontier)
-            (if (send config get-highlight-foci?)
+            (insert-syntax/color stx foci definites frontier "LightCyan"))
-                (send sbview add-syntax stx
-                      #:hi-stxs foci #:hi-color "LightCyan"
-                      #:alpha-table alpha-table
-                      #:definites definites
-                      #:hi2-stxs frontier #:hi2-color "WhiteSmoke")
-                (send sbview add-syntax stx
-                      #:alpha-table alpha-table
-                      #:definites definites)))
 
           ;; enable/disable-buttons : -> void
           (define/private (enable/disable-buttons)
@@ -605,7 +642,7 @@
             (for-each trec:invalidate-synth! (cursor->list terms))
             (refresh))
 
-          ;; refres/re-reduce : -> void
+          ;; 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))
@@ -748,8 +785,10 @@
                                     (unless (send config get-suppress-warnings?)
                                       (unless warnings-frame
                                         (set! warnings-frame (new warnings-frame%)))
-                                      (send warnings-frame add-warning tag)
+                                      (send warnings-frame add-warning tag message)
-                                      (send warnings-frame show #t)))))
+                                      (send warnings-frame show #t))))
+                                 (force-letrec-transformation
+                                  (send config get-force-letrec-transformation?)))
                     (hide/policy deriv show-macro?))
                   (values deriv (lift/deriv-e2 deriv)))))
 

collects/macro-debugger/view/interfaces.ss

@@ -27,10 +27,12 @@
      pref:identifier=?
      pref:show-rename-steps?
      pref:highlight-foci?
+     pref:highlight-frontier?
      pref:suppress-warnings?
      pref:one-by-one?
      pref:extra-navigation?
      pref:debug-catch-errors?
+     pref:force-letrec-transformation?
      ))
 
   ;; macro-stepper-config%

collects/macro-debugger/view/prefs.ss

@@ -13,11 +13,6 @@
            [() (preferences:get 'prop)]
            [(newval) (preferences:set 'prop newval)]))]))
 
-  (define prefs@
-    (unit
-      (import)
-      (export prefs^)
-      
   (preferences:set-default 'MacroStepper:Frame:Width 700 number?)
   (preferences:set-default 'MacroStepper:Frame:Height 600 number?)
   (preferences:set-default 'MacroStepper:PropertiesPanelPercentage 1/3 number?)
@@ -28,11 +23,18 @@
   (preferences:set-default 'MacroStepper:HideLibs? #t boolean?)
   (preferences:set-default 'MacroStepper:IdentifierComparison "bound-identifier=?" string?)
   (preferences:set-default 'MacroStepper:HighlightFoci? #t boolean?)
+  (preferences:set-default 'MacroStepper:HighlightFrontier? #t boolean?)
   (preferences:set-default 'MacroStepper:ShowRenameSteps? #f boolean?)
   (preferences:set-default 'MacroStepper:SuppressWarnings? #f boolean?)
   (preferences:set-default 'MacroStepper:OneByOne? #f boolean?)
   (preferences:set-default 'MacroStepper:ExtraNavigation? #f boolean?)
   (preferences:set-default 'MacroStepper:DebugCatchErrors? #t boolean?)
+  (preferences:set-default 'MacroStepper:ForceLetrecTransformation? #f boolean?)
+
+  (define prefs@
+    (unit
+      (import)
+      (export prefs^)
       
       (pref:get/set pref:width MacroStepper:Frame:Width)
       (pref:get/set pref:height MacroStepper:Frame:Height)
@@ -44,11 +46,13 @@
       (pref:get/set pref:hide-libs? MacroStepper:HideLibs?)
       (pref:get/set pref:identifier=? MacroStepper:IdentifierComparison)
       (pref:get/set pref:highlight-foci? MacroStepper:HighlightFoci?)
+      (pref:get/set pref:highlight-frontier? MacroStepper:HighlightFrontier?)
       (pref:get/set pref:show-rename-steps? MacroStepper:ShowRenameSteps?)
       (pref:get/set pref:suppress-warnings? MacroStepper:SuppressWarnings?)
       (pref:get/set pref:one-by-one? MacroStepper:OneByOne?)
       (pref:get/set pref:extra-navigation? MacroStepper:ExtraNavigation?)
       (pref:get/set pref:debug-catch-errors? MacroStepper:DebugCatchErrors?)
+      (pref:get/set pref:force-letrec-transformation? MacroStepper:ForceLetrecTransformation?)
       
       ))
   )

collects/macro-debugger/view/warning.ss

@@ -5,6 +5,8 @@
            (lib "framework.ss" "framework"))
   (provide warnings-frame%)
 
+  (define include-message? #f)
+
   ;; warnings-frame%
   (define warnings-frame%
     (class frame%
@@ -44,14 +46,16 @@
         (send text insert "\n\n")
         (send text lock #t))
       
-      (define/public (add-warning tag)
+      (define/public (add-warning tag message)
         (case tag
           ((nonlinearity)
            (add-nonlinearity-text))
           ((localactions)
            (add-localactions-text))
           ((lifts)
-           (add-lifts-text))))
+           (add-lifts-text)))
+        (when include-message?
+          (add-text message)))
 
       (send this show #t)))