diff --git a/collects/framework/framework.ss b/collects/framework/framework.ss index 7b645d51..038a752d 100644 --- a/collects/framework/framework.ss +++ b/collects/framework/framework.ss @@ -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^))) diff --git a/collects/framework/private/finder.ss b/collects/framework/private/finder.ss index 286fb03f..71cdcde7 100644 --- a/collects/framework/private/finder.ss +++ b/collects/framework/private/finder.ss @@ -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 diff --git a/collects/framework/private/frame.ss b/collects/framework/private/frame.ss index 4a32fcef..60f19536 100644 --- a/collects/framework/private/frame.ss +++ b/collects/framework/private/frame.ss @@ -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 diff --git a/collects/framework/private/main.ss b/collects/framework/private/main.ss index 5eaf9990..8377cc14 100644 --- a/collects/framework/private/main.ss +++ b/collects/framework/private/main.ss @@ -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) diff --git a/collects/framework/private/panel.ss b/collects/framework/private/panel.ss index aaa47e4e..e06a7dea 100644 --- a/collects/framework/private/panel.ss +++ b/collects/framework/private/panel.ss @@ -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] diff --git a/collects/framework/private/preferences.ss b/collects/framework/private/preferences.ss index aef2c5c7..747ef5ea 100644 --- a/collects/framework/private/preferences.ss +++ b/collects/framework/private/preferences.ss @@ -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 diff --git a/collects/framework/private/scheme.ss b/collects/framework/private/scheme.ss index ffe59891..69561913 100644 --- a/collects/framework/private/scheme.ss +++ b/collects/framework/private/scheme.ss @@ -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) diff --git a/collects/framework/private/standard-menus-items.ss b/collects/framework/private/standard-menus-items.ss index 6fe9fbff..aaa1aecf 100644 --- a/collects/framework/private/standard-menus-items.ss +++ b/collects/framework/private/standard-menus-items.ss @@ -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")) diff --git a/collects/framework/private/text.ss b/collects/framework/private/text.ss index fa584a59..88a5b2f4 100644 --- a/collects/framework/private/text.ss +++ b/collects/framework/private/text.ss @@ -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?)