...
original commit: 1b01f103192530c2db2bfdef67d4af3fe3bbc476
This commit is contained in:
Robby Findler
parent
ecad5706b7
commit
f62a277e60
|
|
@ -6,9 +6,6 @@
|
|||
"test.ss"
|
||||
"test-sig.ss"
|
||||
|
||||
"prefs-file.ss"
|
||||
"prefs-file-sig.ss"
|
||||
|
||||
"gui-utils.ss"
|
||||
"gui-utils-sig.ss"
|
||||
|
||||
|
|
@ -26,6 +23,5 @@
|
|||
#f
|
||||
mred^
|
||||
(test : framework:test^)
|
||||
(prefs-file : framework:prefs-file^)
|
||||
(gui-utils : framework:gui-utils^)))
|
||||
|
||||
|
|
|
|||
|
|
@ -57,7 +57,7 @@
|
|||
x))
|
||||
(set! val x)])))
|
||||
|
||||
; the finder-dialog% class controls the user interface for dialogs
|
||||
; the finder-dialog% class controls the user interface for dialogs
|
||||
|
||||
(define finder-dialog%
|
||||
(class100 dialog% (parent-win
|
||||
|
|
|
|||
|
|
@ -904,9 +904,7 @@
|
|||
(send evt get-y))])
|
||||
(send delegate-frame click-in-overview
|
||||
(send text find-position editor-x editor-y)))))))
|
||||
(super-instantiate ())
|
||||
;(send (get-dc) set-scale 1/12 1/12)
|
||||
))
|
||||
(super-instantiate ())))
|
||||
|
||||
(define delegatee-text%
|
||||
(class text:basic%
|
||||
|
|
@ -967,6 +965,7 @@
|
|||
(invalidate-bitmap-cache x y w h)))))))
|
||||
|
||||
(define/override (on-paint before? dc left top right bottom dx dy draw-caret)
|
||||
(super-on-paint before? dc left top right bottom dx dy draw-caret)
|
||||
(when (and before?
|
||||
start-para
|
||||
end-para)
|
||||
|
|
@ -984,8 +983,7 @@
|
|||
w
|
||||
h)))
|
||||
(send dc set-pen old-pen)
|
||||
(send dc set-brush old-brush)))
|
||||
(super-on-paint before? dc left top right bottom dx dy draw-caret))
|
||||
(send dc set-brush old-brush))))
|
||||
|
||||
|
||||
;; get-rectangle : number number ->
|
||||
|
|
@ -1155,13 +1153,6 @@
|
|||
'(hide-hscroll hide-vscroll))]
|
||||
|
||||
[button-panel (make-object horizontal-panel% dialog)]
|
||||
[pref-check (make-object check-box%
|
||||
(string-constant use-separate-dialog-for-searching)
|
||||
dialog
|
||||
(lambda (pref-check evt)
|
||||
(preferences:set
|
||||
'framework:search-using-dialog?
|
||||
(send pref-check get-value))))]
|
||||
|
||||
[update-texts
|
||||
(lambda ()
|
||||
|
|
@ -1189,11 +1180,31 @@
|
|||
(lambda x
|
||||
(update-texts)
|
||||
(send frame replace-all)))]
|
||||
|
||||
[dock-button (make-object button%
|
||||
(string-constant dock)
|
||||
button-panel
|
||||
(lambda (btn evt)
|
||||
(update-texts)
|
||||
(preferences:set 'framework:search-using-dialog? #f)
|
||||
(send frame unhide-search)))]
|
||||
|
||||
[close
|
||||
(lambda ()
|
||||
(send to-be-searched-canvas force-display-focus #f)
|
||||
(send dialog show #f))]
|
||||
|
||||
[close-button (make-object button% (string-constant close) button-panel
|
||||
(lambda x
|
||||
(send to-be-searched-canvas force-display-focus #f)
|
||||
(send dialog show #f)))])
|
||||
(lambda (x y)
|
||||
(close)))]
|
||||
|
||||
[remove-pref-callback
|
||||
(preferences:add-callback
|
||||
'framework:search-using-dialog?
|
||||
(lambda (p v)
|
||||
(unless v
|
||||
(close))))])
|
||||
|
||||
(unless allow-replace?
|
||||
(send button-panel change-children
|
||||
(lambda (l)
|
||||
|
|
@ -1224,11 +1235,11 @@
|
|||
(send replace-message min-width msg-width))
|
||||
(send find-canvas focus)
|
||||
(send f-text set-position 0 (send f-text last-position))
|
||||
(send pref-check set-value (preferences:get 'framework:search-using-dialog?))
|
||||
(send button-panel set-alignment 'right 'center)
|
||||
(send dialog center 'both)
|
||||
(send to-be-searched-canvas force-display-focus #t)
|
||||
(send dialog show #t)))))
|
||||
(send dialog show #t)
|
||||
(remove-pref-callback)))))
|
||||
|
||||
(define searchable<%> (interface (basic<%>)
|
||||
get-text-to-search
|
||||
|
|
@ -1266,106 +1277,94 @@
|
|||
(send edit get-start-position))])
|
||||
(set! search-anchor position)
|
||||
|
||||
;; don't draw the anchor
|
||||
;; don't draw the anchor
|
||||
'(set! old-search-highlight
|
||||
(send edit highlight-range position position color #f))))))
|
||||
|
||||
(define find-string-embedded
|
||||
(let ([default-direction 'forward]
|
||||
[default-start 'start]
|
||||
[default-end 'eof]
|
||||
[default-get-start #t]
|
||||
[default-case-sensitive? #t]
|
||||
[default-pop-out? #f])
|
||||
(case-lambda
|
||||
[(edit str)
|
||||
(find-string-embedded edit str default-direction default-start default-end default-get-start default-case-sensitive? default-pop-out?)]
|
||||
[(edit str direction)
|
||||
(find-string-embedded edit str direction default-start default-end default-get-start default-case-sensitive? default-pop-out?)]
|
||||
[(edit str direction start)
|
||||
(find-string-embedded edit str direction start default-end default-get-start default-case-sensitive? default-pop-out?)]
|
||||
[(edit str direction start end)
|
||||
(find-string-embedded edit str direction start end default-get-start default-case-sensitive? default-pop-out?)]
|
||||
[(edit str direction start end get-start)
|
||||
(find-string-embedded edit str direction start end get-start default-case-sensitive? default-pop-out?)]
|
||||
[(edit str direction start end get-start case-sensitive?)
|
||||
(find-string-embedded edit str direction start end get-start case-sensitive? default-pop-out?)]
|
||||
[(edit str direction start end get-start case-sensitive? pop-out?)
|
||||
(unless (member direction '(forward backward))
|
||||
(error 'find-string-embedded
|
||||
"expected ~e or ~e as first argument, got: ~e" 'forward 'backward direction))
|
||||
(let/ec k
|
||||
(let* ([start (if (eq? start 'start)
|
||||
(send edit get-start-position)
|
||||
start)]
|
||||
[end (if (eq? 'eof end)
|
||||
(if (eq? direction 'forward)
|
||||
(send edit last-position)
|
||||
0)
|
||||
end)]
|
||||
[flat (send edit find-string str direction
|
||||
start end get-start
|
||||
case-sensitive?)]
|
||||
[pop-out
|
||||
(lambda ()
|
||||
(let ([admin (send edit get-admin)])
|
||||
(if (is-a? admin editor-snip-editor-admin<%>)
|
||||
(let* ([snip (send admin get-snip)]
|
||||
[edit-above (send (send snip get-admin) get-editor)]
|
||||
[pos (send edit-above get-snip-position snip)]
|
||||
[pop-out-pos (if (eq? direction 'forward) (add1 pos) pos)])
|
||||
(find-string-embedded
|
||||
edit-above
|
||||
str
|
||||
direction
|
||||
pop-out-pos
|
||||
(if (eq? direction 'forward) 'eof 0)
|
||||
get-start
|
||||
case-sensitive?
|
||||
pop-out?))
|
||||
(values edit #f))))])
|
||||
(let loop ([current-snip (send edit find-snip start
|
||||
(if (eq? direction 'forward)
|
||||
'after-or-none
|
||||
'before-or-none))])
|
||||
(let ([next-loop
|
||||
(lambda ()
|
||||
(if (eq? direction 'forward)
|
||||
(loop (send current-snip next))
|
||||
(loop (send current-snip previous))))])
|
||||
(cond
|
||||
[(or (not current-snip)
|
||||
(and flat
|
||||
(let* ([start (send edit get-snip-position current-snip)]
|
||||
[end (+ start (send current-snip get-count))])
|
||||
(if (eq? direction 'forward)
|
||||
(and (<= start flat)
|
||||
(< flat end))
|
||||
(and (< start flat)
|
||||
(<= flat end))))))
|
||||
(if (and (not flat) pop-out?)
|
||||
(pop-out)
|
||||
(values edit flat))]
|
||||
[(is-a? current-snip editor-snip%)
|
||||
(let-values ([(embedded embedded-pos)
|
||||
(let ([media (send current-snip get-editor)])
|
||||
(if (and media
|
||||
(is-a? media text%))
|
||||
(begin
|
||||
(find-string-embedded
|
||||
media
|
||||
str
|
||||
direction
|
||||
(if (eq? 'forward direction)
|
||||
0
|
||||
(send media last-position))
|
||||
'eof
|
||||
get-start case-sensitive?))
|
||||
(values #f #f)))])
|
||||
(if (not embedded-pos)
|
||||
(next-loop)
|
||||
(values embedded embedded-pos)))]
|
||||
[else (next-loop)])))))])))
|
||||
(opt-lambda (edit
|
||||
str
|
||||
[direction 'forward]
|
||||
[start 'start]
|
||||
[end 'eof]
|
||||
[get-start #t]
|
||||
[case-sensitive? #t]
|
||||
[pop-out? #f])
|
||||
(unless (member direction '(forward backward))
|
||||
(error 'find-string-embedded
|
||||
"expected ~e or ~e as first argument, got: ~e" 'forward 'backward direction))
|
||||
(let/ec k
|
||||
(let* ([start (if (eq? start 'start)
|
||||
(send edit get-start-position)
|
||||
start)]
|
||||
[end (if (eq? 'eof end)
|
||||
(if (eq? direction 'forward)
|
||||
(send edit last-position)
|
||||
0)
|
||||
end)]
|
||||
[flat (send edit find-string str direction
|
||||
start end get-start
|
||||
case-sensitive?)]
|
||||
[pop-out
|
||||
(lambda ()
|
||||
(let ([admin (send edit get-admin)])
|
||||
(if (is-a? admin editor-snip-editor-admin<%>)
|
||||
(let* ([snip (send admin get-snip)]
|
||||
[edit-above (send (send snip get-admin) get-editor)]
|
||||
[pos (send edit-above get-snip-position snip)]
|
||||
[pop-out-pos (if (eq? direction 'forward) (add1 pos) pos)])
|
||||
(find-string-embedded
|
||||
edit-above
|
||||
str
|
||||
direction
|
||||
pop-out-pos
|
||||
(if (eq? direction 'forward) 'eof 0)
|
||||
get-start
|
||||
case-sensitive?
|
||||
pop-out?))
|
||||
(values edit #f))))])
|
||||
(let loop ([current-snip (send edit find-snip start
|
||||
(if (eq? direction 'forward)
|
||||
'after-or-none
|
||||
'before-or-none))])
|
||||
(let ([next-loop
|
||||
(lambda ()
|
||||
(if (eq? direction 'forward)
|
||||
(loop (send current-snip next))
|
||||
(loop (send current-snip previous))))])
|
||||
(cond
|
||||
[(or (not current-snip)
|
||||
(and flat
|
||||
(let* ([start (send edit get-snip-position current-snip)]
|
||||
[end (+ start (send current-snip get-count))])
|
||||
(if (eq? direction 'forward)
|
||||
(and (<= start flat)
|
||||
(< flat end))
|
||||
(and (< start flat)
|
||||
(<= flat end))))))
|
||||
(if (and (not flat) pop-out?)
|
||||
(pop-out)
|
||||
(values edit flat))]
|
||||
[(is-a? current-snip editor-snip%)
|
||||
(let-values ([(embedded embedded-pos)
|
||||
(let ([media (send current-snip get-editor)])
|
||||
(if (and media
|
||||
(is-a? media text%))
|
||||
(begin
|
||||
(find-string-embedded
|
||||
media
|
||||
str
|
||||
direction
|
||||
(if (eq? 'forward direction)
|
||||
0
|
||||
(send media last-position))
|
||||
'eof
|
||||
get-start case-sensitive?))
|
||||
(values #f #f)))])
|
||||
(if (not embedded-pos)
|
||||
(next-loop)
|
||||
(values embedded embedded-pos)))]
|
||||
[else (next-loop)])))))))
|
||||
|
||||
(define searching-frame #f)
|
||||
(define (set-searching-frame frame)
|
||||
|
|
@ -1471,10 +1470,10 @@
|
|||
(search #f)))])
|
||||
(sequence (apply super-init args))))
|
||||
|
||||
; this is here for when editors are printed.
|
||||
; this is here for when editors are printed, during debugging
|
||||
(define replace-text%
|
||||
(class100 text:keymap% args
|
||||
(sequence (apply super-init args))))
|
||||
(class text:keymap%
|
||||
(super-instantiate ())))
|
||||
|
||||
(define find-edit #f)
|
||||
(define replace-edit #f)
|
||||
|
|
@ -1552,19 +1551,28 @@
|
|||
(remove search-panel l)))
|
||||
(clear-search-highlight)
|
||||
(unless startup?
|
||||
(send
|
||||
(send (get-text-to-search) get-canvas)
|
||||
focus))
|
||||
(let ([canvas (send (get-text-to-search) get-canvas)])
|
||||
(send canvas force-display-focus #f)
|
||||
(send canvas focus)))
|
||||
(set! hidden? #t)))
|
||||
(define unhide-search
|
||||
(lambda ()
|
||||
(when (and hidden?
|
||||
(not (preferences:get 'framework:search-using-dialog?)))
|
||||
(set! hidden? #f)
|
||||
(show/hide-replace (send (get-text-to-search) is-locked?))
|
||||
(send search-panel focus)
|
||||
(send super-root add-child search-panel)
|
||||
(reset-search-anchor (get-text-to-search)))))
|
||||
|
||||
(define (unhide-search)
|
||||
(when (and hidden?
|
||||
(not (preferences:get 'framework:search-using-dialog?)))
|
||||
(set! hidden? #f)
|
||||
(let ([canvas (send (get-text-to-search) get-canvas)])
|
||||
(when canvas
|
||||
(send canvas force-display-focus #t)))
|
||||
(show/hide-replace (send (get-text-to-search) is-locked?))
|
||||
(send search-panel focus)
|
||||
(send find-edit set-position 0 (send find-edit last-position))
|
||||
(send super-root add-child search-panel)
|
||||
(reset-search-anchor (get-text-to-search))))
|
||||
|
||||
(define (undock)
|
||||
(preferences:set 'framework:search-using-dialog? #t)
|
||||
(hide-search)
|
||||
(search-dialog this))
|
||||
|
||||
(define (show/hide-replace hide?)
|
||||
(cond
|
||||
|
|
@ -1748,9 +1756,13 @@
|
|||
'backward)])
|
||||
(set-search-direction forward)
|
||||
(reset-search-anchor (get-text-to-search))))))
|
||||
(define close-button (make-object button% (string-constant hide)
|
||||
middle-right-panel
|
||||
(define hide/undock-pane (make-object horizontal-panel% middle-right-panel))
|
||||
(define hide-button (make-object button% (string-constant hide)
|
||||
hide/undock-pane
|
||||
(lambda args (hide-search))))
|
||||
(define undock-button (make-object button% (string-constant undock)
|
||||
hide/undock-pane
|
||||
(lambda args (undock))))
|
||||
(define hidden? #f)
|
||||
|
||||
(let ([align
|
||||
|
|
|
|||
|
|
@ -2,7 +2,9 @@
|
|||
(require (lib "unitsig.ss")
|
||||
(lib "class.ss")
|
||||
"sig.ss"
|
||||
"../gui-utils-sig.ss"
|
||||
"../macro"
|
||||
(lib "string-constant.ss" "string-constants")
|
||||
(lib "mred-sig.ss" "mred"))
|
||||
|
||||
(provide main@)
|
||||
|
|
@ -12,7 +14,8 @@
|
|||
(import mred^
|
||||
[preferences : framework:preferences^]
|
||||
[exit : framework:exit^]
|
||||
[group : framework:group^])
|
||||
[group : framework:group^]
|
||||
[gui-utils : framework:gui-utils^])
|
||||
|
||||
;; preferences
|
||||
|
||||
|
|
@ -149,9 +152,17 @@
|
|||
(lambda ()
|
||||
(send (group:get-the-frame-group) on-close-all))))))
|
||||
|
||||
(exit:insert-on-callback
|
||||
(exit:insert-can?-callback
|
||||
(lambda ()
|
||||
(preferences:save)))
|
||||
(or (preferences:save)
|
||||
(exit-anyway?))))
|
||||
|
||||
(define (exit-anyway?)
|
||||
(gui-utils:get-choice
|
||||
(string-constant still-locked-exit-anyway?)
|
||||
(string-constant yes)
|
||||
(string-constant no)
|
||||
(string-constant drscheme)))
|
||||
|
||||
(preferences:read)
|
||||
|
||||
|
|
|
|||
|
|
@ -30,46 +30,53 @@
|
|||
(define single<%> (interface (area-container<%>) active-child))
|
||||
(define single-mixin
|
||||
(mixin (area-container<%>) (single<%>)
|
||||
(inherit get-alignment)
|
||||
(inherit get-alignment change-children)
|
||||
(rename [super-after-new-child after-new-child])
|
||||
(override after-new-child container-size place-children)
|
||||
[define after-new-child
|
||||
(lambda (c)
|
||||
(if current-active-child
|
||||
(send c show #f)
|
||||
(set! current-active-child c)))]
|
||||
[define container-size
|
||||
(lambda (l)
|
||||
(if (null? l)
|
||||
(values 0 0)
|
||||
(values (apply max (map car l)) (apply max (map cadr l)))))]
|
||||
[define place-children
|
||||
(lambda (l width height)
|
||||
(let-values ([(h-align-spec v-align-spec) (get-alignment)])
|
||||
(let ([align
|
||||
(lambda (total-size spec item-size)
|
||||
(floor
|
||||
(case spec
|
||||
[(center) (- (/ total-size 2) (/ item-size 2))]
|
||||
[(left top) 0]
|
||||
[(right bottom) (- total-size item-size)]
|
||||
[else (error 'place-children
|
||||
"alignment spec is unknown ~a~n" spec)])))])
|
||||
(map (lambda (l)
|
||||
(let*-values ([(min-width min-height v-stretch? h-stretch?)
|
||||
(apply values l)]
|
||||
[(x this-width)
|
||||
(if h-stretch?
|
||||
(values 0 width)
|
||||
(values (align width h-align-spec min-width)
|
||||
min-width))]
|
||||
[(y this-height)
|
||||
(if v-stretch?
|
||||
(values 0 height)
|
||||
(values (align height v-align-spec min-height)
|
||||
min-height))])
|
||||
(list x y this-width this-height)))
|
||||
l))))]
|
||||
(define/override (after-new-child c)
|
||||
(unless (is-a? c window<%>)
|
||||
|
||||
;; would like to remove the child here, waiting on a PR submitted
|
||||
;; about change-children during after-new-child
|
||||
(change-children
|
||||
(lambda (l)
|
||||
(remq c l)))
|
||||
|
||||
(error 'single-mixin::after-new-child
|
||||
"all children must implement window<%>, got ~e"
|
||||
c))
|
||||
(if current-active-child
|
||||
(send c show #f)
|
||||
(set! current-active-child c)))
|
||||
[define/override (container-size l)
|
||||
(if (null? l)
|
||||
(values 0 0)
|
||||
(values (apply max (map car l)) (apply max (map cadr l))))]
|
||||
[define/override (place-children l width height)
|
||||
(let-values ([(h-align-spec v-align-spec) (get-alignment)])
|
||||
(let ([align
|
||||
(lambda (total-size spec item-size)
|
||||
(floor
|
||||
(case spec
|
||||
[(center) (- (/ total-size 2) (/ item-size 2))]
|
||||
[(left top) 0]
|
||||
[(right bottom) (- total-size item-size)]
|
||||
[else (error 'place-children
|
||||
"alignment spec is unknown ~a~n" spec)])))])
|
||||
(map (lambda (l)
|
||||
(let*-values ([(min-width min-height v-stretch? h-stretch?)
|
||||
(apply values l)]
|
||||
[(x this-width)
|
||||
(if h-stretch?
|
||||
(values 0 width)
|
||||
(values (align width h-align-spec min-width)
|
||||
min-width))]
|
||||
[(y this-height)
|
||||
(if v-stretch?
|
||||
(values 0 height)
|
||||
(values (align height v-align-spec min-height)
|
||||
min-height))])
|
||||
(list x y this-width this-height)))
|
||||
l)))]
|
||||
|
||||
(inherit get-children)
|
||||
[define current-active-child #f]
|
||||
|
|
|
|||
|
|
@ -6,7 +6,6 @@
|
|||
(lib "file.ss")
|
||||
(lib "class100.ss")
|
||||
"sig.ss"
|
||||
"../prefs-file-sig.ss"
|
||||
(lib "mred-sig.ss" "mred")
|
||||
(lib "pretty.ss")
|
||||
(lib "list.ss"))
|
||||
|
|
@ -15,16 +14,13 @@
|
|||
(define preferences@
|
||||
(unit/sig framework:preferences^
|
||||
(import mred^
|
||||
[prefs-file : framework:prefs-file^]
|
||||
[exn : framework:exn^]
|
||||
[exit : framework:exit^]
|
||||
[panel : framework:panel^])
|
||||
|
||||
(rename [-read read])
|
||||
|
||||
;; default-preferences-filename
|
||||
(define default-preferences-filename
|
||||
(build-path (collection-path "defaults") "prefs.ss"))
|
||||
(define main-preferences-symbol 'plt:framework-prefs)
|
||||
|
||||
;; preferences : sym -o> (union marshalled pref)
|
||||
(define preferences (make-hash-table))
|
||||
|
|
@ -35,9 +31,6 @@
|
|||
;; callbacks : sym -o> (listof (sym TST -> boolean))
|
||||
(define callbacks (make-hash-table))
|
||||
|
||||
;; saved-defaults : sym -o> (union marshalled pref)
|
||||
(define saved-defaults (make-hash-table))
|
||||
|
||||
;; defaults : sym -o> default
|
||||
(define defaults (make-hash-table))
|
||||
|
||||
|
|
@ -78,32 +71,38 @@
|
|||
p
|
||||
(lambda () null)))
|
||||
|
||||
;; pref-callback : (make-pref-callback (sym tst -> void))
|
||||
;; this is used as a wrapped to hack around the problem
|
||||
;; that different procedures might be eq?.
|
||||
(define-struct pref-callback (cb))
|
||||
|
||||
;; add-callback : sym (-> void) -> void
|
||||
(define (add-callback p callback)
|
||||
(hash-table-put! callbacks p
|
||||
(append
|
||||
(hash-table-get callbacks p (lambda () null))
|
||||
(list callback)))
|
||||
(lambda ()
|
||||
(hash-table-put!
|
||||
callbacks
|
||||
p
|
||||
(let loop ([callbacks (hash-table-get callbacks p (lambda () null))])
|
||||
(cond
|
||||
[(null? callbacks) null]
|
||||
[else
|
||||
(let ([callback (car callbacks)])
|
||||
(cond
|
||||
[(eq? callback callback)
|
||||
(loop (cdr callbacks))]
|
||||
[else
|
||||
(cons (car callbacks) (loop (cdr callbacks)))]))])))))
|
||||
(let ([new-cb (make-pref-callback callback)])
|
||||
(hash-table-put! callbacks p
|
||||
(append
|
||||
(hash-table-get callbacks p (lambda () null))
|
||||
(list new-cb)))
|
||||
(lambda ()
|
||||
(hash-table-put!
|
||||
callbacks
|
||||
p
|
||||
(let loop ([callbacks (hash-table-get callbacks p (lambda () null))])
|
||||
(cond
|
||||
[(null? callbacks) null]
|
||||
[else
|
||||
(let ([callback (car callbacks)])
|
||||
(cond
|
||||
[(eq? callback new-cb)
|
||||
(loop (cdr callbacks))]
|
||||
[else
|
||||
(cons (car callbacks) (loop (cdr callbacks)))]))]))))))
|
||||
|
||||
(define check-callbacks
|
||||
(lambda (p value)
|
||||
(andmap (lambda (x)
|
||||
(guard "calling callback" p value
|
||||
(lambda () (x p value))
|
||||
(lambda () ((pref-callback-cb x) p value))
|
||||
raise))
|
||||
(get-callbacks p))))
|
||||
|
||||
|
|
@ -137,9 +136,17 @@
|
|||
(pref-value ans)]
|
||||
[else (error 'prefs.ss "robby error.1: ~a" ans)])))
|
||||
|
||||
(define (default-set? p)
|
||||
(let/ec k
|
||||
(hash-table-get defaults p (lambda () (k #f)))
|
||||
#t))
|
||||
|
||||
(define (set p value)
|
||||
(let* ([pref (hash-table-get preferences p (lambda () #f))])
|
||||
(cond
|
||||
(unless (default-set? p)
|
||||
(error 'preferences:set "tried to set a preference but no default set for ~e, with ~e"
|
||||
p value))
|
||||
(cond
|
||||
[(pref? pref)
|
||||
(when (check-callbacks p value)
|
||||
(set-pref-value! pref value))]
|
||||
|
|
@ -152,8 +159,7 @@
|
|||
|
||||
(define set-un/marshall
|
||||
(lambda (p marshall unmarshall)
|
||||
(when (let ([b (box #f)])
|
||||
(eq? b (hash-table-get defaults p (lambda () b))))
|
||||
(unless (default-set? p)
|
||||
(error 'set-un/marshall "must call set-default for ~s before calling set-un/marshall for ~s"
|
||||
p p))
|
||||
(hash-table-put! marshall-unmarshall p (make-un/marshall marshall unmarshall))))
|
||||
|
|
@ -165,27 +171,8 @@
|
|||
(lambda (p v) (set p v)))))
|
||||
|
||||
;; set-default : (sym TST (TST -> boolean) -> void
|
||||
(define (set-default p in-default-value checker)
|
||||
(let* ([default-value
|
||||
(let/ec k
|
||||
(let ([saved-default
|
||||
(hash-table-get saved-defaults p (lambda ()
|
||||
(k in-default-value)))])
|
||||
(cond
|
||||
[(marshalled? saved-default)
|
||||
(let* ([unmarsh (unmarshall p saved-default)]
|
||||
[unmarshalled
|
||||
(if (checker unmarsh)
|
||||
unmarsh
|
||||
in-default-value)]
|
||||
[pref (if (check-callbacks p unmarshalled)
|
||||
unmarshalled
|
||||
in-default-value)])
|
||||
(hash-table-put! saved-defaults p (make-pref pref))
|
||||
pref)]
|
||||
[(pref? saved-default)
|
||||
(pref-value saved-default)])))]
|
||||
[default-okay? (checker default-value)])
|
||||
(define (set-default p default-value checker)
|
||||
(let ([default-okay? (checker default-value)])
|
||||
(unless default-okay?
|
||||
(error 'set-default "~s: checker (~s) returns ~s for ~s, expected #t~n"
|
||||
p checker default-okay? default-value))
|
||||
|
|
@ -194,38 +181,55 @@
|
|||
(hash-table-put! preferences p (make-pref default-value))))
|
||||
(hash-table-put! defaults p (make-default default-value checker))))
|
||||
|
||||
(define save
|
||||
(let ([marshall-pref
|
||||
(lambda (p ht-value)
|
||||
(cond
|
||||
[(marshalled? ht-value) (list p (marshalled-data ht-value))]
|
||||
[(pref? ht-value)
|
||||
(let* ([value (pref-value ht-value)]
|
||||
[marshalled
|
||||
(let/ec k
|
||||
(guard "marshalling" p value
|
||||
(lambda ()
|
||||
((un/marshall-marshall
|
||||
(hash-table-get marshall-unmarshall p
|
||||
(lambda ()
|
||||
(k value))))
|
||||
value))
|
||||
raise))])
|
||||
(list p marshalled))]
|
||||
[else (error 'prefs.ss "robby error.2: ~a" ht-value)]))])
|
||||
(lambda ()
|
||||
(with-handlers ([(lambda (x) #t)
|
||||
(lambda (exn)
|
||||
(message-box
|
||||
(string-constant error-saving-preferences)
|
||||
(exn-message exn)))])
|
||||
(call-with-output-file (prefs-file:get-preferences-filename)
|
||||
(lambda (p)
|
||||
(pretty-print
|
||||
(hash-table-map preferences marshall-pref) p))
|
||||
'truncate 'text)))))
|
||||
(define (save)
|
||||
(with-handlers ([(lambda (x) #t)
|
||||
(lambda (exn)
|
||||
(message-box
|
||||
(string-constant preferences)
|
||||
(format (string-constant error-saving-preferences)
|
||||
(exn-message exn)))
|
||||
#f)])
|
||||
(let ([syms (list main-preferences-symbol)]
|
||||
[vals (list (hash-table-map preferences marshall-pref))]
|
||||
[res #t])
|
||||
(put-preferences
|
||||
syms vals
|
||||
(lambda (filename)
|
||||
(let* ([d (make-object dialog% (string-constant preferences))]
|
||||
[m (make-object message% (string-constant waiting-for-pref-lock) d)])
|
||||
(thread
|
||||
(lambda ()
|
||||
(sleep 2)
|
||||
(send d show #f)))
|
||||
(send d show #t)
|
||||
(put-preferences
|
||||
syms vals
|
||||
(lambda (filename)
|
||||
(set! res #f)
|
||||
(message-box
|
||||
(string-constant preferences)
|
||||
(format (string-constant pref-lock-not-gone) filename)))))))
|
||||
res)))
|
||||
|
||||
(define (err input msg)
|
||||
(define (marshall-pref p ht-value)
|
||||
(cond
|
||||
[(marshalled? ht-value) (list p (marshalled-data ht-value))]
|
||||
[(pref? ht-value)
|
||||
(let* ([value (pref-value ht-value)]
|
||||
[marshalled
|
||||
(let/ec k
|
||||
(guard "marshalling" p value
|
||||
(lambda ()
|
||||
((un/marshall-marshall
|
||||
(hash-table-get marshall-unmarshall p
|
||||
(lambda ()
|
||||
(k value))))
|
||||
value))
|
||||
raise))])
|
||||
(list p marshalled))]
|
||||
[else (error 'prefs.ss "robby error.2: ~a" ht-value)]))
|
||||
|
||||
(define (read-err input msg)
|
||||
(message-box
|
||||
(string-constant preferences)
|
||||
(let* ([max-len 150]
|
||||
|
|
@ -268,18 +272,10 @@
|
|||
(if (and (list? pre-pref)
|
||||
(= 2 (length pre-pref)))
|
||||
(parse-pref (car pre-pref) (cadr pre-pref))
|
||||
(begin (err input (string-constant expected-list-of-length2))
|
||||
(begin (read-err input (string-constant expected-list-of-length2))
|
||||
(k #f))))
|
||||
(loop (cdr input))))))
|
||||
|
||||
;; read-from-file-to-ht : string hash-table -> void
|
||||
(define (read-from-file-to-ht filename ht)
|
||||
(let* ([parse-pref
|
||||
(lambda (p marshalled)
|
||||
(add-raw-pref-to-ht ht p marshalled))])
|
||||
(when (file-exists? filename)
|
||||
(for-each-pref-in-file parse-pref filename))))
|
||||
|
||||
;; add-raw-pref-to-ht : hash-table symbol marshalled-preference -> void
|
||||
(define (add-raw-pref-to-ht ht p marshalled)
|
||||
(let* ([ht-pref (hash-table-get ht p (lambda () #f))]
|
||||
|
|
@ -305,22 +301,12 @@
|
|||
;; read : -> void
|
||||
(define (-read)
|
||||
(let/ec k
|
||||
(let ([sexp (get-preference
|
||||
'drscheme:preferences
|
||||
(lambda ()
|
||||
(k #f)))])
|
||||
(let ([sexp (get-preference main-preferences-symbol (lambda () (k #f)))])
|
||||
(for-each-pref-in-sexp
|
||||
sexp
|
||||
(lambda (p marshalled)
|
||||
(add-raw-pref-to-ht preferences p marshalled)))))
|
||||
;(read-from-file-to-ht (prefs-file:get-preferences-filename) preferences)
|
||||
)
|
||||
|
||||
;; read in the saved defaults. These should override the
|
||||
;; values used with set-default.
|
||||
(read-from-file-to-ht default-preferences-filename saved-defaults)
|
||||
|
||||
|
||||
(add-raw-pref-to-ht preferences p marshalled))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; ;;;
|
||||
;;; preferences dialog ;;;
|
||||
|
|
@ -571,6 +557,12 @@
|
|||
|
||||
(define add-panel
|
||||
(lambda (title container)
|
||||
(unless (and (string? title)
|
||||
(procedure? container)
|
||||
(procedure-arity-includes? container 1))
|
||||
(error 'preferences:add-panel
|
||||
"expected a string and a function that can accept one argument, got ~e and ~e"
|
||||
title container))
|
||||
(set! ppanels
|
||||
(append ppanels (list (make-ppanel title container #f))))
|
||||
(when preferences-dialog
|
||||
|
|
|
|||
|
|
@ -50,13 +50,14 @@
|
|||
(field [sizing-text (format "~a ~a" left-bracket right-bracket)])
|
||||
|
||||
(rename [super-get-text get-text])
|
||||
(define/override (get-text offset num flattened?)
|
||||
(if flattened?
|
||||
(apply string-append
|
||||
(map (lambda (snip)
|
||||
(send snip get-text 0 (send snip get-count) flattened?))
|
||||
saved-snips))
|
||||
(super-get-text offset num flattened?)))
|
||||
(define/override get-text
|
||||
(opt-lambda (offset num [flattened? #f])
|
||||
(if flattened?
|
||||
(apply string-append
|
||||
(map (lambda (snip)
|
||||
(send snip get-text 0 (send snip get-count) flattened?))
|
||||
saved-snips))
|
||||
(super-get-text offset num flattened?))))
|
||||
|
||||
(define/override (copy)
|
||||
(instantiate (get-sexp-snip-class) ()
|
||||
|
|
@ -237,11 +238,20 @@
|
|||
left-pos left-pos)
|
||||
(send text end-edit-sequence))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; ;;
|
||||
;; Text ;;
|
||||
;; ;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
|
||||
;;
|
||||
; ; ;
|
||||
; ; ;
|
||||
;;; ;;; ; ;; ;;; ;;; ; ;;; ;;;;; ;;; ;;; ;;; ;;;;;
|
||||
; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
||||
;;; ; ; ; ;;;;; ; ; ; ;;;;; ; ;;;;; ; ;
|
||||
; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
||||
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
||||
;;; ;;; ;;; ;;; ;;; ;; ; ;; ;;; ; ;;; ;;; ;; ;; ;;;
|
||||
|
||||
|
||||
|
||||
|
||||
(define-struct string/pos (string pos))
|
||||
|
||||
|
|
@ -467,8 +477,7 @@
|
|||
[define clear-old-locations 'dummy]
|
||||
(set! clear-old-locations void)
|
||||
|
||||
(public highlight-parens)
|
||||
(define highlight-parens
|
||||
(define/public highlight-parens
|
||||
(opt-lambda ([just-clear? #f])
|
||||
(when highlight-parens?
|
||||
(set! in-highlight-parens? #t)
|
||||
|
|
@ -1046,13 +1055,22 @@
|
|||
(set-styles-fixed #t)))
|
||||
|
||||
(define -text% (text-mixin text:info%))
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; ;;
|
||||
;; Scheme Keymap ;;
|
||||
;; ;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
|
||||
|
||||
;; ;;
|
||||
; ;
|
||||
; ;
|
||||
;;; ;;; ; ;; ;;; ;;; ; ;;; ; ;; ;;; ;;; ;;;;;; ; ;;;; ; ;;;
|
||||
; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
||||
;;; ; ; ; ;;;;; ; ; ; ;;;;; ;; ;;;;; ; ; ; ; ; ;;;; ; ;
|
||||
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
||||
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;; ; ; ; ; ; ; ;
|
||||
;;; ;;; ;;; ;;; ;;; ;; ; ;; ;;; ;; ;; ;;; ; ;; ; ;; ;;; ; ;;;;
|
||||
; ;
|
||||
; ;
|
||||
;; ;;;
|
||||
(define setup-keymap
|
||||
(lambda (keymap)
|
||||
|
||||
|
|
@ -1180,13 +1198,30 @@
|
|||
(map-meta "s:c:n" "flash-forward-sexp")
|
||||
|
||||
(map-meta "c:space" "select-forward-sexp")
|
||||
(map-meta "c:t" "transpose-sexp"))
|
||||
(map-meta "c:t" "transpose-sexp")
|
||||
|
||||
(map-meta "c:m" "mark-matching-parenthesis"))
|
||||
(send keymap map-function "c:c;c:b" "remove-parens-forward")))
|
||||
|
||||
(define keymap (make-object keymap:aug-keymap%))
|
||||
(setup-keymap keymap)
|
||||
(define (get-keymap) keymap)
|
||||
|
||||
|
||||
;;; ;;;
|
||||
; ;
|
||||
; ;
|
||||
; ;;; ; ;;; ;;; ;;;;; ;;; ; ;;; ;;;; ; ;;; ;;; ;
|
||||
; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ;
|
||||
; ; ; ;;;;; ; ;;; ; ; ;;;; ; ; ;;;;; ;
|
||||
; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
||||
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
||||
;;;; ;;;; ;;; ;;;; ;;; ;;;; ;;; ;;;; ;; ;;; ;;;;;;
|
||||
; ;
|
||||
; ;
|
||||
;;; ;;;
|
||||
|
||||
|
||||
(define (add-preferences-panel)
|
||||
(preferences:add-panel
|
||||
(string-constant indenting-prefs-panel-label)
|
||||
|
|
|
|||
|
|
@ -140,7 +140,7 @@
|
|||
"@ilink frame:standard-menus get-help-menu %"
|
||||
". "
|
||||
""
|
||||
"@return : (derived-from \\iscmclass{menu:can-restore-underscore-menu%})"
|
||||
"@return : (derived-from \\iscmclass{menu:can-restore-underscore-menu})"
|
||||
""
|
||||
"defaultly returns"
|
||||
"@link menu"))
|
||||
|
|
|
|||
|
|
@ -60,32 +60,42 @@
|
|||
(let ([b1 (box 0)]
|
||||
[b2 (box 0)]
|
||||
[b3 (box 0)]
|
||||
[b4 (box 0)])
|
||||
[b4 (box 0)]
|
||||
[canvases (get-canvases)])
|
||||
(let-values ([(min-left max-right)
|
||||
(let loop ([left #f]
|
||||
[right #f]
|
||||
[canvases (get-canvases)])
|
||||
(cond
|
||||
[(null? canvases)
|
||||
(values left right)]
|
||||
[else
|
||||
(let-values ([(this-left this-right)
|
||||
(send (car canvases)
|
||||
call-as-primary-owner
|
||||
(lambda ()
|
||||
(send (get-admin) get-view b1 b2 b3 b4)
|
||||
(let* ([this-left (unbox b1)]
|
||||
[this-width (unbox b3)]
|
||||
[this-right (+ this-left this-width)])
|
||||
(values this-left
|
||||
this-right))))])
|
||||
(if (and left right)
|
||||
(loop (min this-left left)
|
||||
(max this-right right)
|
||||
(cdr canvases))
|
||||
(loop this-left
|
||||
this-right
|
||||
(cdr canvases))))]))])
|
||||
(cond
|
||||
[(null? canvases)
|
||||
(send (get-admin) get-view b1 b2 b3 b4)
|
||||
(let* ([this-left (unbox b1)]
|
||||
[this-width (unbox b3)]
|
||||
[this-right (+ this-left this-width)])
|
||||
(values this-left
|
||||
this-right))]
|
||||
[else
|
||||
(let loop ([left #f]
|
||||
[right #f]
|
||||
[canvases canvases])
|
||||
(cond
|
||||
[(null? canvases)
|
||||
(values left right)]
|
||||
[else
|
||||
(let-values ([(this-left this-right)
|
||||
(send (car canvases)
|
||||
call-as-primary-owner
|
||||
(lambda ()
|
||||
(send (get-admin) get-view b1 b2 b3 b4)
|
||||
(let* ([this-left (unbox b1)]
|
||||
[this-width (unbox b3)]
|
||||
[this-right (+ this-left this-width)])
|
||||
(values this-left
|
||||
this-right))))])
|
||||
(if (and left right)
|
||||
(loop (min this-left left)
|
||||
(max this-right right)
|
||||
(cdr canvases))
|
||||
(loop this-left
|
||||
this-right
|
||||
(cdr canvases))))]))])])
|
||||
(when (and min-left max-right)
|
||||
(let loop ([left #f]
|
||||
[top #f]
|
||||
|
|
@ -196,7 +206,7 @@
|
|||
|
||||
(public highlight-range)
|
||||
(define highlight-range
|
||||
(opt-lambda (start end color bitmap [caret-space? #f] [priority 'low])
|
||||
(opt-lambda (start end color [bitmap #f] [caret-space? #f] [priority 'low])
|
||||
(unless (let ([exact-pos-int?
|
||||
(lambda (x) (and (integer? x) (exact? x) (x . >= . 0)))])
|
||||
(and (exact-pos-int? start)
|
||||
|
|
@ -380,7 +390,6 @@
|
|||
get-delegate
|
||||
set-delegate))
|
||||
|
||||
;; this won't work properly for tab snips. probably need another subclass, or something.
|
||||
(define 1-pixel-string-snip%
|
||||
(class string-snip%
|
||||
(init-rest args)
|
||||
|
|
@ -416,16 +425,17 @@
|
|||
(set! cache-function #f)
|
||||
(super-insert s len pos))
|
||||
|
||||
;; for-each/sections : string -> (number number -> void) -> void
|
||||
(define (for-each/sections make-f str)
|
||||
;; for-each/sections : string -> dc number number -> void
|
||||
(define (for-each/sections str)
|
||||
(let loop ([n (string-length str)]
|
||||
[len 0]
|
||||
[blank? #t])
|
||||
(cond
|
||||
[(zero? n)
|
||||
(if blank?
|
||||
(lambda (f) (void))
|
||||
(lambda (f) (f n len)))]
|
||||
(lambda (dc x y) (void))
|
||||
(lambda (dc x y)
|
||||
(send dc draw-line (+ x n) y (+ x n (- len 1)) y)))]
|
||||
[else
|
||||
(let ([white? (char-whitespace? (string-ref str (- n 1)))])
|
||||
(cond
|
||||
|
|
@ -435,22 +445,16 @@
|
|||
(let ([res (loop (- n 1) 1 (not blank?))])
|
||||
(if blank?
|
||||
res
|
||||
(lambda (f)
|
||||
(f n len)
|
||||
(res f))))]))])))
|
||||
(lambda (dc x y)
|
||||
(send dc draw-line (+ x n) y (+ x n (- len 1)) y)
|
||||
(res dc x y))))]))])))
|
||||
|
||||
(define/override (draw dc x y left top right bottom dx dy draw-caret)
|
||||
(let ([str (get-text 0 (get-count))])
|
||||
(unless cache-function
|
||||
(set! cache-function (for-each/sections str)))
|
||||
(when (<= top y bottom)
|
||||
(cache-function
|
||||
(lambda (start len)
|
||||
(send dc draw-line
|
||||
(+ x start)
|
||||
y
|
||||
(+ x start (- len 1))
|
||||
y))))))
|
||||
(cache-function dc x y))))
|
||||
(apply super-make-object args)))
|
||||
|
||||
(define 1-pixel-tab-snip%
|
||||
|
|
@ -532,6 +536,18 @@
|
|||
(send delegate lock #t)
|
||||
(send delegate end-edit-sequence)))
|
||||
|
||||
(rename [super-highlight-range highlight-range])
|
||||
(define/override highlight-range
|
||||
(opt-lambda (start end color bitmap [caret-space? #f] [priority 'low])
|
||||
(let ([res (super-highlight-range start end color bitmap caret-space? priority)])
|
||||
(if delegate
|
||||
(let ([delegate-res (send delegate highlight-range
|
||||
start end color bitmap caret-space? priority)])
|
||||
(lambda ()
|
||||
(res)
|
||||
(delegate-res)))
|
||||
res))))
|
||||
|
||||
(rename [super-on-paint on-paint])
|
||||
(inherit get-canvas)
|
||||
(define/override (on-paint before? dc left top right bottom dx dy draw-caret?)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user