Syncing up to trunk.

svn: r13115

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

@@ -68,9 +68,10 @@
     (super-new)))
 
 (define controller%
-  (class (secondary-partition-mixin
+  (class* (secondary-partition-mixin
            (selection-manager-mixin
             (mark-manager-mixin
              (displays-manager-mixin
               object%))))
+    (controller<%>)
     (super-new)))

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

@@ -1,11 +1,10 @@
-
 #lang scheme/base
 (require scheme/class
          macro-debugger/util/class-iop)
 (provide (all-defined-out))
 
 ;; displays-manager<%>
-(define-interface displays-manager<%>
+(define-interface displays-manager<%> ()
   (;; add-syntax-display : display<%> -> void
    add-syntax-display
 
@@ -13,7 +12,7 @@
    remove-all-syntax-displays))
 
 ;; selection-manager<%>
-(define-interface selection-manager<%>
+(define-interface selection-manager<%> ()
   (;; selected-syntax : syntax/#f
    set-selected-syntax
    get-selected-syntax
@@ -21,12 +20,15 @@
 
 ;; mark-manager<%>
 ;; Manages marks, mappings from marks to colors
-(define-interface mark-manager<%>
+(define-interface mark-manager<%> ()
   (;; get-primary-partition : -> partition
-   get-primary-partition))
+   get-primary-partition
+
+   ;; reset-primary-partition : -> void
+   reset-primary-partition))
 
 ;; secondary-partition<%>
-(define-interface secondary-partition<%>
+(define-interface secondary-partition<%> ()
   (;; get-secondary-partition : -> partition<%>
    get-secondary-partition
 
@@ -46,27 +48,15 @@
    listen-identifier=?))
 
 ;; controller<%>
-(define-interface/dynamic controller<%>
+(define-interface controller<%> (displays-manager<%>
-  (interface (displays-manager<%>
                                  selection-manager<%>
                                  mark-manager<%>
-              secondary-partition<%>))
+                                 secondary-partition<%>)
-  (add-syntax-display
+  ())
-   remove-all-syntax-displays
-   set-selected-syntax
-   get-selected-syntax
-   listen-selected-syntax
-   get-primary-partition
-   get-secondary-partition
-   set-secondary-partition
-   listen-secondary-partition
-   get-identifier=?
-   set-identifier=?
-   listen-identifier=?))
 
 
 ;; host<%>
-(define-interface host<%>
+(define-interface host<%> ()
   (;; get-controller : -> controller<%>
    get-controller
 
@@ -74,7 +64,7 @@
    add-keymap))
 
 ;; display<%>
-(define-interface display<%>
+(define-interface display<%> ()
   (;; refresh : -> void
    refresh
 
@@ -94,7 +84,7 @@
    get-range))
 
 ;; range<%>
-(define-interface range<%>
+(define-interface range<%> ()
   (;; get-ranges : datum -> (list-of (cons number number))
    get-ranges
 
@@ -111,14 +101,14 @@
 
 
 ;; syntax-prefs<%>
-(define-interface syntax-prefs<%>
+(define-interface syntax-prefs<%> ()
   (pref:width
    pref:height
    pref:props-percentage
    pref:props-shown?))
 
 ;; widget-hooks<%>
-(define-interface widget-hooks<%>
+(define-interface widget-hooks<%> ()
   (;; setup-keymap : -> void
    setup-keymap
 
@@ -126,7 +116,7 @@
    shutdown))
 
 ;; keymap-hooks<%>
-(define-interface keymap-hooks<%>
+(define-interface keymap-hooks<%> ()
   (;; make-context-menu : -> context-menu<%>
    make-context-menu
 
@@ -134,7 +124,7 @@
    get-context-menu%))
 
 ;; context-menu-hooks<%>
-(define-interface context-menu-hooks<%>
+(define-interface context-menu-hooks<%> ()
   (add-edit-items
    after-edit-items
    add-selection-items
@@ -146,15 +136,16 @@
 ;;----------
 
 ;; Convenience widget, specialized for displaying stx and not much else
-(define-interface syntax-browser<%>
+(define-interface syntax-browser<%> ()
   (add-syntax
    add-text
+   add-error-text
+   add-clickback
    add-separator
    erase-all
-   select-syntax
    get-text))
 
-(define-interface partition<%>
+(define-interface partition<%> ()
   (;; get-partition : any -> number
    get-partition
 

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

@@ -1,4 +1,3 @@
-
 #lang scheme/base
 (require scheme/class
          scheme/gui

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

@@ -21,7 +21,7 @@
 ;; widget%
 ;; A syntax widget creates its own syntax-controller.
 (define widget%
-  (class* object% (widget-hooks<%>)
+  (class* object% (syntax-browser<%> widget-hooks<%>)
     (init parent)
     (init-field config)
 

collects/macro-debugger/util/class-iop.ss

@@ -13,6 +13,7 @@
          define:
          lambda:
          init:
+	 init-field:
          init-private:)
 
 ;; Configuration
@@ -25,10 +26,13 @@
 ;; Defines NAME as an interface.
 (define-syntax (define-interface stx)
   (syntax-parse stx
-    [(_ name:id (mname:id ...))
+    [(_ name:id (super:static-interface ...) (mname:id ...))
+     (with-syntax ([((super-method ...) ...)
+                    (map static-interface-members
+                         (syntax->datum #'(super.value ...)))])
        #'(define-interface/dynamic name
-         (let ([name (interface () mname ...)]) name)
+           (let ([name (interface (super ...) mname ...)]) name)
-         (mname ...))]))
+           (super-method ... ... mname ...)))]))
 
 ;; define-interface/dynamic SYNTAX
 ;; (define-interface/dynamic NAME EXPR (IDENTIFIER ...))
@@ -181,7 +185,7 @@
   (syntax-parse stx
     [(_ init name:id iface:static-interface)
      (with-syntax ([(name-internal) (generate-temporaries #'(name))])
-       #'(begin (init (name name-internal))
+       #'(begin (init ((name-internal name)))
                 (void (check-object<:interface init: name-internal iface))
                 (define-syntax name 
                   (make-checked-binding

collects/macro-debugger/view/extensions.ss

@@ -1,6 +1,7 @@
 
 #lang scheme/base
 (require scheme/class
+         macro-debugger/util/class-iop
          scheme/unit
          scheme/list
          scheme/match
@@ -13,6 +14,7 @@
          "hiding-panel.ss"
          (prefix-in s: "../syntax-browser/widget.ss")
          (prefix-in s: "../syntax-browser/keymap.ss")
+         (prefix-in s: "../syntax-browser/interfaces.ss")
          "../model/deriv.ss"
          "../model/deriv-util.ss"
          "../model/trace.ss"
@@ -26,7 +28,7 @@
 
 (define stepper-keymap%
   (class s:syntax-keymap%
-    (init-field macro-stepper)
+    (init-field: (macro-stepper widget<%>))
     (inherit-field config
                    controller
                    the-context-menu)
@@ -39,17 +41,17 @@
     (super-new)
 
     (define/public (get-hiding-panel)
-      (send macro-stepper get-macro-hiding-prefs))
+      (send: macro-stepper widget<%> get-macro-hiding-prefs))
 
     (add-function "hiding:show-macro"
                   (lambda (i e)
-                    (send* (get-hiding-panel)
+                    (send*: (get-hiding-panel) hiding-prefs<%>
                       (add-show-identifier)
                       (refresh))))
 
     (add-function "hiding:hide-macro"
                   (lambda (i e)
-                    (send* (get-hiding-panel)
+                    (send*: (get-hiding-panel) hiding-prefs<%>
                       (add-hide-identifier)
                       (refresh))))
 
@@ -75,26 +77,27 @@
       (send show-macro enable ?)
       (send hide-macro enable ?))
 
-    (send controller listen-selected-syntax
+    (send: controller s:controller<%> listen-selected-syntax
            (lambda (stx)
              (enable/disable-hide/show (identifier? stx))))))
 
 (define stepper-syntax-widget%
   (class s:widget%
-    (init-field macro-stepper)
+    (init-field: (macro-stepper widget<%>))
     (inherit get-text)
     (inherit-field controller)
 
     (define/override (setup-keymap)
       (new stepper-keymap%
            (editor (get-text))
-           (config (send macro-stepper get-config))
+           (config (send: macro-stepper widget<%> get-config))
            (controller controller)
            (macro-stepper macro-stepper)))
 
     (define/override (show-props show?)
       (super show-props show?)
-      (send macro-stepper update/preserve-view))
+      (send: macro-stepper widget<%> update/preserve-view))
 
     (super-new
-     (config (send macro-stepper get-config)))))
+     (config (send: macro-stepper widget<%> get-config)))))
+

collects/macro-debugger/view/frame.ss

@@ -1,6 +1,7 @@
 
 #lang scheme/base
 (require scheme/class
+         macro-debugger/util/class-iop
          scheme/unit
          scheme/list
          scheme/file
@@ -14,6 +15,7 @@
          "warning.ss"
          "hiding-panel.ss"
          (prefix-in sb: "../syntax-browser/embed.ss")
+	 (prefix-in sb: "../syntax-browser/interfaces.ss")
          "../model/deriv.ss"
          "../model/deriv-util.ss"
          "../model/trace.ss"
@@ -23,7 +25,7 @@
 (provide macro-stepper-frame-mixin)
 
 (define (macro-stepper-frame-mixin base-frame%)
-  (class base-frame%
+  (class* base-frame% (stepper-frame<%>)
     (init-field config)
     (init-field director)
     (init-field (filename #f))
@@ -54,7 +56,7 @@
     (define/override (on-size w h)
       (send config set-width w)
       (send config set-height h)
-      (send widget update/preserve-view))
+      (send: widget widget<%> update/preserve-view))
 
     (define warning-panel
       (new horizontal-panel%
@@ -65,12 +67,13 @@
     (define/public (get-macro-stepper-widget%)
       macro-stepper-widget%)
 
-    (define widget
+    (define: widget widget<%>
       (new (get-macro-stepper-widget%)
            (parent (get-area-container))
            (director director)
            (config config)))
-    (define controller (send widget get-controller))
+    (define: controller sb:controller<%>
+      (send: widget widget<%> get-controller))
 
     (define/public (get-widget) widget)
     (define/public (get-controller) controller)
@@ -112,11 +115,11 @@
       (new (get-menu-item%)
            (label "Duplicate stepper")
            (parent file-menu)
-           (callback (lambda _ (send widget duplicate-stepper))))
+           (callback (lambda _ (send: widget widget<%> duplicate-stepper))))
       (new (get-menu-item%)
            (label "Duplicate stepper (current term only)")
            (parent file-menu)
-           (callback (lambda _ (send widget show-in-new-frame)))))
+           (callback (lambda _ (send: widget widget<%> show-in-new-frame)))))
 
     (menu-option/notify-box stepper-menu
                             "View syntax properties"
@@ -133,8 +136,8 @@
                               (parent id-menu)
                               (callback
                                (lambda _ 
-                                 (send controller set-identifier=? p))))])
+                                 (send: controller sb:controller<%> set-identifier=? p))))])
-                    (send controller listen-identifier=?
+                    (send: controller sb:controller<%> listen-identifier=?
                            (lambda (name+func)
                              (send this-choice check
                                    (eq? (car name+func) (car p)))))))
@@ -143,13 +146,14 @@
     (let ([identifier=? (send config get-identifier=?)])
       (when identifier=?
         (let ([p (assoc identifier=? (sb:identifier=-choices))])
-          (send controller set-identifier=? p))))
+          (send: controller sb:controller<%> set-identifier=? p))))
 
     (new (get-menu-item%)
          (label "Clear selection")
          (parent stepper-menu)
          (callback
-          (lambda _ (send controller set-selected-syntax #f))))
+          (lambda _ (send: controller sb:controller<%> 
+			   set-selected-syntax #f))))
 
     (new separator-menu-item% (parent stepper-menu))
 
@@ -160,11 +164,11 @@
     (new (get-menu-item%)
          (label "Remove selected term")
          (parent stepper-menu)
-         (callback (lambda _ (send widget remove-current-term))))
+         (callback (lambda _ (send: widget widget<%> remove-current-term))))
     (new (get-menu-item%)
          (label "Reset mark numbering")
          (parent stepper-menu)
-         (callback (lambda _ (send widget reset-primary-partition))))
+         (callback (lambda _ (send: widget widget<%> reset-primary-partition))))
     (let ([extras-menu
            (new (get-menu%)
                 (label "Extra options")
@@ -178,7 +182,7 @@
                     (if (send i is-checked?)
                         'always
                         'over-limit))
-              (send widget update/preserve-view))))
+              (send: widget widget<%> update/preserve-view))))
       (menu-option/notify-box extras-menu
                               "Highlight redex/contractum"
                               (get-field highlight-foci? config))

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

@@ -1,9 +1,11 @@
 
 #lang scheme/base
 (require scheme/class
+         macro-debugger/util/class-iop
          scheme/gui
          scheme/list
          syntax/boundmap
+         "interfaces.ss"
          "../model/hiding-policies.ss"
          "../util/mpi.ss"
          "../util/notify.ss")
@@ -16,9 +18,9 @@
 
 ;; macro-hiding-prefs-widget%
 (define macro-hiding-prefs-widget%
-  (class object%
+  (class* object% (hiding-prefs<%>)
     (init parent)
-    (init-field stepper)
+    (init-field: (stepper widget<%>))
     (init-field config)
 
     (define/public (get-policy)
@@ -173,11 +175,11 @@
     ;; refresh : -> void
     (define/public (refresh)
       (when (macro-hiding-enabled?)
-        (send stepper refresh/resynth)))
+        (send: stepper widget<%> refresh/resynth)))
 
     ;; force-refresh : -> void
     (define/private (force-refresh)
-      (send stepper refresh/resynth))
+      (send: stepper widget<%> refresh/resynth))
 
     ;; set-syntax : syntax/#f -> void
     (define/public (set-syntax lstx)

collects/macro-debugger/view/interfaces.ss

@@ -1,50 +1,77 @@
 
 #lang scheme/base
-(require scheme/unit)
+(require macro-debugger/util/class-iop)
 (provide (all-defined-out))
 
-;; Signatures
+(define-interface widget<%> ()
+  (get-config
+   get-controller
+   get-macro-hiding-prefs
+   get-step-displayer
 
-#;
+   add-trace
-(define-signature view^
+   add-deriv
-  (macro-stepper-frame%
-   macro-stepper-widget%
-   make-macro-stepper
-   go
-   go/deriv))
 
-#;
+   update/preserve-view
-(define-signature view-base^
+   refresh/resynth
-  (base-frame%))
 
-#;
+   reset-primary-partition
-(define-signature prefs^
+   remove-current-term
-  (pref:width
+   duplicate-stepper
-   pref:height
+   show-in-new-frame
-   pref:props-shown?
+
-   pref:props-percentage
+   get-preprocess-deriv
-   pref:macro-hiding-mode
+   get-show-macro?
-   pref:show-syntax-properties?
+))
-   pref:show-hiding-panel?
+
-   pref:identifier=?
+(define-interface stepper-frame<%> ()
-   pref:show-rename-steps?
+  (get-widget
-   pref:highlight-foci?
+   get-controller
-   pref:highlight-frontier?
+   add-obsoleted-warning))
-   pref:suppress-warnings?
+
-   pref:one-by-one?
+(define-interface hiding-prefs<%> ()
-   pref:extra-navigation?
+  (add-show-identifier
-   pref:debug-catch-errors?
+   add-hide-identifier
-   pref:force-letrec-transformation?
+   set-syntax
+   get-policy
+   refresh))
+
+
+(define-interface step-display<%> ()
+  (add-syntax
+   add-step
+   add-error
+   add-final
+   add-internal-error))
+
+
+(define-interface term-record<%> ()
+  (get-raw-deriv
+   get-deriv-hidden?
+   get-step-index
+   invalidate-synth!
+   invalidate-steps!
+
+   has-prev?
+   has-next?
+#|
+   at-start?
+   at-end?
+|#
+   navigate-to-start
+   navigate-to-end
+   navigate-previous
+   navigate-next
+   navigate-to
+
+   on-get-focus
+   on-lose-focus
+
+   display-initial-term
+   display-final-term
+   display-step
    ))
 
-;; macro-stepper-config%
+(define-interface director<%> ()
-;;   all fields are notify-box% objects
+  (add-deriv
-;;     width
+   new-stepper))
-;;     height
-;;     macro-hiding?
-;;     hide-primitives?
-;;     hide-libs?
-;;     show-syntax-properties?
-;;     show-hiding-panel?
-;;     show-rename-steps?
-;;     highlight-foci?

collects/macro-debugger/view/step-display.ss

@@ -1,6 +1,7 @@
 
 #lang scheme/base
 (require scheme/class
+         macro-debugger/util/class-iop
          scheme/unit
          scheme/list
          scheme/match
@@ -21,8 +22,10 @@
          "../model/reductions.ss"
          "../model/steps.ss"
          "../util/notify.ss"
+	 (prefix-in sb: "../syntax-browser/interfaces.ss")
          "cursor.ss"
          "debug-format.ss")
+
 #;
 (provide step-display%
          step-display<%>)
@@ -35,24 +38,6 @@
 (define (prestep-term1 s) (state-term (protostep-s1 s)))
 (define (poststep-term2 s) (state-term (protostep-s1 s)))
 
-
-(define step-display<%>
-  (interface ()
-    ;; add-syntax
-    add-syntax
-
-    ;; add-step
-    add-step
-
-    ;; add-error
-    add-error
-
-    ;; add-final
-    add-final
-
-    ;; add-internal-error
-    add-internal-error))
-
 (define step-display%
   (class* object% (step-display<%>)
 
@@ -61,18 +46,18 @@
     (super-new)
 
     (define/public (add-internal-error part exn stx events)
-      (send sbview add-text
+      (send: sbview sb:syntax-browser<%> add-text
              (if part
                  (format "Macro stepper error (~a)" part)
                  "Macro stepper error"))
       (when (exn? exn)
-        (send sbview add-text " ")
+        (send: sbview sb:syntax-browser<%> add-text " ")
-        (send sbview add-clickback "[details]"
+        (send: sbview sb:syntax-browser<%> add-clickback "[details]"
                (lambda _ (show-internal-error-details exn events))))
-      (send sbview add-text ".  ")
+      (send: sbview sb:syntax-browser<%> add-text ".  ")
-      (when stx (send sbview add-text "Original syntax:"))
+      (when stx (send: sbview sb:syntax-browser<%> add-text "Original syntax:"))
-      (send sbview add-text "\n")
+      (send: sbview sb:syntax-browser<%> add-text "\n")
-      (when stx (send sbview add-syntax stx)))
+      (when stx (send: sbview sb:syntax-browser<%> add-syntax stx)))
 
     (define/private (show-internal-error-details exn events)
       (case (message-box/custom "Macro stepper internal error"
@@ -91,8 +76,9 @@
         ((3 #f) (void))))
 
     (define/public (add-error exn)
-      (send sbview add-error-text (exn-message exn))
+      (send*: sbview sb:syntax-browser<%>
-      (send sbview add-text "\n"))
+        (add-error-text (exn-message exn))
+        (add-text "\n")))
 
     (define/public (add-step step
                              #:binders binders
@@ -110,7 +96,7 @@
                                #:binders [binders #f]
                                #:shift-table [shift-table #f]
                                #:definites [definites null])
-      (send sbview add-syntax stx
+      (send: sbview sb:syntax-browser<%> add-syntax stx
              #:binder-table binders
              #:shift-table shift-table
              #:definites definites))
@@ -120,11 +106,12 @@
                               #:shift-table [shift-table #f]
                               #:definites definites)
       (when stx
-        (send sbview add-text "Expansion finished\n")
+        (send*: sbview sb:syntax-browser<%>
-        (send sbview add-syntax stx
+          (add-text "Expansion finished\n")
+          (add-syntax stx
                       #:binder-table binders
                       #:shift-table shift-table
-              #:definites definites))
+                      #:definites definites)))
       (when error
         (add-error error)))
 
@@ -133,17 +120,16 @@
       (define state (protostep-s1 step))
       (define lctx (state-lctx state))
       (when (pair? lctx)
-        (send sbview add-text "\n")
+        (send: sbview sb:syntax-browser<%> add-text "\n")
-        (for-each (lambda (bf)
+        (for ([bf (reverse lctx)])
-                    (send sbview add-text 
+          (send: sbview sb:syntax-browser<%> add-text 
                  "while executing macro transformer in:\n")
           (insert-syntax/redex (bigframe-term bf)
                                (bigframe-foci bf)
                                binders
                                shift-table
                                (state-uses state)
-                                         (state-frontier state)))
+                               (state-frontier state)))))
-                  (reverse lctx))))
 
     ;; separator : Step -> void
     (define/private (separator step)
@@ -194,15 +180,15 @@
       (define state (protostep-s1 step))
       (show-state/redex state binders shift-table)
       (separator step)
-      (send sbview add-error-text (exn-message (misstep-exn step)))
+      (send*: sbview sb:syntax-browser<%>
-      (send sbview add-text "\n")
+        (add-error-text (exn-message (misstep-exn step)))
+        (add-text "\n"))
       (when (exn:fail:syntax? (misstep-exn step))
-        (for-each (lambda (e)
+        (for ([e (exn:fail:syntax-exprs (misstep-exn step))])
-                    (send sbview add-syntax e
+          (send: sbview sb:syntax-browser<%> add-syntax e
                  #:binder-table binders
                  #:shift-table shift-table
-                          #:definites (or (state-uses state) null)))
+                 #:definites (or (state-uses state) null))))
-                  (exn:fail:syntax-exprs (misstep-exn step))))
       (show-lctx step binders shift-table))
 
     ;; insert-syntax/color
@@ -210,7 +196,7 @@
                                          definites frontier hi-color)
       (define highlight-foci? (send config get-highlight-foci?))
       (define highlight-frontier? (send config get-highlight-frontier?))
-      (send sbview add-syntax stx
+      (send: sbview sb:syntax-browser<%> add-syntax stx
              #:definites (or definites null)
              #:binder-table binders
              #:shift-table shift-table
@@ -233,29 +219,32 @@
 
     ;; insert-step-separator : string -> void
     (define/private (insert-step-separator text)
-      (send sbview add-text "\n    ")
+      (send*: sbview sb:syntax-browser<%>
-      (send sbview add-text
+        (add-text "\n    ")
+        (add-text
          (make-object image-snip% 
                       (build-path (collection-path "icons")
                                   "red-arrow.bmp")))
-      (send sbview add-text "  ")
+        (add-text "  ")
-      (send sbview add-text text)
+        (add-text text)
-      (send sbview add-text "\n\n"))
+        (add-text "\n\n")))
 
     ;; insert-as-separator : string -> void
     (define/private (insert-as-separator text)
-      (send sbview add-text "\n    ")
+      (send*: sbview sb:syntax-browser<%>
-      (send sbview add-text text)
+        (add-text "\n    ")
-      (send sbview add-text "\n\n"))
+        (add-text text)
+        (add-text "\n\n")))
 
     ;; insert-step-separator/small : string -> void
     (define/private (insert-step-separator/small text)
-      (send sbview add-text "    ")
+      (send*: sbview sb:syntax-browser<%>
-      (send sbview add-text
+        (add-text "    ")
+        (add-text
          (make-object image-snip% 
                       (build-path (collection-path "icons")
                                   "red-arrow.bmp")))
-      (send sbview add-text "  ")
+        (add-text "  ")
-      (send sbview add-text text)
+        (add-text text)
-      (send sbview add-text "\n\n"))
+        (add-text "\n\n")))
     ))

collects/macro-debugger/view/stepper.ss

@@ -1,6 +1,7 @@
 
 #lang scheme/base
 (require scheme/class
+         macro-debugger/util/class-iop
          scheme/unit
          scheme/list
          scheme/match
@@ -14,6 +15,7 @@
          "hiding-panel.ss"
          "term-record.ss"
          "step-display.ss"
+	 (prefix-in sb: "../syntax-browser/interfaces.ss")
          "../model/deriv.ss"
          "../model/deriv-util.ss"
          "../model/deriv-find.ss"
@@ -29,10 +31,10 @@
 
 ;; macro-stepper-widget%
 (define macro-stepper-widget%
-  (class* object% ()
+  (class* object% (widget<%>)
     (init-field parent)
     (init-field config)
-    (init-field director)
+    (init-field: (director director<%>))
 
     ;; Terms
 
@@ -65,7 +67,7 @@
     (define/public (add trec)
       (set! all-terms (cons trec all-terms))
       (let ([display-new-term? (cursor:at-end? terms)]
-            [invisible? (send trec get-deriv-hidden?)])
+            [invisible? (send: trec term-record<%> get-deriv-hidden?)])
         (unless invisible?
           (cursor:add-to-end! terms (list trec))
           (trim-navigator)
@@ -83,15 +85,16 @@
     (define/public (show-in-new-frame)
       (let ([term (focused-term)])
         (when term
-          (let ([new-stepper (send director new-stepper '(no-new-traces))])
+          (let ([new-stepper (send: director director<%> new-stepper '(no-new-traces))])
-            (send new-stepper add-deriv (send term get-raw-deriv))
+            (send: new-stepper widget<%> add-deriv (send term get-raw-deriv))
             (void)))))
 
     ;; duplicate-stepper : -> void
     (define/public (duplicate-stepper)
-      (let ([new-stepper (send director new-stepper)])
+      (let ([new-stepper (send: director director<%> new-stepper)])
         (for ([term (cursor->list terms)])
-          (send new-stepper add-deriv (send term get-raw-deriv)))))
+          (send: new-stepper widget<%> add-deriv
+                 (send: term term-record<%> get-raw-deriv)))))
 
     (define/public (get-config) config)
     (define/public (get-controller) sbc)
@@ -101,7 +104,7 @@
     (define/public (get-macro-hiding-prefs) macro-hiding-prefs)
 
     (define/public (reset-primary-partition)
-      (send sbc reset-primary-partition)
+      (send: sbc sb:controller<%> reset-primary-partition)
       (update/preserve-view))
 
     (define area (new vertical-panel% (parent parent)))
@@ -126,16 +129,19 @@
     
     (define warnings-area (new stepper-warnings% (parent area)))
     
-    (define sbview (new stepper-syntax-widget% 
+    (define: sbview sb:syntax-browser<%>
+      (new stepper-syntax-widget% 
            (parent area)
            (macro-stepper this)))
-    (define step-displayer (new step-display%
+    (define: step-displayer step-display<%>
+      (new step-display%
            (config config)
            (syntax-widget sbview)))
-    (define sbc (send sbview get-controller))
+    (define: sbc sb:controller<%>
+      (send sbview get-controller))
     (define control-pane
       (new vertical-panel% (parent area) (stretchable-height #f)))
-    (define macro-hiding-prefs
+    (define: macro-hiding-prefs hiding-prefs<%>
       (new macro-hiding-prefs-widget%
            (parent control-pane)
            (stepper this)
@@ -144,7 +150,7 @@
     (send config listen-show-hiding-panel?
           (lambda (show?) (show-macro-hiding-panel show?)))
     (send sbc listen-selected-syntax
-          (lambda (stx) (send macro-hiding-prefs set-syntax stx)))
+          (lambda (stx) (send: macro-hiding-prefs hiding-prefs<%> set-syntax stx)))
     (send config listen-highlight-foci?
           (lambda (_) (update/preserve-view)))
     (send config listen-highlight-frontier?
@@ -231,36 +237,36 @@
                   (list navigator)))))
 
     ;; Navigation
-
+#|
     (define/public-final (at-start?)
-      (send (focused-term) at-start?))
+      (send: (focused-term) term-record<%> at-start?))
     (define/public-final (at-end?)
-      (send (focused-term) at-end?))
+      (send: (focused-term) term-record<%> at-end?))
-
+|#
     (define/public-final (navigate-to-start)
-      (send (focused-term) navigate-to-start)
+      (send: (focused-term) term-record<%> navigate-to-start)
       (update/save-position))
     (define/public-final (navigate-to-end)
-      (send (focused-term) navigate-to-end)
+      (send: (focused-term) term-record<%> navigate-to-end)
       (update/save-position))
     (define/public-final (navigate-previous)
-      (send (focused-term) navigate-previous)
+      (send: (focused-term) term-record<%> navigate-previous)
       (update/save-position))
     (define/public-final (navigate-next)
-      (send (focused-term) navigate-next)
+      (send: (focused-term) term-record<%> navigate-next)
       (update/save-position))
     (define/public-final (navigate-to n)
-      (send (focused-term) navigate-to n)
+      (send: (focused-term) term-record<%> navigate-to n)
       (update/save-position))
 
     (define/public-final (navigate-up)
       (when (focused-term)
-        (send (focused-term) on-lose-focus))
+        (send: (focused-term) term-record<%> on-lose-focus))
       (cursor:move-prev terms)
       (refresh/move))
     (define/public-final (navigate-down)
       (when (focused-term)
-        (send (focused-term) on-lose-focus))
+        (send: (focused-term) term-record<%> on-lose-focus))
       (cursor:move-next terms)
       (refresh/move))
 
@@ -272,7 +278,7 @@
 
     ;; update/preserve-lines-view : -> void
     (define/public (update/preserve-lines-view)
-      (define text (send sbview get-text))
+      (define text (send: sbview sb:syntax-browser<%> get-text))
       (define start-box (box 0))
       (define end-box (box 0))
       (send text get-visible-line-range start-box end-box)
@@ -285,7 +291,7 @@
 
     ;; update/preserve-view : -> void
     (define/public (update/preserve-view)
-      (define text (send sbview get-text))
+      (define text (send: sbview sb:syntax-browser<%> get-text))
       (define start-box (box 0))
       (define end-box (box 0))
       (send text get-visible-position-range start-box end-box)
@@ -295,17 +301,17 @@
     ;; update : -> void
     ;; Updates the terms in the syntax browser to the current step
     (define/private (update)
-      (define text (send sbview get-text))
+      (define text (send: sbview sb:syntax-browser<%> get-text))
       (define position-of-interest 0)
       (define multiple-terms? (> (length (cursor->list terms)) 1))
       (send text begin-edit-sequence)
-      (send sbview erase-all)
+      (send: sbview sb:syntax-browser<%> erase-all)
 
       (update:show-prefix)
-      (when multiple-terms? (send sbview add-separator))
+      (when multiple-terms? (send: sbview sb:syntax-browser<%> add-separator))
       (set! position-of-interest (send text last-position))
       (update:show-current-step)
-      (when multiple-terms? (send sbview add-separator))
+      (when multiple-terms? (send: sbview sb:syntax-browser<%> add-separator))
       (update:show-suffix)
       (send text end-edit-sequence)
       (send text scroll-to-position
@@ -319,35 +325,35 @@
     ;; update:show-prefix : -> void
     (define/private (update:show-prefix)
       ;; Show the final terms from the cached synth'd derivs
-      (for-each (lambda (trec) (send trec display-final-term))
+      (for-each (lambda (trec) (send: trec term-record<%> display-final-term))
                 (cursor:prefix->list terms)))
 
     ;; update:show-current-step : -> void
     (define/private (update:show-current-step)
       (when (focused-term)
-        (send (focused-term) display-step)))
+        (send: (focused-term) term-record<%> display-step)))
 
     ;; update:show-suffix : -> void
     (define/private (update:show-suffix)
       (let ([suffix0 (cursor:suffix->list terms)])
         (when (pair? suffix0)
           (for-each (lambda (trec)
-                      (send trec display-initial-term))
+                      (send: trec term-record<%> display-initial-term))
                     (cdr suffix0)))))
 
     ;; update-nav-index : -> void
     (define/private (update-nav-index)
       (define term (focused-term))
       (set-current-step-index
-       (and term (send term get-step-index))))
+       (and term (send: term term-record<%> get-step-index))))
 
     ;; enable/disable-buttons : -> void
     (define/private (enable/disable-buttons)
       (define term (focused-term))
-      (send nav:start enable (and term (send term has-prev?)))
+      (send nav:start enable (and term (send: term term-record<%> has-prev?)))
-      (send nav:previous enable (and term (send term has-prev?)))
+      (send nav:previous enable (and term (send: term term-record<%> has-prev?)))
-      (send nav:next enable (and term (send term has-next?)))
+      (send nav:next enable (and term (send: term term-record<%> has-next?)))
-      (send nav:end enable (and term (send term has-next?)))
+      (send nav:end enable (and term (send: term term-record<%> has-next?)))
       (send nav:text enable (and term #t))
       (send nav:up enable (cursor:has-prev? terms))
       (send nav:down enable (cursor:has-next? terms)))
@@ -357,14 +363,14 @@
     ;; refresh/resynth : -> void
     ;; Macro hiding policy has changed; invalidate cached parts of trec
     (define/public (refresh/resynth)
-      (for-each (lambda (trec) (send trec invalidate-synth!))
+      (for-each (lambda (trec) (send: trec term-record<%> 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 (lambda (trec) (send trec invalidate-steps!))
+      (for-each (lambda (trec) (send: trec term-record<%> invalidate-steps!))
                 (cursor->list terms))
       (refresh))
 
@@ -377,47 +383,15 @@
     (define/public (refresh)
       (send warnings-area clear)
       (when (focused-term)
-        (send (focused-term) on-get-focus))
+        (send: (focused-term) term-record<%> on-get-focus))
       (update))
 
-#|
-    ;; 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)))
-|#
-
     (define/private (foci x) (if (list? x) x (list x)))
 
     ;; Hiding policy
     
     (define/public (get-show-macro?)
-      (send macro-hiding-prefs get-policy))
+      (send: macro-hiding-prefs hiding-prefs<%> get-policy))
 
     ;; Derivation pre-processing
 

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

@@ -1,6 +1,6 @@
-
 #lang scheme/base
 (require scheme/class
+         macro-debugger/util/class-iop
          scheme/unit
          scheme/list
          scheme/match
@@ -30,11 +30,12 @@
 ;; TermRecords
 
 (define term-record%
-  (class object%
+  (class* object% (term-record<%>)
-    (init-field stepper)
+    (init-field: (stepper widget<%>))
 
     (define config (send stepper get-config))
-    (define displayer (send stepper get-step-displayer))
+    (define: displayer step-display<%>
+      (send: stepper widget<%> get-step-displayer))
 
     ;; Data
     
@@ -128,7 +129,7 @@
       (unless (or deriv deriv-hidden?)
         (recache-raw-deriv!)
         (when raw-deriv
-          (let ([process (send stepper get-preprocess-deriv)])
+          (let ([process (send: stepper widget<%> get-preprocess-deriv)])
             (let ([d (process raw-deriv)])
               (when (not d)
                 (set! deriv-hidden? #t))
@@ -151,7 +152,7 @@
       (unless (or raw-steps raw-steps-oops)
         (recache-synth!)
         (when deriv
-          (let ([show-macro? (or (send stepper get-show-macro?)
+          (let ([show-macro? (or (send: stepper widget<%> get-show-macro?)
                                  (lambda (id) #t))])
             (with-handlers ([(lambda (e) #t)
                              (lambda (e)
@@ -274,18 +275,18 @@
 
     ;; display-initial-term : -> void
     (define/public (display-initial-term)
-      (send displayer add-syntax (wderiv-e1 deriv)))
+      (send: displayer step-display<%> add-syntax (wderiv-e1 deriv)))
 
     ;; display-final-term : -> void
     (define/public (display-final-term)
       (recache-steps!)
       (cond [(syntax? raw-steps-estx)
-             (send displayer add-syntax raw-steps-estx
+             (send: displayer step-display<%> add-syntax raw-steps-estx
                     #:binders binders
                     #:shift-table shift-table
                     #:definites raw-steps-definites)]
             [(exn? raw-steps-exn)
-             (send displayer add-error raw-steps-exn)]
+             (send: displayer step-display<%> add-error raw-steps-exn)]
             [else (display-oops #f)]))
 
     ;; display-step : -> void
@@ -294,10 +295,10 @@
       (cond [steps
              (let ([step (cursor:next steps)])
                (if step
-                   (send displayer add-step step
+                   (send: displayer step-display<%> add-step step
                           #:binders binders
                           #:shift-table shift-table)
-                   (send displayer add-final raw-steps-estx raw-steps-exn
+                   (send: displayer step-display<%> add-final raw-steps-estx raw-steps-exn
                           #:binders binders
                           #:shift-table shift-table
                           #:definites raw-steps-definites)))]
@@ -306,12 +307,12 @@
     ;; display-oops : boolean -> void
     (define/private (display-oops show-syntax?)
       (cond [raw-steps-oops
-             (send displayer add-internal-error
+             (send: displayer step-display<%> add-internal-error
                     "steps" raw-steps-oops
                     (and show-syntax? (wderiv-e1 deriv))
                     events)]
             [raw-deriv-oops
-             (send displayer add-internal-error
+             (send: displayer step-display<%> add-internal-error
                     "derivation" raw-deriv-oops #f events)]
             [else
              (error 'term-record::display-oops "internal error")]))

collects/macro-debugger/view/view.ss

@@ -1,6 +1,7 @@
 
 #lang scheme/base
 (require scheme/class
+         macro-debugger/util/class-iop
          scheme/pretty
          scheme/gui
          framework/framework
@@ -13,7 +14,7 @@
          go)
 
 (define macro-stepper-director%
-  (class object%
+  (class* object% (director<%>)
     (define stepper-frames (make-hasheq))
 
     ;; Flags is a subset(list) of '(no-obsolete no-new-traces)
@@ -27,23 +28,23 @@
       (hash-for-each stepper-frames
                      (lambda (stepper-frame flags)
                        (unless (memq 'no-obsolete flags)
-                         (send stepper-frame add-obsoleted-warning)))))
+                         (send: stepper-frame stepper-frame<%> add-obsoleted-warning)))))
     (define/public (add-trace events)
       (hash-for-each stepper-frames
                      (lambda (stepper-frame flags)
                        (unless (memq 'no-new-traces flags)
-                         (send (send stepper-frame get-widget)
+                         (send: (send: stepper-frame stepper-frame<%> get-widget) widget<%>
                                 add-trace events)))))
     (define/public (add-deriv deriv)
       (hash-for-each stepper-frames
                      (lambda (stepper-frame flags)
                        (unless (memq 'no-new-traces flags)
-                         (send (send stepper-frame get-widget)
+                         (send: (send: stepper-frame stepper-frame<%> get-widget) widget<%>
                                 add-deriv deriv)))))
 
     (define/public (new-stepper [flags '()])
       (define stepper-frame (new-stepper-frame))
-      (define stepper (send stepper-frame get-widget))
+      (define stepper (send: stepper-frame stepper-frame<%> get-widget))
       (send stepper-frame show #t)
       (add-stepper! stepper-frame flags)
       stepper)
@@ -64,31 +65,6 @@
 
 (define (go stx)
   (define director (new macro-stepper-director%))
-  (define stepper (send director new-stepper))
+  (define stepper (send: director director<%> new-stepper))
-  (send director add-deriv (trace stx))
+  (send: director director<%> add-deriv (trace stx))
   (void))
-
-#|
-(define (make-macro-stepper)
-  (let ([f (new macro-stepper-frame%
-                (config (new macro-stepper-config/prefs%)))])
-    (send f show #t)
-    (send f get-widget)))
-
-(define (go stx)
-  (let ([stepper (make-macro-stepper)])
-    (send stepper add-deriv (trace stx))
-    stepper))
-
-(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))
-
-(define (go/trace events)
-  (let* ([w (make-macro-stepper)])
-    (send w add-trace events)
-    w))
-|#

collects/redex/private/size-snip.ss

@@ -1,19 +1,20 @@
-(module size-snip mzscheme
+#lang scheme/base
-  (require (lib "mred.ss" "mred")
+(require scheme/gui/base
-           (lib "class.ss")
+         scheme/class
-           (lib "pretty.ss")
+         framework
-           (lib "framework.ss" "framework")
+         scheme/pretty
          "matcher.ss")
 
-  (provide reflowing-snip<%>
+(provide reflowing-snip<%>
          size-editor-snip%
+         size-text%
          default-pretty-printer
          initial-char-width
          resizing-pasteboard-mixin)
 
-  (define initial-char-width (make-parameter 30))
+(define initial-char-width (make-parameter 30))
 
-  (define (default-pretty-printer v port w spec)
+(define (default-pretty-printer v port w spec)
   (parameterize ([pretty-print-columns w]
                  [pretty-print-size-hook
                   (λ (val display? op)
@@ -30,13 +31,12 @@
                        (display ",'hole" op)]))])
     (pretty-print v port)))
 
-  (define reflowing-snip<%>
+(define reflowing-snip<%>
   (interface ()
     reflow-program))
 
-  (define (resizing-pasteboard-mixin pb%)
+(define (resizing-pasteboard-mixin pb%)
   (class pb%
-      (init-field shrink-down?)
     
     (define/augment (on-interactive-resize snip)
       (when (is-a? snip reflowing-snip<%>)
@@ -55,29 +55,13 @@
     
     (inherit get-snip-location
              begin-edit-sequence
-               end-edit-sequence)
+             end-edit-sequence
+             find-first-snip
+             get-dc)
     
-      (define/augment (on-insert snip before x y)
-        (begin-edit-sequence)
-        (inner (void) on-insert snip before x y))
-      (define/augment (after-insert snip before x y)
-        (inner (void) after-insert snip before x y)
-        (when (is-a? snip size-editor-snip%)
-           (let ([cw (send snip get-char-width)]
-                 [woc (send snip get-width-of-char)]
-                 [bt (box 0)]
-                 [bb (box 0)])
-             (get-snip-location snip #f bt #f)
-             (get-snip-location snip #f bb #t)
-             (send snip resize 
-                   (* cw woc)
-                   (- (unbox bb) (unbox bt)))
-             (when shrink-down?
-               (send snip shrink-down))))
-        (end-edit-sequence))
     (super-new)))
 
-  (define size-editor-snip%
+(define size-editor-snip%
   (class* editor-snip% (reflowing-snip<%>)
     (init-field expr)
     (init pp)
@@ -86,6 +70,7 @@
       (if (procedure-arity-includes? pp 4)
           pp
           (lambda (v port w spec) (display (pp v) port))))
+    
     (inherit get-admin)
     (define/public (get-expr) expr)
     (define/public (get-char-width) char-width)
@@ -106,29 +91,6 @@
               (format-expr)
               (on-width-changed char-width))))))
     
-      ;; final
-      (define/pubment (shrink-down)
-        (let ([ed (get-editor)]
-              [bx (box 0)]
-              [by (box 0)])
-          (let ([max-line-width
-                 (let loop ([p 0]
-                            [max-w 0])
-                   (cond
-                     [(<= p (send ed last-paragraph))
-                      (send ed position-location 
-                            (send ed paragraph-end-position p)
-                            bx by #t)
-                      (let ([this-w (unbox bx)])
-                        (loop (+ p 1)
-                              (max this-w max-w)))]
-                     [else max-w]))])
-            (send ed position-location (send ed last-position) bx by #f)
-            (let-values ([(hms vms) (get-margin-space)])
-              (super resize
-                     (+ max-line-width hms)
-                     (+ (unbox by) vms))))))
-      
     (inherit get-margin)
     (define/public (get-snip-width)
       (let ([admin (get-admin)])
@@ -148,20 +110,23 @@
             [bt (box 0)]
             [bb (box 0)])
         (get-margin bl bt br bb)
-          (values (+ (unbox bl) (unbox br) 2)   ;; not sure what the 2 is for. Maybe caret space?
+        (values (+ (unbox bl) (unbox br) 6)   ;; not sure what the 2 is for. Maybe caret space?
                 (+ (unbox bt) (unbox bb)))))
     
+    ;; get-width-of-char : -> number or false
+    ;; depends on `dc' field
     (define/public (get-width-of-char)
       (let ([ed (get-editor)])
         (and ed
-               (let ([dc (send ed get-dc)]
+             (let ([std-style (send (editor:get-standard-style-list) find-named-style "Standard")]
-                     [std-style (send (editor:get-standard-style-list) find-named-style "Standard")])
+                   [dc (send ed get-dc)])
                (and dc
                     (let-values ([(tw th _2 _3) (send dc get-text-extent "w"
                                                       (and std-style
                                                            (send std-style get-font)))])
                       tw))))))
     
+    ;; depends on `dc' field
     (define/public (get-height-of-char)
       (let ([ed (get-editor)])
         (and ed
@@ -193,4 +158,14 @@
     
     (super-new)
     (inherit use-style-background)
-      (use-style-background #t))))
+    (use-style-background #t)))
+
+(define size-text%
+  (scheme:set-mode-mixin
+   (scheme:text-mixin
+    (color:text-mixin
+     (text:autocomplete-mixin
+      (mode:host-text-mixin
+       (editor:standard-style-list-mixin
+        text:basic%)))))))
+

collects/redex/private/stepper.ss

@@ -77,7 +77,6 @@ todo:
     (define upper-hp (new horizontal-panel% [parent dp]))
     (define lower-hp (new horizontal-panel% [alignment '(center center)] [parent f] [stretchable-height #f]))
     (define pb (new columnar-pasteboard% 
-                    [shrink-down? #f]
                     [moved (λ (a b c d) 
                              (when (procedure? moved)
                                (moved a b c d)))]))
@@ -801,7 +800,7 @@ todo:
            flat-to-remove)
           (for-each (λ (x) (insert x)) flat-to-insert)))
       
-      (inherit get-admin move-to resize)
+      (inherit get-admin move-to)
       (define/public (update-heights)
         (let ([admin (get-admin)])
           (let-values ([(w h) (get-view-size)])
@@ -816,9 +815,11 @@ todo:
                       ;; if there is only a single snip in the column, we let it be as long as it wants to be.
                       (let* ([snip (car column)]
                              [sw (get-snip-width snip)]
-                             [sh (get-snip-max-height snip)])
+                             [sh (get-snip-max-height snip)]
+                             [new-height (- (max h sh) (get-border-height snip))])
                         (move-to snip x 0)
-                        (resize snip sw (max h sh))
+                        (send snip set-min-height new-height)
+                        (send snip set-max-height new-height)
                         (loop (cdr columns) (+ x sw)))]
                      [else
                       ;; otherwise, we make all of the snips fit into the visible area
@@ -838,16 +839,39 @@ todo:
                                                     0
                                                     1))])
                                      (move-to snip x y)
-                                     (resize snip sw h)
+                                     (let ([border-height (get-border-height snip)])
+                                       (send snip set-min-height (- h border-height))
+                                       (send snip set-max-height (- h border-height)))
                                      (loop (cdr snips)
                                            (if (zero? extra-space)
                                                0
                                                (- extra-space 1))
                                            (+ y h)
                                            (max widest sw)))]))])
+                          (for-each (λ (snip) 
+                                      (let ([border-width (get-border-width snip)])
+                                        (send snip set-min-width (- widest border-width))
+                                        (send snip set-max-width (- widest border-width))))
+                                    column)
                         (loop (cdr columns)
                               (+ x widest)))]))])))))
 
+      (define/private (get-border-height snip)
+        (let ([lb (box 0)]
+              [tb (box 0)]
+              [rb (box 0)]
+              [bb (box 0)])
+          (send snip get-margin lb tb bb rb)
+          (+ (unbox bb) (unbox tb))))
+      
+      (define/private (get-border-width snip)
+        (let ([lb (box 0)]
+              [tb (box 0)]
+              [rb (box 0)]
+              [bb (box 0)])
+          (send snip get-margin lb tb bb rb)
+          (+ (unbox lb) (unbox rb))))
+      
       (inherit get-snip-location)
       (define/public (get-snip-width snip)
         (let ([lb (box 0)]

collects/redex/private/traces.ss

@@ -1,15 +1,17 @@
+#lang scheme/base
+
 ;; should cache the count of new snips -- dont
 ;; use `count-snips'; use something associated with the
 ;; equal hash-table
 
-#lang scheme
-
 (require mrlib/graph
          "reduction-semantics.ss"
          "matcher.ss"
          "size-snip.ss"
          "dot.ss"
          scheme/gui/base
+         scheme/class
+         scheme/file
          framework)
 
 (preferences:set-default 'plt-reducer:show-bottom #t boolean?)
@@ -139,12 +141,83 @@
                         #:scheme-colors? scheme-colors?
                         #:colors colors
                         #:layout layout)])
+    (print-to-ps graph-pb filename)))
+
+(define (print-to-ps graph-pb filename)
+  (let ([admin (send graph-pb get-admin)]
+        [printing-admin (new printing-editor-admin%)])
+    (send graph-pb set-admin printing-admin)
+    
+    (dynamic-wind
+     void
+     (λ ()
+       (let loop ([snip (send graph-pb find-first-snip)])
+         (when snip
+           (send snip size-cache-invalid)
+           (loop (send snip next))))
+       (send graph-pb invalidate-bitmap-cache)
+       
+       (send graph-pb re-run-layout)
+       
        (let ([ps-setup (make-object ps-setup%)])
          (send ps-setup copy-from (current-ps-setup))
          (send ps-setup set-file filename)
          (send ps-setup set-mode 'file)
          (parameterize ([current-ps-setup ps-setup])
-        (send graph-pb print #f #f 'postscript #f #f #t)))))
+           (send graph-pb print #f #f 'postscript #f #f #t))))
+     
+     (λ ()
+       (send graph-pb set-admin admin)
+       (send printing-admin shutdown) ;; do this early
+       (let loop ([snip (send graph-pb find-first-snip)])
+         (when snip
+           (send snip size-cache-invalid)
+           (loop (send snip next))))
+       (send graph-pb invalidate-bitmap-cache)
+       (send graph-pb re-run-layout)))))
+
+(define printing-editor-admin%
+  (class editor-admin%
+    
+    (define temp-file (make-temporary-file "redex-size-snip-~a"))
+    
+    (define ps-dc
+      (let ([ps-setup (make-object ps-setup%)])
+        (send ps-setup copy-from (current-ps-setup))
+        (send ps-setup set-file temp-file)
+        (parameterize ([current-ps-setup ps-setup])
+          (make-object post-script-dc% #f #f #f #t))))
+    
+    (send ps-dc start-doc "fake dc")
+    (send ps-dc start-page)
+    (super-new)
+    
+    (define/public (shutdown)
+      (send ps-dc end-page)
+      (send ps-dc end-doc)
+      (delete-file temp-file))
+       
+    
+    (define/override (get-dc [x #f] [y #f])
+      (super get-dc x y)
+      ps-dc)
+    (define/override (get-max-view x y w h [full? #f])
+      (get-view x y w h full?))
+    (define/override (get-view x y w h [full? #f])
+      (super get-view x y w h full?)
+      (when (box? w) (set-box! w 500))
+      (when (box? h) (set-box! h 500)))
+    
+    ;; the following methods are not overridden; they all default to doing nothing.
+    ;;   grab-caret
+    ;;   modified
+    ;;   needs-update
+    ;;   popup-menu
+    ;;   refresh-delayed?
+    ;;   resized
+    ;;   scroll-to
+    ;;   update-cursor
+    ))
 
 (define (traces reductions pre-exprs 
                 #:multiple? [multiple? #f] 
@@ -157,7 +230,7 @@
   (define exprs (if multiple? pre-exprs (list pre-exprs)))
   (define main-eventspace (current-eventspace))
   (define saved-parameterization (current-parameterization))
-  (define graph-pb (new graph-pasteboard% [shrink-down? #t]))
+  (define graph-pb (new graph-pasteboard% [layout layout]))
   (define f (instantiate red-sem-frame% ()
               (label "PLT Redex Reduction Graph")
               (style '(toolbar-button))
@@ -275,7 +348,7 @@
       (let loop ([snip (send graph-pb find-first-snip)])
         (when snip
           (when (is-a? snip reflowing-snip<%>)
-            (send snip shrink-down))
+            (send snip reflow-program))
           (loop (send snip next))))))
   
   ;; fill-out : (listof X) (listof X) -> (listof X)
@@ -338,7 +411,7 @@
                         (set! col (+ x-spacing (find-rightmost-x graph-pb))))
                       (begin0
                         (insert-into col y graph-pb new-snips)
-                        (layout (hash-map snip-cache (lambda (x y) (send y get-term-node))))
+                        (send graph-pb re-run-layout)
                         (send graph-pb end-edit-sequence)
                         (send status-message set-label
                               (string-append (term-count (count-snips)) "...")))))])
@@ -469,7 +542,7 @@
               null)))
   (out-of-dot-state) ;; make sure the state is initialized right
   (insert-into init-rightmost-x 0 graph-pb frontier)
-  (layout (map (lambda (y) (send y get-term-node)) frontier))
+  (send graph-pb re-run-layout)
   (set-font-size (initial-font-size))
   (cond
     [no-show-frame?
@@ -507,6 +580,10 @@
 (define graph-pasteboard% 
   (class (resizing-pasteboard-mixin
           (graph-pasteboard-mixin pasteboard%))
+    
+    (init-field layout) ;; (-> (listof term-node) void)
+    ;; this is the function supplied by the :#layout argument to traces or traces/ps
+    
     (define dot-callback #f)
     (define/public (set-dot-callback cb) (set! dot-callback cb))
     (define/override (draw-edges dc left top right bottom dx dy)
@@ -521,6 +598,17 @@
     (define/augment (can-interactive-move? evt) mobile?)
     (define/augment (can-interactive-resize? evt) mobile?)
     
+    (inherit find-first-snip)
+    (define/public (re-run-layout)
+      (layout 
+       (let loop ([snip (find-first-snip)])
+         (cond
+           [(not snip) '()]
+           [(is-a? snip reflowing-snip<%>)
+            (cons (send snip get-term-node)
+                  (loop (send snip next)))]
+           [else (loop (send snip next))]))))
+    
     (super-new)))
 
 (define graph-editor-snip%
@@ -578,7 +666,7 @@
     (super-new)))
 
 (define program-text%
-  (class scheme:text%
+  (class size-text%
     (define bad-color #f)
     (define/public (set-bad color) (set! bad-color color))
     
@@ -688,6 +776,7 @@
                (pp pp)
                (expr expr))])
     (send text set-autowrap-bitmap #f)
+    (send text set-max-width 'none)
     (send text freeze-colorer)
     (send text stop-colorer (not scheme-colors?))
     (send es format-expr)

collects/redex/redex.scrbl

@@ -213,12 +213,13 @@ looking for a decomposition, it ignores any holes found in
 that @|pattern|.
 }
 
-@item{The @tt{(@defpattech[side-condition] @ttpattern guard)} @pattern matches
+@item{The @tt{(@defpattech[side-condition] @ttpattern guard)} @pattern
-what the embedded @pattern matches, and then the guard expression is
+matches what the embedded @pattern matches, and then the guard
-evaluated. If it returns @scheme[#f], the @pattern fails to match, and if it
+expression is evaluated. If it returns @scheme[#f], the @pattern fails
-returns anything else, the @pattern matches. In addition, any
+to match, and if it returns anything else, the @pattern matches. Any
-occurrences of `name' in the @pattern are bound using @scheme[term-let]
+occurrences of `name' in the @pattern (including those implicitly
-in the guard.
+there via @tt{_} pattersn) are bound using @scheme[term-let] in the
+guard. 
 }
 
 @item{The @tt{(@defpattech[cross] symbol)} @pattern is used for the compatible
@@ -1095,7 +1096,7 @@ pattern does not match the @scheme[pattern].}
           [relation reduction-relation?]
           [property (-> any/c any/c)]
           [#:attempts attempts natural-number/c 100])
-         (or/c true/c void?)]{
+         void?]{
 Tests a @scheme[relation] as follows: for each case of @scheme[relation],
 @scheme[check-reduction-relation] generates @scheme[attempts] random
 terms that match that case's left-hand side and applies @scheme[property] 
@@ -1367,9 +1368,18 @@ the stepper and traces.
 @defparam[dark-pen-color color (or/c string? (is-a?/c color<%>))]{}
 @defparam[dark-brush-color color (or/c string? (is-a?/c color<%>))]{}
 @defparam[light-pen-color color (or/c string? (is-a?/c color<%>))]{}
-@defparam[light-brush-color color (or/c string? (is-a?/c color<%>))]{}]]{
+@defparam[light-brush-color color (or/c string? (is-a?/c color<%>))]{}
+@defparam[dark-text-color color (or/c string? (is-a?/c color<%>))]{}
+@defparam[light-text-color color (or/c string? (is-a?/c color<%>))]{}]]{
 
-These four parameters control the color of the edges in the graph.
+These six parameters control the color of the edges in the graph.
+
+The dark colors are used when the mouse is over one of the nodes that
+is connected to this edge. The light colors are used when it isn't.
+
+The pen colors control the color of the line. The brush colors control
+the color used to fill the arrowhead and the text colors control the
+color used to draw the label on the edge.
 }
 
 @defproc[(default-pretty-printer [v any] [port output-port] [width number] [text (is-a?/c text%)]) void?]{

collects/repos-time-stamp/stamp.ss

@@ -1 +1 @@
-#lang scheme/base (provide stamp) (define stamp "13jan2009")
+#lang scheme/base (provide stamp) (define stamp "14jan2009")

collects/scheme/private/map.ss

@@ -127,4 +127,3 @@
                  (ormap f l1 l2))]
             [(f . args) (apply ormap f args)])])
       ormap)))
-  

collects/scribblings/gui/blurbs.ss

@@ -267,8 +267,8 @@ information@|details|, even if the editor currently has delayed refreshing (see
 
   (define (edsnipsize a b c)
     @elem{An @scheme[editor-snip%] normally stretches to wrap around the size
-          of the editor it contains. This method #1 of the snip
+          of the editor it contains. This method @|a| of the snip
-          (and if the editor is #2, #3).})
+          (and if the editor is @|b|, @|c|).})
   (define (edsnipmax n)
     (edsnipsize @elem{limits the @|n|}
                 @elem{larger}

collects/tests/typed-scheme/succeed/hw01.scm

@@ -108,4 +108,3 @@
   (= 0 (list-length '()))
   (= 2 (list-length '(1 2)))
   (= 3 (list-length '(1 2 (1 2 3 4))))
-  

collects/typed/net/base64.ss

@@ -10,4 +10,3 @@
   [base64-decode (Bytes -> Bytes)])
 
 (provide base64-encode-stream base64-decode-stream base64-encode base64-decode)
-  

collects/typed/net/pop3.ss

@@ -40,5 +40,3 @@
 (require-typed-struct/provide (malformed-server-response pop3) 
 			      ([communicator : communicator]) net/pop3) 
 
-
-  

collects/typed/net/qp.ss

@@ -7,4 +7,3 @@
   [qp-decode ( String -> String )]
   [qp-encode-stream (case-lambda (Input-Port Output-Port -> Void) (Input-Port Output-Port String -> Void) )]
   [qp-decode-stream ( Input-Port Output-Port -> Void )])
-  

collects/typed/net/sendmail.ss

@@ -9,4 +9,3 @@
    (String String (Listof String) (Listof String) (Listof String) (Listof String) String * -> Output-Port)])
   
 (provide send-mail-message/port send-mail-message #;no-mail-recipients)
-  

collects/typed/net/sendurl.ss

@@ -6,4 +6,3 @@
 	       [external-browser  (-> (U Symbol #f (Pair String String)))])
 
 (provide send-url unix-browser-list browser-preference? external-browser)
-  

collects/typed/net/smtp.ss

@@ -7,5 +7,3 @@
   [smtp-sending-end-of-message (Parameter (-> Any))])
   
 (provide smtp-send-message smtp-sending-end-of-message)
-  
-  

collects/typed/net/uri-codec.ss

@@ -12,4 +12,3 @@
   [alist->form-urlencoded ( (Listof (cons Symbol String)) -> String )]
   [form-urlencoded->alist ( String -> (Listof (cons Symbol String)) )]
   [current-alist-separator-mode (Parameter Symbol)])
-    

src/mzscheme/src/string.c

@@ -968,7 +968,7 @@ void scheme_get_substring_indices(const char *name, Scheme_Object *str,
 
   if (SCHEME_VECTORP(str))
     len = SCHEME_VEC_SIZE(str);
-  if (SCHEME_CHAR_STRINGP(str))
+  else if (SCHEME_CHAR_STRINGP(str))
     len = SCHEME_CHAR_STRTAG_VAL(str);
   else
     len = SCHEME_BYTE_STRTAG_VAL(str);