From 50bfe1b8be5f548f3fca0ff99839b20fdc046315 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Thu, 19 Nov 2009 08:29:57 +0000 Subject: [PATCH] unstable: more docs, a few changes to gui libs svn: r16887 --- .../syntax-browser/controller.ss | 8 +- .../macro-debugger/syntax-browser/prefs.ss | 43 +++--- .../syntax-browser/syntax-snip.ss | 9 +- .../macro-debugger/syntax-browser/text.ss | 2 +- collects/macro-debugger/view/frame.ss | 13 +- collects/macro-debugger/view/interfaces.ss | 1 - collects/macro-debugger/view/prefs.ss | 107 ++++++-------- collects/macro-debugger/view/stepper.ss | 4 +- collects/unstable/class-iop.ss | 1 + collects/unstable/gui/notify.ss | 131 +----------------- collects/unstable/gui/prefs.ss | 15 +- collects/unstable/private/class-iop-ct.ss | 1 + collects/unstable/private/notify.ss | 85 ++++++++++++ collects/unstable/scribblings/class-iop.scrbl | 3 + collects/unstable/scribblings/find.scrbl | 3 + collects/unstable/scribblings/gui.scrbl | 1 + .../unstable/scribblings/gui/notify.scrbl | 75 ++++++++-- collects/unstable/scribblings/gui/prefs.scrbl | 21 +++ collects/unstable/scribblings/struct.scrbl | 3 + collects/unstable/scribblings/syntax.scrbl | 2 + collects/unstable/scribblings/utils.ss | 4 +- 21 files changed, 269 insertions(+), 263 deletions(-) create mode 100644 collects/unstable/private/notify.ss create mode 100644 collects/unstable/scribblings/gui/prefs.scrbl diff --git a/collects/macro-debugger/syntax-browser/controller.ss b/collects/macro-debugger/syntax-browser/controller.ss index e1a1da87e5..897a9c8829 100644 --- a/collects/macro-debugger/syntax-browser/controller.ss +++ b/collects/macro-debugger/syntax-browser/controller.ss @@ -28,8 +28,8 @@ (define selection-manager-mixin (mixin (displays-manager<%>) (selection-manager<%>) (inherit-field displays) - (field/notify selected-syntax (new notify-box% (value #f))) - + (define-notify selected-syntax (new notify-box% (value #f))) + (super-new) (listen-selected-syntax (lambda (new-value) @@ -54,8 +54,8 @@ (define secondary-partition-mixin (mixin (displays-manager<%>) (secondary-partition<%>) (inherit-field displays) - (field/notify identifier=? (new notify-box% (value #f))) - (field/notify secondary-partition (new notify-box% (value #f))) + (define-notify identifier=? (new notify-box% (value #f))) + (define-notify secondary-partition (new notify-box% (value #f))) (listen-identifier=? (lambda (name+proc) diff --git a/collects/macro-debugger/syntax-browser/prefs.ss b/collects/macro-debugger/syntax-browser/prefs.ss index ca3d7723c7..9f570c57ef 100644 --- a/collects/macro-debugger/syntax-browser/prefs.ss +++ b/collects/macro-debugger/syntax-browser/prefs.ss @@ -1,4 +1,3 @@ - #lang scheme/base (require scheme/class framework/framework @@ -15,22 +14,22 @@ (preferences:set-default 'SyntaxBrowser:PropertiesPanelPercentage 1/3 number?) (preferences:set-default 'SyntaxBrowser:PropertiesPanelShown #t boolean?) -(pref:get/set pref:width SyntaxBrowser:Width) -(pref:get/set pref:height SyntaxBrowser:Height) -(pref:get/set pref:props-percentage SyntaxBrowser:PropertiesPanelPercentage) -(pref:get/set pref:props-shown? SyntaxBrowser:PropertiesPanelShown) +(define pref:width (pref:get/set 'SyntaxBrowser:Width)) +(define pref:height (pref:get/set 'SyntaxBrowser:Height)) +(define pref:props-percentage (pref:get/set 'SyntaxBrowser:PropertiesPanelPercentage)) +(define pref:props-shown? (pref:get/set 'SyntaxBrowser:PropertiesPanelShown)) (define prefs-base% (class object% ;; suffix-option : SuffixOption - (field/notify suffix-option (new notify-box% (value 'over-limit))) + (define-notify suffix-option (new notify-box% (value 'over-limit))) ;; syntax-font-size : number/#f ;; When non-false, overrides the default font size - (field/notify syntax-font-size (new notify-box% (value #f))) + (define-notify syntax-font-size (new notify-box% (value #f))) ;; colors : (listof string) - (field/notify colors + (define-notify colors (new notify-box% (value '("black" "red" "blue" "mediumforestgreen" "darkgreen" @@ -43,29 +42,23 @@ (define syntax-prefs-base% (class* prefs-base% (config<%>) - ;; width, height : number - (notify-methods width) - (notify-methods height) + (init readonly?) - ;; props-percentage : ... - (notify-methods props-percentage) + (define-syntax-rule (define-pref-notify* (name pref) ...) + (begin (define-notify name (notify-box/pref pref #:readonly? readonly?)) ...)) + + (define-pref-notify* + (width pref:width) + (height pref:height) + (props-percentage pref:props-percentage) + (props-shown? pref:props-shown?)) - ;; props-shown? : boolean - (notify-methods props-shown?) (super-new))) (define syntax-prefs% (class syntax-prefs-base% - (connect-to-pref width pref:width) - (connect-to-pref height pref:height) - (connect-to-pref props-percentage pref:props-percentage) - (connect-to-pref props-shown? pref:props-shown?) - (super-new))) + (super-new (readonly? #f)))) (define syntax-prefs/readonly% (class syntax-prefs-base% - (connect-to-pref/readonly width pref:width) - (connect-to-pref/readonly height pref:height) - (connect-to-pref/readonly props-percentage pref:props-percentage) - (connect-to-pref/readonly props-shown? pref:props-shown?) - (super-new))) + (super-new (readonly? #t)))) diff --git a/collects/macro-debugger/syntax-browser/syntax-snip.ss b/collects/macro-debugger/syntax-browser/syntax-snip.ss index 7aeba5139d..c5063b0c4b 100644 --- a/collects/macro-debugger/syntax-browser/syntax-snip.ss +++ b/collects/macro-debugger/syntax-browser/syntax-snip.ss @@ -19,14 +19,9 @@ (provide syntax-snip% syntax-value-snip%) -(define syntax-snip-config-base% - (class prefs-base% - (notify-methods props-shown?) - (super-new))) - (define syntax-snip-config% - (class syntax-snip-config-base% - (define/override (init-props-shown?) (new notify-box% (value #f))) + (class prefs-base% + (define-notify props-shown? (new notify-box% (value #f))) (super-new))) ;; syntax-value-snip% diff --git a/collects/macro-debugger/syntax-browser/text.ss b/collects/macro-debugger/syntax-browser/text.ss index 72193dc326..d492aa859d 100644 --- a/collects/macro-debugger/syntax-browser/text.ss +++ b/collects/macro-debugger/syntax-browser/text.ss @@ -108,7 +108,7 @@ (define text:hover-identifier-mixin (mixin (text:hover<%>) (text:hover-identifier<%>) - (field/notify hovered-identifier (new notify-box% (value #f))) + (define-notify hovered-identifier (new notify-box% (value #f))) (define idlocs null) diff --git a/collects/macro-debugger/view/frame.ss b/collects/macro-debugger/view/frame.ss index 04c0745547..f86ac94f89 100644 --- a/collects/macro-debugger/view/frame.ss +++ b/collects/macro-debugger/view/frame.ss @@ -211,18 +211,17 @@ (menu-option/notify-box extras-menu "One term at a time" (get-field one-by-one? config)) + (menu-option/notify-box extras-menu + "Extra navigation" + (get-field extra-navigation? config)) + #| (menu-option/notify-box extras-menu "Suppress warnings" (get-field suppress-warnings? config)) - (menu-option/notify-box extras-menu - "Extra navigation" - (get-field extra-navigation? config)) - (menu-option/notify-box extras-menu - "Force block->letrec transformation" - (get-field force-letrec-transformation? config)) (menu-option/notify-box extras-menu "(Debug) Catch internal errors?" - (get-field debug-catch-errors? config))) + (get-field debug-catch-errors? config)) + |#) ;; fixup-menu : menu -> void ;; Delete separators at beginning/end and duplicates in middle diff --git a/collects/macro-debugger/view/interfaces.ss b/collects/macro-debugger/view/interfaces.ss index 747c930cf8..270e406824 100644 --- a/collects/macro-debugger/view/interfaces.ss +++ b/collects/macro-debugger/view/interfaces.ss @@ -14,7 +14,6 @@ one-by-one? extra-navigation? debug-catch-errors? - force-letrec-transformation? split-context?))) (define-interface widget<%> () diff --git a/collects/macro-debugger/view/prefs.ss b/collects/macro-debugger/view/prefs.ss index 5dd1bf0d74..39100ed5b2 100644 --- a/collects/macro-debugger/view/prefs.ss +++ b/collects/macro-debugger/view/prefs.ss @@ -1,4 +1,3 @@ - #lang scheme/base (require scheme/class framework/framework @@ -16,7 +15,6 @@ (preferences:set-default 'MacroStepper:PropertiesShown? #f boolean?) (preferences:set-default 'MacroStepper:PropertiesPanelPercentage 1/3 number?) (preferences:set-default 'MacroStepper:MacroHidingMode "Standard" string?) -(preferences:set-default 'MacroStepper:ShowSyntaxProperties? #f boolean?) (preferences:set-default 'MacroStepper:ShowHidingPanel? #t boolean?) (preferences:set-default 'MacroStepper:IdentifierComparison "bound-identifier=?" string?) (preferences:set-default 'MacroStepper:HighlightFoci? #t boolean?) @@ -26,82 +24,57 @@ (preferences:set-default 'MacroStepper:OneByOne? #f boolean?) (preferences:set-default 'MacroStepper:ExtraNavigation? #f boolean?) (preferences:set-default 'MacroStepper:DebugCatchErrors? #t boolean?) -(preferences:set-default 'MacroStepper:ForceLetrecTransformation? #f boolean?) (preferences:set-default 'MacroStepper:SplitContext? #f boolean?) - (preferences:set-default 'MacroStepper:MacroStepLimit 40000 (lambda (x) (or (eq? x #f) (exact-positive-integer? x)))) -(pref:get/set pref:width MacroStepper:Frame:Width) -(pref:get/set pref:height MacroStepper:Frame:Height) -(pref:get/set pref:props-shown? MacroStepper:PropertiesShown?) -(pref:get/set pref:props-percentage MacroStepper:PropertiesPanelPercentage) -(pref:get/set pref:macro-hiding-mode MacroStepper:MacroHidingMode) -(pref:get/set pref:show-hiding-panel? MacroStepper:ShowHidingPanel?) -(pref:get/set pref:identifier=? MacroStepper:IdentifierComparison) -(pref:get/set pref:highlight-foci? MacroStepper:HighlightFoci?) -(pref:get/set pref:highlight-frontier? MacroStepper:HighlightFrontier?) -(pref:get/set pref:show-rename-steps? MacroStepper:ShowRenameSteps?) -(pref:get/set pref:suppress-warnings? MacroStepper:SuppressWarnings?) -(pref:get/set pref:one-by-one? MacroStepper:OneByOne?) -(pref:get/set pref:extra-navigation? MacroStepper:ExtraNavigation?) -(pref:get/set pref:debug-catch-errors? MacroStepper:DebugCatchErrors?) -(pref:get/set pref:force-letrec-transformation? MacroStepper:ForceLetrecTransformation?) -(pref:get/set pref:split-context? MacroStepper:SplitContext?) +(define pref:width (pref:get/set 'MacroStepper:Frame:Width)) +(define pref:height (pref:get/set 'MacroStepper:Frame:Height)) +(define pref:props-shown? (pref:get/set 'MacroStepper:PropertiesShown?)) +(define pref:props-percentage (pref:get/set 'MacroStepper:PropertiesPanelPercentage)) +(define pref:macro-hiding-mode (pref:get/set 'MacroStepper:MacroHidingMode)) +(define pref:show-hiding-panel? (pref:get/set 'MacroStepper:ShowHidingPanel?)) +(define pref:identifier=? (pref:get/set 'MacroStepper:IdentifierComparison)) +(define pref:highlight-foci? (pref:get/set 'MacroStepper:HighlightFoci?)) +(define pref:highlight-frontier? (pref:get/set 'MacroStepper:HighlightFrontier?)) +(define pref:show-rename-steps? (pref:get/set 'MacroStepper:ShowRenameSteps?)) +(define pref:suppress-warnings? (pref:get/set 'MacroStepper:SuppressWarnings?)) +(define pref:one-by-one? (pref:get/set 'MacroStepper:OneByOne?)) +(define pref:extra-navigation? (pref:get/set 'MacroStepper:ExtraNavigation?)) +(define pref:debug-catch-errors? (pref:get/set 'MacroStepper:DebugCatchErrors?)) +(define pref:split-context? (pref:get/set 'MacroStepper:SplitContext?)) +(define pref:macro-step-limit (pref:get/set 'MacroStepper:MacroStepLimit)) -(pref:get/set pref:macro-step-limit MacroStepper:MacroStepLimit) (define macro-stepper-config-base% - (class* syntax-prefs-base% (config<%>) - (notify-methods macro-hiding-mode) - (notify-methods show-hiding-panel?) - (notify-methods identifier=?) - (notify-methods highlight-foci?) - (notify-methods highlight-frontier?) - (notify-methods show-rename-steps?) - (notify-methods suppress-warnings?) - (notify-methods one-by-one?) - (notify-methods extra-navigation?) - (notify-methods debug-catch-errors?) - (notify-methods force-letrec-transformation?) - (notify-methods split-context?) + (class* prefs-base% (config<%>) + (init-field readonly?) + + (define-syntax-rule (define-pref-notify* (name pref) ...) + (begin (define-notify name (notify-box/pref pref #:readonly? readonly?)) ...)) + + (define-pref-notify* + (width pref:width) + (height pref:height) + (props-percentage pref:props-percentage) + (props-shown? pref:props-shown?) + (macro-hiding-mode pref:macro-hiding-mode) + (show-hiding-panel? pref:show-hiding-panel?) + (identifier=? pref:identifier=?) + (highlight-foci? pref:highlight-foci?) + (highlight-frontier? pref:highlight-frontier?) + (show-rename-steps? pref:show-rename-steps?) + (suppress-warnings? pref:suppress-warnings?) + (one-by-one? pref:one-by-one?) + (extra-navigation? pref:extra-navigation?) + (debug-catch-errors? pref:debug-catch-errors?) + (split-context? pref:split-context?)) (super-new))) (define macro-stepper-config/prefs% (class macro-stepper-config-base% - (connect-to-pref width pref:width) - (connect-to-pref height pref:height) - (connect-to-pref props-percentage pref:props-percentage) - (connect-to-pref props-shown? pref:props-shown?) - (connect-to-pref macro-hiding-mode pref:macro-hiding-mode) - (connect-to-pref show-hiding-panel? pref:show-hiding-panel?) - (connect-to-pref identifier=? pref:identifier=?) - (connect-to-pref highlight-foci? pref:highlight-foci?) - (connect-to-pref highlight-frontier? pref:highlight-frontier?) - (connect-to-pref show-rename-steps? pref:show-rename-steps?) - (connect-to-pref suppress-warnings? pref:suppress-warnings?) - (connect-to-pref one-by-one? pref:one-by-one?) - (connect-to-pref extra-navigation? pref:extra-navigation?) - (connect-to-pref debug-catch-errors? pref:debug-catch-errors?) - (connect-to-pref force-letrec-transformation? pref:force-letrec-transformation?) - (connect-to-pref split-context? pref:split-context?) - (super-new))) + (super-new (readonly? #f)))) (define macro-stepper-config/prefs/readonly% (class macro-stepper-config-base% - (connect-to-pref/readonly width pref:width) - (connect-to-pref/readonly height pref:height) - (connect-to-pref/readonly macro-hiding-mode pref:macro-hiding-mode) - (connect-to-pref/readonly props-percentage pref:props-percentage) - (connect-to-pref/readonly show-hiding-panel? pref:show-hiding-panel?) - (connect-to-pref/readonly identifier=? pref:identifier=?) - (connect-to-pref/readonly highlight-foci? pref:highlight-foci?) - (connect-to-pref/readonly highlight-frontier? pref:highlight-frontier?) - (connect-to-pref/readonly show-rename-steps? pref:show-rename-steps?) - (connect-to-pref/readonly suppress-warnings? pref:suppress-warnings?) - (connect-to-pref/readonly one-by-one? pref:one-by-one?) - (connect-to-pref/readonly extra-navigation? pref:extra-navigation?) - (connect-to-pref/readonly debug-catch-errors? pref:debug-catch-errors?) - (connect-to-pref/readonly force-letrec-transformation? pref:force-letrec-transformation?) - (connect-to-pref/readonly split-context? pref:split-context?) - (super-new))) + (super-new (readonly? #t)))) diff --git a/collects/macro-debugger/view/stepper.ss b/collects/macro-debugger/view/stepper.ss index ecab49d28f..6d8287678c 100644 --- a/collects/macro-debugger/view/stepper.ss +++ b/collects/macro-debugger/view/stepper.ss @@ -54,7 +54,7 @@ (cursor:next terms)) ;; current-step-index : notify of number/#f - (field/notify current-step-index (new notify-box% (value #f))) + (define-notify current-step-index (new notify-box% (value #f))) ;; add-deriv : Deriv -> void (define/public (add-deriv d) @@ -166,8 +166,6 @@ (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?)))) diff --git a/collects/unstable/class-iop.ss b/collects/unstable/class-iop.ss index a6a07e3279..1cc78b4780 100644 --- a/collects/unstable/class-iop.ss +++ b/collects/unstable/class-iop.ss @@ -1,4 +1,5 @@ #lang scheme/base +;; owner: ryanc (require scheme/class (for-syntax scheme/base syntax/parse diff --git a/collects/unstable/gui/notify.ss b/collects/unstable/gui/notify.ss index 099a5b7c33..927bef3c6a 100644 --- a/collects/unstable/gui/notify.ss +++ b/collects/unstable/gui/notify.ss @@ -1,134 +1,17 @@ - #lang scheme/base -(require (for-syntax scheme/base unstable/syntax) - scheme/list +;; owner: ryanc +(require scheme/list scheme/class - scheme/gui) -(provide field/notify - notify-methods - connect-to-pref - connect-to-pref/readonly - notify-box% - notify-box/pref - notify-box/pref/readonly + scheme/gui + "../private/notify.ss") +(provide (all-from-out "../private/notify.ss") menu-option/notify-box menu-group/notify-box check-box/notify-box choice/notify-box) -(define-for-syntax (mk-init name) - (format-id name "init-~a" (syntax-e name))) -(define-for-syntax (mk-get name) - (format-id name "get-~a" (syntax-e name))) -(define-for-syntax (mk-set name) - (format-id name "set-~a" (syntax-e name))) -(define-for-syntax (mk-listen name) - (format-id name "listen-~a" (syntax-e name))) - -(define-syntax (field/notify stx) - (syntax-case stx () - [(field/notify name value) - (with-syntax ([init-name (mk-init #'name)] - [get-name (mk-get #'name)] - [set-name (mk-set #'name)] - [listen-name (mk-listen #'name)]) - #'(begin (field [name (init-name)]) - (define/public (init-name) value) - (define/public-final (get-name) - (send name get)) - (define/public-final (set-name new-value) - (send name set new-value)) - (define/public-final (listen-name listener) - (send name listen listener))))])) - -(define-syntax (notify-methods stx) - (syntax-case stx () - [(notify-methods name) - (with-syntax ([init-name (mk-init #'name)] - [get-name (mk-get #'name)] - [set-name (mk-set #'name)] - [listen-name (mk-listen #'name)]) - #'(begin (field [name (init-name)]) - (define/public (init-name) - (new notify-box% (value #f))) - (define/public-final (get-name) - (send name get)) - (define/public-final (set-name new-value) - (send name set new-value)) - (define/public-final (listen-name listener) - (send name listen listener))))])) - -(define-syntax (connect-to-pref stx) - (syntax-case stx () - [(connect-to-pref name pref) - (with-syntax ([init-name (mk-init #'name)]) - #'(define/override (init-name) (notify-box/pref pref)))])) - -(define-syntax (connect-to-pref/readonly stx) - (syntax-case stx () - [(connect-to-pref/readonly name pref) - (with-syntax ([init-name (mk-init #'name)]) - #'(define/override (init-name) (notify-box/pref/readonly pref)))])) - -#| -(define-syntax (define/listen stx) - (syntax-case stx () - [(define/listen name value) - (unless (identifier? #'name) - (raise-syntax-error 'define/listen "expected identifier" #'name)) - (with-syntax ([get-name (mk-get #'name)] - [set-name (mk-set #'name)] - [listen-name (mk-listen #'name)]) - #'(begin - (define name value) - (define listeners null) - (define/public-final (get-name) name) - (define/public-final (set-name new-value) - (set! name new-value) - (for-each (lambda (listener) (listener new-value)) listeners)) - (define/public-final (listen-name listener) - (set! listeners (cons listener listeners)))))])) -|# - -(define notify-box% - (class object% - (init value) - (define v value) - (define listeners null) - - ;; get : -> value - ;; Fetch current value - (define/public (get) - v) - - ;; set : value -> void - ;; Update value and notify listeners - (define/public (set nv) - (set! v nv) - (for-each (lambda (p) (p nv)) listeners)) - - ;; listen : (value -> void) -> void - ;; Add a listener - (define/public (listen p) - (set! listeners (cons p listeners))) - - ;; remove-listener : (value -> void) -> void - (define/public (remove-listener p) - (set! listeners (remq p listeners))) - - ;; remove-all-listeners : -> void - (define/public (remove-all-listeners) - (set! listeners null)) - - (super-new))) - -(define (notify-box/pref pref) - (define nb (new notify-box% (value (pref)))) - (send nb listen pref) - nb) - -(define (notify-box/pref/readonly pref) - (new notify-box% (value (pref)))) +;; GUI elements tied to notify-boxes +;; See unstable/private/notify.ss for the non-gui parts of notify-boxes. (define (menu-option/notify-box parent label nb) (define menu-item diff --git a/collects/unstable/gui/prefs.ss b/collects/unstable/gui/prefs.ss index ebc5aa07f3..a9b4faa71f 100644 --- a/collects/unstable/gui/prefs.ss +++ b/collects/unstable/gui/prefs.ss @@ -1,13 +1,10 @@ - #lang scheme/base -(require (for-syntax scheme/base) +;; owner: ryanc +(require (for-syntax scheme/base syntax/parse) framework/framework) (provide pref:get/set) -(define-syntax pref:get/set - (syntax-rules () - [(_ get/set prop) - (define get/set - (case-lambda - [() (preferences:get 'prop)] - [(newval) (preferences:set 'prop newval)]))])) +(define (pref:get/set sym) + (case-lambda + [() (preferences:get sym)] + [(v) (preferences:set sym v)])) diff --git a/collects/unstable/private/class-iop-ct.ss b/collects/unstable/private/class-iop-ct.ss index fd9752da68..271ddf0fbe 100644 --- a/collects/unstable/private/class-iop-ct.ss +++ b/collects/unstable/private/class-iop-ct.ss @@ -1,4 +1,5 @@ #lang scheme/base +;; owner: ryanc (require (for-template scheme/base scheme/class) syntax/parse diff --git a/collects/unstable/private/notify.ss b/collects/unstable/private/notify.ss new file mode 100644 index 0000000000..1c53ce6910 --- /dev/null +++ b/collects/unstable/private/notify.ss @@ -0,0 +1,85 @@ +#lang scheme/base +;; owner: ryanc +(require (for-syntax scheme/base syntax/parse unstable/syntax) + scheme/list + scheme/class) +(provide define-notify + notify-box% + notify-box/pref) + +;; Non-gui parts of notify-boxes +;; Worth splitting into two libraries? +;; Probably not, very few non-gui uses of classes. + +(define-for-syntax (mk-init name) + (format-id name "init-~a" (syntax-e name))) +(define-for-syntax (mk-get name) + (format-id name "get-~a" (syntax-e name))) +(define-for-syntax (mk-set name) + (format-id name "set-~a" (syntax-e name))) +(define-for-syntax (mk-listen name) + (format-id name "listen-~a" (syntax-e name))) + +(define-syntax (define-notify stx) + (syntax-parse stx + [(define-notify name:id + (~optional value:expr + #:defaults ([value #'(new notify-box% (value #f))])) + (~optional (~and #:init-method init-method))) + (with-syntax ([init-name (mk-init #'name)] + [get-name (mk-get #'name)] + [set-name (mk-set #'name)] + [listen-name (mk-listen #'name)]) + (with-syntax ([(init-expr init-method-decl) + (if (attribute init-method) + (list #'(init-name) + #'(define/public (init-name) value)) + (list #'value + #'(begin)))]) + (quasisyntax/loc stx + (begin (field [name init-expr]) + init-method-decl + (define/public-final (get-name) + (send name get)) + (define/public-final (set-name new-value) + (send name set new-value)) + (define/public-final (listen-name listener) + (send name listen listener))))))])) + +(define notify-box% + (class object% + (init value) + (define v value) + (define listeners null) + + ;; get : -> value + ;; Fetch current value + (define/public (get) + v) + + ;; set : value -> void + ;; Update value and notify listeners + (define/public (set nv) + (set! v nv) + (for-each (lambda (p) (p nv)) listeners)) + + ;; listen : (value -> void) -> void + ;; Add a listener + (define/public (listen p) + (set! listeners (cons p listeners))) + + ;; remove-listener : (value -> void) -> void + (define/public (remove-listener p) + (set! listeners (remq p listeners))) + + ;; remove-all-listeners : -> void + (define/public (remove-all-listeners) + (set! listeners null)) + + (super-new))) + + +(define (notify-box/pref pref #:readonly? [readonly? #f]) + (define nb (new notify-box% (value (pref)))) + (send nb listen pref) + nb) diff --git a/collects/unstable/scribblings/class-iop.scrbl b/collects/unstable/scribblings/class-iop.scrbl index 93ce21ecb1..7a7b2f9652 100644 --- a/collects/unstable/scribblings/class-iop.scrbl +++ b/collects/unstable/scribblings/class-iop.scrbl @@ -1,5 +1,6 @@ #lang scribble/manual @(require scribble/eval + "utils.ss" (for-label unstable/class-iop scheme/class scheme/contract @@ -12,6 +13,8 @@ @defmodule[unstable/class-iop] +@unstable[@author+email["Ryan Culpepper" "ryanc@plt-scheme.org"]] + @defform[(define-interface name-id (super-ifc-id ...) (method-id ...))]{ Defines @scheme[name-id] as a static interface extending the diff --git a/collects/unstable/scribblings/find.scrbl b/collects/unstable/scribblings/find.scrbl index 36ce5d2cbe..44479a6484 100644 --- a/collects/unstable/scribblings/find.scrbl +++ b/collects/unstable/scribblings/find.scrbl @@ -1,5 +1,6 @@ #lang scribble/manual @(require scribble/eval + "utils.ss" (for-label unstable/find scheme/contract scheme/shared @@ -13,6 +14,8 @@ @defmodule[unstable/find] +@unstable[@author+email["Ryan Culpepper" "ryanc@plt-scheme.org"]] + @defproc[(find [pred (-> any/c any/c)] [x any/c] [#:stop-on-found? stop-on-found? any/c #f] diff --git a/collects/unstable/scribblings/gui.scrbl b/collects/unstable/scribblings/gui.scrbl index b8792b7311..333e0ccaba 100644 --- a/collects/unstable/scribblings/gui.scrbl +++ b/collects/unstable/scribblings/gui.scrbl @@ -8,3 +8,4 @@ @local-table-of-contents[] @include-section["gui/notify.scrbl"] +@include-section["gui/prefs.scrbl"] diff --git a/collects/unstable/scribblings/gui/notify.scrbl b/collects/unstable/scribblings/gui/notify.scrbl index ef0eb83b63..32cd6ac650 100644 --- a/collects/unstable/scribblings/gui/notify.scrbl +++ b/collects/unstable/scribblings/gui/notify.scrbl @@ -1,20 +1,35 @@ #lang scribble/manual -@(require (for-label unstable/gui/notify +@(require scribble/eval + "../utils.ss" + (for-label unstable/gui/notify scheme/contract scheme/class scheme/base)) @title[#:tag "gui-notify"]{Notify-boxes} +@(define the-eval (make-base-eval)) +@(the-eval '(require scheme/class unstable/private/notify)) + @defmodule[unstable/gui/notify] +@unstable[@author+email["Ryan Culpepper" "ryanc@plt-scheme.org"]] + @defclass[notify-box% object% ()]{ A notify-box contains a mutable cell. The notify-box notifies its listeners when the contents of the cell is changed. +@examples[#:eval the-eval +(define nb (new notify-box% (value 'apple))) +(send nb get) +(send nb set 'orange) +(send nb listen (lambda (v) (printf "New value: ~s\n" v))) +(send nb set 'potato) +] + @defconstructor[([value any/c])]{ - Creates a notify-box with the initial value @scheme[value]. + Creates a notify-box initially containing @scheme[value]. } @defmethod[(get) any/c]{ Gets the value currently stored in the notify-box. @@ -35,23 +50,58 @@ listeners when the contents of the cell is changed. } @defproc[(notify-box/pref - [proc (case-> (-> any/c) (-> any/c void?))]) + [proc (case-> (-> any/c) (-> any/c void?))] + [#:readonly? readonly? boolean? #f]) (is-a?/c notify-box%)]{ -Creates a notify-box with an initial value of @scheme[(proc)] that -invokes @scheme[proc] on the new value when the notify-box is updated. +Creates a notify-box with an initial value of @scheme[(proc)]. Unless +@scheme[readonly?] is true, @scheme[proc] is invoked on the new value +when the notify-box is updated. -Useful for making a notify-box tied to a preference or parameter. +Useful for tying a notify-box to a preference or parameter. Of course, +changes made directly to the underlying parameter or state are not +reflected in the notify-box. + +@examples[#:eval the-eval +(define animal (make-parameter 'ant)) +(define nb (notify-box/pref animal)) +(send nb listen (lambda (v) (printf "New value: ~s\n" v))) +(send nb set 'bee) +(animal 'cow) +(send nb get) +(send nb set 'deer) +(animal) +] } -@defproc[(notify-box/pref/readonly [proc (-> any/c)]) - (is-a?/c notify-box%)]{ +@defform[(define-notify name value-expr) + #:contracts ([value-expr (is-a?/c notify-box%)])]{ -Creates a notify-box with an initial value of @scheme[(proc)]. +Class-body form. Declares @scheme[name] as a field and +@schemeidfont{get-@scheme[name]}, @schemeidfont{set-@scheme[name]}, +and @schemeidfont{listen-@scheme[name]} as methods that delegate to +the @method[notify-box% get], @method[notify-box% set], and +@method[notify-box% listen] methods of @scheme[value]. -Useful for making a notify-box that takes its initial value from a -preference or parameter but does not update the preference or -parameter. +The @scheme[value-expr] argument must evaluate to a notify-box, not +just the initial contents for a notify box. + +Useful for aggregating many notify-boxes together into one +``configuration'' object. + +@examples[#:eval the-eval +(define config% + (class object% + (define-notify food (new notify-box% (value 'apple))) + (define-notify animal (new notify-box% (value 'ant))) + (super-new))) +(define c (new config%)) +(send c listen-food + (lambda (v) (when (eq? v 'honey) (send c set-animal 'bear)))) +(let ([food (get-field food c)]) + (send food set 'honey)) +(send c get-animal) +] } @defproc[(menu-option/notify-box @@ -107,4 +157,3 @@ Returns a list of @scheme[checkable-menu-item%] controls tied to @scheme[notify-box] to its label and invokes @scheme[notify-box]'s listeners. } - diff --git a/collects/unstable/scribblings/gui/prefs.scrbl b/collects/unstable/scribblings/gui/prefs.scrbl new file mode 100644 index 0000000000..a8ec5e4cac --- /dev/null +++ b/collects/unstable/scribblings/gui/prefs.scrbl @@ -0,0 +1,21 @@ +#lang scribble/manual +@(require "../utils.ss" + (for-label unstable/gui/prefs + scheme/contract + scheme/base)) + +@title[#:tag "gui-prefs"]{Preferences} + +@defmodule[unstable/gui/prefs] + +@unstable[@author+email["Ryan Culpepper" "ryanc@plt-scheme.org"]] + +@defproc[(pref:get/set [pref symbol?]) + (case-> (-> any/c) (-> any/c void?))]{ + +Returns a procedure that when applied to zero arguments retrieves the +current value of the preference +(@schememodname[framework/preferences]) named @scheme[pref] and when +applied to one argument updates the preference named @scheme[pref]. + +} diff --git a/collects/unstable/scribblings/struct.scrbl b/collects/unstable/scribblings/struct.scrbl index 31e5bd8fde..3ebb5f8c29 100644 --- a/collects/unstable/scribblings/struct.scrbl +++ b/collects/unstable/scribblings/struct.scrbl @@ -1,5 +1,6 @@ #lang scribble/manual @(require scribble/eval + "utils.ss" (for-label unstable/struct scheme/contract scheme/base)) @@ -11,6 +12,8 @@ @defmodule[unstable/struct] +@unstable[@author+email["Ryan Culpepper" "ryanc@plt-scheme.org"]] + @defform[(make struct-id expr ...)]{ Creates an instance of @scheme[struct-id], which must be bound as a diff --git a/collects/unstable/scribblings/syntax.scrbl b/collects/unstable/scribblings/syntax.scrbl index 7ef0fdc571..cca32cc1bb 100644 --- a/collects/unstable/scribblings/syntax.scrbl +++ b/collects/unstable/scribblings/syntax.scrbl @@ -15,6 +15,8 @@ @defmodule[unstable/syntax] +@unstable[@author+email["Ryan Culpepper" "ryanc@plt-scheme.org"]] + @defparam[current-syntax-context stx (or/c syntax? false/c)]{ The current contextual syntax object, defaulting to @scheme[#f]. It diff --git a/collects/unstable/scribblings/utils.ss b/collects/unstable/scribblings/utils.ss index c21e298715..639f9311c1 100644 --- a/collects/unstable/scribblings/utils.ss +++ b/collects/unstable/scribblings/utils.ss @@ -7,8 +7,8 @@ (make-compound-paragraph plain (list (apply author authors) - @para{This library is @emph{unstable} - ; compatibility will not be maintained. + @para{This library is @emph{unstable}; + compatibility will not be maintained. See @secref{unstable} for more information.}))) (define (addition name)