unstable: more docs, a few changes to gui libs
svn: r16887
This commit is contained in:
parent
89385ad309
commit
50bfe1b8be
|
@ -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)
|
||||
|
|
|
@ -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))))
|
||||
|
|
|
@ -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%
|
||||
|
|
|
@ -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)
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -14,7 +14,6 @@
|
|||
one-by-one?
|
||||
extra-navigation?
|
||||
debug-catch-errors?
|
||||
force-letrec-transformation?
|
||||
split-context?)))
|
||||
|
||||
(define-interface widget<%> ()
|
||||
|
|
|
@ -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))))
|
||||
|
|
|
@ -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?))))
|
||||
|
||||
|
|
|
@ -1,4 +1,5 @@
|
|||
#lang scheme/base
|
||||
;; owner: ryanc
|
||||
(require scheme/class
|
||||
(for-syntax scheme/base
|
||||
syntax/parse
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)]))
|
||||
|
|
|
@ -1,4 +1,5 @@
|
|||
#lang scheme/base
|
||||
;; owner: ryanc
|
||||
(require (for-template scheme/base
|
||||
scheme/class)
|
||||
syntax/parse
|
||||
|
|
85
collects/unstable/private/notify.ss
Normal file
85
collects/unstable/private/notify.ss
Normal file
|
@ -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)
|
|
@ -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
|
||||
|
|
|
@ -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]
|
||||
|
|
|
@ -8,3 +8,4 @@
|
|||
@local-table-of-contents[]
|
||||
|
||||
@include-section["gui/notify.scrbl"]
|
||||
@include-section["gui/prefs.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.
|
||||
}
|
||||
|
||||
|
|
21
collects/unstable/scribblings/gui/prefs.scrbl
Normal file
21
collects/unstable/scribblings/gui/prefs.scrbl
Normal file
|
@ -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].
|
||||
|
||||
}
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
Loading…
Reference in New Issue
Block a user