Macro Stepper: merged new ui from branches/ryanc/ms-new-ui

svn: r7215

original commit: 2be282a0be517b1a5e8b1156c6dc8bd58e66726b

collects/macro-debugger/expand.ss

@@ -5,11 +5,6 @@
   (provide expand-only
            expand/hide)
   
-  (provide expand/step)
-  (define (expand/step . args)
-    (apply (dynamic-require '(lib "stepper.ss" "macro-debugger") 'expand/step)
-           args))
-  
   (define (expand-only stx show-list)
     (define (show? id)
       (ormap (lambda (x) (module-identifier=? id x))

collects/macro-debugger/model/reductions-engine.ss

@@ -23,6 +23,7 @@
            revappend)
   (provide walk
            walk/foci
+           walk/mono
            stumble
            stumble/E)
 
@@ -213,15 +214,21 @@
     (current-frontier
      (apply append (map (make-rename-mapping from to) (current-frontier)))))
 
-  (define (make-rename-mapping from to)
+  (define (make-rename-mapping from0 to0)
     (define table (make-hash-table))
-    (let loop ([from from] [to to])
+    (let loop ([from from0] [to to0])
       (cond [(syntax? from)
              (hash-table-put! table from (flatten-syntaxes to))
              (loop (syntax-e from) to)]
             [(syntax? to)
              (loop from (syntax-e to))]
             [(pair? from)
+             #;(unless (pair? to)
+               (fprintf (current-error-port)
+                        "from:\n~s\n\n" (syntax-object->datum from0))
+               (fprintf (current-error-port)
+                        "to:\n~s\n\n" (syntax-object->datum to0))
+               (error 'frontier-renaming))
              (loop (car from) (car to))
              (loop (cdr from) (cdr to))]
             [(vector? from)
@@ -264,6 +271,12 @@
                (current-definites) (current-frontier)
                (foci foci1) (foci foci2) Ee1 Ee2))
 
+  ;; walk/mono : syntax StepType -> Reduction
+  (define (walk/mono e1 type)
+    (make-mono (current-derivation) (big-context) type (context)
+               (current-definites) (current-frontier)
+               (foci e1) e1))
+  
   ;; stumble : syntax exception -> Reduction
   (define (stumble stx exn)
     (make-misstep (current-derivation) (big-context) 'error (context)

collects/macro-debugger/model/reductions.ss

@@ -400,7 +400,7 @@
       [(struct local-lift (expr id))
        (list (walk expr id 'local-lift))]
       [(struct local-lift-end (decl))
-       (list (walk decl decl 'module-lift))]
+       (list (walk/mono decl 'module-lift))]
       [(struct local-bind (deriv))
        (reductions* deriv)]))
 

collects/macro-debugger/model/steps.ss

@@ -2,6 +2,7 @@
 (module steps mzscheme
   (require "deriv.ss"
            "deriv-util.ss")
+  (provide (all-defined))
 
   ;; A ReductionSequence is a (list-of Reduction)
 
@@ -22,11 +23,13 @@
 
   ;; A Reduction is one of 
   ;;   - (make-step ... Syntaxes Syntaxes Syntax Syntax)
+  ;;   - (make-mono ... Syntaxes Syntax)
   ;;   - (make-misstep ... Syntax Syntax Exception)
 
   (define-struct protostep (deriv lctx type ctx definites frontier) #f)
 
   (define-struct (step protostep) (foci1 foci2 e1 e2) #f)
+  (define-struct (mono protostep) (foci1 e1) #f)
   (define-struct (misstep protostep) (foci1 e1 exn) #f)
 
   ;; context-fill : Context Syntax -> Syntax
@@ -56,6 +59,9 @@
   (define (step-term2 s)
     (context-fill (protostep-ctx s) (step-e2 s)))
 
+  (define (mono-term1 s)
+    (context-fill (protostep-ctx s) (mono-e1 s)))
+
   (define (misstep-term1 s)
     (context-fill (protostep-ctx s) (misstep-e1 s)))
 
@@ -106,40 +112,4 @@
 
   (define (rewrite-step? x)
     (and (step? x) (not (rename-step? x))))
-
-  (provide (all-defined))
-
-  #;(begin
-  (require (lib "contract.ss"))
-  (provide rewrite-step?
-           rename-step?)
-  (provide/contract
-   [step-type->string (any/c . -> . string?)]
-   [step-term1        (step? . -> . syntax?)]
-   [step-term2        (step? . -> . syntax?)]
-   [misstep-term1     (misstep? . -> . syntax?)]
-   [context-fill      ((listof procedure?) syntax? . -> . syntax?)]
-   (struct protostep 
-           ([deriv deriv?]
-            [lctx list?]
-            [type (or/c symbol? boolean?)]
-            [ctx (listof procedure?)]))
-   (struct (step protostep)
-           ([deriv deriv?]
-            [lctx list?]
-            [type (or/c symbol? boolean?)]
-            [ctx (listof procedure?)]
-            [foci1 (listof syntax?)]
-            [foci2 (listof syntax?)]
-            [e1 syntax?]
-            [e2 syntax?]))
-   (struct (misstep protostep)
-           ([deriv deriv?]
-            [lctx list?]
-            [type (or/c symbol? boolean?)]
-            [ctx (listof procedure?)]
-            [foci1 (listof syntax?)]
-            [e1 syntax?]
-            [exn exn?])))
-  )
 )

collects/macro-debugger/stepper.ss

@@ -5,5 +5,4 @@
   
   (define (expand/step stx)
     (go stx))
-  
   )

collects/macro-debugger/syntax-browser.ss

@@ -1,8 +1,7 @@
 
 (module syntax-browser mzscheme
-  (require "syntax-browser/browser.ss")
+  (require "syntax-browser/frame.ss")
   (provide browse-syntax
            browse-syntaxes
-           make-syntax-browser
+           make-syntax-browser)
-           syntax-snip)
   )

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

@@ -2,73 +2,75 @@
 (module controller mzscheme
   (require (lib "class.ss")
            "interfaces.ss"
-           "partition.ss")
+           "partition.ss"
+           "../util/notify.ss")
+  (provide controller%)
 
-  (provide syntax-controller%)
+  ;; displays-manager-mixin
+  (define displays-manager-mixin
+    (mixin () (displays-manager<%>)
+      ;; displays : (list-of display<%>)
+      (field [displays null])
 
-  ;; syntax-controller%
+      ;; add-syntax-display : display<%> -> void
-  (define syntax-controller%
+      (define/public (add-syntax-display c)
-    (class* object% (syntax-controller<%>
+        (set! displays (cons c displays)))
-                     syntax-pp-snip-controller<%>
-                     color-controller<%>)
-      (init-field (primary-partition (new-bound-partition)))
-      (init-field (properties-controller #f))
 
-      (define colorers null)
+      ;; remove-all-syntax-displays : -> void
-      (define selection-listeners null)
+      (define/public (remove-all-syntax-displays)
-      (define selected-syntax #f)
+        (set! displays null))
-      (define identifier=?-listeners null)
 
-      ;; syntax-controller<%> Methods
+      (super-new)))
 
-      (define/public (select-syntax stx)
+  ;; selection-manager-mixin
-        (set! selected-syntax stx)
+  (define selection-manager-mixin
-        (send properties-controller set-syntax stx)
+    (mixin (displays-manager<%>) (selection-manager<%>)
-        (for-each (lambda (c) (send c select-syntax stx)) colorers)
+      (inherit-field displays)
-        (for-each (lambda (p) (p stx)) selection-listeners))
+      (field/notify selected-syntax (new notify-box% (value #f)))
 
-      (define/public (get-selected-syntax) selected-syntax)
-
-      (define/public (get-properties-controller) properties-controller)
-      (define/public (set-properties-controller pc)
-        (set! properties-controller pc))
-
-      (define/public (add-view-colorer c)
-        (set! colorers (cons c colorers))
-        (send c select-syntax selected-syntax))
-
-      (define/public (get-view-colorers) colorers)
-
-      (define/public (add-selection-listener p)
-        (set! selection-listeners (cons p selection-listeners)))
-      
-      (define/public (on-update-identifier=? name id=?)
-        (set! secondary-partition 
-              (and id=? (new partition% (relation id=?))))
-        (for-each (lambda (c) (send c refresh)) colorers)
-        (for-each (lambda (f) (f name id=?)) identifier=?-listeners))
-      
-      (define/public (add-identifier=?-listener f)
-        (set! identifier=?-listeners
-              (cons f identifier=?-listeners)))
-
-      (define/public (erase)
-        (set! colorers null))
-
-      ;; syntax-pp-snip-controller<%> Methods
-
-      (define/public (on-select-syntax stx)
-        (select-syntax stx))
-
-      ;; color-controller<%> Methods
-
-      (define secondary-partition #f)
-
-      (define/public (get-primary-partition) primary-partition)
-      (define/public (get-secondary-partition) secondary-partition)
-
-      ;; Initialization
       (super-new)
-      ))
+      (listen-selected-syntax
+       (lambda (new-value)
+         (for-each (lambda (display) (send display refresh))
+                   displays)))))
 
+  ;; mark-manager-mixin
+  (define mark-manager-mixin
+    (mixin () (mark-manager<%>)
+      (init-field [primary-partition (new-bound-partition)])
+      (super-new)
+
+      ;; get-primary-partition : -> partition
+      (define/public-final (get-primary-partition)
+        primary-partition)
+
+      ;; reset-primary-partition : -> void
+      (define/public-final (reset-primary-partition)
+        (set! primary-partition (new-bound-partition)))))
+
+  ;; secondary-partition-mixin
+  (define secondary-partition-mixin
+    (mixin (displays-manager<%>) (secondary-partition<%>)
+      (inherit-field displays)
+      (field/notify identifier=? (new notify-box% (value #f)))
+      (field/notify secondary-partition (new notify-box% (value #f)))
+
+      (listen-identifier=?
+       (lambda (name+proc)
+         (set-secondary-partition
+          (and name+proc
+               (new partition% (relation (cdr name+proc)))))))
+      (listen-secondary-partition
+       (lambda (p)
+         (for-each (lambda (d) (send d refresh))
+                   displays)))
+      (super-new)))
+
+  (define controller%
+    (class (secondary-partition-mixin
+            (selection-manager-mixin
+             (mark-manager-mixin
+              (displays-manager-mixin
+               object%))))
+      (super-new)))
   )

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

@@ -0,0 +1,251 @@
+
+(module display mzscheme
+  (require (lib "class.ss")
+           (lib "mred.ss" "mred")
+           (lib "plt-match.ss")
+           "params.ss"
+           "pretty-printer.ss"
+           "interfaces.ss"
+           "util.ss")
+  (provide print-syntax-to-editor
+           code-style)
+
+  ;; print-syntax-to-editor : syntax text controller<%> -> display<%>
+  (define (print-syntax-to-editor stx text controller)
+    (new display% (syntax stx) (text text) (controller controller)))
+
+  ;; FIXME: assumes text never moves
+
+  ;; display%
+  (define display%
+    (class* object% (display<%>)
+      (init ((stx syntax)))
+      (init-field text)
+      (init-field controller)
+
+      (define start-anchor (new anchor-snip%))
+      (define end-anchor (new anchor-snip%))
+      (define range #f)
+      (define extra-styles (make-hash-table))
+
+      ;; render-syntax : syntax -> void
+      (define/public (render-syntax stx)
+        (with-unlock text
+          (send text delete (get-start-position) (get-end-position))
+          (set! range
+                (print-syntax stx text controller
+                              (lambda () (get-start-position))
+                              (lambda () (get-end-position))))
+          (apply-primary-partition-styles))
+        (refresh))
+
+      ;; refresh : -> void
+      ;; Clears all highlighting and reapplies all non-foreground styles.
+      (define/public (refresh)
+        (with-unlock text
+          (send* text 
+            (begin-edit-sequence)
+            (change-style unhighlight-d (get-start-position) (get-end-position)))
+          (apply-extra-styles)
+          (let ([selected-syntax (send controller get-selected-syntax)])
+            (apply-secondary-partition-styles selected-syntax)
+            (apply-selection-styles selected-syntax))
+          (send* text
+            (end-edit-sequence))))
+
+      ;; cached-start-position : number
+      (define cached-start-position #f)
+
+      ;; get-start-position : -> number
+      (define/public-final (get-start-position)
+        (unless cached-start-position
+          (set! cached-start-position (send text get-snip-position start-anchor)))
+        cached-start-position)
+
+      ;; get-end-position : -> number
+      (define/public-final (get-end-position)
+        (send text get-snip-position end-anchor))
+
+      ;; relative->text-position : number -> number
+      ;; FIXME: might be slow to find start every time!
+      (define/public-final (relative->text-position pos)
+        (+ pos (get-start-position)))
+
+      ;; Styling
+
+      ;; get-range : -> range<%>
+      (define/public (get-range) range)
+      
+      ;; highlight-syntaxes : (list-of syntax) string -> void
+      (define/public (highlight-syntaxes stxs hi-color)
+        (let ([style-delta (highlight-style-delta hi-color #f)])
+          (for-each (lambda (stx) (hash-table-put! extra-styles stx style-delta))
+                    stxs))
+        (refresh))
+
+      ;; apply-extra-styles : -> void
+      ;; Applies externally-added styles (such as highlighting)
+      (define/private (apply-extra-styles)
+        (hash-table-for-each
+         extra-styles
+         (lambda (hi-stx style-delta)
+           (let ([rs (send range get-ranges hi-stx)])
+             (for-each (lambda (r) (restyle-range r style-delta)) rs)))))
+
+      ;; apply-secondary-partition-styles : selected-syntax -> void
+      ;; If the selected syntax is an identifier, then styles all identifiers
+      ;; in the same partition in blue.
+      (define/private (apply-secondary-partition-styles selected-syntax)
+        (when (identifier? selected-syntax)
+          (let ([partition (send controller get-secondary-partition)])
+            (when partition
+              (for-each (lambda (id)
+                          (when (send partition same-partition? selected-syntax id)
+                            (draw-secondary-connection id)))
+                        (send range get-identifier-list))))))
+
+      ;; apply-selection-styles : syntax -> void
+      ;; Styles subterms eq to the selected syntax
+      (define/private (apply-selection-styles selected-syntax)
+        (let ([rs (send range get-ranges selected-syntax)])
+          (for-each (lambda (r) (restyle-range r select-highlight-d)) rs)))
+
+      ;; draw-secondary-connection : syntax -> void
+      (define/private (draw-secondary-connection stx2)
+        (let ([rs (send range get-ranges stx2)])
+          (for-each (lambda (r) (restyle-range r select-sub-highlight-d)) rs)))
+
+      ;; restyle-range : (cons num num) style-delta% -> void
+      (define/private (restyle-range r style)
+        (send text change-style style
+              (relative->text-position (car r))
+              (relative->text-position (cdr r))))
+
+      ;; Primary styles
+
+      ;; apply-primary-partition-styles : -> void
+      ;; Changes the foreground color according to the primary partition.
+      ;; Only called once, when the syntax is first drawn.
+      (define/private (apply-primary-partition-styles)
+        (define (color-style color)
+          (let ([delta (new style-delta%)])
+            (send delta set-delta-foreground color)
+            delta))
+        (define color-styles (list->vector (map color-style (current-colors))))
+        (define overflow-style (color-style "darkgray"))
+        (define color-partition (send controller get-primary-partition))
+        (define offset (get-start-position))
+        (for-each
+         (lambda (range)
+           (let ([stx (range-obj range)]
+                 [start (range-start range)]
+                 [end (range-end range)])
+             (send text change-style
+                   (primary-style stx color-partition color-styles overflow-style)
+                   (+ offset start)
+                   (+ offset end))))
+         (send range all-ranges)))
+
+      ;; primary-style : syntax partition (vector-of style-delta%) style-delta%
+      ;;               -> style-delta%
+      (define/private (primary-style stx partition color-vector overflow)
+        (let ([n (send partition get-partition stx)])
+          (cond [(< n (vector-length color-vector))
+                 (vector-ref color-vector n)]
+                [else
+                 overflow])))
+
+      ;; Initialize
+      (super-new)
+      (send text insert start-anchor)
+      (send text insert end-anchor)
+      (render-syntax stx)
+      (send controller add-syntax-display this)))
+
+  ;; print-syntax : syntax controller (-> number) (-> number)
+  ;;                -> range%
+  (define (print-syntax stx text controller
+                        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))
+
+    (port-count-lines! output-port)
+    (let ([range (pretty-print-syntax stx output-port primary-partition)])
+      (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.
+        (send text delete (sub1 end) end))
+      ;; Set font to standard
+      (send text change-style
+            (code-style text)
+            (get-start-position)
+            (get-end-position))
+      (let ([offset (get-start-position)])
+        (fixup-parentheses text range offset)
+        (for-each
+         (lambda (range)
+           (let* ([stx (range-obj range)]
+                  [start (range-start range)]
+                  [end (range-end range)])
+             (send text set-clickback (+ offset start) (+ offset end)
+                   (lambda (_1 _2 _3)
+                     (send controller set-selected-syntax stx)))))
+         (send range all-ranges))
+        range)))
+
+  ;; fixup-parentheses : text range -> void
+  (define (fixup-parentheses text range offset)
+    (define (fixup r)
+      (let ([stx (range-obj r)]
+            [start (+ offset (range-start r))]
+            [end (+ offset (range-end r))])
+        (when (and (syntax? stx) (pair? (syntax-e stx)))
+          (case (syntax-property stx 'paren-shape)
+            ((#\[)
+             (replace start #\[)
+             (replace (sub1 end) #\]))
+            ((#\{) 
+             (replace start #\{)
+             (replace (sub1 end) #\}))))))
+    (define (replace pos char)
+      (send text insert char pos (add1 pos)))
+    (for-each fixup (send range all-ranges)))
+
+  ;; code-style : text<%> -> style<%>
+  (define (code-style text)
+    (let* ([style-list (send text get-style-list)]
+           [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
+                (make-object style-delta% 'change-size font-size))
+          style)))
+
+  ;; anchor-snip%
+  (define anchor-snip%
+    (class snip%
+      (define/override (copy)
+        (make-object string-snip% ""))
+      (super-instantiate ())))
+
+  ;; Styles
+
+  (define (highlight-style-delta color em?)
+    (let ([sd (new style-delta%)])
+      (unless em? (send sd set-delta-background color))
+      (when em? (send sd set-weight-on 'bold))
+      (unless em? (send sd set-underlined-off #t)
+        (send sd set-weight-off 'bold))
+      sd))
+
+  (define selection-color "yellow")
+  (define subselection-color "yellow")
+
+  (define select-highlight-d (highlight-style-delta selection-color #t))
+  (define select-sub-highlight-d (highlight-style-delta subselection-color #f))
+
+  (define unhighlight-d (highlight-style-delta "white" #f))
+
+  )

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

@@ -3,13 +3,11 @@
   (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

@@ -1,19 +1,17 @@
 
 (module frame mzscheme
   (require (lib "class.ss")
-           (lib "unit.ss")
            (lib "mred.ss" "mred")
            (lib "framework.ss" "framework")
            (lib "list.ss")
-           "interfaces.ss"
+           "partition.ss"
-           "partition.ss")
+           "prefs.ss"
-  (provide frame@)
+           "widget.ss")
-  
+  (provide browse-syntax
-  (define frame@
+           browse-syntaxes
-    (unit
+           make-syntax-browser
-      (import prefs^
+           syntax-browser-frame%
-              widget^)
+           syntax-widget/controls%)
-      (export browser^)
 
   ;; browse-syntax : syntax -> void
   (define (browse-syntax stx)
@@ -36,31 +34,35 @@
   ;; syntax-browser-frame%
   (define syntax-browser-frame%
     (class* frame% ()
+      (init-field [config (new syntax-prefs%)])
       (super-new (label "Syntax Browser")
-                     (width (pref:width))
+                 (width (send config pref:width))
-                     (height (pref:height)))
+                 (height (send config pref:height)))
       (define widget
         (new syntax-widget/controls%
              (parent this)
-                 (pref:props-percentage pref:props-percentage)))
+             (config config)))
       (define/public (get-widget) widget)
       (define/augment (on-close)
-            (pref:width (send this get-width))
+        (send config pref:width (send this get-width))
-            (pref:height (send this get-height))
+        (send config pref:height (send this get-height))
-            (send widget save-prefs)
+        (send widget shutdown)
         (inner (void) on-close))
       ))
 
   ;; syntax-widget/controls%
   (define syntax-widget/controls%
-        (class* syntax-widget% ()
+    (class* widget% ()
       (inherit get-main-panel
                get-controller
                toggle-props)
       (super-new)
+      (inherit-field config)
 
       (define -control-panel 
-            (new horizontal-pane% (parent (get-main-panel)) (stretchable-height #f)))
+        (new horizontal-pane%
+             (parent (get-main-panel))
+             (stretchable-height #f)))
 
       ;; Put the control panel up front
       (send (get-main-panel) change-children
@@ -71,7 +73,11 @@
       (define -choice
         (new choice% (label "identifer=?") (parent -control-panel)
              (choices (map car -identifier=-choices))
-                 (callback (lambda _ (on-update-identifier=?-choice)))))
+             (callback 
+              (lambda (c e)
+                (send (get-controller) set-identifier=?
+                      (assoc (send c get-string-selection)
+                             -identifier=-choices))))))
       (new button% 
            (label "Clear")
            (parent -control-panel)
@@ -81,17 +87,10 @@
            (parent -control-panel)
            (callback (lambda _ (toggle-props))))
 
-          (define/private (on-update-identifier=?-choice)
+      (send (get-controller) listen-identifier=?
-            (cond [(assoc (send -choice get-string-selection)
+            (lambda (name+func)
-                          -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))))))
+                    (or (send -choice find-string (car name+func)) 0))))
-      
       ))
+
   )

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

@@ -1,127 +1,147 @@
 
 (module interfaces mzscheme
-  (require (lib "class.ss")
+  (require (lib "class.ss"))
-           (lib "unit.ss"))
   (provide (all-defined))
 
-  ;; Signatures
+  ;; displays-manager<%>
-  
+  (define displays-manager<%>
-  (define-signature browser^
-    (;; browse-syntax : syntax -> void
-     browse-syntax
-     
-     ;; browse-syntaxes : (list-of syntax) -> void
-     browse-syntaxes
-     
-     ;; make-syntax-browser : -> syntax-browser<%>
-     make-syntax-browser
-     
-     ;; syntax-widget/controls%
-     syntax-widget/controls%
-     
-     ;; syntax-browser-frame%
-     syntax-browser-frame%))
-
-  (define-signature prefs^
-    (;; pref:width : pref of number
-     pref:width
-     
-     ;; pref:height : pref of number
-     pref:height
-     
-     ;; pref:props-percentage : pref of number in (0,1)
-     pref:props-percentage))
-
-  (define-signature keymap^
-    (;; syntax-keymap% implements syntax-keymap<%>
-     syntax-keymap%))
-  
-  (define-signature context-menu^
-    (;; context-menu%
-     context-menu%))
-
-  (define-signature snip^
-    (;; syntax-snip : syntax -> snip
-     syntax-snip
-     
-     ;; syntax-snip%
-     syntax-snip%))
-
-  (define-signature snipclass^
-    (;; snip-class
-     snip-class))
-  
-  (define-signature widget^
-    (;; syntax-widget%
-     syntax-widget%))
-
-  ;; Class Interfaces
-
-  ;; syntax-controller<%>
-  ;; A syntax-controller coordinates state shared by many different syntax views.
-  ;; Syntax views can share:
-  ;;   - selection
-  ;;   - partitioning configuration
-  ;;   - property display
-  (define syntax-controller<%>
     (interface ()
-      ;; select-syntax : syntax -> void
+      ;; add-syntax-display : display<%> -> void
-      select-syntax
+      add-syntax-display
 
-      ;; get-selected-syntax : -> syntax/#f
+      ;; remove-all-syntax-displays : -> void
+      remove-all-syntax-displays))
+
+  ;; selection-manager<%>
+  (define selection-manager<%>
+    (interface ()
+      ;; set-selected-syntax : syntax -> void
+      set-selected-syntax
+
+      ;; get-selected-syntax : -> syntax
       get-selected-syntax
 
-      ;; get-properties-controller : -> syntax-properties-controller<%>
+      ;; listen-selected-syntax : (syntax -> void) -> void
-      get-properties-controller
+      listen-selected-syntax))
 
-      ;; add-view-colorer : syntax-colorer<%> -> void
+  ;; mark-manager<%>
-      add-view-colorer
+  ;; Manages marks, mappings from marks to colors
-      
+  (define mark-manager<%>
-      ;; get-view-colorers : -> (list-of syntax-colorer<%>)
-      get-view-colorers
-      
-      ;; add-selection-listener : syntax -> void
-      add-selection-listener
-      ))
-
-  ;; syntax-properties-controller<%>
-  (define syntax-properties-controller<%>
     (interface ()
-      ;; set-syntax : syntax -> void
+      ;; get-primary-partition : -> partition
-      set-syntax
+      get-primary-partition))
-      
-      ;; show : boolean -> void
-      #;show
-      
-      ;; props-shown? : -> boolean
-      props-shown?))
-
-  ;; syntax-configuration<%>
-  (define syntax-configuration<%>
-    (interface ()
-      ;; get-primary-partition : -> partition<%>
-      get-primary-partition
 
+  ;; secondary-partition<%>
+  (define secondary-partition<%>
+    (interface (displays-manager<%>)
       ;; get-secondary-partition : -> partition<%>
       get-secondary-partition
 
-      ;; update-identifier=? : ... -> void
+      ;; set-secondary-partition : partition<%> -> void
-      update-identifier=?))
+      set-secondary-partition
 
+      ;; listen-secondary-partition : (partition<%> -> void) -> void
+      listen-secondary-partition
 
-  ;; syntax-colorer<%>
+      ;; get-identifier=? : -> (cons string procedure)
-  (define syntax-colorer<%>
+      get-identifier=?
+
+      ;; set-identifier=? : (cons string procedure) -> void
+      set-identifier=?
+
+      ;; listen-identifier=? : ((cons string procedure) -> void) -> void
+      listen-identifier=?))
+
+  ;; controller<%>
+  (define controller<%>
+    (interface (displays-manager<%>
+                selection-manager<%>
+                mark-manager<%> 
+                secondary-partition<%>)))
+
+  ;; host<%>
+  (define host<%>
     (interface ()
-      select-syntax
+      ;; get-controller : -> controller<%>
-      apply-styles))
+      get-controller
 
-  ;; syntax-sharing-context<%>
+      ;; add-keymap : text snip
-  ;; A syntax-sharing-context<%> 
+      add-keymap
-  ;; Syntax snips search their enclosing editors for instances of sharing contexts
+      ))
-  (define syntax-sharing-context<%>
+
+
+  ;; display<%>
+  (define display<%>
     (interface ()
-      ;; get-shared-partition
+      ;; refresh : -> void
-      get-shared-partition))
+      refresh
+
+      ;; highlight-syntaxes : (list-of syntax) color -> void
+      highlight-syntaxes
+
+      ;; get-start-position : -> number
+      get-start-position
+
+      ;; get-end-position : -> number
+      get-end-position
+
+      ;; get-range : -> range<%>
+      get-range))
+
+  ;; range<%>
+  (define range<%>
+    (interface ()
+      ;; get-ranges : datum -> (list-of (cons number number))
+      get-ranges
+
+      ;; all-ranges : (list-of Range)
+      ;; Sorted outermost-first
+      all-ranges
+
+      ;; get-identifier-list : (list-of identifier)
+      get-identifier-list))
+
+  ;; A Range is (make-range datum number number)
+  (define-struct range (obj start end))
+
+
+  ;; syntax-prefs<%>
+  (define syntax-prefs<%>
+    (interface ()
+      pref:width
+      pref:height
+      pref:props-percentage
+      pref:props-shown?))
+
+  ;; widget-hooks<%>
+  (define widget-hooks<%>
+    (interface ()
+      ;; setup-keymap : -> void
+      setup-keymap
+
+      ;; shutdown : -> void
+      shutdown
+      ))
+
+  ;; keymap-hooks<%>
+  (define keymap-hooks<%>
+    (interface ()
+      ;; make-context-menu : -> context-menu<%>
+      make-context-menu
+
+      ;; get-context-menu% : -> class
+      get-context-menu%))
+
+  ;; context-menu-hooks<%>
+  (define context-menu-hooks<%>
+    (interface ()
+      add-edit-items
+      after-edit-items
+      add-selection-items
+      after-selection-items
+      add-partition-items
+      after-partition-items))
+
 
   ;;----------
 
@@ -147,39 +167,4 @@
       ;; count : -> number
       count))
 
-  ;; Internal interfaces
-  
-  (define syntax-pp-snip-controller<%>
-    (interface ()
-      on-select-syntax
-      ))
-
-  (define color-controller<%>
-    (interface ()
-      get-primary-partition
-      get-secondary-partition
-      ))
-
-  (define syntax-pp<%>
-    (interface ()
-      pretty-print-syntax
-
-      get-range
-      get-identifier-list
-      flat=>stx
-      stx=>flat))
-
-  (define typesetter<%>
-    (interface ()
-      get-output-port
-      get-current-position))
-
-  (define range<%>
-    (interface ()
-      get-start
-      set-start
-      get-ranges
-      add-range
-      all-ranges))
-
   )

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

@@ -1,17 +1,69 @@
 
 (module keymap mzscheme
   (require (lib "class.ss")
-           (lib "unit.ss")
            (lib "mred.ss" "mred")
            "interfaces.ss"
            "partition.ss")
-  (provide keymap@
+  (provide syntax-keymap%
-           context-menu@)
+           context-menu%)
 
-  (define context-menu@
+  (define syntax-keymap%
-    (unit
+    (class keymap%
-      (import)
+      (init editor)
-      (export context-menu^)
+      (init-field controller)
+
+      (inherit add-function
+               map-function
+               chain-to-keymap)
+      (super-new)
+
+      (define/public (get-context-menu%)
+        context-menu%)
+
+      (define/public (make-context-menu)
+        (new (get-context-menu%) (controller controller) (keymap this)))
+
+      ;; Key mappings
+
+      (map-function "rightbutton" "popup-context-window")
+
+      ;; Functionality
+
+      (add-function "popup-context-window"
+                    (lambda (editor event)
+                      (do-popup-context-window editor event)))
+
+      (add-function "copy-text"
+                    (lambda (_ event)
+                      (define stx (send controller get-selected-syntax))
+                      (send the-clipboard set-clipboard-string
+                            (if stx 
+                                (format "~s" (syntax-object->datum stx))
+                                "")
+                            (send event get-time-stamp))))
+
+      (add-function "clear-syntax-selection"
+                    (lambda (i e)
+                      (send controller set-selected-syntax #f)))
+
+      (add-function "show-syntax-properties"
+                    (lambda (i e)
+                      (error 'show-syntax-properties "not provided by this keymap")))
+
+      ;; Attach to editor
+
+      (chain-to-keymap (send editor get-keymap) #t)
+      (send editor set-keymap this)
+
+      (define/public (get-controller) controller)
+
+      (define/private (do-popup-context-window editor event)
+        (define-values (x y)
+          (send editor dc-location-to-editor-location
+                (send event get-x)
+                (send event get-y)))
+        (define admin (send editor get-admin))
+        (send admin popup-menu (make-context-menu) x y))))
 
   (define context-menu%
     (class popup-menu%
@@ -20,7 +72,6 @@
       (super-new)
 
       (field [copy-menu #f]
-                 [copy-syntax-menu #f]
              [clear-menu #f]
              [props-menu #f])
 
@@ -29,10 +80,6 @@
               (new menu-item% (label "Copy") (parent this)
                    (callback (lambda (i e)
                                (send keymap call-function "copy-text" i e)))))
-            (set! copy-syntax-menu
-                  (new menu-item% (label "Copy syntax") (parent this)
-                       (callback (lambda (i e)
-                                   (send keymap call-function "copy-syntax" i e)))))
         (void))
 
       (define/public (after-edit-items)
@@ -68,10 +115,11 @@
                          (parent secondary)
                          (callback 
                           (lambda (i e)
-                                (send controller on-update-identifier=? name func))))])
+                            (send controller set-identifier=? 
-                   (send controller add-identifier=?-listener
+                                  (cons name func)))))])
-                         (lambda (new-name new-id=?) 
+               (send controller listen-identifier=?
-                           (send this-choice check (eq? name new-name))))))
+                     (lambda (name+proc)
+                       (send this-choice check (eq? name (car name+proc)))))))
            (map car (identifier=-choices))
            (map cdr (identifier=-choices))))
         (void))
@@ -85,7 +133,6 @@
       (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))
 
@@ -100,78 +147,6 @@
       (add-separator)
       (add-partition-items)
       (after-partition-items)
+      ))
 
-          ))))
-  
-  (define keymap@
-    (unit
-      (import context-menu^ snip^)
-      (export keymap^)
-      
-      (define syntax-keymap%
-        (class keymap%
-          (init editor)
-          (init-field controller)
-          
-          (inherit add-function
-                   map-function
-                   chain-to-keymap)
-          (super-new)
-          
-          (define context-menu (make-context-menu))
-          
-          (define/public (make-context-menu)
-            (new context-menu% (controller controller) (keymap this)))
-          
-          ;; Key mappings
-
-          (map-function "rightbutton" "popup-context-window")
-          
-          ;; Functionality
-          
-          (add-function "popup-context-window"
-                        (lambda (editor event)
-                          (do-popup-context-window editor event)))
-          
-          (add-function "copy-text"
-                        (lambda (_ event)
-                          (define stx (send controller get-selected-syntax))
-                          (send the-clipboard set-clipboard-string
-                                (if stx 
-                                    (format "~s" (syntax-object->datum stx))
-                                    "")
-                                (send event get-time-stamp))))
-          
-          (add-function "copy-syntax"
-                        (lambda (_ event)
-                          (define stx (send controller get-selected-syntax))
-                          (define t (new text%))
-                          (send t insert
-                                (new syntax-snip%
-                                     (syntax stx)))
-                          (send t select-all)
-                          (send t copy)))
-          
-          (add-function "clear-syntax-selection"
-                        (lambda (i e)
-                          (send controller select-syntax #f)))
-          
-          (add-function "show-syntax-properties"
-                        (lambda (i e)
-                          (error 'show-syntax-properties "not provided by this keymap")))
-          
-          ;; Attach to editor
-
-          (chain-to-keymap (send editor get-keymap) #t)
-          (send editor set-keymap this)
-          
-          (define/public (get-controller) controller)
-          
-          (define/private (do-popup-context-window editor event)
-            (define-values (x y)
-              (send editor dc-location-to-editor-location
-                    (send event get-x)
-                    (send event get-y)))
-            (define admin (send editor get-admin))
-            (send admin popup-menu context-menu x y))))))
   )

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

@@ -1,22 +1,13 @@
 
 (module prefs mzscheme
-  (require (lib "unit.ss")
+  (require (lib "class.ss")
            (lib "framework.ss" "framework")
-           "interfaces.ss")
+           "interfaces.ss"
-  (provide prefs@)
+           "../util/misc.ss")
+  (provide syntax-prefs%
+           syntax-prefs-mixin
 
-  (define-syntax pref:get/set
+           pref:tabify)
-    (syntax-rules ()
-      [(_ get/set prop)
-       (define get/set
-         (case-lambda
-           [() (preferences:get 'prop)]
-           [(newval) (preferences:set 'prop newval)]))]))
-
-  (define prefs@
-    (unit
-      (import)
-      (export prefs^)
 
   (preferences:set-default 'SyntaxBrowser:Width 700 number?)
   (preferences:set-default 'SyntaxBrowser:Height 600 number?)
@@ -26,6 +17,16 @@
   (pref:get/set pref:width SyntaxBrowser:Width)
   (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:props-shown? SyntaxBrowser:PropertiesPanelShown)
 
+  (pref:get/set pref:tabify framework:tabify)
+
+  (define syntax-prefs-mixin
+    (closure-mixin (syntax-prefs<%>)
+      (pref:width pref:width)
+      (pref:height pref:height)
+      (pref:props-percentage pref:props-percentage)
+      (pref:props-shown? pref:props-shown?)))
+
+  (define syntax-prefs% (syntax-prefs-mixin object%))
   )

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

@@ -1,3 +1,4 @@
+
 (module pretty-helper mzscheme
   (require (lib "class.ss")
            (lib "stx.ss" "syntax")

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

@@ -6,83 +6,54 @@
            (lib "class.ss")
            (lib "pretty.ss")
            (lib "mred.ss" "mred")
-           "pretty-range.ss"
            "pretty-helper.ss"
            "interfaces.ss"
-           "params.ss")
+           "params.ss"
-  (provide syntax-pp%
+           "prefs.ss")
-           (struct range (obj start end)))
 
-  ;; syntax-pp%
+  (provide pretty-print-syntax)
-  ;; Pretty printer for syntax objects.
-  (define syntax-pp%
-    (class* object% (syntax-pp<%>)
-      (init-field main-stx)
-      (init-field typesetter)
-      (init-field (primary-partition #f))
-      (init-field (columns (current-default-columns)))
 
-      (unless (syntax? main-stx)
+  ;; pretty-print-syntax : syntax port partition -> range%
-        (error 'syntax-pretty-printer "got non-syntax object: ~s" main-stx))
+  (define (pretty-print-syntax stx port primary-partition)
-
+    (define range-builder (new range-builder%))
-      (define datum #f)
+    (define-values (datum ht:flat=>stx ht:stx=>flat)
-      (define ht:flat=>stx #f)
+      (syntax->datum/tables stx primary-partition
-      (define ht:stx=>flat #f)
+                            (length (current-colors))
-      (define identifier-list null)
+                            (current-suffix-option)))
-      (define -range #f)
+    (define identifier-list
-      
+      (filter identifier? (hash-table-map ht:stx=>flat (lambda (k v) k))))
-      (define/public (get-range) -range)
+    (define (flat=>stx obj)
-      (define/public (get-identifier-list) identifier-list)
-      (define/public (flat=>stx obj)
       (hash-table-get ht:flat=>stx obj))
-      (define/public (stx=>flat obj)
+    (define (stx=>flat stx)
-        (hash-table-get ht:stx=>flat obj))
+      (hash-table-get ht:stx=>flat stx))
-      
+    (define (current-position)
-      (define/public (pretty-print-syntax)
+      (let-values ([(line column position) (port-next-location port)])
-        (define range (new ranges%))
+        (sub1 position)))
     (define (pp-pre-hook obj port)
-          (send range set-start obj (send typesetter get-current-position)))
+      (send range-builder set-start obj (current-position)))
     (define (pp-post-hook obj port)
-          (let ([start (send range get-start obj)]
+      (let ([start (send range-builder get-start obj)]
-                [end (send typesetter get-current-position)])
+            [end (current-position)]
-            (when start
+            [stx (flat=>stx obj)])
-              (send range add-range
+        (when (and start stx)
-                    (flat=>stx obj)
+          (send range-builder add-range stx (cons start end)))))
-                    (cons start end)))))
+    (define (pp-extend-style-table identifier-list)
-        (define (pp-size-hook obj display-like? port)
+      (let* ([syms (map (lambda (x) (stx=>flat x)) identifier-list)]
-          (cond [(is-a? obj editor-snip%)
+             [like-syms (map syntax-e identifier-list)])
-                 columns]
-                [(syntax-dummy? obj)
-                 (let ((ostring (open-output-string)))
-                   ((if display-like? display write) (syntax-dummy-val obj) ostring)
-                   (string-length (get-output-string ostring)))]
-                [else #f]))
-        (define (pp-print-hook obj display-like? port)
-          (cond [(syntax-dummy? obj)
-                 ((if display-like? display write) (syntax-dummy-val obj) port)]
-                [(is-a? obj editor-snip%)
-                 (write-special obj port)]
-                [else 
-                 (error 'pretty-print-hook "unexpected special value: ~e" obj)]))
-        (define (pp-extend-style-table)
-          (let* ([ids identifier-list]
-                 [syms (map (lambda (x) (stx=>flat x)) ids)]
-                 [like-syms (map syntax-e ids)])
         (pretty-print-extend-style-table (pp-better-style-table)
                                          syms
                                          like-syms)))
-        (define (pp-better-style-table)
-          (pretty-print-extend-style-table (pretty-print-current-style-table)
-                                           (map car extended-style-list)
-                                           (map cdr extended-style-list)))
 
+
+    (unless (syntax? stx)
+      (raise-type-error 'pretty-print-syntax "syntax" stx))
     (parameterize 
      ([pretty-print-pre-print-hook pp-pre-hook]
       [pretty-print-post-print-hook pp-post-hook]
       [pretty-print-size-hook pp-size-hook]
       [pretty-print-print-hook pp-print-hook]
-             [pretty-print-columns columns]
+      [pretty-print-current-style-table (pp-extend-style-table identifier-list)]
-             [pretty-print-current-style-table (pp-extend-style-table)]
+      [pretty-print-columns (current-default-columns)]
       ;; Printing parameters (mzscheme manual 7.9.1.4)
       [print-unreadable #t]
       [print-graph #f]
@@ -91,23 +62,100 @@
       [print-vector-length #t]
       [print-hash-table #f]
       [print-honu #f])
-          (pretty-print datum (send typesetter get-output-port))
+     (pretty-print datum port)
-          (set! -range range)))
+     (new range%
+          (range-builder range-builder)
+          (identifier-list identifier-list))))
 
-      ;; recompute-tables : -> void
+  (define (pp-print-hook obj display-like? port)
-      (define/private (recompute-tables)
+    (cond [(syntax-dummy? obj)
-        (set!-values (datum ht:flat=>stx ht:stx=>flat)
+           ((if display-like? display write) (syntax-dummy-val obj) port)]
-                     (syntax->datum/tables main-stx primary-partition
+          [(is-a? obj editor-snip%)
-                                           (length (current-colors))
+           (write-special obj port)]
-                                           (current-suffix-option)))
+          [else 
-        (set! identifier-list 
+           (error 'pretty-print-hook "unexpected special value: ~e" obj)]))
-              (filter identifier? (hash-table-map ht:stx=>flat (lambda (k v) k)))))
 
-      ;; Initialization
+  (define (pp-size-hook obj display-like? port)
-      (recompute-tables)
+    (cond [(is-a? obj editor-snip%)
-      (super-new)))
+           (pretty-print-columns)]
+          [(syntax-dummy? obj)
+           (let ((ostring (open-output-string)))
+             ((if display-like? display write) (syntax-dummy-val obj) ostring)
+             (string-length (get-output-string ostring)))]
+          [else #f]))
 
-  (define extended-style-list
+  (define (pp-better-style-table)
+    (let* ([pref (pref:tabify)]
+           [table (car pref)]
+           [begin-rx (cadr pref)]
+           [define-rx (caddr pref)]
+           [lambda-rx (cadddr pref)])
+      (let ([style-list (hash-table-map table cons)])
+        (pretty-print-extend-style-table
+         (basic-style-list)
+         (map car style-list)
+         (map cdr style-list)))))
+
+  (define (basic-style-list)
+    (pretty-print-extend-style-table
+     (pretty-print-current-style-table)
+     (map car basic-styles)
+     (map cdr basic-styles)))
+  (define basic-styles
     '((define-values          . define)
       (define-syntaxes        . define-syntax)))
+
+  (define-local-member-name range:get-ranges)
+
+  ;; range-builder%
+  (define range-builder%
+    (class object%
+      (define starts (make-hash-table))
+      (define ranges (make-hash-table))
+
+      (define/public (set-start obj n)
+        (hash-table-put! starts obj n))
+
+      (define/public (get-start obj)
+        (hash-table-get starts obj (lambda _ #f)))
+
+      (define/public (add-range obj range)
+        (hash-table-put! ranges obj (cons range (get-ranges obj))))
+
+      (define (get-ranges obj)
+        (hash-table-get ranges obj (lambda () null)))
+
+      (define/public (range:get-ranges) ranges)
+
+      (super-new)))
+
+  ;; range%
+  (define range%
+    (class* object% (range<%>)
+      (init range-builder)
+      (init-field identifier-list)
+      (super-new)
+
+      (define ranges (hash-table-copy (send range-builder range:get-ranges)))
+
+      (define/public (get-ranges obj)
+        (hash-table-get ranges obj (lambda _ null)))
+
+      (define/public (all-ranges)
+        sorted-ranges)
+
+      (define/public (get-identifier-list)
+        identifier-list)
+
+      (define sorted-ranges
+        (sort 
+         (apply append 
+                (hash-table-map
+                 ranges
+                 (lambda (k vs)
+                   (map (lambda (v) (make-range k (car v) (cdr v))) vs))))
+         (lambda (x y)
+           (>= (- (range-end x) (range-start x))
+               (- (range-end y) (range-start y))))))))
+
   )

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

@@ -4,27 +4,33 @@
            "util.ss"
            (lib "class.ss")
            (lib "mred.ss" "mred")
-           (lib "framework.ss" "framework")
+           #;(lib "framework.ss" "framework")
-           (lib "interactive-value-port.ss" "mrlib"))
+           #;(lib "interactive-value-port.ss" "mrlib"))
   (provide properties-view%
            properties-snip%)
 
   ;; properties-view-base-mixin
   (define properties-view-base-mixin
     (mixin () ()
-      (init)
+      ;; controller : controller<%>
+      (init-field controller)
 
       ;; selected-syntax : syntax
       (field (selected-syntax #f))
 
-      ;; set-syntax : syntax -> void
-      (define/public (set-syntax stx)
-        (set! selected-syntax stx)
-        (refresh))
-
       ;; mode : maybe symbol in '(term stxobj)
       (define mode 'term)
 
+      ;; text : text%
+      (field (text (new text%)))
+      (field (pdisplayer (new properties-displayer% (text text))))
+
+      (send controller listen-selected-syntax
+            (lambda (stx)
+              (set! selected-syntax stx)
+              (refresh)))
+      (super-new)
+
       ;; get-mode : -> symbol
       (define/public (get-mode) mode)
 
@@ -53,17 +59,13 @@
           ((term) (send pdisplayer display-meaning-info selected-syntax))
           ((stxobj) (send pdisplayer display-stxobj-info selected-syntax))
           ((#f) (send pdisplayer display-null-info))
-          (else (error 'properties-view%:refresh "internal error: no such mode: ~s" mode))))
+          (else (error 'properties-view-base:refresh
-
+                       "internal error: no such mode: ~s" mode))))
-      ;; text : text%
-      (field (text (new text%))) ;; text:wide-snip%)))
-      (field (pdisplayer (new properties-displayer% (text text))))
 
       (send text set-styles-sticky #f)
       #;(send text hide-caret #t)
       (send text lock #t)
-      (refresh)
+      (refresh)))
-      (super-new)))
 
 
   ;; properties-snip%
@@ -113,14 +115,13 @@
 
       (super-new)
       (define tab-choices (get-tab-choices))
-      (define tab-panel (new tab-panel% 
+      (define tab-panel
+        (new tab-panel% 
              (choices (map car tab-choices))
              (parent parent)
              (callback
               (lambda (tp e)
-                                (set-mode
+                (set-mode (cdr (list-ref tab-choices (send tp get-selection))))))))
-                                 (cdr (list-ref tab-choices (send tp get-selection))))))))
-      ;; canvas:wide-?%
       (define ecanvas (new editor-canvas% (editor text) (parent tab-panel)))))
 
   ;; properties-displayer%
@@ -267,20 +268,6 @@
            'editor]
           [else s]))
   
-  ;; make-text-port : text -> port
-  ;; builds a port from a text object.  
-  (define (make-text-port text)
-    (make-output-port #f
-                      always-evt
-                      (lambda (s start end flush? enable-break?)
-                        (send text insert
-                              (bytes->string/utf-8 s #f start end))
-                        (- end start))
-                      void
-                      (lambda (special buffer? enable-break?)
-                        (send text insert special)
-                        #t)))
-
   ;; Styles
     
   (define key-sd

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

@@ -1,84 +1,44 @@
 
 (module syntax-snip mzscheme
   (require (lib "class.ss")
-           (lib "unit.ss")
            (lib "mred.ss" "mred")
            (lib "framework.ss" "framework")
+           (lib "match.ss")
+           (lib "list.ss")
+           (lib "string.ss")
            "interfaces.ss"
+           "display.ss"
            "controller.ss"
            "properties.ss"
-           "typesetter.ss"
            "partition.ss")
-  (provide snip@
-           snip-keymap-extension@)
 
-  ;; Every snip has its own controller and properties-controller
+  (provide syntax-value-snip%)
-  ;; (because every snip now displays its own properties)
-
-  (define snip@
-    (unit
-      (import prefs^
-              keymap^
-              context-menu^
-              snipclass^)
-      (export snip^)
-
-      ;; syntax-snip : syntax -> snip
-      (define (syntax-snip stx)
-        (new syntax-snip% (syntax stx)))
 
   ;; syntax-value-snip%
   (define syntax-value-snip%
     (class* editor-snip% (readable-snip<%>)
       (init-field ((stx syntax)))
-          (init-field controller)
+      (init-field host)
       (inherit set-margin
                set-inset)
 
-          (define -outer (new text:standard-style-list%))
+      (define text (new text:standard-style-list%))
-          (super-new (editor -outer) (with-border? #f))
+      (super-new (editor text) (with-border? #f))
       (set-margin 0 0 0 0)
       (set-inset 2 2 2 2)
-          (send -outer change-style (make-object style-delta% 'change-alignment 'top))
+      (send text begin-edit-sequence)
-          (new syntax-keymap%
+      (send text change-style (make-object style-delta% 'change-alignment 'top))
-               (editor -outer)
+      (define display
-               (snip this))
+        (print-syntax-to-editor stx text (send host get-controller)))
-          (refresh)
+      (send text lock #t)
+      (send text end-edit-sequence)
+      (send text hide-caret #t)
 
-          (define/public (get-controller) controller)
+      (send host add-keymap text this)
-
-          (define/private (refresh)
-            (send -outer begin-edit-sequence)
-            (send -outer erase)
-            (new typesetter-for-text%
-                 (syntax stx)
-                 (controller controller)
-                 (text -outer))
-            (send -outer lock #t)
-            (send -outer end-edit-sequence)
-            (send -outer hide-caret #t))
-          
-          (define/public (show-props)
-            (send (send controller get-properties-controller)
-                  show #t))
-          
-          (define/private outer:insert
-            (case-lambda
-              [(obj)
-               (outer:insert obj style:normal)]
-              [(text style)
-               (outer:insert text style #f)]
-              [(text style clickback)
-               (let ([start (send -outer last-position)])
-                 (send -outer insert text)
-                 (let ([end (send -outer last-position)])
-                   (send -outer change-style style start end #f)
-                   (when clickback
-                     (send -outer set-clickback start end clickback))))]))
 
       ;; snip% Methods
       (define/override (copy)
-            (new syntax-value-snip% (controller controller) (syntax stx)))
+        (new syntax-value-snip% (host host) (syntax stx)))
 
       ;; read-special : any number/#f number/#f number/#f -> syntax
       ;; Produces 3D syntax to preserve eq-ness of syntax
@@ -88,11 +48,12 @@
           #'(p)))
       ))
 
-
   ;; syntax-snip%
+  #;
   (define syntax-snip%
     (class* editor-snip% (readable-snip<%>)
       (init-field ((stx syntax)))
+      (init-field primary-partition)
       (inherit set-margin
                set-inset
                set-snipclass
@@ -100,10 +61,7 @@
                show-border
                get-admin)
 
-          (define controller
-            (new syntax-controller% (primary-partition (find-primary-partition))))
       (define properties-snip (new properties-snip%))
-          (send controller set-properties-controller this)
 
       (define -outer (new text%))
       (super-new (editor -outer) (with-border? #f))
@@ -113,7 +71,12 @@
       (send -outer select-all)
 
       (define the-syntax-snip
-            (new syntax-value-snip% (syntax stx) (controller controller)))
+        (new syntax-value-snip%
+             (syntax stx)
+             (controller controller)
+             ;; FIXME
+             #;(syntax-keymap% syntax-keymap%)
+             ))
       (define the-summary
         (let ([line (syntax-line stx)]
               [col (syntax-column stx)])
@@ -231,8 +194,9 @@
         (send parent is-shown?))
 
       (super-new)))
-      ))
 
+
+  #;
   (define snip-keymap-extension@
     (unit
       (import (prefix pre: keymap^))
@@ -310,4 +274,74 @@
            (null? obj))
        `(other ,obj)]
       [else (string->symbol (format "unknown-object: ~s" obj))]))
+
+  ;; COPIED AND MODIFIED from mrlib/syntax-browser.ss
+  #;
+  (define syntax-snipclass%
+    (class snip-class%
+      (define/override (read stream)
+        (make-object syntax-snip%
+          (unmarshall-syntax (read-from-string (send stream get-bytes)))))
+      (super-instantiate ())))
+
+  #;(define snip-class (make-object syntax-snipclass%))
+  #;(send snip-class set-version 2)
+  #;(send snip-class set-classname
+        (format "~s" '(lib "implementation.ss" "macro-debugger" "syntax-browser")))
+  #;(send (get-the-snip-class-list) add snip-class)
+  
+  (define (unmarshall-syntax stx)
+    (match stx
+      [`(syntax
+         (source ,src)
+         (source-module ,source-module) ;; marshalling
+         (position ,pos)
+         (line ,line)
+         (column ,col)
+         (span ,span)
+         (original? ,original?)
+         (properties ,@(properties ...))
+         (contents ,contents))
+        (foldl
+         add-properties
+         (datum->syntax-object
+          #'here ;; ack
+          (unmarshall-object contents)
+          (list (unmarshall-object src)
+                line
+                col
+                pos
+                span))
+         properties)]
+      [else #'unknown-syntax-object]))
+  
+  ;; add-properties : syntax any -> syntax
+  (define (add-properties prop-spec stx)
+    (match prop-spec
+      [`(,(and sym (? symbol?))
+          ,prop)
+        (syntax-property stx sym (unmarshall-object prop))]
+      [else stx]))
+  
+  (define (unmarshall-object obj)
+    (let ([unknown (lambda () (string->symbol (format "unknown: ~s" obj)))])
+      (if (and (pair? obj)
+               (symbol? (car obj)))
+          (case (car obj)
+            [(pair) 
+             (if (pair? (cdr obj))
+                 (let ([raw-obj (cadr obj)])
+                   (if (pair? raw-obj)
+                       (cons (unmarshall-object (car raw-obj))
+                             (unmarshall-object (cdr raw-obj)))
+                       (unknown)))
+                 (unknown))]
+            [(other) 
+             (if (pair? (cdr obj))
+                 (cadr obj)
+                 (unknown))]
+            [(syntax) (unmarshall-syntax obj)]
+            [else (unknown)])
+          (unknown))))
+
   )

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

@@ -6,14 +6,26 @@
            (lib "arrow.ss" "drscheme")
            (lib "framework.ss" "framework"))
 
-  (provide text:drawings<%>
+  (provide text:mouse-drawings<%>
-           text:mouse-drawings<%>
            text:arrows<%>
 
-           text:drawings-mixin
            text:mouse-drawings-mixin
+           text:tacking-mixin
            text:arrows-mixin)
 
+  (define arrow-brush
+    (send the-brush-list find-or-create-brush "white" 'solid))
+  (define (tacked-arrow-brush color)
+    (send the-brush-list find-or-create-brush color 'solid))
+
+  (define billboard-brush
+    (send the-brush-list find-or-create-brush "white" 'solid))
+
+  (define white (send the-color-database find-color "white"))
+
+  ;; A Drawing is (make-drawing number number (??? -> void) boolean boolean)
+  (define-struct drawing (start end draw visible? tacked?) #f)
+
   (define (mean x y)
     (/ (+ x y) 2))
 
@@ -45,76 +57,49 @@
               (send dc set-text-background old-background)
               (send dc set-text-mode old-mode))))
 
-  (define text:drawings<%>
-    (interface (text:basic<%>)
-      add-drawings
-      delete-drawings
-      delete-all-drawings))
-
   (define text:mouse-drawings<%>
-    (interface (text:drawings<%>)
+    (interface (text:basic<%>)
       add-mouse-drawing
-      delete-mouse-drawings))
+      for-each-drawing
+      delete-all-drawings))
 
   (define text:arrows<%>
     (interface (text:mouse-drawings<%>)
       add-arrow
-      add-question-arrow))
+      add-question-arrow
+      add-billboard))
 
-  (define text:drawings-mixin
+  (define text:mouse-drawings-mixin
-    (mixin (text:basic<%>) (text:drawings<%>)
+    (mixin (text:basic<%>) (text:mouse-drawings<%>)
-      (define draw-table (make-hash-table))
+      (inherit dc-location-to-editor-location
+               find-position
+               invalidate-bitmap-cache)
 
-      (define/public (add-drawings key draws)
+      ;; list of Drawings
-        (hash-table-put! draw-table
+      (field [drawings-list null])
-                         key
-                         (append draws (hash-table-get draw-table key (lambda () null)))))
 
-      (define/public (delete-drawings key)
+      (define/public add-mouse-drawing
-        (hash-table-remove! draw-table key))
+        (case-lambda
+          [(start end draw)
+           (add-mouse-drawing start end draw (box #f))]
+          [(start end draw tack-box)
+           (set! drawings-list 
+                 (cons (make-drawing start end draw #f tack-box)
+                       drawings-list))]))
 
       (define/public (delete-all-drawings)
-        (for-each (lambda (key) (hash-table-remove! draw-table key))
+        (set! drawings-list null))
-                  (hash-table-map draw-table (lambda (k v) k))))
+
+      (define/public-final (for-each-drawing f)
+        (for-each f drawings-list))
 
       (define/override (on-paint before? dc left top right bottom dx dy draw-caret)
         (super on-paint before? dc left top right bottom dx dy draw-caret)
         (unless before?
-          (hash-table-for-each
+          (for-each-drawing
-           draw-table
+           (lambda (d)
-           (lambda (k v)
+             (when (or (drawing-visible? d) (unbox (drawing-tacked? d)))
-             (for-each (lambda (d) (d this dc left top right bottom dx dy))
+               ((drawing-draw d) this dc left top right bottom dx dy))))))
-                       v)))))
-
-      (super-new)))
-
-  ;; A Drawing is (make-drawing number number (??? -> void))
-  (define-struct drawing (start end draw) #f)
-
-  (define text:mouse-drawings-mixin
-    (mixin (text:drawings<%>) (text:mouse-drawings<%>)
-      (inherit dc-location-to-editor-location
-               find-position
-               invalidate-bitmap-cache
-               add-drawings
-               delete-drawings)
-
-      ;; lists of Drawings
-      (field [inactive-list null]
-             [active-list null])
-      
-      (define/public (add-mouse-drawing start end draw)
-        (set! inactive-list 
-              (cons (make-drawing start end draw)
-                    inactive-list)))
-      
-      (define/public (delete-mouse-drawings)
-        (set! inactive-list null))
-
-      (define/override (delete-all-drawings)
-        (super delete-all-drawings)
-        (set! inactive-list null)
-        (set! active-list null))
 
       (define/override (on-default-event ev)
         (define gx (send ev get-x))
@@ -123,35 +108,69 @@
         (define pos (find-position x y))
         (super on-default-event ev)
         (case (send ev get-event-type)
-          ((enter motion)
+          ((enter motion leave)
-           (let ([new-active-annotations
+           (let ([changed? (update-visible-drawings pos)])
-                  (filter (lambda (rec)
+             (when changed? (invalidate-bitmap-cache 0.0 0.0 +inf.0 +inf.0))))))
-                            (<= (drawing-start rec) pos (drawing-end rec)))
+
-                          inactive-list)])
+      (define/private (update-visible-drawings pos)
-             (unless (equal? active-list new-active-annotations)
+        (let ([changed? #f])
-               (set! active-list new-active-annotations)
+          (for-each-drawing
-               (delete-drawings 'mouse-over)
+           (lambda (d)
-               (add-drawings 'mouse-over (map drawing-draw active-list))
+             (let ([vis? (<= (drawing-start d) pos (drawing-end d))])
-               (invalidate-bitmap-cache))))
+               (unless (eqv? vis? (drawing-visible? d))
-          ((leave)
+                 (set-drawing-visible?! d vis?)
-           (unless (null? active-list)
+                 (set! changed? #t)))))
-             (set! active-list null)
+          changed?))
-             (delete-drawings 'mouse-over)
-             (invalidate-bitmap-cache)))))
 
       (super-new)))
 
-  (define arrow-brush (send the-brush-list find-or-create-brush "white" 'solid))
+  (define text:tacking-mixin
+    (mixin (text:basic<%> text:mouse-drawings<%>) ()
+      (inherit get-canvas
+               for-each-drawing)
+      (inherit-field drawings-list)
+      (super-new)
+
+      (define/override (on-event ev)
+        (case (send ev get-event-type)
+          ((right-down)
+           (if (ormap (lambda (d) (drawing-visible? d)) drawings-list)
+               (send (get-canvas) popup-menu
+                     (make-tack/untack-menu)
+                     (send ev get-x)
+                     (send ev get-y))
+               (super on-event ev)))
+          (else
+           (super on-event ev))))
+
+      (define/private (make-tack/untack-menu)
+        (define menu (new popup-menu%))
+        (new menu-item% (label "Tack")
+             (parent menu)
+             (callback
+              (lambda _ (tack))))
+        (new menu-item% (label "Untack")
+             (parent menu)
+             (callback
+              (lambda _ (untack))))
+        menu)
+
+      (define/private (tack)
+        (for-each-drawing
+         (lambda (d)
+           (when (drawing-visible? d)
+             (set-box! (drawing-tacked? d) #t)))))
+      (define/private (untack)
+        (for-each-drawing
+         (lambda (d)
+           (when (drawing-visible? d)
+             (set-box! (drawing-tacked? d) #f)))))))
 
   (define text:arrows-mixin
     (mixin (text:mouse-drawings<%>) (text:arrows<%>)
       (inherit position-location
                add-mouse-drawing
-               find-wordbreak
+               find-wordbreak)
-               add-drawings
-               delete-drawings
-               get-canvas)
-      (inherit-field active-list inactive-list)
 
       (define/public (add-arrow from1 from2 to1 to2 color)
         (internal-add-arrow from1 from2 to1 to2 color #f))
@@ -159,36 +178,62 @@
       (define/public (add-question-arrow from1 from2 to1 to2 color)
         (internal-add-arrow from1 from2 to1 to2 color #t))
 
-      (define/private (internal-add-arrow from1 from2 to1 to2 color question?)
+      (define/public (add-billboard pos1 pos2 str color-name)
+        (define color (send the-color-database find-color color-name))
+        (let ([draw 
+               (lambda (text dc left top right bottom dx dy)
+                 (let-values ([(x y) (range->mean-loc pos1 pos1)]
+                              [(fw fh _d _v) (send dc get-text-extent "y")])
+                   (with-saved-pen&brush dc
+                     (with-saved-text-config dc
+                       (send* dc
+                         (set-pen color 1 'solid)
+                         (set-brush billboard-brush)
+                         (set-text-mode 'solid)
+                         (set-font (billboard-font dc))
+                         (set-text-foreground color))
+                       (let-values ([(w h d v) (send dc get-text-extent str)]
+                                    [(adj-y) fh]
+                                    [(mini) _d])
+                         (send* dc
+                           (draw-rounded-rectangle
+                            (+ x dx)
+                            (+ y dy adj-y)
+                            (+ w mini mini)
+                            (+ h mini mini))
+                           (draw-text str (+ x dx mini) (+ y dy mini adj-y))))))))])
+          (add-mouse-drawing pos1 pos2 draw)))
+
+      (define/private (internal-add-arrow from1 from2 to1 to2 color-name question?)
+        (define color (send the-color-database find-color color-name))
+        (define tack-box (box #f))
         (unless (and (= from1 to1) (= from2 to2))
           (let ([draw 
                  (lambda (text dc left top right bottom dx dy)
-                   (let*-values ([(start1x start1y) (position->location from1)]
+                   (let-values ([(startx starty) (range->mean-loc from1 from2)]
-                                 [(start2x start2y) (position->location from2)]
+                                [(endx endy) (range->mean-loc to1 to2)]
-                                 [(end1x end1y) (position->location to1)]
+                                [(fw fh _d _v) (send dc get-text-extent "x")])
-                                 [(end2x end2y) (position->location to2)]
-                                 [(startx) (mean start1x start2x)]
-                                 [(starty) (mean start1y start2y)]
-                                 [(endx) (mean end1x end2x)]
-                                 [(endy) (mean end1y end2y)]
-                                 [(fw fh _d _v) (send dc get-text-extent "")])
-                     (let ([starty (+ starty (/ fh 2))]
-                           [endy (+ endy (/ fh 2))])
                      (with-saved-pen&brush dc
                        (with-saved-text-config dc
                          (send dc set-pen color 1 'solid)
-                           (send dc set-brush arrow-brush)
+                         (send dc set-brush
-                           (draw-arrow dc startx starty endx endy dx dy)
+                               (if (unbox tack-box)
-                           #;(send dc set-text-mode 'solid)
+                                   (tacked-arrow-brush color)
+                                   arrow-brush))
+                         (draw-arrow dc startx
+                                     (+ starty (/ fh 2))
+                                     endx
+                                     (+ endy (/ fh 2))
+                                     dx dy)
+                         (send dc set-text-mode 'transparent)
                          (when question?
                            (send dc set-font (?-font dc))
-                             (send dc set-text-foreground 
+                           (send dc set-text-foreground color)
-                                   (send the-color-database find-color color))
                            (send dc draw-text "?" 
-                                   (+ (+ startx dx) fw)
+                                 (+ endx dx fw)
-                                   (- (+ starty dy) fh))))))))])
+                                 (- endy dy fh)))))))])
-            (add-mouse-drawing from1 from2 draw)
+            (add-mouse-drawing from1 from2 draw tack-box)
-            (add-mouse-drawing to1 to2 draw))))
+            (add-mouse-drawing to1 to2 draw tack-box))))
 
       (define/private (position->location p)
         (define xbox (box 0.0))
@@ -196,62 +241,29 @@
         (position-location p xbox ybox)
         (values (unbox xbox) (unbox ybox)))
 
-      (define/override (on-event ev)
-        (case (send ev get-event-type)
-          ((right-down)
-           (let ([arrows active-list])
-             (if (pair? arrows)
-                 (send (get-canvas) popup-menu
-                       (make-tack/untack-menu)
-                       (send ev get-x)
-                       (send ev get-y))
-                 (super on-event ev))))
-          (else
-           (super on-event ev))))
-
-      (define/private (make-tack/untack-menu)
-        (define menu (new popup-menu%))
-        (new menu-item% (label "Tack arrows")
-             (parent menu)
-             (callback
-              (lambda _ (tack-arrows))))
-        (new menu-item% (label "Untack arrows")
-             (parent menu)
-             (callback
-              (lambda _ (untack-arrows))))
-        menu)
-
-      (define/private (tack-arrows)
-        (for-each (lambda (arrow) 
-                    (add-drawings (drawing-draw arrow) (list (drawing-draw arrow))))
-                  active-list))
-      (define/private (untack-arrows)
-        (for-each (lambda (arrow) (delete-drawings (drawing-draw arrow)))
-                  active-list))
-
       (define/private (?-font dc)
         (let ([size (send (send dc get-font) get-point-size)])
           (send the-font-list find-or-create-font size 'default 'normal 'bold)))
 
+      (define/private (billboard-font dc)
+        (let ([size (send (send dc get-font) get-point-size)])
+          (send the-font-list find-or-create-font size 'default 'normal)))
+
+      (define/private (range->mean-loc pos1 pos2)
+        (let*-values ([(loc1x loc1y) (position->location pos1)]
+                      [(loc2x loc2y) (position->location pos2)]
+                      [(locx) (mean loc1x loc2x)]
+                      [(locy) (mean loc1y loc2y)])
+          (values locx locy)))
+
       (super-new)))
 
   (define text:mouse-drawings%
     (text:mouse-drawings-mixin
-     (text:drawings-mixin text:standard-style-list%)))
+     text:standard-style-list%))
 
   (define text:arrows%
-    (text:arrows-mixin text:mouse-drawings%))
+    (text:arrows-mixin
-
+     (text:tacking-mixin
-  #;
+      text:mouse-drawings%)))
-  (begin
-    (define f (new frame% (label "testing") (width 100) (height 100)))
-    (define t (new text:crazy% (auto-wrap #t)))
-    (define ec (new editor-canvas% (parent f) (editor t)))
-    (send f show #t)
-    (send t insert "this is the time to remember, because it will not last forever\n")
-    (send t insert "these are the days to hold on to, but we won't although we'll want to\n")
-    
-    (send t add-dot 5)
-    (send t add-arrow 25 8 "blue"))
-  
   )

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

@@ -2,9 +2,12 @@
 (module util mzscheme
   (require (lib "class.ss"))
   (provide with-unlock
+           make-text-port
            mpi->string
            mpi->list)
 
+  ;; with-unlock SYNTAX (expression)
+  ;; (with-unlock text-expression . body)
   (define-syntax with-unlock
     (syntax-rules ()
       [(with-unlock text . body)
@@ -14,6 +17,22 @@
          (begin0 (let () . body)
                  (send t lock locked?)))]))
 
+  ;; make-text-port : text (-> number) -> port
+  ;; builds a port from a text object.  
+  (define (make-text-port text end-position)
+    (make-output-port #f
+                      always-evt
+                      (lambda (s start end flush? enable-break?)
+                        (send text insert
+                              (bytes->string/utf-8 s #f start end)
+                              (end-position))
+                        (- end start))
+                      void
+                      (lambda (special buffer? enable-break?)
+                        (send text insert special (end-position))
+                        #t)))
+
+  ;; mpi->string : module-path-index -> string
   (define (mpi->string mpi)
     (if (module-path-index? mpi)
         (let ([mps (mpi->list mpi)])
@@ -26,6 +45,7 @@
                 [(null? mps) "this module"]))
         (format "~s" mpi)))
 
+  ;; mpi->list : module-path-index -> (list-of module-spec)
   (define (mpi->list mpi)
     (if mpi
         (let-values ([(path rel) (module-path-index-split mpi)])

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

@@ -1,53 +1,52 @@
 
 (module widget mzscheme
   (require (lib "class.ss")
-           (lib "unit.ss")
            (lib "mred.ss" "mred")
            (lib "framework.ss" "framework")
            (lib "list.ss")
+           (lib "plt-match.ss")
            (lib "kw.ss")
            (lib "boundmap.ss" "syntax")
            "interfaces.ss"
            "params.ss"
            "controller.ss"
-           "typesetter.ss"
+           "display.ss"
+           "keymap.ss"
            "hrule-snip.ss"
            "properties.ss"
            "text.ss"
            "util.ss")
-  (provide widget@
+  (provide widget%
-           widget-keymap-extension@
+           widget-keymap%
-           widget-context-menu-extension@)
+           widget-context-menu%)
 
-  (define widget@
+  ;; widget%
-    (unit
+  ;; A syntax widget creates its own syntax-controller.
-      (import keymap^)
+  (define widget%
-      (export widget^)
+    (class* object% (widget-hooks<%>)
-
-      ;; syntax-widget%
-      ;; A syntax-widget creates its own syntax-controller.
-      (define syntax-widget%
-        (class* object% (syntax-browser<%> syntax-properties-controller<%>)
       (init parent)
-          (init-field pref:props-percentage)
+      (init-field config)
 
-          (define -main-panel (new vertical-panel% (parent parent)))
+      (define controller (new controller%))
-          (define -split-panel (new panel:horizontal-dragable% (parent -main-panel)))
+
+      (define -main-panel
+        (new vertical-panel% (parent parent)))
+      (define -split-panel
+        (new panel:horizontal-dragable% (parent -main-panel)))
       (define -text (new browser-text%))
-          (define -ecanvas (new editor-canvas% (parent -split-panel) (editor -text)))
+      (define -ecanvas
+        (new editor-canvas% (parent -split-panel) (editor -text)))
       (define -props-panel (new horizontal-panel% (parent -split-panel)))
-          (define props (new properties-view% (parent -props-panel)))
+      (define props
-          (define props-percentage (pref:props-percentage))
+        (new properties-view%
+             (parent -props-panel)
+             (controller controller)))
+      (define props-percentage (send config pref:props-percentage))
 
-          (define controller
+      (define/public (setup-keymap)
-            (new syntax-controller%
+        (new widget-keymap% 
-                 (properties-controller this)))
+             (editor -text)
-          
-          (define/public (make-keymap text)
-            (new syntax-keymap% 
-                 (editor text)
              (widget this)))
-          (make-keymap -text)
 
       (send -text lock #t)
       (send -split-panel set-percentages 
@@ -85,9 +84,9 @@
 
       (define/public (get-main-panel) -main-panel)
 
-          (define/public (save-prefs)
+      (define/public (shutdown)
-            (unless (= props-percentage (pref:props-percentage))
+        (unless (= props-percentage (send config pref:props-percentage))
-              (pref:props-percentage props-percentage)))
+          (send config pref:props-percentage props-percentage)))
 
       ;; syntax-browser<%> Methods
 
@@ -98,39 +97,59 @@
       (define/public add-syntax
         (lambda/kw (stx #:key [hi-stxs null] hi-color alpha-table [definites null]
                         hi2-color [hi2-stxs null])
+          (define (get-binder id)
+            (module-identifier-mapping-get alpha-table id (lambda () #f)))
           (when (and (pair? hi-stxs) (not hi-color))
             (error 'syntax-widget%::add-syntax "no highlight color specified"))
-              (let ([colorer (internal-add-syntax stx)]
+          (let ([display (internal-add-syntax stx)]
                 [definite-table (make-hash-table)])
             (when (and hi2-color (pair? hi2-stxs))
-                  (send colorer highlight-syntaxes hi2-stxs hi2-color))
+              (send display highlight-syntaxes hi2-stxs hi2-color))
             (when (and hi-color (pair? hi-stxs))
-                  (send colorer highlight-syntaxes hi-stxs hi-color))
+              (send display highlight-syntaxes hi-stxs hi-color))
             (for-each (lambda (x) (hash-table-put! definite-table x #t)) definites)
             (when alpha-table
-                  (let ([range (send colorer get-range)])
+              (let ([range (send display get-range)]
-                    (for-each (lambda (id)
+                    [start (send display get-start-position)])
-                                (let ([binder
+                (define (adjust n) (+ start n))
-                                       (module-identifier-mapping-get alpha-table
+                (for-each
-                                                                      id
+                 (lambda (id)
-                                                                      (lambda () #f))])
+                   #; ;; DISABLED
+                   (match (identifier-binding id)
+                     [(list src-mod src-name nom-mod nom-name _)
+                      (for-each (lambda (id-r)
+                                  (send -text add-billboard
+                                        (adjust (car id-r))
+                                        (adjust (cdr id-r))
+                                        (string-append "from "
+                                                       (mpi->string src-mod))
+                                        (if (hash-table-get definite-table id #f)
+                                            "blue"
+                                            "purple")))
+                                (send range get-ranges id))]
+                     [_ (void)])
+                   (let ([binder (get-binder id)])
                      (when binder
                        (for-each
                         (lambda (binder-r)
                           (for-each (lambda (id-r)
                                       (if (hash-table-get definite-table id #f)
                                           (send -text add-arrow
-                                                             (car id-r) (cdr id-r)
+                                                (adjust (car binder-r))
-                                                             (car binder-r) (cdr binder-r)
+                                                (adjust (cdr binder-r))
+                                                (adjust (car id-r))
+                                                (adjust (cdr id-r))
                                                 "blue")
                                           (send -text add-question-arrow
-                                                             (car id-r) (cdr id-r)
+                                                (adjust (car binder-r))
-                                                             (car binder-r) (cdr binder-r)
+                                                (adjust (cdr binder-r))
+                                                (adjust (car id-r))
+                                                (adjust (cdr id-r))
                                                 "purple")))
                                     (send range get-ranges id)))
                         (send range get-ranges binder)))))
-                              (send colorer get-identifier-list))))
+                 (send range get-identifier-list))))
-                colorer)))
+            display)))
       
       (define/public (add-separator)
         (with-unlock -text
@@ -142,26 +161,23 @@
         (with-unlock -text
           (send -text erase)
           (send -text delete-all-drawings))
-            (send controller erase))
+        (send controller remove-all-syntax-displays))
 
       (define/public (select-syntax stx)
         (send controller select-syntax stx))
 
       (define/public (get-text) -text)
 
+      ;; internal-add-syntax : syntax -> display
       (define/private (internal-add-syntax stx)
         (with-unlock -text
           (parameterize ((current-default-columns (calculate-columns)))
-                (let ([current-position (send -text last-position)])
+            (let ([display (print-syntax-to-editor stx -text controller)])
-                  (let* ([new-ts (new typesetter-for-text%
-                                      (controller controller)
-                                      (syntax stx)
-                                      (text -text))]
-                         [new-colorer (send new-ts get-colorer)])
               (send* -text
                 (insert "\n")
-                      (scroll-to-position current-position))
+                ;(scroll-to-position current-position)
-                    new-colorer)))))
+                )
+              display))))
 
       (define/private (calculate-columns)
         (define style (code-style -text))
@@ -169,35 +185,31 @@
         (define-values (canvas-w canvas-h) (send -ecanvas get-client-size))
         (sub1 (inexact->exact (floor (/ canvas-w char-width)))))
 
-          (super-new)))
+      ;; Initialize
+      (super-new)
+      (setup-keymap)))
 
-      ))
 
-  (define widget-keymap-extension@
+  ;; Specialized classes for widget
-    (unit
-      (import (prefix pre: keymap^))
-      (export keymap^)
 
-      (define syntax-keymap%
+  (define widget-keymap%
-        (class pre:syntax-keymap%
+    (class syntax-keymap%
       (init-field widget)
       (super-new (controller (send widget get-controller)))
       (inherit add-function)
+      (inherit-field controller)
+
+      (define/override (get-context-menu%)
+        widget-context-menu%)
 
       (add-function "show-syntax-properties"
                     (lambda (i e)
                       (send widget toggle-props)))
 
-          (define/public (get-widget) widget)
+      (define/public (get-widget) widget)))
-          ))))
 
-  (define widget-context-menu-extension@
+  (define widget-context-menu%
-    (unit
+    (class context-menu%
-      (import (prefix pre: context-menu^))
-      (export context-menu^)
-
-      (define context-menu%
-        (class pre:context-menu%
       (inherit-field keymap)
       (inherit-field props-menu)
 
@@ -207,12 +219,14 @@
                   "Hide syntax properties"
                   "Show syntax properties"))
         (super on-demand))
-          (super-new)))))
+      (super-new)))
 
   (define browser-text%
-    (text:arrows-mixin
+    (class (text:arrows-mixin
+            (text:tacking-mixin
              (text:mouse-drawings-mixin
-      (text:drawings-mixin
               (text:hide-caret/selection-mixin
-        (editor:standard-style-list-mixin text:basic%))))))
+               (editor:standard-style-list-mixin text:basic%)))))
+      (define/override (default-style-name) "Basic")
+      (super-new)))
   )

collects/macro-debugger/view/cursor.ss

@@ -3,6 +3,7 @@
   (provide cursor?
            cursor:new
            cursor:add-to-end!
+           cursor:remove-current!
 
            cursor:next
            cursor:prev
@@ -64,6 +65,10 @@
     (let ([suffix (cursor-suffixp c)])
       (set-cursor-suffixp! c (stream-append suffix items))))
 
+  (define (cursor:remove-current! c)
+    (when (cursor:has-next? c)
+      (set-cursor-suffixp! c (stream-cdr (cursor-suffixp c)))))
+
   (define (cursor:next c)
     (let ([suffix (cursor-suffixp c)])
       (if (stream-null? suffix)

collects/macro-debugger/view/extensions.ss

@@ -0,0 +1,112 @@
+
+(module extensions mzscheme
+  (require (lib "class.ss")
+           (lib "unit.ss")
+           (lib "list.ss")
+           (lib "plt-match.ss")
+           (lib "mred.ss" "mred")
+           (lib "framework.ss" "framework")
+           (lib "boundmap.ss" "syntax")
+           "interfaces.ss"
+           "prefs.ss"
+           "warning.ss"
+           "hiding-panel.ss"
+           (prefix s: "../syntax-browser/widget.ss")
+           "../model/deriv.ss"
+           "../model/deriv-util.ss"
+           "../model/trace.ss"
+           "../model/hide.ss"
+           "../model/steps.ss"
+           "cursor.ss"
+           "util.ss")
+  (provide stepper-keymap%
+           stepper-context-menu%
+           stepper-syntax-widget%)
+
+  ;; Extensions
+
+  (define stepper-keymap%
+    (class s:widget-keymap%
+      (init-field macro-stepper)
+      (inherit-field controller)
+      (inherit add-function)
+
+      (super-new)
+
+      (define/override (get-context-menu%)
+        stepper-context-menu%)
+
+      (define/public (get-hiding-panel)
+        (send macro-stepper get-macro-hiding-prefs))
+
+      (add-function "hiding:show-macro"
+                    (lambda (i e)
+                      (send* (get-hiding-panel)
+                        (add-show-identifier)
+                        (refresh))))
+      
+      (add-function "hiding:hide-macro"
+                    (lambda (i e)
+                      (send* (get-hiding-panel)
+                        (add-hide-identifier)
+                        (refresh))))))
+
+  (define stepper-context-menu%
+    (class s:widget-context-menu%
+      (inherit-field keymap)
+      (inherit add-separator)
+      
+      (field [show-macro #f]
+             [hide-macro #f])
+      
+      (define/override (after-selection-items)
+        (super after-selection-items)
+        (add-separator)
+        (set! show-macro
+              (new menu-item% (label "Show this macro") (parent this)
+                   (callback (lambda (i e)
+                               (send keymap call-function "hiding:show-macro" i e)))))
+        (set! hide-macro
+              (new menu-item% (label "Hide this macro") (parent this)
+                   (callback (lambda (i e)
+                               (send keymap call-function "hiding:hide-macro" i e)))))
+        (void))
+      
+      (define/override (on-demand)
+        (define hiding-panel (send keymap get-hiding-panel))
+        (define controller (send keymap get-controller))
+        (define stx (send controller get-selected-syntax))
+        (define id? (identifier? stx))
+        (send show-macro enable id?)
+        (send hide-macro enable id?)
+        (super on-demand))
+
+      (super-new)))
+  
+  (define stepper-syntax-widget%
+    (class s:widget%
+      (init-field macro-stepper)
+      (inherit get-text)
+
+      (define/override (setup-keymap)
+        (new stepper-keymap%
+             (editor (get-text))
+             (widget this)
+             (macro-stepper macro-stepper)))
+
+      (define/override (show-props show?)
+        (super show-props show?)
+        (send macro-stepper update/preserve-view))
+
+      (super-new
+       (config (new config-adapter%
+                    (config (send macro-stepper get-config)))))))
+  
+  (define config-adapter%
+    (class object%
+      (init-field config)
+      (define/public pref:props-percentage
+        (case-lambda [() (send config get-props-percentage)]
+                     [(v) (send config set-props-percentage v)]))
+      (super-new)))
+  )

collects/macro-debugger/view/frame.ss

@@ -0,0 +1,239 @@
+
+(module frame mzscheme
+  (require (lib "class.ss")
+           (lib "unit.ss")
+           (lib "list.ss")
+           (lib "file.ss")
+           (lib "plt-match.ss")
+           (lib "mred.ss" "mred")
+           (lib "framework.ss" "framework")
+           (lib "boundmap.ss" "syntax")
+           "interfaces.ss"
+           "stepper.ss"
+           "prefs.ss"
+           "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"
+           "../model/hide.ss"
+           "../model/steps.ss"
+           "cursor.ss"
+           "util.ss")
+  (provide macro-stepper-frame-mixin)
+
+  (define (macro-stepper-frame-mixin base-frame%)
+    (class base-frame%
+      (init-field config)
+      (init-field (filename #f))
+
+      (define obsoleted? #f)
+
+      (inherit get-area-container
+               set-label
+               get-menu%
+               get-menu-item%
+               get-menu-bar
+               get-file-menu
+               get-edit-menu
+               get-help-menu)
+
+      (super-new (label (make-label))
+                 (width (send config get-width))
+                 (height (send config get-height)))
+
+      (define/private (make-label)
+        (if filename
+            (string-append (path->string
+                            (file-name-from-path filename))
+                           (if obsoleted? " (old)" "")
+                           " - Macro stepper")
+            "Macro stepper"))
+
+      (define/override (on-size w h)
+        (send config set-width w)
+        (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?
+                             file-menu:create-revert?
+                             file-menu:create-save?
+                             file-menu:create-save-as?
+                             ;file-menu:create-print?
+                             edit-menu:create-undo?
+                             edit-menu:create-redo?
+                             ;edit-menu:create-cut?
+                             ;edit-menu:create-paste?
+                             edit-menu:create-clear?
+                             ;edit-menu:create-find?
+                             ;edit-menu:create-find-again?
+                             edit-menu:create-replace-and-find-again?)
+
+      (define file-menu (get-file-menu))
+      (define edit-menu (get-edit-menu))
+      (define stepper-menu
+        (new (get-menu%) (parent (get-menu-bar)) (label "Stepper")))
+      (define help-menu (get-help-menu))
+
+      (define warning-panel
+        (new horizontal-panel%
+             (parent (get-area-container))
+             (stretchable-height #f)
+             (style '(deleted))))
+
+      (define widget
+        (new macro-stepper-widget%
+             (parent (get-area-container))
+             (config config)))
+
+      (define/public (get-widget) widget)
+
+      (define/public (add-obsoleted-warning)
+        (unless obsoleted?
+          (set! obsoleted? #t)
+          (new warning-canvas%
+               (warning
+                (string-append
+                 "Warning: This macro stepper session is obsolete. "
+                 "The program may have changed."))
+               (parent warning-panel))
+          (set-label (make-label))
+          (send (get-area-container) change-children
+                (lambda (children)
+                  (cons warning-panel
+                        (remq warning-panel children))))))
+
+      ;; Set up menus
+
+      (menu-option/notify-box stepper-menu
+                              "Show syntax properties"
+                              (get-field show-syntax-properties? config))
+
+      ;; FIXME: rewrite with notify-box
+      (let ([id-menu
+             (new (get-menu%)
+                  (label "Identifier=?")
+                  (parent stepper-menu))])
+        (for-each (lambda (p)
+                    (let ([this-choice
+                           (new checkable-menu-item%
+                                (label (car p)) 
+                                (parent id-menu)
+                                (callback
+                                 (lambda _ 
+                                   (send (send widget get-controller)
+                                         on-update-identifier=?
+                                         (car p)
+                                         (cdr p)))))])
+                      (send (send widget get-controller)
+                            listen-identifier=?
+                            (lambda (name+func)
+                              (send this-choice check
+                                    (eq? (car name+func) (car p)))))))
+                  (sb:identifier=-choices)))
+      (let ([identifier=? (send config get-identifier=?)])
+        (when identifier=?
+          (let ([p (assoc identifier=? (sb:identifier=-choices))])
+            (send (send widget get-controller) set-identifier=? p))))
+
+      (new (get-menu-item%)
+           (label "Clear selection")
+           (parent stepper-menu)
+           (callback
+            (lambda _ (send (send widget get-controller) select-syntax #f))))
+      (new separator-menu-item% (parent stepper-menu))
+
+      (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))))
+      (new (get-menu-item%)
+           (label "Remove selected term")
+           (parent stepper-menu)
+           (callback (lambda _ (send widget remove-current-term))))
+      (new (get-menu-item%)
+           (label "Reset mark numbering")
+           (parent stepper-menu)
+           (callback (lambda _ (send widget reset-primary-partition))))
+      (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))
+        (menu-option/notify-box extras-menu
+                                "One term at a time"
+                                (get-field one-by-one? config))
+        (menu-option/notify-box extras-menu
+                                "Suppress warnings"
+                                (get-field suppress-warnings? config))
+        (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)))
+
+      (frame:reorder-menus this)))
+
+  ;; Stolen from stepper
+
+  (define warning-color "yellow")
+  (define warning-font normal-control-font)
+
+  (define warning-canvas%
+    (class canvas%
+      (init-field warning)
+      (inherit get-dc get-client-size)
+      (define/override (on-paint)
+        (let ([dc (get-dc)])
+          (send dc set-font warning-font) 
+          (let-values ([(cw ch) (get-client-size)]
+                       [(tw th dont-care dont-care2) (send dc get-text-extent warning)])
+            (send dc set-pen (send the-pen-list find-or-create-pen warning-color 1 'solid))
+            (send dc set-brush (send the-brush-list find-or-create-brush warning-color 'solid))
+            (send dc draw-rectangle 0 0 cw ch)
+            (send dc draw-text 
+                  warning
+                  (- (/ cw 2) (/ tw 2))
+                  (- (/ ch 2) (/ th 2))))))
+      (super-new)
+      (inherit min-width min-height stretchable-height)
+      (let-values ([(tw th dc dc2) (send (get-dc) get-text-extent warning warning-font)])
+        (min-width (+ 2 (inexact->exact (ceiling tw))))
+        (min-height (+ 2 (inexact->exact (ceiling th)))))
+      (stretchable-height #f)))
+
+  )

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

@@ -5,10 +5,54 @@
            (lib "list.ss")
            (lib "boundmap.ss" "syntax")
            "util.ss"
-           "../model/hiding-policies.ss"
+           "../model/synth-engine.ss"
            "../syntax-browser/util.ss")
   (provide macro-hiding-prefs-widget%)
 
+  (define mode:disable "Disable")
+  (define mode:standard "Standard")
+  (define mode:custom "Custom ...")
+
+  (define (make-policy hide-mzscheme?
+                       hide-libs?
+                       hide-contracts?
+                       hide-transformers?
+                       specialized-policies)
+    (lambda (id)
+      (define now (phase))
+      (define binding
+        (cond [(= now 0) (identifier-binding id)]
+              [(= now 1) (identifier-transformer-binding id)]
+              [else #f]))
+      (define-values (def-mod def-name nom-mod nom-name)
+        (if (pair? binding)
+            (values (car binding)
+                    (cadr binding)
+                    (caddr binding)
+                    (cadddr binding))
+            (values #f #f #f #f)))
+      (let/ec return
+        (let loop ([policies specialized-policies])
+          (when (pair? policies)
+            ((car policies) id binding return)
+            (loop (cdr policies))))
+        (cond [(and hide-mzscheme? (symbol? def-mod)
+                    (regexp-match #rx"^#%" (symbol->string def-mod)))
+               #f]
+              [(and hide-libs? def-mod
+                    (lib-module? def-mod))
+               #f]
+              [(and hide-contracts? def-name
+                    (regexp-match #rx"^provide/contract-id-"
+                                  (symbol->string def-name)))
+               #f]
+              [(and hide-transformers? (positive? now))
+               #f]
+              [else #t]))))
+
+  (define standard-policy
+    (make-policy #t #t #t #t null))
+
   ;; macro-hiding-prefs-widget%
   (define macro-hiding-prefs-widget%
     (class object%
@@ -16,200 +60,269 @@
       (init-field stepper)
       (init-field config)
 
-      (define policy (new-hiding-policy))
+      (define/public (get-policy)
-      (set-hiding-policy-opaque-kernel! policy (send config get-hide-primitives?))
+        (let ([mode (get-mode)])
-      (set-hiding-policy-opaque-libs! policy (send config get-hide-libs?))
+          (cond [(not (macro-hiding-enabled?)) #f]
-      (send config listen-hide-primitives?
+                [(equal? mode mode:standard) standard-policy]
-            (lambda (value)
+                [(equal? mode mode:custom) (get-custom-policy)])))
-              (set-hiding-policy-opaque-kernel! policy value)
-              (refresh)))
-      (send config listen-hide-libs?
-            (lambda (value)
-              (set-hiding-policy-opaque-libs! policy value)
-              (refresh)))
 
-      (define stx #f)
+      (define/private (get-custom-policy)
-      (define stx-name #f)
+        (let ([hide-mzscheme? (send box:hide-mzscheme get-value)]
-      (define stx-module #f)
+              [hide-libs? (send box:hide-libs get-value)]
+              [hide-contracts? (send box:hide-contracts get-value)]
+              [hide-transformers? (send box:hide-phase1 get-value)]
+              [specialized-policies (get-specialized-policies)])
+          (make-policy hide-mzscheme?
+                       hide-libs?
+                       hide-contracts?
+                       hide-transformers?
+                       specialized-policies)))
 
-      (define super-pane
+      (define super-panel
-        (new horizontal-pane%
+        (new vertical-panel%
              (parent parent)
              (stretchable-height #f)))
+      (define top-line-panel
+        (new horizontal-panel%
+             (parent super-panel)
+             (alignment '(left center))
+             (stretchable-height #f)))
+      (define customize-panel
+        (new horizontal-panel%
+             (parent super-panel)
+             (stretchable-height #f)
+             (alignment '(left top))
+             (style '(deleted))))
       (define left-pane
         (new vertical-pane%
-             (parent super-pane)
+             (parent customize-panel)
              (stretchable-width #f)
              (alignment '(left top))))
       (define right-pane
         (new vertical-pane%
-             (parent super-pane)))
+             (parent customize-panel)))
 
-      (define enable-ctl
+      (define mode-selector
-        (check-box/notify-box left-pane
+        (choice/notify-box
-                              "Enable macro hiding?"
+         top-line-panel
-                              (get-field macro-hiding? config)))
+         "Macro hiding: "
-      (send config listen-macro-hiding?
+         (list mode:disable mode:standard mode:custom)
-            (lambda (value) (force-refresh)))
+         (get-field macro-hiding-mode config)))
+      (define top-line-inner-panel
+        (new horizontal-panel%
+             (parent top-line-panel)
+             (alignment '(right center))
+             (style '(deleted))))
 
-      (define kernel-ctl
+      (define/private (get-mode)
-        (check-box/notify-box left-pane
+        (send config get-macro-hiding-mode))
-                              "Hide mzscheme syntax"
-                              (get-field hide-primitives? config)))
 
-      (define libs-ctl
+      (define/private (macro-hiding-enabled?)
-        (check-box/notify-box left-pane
+        (let ([mode (get-mode)])
-                              "Hide library syntax"
+          (or (equal? mode mode:standard)
-                              (get-field hide-libs? config)))
+              (and (equal? mode mode:custom)
+                   (send box:hiding get-value)))))
+
+      (define/private (ensure-custom-mode)
+        (unless (equal? (get-mode) mode:custom)
+          (send config set-macro-hiding-mode mode:custom)))
+
+      (define/private (update-visibility)
+        (let ([customizing (equal? (get-mode) mode:custom)])
+          (send top-line-panel change-children
+                (lambda (children)
+                  (append (remq top-line-inner-panel children)
+                          (if customizing (list top-line-inner-panel) null))))
+          (send super-panel change-children
+                (lambda (children)
+                  (append (remq customize-panel children)
+                          (if (and customizing (send box:edit get-value))
+                              (list customize-panel)
+                              null))))))
+
+      (send config listen-macro-hiding-mode
+            (lambda (value)
+              (update-visibility)
+              (force-refresh)))
+
+      (define box:hiding
+        (new check-box%
+             (label "Enable macro hiding")
+             (value #t)
+             (parent top-line-inner-panel)
+             (callback (lambda (c e) (force-refresh)))))
+      (define box:edit
+        (new check-box%
+             (label "Show policy editor")
+             (parent top-line-inner-panel)
+             (value #t)
+             (callback (lambda (c e) (update-visibility)))))
+
+      (define box:hide-mzscheme
+        (new check-box%
+             (label "Hide mzscheme syntax")
+             (parent left-pane)
+             (value #t)
+             (callback (lambda (c e) (refresh)))))
+      (define box:hide-libs
+        (new check-box%
+             (label "Hide library syntax")
+             (parent left-pane)
+             (value #t)
+             (callback (lambda (c e) (refresh)))))
+      (define box:hide-contracts
+        (new check-box%
+             (label "Hide contracts (heuristic)")
+             (parent left-pane)
+             (value #t)
+             (callback (lambda (c e) (refresh)))))
+      (define box:hide-phase1
+        (new check-box%
+             (label "Hide phase>0")
+             (parent left-pane)
+             (value #t)
+             (callback (lambda (c e) (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)))
+        (new list-box% (parent right-pane) (label "")
-      (define delete-ctl
+             (choices null) (style '(extended))
-        (new button% (parent look-pane) (label "Delete")
              (callback
-              (lambda _
+              (lambda (c e)
-                (delete-selected)
+                (send delete-ctl enable (pair? (send c get-selections)))))))
-                (refresh)))))
 
-      (define add-pane
+      (define look-button-pane
-        (new horizontal-pane% (parent right-pane) (stretchable-height #f)))
+        (new horizontal-pane% (parent right-pane) (stretchable-width #f)))
-      (define add-text
+
-        (new text-field%
+      (define delete-ctl
-             (label "")
+        (new button% (parent look-button-pane) (label "Delete rule") (enabled #f)
-             (parent add-pane)
+             (callback (lambda _ (delete-selected) (refresh)))))
-             (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)
+        (new button% (parent look-button-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)
+        (new button% (parent look-button-pane) (label "Show macro") (enabled #f)
              (callback (lambda _ (add-show-identifier) (refresh)))))
-
+      #;(new grow-box-spacer-pane% (parent right-pane))
-      (new grow-box-spacer-pane% (parent add-pane))
-
-      (send add-editor lock #t)
 
       ;; Methods
 
-      (define/public (get-show-macro?)
+      (define stx #f)
-        (lambda (id) (policy-show-macro? policy id)))
+      (define stx-name #f)
 
-      ;; refresh
+      ;; refresh : -> void
       (define/public (refresh)
-        (when (send config get-macro-hiding?)
+        (when (macro-hiding-enabled?)
           (send stepper refresh/resynth)))
 
-      ;; force-refresh
+      ;; force-refresh : -> void
       (define/private (force-refresh)
         (send stepper refresh/resynth))
 
       ;; set-syntax : syntax/#f -> void
       (define/public (set-syntax lstx)
-        (set! stx lstx)
+        (set! stx (and (identifier? lstx) 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)))
+                (set! stx-name (syntax-e stx)))))
-                (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)
+      (define identifier-policies null)
-        (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)
+      (define/private (get-specialized-policies)
-        (when stx-module
+        (map (lambda (policy)
-          (policy-hide-module policy stx-module)
+               (define key (car policy))
-          (update-list-view)))
+               (define show? (cdr policy))
+               (cond [(pair? key)
+                      (lambda (id binding return)
+                        (when (and (pair? binding)
+                                   (equal? key (get-id-key/binding id binding)))
+                          (return show?)))]
+                     [else
+                      (lambda (id binding return)
+                        (when (module-identifier=? id key)
+                          (return show?)))]))
+             identifier-policies))
 
       (define/public (add-hide-identifier)
-        (when (identifier? stx)
+        (add-identifier-policy #f)
-          (policy-hide-id policy stx)
+        (ensure-custom-mode))
-          (update-list-view)))
 
       (define/public (add-show-identifier)
+        (add-identifier-policy #t)
+        (ensure-custom-mode))
+
+      (define/private (add-identifier-policy show?)
         (when (identifier? stx)
-          (policy-show-id policy stx)
+          (let ([key (get-id-key stx)])
-          (update-list-view)))
+            (let loop ([i 0] [policies identifier-policies])
+              (cond [(null? policies)
+                     (set! identifier-policies
+                           (cons (cons key show?) identifier-policies))
+                     (send look-ctl append "")
+                     (update-list-view i key show?)]
+                    [(key=? key (car (car policies)))
+                     (set-cdr! (car policies) show?)
+                     (update-list-view i key show?)]
+                    [else (loop (add1 i) (cdr policies))])))))
+
+      (define/private (update-list-view index key show?)
+        (send look-ctl set-data index key)
+        (send look-ctl set-string
+              index
+              (string-append (if show? "show " "hide ")
+                             (key->text key))))
 
       (define/private (delete-selected)
-        (for-each (lambda (n)
+        (define to-delete (sort (send look-ctl get-selections) <))
-                    (let ([d (send look-ctl get-data n)])
+        (set! identifier-policies
-                      (case (car d)
+              (let loop ([i 0] [policies identifier-policies] [to-delete to-delete])
-                        ((identifier) (policy-unhide-id policy (cdr d)))
+                (cond [(null? to-delete) policies]
-                        ((show-identifier) (policy-unshow-id policy (cdr d)))
+                      [(= i (car to-delete))
-                        ((module) (policy-unhide-module policy (cdr d))))))
+                       (loop (add1 i) (cdr policies) (cdr to-delete))]
-                  (send look-ctl get-selections))
+                      [else
-        (update-list-view))
+                       (cons (car policies)
+                             (loop (add1 i) (cdr policies) to-delete))])))
+        (for-each (lambda (n) (send look-ctl delete n)) (reverse to-delete)))
 
-      (define/private (identifier-text prefix id)
+      (super-new)
-        (let ([b (identifier-binding id)])
+      (update-visibility)))
-          (cond [(pair? b)
+
-                 (let ([name (cadr b)]
+  (define (lib-module? mpi)
-                       [mod (car b)])
+    (and (module-path-index? mpi)
-                   (format "~a'~s' from ~a"
+         (let-values ([(path rel) (module-path-index-split mpi)])
-                           prefix
+           (cond [(pair? path) (memq (car path) '(lib planet))]
+                 [(string? path) (lib-module? rel)]
+                 [else #f]))))
+
+  (define (get-id-key id)
+    (let ([binding
+           (or (identifier-binding id)
+               (identifier-transformer-binding id))])
+      (get-id-key/binding id binding)))
+
+  (define (get-id-key/binding id binding)
+      (cond [(pair? binding)
+             binding]
+            [else id]))
+
+  (define (key=? key1 key2)
+    (cond [(and (identifier? key1) (identifier? key2))
+           (module-identifier=? key1 key2)]
+          [(and (pair? key1) (pair? key2))
+           (and (equal? (car key1) (car key2))
+                (equal? (cadr key1) (cadr key2)))]
+          [else #f]))
+
+  (define (key->text key)
+    (cond [(pair? key)
+           (let ([name (cadddr key)]
+                 [mod (caddr key)])
+             (format "'~s' from ~a"
                      name
                      (mpi->string mod)))]
-                [(eq? b 'lexical)
+          [else (symbol->string (syntax-e key))]))
-                 (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

@@ -19,11 +19,9 @@
     (pref:width
      pref:height
      pref:props-percentage
-     pref:macro-hiding?
+     pref:macro-hiding-mode
      pref:show-syntax-properties?
      pref:show-hiding-panel?
-     pref:hide-primitives?
-     pref:hide-libs?
      pref:identifier=?
      pref:show-rename-steps?
      pref:highlight-foci?

collects/macro-debugger/view/prefs.ss

@@ -1,26 +1,19 @@
 
 (module prefs mzscheme
-  (require (lib "unit.ss")
+  (require (lib "class.ss")
            (lib "framework.ss" "framework")
-           "interfaces.ss")
+           "../util/notify.ss"
-  (provide prefs@)
+           "../util/misc.ss")
-  
+  (provide macro-stepper-config-base%
-  (define-syntax pref:get/set
+           macro-stepper-config/prefs%
-    (syntax-rules ()
+           macro-stepper-config/prefs/readonly%)
-      [(_ get/set prop)
-       (define get/set
-         (case-lambda
-           [() (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:MacroHidingMode "Standard" string?)
   (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?)
@@ -31,19 +24,12 @@
   (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)
   (pref:get/set pref:props-percentage MacroStepper:PropertiesPanelPercentage)
-      (pref:get/set pref:macro-hiding? MacroStepper:MacroHiding?)
+  (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:hide-primitives? MacroStepper:HidePrimitives?)
-      (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?)
@@ -54,5 +40,61 @@
   (pref:get/set pref:debug-catch-errors? MacroStepper:DebugCatchErrors?)
   (pref:get/set pref:force-letrec-transformation? MacroStepper:ForceLetrecTransformation?)
 
-      ))
+  (define macro-stepper-config-base%
+    (class object%
+      (notify-methods width)
+      (notify-methods height)
+      (notify-methods macro-hiding-mode)
+      (notify-methods props-percentage)
+      (notify-methods show-syntax-properties?)
+      (notify-methods show-hiding-panel?)
+      (notify-methods identifier=?)
+      (notify-methods highlight-foci?)
+      (notify-methods highlight-frontier?)
+      (notify-methods show-rename-steps?)
+      (notify-methods suppress-warnings?)
+      (notify-methods one-by-one?)
+      (notify-methods extra-navigation?)
+      (notify-methods debug-catch-errors?)
+      (notify-methods force-letrec-transformation?)
+      (super-new)))
+
+  (define macro-stepper-config/prefs%
+    (class macro-stepper-config-base%
+      (connect-to-pref width pref:width)
+      (connect-to-pref height pref:height)
+      (connect-to-pref macro-hiding-mode pref:macro-hiding-mode)
+      (connect-to-pref props-percentage pref:props-percentage)
+      (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?)
+      (connect-to-pref highlight-frontier? pref:highlight-frontier?)
+      (connect-to-pref show-rename-steps? pref:show-rename-steps?)
+      (connect-to-pref suppress-warnings? pref:suppress-warnings?)
+      (connect-to-pref one-by-one? pref:one-by-one?)
+      (connect-to-pref extra-navigation? pref:extra-navigation?)
+      (connect-to-pref debug-catch-errors? pref:debug-catch-errors?)
+      (connect-to-pref force-letrec-transformation? pref:force-letrec-transformation?)
+      (super-new)))
+
+  (define macro-stepper-config/prefs/readonly%
+    (class macro-stepper-config-base%
+      (connect-to-pref/readonly width pref:width)
+      (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?)
+      (connect-to-pref/readonly highlight-frontier? pref:highlight-frontier?)
+      (connect-to-pref/readonly show-rename-steps? pref:show-rename-steps?)
+      (connect-to-pref/readonly suppress-warnings? pref:suppress-warnings?)
+      (connect-to-pref/readonly one-by-one? pref:one-by-one?)
+      (connect-to-pref/readonly extra-navigation? pref:extra-navigation?)
+      (connect-to-pref/readonly debug-catch-errors? pref:debug-catch-errors?)
+      (connect-to-pref/readonly force-letrec-transformation? pref:force-letrec-transformation?)
+      (super-new)))
+
   )

collects/macro-debugger/view/stepper.ss

@@ -0,0 +1,669 @@
+
+(module stepper mzscheme
+  (require (lib "class.ss")
+           (lib "unit.ss")
+           (lib "list.ss")
+           (lib "plt-match.ss")
+           (lib "mred.ss" "mred")
+           (lib "framework.ss" "framework")
+           (lib "boundmap.ss" "syntax")
+           "interfaces.ss"
+           "prefs.ss"
+           "extensions.ss"
+           "warning.ss"
+           "hiding-panel.ss"
+           (prefix s: "../syntax-browser/widget.ss")
+           (prefix s: "../syntax-browser/params.ss")
+           "../model/deriv.ss"
+           "../model/deriv-util.ss"
+           "../model/trace.ss"
+           "../model/hide.ss"
+           "../model/steps.ss"
+           "cursor.ss"
+           "util.ss")
+  (provide macro-stepper-widget%)
+
+  ;; Struct for one-by-one stepping
+
+  (define-struct (prestep protostep) (foci1 e1))
+  (define-struct (poststep protostep) (foci2 e2))
+
+  (define (prestep-term1 s) (context-fill (protostep-ctx s) (prestep-e1 s)))
+  (define (poststep-term2 s) (context-fill (protostep-ctx s) (poststep-e2 s)))
+
+  ;; TermRecords
+
+  (define-struct trec (deriv synth-deriv estx raw-steps steps definites) #f)
+
+  (define (new-trec deriv)
+    (make-trec deriv #f #f #f #f #f))
+
+  ;; trec:invalidate-synth! : TermRecord -> void
+  ;; Invalidates cached parts that depend on macro-hiding policy
+  (define (trec:invalidate-synth! trec)
+    (set-trec-synth-deriv! trec #f)
+    (set-trec-estx! trec #f)
+    (set-trec-raw-steps! trec #f)
+    (set-trec-definites! trec #f)
+    (trec:invalidate-steps! trec))
+
+  ;; trec:invalidate-steps! : TermRecord -> void
+  ;; Invalidates cached parts that depend on reductions config
+  (define (trec:invalidate-steps! trec)
+    (set-trec-steps! trec #f))
+
+
+  ;; Macro Stepper
+
+  ;; macro-stepper-widget%
+  (define macro-stepper-widget%
+    (class* object% ()
+      (init-field parent)
+      (init-field config)
+
+      ;; Terms
+
+      ;; terms : (Cursor-of TermRecord)
+      (define terms (cursor:new null))
+
+      ;; focused-term : -> TermRecord or #f
+      (define (focused-term)
+        (let ([term (cursor:next terms)])
+          (when term (recache term))
+          term))
+
+      ;; focused-steps : -> (Cursor-of Step) or #f
+      (define/private (focused-steps)
+        (let ([term (focused-term)])
+          (and term 
+               (cursor? (trec-steps term))
+               (trec-steps term))))
+
+      ;; alpha-table : module-identifier-mapping[identifier => identifier]
+      (define alpha-table (make-module-identifier-mapping))
+
+      ;; saved-position : number/#f
+      (define saved-position #f)
+
+      ;; add-deriv : Derivation -> void
+      (define/public (add-deriv d)
+        (let ([needs-display? (cursor:at-end? terms)])
+          (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))))
+
+      ;; remove-current-term : -> void
+      (define/public (remove-current-term)
+        (cursor:remove-current! terms)
+        (trim-navigator)
+        (refresh/move))
+
+      (define/public (get-config) config)
+      (define/public (get-controller) sbc)
+      (define/public (get-view) sbview)
+      (define/public (get-macro-hiding-prefs) macro-hiding-prefs)
+
+      (define/public (reset-primary-partition)
+        (send sbc reset-primary-partition)
+        (update/preserve-view))
+
+      (define area (new vertical-panel% (parent parent)))
+      (define supernavigator
+        (new horizontal-panel%
+             (parent area)
+             (stretchable-height #f)
+             (alignment '(center center))))
+      (define navigator
+        (new horizontal-panel%
+             (parent supernavigator)
+             (stretchable-width #f)
+             (stretchable-height #f)
+             (alignment '(left center))))
+      (define extra-navigator
+        (new horizontal-panel%
+             (parent supernavigator)
+             (stretchable-width #f)
+             (stretchable-height #f)
+             (alignment '(left center))
+             (style '(deleted))))
+
+      (define sbview (new stepper-syntax-widget% 
+                          (parent area)
+                          (macro-stepper this)))
+      (define sbc (send sbview get-controller))
+      (define control-pane
+        (new vertical-panel% (parent area) (stretchable-height #f)))
+      (define macro-hiding-prefs
+        (new macro-hiding-prefs-widget%
+             (parent control-pane)
+             (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?
+            (lambda (show?) (show-macro-hiding-prefs show?)))
+      (send sbc listen-selected-syntax
+            (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?)))
+
+      (define nav:up
+        (new button% (label "Previous term") (parent navigator)
+             (callback (lambda (b e) (navigate-up)))))
+      (define nav:start
+        (new button% (label "<-- Start") (parent navigator)
+             (callback (lambda (b e) (navigate-to-start)))))
+      (define nav:previous
+        (new button% (label "<- Step") (parent navigator)
+             (callback (lambda (b e) (navigate-previous)))))
+      (define nav:next
+        (new button% (label "Step ->") (parent navigator)
+             (callback (lambda (b e) (navigate-next)))))
+      (define nav:end
+        (new button% (label "End -->") (parent navigator)
+             (callback (lambda (b e) (navigate-to-end)))))
+      (define nav:down
+        (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)
+                (if show?
+                    (append (remq control-pane children) (list control-pane))
+                    (remq control-pane children)))))
+
+      (define/private (show-extra-navigation show?)
+        (send supernavigator change-children
+              (lambda (children)
+                (if show?
+                    (list navigator extra-navigator)
+                    (list navigator)))))
+
+      ;; Navigate
+
+      (define/private (navigate-to-start)
+        (cursor:move-to-start (focused-steps))
+        (update/save-position))
+      (define/private (navigate-to-end)
+        (cursor:move-to-end (focused-steps))
+        (update/save-position))
+      (define/private (navigate-previous)
+        (cursor:move-prev (focused-steps))
+        (update/save-position))
+      (define/private (navigate-next)
+        (cursor:move-next (focused-steps))
+        (update/save-position))
+
+      (define/private (navigate-up)
+        (cursor:move-prev terms)
+        (refresh/move))
+      (define/private (navigate-down)
+        (cursor:move-next terms)
+        (refresh/move))
+
+      ;; insert-step-separator : string -> void
+      (define/private (insert-step-separator text)
+        (send sbview add-text "\n    ")
+        (send sbview add-text
+              (make-object image-snip% 
+                           (build-path (collection-path "icons")
+                                       "red-arrow.bmp")))
+        (send sbview add-text "  ")
+        (send sbview add-text text)
+        (send sbview add-text "\n\n"))
+
+      ;; insert-as-separator : string -> void
+      (define/private (insert-as-separator text)
+        (send sbview add-text "\n    ")
+        (send sbview add-text text)
+        (send sbview add-text "\n\n"))
+
+      ;; insert-step-separator/small : string -> void
+      (define/private (insert-step-separator/small text)
+        (send sbview add-text "    ")
+        (send sbview add-text
+              (make-object image-snip% 
+                           (build-path (collection-path "icons")
+                                       "red-arrow.bmp")))
+        (send sbview add-text "  ")
+        (send sbview add-text text)
+        (send sbview add-text "\n\n"))
+
+      ;; update/preserve-view : -> void
+      (define/public (update/preserve-view)
+        (define text (send sbview get-text))
+        (define start-box (box 0))
+        (define end-box (box 0))
+        (send text get-visible-position-range start-box end-box)
+        (update)
+        (send text scroll-to-position (unbox start-box) #f (unbox end-box)))
+      
+      ;; update:show-prefix : -> void
+      (define/private (update:show-prefix)
+        ;; Show the final terms from the cached synth'd derivs
+        (for-each (lambda (trec)
+                    (recache trec)
+                    (let ([e2 (trec-estx trec)]
+                          [definites
+                            (if (pair? (trec-definites trec))
+                                (trec-definites trec)
+                                null)])
+                      (if e2
+                          (send sbview add-syntax e2
+                                #:alpha-table alpha-table
+                                #:definites definites)
+                          (send sbview add-text "Error\n"))))
+                  (cursor:prefix->list terms)))
+
+      ;; update:show-current-step : -> void
+      (define/private (update:show-current-step)
+        (define steps (focused-steps))
+        (when (focused-term)
+          (when steps
+            (let ([step (cursor:next steps)])
+              (cond [(step? step)
+                     (update:show-step step)]
+                    [(mono? step)
+                     (update:show-mono step)]
+                    [(misstep? step)
+                     (update:show-misstep step)]
+                    [(prestep? step)
+                     (update:show-prestep step)]
+                    [(poststep? step)
+                     (update:show-poststep step)]
+                    [(not step)
+                     (update:show-final (focused-term))])))
+          (unless steps
+            (send sbview add-text
+                  "Internal error computing reductions. Original term:\n")
+            (send sbview add-syntax
+                  (lift/deriv-e1 (trec-deriv (focused-term)))))))
+
+      ;; update:show-lctx : Step -> void
+      (define/private (update:show-lctx step)
+        (define lctx (protostep-lctx step))
+        (when (pair? lctx)
+          (send sbview add-text "\n")
+          (for-each (lambda (bf)
+                      (send sbview add-text 
+                            "while executing macro transformer in:\n")
+                      (insert-syntax/redex (bigframe-term bf)
+                                           (bigframe-foci bf)
+                                           (protostep-definites step)
+                                           (protostep-frontier step)))
+                    (reverse lctx))))
+
+      ;; update:separator : Step -> void
+      (define/private (update:separator step)
+        (if (not (mono? step))
+            (insert-step-separator (step-type->string (protostep-type step)))
+            (insert-as-separator (step-type->string (protostep-type step)))))
+
+      ;; update:separator/small : Step -> void
+      (define/private (update:separator/small step)
+        (insert-step-separator/small
+         (step-type->string (protostep-type step))))
+      
+      ;; update:show-step : Step -> void
+      (define/private (update:show-step step)
+        (insert-syntax/redex (step-term1 step)
+                             (step-foci1 step)
+                             (protostep-definites step)
+                             (protostep-frontier step))
+        (update:separator step)
+        (insert-syntax/contractum (step-term2 step)
+                                  (step-foci2 step)
+                                  (protostep-definites step)
+                                  (protostep-frontier step))
+        (update:show-lctx step))
+
+      ;; update:show-mono : Step -> void
+      (define/private (update:show-mono step)
+        (update:separator step)
+        (insert-syntax/redex (mono-term1 step)
+                             null
+                             (protostep-definites step)
+                             (protostep-frontier step))
+        (update:show-lctx step))
+
+      ;; update:show-prestep : Step -> void
+      (define/private (update:show-prestep step)
+        (update:separator/small step)
+        (insert-syntax/redex (prestep-term1 step)
+                             (prestep-foci1 step)
+                             (protostep-definites step)
+                             (protostep-frontier step))
+        (update:show-lctx step))
+
+      ;; update:show-poststep : Step -> void
+      (define/private (update:show-poststep step)
+        (update:separator/small step)
+        (insert-syntax/contractum (poststep-term2 step)
+                                  (poststep-foci2 step)
+                                  (protostep-definites step)
+                                  (protostep-frontier step))
+        (update:show-lctx step))
+
+      ;; update:show-misstep : Step -> void
+      (define/private (update:show-misstep step)
+        (insert-syntax/redex (misstep-term1 step)
+                             (misstep-foci1 step)
+                             (protostep-definites step)
+                             (protostep-frontier step))
+        (update:separator step)
+        (send sbview add-text (exn-message (misstep-exn step)))
+        (send sbview add-text "\n")
+        (when (exn:fail:syntax? (misstep-exn step))
+          (for-each (lambda (e) (send sbview add-syntax e
+                                      #:alpha-table alpha-table
+                                      #:definites (protostep-definites step)))
+                    (exn:fail:syntax-exprs (misstep-exn step))))
+        (update:show-lctx step))
+
+      ;; update:show-final : TermRecord -> void
+      (define/private (update:show-final trec)
+        (define result (trec-estx trec))
+        (when result
+          (send sbview add-text "Expansion finished\n")
+          (send sbview add-syntax result
+                #:alpha-table alpha-table
+                #:definites (let ([definites (trec-definites trec)])
+                              (if (pair? definites) definites null))))
+        (unless result
+          (send sbview add-text "Error\n")))
+
+      ;; update:show-suffix : -> void
+      (define/private (update:show-suffix)
+        (let ([suffix0 (cursor:suffix->list terms)])
+          (when (pair? suffix0)
+            (for-each (lambda (trec)
+                        (send sbview add-syntax
+                              (lift/deriv-e1 (trec-deriv trec))
+                              #: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
+              #: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)
+        (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)
+        (insert-syntax/color stx foci definites frontier "LightCyan"))
+
+      ;; enable/disable-buttons : -> void
+      (define/private (enable/disable-buttons)
+        (define steps (focused-steps))
+        (send nav:start enable (and steps (cursor:has-prev? steps)))
+        (send nav:previous enable (and steps (cursor:has-prev? steps)))
+        (send nav:next enable (and steps (cursor:has-next? steps)))
+        (send nav:end enable (and steps (cursor:has-next? steps)))
+        (send nav:up enable (cursor:has-prev? terms))
+        (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)
+        (update))
+
+      ;; recache : TermRecord -> void
+      (define/private (recache trec)
+        (unless (trec-synth-deriv trec)
+          (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))])
+              (set-trec-synth-deriv! trec synth-deriv)
+              (set-trec-estx! trec estx))))
+        (unless (trec-raw-steps trec)
+          (with-handlers ([(lambda (e) #t)
+                           (lambda (e)
+                             (handle-recache-error e 'reductions)
+                             (set-trec-raw-steps! trec 'error)
+                             (set-trec-definites! trec 'error))])
+            (let-values ([(steps definites)
+                          (reductions+definites
+                           (or (trec-synth-deriv trec) (trec-deriv trec)))])
+              (set-trec-raw-steps! trec steps)
+              (set-trec-definites! trec definites))))
+        (unless (trec-steps trec)
+          (with-handlers ([(lambda (e) #t)
+                           (lambda (e)
+                             (handle-recache-error e 'special-reductions)
+                             (set-trec-steps! trec 'error))])
+            (set-trec-steps!
+             trec
+             (let ([raw-steps (trec-raw-steps trec)])
+               (if (eq? raw-steps 'error)
+                   'error
+                   (let ([filtered-steps 
+                          (if (send config get-show-rename-steps?)
+                              raw-steps
+                              (filter (lambda (x) (not (rename-step? x))) raw-steps))])
+                     (cursor:new
+                      (if (send config get-one-by-one?)
+                          (reduce:one-by-one filtered-steps)
+                          filtered-steps)))))))))
+
+      ;; delayed-recache-errors : (list-of (cons exn string))
+      (define delayed-recache-errors null)
+
+      ;; handle-recache-error : exception string -> void
+      (define/private (handle-recache-error exn part)
+        (if (send config get-debug-catch-errors?)
+            (begin
+              (set! delayed-recache-errors 
+                    (cons (cons exn part) delayed-recache-errors))
+              (queue-callback
+               (lambda ()
+                 (when (pair? delayed-recache-errors)
+                   (message-box
+                    "Error"
+                    (string-append 
+                     "Internal errors in macro stepper:\n"
+                     (if (memq 'macro-hiding (map cdr delayed-recache-errors))
+                         (string-append 
+                          "Macro hiding failed on one or more terms. "
+                          "The macro stepper is showing the terms "
+                          "with macro hiding disabled.\n")
+                         "")
+                     (if (memq 'reductions (map cdr delayed-recache-errors))
+                         (string-append
+                          "The macro stepper failed to compute the reduction sequence "
+                          "for one or more terms.\n")
+                         "")))
+                   (set! delayed-recache-errors null)))))
+            (raise exn)))
+
+      ;; update-saved-position : num -> void
+      (define/private (update-saved-position pos)
+        (when pos (set! saved-position pos)))
+
+      ;; clear-saved-position : -> void
+      (define/private (clear-saved-position)
+        (set! saved-position #f))
+
+      ;; save-position : -> void
+      (define/private (save-position)
+        (when (cursor? (focused-steps))
+          (let ([step (cursor:next (focused-steps))])
+            (cond [(not step)
+                   ;; At end; go to the end when restored
+                   (update-saved-position +inf.0)]
+                  [(protostep? step)
+                   (update-saved-position
+                    (extract-protostep-seq step))]))))
+
+      ;; restore-position : number -> void
+      (define/private (restore-position)
+        (define steps (focused-steps))
+        (define (advance)
+          (let ([step (cursor:next steps)])
+            (cond [(not step)
+                   ;; At end; stop
+                   (void)]
+                  [(protostep? step)
+                   (let ([step-pos (extract-protostep-seq step)])
+                     (cond [(not step-pos)
+                            (cursor:move-next steps)
+                            (advance)]
+                           [(< step-pos saved-position)
+                            (cursor:move-next steps)
+                            (advance)]
+                           [else (void)]))])))
+        (when saved-position
+          (when steps
+            (advance))))
+
+      (define/private (extract-protostep-seq step)
+        (match (protostep-deriv step)
+          [(AnyQ mrule (_ _ (AnyQ transformation (_ _ _ _ _ _ seq)) _))
+           seq]
+          [else #f]))
+
+      ;; synthesize : Derivation -> Derivation Syntax
+      (define/private (synthesize deriv)
+        (let ([show-macro? (get-show-macro?)])
+          (if show-macro?
+              (parameterize ((current-hiding-warning-handler
+                              (lambda (tag message)
+                                (unless (send config get-suppress-warnings?)
+                                  (unless warnings-frame
+                                    (set! warnings-frame (new warnings-frame%)))
+                                  (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)))))
+
+      (define/private (reduce:one-by-one rs)
+        (let loop ([rs rs])
+          (match rs
+            [(cons (struct step (d l t c df fr redex contractum e1 e2)) rs)
+             (list* (make-prestep d l "Find redex" c df fr redex e1)
+                    (make-poststep d l t c df fr contractum e2)
+                    (loop rs))]
+            [(cons (struct misstep (d l t c df fr redex e1 exn)) rs)
+             (list* (make-prestep d l "Find redex" c df fr redex e1)
+                    (make-misstep d l t c df fr redex e1 exn)
+                    (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)
+      (send sbview show-props (send config get-show-syntax-properties?))
+      (show-macro-hiding-prefs (send config get-show-hiding-panel?))
+      (show-extra-navigation (send config get-extra-navigation?))
+      (refresh/move)
+      ))
+
+  )

collects/macro-debugger/view/view.ss

@@ -1,26 +1,35 @@
 
 (module view mzscheme
-  (require (lib "unit.ss")
+  (require (lib "class.ss")
            (lib "mred.ss" "mred")
            (lib "framework.ss" "framework")
            "interfaces.ss"
-           "gui.ss")
+           "frame.ss"
+           "prefs.ss"
+           "../model/trace.ss")
   (provide (all-defined))
 
-  (define view-base@
+  (define macro-stepper-frame%
-    (unit
+    (macro-stepper-frame-mixin
-      (import)
+     (frame:standard-menus-mixin
-      (export view-base^)
+      (frame:basic-mixin frame%))))
   
-      (define base-frame%
+  ;; Main entry points
-        (frame:standard-menus-mixin (frame:basic-mixin frame%)))))
   
-  (define-values/invoke-unit
+  (define (make-macro-stepper)
-    (compound-unit
+    (let ([f (new macro-stepper-frame%
-      (import)
+                  (config (new macro-stepper-config/prefs%)))])
-      (link [((BASE : view-base^)) view-base@]
+      (send f show #t)
-            [((STEPPER : view^)) pre-stepper@ BASE])
+      (send f get-widget)))
-      (export STEPPER))
+
-    (import)
+  (define (go stx)
-    (export view^))
+    (let ([stepper (make-macro-stepper)])
+      (send stepper add-deriv (trace stx))))
+  
+  (define (go/deriv deriv)
+    (let* ([f (new macro-stepper-frame%)]
+           [w (send f get-widget)])
+      (send w add-deriv deriv)
+      (send f show #t)
+      w))
   )