macro stepper: simplified prefs/params, fixed menu bugs

svn: r12681

original commit: 2648a3b03f01c04755469c5341fb380c6838e853

collects/macro-debugger/syntax-browser/display.ss

@@ -3,7 +3,6 @@
 (require scheme/class
          scheme/gui
          scheme/match
-         "params.ss"
          "pretty-printer.ss"
          "interfaces.ss"
          "util.ss")
@@ -11,8 +10,8 @@
          code-style)
 
 ;; print-syntax-to-editor : syntax text controller<%> -> display<%>
-(define (print-syntax-to-editor stx text controller)
+(define (print-syntax-to-editor stx text controller config)
-  (new display% (syntax stx) (text text) (controller controller)))
+  (new display% (syntax stx) (text text) (controller controller) (config config)))
 
 ;; FIXME: assumes text never moves
 
@@ -22,6 +21,7 @@
     (init ((stx syntax)))
     (init-field text)
     (init-field controller)
+    (init-field config)
 
     (define start-anchor (new anchor-snip%))
     (define end-anchor (new anchor-snip%))
@@ -33,7 +33,7 @@
       (with-unlock text
         (send text delete (get-start-position) (get-end-position))
         (set! range
-              (print-syntax stx text controller
+              (print-syntax stx text controller config
                             (lambda () (get-start-position))
                             (lambda () (get-end-position))))
         (apply-primary-partition-styles))
@@ -131,7 +131,7 @@
         (let ([delta (new style-delta%)])
           (send delta set-delta-foreground color)
           delta))
-      (define color-styles (list->vector (map color-style (current-colors))))
+      (define color-styles (list->vector (map color-style (send config get-colors))))
       (define overflow-style (color-style "darkgray"))
       (define color-partition (send controller get-primary-partition))
       (define offset (get-start-position))
@@ -162,16 +162,20 @@
     (render-syntax stx)
     (send controller add-syntax-display this)))
 
-;; print-syntax : syntax controller (-> number) (-> number)
+;; print-syntax : syntax text% controller config (-> number) (-> number)
 ;;                -> range%
-(define (print-syntax stx text controller
+(define (print-syntax stx text controller config
                       get-start-position get-end-position)
   (define primary-partition (send controller get-primary-partition))
   (define real-output-port (make-text-port text get-end-position))
   (define output-port (open-output-string))
+  (define colors (send config get-colors))
+  (define suffix-option (send config get-suffix-option))
+  (define columns (send config get-columns))
 
   (port-count-lines! output-port)
-  (let ([range (pretty-print-syntax stx output-port primary-partition)])
+  (let ([range (pretty-print-syntax stx output-port primary-partition 
+                                    colors suffix-option columns)])
     (write-string (get-output-string output-port) real-output-port)
     (let ([end (get-end-position)])
       ;; Pretty printer always inserts final newline; we remove it here.
@@ -189,7 +193,7 @@
        (send range all-ranges)))
     ;; Set font to standard
     (send text change-style
-          (code-style text)
+          (code-style text (send config get-syntax-font-size))
           (get-start-position)
           (get-end-position))
     range))
@@ -212,11 +216,10 @@
     (send text insert char pos (add1 pos)))
   (for-each fixup (send range all-ranges)))
 
-;; code-style : text<%> -> style<%>
+;; code-style : text<%> number/#f -> style<%>
-(define (code-style text)
+(define (code-style text font-size)
   (let* ([style-list (send text get-style-list)]
-         [style (send style-list find-named-style "Standard")]
+         [style (send style-list find-named-style "Standard")])
-         [font-size (current-syntax-font-size)])
     (if font-size
         (send style-list find-or-create-style
               style

collects/macro-debugger/syntax-browser/embed.ss

@@ -3,11 +3,9 @@
 (require "interfaces.ss"
          "widget.ss"
          "keymap.ss"
-         "params.ss"
          "partition.ss")
 
 (provide (all-from-out "interfaces.ss")
          (all-from-out "widget.ss")
          (all-from-out "keymap.ss")
-         (all-from-out "params.ss")
          identifier=-choices)

collects/macro-debugger/syntax-browser/frame.ss

@@ -54,8 +54,7 @@
 (define syntax-widget/controls%
   (class* widget% ()
     (inherit get-main-panel
-             get-controller
+             get-controller)
-             toggle-props)
     (super-new)
     (inherit-field config)
 
@@ -85,7 +84,10 @@
     (new button%
          (label "Properties")
          (parent -control-panel)
-         (callback (lambda _ (toggle-props))))
+         (callback
+          (lambda _ 
+            (send config set-props-shown? 
+                  (not (send config get-props-shown?))))))
 
     (send (get-controller) listen-identifier=?
           (lambda (name+func)

collects/macro-debugger/syntax-browser/keymap.ss

@@ -2,6 +2,7 @@
 #lang scheme/base
 (require scheme/class
          scheme/gui
+         "../util/notify.ss"
          "interfaces.ss"
          "partition.ss")
 (provide smart-keymap%
@@ -48,6 +49,7 @@
       (set! on-demand-actions (cons p on-demand-actions)))
 
     (define/override (on-demand)
+      (super on-demand)
       (for-each (lambda (p) (p)) on-demand-actions))
 
     (super-new)))
@@ -92,28 +94,42 @@
                   (lambda (i e)
                     (send config set-props-shown? #f)))
 
-    (define/public (add-edit-items)
+    (define/private (selected-syntax)
+      (send controller get-selected-syntax))
+
+    (define/public (add-menu-items)
       (set! copy-menu
             (new menu-item% (label "Copy") (parent the-context-menu)
-                 (callback (lambda (i e)
+                 (demand-callback
+                  (lambda (i)
+                    (send i enable (and (selected-syntax) #t))))
+                 (callback
+                  (lambda (i e)
                     (call-function "copy-text" i e)))))
-      (void))
+      (add-separator)
-
-    (define/public (after-edit-items)
-      (void))
-
-    (define/public (add-selection-items)
       (set! clear-menu
             (new menu-item%
                  (label "Clear selection")
                  (parent the-context-menu)
+                 (demand-callback
+                  (lambda (i)
+                    (send i enable (and (selected-syntax) #t))))
                  (callback 
                   (lambda (i e)
                     (call-function "clear-syntax-selection" i e)))))
       (set! props-menu
+            (menu-option/notify-box the-context-menu
+                                    "View syntax properties"
+                                    (get-field props-shown? config))
+            #;
             (new menu-item%
                  (label "Show syntax properties")
                  (parent the-context-menu)
+                 (demand-callback
+                  (lambda (i)
+                    (if (send config get-props-shown?)
+                        (send i set-label "Hide syntax properties")
+                        (send i set-label "Show syntax properties"))))
                  (callback 
                   (lambda (i e)
                     (if (send config get-props-shown?)
@@ -121,55 +137,10 @@
                         (call-function "show-syntax-properties" i e))))))
       (void))
 
-    (define/public (after-selection-items)
-      (void))
-
-    (define/public (add-partition-items)
-      (let ([secondary (new menu% (label "identifier=?") (parent the-context-menu))])
-        (for-each
-         (lambda (name func)
-           (let ([this-choice
-                  (new checkable-menu-item%
-                       (label name)
-                       (parent secondary)
-                       (callback 
-                        (lambda (i e)
-                          (send controller set-identifier=? 
-                                (cons name func)))))])
-             (send controller listen-identifier=?
-                   (lambda (name+proc)
-                     (send this-choice check (eq? name (car name+proc)))))))
-         (map car (identifier=-choices))
-         (map cdr (identifier=-choices))))
-      (void))
-
-    (define/public (after-partition-items)
-      (void))
-
     (define/public (add-separator)
       (new separator-menu-item% (parent the-context-menu)))
 
     ;; Initialize menu
 
-    (add-edit-items)
+    (add-menu-items)
-    (after-edit-items)
+    ))
-
-    (add-separator)
-    (add-selection-items)
-    (after-selection-items)
-
-    (add-separator)
-    (add-partition-items)
-    (after-partition-items)
-
-    (send the-context-menu add-on-demand
-          (lambda ()
-            (define stx (send controller get-selected-syntax))
-            (send copy-menu enable (and stx #t))
-            (send clear-menu enable (and stx #t))))
-    (send config listen-props-shown?
-          (lambda (shown?)
-            (send props-menu set-label
-                  (if shown?
-                      "Hide syntax properties"
-                      "Show syntax properties"))))))

collects/macro-debugger/syntax-browser/prefs.ss

@@ -5,13 +5,9 @@
          "interfaces.ss"
          "../util/notify.ss"
          "../util/misc.ss")
-(provide syntax-prefs%
+(provide syntax-prefs-base%
-         syntax-prefs/readonly%
+         syntax-prefs%
-
+         syntax-prefs/readonly%)
-         #;pref:tabify
-         #;pref:height
-         #;pref:width
-         #;pref:props-percentage)
 
 (preferences:set-default 'SyntaxBrowser:Width 700 number?)
 (preferences:set-default 'SyntaxBrowser:Height 600 number?)
@@ -22,13 +18,37 @@
 (pref:get/set pref:height SyntaxBrowser:Height)
 (pref:get/set pref:props-percentage SyntaxBrowser:PropertiesPanelPercentage)
 (pref:get/set pref:props-shown? SyntaxBrowser:PropertiesPanelShown)
-(pref:get/set pref:tabify framework:tabify)
 
 (define syntax-prefs-base%
   (class object%
+    ;; columns : number
+    (field/notify columns (new notify-box% (value 60)))
+
+    ;; suffix-option : SuffixOption
+    (field/notify suffix-option (new notify-box% (value 'over-limit)))
+
+    ;; syntax-font-size : number/#f
+    ;; When non-false, overrides the default font size
+    (field/notify syntax-font-size (new notify-box% (value #f)))
+
+    ;; colors : (listof string)
+    (field/notify colors 
+      (new notify-box%
+           (value '("black" "red" "blue"
+                    "mediumforestgreen" "darkgreen" 
+                    "darkred"
+                    "cornflowerblue" "royalblue" "steelblue" "darkslategray" "darkblue"
+                    "indigo" "purple" 
+                    "orange" "salmon" "darkgoldenrod" "olive"))))
+
+    ;; width, height : number
     (notify-methods width)
     (notify-methods height)
+
+    ;; props-percentage : ...
     (notify-methods props-percentage)
+
+    ;; props-shown? : boolean
     (notify-methods props-shown?)
     (super-new)))
 

collects/macro-debugger/syntax-browser/pretty-helper.ss

@@ -1,8 +1,7 @@
 
 #lang scheme/base
 (require scheme/class
-         syntax/stx
+         syntax/stx)
-         "partition.ss")
 (provide (all-defined-out))
 
 ;; Problem: If stx1 and stx2 are two distinguishable syntax objects, it
@@ -27,7 +26,7 @@
 ;; - 'over-limit        -- suffix > limit
 ;; - 'all-if-over-limit -- suffix > 0 if any over limit
 
-;; syntax->datum/tables : stx [partition% num SuffixOption]
+;; syntax->datum/tables : stx partition% num SuffixOption
 ;;                        -> (values s-expr hashtable hashtable)
 ;; When partition is not false, tracks the partititions that subterms belong to
 ;; When limit is a number, restarts processing with numbering? set to true
@@ -37,10 +36,8 @@
 ;;   - a hashtable mapping S-expressions to syntax objects
 ;;   - a hashtable mapping syntax objects to S-expressions
 ;; Syntax objects which are eq? will map to same flat values
-(define syntax->datum/tables
+(define (syntax->datum/tables stx partition limit suffixopt)
-  (case-lambda
+  (table stx partition limit suffixopt))
-    [(stx) (table stx #f #f 'never)]
-    [(stx partition limit suffixopt) (table stx partition limit suffixopt)]))
 
 ;; table : syntax maybe-partition% maybe-num SuffixOption -> (values s-expr hashtable hashtable)
 (define (table stx partition limit suffixopt)

collects/macro-debugger/syntax-browser/pretty-printer.ss

@@ -7,19 +7,18 @@
          scheme/pretty
          scheme/gui
          "pretty-helper.ss"
-         "interfaces.ss"
+         "interfaces.ss")
-         "params.ss"
-         "prefs.ss")
-
 (provide pretty-print-syntax)
 
-;; pretty-print-syntax : syntax port partition -> range%
+;; pretty-print-syntax :
-(define (pretty-print-syntax stx port primary-partition)
+;;   syntax port partition (listof string) SuffixOption number
+;;   -> range%
+(define (pretty-print-syntax stx port primary-partition colors suffix-option columns)
   (define range-builder (new range-builder%))
   (define-values (datum ht:flat=>stx ht:stx=>flat)
     (syntax->datum/tables stx primary-partition
-                          (length (current-colors))
+                          (length colors)
-                          (current-suffix-option)))
+                          suffix-option))
   (define identifier-list
     (filter identifier? (hash-map ht:stx=>flat (lambda (k v) k))))
   (define (flat=>stx obj)
@@ -53,7 +52,7 @@
     [pretty-print-size-hook pp-size-hook]
     [pretty-print-print-hook pp-print-hook]
     [pretty-print-current-style-table (pp-extend-style-table identifier-list)]
-    [pretty-print-columns (current-default-columns)]
+    [pretty-print-columns columns]
     ;; Printing parameters (mzscheme manual 7.9.1.4)
     [print-unreadable #t]
     [print-graph #f]

collects/macro-debugger/syntax-browser/syntax-snip.ss

@@ -60,7 +60,9 @@
       (send text begin-edit-sequence)
       (send text change-style (make-object style-delta% 'change-alignment 'top))
       (define display
-        (print-syntax-to-editor stx text (send host get-controller)))
+        (print-syntax-to-editor stx text
+                                (send host get-controller)
+                                (send host get-config)))
       (send text lock #t)
       (send text end-edit-sequence)
       (send text hide-caret #t)

collects/macro-debugger/syntax-browser/widget.ss

@@ -8,7 +8,6 @@
          mzlib/kw
          syntax/boundmap
          "interfaces.ss"
-         "params.ss"
          "controller.ss"
          "display.ss"
          "keymap.ss"
@@ -48,15 +47,10 @@
     (send -text set-styles-sticky #f)
     (send -text lock #t)
 
-    ;; syntax-properties-controller<%> methods
-
-    (define/public (props-shown?)
-      (send -props-panel is-shown?))
-
-    (define/public (toggle-props)
-      (show-props (not (send -props-panel is-shown?))))
-
     (define/public (show-props show?)
+      (internal-show-props show?))
+
+    (define/private (internal-show-props show?)
       (if show?
           (unless (send -props-panel is-shown?)
             (let ([p (send config get-props-percentage)])
@@ -67,27 +61,25 @@
             (send -split-panel delete-child -props-panel)
             (send -props-panel show #f))))
 
-    (send config listen-props-percentage
-          (lambda (p)
-            (update-props-percentage p)))
-    (send config listen-props-shown?
-          (lambda (show?)
-            (show-props show?)))
-
     (define/private (update-props-percentage p)
       (send -split-panel set-percentages
             (list (- 1 p) p)))
 
-    ;;
+    (define/private (props-panel-shown?)
-
+      (send -props-panel is-shown?))
-    (define/public (get-controller) controller)
 
     ;;
 
-    (define/public (get-main-panel) -main-panel)
+    (define/public (get-controller)
+      controller)
+
+    ;;
+
+    (define/public (get-main-panel)
+      -main-panel)
 
     (define/public (shutdown)
-      (when (props-shown?)
+      (when (props-panel-shown?)
         (send config set-props-percentage
               (cadr (send -split-panel get-percentages)))))
 
@@ -187,23 +179,31 @@
     ;; internal-add-syntax : syntax -> display
     (define/private (internal-add-syntax stx)
       (with-unlock -text
-        (parameterize ((current-default-columns (calculate-columns)))
+        (let ([display (print-syntax-to-editor stx -text controller config)])
-          (let ([display (print-syntax-to-editor stx -text controller)])
           (send* -text
             (insert "\n")
-              ;(scroll-to-position current-position)
+            ;;(scroll-to-position current-position)
             )
-            display))))
+          display)))
 
     (define/private (calculate-columns)
-      (define style (code-style -text))
+      (define style (code-style -text (send config get-syntax-font-size)))
       (define char-width (send style get-text-width (send -ecanvas get-dc)))
       (define-values (canvas-w canvas-h) (send -ecanvas get-client-size))
       (sub1 (inexact->exact (floor (/ canvas-w char-width)))))
 
     ;; Initialize
     (super-new)
-    (setup-keymap)))
+    (setup-keymap)
+
+    (send config listen-props-shown?
+          (lambda (show?)
+            (show-props show?)))
+    (send config listen-props-percentage
+          (lambda (p)
+            (update-props-percentage p)))
+    (internal-show-props (send config get-props-shown?))))
+
 
 (define clickback-style
   (let ([sd (new style-delta%)])

collects/macro-debugger/view/extensions.ss

@@ -57,8 +57,8 @@
 
     (inherit add-separator)
 
-    (define/override (after-selection-items)
+    (define/override (add-menu-items)
-      (super after-selection-items)
+      (super add-menu-items)
       (add-separator)
       (set! show-macro
             (new menu-item% (label "Show selected identifier") (parent the-context-menu)

collects/macro-debugger/view/frame.ss

@@ -14,7 +14,6 @@
          "warning.ss"
          "hiding-panel.ss"
          (prefix-in sb: "../syntax-browser/embed.ss")
-         (prefix-in sb: "../syntax-browser/params.ss")
          "../model/deriv.ss"
          "../model/deriv-util.ss"
          "../model/trace.ss"
@@ -120,8 +119,8 @@
            (callback (lambda _ (send widget show-in-new-frame)))))
 
     (menu-option/notify-box stepper-menu
-                            "Show syntax properties"
+                            "View syntax properties"
-                            (get-field show-syntax-properties? config))
+                            (get-field props-shown? config))
 
     (let ([id-menu
            (new (get-menu%)
@@ -175,7 +174,7 @@
            (parent extras-menu)
            (callback
             (lambda (i e)
-              (sb:current-suffix-option
+              (send config set-suffix-option
                     (if (send i is-checked?)
                         'always
                         'over-limit))

collects/macro-debugger/view/interfaces.ss

@@ -5,6 +5,7 @@
 
 ;; Signatures
 
+#;
 (define-signature view^
   (macro-stepper-frame%
    macro-stepper-widget%
@@ -12,12 +13,15 @@
    go
    go/deriv))
 
+#;
 (define-signature view-base^
   (base-frame%))
 
+#;
 (define-signature prefs^
   (pref:width
    pref:height
+   pref:props-shown?
    pref:props-percentage
    pref:macro-hiding-mode
    pref:show-syntax-properties?

collects/macro-debugger/view/prefs.ss

@@ -2,6 +2,7 @@
 #lang scheme/base
 (require scheme/class
          framework/framework
+         "../syntax-browser/prefs.ss"
          "../util/notify.ss"
          "../util/misc.ss")
 (provide macro-stepper-config-base%
@@ -30,7 +31,6 @@
 (pref:get/set pref:props-shown? MacroStepper:PropertiesShown?)
 (pref:get/set pref:props-percentage MacroStepper:PropertiesPanelPercentage)
 (pref:get/set pref:macro-hiding-mode MacroStepper:MacroHidingMode)
-(pref:get/set pref:show-syntax-properties? MacroStepper:ShowSyntaxProperties?)
 (pref:get/set pref:show-hiding-panel? MacroStepper:ShowHidingPanel?)
 (pref:get/set pref:identifier=? MacroStepper:IdentifierComparison)
 (pref:get/set pref:highlight-foci? MacroStepper:HighlightFoci?)
@@ -43,13 +43,8 @@
 (pref:get/set pref:force-letrec-transformation? MacroStepper:ForceLetrecTransformation?)
 
 (define macro-stepper-config-base%
-  (class object%
+  (class syntax-prefs-base%
-    (notify-methods width)
-    (notify-methods height)
-    (notify-methods props-shown?)
-    (notify-methods props-percentage)
     (notify-methods macro-hiding-mode)
-    (notify-methods show-syntax-properties?)
     (notify-methods show-hiding-panel?)
     (notify-methods identifier=?)
     (notify-methods highlight-foci?)
@@ -66,10 +61,9 @@
   (class macro-stepper-config-base%
     (connect-to-pref width pref:width)
     (connect-to-pref height pref:height)
-    (connect-to-pref props-shown? pref:props-shown?)
     (connect-to-pref props-percentage pref:props-percentage)
+    (connect-to-pref props-shown? pref:props-shown?)
     (connect-to-pref macro-hiding-mode pref:macro-hiding-mode)
-    (connect-to-pref show-syntax-properties? pref:show-syntax-properties?)
     (connect-to-pref show-hiding-panel? pref:show-hiding-panel?)
     (connect-to-pref identifier=? pref:identifier=?)
     (connect-to-pref highlight-foci? pref:highlight-foci?)
@@ -88,7 +82,6 @@
     (connect-to-pref/readonly height pref:height)
     (connect-to-pref/readonly macro-hiding-mode pref:macro-hiding-mode)
     (connect-to-pref/readonly props-percentage pref:props-percentage)
-    (connect-to-pref/readonly show-syntax-properties? pref:show-syntax-properties?)
     (connect-to-pref/readonly show-hiding-panel? pref:show-hiding-panel?)
     (connect-to-pref/readonly identifier=? pref:identifier=?)
     (connect-to-pref/readonly highlight-foci? pref:highlight-foci?)

collects/macro-debugger/view/stepper.ss

@@ -13,8 +13,6 @@
          "warning.ss"
          "hiding-panel.ss"
          "term-record.ss"
-         (prefix-in s: "../syntax-browser/widget.ss")
-         (prefix-in s: "../syntax-browser/params.ss")
          "../model/deriv.ss"
          "../model/deriv-util.ss"
          "../model/deriv-find.ss"
@@ -138,10 +136,11 @@
            (stepper this)
            (config config)))
 
+    #;
     (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?)))
+          (lambda (show?) (show-macro-hiding-panel show?)))
     (send sbc listen-selected-syntax
           (lambda (stx) (send macro-hiding-prefs set-syntax stx)))
     (send config listen-highlight-foci?
@@ -215,7 +214,7 @@
                         nav:next
                         nav:end)))))
 
-    (define/public (show-macro-hiding-prefs show?)
+    (define/public (show-macro-hiding-panel show?)
       (send area change-children
             (lambda (children)
               (if show?
@@ -423,8 +422,8 @@
     ;; Initialization
 
     (super-new)
-    (send sbview show-props (send config get-show-syntax-properties?))
+    #;(send sbview show-props (send config get-show-syntax-properties?))
-    (show-macro-hiding-prefs (send config get-show-hiding-panel?))
+    (show-macro-hiding-panel (send config get-show-hiding-panel?))
     (show-extra-navigation (send config get-extra-navigation?))
     (refresh/move)
     ))

collects/macro-debugger/view/term-record.ss

@@ -12,8 +12,6 @@
          "extensions.ss"
          "warning.ss"
          "hiding-panel.ss"
-         (prefix-in s: "../syntax-browser/widget.ss")
-         (prefix-in s: "../syntax-browser/params.ss")
          "../model/deriv.ss"
          "../model/deriv-util.ss"
          "../model/deriv-find.ss"