From 3219cfd0b6f600e3ee427f05a153b35b2ce7cd94 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 8 Jun 2010 10:53:50 -0500 Subject: [PATCH 01/15] changed the macro stepper to be responsive to the white-on-black preference (but there is still some work to do to actually select a reasonable set of colors and probably some refactoring, but at least the interface with the framework is there now, so the changes should not be hard from here on) original commit: e74e929a9285a47b67a5228dfd1a68280c6b1243 --- .../macro-debugger/syntax-browser/display.rkt | 42 +++++++++++++------ .../macro-debugger/syntax-browser/image.rkt | 6 +-- .../macro-debugger/syntax-browser/widget.rkt | 29 ++++++++----- 3 files changed, 51 insertions(+), 26 deletions(-) diff --git a/collects/macro-debugger/syntax-browser/display.rkt b/collects/macro-debugger/syntax-browser/display.rkt index b79f081..653234d 100644 --- a/collects/macro-debugger/syntax-browser/display.rkt +++ b/collects/macro-debugger/syntax-browser/display.rkt @@ -2,6 +2,7 @@ (require scheme/class scheme/gui scheme/list + framework (rename-in unstable/class-iop [send/i send:] [init-field/i init-field:]) @@ -106,7 +107,7 @@ (with-unlock text (send* text (begin-edit-sequence #f) - (change-style unhighlight-d start-position end-position)) + (change-style (unhighlight-d) start-position end-position)) (apply-extra-styles) (let ([selected-syntax (send: controller selection-manager<%> @@ -157,7 +158,7 @@ (send delta set-delta-foreground color) (send style-list find-or-create-style base-style delta))) (define color-styles - (list->vector (map color-style (send: config config<%> get-colors)))) + (list->vector (map color-style (map translate-color (send: config config<%> get-colors))))) (define overflow-style (color-style "darkgray")) (define color-partition (send: controller mark-manager<%> get-primary-partition)) @@ -219,7 +220,7 @@ ;; draw-secondary-connection : syntax -> void (define/private (draw-secondary-connection stx2) (for ([r (send: range range<%> get-ranges stx2)]) - (restyle-range r select-sub-highlight-d))) + (restyle-range r (select-sub-highlight-d)))) ;; restyle-range : (cons num num) style-delta% -> void (define/private (restyle-range r style) @@ -258,7 +259,7 @@ ;; code-style : text<%> number/#f -> style<%> (define (code-style text font-size) (let* ([style-list (send text get-style-list)] - [style (send style-list find-named-style "Standard")]) + [style (send style-list find-named-style (editor:get-default-color-style-name))]) (if font-size (send style-list find-or-create-style style @@ -274,23 +275,40 @@ ;; Styles -(define (highlight-style-delta color em?) - (let ([sd (new style-delta%)]) - (unless em? (send sd set-delta-background color)) +(define (highlight-style-delta raw-color em? #:translate-color? [translate-color? #t]) + (let* ([sd (new style-delta%)]) + (unless em? (send sd set-delta-background (if translate-color? (translate-color raw-color) raw-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 (translate-color color) + (let ([reversed-color + (case (string->symbol (string-downcase color)) + [(white) "black"] + [(black) "white"] + [(yellow) "goldenrod"] + [else (printf "unknown color ~s\n" color) + color])]) + (if (preferences:get 'framework:white-on-black?) + reversed-color + color))) + (define underline-style-delta (let ([sd (new style-delta%)]) (send sd set-underlined-on #t) sd)) -(define selection-color "yellow") -(define subselection-color "yellow") +(define (mk-2-constant-style wob-color bow-color) + (let ([wob-version (highlight-style-delta wob-color #f #:translate-color? #f)] + [bow-version (highlight-style-delta bow-color #f #:translate-color? #f)]) + (λ () + (if (preferences:get 'framework:white-on-black?) + wob-version + bow-version)))) -(define select-highlight-d (highlight-style-delta selection-color #t)) -(define select-sub-highlight-d (highlight-style-delta subselection-color #f)) +(define select-highlight-d (mk-2-constant-style "yellow" "darkgoldenrod")) +(define select-sub-highlight-d select-highlight-d) ;; can get rid of this definition(?). -(define unhighlight-d (highlight-style-delta "white" #f)) +(define unhighlight-d (mk-2-constant-style "black" "white")) diff --git a/collects/macro-debugger/syntax-browser/image.rkt b/collects/macro-debugger/syntax-browser/image.rkt index d8151c5..7e5774a 100644 --- a/collects/macro-debugger/syntax-browser/image.rkt +++ b/collects/macro-debugger/syntax-browser/image.rkt @@ -36,7 +36,7 @@ TODO: tacked arrows ;; print-syntax-columns : (parameter-of (U number 'infinity)) (define print-syntax-columns (make-parameter 40)) -(define standard-text% (editor:standard-style-list-mixin text%)) +(define standard-text% (text:foreground-color-mixin (editor:standard-style-list-mixin text:basic%))) ;; print-syntax-to-png : syntax path -> void (define (print-syntax-to-png stx file @@ -54,7 +54,7 @@ TODO: tacked arrows (define dc (new bitmap-dc% (bitmap (make-object bitmap% 1 1)))) (define char-width (let* ([sl (send t get-style-list)] - [style (send sl find-named-style "Standard")] + [style (send sl find-named-style (editor:get-default-color-style-name))] [font (send style get-font)]) (send dc set-font font) (send dc get-char-width))) @@ -89,7 +89,7 @@ TODO: tacked arrows (define (prepare-editor stx columns) (define t (new standard-text%)) (define sl (send t get-style-list)) - (send t change-style (send sl find-named-style "Standard")) + (send t change-style (send sl find-named-style (editor:get-default-color-style-name))) (print-syntax-to-editor stx t (new controller%) (new syntax-prefs/readonly%) columns (send t last-position)) diff --git a/collects/macro-debugger/syntax-browser/widget.rkt b/collects/macro-debugger/syntax-browser/widget.rkt index 30af2e7..598d3b6 100644 --- a/collects/macro-debugger/syntax-browser/widget.rkt +++ b/collects/macro-debugger/syntax-browser/widget.rkt @@ -33,7 +33,7 @@ (new panel:horizontal-dragable% (parent -main-panel))) (define -text (new browser-text%)) (define -ecanvas - (new editor-canvas% (parent -split-panel) (editor -text))) + (new canvas:color% (parent -split-panel) (editor -text))) (define -props-panel (new horizontal-panel% (parent -split-panel))) (define props (new properties-view% @@ -251,13 +251,20 @@ ;; Specialized classes for widget (define browser-text% - (class (text:arrows-mixin - (text:tacking-mixin - (text:hover-drawings-mixin - (text:hover-mixin - (text:hide-caret/selection-mixin - (editor:standard-style-list-mixin text:basic%)))))) - (inherit set-autowrap-bitmap) - (define/override (default-style-name) "Basic") - (super-new (auto-wrap #t)) - (set-autowrap-bitmap #f))) + (let ([browser-text-default-style-name "widget.rkt::browser-text% basic"]) + (class (text:arrows-mixin + (text:tacking-mixin + (text:hover-drawings-mixin + (text:hover-mixin + (text:hide-caret/selection-mixin + (text:foreground-color-mixin + (editor:standard-style-list-mixin text:basic%))))))) + (inherit set-autowrap-bitmap get-style-list) + (define/override (default-style-name) browser-text-default-style-name) + (super-new (auto-wrap #t)) + (let* ([sl (get-style-list)] + [standard (send sl find-named-style (editor:get-default-color-style-name))] + [browser-basic (send sl find-or-create-style standard + (make-object style-delta% 'change-family 'default))]) + (send sl new-named-style browser-text-default-style-name browser-basic)) + (set-autowrap-bitmap #f)))) From f76c2a31468591aaae2f3b246f4fd57dc267988a Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Tue, 8 Jun 2010 13:18:15 -0600 Subject: [PATCH 02/15] macro-stepper: fixed colors for white-on-black display original commit: 1c9bb4a72ad72e8e247240edde0f27974eb831db --- .../macro-debugger/syntax-browser/display.rkt | 125 +++++++++++++++--- 1 file changed, 108 insertions(+), 17 deletions(-) diff --git a/collects/macro-debugger/syntax-browser/display.rkt b/collects/macro-debugger/syntax-browser/display.rkt index 653234d..f3b640e 100644 --- a/collects/macro-debugger/syntax-browser/display.rkt +++ b/collects/macro-debugger/syntax-browser/display.rkt @@ -158,8 +158,11 @@ (send delta set-delta-foreground color) (send style-list find-or-create-style base-style delta))) (define color-styles - (list->vector (map color-style (map translate-color (send: config config<%> get-colors))))) - (define overflow-style (color-style "darkgray")) + (list->vector + (map color-style + (map translate-color + (send: config config<%> get-colors))))) + (define overflow-style (color-style (translate-color "darkgray"))) (define color-partition (send: controller mark-manager<%> get-primary-partition)) (define offset start-position) @@ -215,7 +218,7 @@ ;; Styles subterms eq to the selected syntax (define/private (apply-selection-styles selected-syntax) (for ([r (send: range range<%> get-ranges selected-syntax)]) - (restyle-range r select-highlight-d))) + (restyle-range r (select-highlight-d)))) ;; draw-secondary-connection : syntax -> void (define/private (draw-secondary-connection stx2) @@ -273,16 +276,23 @@ (make-object string-snip% "")) (super-instantiate ()))) -;; Styles +;; Color translation -(define (highlight-style-delta raw-color em? #:translate-color? [translate-color? #t]) - (let* ([sd (new style-delta%)]) - (unless em? (send sd set-delta-background (if translate-color? (translate-color raw-color) raw-color))) - (when em? (send sd set-weight-on 'bold)) - (unless em? (send sd set-underlined-off #t) - (send sd set-weight-off 'bold)) - sd)) +;; translate-color : color-string -> color% +(define (translate-color color-string) + (let ([c (make-object color% color-string)]) + (if (preferences:get 'framework:white-on-black?) + (let-values ([(r* g* b*) + (lightness-invert (send c red) (send c green) (send c blue))]) + #| + (printf "translate: ~s -> ~s\n" + (list (send c red) (send c green) (send c blue)) + (list r* g* b*)) + |# + (make-object color% r* g* b*)) + c))) +#; (define (translate-color color) (let ([reversed-color (case (string->symbol (string-downcase color)) @@ -295,20 +305,101 @@ reversed-color color))) +;; lightness-invert : uint8 uint8 uint8 -> (values uint8 uint8 uint8) +(define (lightness-invert r g b) + (define (c x) + (/ (exact->inexact x) 255.0)) + (define (d x) + (inexact->exact (round (* x 255)))) + (let-values ([(r g b) (lightness-invert* (c r) (c g) (c b))]) + (values (d r) (d g) (d b)))) + +(define (lightness-invert* R G B) + (let-values ([(Hp Sl L) (rgb->hsl* R G B)]) + (hsl*->rgb Hp Sl (- 1.0 L)))) + +(define (rgb->hsl* R G B) + (define M (max R G B)) + (define m (min R G B)) + (define C (- M m)) + (define Hp + (cond [(zero? C) + ;; Undefined, but use 0 + 0.0] + [(= M R) + (realmod* (/ (- G B) C) 6)] + [(= M G) + (+ (/ (- B R) C) 2)] + [(= M B) + (+ (/ (- R G) C) 4)])) + (define L (* 0.5 (+ M m))) + (define Sl + (cond [(zero? C) 0.0] + [(>= L 0.5) (/ C (* 2 L))] + [else (/ C (- 2 (* 2 L)))])) + + (values Hp Sl L)) + +(define (hsl*->rgb Hp Sl L) + (define C + (cond [(>= L 0.5) (* 2 L Sl)] + [else (* (- 2 (* 2 L)) Sl)])) + (define X (* C (- 1 (abs (- (realmod Hp 2) 1))))) + (define-values (R1 G1 B1) + (cond [(< Hp 1) (values C X 0)] + [(< Hp 2) (values X C 0)] + [(< Hp 3) (values 0 C X)] + [(< Hp 4) (values 0 X C)] + [(< Hp 5) (values X 0 C)] + [(< Hp 6) (values C 0 X)])) + (define m (- L (* 0.5 C))) + (values (+ R1 m) (+ G1 m) (+ B1 m))) + +;; realmod : real integer -> real +;; Adjusts a real number to [0, base] +(define (realmod x base) + (define xint (ceiling x)) + (define m (modulo xint base)) + (realmod* (- m (- xint x)) base)) + +;; realmod* : real real -> real +;; Adjusts a number in [-base, base] to [0,base] +;; Not a real mod, but faintly reminiscent. +(define (realmod* x base) + (if (negative? x) + (+ x base) + x)) + +;; Styles + +(define (highlight-style-delta raw-color em? + #:translate-color? [translate-color? #t]) + (let* ([sd (new style-delta%)]) + (unless em? + (send sd set-delta-background + (if translate-color? (translate-color raw-color) raw-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 underline-style-delta (let ([sd (new style-delta%)]) (send sd set-underlined-on #t) sd)) -(define (mk-2-constant-style wob-color bow-color) - (let ([wob-version (highlight-style-delta wob-color #f #:translate-color? #f)] - [bow-version (highlight-style-delta bow-color #f #:translate-color? #f)]) +(define (mk-2-constant-style bow-color em? [wob-color (translate-color bow-color)]) + (let ([wob-version (highlight-style-delta wob-color em? #:translate-color? #f)] + [bow-version (highlight-style-delta bow-color em? #:translate-color? #f)]) (λ () (if (preferences:get 'framework:white-on-black?) wob-version bow-version)))) -(define select-highlight-d (mk-2-constant-style "yellow" "darkgoldenrod")) -(define select-sub-highlight-d select-highlight-d) ;; can get rid of this definition(?). +(define select-highlight-d + (mk-2-constant-style "yellow" #t "darkgoldenrod")) +(define select-sub-highlight-d + (mk-2-constant-style "yellow" #f "darkgoldenrod")) -(define unhighlight-d (mk-2-constant-style "black" "white")) +(define unhighlight-d (mk-2-constant-style "white" #f #|"black"|#)) From ed46c25db536207e3280db4cd3d159d8ac8aef4a Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Tue, 8 Jun 2010 14:11:44 -0600 Subject: [PATCH 03/15] macro-debugger: made properties display respect inverted-colors mode original commit: b6b8e299572c53f2b75646755f46badf92a5ffd6 --- .../macro-debugger/syntax-browser/display.rkt | 18 +++------------ .../macro-debugger/syntax-browser/prefs.rkt | 6 ++++- .../syntax-browser/properties.rkt | 22 +++++++++++++++++-- 3 files changed, 28 insertions(+), 18 deletions(-) diff --git a/collects/macro-debugger/syntax-browser/display.rkt b/collects/macro-debugger/syntax-browser/display.rkt index f3b640e..ba42808 100644 --- a/collects/macro-debugger/syntax-browser/display.rkt +++ b/collects/macro-debugger/syntax-browser/display.rkt @@ -9,6 +9,7 @@ (only-in mzlib/etc begin-with-definitions) "pretty-printer.ss" "interfaces.ss" + "prefs.ss" "util.ss") (provide print-syntax-to-editor code-style) @@ -281,7 +282,7 @@ ;; translate-color : color-string -> color% (define (translate-color color-string) (let ([c (make-object color% color-string)]) - (if (preferences:get 'framework:white-on-black?) + (if (pref:invert-colors?) (let-values ([(r* g* b*) (lightness-invert (send c red) (send c green) (send c blue))]) #| @@ -292,19 +293,6 @@ (make-object color% r* g* b*)) c))) -#; -(define (translate-color color) - (let ([reversed-color - (case (string->symbol (string-downcase color)) - [(white) "black"] - [(black) "white"] - [(yellow) "goldenrod"] - [else (printf "unknown color ~s\n" color) - color])]) - (if (preferences:get 'framework:white-on-black?) - reversed-color - color))) - ;; lightness-invert : uint8 uint8 uint8 -> (values uint8 uint8 uint8) (define (lightness-invert r g b) (define (c x) @@ -393,7 +381,7 @@ (let ([wob-version (highlight-style-delta wob-color em? #:translate-color? #f)] [bow-version (highlight-style-delta bow-color em? #:translate-color? #f)]) (λ () - (if (preferences:get 'framework:white-on-black?) + (if (pref:invert-colors?) wob-version bow-version)))) diff --git a/collects/macro-debugger/syntax-browser/prefs.rkt b/collects/macro-debugger/syntax-browser/prefs.rkt index 8df1e63..63e245b 100644 --- a/collects/macro-debugger/syntax-browser/prefs.rkt +++ b/collects/macro-debugger/syntax-browser/prefs.rkt @@ -7,7 +7,9 @@ (provide prefs-base% syntax-prefs-base% syntax-prefs% - syntax-prefs/readonly%) + syntax-prefs/readonly% + + pref:invert-colors?) (preferences:set-default 'SyntaxBrowser:Width 700 number?) (preferences:set-default 'SyntaxBrowser:Height 600 number?) @@ -19,6 +21,8 @@ (define pref:props-percentage (pref:get/set 'SyntaxBrowser:PropertiesPanelPercentage)) (define pref:props-shown? (pref:get/set 'SyntaxBrowser:PropertiesPanelShown)) +(define pref:invert-colors? (pref:get/set 'framework:white-on-black?)) + (define prefs-base% (class object% ;; suffix-option : SuffixOption diff --git a/collects/macro-debugger/syntax-browser/properties.rkt b/collects/macro-debugger/syntax-browser/properties.rkt index f6a1a9d..a0d30f1 100644 --- a/collects/macro-debugger/syntax-browser/properties.rkt +++ b/collects/macro-debugger/syntax-browser/properties.rkt @@ -1,6 +1,7 @@ #lang scheme/base (require scheme/class scheme/gui + framework (rename-in unstable/class-iop [send/i send:]) "interfaces.ss" @@ -9,6 +10,23 @@ (provide properties-view% properties-snip%) +(define color-text-default-style-name + "macro-debugger/syntax-browser/properties color-text% basic") + +(define color-text% + (class (editor:standard-style-list-mixin text:basic%) + (inherit get-style-list) + (define/override (default-style-name) + color-text-default-style-name) + (super-new) + (let* ([sl (get-style-list)] + [standard + (send sl find-named-style (editor:get-default-color-style-name))] + [basic + (send sl find-or-create-style standard + (make-object style-delta% 'change-family 'default))]) + (send sl new-named-style color-text-default-style-name basic)))) + ;; properties-view-base-mixin (define properties-view-base-mixin (mixin () () @@ -22,7 +40,7 @@ (define mode 'term) ;; text : text% - (field (text (new text%))) + (field (text (new color-text%))) (field (pdisplayer (new properties-displayer% (text text)))) (send: controller selection-manager<%> listen-selected-syntax @@ -122,7 +140,7 @@ (callback (lambda (tp e) (set-mode (cdr (list-ref tab-choices (send tp get-selection)))))))) - (define ecanvas (new editor-canvas% (editor text) (parent tab-panel))))) + (define ecanvas (new canvas:color% (editor text) (parent tab-panel))))) ;; properties-displayer% (define properties-displayer% From 50d21a212d307cee2588bdb0dab4e4c0f894bc9c Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Wed, 9 Jun 2010 14:04:17 -0600 Subject: [PATCH 04/15] macro-stepper: preserve underlining in highlights original commit: eb1a1228881f33b36e045e7c46a704198d3252d9 --- collects/macro-debugger/syntax-browser/display.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/macro-debugger/syntax-browser/display.rkt b/collects/macro-debugger/syntax-browser/display.rkt index ba42808..2ca32ef 100644 --- a/collects/macro-debugger/syntax-browser/display.rkt +++ b/collects/macro-debugger/syntax-browser/display.rkt @@ -368,7 +368,7 @@ (if translate-color? (translate-color raw-color) raw-color))) (when em? (send sd set-weight-on 'bold)) (unless em? - (send sd set-underlined-off #t) + ;; (send sd set-underlined-off #t) (send sd set-weight-off 'bold)) sd)) From cedc2417f42f18e10b26461397f22b7b6f655e6f Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Wed, 9 Jun 2010 16:04:28 -0600 Subject: [PATCH 05/15] macro-stepper: added api for macro "remarks" (no docs yet) original commit: 2068acc22b65415072d753828d182e970b7def0b --- collects/macro-debugger/emit.rkt | 22 +++++++++++++++++++ collects/macro-debugger/model/deriv-c.rkt | 2 ++ .../macro-debugger/model/deriv-parser.rkt | 2 ++ .../macro-debugger/model/deriv-tokens.rkt | 3 +++ .../model/reductions-config.rkt | 8 +++++++ collects/macro-debugger/model/reductions.rkt | 14 ++++++++++-- collects/macro-debugger/model/steps.rkt | 6 ++++- collects/macro-debugger/view/step-display.rkt | 18 +++++++++++++++ 8 files changed, 72 insertions(+), 3 deletions(-) create mode 100644 collects/macro-debugger/emit.rkt diff --git a/collects/macro-debugger/emit.rkt b/collects/macro-debugger/emit.rkt new file mode 100644 index 0000000..6b24190 --- /dev/null +++ b/collects/macro-debugger/emit.rkt @@ -0,0 +1,22 @@ +#lang racket/base +(require racket/contract/base) + +(provide/contract + [emit-remark + (->* () (#:unmark? any/c) #:rest (listof (or/c string? syntax?)) + any)]) + +(define current-expand-observe + (dynamic-require ''#%expobs 'current-expand-observe)) + +(define (emit-remark #:unmark? [unmark? #t] . args) + (let ([observe (current-expand-observe)]) + (when observe + (let ([args + (if unmark? + (for/list ([arg (in-list args)]) + (if (syntax? arg) + (syntax-local-introduce arg) + arg)) + args)]) + (observe 'local-remark args))))) diff --git a/collects/macro-debugger/model/deriv-c.rkt b/collects/macro-debugger/model/deriv-c.rkt index 09966bf..9221dfc 100644 --- a/collects/macro-debugger/model/deriv-c.rkt +++ b/collects/macro-debugger/model/deriv-c.rkt @@ -40,6 +40,8 @@ (define-struct local-lift-require (req expr mexpr) #:transparent) (define-struct local-lift-provide (prov) #:transparent) (define-struct local-bind (names ?1 renames bindrhs) #:transparent) +(define-struct local-remark (contents) #:transparent) + ;; contents : (listof (U string syntax)) ;; A PrimDeriv is one of (define-struct (prule base) () #:transparent) diff --git a/collects/macro-debugger/model/deriv-parser.rkt b/collects/macro-debugger/model/deriv-parser.rkt index 9124ea6..3c3c153 100644 --- a/collects/macro-debugger/model/deriv-parser.rkt +++ b/collects/macro-debugger/model/deriv-parser.rkt @@ -202,6 +202,8 @@ (make local-bind $1 $2 $3 #f)] [(local-bind rename-list (? BindSyntaxes)) (make local-bind $1 #f $2 $3)] + [(local-remark) + (make local-remark $1)] ;; -- Not really local actions, but can occur during evaluation ;; called 'expand' (not 'local-expand') within transformer [(start (? EE)) #f] diff --git a/collects/macro-debugger/model/deriv-tokens.rkt b/collects/macro-debugger/model/deriv-tokens.rkt index 9dc8b0d..9f7d48a 100644 --- a/collects/macro-debugger/model/deriv-tokens.rkt +++ b/collects/macro-debugger/model/deriv-tokens.rkt @@ -59,6 +59,8 @@ top-begin ; identifier top-non-begin ; . + + local-remark ; (listof (U string syntax)) )) (define-tokens renames-tokens @@ -93,6 +95,7 @@ (#f start ,token-start) (#f top-begin ,token-top-begin) (#f top-non-begin ,token-top-non-begin) + (#f local-remark ,token-local-remark) ;; Standard signals (0 visit ,token-visit) diff --git a/collects/macro-debugger/model/reductions-config.rkt b/collects/macro-debugger/model/reductions-config.rkt index 35b6d1c..160255c 100644 --- a/collects/macro-debugger/model/reductions-config.rkt +++ b/collects/macro-debugger/model/reductions-config.rkt @@ -60,6 +60,9 @@ [#:foci1 syntaxish? #:foci2 syntaxish?] . ->* . step?)] [stumble ([syntaxish? exn?] [#:focus syntaxish?] . ->* . misstep?)] + [walk/talk + (-> (or/c symbol? string?) (listof (or/c syntax? string? 'arrow)) + remarkstep?)] [current-pass-hides? (parameterlike/c boolean?)] @@ -343,6 +346,11 @@ (current-state-with stx focus) exn)) +(define (walk/talk type contents) + (make remarkstep type + (current-state-with #f null) + contents)) + (define (foci x) (cond [(syntax? x) (list x)] diff --git a/collects/macro-debugger/model/reductions.rkt b/collects/macro-debugger/model/reductions.rkt index 574a211..82943aa 100644 --- a/collects/macro-debugger/model/reductions.rkt +++ b/collects/macro-debugger/model/reductions.rkt @@ -419,7 +419,15 @@ ;; FIXME: add action (R [#:do (take-lift!)] [#:binders ids] - [#:reductions (list (walk expr ids 'local-lift))])] + [#:reductions + (list + (walk/talk 'local-lift + (list "The macro lifted an expression" + "" + "Expression:" + expr + "Identifiers:" + (datum->syntax #f ids))))])] [(struct local-lift-end (decl)) ;; (walk/mono decl 'module-lift) @@ -436,7 +444,9 @@ [R [! ?1] ;; FIXME: use renames [#:binders names] - [#:when bindrhs => (BindSyntaxes bindrhs)]]])) + [#:when bindrhs => (BindSyntaxes bindrhs)]]] + [(struct local-remark (contents)) + (R [#:reductions (list (walk/talk 'remark contents))])])) ;; List : ListDerivation -> RST (define (List ld) diff --git a/collects/macro-debugger/model/steps.rkt b/collects/macro-debugger/model/steps.rkt index b75d7b4..4412186 100644 --- a/collects/macro-debugger/model/steps.rkt +++ b/collects/macro-debugger/model/steps.rkt @@ -1,10 +1,10 @@ - #lang scheme/base (require "deriv.ss" "deriv-util.ss") (provide (struct-out protostep) (struct-out step) (struct-out misstep) + (struct-out remarkstep) (struct-out state) (struct-out bigframe) context-fill @@ -22,9 +22,11 @@ ;; A Step is one of ;; - (make-step StepType State State) ;; - (make-misstep StepType State exn) +;; - (make-remarkstep StepType State (listof (U string syntax 'arrow))) (define-struct protostep (type s1) #:transparent) (define-struct (step protostep) (s2) #:transparent) (define-struct (misstep protostep) (exn) #:transparent) +(define-struct (remarkstep protostep) (contents) #:transparent) ;; A State is ;; (make-state stx stxs Context BigContext (listof id) (listof id) (listof stx) nat/#f) @@ -89,6 +91,8 @@ (splice-lifts . "Splice definitions from lifted expressions") (splice-module-lifts . "Splice lifted module declarations") + (remark . "Macro made a remark") + (error . "Error"))) (define (step-type->string x) diff --git a/collects/macro-debugger/view/step-display.rkt b/collects/macro-debugger/view/step-display.rkt index 075c0d1..f33eb92 100644 --- a/collects/macro-debugger/view/step-display.rkt +++ b/collects/macro-debugger/view/step-display.rkt @@ -87,6 +87,8 @@ (show-step step shift-table)] [(misstep? step) (show-misstep step shift-table)] + [(remarkstep? step) + (show-remarkstep step shift-table)] [(prestep? step) (show-prestep step shift-table)] [(poststep? step) @@ -229,6 +231,22 @@ #:shift-table shift-table))) (show-lctx step shift-table)) + (define/private (show-remarkstep step shift-table) + (define state (protostep-s1 step)) + (for ([content (in-list (remarkstep-contents step))]) + (cond [(string? content) + (send*: sbview sb:syntax-browser<%> + (add-text content) + (add-text "\n"))] + [(syntax? content) + (send*: sbview sb:syntax-browser<%> + (add-syntax content + #:binders (or (state-binders state) null) + #:definites (or (state-uses state) null) + #:shift-table shift-table) + (add-text "\n"))])) + (show-lctx step shift-table)) + ;; insert-syntax/color (define/private (insert-syntax/color stx foci binders shift-table definites frontier hi-color) From 54d3e93501ce85fda50b801767ea402e9f287d17 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Thu, 10 Jun 2010 14:58:28 -0600 Subject: [PATCH 06/15] macro-stepper: added docs for macro-debugger/emit original commit: 70fedd766f94bc6c7773c1864e2f6f8462d71d69 --- collects/macro-debugger/macro-debugger.scrbl | 42 ++++++++++++++++++++ 1 file changed, 42 insertions(+) diff --git a/collects/macro-debugger/macro-debugger.scrbl b/collects/macro-debugger/macro-debugger.scrbl index f80a66f..6fbfe33 100644 --- a/collects/macro-debugger/macro-debugger.scrbl +++ b/collects/macro-debugger/macro-debugger.scrbl @@ -4,6 +4,7 @@ scribble/eval (for-label scheme/base macro-debugger/expand + macro-debugger/emit macro-debugger/stepper macro-debugger/stepper-text macro-debugger/syntax-browser @@ -101,6 +102,47 @@ thing as the original syntax. (lambda (id) (memq (syntax-e id) '(or #%app)))))) } + +@section{Macro stepper API for macros} + +@defmodule[macro-debugger/emit] + +Macros can explicitly send information to a listening macro stepper by +using the procedures in this module. + +@defproc[(emit-remark [fragment (or/c syntax? string?)] ... + [#:unmark? unmark? boolean? #t]) + void?]{ + +Emits an event to the macro stepper (if one is listening) containing +the given strings and syntax objects. The macro stepper displays a +remark by printing the strings and syntax objects above a rendering of +the macro's context. The remark is only displayed if the macro that +emits it is considered transparent by the hiding policy. + +By default, syntax objects in remarks have the transformer's mark +applied (using @scheme[syntax-local-introduce]) so that their +appearance in the macro stepper matches their appearance after the +transformer returns. Unmarking is suppressed if @scheme[unmark?] is +@scheme[#f]. + +@schemeblock[ +(define-syntax (mymac stx) + (syntax-case stx () + [(_ x y) + (emit-remark "I got some arguments!" + #'x + "and" + #'y) + #'(list 'x 'y)])) +(mymac 37 (+ 1 2)) +] + +(Run the fragment above in the macro stepper.) + +} + + @section{Macro stepper text interface} @defmodule[macro-debugger/stepper-text] From f4d14edaac382e1784b252eb3dbbd6a2cbc75e7f Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Thu, 10 Jun 2010 16:40:52 -0600 Subject: [PATCH 07/15] macro-stepper: added emit-local-step original commit: 3d21f97f3f7fe71663a6224ee28bb47ecae44ff1 --- collects/macro-debugger/emit.rkt | 12 +++++++++++- collects/macro-debugger/macro-debugger.scrbl | 11 +++++++++++ collects/macro-debugger/model/deriv-parser.rkt | 12 ++++++++++++ collects/macro-debugger/model/deriv-tokens.rkt | 2 ++ 4 files changed, 36 insertions(+), 1 deletion(-) diff --git a/collects/macro-debugger/emit.rkt b/collects/macro-debugger/emit.rkt index 6b24190..e5ea883 100644 --- a/collects/macro-debugger/emit.rkt +++ b/collects/macro-debugger/emit.rkt @@ -4,7 +4,9 @@ (provide/contract [emit-remark (->* () (#:unmark? any/c) #:rest (listof (or/c string? syntax?)) - any)]) + any)] + [emit-local-step + (-> syntax? syntax? #:id identifier? any)]) (define current-expand-observe (dynamic-require ''#%expobs 'current-expand-observe)) @@ -20,3 +22,11 @@ arg)) args)]) (observe 'local-remark args))))) + +(define (emit-local-step before after #:id id) + (let ([observe (current-expand-observe)]) + (when observe + (observe 'local-artificial-step + (list (list id) + before (syntax-local-introduce before) + (syntax-local-introduce after) after))))) diff --git a/collects/macro-debugger/macro-debugger.scrbl b/collects/macro-debugger/macro-debugger.scrbl index 6fbfe33..051ce25 100644 --- a/collects/macro-debugger/macro-debugger.scrbl +++ b/collects/macro-debugger/macro-debugger.scrbl @@ -142,6 +142,17 @@ transformer returns. Unmarking is suppressed if @scheme[unmark?] is } +@defproc[(emit-local-step [before syntax?] [after syntax?] + [#:id id identifier?]) + void?]{ + +Emits an event that simulates a local expansion step from +@scheme[before] to @scheme[after]. + +The @scheme[id] argument acts as the step's ``macro'' for the purposes +of macro hiding. + +} @section{Macro stepper text interface} diff --git a/collects/macro-debugger/model/deriv-parser.rkt b/collects/macro-debugger/model/deriv-parser.rkt index 3c3c153..f4f8ca0 100644 --- a/collects/macro-debugger/model/deriv-parser.rkt +++ b/collects/macro-debugger/model/deriv-parser.rkt @@ -204,6 +204,18 @@ (make local-bind $1 #f $2 $3)] [(local-remark) (make local-remark $1)] + [(local-artificial-step) + (let ([ids (list-ref $1 0)] + [before (list-ref $1 1)] + [mbefore (list-ref $1 2)] + [mafter (list-ref $1 3)] + [after (list-ref $1 4)]) + (make local-expansion + before after #f mbefore + (make mrule mbefore mafter ids #f + before null after #f mafter + (make p:stop mafter mafter null #f)) + #f after #f))] ;; -- Not really local actions, but can occur during evaluation ;; called 'expand' (not 'local-expand') within transformer [(start (? EE)) #f] diff --git a/collects/macro-debugger/model/deriv-tokens.rkt b/collects/macro-debugger/model/deriv-tokens.rkt index 9f7d48a..6448e7a 100644 --- a/collects/macro-debugger/model/deriv-tokens.rkt +++ b/collects/macro-debugger/model/deriv-tokens.rkt @@ -61,6 +61,7 @@ top-non-begin ; . local-remark ; (listof (U string syntax)) + local-artificial-step ; (list syntax syntax syntax syntax) )) (define-tokens renames-tokens @@ -96,6 +97,7 @@ (#f top-begin ,token-top-begin) (#f top-non-begin ,token-top-non-begin) (#f local-remark ,token-local-remark) + (#f local-artificial-step ,token-local-artificial-step) ;; Standard signals (0 visit ,token-visit) From fc8ab37c3f8a2de12855bd9f184a66cef9725c4d Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Mon, 14 Jun 2010 18:38:21 -0600 Subject: [PATCH 08/15] macro-stepper: fetch mark lists directly original commit: 472b5ecdc0d6048750ec3ff12bec3af51a1a43a4 --- .../syntax-browser/partition.rkt | 39 +++++++++++-------- .../syntax-browser/properties.rkt | 14 +++++-- collects/macro-debugger/util/stxobj.rkt | 30 ++++++++++++++ 3 files changed, 63 insertions(+), 20 deletions(-) create mode 100644 collects/macro-debugger/util/stxobj.rkt diff --git a/collects/macro-debugger/syntax-browser/partition.rkt b/collects/macro-debugger/syntax-browser/partition.rkt index 54cb429..9a44a2f 100644 --- a/collects/macro-debugger/syntax-browser/partition.rkt +++ b/collects/macro-debugger/syntax-browser/partition.rkt @@ -1,9 +1,9 @@ - #lang scheme/base (require scheme/class syntax/boundmap syntax/stx - "interfaces.ss") + "interfaces.rkt" + "../util/stxobj.rkt") (provide new-bound-partition partition% identifier=-choices) @@ -79,27 +79,32 @@ ;; bound-partition% (define bound-partition% (class* object% (partition<%>) - ;; numbers : bound-identifier-mapping[identifier => number] - (define numbers (make-bound-identifier-mapping)) + + ;; simplified : hash[(listof nat) => nat] + (define simplified (make-hash)) + + ;; unsimplified : hash[(listof nat) => nat] + (define unsimplified (make-hash)) + + ;; next-number : nat (define next-number 0) - + (define/public (get-partition stx) - (let* ([r (representative stx)] - [n (bound-identifier-mapping-get numbers r (lambda _ #f))]) - (or n - (begin0 next-number - (bound-identifier-mapping-put! numbers r next-number) - #;(printf "primary partition new stx:~n~s~n~s~n" stx (syntax->datum stx)) - (set! next-number (add1 next-number)))))) - + (let ([umarks (get-marks stx)]) + (or (hash-ref unsimplified umarks #f) + (let ([smarks (simplify-marks umarks)]) + (or (hash-ref simplified smarks #f) + (let ([n next-number]) + (hash-set! simplified smarks n) + (hash-set! unsimplified umarks n) + (set! next-number (add1 n)) + n)))))) + (define/public (same-partition? a b) (= (get-partition a) (get-partition b))) - + (define/public (count) next-number) - - (define/private (representative stx) - (datum->syntax stx representative-symbol)) (get-partition unmarked-syntax) (super-new))) diff --git a/collects/macro-debugger/syntax-browser/properties.rkt b/collects/macro-debugger/syntax-browser/properties.rkt index a0d30f1..e46a0e9 100644 --- a/collects/macro-debugger/syntax-browser/properties.rkt +++ b/collects/macro-debugger/syntax-browser/properties.rkt @@ -6,7 +6,8 @@ [send/i send:]) "interfaces.ss" "util.ss" - "../util/mpi.ss") + "../util/mpi.ss" + "../util/stxobj.rkt") (provide properties-view% properties-snip%) @@ -206,7 +207,8 @@ (define/public (display-stxobj-info stx) (display-source-info stx) (display-extra-source-info stx) - (display-symbol-property-info stx)) + (display-symbol-property-info stx) + (display-marks stx)) ;; display-source-info : syntax -> void (define/private (display-source-info stx) @@ -244,7 +246,13 @@ (display "No additional properties available.\n" n/a-sd)) (when (pair? keys) (for-each (lambda (k) (display-subkv/value k (syntax-property stx k))) - keys)))) + keys)) + (display "\n" #f))) + + ;; display-marks : syntax -> void + (define/private (display-marks stx) + (display "Marks: " key-sd) + (display (format "~s\n" (simplify-marks (get-marks stx))) #f)) ;; display-kv : any any -> void (define/private (display-kv key value) diff --git a/collects/macro-debugger/util/stxobj.rkt b/collects/macro-debugger/util/stxobj.rkt new file mode 100644 index 0000000..dcbd429 --- /dev/null +++ b/collects/macro-debugger/util/stxobj.rkt @@ -0,0 +1,30 @@ +#lang racket +(require (rename-in racket/contract [-> c:->]) + ffi/unsafe) + +(define lib (ffi-lib #f)) + +(define get-marks + (get-ffi-obj "scheme_stx_extract_marks" lib + (_fun _scheme -> _scheme))) + +(define (simplify-marks marklist) + (simplify* (sort marklist <))) + +(define (simplify* marklist) + (cond [(null? marklist) marklist] + [(null? (cdr marklist)) marklist] + [(= (car marklist) (cadr marklist)) + (simplify* (cddr marklist))] + [else + (let ([result (simplify* (cdr marklist))]) + (if (eq? result (cdr marklist)) + marklist + (cons (car marklist) result)))])) + +(provide/contract + [get-marks + ;; syntax? check needed for safety! + (c:-> syntax? any)]) + +(provide simplify-marks) From ddc9d3e953d4643148e2223e9acd03f6be129f58 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Wed, 16 Jun 2010 16:37:25 -0600 Subject: [PATCH 09/15] macro-stepper: simplified partition code original commit: e9a8e92585e029410245f30c218ce8cbebe15fb3 --- .../syntax-browser/partition.rkt | 18 ++++++------------ 1 file changed, 6 insertions(+), 12 deletions(-) diff --git a/collects/macro-debugger/syntax-browser/partition.rkt b/collects/macro-debugger/syntax-browser/partition.rkt index 9a44a2f..f9600c0 100644 --- a/collects/macro-debugger/syntax-browser/partition.rkt +++ b/collects/macro-debugger/syntax-browser/partition.rkt @@ -83,22 +83,16 @@ ;; simplified : hash[(listof nat) => nat] (define simplified (make-hash)) - ;; unsimplified : hash[(listof nat) => nat] - (define unsimplified (make-hash)) - ;; next-number : nat (define next-number 0) (define/public (get-partition stx) - (let ([umarks (get-marks stx)]) - (or (hash-ref unsimplified umarks #f) - (let ([smarks (simplify-marks umarks)]) - (or (hash-ref simplified smarks #f) - (let ([n next-number]) - (hash-set! simplified smarks n) - (hash-set! unsimplified umarks n) - (set! next-number (add1 n)) - n)))))) + (let ([marks (simplify-marks (get-marks stx))]) + (or (hash-ref simplified marks #f) + (let ([n next-number]) + (hash-set! simplified marks n) + (set! next-number (add1 n)) + n)))) (define/public (same-partition? a b) (= (get-partition a) (get-partition b))) From 3bcff8e3d13958b16687afdd8bf1e3f012e1870c Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Thu, 24 Jun 2010 17:33:14 -0600 Subject: [PATCH 10/15] macro-stepper: clarified "from" in hiding rules, added todo list original commit: a91e9e7bf630a9a6ee35adaf61f58f56d268b200 --- collects/macro-debugger/util/mpi.rkt | 17 ++++++++++++----- collects/macro-debugger/view/hiding-panel.rkt | 15 +++++++++++++-- 2 files changed, 25 insertions(+), 7 deletions(-) diff --git a/collects/macro-debugger/util/mpi.rkt b/collects/macro-debugger/util/mpi.rkt index 6f627aa..c4f832c 100644 --- a/collects/macro-debugger/util/mpi.rkt +++ b/collects/macro-debugger/util/mpi.rkt @@ -1,9 +1,12 @@ #lang scheme/base -(require scheme/match) +(require scheme/match + scheme/string) (provide mpi->list - mpi->string) + mpi->string + self-mpi?) +;; mpi->list : module-path-index -> list (define (mpi->list mpi) (cond [(module-path-index? mpi) (let-values ([(path relto) (module-path-index-split mpi)]) @@ -18,12 +21,16 @@ (if (module-path-index? mpi) (let ([mps (mpi->list mpi)]) (cond [(pair? mps) - (apply string-append - (format "~s" (car mps)) - (map (lambda (x) (format " <= ~s" x)) (cdr mps)))] + (string-join (map (lambda (x) (format "~s" x)) mps) + " <= ")] [(null? mps) "this module"])) (format "~s" mpi))) +;; self-mpi? : module-path-index -> bool +(define (self-mpi? mpi) + (let-values ([(path relto) (module-path-index-split mpi)]) + (eq? path #f))) + ;; -- (provide mpi->mpi-sexpr diff --git a/collects/macro-debugger/view/hiding-panel.rkt b/collects/macro-debugger/view/hiding-panel.rkt index 6522fcd..0b1d692 100644 --- a/collects/macro-debugger/view/hiding-panel.rkt +++ b/collects/macro-debugger/view/hiding-panel.rkt @@ -16,6 +16,15 @@ (define mode:standard "Standard") (define mode:custom "Custom ...") +#| + +TODO + + - allow entry of more policies + - visual feedback on rules applying to selected identifier + (need to switch from list to editor) + +|# ;; macro-hiding-prefs-widget% (define macro-hiding-prefs-widget% @@ -255,11 +264,13 @@ (match condition [`(free=? ,id) (let ([b (identifier-binding id)]) - (or #;(identifier->string id) + (or #| (identifier->string id) |# (cond [(list? b) (let ([mod (caddr b)] [name (cadddr b)]) - (format "'~s' from ~a" name (mpi->string mod)))] + (if (self-mpi? mod) + (format "'~a' defined in this module" name) + (format "'~s' imported from ~a" name (mpi->string mod))))] [else (symbol->string (syntax-e id))])))] [_ From 5a58b97f12cf953027019afb8ba62b76015b8b0f Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Wed, 30 Jun 2010 13:38:23 -0600 Subject: [PATCH 11/15] unstable: added comments original commit: 7473cf624ef07926ced6124f3d7b1b1473320989 --- collects/unstable/find.rkt | 1 - 1 file changed, 1 deletion(-) diff --git a/collects/unstable/find.rkt b/collects/unstable/find.rkt index 86fdbb2..0ca5a23 100644 --- a/collects/unstable/find.rkt +++ b/collects/unstable/find.rkt @@ -70,4 +70,3 @@ (if (procedure? default) (default) default))) -;; Eli: Note that this is documented "Like `find-first'". From 9cb5f4756d1c1072fbf5f633cc18e5658309de9a Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Wed, 30 Jun 2010 15:38:23 -0600 Subject: [PATCH 12/15] macro-stepper: added step count also removed some dead code (warnings) original commit: 5673d7b877a4ebbf2f0ec390c97bac92d678da41 --- collects/macro-debugger/view/cursor.rkt | 3 ++- collects/macro-debugger/view/interfaces.rkt | 1 + collects/macro-debugger/view/stepper.rkt | 23 +++++++++++++++----- collects/macro-debugger/view/term-record.rkt | 6 ++++- 4 files changed, 25 insertions(+), 8 deletions(-) diff --git a/collects/macro-debugger/view/cursor.rkt b/collects/macro-debugger/view/cursor.rkt index a83a8ab..981d4d5 100644 --- a/collects/macro-debugger/view/cursor.rkt +++ b/collects/macro-debugger/view/cursor.rkt @@ -24,7 +24,8 @@ cursor->list cursor:prefix->list - cursor:suffix->list) + cursor:suffix->list + cursor-count) (define-struct cursor (vector count position) #:mutable) diff --git a/collects/macro-debugger/view/interfaces.rkt b/collects/macro-debugger/view/interfaces.rkt index 270e406..54f8088 100644 --- a/collects/macro-debugger/view/interfaces.rkt +++ b/collects/macro-debugger/view/interfaces.rkt @@ -62,6 +62,7 @@ (get-raw-deriv get-deriv-hidden? get-step-index + get-step-count invalidate-synth! invalidate-steps! diff --git a/collects/macro-debugger/view/stepper.rkt b/collects/macro-debugger/view/stepper.rkt index f4f2e5f..ec1edfb 100644 --- a/collects/macro-debugger/view/stepper.rkt +++ b/collects/macro-debugger/view/stepper.rkt @@ -14,7 +14,6 @@ "interfaces.ss" "prefs.ss" "extensions.ss" - "warning.ss" "hiding-panel.ss" "term-record.ss" "step-display.ss" @@ -103,7 +102,6 @@ (define/public (get-controller) sbc) (define/public (get-view) sbview) (define/public (get-step-displayer) step-displayer) - (define/public (get-warnings-area) warnings-area) (define/public (get-macro-hiding-prefs) macro-hiding-prefs) (define/public (reset-primary-partition) @@ -129,9 +127,7 @@ (stretchable-height #f) (alignment '(left center)) (style '(deleted)))) - - (define warnings-area (new stepper-warnings% (parent area))) - + (define: sbview sb:syntax-browser<%> (new stepper-syntax-widget% (parent area) @@ -206,7 +202,16 @@ (navigate-to (sub1 step))] [(equal? value "end") (navigate-to-end)]))))))) + + (define nav:step-count + (new message% + (label "") + (parent extra-navigator) + (auto-resize #t) + (stretchable-width #f) + (stretchable-height #f))) (send nav:text set-value "") + (listen-current-step-index (lambda (n) (send nav:text set-value @@ -388,9 +393,15 @@ ;; refresh : -> void (define/public (refresh) - (send warnings-area clear) (when (focused-term) (send: (focused-term) term-record<%> on-get-focus)) + (send nav:step-count set-label "") + (let ([term (focused-term)]) + (when term + (let ([step-count (send: term term-record<%> get-step-count)]) + (when step-count + ;; +1 for end of expansion "step" + (send nav:step-count set-label (format "of ~s" (add1 step-count))))))) (update)) (define/private (foci x) (if (list? x) x (list x))) diff --git a/collects/macro-debugger/view/term-record.rkt b/collects/macro-debugger/view/term-record.rkt index 1839dfd..de47697 100644 --- a/collects/macro-debugger/view/term-record.rkt +++ b/collects/macro-debugger/view/term-record.rkt @@ -207,7 +207,11 @@ (and (get-steps) (not (cursor:at-end? (get-steps))))) (define/public-final (get-step-index) - (and (get-steps) (cursor-position (get-steps)))) + (let ([steps (get-steps)]) + (and steps (cursor-position steps)))) + (define/public-final (get-step-count) + (let ([steps (get-steps)]) + (and steps (cursor-count steps)))) (define/public-final (navigate-to-start) (cursor:move-to-start (get-steps)) From 79f7ee30487c20d9dec215360cb5fb20e6de6281 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Wed, 30 Jun 2010 16:31:48 -0600 Subject: [PATCH 13/15] macro-stepper: replaced {scheme -> racket}, {*.ss -> *.rkt}, etc original commit: efc03566055f549de2a9bf32a402185f66c14a64 --- collects/macro-debugger/expand.rkt | 10 +- collects/macro-debugger/info.rkt | 2 +- collects/macro-debugger/model/context.rkt | 3 +- collects/macro-debugger/model/debug.rkt | 35 +- collects/macro-debugger/model/deriv-c.rkt | 3 +- .../macro-debugger/model/deriv-parser.rkt | 15 +- .../macro-debugger/model/deriv-tokens.rkt | 5 +- collects/macro-debugger/model/deriv-util.rkt | 11 +- collects/macro-debugger/model/deriv.rkt | 371 +----------------- .../macro-debugger/model/hiding-policies.rkt | 12 +- .../model/reductions-config.rkt | 21 +- .../model/reductions-engine.rkt | 26 +- collects/macro-debugger/model/reductions.rkt | 13 +- collects/macro-debugger/model/steps.rkt | 6 +- collects/macro-debugger/model/stx-util.rkt | 5 +- collects/macro-debugger/model/trace-raw.rkt | 11 +- collects/macro-debugger/model/trace.rkt | 11 +- collects/macro-debugger/model/yacc-ext.rkt | 7 +- .../macro-debugger/model/yacc-interrupted.rkt | 8 +- collects/macro-debugger/stepper-text.rkt | 19 +- collects/macro-debugger/stepper.rkt | 5 +- collects/macro-debugger/syntax-browser.rkt | 5 +- .../syntax-browser/controller.rkt | 18 +- .../macro-debugger/syntax-browser/display.rkt | 70 ++-- .../macro-debugger/syntax-browser/embed.rkt | 17 +- .../macro-debugger/syntax-browser/frame.rkt | 46 +-- .../syntax-browser/hrule-snip.rkt | 10 +- .../macro-debugger/syntax-browser/image.rkt | 14 +- .../syntax-browser/interfaces.rkt | 8 +- .../macro-debugger/syntax-browser/keymap.rkt | 12 +- .../syntax-browser/partition.rkt | 5 +- .../macro-debugger/syntax-browser/prefs.rkt | 8 +- .../syntax-browser/pretty-helper.rkt | 21 +- .../syntax-browser/pretty-printer.rkt | 14 +- .../syntax-browser/properties.rkt | 23 +- .../syntax-browser/snip-decorated.rkt | 29 +- .../macro-debugger/syntax-browser/snip.rkt | 26 +- .../macro-debugger/syntax-browser/text.rkt | 10 +- .../macro-debugger/syntax-browser/util.rkt | 5 +- .../macro-debugger/syntax-browser/widget.rkt | 71 ++-- collects/macro-debugger/util/mpi.rkt | 10 +- collects/macro-debugger/util/stxobj.rkt | 2 +- collects/macro-debugger/view/cursor.rkt | 4 +- collects/macro-debugger/view/debug-format.rkt | 5 +- collects/macro-debugger/view/debug.rkt | 19 +- collects/macro-debugger/view/extensions.rkt | 59 ++- collects/macro-debugger/view/frame.rkt | 82 ++-- collects/macro-debugger/view/hiding-panel.rkt | 37 +- collects/macro-debugger/view/interfaces.rkt | 4 +- collects/macro-debugger/view/prefs.rkt | 10 +- collects/macro-debugger/view/step-display.rkt | 133 +++---- collects/macro-debugger/view/stepper.rkt | 139 ++++--- collects/macro-debugger/view/term-record.rkt | 107 +++-- collects/macro-debugger/view/view.rkt | 33 +- 54 files changed, 611 insertions(+), 1044 deletions(-) diff --git a/collects/macro-debugger/expand.rkt b/collects/macro-debugger/expand.rkt index 48d4c22..b34cb03 100644 --- a/collects/macro-debugger/expand.rkt +++ b/collects/macro-debugger/expand.rkt @@ -1,8 +1,8 @@ -#lang scheme/base -(require scheme/contract - "model/trace.ss" - "model/reductions-config.ss" - "model/reductions.ss") +#lang racket/base +(require racket/contract + "model/trace.rkt" + "model/reductions-config.rkt" + "model/reductions.rkt") (provide/contract [expand-only diff --git a/collects/macro-debugger/info.rkt b/collects/macro-debugger/info.rkt index 55db6ff..0a5856f 100644 --- a/collects/macro-debugger/info.rkt +++ b/collects/macro-debugger/info.rkt @@ -1,5 +1,5 @@ #lang setup/infotab -(define tools '(["tool.ss"])) +(define tools '(["tool.rkt"])) (define tool-names '("Macro Stepper")) (define scribblings '(("macro-debugger.scrbl" () (tool-library)))) diff --git a/collects/macro-debugger/model/context.rkt b/collects/macro-debugger/model/context.rkt index c385aff..8d6073d 100644 --- a/collects/macro-debugger/model/context.rkt +++ b/collects/macro-debugger/model/context.rkt @@ -1,5 +1,4 @@ -#lang scheme/base - +#lang racket/base (require syntax/stx) (provide (struct-out ref) (struct-out tail) diff --git a/collects/macro-debugger/model/debug.rkt b/collects/macro-debugger/model/debug.rkt index 3ba4ad0..1bb8157 100644 --- a/collects/macro-debugger/model/debug.rkt +++ b/collects/macro-debugger/model/debug.rkt @@ -1,19 +1,18 @@ -#lang scheme/base +#lang racket/base +(require racket/match + "trace.rkt" + "reductions.rkt" + "reductions-config.rkt" + "deriv-util.rkt" + "hiding-policies.rkt" + "deriv.rkt" + "steps.rkt") -(require scheme/match - "trace.ss" - "reductions.ss" - "reductions-config.ss" - "deriv-util.ss" - "hiding-policies.ss" - "deriv.ss" - "steps.ss") - -(provide (all-from-out "trace.ss") - (all-from-out "reductions.ss") - (all-from-out "reductions-config.ss") - (all-from-out "deriv.ss") - (all-from-out "deriv-util.ss") - (all-from-out "hiding-policies.ss") - (all-from-out "steps.ss") - (all-from-out scheme/match)) +(provide (all-from-out "trace.rkt") + (all-from-out "reductions.rkt") + (all-from-out "reductions-config.rkt") + (all-from-out "deriv.rkt") + (all-from-out "deriv-util.rkt") + (all-from-out "hiding-policies.rkt") + (all-from-out "steps.rkt") + (all-from-out racket/match)) diff --git a/collects/macro-debugger/model/deriv-c.rkt b/collects/macro-debugger/model/deriv-c.rkt index 9221dfc..2ab5dc6 100644 --- a/collects/macro-debugger/model/deriv-c.rkt +++ b/collects/macro-debugger/model/deriv-c.rkt @@ -1,5 +1,4 @@ - -#lang scheme/base +#lang racket/base (provide (all-defined-out)) ;; A Node(a) is: diff --git a/collects/macro-debugger/model/deriv-parser.rkt b/collects/macro-debugger/model/deriv-parser.rkt index f4f8ca0..c24e0d2 100644 --- a/collects/macro-debugger/model/deriv-parser.rkt +++ b/collects/macro-debugger/model/deriv-parser.rkt @@ -1,12 +1,11 @@ - -#lang scheme/base -(require (for-syntax scheme/base) +#lang racket/base +(require (for-syntax racket/base) syntax/stx - "yacc-ext.ss" - "yacc-interrupted.ss" - "deriv.ss" - "deriv-util.ss" - "deriv-tokens.ss") + "yacc-ext.rkt" + "yacc-interrupted.rkt" + "deriv.rkt" + "deriv-util.rkt" + "deriv-tokens.rkt") (provide parse-derivation) (define (deriv-error ok? name value start end) diff --git a/collects/macro-debugger/model/deriv-tokens.rkt b/collects/macro-debugger/model/deriv-tokens.rkt index 6448e7a..d33e3c2 100644 --- a/collects/macro-debugger/model/deriv-tokens.rkt +++ b/collects/macro-debugger/model/deriv-tokens.rkt @@ -1,7 +1,6 @@ - -#lang scheme/base +#lang racket/base (require parser-tools/lex - "deriv.ss") + "deriv.rkt") (provide (all-defined-out)) (define-tokens basic-tokens diff --git a/collects/macro-debugger/model/deriv-util.rkt b/collects/macro-debugger/model/deriv-util.rkt index 0a3c2a3..8987afb 100644 --- a/collects/macro-debugger/model/deriv-util.rkt +++ b/collects/macro-debugger/model/deriv-util.rkt @@ -1,11 +1,10 @@ - -#lang scheme/base -(require (for-syntax scheme/base) +#lang racket/base +(require (for-syntax racket/base) (for-syntax racket/private/struct-info) - scheme/list - scheme/match + racket/list + racket/match unstable/struct - "deriv.ss") + "deriv.rkt") (provide make diff --git a/collects/macro-debugger/model/deriv.rkt b/collects/macro-debugger/model/deriv.rkt index a7be9bd..420d6ca 100644 --- a/collects/macro-debugger/model/deriv.rkt +++ b/collects/macro-debugger/model/deriv.rkt @@ -1,368 +1,5 @@ - -#lang scheme/base -(require scheme/contract +#lang racket/base +(require racket/contract syntax/stx - "deriv-c.ss") - -(provide (all-from-out "deriv-c.ss")) - -#| - -(define (?? c) (or/c c false/c)) - -(define (stx? x) - (or (syntax? x) - (and (pair? x) (stx? (car x)) (stx? (cdr x))) - (null? x))) - -(define (stx-list-like? x) - (let ([x (stx->list x)]) - (and x (andmap syntax? x)))) - -(define syntax/f (?? syntax?)) -(define syntaxes/c stx-list-like?) -(define syntaxes/f (?? syntaxes/c)) -(define resolves/c (listof identifier?)) - -(define localaction/c - (or/c local-expansion? local-expansion/expr? local-lift? - local-lift-end? local-bind?)) - -(provide/contract - (struct node - ([z1 any/c] - [z2 any/c])) - (struct (deriv node) - ([z1 syntax?] - [z2 syntax/f])) - (struct (lift-deriv deriv) - ([z1 syntax?] - [z2 syntax/f] - [first deriv?] - [lift-stx syntax?] - [second deriv?])) - (struct (mrule deriv) - ([z1 syntax?] - [z2 syntax/f] - [transformation transformation?] - [next (?? deriv?)])) - (struct (lift/let-deriv deriv) - ([z1 syntax?] - [z2 syntax/f] - [first deriv?] - [lift-stx syntax?] - [second deriv?])) - (struct (transformation node) - ([z1 syntax?] - [z2 syntax/f] - [resolves resolves/c] - [?1 (?? exn?)] - [me1 (?? syntax?)] - [locals (?? (listof localaction/c))] - [me2 (?? syntax?)] - [?2 (?? exn?)] - [seq number?])) - (struct (local-expansion node) - ([z1 syntax?] - [z2 syntax/f] - [me1 syntax?] - [me2 syntax/f] - [for-stx? boolean?] - [inner deriv?])) - (struct (local-expansion/expr node) - ([z1 syntax?] - [z2 syntax/f] - [me1 syntax?] - [me2 syntax/f] - [for-stx? boolean?] - [opaque any/c] - [inner deriv?])) - (struct local-lift - ([expr syntax?] - [id identifier?])) - (struct local-lift-end - ([decl syntax?])) - (struct local-bind - ([bindrhs bind-syntaxes?])) - (struct (base deriv) - ([z1 syntax?] - [z2 syntax/f] - [resolves resolves/c] - [?1 (?? exn?)])) - (struct (prule base) - ([z1 syntax?] - [z2 syntax/f] - [resolves resolves/c] - [?1 (?? exn?)])) - (struct (p:variable prule) - ([z1 syntax?] - [z2 syntax/f] - [resolves resolves/c] - [?1 (?? exn?)])) - (struct (p:module prule) - ([z1 syntax?] - [z2 syntax/f] - [resolves resolves/c] - [?1 (?? exn?)] - [one-body-form? boolean?] - [mb (?? deriv?)] - [?2 (?? exn?)] - [body (?? deriv?)])) - (struct (p:#%module-begin prule) - ([z1 syntax?] - [z2 syntax/f] - [resolves resolves/c] - [?1 (?? exn?)] - [pass1 (?? (listof modrule?))] - [pass2 (?? (listof modrule?))] - [?2 (?? exn?)])) - (struct (p:define-syntaxes prule) - ([z1 syntax?] - [z2 syntax/f] - [resolves resolves/c] - [?1 (?? exn?)] - [rhs (?? deriv?)] - [?2 (?? exn?)])) - (struct (p:define-values prule) - ([z1 syntax?] - [z2 syntax/f] - [resolves resolves/c] - [?1 (?? exn?)] - [rhs (?? deriv?)])) - (struct (p:#%expression prule) - ([z1 syntax?] - [z2 syntax/f] - [resolves resolves/c] - [?1 (?? exn?)] - [inner (?? deriv?)])) - (struct (p:if prule) - ([z1 syntax?] - [z2 syntax/f] - [resolves resolves/c] - [?1 (?? exn?)] - [full? boolean?] - [test (?? deriv?)] - [then (?? deriv?)] - [else (?? deriv?)])) - (struct (p:wcm prule) - ([z1 syntax?] - [z2 syntax/f] - [resolves resolves/c] - [?1 (?? exn?)] - [key (?? deriv?)] - [mark (?? deriv?)] - [body (?? deriv?)])) - (struct (p:set! prule) - ([z1 syntax?] - [z2 syntax/f] - [resolves resolves/c] - [?1 (?? exn?)] - [id-resolves (?? resolves/c)] - [rhs (?? deriv?)])) - (struct (p:set!-macro prule) - ([z1 syntax?] - [z2 syntax/f] - [resolves resolves/c] - [?1 (?? exn?)] - [deriv (?? deriv?)])) - (struct (p:#%app prule) - ([z1 syntax?] - [z2 syntax/f] - [resolves resolves/c] - [?1 (?? exn?)] - [tagged-stx syntax/f] - [lderiv (?? lderiv?)])) - (struct (p:begin prule) - ([z1 syntax?] - [z2 syntax/f] - [resolves resolves/c] - [?1 (?? exn?)] - [lderiv (?? lderiv?)])) - (struct (p:begin0 prule) - ([z1 syntax?] - [z2 syntax/f] - [resolves resolves/c] - [?1 (?? exn?)] - [first (?? deriv?)] - [lderiv (?? lderiv?)])) - (struct (p:lambda prule) - ([z1 syntax?] - [z2 syntax/f] - [resolves resolves/c] - [?1 (?? exn?)] - [renames any/c] ;; fixme - [body (?? bderiv?)])) - (struct (p:case-lambda prule) - ([z1 syntax?] - [z2 syntax/f] - [resolves resolves/c] - [?1 (?? exn?)] - [renames+bodies (listof clc?)])) - (struct (p:let-values prule) - ([z1 syntax?] - [z2 syntax/f] - [resolves resolves/c] - [?1 (?? exn?)] - [renames any/c] ;; fixme - [rhss (?? (listof deriv?))] - [body (?? bderiv?)])) - (struct (p:letrec-values prule) - ([z1 syntax?] - [z2 syntax/f] - [resolves resolves/c] - [?1 (?? exn?)] - [renames any/c] ;; fixme - [rhss (?? (listof deriv?))] - [body (?? bderiv?)])) - (struct (p:letrec-syntaxes+values prule) - ([z1 syntax?] - [z2 syntax/f] - [resolves resolves/c] - [?1 (?? exn?)] - [srenames any/c] ;; fixme - [sbindrhss (?? (listof bind-syntaxes?))] - [vrenames any/c] ;; fixme - [vrhss (?? (listof deriv?))] - [body (?? bderiv?)])) - (struct (p::STOP prule) - ([z1 syntax?] - [z2 syntax/f] - [resolves resolves/c] - [?1 (?? exn?)])) - (struct (p:stop p::STOP) - ([z1 syntax?] - [z2 syntax/f] - [resolves resolves/c] - [?1 (?? exn?)])) - (struct (p:unknown p::STOP) - ([z1 syntax?] - [z2 syntax/f] - [resolves resolves/c] - [?1 (?? exn?)])) - (struct (p:#%top p::STOP) - ([z1 syntax?] - [z2 syntax/f] - [resolves resolves/c] - [?1 (?? exn?)] - [tagged-stx syntax/f])) - (struct (p:#%datum p::STOP) - ([z1 syntax?] - [z2 syntax/f] - [resolves resolves/c] - [?1 (?? exn?)] - [tagged-stx syntax/f])) - (struct (p:quote p::STOP) - ([z1 syntax?] - [z2 syntax/f] - [resolves resolves/c] - [?1 (?? exn?)])) - (struct (p:quote-syntax p::STOP) - ([z1 syntax?] - [z2 syntax/f] - [resolves resolves/c] - [?1 (?? exn?)])) - (struct (p:require p::STOP) - ([z1 syntax?] - [z2 syntax/f] - [resolves resolves/c] - [?1 (?? exn?)])) - (struct (p:require-for-syntax p::STOP) - ([z1 syntax?] - [z2 syntax/f] - [resolves resolves/c] - [?1 (?? exn?)])) - (struct (p:require-for-template p::STOP) - ([z1 syntax?] - [z2 syntax/f] - [resolves resolves/c] - [?1 (?? exn?)])) - (struct (p:provide p::STOP) - ([z1 syntax?] - [z2 syntax/f] - [resolves resolves/c] - [?1 (?? exn?)])) - (struct (p:rename prule) - ([z1 syntax?] - [z2 syntax/f] - [resolves resolves/c] - [?1 (?? exn?)] - [renames any/c] - [inner (?? deriv?)])) - (struct (p:synth prule) - ([z1 syntax?] - [z2 syntax/f] - [resolves resolves/c] - [?1 (?? exn?)] - [subterms (?? (listof subitem?))] - [?2 (?? exn?)])) - - (struct (lderiv node) - ([z1 stx?] - [z2 syntaxes/f] - [?1 (?? exn?)] - [derivs (?? (listof deriv?))])) - (struct (bderiv node) - ([z1 stx?] - [z2 syntaxes/f] - [pass1 (?? (listof (or/c b:error? brule?)))] - [trans (symbols 'list 'letrec)] - [pass2 (?? lderiv?)])) - - (struct b:error - ([?1 exn?])) - (struct brule - ([renames any/c])) - (struct (b:expr brule) - ([renames any/c] - [head deriv?])) - (struct (b:splice brule) - ([renames any/c] - [head deriv?] - [?1 (?? exn?)] - [tail (?? stx?)] - [?2 (?? exn?)])) - (struct (b:defvals brule) - ([renames any/c] - [head deriv?] - [?1 (?? exn?)])) - (struct (b:defstx brule) - ([renames any/c] - [head deriv?] - [?1 (?? exn?)] - [bindrhs (?? bind-syntaxes?)])) - - (struct bind-syntaxes - ([rhs deriv?] - [?1 (?? exn?)])) - - (struct clc - ([?1 (?? exn?)] - [renames any/c] - [body (?? bderiv?)])) - - (struct modrule ()) - (struct (mod:cons modrule) - ([head deriv?])) - (struct (mod:prim modrule) - ([head deriv?] - [prim (?? deriv?)])) - (struct (mod:skip modrule) ()) - (struct (mod:splice modrule) - ([head deriv?] - [?1 (?? exn?)] - [tail (?? stx?)])) - (struct (mod:lift modrule) - ([head deriv?] - [tail syntaxes/c])) - (struct (mod:lift-end modrule) - ([tail syntaxes/c])) - - (struct subitem ()) - (struct (s:subterm subitem) - ([path any/c] - [deriv deriv?])) - (struct (s:rename subitem) - ([path any/c] - [before syntax?] - [after syntax?]))) -|# + "deriv-c.rkt") +(provide (all-from-out "deriv-c.rkt")) diff --git a/collects/macro-debugger/model/hiding-policies.rkt b/collects/macro-debugger/model/hiding-policies.rkt index 51c1027..0be2f56 100644 --- a/collects/macro-debugger/model/hiding-policies.rkt +++ b/collects/macro-debugger/model/hiding-policies.rkt @@ -1,10 +1,8 @@ - -#lang scheme/base -(require (for-syntax scheme/base) - scheme/match - syntax/boundmap - "reductions-config.ss" - "../util/mpi.ss") +#lang racket/base +(require (for-syntax racket/base) + racket/match + "reductions-config.rkt" + "../util/mpi.rkt") (provide policy->predicate) ;; A Policy is one of diff --git a/collects/macro-debugger/model/reductions-config.rkt b/collects/macro-debugger/model/reductions-config.rkt index 160255c..f3c82aa 100644 --- a/collects/macro-debugger/model/reductions-config.rkt +++ b/collects/macro-debugger/model/reductions-config.rkt @@ -1,14 +1,13 @@ -#lang scheme/base - -(require (for-syntax scheme/base) - scheme/list - scheme/contract - scheme/match - "deriv.ss" - "deriv-util.ss" - "stx-util.ss" - "context.ss" - "steps.ss") +#lang racket/base +(require (for-syntax racket/base) + racket/list + racket/contract + racket/match + "deriv.rkt" + "deriv-util.rkt" + "stx-util.rkt" + "context.rkt" + "steps.rkt") (define-syntax-rule (STRICT-CHECKS form ...) (when #f diff --git a/collects/macro-debugger/model/reductions-engine.rkt b/collects/macro-debugger/model/reductions-engine.rkt index 9c89829..80e5e31 100644 --- a/collects/macro-debugger/model/reductions-engine.rkt +++ b/collects/macro-debugger/model/reductions-engine.rkt @@ -1,16 +1,16 @@ -#lang scheme/base -(require (for-syntax scheme/base) - (for-syntax syntax/parse) - scheme/list - scheme/contract - "deriv.ss" - "deriv-util.ss" - "stx-util.ss" - "context.ss" - "steps.ss" - "reductions-config.ss") -(provide (all-from-out "steps.ss") - (all-from-out "reductions-config.ss") +#lang racket/base +(require (for-syntax racket/base + syntax/parse) + racket/list + racket/contract + "deriv.rkt" + "deriv-util.rkt" + "stx-util.rkt" + "context.rkt" + "steps.rkt" + "reductions-config.rkt") +(provide (all-from-out "steps.rkt") + (all-from-out "reductions-config.rkt") DEBUG R !) diff --git a/collects/macro-debugger/model/reductions.rkt b/collects/macro-debugger/model/reductions.rkt index 82943aa..3f60cf6 100644 --- a/collects/macro-debugger/model/reductions.rkt +++ b/collects/macro-debugger/model/reductions.rkt @@ -1,10 +1,9 @@ - -#lang scheme/base -(require scheme/match - "stx-util.ss" - "deriv-util.ss" - "deriv.ss" - "reductions-engine.ss") +#lang racket/base +(require racket/match + "stx-util.rkt" + "deriv-util.rkt" + "deriv.rkt" + "reductions-engine.rkt") (provide reductions reductions+) diff --git a/collects/macro-debugger/model/steps.rkt b/collects/macro-debugger/model/steps.rkt index 4412186..bb4feed 100644 --- a/collects/macro-debugger/model/steps.rkt +++ b/collects/macro-debugger/model/steps.rkt @@ -1,6 +1,6 @@ -#lang scheme/base -(require "deriv.ss" - "deriv-util.ss") +#lang racket/base +(require "deriv.rkt" + "deriv-util.rkt") (provide (struct-out protostep) (struct-out step) (struct-out misstep) diff --git a/collects/macro-debugger/model/stx-util.rkt b/collects/macro-debugger/model/stx-util.rkt index 1073298..def760a 100644 --- a/collects/macro-debugger/model/stx-util.rkt +++ b/collects/macro-debugger/model/stx-util.rkt @@ -1,6 +1,5 @@ - -#lang scheme/base -(require (for-syntax scheme/base) +#lang racket/base +(require (for-syntax racket/base) syntax/stx) (provide (all-defined-out) diff --git a/collects/macro-debugger/model/trace-raw.rkt b/collects/macro-debugger/model/trace-raw.rkt index 5fc8702..40615d6 100644 --- a/collects/macro-debugger/model/trace-raw.rkt +++ b/collects/macro-debugger/model/trace-raw.rkt @@ -1,10 +1,9 @@ - -#lang scheme/base -(require scheme/class +#lang racket/base +(require racket/class parser-tools/lex - "deriv-tokens.ss" - "deriv-parser.ss" - "../syntax-browser.ss") + "deriv-tokens.rkt" + "deriv-parser.rkt" + "../syntax-browser.rkt") (provide (all-defined-out)) (define current-expand-observe diff --git a/collects/macro-debugger/model/trace.rkt b/collects/macro-debugger/model/trace.rkt index 12e08c5..5f509e5 100644 --- a/collects/macro-debugger/model/trace.rkt +++ b/collects/macro-debugger/model/trace.rkt @@ -1,10 +1,9 @@ - -#lang scheme/base -(require scheme/promise +#lang racket/base +(require racket/promise parser-tools/lex - "deriv.ss" - "deriv-parser.ss" - "deriv-tokens.ss") + "deriv.rkt" + "deriv-parser.rkt" + "deriv-tokens.rkt") (provide trace trace* diff --git a/collects/macro-debugger/model/yacc-ext.rkt b/collects/macro-debugger/model/yacc-ext.rkt index 85ef44b..a8d262a 100644 --- a/collects/macro-debugger/model/yacc-ext.rkt +++ b/collects/macro-debugger/model/yacc-ext.rkt @@ -1,7 +1,6 @@ - -#lang scheme/base -(require (prefix-in yacc: parser-tools/yacc) - (for-syntax scheme/base)) +#lang racket/base +(require (for-syntax racket/base) + (prefix-in yacc: parser-tools/yacc)) (provide parser options productions diff --git a/collects/macro-debugger/model/yacc-interrupted.rkt b/collects/macro-debugger/model/yacc-interrupted.rkt index 7d7c491..9e8d2a5 100644 --- a/collects/macro-debugger/model/yacc-interrupted.rkt +++ b/collects/macro-debugger/model/yacc-interrupted.rkt @@ -1,9 +1,7 @@ - -#lang scheme/base -(require (for-syntax scheme/base - mzlib/etc +#lang racket/base +(require (for-syntax racket/base unstable/syntax) - "yacc-ext.ss") + "yacc-ext.rkt") (provide ! ? !! define-production-splitter skipped-token-values diff --git a/collects/macro-debugger/stepper-text.rkt b/collects/macro-debugger/stepper-text.rkt index 327b52a..15df8ef 100644 --- a/collects/macro-debugger/stepper-text.rkt +++ b/collects/macro-debugger/stepper-text.rkt @@ -1,13 +1,12 @@ - -#lang scheme/base -(require scheme/list - scheme/pretty - "model/trace.ss" - "model/reductions.ss" - "model/reductions-config.ss" - "model/steps.ss" - "syntax-browser/partition.ss" - "syntax-browser/pretty-helper.ss") +#lang racket/base +(require racket/list + racket/pretty + "model/trace.rkt" + "model/reductions.rkt" + "model/reductions-config.rkt" + "model/steps.rkt" + "syntax-browser/partition.rkt" + "syntax-browser/pretty-helper.rkt") (provide expand/step-text stepper-text) diff --git a/collects/macro-debugger/stepper.rkt b/collects/macro-debugger/stepper.rkt index 30fec39..07e782b 100644 --- a/collects/macro-debugger/stepper.rkt +++ b/collects/macro-debugger/stepper.rkt @@ -1,6 +1,5 @@ - -#lang scheme/base -(require "view/view.ss") +#lang racket/base +(require "view/view.rkt") (provide expand/step) (define (expand/step stx) diff --git a/collects/macro-debugger/syntax-browser.rkt b/collects/macro-debugger/syntax-browser.rkt index ce23cef..155ef03 100644 --- a/collects/macro-debugger/syntax-browser.rkt +++ b/collects/macro-debugger/syntax-browser.rkt @@ -1,6 +1,5 @@ - -#lang scheme/base -(require "syntax-browser/frame.ss") +#lang racket/base +(require "syntax-browser/frame.rkt") (provide browse-syntax browse-syntaxes make-syntax-browser) diff --git a/collects/macro-debugger/syntax-browser/controller.rkt b/collects/macro-debugger/syntax-browser/controller.rkt index 897a9c8..82a2d06 100644 --- a/collects/macro-debugger/syntax-browser/controller.rkt +++ b/collects/macro-debugger/syntax-browser/controller.rkt @@ -1,10 +1,8 @@ -#lang scheme/base -(require scheme/class - (rename-in unstable/class-iop - [send/i send:] - [init-field/i init-field:]) - "interfaces.ss" - "partition.ss" +#lang racket/base +(require racket/class + unstable/class-iop + "interfaces.rkt" + "partition.rkt" unstable/gui/notify) (provide controller%) @@ -33,13 +31,13 @@ (super-new) (listen-selected-syntax (lambda (new-value) - (for-each (lambda (display) (send: display display<%> refresh)) + (for-each (lambda (display) (send/i display display<%> refresh)) displays))))) ;; mark-manager-mixin (define mark-manager-mixin (mixin () (mark-manager<%>) - (init-field: [primary-partition partition<%> (new-bound-partition)]) + (init-field/i [primary-partition partition<%> (new-bound-partition)]) (super-new) ;; get-primary-partition : -> partition @@ -65,7 +63,7 @@ (listen-secondary-partition (lambda (p) (for ([d displays]) - (send: d display<%> refresh)))) + (send/i d display<%> refresh)))) (super-new))) (define controller% diff --git a/collects/macro-debugger/syntax-browser/display.rkt b/collects/macro-debugger/syntax-browser/display.rkt index 2ca32ef..e0a7da0 100644 --- a/collects/macro-debugger/syntax-browser/display.rkt +++ b/collects/macro-debugger/syntax-browser/display.rkt @@ -1,16 +1,14 @@ -#lang scheme/base -(require scheme/class - scheme/gui - scheme/list +#lang racket/base +(require racket/class + racket/gui + racket/list + racket/block framework - (rename-in unstable/class-iop - [send/i send:] - [init-field/i init-field:]) - (only-in mzlib/etc begin-with-definitions) - "pretty-printer.ss" - "interfaces.ss" - "prefs.ss" - "util.ss") + unstable/class-iop + "pretty-printer.rkt" + "interfaces.rkt" + "prefs.rkt" + "util.rkt") (provide print-syntax-to-editor code-style) @@ -27,13 +25,13 @@ ;; -> display<%> (define (print-syntax-to-editor stx text controller config columns [insertion-point (send text last-position)]) - (begin-with-definitions + (block (define output-port (open-output-string/count-lines)) (define range (pretty-print-syntax stx output-port - (send: controller controller<%> get-primary-partition) - (length (send: config config<%> get-colors)) - (send: config config<%> get-suffix-option) + (send/i controller controller<%> get-primary-partition) + (length (send/i config config<%> get-colors)) + (send/i config config<%> get-suffix-option) (send config get-pretty-styles) columns)) (define output-string (get-output-string output-port)) @@ -56,15 +54,15 @@ ;; display% (define display% (class* object% (display<%>) - (init-field: [controller controller<%>] - [config config<%>] - [range range<%>]) + (init-field/i [controller controller<%>] + [config config<%>] + [range range<%>]) (init-field text start-position end-position) (define base-style - (code-style text (send: config config<%> get-syntax-font-size))) + (code-style text (send/i config config<%> get-syntax-font-size))) (define extra-styles (make-hasheq)) @@ -78,10 +76,10 @@ ;; add-clickbacks : -> void (define/private (add-clickbacks) (define (the-clickback editor start end) - (send: controller selection-manager<%> set-selected-syntax + (send/i controller selection-manager<%> set-selected-syntax (clickback->stx (- start start-position) (- end start-position)))) - (for ([range (send: range range<%> all-ranges)]) + (for ([range (send/i range range<%> all-ranges)]) (let ([stx (range-obj range)] [start (range-start range)] [end (range-end range)]) @@ -91,7 +89,7 @@ ;; clickback->stx : num num -> syntax ;; FIXME: use vectors for treerange-subs and do binary search to narrow? (define/private (clickback->stx start end) - (let ([treeranges (send: range range<%> get-treeranges)]) + (let ([treeranges (send/i range range<%> get-treeranges)]) (let loop* ([treeranges treeranges]) (for/or ([tr treeranges]) (cond [(and (= (treerange-start tr) start) @@ -111,7 +109,7 @@ (change-style (unhighlight-d) start-position end-position)) (apply-extra-styles) (let ([selected-syntax - (send: controller selection-manager<%> + (send/i controller selection-manager<%> get-selected-syntax)]) (apply-secondary-partition-styles selected-syntax) (apply-selection-styles selected-syntax)) @@ -162,13 +160,13 @@ (list->vector (map color-style (map translate-color - (send: config config<%> get-colors))))) + (send/i config config<%> get-colors))))) (define overflow-style (color-style (translate-color "darkgray"))) (define color-partition - (send: controller mark-manager<%> get-primary-partition)) + (send/i controller mark-manager<%> get-primary-partition)) (define offset start-position) ;; Optimization: don't call change-style when new style = old style - (let tr*loop ([trs (send: range range<%> get-treeranges)] [old-style #f]) + (let tr*loop ([trs (send/i range range<%> get-treeranges)] [old-style #f]) (for ([tr trs]) (define stx (treerange-obj tr)) (define start (treerange-start tr)) @@ -184,7 +182,7 @@ ;; 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 partition<%> get-partition stx)]) + (let ([n (send/i partition partition<%> get-partition stx)]) (cond [(< n (vector-length color-vector)) (vector-ref color-vector n)] [else @@ -197,7 +195,7 @@ ;; Applies externally-added styles (such as highlighting) (define/private (apply-extra-styles) (for ([(stx style-deltas) extra-styles]) - (for ([r (send: range range<%> get-ranges stx)]) + (for ([r (send/i range range<%> get-ranges stx)]) (for ([style-delta style-deltas]) (restyle-range r style-delta))))) @@ -207,23 +205,23 @@ (define/private (apply-secondary-partition-styles selected-syntax) (when (identifier? selected-syntax) (let ([partition - (send: controller secondary-partition<%> + (send/i controller secondary-partition<%> get-secondary-partition)]) (when partition - (for ([id (send: range range<%> get-identifier-list)]) - (when (send: partition partition<%> + (for ([id (send/i range range<%> get-identifier-list)]) + (when (send/i partition partition<%> same-partition? selected-syntax id) (draw-secondary-connection id))))))) ;; apply-selection-styles : syntax -> void ;; Styles subterms eq to the selected syntax (define/private (apply-selection-styles selected-syntax) - (for ([r (send: range range<%> get-ranges selected-syntax)]) + (for ([r (send/i range range<%> get-ranges selected-syntax)]) (restyle-range r (select-highlight-d)))) ;; draw-secondary-connection : syntax -> void (define/private (draw-secondary-connection stx2) - (for ([r (send: range range<%> get-ranges stx2)]) + (for ([r (send/i range range<%> get-ranges stx2)]) (restyle-range r (select-sub-highlight-d)))) ;; restyle-range : (cons num num) style-delta% -> void @@ -238,11 +236,11 @@ ;; Initialize (super-new) - (send: controller controller<%> add-syntax-display this))) + (send/i controller controller<%> add-syntax-display this))) ;; fixup-parentheses : string range -> void (define (fixup-parentheses string range) - (for ([r (send: range range<%> all-ranges)]) + (for ([r (send/i range range<%> all-ranges)]) (let ([stx (range-obj r)] [start (range-start r)] [end (range-end r)]) diff --git a/collects/macro-debugger/syntax-browser/embed.rkt b/collects/macro-debugger/syntax-browser/embed.rkt index 2edc5e6..b3cb5d3 100644 --- a/collects/macro-debugger/syntax-browser/embed.rkt +++ b/collects/macro-debugger/syntax-browser/embed.rkt @@ -1,11 +1,10 @@ +#lang racket/base +(require "interfaces.rkt" + "widget.rkt" + "keymap.rkt" + "partition.rkt") -#lang scheme/base -(require "interfaces.ss" - "widget.ss" - "keymap.ss" - "partition.ss") - -(provide (all-from-out "interfaces.ss") - (all-from-out "widget.ss") - (all-from-out "keymap.ss") +(provide (all-from-out "interfaces.rkt") + (all-from-out "widget.rkt") + (all-from-out "keymap.rkt") identifier=-choices) diff --git a/collects/macro-debugger/syntax-browser/frame.rkt b/collects/macro-debugger/syntax-browser/frame.rkt index 7b4a3ff..d59f2eb 100644 --- a/collects/macro-debugger/syntax-browser/frame.rkt +++ b/collects/macro-debugger/syntax-browser/frame.rkt @@ -1,17 +1,13 @@ -#lang scheme/base -(require scheme/class - (rename-in unstable/class-iop - [define/i define:] - [send/i send:] - [send*/i send*:] - [init-field/i init-field:]) - scheme/gui - framework/framework - scheme/list - "interfaces.ss" - "partition.ss" - "prefs.ss" - "widget.ss") +#lang racket/base +(require racket/class + racket/gui + racket/list + framework + unstable/class-iop + "interfaces.rkt" + "partition.rkt" + "prefs.rkt" + "widget.rkt") (provide browse-syntax browse-syntaxes make-syntax-browser @@ -26,7 +22,7 @@ (define (browse-syntaxes stxs) (let ((w (make-syntax-browser))) (for ([stx stxs]) - (send*: w syntax-browser<%> + (send*/i w syntax-browser<%> (add-syntax stx) (add-separator))))) @@ -41,17 +37,17 @@ (class* frame% () (inherit get-width get-height) - (init-field: [config config<%> (new syntax-prefs%)]) + (init-field/i [config config<%> (new syntax-prefs%)]) (super-new (label "Syntax Browser") - (width (send: config config<%> get-width)) - (height (send: config config<%> get-height))) - (define: widget syntax-browser<%> + (width (send/i config config<%> get-width)) + (height (send/i config config<%> get-height))) + (define/i widget syntax-browser<%> (new syntax-widget/controls% (parent this) (config config))) (define/public (get-widget) widget) (define/augment (on-close) - (send*: config config<%> + (send*/i config config<%> (set-width (get-width)) (set-height (get-height))) (send widget shutdown) @@ -81,22 +77,22 @@ (choices (map car -identifier=-choices)) (callback (lambda (c e) - (send: (get-controller) controller<%> set-identifier=? + (send/i (get-controller) controller<%> set-identifier=? (assoc (send c get-string-selection) -identifier=-choices)))))) (new button% (label "Clear") (parent -control-panel) - (callback (lambda _ (send: (get-controller) controller<%> set-selected-syntax #f)))) + (callback (lambda _ (send/i (get-controller) controller<%> set-selected-syntax #f)))) (new button% (label "Properties") (parent -control-panel) (callback (lambda _ - (send: config config<%> set-props-shown? - (not (send: config config<%> get-props-shown?)))))) + (send/i config config<%> set-props-shown? + (not (send/i config config<%> get-props-shown?)))))) - (send: (get-controller) controller<%> listen-identifier=? + (send/i (get-controller) controller<%> listen-identifier=? (lambda (name+func) (send -choice set-selection (or (send -choice find-string (car name+func)) 0)))) diff --git a/collects/macro-debugger/syntax-browser/hrule-snip.rkt b/collects/macro-debugger/syntax-browser/hrule-snip.rkt index 148d3f2..c7bb859 100644 --- a/collects/macro-debugger/syntax-browser/hrule-snip.rkt +++ b/collects/macro-debugger/syntax-browser/hrule-snip.rkt @@ -1,8 +1,6 @@ - -#lang scheme/base - -(require scheme/class - scheme/gui) +#lang racket/base +(require racket/class + racket/gui) (provide hrule-snip%) ;; hrule-snip% @@ -53,5 +51,5 @@ (define snip-class (new hrule-snipclass%)) (send snip-class set-version 1) (send snip-class set-classname - (format "~s" '(lib "hrule-snip.ss" "macro-debugger" "syntax-browser"))) + (format "~s" '(lib "hrule-snip.rkt" "macro-debugger" "syntax-browser"))) (send (get-the-snip-class-list) add snip-class) diff --git a/collects/macro-debugger/syntax-browser/image.rkt b/collects/macro-debugger/syntax-browser/image.rkt index 7e5774a..23fa15c 100644 --- a/collects/macro-debugger/syntax-browser/image.rkt +++ b/collects/macro-debugger/syntax-browser/image.rkt @@ -1,11 +1,11 @@ -#lang scheme/base -(require scheme/contract - scheme/class - scheme/gui +#lang racket/base +(require racket/contract + racket/class + racket/gui framework - "prefs.ss" - "controller.ss" - "display.ss") + "prefs.rkt" + "controller.rkt" + "display.rkt") #| diff --git a/collects/macro-debugger/syntax-browser/interfaces.rkt b/collects/macro-debugger/syntax-browser/interfaces.rkt index 411f922..5f057ba 100644 --- a/collects/macro-debugger/syntax-browser/interfaces.rkt +++ b/collects/macro-debugger/syntax-browser/interfaces.rkt @@ -1,7 +1,7 @@ -#lang scheme/base -(require scheme/class +#lang racket/base +(require racket/class unstable/class-iop - (for-syntax scheme/base)) + (for-syntax racket/base)) (provide (all-defined-out)) ;; Helpers @@ -14,7 +14,7 @@ [else (error '->string)])) (string->symbol (apply string-append (map ->string args)))) -;; not in notify.ss because notify depends on scheme/gui +;; not in notify.rkt because notify depends on gui (define-interface-expander methods:notify (lambda (stx) (syntax-case stx () diff --git a/collects/macro-debugger/syntax-browser/keymap.rkt b/collects/macro-debugger/syntax-browser/keymap.rkt index 7da1a99..afc3fc2 100644 --- a/collects/macro-debugger/syntax-browser/keymap.rkt +++ b/collects/macro-debugger/syntax-browser/keymap.rkt @@ -1,10 +1,10 @@ -#lang scheme/base -(require scheme/class - scheme/gui - scheme/pretty +#lang racket/base +(require racket/class + racket/gui + racket/pretty unstable/gui/notify - "interfaces.ss" - "partition.ss") + "interfaces.rkt" + "partition.rkt") (provide syntax-keymap%) (define keymap/popup% diff --git a/collects/macro-debugger/syntax-browser/partition.rkt b/collects/macro-debugger/syntax-browser/partition.rkt index f9600c0..b99cec0 100644 --- a/collects/macro-debugger/syntax-browser/partition.rkt +++ b/collects/macro-debugger/syntax-browser/partition.rkt @@ -1,6 +1,5 @@ -#lang scheme/base -(require scheme/class - syntax/boundmap +#lang racket/base +(require racket/class syntax/stx "interfaces.rkt" "../util/stxobj.rkt") diff --git a/collects/macro-debugger/syntax-browser/prefs.rkt b/collects/macro-debugger/syntax-browser/prefs.rkt index 63e245b..ec9c0ad 100644 --- a/collects/macro-debugger/syntax-browser/prefs.rkt +++ b/collects/macro-debugger/syntax-browser/prefs.rkt @@ -1,7 +1,7 @@ -#lang scheme/base -(require scheme/class - framework/framework - "interfaces.ss" +#lang racket/base +(require racket/class + framework + "interfaces.rkt" unstable/gui/notify unstable/gui/prefs) (provide prefs-base% diff --git a/collects/macro-debugger/syntax-browser/pretty-helper.rkt b/collects/macro-debugger/syntax-browser/pretty-helper.rkt index af67d15..7a4ae10 100644 --- a/collects/macro-debugger/syntax-browser/pretty-helper.rkt +++ b/collects/macro-debugger/syntax-browser/pretty-helper.rkt @@ -1,11 +1,10 @@ -#lang scheme/base -(require scheme/class - scheme/pretty - (rename-in unstable/class-iop - [send/i send:]) +#lang racket/base +(require racket/class + racket/pretty + unstable/class-iop syntax/stx unstable/struct - "interfaces.ss") + "interfaces.rkt") (provide (all-defined-out)) ;; Problem: If stx1 and stx2 are two distinguishable syntax objects, it @@ -64,12 +63,12 @@ ((never) (make-id-syntax-dummy sym sym)) ((always) - (let ([n (send: partition partition<%> get-partition id)]) + (let ([n (send/i partition partition<%> get-partition id)]) (if (zero? n) (make-id-syntax-dummy sym sym) (make-id-syntax-dummy (suffix sym n) sym)))) ((over-limit) - (let ([n (send: partition partition<%> get-partition id)]) + (let ([n (send/i partition partition<%> get-partition id)]) (if (<= n limit) (make-id-syntax-dummy sym sym) (make-id-syntax-dummy (suffix sym n) sym)))))) @@ -82,7 +81,7 @@ => (lambda (datum) datum)] [(and partition (identifier? obj)) (when (and (eq? suffixopt 'all-if-over-limit) - (> (send: partition partition<%> count) limit)) + (> (send/i partition partition<%> count) limit)) (call-with-values (lambda () (table stx partition #f 'always)) escape)) (let ([lp-datum (make-identifier-proxy obj)]) @@ -91,7 +90,7 @@ lp-datum)] [(and (syntax? obj) (check+convert-special-expression obj)) => (lambda (newobj) - (when partition (send: partition partition<%> get-partition obj)) + (when partition (send/i partition partition<%> get-partition obj)) (let* ([inner (cadr newobj)] [lp-inner-datum (loop inner)] [lp-datum (list (car newobj) lp-inner-datum)]) @@ -101,7 +100,7 @@ (hash-set! stx=>flat obj lp-datum) lp-datum))] [(syntax? obj) - (when partition (send: partition partition<%> get-partition obj)) + (when partition (send/i partition partition<%> get-partition obj)) (let ([lp-datum (loop (syntax-e obj))]) (hash-set! flat=>stx lp-datum obj) (hash-set! stx=>flat obj lp-datum) diff --git a/collects/macro-debugger/syntax-browser/pretty-printer.rkt b/collects/macro-debugger/syntax-browser/pretty-printer.rkt index 4787e83..442115c 100644 --- a/collects/macro-debugger/syntax-browser/pretty-printer.rkt +++ b/collects/macro-debugger/syntax-browser/pretty-printer.rkt @@ -1,10 +1,10 @@ -#lang scheme/base -(require scheme/list - scheme/class - scheme/pretty - scheme/gui - "pretty-helper.ss" - "interfaces.ss") +#lang racket/base +(require racket/list + racket/class + racket/pretty + racket/gui + "pretty-helper.rkt" + "interfaces.rkt") (provide pretty-print-syntax) ;; FIXME: Need to disable printing of structs with custom-write property diff --git a/collects/macro-debugger/syntax-browser/properties.rkt b/collects/macro-debugger/syntax-browser/properties.rkt index e46a0e9..2d0a482 100644 --- a/collects/macro-debugger/syntax-browser/properties.rkt +++ b/collects/macro-debugger/syntax-browser/properties.rkt @@ -1,12 +1,11 @@ -#lang scheme/base -(require scheme/class - scheme/gui +#lang racket/base +(require racket/class + racket/gui framework - (rename-in unstable/class-iop - [send/i send:]) - "interfaces.ss" - "util.ss" - "../util/mpi.ss" + unstable/class-iop + "interfaces.rkt" + "util.rkt" + "../util/mpi.rkt" "../util/stxobj.rkt") (provide properties-view% properties-snip%) @@ -44,10 +43,10 @@ (field (text (new color-text%))) (field (pdisplayer (new properties-displayer% (text text)))) - (send: controller selection-manager<%> listen-selected-syntax - (lambda (stx) - (set! selected-syntax stx) - (refresh))) + (send/i controller selection-manager<%> listen-selected-syntax + (lambda (stx) + (set! selected-syntax stx) + (refresh))) (super-new) ;; get-mode : -> symbol diff --git a/collects/macro-debugger/syntax-browser/snip-decorated.rkt b/collects/macro-debugger/syntax-browser/snip-decorated.rkt index 55f0574..c408255 100644 --- a/collects/macro-debugger/syntax-browser/snip-decorated.rkt +++ b/collects/macro-debugger/syntax-browser/snip-decorated.rkt @@ -1,14 +1,13 @@ -#lang scheme/base -(require scheme/class - (rename-in unstable/class-iop - [send/i send:]) - mzlib/string - mred - "interfaces.ss" - "controller.ss" - "properties.ss" - "prefs.ss" - (except-in "snip.ss" +#lang racket/base +(require racket/class + racket/gui + (only-in mzlib/string read-from-string) + unstable/class-iop + "interfaces.rkt" + "controller.rkt" + "properties.rkt" + "prefs.rkt" + (except-in "snip.rkt" snip-class)) (provide decorated-syntax-snip% @@ -145,8 +144,8 @@ (define/public (read-special src line col pos) (send the-syntax-snip read-special src line col pos)) - (send: config config<%> listen-props-shown? - (lambda (?) (refresh-contents))) + (send/i config config<%> listen-props-shown? + (lambda (?) (refresh-contents))) (super-new) (set-snipclass snip-class) @@ -198,7 +197,7 @@ ;; SNIPCLASS -;; COPIED AND MODIFIED from mrlib/syntax-browser.ss +;; COPIED AND MODIFIED from mrlib/syntax-browser.rkt (define decorated-syntax-snipclass% (class snip-class% (define/override (read stream) @@ -210,4 +209,4 @@ (define snip-class (make-object decorated-syntax-snipclass%)) (send snip-class set-version 2) (send snip-class set-classname - (format "~s" '(lib "macro-debugger/syntax-browser/snip-decorated.ss"))) + (format "~s" '(lib "macro-debugger/syntax-browser/snip-decorated.rkt"))) diff --git a/collects/macro-debugger/syntax-browser/snip.rkt b/collects/macro-debugger/syntax-browser/snip.rkt index 7116afc..545b213 100644 --- a/collects/macro-debugger/syntax-browser/snip.rkt +++ b/collects/macro-debugger/syntax-browser/snip.rkt @@ -1,16 +1,14 @@ -#lang scheme/base -(require scheme/class - (rename-in unstable/class-iop - [send/i send:]) - scheme/match - mzlib/string - mred +#lang racket/base +(require racket/class + racket/gui + racket/match + (only-in mzlib/string read-from-string) framework - "interfaces.ss" - "display.ss" - "controller.ss" - "keymap.ss" - "prefs.ss") + "interfaces.rkt" + "display.rkt" + "controller.rkt" + "keymap.rkt" + "prefs.rkt") (provide syntax-snip% marshall-syntax @@ -167,7 +165,7 @@ ;; SNIPCLASS -;; COPIED AND MODIFIED from mrlib/syntax-browser.ss +;; COPIED AND MODIFIED from mrlib/syntax-browser.rkt (define syntax-snipclass% (class snip-class% (define/override (read stream) @@ -178,4 +176,4 @@ (define snip-class (new syntax-snipclass%)) (send snip-class set-version 2) (send snip-class set-classname - (format "~s" '(lib "macro-debugger/syntax-browser/snip.ss"))) + (format "~s" '(lib "macro-debugger/syntax-browser/snip.rkt"))) diff --git a/collects/macro-debugger/syntax-browser/text.rkt b/collects/macro-debugger/syntax-browser/text.rkt index 6af632a..839123c 100644 --- a/collects/macro-debugger/syntax-browser/text.rkt +++ b/collects/macro-debugger/syntax-browser/text.rkt @@ -1,12 +1,12 @@ -#lang scheme/base -(require scheme/list - scheme/class - scheme/gui +#lang racket/base +(require racket/list + racket/class + racket/gui drracket/arrow framework/framework unstable/interval-map unstable/gui/notify - "interfaces.ss") + "interfaces.rkt") (provide text:hover<%> text:hover-drawings<%> diff --git a/collects/macro-debugger/syntax-browser/util.rkt b/collects/macro-debugger/syntax-browser/util.rkt index c74553a..1c3ad52 100644 --- a/collects/macro-debugger/syntax-browser/util.rkt +++ b/collects/macro-debugger/syntax-browser/util.rkt @@ -1,6 +1,5 @@ - -#lang scheme/base -(require scheme/class) +#lang racket/base +(require racket/class) (provide with-unlock make-text-port) diff --git a/collects/macro-debugger/syntax-browser/widget.rkt b/collects/macro-debugger/syntax-browser/widget.rkt index 598d3b6..5aaccbc 100644 --- a/collects/macro-debugger/syntax-browser/widget.rkt +++ b/collects/macro-debugger/syntax-browser/widget.rkt @@ -1,21 +1,20 @@ -#lang scheme/base -(require scheme/class - mred - framework/framework - scheme/list - scheme/match +#lang racket/base +(require racket/class + racket/gui + racket/list + racket/match + framework syntax/id-table - (rename-in unstable/class-iop - [send/i send:]) - "interfaces.ss" - "controller.ss" - "display.ss" - "keymap.ss" - "hrule-snip.ss" - "properties.ss" - "text.ss" - "util.ss" - "../util/mpi.ss") + unstable/class-iop + "interfaces.rkt" + "controller.rkt" + "display.rkt" + "keymap.rkt" + "hrule-snip.rkt" + "properties.rkt" + "text.rkt" + "util.rkt" + "../util/mpi.rkt") (provide widget%) ;; widget% @@ -55,7 +54,7 @@ (define/private (internal-show-props show?) (if show? (unless (send -props-panel is-shown?) - (let ([p (send: config config<%> get-props-percentage)]) + (let ([p (send/i config config<%> get-props-percentage)]) (send -split-panel add-child -props-panel) (update-props-percentage p)) (send -props-panel show #t)) @@ -82,7 +81,7 @@ (define/public (shutdown) (when (props-panel-shown?) - (send: config config<%> set-props-percentage + (send/i config config<%> set-props-percentage (cadr (send -split-panel get-percentages))))) ;; syntax-browser<%> Methods @@ -115,29 +114,29 @@ #:substitutions [substitutions null]) (let ([display (internal-add-syntax stx)] [definite-table (make-hasheq)]) - (let ([range (send: display display<%> get-range)] - [offset (send: display display<%> get-start-position)]) + (let ([range (send/i display display<%> get-range)] + [offset (send/i display display<%> get-start-position)]) (for ([subst substitutions]) - (for ([r (send: range range<%> get-ranges (car subst))]) + (for ([r (send/i range range<%> get-ranges (car subst))]) (with-unlock -text (send -text insert (cdr subst) (+ offset (car r)) (+ offset (cdr r)) #f) (send -text change-style - (code-style -text (send: config config<%> get-syntax-font-size)) + (code-style -text (send/i config config<%> get-syntax-font-size)) (+ offset (car r)) (+ offset (cdr r))))))) (for ([hi-stxs hi-stxss] [hi-color hi-colors]) - (send: display display<%> highlight-syntaxes hi-stxs hi-color)) + (send/i display display<%> highlight-syntaxes hi-stxs hi-color)) (for ([definite definites]) (hash-set! definite-table definite #t) (when shift-table (for ([shifted-definite (hash-ref shift-table definite null)]) (hash-set! definite-table shifted-definite #t)))) (let ([binder-table (make-free-id-table)]) - (define range (send: display display<%> get-range)) - (define start (send: display display<%> get-start-position)) + (define range (send/i display display<%> get-range)) + (define start (send/i display display<%> get-start-position)) (define (get-binders id) (let ([binder (free-id-table-ref binder-table id #f)]) (cond [(not binder) null] @@ -149,17 +148,17 @@ (for ([binder binders]) (free-id-table-set! binder-table binder binder)) ;; Underline binders (and shifted binders) - (send: display display<%> underline-syntaxes + (send/i display display<%> underline-syntaxes (append (apply append (map get-shifted binders)) binders)) ;; Make arrows (& billboards, when enabled) - (for ([id (send: range range<%> get-identifier-list)]) + (for ([id (send/i range range<%> get-identifier-list)]) (define definite? (hash-ref definite-table id #f)) (when #f ;; DISABLED (add-binding-billboard start range id definite?)) (for ([binder (get-binders id)]) - (for ([binder-r (send: range range<%> get-ranges binder)]) - (for ([id-r (send: range range<%> get-ranges id)]) + (for ([binder-r (send/i range range<%> get-ranges binder)]) + (for ([id-r (send/i range range<%> get-ranges id)]) (add-binding-arrow start binder-r id-r definite?)))))) (void))) @@ -187,7 +186,7 @@ (+ start (cdr id-r)) (string-append "from " (mpi->string src-mod)) (if definite? "blue" "purple"))) - (send: range range<%> get-ranges id))] + (send/i range range<%> get-ranges id))] [_ (void)])) (define/public (add-separator) @@ -200,7 +199,7 @@ (with-unlock -text (send -text erase) (send -text delete-all-drawings)) - (send: controller displays-manager<%> remove-all-syntax-displays)) + (send/i controller displays-manager<%> remove-all-syntax-displays)) (define/public (get-text) -text) @@ -218,7 +217,7 @@ display))) (define/private (calculate-columns) - (define style (code-style -text (send: config config<%> get-syntax-font-size))) + (define style (code-style -text (send/i config config<%> get-syntax-font-size))) (define char-width (send style get-text-width (send -ecanvas get-dc))) (define-values (canvas-w canvas-h) (send -ecanvas get-client-size)) (sub1 (inexact->exact (floor (/ canvas-w char-width))))) @@ -227,13 +226,13 @@ (super-new) (setup-keymap) - (send: config config<%> listen-props-shown? + (send/i config config<%> listen-props-shown? (lambda (show?) (show-props show?))) - (send: config config<%> listen-props-percentage + (send/i config config<%> listen-props-percentage (lambda (p) (update-props-percentage p))) - (internal-show-props (send: config config<%> get-props-shown?)))) + (internal-show-props (send/i config config<%> get-props-shown?)))) (define clickback-style diff --git a/collects/macro-debugger/util/mpi.rkt b/collects/macro-debugger/util/mpi.rkt index c4f832c..5713951 100644 --- a/collects/macro-debugger/util/mpi.rkt +++ b/collects/macro-debugger/util/mpi.rkt @@ -1,6 +1,6 @@ -#lang scheme/base -(require scheme/match - scheme/string) +#lang racket/base +(require racket/match + racket/string) (provide mpi->list mpi->string @@ -176,7 +176,7 @@ [package (string-append (caddr m) ".plt")] [version (and (cadddr m) (parse-version (cadddr m)))] [path (list-ref m 4)]) - `(planet ,(string-append (or path "main") ".ss") + `(planet ,(string-append (or path "main") ".rkt") (,owner ,package . ,version))))) (define (parse-version str) @@ -186,7 +186,7 @@ (define (split-mods* path) (let ([mods (split-mods path)]) (if (and (pair? mods) (null? (cdr mods))) - (append mods (list "main.ss")) + (append mods (list "main.rkt")) mods))) (define (split-mods path [more null]) diff --git a/collects/macro-debugger/util/stxobj.rkt b/collects/macro-debugger/util/stxobj.rkt index dcbd429..58d30f2 100644 --- a/collects/macro-debugger/util/stxobj.rkt +++ b/collects/macro-debugger/util/stxobj.rkt @@ -1,4 +1,4 @@ -#lang racket +#lang racket/base (require (rename-in racket/contract [-> c:->]) ffi/unsafe) diff --git a/collects/macro-debugger/view/cursor.rkt b/collects/macro-debugger/view/cursor.rkt index 981d4d5..080c1ec 100644 --- a/collects/macro-debugger/view/cursor.rkt +++ b/collects/macro-debugger/view/cursor.rkt @@ -1,6 +1,4 @@ - -#lang scheme/base -(require scheme/promise) +#lang racket/base (provide cursor? cursor-position cursor:new diff --git a/collects/macro-debugger/view/debug-format.rkt b/collects/macro-debugger/view/debug-format.rkt index 87cdc04..6527397 100644 --- a/collects/macro-debugger/view/debug-format.rkt +++ b/collects/macro-debugger/view/debug-format.rkt @@ -1,6 +1,5 @@ - -#lang scheme/base -(require scheme/pretty) +#lang racket/base +(require racket/pretty) (provide write-debug-file load-debug-file) diff --git a/collects/macro-debugger/view/debug.rkt b/collects/macro-debugger/view/debug.rkt index dff2ec1..8ebc9da 100644 --- a/collects/macro-debugger/view/debug.rkt +++ b/collects/macro-debugger/view/debug.rkt @@ -1,12 +1,11 @@ -#lang scheme/base -(require scheme/pretty - scheme/class - (rename-in unstable/class-iop - [send/i send:]) - "interfaces.ss" - "debug-format.ss" - "prefs.ss" - "view.ss") +#lang racket/base +(require racket/pretty + racket/class + unstable/class-iop + "interfaces.rkt" + "debug-format.rkt" + "prefs.rkt" + "view.rkt") (provide debug-file) (define (widget-mixin %) @@ -30,5 +29,5 @@ (pretty-print msg) (pretty-print ctx) (let* ([w (make-stepper)]) - (send: w widget<%> add-trace events) + (send/i w widget<%> add-trace events) w))) diff --git a/collects/macro-debugger/view/extensions.rkt b/collects/macro-debugger/view/extensions.rkt index 88cd113..61425dc 100644 --- a/collects/macro-debugger/view/extensions.rkt +++ b/collects/macro-debugger/view/extensions.rkt @@ -1,27 +1,22 @@ -#lang scheme/base -(require scheme/class - (rename-in unstable/class-iop - [send/i send:] - [send*/i send*:] - [init-field/i init-field:]) - scheme/unit - scheme/list - scheme/match - scheme/gui - framework/framework - syntax/boundmap - "interfaces.ss" - "prefs.ss" - "warning.ss" - "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" - "../model/steps.ss" - "cursor.ss" +#lang racket/base +(require racket/class + racket/unit + racket/list + racket/match + racket/gui + framework + unstable/class-iop + "interfaces.rkt" + "prefs.rkt" + "hiding-panel.rkt" + (prefix-in s: "../syntax-browser/widget.rkt") + (prefix-in s: "../syntax-browser/keymap.rkt") + (prefix-in s: "../syntax-browser/interfaces.rkt") + "../model/deriv.rkt" + "../model/deriv-util.rkt" + "../model/trace.rkt" + "../model/steps.rkt" + "cursor.rkt" unstable/gui/notify) (provide stepper-keymap% stepper-syntax-widget%) @@ -30,7 +25,7 @@ (define stepper-keymap% (class s:syntax-keymap% - (init-field: (macro-stepper widget<%>)) + (init-field/i (macro-stepper widget<%>)) (inherit-field config controller) (inherit add-function @@ -42,17 +37,17 @@ (super-new) (define/public (get-hiding-panel) - (send: macro-stepper widget<%> get-macro-hiding-prefs)) + (send/i macro-stepper widget<%> get-macro-hiding-prefs)) (add-function "hiding:show-macro" (lambda (i e) - (send*: (get-hiding-panel) hiding-prefs<%> + (send*/i (get-hiding-panel) hiding-prefs<%> (add-show-identifier) (refresh)))) (add-function "hiding:hide-macro" (lambda (i e) - (send*: (get-hiding-panel) hiding-prefs<%> + (send*/i (get-hiding-panel) hiding-prefs<%> (add-hide-identifier) (refresh)))) @@ -78,21 +73,21 @@ (define stepper-syntax-widget% (class s:widget% - (init-field: (macro-stepper widget<%>)) + (init-field/i (macro-stepper widget<%>)) (inherit get-text) (inherit-field controller) (define/override (setup-keymap) (new stepper-keymap% (editor (get-text)) - (config (send: macro-stepper widget<%> get-config)) + (config (send/i macro-stepper widget<%> get-config)) (controller controller) (macro-stepper macro-stepper))) (define/override (show-props show?) (super show-props show?) - (send: macro-stepper widget<%> update/preserve-view)) + (send/i macro-stepper widget<%> update/preserve-view)) (super-new - (config (send: macro-stepper widget<%> get-config))))) + (config (send/i macro-stepper widget<%> get-config))))) diff --git a/collects/macro-debugger/view/frame.rkt b/collects/macro-debugger/view/frame.rkt index f86ac94..3d02a47 100644 --- a/collects/macro-debugger/view/frame.rkt +++ b/collects/macro-debugger/view/frame.rkt @@ -1,27 +1,23 @@ -#lang scheme/base -(require scheme/class - (rename-in unstable/class-iop - [define/i define:] - [send/i send:]) - scheme/unit - scheme/list - scheme/file - scheme/match - scheme/gui - framework/framework - syntax/boundmap - "interfaces.ss" - "stepper.ss" - "prefs.ss" - "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" - "../model/steps.ss" - "cursor.ss" +#lang racket/base +(require racket/class + racket/unit + racket/list + racket/file + racket/match + racket/gui + framework + unstable/class-iop + "interfaces.rkt" + "stepper.rkt" + "prefs.rkt" + "hiding-panel.rkt" + (prefix-in sb: "../syntax-browser/embed.rkt") + (prefix-in sb: "../syntax-browser/interfaces.rkt") + "../model/deriv.rkt" + "../model/deriv-util.rkt" + "../model/trace.rkt" + "../model/steps.rkt" + "cursor.rkt" unstable/gui/notify) (provide macro-stepper-frame-mixin) @@ -49,8 +45,8 @@ get-help-menu) (super-new (label (make-label)) - (width (send: config config<%> get-width)) - (height (send: config config<%> get-height))) + (width (send/i config config<%> get-width)) + (height (send/i config config<%> get-height))) (define/private (make-label) (if filename @@ -65,10 +61,10 @@ ;; to doing something. Avoid unnecessary updates. (define-values (w0 h0) (get-size)) (define/override (on-size w h) - (send: config config<%> set-width w) - (send: config config<%> set-height h) + (send/i config config<%> set-width w) + (send/i config config<%> set-height h) (unless (and (= w0 w) (= h0 h)) - (send: widget widget<%> update/preserve-view)) + (send/i widget widget<%> update/preserve-view)) (set!-values (w0 h0) (values w h))) (define warning-panel @@ -80,13 +76,13 @@ (define/public (get-macro-stepper-widget%) macro-stepper-widget%) - (define: widget widget<%> + (define/i widget widget<%> (new (get-macro-stepper-widget%) (parent (get-area-container)) (director director) (config config))) - (define: controller sb:controller<%> - (send: widget widget<%> get-controller)) + (define/i controller sb:controller<%> + (send/i widget widget<%> get-controller)) (define/public (get-widget) widget) (define/public (get-controller) controller) @@ -128,11 +124,11 @@ (new (get-menu-item%) (label "Duplicate stepper") (parent file-menu) - (callback (lambda _ (send: widget widget<%> duplicate-stepper)))) + (callback (lambda _ (send/i widget widget<%> duplicate-stepper)))) (new (get-menu-item%) (label "Duplicate stepper (current term only)") (parent file-menu) - (callback (lambda _ (send: widget widget<%> show-in-new-frame))))) + (callback (lambda _ (send/i widget widget<%> show-in-new-frame))))) (menu-option/notify-box stepper-menu "View syntax properties" @@ -149,23 +145,23 @@ (parent id-menu) (callback (lambda _ - (send: controller sb:controller<%> set-identifier=? p))))]) - (send: controller sb:controller<%> listen-identifier=? + (send/i controller sb:controller<%> set-identifier=? p))))]) + (send/i controller sb:controller<%> listen-identifier=? (lambda (name+func) (send this-choice check (eq? (car name+func) (car p))))))) (sb:identifier=-choices))) - (let ([identifier=? (send: config config<%> get-identifier=?)]) + (let ([identifier=? (send/i config config<%> get-identifier=?)]) (when identifier=? (let ([p (assoc identifier=? (sb:identifier=-choices))]) - (send: controller sb:controller<%> set-identifier=? p)))) + (send/i controller sb:controller<%> set-identifier=? p)))) (new (get-menu-item%) (label "Clear selection") (parent stepper-menu) (callback - (lambda _ (send: controller sb:controller<%> + (lambda _ (send/i controller sb:controller<%> set-selected-syntax #f)))) (new separator-menu-item% (parent stepper-menu)) @@ -177,11 +173,11 @@ (new (get-menu-item%) (label "Remove selected term") (parent stepper-menu) - (callback (lambda _ (send: widget widget<%> remove-current-term)))) + (callback (lambda _ (send/i widget widget<%> remove-current-term)))) (new (get-menu-item%) (label "Reset mark numbering") (parent stepper-menu) - (callback (lambda _ (send: widget widget<%> reset-primary-partition)))) + (callback (lambda _ (send/i widget widget<%> reset-primary-partition)))) (let ([extras-menu (new (get-menu%) (label "Extra options") @@ -191,11 +187,11 @@ (parent extras-menu) (callback (lambda (i e) - (send: config config<%> set-suffix-option + (send/i config config<%> set-suffix-option (if (send i is-checked?) 'always 'over-limit)) - (send: widget widget<%> update/preserve-view)))) + (send/i widget widget<%> update/preserve-view)))) (menu-option/notify-box extras-menu "Factor out common context?" (get-field split-context? config)) diff --git a/collects/macro-debugger/view/hiding-panel.rkt b/collects/macro-debugger/view/hiding-panel.rkt index 0b1d692..f8bc2f1 100644 --- a/collects/macro-debugger/view/hiding-panel.rkt +++ b/collects/macro-debugger/view/hiding-panel.rkt @@ -1,14 +1,11 @@ -#lang scheme/base -(require scheme/class - (rename-in unstable/class-iop - [send/i send:] - [init-field/i init-field:]) - scheme/gui - scheme/list - syntax/boundmap - "interfaces.ss" - "../model/hiding-policies.ss" - "../util/mpi.ss" +#lang racket/base +(require racket/class + racket/gui + racket/list + unstable/class-iop + "interfaces.rkt" + "../model/hiding-policies.rkt" + "../util/mpi.rkt" unstable/gui/notify) (provide macro-hiding-prefs-widget%) @@ -30,7 +27,7 @@ TODO (define macro-hiding-prefs-widget% (class* object% (hiding-prefs<%>) (init parent) - (init-field: (stepper widget<%>)) + (init-field/i (stepper widget<%>)) (init-field config) (define/public (get-policy) @@ -89,7 +86,7 @@ TODO (style '(deleted)))) (define/private (get-mode) - (send: config config<%> get-macro-hiding-mode)) + (send/i config config<%> get-macro-hiding-mode)) (define/private (macro-hiding-enabled?) (let ([mode (get-mode)]) @@ -99,7 +96,7 @@ TODO (define/private (ensure-custom-mode) (unless (equal? (get-mode) mode:custom) - (send: config config<%> set-macro-hiding-mode mode:custom))) + (send/i config config<%> set-macro-hiding-mode mode:custom))) (define/private (update-visibility) (let ([customizing (equal? (get-mode) mode:custom)]) @@ -114,10 +111,10 @@ TODO (list customize-panel) null)))))) - (send: config config<%> listen-macro-hiding-mode - (lambda (value) - (update-visibility) - (force-refresh))) + (send/i config config<%> listen-macro-hiding-mode + (lambda (value) + (update-visibility) + (force-refresh))) (define box:hiding (new check-box% @@ -185,11 +182,11 @@ TODO ;; refresh : -> void (define/public (refresh) (when (macro-hiding-enabled?) - (send: stepper widget<%> refresh/resynth))) + (send/i stepper widget<%> refresh/resynth))) ;; force-refresh : -> void (define/private (force-refresh) - (send: stepper widget<%> refresh/resynth)) + (send/i stepper widget<%> refresh/resynth)) ;; set-syntax : syntax/#f -> void (define/public (set-syntax lstx) diff --git a/collects/macro-debugger/view/interfaces.rkt b/collects/macro-debugger/view/interfaces.rkt index 54f8088..e038725 100644 --- a/collects/macro-debugger/view/interfaces.rkt +++ b/collects/macro-debugger/view/interfaces.rkt @@ -1,6 +1,6 @@ -#lang scheme/base +#lang racket/base (require unstable/class-iop - (prefix-in sb: "../syntax-browser/interfaces.ss")) + (prefix-in sb: "../syntax-browser/interfaces.rkt")) (provide (all-defined-out)) (define-interface config<%> (sb:config<%>) diff --git a/collects/macro-debugger/view/prefs.rkt b/collects/macro-debugger/view/prefs.rkt index 39100ed..237d86a 100644 --- a/collects/macro-debugger/view/prefs.rkt +++ b/collects/macro-debugger/view/prefs.rkt @@ -1,8 +1,8 @@ -#lang scheme/base -(require scheme/class - framework/framework - "interfaces.ss" - "../syntax-browser/prefs.ss" +#lang racket/base +(require racket/class + framework + "interfaces.rkt" + "../syntax-browser/prefs.rkt" unstable/gui/notify unstable/gui/prefs) (provide pref:macro-step-limit diff --git a/collects/macro-debugger/view/step-display.rkt b/collects/macro-debugger/view/step-display.rkt index f33eb92..0e01ccf 100644 --- a/collects/macro-debugger/view/step-display.rkt +++ b/collects/macro-debugger/view/step-display.rkt @@ -1,31 +1,26 @@ -#lang scheme/base -(require scheme/class - (rename-in unstable/class-iop - [send/i send:] - [send*/i send*:] - [init-field/i init-field:]) - scheme/unit - scheme/list - scheme/match - scheme/gui - framework/framework - syntax/boundmap - "interfaces.ss" - "prefs.ss" - "extensions.ss" - "warning.ss" - "hiding-panel.ss" - "../model/deriv.ss" - "../model/deriv-util.ss" - "../model/deriv-parser.ss" - "../model/trace.ss" - "../model/reductions-config.ss" - "../model/reductions.ss" - "../model/steps.ss" +#lang racket/base +(require racket/class + racket/unit + racket/list + racket/match + racket/gui + framework + unstable/class-iop + "interfaces.rkt" + "prefs.rkt" + "extensions.rkt" + "hiding-panel.rkt" + "../model/deriv.rkt" + "../model/deriv-util.rkt" + "../model/deriv-parser.rkt" + "../model/trace.rkt" + "../model/reductions-config.rkt" + "../model/reductions.rkt" + "../model/steps.rkt" unstable/gui/notify - (prefix-in sb: "../syntax-browser/interfaces.ss") - "cursor.ss" - "debug-format.ss") + (prefix-in sb: "../syntax-browser/interfaces.rkt") + "cursor.rkt" + "debug-format.rkt") #; (provide step-display% @@ -42,23 +37,23 @@ (define step-display% (class* object% (step-display<%>) - (init-field: (config config<%>)) + (init-field/i (config config<%>)) (init-field ((sbview syntax-widget))) (super-new) (define/public (add-internal-error part exn stx events) - (send: sbview sb:syntax-browser<%> add-text - (if part - (format "Macro stepper error (~a)" part) - "Macro stepper error")) + (send/i sbview sb:syntax-browser<%> add-text + (if part + (format "Macro stepper error (~a)" part) + "Macro stepper error")) (when (exn? exn) - (send: sbview sb:syntax-browser<%> add-text " ") - (send: sbview sb:syntax-browser<%> add-clickback "[details]" - (lambda _ (show-internal-error-details exn events)))) - (send: sbview sb:syntax-browser<%> add-text ". ") - (when stx (send: sbview sb:syntax-browser<%> add-text "Original syntax:")) - (send: sbview sb:syntax-browser<%> add-text "\n") - (when stx (send: sbview sb:syntax-browser<%> add-syntax stx))) + (send/i sbview sb:syntax-browser<%> add-text " ") + (send/i sbview sb:syntax-browser<%> add-clickback "[details]" + (lambda _ (show-internal-error-details exn events)))) + (send/i sbview sb:syntax-browser<%> add-text ". ") + (when stx (send/i sbview sb:syntax-browser<%> add-text "Original syntax:")) + (send/i sbview sb:syntax-browser<%> add-text "\n") + (when stx (send/i sbview sb:syntax-browser<%> add-syntax stx))) (define/private (show-internal-error-details exn events) (case (message-box/custom "Macro stepper internal error" @@ -77,7 +72,7 @@ ((3 #f) (void)))) (define/public (add-error exn) - (send*: sbview sb:syntax-browser<%> + (send*/i sbview sb:syntax-browser<%> (add-error-text (exn-message exn)) (add-text "\n"))) @@ -98,17 +93,17 @@ #:binders [binders null] #:definites [definites null] #:shift-table [shift-table #f]) - (send: sbview sb:syntax-browser<%> add-syntax stx - #:binders binders - #:definites definites - #:shift-table shift-table)) + (send/i sbview sb:syntax-browser<%> add-syntax stx + #:binders binders + #:definites definites + #:shift-table shift-table)) (define/public (add-final stx error #:binders binders #:definites definites #:shift-table [shift-table #f]) (when stx - (send*: sbview sb:syntax-browser<%> + (send*/i sbview sb:syntax-browser<%> (add-text "Expansion finished\n") (add-syntax stx #:binders binders @@ -122,8 +117,8 @@ (define state (protostep-s1 step)) (define lctx (state-lctx state)) (for ([bf lctx]) - (send: sbview sb:syntax-browser<%> add-text - "\nwhile executing macro transformer in:\n") + (send/i sbview sb:syntax-browser<%> add-text + "\nwhile executing macro transformer in:\n") (insert-syntax/redex (bigframe-term bf) (bigframe-foci bf) (state-binders state) @@ -152,7 +147,7 @@ (show-lctx step shift-table))) (define/private (factor-common-context state1 state2) - (if (send: config config<%> get-split-context?) + (if (send/i config config<%> get-split-context?) (factor-common-context* state1 state2) (values null state1 state2))) @@ -179,7 +174,7 @@ (when (pair? ctx) (let* ([hole-stx #'~~HOLE~~] [the-syntax (context-fill ctx hole-stx)]) - (send*: sbview sb:syntax-browser<%> + (send*/i sbview sb:syntax-browser<%> (add-text "\nin context:\n") (add-syntax the-syntax #:definites uses1 @@ -220,26 +215,26 @@ (define state (protostep-s1 step)) (show-state/redex state shift-table) (separator step) - (send*: sbview sb:syntax-browser<%> + (send*/i sbview sb:syntax-browser<%> (add-error-text (exn-message (misstep-exn step))) (add-text "\n")) (when (exn:fail:syntax? (misstep-exn step)) (for ([e (exn:fail:syntax-exprs (misstep-exn step))]) - (send: sbview sb:syntax-browser<%> add-syntax e - #:binders (or (state-binders state) null) - #:definites (or (state-uses state) null) - #:shift-table shift-table))) + (send/i sbview sb:syntax-browser<%> add-syntax e + #:binders (or (state-binders state) null) + #:definites (or (state-uses state) null) + #:shift-table shift-table))) (show-lctx step shift-table)) (define/private (show-remarkstep step shift-table) (define state (protostep-s1 step)) (for ([content (in-list (remarkstep-contents step))]) (cond [(string? content) - (send*: sbview sb:syntax-browser<%> + (send*/i sbview sb:syntax-browser<%> (add-text content) (add-text "\n"))] [(syntax? content) - (send*: sbview sb:syntax-browser<%> + (send*/i sbview sb:syntax-browser<%> (add-syntax content #:binders (or (state-binders state) null) #:definites (or (state-uses state) null) @@ -250,16 +245,16 @@ ;; insert-syntax/color (define/private (insert-syntax/color stx foci binders shift-table definites frontier hi-color) - (define highlight-foci? (send: config config<%> get-highlight-foci?)) - (define highlight-frontier? (send: config config<%> get-highlight-frontier?)) - (send: sbview sb:syntax-browser<%> add-syntax stx - #:definites (or definites null) - #:binders binders - #:shift-table shift-table - #:hi-colors (list hi-color - "WhiteSmoke") - #:hi-stxss (list (if highlight-foci? foci null) - (if highlight-frontier? frontier null)))) + (define highlight-foci? (send/i config config<%> get-highlight-foci?)) + (define highlight-frontier? (send/i config config<%> get-highlight-frontier?)) + (send/i sbview sb:syntax-browser<%> add-syntax stx + #:definites (or definites null) + #:binders binders + #:shift-table shift-table + #:hi-colors (list hi-color + "WhiteSmoke") + #:hi-stxss (list (if highlight-foci? foci null) + (if highlight-frontier? frontier null)))) ;; insert-syntax/redex (define/private (insert-syntax/redex stx foci binders shift-table @@ -275,7 +270,7 @@ ;; insert-step-separator : string -> void (define/private (insert-step-separator text) - (send*: sbview sb:syntax-browser<%> + (send*/i sbview sb:syntax-browser<%> (add-text "\n ") (add-text (make-object image-snip% @@ -287,14 +282,14 @@ ;; insert-as-separator : string -> void (define/private (insert-as-separator text) - (send*: sbview sb:syntax-browser<%> + (send*/i sbview sb:syntax-browser<%> (add-text "\n ") (add-text text) (add-text "\n\n"))) ;; insert-step-separator/small : string -> void (define/private (insert-step-separator/small text) - (send*: sbview sb:syntax-browser<%> + (send*/i sbview sb:syntax-browser<%> (add-text " ") (add-text (make-object image-snip% diff --git a/collects/macro-debugger/view/stepper.rkt b/collects/macro-debugger/view/stepper.rkt index ec1edfb..bba35c7 100644 --- a/collects/macro-debugger/view/stepper.rkt +++ b/collects/macro-debugger/view/stepper.rkt @@ -1,29 +1,24 @@ -#lang scheme/base -(require scheme/class - (rename-in unstable/class-iop - [define/i define:] - [send/i send:] - [send*/i send*:] - [init-field/i init-field:]) - scheme/unit - scheme/list - scheme/match - scheme/gui - framework/framework - syntax/boundmap - "interfaces.ss" - "prefs.ss" - "extensions.ss" - "hiding-panel.ss" - "term-record.ss" - "step-display.ss" - (prefix-in sb: "../syntax-browser/interfaces.ss") - "../model/deriv.ss" - "../model/deriv-util.ss" - "../model/trace.ss" - "../model/reductions.ss" - "../model/steps.ss" - "cursor.ss" +#lang racket/base +(require racket/class + racket/unit + racket/list + racket/match + racket/gui + framework + unstable/class-iop + "interfaces.rkt" + "prefs.rkt" + "extensions.rkt" + "hiding-panel.rkt" + "term-record.rkt" + "step-display.rkt" + (prefix-in sb: "../syntax-browser/interfaces.rkt") + "../model/deriv.rkt" + "../model/deriv-util.rkt" + "../model/trace.rkt" + "../model/reductions.rkt" + "../model/steps.rkt" + "cursor.rkt" unstable/gui/notify (only-in mzscheme [#%top-interaction mz-top-interaction])) (provide macro-stepper-widget% @@ -36,7 +31,7 @@ (class* object% (widget<%>) (init-field parent) (init-field config) - (init-field: (director director<%>)) + (init-field/i (director director<%>)) ;; Terms @@ -69,7 +64,7 @@ (define/public (add trec) (set! all-terms (cons trec all-terms)) (let ([display-new-term? (cursor:at-end? terms)] - [invisible? (send: trec term-record<%> get-deriv-hidden?)]) + [invisible? (send/i trec term-record<%> get-deriv-hidden?)]) (unless invisible? (cursor:add-to-end! terms (list trec)) (trim-navigator) @@ -87,16 +82,16 @@ (define/public (show-in-new-frame) (let ([term (focused-term)]) (when term - (let ([new-stepper (send: director director<%> new-stepper '(no-new-traces))]) - (send: new-stepper widget<%> add-deriv (send: term term-record<%> get-raw-deriv)) + (let ([new-stepper (send/i director director<%> new-stepper '(no-new-traces))]) + (send/i new-stepper widget<%> add-deriv (send/i term term-record<%> get-raw-deriv)) (void))))) ;; duplicate-stepper : -> void (define/public (duplicate-stepper) - (let ([new-stepper (send: director director<%> new-stepper)]) + (let ([new-stepper (send/i director director<%> new-stepper)]) (for ([term (cursor->list terms)]) - (send: new-stepper widget<%> add-deriv - (send: term term-record<%> get-raw-deriv))))) + (send/i new-stepper widget<%> add-deriv + (send/i term term-record<%> get-raw-deriv))))) (define/public (get-config) config) (define/public (get-controller) sbc) @@ -105,7 +100,7 @@ (define/public (get-macro-hiding-prefs) macro-hiding-prefs) (define/public (reset-primary-partition) - (send: sbc sb:controller<%> reset-primary-partition) + (send/i sbc sb:controller<%> reset-primary-partition) (update/preserve-view)) (define area (new vertical-panel% (parent parent))) @@ -128,28 +123,28 @@ (alignment '(left center)) (style '(deleted)))) - (define: sbview sb:syntax-browser<%> + (define/i sbview sb:syntax-browser<%> (new stepper-syntax-widget% (parent area) (macro-stepper this))) - (define: step-displayer step-display<%> + (define/i step-displayer step-display<%> (new step-display% (config config) (syntax-widget sbview))) - (define: sbc sb:controller<%> - (send: sbview sb:syntax-browser<%> get-controller)) + (define/i sbc sb:controller<%> + (send/i sbview sb:syntax-browser<%> get-controller)) (define control-pane (new vertical-panel% (parent area) (stretchable-height #f))) - (define: macro-hiding-prefs hiding-prefs<%> + (define/i macro-hiding-prefs hiding-prefs<%> (new macro-hiding-prefs-widget% (parent control-pane) (stepper this) (config config))) - (send: sbc sb:controller<%> + (send/i sbc sb:controller<%> listen-selected-syntax - (lambda (stx) (send: macro-hiding-prefs hiding-prefs<%> set-syntax stx))) - (send*: config config<%> + (lambda (stx) (send/i macro-hiding-prefs hiding-prefs<%> set-syntax stx))) + (send*/i config config<%> (listen-show-hiding-panel? (lambda (show?) (show-macro-hiding-panel show?))) (listen-split-context? @@ -251,34 +246,34 @@ ;; Navigation #| (define/public-final (at-start?) - (send: (focused-term) term-record<%> at-start?)) + (send/i (focused-term) term-record<%> at-start?)) (define/public-final (at-end?) - (send: (focused-term) term-record<%> at-end?)) + (send/i (focused-term) term-record<%> at-end?)) |# (define/public-final (navigate-to-start) - (send: (focused-term) term-record<%> navigate-to-start) + (send/i (focused-term) term-record<%> navigate-to-start) (update/save-position)) (define/public-final (navigate-to-end) - (send: (focused-term) term-record<%> navigate-to-end) + (send/i (focused-term) term-record<%> navigate-to-end) (update/save-position)) (define/public-final (navigate-previous) - (send: (focused-term) term-record<%> navigate-previous) + (send/i (focused-term) term-record<%> navigate-previous) (update/save-position)) (define/public-final (navigate-next) - (send: (focused-term) term-record<%> navigate-next) + (send/i (focused-term) term-record<%> navigate-next) (update/save-position)) (define/public-final (navigate-to n) - (send: (focused-term) term-record<%> navigate-to n) + (send/i (focused-term) term-record<%> navigate-to n) (update/save-position)) (define/public-final (navigate-up) (when (focused-term) - (send: (focused-term) term-record<%> on-lose-focus)) + (send/i (focused-term) term-record<%> on-lose-focus)) (cursor:move-prev terms) (refresh/move)) (define/public-final (navigate-down) (when (focused-term) - (send: (focused-term) term-record<%> on-lose-focus)) + (send/i (focused-term) term-record<%> on-lose-focus)) (cursor:move-next terms) (refresh/move)) @@ -290,7 +285,7 @@ ;; update/preserve-lines-view : -> void (define/public (update/preserve-lines-view) - (define text (send: sbview sb:syntax-browser<%> get-text)) + (define text (send/i 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) @@ -303,7 +298,7 @@ ;; update/preserve-view : -> void (define/public (update/preserve-view) - (define text (send: sbview sb:syntax-browser<%> get-text)) + (define text (send/i 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) @@ -313,17 +308,17 @@ ;; update : -> void ;; Updates the terms in the syntax browser to the current step (define/private (update) - (define text (send: sbview sb:syntax-browser<%> get-text)) + (define text (send/i sbview sb:syntax-browser<%> get-text)) (define position-of-interest 0) (define multiple-terms? (> (length (cursor->list terms)) 1)) (send text begin-edit-sequence #f) - (send: sbview sb:syntax-browser<%> erase-all) + (send/i sbview sb:syntax-browser<%> erase-all) (update:show-prefix) - (when multiple-terms? (send: sbview sb:syntax-browser<%> add-separator)) + (when multiple-terms? (send/i sbview sb:syntax-browser<%> add-separator)) (set! position-of-interest (send text last-position)) (update:show-current-step) - (when multiple-terms? (send: sbview sb:syntax-browser<%> add-separator)) + (when multiple-terms? (send/i sbview sb:syntax-browser<%> add-separator)) (update:show-suffix) (send text end-edit-sequence) (send text scroll-to-position @@ -337,35 +332,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 term-record<%> display-final-term)) + (for-each (lambda (trec) (send/i 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) term-record<%> display-step))) + (send/i (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 term-record<%> display-initial-term)) + (send/i 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 term-record<%> get-step-index)))) + (and term (send/i 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 term-record<%> has-prev?))) - (send nav:previous enable (and term (send: term term-record<%> has-prev?))) - (send nav:next enable (and term (send: term term-record<%> has-next?))) - (send nav:end enable (and term (send: term term-record<%> has-next?))) + (send nav:start enable (and term (send/i term term-record<%> has-prev?))) + (send nav:previous enable (and term (send/i term term-record<%> has-prev?))) + (send nav:next enable (and term (send/i term term-record<%> has-next?))) + (send nav:end enable (and term (send/i 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))) @@ -375,14 +370,14 @@ ;; refresh/resynth : -> void ;; Macro hiding policy has changed; invalidate cached parts of trec (define/public (refresh/resynth) - (for-each (lambda (trec) (send: trec term-record<%> invalidate-synth!)) + (for-each (lambda (trec) (send/i 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 term-record<%> invalidate-steps!)) + (for-each (lambda (trec) (send/i trec term-record<%> invalidate-steps!)) (cursor->list terms)) (refresh)) @@ -394,11 +389,11 @@ ;; refresh : -> void (define/public (refresh) (when (focused-term) - (send: (focused-term) term-record<%> on-get-focus)) + (send/i (focused-term) term-record<%> on-get-focus)) (send nav:step-count set-label "") (let ([term (focused-term)]) (when term - (let ([step-count (send: term term-record<%> get-step-count)]) + (let ([step-count (send/i term term-record<%> get-step-count)]) (when step-count ;; +1 for end of expansion "step" (send nav:step-count set-label (format "of ~s" (add1 step-count))))))) @@ -409,7 +404,7 @@ ;; Hiding policy (define/public (get-show-macro?) - (send: macro-hiding-prefs hiding-prefs<%> get-policy)) + (send/i macro-hiding-prefs hiding-prefs<%> get-policy)) ;; Derivation pre-processing @@ -418,8 +413,8 @@ ;; Initialization (super-new) - (show-macro-hiding-panel (send: config config<%> get-show-hiding-panel?)) - (show-extra-navigation (send: config config<%> get-extra-navigation?)) + (show-macro-hiding-panel (send/i config config<%> get-show-hiding-panel?)) + (show-extra-navigation (send/i config config<%> get-extra-navigation?)) (refresh/move) )) diff --git a/collects/macro-debugger/view/term-record.rkt b/collects/macro-debugger/view/term-record.rkt index de47697..44d7a9c 100644 --- a/collects/macro-debugger/view/term-record.rkt +++ b/collects/macro-debugger/view/term-record.rkt @@ -1,33 +1,28 @@ -#lang scheme/base -(require scheme/class - (rename-in unstable/class-iop - [define/i define:] - [send/i send:] - [init-field/i init-field:]) - scheme/unit - scheme/list - scheme/match - scheme/gui - framework/framework - syntax/boundmap +#lang racket/base +(require racket/class + racket/unit + racket/list + racket/match + racket/gui + framework syntax/stx unstable/find - "interfaces.ss" - "prefs.ss" - "extensions.ss" - "warning.ss" - "hiding-panel.ss" - "step-display.ss" - "../model/deriv.ss" - "../model/deriv-util.ss" - "../model/deriv-parser.ss" - "../model/trace.ss" - "../model/reductions-config.ss" - "../model/reductions.ss" - "../model/steps.ss" + unstable/class-iop + "interfaces.rkt" + "prefs.rkt" + "extensions.rkt" + "hiding-panel.rkt" + "step-display.rkt" + "../model/deriv.rkt" + "../model/deriv-util.rkt" + "../model/deriv-parser.rkt" + "../model/trace.rkt" + "../model/reductions-config.rkt" + "../model/reductions.rkt" + "../model/steps.rkt" unstable/gui/notify - "cursor.ss" - "debug-format.ss") + "cursor.rkt" + "debug-format.rkt") (provide term-record%) @@ -35,12 +30,12 @@ (define term-record% (class* object% (term-record<%>) - (init-field: (stepper widget<%>)) + (init-field/i (stepper widget<%>)) - (define: config config<%> - (send: stepper widget<%> get-config)) - (define: displayer step-display<%> - (send: stepper widget<%> get-step-displayer)) + (define/i config config<%> + (send/i stepper widget<%> get-config)) + (define/i displayer step-display<%> + (send/i stepper widget<%> get-step-displayer)) ;; Data @@ -134,7 +129,7 @@ (unless (or deriv deriv-hidden?) (recache-raw-deriv!) (when raw-deriv - (let ([process (send: stepper widget<%> get-preprocess-deriv)]) + (let ([process (send/i stepper widget<%> get-preprocess-deriv)]) (let ([d (process raw-deriv)]) (when (not d) (set! deriv-hidden? #t)) @@ -151,7 +146,7 @@ (unless (or raw-steps raw-steps-oops) (recache-synth!) (when deriv - (let ([show-macro? (or (send: stepper widget<%> get-show-macro?) + (let ([show-macro? (or (send/i stepper widget<%> get-show-macro?) (lambda (id) #t))]) (with-handlers ([(lambda (e) #t) (lambda (e) @@ -173,12 +168,12 @@ (set! steps (and raw-steps (let* ([filtered-steps - (if (send: config config<%> get-show-rename-steps?) + (if (send/i config config<%> get-show-rename-steps?) raw-steps (filter (lambda (x) (not (rename-step? x))) raw-steps))] [processed-steps - (if (send: config config<%> get-one-by-one?) + (if (send/i config config<%> get-one-by-one?) (reduce:one-by-one filtered-steps) filtered-steps)]) (cursor:new processed-steps)))) @@ -280,21 +275,21 @@ ;; display-initial-term : -> void (define/public (display-initial-term) (cond [raw-deriv-oops - (send: displayer step-display<%> add-internal-error - "derivation" raw-deriv-oops #f events)] + (send/i displayer step-display<%> add-internal-error + "derivation" raw-deriv-oops #f events)] [else - (send: displayer step-display<%> add-syntax (wderiv-e1 deriv))])) + (send/i 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 step-display<%> add-syntax raw-steps-estx - #:binders raw-steps-binders - #:shift-table shift-table - #:definites raw-steps-definites)] + (send/i displayer step-display<%> add-syntax raw-steps-estx + #:binders raw-steps-binders + #:shift-table shift-table + #:definites raw-steps-definites)] [(exn? raw-steps-exn) - (send: displayer step-display<%> add-error raw-steps-exn)] + (send/i displayer step-display<%> add-error raw-steps-exn)] [else (display-oops #f)])) ;; display-step : -> void @@ -303,24 +298,24 @@ (cond [steps (let ([step (cursor:next steps)]) (if step - (send: displayer step-display<%> add-step step - #:shift-table shift-table) - (send: displayer step-display<%> add-final raw-steps-estx raw-steps-exn - #:binders raw-steps-binders - #:shift-table shift-table - #:definites raw-steps-definites)))] + (send/i displayer step-display<%> add-step step + #:shift-table shift-table) + (send/i displayer step-display<%> add-final raw-steps-estx raw-steps-exn + #:binders raw-steps-binders + #:shift-table shift-table + #:definites raw-steps-definites)))] [else (display-oops #t)])) ;; display-oops : boolean -> void (define/private (display-oops show-syntax?) (cond [raw-steps-oops - (send: displayer step-display<%> add-internal-error - "steps" raw-steps-oops - (and show-syntax? (wderiv-e1 deriv)) - events)] + (send/i displayer step-display<%> add-internal-error + "steps" raw-steps-oops + (and show-syntax? (wderiv-e1 deriv)) + events)] [raw-deriv-oops - (send: displayer step-display<%> add-internal-error - "derivation" raw-deriv-oops #f events)] + (send/i displayer step-display<%> add-internal-error + "derivation" raw-deriv-oops #f events)] [else (error 'term-record::display-oops "internal error")])) )) diff --git a/collects/macro-debugger/view/view.rkt b/collects/macro-debugger/view/view.rkt index 7162a98..4552b48 100644 --- a/collects/macro-debugger/view/view.rkt +++ b/collects/macro-debugger/view/view.rkt @@ -1,14 +1,13 @@ -#lang scheme/base -(require scheme/class - (rename-in unstable/class-iop - [send/i send:]) - scheme/pretty - scheme/gui - framework/framework - "interfaces.ss" - "frame.ss" - "prefs.ss" - "../model/trace.ss") +#lang racket/base +(require racket/class + racket/pretty + racket/gui + framework + unstable/class-iop + "interfaces.rkt" + "frame.rkt" + "prefs.rkt" + "../model/trace.rkt") (provide macro-stepper-director% macro-stepper-frame% go) @@ -28,23 +27,23 @@ (hash-for-each stepper-frames (lambda (stepper-frame flags) (unless (memq 'no-obsolete flags) - (send: stepper-frame stepper-frame<%> add-obsoleted-warning))))) + (send/i 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 stepper-frame<%> get-widget) widget<%> + (send/i (send/i 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 stepper-frame<%> get-widget) widget<%> + (send/i (send/i 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 stepper-frame<%> get-widget)) + (define stepper (send/i stepper-frame stepper-frame<%> get-widget)) (send stepper-frame show #t) (add-stepper! stepper-frame flags) stepper) @@ -65,6 +64,6 @@ (define (go stx) (define director (new macro-stepper-director%)) - (define stepper (send: director director<%> new-stepper)) - (send: director director<%> add-deriv (trace stx)) + (define stepper (send/i director director<%> new-stepper)) + (send/i director director<%> add-deriv (trace stx)) (void)) From bc306a09bd470a50eae40f26a837bd5e3e3fc7bb Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Thu, 1 Jul 2010 13:17:22 -0600 Subject: [PATCH 14/15] macro-stepper: fixed pretty-{printing => writing} original commit: 856dd4e14c7a076b98eca3604a4d8a92ff611ff2 --- collects/macro-debugger/syntax-browser/pretty-helper.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/macro-debugger/syntax-browser/pretty-helper.rkt b/collects/macro-debugger/syntax-browser/pretty-helper.rkt index 7a4ae10..1f58acf 100644 --- a/collects/macro-debugger/syntax-browser/pretty-helper.rkt +++ b/collects/macro-debugger/syntax-browser/pretty-helper.rkt @@ -31,7 +31,7 @@ [print-vector-length #f] [print-hash-table #t] [print-honu #f]) - (pretty-print datum port))) + (pretty-write datum port))) (define-struct syntax-dummy (val)) (define-struct (id-syntax-dummy syntax-dummy) (remap)) From 803cc3ec82a44c0669d3c57c5865c1e3a35b602c Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Thu, 1 Jul 2010 13:18:58 -0600 Subject: [PATCH 15/15] macro-stepper: removed unnecessary partition code downgraded secondary "partition" to simple binary predicate original commit: f6f480053eefb840bf723a4c55fa96729d4c4c00 --- .../syntax-browser/controller.rkt | 16 +-- .../macro-debugger/syntax-browser/display.rkt | 20 +-- .../syntax-browser/interfaces.rkt | 12 +- .../syntax-browser/partition.rkt | 116 +----------------- 4 files changed, 23 insertions(+), 141 deletions(-) diff --git a/collects/macro-debugger/syntax-browser/controller.rkt b/collects/macro-debugger/syntax-browser/controller.rkt index 82a2d06..c5facda 100644 --- a/collects/macro-debugger/syntax-browser/controller.rkt +++ b/collects/macro-debugger/syntax-browser/controller.rkt @@ -48,26 +48,20 @@ (define/public-final (reset-primary-partition) (set! primary-partition (new-bound-partition))))) -;; secondary-partition-mixin -(define secondary-partition-mixin - (mixin (displays-manager<%>) (secondary-partition<%>) +;; secondary-relation-mixin +(define secondary-relation-mixin + (mixin (displays-manager<%>) (secondary-relation<%>) (inherit-field displays) (define-notify identifier=? (new notify-box% (value #f))) - (define-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 ([d displays]) + (for ([d (in-list displays)]) (send/i d display<%> refresh)))) (super-new))) (define controller% - (class* (secondary-partition-mixin + (class* (secondary-relation-mixin (selection-manager-mixin (mark-manager-mixin (displays-manager-mixin diff --git a/collects/macro-debugger/syntax-browser/display.rkt b/collects/macro-debugger/syntax-browser/display.rkt index e0a7da0..bc3b1ff 100644 --- a/collects/macro-debugger/syntax-browser/display.rkt +++ b/collects/macro-debugger/syntax-browser/display.rkt @@ -111,7 +111,7 @@ (let ([selected-syntax (send/i controller selection-manager<%> get-selected-syntax)]) - (apply-secondary-partition-styles selected-syntax) + (apply-secondary-relation-styles selected-syntax) (apply-selection-styles selected-syntax)) (send* text (end-edit-sequence)))) @@ -199,18 +199,18 @@ (for ([style-delta style-deltas]) (restyle-range r style-delta))))) - ;; apply-secondary-partition-styles : selected-syntax -> void + ;; apply-secondary-relation-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) + ;; in the relation with it. + (define/private (apply-secondary-relation-styles selected-syntax) (when (identifier? selected-syntax) - (let ([partition - (send/i controller secondary-partition<%> - get-secondary-partition)]) - (when partition + (let* ([name+relation + (send/i controller secondary-relation<%> + get-identifier=?)] + [relation (and name+relation (cdr name+relation))]) + (when relation (for ([id (send/i range range<%> get-identifier-list)]) - (when (send/i partition partition<%> - same-partition? selected-syntax id) + (when (relation selected-syntax id) (draw-secondary-connection id))))))) ;; apply-selection-styles : syntax -> void diff --git a/collects/macro-debugger/syntax-browser/interfaces.rkt b/collects/macro-debugger/syntax-browser/interfaces.rkt index 5f057ba..9d04748 100644 --- a/collects/macro-debugger/syntax-browser/interfaces.rkt +++ b/collects/macro-debugger/syntax-browser/interfaces.rkt @@ -61,18 +61,16 @@ ;; reset-primary-partition : -> void reset-primary-partition)) -;; secondary-partition<%> -(define-interface secondary-partition<%> () - (;; secondary-partition : notify-box of partition<%> - ;; identifier=? : notify-box of (cons string procedure) - (methods:notify secondary-partition - identifier=?))) +;; secondary-relation<%> +(define-interface secondary-relation<%> () + (;; identifier=? : notify-box of (cons string (U #f (id id -> bool))) + (methods:notify identifier=?))) ;; controller<%> (define-interface controller<%> (displays-manager<%> selection-manager<%> mark-manager<%> - secondary-partition<%>) + secondary-relation<%>) ()) diff --git a/collects/macro-debugger/syntax-browser/partition.rkt b/collects/macro-debugger/syntax-browser/partition.rkt index b99cec0..35f662d 100644 --- a/collects/macro-debugger/syntax-browser/partition.rkt +++ b/collects/macro-debugger/syntax-browser/partition.rkt @@ -4,77 +4,11 @@ "interfaces.rkt" "../util/stxobj.rkt") (provide new-bound-partition - partition% identifier=-choices) (define (new-bound-partition) (new bound-partition%)) -;; representative-symbol : symbol -;; Must be fresh---otherwise, using it could detect rename wraps -;; instead of only marks. -;; For example, in (lambda (representative) representative) -(define representative-symbol - (gensym 'representative)) - -;; unmarked-syntax : identifier -;; Has no marks---used to initialize bound partition so that -;; unmarked syntax always gets colored "black" -(define unmarked-syntax - (datum->syntax #f representative-symbol)) - -(define partition% - (class* object% (partition<%>) - (init relation) - - (define related? (or relation (lambda (a b) #f))) - (field (rep=>num (make-hasheq))) - (field (obj=>rep (make-weak-hasheq))) - (field (reps null)) - (field (next-num 0)) - - (define/public (get-partition obj) - (rep->partition (obj->rep obj))) - - (define/public (same-partition? A B) - (= (get-partition A) (get-partition B))) - - (define/private (obj->rep obj) - (hash-ref obj=>rep obj (lambda () (obj->rep* obj)))) - - (define/public (count) - next-num) - - (define/private (obj->rep* obj) - (let loop ([reps reps]) - (cond [(null? reps) - (new-rep obj)] - [(related? obj (car reps)) - (hash-set! obj=>rep obj (car reps)) - (car reps)] - [else - (loop (cdr reps))]))) - - (define/private (new-rep rep) - (hash-set! rep=>num rep next-num) - (set! next-num (add1 next-num)) - (set! reps (cons rep reps)) - rep) - - (define/private (rep->partition rep) - (hash-ref rep=>num rep)) - - ;; Nearly useless as it stands - (define/public (dump) - (hash-for-each - rep=>num - (lambda (k v) - (printf "~s => ~s~n" k v)))) - - (get-partition unmarked-syntax) - (super-new) - )) - ;; bound-partition% (define bound-partition% (class* object% (partition<%>) @@ -99,57 +33,13 @@ (define/public (count) next-number) - (get-partition unmarked-syntax) + (get-partition (datum->syntax #f 'nowhere)) (super-new))) -;; Different identifier relations for highlighting. - -(define (lift/rep id=?) - (lambda (A B) - (let ([ra (datum->syntax A representative-symbol)] - [rb (datum->syntax B representative-symbol)]) - (id=? ra rb)))) - -(define (lift id=?) - (lambda (A B) - (and (identifier? A) (identifier? B) (id=? A B)))) - -;; id:same-marks? : syntax syntax -> boolean -(define id:same-marks? - (lift/rep bound-identifier=?)) - -;; id:X-module=? : identifier identifier -> boolean -;; If both module-imported, do they come from the same module? -;; If both top-bound, then same source. -(define (id:source-module=? a b) - (let ([ba (identifier-binding a)] - [bb (identifier-binding b)]) - (cond [(or (eq? 'lexical ba) (eq? 'lexical bb)) - (free-identifier=? a b)] - [(and (not ba) (not bb)) - #t] - [(or (not ba) (not bb)) - #f] - [else - (eq? (car ba) (car bb))]))) -(define (id:nominal-module=? A B) - (let ([ba (identifier-binding A)] - [bb (identifier-binding B)]) - (cond [(or (eq? 'lexical ba) (eq? 'lexical bb)) - (free-identifier=? A B)] - [(or (not ba) (not bb)) - (and (not ba) (not bb))] - [else (eq? (caddr ba) (caddr bb))]))) - -(define (symbolic-identifier=? A B) - (eq? (syntax-e A) (syntax-e B))) +;; ==== Identifier relations ==== (define identifier=-choices (make-parameter `(("" . #f) ("bound-identifier=?" . ,bound-identifier=?) - ("free-identifier=?" . ,free-identifier=?) - ("module-or-top-identifier=?" . ,module-or-top-identifier=?) - ("symbolic-identifier=?" . ,symbolic-identifier=?) - ("same source module" . ,id:source-module=?) - ("same nominal module" . ,id:nominal-module=?)))) + ("free-identifier=?" . ,free-identifier=?))))