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

svn: r5933
2007-04-13 21:33:34 +00:00 · 2007-04-13 21:33:34 +00:00 · b49fbe2765
commit b49fbe2765
parent d29f1d82fc
4 changed files with 94 additions and 45 deletions
--- a/collects/macro-debugger/view/gui.ss
+++ b/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?)
-                (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/color stx foci definites frontier "MistyRose"))

          ;; insert-syntax/contractum : syntax syntaxes identifiers syntaxes -> void
          (define/private (insert-syntax/contractum stx foci definites frontier)
-            (if (send config get-highlight-foci?)
-                (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)))
+            (insert-syntax/color stx foci definites frontier "LightCyan"))

          ;; 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 show #t)))))
+                                      (send warnings-frame add-warning tag message)
+                                      (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)))))

--- a/collects/macro-debugger/view/interfaces.ss
+++ b/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%
--- a/collects/macro-debugger/view/prefs.ss
+++ b/collects/macro-debugger/view/prefs.ss
@ -13,27 +13,29 @@
           [() (preferences:get 'prop)]
           [(newval) (preferences:set 'prop newval)]))]))

+  (preferences:set-default 'MacroStepper:Frame:Width 700 number?)
+  (preferences:set-default 'MacroStepper:Frame:Height 600 number?)
+  (preferences:set-default 'MacroStepper:PropertiesPanelPercentage 1/3 number?)
+  (preferences:set-default 'MacroStepper:MacroHiding? #t boolean?)
+  (preferences:set-default 'MacroStepper:ShowSyntaxProperties? #f boolean?)
+  (preferences:set-default 'MacroStepper:ShowHidingPanel? #t boolean?)
+  (preferences:set-default 'MacroStepper:HidePrimitives? #t boolean?)
+  (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^)
      
-      (preferences:set-default 'MacroStepper:Frame:Width 700 number?)
-      (preferences:set-default 'MacroStepper:Frame:Height 600 number?)
-      (preferences:set-default 'MacroStepper:PropertiesPanelPercentage 1/3 number?)
-      (preferences:set-default 'MacroStepper:MacroHiding? #t boolean?)
-      (preferences:set-default 'MacroStepper:ShowSyntaxProperties? #f boolean?)
-      (preferences:set-default 'MacroStepper:ShowHidingPanel? #t boolean?)
-      (preferences:set-default 'MacroStepper:HidePrimitives? #t boolean?)
-      (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: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?)
-      
      (pref:get/set pref:width MacroStepper:Frame:Width)
      (pref:get/set pref:height MacroStepper:Frame:Height)
      (pref:get/set pref:props-percentage MacroStepper:PropertiesPanelPercentage)
@ -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?)
      
      ))
  )
--- a/collects/macro-debugger/view/warning.ss
+++ b/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)))