Fixed eol properties

Reorganized macro stepper gui
Added macro stepper actions to popup menu

svn: r4505

original commit: 39145f9c71807baf1e97d66db63f135fbf7e2999

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

@@ -1,11 +1,15 @@
 
 (module embed mzscheme
   (require "interfaces.ss"
+           "widget.ss"
+           "keymap.ss"
            "implementation.ss"
            "params.ss"
            "partition.ss")
   
   (provide (all-from "interfaces.ss")
+           (all-from "widget.ss")
+           (all-from "keymap.ss")
            (all-from "implementation.ss")
            (all-from "params.ss")
            identifier=-choices))

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

@@ -4,7 +4,9 @@
            (lib "unitsig.ss")
            (lib "mred.ss" "mred")
            (lib "framework.ss" "framework")
-           "interfaces.ss")
+           (lib "list.ss")
+           "interfaces.ss"
+           "partition.ss")
   (provide frame@)
   
   (define frame@
@@ -47,5 +49,49 @@
             (send widget save-prefs)
             (preferences:save)
             (inner (void) on-close))
-          ))))
+          ))
+      
+      ;; syntax-widget/controls%
+      (define syntax-widget/controls%
+        (class* syntax-widget% ()
+          (inherit get-main-panel
+                   get-controller
+                   toggle-props)
+          (super-new)
+          
+          (define -control-panel 
+            (new horizontal-pane% (parent (get-main-panel)) (stretchable-height #f)))
+          
+          ;; Put the control panel up front
+          (send (get-main-panel) change-children
+                (lambda (children)
+                  (cons -control-panel (remq -control-panel children))))
+          
+          (define -identifier=-choices (identifier=-choices))
+          (define -choice
+            (new choice% (label "identifer=?") (parent -control-panel)
+                 (choices (map car -identifier=-choices))
+                 (callback (lambda _ (on-update-identifier=?-choice)))))
+          (new button% 
+               (label "Clear")
+               (parent -control-panel)
+               (callback (lambda _ (send (get-controller) select-syntax #f))))
+          (new button%
+               (label "Properties")
+               (parent -control-panel)
+               (callback (lambda _ (toggle-props))))
+          
+          (define/private (on-update-identifier=?-choice)
+            (cond [(assoc (send -choice get-string-selection)
+                          -identifier=-choices)
+                   => (lambda (p)
+                        (send (get-controller)
+                              on-update-identifier=? (car p) (cdr p)))]
+                  [else #f]))
+          (send (get-controller) add-identifier=?-listener
+                (lambda (name func)
+                  (send -choice set-selection
+                        (or (send -choice find-string name) 0))))))
+      
+      ))
   )

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

@@ -16,6 +16,9 @@
      ;; make-syntax-browser : -> syntax-browser<%>
      make-syntax-browser
      
+     ;; syntax-widget/controls%
+     syntax-widget/controls%
+     
      ;; syntax-browser-frame%
      syntax-browser-frame%))
 
@@ -50,10 +53,7 @@
   
   (define-signature widget^
     (;; syntax-widget%
-     syntax-widget%
+     syntax-widget%))
-     
-     ;; syntax-widget/controls%
-     syntax-widget/controls%))
 
   (define-signature implementation^
     ([unit widget : widget^]
@@ -97,8 +97,8 @@
       ;; show : boolean -> void
       #;show
       
-      ;; is-shown? : -> boolean
+      ;; props-shown? : -> boolean
-      #;is-shown?))
+      props-shown?))
 
   ;; syntax-configuration<%>
   (define syntax-configuration<%>

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

@@ -49,7 +49,12 @@
           (init-field controller)
           (super-new)
 
+          (define copy-menu #f)
+          (define copy-syntax-menu #f)
+          (define clear-menu #f)
+          
           (define/public (add-edit-items)
+            (set! copy-menu
                   (new menu-item% (label "Copy") (parent this)
                        (callback (lambda (i e)
                                    (define stx (send controller get-selected-syntax))
@@ -57,7 +62,8 @@
                                          (if stx 
                                              (format "~s" (syntax-object->datum stx))
                                              "")
-                                   (send e get-time-stamp)))))
+                                         (send e get-time-stamp))))))
+            (set! copy-syntax-menu
                   (new menu-item% (label "Copy syntax") (parent this)
                        (callback (lambda (i e)
                                    (define stx (send controller get-selected-syntax))
@@ -67,17 +73,18 @@
                                               (syntax stx)
                                               #;(controller controller)))
                                    (send t select-all)
-                             (send t copy))))
+                                   (send t copy)))))
             (void))
 
           (define/public (after-edit-items)
             (void))
 
           (define/public (add-selection-items)
+            (set! clear-menu
                   (new menu-item%
                        (label "Clear selection")
                        (parent this)
-                 (callback (lambda _ (send controller select-syntax #f))))
+                       (callback (lambda _ (send controller select-syntax #f)))))
             (void))
           
           (define/public (after-selection-items)
@@ -107,6 +114,13 @@
           (define/public (add-separator)
             (new separator-menu-item% (parent this)))
 
+          (define/override (on-demand)
+            (define stx (send controller get-selected-syntax))
+            (send copy-menu enable (and stx #t))
+            (send copy-syntax-menu enable (and stx #t))
+            (send clear-menu enable (and stx #t))
+            (super on-demand))
+
           ;; Initialization
           (add-edit-items)
           (after-edit-items)

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

@@ -105,8 +105,8 @@
           
           (define -outer (new text%))
           (super-new (editor -outer) (with-border? #f))
-          (set-margin 2 0 0 0)
+          (set-margin 0 0 0 0)
-          (set-inset 3 0 0 0)
+          (set-inset 0 0 0 0)
           (set-snipclass snip-class)
           (send -outer select-all)
           (send -outer change-style (make-object style-delta% 'change-alignment 'top)
@@ -195,7 +195,7 @@
             (send pv set-syntax stx))
           (define/public (show ?)
             (send parent show ?))
-          (define/public (is-shown?)
+          (define/public (props-shown?)
             (send parent is-shown?))
           (super-new)))
       ))

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

@@ -11,7 +11,6 @@
            "typesetter.ss"
            "hrule-snip.ss"
            "properties.ss"
-           "partition.ss"
            "util.ss")
   (provide widget@
            widget-context-menu-extension@)
@@ -40,9 +39,12 @@
             (new syntax-controller%
                  (properties-controller this)))
           
+          (define/public (make-context-menu)
+            (new context-menu% (widget this)))
+          
           (new syntax-keymap% 
                (editor -text)
-               (context-menu (new context-menu% (widget this))))
+               (context-menu (make-context-menu)))
           
           ;; FIXME: Why doesn't this work?
           #;
@@ -68,7 +70,7 @@
           (define/public (show ?)
             (if ? (show-props) (hide-props)))
           
-          (define/public (is-shown?)
+          (define/public (props-shown?)
             (send -props-panel is-shown?))
           
           (define/public (toggle-props)
@@ -152,47 +154,6 @@
           
           (super-new)))
       
-      ;; syntax-widget/controls%
-      (define syntax-widget/controls%
-        (class* syntax-widget% ()
-          (inherit get-main-panel
-                   get-controller
-                   toggle-props)
-          (super-new)
-          
-          (define -control-panel 
-            (new horizontal-pane% (parent (get-main-panel)) (stretchable-height #f)))
-          
-          ;; Put the control panel up front
-          (send (get-main-panel) change-children
-                (lambda (children)
-                  (cons -control-panel (remq -control-panel children))))
-          
-          (define -identifier=-choices (identifier=-choices))
-          (define -choice
-            (new choice% (label "identifer=?") (parent -control-panel)
-                 (choices (map car -identifier=-choices))
-                 (callback (lambda _ (on-update-identifier=?-choice)))))
-          (new button% 
-               (label "Clear")
-               (parent -control-panel)
-               (callback (lambda _ (send (get-controller) select-syntax #f))))
-          (new button%
-               (label "Properties")
-               (parent -control-panel)
-               (callback (lambda _ (toggle-props))))
-          
-          (define/private (on-update-identifier=?-choice)
-            (cond [(assoc (send -choice get-string-selection)
-                          -identifier=-choices)
-                   => (lambda (p)
-                        (send (get-controller)
-                              on-update-identifier=? (car p) (cdr p)))]
-                  [else #f]))
-          (send (get-controller) add-identifier=?-listener
-                (lambda (name func)
-                  (send -choice set-selection
-                        (or (send -choice find-string name) 0))))))
       ))
 
   (define widget-context-menu-extension@
@@ -203,13 +164,23 @@
         (class pre:context-menu%
           (init-field widget)
           
+          (define props-menu #f)
+
           (define/override (after-selection-items)
             (super after-selection-items)
+            (set! props-menu
                   (new menu-item% (label "Show/hide syntax properties")
                        (parent this)
-                 (callback (lambda _ (send widget toggle-props))))
+                       (callback (lambda _ (send widget toggle-props)))))
             (void))
           
+          (define/override (on-demand)
+            (send props-menu set-label
+                  (if (send widget props-shown?)
+                      "Hide syntax properties"
+                      "Show syntax properties"))
+            (super on-demand))
+          
           (super-new (controller (send widget get-controller)))))))
 
   (define browser-text% (editor:standard-style-list-mixin text:basic%))

collects/macro-debugger/view/hiding-panel.ss

@@ -0,0 +1,223 @@
+
+(module hiding-panel mzscheme
+  (require (lib "class.ss")
+           (lib "mred.ss" "mred")
+           (lib "list.ss")
+           (lib "boundmap.ss" "syntax")
+           "../model/hiding-policies.ss"
+           "../syntax-browser/util.ss")
+  (provide macro-hiding-prefs-widget%)
+  
+  ;; macro-hiding-prefs-widget%
+  (define macro-hiding-prefs-widget%
+    (class object%
+      (init parent)
+      (init-field stepper)
+      (init-field policy)
+      (init-field (enabled? #f))
+      
+      (define stx #f)
+      (define stx-name #f)
+      (define stx-module #f)
+      
+      (define super-pane
+        (new horizontal-pane%
+             (parent parent)
+             (stretchable-height #f)))
+      (define left-pane
+        (new vertical-pane%
+             (parent super-pane)
+             (stretchable-width #f)
+             (alignment '(left top))))
+      (define right-pane
+        (new vertical-pane%
+             (parent super-pane)))
+      
+      (define enable-ctl
+        (new check-box% 
+             (label "Enable macro hiding?")
+             (parent left-pane)
+             (value enabled?) 
+             (callback
+              (lambda _
+                (set! enabled? (send enable-ctl get-value))
+                (force-refresh)))))
+      
+      (define kernel-ctl
+        (new check-box%
+             (label "Hide mzscheme syntax")
+             (parent left-pane)
+             (value (hiding-policy-opaque-kernel policy))
+             (callback (lambda _
+                         (if (send kernel-ctl get-value)
+                             (policy-hide-kernel policy)
+                             (policy-unhide-kernel policy))
+                         (refresh)))))
+      (define libs-ctl
+        (new check-box%
+             (label "Hide library syntax")
+             (parent left-pane)
+             (value (hiding-policy-opaque-libs policy))
+             (callback (lambda _
+                         (if (send libs-ctl get-value)
+                             (policy-hide-libs policy)
+                             (policy-unhide-libs policy))
+                         (refresh)))))
+      
+      (define look-pane
+        (new horizontal-pane% (parent right-pane) (stretchable-height #f)))
+      (define look-ctl
+        (new list-box% (parent look-pane) (label "") (choices null)))
+      (define delete-ctl
+        (new button% (parent look-pane) (label "Delete")
+             (callback
+              (lambda _
+                (delete-selected)
+                (refresh)))))
+      
+      (define add-pane
+        (new horizontal-pane% (parent right-pane) (stretchable-height #f)))
+      (define add-text
+        (new text-field%
+             (label "")
+             (parent add-pane)
+             (stretchable-width #t)))
+      (define add-editor (send add-text get-editor))
+      (define add-hide-module-button
+        (new button% (parent add-pane) (label "Hide module") (enabled #f)
+             (callback (lambda _ (add-hide-module) (refresh)))))
+      (define add-hide-id-button
+        (new button% (parent add-pane) (label "Hide macro") (enabled #f)
+             (callback (lambda _ (add-hide-identifier) (refresh)))))
+      (define add-show-id-button
+        (new button% (parent add-pane) (label "Show macro") (enabled #f)
+             (callback (lambda _ (add-show-identifier) (refresh)))))
+      
+      (send add-editor lock #t)
+      
+      ;; Methods
+      
+      ;; enable-hiding : boolean -> void
+      ;; Called only by stepper, which does it's own refresh
+      (define/public (enable-hiding ok?)
+        (set! enabled? ok?))
+      
+      ;; get-enabled?
+      (define/public (get-enabled?) enabled?)
+      
+      ;; get-policy
+      (define/public (get-policy) policy)
+      
+      ;; refresh
+      (define/private (refresh)
+        (when enabled?
+          (send stepper refresh/resynth)))
+      
+      ;; force-refresh
+      (define/private (force-refresh)
+        (send stepper refresh/resynth))
+      
+      ;; set-syntax : syntax/#f -> void
+      (define/public (set-syntax lstx)
+        (set! stx lstx)
+        (send add-editor lock #f)
+        (send add-editor erase)
+        (unless (identifier? stx)
+          (send add-hide-module-button enable #f))
+        (when (identifier? stx)
+          (let ([binding (identifier-binding stx)])
+            (send add-hide-module-button enable (pair? binding))
+            (if (pair? binding)
+                (begin
+                  (set! stx-name (cadr binding))
+                  (set! stx-module (car binding)))
+                (begin
+                  (set! stx-name (syntax-e stx))
+                  (set! stx-module #f)))
+            (update-add-text)))
+        (send add-editor lock #t)
+        (send add-show-id-button enable (identifier? lstx))
+        (send add-hide-id-button enable (identifier? lstx)))
+      
+      (define/private (update-add-text)
+        (send add-editor lock #f)
+        (when (identifier? stx)
+          (send add-editor insert (identifier-text "" stx)))
+        (send add-editor lock #t))
+      
+      (define/public (add-hide-module)
+        (when stx-module
+          (policy-hide-module policy stx-module)
+          (update-list-view)))
+      
+      (define/public (add-hide-identifier)
+        (when (identifier? stx)
+          (policy-hide-id policy stx)
+          (update-list-view)))
+      
+      (define/public (add-show-identifier)
+        (when (identifier? stx)
+          (policy-show-id policy stx)
+          (update-list-view)))
+      
+      (define/private (delete-selected)
+        (for-each (lambda (n)
+                    (let ([d (send look-ctl get-data n)])
+                      (case (car d)
+                        ((identifier) (policy-unhide-id policy (cdr d)))
+                        ((show-identifier) (policy-unshow-id policy (cdr d)))
+                        ((module) (policy-unhide-module policy (cdr d))))))
+                  (send look-ctl get-selections))
+        (update-list-view))
+      
+      (define/private (identifier-text prefix id)
+        (let ([b (identifier-binding id)])
+          (cond [(pair? b)
+                 (let ([name (cadr b)]
+                       [mod (car b)])
+                   (format "~a'~s' from module ~a"
+                           prefix
+                           name
+                           (mpi->string mod)))]
+                [(eq? b 'lexical)
+                 (format "~alexically bound '~s'"
+                         prefix
+                         (syntax-e id))]
+                [(not b)
+                 (format "~aglobal or unbound '~s'" prefix (syntax-e id))])))
+      
+      (define/private (update-list-view)
+        (let ([opaque-modules
+               (hash-table-map (hiding-policy-opaque-modules policy)
+                               (lambda (k v) k))]
+              [opaque-ids
+               (filter values
+                       (module-identifier-mapping-map
+                        (hiding-policy-opaque-ids policy)
+                        (lambda (k v) (and v k))))]
+              [transparent-ids
+               (filter values
+                       (module-identifier-mapping-map
+                        (hiding-policy-transparent-ids policy)
+                        (lambda (k v) (and v k))))])
+          (define (om s)
+            (cons (format "hide from module ~a" (mpi->string s))
+                  (cons 'module s)))
+          (define (*i prefix tag id)
+            (cons (identifier-text prefix id)
+                  (cons tag id)))
+          (define (oid id) (*i "hide " 'identifier id))
+          (define (tid id) (*i "show " 'show-identifier id))
+          (let ([choices
+                 (sort (append (map om opaque-modules)
+                               (map oid opaque-ids)
+                               (map tid transparent-ids))
+                       (lambda (a b)
+                         (string<=? (car a) (car b))))])
+            (send look-ctl clear)
+            (for-each (lambda (c) (send look-ctl append (car c) (cdr c)))
+                      choices))))
+      
+      (super-new)))
+  
+  )

collects/macro-debugger/view/interfaces.ss

@@ -0,0 +1,28 @@
+
+(module interfaces mzscheme
+  (require (lib "unitsig.ss"))
+  (provide (all-defined))
+  
+  ;; Signatures
+
+  (define-signature view^
+    (macro-stepper-frame%
+     macro-stepper-widget%
+     make-macro-stepper
+     go
+     go/deriv))
+
+  (define-signature view-base^
+    (base-frame%))
+
+  (define-signature prefs^
+    (pref:width
+     pref:height
+     pref:props-percentage
+     pref:macro-hiding?
+     pref:show-hiding-panel?
+     pref:hide-primitives?
+     pref:hide-libs?
+     pref:identifier=?))
+
+  )

collects/macro-debugger/view/prefs.ss

@@ -1,5 +1,38 @@
 
 (module prefs mzscheme
-  (require (lib "framework.ss" "framework"))
+  (require (lib "unitsig.ss")
+           (lib "framework.ss" "framework")
+           "interfaces.ss")
+  (provide prefs@)
   
-  '...)
+  (define-syntax pref:get/set
+    (syntax-rules ()
+      [(_ get/set prop)
+       (define get/set
+         (case-lambda
+           [() (preferences:get 'prop)]
+           [(newval) (preferences:set 'prop newval)]))]))
+
+  (define prefs@
+    (unit/sig prefs^
+      (import)
+      
+      (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: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?)
+      
+      (pref:get/set pref:width MacroStepper:Frame:Width)
+      (pref:get/set pref:height MacroStepper:Frame:Height)
+      (pref:get/set pref:props-percentage MacroStepper:PropertiesPanelPercentage)
+      (pref:get/set pref:macro-hiding? MacroStepper:MacroHiding?)
+      (pref:get/set pref:show-hiding-panel? MacroStepper:ShowHidingPanel?)
+      (pref:get/set pref:hide-primitives? MacroStepper:HidePrimitives?)
+      (pref:get/set pref:hide-libs? MacroStepper:HideLibs?)
+      (pref:get/set pref:identifier=? MacroStepper:IdentifierComparison)
+      ))
+  )

collects/macro-debugger/view/view.ss

@@ -1,16 +1,27 @@
 
 (module view mzscheme
   (require (lib "unitsig.ss")
+           (lib "class.ss")
+           (lib "mred.ss" "mred")
+           (lib "framework.ss" "framework")
            (prefix sb: "../syntax-browser/embed.ss")
+           "interfaces.ss"
+           "prefs.ss"
            "gui.ss")
   (provide (all-defined))
 
+  (define view-base@
+    (unit/sig view-base^
+      (import)
+      (define base-frame%
+        (frame:standard-menus-mixin (frame:basic-mixin frame%)))))
+
   (define-values/invoke-unit/sig view^
     (compound-unit/sig
       (import)
-      (link (PREFS : sb:prefs^ (sb:global-prefs@))
+      (link (PREFS : prefs^ (prefs@))
             (SB   : sb:implementation^ (sb:implementation@))
             (BASE : view-base^ (view-base@))
-            (VIEW : view^ (view@ BASE PREFS SB)))
+            (VIEW : view^ (view@ BASE SB)))
       (export (open VIEW))))
   )