From ae1e6ca26369632f3695ab15c5eb0efc3ba531d3 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 14 Jan 2009 18:05:21 +0000 Subject: [PATCH 01/13] fixed an x/y reversal bug and improved the #:layout function so it isn't called as much svn: r13116 --- collects/redex/private/traces.ss | 23 ++++++++++++++--------- collects/redex/redex.scrbl | 8 +++++--- 2 files changed, 19 insertions(+), 12 deletions(-) diff --git a/collects/redex/private/traces.ss b/collects/redex/private/traces.ss index af80b79bab..e11d7d5141 100644 --- a/collects/redex/private/traces.ss +++ b/collects/redex/private/traces.ss @@ -86,7 +86,7 @@ (λ (ed) (let ([yb (box 0)] [snip (term-node-snip term-node)]) - (if (send ed get-snip-location snip yb #f #f) + (if (send ed get-snip-location snip #f yb #f) (unbox yb) 0))))) @@ -145,7 +145,7 @@ (define (print-to-ps graph-pb filename) (let ([admin (send graph-pb get-admin)] - [printing-admin (new printing-editor-admin%)]) + [printing-admin (new printing-editor-admin% [ed graph-pb])]) (send graph-pb set-admin printing-admin) (dynamic-wind @@ -153,7 +153,7 @@ (λ () (let loop ([snip (send graph-pb find-first-snip)]) (when snip - (send snip size-cache-invalid) + (send (send snip get-admin) resized snip #t) (loop (send snip next)))) (send graph-pb invalidate-bitmap-cache) @@ -179,6 +179,8 @@ (define printing-editor-admin% (class editor-admin% + (init-field ed) + (define temp-file (make-temporary-file "redex-size-snip-~a")) (define ps-dc @@ -270,7 +272,7 @@ "Reducing..." lower-panel (lambda (x y) - (reduce-button-callback)))) + (reduce-button-callback #f)))) (define status-message (instantiate message% () (label "") (parent lower-panel) @@ -411,7 +413,6 @@ (set! col (+ x-spacing (find-rightmost-x graph-pb)))) (begin0 (insert-into col y graph-pb new-snips) - (send graph-pb re-run-layout) (send graph-pb end-edit-sequence) (send status-message set-label (string-append (term-count (count-snips)) "...")))))]) @@ -455,9 +456,10 @@ (send reduce-button enable #t) (send font-size enable #t)) - ;; reduce-button-callback : -> void + ;; reduce-button-callback : boolean -> void ;; =eventspace main thread= - (define (reduce-button-callback) + (define (reduce-button-callback show-all-at-once?) + (when show-all-at-once? (send graph-pb begin-edit-sequence)) (send reduce-button enable #f) (send reduce-button set-label "Reducing...") (thread @@ -465,6 +467,10 @@ (do-some-reductions) (queue-callback (lambda () ;; =eventspace main thread= + (send graph-pb begin-edit-sequence) + (send graph-pb re-run-layout) + (send graph-pb end-edit-sequence) + (when show-all-at-once? (send graph-pb end-edit-sequence)) (scroll-to-rightmost-snip) (send reduce-button set-label "Reduce") (cond @@ -542,7 +548,6 @@ null))) (out-of-dot-state) ;; make sure the state is initialized right (insert-into init-rightmost-x 0 graph-pb frontier) - (send graph-pb re-run-layout) (set-font-size (initial-font-size)) (cond [no-show-frame? @@ -553,7 +558,7 @@ (yield s)) (values graph-pb f)] [else - (reduce-button-callback) + (reduce-button-callback #t) (send f show #t)])) (define red-sem-frame% diff --git a/collects/redex/redex.scrbl b/collects/redex/redex.scrbl index 19fb18d782..b02ee88aef 100644 --- a/collects/redex/redex.scrbl +++ b/collects/redex/redex.scrbl @@ -1218,9 +1218,11 @@ The @scheme[scheme-colors?] argument, if @scheme[#t] causes to DrScheme's Scheme mode color Scheme. If it is @scheme[#f], @scheme[traces] just uses black for the color scheme. -The @scheme[layout] argument is called (with all of the terms) each -time a new term is inserted into the window. See also -@scheme[term-node-set-position!]. +The @scheme[layout] argument is called (with all of the terms) when +new terms is inserted into the window. In general, it is called when +after new terms are inserted in response to the user clicking on the +reduce button, and after the initial set of terms is inserted. +See also @scheme[term-node-set-position!]. You can save the contents of the window as a postscript file from the menus. From 8f3547e3116a2ae5b2efec9f72199f8cef64e047 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 14 Jan 2009 18:21:55 +0000 Subject: [PATCH 02/13] added code to remove the graph-pb from the canvas while printing svn: r13117 --- collects/redex/private/traces.ss | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/collects/redex/private/traces.ss b/collects/redex/private/traces.ss index e11d7d5141..070bec528b 100644 --- a/collects/redex/private/traces.ss +++ b/collects/redex/private/traces.ss @@ -132,7 +132,7 @@ #:scheme-colors? [scheme-colors? #t] #:colors [colors '()] #:layout [layout void]) - (let-values ([(graph-pb frame) + (let-values ([(graph-pb canvas) (traces reductions pre-exprs #:no-show-frame? #t #:multiple? multiple? @@ -141,11 +141,12 @@ #:scheme-colors? scheme-colors? #:colors colors #:layout layout)]) - (print-to-ps graph-pb filename))) + (print-to-ps graph-pb canvas filename))) -(define (print-to-ps graph-pb filename) +(define (print-to-ps graph-pb canvas filename) (let ([admin (send graph-pb get-admin)] [printing-admin (new printing-editor-admin% [ed graph-pb])]) + (send canvas set-editor #f) (send graph-pb set-admin printing-admin) (dynamic-wind @@ -168,6 +169,7 @@ (λ () (send graph-pb set-admin admin) + (send canvas set-editor graph-pb) (send printing-admin shutdown) ;; do this early (let loop ([snip (send graph-pb find-first-snip)]) (when snip @@ -556,7 +558,7 @@ (do-some-reductions) (semaphore-post s))) (yield s)) - (values graph-pb f)] + (values graph-pb ec)] [else (reduce-button-callback #t) (send f show #t)])) From 074be235b4427530b4967fcc898fc4a1860229e5 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 14 Jan 2009 19:26:03 +0000 Subject: [PATCH 03/13] fixed a bug svn: r13119 --- collects/redex/private/traces.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/redex/private/traces.ss b/collects/redex/private/traces.ss index 070bec528b..4ac5cca69d 100644 --- a/collects/redex/private/traces.ss +++ b/collects/redex/private/traces.ss @@ -549,8 +549,8 @@ (list bottom-panel) null))) (out-of-dot-state) ;; make sure the state is initialized right + (set-font-size (initial-font-size)) ;; have to call this before 'insert-into' or else it triggers resizing (insert-into init-rightmost-x 0 graph-pb frontier) - (set-font-size (initial-font-size)) (cond [no-show-frame? (let ([s (make-semaphore)]) From cf2e98eb921d2e0f7c6acb87e19d966af933a72c Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 14 Jan 2009 20:29:37 +0000 Subject: [PATCH 04/13] size-cache-invalid for editor<%> svn: r13120 --- collects/mred/private/kernel.ss | 3 ++ collects/redex/examples/arithmetic.ss | 3 +- collects/redex/private/traces.ss | 11 ++-- collects/scribblings/gui/editor-intf.scrbl | 16 +++++- src/mred/wxs/wxs_mbuf.xci | 1 + src/mred/wxs/wxs_mede.cxx | 61 +++++++++++++++++++++- src/mred/wxs/wxs_mpb.cxx | 61 +++++++++++++++++++++- 7 files changed, 145 insertions(+), 11 deletions(-) diff --git a/collects/mred/private/kernel.ss b/collects/mred/private/kernel.ss index e21bfd92ae..f448c6787f 100644 --- a/collects/mred/private/kernel.ss +++ b/collects/mred/private/kernel.ss @@ -240,6 +240,7 @@ can-save-file? on-new-box on-new-image-snip + size-cache-invalid invalidate-bitmap-cache on-paint write-footers-to-file @@ -921,6 +922,7 @@ can-save-file? on-new-box on-new-image-snip + size-cache-invalid invalidate-bitmap-cache on-paint write-footers-to-file @@ -1133,6 +1135,7 @@ can-save-file? on-new-box on-new-image-snip + size-cache-invalid invalidate-bitmap-cache on-paint write-footers-to-file diff --git a/collects/redex/examples/arithmetic.ss b/collects/redex/examples/arithmetic.ss index a9015b32d2..7c8ee28f80 100644 --- a/collects/redex/examples/arithmetic.ss +++ b/collects/redex/examples/arithmetic.ss @@ -38,4 +38,5 @@ [(--> (in-hole e-ctxt_1 a) (in-hole e-ctxt_1 b)) (c--> a b)])) -(traces reductions (term (- (* (sqrt 36) (/ 1 2)) (+ 1 2)))) +(traces/ps reductions (term (- (* (sqrt 36) (/ 1 2)) (+ 1 2))) + "/home/mflatt/Desktop/p.ps") diff --git a/collects/redex/private/traces.ss b/collects/redex/private/traces.ss index 4ac5cca69d..4098ff0f78 100644 --- a/collects/redex/private/traces.ss +++ b/collects/redex/private/traces.ss @@ -152,11 +152,7 @@ (dynamic-wind void (λ () - (let loop ([snip (send graph-pb find-first-snip)]) - (when snip - (send (send snip get-admin) resized snip #t) - (loop (send snip next)))) - (send graph-pb invalidate-bitmap-cache) + (send graph-pb size-cache-invalid) (send graph-pb re-run-layout) @@ -175,7 +171,7 @@ (when snip (send snip size-cache-invalid) (loop (send snip next)))) - (send graph-pb invalidate-bitmap-cache) + (send graph-pb size-cache-invalid) (send graph-pb re-run-layout))))) (define printing-editor-admin% @@ -208,7 +204,8 @@ (define/override (get-max-view x y w h [full? #f]) (get-view x y w h full?)) (define/override (get-view x y w h [full? #f]) - (super get-view x y w h full?) + (when x (set-box! x 0.0)) + (when y (set-box! x 0.0)) (when (box? w) (set-box! w 500)) (when (box? h) (set-box! h 500))) diff --git a/collects/scribblings/gui/editor-intf.scrbl b/collects/scribblings/gui/editor-intf.scrbl index 3b4cff2df2..0b4e7714e9 100644 --- a/collects/scribblings/gui/editor-intf.scrbl +++ b/collects/scribblings/gui/editor-intf.scrbl @@ -1015,7 +1015,7 @@ The default implementation triggers a redraw of the editor, either immediately or at the end of the current edit sequence (if any) started by @method[editor<%> begin-edit-sequence]. -} +See also @method[editor<%> size-cache-invalid].} @defmethod[(is-locked?) @@ -2322,6 +2322,20 @@ Setting the style list is disallowed when the editor is internally } +@defmethod[(size-cache-invalid) + void?]{ + +This method is called when the drawing context given to the editor by +its administrator changes in a way that makes cached size information +(such as the width of a string) invalid. + +The default implementation eventually propagates the message to snips, +and, more generally, causes @tech{location} information to be +recalculated on demand. + +See also @method[editor<%> invalidate-bitmap-cache].} + + @defmethod[(style-has-changed [style (or/c (is-a?/c style<%>) false/c)]) void?]{ diff --git a/src/mred/wxs/wxs_mbuf.xci b/src/mred/wxs/wxs_mbuf.xci index b7c06d91b0..ac8d912ae7 100644 --- a/src/mred/wxs/wxs_mbuf.xci +++ b/src/mred/wxs/wxs_mbuf.xci @@ -73,6 +73,7 @@ @ Z "on-paint" : void OnPaint(bool,wxDC!,double,double,double,double,double,double,SYM[caret]); : : /CHECKDCOK[1.METHODNAME("editor<%>","on-paint")] @ Y "invalidate-bitmap-cache" : void InvalidateBitmapCache(double=0.0,double=0.0,nnfs[end]=-1.0,nnfs[end]=-1.0); +@ Y "size-cache-invalid" : void SizeCacheInvalid(); @ Z "on-new-image-snip" : wxImageSnip! OnNewImageSnip(nxpathname,SYM[bitmapType],bool,bool); @ Z "on-new-box" : wxSnip! OnNewBox(SYM[bufferType]); diff --git a/src/mred/wxs/wxs_mede.cxx b/src/mred/wxs/wxs_mede.cxx index 18c4dff967..a81ace7f7d 100644 --- a/src/mred/wxs/wxs_mede.cxx +++ b/src/mred/wxs/wxs_mede.cxx @@ -1015,6 +1015,7 @@ class os_wxMediaEdit : public wxMediaEdit { Bool CanSaveFile(epathname x0, int x1); class wxSnip* OnNewBox(int x0); class wxImageSnip* OnNewImageSnip(nxpathname x0, int x1, Bool x2, Bool x3); + void SizeCacheInvalid(); void InvalidateBitmapCache(double x0 = 0.0, double x1 = 0.0, double x2 = -1.0, double x3 = -1.0); void OnPaint(Bool x0, class wxDC* x1, double x2, double x3, double x4, double x5, double x6, double x7, int x8); Bool WriteFootersToFile(class wxMediaStreamOut* x0); @@ -2469,6 +2470,40 @@ class wxImageSnip* os_wxMediaEdit::OnNewImageSnip(nxpathname x0, int x1, Bool x2 } } +static Scheme_Object *os_wxMediaEditSizeCacheInvalid(int n, Scheme_Object *p[]); + +void os_wxMediaEdit::SizeCacheInvalid() +{ + Scheme_Object *p[POFFSET+0] INIT_NULLED_ARRAY({ NULLED_OUT }); + Scheme_Object *v; + Scheme_Object *method INIT_NULLED_OUT; +#ifdef MZ_PRECISE_GC + os_wxMediaEdit *sElF = this; +#endif + static void *mcache = 0; + + SETUP_VAR_STACK(5); + VAR_STACK_PUSH(0, method); + VAR_STACK_PUSH(1, sElF); + VAR_STACK_PUSH_ARRAY(2, p, POFFSET+0); + SET_VAR_STACK(); + + method = objscheme_find_method((Scheme_Object *) ASSELF __gc_external, os_wxMediaEdit_class, "size-cache-invalid", &mcache); + if (!method || OBJSCHEME_PRIM_METHOD(method, os_wxMediaEditSizeCacheInvalid)) { + SET_VAR_STACK(); + READY_TO_RETURN; ASSELF wxMediaEdit::SizeCacheInvalid(); + } else { + + + p[0] = (Scheme_Object *) ASSELF __gc_external; + + v = WITH_VAR_STACK(scheme_apply(method, POFFSET+0, p)); + + + READY_TO_RETURN; + } +} + static Scheme_Object *os_wxMediaEditInvalidateBitmapCache(int n, Scheme_Object *p[]); void os_wxMediaEdit::InvalidateBitmapCache(double x0, double x1, double x2, double x3) @@ -7673,6 +7708,29 @@ static Scheme_Object *os_wxMediaEditOnNewImageSnip(int n, Scheme_Object *p[]) return WITH_REMEMBERED_STACK(objscheme_bundle_wxImageSnip(r)); } +static Scheme_Object *os_wxMediaEditSizeCacheInvalid(int n, Scheme_Object *p[]) +{ + WXS_USE_ARGUMENT(n) WXS_USE_ARGUMENT(p) + REMEMBER_VAR_STACK(); + objscheme_check_valid(os_wxMediaEdit_class, "size-cache-invalid in text%", n, p); + + SETUP_VAR_STACK_REMEMBERED(1); + VAR_STACK_PUSH(0, p); + + + + + if (((Scheme_Class_Object *)p[0])->primflag) + WITH_VAR_STACK(((os_wxMediaEdit *)((Scheme_Class_Object *)p[0])->primdata)->wxMediaEdit::SizeCacheInvalid()); + else + WITH_VAR_STACK(((wxMediaEdit *)((Scheme_Class_Object *)p[0])->primdata)->SizeCacheInvalid()); + + + + READY_TO_RETURN; + return scheme_void; +} + static Scheme_Object *os_wxMediaEditInvalidateBitmapCache(int n, Scheme_Object *p[]) { WXS_USE_ARGUMENT(n) WXS_USE_ARGUMENT(p) @@ -8778,7 +8836,7 @@ void objscheme_setup_wxMediaEdit(Scheme_Env *env) wxREGGLOB(os_wxMediaEdit_class); - os_wxMediaEdit_class = WITH_VAR_STACK(objscheme_def_prim_class(env, "text%", "editor%", (Scheme_Method_Prim *)os_wxMediaEdit_ConstructScheme, 153)); + os_wxMediaEdit_class = WITH_VAR_STACK(objscheme_def_prim_class(env, "text%", "editor%", (Scheme_Method_Prim *)os_wxMediaEdit_ConstructScheme, 154)); WITH_VAR_STACK(scheme_add_method_w_arity(os_wxMediaEdit_class, "call-clickback" " method", (Scheme_Method_Prim *)os_wxMediaEditCallClickback, 2, 2)); WITH_VAR_STACK(scheme_add_method_w_arity(os_wxMediaEdit_class, "remove-clickback" " method", (Scheme_Method_Prim *)os_wxMediaEditRemoveClickback, 2, 2)); @@ -8896,6 +8954,7 @@ void objscheme_setup_wxMediaEdit(Scheme_Env *env) WITH_VAR_STACK(scheme_add_method_w_arity(os_wxMediaEdit_class, "can-save-file?" " method", (Scheme_Method_Prim *)os_wxMediaEditCanSaveFile, 2, 2)); WITH_VAR_STACK(scheme_add_method_w_arity(os_wxMediaEdit_class, "on-new-box" " method", (Scheme_Method_Prim *)os_wxMediaEditOnNewBox, 1, 1)); WITH_VAR_STACK(scheme_add_method_w_arity(os_wxMediaEdit_class, "on-new-image-snip" " method", (Scheme_Method_Prim *)os_wxMediaEditOnNewImageSnip, 4, 4)); + WITH_VAR_STACK(scheme_add_method_w_arity(os_wxMediaEdit_class, "size-cache-invalid" " method", (Scheme_Method_Prim *)os_wxMediaEditSizeCacheInvalid, 0, 0)); WITH_VAR_STACK(scheme_add_method_w_arity(os_wxMediaEdit_class, "invalidate-bitmap-cache" " method", (Scheme_Method_Prim *)os_wxMediaEditInvalidateBitmapCache, 0, 4)); WITH_VAR_STACK(scheme_add_method_w_arity(os_wxMediaEdit_class, "on-paint" " method", (Scheme_Method_Prim *)os_wxMediaEditOnPaint, 9, 9)); WITH_VAR_STACK(scheme_add_method_w_arity(os_wxMediaEdit_class, "write-footers-to-file" " method", (Scheme_Method_Prim *)os_wxMediaEditWriteFootersToFile, 1, 1)); diff --git a/src/mred/wxs/wxs_mpb.cxx b/src/mred/wxs/wxs_mpb.cxx index fb729fa307..e61d08798e 100644 --- a/src/mred/wxs/wxs_mpb.cxx +++ b/src/mred/wxs/wxs_mpb.cxx @@ -436,6 +436,7 @@ class os_wxMediaPasteboard : public wxMediaPasteboard { Bool CanSaveFile(epathname x0, int x1); class wxSnip* OnNewBox(int x0); class wxImageSnip* OnNewImageSnip(nxpathname x0, int x1, Bool x2, Bool x3); + void SizeCacheInvalid(); void InvalidateBitmapCache(double x0 = 0.0, double x1 = 0.0, double x2 = -1.0, double x3 = -1.0); void OnPaint(Bool x0, class wxDC* x1, double x2, double x3, double x4, double x5, double x6, double x7, int x8); Bool WriteFootersToFile(class wxMediaStreamOut* x0); @@ -2217,6 +2218,40 @@ class wxImageSnip* os_wxMediaPasteboard::OnNewImageSnip(nxpathname x0, int x1, B } } +static Scheme_Object *os_wxMediaPasteboardSizeCacheInvalid(int n, Scheme_Object *p[]); + +void os_wxMediaPasteboard::SizeCacheInvalid() +{ + Scheme_Object *p[POFFSET+0] INIT_NULLED_ARRAY({ NULLED_OUT }); + Scheme_Object *v; + Scheme_Object *method INIT_NULLED_OUT; +#ifdef MZ_PRECISE_GC + os_wxMediaPasteboard *sElF = this; +#endif + static void *mcache = 0; + + SETUP_VAR_STACK(5); + VAR_STACK_PUSH(0, method); + VAR_STACK_PUSH(1, sElF); + VAR_STACK_PUSH_ARRAY(2, p, POFFSET+0); + SET_VAR_STACK(); + + method = objscheme_find_method((Scheme_Object *) ASSELF __gc_external, os_wxMediaPasteboard_class, "size-cache-invalid", &mcache); + if (!method || OBJSCHEME_PRIM_METHOD(method, os_wxMediaPasteboardSizeCacheInvalid)) { + SET_VAR_STACK(); + READY_TO_RETURN; ASSELF wxMediaPasteboard::SizeCacheInvalid(); + } else { + + + p[0] = (Scheme_Object *) ASSELF __gc_external; + + v = WITH_VAR_STACK(scheme_apply(method, POFFSET+0, p)); + + + READY_TO_RETURN; + } +} + static Scheme_Object *os_wxMediaPasteboardInvalidateBitmapCache(int n, Scheme_Object *p[]); void os_wxMediaPasteboard::InvalidateBitmapCache(double x0, double x1, double x2, double x3) @@ -5718,6 +5753,29 @@ static Scheme_Object *os_wxMediaPasteboardOnNewImageSnip(int n, Scheme_Object * return WITH_REMEMBERED_STACK(objscheme_bundle_wxImageSnip(r)); } +static Scheme_Object *os_wxMediaPasteboardSizeCacheInvalid(int n, Scheme_Object *p[]) +{ + WXS_USE_ARGUMENT(n) WXS_USE_ARGUMENT(p) + REMEMBER_VAR_STACK(); + objscheme_check_valid(os_wxMediaPasteboard_class, "size-cache-invalid in pasteboard%", n, p); + + SETUP_VAR_STACK_REMEMBERED(1); + VAR_STACK_PUSH(0, p); + + + + + if (((Scheme_Class_Object *)p[0])->primflag) + WITH_VAR_STACK(((os_wxMediaPasteboard *)((Scheme_Class_Object *)p[0])->primdata)->wxMediaPasteboard::SizeCacheInvalid()); + else + WITH_VAR_STACK(((wxMediaPasteboard *)((Scheme_Class_Object *)p[0])->primdata)->SizeCacheInvalid()); + + + + READY_TO_RETURN; + return scheme_void; +} + static Scheme_Object *os_wxMediaPasteboardInvalidateBitmapCache(int n, Scheme_Object *p[]) { WXS_USE_ARGUMENT(n) WXS_USE_ARGUMENT(p) @@ -6999,7 +7057,7 @@ void objscheme_setup_wxMediaPasteboard(Scheme_Env *env) wxREGGLOB(os_wxMediaPasteboard_class); - os_wxMediaPasteboard_class = WITH_VAR_STACK(objscheme_def_prim_class(env, "pasteboard%", "editor%", (Scheme_Method_Prim *)os_wxMediaPasteboard_ConstructScheme, 115)); + os_wxMediaPasteboard_class = WITH_VAR_STACK(objscheme_def_prim_class(env, "pasteboard%", "editor%", (Scheme_Method_Prim *)os_wxMediaPasteboard_ConstructScheme, 116)); WITH_VAR_STACK(scheme_add_method_w_arity(os_wxMediaPasteboard_class, "set-scroll-step" " method", (Scheme_Method_Prim *)os_wxMediaPasteboardSetScrollStep, 1, 1)); WITH_VAR_STACK(scheme_add_method_w_arity(os_wxMediaPasteboard_class, "get-scroll-step" " method", (Scheme_Method_Prim *)os_wxMediaPasteboardGetScrollStep, 0, 0)); @@ -7072,6 +7130,7 @@ void objscheme_setup_wxMediaPasteboard(Scheme_Env *env) WITH_VAR_STACK(scheme_add_method_w_arity(os_wxMediaPasteboard_class, "can-save-file?" " method", (Scheme_Method_Prim *)os_wxMediaPasteboardCanSaveFile, 2, 2)); WITH_VAR_STACK(scheme_add_method_w_arity(os_wxMediaPasteboard_class, "on-new-box" " method", (Scheme_Method_Prim *)os_wxMediaPasteboardOnNewBox, 1, 1)); WITH_VAR_STACK(scheme_add_method_w_arity(os_wxMediaPasteboard_class, "on-new-image-snip" " method", (Scheme_Method_Prim *)os_wxMediaPasteboardOnNewImageSnip, 4, 4)); + WITH_VAR_STACK(scheme_add_method_w_arity(os_wxMediaPasteboard_class, "size-cache-invalid" " method", (Scheme_Method_Prim *)os_wxMediaPasteboardSizeCacheInvalid, 0, 0)); WITH_VAR_STACK(scheme_add_method_w_arity(os_wxMediaPasteboard_class, "invalidate-bitmap-cache" " method", (Scheme_Method_Prim *)os_wxMediaPasteboardInvalidateBitmapCache, 0, 4)); WITH_VAR_STACK(scheme_add_method_w_arity(os_wxMediaPasteboard_class, "on-paint" " method", (Scheme_Method_Prim *)os_wxMediaPasteboardOnPaint, 9, 9)); WITH_VAR_STACK(scheme_add_method_w_arity(os_wxMediaPasteboard_class, "write-footers-to-file" " method", (Scheme_Method_Prim *)os_wxMediaPasteboardWriteFootersToFile, 1, 1)); From ac5dcae9e6735e63702effff08075ff9b3eb9d7b Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Wed, 14 Jan 2009 22:35:39 +0000 Subject: [PATCH 05/13] make (help "foo") run a search for "foo" svn: r13126 --- collects/scheme/help.ss | 3 +++ 1 file changed, 3 insertions(+) diff --git a/collects/scheme/help.ss b/collects/scheme/help.ss index dba69b06e3..a5c0951fb6 100644 --- a/collects/scheme/help.ss +++ b/collects/scheme/help.ss @@ -21,6 +21,9 @@ #f "expected a module path after #:from" stx #'lib)) (raise-syntax-error #f "expected an identifier before #:from" stx #'id))] + [(help str ...) + (andmap (lambda (s) (string? (syntax-e s))) (syntax->list #'(str ...))) + #'(search-for (list str ...))] [(help #:search str ...) (with-syntax ([(str ...) (map (lambda (e) From 62ed5ba3adef5bf63143ef3704281e23d52c9bec Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Wed, 14 Jan 2009 22:39:17 +0000 Subject: [PATCH 06/13] make it require one or more strings, just in case svn: r13127 --- collects/scheme/help.ss | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/collects/scheme/help.ss b/collects/scheme/help.ss index a5c0951fb6..c2b78143cd 100644 --- a/collects/scheme/help.ss +++ b/collects/scheme/help.ss @@ -21,9 +21,10 @@ #f "expected a module path after #:from" stx #'lib)) (raise-syntax-error #f "expected an identifier before #:from" stx #'id))] - [(help str ...) - (andmap (lambda (s) (string? (syntax-e s))) (syntax->list #'(str ...))) - #'(search-for (list str ...))] + [(help str0 str ...) + (andmap (lambda (s) (string? (syntax-e s))) + (syntax->list #'(str0 str ...))) + #'(search-for (list str0 str ...))] [(help #:search str ...) (with-syntax ([(str ...) (map (lambda (e) From fd2136071a4f805909d0ad3e431209e7ca6ad012 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 14 Jan 2009 22:45:46 +0000 Subject: [PATCH 07/13] document 'help' change svn: r13128 --- collects/scribblings/reference/help.scrbl | 23 +++++++++++++++++------ collects/scribblings/reference/mz.ss | 2 +- 2 files changed, 18 insertions(+), 7 deletions(-) diff --git a/collects/scribblings/reference/help.scrbl b/collects/scribblings/reference/help.scrbl index b98f6f070f..57f4efb19e 100644 --- a/collects/scribblings/reference/help.scrbl +++ b/collects/scribblings/reference/help.scrbl @@ -19,6 +19,7 @@ @deftogether[( @defidform[help] +@defform/none[#:literals (help) (help string ...)] @defform/none[#:literals (help) (help id)] @defform/none[#:literals (help) (help id #:from module-path)] @defform/none[#:literals (help) (help #:search datum ...)] @@ -35,6 +36,17 @@ the user's browser is launched to display help information.} A simple @scheme[help] or @scheme[(help)] form opens the main documentation page. +The @scheme[(help string ...)] form---using literal strings, as +opposed to expressions that produce strings---performs a +string-matching search. For example, + +@schemeblock[ +(help "web browser" "firefox") +] + +searches the documentation index for references that include the +phrase ``web browser'' or ``firefox.'' + A @scheme[(help id)] form looks for documentation specific to the current binding of @scheme[id]. For example, @@ -70,11 +82,10 @@ The @scheme[(help id #:from module-path)] variant is similar to (help frame% #:from scheme/gui) (code:comment #, @t{equivalent to the above}) ] -The @scheme[(help #:search datum ...)] form performs a general -search. Searching uses strings; each string @scheme[datum] is used -as-is, and any other form of @scheme[datum] is converted to a string -using @scheme[display]. No @scheme[datum] is evaluated as an -expression. +The @scheme[(help #:search datum ...)] form is similar to +@scheme[(help string ...)], where any non-string form of +@scheme[datum] is converted to a string using @scheme[display]. No +@scheme[datum] is evaluated as an expression. For example, @@ -82,7 +93,7 @@ For example, (help #:search "web browser" firefox) ] -searches the documentation index for references that include the +also searches the documentation index for references that include the phrase ``web browser'' or ``firefox.'' } diff --git a/collects/scribblings/reference/mz.ss b/collects/scribblings/reference/mz.ss index 3d6230d69f..9eb2124533 100644 --- a/collects/scribblings/reference/mz.ss +++ b/collects/scribblings/reference/mz.ss @@ -57,7 +57,7 @@ (schememodname lib) " and " (schememodname scheme/init) - " libraries, which means that they ara available when " + " libraries, which means that they are available when " (exec "mzscheme") " is started with no command-line arguments." " They are not provided by " (schememodname scheme/base) " or " (schememodname scheme) "." From 9e341c4e0d6bd01bf1416c7d07e8fba592a285a8 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 14 Jan 2009 22:52:06 +0000 Subject: [PATCH 08/13] correct syntax-error message for 'help' svn: r13129 --- collects/scheme/help.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/scheme/help.ss b/collects/scheme/help.ss index c2b78143cd..238b99a995 100644 --- a/collects/scheme/help.ss +++ b/collects/scheme/help.ss @@ -36,7 +36,7 @@ [_ (raise-syntax-error #f - (string-append "expects a single identifer, a #:from clause, or a" + (string-append "expects any number of literal strings, a single identifer, a #:from clause, or a" " #:search clause; try `(help help)' for more information") stx)]))) From 559363bc2bee1542114353c1fbc33f07627afa17 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Wed, 14 Jan 2009 22:57:52 +0000 Subject: [PATCH 09/13] remove #:from from error message, a little clearer code svn: r13130 --- collects/scheme/help.ss | 19 ++++++++++--------- 1 file changed, 10 insertions(+), 9 deletions(-) diff --git a/collects/scheme/help.ss b/collects/scheme/help.ss index 238b99a995..4c8eb0a9aa 100644 --- a/collects/scheme/help.ss +++ b/collects/scheme/help.ss @@ -14,13 +14,13 @@ (identifier? #'id) #'(find-help (quote-syntax id))] [(help id #:from lib) - (if (identifier? #'id) - (if (module-path? (syntax->datum #'lib)) - #'(find-help/lib (quote id) (quote lib)) - (raise-syntax-error - #f "expected a module path after #:from" stx #'lib)) - (raise-syntax-error - #f "expected an identifier before #:from" stx #'id))] + (cond [(not (identifier? #'id)) + (raise-syntax-error + #f "expected an identifier before #:from" stx #'id)] + [(not (module-path? (syntax->datum #'lib))) + (raise-syntax-error + #f "expected a module path after #:from" stx #'lib)] + [else #'(find-help/lib (quote id) (quote lib))])] [(help str0 str ...) (andmap (lambda (s) (string? (syntax-e s))) (syntax->list #'(str0 str ...))) @@ -36,8 +36,9 @@ [_ (raise-syntax-error #f - (string-append "expects any number of literal strings, a single identifer, a #:from clause, or a" - " #:search clause; try `(help help)' for more information") + (string-append "expects a single identifer, any number of literal" + " strings, or a #:search clause;" + " try `(help help)' for more information") stx)]))) (define (open-help-start) From 3418b1404e629c8ac7def529ffd2154a9899dfb6 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Wed, 14 Jan 2009 22:58:06 +0000 Subject: [PATCH 10/13] plural svn: r13131 --- collects/scheme/help.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/scheme/help.ss b/collects/scheme/help.ss index 4c8eb0a9aa..a890451d4d 100644 --- a/collects/scheme/help.ss +++ b/collects/scheme/help.ss @@ -37,7 +37,7 @@ (raise-syntax-error #f (string-append "expects a single identifer, any number of literal" - " strings, or a #:search clause;" + " strings, or #:search clauses;" " try `(help help)' for more information") stx)]))) From 01b980f97e5e85efdccf983a04a9b7a3b65057a7 Mon Sep 17 00:00:00 2001 From: Matthias Felleisen Date: Wed, 14 Jan 2009 23:31:20 +0000 Subject: [PATCH 11/13] doc typos svn: r13132 --- collects/teachpack/2htdp/scribblings/universe.scrbl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/teachpack/2htdp/scribblings/universe.scrbl b/collects/teachpack/2htdp/scribblings/universe.scrbl index 3547e2a548..b0f3ec8363 100644 --- a/collects/teachpack/2htdp/scribblings/universe.scrbl +++ b/collects/teachpack/2htdp/scribblings/universe.scrbl @@ -125,7 +125,7 @@ Your program may deal with such events via the @emph{designation} of @emph{handler} functions. Specifically, the teachpack provides for the installation of three event handlers: @scheme[on-tick], @scheme[on-key], and @scheme[on-mouse]. In addition, a @tech{world} program may specify a - @scheme[_dra]} function, which is called every time your program should + @scheme[draw] function, which is called every time your program should visualize the current world, and a @scheme[_stop?] predicate, which is used to determine when the @tech{world} program should shut down. From 92a938dc6dee5cc1f255135639a36f478c08151e Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Thu, 15 Jan 2009 00:07:47 +0000 Subject: [PATCH 12/13] macro stepper tests: updated svn: r13133 --- collects/tests/macro-debugger/gui-tests.ss | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/collects/tests/macro-debugger/gui-tests.ss b/collects/tests/macro-debugger/gui-tests.ss index 3fe08529a3..f3ba1f92a0 100644 --- a/collects/tests/macro-debugger/gui-tests.ss +++ b/collects/tests/macro-debugger/gui-tests.ss @@ -207,7 +207,8 @@ (sleep 1) (parameterize ((current-eventspace (make-eventspace))) (let ([frame (new macro-stepper-frame% - (config (new macro-stepper-config/prefs/readonly%)))]) + (config (new macro-stepper-config/prefs/readonly%)) + (director (new macro-stepper-director%)))]) (send frame show #t) frame))) @@ -270,4 +271,4 @@ (send frame get-eventspace)))))))))) (define (test-stepper expr) - (test-stepper* (list expr) '(none basic normal)))) + (test-stepper* (list expr) '(none basic normal))) From b91874f41ca5ae60a2e83d533a821b4e018c6fe5 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Thu, 15 Jan 2009 00:10:09 +0000 Subject: [PATCH 13/13] macro stepper: more iop svn: r13134 --- .../syntax-browser/controller.ss | 6 +-- .../macro-debugger/syntax-browser/display.ss | 30 ++++++------- .../macro-debugger/syntax-browser/frame.ss | 45 ++++++++++--------- .../syntax-browser/interfaces.ss | 41 ++++++++--------- .../macro-debugger/syntax-browser/prefs.ss | 2 +- .../syntax-browser/pretty-helper.ss | 14 +++--- .../syntax-browser/syntax-snip.ss | 5 ++- .../macro-debugger/syntax-browser/widget.ss | 23 +++++----- collects/macro-debugger/util/class-ct.ss | 32 ++++++++++++- collects/macro-debugger/util/class-iop.ss | 27 ++++++----- collects/macro-debugger/util/notify.ss | 18 +++++++- collects/macro-debugger/view/debug.ss | 4 +- collects/macro-debugger/view/frame.ss | 18 ++++---- collects/macro-debugger/view/hiding-panel.ss | 12 ++--- collects/macro-debugger/view/interfaces.ss | 17 ++++++- collects/macro-debugger/view/prefs.ss | 3 +- collects/macro-debugger/view/step-display.ss | 6 +-- collects/macro-debugger/view/stepper.ss | 42 ++++++++--------- collects/macro-debugger/view/term-record.ss | 7 +-- 19 files changed, 215 insertions(+), 137 deletions(-) diff --git a/collects/macro-debugger/syntax-browser/controller.ss b/collects/macro-debugger/syntax-browser/controller.ss index f834abc2f8..030c9389d1 100644 --- a/collects/macro-debugger/syntax-browser/controller.ss +++ b/collects/macro-debugger/syntax-browser/controller.ss @@ -38,7 +38,7 @@ ;; mark-manager-mixin (define mark-manager-mixin (mixin () (mark-manager<%>) - (init-field [primary-partition (new-bound-partition)]) + (init-field: [primary-partition partition<%> (new-bound-partition)]) (super-new) ;; get-primary-partition : -> partition @@ -63,8 +63,8 @@ (new partition% (relation (cdr name+proc))))))) (listen-secondary-partition (lambda (p) - (for-each (lambda (d) (send: d display<%> refresh)) - displays))) + (for ([d displays]) + (send: d display<%> refresh)))) (super-new))) (define controller% diff --git a/collects/macro-debugger/syntax-browser/display.ss b/collects/macro-debugger/syntax-browser/display.ss index d0645e402b..3fdef92cd9 100644 --- a/collects/macro-debugger/syntax-browser/display.ss +++ b/collects/macro-debugger/syntax-browser/display.ss @@ -1,4 +1,3 @@ - #lang scheme/base (require scheme/class scheme/gui @@ -19,8 +18,8 @@ (define range (pretty-print-syntax stx output-port (send: controller controller<%> get-primary-partition) - (send config get-colors) - (send config get-suffix-option) + (send: config config<%> get-colors) + (send: config config<%> get-suffix-option) columns)) (define output-string (get-output-string output-port)) (define output-length (sub1 (string-length output-string))) ;; skip final newline @@ -55,18 +54,18 @@ ;; set-standard-font : text% config number number -> void (define (set-standard-font text config start end) (send text change-style - (code-style text (send config get-syntax-font-size)) + (code-style text (send: config config<%> get-syntax-font-size)) start end)) ;; display% (define display% (class* object% (display<%>) - (init-field text) - (init-field controller) - (init-field config) - (init-field range) - (init-field start-position) - (init-field end-position) + (init-field: [controller controller<%>] + [config config<%>] + [range range<%>]) + (init-field text + start-position + end-position) (define extra-styles (make-hasheq)) @@ -131,7 +130,7 @@ (send delta set-delta-foreground color) delta)) (define color-styles - (list->vector (map color-style (send config get-colors)))) + (list->vector (map color-style (send: config config<%> get-colors)))) (define overflow-style (color-style "darkgray")) (define color-partition (send: controller mark-manager<%> get-primary-partition)) @@ -189,7 +188,7 @@ ;; draw-secondary-connection : syntax -> void (define/private (draw-secondary-connection stx2) - (for ([r (send range get-ranges stx2)]) + (for ([r (send: range range<%> get-ranges stx2)]) (restyle-range r select-sub-highlight-d))) ;; restyle-range : (cons num num) style-delta% -> void @@ -204,11 +203,11 @@ ;; Initialize (super-new) - (send controller add-syntax-display this))) + (send: controller controller<%> add-syntax-display this))) ;; fixup-parentheses : string range -> void (define (fixup-parentheses string range) - (define (fixup r) + (for ([r (send: range range<%> all-ranges)]) (let ([stx (range-obj r)] [start (range-start r)] [end (range-end r)]) @@ -219,8 +218,7 @@ (string-set! string (sub1 end) #\])) ((#\{) (string-set! string start #\{) - (string-set! string (sub1 end) #\})))))) - (for-each fixup (send range all-ranges))) + (string-set! string (sub1 end) #\}))))))) (define (open-output-string/count-lines) (let ([os (open-output-string)]) diff --git a/collects/macro-debugger/syntax-browser/frame.ss b/collects/macro-debugger/syntax-browser/frame.ss index b5a8489066..9f41e052c3 100644 --- a/collects/macro-debugger/syntax-browser/frame.ss +++ b/collects/macro-debugger/syntax-browser/frame.ss @@ -1,8 +1,10 @@ #lang scheme/base (require scheme/class + macro-debugger/util/class-iop scheme/gui framework/framework scheme/list + "interfaces.ss" "partition.ss" "prefs.ss" "widget.ss") @@ -20,8 +22,9 @@ (define (browse-syntaxes stxs) (let ((w (make-syntax-browser))) (for ([stx stxs]) - (send w add-syntax stx) - (send w add-separator)))) + (send*: w syntax-browser<%> + (add-syntax stx) + (add-separator))))) ;; make-syntax-browser : -> syntax-browser<%> (define (make-syntax-browser) @@ -32,21 +35,23 @@ ;; syntax-browser-frame% (define syntax-browser-frame% (class* frame% () - (init-field [config (new syntax-prefs%)]) + (inherit get-width + get-height) + (init-field: [config config<%> (new syntax-prefs%)]) (super-new (label "Syntax Browser") - (width (send config pref:width)) - (height (send config pref:height))) - (define widget + (width (send: config config<%> get-width)) + (height (send: config config<%> get-height))) + (define: widget syntax-browser<%> (new syntax-widget/controls% (parent this) (config config))) (define/public (get-widget) widget) (define/augment (on-close) - (send config pref:width (send this get-width)) - (send config pref:height (send this get-height)) + (send*: config config<%> + (set-width (get-width)) + (set-height (get-height))) (send widget shutdown) - (inner (void) on-close)) - )) + (inner (void) on-close)))) ;; syntax-widget/controls% (define syntax-widget/controls% @@ -72,23 +77,23 @@ (choices (map car -identifier=-choices)) (callback (lambda (c e) - (send (get-controller) set-identifier=? - (assoc (send c get-string-selection) - -identifier=-choices)))))) + (send: (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) select-syntax #f)))) + (callback (lambda _ (send: (get-controller) controller<%> set-selected-syntax #f)))) (new button% (label "Properties") (parent -control-panel) (callback (lambda _ - (send config set-props-shown? - (not (send config get-props-shown?)))))) + (send: config config<%> set-props-shown? + (not (send: config config<%> get-props-shown?)))))) - (send (get-controller) listen-identifier=? - (lambda (name+func) - (send -choice set-selection - (or (send -choice find-string (car name+func)) 0)))) + (send: (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/interfaces.ss b/collects/macro-debugger/syntax-browser/interfaces.ss index 32cbf6d3ad..9c7ade2634 100644 --- a/collects/macro-debugger/syntax-browser/interfaces.ss +++ b/collects/macro-debugger/syntax-browser/interfaces.ss @@ -1,8 +1,19 @@ #lang scheme/base (require scheme/class - macro-debugger/util/class-iop) + macro-debugger/util/class-iop + "../util/notify.ss") (provide (all-defined-out)) +;; config<%> +(define-interface config<%> () + ((methods:notify suffix-option + syntax-font-size + colors + width + height + props-percentage + props-shown?))) + ;; displays-manager<%> (define-interface displays-manager<%> () (;; add-syntax-display : display<%> -> void @@ -13,10 +24,8 @@ ;; selection-manager<%> (define-interface selection-manager<%> () - (;; selected-syntax : syntax/#f - set-selected-syntax - get-selected-syntax - listen-selected-syntax)) + (;; selected-syntax : notify-box of syntax/#f + (methods:notify selected-syntax))) ;; mark-manager<%> ;; Manages marks, mappings from marks to colors @@ -29,23 +38,10 @@ ;; secondary-partition<%> (define-interface secondary-partition<%> () - (;; get-secondary-partition : -> partition<%> - get-secondary-partition - - ;; set-secondary-partition : partition<%> -> void - set-secondary-partition - - ;; listen-secondary-partition : (partition<%> -> void) -> void - listen-secondary-partition - - ;; get-identifier=? : -> (cons string procedure) - get-identifier=? - - ;; set-identifier=? : (cons string procedure) -> void - set-identifier=? - - ;; listen-identifier=? : ((cons string procedure) -> void) -> void - listen-identifier=?)) + (;; secondary-partition : notify-box of partition<%> + ;; identifier=? : notify-box of (cons string procedure) + (methods:notify secondary-partition + identifier=?))) ;; controller<%> (define-interface controller<%> (displays-manager<%> @@ -143,6 +139,7 @@ add-clickback add-separator erase-all + get-controller get-text)) (define-interface partition<%> () diff --git a/collects/macro-debugger/syntax-browser/prefs.ss b/collects/macro-debugger/syntax-browser/prefs.ss index fe31a40cc2..fe86c83f47 100644 --- a/collects/macro-debugger/syntax-browser/prefs.ss +++ b/collects/macro-debugger/syntax-browser/prefs.ss @@ -42,7 +42,7 @@ (super-new))) (define syntax-prefs-base% - (class prefs-base% + (class* prefs-base% (config<%>) ;; width, height : number (notify-methods width) (notify-methods height) diff --git a/collects/macro-debugger/syntax-browser/pretty-helper.ss b/collects/macro-debugger/syntax-browser/pretty-helper.ss index 0eadf413b1..846eae3a0c 100644 --- a/collects/macro-debugger/syntax-browser/pretty-helper.ss +++ b/collects/macro-debugger/syntax-browser/pretty-helper.ss @@ -1,7 +1,9 @@ #lang scheme/base (require scheme/class - syntax/stx) + macro-debugger/util/class-iop + syntax/stx + "interfaces.ss") (provide (all-defined-out)) ;; Problem: If stx1 and stx2 are two distinguishable syntax objects, it @@ -45,10 +47,10 @@ (case suffixopt ((never) (unintern (syntax-e id))) ((always) - (let ([n (send partition get-partition id)]) + (let ([n (send: partition partition<%> get-partition id)]) (if (zero? n) (unintern (syntax-e id)) (suffix (syntax-e id) n)))) ((over-limit) - (let ([n (send partition get-partition id)]) + (let ([n (send: partition partition<%> get-partition id)]) (if (<= n limit) (unintern (syntax-e id)) (suffix (syntax-e id) n)))))) @@ -61,7 +63,7 @@ => (lambda (datum) datum)] [(and partition (identifier? obj)) (when (and (eq? suffixopt 'all-if-over-limit) - (> (send partition count) limit)) + (> (send: partition partition<%> count) limit)) (call-with-values (lambda () (table stx partition #f 'always)) escape)) (let ([lp-datum (make-identifier-proxy obj)]) @@ -70,7 +72,7 @@ lp-datum)] [(and (syntax? obj) (check+convert-special-expression obj)) => (lambda (newobj) - (when partition (send partition get-partition obj)) + (when partition (send: partition partition<%> get-partition obj)) (let* ([inner (cadr newobj)] [lp-inner-datum (loop inner)] [lp-datum (list (car newobj) lp-inner-datum)]) @@ -80,7 +82,7 @@ (hash-set! stx=>flat obj lp-datum) lp-datum))] [(syntax? obj) - (when partition (send partition get-partition obj)) + (when partition (send: 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/syntax-snip.ss b/collects/macro-debugger/syntax-browser/syntax-snip.ss index 87cda8994b..d002b16507 100644 --- a/collects/macro-debugger/syntax-browser/syntax-snip.ss +++ b/collects/macro-debugger/syntax-browser/syntax-snip.ss @@ -1,6 +1,7 @@ #lang scheme/base (require scheme/class + macro-debugger/util/class-iop scheme/match scheme/list mzlib/string @@ -205,8 +206,8 @@ (define/public (read-special src line col pos) (send the-syntax-snip read-special src line col pos)) - (send config listen-props-shown? - (lambda (?) (refresh-contents))) + (send: config config<%> listen-props-shown? + (lambda (?) (refresh-contents))) (super-new) (set-snipclass snip-class) diff --git a/collects/macro-debugger/syntax-browser/widget.ss b/collects/macro-debugger/syntax-browser/widget.ss index 51ab11e9e7..6d90770437 100644 --- a/collects/macro-debugger/syntax-browser/widget.ss +++ b/collects/macro-debugger/syntax-browser/widget.ss @@ -43,6 +43,7 @@ (define/public (setup-keymap) (new syntax-keymap% (editor -text) + (controller controller) (config config))) (send -text set-styles-sticky #f) @@ -54,7 +55,7 @@ (define/private (internal-show-props show?) (if show? (unless (send -props-panel is-shown?) - (let ([p (send config get-props-percentage)]) + (let ([p (send: config config<%> get-props-percentage)]) (send -split-panel add-child -props-panel) (update-props-percentage p)) (send -props-panel show #t)) @@ -81,8 +82,8 @@ (define/public (shutdown) (when (props-panel-shown?) - (send config set-props-percentage - (cadr (send -split-panel get-percentages))))) + (send: config config<%> set-props-percentage + (cadr (send -split-panel get-percentages))))) ;; syntax-browser<%> Methods @@ -202,7 +203,7 @@ display))) (define/private (calculate-columns) - (define style (code-style -text (send config get-syntax-font-size))) + (define style (code-style -text (send: 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))))) @@ -211,13 +212,13 @@ (super-new) (setup-keymap) - (send config listen-props-shown? - (lambda (show?) - (show-props show?))) - (send config listen-props-percentage - (lambda (p) - (update-props-percentage p))) - (internal-show-props (send config get-props-shown?)))) + (send: config config<%> listen-props-shown? + (lambda (show?) + (show-props show?))) + (send: config config<%> listen-props-percentage + (lambda (p) + (update-props-percentage p))) + (internal-show-props (send: config config<%> get-props-shown?)))) (define clickback-style diff --git a/collects/macro-debugger/util/class-ct.ss b/collects/macro-debugger/util/class-ct.ss index 473acbacfc..2d63b3e524 100644 --- a/collects/macro-debugger/util/class-ct.ss +++ b/collects/macro-debugger/util/class-ct.ss @@ -14,7 +14,15 @@ checked-binding-iface checked-binding - static-interface) + static-interface + + interface-expander? + make-interface-expander + interface-expander-proc + + interface-expander + method-entry) + (define-struct static-interface (dynamic members) #:omit-define-syntaxes @@ -60,6 +68,11 @@ (define (checked-binding-iface x) (raw-checked-binding-iface (set!-transformer-procedure x))) + +(define-struct interface-expander (proc) + #:omit-define-syntaxes) + + ;; Syntax (define-syntax-class static-interface @@ -71,3 +84,20 @@ (pattern x #:declare x (static-of 'checked-binding checked-binding?) #:with value #'x.value)) + + +(define-syntax-class interface-expander + (pattern x + #:declare x (static-of 'interface-expander interface-expander?) + #:with value #'x.value)) + +(define-syntax-class method-entry + (pattern method:id + #:with methods (list #'method)) + (pattern (macro:interface-expander . args) + #:with methods + (apply append + (for/list ([m ((interface-expander-proc #'macro.value) + #'(macro . args))]) + (syntax-parse m + [m:method-entry #'m.methods]))))) diff --git a/collects/macro-debugger/util/class-iop.ss b/collects/macro-debugger/util/class-iop.ss index 029196a6b5..0fdef90146 100644 --- a/collects/macro-debugger/util/class-iop.ss +++ b/collects/macro-debugger/util/class-iop.ss @@ -5,6 +5,7 @@ "class-ct.ss")) (provide define-interface define-interface/dynamic + define-interface-expander send: send*: @@ -26,13 +27,14 @@ ;; Defines NAME as an interface. (define-syntax (define-interface stx) (syntax-parse stx - [(_ name:id (super:static-interface ...) (mname:id ...)) + [(_ name:id (super:static-interface ...) (m:method-entry ...)) (with-syntax ([((super-method ...) ...) (map static-interface-members - (syntax->datum #'(super.value ...)))]) + (syntax->datum #'(super.value ...)))] + [((mname ...) ...) #'(m.methods ...)]) #'(define-interface/dynamic name - (let ([name (interface (super ...) mname ...)]) name) - (super-method ... ... mname ...)))])) + (let ([name (interface (super ...) mname ... ...)]) name) + (super-method ... ... mname ... ...)))])) ;; define-interface/dynamic SYNTAX ;; (define-interface/dynamic NAME EXPR (IDENTIFIER ...)) @@ -54,6 +56,11 @@ (define-syntax name (make-static-interface #'dynamic-name '(mname ...)))))])) +(define-syntax (define-interface-expander stx) + (syntax-parse stx + [(_ name:id rhs:expr) + #'(define-syntax name (make-interface-expander rhs))])) + ;; Helper (begin-for-syntax @@ -173,19 +180,19 @@ ;; FIXME: unsafe due to mutation (define-syntax (init-field: stx) (syntax-parse stx - [(_ (name:id iface:static-interface) ...) - #'(begin (init1: init-field name iface) ...)])) + [(_ (name:id iface:static-interface . default) ...) + #'(begin (init1: init-field name iface . default) ...)])) (define-syntax (init: stx) (syntax-parse stx - [(_ (name:id iface:static-interface) ...) - #'(begin (init1: init name iface) ...)])) + [(_ (name:id iface:static-interface . default) ...) + #'(begin (init1: init name iface . default) ...)])) (define-syntax (init1: stx) (syntax-parse stx - [(_ init name:id iface:static-interface) + [(_ init name:id iface:static-interface . default) (with-syntax ([(name-internal) (generate-temporaries #'(name))]) - #'(begin (init ((name-internal name))) + #'(begin (init ((name-internal name) . default)) (void (check-object<:interface init: name-internal iface)) (define-syntax name (make-checked-binding diff --git a/collects/macro-debugger/util/notify.ss b/collects/macro-debugger/util/notify.ss index 33267dd89a..8da4293f64 100644 --- a/collects/macro-debugger/util/notify.ss +++ b/collects/macro-debugger/util/notify.ss @@ -3,6 +3,7 @@ (require (for-syntax scheme/base) scheme/list scheme/class + macro-debugger/util/class-iop scheme/gui) (provide define/listen field/notify @@ -15,7 +16,9 @@ menu-option/notify-box menu-group/notify-box check-box/notify-box - choice/notify-box) + choice/notify-box + + methods:notify) (define-for-syntax (join . args) (define (->string x) @@ -71,6 +74,19 @@ (define/public-final (listen-name listener) (send name listen listener))))])) + +(define-interface-expander methods:notify + (lambda (stx) + (syntax-case stx () + [(_ name ...) + (apply append + (for/list ([name (syntax->list #'(name ...))]) + (list ;; (join "init-" #'name) + (join "get-" name) + (join "set-" name) + (join "listen-" name))))]))) + + (define-syntax (connect-to-pref stx) (syntax-case stx () [(connect-to-pref name pref) diff --git a/collects/macro-debugger/view/debug.ss b/collects/macro-debugger/view/debug.ss index 32603722cc..efa0a3e04d 100644 --- a/collects/macro-debugger/view/debug.ss +++ b/collects/macro-debugger/view/debug.ss @@ -2,6 +2,8 @@ #lang scheme/base (require scheme/pretty scheme/class + macro-debugger/util/class-iop + "interfaces.ss" "debug-format.ss" "prefs.ss" "view.ss") @@ -30,5 +32,5 @@ (pretty-print msg) (pretty-print ctx) (let* ([w (make-stepper)]) - (send w add-trace events) + (send: w widget<%> add-trace events) w))) diff --git a/collects/macro-debugger/view/frame.ss b/collects/macro-debugger/view/frame.ss index 856c5bb9de..07221aad5d 100644 --- a/collects/macro-debugger/view/frame.ss +++ b/collects/macro-debugger/view/frame.ss @@ -42,8 +42,8 @@ get-help-menu) (super-new (label (make-label)) - (width (send config get-width)) - (height (send config get-height))) + (width (send: config config<%> get-width)) + (height (send: config config<%> get-height))) (define/private (make-label) (if filename @@ -54,8 +54,8 @@ "Macro stepper")) (define/override (on-size w h) - (send config set-width w) - (send config set-height h) + (send: config config<%> set-width w) + (send: config config<%> set-height h) (send: widget widget<%> update/preserve-view)) (define warning-panel @@ -143,7 +143,7 @@ (eq? (car name+func) (car p))))))) (sb:identifier=-choices))) - (let ([identifier=? (send config get-identifier=?)]) + (let ([identifier=? (send: config config<%> get-identifier=?)]) (when identifier=? (let ([p (assoc identifier=? (sb:identifier=-choices))]) (send: controller sb:controller<%> set-identifier=? p)))) @@ -178,10 +178,10 @@ (parent extras-menu) (callback (lambda (i e) - (send config set-suffix-option - (if (send i is-checked?) - 'always - 'over-limit)) + (send: config config<%> set-suffix-option + (if (send i is-checked?) + 'always + 'over-limit)) (send: widget widget<%> update/preserve-view)))) (menu-option/notify-box extras-menu "Highlight redex/contractum" diff --git a/collects/macro-debugger/view/hiding-panel.ss b/collects/macro-debugger/view/hiding-panel.ss index 993354928f..be6b24890b 100644 --- a/collects/macro-debugger/view/hiding-panel.ss +++ b/collects/macro-debugger/view/hiding-panel.ss @@ -79,7 +79,7 @@ (style '(deleted)))) (define/private (get-mode) - (send config get-macro-hiding-mode)) + (send: config config<%> get-macro-hiding-mode)) (define/private (macro-hiding-enabled?) (let ([mode (get-mode)]) @@ -89,7 +89,7 @@ (define/private (ensure-custom-mode) (unless (equal? (get-mode) mode:custom) - (send config set-macro-hiding-mode mode:custom))) + (send: config config<%> set-macro-hiding-mode mode:custom))) (define/private (update-visibility) (let ([customizing (equal? (get-mode) mode:custom)]) @@ -104,10 +104,10 @@ (list customize-panel) null)))))) - (send config listen-macro-hiding-mode - (lambda (value) - (update-visibility) - (force-refresh))) + (send: config config<%> listen-macro-hiding-mode + (lambda (value) + (update-visibility) + (force-refresh))) (define box:hiding (new check-box% diff --git a/collects/macro-debugger/view/interfaces.ss b/collects/macro-debugger/view/interfaces.ss index aae81722e6..7e146436f3 100644 --- a/collects/macro-debugger/view/interfaces.ss +++ b/collects/macro-debugger/view/interfaces.ss @@ -1,8 +1,23 @@ #lang scheme/base -(require macro-debugger/util/class-iop) +(require macro-debugger/util/class-iop + "../util/notify.ss" + (prefix-in sb: "../syntax-browser/interfaces.ss")) (provide (all-defined-out)) +(define-interface config<%> (sb:config<%>) + ((methods:notify macro-hiding-mode + show-hiding-panel? + identifier=? + highlight-foci? + highlight-frontier? + show-rename-steps? + suppress-warnings? + one-by-one? + extra-navigation? + debug-catch-errors? + force-letrec-transformation?))) + (define-interface widget<%> () (get-config get-controller diff --git a/collects/macro-debugger/view/prefs.ss b/collects/macro-debugger/view/prefs.ss index cdeeee8be6..73eb46d71a 100644 --- a/collects/macro-debugger/view/prefs.ss +++ b/collects/macro-debugger/view/prefs.ss @@ -2,6 +2,7 @@ #lang scheme/base (require scheme/class framework/framework + "interfaces.ss" "../syntax-browser/prefs.ss" "../util/notify.ss" "../util/misc.ss") @@ -43,7 +44,7 @@ (pref:get/set pref:force-letrec-transformation? MacroStepper:ForceLetrecTransformation?) (define macro-stepper-config-base% - (class syntax-prefs-base% + (class* syntax-prefs-base% (config<%>) (notify-methods macro-hiding-mode) (notify-methods show-hiding-panel?) (notify-methods identifier=?) diff --git a/collects/macro-debugger/view/step-display.ss b/collects/macro-debugger/view/step-display.ss index d1af9a8ee5..733e5362de 100644 --- a/collects/macro-debugger/view/step-display.ss +++ b/collects/macro-debugger/view/step-display.ss @@ -41,7 +41,7 @@ (define step-display% (class* object% (step-display<%>) - (init-field config) + (init-field: (config config<%>)) (init-field ((sbview syntax-widget))) (super-new) @@ -194,8 +194,8 @@ ;; insert-syntax/color (define/private (insert-syntax/color stx foci binders shift-table definites frontier hi-color) - (define highlight-foci? (send config get-highlight-foci?)) - (define highlight-frontier? (send config get-highlight-frontier?)) + (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) #:binder-table binders diff --git a/collects/macro-debugger/view/stepper.ss b/collects/macro-debugger/view/stepper.ss index ed9b6ed08a..8f72e06a8f 100644 --- a/collects/macro-debugger/view/stepper.ss +++ b/collects/macro-debugger/view/stepper.ss @@ -86,7 +86,7 @@ (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 get-raw-deriv)) + (send: new-stepper widget<%> add-deriv (send: term term-record<%> get-raw-deriv)) (void))))) ;; duplicate-stepper : -> void @@ -138,7 +138,7 @@ (config config) (syntax-widget sbview))) (define: sbc sb:controller<%> - (send sbview get-controller)) + (send: sbview sb:syntax-browser<%> get-controller)) (define control-pane (new vertical-panel% (parent area) (stretchable-height #f))) (define: macro-hiding-prefs hiding-prefs<%> @@ -147,22 +147,24 @@ (stepper this) (config config))) - (send config listen-show-hiding-panel? - (lambda (show?) (show-macro-hiding-panel show?))) - (send sbc listen-selected-syntax - (lambda (stx) (send: macro-hiding-prefs hiding-prefs<%> set-syntax stx))) - (send config listen-highlight-foci? - (lambda (_) (update/preserve-view))) - (send config listen-highlight-frontier? - (lambda (_) (update/preserve-view))) - (send config listen-show-rename-steps? - (lambda (_) (refresh/re-reduce))) - (send config listen-one-by-one? - (lambda (_) (refresh/re-reduce))) - (send config listen-force-letrec-transformation? - (lambda (_) (refresh/resynth))) - (send config listen-extra-navigation? - (lambda (show?) (show-extra-navigation show?))) + (send: sbc sb:controller<%> + listen-selected-syntax + (lambda (stx) (send: macro-hiding-prefs hiding-prefs<%> set-syntax stx))) + (send*: config config<%> + (listen-show-hiding-panel? + (lambda (show?) (show-macro-hiding-panel show?))) + (listen-highlight-foci? + (lambda (_) (update/preserve-view))) + (listen-highlight-frontier? + (lambda (_) (update/preserve-view))) + (listen-show-rename-steps? + (lambda (_) (refresh/re-reduce))) + (listen-one-by-one? + (lambda (_) (refresh/re-reduce))) + (listen-force-letrec-transformation? + (lambda (_) (refresh/resynth))) + (listen-extra-navigation? + (lambda (show?) (show-extra-navigation show?)))) (define nav:up (new button% (label "Previous term") (parent navigator) @@ -400,8 +402,8 @@ ;; Initialization (super-new) - (show-macro-hiding-panel (send config get-show-hiding-panel?)) - (show-extra-navigation (send config get-extra-navigation?)) + (show-macro-hiding-panel (send: config config<%> get-show-hiding-panel?)) + (show-extra-navigation (send: config config<%> get-extra-navigation?)) (refresh/move) )) diff --git a/collects/macro-debugger/view/term-record.ss b/collects/macro-debugger/view/term-record.ss index ae007a7781..b58e0e5879 100644 --- a/collects/macro-debugger/view/term-record.ss +++ b/collects/macro-debugger/view/term-record.ss @@ -33,7 +33,8 @@ (class* object% (term-record<%>) (init-field: (stepper widget<%>)) - (define config (send stepper get-config)) + (define: config config<%> + (send: stepper widget<%> get-config)) (define: displayer step-display<%> (send: stepper widget<%> get-step-displayer)) @@ -173,12 +174,12 @@ (set! steps (and raw-steps (let* ([filtered-steps - (if (send config get-show-rename-steps?) + (if (send: config config<%> get-show-rename-steps?) raw-steps (filter (lambda (x) (not (rename-step? x))) raw-steps))] [processed-steps - (if (send config get-one-by-one?) + (if (send: config config<%> get-one-by-one?) (reduce:one-by-one filtered-steps) filtered-steps)]) (cursor:new processed-steps))))