diff --git a/collects/framework/private/autosave.ss b/collects/framework/private/autosave.ss index a68825fe..98e2fed7 100644 --- a/collects/framework/private/autosave.ss +++ b/collects/framework/private/autosave.ss @@ -2,8 +2,8 @@ (module autosave (lib "a-unit.ss") (require (lib "class.ss") (lib "file.ss") - "sig.ss" - "../gui-utils.ss" + "sig.ss" + "../gui-utils.ss" "../preferences.ss" (lib "mred-sig.ss" "mred") (lib "list.ss") @@ -20,296 +20,296 @@ (export framework:autosave^) - (define autosavable<%> - (interface () - do-autosave)) - - (define objects null) - - (define autosave-toc-filename - (build-path (find-system-path 'pref-dir) - (case (system-type) - [(unix) ".plt-autosave-toc"] - [else "PLT-autosave-toc"]))) - - (define autosave-toc-save-filename - (build-path (find-system-path 'pref-dir) - (case (system-type) - [(unix) ".plt-autosave-toc-save"] - [else "PLT-autosave-toc-save"]))) - - (define autosave-timer% - (class timer% - (inherit start) - (field [last-name-mapping #f]) - (define/override (notify) - (when (preferences:get 'framework:autosaving-on?) - (let-values ([(new-objects new-name-mapping) (rebuild-object-list)]) - (set! objects new-objects) - (unless (equal? last-name-mapping new-name-mapping) - (set! last-name-mapping new-name-mapping) - (when (file-exists? autosave-toc-save-filename) - (delete-file autosave-toc-save-filename)) - (when (file-exists? autosave-toc-filename) - (copy-file autosave-toc-filename autosave-toc-save-filename)) - (call-with-output-file autosave-toc-filename - (λ (port) - (write new-name-mapping port)) - 'truncate - 'text)))) - (let ([seconds (preferences:get 'framework:autosave-delay)]) - (start (* 1000 seconds) #t))) - (super-new) - (let ([seconds (preferences:get 'framework:autosave-delay)]) - (start (* 1000 seconds) #t)))) - - ;; rebuild-object-list : -> (values (listof (weak-box (is-a?/c editor<%>))) - ;; (listof (list (union #f string[filename]) string[filename])) - (define (rebuild-object-list) - (let loop ([orig-objects objects] - [name-mapping null] - [new-objects null]) - (if (null? orig-objects) - (values new-objects name-mapping) - (let* ([object-wb (car orig-objects)] - [object (weak-box-value object-wb)]) - (if object - (let* ([new-filename (send object do-autosave)] - [tmp-box (box #f)] - [filename (send object get-filename tmp-box)]) - (loop (cdr orig-objects) - (if new-filename - (cons (list (and (not (unbox tmp-box)) filename) - new-filename) - name-mapping) - name-mapping) - (cons object-wb new-objects))) - (loop (cdr orig-objects) - name-mapping - new-objects)))))) - - (define timer #f) - - (define (register b) - (unless timer - (set! timer (make-object autosave-timer%))) - (set! objects - (let loop ([objects objects]) - (cond - [(null? objects) (list (make-weak-box b))] - [else (let ([weak-box (car objects)]) - (if (weak-box-value weak-box) - (cons weak-box (loop (cdr objects))) - (loop (cdr objects))))])))) - - ;; restore-autosave-files/gui : -> (union #f (is-a?/c top-level-window<%>)) - ;; opens a frame that lists the autosave files that have changed. - (define (restore-autosave-files/gui) - - ;; main : -> void - ;; start everything going - (define (main) - (when (file-exists? autosave-toc-filename) - ;; Load table from file, and check that the file was not corrupted - (let* ([table (let ([v (with-handlers ([exn:fail? (λ (x) null)]) - (call-with-input-file autosave-toc-filename read))] - [path? (λ (x) - (and (string? x) - (absolute-path? x)))]) - (if (and (list? v) - (andmap (λ (i) - (and (list? i) - (= 2 (length i)) - (or (not (car i)) - (path? (car i))) - (path? (cadr i)))) - v)) - v - null))] - ;; assume that the autosave file was deleted due to the file being saved - [filtered-table - (filter (λ (x) (file-exists? (cadr x))) table)]) - (unless (null? filtered-table) - (let* ([f (new final-frame% - (label (string-constant recover-autosave-files-frame-title)))] - [t (new text% (auto-wrap #t))] - [ec (new editor-canvas% - (parent (send f get-area-container)) - (editor t) - (line-count 2) - (style '(no-hscroll)))] - [hp (make-object horizontal-panel% (send f get-area-container))] - [vp (make-object vertical-panel% hp)]) - (send vp set-alignment 'right 'center) - (make-object grow-box-spacer-pane% hp) - (send t insert (string-constant autosave-explanation)) - (send t hide-caret #t) - (send t set-position 0 0) - (send t lock #t) - - (for-each (add-table-line vp f) filtered-table) - (make-object button% - (string-constant autosave-done) - vp - (λ (x y) - (when (send f can-close?) - (send f on-close) - (send f show #f)))) - (send f show #t) - (yield done-semaphore) - (void)))))) - - (define done-semaphore (make-semaphore 0)) - - (define final-frame% - (class frame:basic% - (define/augment (can-close?) #t) - (define/augment (on-close) - (inner (void) on-close) - (send (group:get-the-frame-group) - remove-frame - this) - (semaphore-post done-semaphore)) - (super-new))) - - ;; add-table-line : (is-a? area-container<%>) (union #f (is-a?/c top-level-window<%>)) - ;; -> (list (union #f string[filename]) string[filename-file-exists?]) - ;; -> void - ;; adds in a line to the overview table showing this pair of files. - (define (add-table-line area-container parent) - (λ (table-entry) - (letrec ([orig-file (car table-entry)] - [backup-file (cadr table-entry)] - [hp (new horizontal-panel% - (parent area-container) - (style '(border)) - (stretchable-height #f))] - [vp (new vertical-panel% - (parent hp))] - [msg1-panel (new horizontal-panel% - (parent vp))] - [msg1-label (new message% - (parent msg1-panel) - (label (string-constant autosave-original-label:)))] - [msg1 (new message% - (label (or orig-file (string-constant autosave-unknown-filename))) - (stretchable-width #t) - (parent msg1-panel))] - [msg2-panel (new horizontal-panel% - (parent vp))] - [msg2-label (new message% - (parent msg2-panel) - (label (string-constant autosave-autosave-label:)))] - [msg2 (new message% - (label backup-file) - (stretchable-width #t) - (parent msg2-panel))] - [details - (make-object button% (string-constant autosave-details) hp - (λ (x y) - (show-files table-entry)))] - [delete - (make-object button% - (string-constant autosave-delete-button) - hp - (λ (delete y) - (when (delete-autosave table-entry) - (disable-line) - (send msg2 set-label (string-constant autosave-deleted)))))] - [recover - (make-object button% - (string-constant autosave-recover) - hp - (λ (recover y) - (let ([filename-result (recover-file parent table-entry)]) - (when filename-result - (disable-line) - (send msg2 set-label (string-constant autosave-recovered!)) - (send msg1 set-label filename-result)))))] - [disable-line - (λ () - (send recover enable #f) - (send details enable #f) - (send delete enable #f))]) - (let ([w (max (send msg1-label get-width) (send msg2-label get-width))]) - (send msg1-label min-width w) - (send msg2-label min-width w)) - (void)))) - - ;; delete-autosave : (list (union #f string[filename]) string[filename]) -> boolean - ;; result indicates if delete occurred - (define (delete-autosave table-entry) - (let ([autosave-file (cadr table-entry)]) - (and (gui-utils:get-choice - (format (string-constant are-you-sure-delete?) - autosave-file) - (string-constant autosave-delete-title) - (string-constant cancel) - (string-constant warning) - #f) - (with-handlers ([exn:fail? - (λ (exn) - (message-box - (string-constant warning) - (format (string-constant autosave-error-deleting) - autosave-file - (if (exn? exn) - (format "~a" (exn-message exn)) - (format "~s" exn)))) - #f)]) - (delete-file autosave-file) - #t)))) - - ;; show-files : (list (union #f string[filename]) string) -> void - (define (show-files table-entry) - (let ([file1 (car table-entry)] - [file2 (cadr table-entry)]) - (define frame (make-object show-files-frame% - (if file1 - (string-constant autosave-compare-files) - (string-constant autosave-show-autosave)) - #f - (if file1 600 300) - 600)) - (define hp (new horizontal-panel% - (parent (send frame get-area-container)))) - (when file1 - (add-file-viewer file1 hp (string-constant autosave-original-label))) - (add-file-viewer file2 hp (string-constant autosave-autosave-label)) - (send frame show #t))) - - ;; add-file-viewer : string[filename] -> void - (define (add-file-viewer filename parent label) - (define vp (make-object vertical-panel% parent)) - (define t (make-object show-files-text%)) - (define msg1 (make-object message% label vp)) - (define msg2 (make-object message% filename vp)) - (define ec (make-object editor-canvas% vp t)) - (send t load-file filename) - (send t hide-caret #t) - (send t lock #t)) - - (define show-files-frame% frame:basic%) - (define show-files-text% text:keymap%) - - (main)) - - ;; recover-file : (union #f (is-a?/c toplevel-window<%>)) - ;; (list (union #f string[filename]) string) - ;; -> (union #f string) - (define (recover-file parent table-entry) - (let ([orig-name (or (car table-entry) - (parameterize ([finder:dialog-parent-parameter parent]) - (finder:put-file #f #f #f - (string-constant autosave-restore-to-where?))))]) - (and orig-name - (let ([autosave-name (cadr table-entry)]) - (let ([tmp-name (and (file-exists? orig-name) - (make-temporary-file "autosave-repair~a" orig-name))]) - (when (file-exists? orig-name) - (delete-file orig-name)) - (copy-file autosave-name orig-name) - (delete-file autosave-name) - (when tmp-name - (delete-file tmp-name)) - orig-name)))))) + (define autosavable<%> + (interface () + do-autosave)) + + (define objects null) + + (define autosave-toc-filename + (build-path (find-system-path 'pref-dir) + (case (system-type) + [(unix) ".plt-autosave-toc"] + [else "PLT-autosave-toc"]))) + + (define autosave-toc-save-filename + (build-path (find-system-path 'pref-dir) + (case (system-type) + [(unix) ".plt-autosave-toc-save"] + [else "PLT-autosave-toc-save"]))) + + (define autosave-timer% + (class timer% + (inherit start) + (field [last-name-mapping #f]) + (define/override (notify) + (when (preferences:get 'framework:autosaving-on?) + (let-values ([(new-objects new-name-mapping) (rebuild-object-list)]) + (set! objects new-objects) + (unless (equal? last-name-mapping new-name-mapping) + (set! last-name-mapping new-name-mapping) + (when (file-exists? autosave-toc-save-filename) + (delete-file autosave-toc-save-filename)) + (when (file-exists? autosave-toc-filename) + (copy-file autosave-toc-filename autosave-toc-save-filename)) + (call-with-output-file autosave-toc-filename + (λ (port) + (write new-name-mapping port)) + 'truncate + 'text)))) + (let ([seconds (preferences:get 'framework:autosave-delay)]) + (start (* 1000 seconds) #t))) + (super-new) + (let ([seconds (preferences:get 'framework:autosave-delay)]) + (start (* 1000 seconds) #t)))) + + ;; rebuild-object-list : -> (values (listof (weak-box (is-a?/c editor<%>))) + ;; (listof (list (union #f string[filename]) string[filename])) + (define (rebuild-object-list) + (let loop ([orig-objects objects] + [name-mapping null] + [new-objects null]) + (if (null? orig-objects) + (values new-objects name-mapping) + (let* ([object-wb (car orig-objects)] + [object (weak-box-value object-wb)]) + (if object + (let* ([new-filename (send object do-autosave)] + [tmp-box (box #f)] + [filename (send object get-filename tmp-box)]) + (loop (cdr orig-objects) + (if new-filename + (cons (list (and (not (unbox tmp-box)) filename) + new-filename) + name-mapping) + name-mapping) + (cons object-wb new-objects))) + (loop (cdr orig-objects) + name-mapping + new-objects)))))) + + (define timer #f) + + (define (register b) + (unless timer + (set! timer (make-object autosave-timer%))) + (set! objects + (let loop ([objects objects]) + (cond + [(null? objects) (list (make-weak-box b))] + [else (let ([weak-box (car objects)]) + (if (weak-box-value weak-box) + (cons weak-box (loop (cdr objects))) + (loop (cdr objects))))])))) + + ;; restore-autosave-files/gui : -> (union #f (is-a?/c top-level-window<%>)) + ;; opens a frame that lists the autosave files that have changed. + (define (restore-autosave-files/gui) + + ;; main : -> void + ;; start everything going + (define (main) + (when (file-exists? autosave-toc-filename) + ;; Load table from file, and check that the file was not corrupted + (let* ([table (let ([v (with-handlers ([exn:fail? (λ (x) null)]) + (call-with-input-file autosave-toc-filename read))] + [path? (λ (x) + (and (string? x) + (absolute-path? x)))]) + (if (and (list? v) + (andmap (λ (i) + (and (list? i) + (= 2 (length i)) + (or (not (car i)) + (path? (car i))) + (path? (cadr i)))) + v)) + v + null))] + ;; assume that the autosave file was deleted due to the file being saved + [filtered-table + (filter (λ (x) (file-exists? (cadr x))) table)]) + (unless (null? filtered-table) + (let* ([f (new final-frame% + (label (string-constant recover-autosave-files-frame-title)))] + [t (new text% (auto-wrap #t))] + [ec (new editor-canvas% + (parent (send f get-area-container)) + (editor t) + (line-count 2) + (style '(no-hscroll)))] + [hp (make-object horizontal-panel% (send f get-area-container))] + [vp (make-object vertical-panel% hp)]) + (send vp set-alignment 'right 'center) + (make-object grow-box-spacer-pane% hp) + (send t insert (string-constant autosave-explanation)) + (send t hide-caret #t) + (send t set-position 0 0) + (send t lock #t) + + (for-each (add-table-line vp f) filtered-table) + (make-object button% + (string-constant autosave-done) + vp + (λ (x y) + (when (send f can-close?) + (send f on-close) + (send f show #f)))) + (send f show #t) + (yield done-semaphore) + (void)))))) + + (define done-semaphore (make-semaphore 0)) + + (define final-frame% + (class frame:basic% + (define/augment (can-close?) #t) + (define/augment (on-close) + (inner (void) on-close) + (send (group:get-the-frame-group) + remove-frame + this) + (semaphore-post done-semaphore)) + (super-new))) + + ;; add-table-line : (is-a? area-container<%>) (union #f (is-a?/c top-level-window<%>)) + ;; -> (list (union #f string[filename]) string[filename-file-exists?]) + ;; -> void + ;; adds in a line to the overview table showing this pair of files. + (define (add-table-line area-container parent) + (λ (table-entry) + (letrec ([orig-file (car table-entry)] + [backup-file (cadr table-entry)] + [hp (new horizontal-panel% + (parent area-container) + (style '(border)) + (stretchable-height #f))] + [vp (new vertical-panel% + (parent hp))] + [msg1-panel (new horizontal-panel% + (parent vp))] + [msg1-label (new message% + (parent msg1-panel) + (label (string-constant autosave-original-label:)))] + [msg1 (new message% + (label (or orig-file (string-constant autosave-unknown-filename))) + (stretchable-width #t) + (parent msg1-panel))] + [msg2-panel (new horizontal-panel% + (parent vp))] + [msg2-label (new message% + (parent msg2-panel) + (label (string-constant autosave-autosave-label:)))] + [msg2 (new message% + (label backup-file) + (stretchable-width #t) + (parent msg2-panel))] + [details + (make-object button% (string-constant autosave-details) hp + (λ (x y) + (show-files table-entry)))] + [delete + (make-object button% + (string-constant autosave-delete-button) + hp + (λ (delete y) + (when (delete-autosave table-entry) + (disable-line) + (send msg2 set-label (string-constant autosave-deleted)))))] + [recover + (make-object button% + (string-constant autosave-recover) + hp + (λ (recover y) + (let ([filename-result (recover-file parent table-entry)]) + (when filename-result + (disable-line) + (send msg2 set-label (string-constant autosave-recovered!)) + (send msg1 set-label filename-result)))))] + [disable-line + (λ () + (send recover enable #f) + (send details enable #f) + (send delete enable #f))]) + (let ([w (max (send msg1-label get-width) (send msg2-label get-width))]) + (send msg1-label min-width w) + (send msg2-label min-width w)) + (void)))) + + ;; delete-autosave : (list (union #f string[filename]) string[filename]) -> boolean + ;; result indicates if delete occurred + (define (delete-autosave table-entry) + (let ([autosave-file (cadr table-entry)]) + (and (gui-utils:get-choice + (format (string-constant are-you-sure-delete?) + autosave-file) + (string-constant autosave-delete-title) + (string-constant cancel) + (string-constant warning) + #f) + (with-handlers ([exn:fail? + (λ (exn) + (message-box + (string-constant warning) + (format (string-constant autosave-error-deleting) + autosave-file + (if (exn? exn) + (format "~a" (exn-message exn)) + (format "~s" exn)))) + #f)]) + (delete-file autosave-file) + #t)))) + + ;; show-files : (list (union #f string[filename]) string) -> void + (define (show-files table-entry) + (let ([file1 (car table-entry)] + [file2 (cadr table-entry)]) + (define frame (make-object show-files-frame% + (if file1 + (string-constant autosave-compare-files) + (string-constant autosave-show-autosave)) + #f + (if file1 600 300) + 600)) + (define hp (new horizontal-panel% + (parent (send frame get-area-container)))) + (when file1 + (add-file-viewer file1 hp (string-constant autosave-original-label))) + (add-file-viewer file2 hp (string-constant autosave-autosave-label)) + (send frame show #t))) + + ;; add-file-viewer : string[filename] -> void + (define (add-file-viewer filename parent label) + (define vp (make-object vertical-panel% parent)) + (define t (make-object show-files-text%)) + (define msg1 (make-object message% label vp)) + (define msg2 (make-object message% filename vp)) + (define ec (make-object editor-canvas% vp t)) + (send t load-file filename) + (send t hide-caret #t) + (send t lock #t)) + + (define show-files-frame% frame:basic%) + (define show-files-text% text:keymap%) + + (main)) + + ;; recover-file : (union #f (is-a?/c toplevel-window<%>)) + ;; (list (union #f string[filename]) string) + ;; -> (union #f string) + (define (recover-file parent table-entry) + (let ([orig-name (or (car table-entry) + (parameterize ([finder:dialog-parent-parameter parent]) + (finder:put-file #f #f #f + (string-constant autosave-restore-to-where?))))]) + (and orig-name + (let ([autosave-name (cadr table-entry)]) + (let ([tmp-name (and (file-exists? orig-name) + (make-temporary-file "autosave-repair~a" orig-name))]) + (when (file-exists? orig-name) + (delete-file orig-name)) + (copy-file autosave-name orig-name) + (delete-file autosave-name) + (when tmp-name + (delete-file tmp-name)) + orig-name)))))) diff --git a/collects/framework/private/canvas.ss b/collects/framework/private/canvas.ss index 7551357e..8e200e0d 100644 --- a/collects/framework/private/canvas.ss +++ b/collects/framework/private/canvas.ss @@ -1,181 +1,181 @@ (module canvas (lib "a-unit.ss") (require (lib "class.ss") - "sig.ss" - "../preferences.ss" + "sig.ss" + "../preferences.ss" (lib "mred-sig.ss" "mred")) - + (import mred^ [prefix frame: framework:frame^] [prefix text: framework:text^]) - + (export (rename framework:canvas^ (-color% color%))) + + (define basic<%> (interface ((class->interface editor-canvas%)))) + (define basic-mixin + (mixin ((class->interface editor-canvas%)) (basic<%>) + (super-new))) + + (define color<%> (interface (basic<%>))) + + (define color-mixin + (mixin (basic<%>) (color<%>) + (define callback (λ (p v) (set-canvas-background v))) + (super-new) + (inherit set-canvas-background) + (set-canvas-background (preferences:get 'framework:basic-canvas-background)) + (preferences:add-callback 'framework:basic-canvas-background callback #t))) + + (define delegate<%> (interface (basic<%>))) + + (define delegate-mixin + (mixin (basic<%>) (delegate<%>) + (inherit get-top-level-window) + (define/override (on-superwindow-show shown?) + (send (send (get-top-level-window) get-delegatee) set-start/end-para #f #f) + (super on-superwindow-show shown?)) + (super-instantiate ()))) + + (define info<%> (interface (basic<%>))) + ;; (basic<%> -> (class (is-a? (send this get-top-level-window) frame:info<%>))) + (define info-mixin + (mixin (basic<%>) (info<%>) + (inherit has-focus? get-top-level-window) + (define/override (on-focus on?) + (super on-focus on?) + (send (get-top-level-window) set-info-canvas (and on? this)) + (when on? + (send (get-top-level-window) update-info))) + (define/override (set-editor m) + (super set-editor m) + (let ([tlw (get-top-level-window)]) + (when (eq? this (send tlw get-info-canvas)) + (send tlw update-info)))) - (define basic<%> (interface ((class->interface editor-canvas%)))) - (define basic-mixin - (mixin ((class->interface editor-canvas%)) (basic<%>) - (super-new))) + (super-new) - (define color<%> (interface (basic<%>))) + (unless (is-a? (get-top-level-window) frame:info<%>) + (error 'canvas:text-info-mixin + "expected to be placed into a frame or dialog implementing frame:info<%>, got: ~e" + (get-top-level-window))) - (define color-mixin - (mixin (basic<%>) (color<%>) - (define callback (λ (p v) (set-canvas-background v))) - (super-new) - (inherit set-canvas-background) - (set-canvas-background (preferences:get 'framework:basic-canvas-background)) - (preferences:add-callback 'framework:basic-canvas-background callback #t))) - - (define delegate<%> (interface (basic<%>))) - - (define delegate-mixin - (mixin (basic<%>) (delegate<%>) - (inherit get-top-level-window) - (define/override (on-superwindow-show shown?) - (send (send (get-top-level-window) get-delegatee) set-start/end-para #f #f) - (super on-superwindow-show shown?)) - (super-instantiate ()))) - - (define info<%> (interface (basic<%>))) - ;; (basic<%> -> (class (is-a? (send this get-top-level-window) frame:info<%>))) - (define info-mixin - (mixin (basic<%>) (info<%>) - (inherit has-focus? get-top-level-window) - (define/override (on-focus on?) - (super on-focus on?) - (send (get-top-level-window) set-info-canvas (and on? this)) - (when on? - (send (get-top-level-window) update-info))) - (define/override (set-editor m) - (super set-editor m) - (let ([tlw (get-top-level-window)]) - (when (eq? this (send tlw get-info-canvas)) - (send tlw update-info)))) - - (super-new) - - (unless (is-a? (get-top-level-window) frame:info<%>) - (error 'canvas:text-info-mixin - "expected to be placed into a frame or dialog implementing frame:info<%>, got: ~e" - (get-top-level-window))) - - (when (has-focus?) - (send (get-top-level-window) update-info)))) - - (define wide-snip<%> (interface (basic<%>) - recalc-snips - add-wide-snip - add-tall-snip)) - - (define wide-snip-mixin - (mixin (basic<%>) (wide-snip<%>) - (inherit get-editor) - (define/private ((update-snip-size width?) s) - (let* ([width (box 0)] - [height (box 0)] - [leftm (box 0)] - [rightm (box 0)] - [topm (box 0)] - [bottomm (box 0)] - [left-edge-box (box 0)] - [top-edge-box (box 0)] - [snip-media (send s get-editor)] - [edit (get-editor)] - [get-width - (let ([bl (box 0)] - [br (box 0)]) - (λ (s) - (send edit get-snip-location s bl #f #f) - (send edit get-snip-location s br #f #t) - (- (unbox br) (unbox bl))))] - [calc-after-width - (λ (s) - (+ 4 ;; this is compensate for an autowrapping bug - (let loop ([s s]) - (cond - [(not s) 0] - [(member 'hard-newline (send s get-flags)) (get-width s)] - [(member 'newline (send s get-flags)) (get-width s)] - [else - (+ (get-width s) - 2 ;; for the caret - (loop (send s next)))]))))]) - (when edit - (send edit - run-after-edit-sequence - (λ () - (let ([admin (send edit get-admin)]) - (send admin get-view #f #f width height) - (send s get-margin leftm topm rightm bottomm) - - - ;; when the width is to be maximized and there is a - ;; newline just behind the snip, we know that the left - ;; edge is zero. Special case for efficiency in the - ;; console printer - (let ([fallback - (λ () - (send edit get-snip-location s left-edge-box top-edge-box))]) - (cond - [(not width?) (fallback)] - [(let ([prev (send s previous)]) - (and prev - (member 'hard-newline (send prev get-flags)))) - (set-box! left-edge-box 0)] - [else (fallback)])) - - (if width? - (let* ([after-width (calc-after-width (send s next))] - [snip-width (max 0 (- (unbox width) - (unbox left-edge-box) - (unbox leftm) - (unbox rightm) - after-width - ;; this two is the space that - ;; the caret needs at the right of - ;; a buffer. - 2))]) - (send* s - (set-min-width snip-width) - (set-max-width snip-width)) - (when snip-media - (send snip-media set-max-width - (if (send snip-media auto-wrap) - snip-width - 0)))) - (let ([snip-height (max 0 (- (unbox height) - (unbox top-edge-box) - (unbox topm) - (unbox bottomm)))]) - (send* s - (set-min-height snip-height) - (set-max-height snip-height)))))))))) - (define/public (recalc-snips) - (let ([editor (get-editor)]) - (unless (is-a? editor text:wide-snip<%>) - (error 'recalc-snips "expected a text:wide-snip<%> editor, instead ~e" editor)) - (when (eq? (send editor get-canvas) this) - (for-each (update-snip-size #t) (send editor get-wide-snips)) - (for-each (update-snip-size #f) (send editor get-tall-snips))))) - (define/public (add-wide-snip snip) - (let ([editor (get-editor)]) - (unless (is-a? editor text:wide-snip<%>) - (error 'add-wide-snip "expected to have a text:wide-snip<%> editor, instead ~e" editor)) - (send editor add-wide-snip snip)) - ((update-snip-size #t) snip)) - (define/public (add-tall-snip snip) - (let ([editor (get-editor)]) - (unless (is-a? editor text:wide-snip<%>) - (error 'add-wide-snip "expected to have a text:wide-snip<%> editor, instead ~e" editor)) - (send editor add-tall-snip snip)) - ((update-snip-size #f) snip)) - (define/override (on-size width height) - (recalc-snips) - (super on-size width height)) - (super-new))) - - (define basic% (basic-mixin editor-canvas%)) - (define -color% (color-mixin basic%)) - (define info% (info-mixin basic%)) - (define delegate% (delegate-mixin basic%)) - (define wide-snip% (wide-snip-mixin basic%))) + (when (has-focus?) + (send (get-top-level-window) update-info)))) + + (define wide-snip<%> (interface (basic<%>) + recalc-snips + add-wide-snip + add-tall-snip)) + + (define wide-snip-mixin + (mixin (basic<%>) (wide-snip<%>) + (inherit get-editor) + (define/private ((update-snip-size width?) s) + (let* ([width (box 0)] + [height (box 0)] + [leftm (box 0)] + [rightm (box 0)] + [topm (box 0)] + [bottomm (box 0)] + [left-edge-box (box 0)] + [top-edge-box (box 0)] + [snip-media (send s get-editor)] + [edit (get-editor)] + [get-width + (let ([bl (box 0)] + [br (box 0)]) + (λ (s) + (send edit get-snip-location s bl #f #f) + (send edit get-snip-location s br #f #t) + (- (unbox br) (unbox bl))))] + [calc-after-width + (λ (s) + (+ 4 ;; this is compensate for an autowrapping bug + (let loop ([s s]) + (cond + [(not s) 0] + [(member 'hard-newline (send s get-flags)) (get-width s)] + [(member 'newline (send s get-flags)) (get-width s)] + [else + (+ (get-width s) + 2 ;; for the caret + (loop (send s next)))]))))]) + (when edit + (send edit + run-after-edit-sequence + (λ () + (let ([admin (send edit get-admin)]) + (send admin get-view #f #f width height) + (send s get-margin leftm topm rightm bottomm) + + + ;; when the width is to be maximized and there is a + ;; newline just behind the snip, we know that the left + ;; edge is zero. Special case for efficiency in the + ;; console printer + (let ([fallback + (λ () + (send edit get-snip-location s left-edge-box top-edge-box))]) + (cond + [(not width?) (fallback)] + [(let ([prev (send s previous)]) + (and prev + (member 'hard-newline (send prev get-flags)))) + (set-box! left-edge-box 0)] + [else (fallback)])) + + (if width? + (let* ([after-width (calc-after-width (send s next))] + [snip-width (max 0 (- (unbox width) + (unbox left-edge-box) + (unbox leftm) + (unbox rightm) + after-width + ;; this two is the space that + ;; the caret needs at the right of + ;; a buffer. + 2))]) + (send* s + (set-min-width snip-width) + (set-max-width snip-width)) + (when snip-media + (send snip-media set-max-width + (if (send snip-media auto-wrap) + snip-width + 0)))) + (let ([snip-height (max 0 (- (unbox height) + (unbox top-edge-box) + (unbox topm) + (unbox bottomm)))]) + (send* s + (set-min-height snip-height) + (set-max-height snip-height)))))))))) + (define/public (recalc-snips) + (let ([editor (get-editor)]) + (unless (is-a? editor text:wide-snip<%>) + (error 'recalc-snips "expected a text:wide-snip<%> editor, instead ~e" editor)) + (when (eq? (send editor get-canvas) this) + (for-each (update-snip-size #t) (send editor get-wide-snips)) + (for-each (update-snip-size #f) (send editor get-tall-snips))))) + (define/public (add-wide-snip snip) + (let ([editor (get-editor)]) + (unless (is-a? editor text:wide-snip<%>) + (error 'add-wide-snip "expected to have a text:wide-snip<%> editor, instead ~e" editor)) + (send editor add-wide-snip snip)) + ((update-snip-size #t) snip)) + (define/public (add-tall-snip snip) + (let ([editor (get-editor)]) + (unless (is-a? editor text:wide-snip<%>) + (error 'add-wide-snip "expected to have a text:wide-snip<%> editor, instead ~e" editor)) + (send editor add-tall-snip snip)) + ((update-snip-size #f) snip)) + (define/override (on-size width height) + (recalc-snips) + (super on-size width height)) + (super-new))) + + (define basic% (basic-mixin editor-canvas%)) + (define -color% (color-mixin basic%)) + (define info% (info-mixin basic%)) + (define delegate% (delegate-mixin basic%)) + (define wide-snip% (wide-snip-mixin basic%))) diff --git a/collects/framework/private/collapsed-snipclass-helpers.ss b/collects/framework/private/collapsed-snipclass-helpers.ss index 75e6d184..313a89c2 100644 --- a/collects/framework/private/collapsed-snipclass-helpers.ss +++ b/collects/framework/private/collapsed-snipclass-helpers.ss @@ -24,4 +24,3 @@ (right-bracket right-bracket) (saved-snips saved-snips)))) (super-instantiate ())))) - \ No newline at end of file diff --git a/collects/framework/private/color-model.ss b/collects/framework/private/color-model.ss index b38620f6..18d5ba3e 100644 --- a/collects/framework/private/color-model.ss +++ b/collects/framework/private/color-model.ss @@ -1,9 +1,9 @@ (module color-model (lib "a-unit.ss") (require (lib "class.ss") - "sig.ss" - (lib "mred-sig.ss" "mred") - (lib "list.ss")) - + "sig.ss" + (lib "mred-sig.ss" "mred") + (lib "list.ss")) + (import) (export framework:color-model^) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -11,258 +11,258 @@ ;;; matrix ops ;;; ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - ;; matrix inversion using cramer's rule - - ;; submatrix : (list-of (list-of num)) int int -> (list-of (list-of num)) - ;; submatrix "crosses out" row i and column j from the matrix, returning a new one - - (define (submatrix source i j) - (let row-loop ([row 0]) - (cond - [(eq? row (length source)) null] - [(eq? row i) (row-loop (+ row 1))] - [else - (cons - (let col-loop ([col 0]) - (cond - [(eq? col (length (car source))) null] - [(eq? col j) (col-loop (+ col 1))] - [else - (cons (list-ref (list-ref source row) col) - (col-loop (+ col 1)))])) - (row-loop (+ row 1)))]))) - - ;;(equal? (submatrix test-matrix 1 2) - ;; '((1 2 6) (7 8 4))) - - ;; det : (list-of (list-of num)) -> num - - (define (det matrix) - (if (null? matrix) - 1 - (let loop ([row 0] [sign 1]) - (if (= row (length matrix)) - 0 - (+ (* sign - (list-ref (list-ref matrix row) 0) - (det (submatrix matrix row 0))) - (loop (+ row 1) (- sign))))))) - - ;;(define square-test-matrix '((3 20 3) (37 0 8) (2 1 4))) - - ;;(= (det square-test-matrix) -2553) - - ;; invert : (list-of (list-of num)) -> (list-of (list-of num)) - - (define (matrix-invert matrix) - (let-values ([(width height) (matrix-dimension matrix)]) - (when (not (= width height)) - (error 'invert "matrix is not square: ~s" matrix)) - (let ([delta-inv (/ 1 (det matrix))]) - (let row-loop ([row 0] [sign 1]) - (if (= row (length matrix)) - null - (cons - (let col-loop ([col 0] [sign sign]) - (if (= col (length (car matrix))) - null - (cons (* delta-inv - sign - (det (submatrix matrix col row))) - (col-loop (+ col 1) (- sign))))) - (row-loop (+ row 1) (- sign)))))))) - - ;;(equal? (matrix-invert square-test-matrix) - ;; '((8/2553 77/2553 -160/2553) (44/851 -2/851 -29/851) (-1/69 -1/69 20/69))) - - ;; matrix-dimension : (list-of (list-of num)) -> (values num num) - ;; takes a matrix, returns width and height - - (define (matrix-dimension matrix) - (when (not (pair? matrix)) - (error 'matrix-dimension "matrix argument is not a list: ~s" matrix)) - (let ([height (length matrix)]) - (when (= height 0) - (error 'matrix-dimension "matrix argument is empty: ~s" matrix)) - (when (not (pair? (car matrix))) - (error 'matrix-dimension "matrix row is not a list: ~s" (car matrix))) - (let ([width (length (car matrix))]) - (when (= width 0) - (error 'matrix-dimension "matrix argument has width 0: ~s" matrix)) - (let loop ([rows matrix]) - (if (null? rows) - (values width height) - (begin - (when (not (pair? (car rows))) - (error 'matrix-dimension "row is not a list: ~s" (car rows))) - (when (not (= width (length (car rows)))) - (error 'matrix-dimension "rows have different widths: ~s and ~s" width (length (car rows)))) - (loop (cdr rows)))))))) - - ;; transpose : (list-of (list-of num)) -> (list-of (list-of num)) - (define (transpose vector) (apply map list vector)) - - - ;; test code - ;;(equal? (transpose '((3 2 1) (9 8 7))) '((3 9) (2 8) (1 7))) - - ;; inner-product : (list-of num) (list-of num) -> num - (define (inner-product a b) - (foldl + 0 (map * a b))) - - ;; test code - ;; (= (inner-product '(4 1 3) '(0 3 4)) 15) - - ;; matrix-multiply: (list-of (list-of num)) (list-of (list-of num)) -> (list-of (list-of num)) - ;; multiplies the two matrices. - (define (matrix-multiply a b) - (let-values ([(width-a height-a) (matrix-dimension a)] - [(width-b height-b) (matrix-dimension b)]) - (when (not (= width-a height-b)) - (error 'matrix-multiply "matrix dimensions do not match for multiplication")) - (let ([b-t (transpose b)]) - (map (λ (row) - (map (λ (col) - (inner-product row col)) - b-t)) - a)))) - - ;; test code - ;; (equal? (matrix-multiply '((1 2 3 4) (9 8 3 2)) '((0) (2) (0) (3))) - ;; '((16) (22))) - + + ;; matrix inversion using cramer's rule + + ;; submatrix : (list-of (list-of num)) int int -> (list-of (list-of num)) + ;; submatrix "crosses out" row i and column j from the matrix, returning a new one + + (define (submatrix source i j) + (let row-loop ([row 0]) + (cond + [(eq? row (length source)) null] + [(eq? row i) (row-loop (+ row 1))] + [else + (cons + (let col-loop ([col 0]) + (cond + [(eq? col (length (car source))) null] + [(eq? col j) (col-loop (+ col 1))] + [else + (cons (list-ref (list-ref source row) col) + (col-loop (+ col 1)))])) + (row-loop (+ row 1)))]))) + + ;;(equal? (submatrix test-matrix 1 2) + ;; '((1 2 6) (7 8 4))) + + ;; det : (list-of (list-of num)) -> num + + (define (det matrix) + (if (null? matrix) + 1 + (let loop ([row 0] [sign 1]) + (if (= row (length matrix)) + 0 + (+ (* sign + (list-ref (list-ref matrix row) 0) + (det (submatrix matrix row 0))) + (loop (+ row 1) (- sign))))))) + + ;;(define square-test-matrix '((3 20 3) (37 0 8) (2 1 4))) + + ;;(= (det square-test-matrix) -2553) + + ;; invert : (list-of (list-of num)) -> (list-of (list-of num)) + + (define (matrix-invert matrix) + (let-values ([(width height) (matrix-dimension matrix)]) + (when (not (= width height)) + (error 'invert "matrix is not square: ~s" matrix)) + (let ([delta-inv (/ 1 (det matrix))]) + (let row-loop ([row 0] [sign 1]) + (if (= row (length matrix)) + null + (cons + (let col-loop ([col 0] [sign sign]) + (if (= col (length (car matrix))) + null + (cons (* delta-inv + sign + (det (submatrix matrix col row))) + (col-loop (+ col 1) (- sign))))) + (row-loop (+ row 1) (- sign)))))))) + + ;;(equal? (matrix-invert square-test-matrix) + ;; '((8/2553 77/2553 -160/2553) (44/851 -2/851 -29/851) (-1/69 -1/69 20/69))) + + ;; matrix-dimension : (list-of (list-of num)) -> (values num num) + ;; takes a matrix, returns width and height + + (define (matrix-dimension matrix) + (when (not (pair? matrix)) + (error 'matrix-dimension "matrix argument is not a list: ~s" matrix)) + (let ([height (length matrix)]) + (when (= height 0) + (error 'matrix-dimension "matrix argument is empty: ~s" matrix)) + (when (not (pair? (car matrix))) + (error 'matrix-dimension "matrix row is not a list: ~s" (car matrix))) + (let ([width (length (car matrix))]) + (when (= width 0) + (error 'matrix-dimension "matrix argument has width 0: ~s" matrix)) + (let loop ([rows matrix]) + (if (null? rows) + (values width height) + (begin + (when (not (pair? (car rows))) + (error 'matrix-dimension "row is not a list: ~s" (car rows))) + (when (not (= width (length (car rows)))) + (error 'matrix-dimension "rows have different widths: ~s and ~s" width (length (car rows)))) + (loop (cdr rows)))))))) + + ;; transpose : (list-of (list-of num)) -> (list-of (list-of num)) + (define (transpose vector) (apply map list vector)) + + + ;; test code + ;;(equal? (transpose '((3 2 1) (9 8 7))) '((3 9) (2 8) (1 7))) + + ;; inner-product : (list-of num) (list-of num) -> num + (define (inner-product a b) + (foldl + 0 (map * a b))) + + ;; test code + ;; (= (inner-product '(4 1 3) '(0 3 4)) 15) + + ;; matrix-multiply: (list-of (list-of num)) (list-of (list-of num)) -> (list-of (list-of num)) + ;; multiplies the two matrices. + (define (matrix-multiply a b) + (let-values ([(width-a height-a) (matrix-dimension a)] + [(width-b height-b) (matrix-dimension b)]) + (when (not (= width-a height-b)) + (error 'matrix-multiply "matrix dimensions do not match for multiplication")) + (let ([b-t (transpose b)]) + (map (λ (row) + (map (λ (col) + (inner-product row col)) + b-t)) + a)))) + + ;; test code + ;; (equal? (matrix-multiply '((1 2 3 4) (9 8 3 2)) '((0) (2) (0) (3))) + ;; '((16) (22))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ;;; color model ;;; ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - ;; ITU reccommendation phosphors: - - ;; red green blue - ;;x 0.64 0.29 0.15 - ;;y 0.33 0.60 0.06 - ;; - ;; white point: - ;; c : x-w = 0.313, y-w = 0.329, big-y-w = 100.0 - - (define x-r 0.64) - (define y-r 0.33) - (define x-g 0.29) - (define y-g 0.60) - (define x-b 0.15) - (define y-b 0.06) - - (define z-r (- 1 x-r y-r)) - (define z-g (- 1 x-g y-g)) - (define z-b (- 1 x-b y-b)) - - (define x-w 0.313) - (define y-w 0.329) - (define big-y-w 100.0) - - (define-struct xyz (x y z)) - - (define (xy-big-y->xyz x y big-y) - (let ([sigma (/ big-y y)]) - (make-xyz - (* x sigma) - (* y sigma) - (* (- 1 x y) sigma)))) - - (define xyz-white (xy-big-y->xyz x-w y-w big-y-w)) - - ;;`((,(xyz-x xyz-white) ,x-r ,x-g ,x-b) - ;; (,(xyz-y xyz-white) ,y-r ,y-g ,y-b) - ;; (,(xyz-z xyz-white) ,z-r ,z-g ,z-b)) - - ;; sigmas were calculated by soving a set of linear equations based upon ntsc standard phosphors - - (define pre-matrix `((,x-r ,x-g ,x-b) - (,y-r ,y-g ,y-b) - (,z-r ,z-g ,z-b))) - - (define-values (sigma-r sigma-g sigma-b) - (let* ([inversion - (matrix-invert pre-matrix)] - [sigmas - (matrix-multiply inversion `((,(xyz-x xyz-white)) - (,(xyz-y xyz-white)) - (,(xyz-z xyz-white))))]) - (apply values (car (transpose sigmas))))) - - ;; (printf "should be equal to xyz-white: ~n~a~n" - ;; (matrix-multiply pre-matrix `((,sigma-r) (,sigma-g) (,sigma-b)))) - - (define rgb->xyz-matrix - (map (λ (row) - (map (λ (row-elt scalar) (* row-elt scalar 1/255)) row `(,sigma-r ,sigma-g ,sigma-b))) - pre-matrix)) - - (define xyz->rgb-matrix - (matrix-invert rgb->xyz-matrix)) - - ;;(printf "should be identity: ~n~a~n" (matrix-multiply rgb->xyz-matrix xyz->rgb-matrix)) - - (define (rgb->xyz r g b) - (apply make-xyz (car (transpose (matrix-multiply rgb->xyz-matrix (transpose `((,r ,g ,b)))))))) - - ;;(print-struct #t) - ;; (printf "should be xyz-white: ~n~a~n" (rgb->xyz 255 255 255)) - - (define (xyz->rgb x y z) - (car (transpose (matrix-multiply xyz->rgb-matrix (transpose `((,x ,y ,z))))))) - - ;;l* = 116(y/big-y-n)^1/3 - 16, y/big-y-n > 0.01 - ;;u* = 13 l*(u-p - u-p-n) - ;;v* = 13 l*(v-p - v-p-n) - ;; - ;;u-p = (4x)/(x+15y+3z) v-p = (9y)/(x+15y+3z) - ;;u-p-n = (same but with -n) v-p-n = (same but with -n) - - ;; the following transformation is undefined if the y component - ;; is zero. So if it is, we bump it up a little. - - (define (xyz-tweak xyz) - (let* ([y (xyz-y xyz)]) - (make-xyz (xyz-x xyz) (if (< y 0.01) 0.01 y) (xyz-z xyz)))) - - (define-struct luv (l u v)) - - (define (xyz-denom xyz) - (+ (xyz-x xyz) (* 15 (xyz-y xyz)) (* 3 (xyz-z xyz)))) - - (define (xyz-u-p xyz) - (/ (* 4 (xyz-x xyz)) (xyz-denom xyz))) - - (define (xyz-v-p xyz) - (/ (* 9 (xyz-y xyz)) (xyz-denom xyz))) - - (define (xyz->luv xyz) - (let ([xyz (xyz-tweak xyz)]) - (let* ([l (- (* 116 (expt (/ (xyz-y xyz) (xyz-y xyz-white)) - 1/3)) - 16)] - [u-p (xyz-u-p xyz)] - [u-p-white (xyz-u-p xyz-white)] - [v-p (xyz-v-p xyz)] - [v-p-white (xyz-v-p xyz-white)]) - (make-luv l (* 13 l (- u-p u-p-white)) (* 13 l (- v-p v-p-white)))))) - - (define (luv-distance a b) - (expt (+ (expt (- (luv-l a) (luv-l b)) 2) - (expt (- (luv-u a) (luv-u b)) 2) - (expt (- (luv-v a) (luv-v b)) 2)) - 1/2)) - - (define (rgb-color-distance r-a g-a b-a r-b g-b b-b) - (let* ([luv-a (xyz->luv (rgb->xyz r-a g-a b-a))] - [luv-b (xyz->luv (rgb->xyz r-b g-b b-b))]) - (luv-distance luv-a luv-b))) - - ;;(rgb-color-distance 0 0 0 0 0 0) - ;; (print-struct #t) - ;; (xyz->luv (make-xyz 95.0 100.0 141.0)) - ;; (xyz->luv (make-xyz 60.0 80.0 20.0)) - ) \ No newline at end of file + + ;; ITU reccommendation phosphors: + + ;; red green blue + ;;x 0.64 0.29 0.15 + ;;y 0.33 0.60 0.06 + ;; + ;; white point: + ;; c : x-w = 0.313, y-w = 0.329, big-y-w = 100.0 + + (define x-r 0.64) + (define y-r 0.33) + (define x-g 0.29) + (define y-g 0.60) + (define x-b 0.15) + (define y-b 0.06) + + (define z-r (- 1 x-r y-r)) + (define z-g (- 1 x-g y-g)) + (define z-b (- 1 x-b y-b)) + + (define x-w 0.313) + (define y-w 0.329) + (define big-y-w 100.0) + + (define-struct xyz (x y z)) + + (define (xy-big-y->xyz x y big-y) + (let ([sigma (/ big-y y)]) + (make-xyz + (* x sigma) + (* y sigma) + (* (- 1 x y) sigma)))) + + (define xyz-white (xy-big-y->xyz x-w y-w big-y-w)) + + ;;`((,(xyz-x xyz-white) ,x-r ,x-g ,x-b) + ;; (,(xyz-y xyz-white) ,y-r ,y-g ,y-b) + ;; (,(xyz-z xyz-white) ,z-r ,z-g ,z-b)) + + ;; sigmas were calculated by soving a set of linear equations based upon ntsc standard phosphors + + (define pre-matrix `((,x-r ,x-g ,x-b) + (,y-r ,y-g ,y-b) + (,z-r ,z-g ,z-b))) + + (define-values (sigma-r sigma-g sigma-b) + (let* ([inversion + (matrix-invert pre-matrix)] + [sigmas + (matrix-multiply inversion `((,(xyz-x xyz-white)) + (,(xyz-y xyz-white)) + (,(xyz-z xyz-white))))]) + (apply values (car (transpose sigmas))))) + + ;; (printf "should be equal to xyz-white: ~n~a~n" + ;; (matrix-multiply pre-matrix `((,sigma-r) (,sigma-g) (,sigma-b)))) + + (define rgb->xyz-matrix + (map (λ (row) + (map (λ (row-elt scalar) (* row-elt scalar 1/255)) row `(,sigma-r ,sigma-g ,sigma-b))) + pre-matrix)) + + (define xyz->rgb-matrix + (matrix-invert rgb->xyz-matrix)) + + ;;(printf "should be identity: ~n~a~n" (matrix-multiply rgb->xyz-matrix xyz->rgb-matrix)) + + (define (rgb->xyz r g b) + (apply make-xyz (car (transpose (matrix-multiply rgb->xyz-matrix (transpose `((,r ,g ,b)))))))) + + ;;(print-struct #t) + ;; (printf "should be xyz-white: ~n~a~n" (rgb->xyz 255 255 255)) + + (define (xyz->rgb x y z) + (car (transpose (matrix-multiply xyz->rgb-matrix (transpose `((,x ,y ,z))))))) + + ;;l* = 116(y/big-y-n)^1/3 - 16, y/big-y-n > 0.01 + ;;u* = 13 l*(u-p - u-p-n) + ;;v* = 13 l*(v-p - v-p-n) + ;; + ;;u-p = (4x)/(x+15y+3z) v-p = (9y)/(x+15y+3z) + ;;u-p-n = (same but with -n) v-p-n = (same but with -n) + + ;; the following transformation is undefined if the y component + ;; is zero. So if it is, we bump it up a little. + + (define (xyz-tweak xyz) + (let* ([y (xyz-y xyz)]) + (make-xyz (xyz-x xyz) (if (< y 0.01) 0.01 y) (xyz-z xyz)))) + + (define-struct luv (l u v)) + + (define (xyz-denom xyz) + (+ (xyz-x xyz) (* 15 (xyz-y xyz)) (* 3 (xyz-z xyz)))) + + (define (xyz-u-p xyz) + (/ (* 4 (xyz-x xyz)) (xyz-denom xyz))) + + (define (xyz-v-p xyz) + (/ (* 9 (xyz-y xyz)) (xyz-denom xyz))) + + (define (xyz->luv xyz) + (let ([xyz (xyz-tweak xyz)]) + (let* ([l (- (* 116 (expt (/ (xyz-y xyz) (xyz-y xyz-white)) + 1/3)) + 16)] + [u-p (xyz-u-p xyz)] + [u-p-white (xyz-u-p xyz-white)] + [v-p (xyz-v-p xyz)] + [v-p-white (xyz-v-p xyz-white)]) + (make-luv l (* 13 l (- u-p u-p-white)) (* 13 l (- v-p v-p-white)))))) + + (define (luv-distance a b) + (expt (+ (expt (- (luv-l a) (luv-l b)) 2) + (expt (- (luv-u a) (luv-u b)) 2) + (expt (- (luv-v a) (luv-v b)) 2)) + 1/2)) + + (define (rgb-color-distance r-a g-a b-a r-b g-b b-b) + (let* ([luv-a (xyz->luv (rgb->xyz r-a g-a b-a))] + [luv-b (xyz->luv (rgb->xyz r-b g-b b-b))]) + (luv-distance luv-a luv-b))) + + ;;(rgb-color-distance 0 0 0 0 0 0) + ;; (print-struct #t) + ;; (xyz->luv (make-xyz 95.0 100.0 141.0)) + ;; (xyz->luv (make-xyz 60.0 80.0 20.0)) + ) \ No newline at end of file diff --git a/collects/framework/private/color-prefs.ss b/collects/framework/private/color-prefs.ss index ca6f4e9b..e516e7fd 100644 --- a/collects/framework/private/color-prefs.ss +++ b/collects/framework/private/color-prefs.ss @@ -85,9 +85,9 @@ (define smoothing-options '(default - partly-smoothed - smoothed - unsmoothed)) + partly-smoothed + smoothed + unsmoothed)) (define smoothing-option-strings '("Default" "Partly smoothed" @@ -119,7 +119,7 @@ (send delta set-smoothing-on (list-ref smoothing-options (send c get-selection))))))])) - + (define color-button (and (>= (get-display-depth) 8) (new button% diff --git a/collects/framework/private/color.ss b/collects/framework/private/color.ss index 7bb9a02f..9c670e67 100644 --- a/collects/framework/private/color.ss +++ b/collects/framework/private/color.ss @@ -8,7 +8,7 @@ (lib "default-lexer.ss" "syntax-color") "../preferences.ss" "sig.ss") - + (import [prefix icon: framework:icon^] [prefix mode: framework:mode^] [prefix text: framework:text^] diff --git a/collects/framework/private/comment-box.ss b/collects/framework/private/comment-box.ss index 87442e72..d1ea8988 100644 --- a/collects/framework/private/comment-box.ss +++ b/collects/framework/private/comment-box.ss @@ -2,7 +2,7 @@ (module comment-box (lib "a-unit.ss") (require (lib "class.ss") (lib "etc.ss") - (lib "mred.ss" "mred") + (lib "mred.ss" "mred") "sig.ss" "../decorated-editor-snip.ss" (lib "include-bitmap.ss" "mrlib") @@ -13,112 +13,112 @@ [prefix keymap: framework:keymap^]) (export (rename framework:comment-box^ (-snip% snip%))) - - (define snipclass% - (class decorated-editor-snipclass% - (define/override (make-snip stream-in) (instantiate -snip% ())) - (super-instantiate ()))) + + (define snipclass% + (class decorated-editor-snipclass% + (define/override (make-snip stream-in) (instantiate -snip% ())) + (super-instantiate ()))) + + (define snipclass (make-object snipclass%)) + (send snipclass set-version 1) + (send snipclass set-classname (format "~s" '(lib "comment-snip.ss" "framework"))) + (send (get-the-snip-class-list) add snipclass) + + (define bm (include-bitmap (lib "semicolon.gif" "icons"))) + + (define (editor-keymap-mixin %) + (class % + (define/override (get-keymaps) + (cons (keymap:get-file) (super get-keymaps))) + (super-instantiate ()))) + + (define scheme+copy-self% #f) + (define (get-scheme+copy-self%) + (unless scheme+copy-self% + (set! scheme+copy-self% + (class scheme:text% + (inherit copy-self-to) + (define/override (copy-self) + (let ([ed (new scheme+copy-self%)]) + (copy-self-to ed) + ed)) + (super-new)))) + scheme+copy-self%) + + (define -snip% + (class* decorated-editor-snip% (readable-snip<%>) + (inherit get-editor get-style) - (define snipclass (make-object snipclass%)) - (send snipclass set-version 1) - (send snipclass set-classname (format "~s" '(lib "comment-snip.ss" "framework"))) - (send (get-the-snip-class-list) add snipclass) + (define/override (make-editor) (new (get-scheme+copy-self%))) + (define/override (make-snip) (make-object -snip%)) + (define/override (get-corner-bitmap) bm) + (define/override (get-position) 'left-top) - (define bm (include-bitmap (lib "semicolon.gif" "icons"))) + (define/override get-text + (opt-lambda (offset num [flattened? #t]) + (let* ([super-res (super get-text offset num flattened?)] + [replaced (string-append "; " (regexp-replace* "\n" super-res "\n; "))]) + (if (char=? #\newline (string-ref replaced (- (string-length replaced) 1))) + replaced + (string-append replaced "\n"))))) - (define (editor-keymap-mixin %) - (class % - (define/override (get-keymaps) - (cons (keymap:get-file) (super get-keymaps))) - (super-instantiate ()))) - (define scheme+copy-self% #f) - (define (get-scheme+copy-self%) - (unless scheme+copy-self% - (set! scheme+copy-self% - (class scheme:text% - (inherit copy-self-to) - (define/override (copy-self) - (let ([ed (new scheme+copy-self%)]) - (copy-self-to ed) - ed)) - (super-new)))) - scheme+copy-self%) + (define/override (get-menu) + (let ([menu (make-object popup-menu%)]) + (make-object menu-item% + (string-constant convert-to-semicolon-comment) + menu + (λ (x y) + (let ([to-ed (find-containing-editor)]) + (when to-ed + (let ([this-pos (find-this-position)]) + (when this-pos + (let ([from-ed (get-editor)]) + (send to-ed begin-edit-sequence) + (send from-ed begin-edit-sequence) + (copy-contents-with-semicolons-to-position to-ed from-ed (+ this-pos 1)) + (send to-ed delete this-pos (+ this-pos 1)) + (send to-ed end-edit-sequence) + (send from-ed end-edit-sequence)))))))) + menu)) - (define -snip% - (class* decorated-editor-snip% (readable-snip<%>) - (inherit get-editor get-style) - - (define/override (make-editor) (new (get-scheme+copy-self%))) - (define/override (make-snip) (make-object -snip%)) - (define/override (get-corner-bitmap) bm) - (define/override (get-position) 'left-top) - - (define/override get-text - (opt-lambda (offset num [flattened? #t]) - (let* ([super-res (super get-text offset num flattened?)] - [replaced (string-append "; " (regexp-replace* "\n" super-res "\n; "))]) - (if (char=? #\newline (string-ref replaced (- (string-length replaced) 1))) - replaced - (string-append replaced "\n"))))) - - - (define/override (get-menu) - (let ([menu (make-object popup-menu%)]) - (make-object menu-item% - (string-constant convert-to-semicolon-comment) - menu - (λ (x y) - (let ([to-ed (find-containing-editor)]) - (when to-ed - (let ([this-pos (find-this-position)]) - (when this-pos - (let ([from-ed (get-editor)]) - (send to-ed begin-edit-sequence) - (send from-ed begin-edit-sequence) - (copy-contents-with-semicolons-to-position to-ed from-ed (+ this-pos 1)) - (send to-ed delete this-pos (+ this-pos 1)) - (send to-ed end-edit-sequence) - (send from-ed end-edit-sequence)))))))) - menu)) - - (inherit get-admin) - ;; find-containing-editor : -> (union #f editor) - (define/private (find-containing-editor) - (let ([admin (get-admin)]) - (and admin - (send admin get-editor)))) - - ;; find-this-position : -> (union #f number) - (define/private (find-this-position) - (let ([ed (find-containing-editor)]) - (and ed - (send ed get-snip-position this)))) - - ;; copy-contents-with-semicolons-to-position : (is-a? text%) number -> void - (define/private (copy-contents-with-semicolons-to-position to-ed from-ed pos) - (let loop ([snip (find-last-snip from-ed)]) - (cond - [snip - (when (or (memq 'hard-newline (send snip get-flags)) - (memq 'newline (send snip get-flags))) - (send to-ed insert "; " pos)) - (send to-ed insert (send snip copy) pos) - (loop (send snip previous))] - [else - (send to-ed insert "; " pos)]))) - - ;; find-last-snip : editor -> snip - ;; returns the last snip in the editor - (define/private (find-last-snip ed) - (let loop ([snip (send ed find-first-snip)] - [acc (send ed find-first-snip)]) - (cond - [snip (loop (send snip next) snip)] - [else acc]))) - - (define/public (read-special source line column position) - (make-special-comment "comment")) - (super-instantiate ()) - (inherit set-snipclass) - (set-snipclass snipclass)))) \ No newline at end of file + (inherit get-admin) + ;; find-containing-editor : -> (union #f editor) + (define/private (find-containing-editor) + (let ([admin (get-admin)]) + (and admin + (send admin get-editor)))) + + ;; find-this-position : -> (union #f number) + (define/private (find-this-position) + (let ([ed (find-containing-editor)]) + (and ed + (send ed get-snip-position this)))) + + ;; copy-contents-with-semicolons-to-position : (is-a? text%) number -> void + (define/private (copy-contents-with-semicolons-to-position to-ed from-ed pos) + (let loop ([snip (find-last-snip from-ed)]) + (cond + [snip + (when (or (memq 'hard-newline (send snip get-flags)) + (memq 'newline (send snip get-flags))) + (send to-ed insert "; " pos)) + (send to-ed insert (send snip copy) pos) + (loop (send snip previous))] + [else + (send to-ed insert "; " pos)]))) + + ;; find-last-snip : editor -> snip + ;; returns the last snip in the editor + (define/private (find-last-snip ed) + (let loop ([snip (send ed find-first-snip)] + [acc (send ed find-first-snip)]) + (cond + [snip (loop (send snip next) snip)] + [else acc]))) + + (define/public (read-special source line column position) + (make-special-comment "comment")) + (super-instantiate ()) + (inherit set-snipclass) + (set-snipclass snipclass)))) \ No newline at end of file diff --git a/collects/framework/private/editor.ss b/collects/framework/private/editor.ss index 40b14de6..d193816a 100644 --- a/collects/framework/private/editor.ss +++ b/collects/framework/private/editor.ss @@ -2,13 +2,13 @@ (module editor (lib "a-unit.ss") (require (lib "class.ss") (lib "string-constant.ss" "string-constants") - "sig.ss" - "../preferences.ss" + "sig.ss" + "../preferences.ss" "../gui-utils.ss" (lib "etc.ss") - (lib "mred-sig.ss" "mred") - (lib "file.ss")) - + (lib "mred-sig.ss" "mred") + (lib "file.ss")) + (import mred^ [prefix autosave: framework:autosave^] [prefix finder: framework:finder^] @@ -23,579 +23,579 @@ [-keymap<%> keymap<%>])) (init-depend mred^ framework:autosave^) - ;; renaming, for editor-mixin where get-file is shadowed by a method. - (define mred:get-file get-file) - - (define basic<%> - (interface (editor<%>) - has-focus? - local-edit-sequence? - run-after-edit-sequence - get-top-level-window - save-file-out-of-date? - save-file/gui-error - load-file/gui-error - on-close - can-close? - close - get-filename/untitled-name)) - - (define basic-mixin - (mixin (editor<%>) (basic<%>) - - (define/pubment (can-close?) (inner #t can-close?)) - (define/pubment (on-close) (inner (void) on-close)) - (define/public (close) (if (can-close?) - (begin (on-close) #t) - #f)) - - ;; get-filename/untitled-name : -> string - ;; returns a string representing the visible name for this file, - ;; or "Untitled " for some n. - (define untitled-name #f) - (define/public (get-filename/untitled-name) - (let ([filename (get-filename)]) - (if filename - (path->string filename) - (begin - (unless untitled-name - (set! untitled-name (gui-utils:next-untitled-name))) - untitled-name)))) - - (inherit get-filename save-file) - (define/public save-file/gui-error - (opt-lambda ([input-filename #f] - [fmt 'same] - [show-errors? #t]) - (let ([filename (if (or (not input-filename) - (equal? input-filename "")) - (let ([internal-filename (get-filename)]) - (if (or (not internal-filename) - (equal? internal-filename "")) - (put-file #f #f) - internal-filename)) - input-filename)]) - (with-handlers ([exn:fail? - (λ (exn) - (message-box - (string-constant error-saving) - (string-append - (format (string-constant error-saving-file/name) - filename) - "\n\n" - (format-error-message exn)) - #f - '(stop ok)) - #f)]) - (when filename - (save-file filename fmt #f)) - #t)))) - - (inherit load-file) - (define/public load-file/gui-error - (opt-lambda ([input-filename #f] - [fmt 'guess] - [show-errors? #t]) - (let ([filename (if (or (not input-filename) - (equal? input-filename "")) - (let ([internal-filename (get-filename)]) - (if (or (not internal-filename) - (equal? internal-filename "")) - (get-file #f) - internal-filename)) - input-filename)]) - (with-handlers ([exn:fail? - (λ (exn) - (message-box - (string-constant error-loading) - (string-append - (format (string-constant error-loading-file/name) - filename) - "\n\n" - (format-error-message exn)) - #f - '(stop ok)) - #f)]) - (load-file input-filename fmt show-errors?) - #t)))) - - (define/private (format-error-message exn) - (let ([sp (open-output-string)]) - (parameterize ([current-output-port sp]) - ((error-display-handler) - (if (exn? exn) - (format "~a" (exn-message exn)) - (format "uncaught exn: ~s" exn)) - exn)) - (get-output-string sp))) - - (inherit refresh-delayed? - get-canvas - get-max-width get-admin) - - (define/augment (can-save-file? filename format) - (and (if (equal? filename (get-filename)) - (if (save-file-out-of-date?) - (gui-utils:get-choice - (string-constant file-has-been-modified) - (string-constant overwrite-file-button-label) - (string-constant cancel) - (string-constant warning) - #f - (get-top-level-window)) - #t) + ;; renaming, for editor-mixin where get-file is shadowed by a method. + (define mred:get-file get-file) + + (define basic<%> + (interface (editor<%>) + has-focus? + local-edit-sequence? + run-after-edit-sequence + get-top-level-window + save-file-out-of-date? + save-file/gui-error + load-file/gui-error + on-close + can-close? + close + get-filename/untitled-name)) + + (define basic-mixin + (mixin (editor<%>) (basic<%>) + + (define/pubment (can-close?) (inner #t can-close?)) + (define/pubment (on-close) (inner (void) on-close)) + (define/public (close) (if (can-close?) + (begin (on-close) #t) + #f)) + + ;; get-filename/untitled-name : -> string + ;; returns a string representing the visible name for this file, + ;; or "Untitled " for some n. + (define untitled-name #f) + (define/public (get-filename/untitled-name) + (let ([filename (get-filename)]) + (if filename + (path->string filename) + (begin + (unless untitled-name + (set! untitled-name (gui-utils:next-untitled-name))) + untitled-name)))) + + (inherit get-filename save-file) + (define/public save-file/gui-error + (opt-lambda ([input-filename #f] + [fmt 'same] + [show-errors? #t]) + (let ([filename (if (or (not input-filename) + (equal? input-filename "")) + (let ([internal-filename (get-filename)]) + (if (or (not internal-filename) + (equal? internal-filename "")) + (put-file #f #f) + internal-filename)) + input-filename)]) + (with-handlers ([exn:fail? + (λ (exn) + (message-box + (string-constant error-saving) + (string-append + (format (string-constant error-saving-file/name) + filename) + "\n\n" + (format-error-message exn)) + #f + '(stop ok)) + #f)]) + (when filename + (save-file filename fmt #f)) + #t)))) + + (inherit load-file) + (define/public load-file/gui-error + (opt-lambda ([input-filename #f] + [fmt 'guess] + [show-errors? #t]) + (let ([filename (if (or (not input-filename) + (equal? input-filename "")) + (let ([internal-filename (get-filename)]) + (if (or (not internal-filename) + (equal? internal-filename "")) + (get-file #f) + internal-filename)) + input-filename)]) + (with-handlers ([exn:fail? + (λ (exn) + (message-box + (string-constant error-loading) + (string-append + (format (string-constant error-loading-file/name) + filename) + "\n\n" + (format-error-message exn)) + #f + '(stop ok)) + #f)]) + (load-file input-filename fmt show-errors?) + #t)))) + + (define/private (format-error-message exn) + (let ([sp (open-output-string)]) + (parameterize ([current-output-port sp]) + ((error-display-handler) + (if (exn? exn) + (format "~a" (exn-message exn)) + (format "uncaught exn: ~s" exn)) + exn)) + (get-output-string sp))) + + (inherit refresh-delayed? + get-canvas + get-max-width get-admin) + + (define/augment (can-save-file? filename format) + (and (if (equal? filename (get-filename)) + (if (save-file-out-of-date?) + (gui-utils:get-choice + (string-constant file-has-been-modified) + (string-constant overwrite-file-button-label) + (string-constant cancel) + (string-constant warning) + #f + (get-top-level-window)) #t) - (inner #t can-save-file? filename format))) - - (define last-saved-file-time #f) - - (define/augment (after-save-file success?) - ;; update recently opened file names - (let* ([temp-b (box #f)] - [filename (get-filename temp-b)]) - (unless (unbox temp-b) - (when filename - (handler:add-to-recent filename)))) - - ;; update last-saved-file-time - (when success? - (let ([filename (get-filename)]) - (set! last-saved-file-time - (and filename - (file-exists? filename) - (file-or-directory-modify-seconds filename))))) - - (inner (void) after-save-file success?)) - - (define/augment (after-load-file success?) - (when success? - (let ([filename (get-filename)]) - (set! last-saved-file-time - (and filename - (file-exists? filename) - (file-or-directory-modify-seconds filename))))) - (inner (void) after-load-file success?)) - (define/public (save-file-out-of-date?) - (and last-saved-file-time - (let ([fn (get-filename)]) - (and fn - (file-exists? fn) - (let ([ms (file-or-directory-modify-seconds fn)]) - (< last-saved-file-time ms)))))) - - (define has-focus #f) - (define/override (on-focus x) - (set! has-focus x) - (super on-focus x)) - (define/public (has-focus?) has-focus) - - (define/public (get-top-level-window) - (let loop ([text this]) - (let ([editor-admin (send text get-admin)]) - (cond - [(is-a? editor-admin editor-snip-editor-admin<%>) - (let* ([snip (send editor-admin get-snip)] - [snip-admin (send snip get-admin)]) - (loop (send snip-admin get-editor)))] - [(send text get-canvas) - => - (λ (canvas) - (send canvas get-top-level-window))] - [else #f])))) - - [define edit-sequence-queue null] - [define edit-sequence-ht (make-hash-table)] - [define in-local-edit-sequence? #f] - [define/public local-edit-sequence? (λ () in-local-edit-sequence?)] - [define/public run-after-edit-sequence - (case-lambda - [(t) (run-after-edit-sequence t #f)] - [(t sym) - (unless (and (procedure? t) - (= 0 (procedure-arity t))) - (error 'editor:basic::run-after-edit-sequence - "expected procedure of arity zero, got: ~s~n" t)) - (unless (or (symbol? sym) (not sym)) - (error 'editor:basic::run-after-edit-sequence - "expected second argument to be a symbol or #f, got: ~s~n" - sym)) - (if (refresh-delayed?) - (if in-local-edit-sequence? - (cond - [(symbol? sym) - (hash-table-put! edit-sequence-ht sym t)] - [else (set! edit-sequence-queue - (cons t edit-sequence-queue))]) - (let ([snip-admin (get-admin)]) - (cond - [(not snip-admin) - (t)] ;; refresh-delayed? is always #t when there is no admin. - [(is-a? snip-admin editor-snip-editor-admin<%>) - (send (send (send (send snip-admin get-snip) get-admin) get-editor) - run-after-edit-sequence t sym)] - [else - '(message-box "run-after-edit-sequence error" - (format "refresh-delayed? is #t but snip admin, ~s, is not an editor-snip-editor-admin<%>" - snip-admin)) - '(t) - (void)]))) - (t)) - (void)])] - [define/public extend-edit-sequence-queue - (λ (l ht) - (hash-table-for-each ht (λ (k t) - (hash-table-put! - edit-sequence-ht - k t))) - (set! edit-sequence-queue (append l edit-sequence-queue)))] - (define/augment (on-edit-sequence) - (set! in-local-edit-sequence? #t) - (inner (void) on-edit-sequence)) - (define/augment (after-edit-sequence) - (set! in-local-edit-sequence? #f) - (let ([queue edit-sequence-queue] - [ht edit-sequence-ht] - [find-enclosing-editor - (λ (editor) - (let ([admin (send editor get-admin)]) - (cond - [(is-a? admin editor-snip-editor-admin<%>) - (send (send (send admin get-snip) get-admin) get-editor)] - [else #f])))]) - (set! edit-sequence-queue null) - (set! edit-sequence-ht (make-hash-table)) - (let loop ([editor (find-enclosing-editor this)]) - (cond - [(and editor - (is-a? editor basic<%>) - (not (send editor local-edit-sequence?))) - (loop (find-enclosing-editor editor))] - [(and editor - (is-a? editor basic<%>)) - (send editor extend-edit-sequence-queue queue ht)] - [else - (hash-table-for-each ht (λ (k t) (t))) - (for-each (λ (t) (t)) queue)]))) - (inner (void) after-edit-sequence)) - - [define/override on-new-box - (λ (type) - (cond - [(eq? type 'text) (make-object editor-snip% (make-object text:basic%))] - [else (make-object editor-snip% (make-object pasteboard:basic%))]))] - - - (define/override (get-file d) - (parameterize ([finder:dialog-parent-parameter - (get-top-level-window)]) - (finder:get-file d))) - (define/override (put-file d f) - (parameterize ([finder:dialog-parent-parameter - (get-top-level-window)]) - (finder:put-file f d))) - - - (super-instantiate ()))) - - (define standard-style-list (new style-list%)) - (define (get-standard-style-list) standard-style-list) + #t) + (inner #t can-save-file? filename format))) - (define default-color-style-name "framework:default-color") - (define (get-default-color-style-name) default-color-style-name) + (define last-saved-file-time #f) - (let ([delta (make-object style-delta% 'change-normal)]) - (send delta set-delta 'change-family 'modern) - (let ([style (send standard-style-list find-named-style "Standard")]) - (if style - (send style set-delta delta) - (send standard-style-list new-named-style "Standard" - (send standard-style-list find-or-create-style - (send standard-style-list find-named-style "Basic") - delta))))) + (define/augment (after-save-file success?) + ;; update recently opened file names + (let* ([temp-b (box #f)] + [filename (get-filename temp-b)]) + (unless (unbox temp-b) + (when filename + (handler:add-to-recent filename)))) - (let ([delta (make-object style-delta%)] - [style (send standard-style-list find-named-style default-color-style-name)]) - (if style - (send style set-delta delta) - (send standard-style-list new-named-style default-color-style-name - (send standard-style-list find-or-create-style - (send standard-style-list find-named-style "Standard") - delta)))) - - (define (set-default-font-color color) - (let* ([scheme-standard (send standard-style-list find-named-style default-color-style-name)] - [scheme-delta (make-object style-delta%)]) - (send scheme-standard get-delta scheme-delta) - (send scheme-delta set-delta-foreground color) - (send scheme-standard set-delta scheme-delta))) - - (define (set-font-size size) - (update-standard-style - (λ (scheme-delta) - (send scheme-delta set-size-mult 0) - (send scheme-delta set-size-add size)))) - - (define (set-font-name name) - (update-standard-style - (λ (scheme-delta) - (send scheme-delta set-delta-face name) - (send scheme-delta set-family 'modern)))) - - (define (set-font-smoothing sym) - (update-standard-style - (λ (scheme-delta) - (send scheme-delta set-smoothing-on sym)))) - - (define (update-standard-style cng-delta) - (let* ([scheme-standard (send standard-style-list find-named-style "Standard")] - [scheme-delta (make-object style-delta%)]) - (send scheme-standard get-delta scheme-delta) - (cng-delta scheme-delta) - (send scheme-standard set-delta scheme-delta))) - - (define standard-style-list<%> - (interface (editor<%>) - )) - - (define standard-style-list-mixin - (mixin (editor<%>) (standard-style-list<%>) - (super-instantiate ()) - (inherit set-style-list set-load-overwrites-styles) - (set-style-list standard-style-list) - (set-load-overwrites-styles #f))) - - (define (set-standard-style-list-pref-callbacks) - (set-font-size (preferences:get 'framework:standard-style-list:font-size)) - (set-font-name (preferences:get 'framework:standard-style-list:font-name)) - (set-font-smoothing (preferences:get 'framework:standard-style-list:smoothing)) - (preferences:add-callback 'framework:standard-style-list:font-size (λ (p v) (set-font-size v))) - (preferences:add-callback 'framework:standard-style-list:font-name (λ (p v) (set-font-name v))) - (preferences:add-callback 'framework:standard-style-list:smoothing (λ (p v) (set-font-smoothing v))) + ;; update last-saved-file-time + (when success? + (let ([filename (get-filename)]) + (set! last-saved-file-time + (and filename + (file-exists? filename) + (file-or-directory-modify-seconds filename))))) - (unless (member (preferences:get 'framework:standard-style-list:font-name) (get-face-list)) - (preferences:set 'framework:standard-style-list:font-name (get-family-builtin-face 'modern)))) + (inner (void) after-save-file success?)) - ;; set-standard-style-list-delta : string (is-a?/c style-delta<%>) -> void - (define (set-standard-style-list-delta name delta) - (let* ([style-list (get-standard-style-list)] - [style (send style-list find-named-style name)]) - (if style - (send style set-delta delta) - (send style-list new-named-style name - (send style-list find-or-create-style - (send style-list find-named-style "Standard") - delta))) - (void))) + (define/augment (after-load-file success?) + (when success? + (let ([filename (get-filename)]) + (set! last-saved-file-time + (and filename + (file-exists? filename) + (file-or-directory-modify-seconds filename))))) + (inner (void) after-load-file success?)) + (define/public (save-file-out-of-date?) + (and last-saved-file-time + (let ([fn (get-filename)]) + (and fn + (file-exists? fn) + (let ([ms (file-or-directory-modify-seconds fn)]) + (< last-saved-file-time ms)))))) - (define -keymap<%> (interface (basic<%>) get-keymaps)) - (define keymap-mixin - (mixin (basic<%>) (-keymap<%>) - [define/public get-keymaps - (λ () - (list (keymap:get-global)))] - (inherit set-keymap) - - (super-instantiate ()) - (let ([keymap (make-object keymap:aug-keymap%)]) - (set-keymap keymap) - (for-each (λ (k) (send keymap chain-to-keymap k #f)) - (get-keymaps))))) - - (define autowrap<%> (interface (basic<%>))) - (define autowrap-mixin - (mixin (basic<%>) (autowrap<%>) - (inherit auto-wrap) - (super-instantiate ()) - (auto-wrap - (preferences:get - 'framework:auto-set-wrap?)))) + (define has-focus #f) + (define/override (on-focus x) + (set! has-focus x) + (super on-focus x)) + (define/public (has-focus?) has-focus) - (define file<%> - (interface (-keymap<%>) - get-can-close-parent - update-frame-filename - allow-close-with-no-filename?)) - - (define file-mixin - (mixin (-keymap<%>) (file<%>) - (inherit get-filename lock get-style-list - is-modified? set-modified - get-top-level-window) - - (inherit get-canvases get-filename/untitled-name) - (define/public (update-frame-filename) - (let* ([filename (get-filename)] - [name (if filename - (path->string - (file-name-from-path - filename)) - (get-filename/untitled-name))]) - (for-each (λ (canvas) - (let ([tlw (send canvas get-top-level-window)]) - (when (and (is-a? tlw frame:editor<%>) - (eq? this (send tlw get-editor))) - (send tlw set-label name)))) - (get-canvases)))) - - (define/override set-filename - (case-lambda - [(name) (set-filename name #f)] - [(name temp?) - (super set-filename name temp?) - (unless temp? - (update-frame-filename))])) - - (inherit save-file) - (define/public (allow-close-with-no-filename?) #f) - (define/augment (can-close?) - (let* ([user-allowed-or-not-modified - (or (not (is-modified?)) - (and (not (get-filename)) - (allow-close-with-no-filename?)) - (case (gui-utils:unsaved-warning - (get-filename/untitled-name) - (string-constant close-anyway) - #t - (or (get-top-level-window) - (get-can-close-parent))) - [(continue) #t] - [(save) (save-file)] - [else #f]))]) - (and user-allowed-or-not-modified - (inner #t can-close?)))) - - (define/public (get-can-close-parent) #f) - - (define/override (get-keymaps) - (cons (keymap:get-file) (super get-keymaps))) - (super-new))) - - (define backup-autosave<%> - (interface (basic<%>) - backup? - autosave? - do-autosave - remove-autosave)) - - (define backup-autosave-mixin - (mixin (basic<%>) (backup-autosave<%> autosave:autosavable<%>) - (inherit is-modified? get-filename save-file) - [define auto-saved-name #f] - [define auto-save-out-of-date? #t] - [define auto-save-error? #f] - (define/private (file-old? filename) - (if (and filename - (file-exists? filename)) - (let ([modified-seconds (file-or-directory-modify-seconds filename)] - [old-seconds (- (current-seconds) (* 7 24 60 60))]) - (< modified-seconds old-seconds)) - #t)) - (define/public (backup?) (preferences:get 'framework:backup-files?)) - (define/augment (on-save-file name format) - (set! auto-save-error? #f) - (when (and (backup?) - (not (eq? format 'copy)) - (file-exists? name)) - (let ([back-name (path-utils:generate-backup-name name)]) - (when (or (not (file-exists? back-name)) - (file-old? back-name)) - (when (file-exists? back-name) - (delete-file back-name)) - (with-handlers ([(λ (x) #t) void]) - (copy-file name back-name))))) - (inner (void) on-save-file name format)) - (define/augment (on-close) - (remove-autosave) - (set! do-autosave? #f) - (inner (void) on-close)) - (define/augment (on-change) - (set! auto-save-out-of-date? #t) - (inner (void) on-change)) - (define/override (set-modified modified?) - (when auto-saved-name - (if modified? - (set! auto-save-out-of-date? #t) - (remove-autosave))) - (super set-modified modified?)) - - [define do-autosave? #t] - (define/public (autosave?) do-autosave?) - - (define/public (do-autosave) + (define/public (get-top-level-window) + (let loop ([text this]) + (let ([editor-admin (send text get-admin)]) (cond - [(and (autosave?) - (not auto-save-error?) - (is-modified?) - (or (not auto-saved-name) - auto-save-out-of-date?)) - (let* ([orig-name (get-filename)] - [old-auto-name auto-saved-name] - [auto-name (path-utils:generate-autosave-name orig-name)] - [orig-format (and (is-a? this text%) - (send this get-file-format))]) - (when (is-a? this text%) - (send this set-file-format 'standard)) - (with-handlers ([exn:fail? - (λ (exn) - (show-autosave-error exn orig-name) - (set! auto-save-error? #t) - (when (is-a? this text%) - (send this set-file-format orig-format)) - #f)]) - (save-file auto-name 'copy #f) - (when (is-a? this text%) - (send this set-file-format orig-format)) - (when old-auto-name - (delete-file old-auto-name)) - (set! auto-saved-name auto-name) - (set! auto-save-out-of-date? #f) - auto-name))] - [else auto-saved-name])) - - ;; show-autosave-error : any (union #f string) -> void - ;; opens a message box displaying the exn and the filename - ;; to the user. - (define/private (show-autosave-error exn orig-name) - (message-box - (string-constant warning) - (string-append - (format (string-constant error-autosaving) - (or orig-name (string-constant untitled))) - "\n" - (string-constant autosaving-turned-off) - "\n\n" - (if (exn? exn) - (format "~a" (exn-message exn)) - (format "~s" exn))) - #f - '(caution ok))) - - (define/public (remove-autosave) - (when auto-saved-name - (when (file-exists? auto-saved-name) - (delete-file auto-saved-name)) - (set! auto-saved-name #f))) - (super-instantiate ()) - (autosave:register this))) - - (define info<%> (interface (basic<%>))) - (define info-mixin - (mixin (basic<%>) (info<%>) - (inherit get-top-level-window run-after-edit-sequence) - (define callback-running? #f) - (define/override (lock x) - (super lock x) - (run-after-edit-sequence - (rec send-frame-update-lock-icon - (λ () - (unless callback-running? - (set! callback-running? #t) - (queue-callback - (λ () - (let ([frame (get-top-level-window)]) - (when (is-a? frame frame:info<%>) - (send frame lock-status-changed))) - (set! callback-running? #f)) - #f)))) - 'framework:update-lock-icon)) - (super-instantiate ())))) + [(is-a? editor-admin editor-snip-editor-admin<%>) + (let* ([snip (send editor-admin get-snip)] + [snip-admin (send snip get-admin)]) + (loop (send snip-admin get-editor)))] + [(send text get-canvas) + => + (λ (canvas) + (send canvas get-top-level-window))] + [else #f])))) + + [define edit-sequence-queue null] + [define edit-sequence-ht (make-hash-table)] + [define in-local-edit-sequence? #f] + [define/public local-edit-sequence? (λ () in-local-edit-sequence?)] + [define/public run-after-edit-sequence + (case-lambda + [(t) (run-after-edit-sequence t #f)] + [(t sym) + (unless (and (procedure? t) + (= 0 (procedure-arity t))) + (error 'editor:basic::run-after-edit-sequence + "expected procedure of arity zero, got: ~s~n" t)) + (unless (or (symbol? sym) (not sym)) + (error 'editor:basic::run-after-edit-sequence + "expected second argument to be a symbol or #f, got: ~s~n" + sym)) + (if (refresh-delayed?) + (if in-local-edit-sequence? + (cond + [(symbol? sym) + (hash-table-put! edit-sequence-ht sym t)] + [else (set! edit-sequence-queue + (cons t edit-sequence-queue))]) + (let ([snip-admin (get-admin)]) + (cond + [(not snip-admin) + (t)] ;; refresh-delayed? is always #t when there is no admin. + [(is-a? snip-admin editor-snip-editor-admin<%>) + (send (send (send (send snip-admin get-snip) get-admin) get-editor) + run-after-edit-sequence t sym)] + [else + '(message-box "run-after-edit-sequence error" + (format "refresh-delayed? is #t but snip admin, ~s, is not an editor-snip-editor-admin<%>" + snip-admin)) + '(t) + (void)]))) + (t)) + (void)])] + [define/public extend-edit-sequence-queue + (λ (l ht) + (hash-table-for-each ht (λ (k t) + (hash-table-put! + edit-sequence-ht + k t))) + (set! edit-sequence-queue (append l edit-sequence-queue)))] + (define/augment (on-edit-sequence) + (set! in-local-edit-sequence? #t) + (inner (void) on-edit-sequence)) + (define/augment (after-edit-sequence) + (set! in-local-edit-sequence? #f) + (let ([queue edit-sequence-queue] + [ht edit-sequence-ht] + [find-enclosing-editor + (λ (editor) + (let ([admin (send editor get-admin)]) + (cond + [(is-a? admin editor-snip-editor-admin<%>) + (send (send (send admin get-snip) get-admin) get-editor)] + [else #f])))]) + (set! edit-sequence-queue null) + (set! edit-sequence-ht (make-hash-table)) + (let loop ([editor (find-enclosing-editor this)]) + (cond + [(and editor + (is-a? editor basic<%>) + (not (send editor local-edit-sequence?))) + (loop (find-enclosing-editor editor))] + [(and editor + (is-a? editor basic<%>)) + (send editor extend-edit-sequence-queue queue ht)] + [else + (hash-table-for-each ht (λ (k t) (t))) + (for-each (λ (t) (t)) queue)]))) + (inner (void) after-edit-sequence)) + + [define/override on-new-box + (λ (type) + (cond + [(eq? type 'text) (make-object editor-snip% (make-object text:basic%))] + [else (make-object editor-snip% (make-object pasteboard:basic%))]))] + + + (define/override (get-file d) + (parameterize ([finder:dialog-parent-parameter + (get-top-level-window)]) + (finder:get-file d))) + (define/override (put-file d f) + (parameterize ([finder:dialog-parent-parameter + (get-top-level-window)]) + (finder:put-file f d))) + + + (super-instantiate ()))) + + (define standard-style-list (new style-list%)) + (define (get-standard-style-list) standard-style-list) + + (define default-color-style-name "framework:default-color") + (define (get-default-color-style-name) default-color-style-name) + + (let ([delta (make-object style-delta% 'change-normal)]) + (send delta set-delta 'change-family 'modern) + (let ([style (send standard-style-list find-named-style "Standard")]) + (if style + (send style set-delta delta) + (send standard-style-list new-named-style "Standard" + (send standard-style-list find-or-create-style + (send standard-style-list find-named-style "Basic") + delta))))) + + (let ([delta (make-object style-delta%)] + [style (send standard-style-list find-named-style default-color-style-name)]) + (if style + (send style set-delta delta) + (send standard-style-list new-named-style default-color-style-name + (send standard-style-list find-or-create-style + (send standard-style-list find-named-style "Standard") + delta)))) + + (define (set-default-font-color color) + (let* ([scheme-standard (send standard-style-list find-named-style default-color-style-name)] + [scheme-delta (make-object style-delta%)]) + (send scheme-standard get-delta scheme-delta) + (send scheme-delta set-delta-foreground color) + (send scheme-standard set-delta scheme-delta))) + + (define (set-font-size size) + (update-standard-style + (λ (scheme-delta) + (send scheme-delta set-size-mult 0) + (send scheme-delta set-size-add size)))) + + (define (set-font-name name) + (update-standard-style + (λ (scheme-delta) + (send scheme-delta set-delta-face name) + (send scheme-delta set-family 'modern)))) + + (define (set-font-smoothing sym) + (update-standard-style + (λ (scheme-delta) + (send scheme-delta set-smoothing-on sym)))) + + (define (update-standard-style cng-delta) + (let* ([scheme-standard (send standard-style-list find-named-style "Standard")] + [scheme-delta (make-object style-delta%)]) + (send scheme-standard get-delta scheme-delta) + (cng-delta scheme-delta) + (send scheme-standard set-delta scheme-delta))) + + (define standard-style-list<%> + (interface (editor<%>) + )) + + (define standard-style-list-mixin + (mixin (editor<%>) (standard-style-list<%>) + (super-instantiate ()) + (inherit set-style-list set-load-overwrites-styles) + (set-style-list standard-style-list) + (set-load-overwrites-styles #f))) + + (define (set-standard-style-list-pref-callbacks) + (set-font-size (preferences:get 'framework:standard-style-list:font-size)) + (set-font-name (preferences:get 'framework:standard-style-list:font-name)) + (set-font-smoothing (preferences:get 'framework:standard-style-list:smoothing)) + (preferences:add-callback 'framework:standard-style-list:font-size (λ (p v) (set-font-size v))) + (preferences:add-callback 'framework:standard-style-list:font-name (λ (p v) (set-font-name v))) + (preferences:add-callback 'framework:standard-style-list:smoothing (λ (p v) (set-font-smoothing v))) + + (unless (member (preferences:get 'framework:standard-style-list:font-name) (get-face-list)) + (preferences:set 'framework:standard-style-list:font-name (get-family-builtin-face 'modern)))) + + ;; set-standard-style-list-delta : string (is-a?/c style-delta<%>) -> void + (define (set-standard-style-list-delta name delta) + (let* ([style-list (get-standard-style-list)] + [style (send style-list find-named-style name)]) + (if style + (send style set-delta delta) + (send style-list new-named-style name + (send style-list find-or-create-style + (send style-list find-named-style "Standard") + delta))) + (void))) + + (define -keymap<%> (interface (basic<%>) get-keymaps)) + (define keymap-mixin + (mixin (basic<%>) (-keymap<%>) + [define/public get-keymaps + (λ () + (list (keymap:get-global)))] + (inherit set-keymap) + + (super-instantiate ()) + (let ([keymap (make-object keymap:aug-keymap%)]) + (set-keymap keymap) + (for-each (λ (k) (send keymap chain-to-keymap k #f)) + (get-keymaps))))) + + (define autowrap<%> (interface (basic<%>))) + (define autowrap-mixin + (mixin (basic<%>) (autowrap<%>) + (inherit auto-wrap) + (super-instantiate ()) + (auto-wrap + (preferences:get + 'framework:auto-set-wrap?)))) + + (define file<%> + (interface (-keymap<%>) + get-can-close-parent + update-frame-filename + allow-close-with-no-filename?)) + + (define file-mixin + (mixin (-keymap<%>) (file<%>) + (inherit get-filename lock get-style-list + is-modified? set-modified + get-top-level-window) + + (inherit get-canvases get-filename/untitled-name) + (define/public (update-frame-filename) + (let* ([filename (get-filename)] + [name (if filename + (path->string + (file-name-from-path + filename)) + (get-filename/untitled-name))]) + (for-each (λ (canvas) + (let ([tlw (send canvas get-top-level-window)]) + (when (and (is-a? tlw frame:editor<%>) + (eq? this (send tlw get-editor))) + (send tlw set-label name)))) + (get-canvases)))) + + (define/override set-filename + (case-lambda + [(name) (set-filename name #f)] + [(name temp?) + (super set-filename name temp?) + (unless temp? + (update-frame-filename))])) + + (inherit save-file) + (define/public (allow-close-with-no-filename?) #f) + (define/augment (can-close?) + (let* ([user-allowed-or-not-modified + (or (not (is-modified?)) + (and (not (get-filename)) + (allow-close-with-no-filename?)) + (case (gui-utils:unsaved-warning + (get-filename/untitled-name) + (string-constant close-anyway) + #t + (or (get-top-level-window) + (get-can-close-parent))) + [(continue) #t] + [(save) (save-file)] + [else #f]))]) + (and user-allowed-or-not-modified + (inner #t can-close?)))) + + (define/public (get-can-close-parent) #f) + + (define/override (get-keymaps) + (cons (keymap:get-file) (super get-keymaps))) + (super-new))) + + (define backup-autosave<%> + (interface (basic<%>) + backup? + autosave? + do-autosave + remove-autosave)) + + (define backup-autosave-mixin + (mixin (basic<%>) (backup-autosave<%> autosave:autosavable<%>) + (inherit is-modified? get-filename save-file) + [define auto-saved-name #f] + [define auto-save-out-of-date? #t] + [define auto-save-error? #f] + (define/private (file-old? filename) + (if (and filename + (file-exists? filename)) + (let ([modified-seconds (file-or-directory-modify-seconds filename)] + [old-seconds (- (current-seconds) (* 7 24 60 60))]) + (< modified-seconds old-seconds)) + #t)) + (define/public (backup?) (preferences:get 'framework:backup-files?)) + (define/augment (on-save-file name format) + (set! auto-save-error? #f) + (when (and (backup?) + (not (eq? format 'copy)) + (file-exists? name)) + (let ([back-name (path-utils:generate-backup-name name)]) + (when (or (not (file-exists? back-name)) + (file-old? back-name)) + (when (file-exists? back-name) + (delete-file back-name)) + (with-handlers ([(λ (x) #t) void]) + (copy-file name back-name))))) + (inner (void) on-save-file name format)) + (define/augment (on-close) + (remove-autosave) + (set! do-autosave? #f) + (inner (void) on-close)) + (define/augment (on-change) + (set! auto-save-out-of-date? #t) + (inner (void) on-change)) + (define/override (set-modified modified?) + (when auto-saved-name + (if modified? + (set! auto-save-out-of-date? #t) + (remove-autosave))) + (super set-modified modified?)) + + [define do-autosave? #t] + (define/public (autosave?) do-autosave?) + + (define/public (do-autosave) + (cond + [(and (autosave?) + (not auto-save-error?) + (is-modified?) + (or (not auto-saved-name) + auto-save-out-of-date?)) + (let* ([orig-name (get-filename)] + [old-auto-name auto-saved-name] + [auto-name (path-utils:generate-autosave-name orig-name)] + [orig-format (and (is-a? this text%) + (send this get-file-format))]) + (when (is-a? this text%) + (send this set-file-format 'standard)) + (with-handlers ([exn:fail? + (λ (exn) + (show-autosave-error exn orig-name) + (set! auto-save-error? #t) + (when (is-a? this text%) + (send this set-file-format orig-format)) + #f)]) + (save-file auto-name 'copy #f) + (when (is-a? this text%) + (send this set-file-format orig-format)) + (when old-auto-name + (delete-file old-auto-name)) + (set! auto-saved-name auto-name) + (set! auto-save-out-of-date? #f) + auto-name))] + [else auto-saved-name])) + + ;; show-autosave-error : any (union #f string) -> void + ;; opens a message box displaying the exn and the filename + ;; to the user. + (define/private (show-autosave-error exn orig-name) + (message-box + (string-constant warning) + (string-append + (format (string-constant error-autosaving) + (or orig-name (string-constant untitled))) + "\n" + (string-constant autosaving-turned-off) + "\n\n" + (if (exn? exn) + (format "~a" (exn-message exn)) + (format "~s" exn))) + #f + '(caution ok))) + + (define/public (remove-autosave) + (when auto-saved-name + (when (file-exists? auto-saved-name) + (delete-file auto-saved-name)) + (set! auto-saved-name #f))) + (super-instantiate ()) + (autosave:register this))) + + (define info<%> (interface (basic<%>))) + (define info-mixin + (mixin (basic<%>) (info<%>) + (inherit get-top-level-window run-after-edit-sequence) + (define callback-running? #f) + (define/override (lock x) + (super lock x) + (run-after-edit-sequence + (rec send-frame-update-lock-icon + (λ () + (unless callback-running? + (set! callback-running? #t) + (queue-callback + (λ () + (let ([frame (get-top-level-window)]) + (when (is-a? frame frame:info<%>) + (send frame lock-status-changed))) + (set! callback-running? #f)) + #f)))) + 'framework:update-lock-icon)) + (super-new)))) diff --git a/collects/framework/private/exit.ss b/collects/framework/private/exit.ss index c49ad268..8eb04670 100644 --- a/collects/framework/private/exit.ss +++ b/collects/framework/private/exit.ss @@ -1,75 +1,75 @@ (module exit (lib "a-unit.ss") (require (lib "string-constant.ss" "string-constants") - "sig.ss" - "../preferences.ss" + "sig.ss" + "../preferences.ss" "../gui-utils.ss" - (lib "mred-sig.ss" "mred")) - + (lib "mred-sig.ss" "mred")) + (import mred^) (export (rename framework:exit^ (-exit exit))) - - (define can?-callbacks '()) - (define on-callbacks '()) - - (define insert-can?-callback - (λ (cb) - (set! can?-callbacks (cons cb can?-callbacks)) - (λ () - (set! can?-callbacks - (let loop ([cb-list can?-callbacks]) - (cond - [(null? cb-list) ()] - [(eq? cb (car cb-list)) (cdr cb-list)] - [else (cons (car cb-list) (loop (cdr cb-list)))])))))) - - (define insert-on-callback - (λ (cb) - (set! on-callbacks (cons cb on-callbacks)) - (λ () - (set! on-callbacks - (let loop ([cb-list on-callbacks]) - (cond - [(null? cb-list) ()] - [(eq? cb (car cb-list)) (cdr cb-list)] - [else (cons (car cb-list) (loop (cdr cb-list)))])))))) - - (define is-exiting? #f) - (define (set-exiting b) (set! is-exiting? b)) - (define (exiting?) is-exiting?) - - (define (can-exit?) (andmap (λ (cb) (cb)) can?-callbacks)) - (define (on-exit) (for-each (λ (cb) (cb)) on-callbacks)) - - (define (user-oks-exit) - (if (preferences:get 'framework:verify-exit) - (gui-utils:get-choice - (if (eq? (system-type) 'windows) - (string-constant are-you-sure-exit) - (string-constant are-you-sure-quit)) - (if (eq? (system-type) 'windows) - (string-constant exit) - (string-constant quit)) - (if (eq? (system-type) 'windows) - (string-constant dont-exit) - (string-constant dont-quit)) - (string-constant warning) - #f - #f - 'app - (case-lambda - [() (not (preferences:get 'framework:verify-exit))] - [(new) (preferences:set 'framework:verify-exit (not new))])) - #t)) - - (define (-exit) - (set! is-exiting? #t) - (cond - [(can-exit?) - (on-exit) - (queue-callback - (λ () - (exit) - (set! is-exiting? #f)))] - [else - (set! is-exiting? #f)]))) + + (define can?-callbacks '()) + (define on-callbacks '()) + + (define insert-can?-callback + (λ (cb) + (set! can?-callbacks (cons cb can?-callbacks)) + (λ () + (set! can?-callbacks + (let loop ([cb-list can?-callbacks]) + (cond + [(null? cb-list) ()] + [(eq? cb (car cb-list)) (cdr cb-list)] + [else (cons (car cb-list) (loop (cdr cb-list)))])))))) + + (define insert-on-callback + (λ (cb) + (set! on-callbacks (cons cb on-callbacks)) + (λ () + (set! on-callbacks + (let loop ([cb-list on-callbacks]) + (cond + [(null? cb-list) ()] + [(eq? cb (car cb-list)) (cdr cb-list)] + [else (cons (car cb-list) (loop (cdr cb-list)))])))))) + + (define is-exiting? #f) + (define (set-exiting b) (set! is-exiting? b)) + (define (exiting?) is-exiting?) + + (define (can-exit?) (andmap (λ (cb) (cb)) can?-callbacks)) + (define (on-exit) (for-each (λ (cb) (cb)) on-callbacks)) + + (define (user-oks-exit) + (if (preferences:get 'framework:verify-exit) + (gui-utils:get-choice + (if (eq? (system-type) 'windows) + (string-constant are-you-sure-exit) + (string-constant are-you-sure-quit)) + (if (eq? (system-type) 'windows) + (string-constant exit) + (string-constant quit)) + (if (eq? (system-type) 'windows) + (string-constant dont-exit) + (string-constant dont-quit)) + (string-constant warning) + #f + #f + 'app + (case-lambda + [() (not (preferences:get 'framework:verify-exit))] + [(new) (preferences:set 'framework:verify-exit (not new))])) + #t)) + + (define (-exit) + (set! is-exiting? #t) + (cond + [(can-exit?) + (on-exit) + (queue-callback + (λ () + (exit) + (set! is-exiting? #f)))] + [else + (set! is-exiting? #f)]))) diff --git a/collects/framework/private/finder.ss b/collects/framework/private/finder.ss index 2807b45e..6320772d 100644 --- a/collects/framework/private/finder.ss +++ b/collects/framework/private/finder.ss @@ -1,67 +1,67 @@ (module finder (lib "a-unit.ss") (require (lib "string-constant.ss" "string-constants") - "sig.ss" + "sig.ss" "../preferences.ss" - (lib "mred-sig.ss" "mred") - (lib "string.ss") - (lib "file.ss") - (lib "etc.ss")) - - + (lib "mred-sig.ss" "mred") + (lib "string.ss") + (lib "file.ss") + (lib "etc.ss")) + + (import mred^ [prefix keymap: framework:keymap^]) - + (export (rename framework:finder^ [-put-file put-file] [-get-file get-file])) - - (define dialog-parent-parameter (make-parameter #f)) - - (define filter-match? - (λ (filter name msg) - (let-values ([(base name dir?) (split-path name)]) - (if (regexp-match-exact? filter (path->bytes name)) - #t - (begin - (message-box (string-constant error) msg) - #f))))) - - (define default-filters (make-parameter '(("Any" "*.*")))) - (define default-extension (make-parameter "")) - - ;; dialog wrappers - - (define (*put-file style) - (opt-lambda ([name #f] - [directory #f] - [replace? #f] - [prompt (string-constant select-file)] - [filter #f] - [filter-msg (string-constant file-wrong-form)] - [parent-win (dialog-parent-parameter)]) - (let* ([directory (if (and (not directory) (string? name)) - (path-only name) - directory)] - [name (or (and (string? name) (file-name-from-path name)) - name)] - [f (put-file prompt parent-win directory name - (default-extension) style (default-filters))]) - (and f (or (not filter) (filter-match? filter f filter-msg)) - (let* ([f (normal-case-path (normalize-path f))] - [dir (path-only f)] - [name (file-name-from-path f)]) - (cond - [(not (and (path-string? dir) (directory-exists? dir))) - (message-box (string-constant error) - (string-constant dir-dne)) - #f] - [(or (not name) (equal? name "")) - (message-box (string-constant error) - (string-constant empty-filename)) - #f] - [else f])))))) - + + (define dialog-parent-parameter (make-parameter #f)) + + (define filter-match? + (λ (filter name msg) + (let-values ([(base name dir?) (split-path name)]) + (if (regexp-match-exact? filter (path->bytes name)) + #t + (begin + (message-box (string-constant error) msg) + #f))))) + + (define default-filters (make-parameter '(("Any" "*.*")))) + (define default-extension (make-parameter "")) + + ;; dialog wrappers + + (define (*put-file style) + (opt-lambda ([name #f] + [directory #f] + [replace? #f] + [prompt (string-constant select-file)] + [filter #f] + [filter-msg (string-constant file-wrong-form)] + [parent-win (dialog-parent-parameter)]) + (let* ([directory (if (and (not directory) (string? name)) + (path-only name) + directory)] + [name (or (and (string? name) (file-name-from-path name)) + name)] + [f (put-file prompt parent-win directory name + (default-extension) style (default-filters))]) + (and f (or (not filter) (filter-match? filter f filter-msg)) + (let* ([f (normal-case-path (normalize-path f))] + [dir (path-only f)] + [name (file-name-from-path f)]) + (cond + [(not (and (path-string? dir) (directory-exists? dir))) + (message-box (string-constant error) + (string-constant dir-dne)) + #f] + [(or (not name) (equal? name "")) + (message-box (string-constant error) + (string-constant empty-filename)) + #f] + [else f])))))) + (define (*get-file style) (opt-lambda ([directory #f] [prompt (string-constant select-file)] @@ -80,24 +80,24 @@ (string-constant file-dne)) #f] [else f])))))) - - ;; external interfaces to file functions - - (define std-put-file (*put-file '())) - (define std-get-file (*get-file '())) - (define common-put-file (*put-file '(common))) - (define common-get-file (*get-file '(common))) - (define common-get-file-list void) - - (define -put-file - (λ args - (apply (case (preferences:get 'framework:file-dialogs) - [(std) std-put-file] - [(common) common-put-file]) - args))) - (define -get-file - (λ args - (apply (case (preferences:get 'framework:file-dialogs) - [(std) std-get-file] - [(common) common-get-file]) - args)))) + + ;; external interfaces to file functions + + (define std-put-file (*put-file '())) + (define std-get-file (*get-file '())) + (define common-put-file (*put-file '(common))) + (define common-get-file (*get-file '(common))) + (define common-get-file-list void) + + (define -put-file + (λ args + (apply (case (preferences:get 'framework:file-dialogs) + [(std) std-put-file] + [(common) common-put-file]) + args))) + (define -get-file + (λ args + (apply (case (preferences:get 'framework:file-dialogs) + [(std) std-get-file] + [(common) common-get-file]) + args)))) diff --git a/collects/framework/private/frame.ss b/collects/framework/private/frame.ss index 241194fa..bd1671e3 100644 --- a/collects/framework/private/frame.ss +++ b/collects/framework/private/frame.ss @@ -1,15 +1,15 @@ (module frame (lib "a-unit.ss") (require (lib "string-constant.ss" "string-constants") - (lib "class.ss") - (lib "include.ss") - "sig.ss" - "../preferences.ss" + (lib "class.ss") + (lib "include.ss") + "sig.ss" + "../preferences.ss" "../gui-utils.ss" "bday.ss" - (lib "mred-sig.ss" "mred") - (lib "list.ss") - (lib "file.ss") - (lib "etc.ss")) + (lib "mred-sig.ss" "mred") + (lib "list.ss") + (lib "file.ss") + (lib "etc.ss")) (import mred^ [prefix group: framework:group^] @@ -33,681 +33,681 @@ [-editor<%> editor<%>] [-pasteboard% pasteboard%] [-text% text%])) - + (init-depend mred^ framework:text^ framework:canvas^) - (define (reorder-menus frame) - (define items (send (send frame get-menu-bar) get-items)) - (define (find-menu name) - (ormap (λ (i) (and (string=? (send i get-plain-label) name) i)) - items)) - (let* ([file-menu (find-menu (string-constant file-menu))] - [edit-menu (find-menu (string-constant edit-menu))] - [windows-menu (find-menu (string-constant windows-menu))] - [help-menu (find-menu (string-constant help-menu))] - [other-items - (remq* (list file-menu edit-menu windows-menu help-menu) items)] - [re-ordered (filter values `(,file-menu ,edit-menu - ,@other-items - ,windows-menu ,help-menu))]) - (for-each (λ (item) (send item delete)) items) - (for-each (λ (item) (send item restore)) re-ordered))) - - (define (remove-empty-menus frame) - (define menus (send (send frame get-menu-bar) get-items)) - (for-each (λ (menu) (send menu delete)) menus) - (for-each (λ (menu) - (when (pair? (send menu get-items)) (send menu restore))) - menus)) - - (define add-snip-menu-items - (opt-lambda (edit-menu c% [func void]) - (let* ([get-edit-target-object - (λ () - (let ([menu-bar - (let loop ([p (send edit-menu get-parent)]) - (cond - [(is-a? p menu-bar%) - p] - [(is-a? p menu%) - (loop (send p get-parent))] - [else #f]))]) - (and menu-bar - (let ([frame (send menu-bar get-frame)]) - (send frame get-edit-target-object)))))] - [edit-menu:do - (λ (const) - (λ (menu evt) - (let ([edit (get-edit-target-object)]) - (when (and edit - (is-a? edit editor<%>)) - (send edit do-edit-operation const))) - #t))] - [on-demand - (λ (menu-item) - (let ([edit (get-edit-target-object)]) - (send menu-item enable (and edit (is-a? edit editor<%>)))))] - [insert-comment-box - (λ () - (let ([text (get-edit-target-object)]) - (when text - (let ([snip (make-object comment-box:snip%)]) - (send text insert snip) - (send text set-caret-owner snip 'global)))))]) - - (let ([item - (new c% - [label (string-constant insert-comment-box-menu-item-label)] - [parent edit-menu] - [callback (λ (x y) (insert-comment-box))] - [demand-callback on-demand])]) - (func item)) - (let ([item - (new c% - [label (string-constant insert-image-item)] - [parent edit-menu] - [callback (edit-menu:do 'insert-image)] - [demand-callback on-demand])]) - (func item)) - (void)))) - - (define frame-width 600) - (define frame-height 650) - (let ([window-trimming-upper-bound-width 20] - [window-trimming-upper-bound-height 50]) - (let-values ([(w h) (get-display-size)]) - (set! frame-width (min frame-width (- w window-trimming-upper-bound-width))) - (set! frame-height (min frame-height (- h window-trimming-upper-bound-height))))) - - (define basic<%> (interface ((class->interface frame%)) - get-area-container% - get-area-container - get-menu-bar% - make-root-area-container - close - editing-this-file? - get-filename - make-visible)) - (define basic-mixin - (mixin ((class->interface frame%)) (basic<%>) + (define (reorder-menus frame) + (define items (send (send frame get-menu-bar) get-items)) + (define (find-menu name) + (ormap (λ (i) (and (string=? (send i get-plain-label) name) i)) + items)) + (let* ([file-menu (find-menu (string-constant file-menu))] + [edit-menu (find-menu (string-constant edit-menu))] + [windows-menu (find-menu (string-constant windows-menu))] + [help-menu (find-menu (string-constant help-menu))] + [other-items + (remq* (list file-menu edit-menu windows-menu help-menu) items)] + [re-ordered (filter values `(,file-menu ,edit-menu + ,@other-items + ,windows-menu ,help-menu))]) + (for-each (λ (item) (send item delete)) items) + (for-each (λ (item) (send item restore)) re-ordered))) + + (define (remove-empty-menus frame) + (define menus (send (send frame get-menu-bar) get-items)) + (for-each (λ (menu) (send menu delete)) menus) + (for-each (λ (menu) + (when (pair? (send menu get-items)) (send menu restore))) + menus)) + + (define add-snip-menu-items + (opt-lambda (edit-menu c% [func void]) + (let* ([get-edit-target-object + (λ () + (let ([menu-bar + (let loop ([p (send edit-menu get-parent)]) + (cond + [(is-a? p menu-bar%) + p] + [(is-a? p menu%) + (loop (send p get-parent))] + [else #f]))]) + (and menu-bar + (let ([frame (send menu-bar get-frame)]) + (send frame get-edit-target-object)))))] + [edit-menu:do + (λ (const) + (λ (menu evt) + (let ([edit (get-edit-target-object)]) + (when (and edit + (is-a? edit editor<%>)) + (send edit do-edit-operation const))) + #t))] + [on-demand + (λ (menu-item) + (let ([edit (get-edit-target-object)]) + (send menu-item enable (and edit (is-a? edit editor<%>)))))] + [insert-comment-box + (λ () + (let ([text (get-edit-target-object)]) + (when text + (let ([snip (make-object comment-box:snip%)]) + (send text insert snip) + (send text set-caret-owner snip 'global)))))]) - (define/override (show on?) - (if on? - (send (group:get-the-frame-group) insert-frame this) - (send (group:get-the-frame-group) remove-frame this)) - (super show on?)) - - (define/override (can-exit?) - (and (exit:user-oks-exit) - (begin - (exit:set-exiting #t) - (let ([res (exit:can-exit?)]) - (unless res - (exit:set-exiting #f)) - res)))) - (define/override (on-exit) - (exit:on-exit) - (queue-callback - (λ () - (exit) - (exit:set-exiting #f)))) - - (define/public (make-visible filename) (void)) - (define/public get-filename - (case-lambda - [() (get-filename #f)] - [(b) #f])) - - (define/public (editing-this-file? filename) #f) - - (define/override (on-superwindow-show shown?) - (send (group:get-the-frame-group) frame-shown/hidden this) - (super on-superwindow-show shown?)) - - (define after-init? #f) - - (define/override on-drop-file - (λ (filename) - (handler:edit-file filename))) - - ;; added call to set label here to hopefully work around a problem in mac mred - (inherit set-label change-children) - (define/override after-new-child - (λ (child) - (when after-init? - (change-children (λ (l) (remq child l))) - (error 'frame:basic-mixin - "do not add children directly to a frame:basic (unless using make-root-area-container); use the get-area-container method instead" - )))) - - (define/public get-area-container% (λ () vertical-panel%)) - (define/public get-menu-bar% (λ () menu-bar%)) - (define/public make-root-area-container - (λ (% parent) - (make-object % parent))) - - (inherit can-close? on-close) - (define/public close - (λ () - (when (can-close?) - (on-close) - (show #f)))) - - (inherit accept-drop-files) - - (super-new) - - (accept-drop-files #t) - - (let ([mb (make-object (get-menu-bar%) this)]) - (when (or (eq? (system-type) 'macos) - (eq? (system-type) 'macosx)) - (make-object menu:can-restore-underscore-menu% (string-constant windows-menu-label) - mb))) - - (reorder-menus this) - - [define panel (make-root-area-container (get-area-container%) this)] - (define/public (get-area-container) panel) - (set! after-init? #t))) + (let ([item + (new c% + [label (string-constant insert-comment-box-menu-item-label)] + [parent edit-menu] + [callback (λ (x y) (insert-comment-box))] + [demand-callback on-demand])]) + (func item)) + (let ([item + (new c% + [label (string-constant insert-image-item)] + [parent edit-menu] + [callback (edit-menu:do 'insert-image)] + [demand-callback on-demand])]) + (func item)) + (void)))) + + (define frame-width 600) + (define frame-height 650) + (let ([window-trimming-upper-bound-width 20] + [window-trimming-upper-bound-height 50]) + (let-values ([(w h) (get-display-size)]) + (set! frame-width (min frame-width (- w window-trimming-upper-bound-width))) + (set! frame-height (min frame-height (- h window-trimming-upper-bound-height))))) + + (define basic<%> (interface ((class->interface frame%)) + get-area-container% + get-area-container + get-menu-bar% + make-root-area-container + close + editing-this-file? + get-filename + make-visible)) + (define basic-mixin + (mixin ((class->interface frame%)) (basic<%>) - (define size-pref<%> - (interface (basic<%>))) + (define/override (show on?) + (if on? + (send (group:get-the-frame-group) insert-frame this) + (send (group:get-the-frame-group) remove-frame this)) + (super show on?)) - (define size-pref-mixin - (mixin (basic<%>) (size-pref<%>) - (init-field size-preferences-key) - (define/override (on-size w h) - (preferences:set size-preferences-key (list w h))) - (let ([lst (preferences:get size-preferences-key)]) - (super-new [width (car lst)] [height (cadr lst)])))) - - (define (setup-size-pref size-preferences-key w h) - (preferences:set-default size-preferences-key - (list w h) - (λ (x) - (and (pair? x) - (pair? (cdr x)) - (null? (cddr x)) - (number? (car x)) - (number? (cadr x)))))) + (define/override (can-exit?) + (and (exit:user-oks-exit) + (begin + (exit:set-exiting #t) + (let ([res (exit:can-exit?)]) + (unless res + (exit:set-exiting #f)) + res)))) + (define/override (on-exit) + (exit:on-exit) + (queue-callback + (λ () + (exit) + (exit:set-exiting #f)))) - (define register-group<%> (interface ())) - (define register-group-mixin - (mixin (basic<%>) (register-group<%>) - - (define/augment (can-close?) - (let ([number-of-frames - (length (send (group:get-the-frame-group) - get-frames))]) - (and (inner #t can-close?) - (or (not (preferences:get 'framework:exit-when-no-frames)) - (exit:exiting?) - (not (= 1 number-of-frames)) - (exit:user-oks-exit))))) - (define/augment (on-close) - (send (group:get-the-frame-group) - remove-frame - this) - (inner (void) on-close) - (when (preferences:get 'framework:exit-when-no-frames) - (unless (exit:exiting?) - (when (null? (send (group:get-the-frame-group) get-frames)) - (exit:exit))))) - - (define/override (on-activate on?) - (super on-activate on?) - (when on? - (send (group:get-the-frame-group) set-active-frame this))) - - (super-new) - (send (group:get-the-frame-group) insert-frame this))) + (define/public (make-visible filename) (void)) + (define/public get-filename + (case-lambda + [() (get-filename #f)] + [(b) #f])) + (define/public (editing-this-file? filename) #f) + + (define/override (on-superwindow-show shown?) + (send (group:get-the-frame-group) frame-shown/hidden this) + (super on-superwindow-show shown?)) + + (define after-init? #f) + + (define/override on-drop-file + (λ (filename) + (handler:edit-file filename))) + + ;; added call to set label here to hopefully work around a problem in mac mred + (inherit set-label change-children) + (define/override after-new-child + (λ (child) + (when after-init? + (change-children (λ (l) (remq child l))) + (error 'frame:basic-mixin + "do not add children directly to a frame:basic (unless using make-root-area-container); use the get-area-container method instead" + )))) + + (define/public get-area-container% (λ () vertical-panel%)) + (define/public get-menu-bar% (λ () menu-bar%)) + (define/public make-root-area-container + (λ (% parent) + (make-object % parent))) + + (inherit can-close? on-close) + (define/public close + (λ () + (when (can-close?) + (on-close) + (show #f)))) + + (inherit accept-drop-files) + + (super-new) + + (accept-drop-files #t) + + (let ([mb (make-object (get-menu-bar%) this)]) + (when (or (eq? (system-type) 'macos) + (eq? (system-type) 'macosx)) + (make-object menu:can-restore-underscore-menu% (string-constant windows-menu-label) + mb))) + + (reorder-menus this) + + [define panel (make-root-area-container (get-area-container%) this)] + (define/public (get-area-container) panel) + (set! after-init? #t))) + + (define size-pref<%> + (interface (basic<%>))) + + (define size-pref-mixin + (mixin (basic<%>) (size-pref<%>) + (init-field size-preferences-key) + (define/override (on-size w h) + (preferences:set size-preferences-key (list w h))) + (let ([lst (preferences:get size-preferences-key)]) + (super-new [width (car lst)] [height (cadr lst)])))) + + (define (setup-size-pref size-preferences-key w h) + (preferences:set-default size-preferences-key + (list w h) + (λ (x) + (and (pair? x) + (pair? (cdr x)) + (null? (cddr x)) + (number? (car x)) + (number? (cadr x)))))) + + (define register-group<%> (interface ())) + (define register-group-mixin + (mixin (basic<%>) (register-group<%>) + + (define/augment (can-close?) + (let ([number-of-frames + (length (send (group:get-the-frame-group) + get-frames))]) + (and (inner #t can-close?) + (or (not (preferences:get 'framework:exit-when-no-frames)) + (exit:exiting?) + (not (= 1 number-of-frames)) + (exit:user-oks-exit))))) + (define/augment (on-close) + (send (group:get-the-frame-group) + remove-frame + this) + (inner (void) on-close) + (when (preferences:get 'framework:exit-when-no-frames) + (unless (exit:exiting?) + (when (null? (send (group:get-the-frame-group) get-frames)) + (exit:exit))))) + + (define/override (on-activate on?) + (super on-activate on?) + (when on? + (send (group:get-the-frame-group) set-active-frame this))) + + (super-new) + (send (group:get-the-frame-group) insert-frame this))) + (define locked-message-line1 (string-constant read-only-line1)) (define locked-message-line2 (string-constant read-only-line2)) (define unlocked-message-line1 (string-constant read/write-line1)) (define unlocked-message-line2 (string-constant read/write-line2)) - - (define lock-canvas% - (class canvas% - (field [locked? #f]) - (inherit refresh) - (define/public (set-locked l) - (set! locked? l) - (refresh)) - (inherit get-client-size get-dc) - (define/override (on-paint) - (let* ([dc (get-dc)] - [draw - (λ (str1 str2 bg-color bg-style line-color line-style) - (send dc set-font small-control-font) - (let-values ([(w h) (get-client-size)] - [(tw1 th1 _1 _2) (send dc get-text-extent str1)] - [(tw2 th2 _3 _4) (send dc get-text-extent str2)]) - (send dc set-pen (send the-pen-list find-or-create-pen line-color 1 line-style)) - (send dc set-brush (send the-brush-list find-or-create-brush bg-color bg-style)) - (send dc draw-rectangle 0 0 w h) - (cond - [(string=? str2 "") - (send dc draw-text str1 - (- (/ w 2) (/ tw1 2)) - (- (* h 1/2) (/ th1 2)))] - [else - (send dc draw-text str1 - (- (/ w 2) (/ tw1 2)) - (- (* h 1/2) th1)) - (send dc draw-text str2 - (- (/ w 2) (/ tw2 2)) - (* h 1/2))])))]) - (if locked? - (draw locked-message-line1 locked-message-line2 - "yellow" 'solid "black" 'solid) - (draw unlocked-message-line1 unlocked-message-line2 - (get-panel-background) 'transparent (get-panel-background) 'transparent)))) - (inherit get-parent min-width min-height stretchable-width stretchable-height) - - (super-new [style '(transparent)]) - - (let ([dc (get-dc)]) - (send dc set-font small-control-font) - (let-values ([(wl1 hl1 _1 _2) (send dc get-text-extent locked-message-line1)] - [(wl2 hl2 _3 _4) (send dc get-text-extent locked-message-line2)] - [(wu1 hu1 _5 _6) (send dc get-text-extent unlocked-message-line1)] - [(wu2 hu2 _7 _8) (send dc get-text-extent unlocked-message-line2)]) - (stretchable-width #f) - (stretchable-height #t) - (min-width (inexact->exact (floor (+ 2 (max (+ wl1 2) (+ wl2 2) wu1 wu2))))) - (min-height (inexact->exact (floor (+ 2 hu1 hu2)))))))) - (define status-line<%> - (interface (basic<%>) - open-status-line - close-status-line - update-status-line)) + (define lock-canvas% + (class canvas% + (field [locked? #f]) + (inherit refresh) + (define/public (set-locked l) + (set! locked? l) + (refresh)) + (inherit get-client-size get-dc) + (define/override (on-paint) + (let* ([dc (get-dc)] + [draw + (λ (str1 str2 bg-color bg-style line-color line-style) + (send dc set-font small-control-font) + (let-values ([(w h) (get-client-size)] + [(tw1 th1 _1 _2) (send dc get-text-extent str1)] + [(tw2 th2 _3 _4) (send dc get-text-extent str2)]) + (send dc set-pen (send the-pen-list find-or-create-pen line-color 1 line-style)) + (send dc set-brush (send the-brush-list find-or-create-brush bg-color bg-style)) + (send dc draw-rectangle 0 0 w h) + (cond + [(string=? str2 "") + (send dc draw-text str1 + (- (/ w 2) (/ tw1 2)) + (- (* h 1/2) (/ th1 2)))] + [else + (send dc draw-text str1 + (- (/ w 2) (/ tw1 2)) + (- (* h 1/2) th1)) + (send dc draw-text str2 + (- (/ w 2) (/ tw2 2)) + (* h 1/2))])))]) + (if locked? + (draw locked-message-line1 locked-message-line2 + "yellow" 'solid "black" 'solid) + (draw unlocked-message-line1 unlocked-message-line2 + (get-panel-background) 'transparent (get-panel-background) 'transparent)))) + (inherit get-parent min-width min-height stretchable-width stretchable-height) - ;; status-line : (make-status-line symbol number) - (define-struct status-line (id count)) + (super-new [style '(transparent)]) - ;; status-line-msg : (make-status-line-msg (is-a?/c message%) (union symbol #f)) - (define-struct status-line-msg (message id)) + (let ([dc (get-dc)]) + (send dc set-font small-control-font) + (let-values ([(wl1 hl1 _1 _2) (send dc get-text-extent locked-message-line1)] + [(wl2 hl2 _3 _4) (send dc get-text-extent locked-message-line2)] + [(wu1 hu1 _5 _6) (send dc get-text-extent unlocked-message-line1)] + [(wu2 hu2 _7 _8) (send dc get-text-extent unlocked-message-line2)]) + (stretchable-width #f) + (stretchable-height #t) + (min-width (inexact->exact (floor (+ 2 (max (+ wl1 2) (+ wl2 2) wu1 wu2))))) + (min-height (inexact->exact (floor (+ 2 hu1 hu2)))))))) + + (define status-line<%> + (interface (basic<%>) + open-status-line + close-status-line + update-status-line)) + + ;; status-line : (make-status-line symbol number) + (define-struct status-line (id count)) + + ;; status-line-msg : (make-status-line-msg (is-a?/c message%) (union symbol #f)) + (define-struct status-line-msg (message id)) + + (define status-line-mixin + (mixin (basic<%>) (status-line<%>) + (field [status-line-container-panel #f] + + ;; status-lines : (listof status-line) + [status-lines null] + + ;; status-line-msgs : (listof status-line-msg) + [status-line-msgs null]) + (define/override (make-root-area-container % parent) + (let* ([s-root (super make-root-area-container vertical-panel% parent)] + [r-root (make-object % s-root)]) + (set! status-line-container-panel + (instantiate vertical-panel% () + (parent s-root) + (stretchable-height #f))) + r-root)) + (define/public (open-status-line id) + (do-main-thread + (λ () + (when status-line-container-panel + (set! status-lines + (let loop ([status-lines status-lines]) + (cond + [(null? status-lines) + (list (make-status-line id 1))] + [else (let ([status-line (car status-lines)]) + (if (eq? id (status-line-id status-line)) + (cons (make-status-line id (+ (status-line-count status-line) 1)) + (cdr status-lines)) + (cons status-line (loop (cdr status-lines)))))]))))))) - (define status-line-mixin - (mixin (basic<%>) (status-line<%>) - (field [status-line-container-panel #f] - - ;; status-lines : (listof status-line) - [status-lines null] - - ;; status-line-msgs : (listof status-line-msg) - [status-line-msgs null]) - (define/override (make-root-area-container % parent) - (let* ([s-root (super make-root-area-container vertical-panel% parent)] - [r-root (make-object % s-root)]) - (set! status-line-container-panel - (instantiate vertical-panel% () - (parent s-root) - (stretchable-height #f))) - r-root)) - (define/public (open-status-line id) - (do-main-thread - (λ () - (when status-line-container-panel - (set! status-lines - (let loop ([status-lines status-lines]) - (cond - [(null? status-lines) - (list (make-status-line id 1))] - [else (let ([status-line (car status-lines)]) - (if (eq? id (status-line-id status-line)) - (cons (make-status-line id (+ (status-line-count status-line) 1)) - (cdr status-lines)) - (cons status-line (loop (cdr status-lines)))))]))))))) - - (define/public (close-status-line id) - (do-main-thread - (λ () - (when status-line-container-panel - - ;; decrement counter in for status line, or remove it if - ;; counter goes to zero. - (set! status-lines - (let loop ([status-lines status-lines]) - (cond - [(null? status-lines) (error 'close-status-line "status line not open ~e" id)] - [else (let* ([status-line (car status-lines)] - [this-line? (eq? (status-line-id status-line) id)]) - (cond - [(and this-line? (= 1 (status-line-count status-line))) - (cdr status-lines)] - [this-line? - (cons (make-status-line id (- (status-line-count status-line) 1)) - (cdr status-lines))] - [else (cons status-line (loop (cdr status-lines)))]))]))) - - ;; make sure that there are only as many messages as different status lines, in total - (let ([status-line-msg (find-status-line-msg id)]) - (when status-line-msg - (send (status-line-msg-message status-line-msg) set-label "") - (set-status-line-msg-id! status-line-msg #f))) - (let* ([msgs-that-can-be-removed (filter (λ (x) (not (status-line-msg-id x))) status-line-msgs)] - [max-to-include (length status-lines)] - [msgs-to-remove - (let loop ([n max-to-include] - [l msgs-that-can-be-removed]) - (cond - [(null? l) l] - [(zero? n) l] - [else (loop (- n 1) (cdr l))]))]) - (send status-line-container-panel - change-children - (λ (old-children) - (foldl (λ (status-line-msg l) - (remq (status-line-msg-message status-line-msg) l)) - old-children - msgs-to-remove))) - (set! status-line-msgs - (let loop ([l msgs-to-remove] - [status-line-msgs status-line-msgs]) - (cond - [(null? l) status-line-msgs] - [else (loop (cdr l) - (remq (car l) status-line-msgs))])))))))) - - ;; update-status-line : symbol (union #f string) - (define/public (update-status-line id msg-txt) - (do-main-thread - (λ () - (unless (open-status-line? id) - (error 'update-status-line "unknown id ~e, other arg ~e" id msg-txt)) - (if msg-txt - (cond - [(find-status-line-msg id) - => - (λ (existing-status-line-msg) - (let ([msg (status-line-msg-message existing-status-line-msg)]) - (unless (equal? (send msg get-label) msg-txt) - (send msg set-label msg-txt))))] - [(find-available-status-line-msg) - => - (λ (available-status-line-msg) - (send (status-line-msg-message available-status-line-msg) set-label msg-txt) - (set-status-line-msg-id! available-status-line-msg id))] - [else - (set! status-line-msgs - (cons (make-new-status-line-msg id msg-txt) - status-line-msgs))]) - (let ([status-line-msg (find-status-line-msg id)]) - (when status-line-msg - (send (status-line-msg-message status-line-msg) set-label "") - (set-status-line-msg-id! status-line-msg #f))))))) - - ;; open-status-line? : symbol -> boolean - (define/private (open-status-line? id) - (let loop ([status-lines status-lines]) - (cond - [(null? status-lines) #f] - [else - (let ([status-line (car status-lines)]) - (or (eq? (status-line-id status-line) id) - (loop (cdr status-lines))))]))) - - ;; find-available-status-line-msg : -> (union #f status-line-msg) - (define/private (find-available-status-line-msg) - (let loop ([status-line-msgs status-line-msgs]) - (cond - [(null? status-line-msgs) #f] - [else (let ([status-line-msg (car status-line-msgs)]) - (if (status-line-msg-id status-line-msg) - (loop (cdr status-line-msgs)) - status-line-msg))]))) - - ;; find-status-line-msg : symbol -> (union #f status-line-msg) - (define/private (find-status-line-msg id) - (let loop ([status-line-msgs status-line-msgs]) - (cond - [(null? status-line-msgs) #f] - [else (let ([status-line-msg (car status-line-msgs)]) - (if (eq? id (status-line-msg-id status-line-msg)) - status-line-msg - (loop (cdr status-line-msgs))))]))) - - ;; make-new-status-line-msg : symbol string -> status-line-msg - (define/private (make-new-status-line-msg id msg-txt) - (make-status-line-msg - (instantiate message% () - (parent status-line-container-panel) - (stretchable-width #t) - (label msg-txt)) - id)) - - (field [eventspace-main-thread (current-thread)]) ;; replace by using new primitive in 203.5 called eventspace-main-thread - (inherit get-eventspace) - (define/private (do-main-thread t) - (if (eq? (current-thread) eventspace-main-thread) - (t) - (parameterize ([current-eventspace (get-eventspace)]) - ;; need high priority callbacks to ensure ordering wrt other callbacks - (queue-callback t #t)))) - - (super-instantiate ()))) + (define/public (close-status-line id) + (do-main-thread + (λ () + (when status-line-container-panel + + ;; decrement counter in for status line, or remove it if + ;; counter goes to zero. + (set! status-lines + (let loop ([status-lines status-lines]) + (cond + [(null? status-lines) (error 'close-status-line "status line not open ~e" id)] + [else (let* ([status-line (car status-lines)] + [this-line? (eq? (status-line-id status-line) id)]) + (cond + [(and this-line? (= 1 (status-line-count status-line))) + (cdr status-lines)] + [this-line? + (cons (make-status-line id (- (status-line-count status-line) 1)) + (cdr status-lines))] + [else (cons status-line (loop (cdr status-lines)))]))]))) + + ;; make sure that there are only as many messages as different status lines, in total + (let ([status-line-msg (find-status-line-msg id)]) + (when status-line-msg + (send (status-line-msg-message status-line-msg) set-label "") + (set-status-line-msg-id! status-line-msg #f))) + (let* ([msgs-that-can-be-removed (filter (λ (x) (not (status-line-msg-id x))) status-line-msgs)] + [max-to-include (length status-lines)] + [msgs-to-remove + (let loop ([n max-to-include] + [l msgs-that-can-be-removed]) + (cond + [(null? l) l] + [(zero? n) l] + [else (loop (- n 1) (cdr l))]))]) + (send status-line-container-panel + change-children + (λ (old-children) + (foldl (λ (status-line-msg l) + (remq (status-line-msg-message status-line-msg) l)) + old-children + msgs-to-remove))) + (set! status-line-msgs + (let loop ([l msgs-to-remove] + [status-line-msgs status-line-msgs]) + (cond + [(null? l) status-line-msgs] + [else (loop (cdr l) + (remq (car l) status-line-msgs))])))))))) - (define info<%> (interface (basic<%>) - determine-width - lock-status-changed - update-info - set-info-canvas - get-info-canvas - get-info-editor - get-info-panel - show-info - hide-info - is-info-hidden?)) - - (define magic-space 25) - - (define info-mixin - (mixin (basic<%>) (info<%>) - [define rest-panel 'uninitialized-root] - [define super-root 'uninitialized-super-root] - (define/override (make-root-area-container % parent) - (let* ([s-root (super make-root-area-container - vertical-panel% - parent)] - [r-root (make-object % s-root)]) - (set! super-root s-root) - (set! rest-panel r-root) - r-root)) - - (define info-canvas #f) - (define/public (get-info-canvas) info-canvas) - (define/public (set-info-canvas c) (set! info-canvas c)) - (define/public (get-info-editor) - (and info-canvas - (send info-canvas get-editor))) - - (define/public (determine-width string canvas edit) - (send edit set-autowrap-bitmap #f) - (send canvas call-as-primary-owner - (λ () - (let ([lb (box 0)] - [rb (box 0)]) - (send edit erase) - (send edit insert string) - (send edit position-location - (send edit last-position) - rb) - (send edit position-location 0 lb) - (send canvas min-width - (+ (get-client-width/view-delta edit canvas) - (- (inexact->exact (floor (unbox rb))) - (inexact->exact (floor (unbox lb)))))))))) - - (define outer-info-panel 'top-info-panel-uninitialized) - - ;; this flag is specific to this frame - ;; the true state of the info panel is - ;; the combination of this flag and the - ;; the 'framework:show-status-line preference - ;; as shown in update-info-visibility - (define info-hidden? #f) - (define/public (hide-info) - (set! info-hidden? #t) - (update-info-visibility (preferences:get 'framework:show-status-line))) - (define/public (show-info) - (set! info-hidden? #f) - (update-info-visibility (preferences:get 'framework:show-status-line))) - (define/public (is-info-hidden?) info-hidden?) - (define/private (update-info-visibility pref-value) - (cond - [(or info-hidden? (not pref-value)) - (send super-root change-children - (λ (l) - (if (memq outer-info-panel l) - (begin (unregister-collecting-blit gc-canvas) - (list rest-panel)) - l)))] - [else - (send super-root change-children - (λ (l) - (if (memq outer-info-panel l) - l - (begin - (register-gc-blit) - (list rest-panel outer-info-panel)))))])) - - [define close-panel-callback - (preferences:add-callback - 'framework:show-status-line - (λ (p v) - (update-info-visibility v)))] - (define memory-cleanup void) ;; only for checkouts and nightly build users; used with memory-text - - (define/augment (on-close) - (unregister-collecting-blit gc-canvas) - (close-panel-callback) - (memory-cleanup) - (inner (void) on-close)) - - (define icon-currently-locked? 'uninit) - (define/public (lock-status-changed) - (let ([info-edit (get-info-editor)]) - (cond - [(not (object? lock-canvas)) - (void)] - [(is-a? info-edit editor:file<%>) - (unless (send lock-canvas is-shown?) - (send lock-canvas show #t)) - (let ([locked-now? (not (send info-edit get-read-write?))]) - (unless (eq? locked-now? icon-currently-locked?) - (set! icon-currently-locked? locked-now?) - (when (object? lock-canvas) - (send lock-canvas set-locked locked-now?))))] - [else - (when (send lock-canvas is-shown?) - (send lock-canvas show #f))]))) - - (define/public (update-info) (lock-status-changed)) - - (super-new) - (set! outer-info-panel (make-object horizontal-panel% super-root)) - (send outer-info-panel stretchable-height #f) - - (define info-panel (new horizontal-panel% [parent outer-info-panel])) - (new grow-box-spacer-pane% [parent outer-info-panel]) - - (define/public (get-info-panel) info-panel) - (define/public (update-memory-text) - (when (and show-memory-text? - memory-canvas) - (send memory-text begin-edit-sequence) - (send memory-text lock #f) - (send memory-text erase) - (send memory-text insert (format-number (current-memory-use))) - (ensure-enough-width memory-canvas memory-text) - (send memory-text lock #t) - (send memory-text end-edit-sequence))) - - (define/private (format-number n) - (let* ([mbytes (/ n 1024 1024)] - [before-decimal (floor mbytes)] - [after-decimal (modulo (floor (* mbytes 100)) 100)]) - (string-append - (number->string before-decimal) - "." + ;; update-status-line : symbol (union #f string) + (define/public (update-status-line id msg-txt) + (do-main-thread + (λ () + (unless (open-status-line? id) + (error 'update-status-line "unknown id ~e, other arg ~e" id msg-txt)) + (if msg-txt (cond - [(<= after-decimal 9) (format "0~a" after-decimal)] - [else (number->string after-decimal)])))) - - (define/private (pad-to-3 n) - (cond - [(<= n 9) (format "00~a" n)] - [(<= n 99) (format "0~a" n)] - [else (number->string n)])) - - ; only for checkouts and nightly build users - (when show-memory-text? - (let* ([panel (new horizontal-panel% - [parent (get-info-panel)] - [style '(border)] - [stretchable-width #f] - [stretchable-height #f])] - [button (new button% - [label (string-constant collect-button-label)] - [parent panel] - [callback - (λ x - (collect-garbage) - (update-memory-text))])] - [ec (new editor-canvas% - [parent panel] - [editor memory-text] - [line-count 1] - [style '(no-hscroll no-vscroll)])]) - (set! memory-canvas ec) - (determine-width "99.99" ec memory-text) - (update-memory-text) - (set! memory-cleanup - (λ () - (send ec set-editor #f))) - (send panel stretchable-width #f))) - - [define lock-canvas (make-object lock-canvas% (get-info-panel))] - [define gc-canvas (make-object bday-click-canvas% (get-info-panel) '(border))] - (define/private (register-gc-blit) - (let ([onb (icon:get-gc-on-bitmap)] - [offb (icon:get-gc-off-bitmap)]) - (when (and (send onb ok?) - (send offb ok?)) - (register-collecting-blit gc-canvas - 0 0 - (send onb get-width) - (send onb get-height) - onb offb)))) - - (unless (preferences:get 'framework:show-status-line) - (send super-root change-children - (λ (l) - (list rest-panel)))) - (register-gc-blit) - - (let* ([gcb (icon:get-gc-on-bitmap)] - [gc-width (if (send gcb ok?) - (send gcb get-width) - 10)] - [gc-height (if (send gcb ok?) - (send gcb get-height) - 10)]) - (send* gc-canvas - (min-client-width (max (send gc-canvas min-width) gc-width)) - (min-client-height (max (send gc-canvas min-height) gc-height)) - (stretchable-width #f) - (stretchable-height #f))) - (send* (get-info-panel) - (set-alignment 'right 'center) - (stretchable-height #f) - (spacing 3) - (border 3)))) + [(find-status-line-msg id) + => + (λ (existing-status-line-msg) + (let ([msg (status-line-msg-message existing-status-line-msg)]) + (unless (equal? (send msg get-label) msg-txt) + (send msg set-label msg-txt))))] + [(find-available-status-line-msg) + => + (λ (available-status-line-msg) + (send (status-line-msg-message available-status-line-msg) set-label msg-txt) + (set-status-line-msg-id! available-status-line-msg id))] + [else + (set! status-line-msgs + (cons (make-new-status-line-msg id msg-txt) + status-line-msgs))]) + (let ([status-line-msg (find-status-line-msg id)]) + (when status-line-msg + (send (status-line-msg-message status-line-msg) set-label "") + (set-status-line-msg-id! status-line-msg #f))))))) + ;; open-status-line? : symbol -> boolean + (define/private (open-status-line? id) + (let loop ([status-lines status-lines]) + (cond + [(null? status-lines) #f] + [else + (let ([status-line (car status-lines)]) + (or (eq? (status-line-id status-line) id) + (loop (cdr status-lines))))]))) + + ;; find-available-status-line-msg : -> (union #f status-line-msg) + (define/private (find-available-status-line-msg) + (let loop ([status-line-msgs status-line-msgs]) + (cond + [(null? status-line-msgs) #f] + [else (let ([status-line-msg (car status-line-msgs)]) + (if (status-line-msg-id status-line-msg) + (loop (cdr status-line-msgs)) + status-line-msg))]))) + + ;; find-status-line-msg : symbol -> (union #f status-line-msg) + (define/private (find-status-line-msg id) + (let loop ([status-line-msgs status-line-msgs]) + (cond + [(null? status-line-msgs) #f] + [else (let ([status-line-msg (car status-line-msgs)]) + (if (eq? id (status-line-msg-id status-line-msg)) + status-line-msg + (loop (cdr status-line-msgs))))]))) + + ;; make-new-status-line-msg : symbol string -> status-line-msg + (define/private (make-new-status-line-msg id msg-txt) + (make-status-line-msg + (instantiate message% () + (parent status-line-container-panel) + (stretchable-width #t) + (label msg-txt)) + id)) + + (field [eventspace-main-thread (current-thread)]) ;; replace by using new primitive in 203.5 called eventspace-main-thread + (inherit get-eventspace) + (define/private (do-main-thread t) + (if (eq? (current-thread) eventspace-main-thread) + (t) + (parameterize ([current-eventspace (get-eventspace)]) + ;; need high priority callbacks to ensure ordering wrt other callbacks + (queue-callback t #t)))) + + (super-instantiate ()))) + + (define info<%> (interface (basic<%>) + determine-width + lock-status-changed + update-info + set-info-canvas + get-info-canvas + get-info-editor + get-info-panel + show-info + hide-info + is-info-hidden?)) + + (define magic-space 25) + + (define info-mixin + (mixin (basic<%>) (info<%>) + [define rest-panel 'uninitialized-root] + [define super-root 'uninitialized-super-root] + (define/override (make-root-area-container % parent) + (let* ([s-root (super make-root-area-container + vertical-panel% + parent)] + [r-root (make-object % s-root)]) + (set! super-root s-root) + (set! rest-panel r-root) + r-root)) + + (define info-canvas #f) + (define/public (get-info-canvas) info-canvas) + (define/public (set-info-canvas c) (set! info-canvas c)) + (define/public (get-info-editor) + (and info-canvas + (send info-canvas get-editor))) + + (define/public (determine-width string canvas edit) + (send edit set-autowrap-bitmap #f) + (send canvas call-as-primary-owner + (λ () + (let ([lb (box 0)] + [rb (box 0)]) + (send edit erase) + (send edit insert string) + (send edit position-location + (send edit last-position) + rb) + (send edit position-location 0 lb) + (send canvas min-width + (+ (get-client-width/view-delta edit canvas) + (- (inexact->exact (floor (unbox rb))) + (inexact->exact (floor (unbox lb)))))))))) + + (define outer-info-panel 'top-info-panel-uninitialized) + + ;; this flag is specific to this frame + ;; the true state of the info panel is + ;; the combination of this flag and the + ;; the 'framework:show-status-line preference + ;; as shown in update-info-visibility + (define info-hidden? #f) + (define/public (hide-info) + (set! info-hidden? #t) + (update-info-visibility (preferences:get 'framework:show-status-line))) + (define/public (show-info) + (set! info-hidden? #f) + (update-info-visibility (preferences:get 'framework:show-status-line))) + (define/public (is-info-hidden?) info-hidden?) + (define/private (update-info-visibility pref-value) + (cond + [(or info-hidden? (not pref-value)) + (send super-root change-children + (λ (l) + (if (memq outer-info-panel l) + (begin (unregister-collecting-blit gc-canvas) + (list rest-panel)) + l)))] + [else + (send super-root change-children + (λ (l) + (if (memq outer-info-panel l) + l + (begin + (register-gc-blit) + (list rest-panel outer-info-panel)))))])) + + [define close-panel-callback + (preferences:add-callback + 'framework:show-status-line + (λ (p v) + (update-info-visibility v)))] + (define memory-cleanup void) ;; only for checkouts and nightly build users; used with memory-text + + (define/augment (on-close) + (unregister-collecting-blit gc-canvas) + (close-panel-callback) + (memory-cleanup) + (inner (void) on-close)) + + (define icon-currently-locked? 'uninit) + (define/public (lock-status-changed) + (let ([info-edit (get-info-editor)]) + (cond + [(not (object? lock-canvas)) + (void)] + [(is-a? info-edit editor:file<%>) + (unless (send lock-canvas is-shown?) + (send lock-canvas show #t)) + (let ([locked-now? (not (send info-edit get-read-write?))]) + (unless (eq? locked-now? icon-currently-locked?) + (set! icon-currently-locked? locked-now?) + (when (object? lock-canvas) + (send lock-canvas set-locked locked-now?))))] + [else + (when (send lock-canvas is-shown?) + (send lock-canvas show #f))]))) + + (define/public (update-info) (lock-status-changed)) + + (super-new) + (set! outer-info-panel (make-object horizontal-panel% super-root)) + (send outer-info-panel stretchable-height #f) + + (define info-panel (new horizontal-panel% [parent outer-info-panel])) + (new grow-box-spacer-pane% [parent outer-info-panel]) + + (define/public (get-info-panel) info-panel) + (define/public (update-memory-text) + (when (and show-memory-text? + memory-canvas) + (send memory-text begin-edit-sequence) + (send memory-text lock #f) + (send memory-text erase) + (send memory-text insert (format-number (current-memory-use))) + (ensure-enough-width memory-canvas memory-text) + (send memory-text lock #t) + (send memory-text end-edit-sequence))) + + (define/private (format-number n) + (let* ([mbytes (/ n 1024 1024)] + [before-decimal (floor mbytes)] + [after-decimal (modulo (floor (* mbytes 100)) 100)]) + (string-append + (number->string before-decimal) + "." + (cond + [(<= after-decimal 9) (format "0~a" after-decimal)] + [else (number->string after-decimal)])))) + + (define/private (pad-to-3 n) + (cond + [(<= n 9) (format "00~a" n)] + [(<= n 99) (format "0~a" n)] + [else (number->string n)])) + + ; only for checkouts and nightly build users + (when show-memory-text? + (let* ([panel (new horizontal-panel% + [parent (get-info-panel)] + [style '(border)] + [stretchable-width #f] + [stretchable-height #f])] + [button (new button% + [label (string-constant collect-button-label)] + [parent panel] + [callback + (λ x + (collect-garbage) + (update-memory-text))])] + [ec (new editor-canvas% + [parent panel] + [editor memory-text] + [line-count 1] + [style '(no-hscroll no-vscroll)])]) + (set! memory-canvas ec) + (determine-width "99.99" ec memory-text) + (update-memory-text) + (set! memory-cleanup + (λ () + (send ec set-editor #f))) + (send panel stretchable-width #f))) + + [define lock-canvas (make-object lock-canvas% (get-info-panel))] + [define gc-canvas (make-object bday-click-canvas% (get-info-panel) '(border))] + (define/private (register-gc-blit) + (let ([onb (icon:get-gc-on-bitmap)] + [offb (icon:get-gc-off-bitmap)]) + (when (and (send onb ok?) + (send offb ok?)) + (register-collecting-blit gc-canvas + 0 0 + (send onb get-width) + (send onb get-height) + onb offb)))) + + (unless (preferences:get 'framework:show-status-line) + (send super-root change-children + (λ (l) + (list rest-panel)))) + (register-gc-blit) + + (let* ([gcb (icon:get-gc-on-bitmap)] + [gc-width (if (send gcb ok?) + (send gcb get-width) + 10)] + [gc-height (if (send gcb ok?) + (send gcb get-height) + 10)]) + (send* gc-canvas + (min-client-width (max (send gc-canvas min-width) gc-width)) + (min-client-height (max (send gc-canvas min-height) gc-height)) + (stretchable-width #f) + (stretchable-height #f))) + (send* (get-info-panel) + (set-alignment 'right 'center) + (stretchable-height #f) + (spacing 3) + (border 3)))) + (define (ensure-enough-width editor-canvas text) (send editor-canvas call-as-primary-owner (λ () @@ -736,1739 +736,1739 @@ overwrite-status-changed anchor-status-changed editor-position-changed)) - (define text-info-mixin - (mixin (info<%>) (text-info<%>) - (inherit get-info-editor) - (define remove-first - (preferences:add-callback - 'framework:col-offsets - (λ (p v) - (editor-position-changed-offset/numbers - v - (preferences:get 'framework:display-line-numbers)) - #t))) - (define remove-second - (preferences:add-callback - 'framework:display-line-numbers - (λ (p v) - (editor-position-changed-offset/numbers - (preferences:get 'framework:col-offsets) - v) - #t))) - (define/augment (on-close) - (remove-first) - (remove-second) - (inner (void) on-close)) - [define last-start #f] - [define last-end #f] - [define last-params #f] - (define/private (editor-position-changed-offset/numbers offset? line-numbers?) - (let* ([edit (get-info-editor)] - [make-one - (λ (pos) - (let* ([line (send edit position-paragraph pos)] - [col (find-col edit line pos)]) - (if line-numbers? - (format "~a:~a" - (add1 line) - (if offset? - (add1 col) - col)) - (format "~a" pos))))]) - (cond - [(not (object? position-canvas)) - (void)] - [edit - (unless (send position-canvas is-shown?) - (send position-canvas show #t)) - (let ([start (send edit get-start-position)] - [end (send edit get-end-position)]) - (unless (and last-start - (equal? last-params (list offset? line-numbers?)) - (= last-start start) - (= last-end end)) - (set! last-params (list offset? line-numbers?)) - (set! last-start start) - (set! last-end end) - (when (object? position-edit) - (change-position-edit-contents - (if (= start end) - (make-one start) - (string-append (make-one start) - "-" - (make-one end)))))))] - [else - (when (send position-canvas is-shown?) - (send position-canvas show #f))]))) - - ;; find-col : text number number -> number - ;; given a line number and a position, finds the - ;; column number for that position - (define/private (find-col text line pos) - (let ([line-start (send text paragraph-start-position line)]) - (if (= line-start pos) - 0 - (let loop ([col 0] - [snip (send text find-snip line-start 'after-or-none)]) - (cond - [(and snip (is-a? snip tab-snip%)) - ;; assume cursor isn't in the middle of the tab snip - ;; and that there is no tab array - (let ([twb (box 0)]) - (send text get-tabs #f twb #f) - (let ([tw (floor (inexact->exact (unbox twb)))]) - (loop (+ col (- tw (modulo col tw))) - (send snip next))))] - [snip - (let ([snip-position (send text get-snip-position snip)] - [snip-length (send snip get-count)]) - (if (<= snip-position pos (+ snip-position snip-length)) - (+ col (- pos snip-position)) - (loop (+ col snip-length) - (send snip next))))] - [else - col]))))) - - - [define anchor-last-state? #f] - [define overwrite-last-state? #f] - - (field (macro-recording? #f)) - (define/private (update-macro-recording-icon) - (unless (eq? (send macro-recording-message is-shown?) - macro-recording?) - (send macro-recording-message show macro-recording?))) - (define/public (set-macro-recording on?) - (set! macro-recording? on?) - (update-macro-recording-icon)) - - (define/public (anchor-status-changed) - (let ([info-edit (get-info-editor)] - [failed - (λ () - (unless (eq? anchor-last-state? #f) - (set! anchor-last-state? #f) - (send anchor-message show #f)))]) - (cond - [info-edit - (let ([anchor-now? (send info-edit get-anchor)]) - (unless (eq? anchor-now? anchor-last-state?) - (cond - [(object? anchor-message) - (send anchor-message - show - anchor-now?) - (set! anchor-last-state? anchor-now?)] - [else (failed)])))] - [else - (failed)]))) - (define/public (editor-position-changed) - (editor-position-changed-offset/numbers - (preferences:get 'framework:col-offsets) - (preferences:get 'framework:display-line-numbers))) - [define/public overwrite-status-changed - (λ () - (let ([info-edit (get-info-editor)] - [failed - (λ () - (set! overwrite-last-state? #f) - (send overwrite-message show #f))]) + (define text-info-mixin + (mixin (info<%>) (text-info<%>) + (inherit get-info-editor) + (define remove-first + (preferences:add-callback + 'framework:col-offsets + (λ (p v) + (editor-position-changed-offset/numbers + v + (preferences:get 'framework:display-line-numbers)) + #t))) + (define remove-second + (preferences:add-callback + 'framework:display-line-numbers + (λ (p v) + (editor-position-changed-offset/numbers + (preferences:get 'framework:col-offsets) + v) + #t))) + (define/augment (on-close) + (remove-first) + (remove-second) + (inner (void) on-close)) + [define last-start #f] + [define last-end #f] + [define last-params #f] + (define/private (editor-position-changed-offset/numbers offset? line-numbers?) + (let* ([edit (get-info-editor)] + [make-one + (λ (pos) + (let* ([line (send edit position-paragraph pos)] + [col (find-col edit line pos)]) + (if line-numbers? + (format "~a:~a" + (add1 line) + (if offset? + (add1 col) + col)) + (format "~a" pos))))]) + (cond + [(not (object? position-canvas)) + (void)] + [edit + (unless (send position-canvas is-shown?) + (send position-canvas show #t)) + (let ([start (send edit get-start-position)] + [end (send edit get-end-position)]) + (unless (and last-start + (equal? last-params (list offset? line-numbers?)) + (= last-start start) + (= last-end end)) + (set! last-params (list offset? line-numbers?)) + (set! last-start start) + (set! last-end end) + (when (object? position-edit) + (change-position-edit-contents + (if (= start end) + (make-one start) + (string-append (make-one start) + "-" + (make-one end)))))))] + [else + (when (send position-canvas is-shown?) + (send position-canvas show #f))]))) + + ;; find-col : text number number -> number + ;; given a line number and a position, finds the + ;; column number for that position + (define/private (find-col text line pos) + (let ([line-start (send text paragraph-start-position line)]) + (if (= line-start pos) + 0 + (let loop ([col 0] + [snip (send text find-snip line-start 'after-or-none)]) + (cond + [(and snip (is-a? snip tab-snip%)) + ;; assume cursor isn't in the middle of the tab snip + ;; and that there is no tab array + (let ([twb (box 0)]) + (send text get-tabs #f twb #f) + (let ([tw (floor (inexact->exact (unbox twb)))]) + (loop (+ col (- tw (modulo col tw))) + (send snip next))))] + [snip + (let ([snip-position (send text get-snip-position snip)] + [snip-length (send snip get-count)]) + (if (<= snip-position pos (+ snip-position snip-length)) + (+ col (- pos snip-position)) + (loop (+ col snip-length) + (send snip next))))] + [else + col]))))) + + + [define anchor-last-state? #f] + [define overwrite-last-state? #f] + + (field (macro-recording? #f)) + (define/private (update-macro-recording-icon) + (unless (eq? (send macro-recording-message is-shown?) + macro-recording?) + (send macro-recording-message show macro-recording?))) + (define/public (set-macro-recording on?) + (set! macro-recording? on?) + (update-macro-recording-icon)) + + (define/public (anchor-status-changed) + (let ([info-edit (get-info-editor)] + [failed + (λ () + (unless (eq? anchor-last-state? #f) + (set! anchor-last-state? #f) + (send anchor-message show #f)))]) + (cond + [info-edit + (let ([anchor-now? (send info-edit get-anchor)]) + (unless (eq? anchor-now? anchor-last-state?) (cond - [info-edit - (let ([overwrite-now? (send info-edit get-overwrite-mode)]) - (unless (eq? overwrite-now? overwrite-last-state?) - (cond - [(object? overwrite-message) - (send overwrite-message - show - overwrite-now?) - (set! overwrite-last-state? overwrite-now?)] - [else - (failed)])))] - [else - (failed)])))] - (define/override (update-info) - (super update-info) - (update-macro-recording-icon) - (overwrite-status-changed) - (anchor-status-changed) - (editor-position-changed)) - (super-new) - - (inherit get-info-panel) - - (define position-parent (new click-pref-panel% - [border 2] - [parent (get-info-panel)] - [stretchable-width #f] - [stretchable-height #f])) - (define position-canvas (new editor-canvas% - [parent position-parent] - [style '(no-hscroll no-vscroll)])) - - (define position-edit (new text%)) - - (define/private (change-position-edit-contents str) - (send position-edit begin-edit-sequence) - (send position-edit lock #f) - (send position-edit erase) - (send position-edit insert str) - (ensure-enough-width position-canvas position-edit) - (send position-edit lock #t) - (send position-edit end-edit-sequence)) - + [(object? anchor-message) + (send anchor-message + show + anchor-now?) + (set! anchor-last-state? anchor-now?)] + [else (failed)])))] + [else + (failed)]))) + (define/public (editor-position-changed) + (editor-position-changed-offset/numbers + (preferences:get 'framework:col-offsets) + (preferences:get 'framework:display-line-numbers))) + [define/public overwrite-status-changed + (λ () + (let ([info-edit (get-info-editor)] + [failed + (λ () + (set! overwrite-last-state? #f) + (send overwrite-message show #f))]) + (cond + [info-edit + (let ([overwrite-now? (send info-edit get-overwrite-mode)]) + (unless (eq? overwrite-now? overwrite-last-state?) + (cond + [(object? overwrite-message) + (send overwrite-message + show + overwrite-now?) + (set! overwrite-last-state? overwrite-now?)] + [else + (failed)])))] + [else + (failed)])))] + (define/override (update-info) + (super update-info) + (update-macro-recording-icon) + (overwrite-status-changed) + (anchor-status-changed) + (editor-position-changed)) + (super-new) + + (inherit get-info-panel) + + (define position-parent (new click-pref-panel% + [border 2] + [parent (get-info-panel)] + [stretchable-width #f] + [stretchable-height #f])) + (define position-canvas (new editor-canvas% + [parent position-parent] + [style '(no-hscroll no-vscroll)])) + + (define position-edit (new text%)) + + (define/private (change-position-edit-contents str) + (send position-edit begin-edit-sequence) + (send position-edit lock #f) + (send position-edit erase) + (send position-edit insert str) + (ensure-enough-width position-canvas position-edit) + (send position-edit lock #t) + (send position-edit end-edit-sequence)) + + (send (get-info-panel) change-children + (λ (l) + (cons position-parent (remq position-parent l)))) + + + (define-values (anchor-message + overwrite-message + macro-recording-message) + (let* ([text-info-messages-parent + (new vertical-panel% + [parent (get-info-panel)] + [stretchable-width #f])] + [anchor-message + (new message% + [font small-control-font] + [label (string-constant auto-extend-selection)] + [parent text-info-messages-parent])] + [hp (new horizontal-panel% + [alignment '(left center)] + [parent text-info-messages-parent] + [stretchable-height #f])] + [overwrite-message + (new message% + [font small-control-font] + [label (string-constant overwrite)] + [parent hp])] + [macro-recording-message + (new message% + [label "c-x;("] + [font small-control-font] + [parent hp])]) (send (get-info-panel) change-children (λ (l) - (cons position-parent (remq position-parent l)))) - - - (define-values (anchor-message - overwrite-message - macro-recording-message) - (let* ([text-info-messages-parent - (new vertical-panel% - [parent (get-info-panel)] - [stretchable-width #f])] - [anchor-message - (new message% - [font small-control-font] - [label (string-constant auto-extend-selection)] - [parent text-info-messages-parent])] - [hp (new horizontal-panel% - [alignment '(left center)] - [parent text-info-messages-parent] - [stretchable-height #f])] - [overwrite-message - (new message% - [font small-control-font] - [label (string-constant overwrite)] - [parent hp])] - [macro-recording-message - (new message% - [label "c-x;("] - [font small-control-font] - [parent hp])]) - (send (get-info-panel) change-children - (λ (l) - (cons - text-info-messages-parent - (remq text-info-messages-parent l)))) - (values anchor-message - overwrite-message - macro-recording-message))) - - (inherit determine-width) - (send macro-recording-message show #f) - (send anchor-message show #f) - (send overwrite-message show #f) - (send* position-canvas - (set-line-count 1) - (set-editor position-edit) - (stretchable-width #f) - (stretchable-height #f)) - (determine-width "000:00-000:00" - position-canvas - position-edit) - (editor-position-changed) - (send position-edit hide-caret #t) - (send position-edit lock #t))) + (cons + text-info-messages-parent + (remq text-info-messages-parent l)))) + (values anchor-message + overwrite-message + macro-recording-message))) - (define click-pref-panel% - (class horizontal-panel% - (inherit popup-menu) - (define/override (on-subwindow-event receiver evt) - (cond - [(send evt button-down? 'right) - (let ([menu (new popup-menu%)] - [line-numbers? (preferences:get 'framework:display-line-numbers)]) - (new checkable-menu-item% - [parent menu] - [label (string-constant show-line-and-column-numbers)] - [callback (λ (x y) (preferences:set 'framework:display-line-numbers #t))] - [checked line-numbers?]) - (new checkable-menu-item% - [parent menu] - [label (string-constant show-character-offsets)] - [callback (λ (x y) (preferences:set 'framework:display-line-numbers #f))] - [checked (not line-numbers?)]) - (popup-menu menu - (+ 1 (send evt get-x)) - (+ 1 (send evt get-y)))) - #t] - [else - (super on-subwindow-event receiver evt)])) - (super-new))) - - (define pasteboard-info<%> (interface (info<%>))) - (define pasteboard-info-mixin - (mixin (basic<%>) (pasteboard-info<%>) - (super-instantiate ()))) - - (include "standard-menus.ss") - - (define -editor<%> (interface (standard-menus<%>) - get-entire-label - get-label-prefix - set-label-prefix - - get-canvas% - get-canvas<%> - get-editor% - get-editor<%> - - make-editor - revert - save - save-as - get-canvas - get-editor)) - - (define editor-mixin - (mixin (standard-menus<%>) (-editor<%>) - (init (filename #f)) - (init-field (editor% #f)) - - (inherit get-area-container get-client-size - show get-edit-target-window get-edit-target-object) - - (define/override get-filename - (case-lambda - [() (get-filename #f)] - [(b) - (let ([e (get-editor)]) - (and e (send e get-filename b)))])) - - (define/override (editing-this-file? filename) - (let ([path-equal? - (λ (x y) - (equal? (normal-case-path (normalize-path x)) - (normal-case-path (normalize-path y))))]) - (let ([this-fn (get-filename)]) - (and this-fn - (path-equal? filename (get-filename)))))) - - (define/augment (on-close) - (send (get-editor) on-close) - (inner (void) on-close)) - - (define/augment (can-close?) - (and (send (get-editor) can-close?) - (inner #t can-close?))) - - [define label ""] - [define label-prefix (application:current-app-name)] - (define/private (do-label) - (super set-label (gui-utils:trim-string (get-entire-label) 200)) - (send (group:get-the-frame-group) frame-label-changed this)) - - (public get-entire-label get-label-prefix set-label-prefix) - [define get-entire-label - (λ () - (cond - [(string=? "" label) - label-prefix] - [(string=? "" label-prefix) - label] - [else - (string-append label " - " label-prefix)]))] - [define get-label-prefix (λ () label-prefix)] - [define set-label-prefix - (λ (s) - (when (and (string? s) - (not (string=? s label-prefix))) - (set! label-prefix s) - (do-label)))] - [define/override get-label (λ () label)] - [define/override set-label - (λ (t) - (when (and (string? t) - (not (string=? t label))) - (set! label t) - (do-label)))] - - (define/public (get-canvas%) editor-canvas%) - (define/public (get-canvas<%>) (class->interface editor-canvas%)) - (define/public (make-canvas) - (let ([% (get-canvas%)] - [<%> (get-canvas<%>)]) - (unless (implementation? % <%>) - (error 'frame:editor% - "result of get-canvas% method must match ~e interface; got: ~e" - <%> %)) - (instantiate % () (parent (get-area-container))))) - (define/public (get-editor%) - (or editor% - (error 'editor-frame% "abstract method: no editor% class specified"))) - (define/public (get-editor<%>) - editor:basic<%>) - (define/public (make-editor) - (let ([% (get-editor%)] - [<%> (get-editor<%>)]) - (unless (implementation? % <%>) - (error 'frame:editor% - "result of get-editor% method must match ~e interface; got: ~e" - <%> %)) - (make-object %))) - - (define/public save - (opt-lambda ([format 'same]) - (let* ([ed (get-editor)] - [filename (send ed get-filename)]) - (if filename - (send ed save-file/gui-error filename format) - (save-as format))))) - - (define/public save-as - (opt-lambda ([format 'same]) - (let* ([editor (get-editor)] - [name (send editor get-filename)]) - (let-values ([(base name) - (if name - (let-values ([(base name dir?) (split-path name)]) - (values base name)) - (values #f #f))]) - (let ([file (send editor put-file base name)]) - (if file - (send editor save-file/gui-error file format) - #f)))))) - - (define/private (basename str) - (let-values ([(base name dir?) (split-path str)]) - base)) - - (inherit get-checkable-menu-item% get-menu-item%) - - (define/override (file-menu:revert-on-demand item) - (send item enable (not (send (get-editor) is-locked?)))) - - (define/override file-menu:revert-callback - (λ (item control) - (let* ([edit (get-editor)] - [b (box #f)] - [filename (send edit get-filename b)]) - (if (or (not filename) - (unbox b)) - (bell) - (when (or (not (send (get-editor) is-modified?)) - (gui-utils:get-choice - (string-constant are-you-sure-revert) - (string-constant yes) - (string-constant no) - (string-constant are-you-sure-revert-title) - #f - this)) - (revert)))) - #t)) - - (define/public (revert) - (let* ([edit (get-editor)] - [b (box #f)] - [filename (send edit get-filename b)]) - (when (and filename - (not (unbox b))) - (let ([start - (if (is-a? edit text%) - (send edit get-start-position) - #f)]) - (send edit begin-edit-sequence) - (let ([status (send edit load-file/gui-error - filename - 'guess - #f)]) - (if status - (begin - (when (is-a? edit text%) - (send edit set-position start start)) - (send edit end-edit-sequence)) - (send edit end-edit-sequence))))))) - - (define/override file-menu:create-revert? (λ () #t)) - (define/override file-menu:save-callback - (λ (item control) - (save) - #t)) - - (define/override file-menu:create-save? (λ () #t)) - (define/override file-menu:save-as-callback (λ (item control) (save-as) #t)) - (define/override file-menu:create-save-as? (λ () #t)) - (define/override file-menu:print-callback (λ (item control) - (send (get-editor) print - #t - #t - (preferences:get 'framework:print-output-mode)) - #t)) - (define/override file-menu:create-print? (λ () #t)) - - (inherit get-top-level-window) - (define/override (file-menu:between-save-as-and-print file-menu) - (when (can-get-page-setup-from-user?) - (new menu-item% - [parent file-menu] - [label (string-constant page-setup-menu-item)] - [help-string (string-constant page-setup-info)] - [callback - (lambda (item event) - (let ([s (get-page-setup-from-user #f (get-top-level-window))]) - (when s - (send (current-ps-setup) copy-from s))))]))) - - (define/override edit-menu:between-select-all-and-find - (λ (edit-menu) - (let* ([c% (get-checkable-menu-item%)] - [on-demand - (λ (menu-item) - (let ([edit (get-edit-target-object)]) - (if (and edit (is-a? edit editor<%>)) - (begin - (send menu-item enable #t) - (send menu-item check (send edit auto-wrap))) - (begin - (send menu-item check #f) - (send menu-item enable #f)))))] - [callback - (λ (item event) - (let ([edit (get-edit-target-object)]) - (when (and edit - (is-a? edit editor<%>)) - (let ([new-pref (not (send edit auto-wrap))]) - (preferences:set 'framework:auto-set-wrap? new-pref) - (send edit auto-wrap new-pref)))))]) - (make-object c% (string-constant wrap-text-item) - edit-menu callback #f #f on-demand)) - - (make-object separator-menu-item% edit-menu))) - - (define/override help-menu:about-callback - (λ (menu evt) - (message-box (application:current-app-name) - (format (string-constant welcome-to-something) - (application:current-app-name)) - #f - '(ok app)))) - (define/override help-menu:about-string (λ () (application:current-app-name))) - (define/override help-menu:create-about? (λ () #t)) - - (super-new (label (get-entire-label))) - - (define canvas #f) - (define editor #f) - (public get-canvas get-editor) - (define get-canvas - (λ () - (unless canvas - (set! canvas (make-canvas)) - (send canvas set-editor (get-editor))) - canvas)) - (define get-editor - (λ () - (unless editor - (set! editor (make-editor)) - (send (get-canvas) set-editor editor)) - editor)) - - (cond - [(and filename (file-exists? filename)) - (let ([ed (get-editor)]) - (send ed begin-edit-sequence) - (send ed load-file/gui-error filename 'guess) - (send ed end-edit-sequence))] - [filename - (send (get-editor) set-filename filename)] - [else (void)]) - - (let ([ed-fn (send (get-editor) get-filename)]) - (set! label (or (and ed-fn - (path->string (file-name-from-path ed-fn))) - (send (get-editor) get-filename/untitled-name)))) - (do-label) - (let ([canvas (get-canvas)]) - (when (is-a? canvas editor-canvas%) - ;; when get-canvas is overridden, - ;; it might not yet be implemented - (send canvas focus))))) - - (define open-here<%> - (interface (-editor<%>) - get-open-here-editor - open-here)) - - (define open-here-mixin - (mixin (-editor<%>) (open-here<%>) - - (define/override (file-menu:new-on-demand item) - (super file-menu:new-on-demand item) - (send item set-label (if (preferences:get 'framework:open-here?) - (string-constant new-...-menu-item) - (string-constant new-menu-item)))) - - (define/override (file-menu:new-callback item event) - (cond - [(preferences:get 'framework:open-here?) - (let ([clear-current (ask-about-new-here)]) - (cond - [(eq? clear-current 'cancel) (void)] - [clear-current - (let* ([editor (get-editor)] - [canceled? (cancel-due-to-unsaved-changes editor)]) - (unless canceled? - (send editor begin-edit-sequence) - (send editor lock #f) - (send editor set-filename #f) - (send editor erase) - (send editor set-modified #f) - (send editor clear-undos) - (send editor end-edit-sequence)))] - [else ((handler:current-create-new-window) #f)]))] - [else ((handler:current-create-new-window) #f)])) - - ;; cancel-due-to-unsaved-changes : -> boolean - ;; returns #t if the action should be cancelled - (define/private (cancel-due-to-unsaved-changes editor) - (and (send editor is-modified?) - (let ([save (gui-utils:unsaved-warning - (let ([fn (send editor get-filename)]) - (if fn - (path->string fn) - (get-label))) - (string-constant clear-anyway) - #t - this)]) - (case save - [(continue) #f] - [(save) (not (send editor save-file/gui-error))] - [(cancel) #t])))) - - ;; ask-about-new-here : -> (union 'cancel boolean?) - ;; prompts the user about creating a new window - ;; or "reusing" the current one. - (define/private (ask-about-new-here) - (gui-utils:get-choice - (string-constant create-new-window-or-clear-current) - (string-constant clear-current) - (string-constant new-window) - (string-constant warning) - 'cancel - this)) - - (define/override (file-menu:open-on-demand item) - (super file-menu:open-on-demand item) - (send item set-label (if (preferences:get 'framework:open-here?) - (string-constant open-here-menu-item) - (string-constant open-menu-item)))) - - (define/augment (on-close) - (let ([group (group:get-the-frame-group)]) - (when (eq? this (send group get-open-here-frame)) - (send group set-open-here-frame #f))) - (inner (void) on-close)) - - (define/override (on-activate on?) - (super on-activate on?) - (when on? - (send (group:get-the-frame-group) set-open-here-frame this))) - - (inherit get-editor) - (define/public (get-open-here-editor) (get-editor)) - (define/public (open-here filename) - (let* ([editor (get-open-here-editor)] - [okay-to-switch? (user-okays-switch? editor)]) - (when okay-to-switch? - (when (is-a? editor text%) - (let* ([b (box #f)] - [filename (send editor get-filename b)]) - (unless (unbox b) - (when filename - (handler:set-recent-position - filename - (send editor get-start-position) - (send editor get-end-position)))))) - (send editor begin-edit-sequence) - (send editor lock #f) - (send editor load-file/gui-error filename) - (send editor end-edit-sequence) - (void)))) - - (inherit get-label) - (define/private (user-okays-switch? ed) - (or (not (send ed is-modified?)) - (let ([answer - (gui-utils:unsaved-warning - (let ([fn (send ed get-filename)]) - (if fn - (path->string fn) - (get-label))) - (string-constant switch-anyway) - #t)]) - (case answer - [(continue) - #t] - [(save) - (send ed save-file/gui-error)] - [(cancel) - #f])))) - - (super-new))) - - (define text<%> (interface (-editor<%>))) - (define text-mixin - (mixin (-editor<%>) (text<%>) - (define/override (get-editor<%>) (class->interface text%)) - (init (filename #f) (editor% text:keymap%)) - (super-new (filename filename) (editor% editor%)))) - - (define pasteboard<%> (interface (-editor<%>))) - (define pasteboard-mixin - (mixin (-editor<%>) (pasteboard<%>) - (define/override get-editor<%> (λ () (class->interface pasteboard%))) - (init (filename #f) (editor% pasteboard:keymap%)) - (super-new (filename filename) (editor% editor%)))) - - (define delegate<%> - (interface (status-line<%> text<%>) - get-delegated-text - delegated-text-shown? - hide-delegated-text - show-delegated-text - delegate-moved)) - - (define delegatee-editor-canvas% - (class (canvas:color-mixin canvas:basic%) - (init-field delegate-frame) - (inherit get-editor get-dc) - - (define/override (on-event evt) - (super on-event evt) - (when delegate-frame - (let ([text (get-editor)]) - (when (and (is-a? text text%) - (send delegate-frame delegated-text-shown?)) - (cond - [(send evt button-down?) - (let-values ([(editor-x editor-y) - (send text dc-location-to-editor-location - (send evt get-x) - (send evt get-y))]) - (send delegate-frame click-in-overview - (send text find-position editor-x editor-y)))] - [(or (send evt entering?) - (send evt moving?)) - (let-values ([(editor-x editor-y) - (send text dc-location-to-editor-location - (send evt get-x) - (send evt get-y))]) - (let* ([b (box #f)] - [pos (send text find-position editor-x editor-y #f b)]) - (cond - [(unbox b) - (let* ([para (send text position-paragraph pos)] - [start-pos (send text paragraph-start-position para)] - [end-pos (send text paragraph-end-position para)]) - (send delegate-frame update-status-line 'plt:delegate - (at-most-200 (send text get-text start-pos end-pos))))] - [else - (send delegate-frame update-status-line 'plt:delegate #f)])))] - [(send evt leaving?) - (send delegate-frame update-status-line 'plt:delegate #f)]))))) - (super-new))) - - (define (at-most-200 s) + (inherit determine-width) + (send macro-recording-message show #f) + (send anchor-message show #f) + (send overwrite-message show #f) + (send* position-canvas + (set-line-count 1) + (set-editor position-edit) + (stretchable-width #f) + (stretchable-height #f)) + (determine-width "000:00-000:00" + position-canvas + position-edit) + (editor-position-changed) + (send position-edit hide-caret #t) + (send position-edit lock #t))) + + (define click-pref-panel% + (class horizontal-panel% + (inherit popup-menu) + (define/override (on-subwindow-event receiver evt) (cond - [(<= (string-length s) 200) - s] - [else (substring s 0 200)])) + [(send evt button-down? 'right) + (let ([menu (new popup-menu%)] + [line-numbers? (preferences:get 'framework:display-line-numbers)]) + (new checkable-menu-item% + [parent menu] + [label (string-constant show-line-and-column-numbers)] + [callback (λ (x y) (preferences:set 'framework:display-line-numbers #t))] + [checked line-numbers?]) + (new checkable-menu-item% + [parent menu] + [label (string-constant show-character-offsets)] + [callback (λ (x y) (preferences:set 'framework:display-line-numbers #f))] + [checked (not line-numbers?)]) + (popup-menu menu + (+ 1 (send evt get-x)) + (+ 1 (send evt get-y)))) + #t] + [else + (super on-subwindow-event receiver evt)])) + (super-new))) + + (define pasteboard-info<%> (interface (info<%>))) + (define pasteboard-info-mixin + (mixin (basic<%>) (pasteboard-info<%>) + (super-instantiate ()))) + + (include "standard-menus.ss") + + (define -editor<%> (interface (standard-menus<%>) + get-entire-label + get-label-prefix + set-label-prefix + + get-canvas% + get-canvas<%> + get-editor% + get-editor<%> + + make-editor + revert + save + save-as + get-canvas + get-editor)) + + (define editor-mixin + (mixin (standard-menus<%>) (-editor<%>) + (init (filename #f)) + (init-field (editor% #f)) - (define delegatee-text<%> - (interface () - set-start/end-para)) + (inherit get-area-container get-client-size + show get-edit-target-window get-edit-target-object) - (define delegatee-text% - (class* text:basic% (delegatee-text<%>) - (inherit get-admin) - (define start-para #f) - (define end-para #f) - (define view-x-b (box 0)) - (define view-width-b (box 0)) - (inherit paragraph-start-position paragraph-end-position - position-location invalidate-bitmap-cache scroll-to-position - get-visible-position-range position-paragraph - last-position) - - (define/override (on-new-string-snip) - (instantiate text:1-pixel-string-snip% ())) + (define/override get-filename + (case-lambda + [() (get-filename #f)] + [(b) + (let ([e (get-editor)]) + (and e (send e get-filename b)))])) + + (define/override (editing-this-file? filename) + (let ([path-equal? + (λ (x y) + (equal? (normal-case-path (normalize-path x)) + (normal-case-path (normalize-path y))))]) + (let ([this-fn (get-filename)]) + (and this-fn + (path-equal? filename (get-filename)))))) + + (define/augment (on-close) + (send (get-editor) on-close) + (inner (void) on-close)) + + (define/augment (can-close?) + (and (send (get-editor) can-close?) + (inner #t can-close?))) + + [define label ""] + [define label-prefix (application:current-app-name)] + (define/private (do-label) + (super set-label (gui-utils:trim-string (get-entire-label) 200)) + (send (group:get-the-frame-group) frame-label-changed this)) + + (public get-entire-label get-label-prefix set-label-prefix) + [define get-entire-label + (λ () + (cond + [(string=? "" label) + label-prefix] + [(string=? "" label-prefix) + label] + [else + (string-append label " - " label-prefix)]))] + [define get-label-prefix (λ () label-prefix)] + [define set-label-prefix + (λ (s) + (when (and (string? s) + (not (string=? s label-prefix))) + (set! label-prefix s) + (do-label)))] + [define/override get-label (λ () label)] + [define/override set-label + (λ (t) + (when (and (string? t) + (not (string=? t label))) + (set! label t) + (do-label)))] + + (define/public (get-canvas%) editor-canvas%) + (define/public (get-canvas<%>) (class->interface editor-canvas%)) + (define/public (make-canvas) + (let ([% (get-canvas%)] + [<%> (get-canvas<%>)]) + (unless (implementation? % <%>) + (error 'frame:editor% + "result of get-canvas% method must match ~e interface; got: ~e" + <%> %)) + (instantiate % () (parent (get-area-container))))) + (define/public (get-editor%) + (or editor% + (error 'editor-frame% "abstract method: no editor% class specified"))) + (define/public (get-editor<%>) + editor:basic<%>) + (define/public (make-editor) + (let ([% (get-editor%)] + [<%> (get-editor<%>)]) + (unless (implementation? % <%>) + (error 'frame:editor% + "result of get-editor% method must match ~e interface; got: ~e" + <%> %)) + (make-object %))) + + (define/public save + (opt-lambda ([format 'same]) + (let* ([ed (get-editor)] + [filename (send ed get-filename)]) + (if filename + (send ed save-file/gui-error filename format) + (save-as format))))) + + (define/public save-as + (opt-lambda ([format 'same]) + (let* ([editor (get-editor)] + [name (send editor get-filename)]) + (let-values ([(base name) + (if name + (let-values ([(base name dir?) (split-path name)]) + (values base name)) + (values #f #f))]) + (let ([file (send editor put-file base name)]) + (if file + (send editor save-file/gui-error file format) + #f)))))) + + (define/private (basename str) + (let-values ([(base name dir?) (split-path str)]) + base)) + + (inherit get-checkable-menu-item% get-menu-item%) + + (define/override (file-menu:revert-on-demand item) + (send item enable (not (send (get-editor) is-locked?)))) + + (define/override file-menu:revert-callback + (λ (item control) + (let* ([edit (get-editor)] + [b (box #f)] + [filename (send edit get-filename b)]) + (if (or (not filename) + (unbox b)) + (bell) + (when (or (not (send (get-editor) is-modified?)) + (gui-utils:get-choice + (string-constant are-you-sure-revert) + (string-constant yes) + (string-constant no) + (string-constant are-you-sure-revert-title) + #f + this)) + (revert)))) + #t)) + + (define/public (revert) + (let* ([edit (get-editor)] + [b (box #f)] + [filename (send edit get-filename b)]) + (when (and filename + (not (unbox b))) + (let ([start + (if (is-a? edit text%) + (send edit get-start-position) + #f)]) + (send edit begin-edit-sequence) + (let ([status (send edit load-file/gui-error + filename + 'guess + #f)]) + (if status + (begin + (when (is-a? edit text%) + (send edit set-position start start)) + (send edit end-edit-sequence)) + (send edit end-edit-sequence))))))) + + (define/override file-menu:create-revert? (λ () #t)) + (define/override file-menu:save-callback + (λ (item control) + (save) + #t)) + + (define/override file-menu:create-save? (λ () #t)) + (define/override file-menu:save-as-callback (λ (item control) (save-as) #t)) + (define/override file-menu:create-save-as? (λ () #t)) + (define/override file-menu:print-callback (λ (item control) + (send (get-editor) print + #t + #t + (preferences:get 'framework:print-output-mode)) + #t)) + (define/override file-menu:create-print? (λ () #t)) + + (inherit get-top-level-window) + (define/override (file-menu:between-save-as-and-print file-menu) + (when (can-get-page-setup-from-user?) + (new menu-item% + [parent file-menu] + [label (string-constant page-setup-menu-item)] + [help-string (string-constant page-setup-info)] + [callback + (lambda (item event) + (let ([s (get-page-setup-from-user #f (get-top-level-window))]) + (when s + (send (current-ps-setup) copy-from s))))]))) + + (define/override edit-menu:between-select-all-and-find + (λ (edit-menu) + (let* ([c% (get-checkable-menu-item%)] + [on-demand + (λ (menu-item) + (let ([edit (get-edit-target-object)]) + (if (and edit (is-a? edit editor<%>)) + (begin + (send menu-item enable #t) + (send menu-item check (send edit auto-wrap))) + (begin + (send menu-item check #f) + (send menu-item enable #f)))))] + [callback + (λ (item event) + (let ([edit (get-edit-target-object)]) + (when (and edit + (is-a? edit editor<%>)) + (let ([new-pref (not (send edit auto-wrap))]) + (preferences:set 'framework:auto-set-wrap? new-pref) + (send edit auto-wrap new-pref)))))]) + (make-object c% (string-constant wrap-text-item) + edit-menu callback #f #f on-demand)) - (define/override (on-new-tab-snip) - (instantiate text:1-pixel-tab-snip% ())) - - ;; set-start/end-para : (union (#f #f -> void) (number number -> void)) - (define/public (set-start/end-para _start-para _end-para) - (unless (and (equal? _start-para start-para) - (equal? _end-para end-para)) - (let ([old-start-para start-para] - [old-end-para end-para]) - (cond - [else - (set! start-para _start-para) - (set! end-para _end-para)]) - - (when (and start-para end-para) - - (let-values ([(v-start v-end) (let ([bs (box 0)] - [bf (box 0)]) - (get-visible-position-range bs bf) - (values (unbox bs) - (unbox bf)))]) - (let ([v-start-para (position-paragraph v-start)] - [v-end-para (position-paragraph v-end)]) - (cond - [(v-start-para . >= . start-para) - (scroll-to-position (paragraph-start-position start-para))] - [(v-end-para . <= . end-para) - (scroll-to-position (paragraph-end-position end-para))] - [else (void)])))) - - (when (and old-start-para old-end-para) - (let-values ([(x y w h) (get-rectangle old-start-para old-end-para)]) - (when x - (invalidate-bitmap-cache x y w h)))) - (when (and start-para end-para) - (let-values ([(x y w h) (get-rectangle start-para end-para)]) - (when x - (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) - (let ([old-pen (send dc get-pen)] - [old-brush (send dc get-brush)]) - (send dc set-pen - (send the-pen-list find-or-create-pen - (preferences:get 'framework:delegatee-overview-color) - 1 - 'solid)) - (send dc set-brush - (send the-brush-list find-or-create-brush - (preferences:get 'framework:delegatee-overview-color) - 'solid)) - (let-values ([(x y w h) (get-rectangle start-para end-para)]) - (when x - (send dc draw-rectangle - (+ dx x) - (+ dy y) - w - h))) - (send dc set-pen old-pen) - (send dc set-brush old-brush)))) - - - ;; get-rectangle : number number -> - ;; (values (union #f number) (union #f number) (union #f number) (union #f number)) - ;; computes the rectangle corresponding the input paragraphs - (define/private (get-rectangle start-para end-para) - (let ([start (get-line-y start-para #t)] - [end (get-line-y end-para #f)] - [admin (get-admin)]) + (make-object separator-menu-item% edit-menu))) + + (define/override help-menu:about-callback + (λ (menu evt) + (message-box (application:current-app-name) + (format (string-constant welcome-to-something) + (application:current-app-name)) + #f + '(ok app)))) + (define/override help-menu:about-string (λ () (application:current-app-name))) + (define/override help-menu:create-about? (λ () #t)) + + (super-new (label (get-entire-label))) + + (define canvas #f) + (define editor #f) + (public get-canvas get-editor) + (define get-canvas + (λ () + (unless canvas + (set! canvas (make-canvas)) + (send canvas set-editor (get-editor))) + canvas)) + (define get-editor + (λ () + (unless editor + (set! editor (make-editor)) + (send (get-canvas) set-editor editor)) + editor)) + + (cond + [(and filename (file-exists? filename)) + (let ([ed (get-editor)]) + (send ed begin-edit-sequence) + (send ed load-file/gui-error filename 'guess) + (send ed end-edit-sequence))] + [filename + (send (get-editor) set-filename filename)] + [else (void)]) + + (let ([ed-fn (send (get-editor) get-filename)]) + (set! label (or (and ed-fn + (path->string (file-name-from-path ed-fn))) + (send (get-editor) get-filename/untitled-name)))) + (do-label) + (let ([canvas (get-canvas)]) + (when (is-a? canvas editor-canvas%) + ;; when get-canvas is overridden, + ;; it might not yet be implemented + (send canvas focus))))) + + (define open-here<%> + (interface (-editor<%>) + get-open-here-editor + open-here)) + + (define open-here-mixin + (mixin (-editor<%>) (open-here<%>) + + (define/override (file-menu:new-on-demand item) + (super file-menu:new-on-demand item) + (send item set-label (if (preferences:get 'framework:open-here?) + (string-constant new-...-menu-item) + (string-constant new-menu-item)))) + + (define/override (file-menu:new-callback item event) + (cond + [(preferences:get 'framework:open-here?) + (let ([clear-current (ask-about-new-here)]) + (cond + [(eq? clear-current 'cancel) (void)] + [clear-current + (let* ([editor (get-editor)] + [canceled? (cancel-due-to-unsaved-changes editor)]) + (unless canceled? + (send editor begin-edit-sequence) + (send editor lock #f) + (send editor set-filename #f) + (send editor erase) + (send editor set-modified #f) + (send editor clear-undos) + (send editor end-edit-sequence)))] + [else ((handler:current-create-new-window) #f)]))] + [else ((handler:current-create-new-window) #f)])) + + ;; cancel-due-to-unsaved-changes : -> boolean + ;; returns #t if the action should be cancelled + (define/private (cancel-due-to-unsaved-changes editor) + (and (send editor is-modified?) + (let ([save (gui-utils:unsaved-warning + (let ([fn (send editor get-filename)]) + (if fn + (path->string fn) + (get-label))) + (string-constant clear-anyway) + #t + this)]) + (case save + [(continue) #f] + [(save) (not (send editor save-file/gui-error))] + [(cancel) #t])))) + + ;; ask-about-new-here : -> (union 'cancel boolean?) + ;; prompts the user about creating a new window + ;; or "reusing" the current one. + (define/private (ask-about-new-here) + (gui-utils:get-choice + (string-constant create-new-window-or-clear-current) + (string-constant clear-current) + (string-constant new-window) + (string-constant warning) + 'cancel + this)) + + (define/override (file-menu:open-on-demand item) + (super file-menu:open-on-demand item) + (send item set-label (if (preferences:get 'framework:open-here?) + (string-constant open-here-menu-item) + (string-constant open-menu-item)))) + + (define/augment (on-close) + (let ([group (group:get-the-frame-group)]) + (when (eq? this (send group get-open-here-frame)) + (send group set-open-here-frame #f))) + (inner (void) on-close)) + + (define/override (on-activate on?) + (super on-activate on?) + (when on? + (send (group:get-the-frame-group) set-open-here-frame this))) + + (inherit get-editor) + (define/public (get-open-here-editor) (get-editor)) + (define/public (open-here filename) + (let* ([editor (get-open-here-editor)] + [okay-to-switch? (user-okays-switch? editor)]) + (when okay-to-switch? + (when (is-a? editor text%) + (let* ([b (box #f)] + [filename (send editor get-filename b)]) + (unless (unbox b) + (when filename + (handler:set-recent-position + filename + (send editor get-start-position) + (send editor get-end-position)))))) + (send editor begin-edit-sequence) + (send editor lock #f) + (send editor load-file/gui-error filename) + (send editor end-edit-sequence) + (void)))) + + (inherit get-label) + (define/private (user-okays-switch? ed) + (or (not (send ed is-modified?)) + (let ([answer + (gui-utils:unsaved-warning + (let ([fn (send ed get-filename)]) + (if fn + (path->string fn) + (get-label))) + (string-constant switch-anyway) + #t)]) + (case answer + [(continue) + #t] + [(save) + (send ed save-file/gui-error)] + [(cancel) + #f])))) + + (super-new))) + + (define text<%> (interface (-editor<%>))) + (define text-mixin + (mixin (-editor<%>) (text<%>) + (define/override (get-editor<%>) (class->interface text%)) + (init (filename #f) (editor% text:keymap%)) + (super-new (filename filename) (editor% editor%)))) + + (define pasteboard<%> (interface (-editor<%>))) + (define pasteboard-mixin + (mixin (-editor<%>) (pasteboard<%>) + (define/override get-editor<%> (λ () (class->interface pasteboard%))) + (init (filename #f) (editor% pasteboard:keymap%)) + (super-new (filename filename) (editor% editor%)))) + + (define delegate<%> + (interface (status-line<%> text<%>) + get-delegated-text + delegated-text-shown? + hide-delegated-text + show-delegated-text + delegate-moved)) + + (define delegatee-editor-canvas% + (class (canvas:color-mixin canvas:basic%) + (init-field delegate-frame) + (inherit get-editor get-dc) + + (define/override (on-event evt) + (super on-event evt) + (when delegate-frame + (let ([text (get-editor)]) + (when (and (is-a? text text%) + (send delegate-frame delegated-text-shown?)) (cond - [(not admin) - (values #f #f #f #f)] - [(= 0 (last-position)) - (values #f #f #f #f)] - [else - (send admin get-view view-x-b #f view-width-b #f) - (send admin get-view view-x-b #f view-width-b #f) - (values (unbox view-x-b) - start - (unbox view-width-b) - (- end start))]))) - - (define/private (get-line-y para top?) - (let ([pos (paragraph-start-position para)] - [b (box 0)]) - (position-location pos #f b top? #f #t) - (unbox b))) - (super-new) - - (inherit set-cursor) - (set-cursor (make-object cursor% 'arrow)) - - (inherit set-line-spacing) - (set-line-spacing 0))) + [(send evt button-down?) + (let-values ([(editor-x editor-y) + (send text dc-location-to-editor-location + (send evt get-x) + (send evt get-y))]) + (send delegate-frame click-in-overview + (send text find-position editor-x editor-y)))] + [(or (send evt entering?) + (send evt moving?)) + (let-values ([(editor-x editor-y) + (send text dc-location-to-editor-location + (send evt get-x) + (send evt get-y))]) + (let* ([b (box #f)] + [pos (send text find-position editor-x editor-y #f b)]) + (cond + [(unbox b) + (let* ([para (send text position-paragraph pos)] + [start-pos (send text paragraph-start-position para)] + [end-pos (send text paragraph-end-position para)]) + (send delegate-frame update-status-line 'plt:delegate + (at-most-200 (send text get-text start-pos end-pos))))] + [else + (send delegate-frame update-status-line 'plt:delegate #f)])))] + [(send evt leaving?) + (send delegate-frame update-status-line 'plt:delegate #f)]))))) + (super-new))) + + (define (at-most-200 s) + (cond + [(<= (string-length s) 200) + s] + [else (substring s 0 200)])) + + (define delegatee-text<%> + (interface () + set-start/end-para)) + + (define delegatee-text% + (class* text:basic% (delegatee-text<%>) + (inherit get-admin) + (define start-para #f) + (define end-para #f) + (define view-x-b (box 0)) + (define view-width-b (box 0)) + (inherit paragraph-start-position paragraph-end-position + position-location invalidate-bitmap-cache scroll-to-position + get-visible-position-range position-paragraph + last-position) - (define delegate-mixin - (mixin (status-line<%> text<%>) (delegate<%>) - - (define/public (get-delegated-text) (get-editor)) - - [define rest-panel 'uninitialized-root] - [define super-root 'uninitialized-super-root] - [define/override make-root-area-container - (λ (% parent) - (let* ([s-root (super make-root-area-container - horizontal-panel% - parent)] - [r-root (make-object % s-root)]) - (set! super-root s-root) - (set! rest-panel r-root) - r-root))] - - (define/override (get-editor<%>) - text:delegate<%>) - - (define/override (get-editor%) - (text:delegate-mixin (super get-editor%))) - - (field (shown? (preferences:get 'framework:show-delegate?))) - (define/public (delegated-text-shown?) - shown?) - - (inherit close-status-line open-status-line) - (define/public (hide-delegated-text) - (close-status-line 'plt:delegate) - (set! shown? #f) - (send (get-delegated-text) set-delegate #f) - (send super-root change-children - (λ (l) (list rest-panel)))) - (define/public (show-delegated-text) + (define/override (on-new-string-snip) + (instantiate text:1-pixel-string-snip% ())) + + (define/override (on-new-tab-snip) + (instantiate text:1-pixel-tab-snip% ())) + + ;; set-start/end-para : (union (#f #f -> void) (number number -> void)) + (define/public (set-start/end-para _start-para _end-para) + (unless (and (equal? _start-para start-para) + (equal? _end-para end-para)) + (let ([old-start-para start-para] + [old-end-para end-para]) + (cond + [else + (set! start-para _start-para) + (set! end-para _end-para)]) + + (when (and start-para end-para) + + (let-values ([(v-start v-end) (let ([bs (box 0)] + [bf (box 0)]) + (get-visible-position-range bs bf) + (values (unbox bs) + (unbox bf)))]) + (let ([v-start-para (position-paragraph v-start)] + [v-end-para (position-paragraph v-end)]) + (cond + [(v-start-para . >= . start-para) + (scroll-to-position (paragraph-start-position start-para))] + [(v-end-para . <= . end-para) + (scroll-to-position (paragraph-end-position end-para))] + [else (void)])))) + + (when (and old-start-para old-end-para) + (let-values ([(x y w h) (get-rectangle old-start-para old-end-para)]) + (when x + (invalidate-bitmap-cache x y w h)))) + (when (and start-para end-para) + (let-values ([(x y w h) (get-rectangle start-para end-para)]) + (when x + (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) + (let ([old-pen (send dc get-pen)] + [old-brush (send dc get-brush)]) + (send dc set-pen + (send the-pen-list find-or-create-pen + (preferences:get 'framework:delegatee-overview-color) + 1 + 'solid)) + (send dc set-brush + (send the-brush-list find-or-create-brush + (preferences:get 'framework:delegatee-overview-color) + 'solid)) + (let-values ([(x y w h) (get-rectangle start-para end-para)]) + (when x + (send dc draw-rectangle + (+ dx x) + (+ dy y) + w + h))) + (send dc set-pen old-pen) + (send dc set-brush old-brush)))) + + + ;; get-rectangle : number number -> + ;; (values (union #f number) (union #f number) (union #f number) (union #f number)) + ;; computes the rectangle corresponding the input paragraphs + (define/private (get-rectangle start-para end-para) + (let ([start (get-line-y start-para #t)] + [end (get-line-y end-para #f)] + [admin (get-admin)]) + (cond + [(not admin) + (values #f #f #f #f)] + [(= 0 (last-position)) + (values #f #f #f #f)] + [else + (send admin get-view view-x-b #f view-width-b #f) + (send admin get-view view-x-b #f view-width-b #f) + (values (unbox view-x-b) + start + (unbox view-width-b) + (- end start))]))) + + (define/private (get-line-y para top?) + (let ([pos (paragraph-start-position para)] + [b (box 0)]) + (position-location pos #f b top? #f #t) + (unbox b))) + (super-new) + + (inherit set-cursor) + (set-cursor (make-object cursor% 'arrow)) + + (inherit set-line-spacing) + (set-line-spacing 0))) + + (define delegate-mixin + (mixin (status-line<%> text<%>) (delegate<%>) + + (define/public (get-delegated-text) (get-editor)) + + [define rest-panel 'uninitialized-root] + [define super-root 'uninitialized-super-root] + [define/override make-root-area-container + (λ (% parent) + (let* ([s-root (super make-root-area-container + horizontal-panel% + parent)] + [r-root (make-object % s-root)]) + (set! super-root s-root) + (set! rest-panel r-root) + r-root))] + + (define/override (get-editor<%>) + text:delegate<%>) + + (define/override (get-editor%) + (text:delegate-mixin (super get-editor%))) + + (field (shown? (preferences:get 'framework:show-delegate?))) + (define/public (delegated-text-shown?) + shown?) + + (inherit close-status-line open-status-line) + (define/public (hide-delegated-text) + (close-status-line 'plt:delegate) + (set! shown? #f) + (send (get-delegated-text) set-delegate #f) + (send super-root change-children + (λ (l) (list rest-panel)))) + (define/public (show-delegated-text) + (open-status-line 'plt:delegate) + (set! shown? #t) + (send (get-delegated-text) set-delegate delegatee) + (send super-root change-children + (λ (l) (list rest-panel delegate-ec)))) + + (define/public (click-in-overview pos) + (when shown? + (let* ([d-text (get-delegated-text)] + [d-canvas (send d-text get-canvas)] + [bx (box 0)] + [by (box 0)]) + (let-values ([(cw ch) (send d-canvas get-client-size)]) + (send d-text position-location pos bx by) + (send d-canvas focus) + (send d-canvas scroll-to + (- (unbox bx) (/ cw 2)) + (- (unbox by) (/ ch 2)) + cw + ch + #t))))) + + (define/public (delegate-moved) + (let ([startb (box 0)] + [endb (box 0)] + [delegate-text (get-delegated-text)]) + (send delegate-text get-visible-position-range startb endb #f) + (send delegatee set-start/end-para + (send delegate-text position-paragraph (unbox startb)) + (send delegate-text position-paragraph (unbox endb))))) + + (define/public (get-delegatee) delegatee) + + (super-instantiate ()) + + (define delegatee (instantiate delegatee-text% ())) + (define delegate-ec (instantiate delegatee-editor-canvas% () + (editor delegatee) + (parent super-root) + (delegate-frame this) + (min-width 150) + (stretchable-width #f))) + (inherit get-editor) + (if (preferences:get 'framework:show-delegate?) + (begin (open-status-line 'plt:delegate) - (set! shown? #t) (send (get-delegated-text) set-delegate delegatee) (send super-root change-children (λ (l) (list rest-panel delegate-ec)))) - - (define/public (click-in-overview pos) - (when shown? - (let* ([d-text (get-delegated-text)] - [d-canvas (send d-text get-canvas)] - [bx (box 0)] - [by (box 0)]) - (let-values ([(cw ch) (send d-canvas get-client-size)]) - (send d-text position-location pos bx by) - (send d-canvas focus) - (send d-canvas scroll-to - (- (unbox bx) (/ cw 2)) - (- (unbox by) (/ ch 2)) - cw - ch - #t))))) - - (define/public (delegate-moved) - (let ([startb (box 0)] - [endb (box 0)] - [delegate-text (get-delegated-text)]) - (send delegate-text get-visible-position-range startb endb #f) - (send delegatee set-start/end-para - (send delegate-text position-paragraph (unbox startb)) - (send delegate-text position-paragraph (unbox endb))))) - - (define/public (get-delegatee) delegatee) - - (super-instantiate ()) - - (define delegatee (instantiate delegatee-text% ())) - (define delegate-ec (instantiate delegatee-editor-canvas% () - (editor delegatee) - (parent super-root) - (delegate-frame this) - (min-width 150) - (stretchable-width #f))) - (inherit get-editor) - (if (preferences:get 'framework:show-delegate?) - (begin - (open-status-line 'plt:delegate) - (send (get-delegated-text) set-delegate delegatee) - (send super-root change-children - (λ (l) (list rest-panel delegate-ec)))) - (begin - (send (get-delegated-text) set-delegate #f) - (send super-root change-children (λ (l) (list rest-panel))))))) + (begin + (send (get-delegated-text) set-delegate #f) + (send super-root change-children (λ (l) (list rest-panel))))))) + + + (define (search-dialog frame) + (init-find/replace-edits) + (keymap:call/text-keymap-initializer + (λ () + (let* ([to-be-searched-text (send frame get-text-to-search)] + [to-be-searched-canvas (send to-be-searched-text get-canvas)] - - (define (search-dialog frame) - (init-find/replace-edits) - (keymap:call/text-keymap-initializer - (λ () - (let* ([to-be-searched-text (send frame get-text-to-search)] - [to-be-searched-canvas (send to-be-searched-text get-canvas)] - - [allow-replace? (not (send to-be-searched-text is-locked?))] - - [dialog (new dialog% - (label (if allow-replace? - (string-constant find-and-replace) - (string-constant find))) - (parent frame) - (style '(no-sheet)))] - - [copy-text - (λ (from to) - (send to erase) - (let loop ([snip (send from find-first-snip)]) - (when snip - (send to insert (send snip copy)) - (loop (send snip next)))))] - - [text-keymap/editor% - (class text:keymap% - (define/override (get-keymaps) - (if (preferences:get 'framework:menu-bindings) - (append (list (keymap:get-editor)) - (super get-keymaps)) - (append (super get-keymaps) - (list (keymap:get-editor))))) - (inherit set-styles-fixed) - (super-new) - (set-styles-fixed #t))] - - - [find-panel (make-object horizontal-panel% dialog)] - [find-message (make-object message% (string-constant find) find-panel)] - [f-text (make-object text-keymap/editor%)] - [find-canvas (make-object editor-canvas% find-panel f-text - '(hide-hscroll hide-vscroll))] - - [replace-panel (make-object horizontal-panel% dialog)] - [replace-message (make-object message% (string-constant replace) replace-panel)] - [r-text (make-object text-keymap/editor%)] - [replace-canvas (make-object editor-canvas% replace-panel r-text - '(hide-hscroll hide-vscroll))] - - [button-panel (make-object horizontal-panel% dialog)] - - [prefs-panel (make-object horizontal-panel% dialog)] - [sensitive-check-box-callback (λ () (send find-edit toggle-case-sensitive))] - [sensitive-check-box (make-object check-box% - (string-constant find-case-sensitive) - prefs-panel (λ (x y) (sensitive-check-box-callback)))] - [dummy (begin (send sensitive-check-box set-value (send find-edit get-case-sensitive?)) - (send prefs-panel set-alignment 'center 'center))] - [update-texts - (λ () - (send find-edit stop-searching) - (copy-text f-text find-edit) - (send find-edit start-searching) - (copy-text r-text replace-edit))] - - [find-button (make-object button% (string-constant find) button-panel - (λ x - (update-texts) - (send frame search-again)) - '(border))] - [replace-button (make-object button% (string-constant replace) button-panel - (λ x - (update-texts) - (send frame replace)))] - [replace-and-find-button (make-object button% (string-constant replace&find-again) - button-panel - (λ x - (update-texts) - (send frame replace&search)))] - [replace-to-end-button - (make-object button% (string-constant replace-to-end) button-panel - (λ x - (update-texts) - (send frame replace-all)))] - - [dock-button (make-object button% - (string-constant dock) - button-panel - (λ (btn evt) - (update-texts) - (preferences:set 'framework:search-using-dialog? #f) - (send frame unhide-search)))] - - [close - (λ () - (when to-be-searched-canvas - (send to-be-searched-canvas force-display-focus #f)) - (send dialog show #f))] - - [close-button (make-object button% (string-constant close) button-panel - (λ (x y) - (close)))] - - [remove-pref-callback - (preferences:add-callback - 'framework:search-using-dialog? - (λ (p v) - (unless v - (close))))]) - - (unless allow-replace? - (send button-panel change-children - (λ (l) - (remq - replace-button - (remq - replace-and-find-button - (remq - replace-to-end-button - l))))) - (send dialog change-children - (λ (l) - (remq replace-panel l)))) - - (copy-text find-edit f-text) - (copy-text replace-edit r-text) - (send find-canvas min-width 400) - (send find-canvas set-line-count 2) - (send find-canvas stretchable-height #f) - (send find-canvas allow-tab-exit #t) - (send replace-canvas min-width 400) - (send replace-canvas set-line-count 2) - (send replace-canvas stretchable-height #f) - (send replace-canvas allow-tab-exit #t) - (let ([msg-width (max (send find-message get-width) - (send replace-message get-width))]) - (send find-message min-width msg-width) - (send replace-message min-width msg-width)) - (send find-canvas focus) - (send f-text set-position 0 (send f-text last-position)) - (send button-panel set-alignment 'right 'center) - (send dialog center 'both) - (when to-be-searched-canvas - (send to-be-searched-canvas force-display-focus #t)) - (send dialog show #t) - (remove-pref-callback))))) - - (define searchable<%> (interface (basic<%>) - get-text-to-search - hide-search - unhide-search - set-search-direction - replace&search - replace-all - replace - can-replace? - toggle-search-focus - move-to-search-or-search - move-to-search-or-reverse-search - search-again)) - (define search-anchor 0) - (define searching-direction 'forward) - (define (set-searching-direction x) - (unless (or (eq? x 'forward) - (eq? x 'backward)) - (error 'set-searching-direction "expected ~e or ~e, got ~e" 'forward 'backward x)) - (set! searching-direction x)) - - (define old-search-highlight void) - (define clear-search-highlight - (λ () - (begin (old-search-highlight) - (set! old-search-highlight void)))) - (define reset-search-anchor - (let ([color (make-object color% "BLUE")]) - (λ (edit) - (old-search-highlight) - (let ([position - (if (eq? 'forward searching-direction) - (send edit get-end-position) - (send edit get-start-position))]) - (set! search-anchor position) + [allow-replace? (not (send to-be-searched-text is-locked?))] - ;; don't draw the anchor - '(set! old-search-highlight - (send edit highlight-range position position color #f)))))) - - (define find-string-embedded - (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) + [dialog (new dialog% + (label (if allow-replace? + (string-constant find-and-replace) + (string-constant find))) + (parent frame) + (style '(no-sheet)))] + + [copy-text + (λ (from to) + (send to erase) + (let loop ([snip (send from find-first-snip)]) + (when snip + (send to insert (send snip copy)) + (loop (send snip next)))))] + + [text-keymap/editor% + (class text:keymap% + (define/override (get-keymaps) + (if (preferences:get 'framework:menu-bindings) + (append (list (keymap:get-editor)) + (super get-keymaps)) + (append (super get-keymaps) + (list (keymap:get-editor))))) + (inherit set-styles-fixed) + (super-new) + (set-styles-fixed #t))] + + + [find-panel (make-object horizontal-panel% dialog)] + [find-message (make-object message% (string-constant find) find-panel)] + [f-text (make-object text-keymap/editor%)] + [find-canvas (make-object editor-canvas% find-panel f-text + '(hide-hscroll hide-vscroll))] + + [replace-panel (make-object horizontal-panel% dialog)] + [replace-message (make-object message% (string-constant replace) replace-panel)] + [r-text (make-object text-keymap/editor%)] + [replace-canvas (make-object editor-canvas% replace-panel r-text + '(hide-hscroll hide-vscroll))] + + [button-panel (make-object horizontal-panel% dialog)] + + [prefs-panel (make-object horizontal-panel% dialog)] + [sensitive-check-box-callback (λ () (send find-edit toggle-case-sensitive))] + [sensitive-check-box (make-object check-box% + (string-constant find-case-sensitive) + prefs-panel (λ (x y) (sensitive-check-box-callback)))] + [dummy (begin (send sensitive-check-box set-value (send find-edit get-case-sensitive?)) + (send prefs-panel set-alignment 'center 'center))] + [update-texts + (λ () + (send find-edit stop-searching) + (copy-text f-text find-edit) + (send find-edit start-searching) + (copy-text r-text replace-edit))] + + [find-button (make-object button% (string-constant find) button-panel + (λ x + (update-texts) + (send frame search-again)) + '(border))] + [replace-button (make-object button% (string-constant replace) button-panel + (λ x + (update-texts) + (send frame replace)))] + [replace-and-find-button (make-object button% (string-constant replace&find-again) + button-panel + (λ x + (update-texts) + (send frame replace&search)))] + [replace-to-end-button + (make-object button% (string-constant replace-to-end) button-panel + (λ x + (update-texts) + (send frame replace-all)))] + + [dock-button (make-object button% + (string-constant dock) + button-panel + (λ (btn evt) + (update-texts) + (preferences:set 'framework:search-using-dialog? #f) + (send frame unhide-search)))] + + [close + (λ () + (when to-be-searched-canvas + (send to-be-searched-canvas force-display-focus #f)) + (send dialog show #f))] + + [close-button (make-object button% (string-constant close) button-panel + (λ (x y) + (close)))] + + [remove-pref-callback + (preferences:add-callback + 'framework:search-using-dialog? + (λ (p v) + (unless v + (close))))]) + + (unless allow-replace? + (send button-panel change-children + (λ (l) + (remq + replace-button + (remq + replace-and-find-button + (remq + replace-to-end-button + l))))) + (send dialog change-children + (λ (l) + (remq replace-panel l)))) + + (copy-text find-edit f-text) + (copy-text replace-edit r-text) + (send find-canvas min-width 400) + (send find-canvas set-line-count 2) + (send find-canvas stretchable-height #f) + (send find-canvas allow-tab-exit #t) + (send replace-canvas min-width 400) + (send replace-canvas set-line-count 2) + (send replace-canvas stretchable-height #f) + (send replace-canvas allow-tab-exit #t) + (let ([msg-width (max (send find-message get-width) + (send replace-message get-width))]) + (send find-message min-width msg-width) + (send replace-message min-width msg-width)) + (send find-canvas focus) + (send f-text set-position 0 (send f-text last-position)) + (send button-panel set-alignment 'right 'center) + (send dialog center 'both) + (when to-be-searched-canvas + (send to-be-searched-canvas force-display-focus #t)) + (send dialog show #t) + (remove-pref-callback))))) + + (define searchable<%> (interface (basic<%>) + get-text-to-search + hide-search + unhide-search + set-search-direction + replace&search + replace-all + replace + can-replace? + toggle-search-focus + move-to-search-or-search + move-to-search-or-reverse-search + search-again)) + (define search-anchor 0) + (define searching-direction 'forward) + (define (set-searching-direction x) + (unless (or (eq? x 'forward) + (eq? x 'backward)) + (error 'set-searching-direction "expected ~e or ~e, got ~e" 'forward 'backward x)) + (set! searching-direction x)) + + (define old-search-highlight void) + (define clear-search-highlight + (λ () + (begin (old-search-highlight) + (set! old-search-highlight void)))) + (define reset-search-anchor + (let ([color (make-object color% "BLUE")]) + (λ (edit) + (old-search-highlight) + (let ([position + (if (eq? 'forward searching-direction) + (send edit get-end-position) + (send edit get-start-position))]) + (set! search-anchor position) + + ;; don't draw the anchor + '(set! old-search-highlight + (send edit highlight-range position position color #f)))))) + + (define find-string-embedded + (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 + (λ () + (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 + (λ () + (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) - (send edit last-position) - 0) - end)] - [flat (send edit find-string str direction - start end get-start - case-sensitive?)] - [pop-out - (λ () - (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 - (λ () - (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) - (set! searching-frame frame)) - - (define find-text% - (class text:keymap% - (inherit get-text) - (define/private (get-searching-edit) - (and searching-frame - (send searching-frame get-text-to-search))) - (define/public search - (opt-lambda ([reset-search-anchor? #t] [beep? #t] [wrap? #t]) - (when searching-frame - (let* ([string (get-text)] - [top-searching-edit (get-searching-edit)] - - [searching-edit (let ([focus-snip (send top-searching-edit get-focus-snip)]) - (if focus-snip - (send focus-snip get-editor) - top-searching-edit))] - - [not-found - (λ (found-edit skip-beep?) - (send found-edit set-position search-anchor) - (when (and beep? - (not skip-beep?)) - (bell)) - #f)] - [found - (λ (edit first-pos) - (let ([last-pos ((if (eq? searching-direction 'forward) + -) - first-pos (string-length string))]) - (send* edit - (set-caret-owner #f 'display) - (set-position - (min first-pos last-pos) - (max first-pos last-pos) - #f #t 'local)) - #t))]) - (if (string=? string "") - (not-found top-searching-edit #t) - (begin - (when reset-search-anchor? - (reset-search-anchor searching-edit)) - (let-values ([(found-edit first-pos) - (find-string-embedded - searching-edit - string - searching-direction - search-anchor - 'eof #t case-sensitive? #t)]) - (cond - [(not first-pos) - (if wrap? - (begin - (let-values ([(found-edit pos) - (find-string-embedded - top-searching-edit - string - searching-direction - (if (eq? 'forward searching-direction) - 0 - (send searching-edit last-position)) - 'eof #t case-sensitive? #f)]) - (if (not pos) - (not-found found-edit #f) - (found found-edit pos)))) - (not-found found-edit #f))] - [else - (found found-edit first-pos)])))))))) - (field [dont-search #f] - [case-sensitive? (preferences:get 'framework:case-sensitive-search?)]) - (define/public (toggle-case-sensitive) - (set! case-sensitive? (not case-sensitive?)) - (preferences:set 'framework:case-sensitive-search? case-sensitive?)) - (define/public (get-case-sensitive?) case-sensitive?) - (define/public (stop-searching) - (set! dont-search #t)) - (define/public (start-searching) - (set! dont-search #f)) - - (define/override (on-focus on?) - (when on? - (let ([edit (get-searching-edit)]) - (when edit - (reset-search-anchor (get-searching-edit))))) - (super on-focus on?)) - (define/augment (after-insert x y) - (unless dont-search - (search #f)) - (inner (void) after-insert x y)) - (define/augment (after-delete x y) - (unless dont-search - (search #f)) - (inner (void) after-delete x y)) - (super-new) - (inherit set-styles-fixed) - (set-styles-fixed #t))) - - (define replace-text% - (class text:keymap% - (inherit set-styles-fixed) - (super-instantiate ()) - (set-styles-fixed #t))) - - (define find-edit #f) - (define replace-edit #f) - - (define searchable-canvas% - (class editor-canvas% - (inherit get-top-level-window set-line-count) - (define/override (on-focus x) - (when x - (set-searching-frame (get-top-level-window))) - (super on-focus x)) - (super-new (style '(hide-hscroll hide-vscroll))) - (set-line-count 2))) - - (define (init-find/replace-edits) - (unless find-edit - (set! find-edit (make-object find-text%)) - (set! replace-edit (make-object replace-text%)) - (for-each (λ (keymap) - (send keymap chain-to-keymap - (keymap:get-search) - #t)) - (list (send find-edit get-keymap) - (send replace-edit get-keymap))))) - - (define searchable-mixin - (mixin (standard-menus<%>) (searchable<%>) - (init-find/replace-edits) - (define super-root 'unitiaialized-super-root) - (define/override edit-menu:find-callback (λ (menu evt) (move-to-search-or-search) #t)) - (define/override edit-menu:create-find? (λ () #t)) - (define/override edit-menu:find-again-callback (λ (menu evt) (search-again) #t)) - (define/override edit-menu:create-find-again? (λ () #t)) - (define/override edit-menu:replace-and-find-again-callback (λ (menu evt) (replace&search) #t)) - (define/override edit-menu:replace-and-find-again-on-demand - (λ (item) (send item enable (can-replace?)))) - (define/override edit-menu:create-replace-and-find-again? (λ () #t)) - (define/override make-root-area-container - (λ (% parent) - (let* ([s-root (super make-root-area-container - vertical-panel% - parent)] - [root (make-object % s-root)]) - (set! super-root s-root) - root))) - - (define/override (on-activate on?) - (unless hidden? - (if on? - (reset-search-anchor (get-text-to-search)) - (clear-search-highlight))) - (super on-activate on?)) - - (define/public (get-text-to-search) - (error 'get-text-to-search "abstract method in searchable-mixin")) - (define/public hide-search - (opt-lambda ([startup? #f]) - (when search-gui-built? - (send super-root change-children - (λ (l) - (remove search-panel l)))) - (clear-search-highlight) - (unless startup? - (let ([canvas (send (get-text-to-search) get-canvas)]) - (when canvas - (send canvas force-display-focus #f) - (send canvas focus)))) - (set! hidden? #t))) - - (define/public (unhide-search) - (when (and hidden? - (not (preferences:get 'framework:search-using-dialog?))) - (set! hidden? #f) - - (build-search-gui-in-frame) - - (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)) - (unless (memq search-panel (send super-root get-children)) - (send super-root add-child search-panel)) - (reset-search-anchor (get-text-to-search)))) - - (define/private (undock) - (preferences:set 'framework:search-using-dialog? #t) - (hide-search) - (search-dialog this)) - - ;; pre-condition : search-gui-built? is #t - (define/private (show/hide-replace hide?) - (cond - [hide? - (send replace-canvas-panel change-children - (λ (l) null)) - (send replace-button-panel change-children (λ (l) null)) - (send middle-middle-panel change-children (λ (l) null))] - [else - (send replace-canvas-panel change-children - (λ (l) (list replace-canvas))) - (send replace-button-panel change-children - (λ (l) (list replace-button))) - (send middle-middle-panel change-children - (λ (l) (list replace&search-button - replace-all-button)))])) - - (define remove-callback - (preferences:add-callback - 'framework:search-using-dialog? - (λ (p v) - (when p - (hide-search))))) - (define/augment (on-close) - (remove-callback) - (let ([close-canvas - (λ (canvas edit) - (send canvas set-editor #f))]) - (when search-gui-built? - (close-canvas find-canvas find-edit) - (close-canvas replace-canvas replace-edit))) - (when (eq? this searching-frame) - (set-searching-frame #f)) - (inner (void) on-close)) - (public set-search-direction can-replace? replace&search replace-all replace - toggle-search-focus move-to-search-or-search move-to-search-or-reverse-search - search-again) - (define set-search-direction - (λ (x) - (set-searching-direction x) - (when dir-radio - (send dir-radio set-selection (if (eq? x 'forward) 0 1))))) - (define (can-replace?) - (let ([tx (get-text-to-search)]) - (and - tx - (not (= 0 (send replace-edit last-position))) - (let ([cmp - (if (send find-edit get-case-sensitive?) - string=? - string-ci=?)]) - (cmp - (send tx get-text - (send tx get-start-position) - (send tx get-end-position)) - (send find-edit get-text 0 (send find-edit last-position))))))) - (define (replace&search) - (let ([text (get-text-to-search)]) - (send text begin-edit-sequence) - (when (replace) - (search-again)) - (send text end-edit-sequence))) - (define (replace-all) - (let* ([replacee-edit (get-text-to-search)] - [embeded-replacee-edit (find-embedded-focus-editor replacee-edit)] - [pos (if (eq? searching-direction 'forward) - (send embeded-replacee-edit get-start-position) - (send embeded-replacee-edit get-end-position))] - [done? (if (eq? 'forward searching-direction) - (λ (x) (>= x (send replacee-edit last-position))) - (λ (x) (<= x 0)))]) - (send replacee-edit begin-edit-sequence) - (when (search-again) - (send embeded-replacee-edit set-position pos) - (let loop () - (when (send find-edit search #t #f #f) - (replace) - (loop)))) - (send replacee-edit end-edit-sequence))) - (define (replace) - (let* ([search-text (send find-edit get-text)] - [replacee-edit (find-embedded-focus-editor (get-text-to-search))] - [replacee-start (send replacee-edit get-start-position)] - [new-text (send replace-edit get-text)] - [replacee (send replacee-edit get-text - replacee-start - (send replacee-edit get-end-position))] - [cmp - (if (send find-edit get-case-sensitive?) - string=? - string-ci=?)]) - (if (cmp replacee search-text) - (begin (send replacee-edit insert new-text) - (send replacee-edit set-position - replacee-start - (+ replacee-start (string-length new-text))) - #t) - #f))) - - (define/private (find-embedded-focus-editor editor) - (let loop ([editor editor]) - (let ([s (send editor get-focus-snip)]) - (cond - [(and s (is-a? s editor-snip%)) - (let ([next-ed (send s get-editor)]) - (if next-ed - (loop next-ed) - editor))] - [else editor])))) - - (define (toggle-search-focus) - (when find-canvas - (set-searching-frame this) - (unhide-search) - (send (cond - [(send find-canvas has-focus?) - replace-canvas] - [(send replace-canvas has-focus?) - (send (get-text-to-search) get-canvas)] - [else - find-canvas]) - focus))) - (define move-to-search-or-search - (λ () - (set-searching-frame this) - (unhide-search) - (cond - [(preferences:get 'framework:search-using-dialog?) - (search-dialog this)] - [else - (if (or (send find-canvas has-focus?) - (send replace-canvas has-focus?)) - (search-again 'forward) - (send find-canvas focus))]))) - (define move-to-search-or-reverse-search - (λ () - (set-searching-frame this) - (unhide-search) - (cond - [(preferences:get 'framework:search-using-dialog?) - (search-again 'backward) - (set-searching-direction 'forward)] - [else - (if (or (send find-canvas has-focus?) - (send replace-canvas has-focus?)) - (search-again 'backward) - (send find-canvas focus))]))) - (define search-again - (opt-lambda ([direction searching-direction] [beep? #t]) - (set-searching-frame this) - (unhide-search) - (set-search-direction direction) - (send find-edit search #t beep?))) - - (define sensitive-check-box #f) - (define search-panel #f) - (define search-gui-built? #f) - (define dir-radio #f) - (define replace-canvas-panel #f) - (define find-canvas #f) - (define replace-canvas #f) - (define hidden? #t) - (define replace-button-panel #f) - (define middle-middle-panel #f) - (define replace-button #f) - (define replace&search-button #f) - (define replace-all-button #f) - - (inherit begin-container-sequence end-container-sequence) - (define/private (build-search-gui-in-frame) - (unless search-gui-built? - (set! search-gui-built? #t) - (begin-container-sequence) - (let () - (define _0 (set! search-panel (make-object horizontal-panel% super-root '(border)))) - (define left-panel (make-object vertical-panel% search-panel)) - (define _1 (set! find-canvas (make-object searchable-canvas% left-panel))) - (define _2 - (set! replace-canvas-panel (instantiate vertical-panel% () - (parent left-panel) - (stretchable-width #t) - (stretchable-height #f)))) - (define _3 - (set! replace-canvas (make-object searchable-canvas% replace-canvas-panel))) - - (define middle-left-panel (make-object vertical-pane% search-panel)) - (define _4 - (set! middle-middle-panel (make-object vertical-pane% search-panel))) - (define middle-right-panel (make-object vertical-pane% search-panel)) - - (define search-button (make-object button% - (string-constant find) - middle-left-panel - (λ args (search-again)))) - - (define _5 - (set! replace-button-panel - (instantiate vertical-panel% () - (parent middle-left-panel) - (stretchable-width #f) - (stretchable-height #f)))) - - (define _6 - (set! replace-button (make-object button% (string-constant replace) - replace-button-panel - (λ x (replace))))) - - (define _7 - (set! replace&search-button (make-object button% - (string-constant replace&find-again) - middle-middle-panel - (λ x (replace&search))))) - - (define _8 - (set! replace-all-button (make-object button% - (string-constant replace-to-end) - middle-middle-panel - (λ x (replace-all))))) - (define _9 - (set! dir-radio (make-object radio-box% - #f - (list (string-constant forward) - (string-constant backward)) - middle-right-panel - (λ (dir-radio evt) - (let ([forward (if (= (send dir-radio get-selection) 0) - 'forward - 'backward)]) - (set-search-direction forward) - (reset-search-anchor (get-text-to-search))))))) - - (define _10 + (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) + (set! searching-frame frame)) + + (define find-text% + (class text:keymap% + (inherit get-text) + (define/private (get-searching-edit) + (and searching-frame + (send searching-frame get-text-to-search))) + (define/public search + (opt-lambda ([reset-search-anchor? #t] [beep? #t] [wrap? #t]) + (when searching-frame + (let* ([string (get-text)] + [top-searching-edit (get-searching-edit)] + + [searching-edit (let ([focus-snip (send top-searching-edit get-focus-snip)]) + (if focus-snip + (send focus-snip get-editor) + top-searching-edit))] + + [not-found + (λ (found-edit skip-beep?) + (send found-edit set-position search-anchor) + (when (and beep? + (not skip-beep?)) + (bell)) + #f)] + [found + (λ (edit first-pos) + (let ([last-pos ((if (eq? searching-direction 'forward) + -) + first-pos (string-length string))]) + (send* edit + (set-caret-owner #f 'display) + (set-position + (min first-pos last-pos) + (max first-pos last-pos) + #f #t 'local)) + #t))]) + (if (string=? string "") + (not-found top-searching-edit #t) (begin - (set! sensitive-check-box (make-object check-box% - (string-constant find-case-sensitive) - middle-right-panel - (λ (x y) (send find-edit toggle-case-sensitive)))) - (send sensitive-check-box set-value (get-field case-sensitive? find-edit)))) - - - (define hide/undock-pane (make-object horizontal-panel% middle-right-panel)) - (define hide-button (make-object button% (string-constant hide) - hide/undock-pane - (λ args (hide-search)))) - (define undock-button (make-object button% (string-constant undock) - hide/undock-pane - (λ args (undock)))) - (let ([align - (λ (x y) - (let ([m (max (send x get-width) - (send y get-width))]) - (send x min-width m) - (send y min-width m)))]) - (align search-button replace-button) - (align replace&search-button replace-all-button)) - (for-each (λ (x) (send x set-alignment 'center 'center)) - (list middle-left-panel middle-middle-panel)) - (for-each (λ (x) (send x stretchable-height #f)) - (list search-panel middle-left-panel middle-middle-panel middle-right-panel)) - (for-each (λ (x) (send x stretchable-width #f)) - (list middle-left-panel middle-middle-panel middle-right-panel)) - (send find-canvas set-editor find-edit) - (send find-canvas stretchable-height #t) - (send replace-canvas set-editor replace-edit)) - (end-container-sequence))) - - (super-instantiate ()) - - (hide-search #t))) + (when reset-search-anchor? + (reset-search-anchor searching-edit)) + (let-values ([(found-edit first-pos) + (find-string-embedded + searching-edit + string + searching-direction + search-anchor + 'eof #t case-sensitive? #t)]) + (cond + [(not first-pos) + (if wrap? + (begin + (let-values ([(found-edit pos) + (find-string-embedded + top-searching-edit + string + searching-direction + (if (eq? 'forward searching-direction) + 0 + (send searching-edit last-position)) + 'eof #t case-sensitive? #f)]) + (if (not pos) + (not-found found-edit #f) + (found found-edit pos)))) + (not-found found-edit #f))] + [else + (found found-edit first-pos)])))))))) + (field [dont-search #f] + [case-sensitive? (preferences:get 'framework:case-sensitive-search?)]) + (define/public (toggle-case-sensitive) + (set! case-sensitive? (not case-sensitive?)) + (preferences:set 'framework:case-sensitive-search? case-sensitive?)) + (define/public (get-case-sensitive?) case-sensitive?) + (define/public (stop-searching) + (set! dont-search #t)) + (define/public (start-searching) + (set! dont-search #f)) - (define searchable-text<%> (interface (searchable<%> text<%>))) + (define/override (on-focus on?) + (when on? + (let ([edit (get-searching-edit)]) + (when edit + (reset-search-anchor (get-searching-edit))))) + (super on-focus on?)) + (define/augment (after-insert x y) + (unless dont-search + (search #f)) + (inner (void) after-insert x y)) + (define/augment (after-delete x y) + (unless dont-search + (search #f)) + (inner (void) after-delete x y)) + (super-new) + (inherit set-styles-fixed) + (set-styles-fixed #t))) + + (define replace-text% + (class text:keymap% + (inherit set-styles-fixed) + (super-instantiate ()) + (set-styles-fixed #t))) + + (define find-edit #f) + (define replace-edit #f) + + (define searchable-canvas% + (class editor-canvas% + (inherit get-top-level-window set-line-count) + (define/override (on-focus x) + (when x + (set-searching-frame (get-top-level-window))) + (super on-focus x)) + (super-new (style '(hide-hscroll hide-vscroll))) + (set-line-count 2))) + + (define (init-find/replace-edits) + (unless find-edit + (set! find-edit (make-object find-text%)) + (set! replace-edit (make-object replace-text%)) + (for-each (λ (keymap) + (send keymap chain-to-keymap + (keymap:get-search) + #t)) + (list (send find-edit get-keymap) + (send replace-edit get-keymap))))) + + (define searchable-mixin + (mixin (standard-menus<%>) (searchable<%>) + (init-find/replace-edits) + (define super-root 'unitiaialized-super-root) + (define/override edit-menu:find-callback (λ (menu evt) (move-to-search-or-search) #t)) + (define/override edit-menu:create-find? (λ () #t)) + (define/override edit-menu:find-again-callback (λ (menu evt) (search-again) #t)) + (define/override edit-menu:create-find-again? (λ () #t)) + (define/override edit-menu:replace-and-find-again-callback (λ (menu evt) (replace&search) #t)) + (define/override edit-menu:replace-and-find-again-on-demand + (λ (item) (send item enable (can-replace?)))) + (define/override edit-menu:create-replace-and-find-again? (λ () #t)) + (define/override make-root-area-container + (λ (% parent) + (let* ([s-root (super make-root-area-container + vertical-panel% + parent)] + [root (make-object % s-root)]) + (set! super-root s-root) + root))) - (define searchable-text-mixin - (mixin (text<%> searchable<%>) (searchable-text<%>) - (inherit get-editor) - (define/override (get-text-to-search) - (get-editor)) - (define/override (get-editor<%>) text:searching<%>) - (define/override (get-editor%) text:searching%) - (super-instantiate ()))) + (define/override (on-activate on?) + (unless hidden? + (if on? + (reset-search-anchor (get-text-to-search)) + (clear-search-highlight))) + (super on-activate on?)) - (define memory-text% (class text% (super-new))) - (define memory-text (make-object memory-text%)) - (define memory-canvas #f) - (send memory-text hide-caret #t) - (define show-memory-text? - (or (with-handlers ([exn:fail:filesystem? - (λ (x) #f)]) - (directory-exists? (collection-path "repos-time-stamp"))) - (with-handlers ([exn:fail:filesystem? - (λ (x) #f)]) - (let ([fw (collection-path "framework")]) - (or (directory-exists? (build-path fw ".svn")) - (directory-exists? (build-path fw "CVS"))))))) + (define/public (get-text-to-search) + (error 'get-text-to-search "abstract method in searchable-mixin")) + (define/public hide-search + (opt-lambda ([startup? #f]) + (when search-gui-built? + (send super-root change-children + (λ (l) + (remove search-panel l)))) + (clear-search-highlight) + (unless startup? + (let ([canvas (send (get-text-to-search) get-canvas)]) + (when canvas + (send canvas force-display-focus #f) + (send canvas focus)))) + (set! hidden? #t))) - (define bday-click-canvas% - (class canvas% - (define/override (on-event evt) + (define/public (unhide-search) + (when (and hidden? + (not (preferences:get 'framework:search-using-dialog?))) + (set! hidden? #f) + + (build-search-gui-in-frame) + + (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)) + (unless (memq search-panel (send super-root get-children)) + (send super-root add-child search-panel)) + (reset-search-anchor (get-text-to-search)))) + + (define/private (undock) + (preferences:set 'framework:search-using-dialog? #t) + (hide-search) + (search-dialog this)) + + ;; pre-condition : search-gui-built? is #t + (define/private (show/hide-replace hide?) + (cond + [hide? + (send replace-canvas-panel change-children + (λ (l) null)) + (send replace-button-panel change-children (λ (l) null)) + (send middle-middle-panel change-children (λ (l) null))] + [else + (send replace-canvas-panel change-children + (λ (l) (list replace-canvas))) + (send replace-button-panel change-children + (λ (l) (list replace-button))) + (send middle-middle-panel change-children + (λ (l) (list replace&search-button + replace-all-button)))])) + + (define remove-callback + (preferences:add-callback + 'framework:search-using-dialog? + (λ (p v) + (when p + (hide-search))))) + (define/augment (on-close) + (remove-callback) + (let ([close-canvas + (λ (canvas edit) + (send canvas set-editor #f))]) + (when search-gui-built? + (close-canvas find-canvas find-edit) + (close-canvas replace-canvas replace-edit))) + (when (eq? this searching-frame) + (set-searching-frame #f)) + (inner (void) on-close)) + (public set-search-direction can-replace? replace&search replace-all replace + toggle-search-focus move-to-search-or-search move-to-search-or-reverse-search + search-again) + (define set-search-direction + (λ (x) + (set-searching-direction x) + (when dir-radio + (send dir-radio set-selection (if (eq? x 'forward) 0 1))))) + (define (can-replace?) + (let ([tx (get-text-to-search)]) + (and + tx + (not (= 0 (send replace-edit last-position))) + (let ([cmp + (if (send find-edit get-case-sensitive?) + string=? + string-ci=?)]) + (cmp + (send tx get-text + (send tx get-start-position) + (send tx get-end-position)) + (send find-edit get-text 0 (send find-edit last-position))))))) + (define (replace&search) + (let ([text (get-text-to-search)]) + (send text begin-edit-sequence) + (when (replace) + (search-again)) + (send text end-edit-sequence))) + (define (replace-all) + (let* ([replacee-edit (get-text-to-search)] + [embeded-replacee-edit (find-embedded-focus-editor replacee-edit)] + [pos (if (eq? searching-direction 'forward) + (send embeded-replacee-edit get-start-position) + (send embeded-replacee-edit get-end-position))] + [done? (if (eq? 'forward searching-direction) + (λ (x) (>= x (send replacee-edit last-position))) + (λ (x) (<= x 0)))]) + (send replacee-edit begin-edit-sequence) + (when (search-again) + (send embeded-replacee-edit set-position pos) + (let loop () + (when (send find-edit search #t #f #f) + (replace) + (loop)))) + (send replacee-edit end-edit-sequence))) + (define (replace) + (let* ([search-text (send find-edit get-text)] + [replacee-edit (find-embedded-focus-editor (get-text-to-search))] + [replacee-start (send replacee-edit get-start-position)] + [new-text (send replace-edit get-text)] + [replacee (send replacee-edit get-text + replacee-start + (send replacee-edit get-end-position))] + [cmp + (if (send find-edit get-case-sensitive?) + string=? + string-ci=?)]) + (if (cmp replacee search-text) + (begin (send replacee-edit insert new-text) + (send replacee-edit set-position + replacee-start + (+ replacee-start (string-length new-text))) + #t) + #f))) + + (define/private (find-embedded-focus-editor editor) + (let loop ([editor editor]) + (let ([s (send editor get-focus-snip)]) (cond - [(and (mrf-bday?) - (send evt button-up?)) - (message-box (string-constant drscheme) - (string-constant happy-birthday-matthew))] - [else (super on-event evt)])) - (super-instantiate ()))) + [(and s (is-a? s editor-snip%)) + (let ([next-ed (send s get-editor)]) + (if next-ed + (loop next-ed) + editor))] + [else editor])))) - (define basic% (register-group-mixin (basic-mixin frame%))) - (define size-pref% (size-pref-mixin basic%)) - (define info% (info-mixin basic%)) - (define text-info% (text-info-mixin info%)) - (define pasteboard-info% (pasteboard-info-mixin text-info%)) - (define status-line% (status-line-mixin text-info%)) - (define standard-menus% (standard-menus-mixin status-line%)) - (define editor% (editor-mixin standard-menus%)) - (define open-here% (open-here-mixin editor%)) + (define (toggle-search-focus) + (when find-canvas + (set-searching-frame this) + (unhide-search) + (send (cond + [(send find-canvas has-focus?) + replace-canvas] + [(send replace-canvas has-focus?) + (send (get-text-to-search) get-canvas)] + [else + find-canvas]) + focus))) + (define move-to-search-or-search + (λ () + (set-searching-frame this) + (unhide-search) + (cond + [(preferences:get 'framework:search-using-dialog?) + (search-dialog this)] + [else + (if (or (send find-canvas has-focus?) + (send replace-canvas has-focus?)) + (search-again 'forward) + (send find-canvas focus))]))) + (define move-to-search-or-reverse-search + (λ () + (set-searching-frame this) + (unhide-search) + (cond + [(preferences:get 'framework:search-using-dialog?) + (search-again 'backward) + (set-searching-direction 'forward)] + [else + (if (or (send find-canvas has-focus?) + (send replace-canvas has-focus?)) + (search-again 'backward) + (send find-canvas focus))]))) + (define search-again + (opt-lambda ([direction searching-direction] [beep? #t]) + (set-searching-frame this) + (unhide-search) + (set-search-direction direction) + (send find-edit search #t beep?))) - (define -text% (text-mixin open-here%)) - (define searchable% (searchable-text-mixin (searchable-mixin -text%))) - (define delegate% (delegate-mixin searchable%)) + (define sensitive-check-box #f) + (define search-panel #f) + (define search-gui-built? #f) + (define dir-radio #f) + (define replace-canvas-panel #f) + (define find-canvas #f) + (define replace-canvas #f) + (define hidden? #t) + (define replace-button-panel #f) + (define middle-middle-panel #f) + (define replace-button #f) + (define replace&search-button #f) + (define replace-all-button #f) - (define -pasteboard% (pasteboard-mixin open-here%))) + (inherit begin-container-sequence end-container-sequence) + (define/private (build-search-gui-in-frame) + (unless search-gui-built? + (set! search-gui-built? #t) + (begin-container-sequence) + (let () + (define _0 (set! search-panel (make-object horizontal-panel% super-root '(border)))) + (define left-panel (make-object vertical-panel% search-panel)) + (define _1 (set! find-canvas (make-object searchable-canvas% left-panel))) + (define _2 + (set! replace-canvas-panel (instantiate vertical-panel% () + (parent left-panel) + (stretchable-width #t) + (stretchable-height #f)))) + (define _3 + (set! replace-canvas (make-object searchable-canvas% replace-canvas-panel))) + + (define middle-left-panel (make-object vertical-pane% search-panel)) + (define _4 + (set! middle-middle-panel (make-object vertical-pane% search-panel))) + (define middle-right-panel (make-object vertical-pane% search-panel)) + + (define search-button (make-object button% + (string-constant find) + middle-left-panel + (λ args (search-again)))) + + (define _5 + (set! replace-button-panel + (instantiate vertical-panel% () + (parent middle-left-panel) + (stretchable-width #f) + (stretchable-height #f)))) + + (define _6 + (set! replace-button (make-object button% (string-constant replace) + replace-button-panel + (λ x (replace))))) + + (define _7 + (set! replace&search-button (make-object button% + (string-constant replace&find-again) + middle-middle-panel + (λ x (replace&search))))) + + (define _8 + (set! replace-all-button (make-object button% + (string-constant replace-to-end) + middle-middle-panel + (λ x (replace-all))))) + (define _9 + (set! dir-radio (make-object radio-box% + #f + (list (string-constant forward) + (string-constant backward)) + middle-right-panel + (λ (dir-radio evt) + (let ([forward (if (= (send dir-radio get-selection) 0) + 'forward + 'backward)]) + (set-search-direction forward) + (reset-search-anchor (get-text-to-search))))))) + + (define _10 + (begin + (set! sensitive-check-box (make-object check-box% + (string-constant find-case-sensitive) + middle-right-panel + (λ (x y) (send find-edit toggle-case-sensitive)))) + (send sensitive-check-box set-value (get-field case-sensitive? find-edit)))) + + + (define hide/undock-pane (make-object horizontal-panel% middle-right-panel)) + (define hide-button (make-object button% (string-constant hide) + hide/undock-pane + (λ args (hide-search)))) + (define undock-button (make-object button% (string-constant undock) + hide/undock-pane + (λ args (undock)))) + (let ([align + (λ (x y) + (let ([m (max (send x get-width) + (send y get-width))]) + (send x min-width m) + (send y min-width m)))]) + (align search-button replace-button) + (align replace&search-button replace-all-button)) + (for-each (λ (x) (send x set-alignment 'center 'center)) + (list middle-left-panel middle-middle-panel)) + (for-each (λ (x) (send x stretchable-height #f)) + (list search-panel middle-left-panel middle-middle-panel middle-right-panel)) + (for-each (λ (x) (send x stretchable-width #f)) + (list middle-left-panel middle-middle-panel middle-right-panel)) + (send find-canvas set-editor find-edit) + (send find-canvas stretchable-height #t) + (send replace-canvas set-editor replace-edit)) + (end-container-sequence))) + + (super-instantiate ()) + + (hide-search #t))) + + (define searchable-text<%> (interface (searchable<%> text<%>))) + + (define searchable-text-mixin + (mixin (text<%> searchable<%>) (searchable-text<%>) + (inherit get-editor) + (define/override (get-text-to-search) + (get-editor)) + (define/override (get-editor<%>) text:searching<%>) + (define/override (get-editor%) text:searching%) + (super-instantiate ()))) + + (define memory-text% (class text% (super-new))) + (define memory-text (make-object memory-text%)) + (define memory-canvas #f) + (send memory-text hide-caret #t) + (define show-memory-text? + (or (with-handlers ([exn:fail:filesystem? + (λ (x) #f)]) + (directory-exists? (collection-path "repos-time-stamp"))) + (with-handlers ([exn:fail:filesystem? + (λ (x) #f)]) + (let ([fw (collection-path "framework")]) + (or (directory-exists? (build-path fw ".svn")) + (directory-exists? (build-path fw "CVS"))))))) + + (define bday-click-canvas% + (class canvas% + (define/override (on-event evt) + (cond + [(and (mrf-bday?) + (send evt button-up?)) + (message-box (string-constant drscheme) + (string-constant happy-birthday-matthew))] + [else (super on-event evt)])) + (super-instantiate ()))) + + (define basic% (register-group-mixin (basic-mixin frame%))) + (define size-pref% (size-pref-mixin basic%)) + (define info% (info-mixin basic%)) + (define text-info% (text-info-mixin info%)) + (define pasteboard-info% (pasteboard-info-mixin text-info%)) + (define status-line% (status-line-mixin text-info%)) + (define standard-menus% (standard-menus-mixin status-line%)) + (define editor% (editor-mixin standard-menus%)) + (define open-here% (open-here-mixin editor%)) + + (define -text% (text-mixin open-here%)) + (define searchable% (searchable-text-mixin (searchable-mixin -text%))) + (define delegate% (delegate-mixin searchable%)) + + (define -pasteboard% (pasteboard-mixin open-here%))) diff --git a/collects/framework/private/gen-standard-menus.ss b/collects/framework/private/gen-standard-menus.ss index dad38028..cf10e2b4 100644 --- a/collects/framework/private/gen-standard-menus.ss +++ b/collects/framework/private/gen-standard-menus.ss @@ -56,18 +56,18 @@ (and (,create-menu-item-name) ,(if (a-submenu-item? item) `(instantiate (get-menu%) () - (label (,(an-item->string-name item))) - (parent ,(menu-item-menu-name item)) - (help-string (,(an-item->help-string-name item))) - (demand-callback (λ (menu-item) (,(an-item->on-demand-name item) menu-item)))) + (label (,(an-item->string-name item))) + (parent ,(menu-item-menu-name item)) + (help-string (,(an-item->help-string-name item))) + (demand-callback (λ (menu-item) (,(an-item->on-demand-name item) menu-item)))) `(instantiate (get-menu-item%) () - (label (,(an-item->string-name item))) - (parent ,(menu-item-menu-name item)) - (callback (let ([,callback-name (λ (item evt) (,callback-name item evt))]) - ,callback-name)) - (shortcut ,key) - (help-string (,(an-item->help-string-name item))) - (demand-callback (λ (menu-item) (,(an-item->on-demand-name item) menu-item)))))))))) + (label (,(an-item->string-name item))) + (parent ,(menu-item-menu-name item)) + (callback (let ([,callback-name (λ (item evt) (,callback-name item evt))]) + ,callback-name)) + (shortcut ,key) + (help-string (,(an-item->help-string-name item))) + (demand-callback (λ (menu-item) (,(an-item->on-demand-name item) menu-item)))))))))) ;; build-after-super-clause : ((X -> symbol) -> X -> (listof clause)) (define build-after-super-clause @@ -95,7 +95,7 @@ (list)] [(generic-method? x) null])) - + ;; build-before-super-generic-clause : generic -> (listof clause) (define (build-before-super-generic-clause generic) (cond @@ -145,42 +145,42 @@ (pretty-print `(define standard-menus-mixin - (mixin (basic<%>) (standard-menus<%>) - (inherit on-menu-char on-traverse-char) - - (define remove-prefs-callback - (preferences:add-callback - 'framework:menu-bindings - (λ (p v) - (let loop ([menu (get-menu-bar)]) - (when (is-a? menu menu:can-restore<%>) - (if v - (send menu restore-keybinding) - (send menu set-shortcut #f))) - (when (is-a? menu menu:can-restore-underscore<%>) - (if v - (send menu restore-underscores) - (send menu erase-underscores))) - (when (is-a? menu menu-item-container<%>) - (for-each loop (send menu get-items))))))) - - (inherit get-menu-bar show can-close? get-edit-target-object) - ,@(apply append (map (λ (x) - (cond - [(between? x) (build-before-super-between-clause x)] - [(or (after? x) (before? x)) (build-before-super-before/after-clause x)] - [(an-item? x) (build-before-super-item-clause x)] - [(generic? x) (build-before-super-generic-clause x)])) - items)) - (super-instantiate ()) - ,@(apply append (map (λ (x) - (cond - [(between? x) (build-after-super-between-clause x)] - [(an-item? x) (build-after-super-item-clause x)] - [(or (after? x) (before? x)) (build-after-super-before/after-clause x)] - [(generic? x) (build-after-super-generic-clause x)])) - items)) - (reorder-menus this))) + (mixin (basic<%>) (standard-menus<%>) + (inherit on-menu-char on-traverse-char) + + (define remove-prefs-callback + (preferences:add-callback + 'framework:menu-bindings + (λ (p v) + (let loop ([menu (get-menu-bar)]) + (when (is-a? menu menu:can-restore<%>) + (if v + (send menu restore-keybinding) + (send menu set-shortcut #f))) + (when (is-a? menu menu:can-restore-underscore<%>) + (if v + (send menu restore-underscores) + (send menu erase-underscores))) + (when (is-a? menu menu-item-container<%>) + (for-each loop (send menu get-items))))))) + + (inherit get-menu-bar show can-close? get-edit-target-object) + ,@(apply append (map (λ (x) + (cond + [(between? x) (build-before-super-between-clause x)] + [(or (after? x) (before? x)) (build-before-super-before/after-clause x)] + [(an-item? x) (build-before-super-item-clause x)] + [(generic? x) (build-before-super-generic-clause x)])) + items)) + (super-instantiate ()) + ,@(apply append (map (λ (x) + (cond + [(between? x) (build-after-super-between-clause x)] + [(an-item? x) (build-after-super-item-clause x)] + [(or (after? x) (before? x)) (build-after-super-before/after-clause x)] + [(generic? x) (build-after-super-generic-clause x)])) + items)) + (reorder-menus this))) port)) 'text 'truncate)) diff --git a/collects/framework/private/group.ss b/collects/framework/private/group.ss index ba41b004..e746a61b 100644 --- a/collects/framework/private/group.ss +++ b/collects/framework/private/group.ss @@ -3,12 +3,12 @@ (require (lib "string-constant.ss" "string-constants") (lib "class.ss") "sig.ss" - "../preferences.ss" + "../preferences.ss" "../gui-utils.ss" (lib "mred-sig.ss" "mred") (lib "list.ss") (lib "file.ss")) - + (import mred^ [prefix application: framework:application^] [prefix frame: framework:frame^] @@ -16,319 +16,319 @@ [prefix canvas: framework:canvas^] [prefix menu: framework:menu^]) (export framework:group^) + + (define-struct frame (frame id)) + + (define mdi-parent #f) + + (define % + (class object% - (define-struct frame (frame id)) + [define active-frame #f] + [define most-recent-window-box (make-weak-box #f)] + [define frame-counter 0] + [define frames null] + [define todo-to-new-frames void] - (define mdi-parent #f) + [define windows-menus null] - (define % - (class object% + ;; get-windows-menu : (is-a?/c frame%) -> (union false? (is-a?/c menu%)) + (define/private (get-windows-menu frame) + (let ([menu-bar (send frame get-menu-bar)]) + (and menu-bar + (let ([menus (send menu-bar get-items)]) + (ormap (λ (x) + (if (string=? (string-constant windows-menu) + (send x get-plain-label)) + x + #f)) + menus))))) + + (define/private (insert-windows-menu frame) + (let ([menu (get-windows-menu frame)]) + (when menu + (set! windows-menus (cons menu windows-menus))))) + + (define/private (remove-windows-menu frame) + (let ([menu (get-windows-menu frame)]) - [define active-frame #f] - [define most-recent-window-box (make-weak-box #f)] - [define frame-counter 0] - [define frames null] - [define todo-to-new-frames void] - - [define windows-menus null] - - ;; get-windows-menu : (is-a?/c frame%) -> (union false? (is-a?/c menu%)) - (define/private (get-windows-menu frame) - (let ([menu-bar (send frame get-menu-bar)]) - (and menu-bar - (let ([menus (send menu-bar get-items)]) - (ormap (λ (x) - (if (string=? (string-constant windows-menu) - (send x get-plain-label)) - x - #f)) - menus))))) - - (define/private (insert-windows-menu frame) - (let ([menu (get-windows-menu frame)]) - (when menu - (set! windows-menus (cons menu windows-menus))))) - - (define/private (remove-windows-menu frame) - (let ([menu (get-windows-menu frame)]) - - (when menu - ;; to help the (conservative) gc. - (for-each (λ (i) (send i delete)) (send menu get-items)) - - (set! windows-menus - (remove - menu - windows-menus - eq?))))) - - (define/private (update-windows-menus) - (let* ([windows (length windows-menus)] - [default-name (string-constant untitled)] - [get-name - (λ (frame) - (let ([label (send frame get-label)]) - (if (string=? label "") - (if (method-in-interface? 'get-entire-label (object-interface frame)) - (let ([label (send frame get-entire-label)]) - (if (string=? label "") - default-name - label)) - default-name) - label)))] - [sorted/visible-frames - (sort - (filter (λ (x) (send (frame-frame x) is-shown?)) frames) - (λ (f1 f2) - (string-ci<=? (get-name (frame-frame f1)) - (get-name (frame-frame f2)))))]) - (for-each - (λ (menu) - (for-each (λ (item) (send item delete)) (send menu get-items)) - (when (eq? (system-type) 'macosx) - (new menu:can-restore-menu-item% - [label (string-constant minimize)] - [parent menu] - [callback (λ (x y) (send (send (send menu get-parent) get-frame) iconize #t))] - [shortcut #\m]) - (new menu:can-restore-menu-item% - [label (string-constant zoom)] - [parent menu] - [callback (λ (x y) - (let ([frame (send (send menu get-parent) get-frame)]) - (send frame maximize (not (send frame is-maximized?)))))]) - (make-object separator-menu-item% menu)) - (instantiate menu:can-restore-menu-item% () - (label (string-constant bring-frame-to-front...)) - (parent menu) - (callback (λ (x y) (choose-a-frame (send (send menu get-parent) get-frame)))) - (shortcut #\j)) - (instantiate menu:can-restore-menu-item% () - (label (string-constant most-recent-window)) - (parent menu) - (callback (λ (x y) (most-recent-window-to-front))) - (shortcut #\')) - (make-object separator-menu-item% menu) - (for-each - (λ (frame) - (let ([frame (frame-frame frame)]) - (make-object menu-item% - (regexp-replace* - #rx"&" - (gui-utils:trim-string (get-name frame) 200) - "&&") - menu - (λ (_1 _2) - (send frame show #t))))) - sorted/visible-frames)) - windows-menus))) - - ;; most-recent-window-to-front : -> void? - ;; brings the most recent window to the front - (define/private (most-recent-window-to-front) - (let ([most-recent-window (weak-box-value most-recent-window-box)]) - (when most-recent-window - (send most-recent-window show #t)))) - - (define/private (update-close-menu-item-state) - (let* ([set-close-menu-item-state! - (λ (frame state) - (when (is-a? frame frame:standard-menus<%>) - (let ([close-menu-item (send frame file-menu:get-close-menu)]) - (when close-menu-item - (send close-menu-item enable state)))))]) - (if (eq? (length frames) 1) - (set-close-menu-item-state! (car frames) #f) - (for-each (λ (a-frame) - (set-close-menu-item-state! a-frame #t)) - frames)))) - - (field [open-here-frame #f]) - (define/public (set-open-here-frame fr) (set! open-here-frame fr)) - (define/public (get-open-here-frame) - (cond - [open-here-frame open-here-frame] - [else - (let ([candidates - (filter (λ (x) (is-a? (frame-frame x) frame:open-here<%>)) - frames)]) - (if (null? candidates) - #f - (frame-frame (car candidates))))])) - - (public get-mdi-parent frame-label-changed for-each-frame - get-active-frame set-active-frame insert-frame - remove-frame clear on-close-all can-close-all? locate-file get-frames - frame-shown/hidden) - (define (get-mdi-parent) - (when (and (eq? (system-type) 'windows) - (preferences:get 'framework:windows-mdi) - (not mdi-parent)) - (set! mdi-parent (make-object frame% (application:current-app-name) - #f #f #f #f #f - '(mdi-parent))) - (send mdi-parent show #t)) - mdi-parent) - - (define (get-frames) (map frame-frame frames)) - - (define (frame-label-changed frame) - (when (memq frame (map frame-frame frames)) - (update-windows-menus))) - - (define (frame-shown/hidden frame) - (when (memq frame (map frame-frame frames)) - (update-windows-menus))) - - (define (for-each-frame f) - (for-each (λ (x) (f (frame-frame x))) frames) - (set! todo-to-new-frames - (let ([old todo-to-new-frames]) - (λ (frame) (old frame) (f frame))))) - - (define (get-active-frame) + (when menu + ;; to help the (conservative) gc. + (for-each (λ (i) (send i delete)) (send menu get-items)) + + (set! windows-menus + (remove + menu + windows-menus + eq?))))) + + (define/private (update-windows-menus) + (let* ([windows (length windows-menus)] + [default-name (string-constant untitled)] + [get-name + (λ (frame) + (let ([label (send frame get-label)]) + (if (string=? label "") + (if (method-in-interface? 'get-entire-label (object-interface frame)) + (let ([label (send frame get-entire-label)]) + (if (string=? label "") + default-name + label)) + default-name) + label)))] + [sorted/visible-frames + (sort + (filter (λ (x) (send (frame-frame x) is-shown?)) frames) + (λ (f1 f2) + (string-ci<=? (get-name (frame-frame f1)) + (get-name (frame-frame f2)))))]) + (for-each + (λ (menu) + (for-each (λ (item) (send item delete)) (send menu get-items)) + (when (eq? (system-type) 'macosx) + (new menu:can-restore-menu-item% + [label (string-constant minimize)] + [parent menu] + [callback (λ (x y) (send (send (send menu get-parent) get-frame) iconize #t))] + [shortcut #\m]) + (new menu:can-restore-menu-item% + [label (string-constant zoom)] + [parent menu] + [callback (λ (x y) + (let ([frame (send (send menu get-parent) get-frame)]) + (send frame maximize (not (send frame is-maximized?)))))]) + (make-object separator-menu-item% menu)) + (instantiate menu:can-restore-menu-item% () + (label (string-constant bring-frame-to-front...)) + (parent menu) + (callback (λ (x y) (choose-a-frame (send (send menu get-parent) get-frame)))) + (shortcut #\j)) + (instantiate menu:can-restore-menu-item% () + (label (string-constant most-recent-window)) + (parent menu) + (callback (λ (x y) (most-recent-window-to-front))) + (shortcut #\')) + (make-object separator-menu-item% menu) + (for-each + (λ (frame) + (let ([frame (frame-frame frame)]) + (make-object menu-item% + (regexp-replace* + #rx"&" + (gui-utils:trim-string (get-name frame) 200) + "&&") + menu + (λ (_1 _2) + (send frame show #t))))) + sorted/visible-frames)) + windows-menus))) + + ;; most-recent-window-to-front : -> void? + ;; brings the most recent window to the front + (define/private (most-recent-window-to-front) + (let ([most-recent-window (weak-box-value most-recent-window-box)]) + (when most-recent-window + (send most-recent-window show #t)))) + + (define/private (update-close-menu-item-state) + (let* ([set-close-menu-item-state! + (λ (frame state) + (when (is-a? frame frame:standard-menus<%>) + (let ([close-menu-item (send frame file-menu:get-close-menu)]) + (when close-menu-item + (send close-menu-item enable state)))))]) + (if (eq? (length frames) 1) + (set-close-menu-item-state! (car frames) #f) + (for-each (λ (a-frame) + (set-close-menu-item-state! a-frame #t)) + frames)))) + + (field [open-here-frame #f]) + (define/public (set-open-here-frame fr) (set! open-here-frame fr)) + (define/public (get-open-here-frame) + (cond + [open-here-frame open-here-frame] + [else + (let ([candidates + (filter (λ (x) (is-a? (frame-frame x) frame:open-here<%>)) + frames)]) + (if (null? candidates) + #f + (frame-frame (car candidates))))])) + + (public get-mdi-parent frame-label-changed for-each-frame + get-active-frame set-active-frame insert-frame + remove-frame clear on-close-all can-close-all? locate-file get-frames + frame-shown/hidden) + (define (get-mdi-parent) + (when (and (eq? (system-type) 'windows) + (preferences:get 'framework:windows-mdi) + (not mdi-parent)) + (set! mdi-parent (make-object frame% (application:current-app-name) + #f #f #f #f #f + '(mdi-parent))) + (send mdi-parent show #t)) + mdi-parent) + + (define (get-frames) (map frame-frame frames)) + + (define (frame-label-changed frame) + (when (memq frame (map frame-frame frames)) + (update-windows-menus))) + + (define (frame-shown/hidden frame) + (when (memq frame (map frame-frame frames)) + (update-windows-menus))) + + (define (for-each-frame f) + (for-each (λ (x) (f (frame-frame x))) frames) + (set! todo-to-new-frames + (let ([old todo-to-new-frames]) + (λ (frame) (old frame) (f frame))))) + + (define (get-active-frame) + (cond + [active-frame active-frame] + [(null? frames) #f] + [else (frame-frame (car frames))])) + + (define (set-active-frame f) + (when (and active-frame + (not (eq? active-frame f))) + (set! most-recent-window-box (make-weak-box active-frame))) + (set! active-frame f)) + + (define (insert-frame new-frame) + (unless (memf (λ (fr) (eq? (frame-frame fr) new-frame)) + frames) + (set! frame-counter (add1 frame-counter)) + (let ([new-frames (cons (make-frame new-frame frame-counter) + frames)]) + (set! frames new-frames) + (update-close-menu-item-state) + (insert-windows-menu new-frame) + (update-windows-menus)) + (todo-to-new-frames new-frame))) + + (define (remove-frame f) + (when (eq? f active-frame) + (set! active-frame #f)) + (let ([new-frames + (remove + f frames + (λ (f fr) (eq? f (frame-frame fr))))]) + (set! frames new-frames) + (update-close-menu-item-state) + (remove-windows-menu f) + (update-windows-menus))) + + (define (clear) + (set! frames null) + #t) + + (define (on-close-all) + (for-each (λ (f) + (let ([frame (frame-frame f)]) + (send frame on-close) + (send frame show #f))) + frames)) + + (define (can-close-all?) + (andmap (λ (f) + (let ([frame (frame-frame f)]) + (send frame can-close?))) + frames)) + + (define (locate-file name) + (let* ([normalized + ;; allow for the possiblity of filenames that are urls + (with-handlers ([(λ (x) #t) + (λ (x) name)]) + (normal-case-path + (normalize-path name)))] + [test-frame + (λ (frame) + (and (is-a? frame frame:basic<%>) + (send frame editing-this-file? normalized)))]) + (let loop ([frames frames]) (cond - [active-frame active-frame] [(null? frames) #f] - [else (frame-frame (car frames))])) - - (define (set-active-frame f) - (when (and active-frame - (not (eq? active-frame f))) - (set! most-recent-window-box (make-weak-box active-frame))) - (set! active-frame f)) - - (define (insert-frame new-frame) - (unless (memf (λ (fr) (eq? (frame-frame fr) new-frame)) - frames) - (set! frame-counter (add1 frame-counter)) - (let ([new-frames (cons (make-frame new-frame frame-counter) - frames)]) - (set! frames new-frames) - (update-close-menu-item-state) - (insert-windows-menu new-frame) - (update-windows-menus)) - (todo-to-new-frames new-frame))) - - (define (remove-frame f) - (when (eq? f active-frame) - (set! active-frame #f)) - (let ([new-frames - (remove - f frames - (λ (f fr) (eq? f (frame-frame fr))))]) - (set! frames new-frames) - (update-close-menu-item-state) - (remove-windows-menu f) - (update-windows-menus))) - - (define (clear) - (set! frames null) - #t) - - (define (on-close-all) - (for-each (λ (f) - (let ([frame (frame-frame f)]) - (send frame on-close) - (send frame show #f))) - frames)) - - (define (can-close-all?) - (andmap (λ (f) - (let ([frame (frame-frame f)]) - (send frame can-close?))) - frames)) - - (define (locate-file name) - (let* ([normalized - ;; allow for the possiblity of filenames that are urls - (with-handlers ([(λ (x) #t) - (λ (x) name)]) - (normal-case-path - (normalize-path name)))] - [test-frame - (λ (frame) - (and (is-a? frame frame:basic<%>) - (send frame editing-this-file? normalized)))]) - (let loop ([frames frames]) - (cond - [(null? frames) #f] - [else - (let* ([frame (frame-frame (car frames))]) - (if (test-frame frame) - frame - (loop (cdr frames))))])))) - - (super-new))) + [else + (let* ([frame (frame-frame (car frames))]) + (if (test-frame frame) + frame + (loop (cdr frames))))])))) - (define (choose-a-frame parent) - (letrec-values ([(sorted-frames) - (sort - (send (get-the-frame-group) get-frames) - (λ (x y) (string-ci<=? (send x get-label) (send y get-label))))] - [(d) (make-object dialog% (string-constant bring-frame-to-front) parent 400 600)] - [(lb) (instantiate list-box% () - (label #f) - (choices (map (λ (x) (gui-utils:trim-string (send x get-label) 200)) sorted-frames)) - (callback (λ (x y) (listbox-callback y))) - (parent d))] - [(t) (instantiate text:hide-caret/selection% ())] - [(ec) (instantiate canvas:basic% () - (parent d) - (stretchable-height #f))] - [(bp) (instantiate horizontal-panel% () - (parent d) - (stretchable-height #f) - (alignment '(right center)))] - [(cancelled?) #t] - [(listbox-callback) - (λ (evt) - (case (send evt get-event-type) - [(list-box) - - (send ok enable (pair? (send lb get-selections))) - - (let ([full-name - (let ([sels (send lb get-selections)]) - (and (pair? sels) - (let ([fr (list-ref sorted-frames (car sels))]) - (and (is-a? fr frame:basic%) - (send fr get-filename)))))]) - (send t begin-edit-sequence) - (send t erase) - (when full-name - (send t insert (path->string full-name))) - (send t end-edit-sequence))] - [(list-box-dclick) - (set! cancelled? #f) - (send d show #f)]))] - [(ok cancel) - (gui-utils:ok/cancel-buttons - bp - (λ (x y) - (set! cancelled? #f) - (send d show #f)) - (λ (x y) - (send d show #f)))]) - (send ec set-line-count 3) - (send ec set-editor t) - (send t auto-wrap #t) - (let ([fr (car sorted-frames)]) - (when (and (is-a? fr frame:basic<%>) - (send fr get-filename)) - (send t insert (path->string (send (car sorted-frames) get-filename)))) - (send lb set-selection 0)) - (send d show #t) - (unless cancelled? - (let ([sels (send lb get-selections)]) - (unless (null? sels) - (send (list-ref sorted-frames (car sels)) show #t)))))) - - - (define (internal-get-the-frame-group) - (let ([the-frame-group (make-object %)]) - (set! internal-get-the-frame-group (λ () the-frame-group)) - (internal-get-the-frame-group))) - - (define (get-the-frame-group) - (internal-get-the-frame-group))) + (super-new))) + + (define (choose-a-frame parent) + (letrec-values ([(sorted-frames) + (sort + (send (get-the-frame-group) get-frames) + (λ (x y) (string-ci<=? (send x get-label) (send y get-label))))] + [(d) (make-object dialog% (string-constant bring-frame-to-front) parent 400 600)] + [(lb) (instantiate list-box% () + (label #f) + (choices (map (λ (x) (gui-utils:trim-string (send x get-label) 200)) sorted-frames)) + (callback (λ (x y) (listbox-callback y))) + (parent d))] + [(t) (instantiate text:hide-caret/selection% ())] + [(ec) (instantiate canvas:basic% () + (parent d) + (stretchable-height #f))] + [(bp) (instantiate horizontal-panel% () + (parent d) + (stretchable-height #f) + (alignment '(right center)))] + [(cancelled?) #t] + [(listbox-callback) + (λ (evt) + (case (send evt get-event-type) + [(list-box) + + (send ok enable (pair? (send lb get-selections))) + + (let ([full-name + (let ([sels (send lb get-selections)]) + (and (pair? sels) + (let ([fr (list-ref sorted-frames (car sels))]) + (and (is-a? fr frame:basic%) + (send fr get-filename)))))]) + (send t begin-edit-sequence) + (send t erase) + (when full-name + (send t insert (path->string full-name))) + (send t end-edit-sequence))] + [(list-box-dclick) + (set! cancelled? #f) + (send d show #f)]))] + [(ok cancel) + (gui-utils:ok/cancel-buttons + bp + (λ (x y) + (set! cancelled? #f) + (send d show #f)) + (λ (x y) + (send d show #f)))]) + (send ec set-line-count 3) + (send ec set-editor t) + (send t auto-wrap #t) + (let ([fr (car sorted-frames)]) + (when (and (is-a? fr frame:basic<%>) + (send fr get-filename)) + (send t insert (path->string (send (car sorted-frames) get-filename)))) + (send lb set-selection 0)) + (send d show #t) + (unless cancelled? + (let ([sels (send lb get-selections)]) + (unless (null? sels) + (send (list-ref sorted-frames (car sels)) show #t)))))) + + + (define (internal-get-the-frame-group) + (let ([the-frame-group (make-object %)]) + (set! internal-get-the-frame-group (λ () the-frame-group)) + (internal-get-the-frame-group))) + + (define (get-the-frame-group) + (internal-get-the-frame-group))) diff --git a/collects/framework/private/handler.ss b/collects/framework/private/handler.ss index 9752f845..cfbebe20 100644 --- a/collects/framework/private/handler.ss +++ b/collects/framework/private/handler.ss @@ -3,11 +3,11 @@ (require (lib "class.ss") (lib "list.ss") (lib "hierlist.ss" "hierlist") - "sig.ss" - "../preferences.ss" + "sig.ss" + "../preferences.ss" "../gui-utils.ss" - (lib "mred-sig.ss" "mred") - (lib "file.ss") + (lib "mred-sig.ss" "mred") + (lib "file.ss") (lib "string-constant.ss" "string-constants")) diff --git a/collects/framework/private/icon.ss b/collects/framework/private/icon.ss index 9aef9277..f6ed5a8c 100644 --- a/collects/framework/private/icon.ss +++ b/collects/framework/private/icon.ss @@ -1,72 +1,72 @@ (module icon (lib "a-unit.ss") (require (lib "class.ss") (lib "include-bitmap.ss" "mrlib") - "bday.ss" + "bday.ss" "sig.ss" - (lib "mred-sig.ss" "mred")) - + (lib "mred-sig.ss" "mred")) + (import mred^) (export framework:icon^) - (define eof-bitmap (delay (include-bitmap (lib "eof.gif" "icons")))) - (define (get-eof-bitmap) (force eof-bitmap)) - - (define anchor-bitmap (delay (include-bitmap (lib "anchor.gif" "icons")))) - (define (get-anchor-bitmap) (force anchor-bitmap)) - - (define lock-bitmap (delay (include-bitmap (lib "lock.gif" "icons")))) - (define (get-lock-bitmap) (force lock-bitmap)) - (define unlock-bitmap (delay (include-bitmap (lib "unlock.gif" "icons")))) - (define (get-unlock-bitmap) (force unlock-bitmap)) - - (define autowrap-bitmap (delay (include-bitmap (lib "return.xbm" "icons")))) - (define (get-autowrap-bitmap) (force autowrap-bitmap)) - (define paren-highlight-bitmap (delay (include-bitmap (lib "paren.xbm" "icons")))) - (define (get-paren-highlight-bitmap) (force paren-highlight-bitmap)) - - (define-syntax (make-get-cursor stx) - (syntax-case stx () - [(_ name mask fallback) - (syntax - (let ([ans (delay - (let* ([msk-b (include-bitmap (lib mask "icons"))] - [csr-b (include-bitmap (lib name "icons"))]) - (if (and (send msk-b ok?) - (send csr-b ok?)) - (let ([csr (make-object cursor% msk-b csr-b 7 7)]) - (if (send csr ok?) - csr - (make-object cursor% fallback))) - (make-object cursor% fallback))))]) - (λ () - (force ans))))])) - - (define get-up/down-cursor (make-get-cursor "up-down-cursor.xbm" "up-down-mask.xbm" 'size-n/s)) - (define get-left/right-cursor (make-get-cursor "left-right-cursor.xbm" "left-right-mask.xbm" 'size-e/w)) - - (define mrf-on-bitmap (delay (include-bitmap (lib "mrf.jpg" "icons")))) - (define gc-on-bitmap (delay (include-bitmap (lib "recycle.gif" "icons")))) - - (define (make-off-bitmap onb) - (let* ([bitmap (make-object bitmap% - (send onb get-width) - (send onb get-height))] - [bdc (make-object bitmap-dc% bitmap)]) - (send bdc clear) - (send bdc set-bitmap #f) - bitmap)) - - (define mrf-off-bitmap (delay (make-off-bitmap (force mrf-on-bitmap)))) - (define gc-off-bitmap (delay (make-off-bitmap (force gc-on-bitmap)))) - - (define (get-gc-on-bitmap) - (force - (if (mrf-bday?) - mrf-on-bitmap - gc-on-bitmap))) - - (define (get-gc-off-bitmap) - (force - (if (mrf-bday?) - mrf-off-bitmap - gc-off-bitmap)))) + (define eof-bitmap (delay (include-bitmap (lib "eof.gif" "icons")))) + (define (get-eof-bitmap) (force eof-bitmap)) + + (define anchor-bitmap (delay (include-bitmap (lib "anchor.gif" "icons")))) + (define (get-anchor-bitmap) (force anchor-bitmap)) + + (define lock-bitmap (delay (include-bitmap (lib "lock.gif" "icons")))) + (define (get-lock-bitmap) (force lock-bitmap)) + (define unlock-bitmap (delay (include-bitmap (lib "unlock.gif" "icons")))) + (define (get-unlock-bitmap) (force unlock-bitmap)) + + (define autowrap-bitmap (delay (include-bitmap (lib "return.xbm" "icons")))) + (define (get-autowrap-bitmap) (force autowrap-bitmap)) + (define paren-highlight-bitmap (delay (include-bitmap (lib "paren.xbm" "icons")))) + (define (get-paren-highlight-bitmap) (force paren-highlight-bitmap)) + + (define-syntax (make-get-cursor stx) + (syntax-case stx () + [(_ name mask fallback) + (syntax + (let ([ans (delay + (let* ([msk-b (include-bitmap (lib mask "icons"))] + [csr-b (include-bitmap (lib name "icons"))]) + (if (and (send msk-b ok?) + (send csr-b ok?)) + (let ([csr (make-object cursor% msk-b csr-b 7 7)]) + (if (send csr ok?) + csr + (make-object cursor% fallback))) + (make-object cursor% fallback))))]) + (λ () + (force ans))))])) + + (define get-up/down-cursor (make-get-cursor "up-down-cursor.xbm" "up-down-mask.xbm" 'size-n/s)) + (define get-left/right-cursor (make-get-cursor "left-right-cursor.xbm" "left-right-mask.xbm" 'size-e/w)) + + (define mrf-on-bitmap (delay (include-bitmap (lib "mrf.jpg" "icons")))) + (define gc-on-bitmap (delay (include-bitmap (lib "recycle.gif" "icons")))) + + (define (make-off-bitmap onb) + (let* ([bitmap (make-object bitmap% + (send onb get-width) + (send onb get-height))] + [bdc (make-object bitmap-dc% bitmap)]) + (send bdc clear) + (send bdc set-bitmap #f) + bitmap)) + + (define mrf-off-bitmap (delay (make-off-bitmap (force mrf-on-bitmap)))) + (define gc-off-bitmap (delay (make-off-bitmap (force gc-on-bitmap)))) + + (define (get-gc-on-bitmap) + (force + (if (mrf-bday?) + mrf-on-bitmap + gc-on-bitmap))) + + (define (get-gc-off-bitmap) + (force + (if (mrf-bday?) + mrf-off-bitmap + gc-off-bitmap)))) diff --git a/collects/framework/private/keymap.ss b/collects/framework/private/keymap.ss index 524528c2..a13b04eb 100644 --- a/collects/framework/private/keymap.ss +++ b/collects/framework/private/keymap.ss @@ -1,14 +1,14 @@ (module keymap (lib "a-unit.ss") (require (lib "string-constant.ss" "string-constants") - (lib "class.ss") - (lib "list.ss") - (lib "mred-sig.ss" "mred") + (lib "class.ss") + (lib "list.ss") + (lib "mred-sig.ss" "mred") (lib "match.ss") "../preferences.ss" "sig.ss") - + (import mred^ [prefix finder: framework:finder^] [prefix handler: framework:handler^] @@ -18,1353 +18,1353 @@ [-get-file get-file])) (init-depend mred^) - (define user-keybindings-files (make-hash-table 'equal)) + (define user-keybindings-files (make-hash-table 'equal)) + + (define (add-user-keybindings-file spec) + (hash-table-get + user-keybindings-files + spec + (λ () + (let* ([path (spec->path spec)] + [sexp (and (file-exists? path) + (call-with-input-file path read))]) + (match sexp + [`(module ,name (lib "keybinding-lang.ss" "framework") ,@(x ...)) + (let ([km (dynamic-require spec '#%keymap)]) + (hash-table-put! user-keybindings-files spec km) + (send global chain-to-keymap km #t))] + [else (error 'add-user-keybindings-file + (string-constant user-defined-keybinding-malformed-file) + (path->string path))]))))) + + (define (spec->path p) + (cond + [(path? p) p] + [else + (let* ([mod-name ((current-module-name-resolver) p #f #f)] + [str (symbol->string mod-name)] + [pth (substring str 1 (string-length str))]) + (let-values ([(base name _) (split-path pth)]) + (let ([filenames + (sort + (filter (λ (x) (substring? (path->string name) x)) + (map path->string (directory-list base))) + (λ (x y) (> (string-length x) (string-length y))))]) + (when (null? filenames) + (error 'spec->path "could not convert ~s, found no filenames for ~s" p mod-name)) + (build-path base (car filenames)))))])) + + (define (substring? s1 s2) + (and (<= (string-length s1) + (string-length s2)) + (string=? s1 (substring s2 0 (string-length s1))))) + + (define (remove-user-keybindings-file spec) + (let/ec k + (let ([km (hash-table-get user-keybindings-files spec (λ () (k (void))))]) + (send global remove-chained-keymap km) + (hash-table-remove! user-keybindings-files spec)))) + + (define (remove-chained-keymap ed keymap-to-remove) + (let ([ed-keymap (send ed get-keymap)]) + (when (eq? keymap-to-remove ed-keymap) + (error 'keymap:remove-keymap "cannot remove initial keymap from editor")) + (let p-loop ([parent-keymap ed-keymap]) + (unless (is-a? parent-keymap aug-keymap<%>) + (error 'keymap:remove-keymap + "found a keymap that is not a keymap:aug-keymap<%> ~e" + parent-keymap)) + (let c-loop ([child-keymaps (send parent-keymap get-chained-keymaps)]) + (cond + [(null? child-keymaps) + (void)] + [else + (let ([child-keymap (car child-keymaps)]) + (cond + [(eq? child-keymap keymap-to-remove) + (send parent-keymap remove-chained-keymap child-keymap) + (c-loop (cdr child-keymaps))] + [else + (p-loop child-keymap) + (c-loop (cdr child-keymaps))]))]))))) + + (define (set-chained-keymaps parent-keymap children-keymaps) + (for-each (λ (orig-sub) (send parent-keymap remove-chained-keymap)) + (send parent-keymap get-chained-keymaps)) + (for-each (λ (new-sub) (send parent-keymap chain-to-keymap new-sub #f)) + children-keymaps)) + + (define aug-keymap<%> (interface ((class->interface keymap%)) + get-chained-keymaps + get-map-function-table + get-map-function-table/ht)) + + (define aug-keymap-mixin + (mixin ((class->interface keymap%)) (aug-keymap<%>) + (define chained-keymaps null) + (define/public (get-chained-keymaps) chained-keymaps) - (define (add-user-keybindings-file spec) - (hash-table-get - user-keybindings-files - spec - (λ () - (let* ([path (spec->path spec)] - [sexp (and (file-exists? path) - (call-with-input-file path read))]) - (match sexp - [`(module ,name (lib "keybinding-lang.ss" "framework") ,@(x ...)) - (let ([km (dynamic-require spec '#%keymap)]) - (hash-table-put! user-keybindings-files spec km) - (send global chain-to-keymap km #t))] - [else (error 'add-user-keybindings-file - (string-constant user-defined-keybinding-malformed-file) - (path->string path))]))))) + (define/override (chain-to-keymap keymap prefix?) + (super chain-to-keymap keymap prefix?) + (set! chained-keymaps + (if prefix? + (cons keymap chained-keymaps) + (append chained-keymaps (list keymap))))) - (define (spec->path p) - (cond - [(path? p) p] - [else - (let* ([mod-name ((current-module-name-resolver) p #f #f)] - [str (symbol->string mod-name)] - [pth (substring str 1 (string-length str))]) - (let-values ([(base name _) (split-path pth)]) - (let ([filenames - (sort - (filter (λ (x) (substring? (path->string name) x)) - (map path->string (directory-list base))) - (λ (x y) (> (string-length x) (string-length y))))]) - (when (null? filenames) - (error 'spec->path "could not convert ~s, found no filenames for ~s" p mod-name)) - (build-path base (car filenames)))))])) + (define/override (remove-chained-keymap keymap) + (super remove-chained-keymap keymap) + (set! chained-keymaps (remq keymap chained-keymaps))) - (define (substring? s1 s2) - (and (<= (string-length s1) - (string-length s2)) - (string=? s1 (substring s2 0 (string-length s1))))) - - (define (remove-user-keybindings-file spec) - (let/ec k - (let ([km (hash-table-get user-keybindings-files spec (λ () (k (void))))]) - (send global remove-chained-keymap km) - (hash-table-remove! user-keybindings-files spec)))) + (define function-table (make-hash-table)) + (define/public (get-function-table) function-table) + (define/override (map-function keyname fname) + (super map-function (canonicalize-keybinding-string keyname) fname) + (hash-table-put! function-table (string->symbol keyname) fname)) - (define (remove-chained-keymap ed keymap-to-remove) - (let ([ed-keymap (send ed get-keymap)]) - (when (eq? keymap-to-remove ed-keymap) - (error 'keymap:remove-keymap "cannot remove initial keymap from editor")) - (let p-loop ([parent-keymap ed-keymap]) - (unless (is-a? parent-keymap aug-keymap<%>) - (error 'keymap:remove-keymap - "found a keymap that is not a keymap:aug-keymap<%> ~e" - parent-keymap)) - (let c-loop ([child-keymaps (send parent-keymap get-chained-keymaps)]) + (define/public (get-map-function-table) + (get-map-function-table/ht (make-hash-table))) + + (define/public (get-map-function-table/ht table) + (hash-table-for-each + function-table + (λ (keyname fname) + (unless (hash-table-get table keyname (λ () #f)) + (hash-table-put! table keyname fname)))) + (for-each + (λ (chained-keymap) + (when (is-a? chained-keymap aug-keymap<%>) + (send chained-keymap get-map-function-table/ht table))) + chained-keymaps) + table) + + (super-new))) + + (define aug-keymap% (aug-keymap-mixin keymap%)) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;; ;;;;;;;; + ;;;;;;; canonicalize-keybinding-string ;;;;;;;; + ;;;;;;; ;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + ;; canonicalize-keybinding-string : string -> string + ;; The result can be used with string=? to determine + ;; if two key bindings refer to the same key. + ;; Assumes a well-formed keystring. + (define (canonicalize-keybinding-string str) + (let* ([chars (map char-downcase (string->list str))] + [separated-keys + (map + canonicalize-single-keybinding-string + (split-out #\; chars))]) + (join-strings ";" separated-keys))) + + ;; join-strings : string (listof string) -> string + ;; concatenates strs with sep between each of them + (define (join-strings sep strs) + (if (null? strs) + "" + (apply + string-append + (cons + (car strs) + (let loop ([sepd-strs (cdr strs)]) + (cond + [(null? sepd-strs) null] + [else (list* + sep + (car sepd-strs) + (loop (cdr sepd-strs)))])))))) + + ;; canonicalize-single-keybinding-string : (listof char) -> string + (define (canonicalize-single-keybinding-string chars) + (let* ([neg? (char=? (car chars) #\:)] + [mods/key (split-out #\: (if neg? (cdr chars) chars))] + [mods + (let loop ([mods mods/key]) (cond - [(null? child-keymaps) - (void)] - [else - (let ([child-keymap (car child-keymaps)]) - (cond - [(eq? child-keymap keymap-to-remove) - (send parent-keymap remove-chained-keymap child-keymap) - (c-loop (cdr child-keymaps))] - [else - (p-loop child-keymap) - (c-loop (cdr child-keymaps))]))]))))) + [(null? mods) null] + [(null? (cdr mods)) null] + [else (cons (car mods) (loop (cdr mods)))]))] + [key (apply string (car (last-pair mods/key)))] + [canon-key + (cond + [(string=? key "enter") "return"] + [(string=? key "del") "delete"] + [(string=? key "ins") "insert"] + [else key])] + [shift (if neg? #f 'd/c)] + [control (if neg? #f 'd/c)] + [alt (if neg? #f 'd/c)] + [meta (if neg? #f 'd/c)] + [command (if neg? #f 'd/c)] + + [do-key + (λ (char val) + (cond + [(eq? val #t) (string char)] + [(eq? val #f) (string #\~ char)] + [(eq? val 'd/c) #f]))]) - (define (set-chained-keymaps parent-keymap children-keymaps) - (for-each (λ (orig-sub) (send parent-keymap remove-chained-keymap)) - (send parent-keymap get-chained-keymaps)) - (for-each (λ (new-sub) (send parent-keymap chain-to-keymap new-sub #f)) - children-keymaps)) - - (define aug-keymap<%> (interface ((class->interface keymap%)) - get-chained-keymaps - get-map-function-table - get-map-function-table/ht)) + (for-each (λ (mod) + (let ([val (not (char=? (car mod) #\~))]) + (case (if (char=? (car mod) #\~) + (cadr mod) + (car mod)) + [(#\s) (set! shift val)] + [(#\c) (set! control val)] + [(#\a) (set! alt val)] + [(#\d) (set! command val)] + [(#\m) (set! meta val)]))) + mods) - (define aug-keymap-mixin - (mixin ((class->interface keymap%)) (aug-keymap<%>) - (define chained-keymaps null) - (define/public (get-chained-keymaps) chained-keymaps) - - (define/override (chain-to-keymap keymap prefix?) - (super chain-to-keymap keymap prefix?) - (set! chained-keymaps - (if prefix? - (cons keymap chained-keymaps) - (append chained-keymaps (list keymap))))) - - (define/override (remove-chained-keymap keymap) - (super remove-chained-keymap keymap) - (set! chained-keymaps (remq keymap chained-keymaps))) - - (define function-table (make-hash-table)) - (define/public (get-function-table) function-table) - (define/override (map-function keyname fname) - (super map-function (canonicalize-keybinding-string keyname) fname) - (hash-table-put! function-table (string->symbol keyname) fname)) - - (define/public (get-map-function-table) - (get-map-function-table/ht (make-hash-table))) - - (define/public (get-map-function-table/ht table) - (hash-table-for-each - function-table - (λ (keyname fname) - (unless (hash-table-get table keyname (λ () #f)) - (hash-table-put! table keyname fname)))) - (for-each - (λ (chained-keymap) - (when (is-a? chained-keymap aug-keymap<%>) - (send chained-keymap get-map-function-table/ht table))) - chained-keymaps) - table) - - (super-new))) - - (define aug-keymap% (aug-keymap-mixin keymap%)) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;; ;;;;;;;; - ;;;;;;; canonicalize-keybinding-string ;;;;;;;; - ;;;;;;; ;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - ;; canonicalize-keybinding-string : string -> string - ;; The result can be used with string=? to determine - ;; if two key bindings refer to the same key. - ;; Assumes a well-formed keystring. - (define (canonicalize-keybinding-string str) - (let* ([chars (map char-downcase (string->list str))] - [separated-keys - (map - canonicalize-single-keybinding-string - (split-out #\; chars))]) - (join-strings ";" separated-keys))) - - ;; join-strings : string (listof string) -> string - ;; concatenates strs with sep between each of them - (define (join-strings sep strs) - (if (null? strs) - "" - (apply - string-append - (cons - (car strs) - (let loop ([sepd-strs (cdr strs)]) - (cond - [(null? sepd-strs) null] - [else (list* - sep - (car sepd-strs) - (loop (cdr sepd-strs)))])))))) - - ;; canonicalize-single-keybinding-string : (listof char) -> string - (define (canonicalize-single-keybinding-string chars) - (let* ([neg? (char=? (car chars) #\:)] - [mods/key (split-out #\: (if neg? (cdr chars) chars))] - [mods - (let loop ([mods mods/key]) - (cond - [(null? mods) null] - [(null? (cdr mods)) null] - [else (cons (car mods) (loop (cdr mods)))]))] - [key (apply string (car (last-pair mods/key)))] - [canon-key + (join-strings ":" + (filter + (λ (x) x) + (list + (do-key #\a alt) + (do-key #\c control) + (do-key #\d command) + (do-key #\m meta) + (do-key #\s shift) + canon-key))))) + + ;; split-out : char (listof char) -> (listof (listof char)) + ;; splits a list of characters at its first argument + ;; if the last character is the same as the first character, + ;; it is not split into an empty list, but returned. + (define (split-out split-char chars) + (let loop ([chars chars] + [this-split null] + [all-split null]) + (cond + [(null? chars) + (reverse (cons (reverse this-split) all-split))] + [else (let ([char (car chars)]) (cond - [(string=? key "enter") "return"] - [(string=? key "del") "delete"] - [(string=? key "ins") "insert"] - [else key])] - [shift (if neg? #f 'd/c)] - [control (if neg? #f 'd/c)] - [alt (if neg? #f 'd/c)] - [meta (if neg? #f 'd/c)] - [command (if neg? #f 'd/c)] - - [do-key - (λ (char val) - (cond - [(eq? val #t) (string char)] - [(eq? val #f) (string #\~ char)] - [(eq? val 'd/c) #f]))]) - - (for-each (λ (mod) - (let ([val (not (char=? (car mod) #\~))]) - (case (if (char=? (car mod) #\~) - (cadr mod) - (car mod)) - [(#\s) (set! shift val)] - [(#\c) (set! control val)] - [(#\a) (set! alt val)] - [(#\d) (set! command val)] - [(#\m) (set! meta val)]))) - mods) - - (join-strings ":" - (filter - (λ (x) x) - (list - (do-key #\a alt) - (do-key #\c control) - (do-key #\d command) - (do-key #\m meta) - (do-key #\s shift) - canon-key))))) - - ;; split-out : char (listof char) -> (listof (listof char)) - ;; splits a list of characters at its first argument - ;; if the last character is the same as the first character, - ;; it is not split into an empty list, but returned. - (define (split-out split-char chars) - (let loop ([chars chars] - [this-split null] - [all-split null]) - (cond - [(null? chars) - (reverse (cons (reverse this-split) all-split))] - [else (let ([char (car chars)]) - (cond - [(char=? split-char char) - (if (null? (cdr chars)) - (loop null - (cons char this-split) - all-split) - (loop (cdr chars) - null - (cons (reverse this-split) all-split)))] - [else - (loop (cdr chars) + [(char=? split-char char) + (if (null? (cdr chars)) + (loop null (cons char this-split) - all-split)]))]))) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;; ;;;;;;;; - ;;;;;;; end canonicalize-keybinding-string ;;;;;;;; - ;;;;;;; ;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - (define (make-meta-prefix-list key) - (list (string-append "m:" key) - (string-append "ESC;" key))) - - (define send-map-function-meta - (λ (keymap key func) - (for-each (λ (key) (send keymap map-function key func)) - (make-meta-prefix-list key)))) - - (define add-to-right-button-menu (make-parameter void)) - (define add-to-right-button-menu/before (make-parameter void)) - - (define setup-global - ; Define some useful keyboard functions - (let* ([ring-bell - (λ (edit event) - (bell))] - - [mouse-popup-menu - (λ (edit event) - (when (send event button-down?) - (let ([a (send edit get-admin)]) - (when a - (let ([m (make-object popup-menu%)]) - - ((add-to-right-button-menu/before) m edit event) - - (append-editor-operation-menu-items m) - (for-each - (λ (i) - (when (is-a? i selectable-menu-item<%>) - (send i set-shortcut #f))) - (send m get-items)) - - ((add-to-right-button-menu) m edit event) - - (let-values ([(x y) (send edit - dc-location-to-editor-location - (send event get-x) - (send event get-y))]) - (send a popup-menu m (+ x 1) (+ y 1))))))))] - - [toggle-anchor - (λ (edit event) - (send edit set-anchor - (not (send edit get-anchor))))] - [center-view-on-line - (λ (edit event) - (let ([new-mid-line (send edit position-line - (send edit get-start-position))] - [bt (box 0)] - [bb (box 0)]) - (send edit get-visible-line-range bt bb #f) - (let* ([half (sub1 (quotient (- (unbox bb) (unbox bt)) 2))] - [last-pos (send edit position-line (send edit last-position))] - [top-pos (send edit line-start-position - (max (min (- new-mid-line half) last-pos) 0))] - [bottom-pos (send edit line-start-position - (max 0 - (min (+ new-mid-line half) - last-pos)))]) - (send edit scroll-to-position - top-pos - #f - bottom-pos))) - #t)] - - [make-insert-brace-pair - (λ (open-brace close-brace) - (λ (edit event) - (send edit begin-edit-sequence) - (let ([selection-start (send edit get-start-position)]) - (send edit set-position (send edit get-end-position)) - (send edit insert close-brace) - (send edit set-position selection-start) - (send edit insert open-brace)) - (send edit end-edit-sequence)))] - - [insert-lambda-template - (λ (edit event) - (send edit begin-edit-sequence) - (let ([selection-start (send edit get-start-position)]) - (send edit set-position (send edit get-end-position)) - (send edit insert ")") - (send edit set-position selection-start) - (send edit insert ") ") - (send edit set-position selection-start) - (send edit insert "(λ (")) - (send edit end-edit-sequence))] - - [collapse-variable-space - ;; As per emacs: collapse tabs & spaces around the point, - ;; perhaps leaving a single space. - ;; drscheme bonus: if at end-of-line, collapse into the next line. - (λ (leave-one? edit event) - (letrec ([last-pos (send edit last-position)] - [sel-start (send edit get-start-position)] - [sel-end (send edit get-end-position)] - [collapsible? (λ (c) (and (char-whitespace? c) - (not (char=? #\newline c))))] - [find-noncollapsible - ; Return index of next non-collapsible char, - ; starting at pos in direction dir. - ; NB returns -1 or last-pos, if examining - ; initial/final whitespace - ; (or, when initial pos is outside of [0,last-pos).) - (λ (pos dir) - (let loop ([pos pos]) - (cond [(< pos 0) -1] - [(>= pos last-pos) last-pos] - [(collapsible? (send edit get-character pos)) - (loop (+ pos dir))] - [else pos])))]) - (when (= sel-start sel-end) ; Only when no selection: - (let* ([start (add1 (find-noncollapsible (sub1 sel-start) -1))] - [end-heeding-eol (find-noncollapsible sel-start +1)] - ; This is the end of the range, were we to always heed newlines. - - ; Special case: if we're sitting at EOL, - ; and we're not affecting much else, - ; then delete that EOL and collapse spaces - ; at the start of next line, too: - [end (if (and (<= (- end-heeding-eol start) - (if leave-one? 1 0)) - (char=? #\newline (send edit get-character end-heeding-eol)) - ; If you wish to avoid deleting an newline at EOF, do so here. - ) - (find-noncollapsible (add1 end-heeding-eol) +1) - end-heeding-eol)] - [making-no-difference? - ; Don't introduce edits into undo-chain, if no effect. - (if leave-one? - (and (= (- end start) 1) - (char=? #\space (send edit get-character start))) - (= (- end start) 0))]) - (unless making-no-difference? - (send edit begin-edit-sequence) - (send edit set-position end) ; Even after delete, caret will be at "end". - (send edit delete start end) - (when leave-one? (send edit insert #\space start)) - (send edit end-edit-sequence))))))] - - [collapse-space - (λ (edit event) - (collapse-variable-space #t edit event))] - - [remove-space - (λ (edit event) - (collapse-variable-space #f edit event))] - - [collapse-newline - (λ (edit event) - (letrec ([find-nonwhite - (λ (pos d offset) - (let/ec escape - (let ([max (if (> offset 0) - (send edit last-position) - 0)]) - (let loop ([pos pos]) - (if (= pos max) - (escape pos) - (let ([c (send edit get-character (+ pos offset))]) - (cond - [(char=? #\newline c) - (loop (+ pos d)) - (escape pos)] - [(char-whitespace? c) - (loop (+ pos d))] - [else pos])))))))]) - (let ([sel-start (send edit get-start-position)] - [sel-end (send edit get-end-position)]) - (when (= sel-start sel-end) - (let* ([pos-line (send edit position-line sel-start #f)] - [pos-line-start (send edit line-start-position pos-line)] - [pos-line-end (send edit line-end-position pos-line)] - - [whiteline? - (let loop ([pos pos-line-start]) - (if (>= pos pos-line-end) - #t - (and (char-whitespace? (send edit get-character pos)) - (loop (add1 pos)))))] - - [start (find-nonwhite pos-line-start -1 -1)] - [end (find-nonwhite pos-line-end 1 0)] - - [start-line - (send edit position-line start #f)] - [start-line-start - (send edit line-start-position start-line)] - [end-line - (send edit position-line end #f)] - [end-line-start - (send edit line-start-position (add1 end-line))]) - (cond - [(and whiteline? - (= start-line pos-line) - (= end-line pos-line)) - ; Special case: just delete this line - (send edit delete pos-line-start (add1 pos-line-end))] - [(and whiteline? (< start-line pos-line)) - ; Can delete before & after - (send* edit - (begin-edit-sequence) - (delete (add1 pos-line-end) end-line-start) - (delete start-line-start pos-line-start) - (end-edit-sequence))] - [else - ; Only delete after - (send edit delete (add1 pos-line-end) - end-line-start)]))))))] - - [open-line - (λ (edit event) - (let ([sel-start (send edit get-start-position)] - [sel-end (send edit get-end-position)]) - (if (= sel-start sel-end) - (send* edit - (insert #\newline) - (set-position sel-start)))))] - - [transpose-chars - (λ (edit event) - (let ([sel-start (send edit get-start-position)] - [sel-end (send edit get-end-position)]) - (when (and (= sel-start sel-end) - (not (= sel-start 0))) - - (let ([sel-start - (if (= sel-start - (send edit line-end-position - (send edit position-line sel-start))) - (sub1 sel-start) - sel-start)]) - (let ([s (send edit get-text - sel-start (add1 sel-start))]) - (send* edit - (begin-edit-sequence) - (delete sel-start (add1 sel-start)) - (insert s (- sel-start 1)) - (set-position (add1 sel-start)) - (end-edit-sequence)))))))] - - [transpose-words - (λ (edit event) - (let ([sel-start (send edit get-start-position)] - [sel-end (send edit get-end-position)]) - (when (= sel-start sel-end) - (let ([word-1-start (box sel-start)]) - (send edit find-wordbreak word-1-start #f 'caret) - (let ([word-1-end (box (unbox word-1-start))]) - (send edit find-wordbreak #f word-1-end 'caret) - (let ([word-2-end (box (unbox word-1-end))]) - (send edit find-wordbreak #f word-2-end 'caret) - (let ([word-2-start (box (unbox word-2-end))]) - (send edit find-wordbreak word-2-start #f 'caret) - (let ([text-1 (send edit get-text - (unbox word-1-start) - (unbox word-1-end))] - [text-2 (send edit get-text - (unbox word-2-start) - (unbox word-2-end))]) - (send* edit - (begin-edit-sequence) - (insert text-1 - (unbox word-2-start) - (unbox word-2-end)) - (insert text-2 - (unbox word-1-start) - (unbox word-1-end)) - (set-position (unbox word-2-end)) - (end-edit-sequence))))))))))] - - [capitalize-it - (λ (edit char-case1 char-case2) - (let ([sel-start (send edit get-start-position)] - [sel-end (send edit get-end-position)] - [real-end (send edit last-position)]) - (when (= sel-start sel-end) - (let ([word-end (let ([b (box sel-start)]) - (send edit find-wordbreak #f b 'caret) - (min real-end (unbox b)))]) - (send edit begin-edit-sequence) - (let loop ([pos sel-start] - [char-case char-case1]) - (when (< pos word-end) - (let ([c (send edit get-character pos)]) - (cond - [(char-alphabetic? c) - (send edit insert - (list->string - (list (char-case c))) - pos (add1 pos)) - (loop (add1 pos) char-case2)] - [else - (loop (add1 pos) char-case)])))) - (send* edit - (end-edit-sequence) - (set-position word-end))))))] - - [capitalize-word - (λ (edit event) - (capitalize-it edit char-upcase char-downcase))] - [upcase-word - (λ (edit event) - (capitalize-it edit char-upcase char-upcase))] - [downcase-word - (λ (edit event) - (capitalize-it edit char-downcase char-downcase))] - - [kill-word - (λ (edit event) - (let ([sel-start (send edit get-start-position)] - [sel-end (send edit get-end-position)]) - (let ([end-box (box sel-end)]) - (send edit find-wordbreak #f end-box 'caret) - (send edit kill 0 sel-start (unbox end-box)))))] - - [backward-kill-word - (λ (edit event) - (let ([sel-start (send edit get-start-position)] - [sel-end (send edit get-end-position)]) - (let ([start-box (box sel-start)]) - (send edit find-wordbreak start-box #f 'caret) - (send edit kill 0 (unbox start-box) sel-end))))] - - [region-click - (λ (edit event f) - (when (and (send event button-down?) - (is-a? edit text%)) - (let ([x-box (box (send event get-x))] - [y-box (box (send event get-y))] - [eol-box (box #f)]) - (send edit global-to-local x-box y-box) - (let ([click-pos (send edit find-position - (unbox x-box) - (unbox y-box) - eol-box)] - [start-pos (send edit get-start-position)] - [end-pos (send edit get-end-position)]) - (let ([eol (unbox eol-box)]) - (if (< start-pos click-pos) - (f click-pos eol start-pos click-pos) - (f click-pos eol click-pos end-pos)))))))] - [copy-click-region - (λ (edit event) - (region-click edit event - (λ (click eol start end) - (send edit flash-on start end) - (send edit copy #f 0 start end))))] - [cut-click-region - (λ (edit event) - (region-click edit event - (λ (click eol start end) - (send edit cut #f 0 start end))))] - [paste-click-region - (λ (edit event) - (region-click edit event - (λ (click eol start end) - (send edit set-position click) - (send edit paste-x-selection 0 click))))] - - [mouse-copy-clipboard - (λ (edit event) - (send edit copy #f (send event get-time-stamp)))] - - [mouse-paste-clipboard - (λ (edit event) - (send edit paste (send event get-time-stamp)))] - - [mouse-cut-clipboard - (λ (edit event) - (send edit cut #f (send event get-time-stamp)))] - - [select-click-word - (λ (edit event) - (region-click edit event - (λ (click eol start end) - (let ([start-box (box click)] - [end-box (box click)]) - (send edit find-wordbreak - start-box - end-box - 'selection) - (send edit set-position - (unbox start-box) - (unbox end-box))))))] - [select-click-line - (λ (edit event) - (region-click edit event - (λ (click eol start end) - (let* ([line (send edit position-line - click eol)] - [start (send edit line-start-position - line #f)] - [end (send edit line-end-position - line #f)]) - (send edit set-position start end)))))] - - [goto-line - (λ (edit event) - (let ([num-str - (call/text-keymap-initializer - (λ () - (get-text-from-user - (string-constant goto-line) - (string-constant goto-line))))]) - (when (string? num-str) - (let* ([possible-num (string->number num-str)] - [line-num (and possible-num (inexact->exact possible-num))]) - (cond - [(and (number? line-num) - (integer? line-num) - (<= 1 line-num (+ (send edit last-paragraph) 1))) - (let ([pos (send edit paragraph-start-position - (sub1 line-num))]) - (send edit set-position pos))] - [else - (message-box - (string-constant goto-line) - (format - (string-constant goto-line-invalid-number) - num-str - (+ (send edit last-line) 1)))])))) - - #t)] - [goto-position - (λ (edit event) - (let ([num-str - (call/text-keymap-initializer - (λ () - (get-text-from-user - (string-constant goto-position) - (string-constant goto-position))))]) - (if (string? num-str) - (let ([pos (string->number num-str)]) - (when pos - (send edit set-position (sub1 pos)))))) - #t)] - [repeater - (λ (n edit) - (let* ([km (send edit get-keymap)] - [done - (λ () - (send km set-break-sequence-callback void) - (send km remove-grab-key-function))]) - (send km set-grab-key-function - (λ (name local-km edit event) - (if name - (begin - (done) - (dynamic-wind - (λ () - (send edit begin-edit-sequence)) - (λ () - (let loop ([n n]) - (unless (zero? n) - (send local-km call-function name edit event) - (loop (sub1 n))))) - (λ () - (send edit end-edit-sequence)))) - (let ([k (send event get-key-code)]) - (if (and (char? k) (char<=? #\0 k #\9)) - (set! n (+ (* n 10) (- (char->integer k) - (char->integer #\0)))) - (begin - (done) - (dynamic-wind - (λ () - (send edit begin-edit-sequence)) - (λ () - (let loop ([n n]) - (unless (zero? n) - (send edit on-char event) - (loop (sub1 n))))) - (λ () - (send edit end-edit-sequence))))))) - #t)) - (send km set-break-sequence-callback done) - #t))] - [make-make-repeater - (λ (n) - (λ (edit event) - (repeater n edit)))] - [current-macro '()] - [building-macro #f] [build-macro-km #f] [build-protect? #f] - [show/hide-keyboard-macro-icon - (λ (edit on?) - (when (is-a? edit editor:basic<%>) - (let ([frame (send edit get-top-level-window)]) - (when (is-a? frame frame:text-info<%>) - (send frame set-macro-recording on?) - (send frame update-shown)))))] - - [do-macro - (λ (edit event) - ; If c:x;e during record, copy the old macro - (when building-macro - (set! building-macro (append (reverse current-macro) - (cdr building-macro)))) - (let ([bm building-macro] - [km (send edit get-keymap)]) - (dynamic-wind - (λ () - (set! building-macro #f) - (send edit begin-edit-sequence)) - (λ () - (let/ec escape - (for-each - (λ (f) - (let ([name (car f)] - [event (cdr f)]) - (if name - (unless (send km call-function name edit event #t) - (escape #t)) - (send edit on-char event)))) - current-macro))) - (λ () - (send edit end-edit-sequence) - (set! building-macro bm)))) - #t)] - [start-macro - (λ (edit event) - (if building-macro - (send build-macro-km break-sequence) - (letrec ([km (send edit get-keymap)] - [done - (λ () - (if build-protect? - (send km set-break-sequence-callback done) - (begin - (set! building-macro #f) - (show/hide-keyboard-macro-icon edit #f) - (send km set-break-sequence-callback void) - (send km remove-grab-key-function))))]) - (set! building-macro '()) - (show/hide-keyboard-macro-icon edit #t) - (set! build-macro-km km) - (send km set-grab-key-function - (λ (name local-km edit event) - (dynamic-wind - (λ () - (set! build-protect? #t)) - (λ () - (if name - (send local-km call-function name edit event) - (send edit on-default-char event))) - (λ () - (set! build-protect? #f))) - (when building-macro - (set! building-macro - (cons (cons name event) - building-macro))) - #t)) - (send km set-break-sequence-callback done))) - #t)] - [end-macro - (λ (edit event) - (when building-macro - (set! current-macro (reverse building-macro)) - (set! build-protect? #f) - (send build-macro-km break-sequence)) - #t)] - [delete-key - (λ (edit event) - (let ([kmap (send edit get-keymap)]) - (send kmap call-function - (if (preferences:get 'framework:delete-forward?) - "delete-next-character" - "delete-previous-character") - edit event #t)))] - - [toggle-overwrite - (λ (edit event) - (send edit set-overwrite-mode - (not (send edit get-overwrite-mode))))] - - [down-into-embedded-editor - (λ (text event) - (let ([start (send text get-start-position)] - [end (send text get-end-position)]) - (when (= start end) - (let* ([bx (box 0)] - [after-snip (send text find-snip start 'after-or-none bx)]) - (cond - [(and (= (unbox bx) start) - after-snip - (is-a? after-snip editor-snip%)) - (let ([embedded-editor (send after-snip get-editor)]) - (when (is-a? embedded-editor text%) - (send embedded-editor set-position 0)) - (send embedded-editor set-caret-owner #f 'global))] - [else - (let ([before-snip (send text find-snip start 'before-or-none bx)]) - (when (and (= (+ (unbox bx) 1) start) - before-snip - (is-a? before-snip editor-snip%)) - (let ([embedded-editor (send before-snip get-editor)]) - (when (is-a? embedded-editor text%) - (send embedded-editor set-position - (send embedded-editor last-position))) - (send embedded-editor set-caret-owner #f 'global))))])))) - #t)] - - [forward-to-next-embedded-editor - (λ (text event) - (let ([start-pos (send text get-start-position)] - [end-pos (send text get-end-position)]) - (when (= start-pos end-pos) - (let loop ([snip (send text find-snip start-pos 'after-or-none)]) - (cond - [(not snip) (void)] - [(is-a? snip editor-snip%) - (send text set-position (send text get-snip-position snip))] - [else (loop (send snip next))])))) - #t)] - - [back-to-prev-embedded-editor - (λ (text event) - (let ([start-pos (send text get-start-position)] - [end-pos (send text get-end-position)]) - (when (= start-pos end-pos) - (let loop ([snip (send text find-snip start-pos 'before-or-none)]) - (cond - [(not snip) (void)] - [(is-a? snip editor-snip%) - (send text set-position (+ (send text get-snip-position snip) 1))] - [else (loop (send snip previous))])))) - #t)] - - [up-out-of-embedded-editor - (λ (text event) - (let ([start (send text get-start-position)] - [end (send text get-end-position)]) - (when (= start end) - (let ([editor-admin (send text get-admin)]) - (when (is-a? editor-admin editor-snip-editor-admin<%>) - (let* ([snip (send editor-admin get-snip)] - [snip-admin (send snip get-admin)]) - (when snip-admin - (let ([editor (send snip-admin get-editor)]) - (when (is-a? editor text%) - (let ([new-pos (send editor get-snip-position snip)]) - (send editor set-position new-pos new-pos)) - (send editor set-caret-owner #f 'display))))))))) - #t)] - - [make-read-only - (λ (text event) - (send text lock #t) - #t)] - - [greek-letters "αβγδεζηθι κλμνξοπρςστυφχψω"] - [Greek-letters "ΑΒΓΔΕΖΗΘΙ ΚΛΜΝΞΟΠΡ ΣΤΥΦΧΨΩ"]) ;; don't have a capital ς, just comes out as \u03A2 (or junk) - - (λ (kmap) - (let* ([map (λ (key func) - (send kmap map-function key func))] - [map-meta (λ (key func) - (send-map-function-meta kmap key func))] - [add (λ (name func) - (send kmap add-function name func))] - [add-m (λ (name func) - (send kmap add-function name func))]) - - ; Map names to keyboard functions - - (for-each - (λ (c) - (unless (equal? c #\space) - (add (format "insert ~a" c) - (λ (txt evt) (send txt insert c))))) - (string->list (string-append greek-letters Greek-letters))) - - (add "down-into-embedded-editor" down-into-embedded-editor) - (add "up-out-of-embedded-editor" up-out-of-embedded-editor) - (add "forward-to-next-embedded-editor" forward-to-next-embedded-editor) - (add "back-to-prev-embedded-editor" back-to-prev-embedded-editor) - - (add "toggle-overwrite" toggle-overwrite) - - (add "exit" (λ (edit event) - (let ([frame (send edit get-frame)]) - (if (and frame - (is-a? frame frame:standard-menus<%>)) - (send frame file-menu:quit) - (bell))))) - - (add "ring-bell" ring-bell) - - (add "insert-()-pair" (make-insert-brace-pair "(" ")")) - (add "insert-[]-pair" (make-insert-brace-pair "[" "]")) - (add "insert-{}-pair" (make-insert-brace-pair "{" "}")) - (add "insert-\"\"-pair" (make-insert-brace-pair "\"" "\"")) - (add "insert-||-pair" (make-insert-brace-pair "|" "|")) - (add "insert-lambda-template" insert-lambda-template) - - (add "toggle-anchor" toggle-anchor) - (add "center-view-on-line" center-view-on-line) - (add "collapse-space" collapse-space) - (add "remove-space" remove-space) - (add "collapse-newline" collapse-newline) - (add "open-line" open-line) - (add "transpose-chars" transpose-chars) - (add "transpose-words" transpose-words) - (add "capitalize-word" capitalize-word) - (add "upcase-word" upcase-word) - (add "downcase-word" downcase-word) - (add "kill-word" kill-word) - (add "backward-kill-word" backward-kill-word) - - (let loop ([n 9]) - (unless (negative? n) - (let ([s (number->string n)]) - (add (string-append "command-repeat-" s) - (make-make-repeater n)) - (loop (sub1 n))))) - - (add "keyboard-macro-run-saved" do-macro) - (add "keyboard-macro-start-record" start-macro) - (add "keyboard-macro-end-record" end-macro) - - (add-m "copy-clipboard" mouse-copy-clipboard) - (add-m "cut-clipboard" mouse-cut-clipboard) - (add-m "paste-clipboard" mouse-paste-clipboard) - (add-m "copy-click-region" copy-click-region) - (add-m "cut-click-region" cut-click-region) - (add-m "paste-click-region" paste-click-region) - (add-m "select-click-word" select-click-word) - (add-m "select-click-line" select-click-line) - - (add "goto-line" goto-line) - (add "goto-position" goto-position) - - (add "delete-key" delete-key) - - (add "mouse-popup-menu" mouse-popup-menu) - - (add "make-read-only" make-read-only) - - ; Map keys to functions - - (let ([setup-mappings - (λ (greek-chars shift?) - (let loop ([i 0]) - (when (< i (string-length greek-chars)) - (let ([greek-char (string-ref greek-chars i)]) - (unless (equal? greek-char #\space) - (let ([roman-char - (integer->char - (+ (char->integer #\a) i))]) - (map (format "a:g;~a~a" - (if shift? "s:" "") - roman-char) - (format "insert ~a" greek-char)) - (map (format "c:x;c:g;~a~a" - (if shift? "s:" "") - roman-char) - (format "insert ~a" greek-char))))) - (loop (+ i 1)))))]) - (setup-mappings greek-letters #f) - (setup-mappings Greek-letters #t)) - - (map-meta "c:down" "down-into-embedded-editor") - (map "a:c:down" "down-into-embedded-editor") - (map-meta "c:up" "up-out-of-embedded-editor") - (map "a:c:up" "up-out-of-embedded-editor") - (map-meta "c:right" "forward-to-next-embedded-editor") - (map "a:c:right" "forward-to-next-embedded-editor") - (map-meta "c:left" "back-to-prev-embedded-editor") - (map "a:c:left" "back-to-prev-embedded-editor") - - (map "c:c;c:g" "ring-bell") - - (map-meta "(" "insert-()-pair") - (map-meta "[" "insert-[]-pair") - (map-meta "{" "insert-{}-pair") - (map-meta "\"" "insert-\"\"-pair") - (map-meta "|" "insert-||-pair") - (map-meta "s:l" "insert-lambda-template") - - (map "c:p" "previous-line") - (map "up" "previous-line") - (map "s:c:p" "select-up") - (map "s:up" "select-up") - - (map "c:n" "next-line") - (map "down" "next-line") - (map "s:c:n" "select-down") - (map "s:down" "select-down") - - (map "c:e" "end-of-line") - (map "d:right" "end-of-line") - (map "m:right" "end-of-line") - (map "end" "end-of-line") - (map "m:s:right" "select-to-end-of-line") - (map "s:end" "select-to-end-of-line") - (map "s:c:e" "select-to-end-of-line") - - (map "c:a" "beginning-of-line") - (map "d:left" "beginning-of-line") - (map "m:left" "beginning-of-line") - (map "home" "beginning-of-line") - (map "m:s:left" "select-to-beginning-of-line") - (map "s:home" "select-to-beginning-of-line") - (map "s:c:a" "select-to-beginning-of-line") - - (map "c:f" "forward-character") - (map "right" "forward-character") - (map "s:c:f" "forward-select") - (map "s:right" "forward-select") - - (map "c:b" "backward-character") - (map "left" "backward-character") - (map "s:c:b" "backward-select") - (map "s:left" "backward-select") - - (map-meta "f" "forward-word") - (map "a:right" "forward-word") - (map "c:right" "forward-word") - (map-meta "s:f" "forward-select-word") - (map "a:s:right" "forward-select-word") - (map "c:s:right" "forward-select-word") - - (map-meta "b" "backward-word") - (map "a:left" "backward-word") - - (map "c:left" "backward-word") - (map-meta "s:b" "backward-select-word") - (map "a:s:left" "backward-select-word") - (map "c:s:left" "backward-select-word") - - (map-meta "<" "beginning-of-file") - (map "d:up" "beginning-of-file") - (map "c:home" "beginning-of-file") - (map "s:c:home" "select-to-beginning-of-file") - (map "s:d:up" "select-to-beginning-of-file") - - (map-meta ">" "end-of-file") - (map "d:down" "end-of-file") - (map "c:end" "end-of-file") - (map "s:c:end" "select-to-end-of-file") - (map "s:d:down" "select-to-end-of-file") - - (map "c:v" "next-page") - (map "a:down" "next-page") - (map "pagedown" "next-page") - (map "c:down" "next-page") - (map "s:c:v" "select-page-down") - (map "a:s:down" "select-page-down") - (map "s:pagedown" "select-page-down") - (map "s:c:down" "select-page-down") - - (map-meta "v" "previous-page") - (map "a:up" "previous-page") - (map "pageup" "previous-page") - (map "c:up" "previous-page") - (map-meta "s:v" "select-page-up") - (map "s:a:up" "select-page-up") - (map "s:pageup" "select-page-up") - (map "s:c:up" "select-page-up") - - (map "c:h" "delete-previous-character") - (map "c:d" "delete-next-character") - (map "del" "delete-key") - - (map-meta "d" "kill-word") - (map-meta "del" "backward-kill-word") - (map-meta "c" "capitalize-word") - (map-meta "u" "upcase-word") - (map-meta "l" "downcase-word") - - (map "c:l" "center-view-on-line") - - (map "c:k" "delete-to-end-of-line") - (map "c:y" "paste-clipboard") - (map-meta "y" "paste-next") - (map "a:v" "paste-clipboard") - (map "d:v" "paste-clipboard") - (map "c:_" "undo") - (map "c:/" "undo") - (map (format "~a" (integer->char 31)) "undo") ; for Windows - strange - (map "c:+" "redo") - (map "a:z" "undo") - (map "d:z" "undo") - (map "c:x;u" "undo") - (map "c:w" "cut-clipboard") - (map "a:x" "cut-clipboard") - (map "d:x" "cut-clipboard") - (map-meta "w" "copy-clipboard") - (map "a:c" "copy-clipboard") - (map "d:c" "copy-clipboard") - - (map "s:delete" "cut-clipboard") - (map "c:insert" "copy-clipboard") - (map "s:insert" "paste-clipboard") - - (map-meta "space" "collapse-space") - ;(map-meta "\\" "remove-space") ; Conflicts with european keyboards. - (map "c:x;c:o" "collapse-newline") - (map "c:o" "open-line") - (map "c:t" "transpose-chars") - (map-meta "t" "transpose-words") - - (map "c:space" "toggle-anchor") - - (map "insert" "toggle-overwrite") - (map-meta "o" "toggle-overwrite") - - (map-meta "g" "goto-line") - (map-meta "p" "goto-position") - - (map "c:u" "command-repeat-0") - (let loop ([n 9]) - (unless (negative? n) - (let ([s (number->string n)]) - (map-meta s (string-append "command-repeat-" s)) - (loop (sub1 n))))) - - (map "c:x;e" "keyboard-macro-run-saved") - (map "c:x;(" "keyboard-macro-start-record") - (map "c:x;)" "keyboard-macro-end-record") - - (map "leftbuttontriple" "select-click-line") - (map "leftbuttondouble" "select-click-word") - - ;; the "roller ball" mice map clicking the ball to button 2. - (unless (eq? (system-type) 'windows) - (map "middlebutton" "paste-click-region")) - - (map ":rightbuttonseq" "mouse-popup-menu") - - (map "c:c;c:r" "make-read-only") - )))) - - (define setup-search - (let* ([send-frame - (λ (invoke-method) - (λ (edit event) - (let ([frame - (cond - [(is-a? edit editor<%>) - (let ([canvas (send edit get-active-canvas)]) - (and canvas - (send canvas get-top-level-window)))] - [(is-a? edit area<%>) - (send edit get-top-level-window)] - [else #f])]) - (if frame - (invoke-method frame) - (bell))) - #t))]) - (λ (kmap) - (let* ([map (λ (key func) - (send kmap map-function key func))] - [map-meta (λ (key func) - (send-map-function-meta kmap key func))] - [add (λ (name func) - (send kmap add-function name func))] - [add-m (λ (name func) - (send kmap add-function name func))]) - - (add "move-to-search-or-search" - (send-frame (λ (f) (send f move-to-search-or-search)))) ;; key 1 - (add "move-to-search-or-reverse-search" - (send-frame (λ (f) (send f move-to-search-or-reverse-search)))) ;; key 1b, backwards - (add "find-string-again" - (send-frame (λ (f) (send f search-again)))) ;; key 2 - (add "toggle-search-focus" - (send-frame (λ (f) (send f toggle-search-focus)))) ;; key 3 - (add "hide-search" - (send-frame (λ (f) (send f hide-search)))) ;; key 4 - - (case (system-type) - [(unix) - (map "c:s" "move-to-search-or-search") - (map-meta "%" "move-to-search-or-search") - (map "c:r" "move-to-search-or-reverse-search") - (map "f3" "find-string-again") - (map "c:i" "toggle-search-focus") - (map "c:g" "hide-search")] - [(windows) - (map "c:r" "move-to-search-or-reverse-search") - (map "f3" "find-string-again") - (map "c:g" "find-string-again") - - ;; covered by menu - ;(map "c:f" "move-to-search-or-search") - - (map "c:i" "toggle-search-focus")] - [(macos macosx) - (map "c:s" "move-to-search-or-search") - (map "c:g" "hide-search") - - ;; covered by menu - ;(map "d:f" "move-to-search-or-search") - - (map "c:r" "move-to-search-or-reverse-search") - (map "d:g" "find-string-again") - (map "c:i" "toggle-search-focus")]))))) - - (define setup-file - (let* ([get-outer-editor ;; : text% -> text% - ;; returns the outermost editor, if this editor is nested in an editor snip. - (λ (edit) - (let loop ([edit edit]) - (let ([admin (send edit get-admin)]) + all-split) + (loop (cdr chars) + null + (cons (reverse this-split) all-split)))] + [else + (loop (cdr chars) + (cons char this-split) + all-split)]))]))) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;; ;;;;;;;; + ;;;;;;; end canonicalize-keybinding-string ;;;;;;;; + ;;;;;;; ;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (define (make-meta-prefix-list key) + (list (string-append "m:" key) + (string-append "ESC;" key))) + + (define send-map-function-meta + (λ (keymap key func) + (for-each (λ (key) (send keymap map-function key func)) + (make-meta-prefix-list key)))) + + (define add-to-right-button-menu (make-parameter void)) + (define add-to-right-button-menu/before (make-parameter void)) + + (define setup-global + ; Define some useful keyboard functions + (let* ([ring-bell + (λ (edit event) + (bell))] + + [mouse-popup-menu + (λ (edit event) + (when (send event button-down?) + (let ([a (send edit get-admin)]) + (when a + (let ([m (make-object popup-menu%)]) + + ((add-to-right-button-menu/before) m edit event) + + (append-editor-operation-menu-items m) + (for-each + (λ (i) + (when (is-a? i selectable-menu-item<%>) + (send i set-shortcut #f))) + (send m get-items)) + + ((add-to-right-button-menu) m edit event) + + (let-values ([(x y) (send edit + dc-location-to-editor-location + (send event get-x) + (send event get-y))]) + (send a popup-menu m (+ x 1) (+ y 1))))))))] + + [toggle-anchor + (λ (edit event) + (send edit set-anchor + (not (send edit get-anchor))))] + [center-view-on-line + (λ (edit event) + (let ([new-mid-line (send edit position-line + (send edit get-start-position))] + [bt (box 0)] + [bb (box 0)]) + (send edit get-visible-line-range bt bb #f) + (let* ([half (sub1 (quotient (- (unbox bb) (unbox bt)) 2))] + [last-pos (send edit position-line (send edit last-position))] + [top-pos (send edit line-start-position + (max (min (- new-mid-line half) last-pos) 0))] + [bottom-pos (send edit line-start-position + (max 0 + (min (+ new-mid-line half) + last-pos)))]) + (send edit scroll-to-position + top-pos + #f + bottom-pos))) + #t)] + + [make-insert-brace-pair + (λ (open-brace close-brace) + (λ (edit event) + (send edit begin-edit-sequence) + (let ([selection-start (send edit get-start-position)]) + (send edit set-position (send edit get-end-position)) + (send edit insert close-brace) + (send edit set-position selection-start) + (send edit insert open-brace)) + (send edit end-edit-sequence)))] + + [insert-lambda-template + (λ (edit event) + (send edit begin-edit-sequence) + (let ([selection-start (send edit get-start-position)]) + (send edit set-position (send edit get-end-position)) + (send edit insert ")") + (send edit set-position selection-start) + (send edit insert ") ") + (send edit set-position selection-start) + (send edit insert "(λ (")) + (send edit end-edit-sequence))] + + [collapse-variable-space + ;; As per emacs: collapse tabs & spaces around the point, + ;; perhaps leaving a single space. + ;; drscheme bonus: if at end-of-line, collapse into the next line. + (λ (leave-one? edit event) + (letrec ([last-pos (send edit last-position)] + [sel-start (send edit get-start-position)] + [sel-end (send edit get-end-position)] + [collapsible? (λ (c) (and (char-whitespace? c) + (not (char=? #\newline c))))] + [find-noncollapsible + ; Return index of next non-collapsible char, + ; starting at pos in direction dir. + ; NB returns -1 or last-pos, if examining + ; initial/final whitespace + ; (or, when initial pos is outside of [0,last-pos).) + (λ (pos dir) + (let loop ([pos pos]) + (cond [(< pos 0) -1] + [(>= pos last-pos) last-pos] + [(collapsible? (send edit get-character pos)) + (loop (+ pos dir))] + [else pos])))]) + (when (= sel-start sel-end) ; Only when no selection: + (let* ([start (add1 (find-noncollapsible (sub1 sel-start) -1))] + [end-heeding-eol (find-noncollapsible sel-start +1)] + ; This is the end of the range, were we to always heed newlines. + + ; Special case: if we're sitting at EOL, + ; and we're not affecting much else, + ; then delete that EOL and collapse spaces + ; at the start of next line, too: + [end (if (and (<= (- end-heeding-eol start) + (if leave-one? 1 0)) + (char=? #\newline (send edit get-character end-heeding-eol)) + ; If you wish to avoid deleting an newline at EOF, do so here. + ) + (find-noncollapsible (add1 end-heeding-eol) +1) + end-heeding-eol)] + [making-no-difference? + ; Don't introduce edits into undo-chain, if no effect. + (if leave-one? + (and (= (- end start) 1) + (char=? #\space (send edit get-character start))) + (= (- end start) 0))]) + (unless making-no-difference? + (send edit begin-edit-sequence) + (send edit set-position end) ; Even after delete, caret will be at "end". + (send edit delete start end) + (when leave-one? (send edit insert #\space start)) + (send edit end-edit-sequence))))))] + + [collapse-space + (λ (edit event) + (collapse-variable-space #t edit event))] + + [remove-space + (λ (edit event) + (collapse-variable-space #f edit event))] + + [collapse-newline + (λ (edit event) + (letrec ([find-nonwhite + (λ (pos d offset) + (let/ec escape + (let ([max (if (> offset 0) + (send edit last-position) + 0)]) + (let loop ([pos pos]) + (if (= pos max) + (escape pos) + (let ([c (send edit get-character (+ pos offset))]) + (cond + [(char=? #\newline c) + (loop (+ pos d)) + (escape pos)] + [(char-whitespace? c) + (loop (+ pos d))] + [else pos])))))))]) + (let ([sel-start (send edit get-start-position)] + [sel-end (send edit get-end-position)]) + (when (= sel-start sel-end) + (let* ([pos-line (send edit position-line sel-start #f)] + [pos-line-start (send edit line-start-position pos-line)] + [pos-line-end (send edit line-end-position pos-line)] + + [whiteline? + (let loop ([pos pos-line-start]) + (if (>= pos pos-line-end) + #t + (and (char-whitespace? (send edit get-character pos)) + (loop (add1 pos)))))] + + [start (find-nonwhite pos-line-start -1 -1)] + [end (find-nonwhite pos-line-end 1 0)] + + [start-line + (send edit position-line start #f)] + [start-line-start + (send edit line-start-position start-line)] + [end-line + (send edit position-line end #f)] + [end-line-start + (send edit line-start-position (add1 end-line))]) (cond - [(is-a? admin editor-snip-editor-admin<%>) - (loop (send (send (send admin get-snip) get-admin) get-editor))] - [else edit]))))] - [save-file-as - (λ (this-edit event) - (let ([edit (get-outer-editor this-edit)]) - (parameterize ([finder:dialog-parent-parameter - (and (is-a? edit editor:basic<%>) - (send edit get-top-level-window))]) - (let ([file (finder:put-file)]) - (when file - (send edit save-file/gui-error file))))) - #t)] - [save-file - (λ (this-edit event) - (let ([edit (get-outer-editor this-edit)]) - (if (send edit get-filename) - (send edit save-file/gui-error) - (save-file-as edit event))) - #t)] - [load-file - (λ (edit event) - (handler:open-file) - #t)]) - (λ (kmap) - (let* ([map (λ (key func) - (send kmap map-function key func))] - [map-meta (λ (key func) - (send-map-function-meta kmap key func))] - [add (λ (name func) - (send kmap add-function name func))] - [add-m (λ (name func) - (send kmap add-function name func))]) - - (add "save-file" save-file) - (add "save-file-as" save-file-as) - (add "load-file" load-file) - - (map "c:x;c:s" "save-file") - (map "d:s" "save-file") - (map "c:x;c:w" "save-file-as") - (map "c:x;c:f" "load-file"))))) + [(and whiteline? + (= start-line pos-line) + (= end-line pos-line)) + ; Special case: just delete this line + (send edit delete pos-line-start (add1 pos-line-end))] + [(and whiteline? (< start-line pos-line)) + ; Can delete before & after + (send* edit + (begin-edit-sequence) + (delete (add1 pos-line-end) end-line-start) + (delete start-line-start pos-line-start) + (end-edit-sequence))] + [else + ; Only delete after + (send edit delete (add1 pos-line-end) + end-line-start)]))))))] + + [open-line + (λ (edit event) + (let ([sel-start (send edit get-start-position)] + [sel-end (send edit get-end-position)]) + (if (= sel-start sel-end) + (send* edit + (insert #\newline) + (set-position sel-start)))))] + + [transpose-chars + (λ (edit event) + (let ([sel-start (send edit get-start-position)] + [sel-end (send edit get-end-position)]) + (when (and (= sel-start sel-end) + (not (= sel-start 0))) + + (let ([sel-start + (if (= sel-start + (send edit line-end-position + (send edit position-line sel-start))) + (sub1 sel-start) + sel-start)]) + (let ([s (send edit get-text + sel-start (add1 sel-start))]) + (send* edit + (begin-edit-sequence) + (delete sel-start (add1 sel-start)) + (insert s (- sel-start 1)) + (set-position (add1 sel-start)) + (end-edit-sequence)))))))] + + [transpose-words + (λ (edit event) + (let ([sel-start (send edit get-start-position)] + [sel-end (send edit get-end-position)]) + (when (= sel-start sel-end) + (let ([word-1-start (box sel-start)]) + (send edit find-wordbreak word-1-start #f 'caret) + (let ([word-1-end (box (unbox word-1-start))]) + (send edit find-wordbreak #f word-1-end 'caret) + (let ([word-2-end (box (unbox word-1-end))]) + (send edit find-wordbreak #f word-2-end 'caret) + (let ([word-2-start (box (unbox word-2-end))]) + (send edit find-wordbreak word-2-start #f 'caret) + (let ([text-1 (send edit get-text + (unbox word-1-start) + (unbox word-1-end))] + [text-2 (send edit get-text + (unbox word-2-start) + (unbox word-2-end))]) + (send* edit + (begin-edit-sequence) + (insert text-1 + (unbox word-2-start) + (unbox word-2-end)) + (insert text-2 + (unbox word-1-start) + (unbox word-1-end)) + (set-position (unbox word-2-end)) + (end-edit-sequence))))))))))] + + [capitalize-it + (λ (edit char-case1 char-case2) + (let ([sel-start (send edit get-start-position)] + [sel-end (send edit get-end-position)] + [real-end (send edit last-position)]) + (when (= sel-start sel-end) + (let ([word-end (let ([b (box sel-start)]) + (send edit find-wordbreak #f b 'caret) + (min real-end (unbox b)))]) + (send edit begin-edit-sequence) + (let loop ([pos sel-start] + [char-case char-case1]) + (when (< pos word-end) + (let ([c (send edit get-character pos)]) + (cond + [(char-alphabetic? c) + (send edit insert + (list->string + (list (char-case c))) + pos (add1 pos)) + (loop (add1 pos) char-case2)] + [else + (loop (add1 pos) char-case)])))) + (send* edit + (end-edit-sequence) + (set-position word-end))))))] + + [capitalize-word + (λ (edit event) + (capitalize-it edit char-upcase char-downcase))] + [upcase-word + (λ (edit event) + (capitalize-it edit char-upcase char-upcase))] + [downcase-word + (λ (edit event) + (capitalize-it edit char-downcase char-downcase))] + + [kill-word + (λ (edit event) + (let ([sel-start (send edit get-start-position)] + [sel-end (send edit get-end-position)]) + (let ([end-box (box sel-end)]) + (send edit find-wordbreak #f end-box 'caret) + (send edit kill 0 sel-start (unbox end-box)))))] + + [backward-kill-word + (λ (edit event) + (let ([sel-start (send edit get-start-position)] + [sel-end (send edit get-end-position)]) + (let ([start-box (box sel-start)]) + (send edit find-wordbreak start-box #f 'caret) + (send edit kill 0 (unbox start-box) sel-end))))] + + [region-click + (λ (edit event f) + (when (and (send event button-down?) + (is-a? edit text%)) + (let ([x-box (box (send event get-x))] + [y-box (box (send event get-y))] + [eol-box (box #f)]) + (send edit global-to-local x-box y-box) + (let ([click-pos (send edit find-position + (unbox x-box) + (unbox y-box) + eol-box)] + [start-pos (send edit get-start-position)] + [end-pos (send edit get-end-position)]) + (let ([eol (unbox eol-box)]) + (if (< start-pos click-pos) + (f click-pos eol start-pos click-pos) + (f click-pos eol click-pos end-pos)))))))] + [copy-click-region + (λ (edit event) + (region-click edit event + (λ (click eol start end) + (send edit flash-on start end) + (send edit copy #f 0 start end))))] + [cut-click-region + (λ (edit event) + (region-click edit event + (λ (click eol start end) + (send edit cut #f 0 start end))))] + [paste-click-region + (λ (edit event) + (region-click edit event + (λ (click eol start end) + (send edit set-position click) + (send edit paste-x-selection 0 click))))] + + [mouse-copy-clipboard + (λ (edit event) + (send edit copy #f (send event get-time-stamp)))] + + [mouse-paste-clipboard + (λ (edit event) + (send edit paste (send event get-time-stamp)))] + + [mouse-cut-clipboard + (λ (edit event) + (send edit cut #f (send event get-time-stamp)))] + + [select-click-word + (λ (edit event) + (region-click edit event + (λ (click eol start end) + (let ([start-box (box click)] + [end-box (box click)]) + (send edit find-wordbreak + start-box + end-box + 'selection) + (send edit set-position + (unbox start-box) + (unbox end-box))))))] + [select-click-line + (λ (edit event) + (region-click edit event + (λ (click eol start end) + (let* ([line (send edit position-line + click eol)] + [start (send edit line-start-position + line #f)] + [end (send edit line-end-position + line #f)]) + (send edit set-position start end)))))] + + [goto-line + (λ (edit event) + (let ([num-str + (call/text-keymap-initializer + (λ () + (get-text-from-user + (string-constant goto-line) + (string-constant goto-line))))]) + (when (string? num-str) + (let* ([possible-num (string->number num-str)] + [line-num (and possible-num (inexact->exact possible-num))]) + (cond + [(and (number? line-num) + (integer? line-num) + (<= 1 line-num (+ (send edit last-paragraph) 1))) + (let ([pos (send edit paragraph-start-position + (sub1 line-num))]) + (send edit set-position pos))] + [else + (message-box + (string-constant goto-line) + (format + (string-constant goto-line-invalid-number) + num-str + (+ (send edit last-line) 1)))])))) + + #t)] + [goto-position + (λ (edit event) + (let ([num-str + (call/text-keymap-initializer + (λ () + (get-text-from-user + (string-constant goto-position) + (string-constant goto-position))))]) + (if (string? num-str) + (let ([pos (string->number num-str)]) + (when pos + (send edit set-position (sub1 pos)))))) + #t)] + [repeater + (λ (n edit) + (let* ([km (send edit get-keymap)] + [done + (λ () + (send km set-break-sequence-callback void) + (send km remove-grab-key-function))]) + (send km set-grab-key-function + (λ (name local-km edit event) + (if name + (begin + (done) + (dynamic-wind + (λ () + (send edit begin-edit-sequence)) + (λ () + (let loop ([n n]) + (unless (zero? n) + (send local-km call-function name edit event) + (loop (sub1 n))))) + (λ () + (send edit end-edit-sequence)))) + (let ([k (send event get-key-code)]) + (if (and (char? k) (char<=? #\0 k #\9)) + (set! n (+ (* n 10) (- (char->integer k) + (char->integer #\0)))) + (begin + (done) + (dynamic-wind + (λ () + (send edit begin-edit-sequence)) + (λ () + (let loop ([n n]) + (unless (zero? n) + (send edit on-char event) + (loop (sub1 n))))) + (λ () + (send edit end-edit-sequence))))))) + #t)) + (send km set-break-sequence-callback done) + #t))] + [make-make-repeater + (λ (n) + (λ (edit event) + (repeater n edit)))] + [current-macro '()] + [building-macro #f] [build-macro-km #f] [build-protect? #f] + [show/hide-keyboard-macro-icon + (λ (edit on?) + (when (is-a? edit editor:basic<%>) + (let ([frame (send edit get-top-level-window)]) + (when (is-a? frame frame:text-info<%>) + (send frame set-macro-recording on?) + (send frame update-shown)))))] + + [do-macro + (λ (edit event) + ; If c:x;e during record, copy the old macro + (when building-macro + (set! building-macro (append (reverse current-macro) + (cdr building-macro)))) + (let ([bm building-macro] + [km (send edit get-keymap)]) + (dynamic-wind + (λ () + (set! building-macro #f) + (send edit begin-edit-sequence)) + (λ () + (let/ec escape + (for-each + (λ (f) + (let ([name (car f)] + [event (cdr f)]) + (if name + (unless (send km call-function name edit event #t) + (escape #t)) + (send edit on-char event)))) + current-macro))) + (λ () + (send edit end-edit-sequence) + (set! building-macro bm)))) + #t)] + [start-macro + (λ (edit event) + (if building-macro + (send build-macro-km break-sequence) + (letrec ([km (send edit get-keymap)] + [done + (λ () + (if build-protect? + (send km set-break-sequence-callback done) + (begin + (set! building-macro #f) + (show/hide-keyboard-macro-icon edit #f) + (send km set-break-sequence-callback void) + (send km remove-grab-key-function))))]) + (set! building-macro '()) + (show/hide-keyboard-macro-icon edit #t) + (set! build-macro-km km) + (send km set-grab-key-function + (λ (name local-km edit event) + (dynamic-wind + (λ () + (set! build-protect? #t)) + (λ () + (if name + (send local-km call-function name edit event) + (send edit on-default-char event))) + (λ () + (set! build-protect? #f))) + (when building-macro + (set! building-macro + (cons (cons name event) + building-macro))) + #t)) + (send km set-break-sequence-callback done))) + #t)] + [end-macro + (λ (edit event) + (when building-macro + (set! current-macro (reverse building-macro)) + (set! build-protect? #f) + (send build-macro-km break-sequence)) + #t)] + [delete-key + (λ (edit event) + (let ([kmap (send edit get-keymap)]) + (send kmap call-function + (if (preferences:get 'framework:delete-forward?) + "delete-next-character" + "delete-previous-character") + edit event #t)))] + + [toggle-overwrite + (λ (edit event) + (send edit set-overwrite-mode + (not (send edit get-overwrite-mode))))] + + [down-into-embedded-editor + (λ (text event) + (let ([start (send text get-start-position)] + [end (send text get-end-position)]) + (when (= start end) + (let* ([bx (box 0)] + [after-snip (send text find-snip start 'after-or-none bx)]) + (cond + [(and (= (unbox bx) start) + after-snip + (is-a? after-snip editor-snip%)) + (let ([embedded-editor (send after-snip get-editor)]) + (when (is-a? embedded-editor text%) + (send embedded-editor set-position 0)) + (send embedded-editor set-caret-owner #f 'global))] + [else + (let ([before-snip (send text find-snip start 'before-or-none bx)]) + (when (and (= (+ (unbox bx) 1) start) + before-snip + (is-a? before-snip editor-snip%)) + (let ([embedded-editor (send before-snip get-editor)]) + (when (is-a? embedded-editor text%) + (send embedded-editor set-position + (send embedded-editor last-position))) + (send embedded-editor set-caret-owner #f 'global))))])))) + #t)] + + [forward-to-next-embedded-editor + (λ (text event) + (let ([start-pos (send text get-start-position)] + [end-pos (send text get-end-position)]) + (when (= start-pos end-pos) + (let loop ([snip (send text find-snip start-pos 'after-or-none)]) + (cond + [(not snip) (void)] + [(is-a? snip editor-snip%) + (send text set-position (send text get-snip-position snip))] + [else (loop (send snip next))])))) + #t)] + + [back-to-prev-embedded-editor + (λ (text event) + (let ([start-pos (send text get-start-position)] + [end-pos (send text get-end-position)]) + (when (= start-pos end-pos) + (let loop ([snip (send text find-snip start-pos 'before-or-none)]) + (cond + [(not snip) (void)] + [(is-a? snip editor-snip%) + (send text set-position (+ (send text get-snip-position snip) 1))] + [else (loop (send snip previous))])))) + #t)] + + [up-out-of-embedded-editor + (λ (text event) + (let ([start (send text get-start-position)] + [end (send text get-end-position)]) + (when (= start end) + (let ([editor-admin (send text get-admin)]) + (when (is-a? editor-admin editor-snip-editor-admin<%>) + (let* ([snip (send editor-admin get-snip)] + [snip-admin (send snip get-admin)]) + (when snip-admin + (let ([editor (send snip-admin get-editor)]) + (when (is-a? editor text%) + (let ([new-pos (send editor get-snip-position snip)]) + (send editor set-position new-pos new-pos)) + (send editor set-caret-owner #f 'display))))))))) + #t)] + + [make-read-only + (λ (text event) + (send text lock #t) + #t)] + + [greek-letters "αβγδεζηθι κλμνξοπρςστυφχψω"] + [Greek-letters "ΑΒΓΔΕΖΗΘΙ ΚΛΜΝΞΟΠΡ ΣΤΥΦΧΨΩ"]) ;; don't have a capital ς, just comes out as \u03A2 (or junk) - (define (setup-editor kmap) - (let ([add/map - (λ (func op key) - (send kmap add-function - func - (λ (editor evt) - (send editor do-edit-operation op))) - (send kmap map-function - (string-append - (case (system-type) - [(macosx macos) "d:"] - [(windows) "c:"] - [(unix) "a:"] - [else (error 'keymap.ss "unknown platform: ~s" (system-type))]) - key) - func))]) - (add/map "editor-undo" 'undo "z") - (add/map "editor-redo" 'redo "y") - (add/map "editor-cut" 'cut "x") - (add/map "editor-copy" 'copy "c") - (add/map "editor-paste" 'paste "v") - (add/map "editor-select-all" 'select-all "a"))) - - (define (generic-setup keymap) - (add-editor-keymap-functions keymap) - (add-pasteboard-keymap-functions keymap) - (add-text-keymap-functions keymap)) - - (define global (make-object aug-keymap%)) - (define global-main (make-object aug-keymap%)) - (send global chain-to-keymap global-main #t) - (setup-global global-main) - (generic-setup global-main) - (define (get-global) global) - - (define file (make-object aug-keymap%)) - (setup-file file) - (generic-setup file) - (define (-get-file) file) - - (define search (make-object aug-keymap%)) - (generic-setup search) - (setup-search search) - (define (get-search) search) - - (define editor (make-object aug-keymap%)) - (setup-editor editor) - (define (get-editor) editor) - - (define (call/text-keymap-initializer thunk) - (let ([ctki (current-text-keymap-initializer)]) - (parameterize ([current-text-keymap-initializer - (λ (keymap) - (send keymap chain-to-keymap global #t) - (ctki keymap))]) - (thunk))))) + (λ (kmap) + (let* ([map (λ (key func) + (send kmap map-function key func))] + [map-meta (λ (key func) + (send-map-function-meta kmap key func))] + [add (λ (name func) + (send kmap add-function name func))] + [add-m (λ (name func) + (send kmap add-function name func))]) + + ; Map names to keyboard functions + + (for-each + (λ (c) + (unless (equal? c #\space) + (add (format "insert ~a" c) + (λ (txt evt) (send txt insert c))))) + (string->list (string-append greek-letters Greek-letters))) + + (add "down-into-embedded-editor" down-into-embedded-editor) + (add "up-out-of-embedded-editor" up-out-of-embedded-editor) + (add "forward-to-next-embedded-editor" forward-to-next-embedded-editor) + (add "back-to-prev-embedded-editor" back-to-prev-embedded-editor) + + (add "toggle-overwrite" toggle-overwrite) + + (add "exit" (λ (edit event) + (let ([frame (send edit get-frame)]) + (if (and frame + (is-a? frame frame:standard-menus<%>)) + (send frame file-menu:quit) + (bell))))) + + (add "ring-bell" ring-bell) + + (add "insert-()-pair" (make-insert-brace-pair "(" ")")) + (add "insert-[]-pair" (make-insert-brace-pair "[" "]")) + (add "insert-{}-pair" (make-insert-brace-pair "{" "}")) + (add "insert-\"\"-pair" (make-insert-brace-pair "\"" "\"")) + (add "insert-||-pair" (make-insert-brace-pair "|" "|")) + (add "insert-lambda-template" insert-lambda-template) + + (add "toggle-anchor" toggle-anchor) + (add "center-view-on-line" center-view-on-line) + (add "collapse-space" collapse-space) + (add "remove-space" remove-space) + (add "collapse-newline" collapse-newline) + (add "open-line" open-line) + (add "transpose-chars" transpose-chars) + (add "transpose-words" transpose-words) + (add "capitalize-word" capitalize-word) + (add "upcase-word" upcase-word) + (add "downcase-word" downcase-word) + (add "kill-word" kill-word) + (add "backward-kill-word" backward-kill-word) + + (let loop ([n 9]) + (unless (negative? n) + (let ([s (number->string n)]) + (add (string-append "command-repeat-" s) + (make-make-repeater n)) + (loop (sub1 n))))) + + (add "keyboard-macro-run-saved" do-macro) + (add "keyboard-macro-start-record" start-macro) + (add "keyboard-macro-end-record" end-macro) + + (add-m "copy-clipboard" mouse-copy-clipboard) + (add-m "cut-clipboard" mouse-cut-clipboard) + (add-m "paste-clipboard" mouse-paste-clipboard) + (add-m "copy-click-region" copy-click-region) + (add-m "cut-click-region" cut-click-region) + (add-m "paste-click-region" paste-click-region) + (add-m "select-click-word" select-click-word) + (add-m "select-click-line" select-click-line) + + (add "goto-line" goto-line) + (add "goto-position" goto-position) + + (add "delete-key" delete-key) + + (add "mouse-popup-menu" mouse-popup-menu) + + (add "make-read-only" make-read-only) + + ; Map keys to functions + + (let ([setup-mappings + (λ (greek-chars shift?) + (let loop ([i 0]) + (when (< i (string-length greek-chars)) + (let ([greek-char (string-ref greek-chars i)]) + (unless (equal? greek-char #\space) + (let ([roman-char + (integer->char + (+ (char->integer #\a) i))]) + (map (format "a:g;~a~a" + (if shift? "s:" "") + roman-char) + (format "insert ~a" greek-char)) + (map (format "c:x;c:g;~a~a" + (if shift? "s:" "") + roman-char) + (format "insert ~a" greek-char))))) + (loop (+ i 1)))))]) + (setup-mappings greek-letters #f) + (setup-mappings Greek-letters #t)) + + (map-meta "c:down" "down-into-embedded-editor") + (map "a:c:down" "down-into-embedded-editor") + (map-meta "c:up" "up-out-of-embedded-editor") + (map "a:c:up" "up-out-of-embedded-editor") + (map-meta "c:right" "forward-to-next-embedded-editor") + (map "a:c:right" "forward-to-next-embedded-editor") + (map-meta "c:left" "back-to-prev-embedded-editor") + (map "a:c:left" "back-to-prev-embedded-editor") + + (map "c:c;c:g" "ring-bell") + + (map-meta "(" "insert-()-pair") + (map-meta "[" "insert-[]-pair") + (map-meta "{" "insert-{}-pair") + (map-meta "\"" "insert-\"\"-pair") + (map-meta "|" "insert-||-pair") + (map-meta "s:l" "insert-lambda-template") + + (map "c:p" "previous-line") + (map "up" "previous-line") + (map "s:c:p" "select-up") + (map "s:up" "select-up") + + (map "c:n" "next-line") + (map "down" "next-line") + (map "s:c:n" "select-down") + (map "s:down" "select-down") + + (map "c:e" "end-of-line") + (map "d:right" "end-of-line") + (map "m:right" "end-of-line") + (map "end" "end-of-line") + (map "m:s:right" "select-to-end-of-line") + (map "s:end" "select-to-end-of-line") + (map "s:c:e" "select-to-end-of-line") + + (map "c:a" "beginning-of-line") + (map "d:left" "beginning-of-line") + (map "m:left" "beginning-of-line") + (map "home" "beginning-of-line") + (map "m:s:left" "select-to-beginning-of-line") + (map "s:home" "select-to-beginning-of-line") + (map "s:c:a" "select-to-beginning-of-line") + + (map "c:f" "forward-character") + (map "right" "forward-character") + (map "s:c:f" "forward-select") + (map "s:right" "forward-select") + + (map "c:b" "backward-character") + (map "left" "backward-character") + (map "s:c:b" "backward-select") + (map "s:left" "backward-select") + + (map-meta "f" "forward-word") + (map "a:right" "forward-word") + (map "c:right" "forward-word") + (map-meta "s:f" "forward-select-word") + (map "a:s:right" "forward-select-word") + (map "c:s:right" "forward-select-word") + + (map-meta "b" "backward-word") + (map "a:left" "backward-word") + + (map "c:left" "backward-word") + (map-meta "s:b" "backward-select-word") + (map "a:s:left" "backward-select-word") + (map "c:s:left" "backward-select-word") + + (map-meta "<" "beginning-of-file") + (map "d:up" "beginning-of-file") + (map "c:home" "beginning-of-file") + (map "s:c:home" "select-to-beginning-of-file") + (map "s:d:up" "select-to-beginning-of-file") + + (map-meta ">" "end-of-file") + (map "d:down" "end-of-file") + (map "c:end" "end-of-file") + (map "s:c:end" "select-to-end-of-file") + (map "s:d:down" "select-to-end-of-file") + + (map "c:v" "next-page") + (map "a:down" "next-page") + (map "pagedown" "next-page") + (map "c:down" "next-page") + (map "s:c:v" "select-page-down") + (map "a:s:down" "select-page-down") + (map "s:pagedown" "select-page-down") + (map "s:c:down" "select-page-down") + + (map-meta "v" "previous-page") + (map "a:up" "previous-page") + (map "pageup" "previous-page") + (map "c:up" "previous-page") + (map-meta "s:v" "select-page-up") + (map "s:a:up" "select-page-up") + (map "s:pageup" "select-page-up") + (map "s:c:up" "select-page-up") + + (map "c:h" "delete-previous-character") + (map "c:d" "delete-next-character") + (map "del" "delete-key") + + (map-meta "d" "kill-word") + (map-meta "del" "backward-kill-word") + (map-meta "c" "capitalize-word") + (map-meta "u" "upcase-word") + (map-meta "l" "downcase-word") + + (map "c:l" "center-view-on-line") + + (map "c:k" "delete-to-end-of-line") + (map "c:y" "paste-clipboard") + (map-meta "y" "paste-next") + (map "a:v" "paste-clipboard") + (map "d:v" "paste-clipboard") + (map "c:_" "undo") + (map "c:/" "undo") + (map (format "~a" (integer->char 31)) "undo") ; for Windows - strange + (map "c:+" "redo") + (map "a:z" "undo") + (map "d:z" "undo") + (map "c:x;u" "undo") + (map "c:w" "cut-clipboard") + (map "a:x" "cut-clipboard") + (map "d:x" "cut-clipboard") + (map-meta "w" "copy-clipboard") + (map "a:c" "copy-clipboard") + (map "d:c" "copy-clipboard") + + (map "s:delete" "cut-clipboard") + (map "c:insert" "copy-clipboard") + (map "s:insert" "paste-clipboard") + + (map-meta "space" "collapse-space") + ;(map-meta "\\" "remove-space") ; Conflicts with european keyboards. + (map "c:x;c:o" "collapse-newline") + (map "c:o" "open-line") + (map "c:t" "transpose-chars") + (map-meta "t" "transpose-words") + + (map "c:space" "toggle-anchor") + + (map "insert" "toggle-overwrite") + (map-meta "o" "toggle-overwrite") + + (map-meta "g" "goto-line") + (map-meta "p" "goto-position") + + (map "c:u" "command-repeat-0") + (let loop ([n 9]) + (unless (negative? n) + (let ([s (number->string n)]) + (map-meta s (string-append "command-repeat-" s)) + (loop (sub1 n))))) + + (map "c:x;e" "keyboard-macro-run-saved") + (map "c:x;(" "keyboard-macro-start-record") + (map "c:x;)" "keyboard-macro-end-record") + + (map "leftbuttontriple" "select-click-line") + (map "leftbuttondouble" "select-click-word") + + ;; the "roller ball" mice map clicking the ball to button 2. + (unless (eq? (system-type) 'windows) + (map "middlebutton" "paste-click-region")) + + (map ":rightbuttonseq" "mouse-popup-menu") + + (map "c:c;c:r" "make-read-only") + )))) + + (define setup-search + (let* ([send-frame + (λ (invoke-method) + (λ (edit event) + (let ([frame + (cond + [(is-a? edit editor<%>) + (let ([canvas (send edit get-active-canvas)]) + (and canvas + (send canvas get-top-level-window)))] + [(is-a? edit area<%>) + (send edit get-top-level-window)] + [else #f])]) + (if frame + (invoke-method frame) + (bell))) + #t))]) + (λ (kmap) + (let* ([map (λ (key func) + (send kmap map-function key func))] + [map-meta (λ (key func) + (send-map-function-meta kmap key func))] + [add (λ (name func) + (send kmap add-function name func))] + [add-m (λ (name func) + (send kmap add-function name func))]) + + (add "move-to-search-or-search" + (send-frame (λ (f) (send f move-to-search-or-search)))) ;; key 1 + (add "move-to-search-or-reverse-search" + (send-frame (λ (f) (send f move-to-search-or-reverse-search)))) ;; key 1b, backwards + (add "find-string-again" + (send-frame (λ (f) (send f search-again)))) ;; key 2 + (add "toggle-search-focus" + (send-frame (λ (f) (send f toggle-search-focus)))) ;; key 3 + (add "hide-search" + (send-frame (λ (f) (send f hide-search)))) ;; key 4 + + (case (system-type) + [(unix) + (map "c:s" "move-to-search-or-search") + (map-meta "%" "move-to-search-or-search") + (map "c:r" "move-to-search-or-reverse-search") + (map "f3" "find-string-again") + (map "c:i" "toggle-search-focus") + (map "c:g" "hide-search")] + [(windows) + (map "c:r" "move-to-search-or-reverse-search") + (map "f3" "find-string-again") + (map "c:g" "find-string-again") + + ;; covered by menu + ;(map "c:f" "move-to-search-or-search") + + (map "c:i" "toggle-search-focus")] + [(macos macosx) + (map "c:s" "move-to-search-or-search") + (map "c:g" "hide-search") + + ;; covered by menu + ;(map "d:f" "move-to-search-or-search") + + (map "c:r" "move-to-search-or-reverse-search") + (map "d:g" "find-string-again") + (map "c:i" "toggle-search-focus")]))))) + + (define setup-file + (let* ([get-outer-editor ;; : text% -> text% + ;; returns the outermost editor, if this editor is nested in an editor snip. + (λ (edit) + (let loop ([edit edit]) + (let ([admin (send edit get-admin)]) + (cond + [(is-a? admin editor-snip-editor-admin<%>) + (loop (send (send (send admin get-snip) get-admin) get-editor))] + [else edit]))))] + [save-file-as + (λ (this-edit event) + (let ([edit (get-outer-editor this-edit)]) + (parameterize ([finder:dialog-parent-parameter + (and (is-a? edit editor:basic<%>) + (send edit get-top-level-window))]) + (let ([file (finder:put-file)]) + (when file + (send edit save-file/gui-error file))))) + #t)] + [save-file + (λ (this-edit event) + (let ([edit (get-outer-editor this-edit)]) + (if (send edit get-filename) + (send edit save-file/gui-error) + (save-file-as edit event))) + #t)] + [load-file + (λ (edit event) + (handler:open-file) + #t)]) + (λ (kmap) + (let* ([map (λ (key func) + (send kmap map-function key func))] + [map-meta (λ (key func) + (send-map-function-meta kmap key func))] + [add (λ (name func) + (send kmap add-function name func))] + [add-m (λ (name func) + (send kmap add-function name func))]) + + (add "save-file" save-file) + (add "save-file-as" save-file-as) + (add "load-file" load-file) + + (map "c:x;c:s" "save-file") + (map "d:s" "save-file") + (map "c:x;c:w" "save-file-as") + (map "c:x;c:f" "load-file"))))) + + (define (setup-editor kmap) + (let ([add/map + (λ (func op key) + (send kmap add-function + func + (λ (editor evt) + (send editor do-edit-operation op))) + (send kmap map-function + (string-append + (case (system-type) + [(macosx macos) "d:"] + [(windows) "c:"] + [(unix) "a:"] + [else (error 'keymap.ss "unknown platform: ~s" (system-type))]) + key) + func))]) + (add/map "editor-undo" 'undo "z") + (add/map "editor-redo" 'redo "y") + (add/map "editor-cut" 'cut "x") + (add/map "editor-copy" 'copy "c") + (add/map "editor-paste" 'paste "v") + (add/map "editor-select-all" 'select-all "a"))) + + (define (generic-setup keymap) + (add-editor-keymap-functions keymap) + (add-pasteboard-keymap-functions keymap) + (add-text-keymap-functions keymap)) + + (define global (make-object aug-keymap%)) + (define global-main (make-object aug-keymap%)) + (send global chain-to-keymap global-main #t) + (setup-global global-main) + (generic-setup global-main) + (define (get-global) global) + + (define file (make-object aug-keymap%)) + (setup-file file) + (generic-setup file) + (define (-get-file) file) + + (define search (make-object aug-keymap%)) + (generic-setup search) + (setup-search search) + (define (get-search) search) + + (define editor (make-object aug-keymap%)) + (setup-editor editor) + (define (get-editor) editor) + + (define (call/text-keymap-initializer thunk) + (let ([ctki (current-text-keymap-initializer)]) + (parameterize ([current-text-keymap-initializer + (λ (keymap) + (send keymap chain-to-keymap global #t) + (ctki keymap))]) + (thunk))))) diff --git a/collects/framework/private/main.ss b/collects/framework/private/main.ss index 11791ada..ef990d91 100644 --- a/collects/framework/private/main.ss +++ b/collects/framework/private/main.ss @@ -1,8 +1,8 @@ (module main (lib "a-unit.ss") (require (lib "class.ss") - "sig.ss" + "sig.ss" "../preferences.ss" - (lib "mred-sig.ss" "mred")) + (lib "mred-sig.ss" "mred")) (import mred^ [prefix preferences: framework:preferences^] @@ -276,7 +276,7 @@ (color-prefs:set-default/color-scheme 'framework:delegatee-overview-color "light blue" (make-object color% 62 67 155)) - + ;; groups diff --git a/collects/framework/private/menu.ss b/collects/framework/private/menu.ss index f4b7b4dd..1fd62879 100644 --- a/collects/framework/private/menu.ss +++ b/collects/framework/private/menu.ss @@ -1,48 +1,48 @@ (module menu (lib "a-unit.ss") (require (lib "class.ss") - "sig.ss" - "../preferences.ss" + "sig.ss" + "../preferences.ss" (lib "mred-sig.ss" "mred")) (import mred^) (export framework:menu^) + + (define can-restore<%> + (interface (selectable-menu-item<%>) + restore-keybinding)) + + (define can-restore-mixin + (mixin (selectable-menu-item<%>) (can-restore<%>) + (inherit set-shortcut get-shortcut) + (define saved-shortcut 'not-yet) + (define/public (restore-keybinding) + (unless (eq? saved-shortcut 'not-yet) + (set-shortcut saved-shortcut))) - (define can-restore<%> - (interface (selectable-menu-item<%>) - restore-keybinding)) - - (define can-restore-mixin - (mixin (selectable-menu-item<%>) (can-restore<%>) - (inherit set-shortcut get-shortcut) - (define saved-shortcut 'not-yet) - (define/public (restore-keybinding) - (unless (eq? saved-shortcut 'not-yet) - (set-shortcut saved-shortcut))) - - (super-new) - (set! saved-shortcut (get-shortcut)) - (unless (preferences:get 'framework:menu-bindings) - (set-shortcut #f)))) - - (define can-restore-underscore<%> - (interface (labelled-menu-item<%>) - erase-underscores - restore-underscores)) - - (define can-restore-underscore-mixin - (mixin (labelled-menu-item<%>) (can-restore-underscore<%>) - (inherit get-label get-plain-label set-label) - (define/public (erase-underscores) - (set-label (get-plain-label))) - (define/public (restore-underscores) - (unless (eq? saved-label 'not-yet-saved-label) - (set-label saved-label))) - (define saved-label 'not-yet-saved-label) - (super-new) - (set! saved-label (get-label)) - (unless (preferences:get 'framework:menu-bindings) - (erase-underscores)))) - - (define can-restore-menu-item% (can-restore-mixin menu-item%)) - (define can-restore-checkable-menu-item% (can-restore-mixin checkable-menu-item%)) - (define can-restore-underscore-menu% (can-restore-underscore-mixin menu%))) + (super-new) + (set! saved-shortcut (get-shortcut)) + (unless (preferences:get 'framework:menu-bindings) + (set-shortcut #f)))) + + (define can-restore-underscore<%> + (interface (labelled-menu-item<%>) + erase-underscores + restore-underscores)) + + (define can-restore-underscore-mixin + (mixin (labelled-menu-item<%>) (can-restore-underscore<%>) + (inherit get-label get-plain-label set-label) + (define/public (erase-underscores) + (set-label (get-plain-label))) + (define/public (restore-underscores) + (unless (eq? saved-label 'not-yet-saved-label) + (set-label saved-label))) + (define saved-label 'not-yet-saved-label) + (super-new) + (set! saved-label (get-label)) + (unless (preferences:get 'framework:menu-bindings) + (erase-underscores)))) + + (define can-restore-menu-item% (can-restore-mixin menu-item%)) + (define can-restore-checkable-menu-item% (can-restore-mixin checkable-menu-item%)) + (define can-restore-underscore-menu% (can-restore-underscore-mixin menu%))) diff --git a/collects/framework/private/mode.ss b/collects/framework/private/mode.ss index ec5456dc..007b24e1 100644 --- a/collects/framework/private/mode.ss +++ b/collects/framework/private/mode.ss @@ -1,50 +1,50 @@ (module mode (lib "a-unit.ss") (require (lib "surrogate.ss") - (lib "class.ss") + (lib "class.ss") "sig.ss") (import) (export framework:mode^) - - (define-values (host-text-mixin host-text<%> surrogate-text% surrogate-text<%>) - (surrogate - (augment (void) on-change ()) - (override on-char (event)) - (override on-default-char (event)) - (override on-default-event (event)) - (augment (void) on-display-size ()) - (augment (void) on-edit-sequence ()) - (override on-event (event)) - (override on-focus (on?)) - (augment (void) on-load-file (filename format)) - (override on-local-char (event)) - (override on-local-event (event)) - (override on-new-box (type)) - (override on-new-image-snip (filename kind relative-path? inline?)) - (override on-paint (before? dc left top right bottom dx dy draw-caret)) - (augment (void) on-save-file (filename format)) - (augment (void) on-snip-modified (snip modified?)) - - (augment (void) on-change-style (start len)) - (augment (void) on-delete (start len)) - (augment (void) on-insert (start len)) - (override on-new-string-snip ()) - (override on-new-tab-snip ()) - (augment (void) on-set-size-constraint ()) - - (augment (void) after-change-style (start len)) - (augment (void) after-delete (start len)) - (augment (void) after-insert (start len)) - (augment (void) after-set-position ()) - (augment (void) after-set-size-constraint ()) - (augment (void) after-edit-sequence ()) - (augment (void) after-load-file (success?)) - (augment (void) after-save-file (success?)) - - (augment #t can-change-style? (start len)) - (augment #t can-delete? (start len)) - (augment #t can-insert? (start len)) - (augment #t can-set-size-constraint? ()) - (override can-do-edit-operation? (op) (op recursive?)) - (augment #t can-load-file? (filename format)) - (augment #t can-save-file? (filename format))))) + + (define-values (host-text-mixin host-text<%> surrogate-text% surrogate-text<%>) + (surrogate + (augment (void) on-change ()) + (override on-char (event)) + (override on-default-char (event)) + (override on-default-event (event)) + (augment (void) on-display-size ()) + (augment (void) on-edit-sequence ()) + (override on-event (event)) + (override on-focus (on?)) + (augment (void) on-load-file (filename format)) + (override on-local-char (event)) + (override on-local-event (event)) + (override on-new-box (type)) + (override on-new-image-snip (filename kind relative-path? inline?)) + (override on-paint (before? dc left top right bottom dx dy draw-caret)) + (augment (void) on-save-file (filename format)) + (augment (void) on-snip-modified (snip modified?)) + + (augment (void) on-change-style (start len)) + (augment (void) on-delete (start len)) + (augment (void) on-insert (start len)) + (override on-new-string-snip ()) + (override on-new-tab-snip ()) + (augment (void) on-set-size-constraint ()) + + (augment (void) after-change-style (start len)) + (augment (void) after-delete (start len)) + (augment (void) after-insert (start len)) + (augment (void) after-set-position ()) + (augment (void) after-set-size-constraint ()) + (augment (void) after-edit-sequence ()) + (augment (void) after-load-file (success?)) + (augment (void) after-save-file (success?)) + + (augment #t can-change-style? (start len)) + (augment #t can-delete? (start len)) + (augment #t can-insert? (start len)) + (augment #t can-set-size-constraint? ()) + (override can-do-edit-operation? (op) (op recursive?)) + (augment #t can-load-file? (filename format)) + (augment #t can-save-file? (filename format))))) diff --git a/collects/framework/private/number-snip.ss b/collects/framework/private/number-snip.ss index 53460550..1e40e10d 100644 --- a/collects/framework/private/number-snip.ss +++ b/collects/framework/private/number-snip.ss @@ -1,8 +1,8 @@ (module number-snip (lib "a-unit.ss") (require "sig.ss" - (lib "mred-sig.ss" "mred") - (lib "class.ss") + (lib "mred-sig.ss" "mred") + (lib "class.ss") "../preferences.ss" (lib "string-constant.ss" "string-constants")) @@ -10,509 +10,509 @@ (export (rename framework:number-snip^ [-snip-class% snip-class%])) (init-depend mred^) + + ;; make-repeating-decimal-snip : number boolean -> snip + (define (make-repeating-decimal-snip number e-prefix?) + (instantiate number-snip% () + [number number] + [decimal-prefix (if e-prefix? "#e" "")])) + + ;; make-fraction-snip : number boolean -> snip + (define (make-fraction-snip number e-prefix?) + (let ([n (instantiate number-snip% () + [number number] + [decimal-prefix (if e-prefix? "#e" "")])]) + (send n set-fraction-view (preferences:get 'framework:fraction-snip-style)) + n)) + + (define (set-box/f! b v) (when (box? b) (set-box! b v))) + (define bw? (< (get-display-depth) 3)) + + (define -snip-class% + (class snip-class% + (define/override (read f) + (let* ([number (string->number (bytes->string/utf-8 (send f get-bytes)))] + [decimal-prefix (bytes->string/utf-8 (send f get-bytes))] + [fraction-bytes (send f get-bytes)] + [expansions (string->number (bytes->string/utf-8 (send f get-bytes)))] + [fraction-view + (cond + [(equal? #"#t" fraction-bytes) 'decimal] + [(equal? #"#f" fraction-bytes) + (preferences:get 'framework:fraction-snip-style)] + [(equal? #"mixed" fraction-bytes) 'mixed] + [(equal? #"decimal" fraction-bytes) 'decimal] + [(equal? #"improper" fraction-bytes) 'improper])] + [snip + (instantiate number-snip% () + [number number] + [decimal-prefix decimal-prefix])]) + (send snip iterate (max 0 (- expansions 1))) ;; one iteration is automatic + (send snip set-fraction-view fraction-view) + snip)) + (super-new))) + + (define old-number-snipclass (new -snip-class%)) + (send old-number-snipclass set-version 3) + (send old-number-snipclass set-classname "drscheme:number") + (send (get-the-snip-class-list) add old-number-snipclass) + + (define number-snipclass (new -snip-class%)) + (send number-snipclass set-version 1) + (send number-snipclass set-classname (format "~s" '(lib "number-snip.ss" "drscheme" "private"))) + (send (get-the-snip-class-list) add number-snipclass) + + (define arrow-cursor (make-object cursor% 'arrow)) + + ;; cut-off : number + ;; indicates how many digits to fetch for each click + (define cut-off 25) + + (define number-snip% + (class* snip% (readable-snip<%>) + ;; number : number + ;; this is the number to show + (init-field number) + (define/public (get-number) number) - ;; make-repeating-decimal-snip : number boolean -> snip - (define (make-repeating-decimal-snip number e-prefix?) - (instantiate number-snip% () - [number number] - [decimal-prefix (if e-prefix? "#e" "")])) + ;; decimal-prefix : string + ;; this prefix is shown on the string when it is viewed in + ;; the decimal view + (init-field [decimal-prefix ""]) - ;; make-fraction-snip : number boolean -> snip - (define (make-fraction-snip number e-prefix?) - (let ([n (instantiate number-snip% () - [number number] - [decimal-prefix (if e-prefix? "#e" "")])]) - (send n set-fraction-view (preferences:get 'framework:fraction-snip-style)) - n)) + ;; fraction-view : (union 'decimal 'mixed 'improper) + ;; this field holds the current view state + (field [fraction-view 'decimal]) - (define (set-box/f! b v) (when (box? b) (set-box! b v))) - (define bw? (< (get-display-depth) 3)) + ;; these fields are for the drawing code for decimal printing + (field + ;; clickable-portion : (union #f string) + [clickable-portion #f] + ;; unbarred-portion : string + [unbarred-portion ""] + ;; barred-portion : (union #f string) + [barred-portion #f]) - (define -snip-class% - (class snip-class% - (define/override (read f) - (let* ([number (string->number (bytes->string/utf-8 (send f get-bytes)))] - [decimal-prefix (bytes->string/utf-8 (send f get-bytes))] - [fraction-bytes (send f get-bytes)] - [expansions (string->number (bytes->string/utf-8 (send f get-bytes)))] - [fraction-view - (cond - [(equal? #"#t" fraction-bytes) 'decimal] - [(equal? #"#f" fraction-bytes) - (preferences:get 'framework:fraction-snip-style)] - [(equal? #"mixed" fraction-bytes) 'mixed] - [(equal? #"decimal" fraction-bytes) 'decimal] - [(equal? #"improper" fraction-bytes) 'improper])] - [snip - (instantiate number-snip% () + (field + ;; wholes/frac : string + ;; the whole-number portion of the number as a fraction + [wholes/frac + (cond + [(= (floor number) 0) ""] + [(= (ceiling number) 0) "-"] + [(< number 0) + (number->string (ceiling number))] + [else + (number->string (floor number))])]) + + (field + ;; wholes/dec : string + ;; the whole-number portion of decimal expansion + [wholes/dec + (cond + [(= (floor number) 0) "0"] + [(= (ceiling number) 0) "-0"] + [(< number 0) + (number->string (ceiling number))] + [else + (number->string (floor number))])]) + + ;; these fields are for the fractional printing view + (field + ;; nums : string + ;; the numerator of the mixed fraction, as a string + [nums (number->string (numerator (- (abs number) (floor (abs number)))))] + + ;; improper-nums : string + ;; the numerator of the improper fraction, as a string + [improper-nums (number->string (numerator (abs number)))] + + ;; mixed-prefix : string + ;; a prefix on the front of the mixed number (indicates if negative) + [improper-prefix (if (number . < . 0) "-" "")] + + ;; dens : string + ;; the denominator, as a string + [dens (number->string (denominator (- (abs number) (floor (abs number)))))]) + + ;; these fields are for the decimal expansion calculation code + (field + [init-num (* 10 (numerator (- (abs number) (floor (abs number)))))] + [den (denominator (- (abs number) (floor (abs number))))]) + + ;; ht : number -o> (cons digit number) + ;; this maps from divisors of the denominator to + ;; digit and new divisor pairs. Use this + ;; to read off the decimal expansion. + (field + [ht (make-hash-table 'equal)] + [expansions 0]) + + ;; this field holds the state of the current computation + ;; of the numbers digits. If it is a number, it corresponds + ;; to the next starting divisor in the iteration. + ;; if it is #f, it means that the string of digits is + ;; fully computed. + (field [state init-num]) + + ;; repeat : (union 'unk number #f) + ;; this field correlates with `state'. If `state' is a number, + ;; this field is 'unk. Otherwise, this is either a number of #f. + ;; #f indicates no repeat. + ;; a number indiates a repeat starting at `number' in `ht'. + (field [repeat 'unk]) + + ;; set-fraction-view : (union 'mixed 'improper 'decimal) -> void + ;; sets the view based on the input + (define/public (set-fraction-view b) + (set! fraction-view b) + (let ([admin (get-admin)]) + (when admin + (send admin resized this #t)))) + + ;; get-fraction-view : -> (union 'mixed 'improper 'decimal) + ;; returns the current fraction view settings + (define/public (get-fraction-view) fraction-view) + + ;; iterate : number -> void + ;; computes the next sequence of digits (`n' times) + ;; and update the strings for GUI drawing + (define/public (iterate n) + (let loop ([n n]) + (unless (zero? n) + (expand-number) + (loop (- n 1)))) + (update-drawing-fields)) + + (inherit get-admin) + + ;; iterate/reflow : -> void + ;; iterates the fraction and tells the administrator to redraw the numbers + (define/private (iterate/reflow) + (iterate 1) + (let ([admin (get-admin)]) + (when admin + (send admin resized this #t)))) + + ;; one-step-division : number -> number number + ;; given a numerator and denominator, + ;; returns a digits and a new numerator to consider + (define/private (one-step-division num) + (cond + [(num . < . den) (values 0 (* 10 num))] + [else + (let ([qu (quotient num den)]) + (values qu (* 10 (- num (* qu den)))))])) + + ;; expand-number : -> void + ;; iterates until the numbers decimal expansion is completely computed, + ;; or the number's decimal expansion terminates. + (define/public (expand-number) + (when state + (set! expansions (+ expansions 1)) + (let loop ([num state] + [counter cut-off]) + (cond + [(hash-table-bound? ht num) + (set! state #f) + (set! repeat num)] + [(zero? counter) + (set! state num)] + [else + (let-values ([(dig next-num) (one-step-division num)]) + (if (zero? next-num) + (begin + (hash-table-put! ht num (cons dig #t)) + (set! state #f) + (set! repeat #f)) + (begin + (hash-table-put! ht num (cons dig next-num)) + (loop next-num (- counter 1)))))])))) + + ;; update-drawing-fields : -> void + (define/public (update-drawing-fields) + (cond + [(number? state) + (set! unbarred-portion + (string-append + decimal-prefix + wholes/dec + "." + (apply string-append (map number->string (extract-non-cycle))))) + (set! barred-portion #f) + (set! clickable-portion "...")] + [(number? repeat) + (set! unbarred-portion + (string-append + decimal-prefix + wholes/dec + "." + (apply string-append + (map number->string (extract-non-cycle))))) + (set! barred-portion (apply string-append (map number->string (extract-cycle)))) + (set! clickable-portion #f)] + [else + (set! unbarred-portion + (string-append + decimal-prefix + wholes/dec + "." + (apply string-append + (map number->string (extract-non-cycle))))) + (set! barred-portion #f) + (set! clickable-portion #f)])) + + ;; extract-cycle : -> (listof digit) + ;; pre: (number? repeat) + (define/private (extract-cycle) + (let ([pr (hash-table-get ht repeat)]) + (cons (car pr) + (extract-helper (cdr pr))))) + + ;; extract-non-cycle : -> (listof digit) + (define/private (extract-non-cycle) (extract-helper init-num)) + + (define/private (extract-helper start) + (let loop ([ind start]) + (cond + [(equal? ind repeat) null] + [else + (let* ([iter (hash-table-get ht ind)] + [dig (car iter)] + [next-num (cdr iter)]) + (cons dig + (if (hash-table-bound? ht next-num) + (loop next-num) + null)))]))) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; ;; + ;; snip infrastructure ;; + ;; ;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + + (define/public (read-special file line col pos) + number) + + (define/override get-text + (case-lambda + [(offset num) (get-text offset num #f)] + [(offset num flattened?) + (case fraction-view + [(mixed) + (cond + [(string=? wholes/frac "") + (string-append nums "/" dens)] + [(string=? wholes/frac "-") + (string-append wholes/frac nums "/" dens)] + [else + (string-append wholes/frac " " nums "/" dens)])] + [(decimal) + (string-append + unbarred-portion + (or barred-portion "") + (or clickable-portion ""))] + [(improper) (string-append + improper-prefix + improper-nums + "/" + dens)])])) + + (define/override (write f) + (send f put (string->bytes/utf-8 (number->string number))) + (send f put (string->bytes/utf-8 decimal-prefix)) + (send f put (string->bytes/utf-8 (format "~a" fraction-view))) + (send f put (string->bytes/utf-8 (number->string expansions)))) + + (define/override (copy) + (let ([snip (instantiate number-snip% () [number number] [decimal-prefix decimal-prefix])]) - (send snip iterate (max 0 (- expansions 1))) ;; one iteration is automatic - (send snip set-fraction-view fraction-view) - snip)) - (super-new))) + (send snip iterate (max 0 (- expansions 1))) ;; one iteration is automatic + (send snip set-fraction-view fraction-view) + snip)) - (define old-number-snipclass (new -snip-class%)) - (send old-number-snipclass set-version 3) - (send old-number-snipclass set-classname "drscheme:number") - (send (get-the-snip-class-list) add old-number-snipclass) + (inherit get-style) - (define number-snipclass (new -snip-class%)) - (send number-snipclass set-version 1) - (send number-snipclass set-classname (format "~s" '(lib "number-snip.ss" "drscheme" "private"))) - (send (get-the-snip-class-list) add number-snipclass) + (define/override (get-extent dc x y wb hb descent space lspace rspace) + (case fraction-view + [(decimal) + (get-decimal-extent dc x y wb hb descent space lspace rspace)] + [(mixed) + (get-mixed-fraction-extent dc x y wb hb descent space lspace rspace)] + [(improper) + (get-improper-fraction-extent dc x y wb hb descent space lspace rspace)])) - (define arrow-cursor (make-object cursor% 'arrow)) + (define/private (get-improper-fraction-extent dc x y w h descent space lspace rspace) + (let* ([style (get-style)] + [th (send style get-text-height dc)] + [old-font (send dc get-font)]) + (send dc set-font (send style get-font)) + (let-values ([(nw nh na nd) (send dc get-text-extent improper-nums)] + [(dw dh da dd) (send dc get-text-extent dens)] + [(ww wh wa wd) (send dc get-text-extent improper-prefix)]) + (set-box/f! h (+ nh dh 1)) + (set-box/f! w (+ ww (max nw dw))) + (set-box/f! descent (+ wd (/ dh 2))) + (set-box/f! space (+ wa (/ nh 2))) + (set-box/f! lspace 0) + (set-box/f! rspace 0)))) - ;; cut-off : number - ;; indicates how many digits to fetch for each click - (define cut-off 25) + (define/private (get-mixed-fraction-extent dc x y w h descent space lspace rspace) + (let* ([style (get-style)] + [th (send style get-text-height dc)] + [old-font (send dc get-font)]) + (send dc set-font (send style get-font)) + (let-values ([(nw nh na nd) (send dc get-text-extent nums)] + [(dw dh da dd) (send dc get-text-extent dens)] + [(ww wh wa wd) (send dc get-text-extent wholes/frac)]) + (set-box/f! h (+ nh dh 1)) + (set-box/f! w (+ ww (max nw dw))) + (set-box/f! descent (+ wd (/ dh 2))) + (set-box/f! space (+ wa (/ nh 2))) + (set-box/f! lspace 0) + (set-box/f! rspace 0)))) - (define number-snip% - (class* snip% (readable-snip<%>) - ;; number : number - ;; this is the number to show - (init-field number) - (define/public (get-number) number) - - ;; decimal-prefix : string - ;; this prefix is shown on the string when it is viewed in - ;; the decimal view - (init-field [decimal-prefix ""]) - - ;; fraction-view : (union 'decimal 'mixed 'improper) - ;; this field holds the current view state - (field [fraction-view 'decimal]) - - ;; these fields are for the drawing code for decimal printing - (field - ;; clickable-portion : (union #f string) - [clickable-portion #f] - ;; unbarred-portion : string - [unbarred-portion ""] - ;; barred-portion : (union #f string) - [barred-portion #f]) - - (field - ;; wholes/frac : string - ;; the whole-number portion of the number as a fraction - [wholes/frac - (cond - [(= (floor number) 0) ""] - [(= (ceiling number) 0) "-"] - [(< number 0) - (number->string (ceiling number))] - [else - (number->string (floor number))])]) - - (field - ;; wholes/dec : string - ;; the whole-number portion of decimal expansion - [wholes/dec - (cond - [(= (floor number) 0) "0"] - [(= (ceiling number) 0) "-0"] - [(< number 0) - (number->string (ceiling number))] - [else - (number->string (floor number))])]) - - ;; these fields are for the fractional printing view - (field - ;; nums : string - ;; the numerator of the mixed fraction, as a string - [nums (number->string (numerator (- (abs number) (floor (abs number)))))] - - ;; improper-nums : string - ;; the numerator of the improper fraction, as a string - [improper-nums (number->string (numerator (abs number)))] - - ;; mixed-prefix : string - ;; a prefix on the front of the mixed number (indicates if negative) - [improper-prefix (if (number . < . 0) "-" "")] - - ;; dens : string - ;; the denominator, as a string - [dens (number->string (denominator (- (abs number) (floor (abs number)))))]) - - ;; these fields are for the decimal expansion calculation code - (field - [init-num (* 10 (numerator (- (abs number) (floor (abs number)))))] - [den (denominator (- (abs number) (floor (abs number))))]) - - ;; ht : number -o> (cons digit number) - ;; this maps from divisors of the denominator to - ;; digit and new divisor pairs. Use this - ;; to read off the decimal expansion. - (field - [ht (make-hash-table 'equal)] - [expansions 0]) - - ;; this field holds the state of the current computation - ;; of the numbers digits. If it is a number, it corresponds - ;; to the next starting divisor in the iteration. - ;; if it is #f, it means that the string of digits is - ;; fully computed. - (field [state init-num]) - - ;; repeat : (union 'unk number #f) - ;; this field correlates with `state'. If `state' is a number, - ;; this field is 'unk. Otherwise, this is either a number of #f. - ;; #f indicates no repeat. - ;; a number indiates a repeat starting at `number' in `ht'. - (field [repeat 'unk]) - - ;; set-fraction-view : (union 'mixed 'improper 'decimal) -> void - ;; sets the view based on the input - (define/public (set-fraction-view b) - (set! fraction-view b) - (let ([admin (get-admin)]) - (when admin - (send admin resized this #t)))) - - ;; get-fraction-view : -> (union 'mixed 'improper 'decimal) - ;; returns the current fraction view settings - (define/public (get-fraction-view) fraction-view) - - ;; iterate : number -> void - ;; computes the next sequence of digits (`n' times) - ;; and update the strings for GUI drawing - (define/public (iterate n) - (let loop ([n n]) - (unless (zero? n) - (expand-number) - (loop (- n 1)))) - (update-drawing-fields)) - - (inherit get-admin) - - ;; iterate/reflow : -> void - ;; iterates the fraction and tells the administrator to redraw the numbers - (define/private (iterate/reflow) - (iterate 1) - (let ([admin (get-admin)]) - (when admin - (send admin resized this #t)))) - - ;; one-step-division : number -> number number - ;; given a numerator and denominator, - ;; returns a digits and a new numerator to consider - (define/private (one-step-division num) - (cond - [(num . < . den) (values 0 (* 10 num))] - [else - (let ([qu (quotient num den)]) - (values qu (* 10 (- num (* qu den)))))])) - - ;; expand-number : -> void - ;; iterates until the numbers decimal expansion is completely computed, - ;; or the number's decimal expansion terminates. - (define/public (expand-number) - (when state - (set! expansions (+ expansions 1)) - (let loop ([num state] - [counter cut-off]) - (cond - [(hash-table-bound? ht num) - (set! state #f) - (set! repeat num)] - [(zero? counter) - (set! state num)] - [else - (let-values ([(dig next-num) (one-step-division num)]) - (if (zero? next-num) - (begin - (hash-table-put! ht num (cons dig #t)) - (set! state #f) - (set! repeat #f)) - (begin - (hash-table-put! ht num (cons dig next-num)) - (loop next-num (- counter 1)))))])))) - - ;; update-drawing-fields : -> void - (define/public (update-drawing-fields) - (cond - [(number? state) - (set! unbarred-portion - (string-append - decimal-prefix - wholes/dec - "." - (apply string-append (map number->string (extract-non-cycle))))) - (set! barred-portion #f) - (set! clickable-portion "...")] - [(number? repeat) - (set! unbarred-portion - (string-append - decimal-prefix - wholes/dec - "." - (apply string-append - (map number->string (extract-non-cycle))))) - (set! barred-portion (apply string-append (map number->string (extract-cycle)))) - (set! clickable-portion #f)] - [else - (set! unbarred-portion - (string-append - decimal-prefix - wholes/dec - "." - (apply string-append - (map number->string (extract-non-cycle))))) - (set! barred-portion #f) - (set! clickable-portion #f)])) - - ;; extract-cycle : -> (listof digit) - ;; pre: (number? repeat) - (define/private (extract-cycle) - (let ([pr (hash-table-get ht repeat)]) - (cons (car pr) - (extract-helper (cdr pr))))) - - ;; extract-non-cycle : -> (listof digit) - (define/private (extract-non-cycle) (extract-helper init-num)) - - (define/private (extract-helper start) - (let loop ([ind start]) - (cond - [(equal? ind repeat) null] - [else - (let* ([iter (hash-table-get ht ind)] - [dig (car iter)] - [next-num (cdr iter)]) - (cons dig - (if (hash-table-bound? ht next-num) - (loop next-num) - null)))]))) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; ;; - ;; snip infrastructure ;; - ;; ;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - - (define/public (read-special file line col pos) - number) - - (define/override get-text - (case-lambda - [(offset num) (get-text offset num #f)] - [(offset num flattened?) - (case fraction-view - [(mixed) - (cond - [(string=? wholes/frac "") - (string-append nums "/" dens)] - [(string=? wholes/frac "-") - (string-append wholes/frac nums "/" dens)] - [else - (string-append wholes/frac " " nums "/" dens)])] - [(decimal) - (string-append - unbarred-portion - (or barred-portion "") - (or clickable-portion ""))] - [(improper) (string-append - improper-prefix - improper-nums - "/" - dens)])])) - - (define/override (write f) - (send f put (string->bytes/utf-8 (number->string number))) - (send f put (string->bytes/utf-8 decimal-prefix)) - (send f put (string->bytes/utf-8 (format "~a" fraction-view))) - (send f put (string->bytes/utf-8 (number->string expansions)))) - - (define/override (copy) - (let ([snip (instantiate number-snip% () - [number number] - [decimal-prefix decimal-prefix])]) - (send snip iterate (max 0 (- expansions 1))) ;; one iteration is automatic - (send snip set-fraction-view fraction-view) - snip)) - - (inherit get-style) - - (define/override (get-extent dc x y wb hb descent space lspace rspace) - (case fraction-view - [(decimal) - (get-decimal-extent dc x y wb hb descent space lspace rspace)] - [(mixed) - (get-mixed-fraction-extent dc x y wb hb descent space lspace rspace)] - [(improper) - (get-improper-fraction-extent dc x y wb hb descent space lspace rspace)])) - - (define/private (get-improper-fraction-extent dc x y w h descent space lspace rspace) - (let* ([style (get-style)] - [th (send style get-text-height dc)] - [old-font (send dc get-font)]) - (send dc set-font (send style get-font)) - (let-values ([(nw nh na nd) (send dc get-text-extent improper-nums)] - [(dw dh da dd) (send dc get-text-extent dens)] - [(ww wh wa wd) (send dc get-text-extent improper-prefix)]) - (set-box/f! h (+ nh dh 1)) - (set-box/f! w (+ ww (max nw dw))) - (set-box/f! descent (+ wd (/ dh 2))) - (set-box/f! space (+ wa (/ nh 2))) - (set-box/f! lspace 0) - (set-box/f! rspace 0)))) - - (define/private (get-mixed-fraction-extent dc x y w h descent space lspace rspace) - (let* ([style (get-style)] - [th (send style get-text-height dc)] - [old-font (send dc get-font)]) - (send dc set-font (send style get-font)) - (let-values ([(nw nh na nd) (send dc get-text-extent nums)] - [(dw dh da dd) (send dc get-text-extent dens)] - [(ww wh wa wd) (send dc get-text-extent wholes/frac)]) - (set-box/f! h (+ nh dh 1)) - (set-box/f! w (+ ww (max nw dw))) - (set-box/f! descent (+ wd (/ dh 2))) - (set-box/f! space (+ wa (/ nh 2))) - (set-box/f! lspace 0) - (set-box/f! rspace 0)))) - - (define/private (get-decimal-extent dc x y wb hb descent space lspace rspace) - (let ([font (send (get-style) get-font)]) - (let-values ([(w1 h1 d1 a1) (get-text-extent/f dc unbarred-portion font)] - [(w2 h2 d2 a2) (get-text-extent/f dc barred-portion font)] - [(w3 h3 d3 a3) (get-text-extent/f dc clickable-portion font)]) - (set-box/f! wb (+ w1 w2 w3)) - (set-box/f! hb (if barred-portion - (+ h1 2) - h1)) - (set-box/f! descent d1) - (set-box/f! space (if barred-portion - (+ a1 2) - a1)) - (set-box/f! lspace 0) - (set-box/f! rspace 0)))) - - (define/private (get-text-extent/f dc str font) - (if str - (let-values ([(w h d a) (send dc get-text-extent str font)]) - (values w h d a)) - (values 0 0 0 0))) - - (define/override (draw dc x y left top right bottom dx dy draw-caret?) - (case fraction-view - [(mixed) (draw-mixed-fraction dc x y)] - [(improper) (draw-improper-fraction dc x y)] - [(decimal) (draw-decimals dc x y)])) - - (define/private (draw-improper-fraction dc x y) - (let-values ([(nw nh na nd) (send dc get-text-extent improper-nums)] - [(dw dh da dd) (send dc get-text-extent dens)] - [(ww wh wa wd) (send dc get-text-extent improper-prefix)]) - (let ([frac-w (max nw dw)]) - (send dc draw-text improper-nums (+ x ww (- frac-w nw)) y) - (send dc draw-text dens (+ x ww (- (/ dw 2)) (/ frac-w 2)) (+ y nh 1)) - (send dc draw-text improper-prefix x (+ y (/ nh 2))) - (send dc draw-line - (+ x ww) (+ y dh) - (+ x ww (max nw dw) -1) (+ y dh))))) - - (define/private (draw-mixed-fraction dc x y) - (let-values ([(nw nh na nd) (send dc get-text-extent nums)] - [(dw dh da dd) (send dc get-text-extent dens)] - [(ww wh wa wd) (send dc get-text-extent wholes/frac)]) - (let ([frac-w (max nw dw)]) - (send dc draw-text nums (+ x ww (- frac-w nw)) y) - (send dc draw-text dens (+ x ww (- (/ dw 2)) (/ frac-w 2)) (+ y nh 1)) - (send dc draw-text wholes/frac x (+ y (/ nh 2))) - (send dc draw-line - (+ x ww) (+ y dh) - (+ x ww (max nw dw) -1) (+ y dh))))) - - (define/private (draw-decimals dc x y) - (define (draw-digits digits x) - (if digits - (let-values ([(w h a d) (send dc get-text-extent digits)]) - (send dc draw-text digits x (if barred-portion (+ y 2) y)) - (+ x w)) - x)) - (let* ([unbarred-end (draw-digits unbarred-portion x)] - [barred-end (draw-digits barred-portion unbarred-end)] - [clickable-end (draw-digits clickable-portion barred-end)]) - (when barred-portion - (send dc draw-line unbarred-end y (- barred-end 1) y)))) - - (define/override (adjust-cursor dc x y editorx editory evt) - (let ([sx (- (send evt get-x) x)] - [sy (- (send evt get-y) y)]) - (if (in-clickable-portion? dc sx sy) - arrow-cursor - #f))) - - (define/override (on-event dc x y editor-x editor-y evt) - (let ([sx (- (send evt get-x) x)] - [sy (- (send evt get-y) y)]) - (cond - [(send evt button-down? 'right) - (let ([admin (get-admin)]) - (when admin - (let ([popup-menu (make-right-clickable-menu)]) - (send admin popup-menu popup-menu this (+ sx 1) (+ sy 1)))))] - [(send evt button-up? 'left) - (when (in-clickable-portion? dc sx sy) - (iterate/reflow))] - [else (void)]))) - - (define/private (make-right-clickable-menu) - (let* ([menu (make-object popup-menu%)] - [decimal-item - (make-object checkable-menu-item% - (string-constant show-decimal-expansion) - menu - (λ (x y) (set-fraction-view 'decimal)))] - [mixed-fraction-item - (make-object checkable-menu-item% - (string-constant show-mixed-fraction-view) - menu - (λ (x y) - (set-fraction-view 'mixed) - (preferences:set 'framework:fraction-snip-style 'mixed)))] - [improper-fraction-item - (make-object checkable-menu-item% - (string-constant show-improper-fraction-view) - menu - (λ (x y) - (set-fraction-view 'improper) - (preferences:set 'framework:fraction-snip-style 'improper)))]) - - (case fraction-view - [(decimal) (send decimal-item check #t)] - [(mixed) (send mixed-fraction-item check #t)] - [(improper) (send improper-fraction-item check #t)]) - - (when (and (eq? fraction-view 'decimal) - clickable-portion) - (make-object menu-item% - (string-constant show-more-decimal-places) + (define/private (get-decimal-extent dc x y wb hb descent space lspace rspace) + (let ([font (send (get-style) get-font)]) + (let-values ([(w1 h1 d1 a1) (get-text-extent/f dc unbarred-portion font)] + [(w2 h2 d2 a2) (get-text-extent/f dc barred-portion font)] + [(w3 h3 d3 a3) (get-text-extent/f dc clickable-portion font)]) + (set-box/f! wb (+ w1 w2 w3)) + (set-box/f! hb (if barred-portion + (+ h1 2) + h1)) + (set-box/f! descent d1) + (set-box/f! space (if barred-portion + (+ a1 2) + a1)) + (set-box/f! lspace 0) + (set-box/f! rspace 0)))) + + (define/private (get-text-extent/f dc str font) + (if str + (let-values ([(w h d a) (send dc get-text-extent str font)]) + (values w h d a)) + (values 0 0 0 0))) + + (define/override (draw dc x y left top right bottom dx dy draw-caret?) + (case fraction-view + [(mixed) (draw-mixed-fraction dc x y)] + [(improper) (draw-improper-fraction dc x y)] + [(decimal) (draw-decimals dc x y)])) + + (define/private (draw-improper-fraction dc x y) + (let-values ([(nw nh na nd) (send dc get-text-extent improper-nums)] + [(dw dh da dd) (send dc get-text-extent dens)] + [(ww wh wa wd) (send dc get-text-extent improper-prefix)]) + (let ([frac-w (max nw dw)]) + (send dc draw-text improper-nums (+ x ww (- frac-w nw)) y) + (send dc draw-text dens (+ x ww (- (/ dw 2)) (/ frac-w 2)) (+ y nh 1)) + (send dc draw-text improper-prefix x (+ y (/ nh 2))) + (send dc draw-line + (+ x ww) (+ y dh) + (+ x ww (max nw dw) -1) (+ y dh))))) + + (define/private (draw-mixed-fraction dc x y) + (let-values ([(nw nh na nd) (send dc get-text-extent nums)] + [(dw dh da dd) (send dc get-text-extent dens)] + [(ww wh wa wd) (send dc get-text-extent wholes/frac)]) + (let ([frac-w (max nw dw)]) + (send dc draw-text nums (+ x ww (- frac-w nw)) y) + (send dc draw-text dens (+ x ww (- (/ dw 2)) (/ frac-w 2)) (+ y nh 1)) + (send dc draw-text wholes/frac x (+ y (/ nh 2))) + (send dc draw-line + (+ x ww) (+ y dh) + (+ x ww (max nw dw) -1) (+ y dh))))) + + (define/private (draw-decimals dc x y) + (define (draw-digits digits x) + (if digits + (let-values ([(w h a d) (send dc get-text-extent digits)]) + (send dc draw-text digits x (if barred-portion (+ y 2) y)) + (+ x w)) + x)) + (let* ([unbarred-end (draw-digits unbarred-portion x)] + [barred-end (draw-digits barred-portion unbarred-end)] + [clickable-end (draw-digits clickable-portion barred-end)]) + (when barred-portion + (send dc draw-line unbarred-end y (- barred-end 1) y)))) + + (define/override (adjust-cursor dc x y editorx editory evt) + (let ([sx (- (send evt get-x) x)] + [sy (- (send evt get-y) y)]) + (if (in-clickable-portion? dc sx sy) + arrow-cursor + #f))) + + (define/override (on-event dc x y editor-x editor-y evt) + (let ([sx (- (send evt get-x) x)] + [sy (- (send evt get-y) y)]) + (cond + [(send evt button-down? 'right) + (let ([admin (get-admin)]) + (when admin + (let ([popup-menu (make-right-clickable-menu)]) + (send admin popup-menu popup-menu this (+ sx 1) (+ sy 1)))))] + [(send evt button-up? 'left) + (when (in-clickable-portion? dc sx sy) + (iterate/reflow))] + [else (void)]))) + + (define/private (make-right-clickable-menu) + (let* ([menu (make-object popup-menu%)] + [decimal-item + (make-object checkable-menu-item% + (string-constant show-decimal-expansion) menu - (λ (x y) - (iterate/reflow)))) - menu)) + (λ (x y) (set-fraction-view 'decimal)))] + [mixed-fraction-item + (make-object checkable-menu-item% + (string-constant show-mixed-fraction-view) + menu + (λ (x y) + (set-fraction-view 'mixed) + (preferences:set 'framework:fraction-snip-style 'mixed)))] + [improper-fraction-item + (make-object checkable-menu-item% + (string-constant show-improper-fraction-view) + menu + (λ (x y) + (set-fraction-view 'improper) + (preferences:set 'framework:fraction-snip-style 'improper)))]) - (define/private (in-clickable-portion? dc sx sy) - (and clickable-portion - (let ([font (send (get-style) get-font)]) - (let-values ([(w1 h1 d1 a1) (get-text-extent/f dc unbarred-portion font)] - [(w2 h2 d2 a2) (get-text-extent/f dc barred-portion font)] - [(w3 h3 d3 a3) (get-text-extent/f dc clickable-portion font)]) - (and (<= (+ w1 w2) sx (+ w1 w2 w3)) - (<= 0 sy h3)))))) + (case fraction-view + [(decimal) (send decimal-item check #t)] + [(mixed) (send mixed-fraction-item check #t)] + [(improper) (send improper-fraction-item check #t)]) - (super-instantiate ()) - (inherit set-snipclass set-flags get-flags) - (set-flags (cons 'handles-events (get-flags))) - (set-snipclass number-snipclass) - (iterate 1))) ;; calc first digits + (when (and (eq? fraction-view 'decimal) + clickable-portion) + (make-object menu-item% + (string-constant show-more-decimal-places) + menu + (λ (x y) + (iterate/reflow)))) + menu)) - ;; hash-table-bound? : hash-table TST -> boolean - (define (hash-table-bound? ht key) - (let/ec k - (hash-table-get ht key (λ () (k #f))) - #t))) \ No newline at end of file + (define/private (in-clickable-portion? dc sx sy) + (and clickable-portion + (let ([font (send (get-style) get-font)]) + (let-values ([(w1 h1 d1 a1) (get-text-extent/f dc unbarred-portion font)] + [(w2 h2 d2 a2) (get-text-extent/f dc barred-portion font)] + [(w3 h3 d3 a3) (get-text-extent/f dc clickable-portion font)]) + (and (<= (+ w1 w2) sx (+ w1 w2 w3)) + (<= 0 sy h3)))))) + + (super-instantiate ()) + (inherit set-snipclass set-flags get-flags) + (set-flags (cons 'handles-events (get-flags))) + (set-snipclass number-snipclass) + (iterate 1))) ;; calc first digits + + ;; hash-table-bound? : hash-table TST -> boolean + (define (hash-table-bound? ht key) + (let/ec k + (hash-table-get ht key (λ () (k #f))) + #t))) \ No newline at end of file diff --git a/collects/framework/private/panel.ss b/collects/framework/private/panel.ss index d608406a..471779e8 100644 --- a/collects/framework/private/panel.ss +++ b/collects/framework/private/panel.ss @@ -1,423 +1,423 @@ (module panel (lib "a-unit.ss") (require (lib "class.ss") - "sig.ss" - (lib "mred-sig.ss" "mred") - (lib "list.ss") - (lib "etc.ss")) + "sig.ss" + (lib "mred-sig.ss" "mred") + (lib "list.ss") + (lib "etc.ss")) (import [prefix icon: framework:icon^] mred^) (export framework:panel^) (init-depend mred^) - - (define single<%> (interface (area-container<%>) active-child)) - (define single-mixin - (mixin (area-container<%>) (single<%>) - (inherit get-alignment change-children) - (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 - (λ (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 - (λ (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 (λ (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 single<%> (interface (area-container<%>) active-child)) + (define single-mixin + (mixin (area-container<%>) (single<%>) + (inherit get-alignment change-children) + (define/override (after-new-child c) + (unless (is-a? c window<%>) - (inherit get-children begin-container-sequence end-container-sequence) - [define current-active-child #f] - (define/public active-child - (case-lambda - [() current-active-child] - [(x) - (unless (memq x (get-children)) - (error 'active-child "got a panel that is not a child: ~e" x)) - (unless (eq? x current-active-child) - (begin-container-sequence) - (for-each (λ (x) (send x show #f)) - (get-children)) - (set! current-active-child x) - (send current-active-child show #t) - (end-container-sequence))])) - (super-instantiate ()))) - - (define single-window<%> (interface (single<%> window<%>))) - (define single-window-mixin - (mixin (single<%> window<%>) (single-window<%>) - (inherit get-client-size get-size) - [define/override container-size - (λ (l) - (let-values ([(super-width super-height) (super container-size l)] - [(client-width client-height) (get-client-size)] - [(window-width window-height) (get-size)] - [(calc-size) - (λ (super client window) - (+ super (max 0 (- window client))))]) - - (values - (calc-size super-width client-width window-width) - (calc-size super-height client-height window-height))))] - (super-new))) - - (define multi-view<%> - (interface (area-container<%>) - split-vertically - split-horizontally - collapse)) - - (define multi-view-mixin - (mixin (area-container<%>) (multi-view<%>) - (init-field parent editor) - (public get-editor-canvas% get-vertical% get-horizontal%) - [define get-editor-canvas% - (λ () - editor-canvas%)] - [define get-vertical% - (λ () - vertical-panel%)] - [define get-horizontal% - (λ () - horizontal-panel%)] + ;; would like to remove the child here, waiting on a PR submitted + ;; about change-children during after-new-child + (change-children + (λ (l) + (remq c l))) - (define/private (split p%) - (let ([canvas (send (send parent get-top-level-window) get-edit-target-window)] - [ec% (get-editor-canvas%)]) - (when (and canvas - (is-a? canvas ec%) - (eq? (send canvas get-editor) editor)) - (let ([p (send canvas get-parent)]) - (send p change-children (λ (x) null)) - (let ([pc (make-object p% p)]) - (send (make-object ec% (make-object vertical-panel% pc) editor) focus) - (make-object ec% (make-object vertical-panel% pc) editor)))))) - [define/public split-vertically - (λ () - (split (get-vertical%)))] - [define/public split-horizontally - (λ () - (split (get-horizontal%)))] - - (define/public (collapse) - (let ([canvas (send (send parent get-top-level-window) get-edit-target-window)] - [ec% (get-editor-canvas%)]) - (when (and canvas - (is-a? canvas ec%) - (eq? (send canvas get-editor) editor)) - (let ([p (send canvas get-parent)]) - (if (eq? p this) - (bell) - (let* ([sp (send p get-parent)] - [p-to-remain (send sp get-parent)]) - (send p-to-remain change-children (λ (x) null)) - (send (make-object ec% p-to-remain editor) focus))))))) - - - (super-instantiate () (parent parent)) - (make-object (get-editor-canvas%) this editor))) + (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 + (λ (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 (λ (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 single% (single-window-mixin (single-mixin panel%))) - (define single-pane% (single-mixin pane%)) - (define multi-view% (multi-view-mixin vertical-panel%)) + (inherit get-children begin-container-sequence end-container-sequence) + [define current-active-child #f] + (define/public active-child + (case-lambda + [() current-active-child] + [(x) + (unless (memq x (get-children)) + (error 'active-child "got a panel that is not a child: ~e" x)) + (unless (eq? x current-active-child) + (begin-container-sequence) + (for-each (λ (x) (send x show #f)) + (get-children)) + (set! current-active-child x) + (send current-active-child show #t) + (end-container-sequence))])) + (super-instantiate ()))) + + (define single-window<%> (interface (single<%> window<%>))) + (define single-window-mixin + (mixin (single<%> window<%>) (single-window<%>) + (inherit get-client-size get-size) + [define/override container-size + (λ (l) + (let-values ([(super-width super-height) (super container-size l)] + [(client-width client-height) (get-client-size)] + [(window-width window-height) (get-size)] + [(calc-size) + (λ (super client window) + (+ super (max 0 (- window client))))]) + + (values + (calc-size super-width client-width window-width) + (calc-size super-height client-height window-height))))] + (super-new))) + + (define multi-view<%> + (interface (area-container<%>) + split-vertically + split-horizontally + collapse)) + + (define multi-view-mixin + (mixin (area-container<%>) (multi-view<%>) + (init-field parent editor) + (public get-editor-canvas% get-vertical% get-horizontal%) + [define get-editor-canvas% + (λ () + editor-canvas%)] + [define get-vertical% + (λ () + vertical-panel%)] + [define get-horizontal% + (λ () + horizontal-panel%)] - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (define/private (split p%) + (let ([canvas (send (send parent get-top-level-window) get-edit-target-window)] + [ec% (get-editor-canvas%)]) + (when (and canvas + (is-a? canvas ec%) + (eq? (send canvas get-editor) editor)) + (let ([p (send canvas get-parent)]) + (send p change-children (λ (x) null)) + (let ([pc (make-object p% p)]) + (send (make-object ec% (make-object vertical-panel% pc) editor) focus) + (make-object ec% (make-object vertical-panel% pc) editor)))))) + [define/public split-vertically + (λ () + (split (get-vertical%)))] + [define/public split-horizontally + (λ () + (split (get-horizontal%)))] - ;; type gap = (make-gap number area<%> percentage number area<%> percentage) - (define-struct gap (before before-dim before-percentage after after-dim after-percentage)) - - ;; type percentage : (make-percentage number) - (define-struct percentage (%)) + (define/public (collapse) + (let ([canvas (send (send parent get-top-level-window) get-edit-target-window)] + [ec% (get-editor-canvas%)]) + (when (and canvas + (is-a? canvas ec%) + (eq? (send canvas get-editor) editor)) + (let ([p (send canvas get-parent)]) + (if (eq? p this) + (bell) + (let* ([sp (send p get-parent)] + [p-to-remain (send sp get-parent)]) + (send p-to-remain change-children (λ (x) null)) + (send (make-object ec% p-to-remain editor) focus))))))) - (define dragable<%> - (interface (window<%> area-container<%>) - after-percentage-change - set-percentages - get-percentages - get-vertical?)) - (define vertical-dragable<%> - (interface (dragable<%>))) + (super-instantiate () (parent parent)) + (make-object (get-editor-canvas%) this editor))) + + (define single% (single-window-mixin (single-mixin panel%))) + (define single-pane% (single-mixin pane%)) + (define multi-view% (multi-view-mixin vertical-panel%)) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + ;; type gap = (make-gap number area<%> percentage number area<%> percentage) + (define-struct gap (before before-dim before-percentage after after-dim after-percentage)) + + ;; type percentage : (make-percentage number) + (define-struct percentage (%)) + + (define dragable<%> + (interface (window<%> area-container<%>) + after-percentage-change + set-percentages + get-percentages + get-vertical?)) + + (define vertical-dragable<%> + (interface (dragable<%>))) + + (define horizontal-dragable<%> + (interface (dragable<%>))) + + (define dragable-mixin + (mixin (window<%> area-container<%>) (dragable<%>) + (init parent) - (define horizontal-dragable<%> - (interface (dragable<%>))) - - (define dragable-mixin - (mixin (window<%> area-container<%>) (dragable<%>) - (init parent) - - (define/public (get-vertical?) - (error 'get-vertical "abstract method")) - (define/private (min-extent child) - (let-values ([(w h) (send child get-graphical-min-size)]) - (if (get-vertical?) - (max (send child min-height) h) - (max (send child min-width) w)))) - (define/private (event-get-dim evt) - (if (get-vertical?) - (send evt get-y) - (send evt get-x))) - (define/private (get-gap-cursor) - (if (get-vertical?) - (icon:get-up/down-cursor) - (icon:get-left/right-cursor))) - - (inherit get-client-size container-flow-modified) - - (init-field [bar-thickness 5]) - - ;; percentages : (listof percentage) - (define percentages null) - - ;; get-percentages : -> (listof number) - (define/public (get-percentages) - (map percentage-% percentages)) - - (define/public (set-percentages ps) - (unless (and (list? ps) - (andmap number? ps) - (= 1 (apply + ps)) - (andmap positive? ps)) - (error 'set-percentages - "expected a list of numbers that are all positive and sum to 1, got: ~e" - ps)) - (unless (= (length ps) (length (get-children))) - (error 'set-percentages - "expected a list of numbers whose length is the number of children: ~a, got ~e" - (length (get-children)) - ps)) - (set! percentages (map make-percentage ps)) - (container-flow-modified)) - - (define/pubment (after-percentage-change) (inner (void) after-percentage-change)) - - (define/private (get-available-extent) - (let-values ([(width height) (get-client-size)]) - (- (if (get-vertical?) height width) - (* bar-thickness (- (length (get-children)) 1))))) - - (inherit get-children) - - (define/private (update-percentages) - (let ([len-children (length (get-children))]) - (unless (= len-children (length percentages)) - (let ([rat (/ 1 len-children)]) - (set! percentages (build-list len-children (λ (i) (make-percentage rat))))) - (after-percentage-change)))) - - (define/override (after-new-child child) - (update-percentages)) - - (define resizing-dim #f) - (define resizing-gap #f) - - (inherit set-cursor) - (define/override (on-subwindow-event receiver evt) - (if (eq? receiver this) - (let ([gap - (ormap (λ (gap) - (and (<= (gap-before-dim gap) - (event-get-dim evt) - (gap-after-dim gap)) - gap)) - cursor-gaps)]) - (set-cursor (and (or gap - resizing-dim) - (let ([c (get-gap-cursor)]) - (and (send c ok?) - c)))) - (cond - [(and gap (send evt button-down? 'left)) - (set! resizing-dim (event-get-dim evt)) - (set! resizing-gap gap)] - [(and resizing-dim (send evt button-up?)) - (set! resizing-dim #f) - (set! resizing-gap #f)] - [(and resizing-dim (send evt moving?)) - (let-values ([(width height) (get-client-size)]) - (let* ([before-percentage (gap-before-percentage resizing-gap)] - [orig-before (percentage-% before-percentage)] - [after-percentage (gap-after-percentage resizing-gap)] - [orig-after (percentage-% after-percentage)] - [available-extent (get-available-extent)] - [change-in-percentage (/ (- resizing-dim (event-get-dim evt)) available-extent)] - [new-before (- (percentage-% before-percentage) change-in-percentage)] - [new-after (+ (percentage-% after-percentage) change-in-percentage)]) - (when ((floor (* new-before available-extent)) . > . (min-extent (gap-before resizing-gap))) - (when ((floor (* new-after available-extent)) . > . (min-extent (gap-after resizing-gap))) - (set-percentage-%! before-percentage new-before) - (set-percentage-%! after-percentage new-after) - (after-percentage-change) - (set! resizing-dim (event-get-dim evt)) - (container-flow-modified)))))] - [else (super on-subwindow-event receiver evt)])) - (begin - (set-cursor #f) - (super on-subwindow-event receiver evt)))) - - (define cursor-gaps null) - - (define/override (place-children _infos width height) - (set! cursor-gaps null) - (update-percentages) - (cond - [(null? _infos) null] - [(null? (cdr _infos)) (list (list 0 0 width height))] - [else - (let ([available-extent (get-available-extent)] - [show-error - (λ (n) - (error 'panel.ss::dragable-panel "internal error.~a" n))]) - (let loop ([percentages percentages] - [children (get-children)] - [infos _infos] - [dim 0]) - (cond - [(null? percentages) - (unless (null? infos) (show-error 1)) - (unless (null? children) (show-error 2)) - null] - [(null? (cdr percentages)) - (when (null? infos) (show-error 3)) - (when (null? children) (show-error 4)) - (unless (null? (cdr infos)) (show-error 5)) - (unless (null? (cdr children)) (show-error 6)) - (if (get-vertical?) - (list (list 0 dim width (- height dim))) - (list (list dim 0 (- width dim) height)))] - [else - (when (null? infos) (show-error 7)) - (when (null? children) (show-error 8)) - (when (null? (cdr infos)) (show-error 9)) - (when (null? (cdr children)) (show-error 10)) - (let* ([info (car infos)] - [percentage (car percentages)] - [this-space (floor (* (percentage-% percentage) available-extent))]) - (set! cursor-gaps (cons (make-gap (car children) - (+ dim this-space) - percentage - (cadr children) - (+ dim this-space bar-thickness) - (cadr percentages)) - cursor-gaps)) - (cons (if (get-vertical?) - (list 0 dim width this-space) - (list dim 0 this-space height)) - (loop (cdr percentages) - (cdr children) - (cdr infos) - (+ dim this-space bar-thickness))))])))])) - - (define/override (container-size children-info) - (update-percentages) - (let loop ([percentages percentages] - [children-info children-info] - [major-size 0] - [minor-size 0]) + (define/public (get-vertical?) + (error 'get-vertical "abstract method")) + (define/private (min-extent child) + (let-values ([(w h) (send child get-graphical-min-size)]) + (if (get-vertical?) + (max (send child min-height) h) + (max (send child min-width) w)))) + (define/private (event-get-dim evt) + (if (get-vertical?) + (send evt get-y) + (send evt get-x))) + (define/private (get-gap-cursor) + (if (get-vertical?) + (icon:get-up/down-cursor) + (icon:get-left/right-cursor))) + + (inherit get-client-size container-flow-modified) + + (init-field [bar-thickness 5]) + + ;; percentages : (listof percentage) + (define percentages null) + + ;; get-percentages : -> (listof number) + (define/public (get-percentages) + (map percentage-% percentages)) + + (define/public (set-percentages ps) + (unless (and (list? ps) + (andmap number? ps) + (= 1 (apply + ps)) + (andmap positive? ps)) + (error 'set-percentages + "expected a list of numbers that are all positive and sum to 1, got: ~e" + ps)) + (unless (= (length ps) (length (get-children))) + (error 'set-percentages + "expected a list of numbers whose length is the number of children: ~a, got ~e" + (length (get-children)) + ps)) + (set! percentages (map make-percentage ps)) + (container-flow-modified)) + + (define/pubment (after-percentage-change) (inner (void) after-percentage-change)) + + (define/private (get-available-extent) + (let-values ([(width height) (get-client-size)]) + (- (if (get-vertical?) height width) + (* bar-thickness (- (length (get-children)) 1))))) + + (inherit get-children) + + (define/private (update-percentages) + (let ([len-children (length (get-children))]) + (unless (= len-children (length percentages)) + (let ([rat (/ 1 len-children)]) + (set! percentages (build-list len-children (λ (i) (make-percentage rat))))) + (after-percentage-change)))) + + (define/override (after-new-child child) + (update-percentages)) + + (define resizing-dim #f) + (define resizing-gap #f) + + (inherit set-cursor) + (define/override (on-subwindow-event receiver evt) + (if (eq? receiver this) + (let ([gap + (ormap (λ (gap) + (and (<= (gap-before-dim gap) + (event-get-dim evt) + (gap-after-dim gap)) + gap)) + cursor-gaps)]) + (set-cursor (and (or gap + resizing-dim) + (let ([c (get-gap-cursor)]) + (and (send c ok?) + c)))) (cond - [(null? children-info) - (if (get-vertical?) - (values (ceiling minor-size) (ceiling major-size)) - (values (ceiling major-size) (ceiling minor-size)))] - [(null? percentages) - (error 'panel.ss::dragable-panel "internal error.12")] - [else - (let ([child-info (car children-info)] - [percentage (car percentages)]) - (let-values ([(child-major major-stretch? child-minor minor-stretch?) - (if (get-vertical?) - (values (list-ref child-info 1) - (list-ref child-info 3) - (list-ref child-info 0) - (list-ref child-info 2)) - (values (list-ref child-info 0) - (list-ref child-info 2) - (list-ref child-info 1) - (list-ref child-info 3)))]) - (loop (cdr percentages) - (cdr children-info) - (max (/ child-major (percentage-% percentage)) major-size) - (max child-minor minor-size))))]))) - - (super-instantiate (parent)))) + [(and gap (send evt button-down? 'left)) + (set! resizing-dim (event-get-dim evt)) + (set! resizing-gap gap)] + [(and resizing-dim (send evt button-up?)) + (set! resizing-dim #f) + (set! resizing-gap #f)] + [(and resizing-dim (send evt moving?)) + (let-values ([(width height) (get-client-size)]) + (let* ([before-percentage (gap-before-percentage resizing-gap)] + [orig-before (percentage-% before-percentage)] + [after-percentage (gap-after-percentage resizing-gap)] + [orig-after (percentage-% after-percentage)] + [available-extent (get-available-extent)] + [change-in-percentage (/ (- resizing-dim (event-get-dim evt)) available-extent)] + [new-before (- (percentage-% before-percentage) change-in-percentage)] + [new-after (+ (percentage-% after-percentage) change-in-percentage)]) + (when ((floor (* new-before available-extent)) . > . (min-extent (gap-before resizing-gap))) + (when ((floor (* new-after available-extent)) . > . (min-extent (gap-after resizing-gap))) + (set-percentage-%! before-percentage new-before) + (set-percentage-%! after-percentage new-after) + (after-percentage-change) + (set! resizing-dim (event-get-dim evt)) + (container-flow-modified)))))] + [else (super on-subwindow-event receiver evt)])) + (begin + (set-cursor #f) + (super on-subwindow-event receiver evt)))) - (define three-bar-pen-bar-width 8) + (define cursor-gaps null) - (define three-bar-canvas% - (class canvas% - (inherit get-dc get-client-size) - (define/override (on-paint) - (let ([dc (get-dc)]) - (let-values ([(w h) (get-client-size)]) - (let ([sx (floor (- (/ w 2) (/ three-bar-pen-bar-width 2)))]) - (send dc set-brush (send the-brush-list find-or-create-brush (get-panel-background) 'panel)) - (send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'transparent)) - (send dc draw-rectangle 0 0 w h) - - (send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'solid)) - (send dc draw-line sx 1 (+ sx three-bar-pen-bar-width) 1) - (send dc draw-line sx 4 (+ sx three-bar-pen-bar-width) 4) - (send dc draw-line sx 7 (+ sx three-bar-pen-bar-width) 7) - - (send dc set-pen (send the-pen-list find-or-create-pen "gray" 1 'solid)) - (send dc draw-line sx 2 (+ sx three-bar-pen-bar-width) 2) - (send dc draw-line sx 5 (+ sx three-bar-pen-bar-width) 5) - (send dc draw-line sx 8 (+ sx three-bar-pen-bar-width) 8))))) - - (super-instantiate ()) - (inherit stretchable-height min-height) - (stretchable-height #f) - (min-height 10))) + (define/override (place-children _infos width height) + (set! cursor-gaps null) + (update-percentages) + (cond + [(null? _infos) null] + [(null? (cdr _infos)) (list (list 0 0 width height))] + [else + (let ([available-extent (get-available-extent)] + [show-error + (λ (n) + (error 'panel.ss::dragable-panel "internal error.~a" n))]) + (let loop ([percentages percentages] + [children (get-children)] + [infos _infos] + [dim 0]) + (cond + [(null? percentages) + (unless (null? infos) (show-error 1)) + (unless (null? children) (show-error 2)) + null] + [(null? (cdr percentages)) + (when (null? infos) (show-error 3)) + (when (null? children) (show-error 4)) + (unless (null? (cdr infos)) (show-error 5)) + (unless (null? (cdr children)) (show-error 6)) + (if (get-vertical?) + (list (list 0 dim width (- height dim))) + (list (list dim 0 (- width dim) height)))] + [else + (when (null? infos) (show-error 7)) + (when (null? children) (show-error 8)) + (when (null? (cdr infos)) (show-error 9)) + (when (null? (cdr children)) (show-error 10)) + (let* ([info (car infos)] + [percentage (car percentages)] + [this-space (floor (* (percentage-% percentage) available-extent))]) + (set! cursor-gaps (cons (make-gap (car children) + (+ dim this-space) + percentage + (cadr children) + (+ dim this-space bar-thickness) + (cadr percentages)) + cursor-gaps)) + (cons (if (get-vertical?) + (list 0 dim width this-space) + (list dim 0 this-space height)) + (loop (cdr percentages) + (cdr children) + (cdr infos) + (+ dim this-space bar-thickness))))])))])) - - (define vertical-dragable-mixin - (mixin (dragable<%>) (vertical-dragable<%>) - (define/override (get-vertical?) #t) - (super-instantiate ()))) + (define/override (container-size children-info) + (update-percentages) + (let loop ([percentages percentages] + [children-info children-info] + [major-size 0] + [minor-size 0]) + (cond + [(null? children-info) + (if (get-vertical?) + (values (ceiling minor-size) (ceiling major-size)) + (values (ceiling major-size) (ceiling minor-size)))] + [(null? percentages) + (error 'panel.ss::dragable-panel "internal error.12")] + [else + (let ([child-info (car children-info)] + [percentage (car percentages)]) + (let-values ([(child-major major-stretch? child-minor minor-stretch?) + (if (get-vertical?) + (values (list-ref child-info 1) + (list-ref child-info 3) + (list-ref child-info 0) + (list-ref child-info 2)) + (values (list-ref child-info 0) + (list-ref child-info 2) + (list-ref child-info 1) + (list-ref child-info 3)))]) + (loop (cdr percentages) + (cdr children-info) + (max (/ child-major (percentage-% percentage)) major-size) + (max child-minor minor-size))))]))) - (define horizontal-dragable-mixin - (mixin (dragable<%>) (vertical-dragable<%>) - (define/override (get-vertical?) #f) - (super-instantiate ()))) - - (define vertical-dragable% (vertical-dragable-mixin (dragable-mixin vertical-panel%))) - - (define horizontal-dragable% (horizontal-dragable-mixin (dragable-mixin horizontal-panel%)))) + (super-instantiate (parent)))) + + (define three-bar-pen-bar-width 8) + + (define three-bar-canvas% + (class canvas% + (inherit get-dc get-client-size) + (define/override (on-paint) + (let ([dc (get-dc)]) + (let-values ([(w h) (get-client-size)]) + (let ([sx (floor (- (/ w 2) (/ three-bar-pen-bar-width 2)))]) + (send dc set-brush (send the-brush-list find-or-create-brush (get-panel-background) 'panel)) + (send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'transparent)) + (send dc draw-rectangle 0 0 w h) + + (send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'solid)) + (send dc draw-line sx 1 (+ sx three-bar-pen-bar-width) 1) + (send dc draw-line sx 4 (+ sx three-bar-pen-bar-width) 4) + (send dc draw-line sx 7 (+ sx three-bar-pen-bar-width) 7) + + (send dc set-pen (send the-pen-list find-or-create-pen "gray" 1 'solid)) + (send dc draw-line sx 2 (+ sx three-bar-pen-bar-width) 2) + (send dc draw-line sx 5 (+ sx three-bar-pen-bar-width) 5) + (send dc draw-line sx 8 (+ sx three-bar-pen-bar-width) 8))))) + + (super-instantiate ()) + (inherit stretchable-height min-height) + (stretchable-height #f) + (min-height 10))) + + + (define vertical-dragable-mixin + (mixin (dragable<%>) (vertical-dragable<%>) + (define/override (get-vertical?) #t) + (super-instantiate ()))) + + (define horizontal-dragable-mixin + (mixin (dragable<%>) (vertical-dragable<%>) + (define/override (get-vertical?) #f) + (super-instantiate ()))) + + (define vertical-dragable% (vertical-dragable-mixin (dragable-mixin vertical-panel%))) + + (define horizontal-dragable% (horizontal-dragable-mixin (dragable-mixin horizontal-panel%)))) diff --git a/collects/framework/private/pasteboard.ss b/collects/framework/private/pasteboard.ss index 73990001..74236a14 100644 --- a/collects/framework/private/pasteboard.ss +++ b/collects/framework/private/pasteboard.ss @@ -1,17 +1,17 @@ (module pasteboard (lib "a-unit.ss") (require "sig.ss" - (lib "mred-sig.ss" "mred")) - + (lib "mred-sig.ss" "mred")) + (import mred^ [prefix editor: framework:editor^]) (export (rename framework:pasteboard^ [-keymap% keymap%])) (init-depend mred^ framework:editor^) - - (define basic% (editor:basic-mixin pasteboard%)) - (define standard-style-list% (editor:standard-style-list-mixin basic%)) - (define -keymap% (editor:keymap-mixin standard-style-list%)) - (define file% (editor:file-mixin -keymap%)) - (define backup-autosave% (editor:backup-autosave-mixin file%)) - (define info% (editor:info-mixin backup-autosave%))) + + (define basic% (editor:basic-mixin pasteboard%)) + (define standard-style-list% (editor:standard-style-list-mixin basic%)) + (define -keymap% (editor:keymap-mixin standard-style-list%)) + (define file% (editor:file-mixin -keymap%)) + (define backup-autosave% (editor:backup-autosave-mixin file%)) + (define info% (editor:info-mixin backup-autosave%))) diff --git a/collects/framework/private/path-utils.ss b/collects/framework/private/path-utils.ss index a45302a3..39cbe74f 100644 --- a/collects/framework/private/path-utils.ss +++ b/collects/framework/private/path-utils.ss @@ -1,58 +1,58 @@ (module path-utils (lib "a-unit.ss") (require "sig.ss" - (lib "mred-sig.ss" "mred")) + (lib "mred-sig.ss" "mred")) (import) (export framework:path-utils^) - - (define (generate-autosave-name name) - (let-values ([(base name dir?) - (if name - (split-path name) - (values (find-system-path 'doc-dir) - (bytes->path-element #"mredauto") - #f))]) - (let* ([base (if (path? base) - base - (current-directory))] - [path (if (relative-path? base) - (build-path (current-directory) base) - base)]) - (let loop ([n 1]) - (let* ([numb (string->bytes/utf-8 (number->string n))] - [new-name - (build-path path - (if (eq? (system-type) 'windows) - (bytes->path-element - (bytes-append (regexp-replace #rx#"\\..*$" - (path-element->bytes name) - #"") - #"." - numb)) - (bytes->path-element - (bytes-append #"#" - (path-element->bytes name) - #"#" - numb - #"#"))))]) - (if (file-exists? new-name) - (loop (add1 n)) - new-name)))))) - - (define (generate-backup-name full-name) - (let-values ([(pre-base name dir?) (split-path full-name)]) - (let ([base (if (path? pre-base) - pre-base - (current-directory))]) - (let ([name-bytes (path-element->bytes name)]) - (cond - [(and (eq? (system-type) 'windows) - (regexp-match #rx#"(.*)\\.[^.]*" name-bytes)) - => - (λ (m) - (build-path base (bytes->path-element (bytes-append (cadr m) #".bak"))))] - [(eq? (system-type) 'windows) - (build-path base (bytes->path-element (bytes-append name-bytes #".bak")))] - [else - (build-path base (bytes->path-element (bytes-append name-bytes #"~")))])))))) + + (define (generate-autosave-name name) + (let-values ([(base name dir?) + (if name + (split-path name) + (values (find-system-path 'doc-dir) + (bytes->path-element #"mredauto") + #f))]) + (let* ([base (if (path? base) + base + (current-directory))] + [path (if (relative-path? base) + (build-path (current-directory) base) + base)]) + (let loop ([n 1]) + (let* ([numb (string->bytes/utf-8 (number->string n))] + [new-name + (build-path path + (if (eq? (system-type) 'windows) + (bytes->path-element + (bytes-append (regexp-replace #rx#"\\..*$" + (path-element->bytes name) + #"") + #"." + numb)) + (bytes->path-element + (bytes-append #"#" + (path-element->bytes name) + #"#" + numb + #"#"))))]) + (if (file-exists? new-name) + (loop (add1 n)) + new-name)))))) + + (define (generate-backup-name full-name) + (let-values ([(pre-base name dir?) (split-path full-name)]) + (let ([base (if (path? pre-base) + pre-base + (current-directory))]) + (let ([name-bytes (path-element->bytes name)]) + (cond + [(and (eq? (system-type) 'windows) + (regexp-match #rx#"(.*)\\.[^.]*" name-bytes)) + => + (λ (m) + (build-path base (bytes->path-element (bytes-append (cadr m) #".bak"))))] + [(eq? (system-type) 'windows) + (build-path base (bytes->path-element (bytes-append name-bytes #".bak")))] + [else + (build-path base (bytes->path-element (bytes-append name-bytes #"~")))])))))) diff --git a/collects/framework/private/scheme.ss b/collects/framework/private/scheme.ss index 7d1212e6..d1a1fb44 100644 --- a/collects/framework/private/scheme.ss +++ b/collects/framework/private/scheme.ss @@ -4,10 +4,10 @@ (module scheme (lib "a-unit.ss") (require "collapsed-snipclass-helpers.ss" (lib "string-constant.ss" "string-constants") - (lib "class.ss") - "sig.ss" - (lib "mred-sig.ss" "mred") - (lib "list.ss") + (lib "class.ss") + "sig.ss" + (lib "mred-sig.ss" "mred") + (lib "list.ss") (lib "etc.ss") (lib "scheme-lexer.ss" "syntax-color") "../gui-utils.ss" @@ -25,7 +25,7 @@ [prefix mode: framework:mode^] [prefix color: framework:color^] [prefix color-prefs: framework:color-prefs^]) - + (export (rename framework:scheme^ [-text-mode<%> text-mode<%>] [-text<%> text<%>] @@ -33,240 +33,240 @@ (init-depend mred^ framework:keymap^ framework:color^ framework:mode^ framework:text^ framework:editor^) + + (define (scheme-paren:get-paren-pairs) + '(("(" . ")") + ("[" . "]") + ("{" . "}"))) + + (define text-balanced? + (opt-lambda (text [start 0] [in-end #f]) + (let* ([end (or in-end (send text last-position))] + [port (open-input-text-editor text start end)]) + (with-handlers ([exn:fail:read:eof? (λ (x) #f)] + [exn:fail:read? (λ (x) #t)]) + (let loop () + (let ([s (read port)]) + (or (eof-object? s) + (loop)))))))) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; ;; + ;; Sexp Snip ;; + ;; ;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (define (set-box/f! b v) (when (box? b) (set-box! b v))) + + (define sexp-snip<%> + (interface () + get-saved-snips)) + + (define sexp-snip% + (class* snip% (sexp-snip<%> readable-snip<%>) + (init-field left-bracket right-bracket saved-snips) + (define/public (get-saved-snips) saved-snips) + (field [sizing-text (format "~a ~a" left-bracket right-bracket)]) - (define (scheme-paren:get-paren-pairs) - '(("(" . ")") - ("[" . "]") - ("{" . "}"))) + (define/public (read-special file line col pos) + (let ([text (make-object text:basic%)]) + (for-each + (λ (s) (send text insert (send s copy) + (send text last-position) + (send text last-position))) + saved-snips) + (datum->syntax-object + #f + (read (open-input-text-editor text)) + (list file line col pos 1)))) - (define text-balanced? - (opt-lambda (text [start 0] [in-end #f]) - (let* ([end (or in-end (send text last-position))] - [port (open-input-text-editor text start end)]) - (with-handlers ([exn:fail:read:eof? (λ (x) #f)] - [exn:fail:read? (λ (x) #t)]) - (let loop () - (let ([s (read port)]) - (or (eof-object? s) - (loop)))))))) + (define/override get-text + (opt-lambda (offset num [flattened? #f]) + (if flattened? + (apply string-append + (map (λ (snip) + (send snip get-text 0 (send snip get-count) flattened?)) + saved-snips)) + (super get-text offset num flattened?)))) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; ;; - ;; Sexp Snip ;; - ;; ;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - (define (set-box/f! b v) (when (box? b) (set-box! b v))) - - (define sexp-snip<%> - (interface () - get-saved-snips)) - - (define sexp-snip% - (class* snip% (sexp-snip<%> readable-snip<%>) - (init-field left-bracket right-bracket saved-snips) - (define/public (get-saved-snips) saved-snips) - (field [sizing-text (format "~a ~a" left-bracket right-bracket)]) - - (define/public (read-special file line col pos) - (let ([text (make-object text:basic%)]) - (for-each - (λ (s) (send text insert (send s copy) - (send text last-position) - (send text last-position))) - saved-snips) - (datum->syntax-object - #f - (read (open-input-text-editor text)) - (list file line col pos 1)))) - - (define/override get-text - (opt-lambda (offset num [flattened? #f]) - (if flattened? - (apply string-append - (map (λ (snip) - (send snip get-text 0 (send snip get-count) flattened?)) - saved-snips)) - (super get-text offset num flattened?)))) - - (define/override (copy) - (instantiate sexp-snip% () - (left-bracket left-bracket) - (right-bracket right-bracket) - (saved-snips saved-snips))) - - (define/override (write stream-out) - (send stream-out put (bytes (char->integer left-bracket))) - (send stream-out put (bytes (char->integer right-bracket))) - (send stream-out put (length saved-snips)) - (let loop ([snips saved-snips]) - (cond - [(null? snips) (void)] - [else - (let* ([snip (car snips)] - [snipclass (send snip get-snipclass)]) - (send stream-out put (string->bytes/utf-8 (send snipclass get-classname))) - (send snip write stream-out)) - (loop (cdr snips))]))) - - (define/override (draw dc x y left top right bottom dx dy draw-caret) - (send dc draw-text sizing-text x y) - (let-values ([(lpw lph lpa lpd) (send dc get-text-extent (string left-bracket))] - [(rpw rph rpa rpd) (send dc get-text-extent (string right-bracket))] - [(sw sh sa sd) (send dc get-text-extent sizing-text)]) - (let* ([dtw (- sw lpw rpw)] - [dot-start (+ x lpw)] - [dt1x (+ dot-start (* dtw 1/5))] - [dt2x (+ dot-start (* dtw 1/2))] - [dt3x (+ dot-start (* dtw 4/5))] - [dty (+ y (/ sh 2))]) - (send dc draw-rectangle dt1x dty 2 2) - (send dc draw-rectangle dt2x dty 2 2) - (send dc draw-rectangle dt3x dty 2 2)))) - - (inherit get-style) - (define/override (get-extent dc x y wb hb descentb spaceb lspaceb rspaceb) - (let-values ([(w h d a) (send dc get-text-extent sizing-text (send (get-style) get-font))]) - (set-box/f! wb w) - (set-box/f! hb h) - (set-box/f! descentb d) - (set-box/f! spaceb a) - (set-box/f! lspaceb 0) - (set-box/f! rspaceb 0))) - (super-instantiate ()) - (inherit set-snipclass) - (set-snipclass lib-snip-class))) - - (define sexp-snipclass% (make-sexp-snipclass% sexp-snip%)) + (define/override (copy) + (instantiate sexp-snip% () + (left-bracket left-bracket) + (right-bracket right-bracket) + (saved-snips saved-snips))) - ;; old snips (from old versions of drscheme) use this snipclass - (define lib-snip-class (make-object sexp-snipclass%)) - (send lib-snip-class set-classname (format "~s" '(lib "collapsed-snipclass.ss" "framework"))) - (send lib-snip-class set-version 0) - (send (get-the-snip-class-list) add lib-snip-class) - - ;; new snips use this snipclass - (define old-snip-class (make-object sexp-snipclass%)) - (send old-snip-class set-classname "drscheme:sexp-snip") - (send old-snip-class set-version 0) - (send (get-the-snip-class-list) add old-snip-class) - - (keymap:add-to-right-button-menu - (let ([old (keymap:add-to-right-button-menu)]) - (λ (menu text event) - (old menu text event) - (split/collapse-text menu text event) - (void)))) + (define/override (write stream-out) + (send stream-out put (bytes (char->integer left-bracket))) + (send stream-out put (bytes (char->integer right-bracket))) + (send stream-out put (length saved-snips)) + (let loop ([snips saved-snips]) + (cond + [(null? snips) (void)] + [else + (let* ([snip (car snips)] + [snipclass (send snip get-snipclass)]) + (send stream-out put (string->bytes/utf-8 (send snipclass get-classname))) + (send snip write stream-out)) + (loop (cdr snips))]))) - ;; split/collapse-text : (instanceof menu%) (instanceof editor<%>) (instanceof mouse-event%) -> void - (define (split/collapse-text menu text event) - (when (and (is-a? text -text<%>) - (not (send text is-frozen?)) - (not (send text is-stopped?))) - (let* ([on-it-box (box #f)] - [click-pos - (call-with-values - (λ () - (send text dc-location-to-editor-location - (send event get-x) - (send event get-y))) - (λ (x y) - (send text find-position x y #f on-it-box)))] - [snip (send text find-snip click-pos 'after)] - [char (send text get-character click-pos)] - [left? (memq char '(#\( #\{ #\[))] - [right? (memq char '(#\) #\} #\]))]) - (cond - [(and snip (is-a? snip sexp-snip<%>)) - (make-expand-item text snip menu)] - [(not (unbox on-it-box)) - ;; clicking in nowhere land, just ignore - (void)] - [(or left? right?) - ;; clicking on left or right paren - (let* ([pos (if left? - click-pos - (+ click-pos 1))] - [other-pos (if left? - (send text get-forward-sexp pos) - (send text get-backward-sexp pos))]) - (when other-pos - (let ([left-pos (min pos other-pos)] - [right-pos (max pos other-pos)]) - (make-collapse-item text left-pos right-pos menu))))] - [else - ;; clicking on some other text -> collapse containing sexp - (let ([up-sexp (send text find-up-sexp click-pos)]) - (when up-sexp - (let ([fwd (send text get-forward-sexp up-sexp)]) - (make-collapse-item text up-sexp fwd menu))))])))) + (define/override (draw dc x y left top right bottom dx dy draw-caret) + (send dc draw-text sizing-text x y) + (let-values ([(lpw lph lpa lpd) (send dc get-text-extent (string left-bracket))] + [(rpw rph rpa rpd) (send dc get-text-extent (string right-bracket))] + [(sw sh sa sd) (send dc get-text-extent sizing-text)]) + (let* ([dtw (- sw lpw rpw)] + [dot-start (+ x lpw)] + [dt1x (+ dot-start (* dtw 1/5))] + [dt2x (+ dot-start (* dtw 1/2))] + [dt3x (+ dot-start (* dtw 4/5))] + [dty (+ y (/ sh 2))]) + (send dc draw-rectangle dt1x dty 2 2) + (send dc draw-rectangle dt2x dty 2 2) + (send dc draw-rectangle dt3x dty 2 2)))) - ;; make-expand-item : (instanceof text%) (instanceof sexp-snip<%>) (instanceof menu%) -> void - (define (make-expand-item text snip menu) - (instantiate separator-menu-item% () - (parent menu)) - (instantiate menu-item% () - (parent menu) - (label (string-constant expand-sexp)) - (callback (λ (item evt) (expand-from text snip))))) - - ;; expand-from : (instanceof text%) (instanceof sexp-snip<%>) -> void - (define (expand-from text snip) - (let ([snips (send snip get-saved-snips)]) - (send text begin-edit-sequence) - (let ([pos (send text get-snip-position snip)]) - (send text delete pos (+ pos 1)) - (let loop ([snips (reverse snips)]) - (cond - [(null? snips) (void)] - [else (send text insert (send (car snips) copy) pos pos) - (loop (cdr snips))]))) - (send text end-edit-sequence))) - - ;; make-collapse-item : (instanceof text%) number number (instanceof menu%) -> void - ;; adds a collapse menu item to the menu - (define (make-collapse-item text left-pos right-pos menu) - (instantiate separator-menu-item% () - (parent menu)) - (instantiate menu-item% () - (parent menu) - (label (string-constant collapse-sexp)) - (callback (λ (item evt) - (collapse-from text left-pos right-pos))))) - - (define (collapse-from text left-pos right-pos) - (let ([left-bracket (send text get-character left-pos)] - [right-bracket (send text get-character (- right-pos 1))]) - (send text begin-edit-sequence) - (send text split-snip left-pos) - (send text split-snip right-pos) - (let ([snips (let loop ([snip (send text find-snip left-pos 'after)]) - (cond - [(not snip) null] - [((send text get-snip-position snip) . >= . right-pos) - null] - [else (cons (send snip copy) (loop (send snip next)))]))]) - (send text delete left-pos right-pos) - (send text insert (instantiate sexp-snip% () - (left-bracket left-bracket) - (right-bracket right-bracket) - (saved-snips snips)) - left-pos left-pos) - (send text end-edit-sequence)))) - - - - ;; - ; ; ; - ; ; ; + (inherit get-style) + (define/override (get-extent dc x y wb hb descentb spaceb lspaceb rspaceb) + (let-values ([(w h d a) (send dc get-text-extent sizing-text (send (get-style) get-font))]) + (set-box/f! wb w) + (set-box/f! hb h) + (set-box/f! descentb d) + (set-box/f! spaceb a) + (set-box/f! lspaceb 0) + (set-box/f! rspaceb 0))) + (super-instantiate ()) + (inherit set-snipclass) + (set-snipclass lib-snip-class))) + + (define sexp-snipclass% (make-sexp-snipclass% sexp-snip%)) + + ;; old snips (from old versions of drscheme) use this snipclass + (define lib-snip-class (make-object sexp-snipclass%)) + (send lib-snip-class set-classname (format "~s" '(lib "collapsed-snipclass.ss" "framework"))) + (send lib-snip-class set-version 0) + (send (get-the-snip-class-list) add lib-snip-class) + + ;; new snips use this snipclass + (define old-snip-class (make-object sexp-snipclass%)) + (send old-snip-class set-classname "drscheme:sexp-snip") + (send old-snip-class set-version 0) + (send (get-the-snip-class-list) add old-snip-class) + + (keymap:add-to-right-button-menu + (let ([old (keymap:add-to-right-button-menu)]) + (λ (menu text event) + (old menu text event) + (split/collapse-text menu text event) + (void)))) + + ;; split/collapse-text : (instanceof menu%) (instanceof editor<%>) (instanceof mouse-event%) -> void + (define (split/collapse-text menu text event) + (when (and (is-a? text -text<%>) + (not (send text is-frozen?)) + (not (send text is-stopped?))) + (let* ([on-it-box (box #f)] + [click-pos + (call-with-values + (λ () + (send text dc-location-to-editor-location + (send event get-x) + (send event get-y))) + (λ (x y) + (send text find-position x y #f on-it-box)))] + [snip (send text find-snip click-pos 'after)] + [char (send text get-character click-pos)] + [left? (memq char '(#\( #\{ #\[))] + [right? (memq char '(#\) #\} #\]))]) + (cond + [(and snip (is-a? snip sexp-snip<%>)) + (make-expand-item text snip menu)] + [(not (unbox on-it-box)) + ;; clicking in nowhere land, just ignore + (void)] + [(or left? right?) + ;; clicking on left or right paren + (let* ([pos (if left? + click-pos + (+ click-pos 1))] + [other-pos (if left? + (send text get-forward-sexp pos) + (send text get-backward-sexp pos))]) + (when other-pos + (let ([left-pos (min pos other-pos)] + [right-pos (max pos other-pos)]) + (make-collapse-item text left-pos right-pos menu))))] + [else + ;; clicking on some other text -> collapse containing sexp + (let ([up-sexp (send text find-up-sexp click-pos)]) + (when up-sexp + (let ([fwd (send text get-forward-sexp up-sexp)]) + (make-collapse-item text up-sexp fwd menu))))])))) + + ;; make-expand-item : (instanceof text%) (instanceof sexp-snip<%>) (instanceof menu%) -> void + (define (make-expand-item text snip menu) + (instantiate separator-menu-item% () + (parent menu)) + (instantiate menu-item% () + (parent menu) + (label (string-constant expand-sexp)) + (callback (λ (item evt) (expand-from text snip))))) + + ;; expand-from : (instanceof text%) (instanceof sexp-snip<%>) -> void + (define (expand-from text snip) + (let ([snips (send snip get-saved-snips)]) + (send text begin-edit-sequence) + (let ([pos (send text get-snip-position snip)]) + (send text delete pos (+ pos 1)) + (let loop ([snips (reverse snips)]) + (cond + [(null? snips) (void)] + [else (send text insert (send (car snips) copy) pos pos) + (loop (cdr snips))]))) + (send text end-edit-sequence))) + + ;; make-collapse-item : (instanceof text%) number number (instanceof menu%) -> void + ;; adds a collapse menu item to the menu + (define (make-collapse-item text left-pos right-pos menu) + (instantiate separator-menu-item% () + (parent menu)) + (instantiate menu-item% () + (parent menu) + (label (string-constant collapse-sexp)) + (callback (λ (item evt) + (collapse-from text left-pos right-pos))))) + + (define (collapse-from text left-pos right-pos) + (let ([left-bracket (send text get-character left-pos)] + [right-bracket (send text get-character (- right-pos 1))]) + (send text begin-edit-sequence) + (send text split-snip left-pos) + (send text split-snip right-pos) + (let ([snips (let loop ([snip (send text find-snip left-pos 'after)]) + (cond + [(not snip) null] + [((send text get-snip-position snip) . >= . right-pos) + null] + [else (cons (send snip copy) (loop (send snip next)))]))]) + (send text delete left-pos right-pos) + (send text insert (instantiate sexp-snip% () + (left-bracket left-bracket) + (right-bracket right-bracket) + (saved-snips snips)) + left-pos left-pos) + (send text end-edit-sequence)))) + + + + ;; + ; ; ; + ; ; ; ;;; ;;; ; ;; ;;; ;;; ; ;;; ;;;;; ;;; ;;; ;;; ;;;;; - ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;; ; ; ; ;;;;; ; ; ; ;;;;; ; ;;;;; ; ; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;; ;;; ;;; ;;; ;;; ;; ; ;; ;;; ; ;;; ;;; ;; ;; ;;; - - + + (define color-prefs-table (let ([constant-green (make-object color% 41 128 38)] [symbol-blue (make-object color% 38 38 128)]) @@ -298,1120 +298,1120 @@ (cddr line)) line))) color-prefs-table))) - + (define (get-color-prefs-table) color-prefs-table) (define (get-white-on-black-color-prefs-table) white-on-black-color-prefs-table) + + (define (short-sym->pref-name sym) (string->symbol (short-sym->style-name sym))) + (define (xlate-sym-style sym) (case sym + [(sexp-comment) 'comment] + [else sym])) + (define sn-hash (make-hash-table)) + (define (short-sym->style-name sym) + (hash-table-get sn-hash sym + (λ () + (let ([s (format "framework:syntax-color:scheme:~a" + (xlate-sym-style sym))]) + (hash-table-put! sn-hash sym s) + s)))) + + (define (add-coloring-preferences-panel) + (color-prefs:add-to-preferences-panel + "Scheme" + (λ (parent) + (for-each + (λ (line) + (let ([sym (car line)]) + (color-prefs:build-color-selection-panel + parent + (short-sym->pref-name sym) + (short-sym->style-name sym) + (caddr line)))) + color-prefs-table)))) + + (define-struct string/pos (string pos)) + + (define -text<%> + (interface (text:basic<%> mode:host-text<%> color:text<%>) + get-limit + balance-parens + tabify-on-return? + tabify + tabify-selection + tabify-all + insert-return + box-comment-out-selection + comment-out-selection + uncomment-selection + get-forward-sexp + remove-sexp + forward-sexp + flash-forward-sexp + get-backward-sexp + flash-backward-sexp + backward-sexp + find-up-sexp + up-sexp + find-down-sexp + down-sexp + remove-parens-forward - (define (short-sym->pref-name sym) (string->symbol (short-sym->style-name sym))) - (define (xlate-sym-style sym) (case sym - [(sexp-comment) 'comment] - [else sym])) - (define sn-hash (make-hash-table)) - (define (short-sym->style-name sym) - (hash-table-get sn-hash sym - (λ () - (let ([s (format "framework:syntax-color:scheme:~a" - (xlate-sym-style sym))]) - (hash-table-put! sn-hash sym s) - s)))) + select-forward-sexp + select-backward-sexp + select-up-sexp + select-down-sexp + transpose-sexp + mark-matching-parenthesis + get-tab-size + set-tab-size - (define (add-coloring-preferences-panel) - (color-prefs:add-to-preferences-panel - "Scheme" - (λ (parent) - (for-each - (λ (line) - (let ([sym (car line)]) - (color-prefs:build-color-selection-panel - parent - (short-sym->pref-name sym) - (short-sym->style-name sym) - (caddr line)))) - color-prefs-table)))) + introduce-let-ans + move-sexp-out)) + + (define init-wordbreak-map + (λ (map) + (let ([v (send map get-map #\-)]) + (send map set-map + #\- + '(line))))) + (define wordbreak-map (make-object editor-wordbreak-map%)) + (define (get-wordbreak-map) wordbreak-map) + (init-wordbreak-map wordbreak-map) + + (define matching-parenthesis-style + (let ([matching-parenthesis-delta (make-object style-delta% 'change-bold)] + [style-list (editor:get-standard-style-list)]) + (send matching-parenthesis-delta set-delta-foreground "forest green") + (send style-list new-named-style "Matching Parenthesis Style" + (send style-list find-or-create-style + (send style-list find-named-style "Standard") + matching-parenthesis-delta)) + (send style-list find-named-style "Matching Parenthesis Style"))) + + (define text-mixin + (mixin (text:basic<%> mode:host-text<%> color:text<%>) (-text<%>) + (inherit begin-edit-sequence + delete + end-edit-sequence + local-edit-sequence? + find-string + get-character + get-keymap + get-text + get-start-position + get-style-list + get-end-position + flash-on + insert + kill + last-position + paragraph-start-position + paragraph-end-position + position-paragraph + set-keymap + set-load-overwrites-styles + set-position + set-wordbreak-map + set-tabs + set-style-list + set-styles-fixed + change-style + get-snip-position + backward-match + backward-containing-sexp + forward-match + skip-whitespace + insert-close-paren + classify-position) - (define-struct string/pos (string pos)) + (inherit get-styles-fixed) + (inherit has-focus? find-snip split-snip + position-location get-dc) - (define -text<%> - (interface (text:basic<%> mode:host-text<%> color:text<%>) - get-limit - balance-parens - tabify-on-return? - tabify - tabify-selection - tabify-all - insert-return - box-comment-out-selection - comment-out-selection - uncomment-selection - get-forward-sexp - remove-sexp - forward-sexp - flash-forward-sexp - get-backward-sexp - flash-backward-sexp - backward-sexp - find-up-sexp - up-sexp - find-down-sexp - down-sexp - remove-parens-forward - - select-forward-sexp - select-backward-sexp - select-up-sexp - select-down-sexp - transpose-sexp - mark-matching-parenthesis - get-tab-size - set-tab-size - - introduce-let-ans - move-sexp-out)) + (public tabify-on-return? tabify + tabify-all insert-return calc-last-para + box-comment-out-selection comment-out-selection uncomment-selection + flash-forward-sexp + flash-backward-sexp backward-sexp find-up-sexp up-sexp find-down-sexp down-sexp + remove-parens-forward) + (define/public (get-limit pos) 0) - (define init-wordbreak-map - (λ (map) - (let ([v (send map get-map #\-)]) - (send map set-map - #\- - '(line))))) - (define wordbreak-map (make-object editor-wordbreak-map%)) - (define (get-wordbreak-map) wordbreak-map) - (init-wordbreak-map wordbreak-map) + (define/public (balance-parens key-event) + (insert-close-paren (get-start-position) + (send key-event get-key-code) + (preferences:get 'framework:paren-match) + (preferences:get 'framework:fixup-parens))) - (define matching-parenthesis-style - (let ([matching-parenthesis-delta (make-object style-delta% 'change-bold)] - [style-list (editor:get-standard-style-list)]) - (send matching-parenthesis-delta set-delta-foreground "forest green") - (send style-list new-named-style "Matching Parenthesis Style" - (send style-list find-or-create-style - (send style-list find-named-style "Standard") - matching-parenthesis-delta)) - (send style-list find-named-style "Matching Parenthesis Style"))) - - (define text-mixin - (mixin (text:basic<%> mode:host-text<%> color:text<%>) (-text<%>) - (inherit begin-edit-sequence - delete - end-edit-sequence - local-edit-sequence? - find-string - get-character - get-keymap - get-text - get-start-position - get-style-list - get-end-position - flash-on - insert - kill - last-position - paragraph-start-position - paragraph-end-position - position-paragraph - set-keymap - set-load-overwrites-styles - set-position - set-wordbreak-map - set-tabs - set-style-list - set-styles-fixed - change-style - get-snip-position - backward-match - backward-containing-sexp - forward-match - skip-whitespace - insert-close-paren - classify-position) - - (inherit get-styles-fixed) - (inherit has-focus? find-snip split-snip - position-location get-dc) - - (public tabify-on-return? tabify - tabify-all insert-return calc-last-para - box-comment-out-selection comment-out-selection uncomment-selection - flash-forward-sexp - flash-backward-sexp backward-sexp find-up-sexp up-sexp find-down-sexp down-sexp - remove-parens-forward) - (define/public (get-limit pos) 0) - - (define/public (balance-parens key-event) - (insert-close-paren (get-start-position) - (send key-event get-key-code) - (preferences:get 'framework:paren-match) - (preferences:get 'framework:fixup-parens))) - - (define (tabify-on-return?) #t) - (define tabify - (opt-lambda ([pos (get-start-position)]) - (let* ([tabify-prefs (preferences:get 'framework:tabify)] - [last-pos (last-position)] - [para (position-paragraph pos)] - [is-tabbable? (and (> para 0) - (not (memq (classify-position (sub1 (paragraph-start-position para))) - '(comment string error))))] - [okay (and is-tabbable? (> para 0))] - [end (if okay (paragraph-start-position para) 0)] - [limit (get-limit pos)] - ;; "contains" is the start of the initial sub-S-exp - ;; in the S-exp that contains "pos". If pos is outside - ;; all S-exps, this will be the start of the initial - ;; S-exp - [contains - (if okay - (backward-containing-sexp end limit) - #f)] - [contain-para (and contains - (position-paragraph contains))] - ;; "last" is the start of the S-exp just before "pos" - [last - (if contains - (let ([p (get-backward-sexp end)]) - (if (and p (p . >= . limit)) - p - (backward-match end limit))) - #f)] - [last-para (and last - (position-paragraph last))]) - (letrec - ([find-offset - (λ (start-pos) - (let ([end-pos - (let loop ([p start-pos]) - (let ([c (get-character p)]) - (cond - [(char=? c #\tab) - (loop (add1 p))] - [(char=? c #\newline) - p] - [(char-whitespace? c) - (loop (add1 p))] - [else - p])))] - [start-x (box 0)] - [end-x (box 0)]) - (position-location start-pos start-x #f #t #t) - (position-location end-pos end-x #f #t #t) - (let-values ([(w _1 _2 _3) (send (get-dc) get-text-extent "x" - (send (send (get-style-list) - find-named-style "Standard") - get-font))]) - (cons (inexact->exact (floor (/ (- (unbox end-x) (unbox start-x)) w))) - end-pos))))] - - [visual-offset - (λ (pos) - (let loop ([p (sub1 pos)]) - (if (= p -1) - 0 - (let ([c (get-character p)]) - (cond - [(char=? c #\null) 0] - [(char=? c #\tab) - (let ([o (loop (sub1 p))]) - (+ o (- 8 (modulo o 8))))] - [(char=? c #\newline) 0] - [else (add1 (loop (sub1 p)))])))))] - [do-indent - (λ (amt) - (let* ([pos-start end] - [curr-offset (find-offset pos-start)]) - (unless (= amt (car curr-offset)) - (delete pos-start (cdr curr-offset)) - (insert - (make-string amt #\space) - pos-start))))] - [get-proc - (λ () - (let ([id-end (get-forward-sexp contains)]) - (if (and id-end (> id-end contains)) - (let* ([text (get-text contains id-end)]) - (or (get-keyword-type text tabify-prefs) - 'other)))))] - [procedure-indent - (λ () - (case (get-proc) - [(begin define) 1] - [(lambda) 3] - [else 0]))] - [special-check - (λ () - (let* ([proc-name (get-proc)]) - (or (eq? proc-name 'define) - (eq? proc-name 'lambda))))] - [indent-first-arg - (λ (start) - (car (find-offset start)))]) - (when (and okay - (not (char=? (get-character (sub1 end)) - #\newline))) - (insert #\newline (paragraph-start-position para))) - (cond - [(not is-tabbable?) (void)] - [(let ([real-start (cdr (find-offset end))]) - (and (<= (+ 3 real-start) (last-position)) - (string=? ";;;" - (get-text real-start - (+ 2 real-start))))) - (void)] - [(= para 0) (do-indent 0)] - [(not contains) - ;; Something went wrong matching. Should we get here? - (do-indent 0)] - [(not last) - ;; We can't find a match backward from pos, - ;; but we seem to be inside an S-exp, so - ;; go "up" an S-exp, and move forward past - ;; the associated paren - (let ([enclosing (find-up-sexp pos)]) - (do-indent (if enclosing - (+ (visual-offset enclosing) 1) - 0)))] - [(= contains last) - ;; There's only one S-expr in the S-expr - ;; containing "pos" - (do-indent (+ (visual-offset contains) - (procedure-indent)))] - [(special-check) - ;; In case of "define", etc., ignore the position of last - ;; and just indent under the "define" - (do-indent (add1 (visual-offset contains)))] - [(= contain-para last-para) - ;; So far, the S-exp containing "pos" was all on - ;; one line (possibly not counting the opening paren), - ;; so indent to follow the first S-exp's end - ;; unless there are just two sexps and the second is an ellipsis. - ;; in that case, we just ignore the ellipsis - (let ([name-length (let ([id-end (get-forward-sexp contains)]) - (if id-end - (- id-end contains) - 0))]) - (if (second-sexp-is-ellipsis? contains) - (do-indent (visual-offset contains)) - (do-indent (+ (visual-offset contains) - name-length - (indent-first-arg (+ contains - name-length))))))] - [else - ;; No particular special case, so indent to match first - ;; S-expr that start on the previous line - (let loop ([last last][last-para last-para]) - (let* ([next-to-last (backward-match last limit)] - [next-to-last-para (and next-to-last - (position-paragraph next-to-last))]) - (if (equal? last-para next-to-last-para) - (loop next-to-last next-to-last-para) - (do-indent (visual-offset last)))))]))))) - - ;; returns #t if `contains' is at a position on a line with an sexp, an ellipsis and nothing else. - ;; otherwise, returns #f - (define/private (second-sexp-is-ellipsis? contains) - (let ([fst-end (get-forward-sexp contains)]) - (and fst-end - (let ([snd-end (get-forward-sexp fst-end)]) - (and snd-end - (let ([snd-start (get-backward-sexp snd-end)]) - (and snd-start - (equal? (get-text snd-start snd-end) - "...") - (let ([thrd-start (get-forward-sexp snd-end)]) - (and (or (not thrd-start) - (not (= (position-paragraph thrd-start) - (position-paragraph snd-start))))))))))))) - - (define/public tabify-selection - (opt-lambda ([start-pos (get-start-position)] - [end-pos (get-end-position)]) - (let ([first-para (position-paragraph start-pos)] - [end-para (position-paragraph end-pos)]) - (with-handlers ([exn:break? - (λ (x) #t)]) - (dynamic-wind - (λ () - (when (< first-para end-para) - (begin-busy-cursor)) - (begin-edit-sequence)) - (λ () - (let loop ([para first-para]) - (when (<= para end-para) - (tabify (paragraph-start-position para)) - (parameterize-break #t (void)) - (loop (add1 para)))) - (when (and (>= (position-paragraph start-pos) end-para) - (<= (skip-whitespace (get-start-position) 'backward #f) - (paragraph-start-position first-para))) - (set-position - (let loop ([new-pos (get-start-position)]) - (if (let ([next (get-character new-pos)]) - (and (char-whitespace? next) - (not (char=? next #\newline)))) - (loop (add1 new-pos)) - new-pos))))) - (λ () - (end-edit-sequence) - (when (< first-para end-para) - (end-busy-cursor)))))))) - - (define (tabify-all) (tabify-selection 0 (last-position))) - (define (insert-return) - (if (tabify-on-return?) - (begin - (begin-edit-sequence) - (insert #\newline) - (tabify (get-start-position)) - (set-position - (let loop ([new-pos (get-start-position)]) - (if (let ([next (get-character new-pos)]) - (and (char-whitespace? next) - (not (char=? next #\newline)))) - (loop (add1 new-pos)) - new-pos))) - (end-edit-sequence)) - (insert #\newline))) - - (define (calc-last-para last-pos) - (let ([last-para (position-paragraph last-pos #t)]) - (if (and (> last-pos 0) - (> last-para 0)) - (begin (split-snip last-pos) - (let ([snip (find-snip last-pos 'before)]) - (if (member 'hard-newline (send snip get-flags)) - (- last-para 1) - last-para))) - last-para))) - - (define comment-out-selection - (opt-lambda ([start-pos (get-start-position)] - [end-pos (get-end-position)]) - (begin-edit-sequence) - (let ([first-pos-is-first-para-pos? - (= (paragraph-start-position (position-paragraph start-pos)) - start-pos)]) - (let* ([first-para (position-paragraph start-pos)] - [last-para (calc-last-para end-pos)]) - (let para-loop ([curr-para first-para]) - (if (<= curr-para last-para) - (let ([first-on-para (paragraph-start-position curr-para)]) - (insert #\; first-on-para) - (para-loop (add1 curr-para)))))) - (when first-pos-is-first-para-pos? - (set-position - (paragraph-start-position (position-paragraph (get-start-position))) - (get-end-position)))) - (end-edit-sequence) - #t)) - - (define box-comment-out-selection - (opt-lambda ([_start-pos 'start] - [_end-pos 'end]) - (let ([start-pos (if (eq? _start-pos 'start) - (get-start-position) - _start-pos)] - [end-pos (if (eq? _end-pos 'end) - (get-end-position) - _end-pos)]) - (begin-edit-sequence) - (split-snip start-pos) - (split-snip end-pos) - (let* ([cb (instantiate comment-box:snip% ())] - [text (send cb get-editor)]) - (let loop ([snip (find-snip start-pos 'after-or-none)]) - (cond - [(not snip) (void)] - [((get-snip-position snip) . >= . end-pos) (void)] - [else - (send text insert (send snip copy) - (send text last-position) - (send text last-position)) - (loop (send snip next))])) - (delete start-pos end-pos) - (insert cb start-pos) - (set-position start-pos start-pos)) - (end-edit-sequence) - #t))) - - ;; uncomment-box/selection : -> void - ;; uncomments a comment box, if the focus is inside one. - ;; otherwise, calls uncomment selection to uncomment - ;; something else. - (inherit get-focus-snip) - (define/public (uncomment-box/selection) - (begin-edit-sequence) - (let ([focus-snip (get-focus-snip)]) + (define (tabify-on-return?) #t) + (define tabify + (opt-lambda ([pos (get-start-position)]) + (let* ([tabify-prefs (preferences:get 'framework:tabify)] + [last-pos (last-position)] + [para (position-paragraph pos)] + [is-tabbable? (and (> para 0) + (not (memq (classify-position (sub1 (paragraph-start-position para))) + '(comment string error))))] + [okay (and is-tabbable? (> para 0))] + [end (if okay (paragraph-start-position para) 0)] + [limit (get-limit pos)] + ;; "contains" is the start of the initial sub-S-exp + ;; in the S-exp that contains "pos". If pos is outside + ;; all S-exps, this will be the start of the initial + ;; S-exp + [contains + (if okay + (backward-containing-sexp end limit) + #f)] + [contain-para (and contains + (position-paragraph contains))] + ;; "last" is the start of the S-exp just before "pos" + [last + (if contains + (let ([p (get-backward-sexp end)]) + (if (and p (p . >= . limit)) + p + (backward-match end limit))) + #f)] + [last-para (and last + (position-paragraph last))]) + (letrec + ([find-offset + (λ (start-pos) + (let ([end-pos + (let loop ([p start-pos]) + (let ([c (get-character p)]) + (cond + [(char=? c #\tab) + (loop (add1 p))] + [(char=? c #\newline) + p] + [(char-whitespace? c) + (loop (add1 p))] + [else + p])))] + [start-x (box 0)] + [end-x (box 0)]) + (position-location start-pos start-x #f #t #t) + (position-location end-pos end-x #f #t #t) + (let-values ([(w _1 _2 _3) (send (get-dc) get-text-extent "x" + (send (send (get-style-list) + find-named-style "Standard") + get-font))]) + (cons (inexact->exact (floor (/ (- (unbox end-x) (unbox start-x)) w))) + end-pos))))] + + [visual-offset + (λ (pos) + (let loop ([p (sub1 pos)]) + (if (= p -1) + 0 + (let ([c (get-character p)]) + (cond + [(char=? c #\null) 0] + [(char=? c #\tab) + (let ([o (loop (sub1 p))]) + (+ o (- 8 (modulo o 8))))] + [(char=? c #\newline) 0] + [else (add1 (loop (sub1 p)))])))))] + [do-indent + (λ (amt) + (let* ([pos-start end] + [curr-offset (find-offset pos-start)]) + (unless (= amt (car curr-offset)) + (delete pos-start (cdr curr-offset)) + (insert + (make-string amt #\space) + pos-start))))] + [get-proc + (λ () + (let ([id-end (get-forward-sexp contains)]) + (if (and id-end (> id-end contains)) + (let* ([text (get-text contains id-end)]) + (or (get-keyword-type text tabify-prefs) + 'other)))))] + [procedure-indent + (λ () + (case (get-proc) + [(begin define) 1] + [(lambda) 3] + [else 0]))] + [special-check + (λ () + (let* ([proc-name (get-proc)]) + (or (eq? proc-name 'define) + (eq? proc-name 'lambda))))] + [indent-first-arg + (λ (start) + (car (find-offset start)))]) + (when (and okay + (not (char=? (get-character (sub1 end)) + #\newline))) + (insert #\newline (paragraph-start-position para))) (cond - [(not focus-snip) (uncomment-selection)] - [(is-a? focus-snip comment-box:snip%) - (extract-contents - (get-snip-position focus-snip) - focus-snip)] - [else (uncomment-selection)])) - (end-edit-sequence) - #t) - - (define uncomment-selection - (opt-lambda ([start-pos (get-start-position)] - [end-pos (get-end-position)]) - (let ([snip-before (find-snip start-pos 'before-or-none)] - [snip-after (find-snip start-pos 'after-or-none)]) - - (begin-edit-sequence) + [(not is-tabbable?) (void)] + [(let ([real-start (cdr (find-offset end))]) + (and (<= (+ 3 real-start) (last-position)) + (string=? ";;;" + (get-text real-start + (+ 2 real-start))))) + (void)] + [(= para 0) (do-indent 0)] + [(not contains) + ;; Something went wrong matching. Should we get here? + (do-indent 0)] + [(not last) + ;; We can't find a match backward from pos, + ;; but we seem to be inside an S-exp, so + ;; go "up" an S-exp, and move forward past + ;; the associated paren + (let ([enclosing (find-up-sexp pos)]) + (do-indent (if enclosing + (+ (visual-offset enclosing) 1) + 0)))] + [(= contains last) + ;; There's only one S-expr in the S-expr + ;; containing "pos" + (do-indent (+ (visual-offset contains) + (procedure-indent)))] + [(special-check) + ;; In case of "define", etc., ignore the position of last + ;; and just indent under the "define" + (do-indent (add1 (visual-offset contains)))] + [(= contain-para last-para) + ;; So far, the S-exp containing "pos" was all on + ;; one line (possibly not counting the opening paren), + ;; so indent to follow the first S-exp's end + ;; unless there are just two sexps and the second is an ellipsis. + ;; in that case, we just ignore the ellipsis + (let ([name-length (let ([id-end (get-forward-sexp contains)]) + (if id-end + (- id-end contains) + 0))]) + (if (second-sexp-is-ellipsis? contains) + (do-indent (visual-offset contains)) + (do-indent (+ (visual-offset contains) + name-length + (indent-first-arg (+ contains + name-length))))))] + [else + ;; No particular special case, so indent to match first + ;; S-expr that start on the previous line + (let loop ([last last][last-para last-para]) + (let* ([next-to-last (backward-match last limit)] + [next-to-last-para (and next-to-last + (position-paragraph next-to-last))]) + (if (equal? last-para next-to-last-para) + (loop next-to-last next-to-last-para) + (do-indent (visual-offset last)))))]))))) + + ;; returns #t if `contains' is at a position on a line with an sexp, an ellipsis and nothing else. + ;; otherwise, returns #f + (define/private (second-sexp-is-ellipsis? contains) + (let ([fst-end (get-forward-sexp contains)]) + (and fst-end + (let ([snd-end (get-forward-sexp fst-end)]) + (and snd-end + (let ([snd-start (get-backward-sexp snd-end)]) + (and snd-start + (equal? (get-text snd-start snd-end) + "...") + (let ([thrd-start (get-forward-sexp snd-end)]) + (and (or (not thrd-start) + (not (= (position-paragraph thrd-start) + (position-paragraph snd-start))))))))))))) + + (define/public tabify-selection + (opt-lambda ([start-pos (get-start-position)] + [end-pos (get-end-position)]) + (let ([first-para (position-paragraph start-pos)] + [end-para (position-paragraph end-pos)]) + (with-handlers ([exn:break? + (λ (x) #t)]) + (dynamic-wind + (λ () + (when (< first-para end-para) + (begin-busy-cursor)) + (begin-edit-sequence)) + (λ () + (let loop ([para first-para]) + (when (<= para end-para) + (tabify (paragraph-start-position para)) + (parameterize-break #t (void)) + (loop (add1 para)))) + (when (and (>= (position-paragraph start-pos) end-para) + (<= (skip-whitespace (get-start-position) 'backward #f) + (paragraph-start-position first-para))) + (set-position + (let loop ([new-pos (get-start-position)]) + (if (let ([next (get-character new-pos)]) + (and (char-whitespace? next) + (not (char=? next #\newline)))) + (loop (add1 new-pos)) + new-pos))))) + (λ () + (end-edit-sequence) + (when (< first-para end-para) + (end-busy-cursor)))))))) + + (define (tabify-all) (tabify-selection 0 (last-position))) + (define (insert-return) + (if (tabify-on-return?) + (begin + (begin-edit-sequence) + (insert #\newline) + (tabify (get-start-position)) + (set-position + (let loop ([new-pos (get-start-position)]) + (if (let ([next (get-character new-pos)]) + (and (char-whitespace? next) + (not (char=? next #\newline)))) + (loop (add1 new-pos)) + new-pos))) + (end-edit-sequence)) + (insert #\newline))) + + (define (calc-last-para last-pos) + (let ([last-para (position-paragraph last-pos #t)]) + (if (and (> last-pos 0) + (> last-para 0)) + (begin (split-snip last-pos) + (let ([snip (find-snip last-pos 'before)]) + (if (member 'hard-newline (send snip get-flags)) + (- last-para 1) + last-para))) + last-para))) + + (define comment-out-selection + (opt-lambda ([start-pos (get-start-position)] + [end-pos (get-end-position)]) + (begin-edit-sequence) + (let ([first-pos-is-first-para-pos? + (= (paragraph-start-position (position-paragraph start-pos)) + start-pos)]) + (let* ([first-para (position-paragraph start-pos)] + [last-para (calc-last-para end-pos)]) + (let para-loop ([curr-para first-para]) + (if (<= curr-para last-para) + (let ([first-on-para (paragraph-start-position curr-para)]) + (insert #\; first-on-para) + (para-loop (add1 curr-para)))))) + (when first-pos-is-first-para-pos? + (set-position + (paragraph-start-position (position-paragraph (get-start-position))) + (get-end-position)))) + (end-edit-sequence) + #t)) + + (define box-comment-out-selection + (opt-lambda ([_start-pos 'start] + [_end-pos 'end]) + (let ([start-pos (if (eq? _start-pos 'start) + (get-start-position) + _start-pos)] + [end-pos (if (eq? _end-pos 'end) + (get-end-position) + _end-pos)]) + (begin-edit-sequence) + (split-snip start-pos) + (split-snip end-pos) + (let* ([cb (instantiate comment-box:snip% ())] + [text (send cb get-editor)]) + (let loop ([snip (find-snip start-pos 'after-or-none)]) (cond - [(and (= start-pos end-pos) - snip-before - (is-a? snip-before comment-box:snip%)) - (extract-contents start-pos snip-before)] - [(and (= start-pos end-pos) - snip-after - (is-a? snip-after comment-box:snip%)) - (extract-contents start-pos snip-after)] - [(and (= (+ start-pos 1) end-pos) - snip-after - (is-a? snip-after comment-box:snip%)) - (extract-contents start-pos snip-after)] + [(not snip) (void)] + [((get-snip-position snip) . >= . end-pos) (void)] [else - (let* ([last-pos (last-position)] - [first-para (position-paragraph start-pos)] - [last-para (calc-last-para end-pos)]) - (let para-loop ([curr-para first-para]) - (when (<= curr-para last-para) - (let ([first-on-para - (skip-whitespace (paragraph-start-position curr-para) - 'forward - #f)]) - (split-snip first-on-para) - (when (and (< first-on-para last-pos) - (char=? #\; (get-character first-on-para)) - (is-a? (find-snip first-on-para 'after-or-none) string-snip%)) - (delete first-on-para (+ first-on-para 1))) - (para-loop (add1 curr-para))))))]) - (end-edit-sequence)) - #t)) - - ;; extract-contents : number (is-a?/c comment-box:snip%) -> void - ;; copies the contents of the comment-box-snip out of the snip - ;; and into this editor as `pos'. Deletes the comment box snip - (define/private (extract-contents pos snip) - (let ([editor (send snip get-editor)]) - (let loop ([snip (send editor find-snip (send editor last-position) 'before-or-none)]) - (cond - [snip - (insert (send snip copy) pos) - (loop (send snip previous))] - [else (void)])) - (let ([snip-pos (get-snip-position snip)]) - (delete snip-pos (+ snip-pos 1))) - (set-position pos pos))) - - (define/private (stick-to-next-sexp? start-pos) - (let ([end-pos (forward-match start-pos (last-position))]) - (and end-pos - (member (get-text start-pos end-pos) - '("'" "," ",@" "`" + (send text insert (send snip copy) + (send text last-position) + (send text last-position)) + (loop (send snip next))])) + (delete start-pos end-pos) + (insert cb start-pos) + (set-position start-pos start-pos)) + (end-edit-sequence) + #t))) + + ;; uncomment-box/selection : -> void + ;; uncomments a comment box, if the focus is inside one. + ;; otherwise, calls uncomment selection to uncomment + ;; something else. + (inherit get-focus-snip) + (define/public (uncomment-box/selection) + (begin-edit-sequence) + (let ([focus-snip (get-focus-snip)]) + (cond + [(not focus-snip) (uncomment-selection)] + [(is-a? focus-snip comment-box:snip%) + (extract-contents + (get-snip-position focus-snip) + focus-snip)] + [else (uncomment-selection)])) + (end-edit-sequence) + #t) + + (define uncomment-selection + (opt-lambda ([start-pos (get-start-position)] + [end-pos (get-end-position)]) + (let ([snip-before (find-snip start-pos 'before-or-none)] + [snip-after (find-snip start-pos 'after-or-none)]) + + (begin-edit-sequence) + (cond + [(and (= start-pos end-pos) + snip-before + (is-a? snip-before comment-box:snip%)) + (extract-contents start-pos snip-before)] + [(and (= start-pos end-pos) + snip-after + (is-a? snip-after comment-box:snip%)) + (extract-contents start-pos snip-after)] + [(and (= (+ start-pos 1) end-pos) + snip-after + (is-a? snip-after comment-box:snip%)) + (extract-contents start-pos snip-after)] + [else + (let* ([last-pos (last-position)] + [first-para (position-paragraph start-pos)] + [last-para (calc-last-para end-pos)]) + (let para-loop ([curr-para first-para]) + (when (<= curr-para last-para) + (let ([first-on-para + (skip-whitespace (paragraph-start-position curr-para) + 'forward + #f)]) + (split-snip first-on-para) + (when (and (< first-on-para last-pos) + (char=? #\; (get-character first-on-para)) + (is-a? (find-snip first-on-para 'after-or-none) string-snip%)) + (delete first-on-para (+ first-on-para 1))) + (para-loop (add1 curr-para))))))]) + (end-edit-sequence)) + #t)) + + ;; extract-contents : number (is-a?/c comment-box:snip%) -> void + ;; copies the contents of the comment-box-snip out of the snip + ;; and into this editor as `pos'. Deletes the comment box snip + (define/private (extract-contents pos snip) + (let ([editor (send snip get-editor)]) + (let loop ([snip (send editor find-snip (send editor last-position) 'before-or-none)]) + (cond + [snip + (insert (send snip copy) pos) + (loop (send snip previous))] + [else (void)])) + (let ([snip-pos (get-snip-position snip)]) + (delete snip-pos (+ snip-pos 1))) + (set-position pos pos))) + + (define/private (stick-to-next-sexp? start-pos) + (let ([end-pos (forward-match start-pos (last-position))]) + (and end-pos + (member (get-text start-pos end-pos) + '("'" "," ",@" "`" "#'" "#," "#`" "#,@" "#&" "#;" "#hash" "#hasheq" "#ci" "#cs"))))) - - (define/public (get-forward-sexp start-pos) - ;; loop to work properly with quote, etc. - (let loop ([one-forward (forward-match start-pos (last-position))]) - (cond - [(and one-forward (not (= 0 one-forward))) - (let ([bw (backward-match one-forward 0)]) - (cond - [(and bw - (stick-to-next-sexp? bw)) - (let ([two-forward (forward-match one-forward (last-position))]) - (if two-forward - (loop two-forward) - one-forward))] - [else - one-forward]))] - [else one-forward]))) - - (define/public (remove-sexp start-pos) - (let ([end-pos (get-forward-sexp start-pos)]) - (if end-pos - (kill 0 start-pos end-pos) - (bell))) - #t) - (define/public (forward-sexp start-pos) - (let ([end-pos (get-forward-sexp start-pos)]) - (if end-pos - (set-position end-pos) - (bell)) - #t)) - [define flash-forward-sexp - (λ (start-pos) - (let ([end-pos (get-forward-sexp start-pos)]) - (if end-pos - (flash-on end-pos (add1 end-pos)) - (bell)) - #t))] - (define/public (get-backward-sexp start-pos) - (let* ([limit (get-limit start-pos)] - [end-pos (backward-match start-pos limit)] - [min-pos (backward-containing-sexp start-pos limit)]) - (if (and end-pos - (or (not min-pos) - (end-pos . >= . min-pos))) - ;; Can go backward, but check for preceding quote, unquote, etc. - (let loop ([end-pos end-pos]) - (let ([next-end-pos (backward-match end-pos limit)]) - (if (and next-end-pos - (or (not min-pos) - (end-pos . >= . min-pos)) - (stick-to-next-sexp? next-end-pos)) - (loop next-end-pos) - end-pos))) - ;; can't go backward at all: - #f))) - [define flash-backward-sexp - (λ (start-pos) - (let ([end-pos (get-backward-sexp start-pos)]) - (if end-pos - (flash-on end-pos (add1 end-pos)) - (bell)) - #t))] - [define backward-sexp - (λ (start-pos) - (let ([end-pos (get-backward-sexp start-pos)]) - (if end-pos - (set-position end-pos) - (bell)) - #t))] - [define find-up-sexp - (λ (start-pos) - (let* ([limit-pos (get-limit start-pos)] - [exp-pos - (backward-containing-sexp start-pos limit-pos)]) - - (if (and exp-pos (> exp-pos limit-pos)) - (let* ([in-start-pos (skip-whitespace exp-pos 'backward #t)] - [paren-pos - (λ (paren-pair) - (find-string - (car paren-pair) - 'backward - in-start-pos - limit-pos))]) - (let ([poss (let loop ([parens (scheme-paren:get-paren-pairs)]) - (cond - [(null? parens) null] - [else - (let ([pos (paren-pos (car parens))]) - (if pos - (cons pos (loop (cdr parens))) - (loop (cdr parens))))]))]) - (if (null? poss) ;; all finds failed - #f - (- (apply max poss) 1)))) ;; subtract one to move outside the paren - #f)))] - [define up-sexp - (λ (start-pos) - (let ([exp-pos (find-up-sexp start-pos)]) - (if exp-pos - (set-position exp-pos) - (bell)) - #t))] - [define find-down-sexp - (λ (start-pos) - (let loop ([pos start-pos]) - (let ([next-pos (get-forward-sexp pos)]) - (if (and next-pos (> next-pos pos)) - (let ([back-pos - (backward-containing-sexp (sub1 next-pos) pos)]) - (if (and back-pos - (> back-pos pos)) - back-pos - (loop next-pos))) - #f))))] - [define down-sexp - (λ (start-pos) - (let ([pos (find-down-sexp start-pos)]) - (if pos - (set-position pos) - (bell)) - #t))] - [define remove-parens-forward - (λ (start-pos) - (let* ([pos (skip-whitespace start-pos 'forward #f)] - [first-char (get-character pos)] - [paren? (or (char=? first-char #\( ) - (char=? first-char #\[ ))] - [closer (if paren? - (get-forward-sexp pos))]) - (if (and paren? closer) - (begin (begin-edit-sequence) - (delete pos (add1 pos)) - (delete (- closer 2) (- closer 1)) - (end-edit-sequence)) - (bell)) - #t))] - - (define/private (select-text f forward?) - (let* ([start-pos (get-start-position)] - [end-pos (get-end-position)]) - (let-values ([(new-start new-end) - (if forward? - (values start-pos (f end-pos)) - (values (f start-pos) end-pos))]) - (if (and new-start new-end) - (set-position new-start new-end) - (bell)) - #t))) - (public select-forward-sexp select-backward-sexp select-up-sexp select-down-sexp) - [define select-forward-sexp (λ () (select-text (λ (x) (get-forward-sexp x)) #t))] - [define select-backward-sexp (λ () (select-text (λ (x) (get-backward-sexp x)) #f))] - [define select-up-sexp (λ () (select-text (λ (x) (find-up-sexp x)) #f))] - [define select-down-sexp (λ () (select-text (λ (x) (find-down-sexp x)) #t))] - - (define/public (introduce-let-ans pos) - (dynamic-wind - (λ () (begin-edit-sequence)) - (λ () - (let ([before-text "(let ([ans "] - [after-text "])\n"] - [after-text2 "(printf \"~s\\n\" ans)\nans)"] - [end-l (get-forward-sexp pos)]) - (cond - [end-l - (insert after-text2 end-l end-l) - (insert after-text end-l end-l) - (insert before-text pos pos) - (let ([blank-line-pos (+ end-l (string-length after-text) (string-length before-text))]) - (set-position blank-line-pos blank-line-pos)) - (tabify-selection - pos - (+ end-l - (string-length before-text) - (string-length after-text) - (string-length after-text2)))] - [else - (bell)]))) - (λ () - (end-edit-sequence)))) - - (define/public (move-sexp-out begin-inner) - (begin-edit-sequence) - (let ([end-inner (get-forward-sexp begin-inner)] - [begin-outer (find-up-sexp begin-inner)]) - (cond - [(and end-inner begin-outer) - (let ([end-outer (get-forward-sexp begin-outer)]) - (cond - [end-outer - (delete end-inner end-outer) - (delete begin-outer begin-inner) - (tabify-selection begin-outer (+ begin-outer (- end-inner begin-inner)))] - [else (bell)]))] - [else (bell)])) - (end-edit-sequence)) - - (inherit get-fixed-style) - (define/public (mark-matching-parenthesis pos) - (let ([open-parens (map car (scheme-paren:get-paren-pairs))] - [close-parens (map cdr (scheme-paren:get-paren-pairs))]) - (when (member (string (get-character pos)) open-parens) - (let ([end (get-forward-sexp pos)]) - (when (and end - (member (string (get-character (- end 1))) close-parens)) - (let ([start-style (send (find-snip pos 'after) get-style)] - [end-style (send (find-snip end 'before) get-style)]) - (cond - [(and (eq? matching-parenthesis-style start-style) - (eq? matching-parenthesis-style end-style)) - (let ([fixed-style (get-fixed-style)]) - (change-style fixed-style pos (+ pos 1)) - (change-style fixed-style (- end 1) end))] - [else - (change-style matching-parenthesis-style pos (+ pos 1)) - (change-style matching-parenthesis-style (- end 1) end)]))))))) - - (define/public (transpose-sexp pos) - (let ([start-1 (get-backward-sexp pos)]) - (if (not start-1) - (bell) - (let ([end-1 (get-forward-sexp start-1)]) - (if (not end-1) - (bell) - (let ([end-2 (get-forward-sexp end-1)]) - (if (not end-2) - (bell) - (let ([start-2 (get-backward-sexp end-2)]) - (if (or (not start-2) - (< start-2 end-1)) - (bell) - (let ([text-1 - (get-text start-1 end-1)] - [text-2 - (get-text start-2 end-2)]) - (begin-edit-sequence) - (insert text-1 start-2 end-2) - (insert text-2 start-1 end-1) - (set-position end-2) - (end-edit-sequence))))))))))) - [define tab-size 8] - (public get-tab-size set-tab-size) - [define get-tab-size (λ () tab-size)] - [define set-tab-size (λ (s) (set! tab-size s))] - - (inherit is-frozen? is-stopped?) - (define/public (rewrite-square-paren) - (cond - [(or (not (preferences:get 'framework:fixup-open-parens)) - (is-frozen?) - (is-stopped?)) - (insert #\[ - (get-start-position) - (get-end-position))] - [else - (insert-paren this)])) - - (super-new))) - - (define -text-mode<%> - (interface () - )) - (define text-mode-mixin - (mixin (color:text-mode<%> mode:surrogate-text<%>) (-text-mode<%>) - - (define/override (on-disable-surrogate text) - (keymap:remove-chained-keymap text keymap) - (super on-disable-surrogate text)) - - (define/override (on-enable-surrogate text) - (send text begin-edit-sequence) - (super on-enable-surrogate text) - (send (send text get-keymap) chain-to-keymap keymap #t) + (define/public (get-forward-sexp start-pos) + ;; loop to work properly with quote, etc. + (let loop ([one-forward (forward-match start-pos (last-position))]) + (cond + [(and one-forward (not (= 0 one-forward))) + (let ([bw (backward-match one-forward 0)]) + (cond + [(and bw + (stick-to-next-sexp? bw)) + (let ([two-forward (forward-match one-forward (last-position))]) + (if two-forward + (loop two-forward) + one-forward))] + [else + one-forward]))] + [else one-forward]))) + + (define/public (remove-sexp start-pos) + (let ([end-pos (get-forward-sexp start-pos)]) + (if end-pos + (kill 0 start-pos end-pos) + (bell))) + #t) + (define/public (forward-sexp start-pos) + (let ([end-pos (get-forward-sexp start-pos)]) + (if end-pos + (set-position end-pos) + (bell)) + #t)) + [define flash-forward-sexp + (λ (start-pos) + (let ([end-pos (get-forward-sexp start-pos)]) + (if end-pos + (flash-on end-pos (add1 end-pos)) + (bell)) + #t))] + (define/public (get-backward-sexp start-pos) + (let* ([limit (get-limit start-pos)] + [end-pos (backward-match start-pos limit)] + [min-pos (backward-containing-sexp start-pos limit)]) + (if (and end-pos + (or (not min-pos) + (end-pos . >= . min-pos))) + ;; Can go backward, but check for preceding quote, unquote, etc. + (let loop ([end-pos end-pos]) + (let ([next-end-pos (backward-match end-pos limit)]) + (if (and next-end-pos + (or (not min-pos) + (end-pos . >= . min-pos)) + (stick-to-next-sexp? next-end-pos)) + (loop next-end-pos) + end-pos))) + ;; can't go backward at all: + #f))) + [define flash-backward-sexp + (λ (start-pos) + (let ([end-pos (get-backward-sexp start-pos)]) + (if end-pos + (flash-on end-pos (add1 end-pos)) + (bell)) + #t))] + [define backward-sexp + (λ (start-pos) + (let ([end-pos (get-backward-sexp start-pos)]) + (if end-pos + (set-position end-pos) + (bell)) + #t))] + [define find-up-sexp + (λ (start-pos) + (let* ([limit-pos (get-limit start-pos)] + [exp-pos + (backward-containing-sexp start-pos limit-pos)]) - ;; I don't know about these editor flag settings. - ;; maybe they belong in drscheme? - (send text set-load-overwrites-styles #f) - (send text set-wordbreak-map wordbreak-map) - (let ([bw (box 0)] - [bu (box #f)] - [tab-size (send text get-tab-size)]) - (unless (and (null? (send text get-tabs #f bw bu)) - (= tab-size (unbox bw)) - (not (unbox bu))) - (send text set-tabs null (send text get-tab-size) #f))) - (send text set-styles-fixed #t) - (send text end-edit-sequence)) - - (define tabify-pref (preferences:get 'framework:tabify)) - (preferences:add-callback - 'framework:tabify - (lambda (k v) (set! tabify-pref v))) - (define/private (scheme-lexer-wrapper in) - (let-values (((lexeme type paren start end) (scheme-lexer in))) - (cond - ((and (eq? type 'symbol) - (get-keyword-type lexeme tabify-pref)) - (values lexeme 'keyword paren start end)) - (else - (values lexeme type paren start end))))) - - (super-new (get-token (lambda (in) (scheme-lexer-wrapper in))) - (token-sym->style short-sym->style-name) - (matches '((|(| |)|) - (|[| |]|) - (|{| |}|)))))) + (if (and exp-pos (> exp-pos limit-pos)) + (let* ([in-start-pos (skip-whitespace exp-pos 'backward #t)] + [paren-pos + (λ (paren-pair) + (find-string + (car paren-pair) + 'backward + in-start-pos + limit-pos))]) + (let ([poss (let loop ([parens (scheme-paren:get-paren-pairs)]) + (cond + [(null? parens) null] + [else + (let ([pos (paren-pos (car parens))]) + (if pos + (cons pos (loop (cdr parens))) + (loop (cdr parens))))]))]) + (if (null? poss) ;; all finds failed + #f + (- (apply max poss) 1)))) ;; subtract one to move outside the paren + #f)))] + [define up-sexp + (λ (start-pos) + (let ([exp-pos (find-up-sexp start-pos)]) + (if exp-pos + (set-position exp-pos) + (bell)) + #t))] + [define find-down-sexp + (λ (start-pos) + (let loop ([pos start-pos]) + (let ([next-pos (get-forward-sexp pos)]) + (if (and next-pos (> next-pos pos)) + (let ([back-pos + (backward-containing-sexp (sub1 next-pos) pos)]) + (if (and back-pos + (> back-pos pos)) + back-pos + (loop next-pos))) + #f))))] + [define down-sexp + (λ (start-pos) + (let ([pos (find-down-sexp start-pos)]) + (if pos + (set-position pos) + (bell)) + #t))] + [define remove-parens-forward + (λ (start-pos) + (let* ([pos (skip-whitespace start-pos 'forward #f)] + [first-char (get-character pos)] + [paren? (or (char=? first-char #\( ) + (char=? first-char #\[ ))] + [closer (if paren? + (get-forward-sexp pos))]) + (if (and paren? closer) + (begin (begin-edit-sequence) + (delete pos (add1 pos)) + (delete (- closer 2) (- closer 1)) + (end-edit-sequence)) + (bell)) + #t))] - ;; get-keyword-type : string (list ht regexp regexp regexp) - ;; -> (union #f 'lambda 'define 'begin) - (define (get-keyword-type text pref) - (let* ([ht (car pref)] - [beg-reg (cadr pref)] - [def-reg (caddr pref)] - [lam-reg (cadddr pref)]) - (hash-table-get - ht - (string->symbol text) - (λ () + (define/private (select-text f forward?) + (let* ([start-pos (get-start-position)] + [end-pos (get-end-position)]) + (let-values ([(new-start new-end) + (if forward? + (values start-pos (f end-pos)) + (values (f start-pos) end-pos))]) + (if (and new-start new-end) + (set-position new-start new-end) + (bell)) + #t))) + (public select-forward-sexp select-backward-sexp select-up-sexp select-down-sexp) + [define select-forward-sexp (λ () (select-text (λ (x) (get-forward-sexp x)) #t))] + [define select-backward-sexp (λ () (select-text (λ (x) (get-backward-sexp x)) #f))] + [define select-up-sexp (λ () (select-text (λ (x) (find-up-sexp x)) #f))] + [define select-down-sexp (λ () (select-text (λ (x) (find-down-sexp x)) #t))] + + (define/public (introduce-let-ans pos) + (dynamic-wind + (λ () (begin-edit-sequence)) + (λ () + (let ([before-text "(let ([ans "] + [after-text "])\n"] + [after-text2 "(printf \"~s\\n\" ans)\nans)"] + [end-l (get-forward-sexp pos)]) (cond - [(and beg-reg (regexp-match beg-reg text)) 'begin] - [(and def-reg (regexp-match def-reg text)) 'define] - [(and lam-reg (regexp-match lam-reg text)) 'lambda] - [else #f]))))) + [end-l + (insert after-text2 end-l end-l) + (insert after-text end-l end-l) + (insert before-text pos pos) + (let ([blank-line-pos (+ end-l (string-length after-text) (string-length before-text))]) + (set-position blank-line-pos blank-line-pos)) + (tabify-selection + pos + (+ end-l + (string-length before-text) + (string-length after-text) + (string-length after-text2)))] + [else + (bell)]))) + (λ () + (end-edit-sequence)))) - (define set-mode-mixin - (mixin (-text<%> mode:host-text<%>) () - (super-new) - (inherit set-surrogate) - (set-surrogate (new text-mode%)))) - - (define -text% (set-mode-mixin - (text-mixin - (mode:host-text-mixin - color:text%)))) - - (define text-mode% (text-mode-mixin color:text-mode%)) - - - ;; ;; - ; ; - ; ; + (define/public (move-sexp-out begin-inner) + (begin-edit-sequence) + (let ([end-inner (get-forward-sexp begin-inner)] + [begin-outer (find-up-sexp begin-inner)]) + (cond + [(and end-inner begin-outer) + (let ([end-outer (get-forward-sexp begin-outer)]) + (cond + [end-outer + (delete end-inner end-outer) + (delete begin-outer begin-inner) + (tabify-selection begin-outer (+ begin-outer (- end-inner begin-inner)))] + [else (bell)]))] + [else (bell)])) + (end-edit-sequence)) + + (inherit get-fixed-style) + (define/public (mark-matching-parenthesis pos) + (let ([open-parens (map car (scheme-paren:get-paren-pairs))] + [close-parens (map cdr (scheme-paren:get-paren-pairs))]) + (when (member (string (get-character pos)) open-parens) + (let ([end (get-forward-sexp pos)]) + (when (and end + (member (string (get-character (- end 1))) close-parens)) + (let ([start-style (send (find-snip pos 'after) get-style)] + [end-style (send (find-snip end 'before) get-style)]) + (cond + [(and (eq? matching-parenthesis-style start-style) + (eq? matching-parenthesis-style end-style)) + (let ([fixed-style (get-fixed-style)]) + (change-style fixed-style pos (+ pos 1)) + (change-style fixed-style (- end 1) end))] + [else + (change-style matching-parenthesis-style pos (+ pos 1)) + (change-style matching-parenthesis-style (- end 1) end)]))))))) + + (define/public (transpose-sexp pos) + (let ([start-1 (get-backward-sexp pos)]) + (if (not start-1) + (bell) + (let ([end-1 (get-forward-sexp start-1)]) + (if (not end-1) + (bell) + (let ([end-2 (get-forward-sexp end-1)]) + (if (not end-2) + (bell) + (let ([start-2 (get-backward-sexp end-2)]) + (if (or (not start-2) + (< start-2 end-1)) + (bell) + (let ([text-1 + (get-text start-1 end-1)] + [text-2 + (get-text start-2 end-2)]) + (begin-edit-sequence) + (insert text-1 start-2 end-2) + (insert text-2 start-1 end-1) + (set-position end-2) + (end-edit-sequence))))))))))) + [define tab-size 8] + (public get-tab-size set-tab-size) + [define get-tab-size (λ () tab-size)] + [define set-tab-size (λ (s) (set! tab-size s))] + + (inherit is-frozen? is-stopped?) + (define/public (rewrite-square-paren) + (cond + [(or (not (preferences:get 'framework:fixup-open-parens)) + (is-frozen?) + (is-stopped?)) + (insert #\[ + (get-start-position) + (get-end-position))] + [else + (insert-paren this)])) + + (super-new))) + + (define -text-mode<%> + (interface () + )) + + (define text-mode-mixin + (mixin (color:text-mode<%> mode:surrogate-text<%>) (-text-mode<%>) + + (define/override (on-disable-surrogate text) + (keymap:remove-chained-keymap text keymap) + (super on-disable-surrogate text)) + + (define/override (on-enable-surrogate text) + (send text begin-edit-sequence) + (super on-enable-surrogate text) + (send (send text get-keymap) chain-to-keymap keymap #t) + + ;; I don't know about these editor flag settings. + ;; maybe they belong in drscheme? + (send text set-load-overwrites-styles #f) + (send text set-wordbreak-map wordbreak-map) + (let ([bw (box 0)] + [bu (box #f)] + [tab-size (send text get-tab-size)]) + (unless (and (null? (send text get-tabs #f bw bu)) + (= tab-size (unbox bw)) + (not (unbox bu))) + (send text set-tabs null (send text get-tab-size) #f))) + (send text set-styles-fixed #t) + (send text end-edit-sequence)) + + (define tabify-pref (preferences:get 'framework:tabify)) + (preferences:add-callback + 'framework:tabify + (lambda (k v) (set! tabify-pref v))) + (define/private (scheme-lexer-wrapper in) + (let-values (((lexeme type paren start end) (scheme-lexer in))) + (cond + ((and (eq? type 'symbol) + (get-keyword-type lexeme tabify-pref)) + (values lexeme 'keyword paren start end)) + (else + (values lexeme type paren start end))))) + + (super-new (get-token (lambda (in) (scheme-lexer-wrapper in))) + (token-sym->style short-sym->style-name) + (matches '((|(| |)|) + (|[| |]|) + (|{| |}|)))))) + + ;; get-keyword-type : string (list ht regexp regexp regexp) + ;; -> (union #f 'lambda 'define 'begin) + (define (get-keyword-type text pref) + (let* ([ht (car pref)] + [beg-reg (cadr pref)] + [def-reg (caddr pref)] + [lam-reg (cadddr pref)]) + (hash-table-get + ht + (string->symbol text) + (λ () + (cond + [(and beg-reg (regexp-match beg-reg text)) 'begin] + [(and def-reg (regexp-match def-reg text)) 'define] + [(and lam-reg (regexp-match lam-reg text)) 'lambda] + [else #f]))))) + + (define set-mode-mixin + (mixin (-text<%> mode:host-text<%>) () + (super-new) + (inherit set-surrogate) + (set-surrogate (new text-mode%)))) + + (define -text% (set-mode-mixin + (text-mixin + (mode:host-text-mixin + color:text%)))) + + (define text-mode% (text-mode-mixin color:text-mode%)) + + + ;; ;; + ; ; + ; ; ;;; ;;; ; ;; ;;; ;;; ; ;;; ; ;; ;;; ;;; ;;;;;; ; ;;;; ; ;;; - ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;; ; ; ; ;;;;; ; ; ; ;;;;; ;; ;;;;; ; ; ; ; ; ;;;; ; ; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;; ; ; ; ; ; ; ; ;;; ;;; ;;; ;;; ;;; ;; ; ;; ;;; ;; ;; ;;; ; ;; ; ;; ;;; ; ;;;; - ; ; - ; ; - ;; ;;; - (define (setup-keymap keymap) - (let ([add-pos-function - (λ (name call-method) - (send keymap add-function name - (λ (edit event) - (call-method - edit - (send edit get-start-position)))))]) - (add-pos-function "remove-sexp" (λ (e p) (send e remove-sexp p))) - (add-pos-function "forward-sexp" (λ (e p) (send e forward-sexp p))) - (add-pos-function "backward-sexp" (λ (e p) (send e backward-sexp p))) - (add-pos-function "up-sexp" (λ (e p) (send e up-sexp p))) - (add-pos-function "down-sexp" (λ (e p) (send e down-sexp p))) - (add-pos-function "flash-backward-sexp" (λ (e p) (send e flash-backward-sexp p))) - (add-pos-function "flash-forward-sexp" (λ (e p) (send e flash-forward-sexp p))) - (add-pos-function "remove-parens-forward" (λ (e p) (send e remove-parens-forward p))) - (add-pos-function "transpose-sexp" (λ (e p) (send e transpose-sexp p))) - (add-pos-function "mark-matching-parenthesis" - (λ (e p) (send e mark-matching-parenthesis p))) - (add-pos-function "introduce-let-ans" - (λ (e p) (send e introduce-let-ans p))) - (add-pos-function "move-sexp-out" - (λ (e p) (send e move-sexp-out p))) - - (let ([add-edit-function - (λ (name call-method) - (send keymap add-function name - (λ (edit event) - (call-method edit))))]) - (add-edit-function "select-forward-sexp" - (λ (x) (send x select-forward-sexp))) - (add-edit-function "select-backward-sexp" - (λ (x) (send x select-backward-sexp))) - (add-edit-function "select-down-sexp" - (λ (x) (send x select-down-sexp))) - (add-edit-function "select-up-sexp" - (λ (x) (send x select-up-sexp))) - (add-edit-function "tabify-at-caret" - (λ (x) (send x tabify-selection))) - (add-edit-function "do-return" - (λ (x) - (send x insert-return))) - (add-edit-function "comment-out" - (λ (x) (send x comment-out-selection))) - (add-edit-function "box-comment-out" - (λ (x) (send x box-comment-out-selection))) - (add-edit-function "uncomment" - (λ (x) (send x uncomment-selection))) - (add-edit-function "rewrite-square-paren" - (λ (x) (send x rewrite-square-paren))) - - (let ([add/map-non-clever - (λ (name keystroke char) - (add-edit-function - name - (λ (e) (send e insert char (send e get-start-position) (send e get-end-position)))) - (send keymap map-function keystroke name))]) - (add/map-non-clever "non-clever-open-square-bracket" "c:[" #\[) - (add/map-non-clever "non-clever-close-square-bracket" "c:]" #\]) - (add/map-non-clever "non-clever-close-curley-bracket" "c:}" #\}) - (add/map-non-clever "non-clever-close-round-paren" "c:)" #\)))) - - (send keymap add-function "balance-parens" - (λ (edit event) - (send edit balance-parens event))) - - (send keymap map-function "TAB" "tabify-at-caret") - - (send keymap map-function "return" "do-return") - (send keymap map-function "s:return" "do-return") - (send keymap map-function "s:c:return" "do-return") - (send keymap map-function "a:return" "do-return") - (send keymap map-function "s:a:return" "do-return") - (send keymap map-function "c:a:return" "do-return") - (send keymap map-function "c:s:a:return" "do-return") - (send keymap map-function "c:return" "do-return") - (send keymap map-function "d:return" "do-return") - - (send keymap map-function ")" "balance-parens") - (send keymap map-function "]" "balance-parens") - (send keymap map-function "}" "balance-parens") - - (send keymap map-function "[" "rewrite-square-paren") - - (let ([map-meta - (λ (key func) - (keymap:send-map-function-meta keymap key func))] - [map - (λ (key func) - (send keymap map-function key func))]) - - (map-meta "up" "up-sexp") - (map-meta "c:u" "up-sexp") - (map "a:up" "up-sexp") - (map-meta "s:up" "select-up-sexp") - (map "a:s:up" "select-up-sexp") - (map-meta "s:c:u" "select-up-sexp") - - (map-meta "down" "down-sexp") - (map "a:down" "down-sexp") - (map-meta "s:down" "select-down-sexp") - (map "a:s:down" "select-down-sexp") - (map-meta "s:c:down" "select-down-sexp") - - (map-meta "right" "forward-sexp") - (map "a:right" "forward-sexp") - (map-meta "s:right" "select-forward-sexp") - (map "a:s:right" "select-forward-sexp") - - (map-meta "left" "backward-sexp") - (map "a:left" "backward-sexp") - (map-meta "s:left" "select-backward-sexp") - (map "a:s:left" "select-backward-sexp") - - (map-meta "return" "do-return") - (map-meta "s:return" "do-return") - (map-meta "s:c:return" "do-return") - (map-meta "a:return" "do-return") - (map-meta "s:a:return" "do-return") - (map-meta "c:a:return" "do-return") - (map-meta "c:s:a:return" "do-return") - (map-meta "c:return" "do-return") - - (map-meta "c:semicolon" "comment-out") - (map-meta "c:=" "uncomment") - (map-meta "c:k" "remove-sexp") - - (map-meta "c:f" "forward-sexp") - (map-meta "s:c:f" "select-forward-sexp") - - (map-meta "c:b" "backward-sexp") - (map-meta "s:c:b" "select-backward-sexp") - - (map-meta "c:p" "flash-backward-sexp") - (map-meta "s:c:n" "flash-forward-sexp") - - (map-meta "c:space" "select-forward-sexp") - (map-meta "c:t" "transpose-sexp") - - ;(map-meta "c:m" "mark-matching-parenthesis") - ; this keybinding doesn't interact with the paren colorer - ) - (send keymap map-function "c:c;c:b" "remove-parens-forward") - (send keymap map-function "c:c;c:l" "introduce-let-ans") - (send keymap map-function "c:c;c:o" "move-sexp-out"))) + ; ; + ; ; + ;; ;;; + (define (setup-keymap keymap) + (let ([add-pos-function + (λ (name call-method) + (send keymap add-function name + (λ (edit event) + (call-method + edit + (send edit get-start-position)))))]) + (add-pos-function "remove-sexp" (λ (e p) (send e remove-sexp p))) + (add-pos-function "forward-sexp" (λ (e p) (send e forward-sexp p))) + (add-pos-function "backward-sexp" (λ (e p) (send e backward-sexp p))) + (add-pos-function "up-sexp" (λ (e p) (send e up-sexp p))) + (add-pos-function "down-sexp" (λ (e p) (send e down-sexp p))) + (add-pos-function "flash-backward-sexp" (λ (e p) (send e flash-backward-sexp p))) + (add-pos-function "flash-forward-sexp" (λ (e p) (send e flash-forward-sexp p))) + (add-pos-function "remove-parens-forward" (λ (e p) (send e remove-parens-forward p))) + (add-pos-function "transpose-sexp" (λ (e p) (send e transpose-sexp p))) + (add-pos-function "mark-matching-parenthesis" + (λ (e p) (send e mark-matching-parenthesis p))) + (add-pos-function "introduce-let-ans" + (λ (e p) (send e introduce-let-ans p))) + (add-pos-function "move-sexp-out" + (λ (e p) (send e move-sexp-out p))) - (define keymap (make-object keymap:aug-keymap%)) - (setup-keymap keymap) - (define (get-keymap) keymap) + (let ([add-edit-function + (λ (name call-method) + (send keymap add-function name + (λ (edit event) + (call-method edit))))]) + (add-edit-function "select-forward-sexp" + (λ (x) (send x select-forward-sexp))) + (add-edit-function "select-backward-sexp" + (λ (x) (send x select-backward-sexp))) + (add-edit-function "select-down-sexp" + (λ (x) (send x select-down-sexp))) + (add-edit-function "select-up-sexp" + (λ (x) (send x select-up-sexp))) + (add-edit-function "tabify-at-caret" + (λ (x) (send x tabify-selection))) + (add-edit-function "do-return" + (λ (x) + (send x insert-return))) + (add-edit-function "comment-out" + (λ (x) (send x comment-out-selection))) + (add-edit-function "box-comment-out" + (λ (x) (send x box-comment-out-selection))) + (add-edit-function "uncomment" + (λ (x) (send x uncomment-selection))) + (add-edit-function "rewrite-square-paren" + (λ (x) (send x rewrite-square-paren))) + + (let ([add/map-non-clever + (λ (name keystroke char) + (add-edit-function + name + (λ (e) (send e insert char (send e get-start-position) (send e get-end-position)))) + (send keymap map-function keystroke name))]) + (add/map-non-clever "non-clever-open-square-bracket" "c:[" #\[) + (add/map-non-clever "non-clever-close-square-bracket" "c:]" #\]) + (add/map-non-clever "non-clever-close-curley-bracket" "c:}" #\}) + (add/map-non-clever "non-clever-close-round-paren" "c:)" #\)))) - ;; choose-paren : scheme-text number -> character - ;; returns the character to replace a #\[ with, based - ;; on the context where it is typed in. - (define (insert-paren text) - (let* ([pos (send text get-start-position)] - [real-char #\[] - [change-to (λ (i c) - ;(printf "change-to, case ~a\n" i) - (set! real-char c))] - [start-pos (send text get-start-position)] - [end-pos (send text get-end-position)] - [letrec-like-forms (preferences:get 'framework:square-bracket:letrec)]) - (send text begin-edit-sequence #f #f) - (send text insert "[" start-pos 'same #f) - (when (eq? (send text classify-position pos) 'parenthesis) - (let* ([before-whitespace-pos (send text skip-whitespace pos 'backward #t)] - [keyword/distance (find-keyword-and-distance before-whitespace-pos text)]) - (cond - [(and keyword/distance - (member keyword/distance - (preferences:get 'framework:square-bracket:cond/offset))) - ;; just leave the square backet in, in this case - (void)] - [(and keyword/distance - (member (car keyword/distance) - (preferences:get 'framework:square-bracket:local))) - (unless (= (cadr keyword/distance) 0) - (change-to 7 #\())] - [else - (let* ([backward-match (send text backward-match before-whitespace-pos 0)] - [b-m-char (and (number? backward-match) (send text get-character backward-match))]) - (cond - [backward-match - ;; there is an expression before this, at this layer - (let* ([before-whitespace-pos2 (send text skip-whitespace backward-match 'backward #t)] - [backward-match2 (send text backward-match before-whitespace-pos2 0)]) - - (cond - [(member b-m-char '(#\( #\[ #\{)) - ;; found a "sibling" parenthesized sequence. use the parens it uses. - (change-to 1 b-m-char)] - [else - ;; otherwise, we switch to ( - (change-to 2 #\()]))] - [(not (zero? before-whitespace-pos)) - ;; this is the first thing in the sequence - ;; pop out one layer and look for a keyword. - (let ([b-w-p-char (send text get-character (- before-whitespace-pos 1))]) - (cond - [(equal? b-w-p-char #\() - (let* ([second-before-whitespace-pos (send text skip-whitespace - (- before-whitespace-pos 1) - 'backward - #t)] - [second-backwards-match (send text backward-match - second-before-whitespace-pos - 0)]) - (cond - [(not second-backwards-match) - (change-to 3 #\()] - [(and (beginning-of-sequence? text second-backwards-match) - (ormap (λ (x) (text-between-equal? x - text + (send keymap add-function "balance-parens" + (λ (edit event) + (send edit balance-parens event))) + + (send keymap map-function "TAB" "tabify-at-caret") + + (send keymap map-function "return" "do-return") + (send keymap map-function "s:return" "do-return") + (send keymap map-function "s:c:return" "do-return") + (send keymap map-function "a:return" "do-return") + (send keymap map-function "s:a:return" "do-return") + (send keymap map-function "c:a:return" "do-return") + (send keymap map-function "c:s:a:return" "do-return") + (send keymap map-function "c:return" "do-return") + (send keymap map-function "d:return" "do-return") + + (send keymap map-function ")" "balance-parens") + (send keymap map-function "]" "balance-parens") + (send keymap map-function "}" "balance-parens") + + (send keymap map-function "[" "rewrite-square-paren") + + (let ([map-meta + (λ (key func) + (keymap:send-map-function-meta keymap key func))] + [map + (λ (key func) + (send keymap map-function key func))]) + + (map-meta "up" "up-sexp") + (map-meta "c:u" "up-sexp") + (map "a:up" "up-sexp") + (map-meta "s:up" "select-up-sexp") + (map "a:s:up" "select-up-sexp") + (map-meta "s:c:u" "select-up-sexp") + + (map-meta "down" "down-sexp") + (map "a:down" "down-sexp") + (map-meta "s:down" "select-down-sexp") + (map "a:s:down" "select-down-sexp") + (map-meta "s:c:down" "select-down-sexp") + + (map-meta "right" "forward-sexp") + (map "a:right" "forward-sexp") + (map-meta "s:right" "select-forward-sexp") + (map "a:s:right" "select-forward-sexp") + + (map-meta "left" "backward-sexp") + (map "a:left" "backward-sexp") + (map-meta "s:left" "select-backward-sexp") + (map "a:s:left" "select-backward-sexp") + + (map-meta "return" "do-return") + (map-meta "s:return" "do-return") + (map-meta "s:c:return" "do-return") + (map-meta "a:return" "do-return") + (map-meta "s:a:return" "do-return") + (map-meta "c:a:return" "do-return") + (map-meta "c:s:a:return" "do-return") + (map-meta "c:return" "do-return") + + (map-meta "c:semicolon" "comment-out") + (map-meta "c:=" "uncomment") + (map-meta "c:k" "remove-sexp") + + (map-meta "c:f" "forward-sexp") + (map-meta "s:c:f" "select-forward-sexp") + + (map-meta "c:b" "backward-sexp") + (map-meta "s:c:b" "select-backward-sexp") + + (map-meta "c:p" "flash-backward-sexp") + (map-meta "s:c:n" "flash-forward-sexp") + + (map-meta "c:space" "select-forward-sexp") + (map-meta "c:t" "transpose-sexp") + + ;(map-meta "c:m" "mark-matching-parenthesis") + ; this keybinding doesn't interact with the paren colorer + ) + (send keymap map-function "c:c;c:b" "remove-parens-forward") + (send keymap map-function "c:c;c:l" "introduce-let-ans") + (send keymap map-function "c:c;c:o" "move-sexp-out"))) + + (define keymap (make-object keymap:aug-keymap%)) + (setup-keymap keymap) + (define (get-keymap) keymap) + + ;; choose-paren : scheme-text number -> character + ;; returns the character to replace a #\[ with, based + ;; on the context where it is typed in. + (define (insert-paren text) + (let* ([pos (send text get-start-position)] + [real-char #\[] + [change-to (λ (i c) + ;(printf "change-to, case ~a\n" i) + (set! real-char c))] + [start-pos (send text get-start-position)] + [end-pos (send text get-end-position)] + [letrec-like-forms (preferences:get 'framework:square-bracket:letrec)]) + (send text begin-edit-sequence #f #f) + (send text insert "[" start-pos 'same #f) + (when (eq? (send text classify-position pos) 'parenthesis) + (let* ([before-whitespace-pos (send text skip-whitespace pos 'backward #t)] + [keyword/distance (find-keyword-and-distance before-whitespace-pos text)]) + (cond + [(and keyword/distance + (member keyword/distance + (preferences:get 'framework:square-bracket:cond/offset))) + ;; just leave the square backet in, in this case + (void)] + [(and keyword/distance + (member (car keyword/distance) + (preferences:get 'framework:square-bracket:local))) + (unless (= (cadr keyword/distance) 0) + (change-to 7 #\())] + [else + (let* ([backward-match (send text backward-match before-whitespace-pos 0)] + [b-m-char (and (number? backward-match) (send text get-character backward-match))]) + (cond + [backward-match + ;; there is an expression before this, at this layer + (let* ([before-whitespace-pos2 (send text skip-whitespace backward-match 'backward #t)] + [backward-match2 (send text backward-match before-whitespace-pos2 0)]) + + (cond + [(member b-m-char '(#\( #\[ #\{)) + ;; found a "sibling" parenthesized sequence. use the parens it uses. + (change-to 1 b-m-char)] + [else + ;; otherwise, we switch to ( + (change-to 2 #\()]))] + [(not (zero? before-whitespace-pos)) + ;; this is the first thing in the sequence + ;; pop out one layer and look for a keyword. + (let ([b-w-p-char (send text get-character (- before-whitespace-pos 1))]) + (cond + [(equal? b-w-p-char #\() + (let* ([second-before-whitespace-pos (send text skip-whitespace + (- before-whitespace-pos 1) + 'backward + #t)] + [second-backwards-match (send text backward-match + second-before-whitespace-pos + 0)]) + (cond + [(not second-backwards-match) + (change-to 3 #\()] + [(and (beginning-of-sequence? text second-backwards-match) + (ormap (λ (x) (text-between-equal? x + text + second-backwards-match + second-before-whitespace-pos)) + letrec-like-forms)) + ;; we found a let keyword, so we get a square bracket + (void)] + [else + ;; go back one more sexp in the same row, looking for `let loop' pattern + (let* ([second-before-whitespace-pos2 (send text skip-whitespace second-backwards-match - second-before-whitespace-pos)) - letrec-like-forms)) - ;; we found a let keyword, so we get a square bracket - (void)] - [else - ;; go back one more sexp in the same row, looking for `let loop' pattern - (let* ([second-before-whitespace-pos2 (send text skip-whitespace - second-backwards-match - 'backward - #t)] - [second-backwards-match2 (send text backward-match - second-before-whitespace-pos2 - 0)]) - (cond - [(and second-backwards-match2 - (eq? (send text classify-position second-backwards-match) - ;;; otherwise, this isn't a `let loop', it is a regular let! - 'symbol) - (member "let" letrec-like-forms) - (text-between-equal? "let" - text - second-backwards-match2 - second-before-whitespace-pos2)) - ;; found the `(let loop (' so we keep the [ - (void)] - [else - ;; otherwise, round. - (change-to 4 #\()]))]))] - [else - (change-to 5 #\()]))] - [else - (change-to 6 #\()]))]))) - (send text delete pos (+ pos 1) #f) - (send text end-edit-sequence) - (send text insert real-char start-pos end-pos))) + 'backward + #t)] + [second-backwards-match2 (send text backward-match + second-before-whitespace-pos2 + 0)]) + (cond + [(and second-backwards-match2 + (eq? (send text classify-position second-backwards-match) + ;;; otherwise, this isn't a `let loop', it is a regular let! + 'symbol) + (member "let" letrec-like-forms) + (text-between-equal? "let" + text + second-backwards-match2 + second-before-whitespace-pos2)) + ;; found the `(let loop (' so we keep the [ + (void)] + [else + ;; otherwise, round. + (change-to 4 #\()]))]))] + [else + (change-to 5 #\()]))] + [else + (change-to 6 #\()]))]))) + (send text delete pos (+ pos 1) #f) + (send text end-edit-sequence) + (send text insert real-char start-pos end-pos))) ;; find-keyword-and-distance : -> (union #f (cons string number)) (define (find-keyword-and-distance before-whitespace-pos text) @@ -1432,195 +1432,195 @@ (send text get-text pos afterwards))]) (and keyword (list keyword (- n 1))))])))) - - ;; beginning-of-sequence? : text number -> boolean - ;; determines if this position is at the beginning of a sequence - ;; that begins with a parenthesis. - (define (beginning-of-sequence? text start) - (let ([before-space (send text skip-whitespace start 'backward #t)]) - (cond - [(zero? before-space) #t] - [else - (equal? (send text get-character (- before-space 1)) - #\()]))) - - (define (text-between-equal? str text start end) - (and (= (string-length str) (- end start)) - (let loop ([i (string-length str)]) - (cond - [(= i 0) #t] - [else - (and (char=? (string-ref str (- i 1)) - (send text get-character (+ i start -1))) - (loop (- i 1)))])))) - - - ;;; ;;; - ; ; - ; ; -; ;;; ; ;;; ;;; ;;;;; ;;; ; ;;; ;;;; ; ;;; ;;; ; - ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; - ; ; ; ;;;;; ; ;;; ; ; ;;;; ; ; ;;;;; ; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ;;;; ;;;; ;;; ;;;; ;;; ;;;; ;;; ;;;; ;; ;;; ;;;;;; - ; ; - ; ; -;;; ;;; - - - (define (add-preferences-panel) - (preferences:add-panel - (list (string-constant editor-prefs-panel-label) - (string-constant indenting-prefs-panel-label)) - make-indenting-prefs-panel) - (preferences:add-panel - (list (string-constant editor-prefs-panel-label) - (string-constant square-bracket-prefs-panel-label)) - make-square-bracket-prefs-panel)) - - (define (make-square-bracket-prefs-panel p) - (define main-panel (make-object vertical-panel% p)) - (define boxes-panel (new horizontal-panel% [parent main-panel])) - - (define (mk-list-box sym keyword-type pref->string get-new-one) - (letrec ([vp (new vertical-panel% [parent boxes-panel])] - [_ (new message% - [label (format (string-constant x-like-keywords) keyword-type)] - [parent vp])] - [lb - (new list-box% - [label #f] - [parent vp] - [choices (map pref->string (preferences:get sym))] - [callback - (λ (lb evt) - (send remove-button enable (pair? (send lb get-selections))))])] - [bp (new horizontal-panel% [parent vp] [stretchable-height #f])] - [add - (new button% - [label (string-constant add-keyword)] - [parent bp] - [callback - (λ (x y) - (let ([new-one (get-new-one)]) - (when new-one - (preferences:set sym (append (preferences:get sym) - (list new-one))))))])] - [remove-button - (new button% - [label (string-constant remove-keyword)] - [parent bp] - [callback - (λ (x y) - (let ([n (send lb get-selections)]) - (when (pair? n) - (preferences:set - sym - (let loop ([i 0] - [prefs (preferences:get sym)]) - (cond - [(= i (car n)) (cdr prefs)] - [else (cons (car prefs) - (loop (+ i 1) - (cdr prefs)))]))) - (cond - [(= 0 (send lb get-number)) - (send remove-button enable #f)] - [else - (send lb set-selection - (if (= (car n) (send lb get-number)) - (- (send lb get-number) 1) - (car n)))]))))])]) - (unless (pair? (send lb get-selections)) - (send remove-button enable #f)) - (preferences:add-callback sym - (λ (p v) - (send lb clear) - (for-each (λ (x) (send lb append (pref->string x))) v))))) - - (define (get-new-simple-keyword label) - (λ () - (let ([new-one - (keymap:call/text-keymap-initializer - (λ () - (get-text-from-user - (format (string-constant enter-new-keyword) label) - (format (string-constant x-keyword) label))))]) - (and new-one - (let ([parsed (with-handlers ((exn:fail:read? (λ (x) #f))) - (read (open-input-string new-one)))]) - - (and (symbol? parsed) - (symbol->string parsed))))))) - - (define (get-new-cond-keyword) - (define f (new dialog% [label (format (string-constant enter-new-keyword) "Cond")])) - (define tb (keymap:call/text-keymap-initializer - (λ () - (new text-field% - [parent f] - [label #f])))) - (define number-panel (new horizontal-panel% [parent f] [stretchable-height #f])) - (define number-label (new message% [parent number-panel] [label (string-constant skip-subexpressions)])) - (define number - (keymap:call/text-keymap-initializer - (λ () - (new text-field% - [parent number-panel] - [init-value "1"] - [min-width 50] - [label #f])))) - - (define answers #f) - (define bp (new horizontal-panel% - [parent f] - [stretchable-height #f] - [alignment '(right center)])) - (define (confirm-callback b e) - (let ([n (string->number (send number get-value))] - [sym (with-handlers ([exn:fail:read? (λ (x) #f)]) - (read (open-input-string (send tb get-value))))]) - (when (and (number? n) - (symbol? sym)) - (set! answers (list (symbol->string sym) n))) - (send f show #f))) + + ;; beginning-of-sequence? : text number -> boolean + ;; determines if this position is at the beginning of a sequence + ;; that begins with a parenthesis. + (define (beginning-of-sequence? text start) + (let ([before-space (send text skip-whitespace start 'backward #t)]) + (cond + [(zero? before-space) #t] + [else + (equal? (send text get-character (- before-space 1)) + #\()]))) + + (define (text-between-equal? str text start end) + (and (= (string-length str) (- end start)) + (let loop ([i (string-length str)]) + (cond + [(= i 0) #t] + [else + (and (char=? (string-ref str (- i 1)) + (send text get-character (+ i start -1))) + (loop (- i 1)))])))) + + + ;;; ;;; + ; ; + ; ; + ; ;;; ; ;;; ;;; ;;;;; ;;; ; ;;; ;;;; ; ;;; ;;; ; + ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; + ; ; ; ;;;;; ; ;;; ; ; ;;;; ; ; ;;;;; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ;;;; ;;;; ;;; ;;;; ;;; ;;;; ;;; ;;;; ;; ;;; ;;;;;; + ; ; + ; ; + ;;; ;;; + + + (define (add-preferences-panel) + (preferences:add-panel + (list (string-constant editor-prefs-panel-label) + (string-constant indenting-prefs-panel-label)) + make-indenting-prefs-panel) + (preferences:add-panel + (list (string-constant editor-prefs-panel-label) + (string-constant square-bracket-prefs-panel-label)) + make-square-bracket-prefs-panel)) + + (define (make-square-bracket-prefs-panel p) + (define main-panel (make-object vertical-panel% p)) + (define boxes-panel (new horizontal-panel% [parent main-panel])) + + (define (mk-list-box sym keyword-type pref->string get-new-one) + (letrec ([vp (new vertical-panel% [parent boxes-panel])] + [_ (new message% + [label (format (string-constant x-like-keywords) keyword-type)] + [parent vp])] + [lb + (new list-box% + [label #f] + [parent vp] + [choices (map pref->string (preferences:get sym))] + [callback + (λ (lb evt) + (send remove-button enable (pair? (send lb get-selections))))])] + [bp (new horizontal-panel% [parent vp] [stretchable-height #f])] + [add + (new button% + [label (string-constant add-keyword)] + [parent bp] + [callback + (λ (x y) + (let ([new-one (get-new-one)]) + (when new-one + (preferences:set sym (append (preferences:get sym) + (list new-one))))))])] + [remove-button + (new button% + [label (string-constant remove-keyword)] + [parent bp] + [callback + (λ (x y) + (let ([n (send lb get-selections)]) + (when (pair? n) + (preferences:set + sym + (let loop ([i 0] + [prefs (preferences:get sym)]) + (cond + [(= i (car n)) (cdr prefs)] + [else (cons (car prefs) + (loop (+ i 1) + (cdr prefs)))]))) + (cond + [(= 0 (send lb get-number)) + (send remove-button enable #f)] + [else + (send lb set-selection + (if (= (car n) (send lb get-number)) + (- (send lb get-number) 1) + (car n)))]))))])]) + (unless (pair? (send lb get-selections)) + (send remove-button enable #f)) + (preferences:add-callback sym + (λ (p v) + (send lb clear) + (for-each (λ (x) (send lb append (pref->string x))) v))))) + + (define (get-new-simple-keyword label) + (λ () + (let ([new-one + (keymap:call/text-keymap-initializer + (λ () + (get-text-from-user + (format (string-constant enter-new-keyword) label) + (format (string-constant x-keyword) label))))]) + (and new-one + (let ([parsed (with-handlers ((exn:fail:read? (λ (x) #f))) + (read (open-input-string new-one)))]) - (define (cancel-callback b e) - (send f show #f)) - - (define-values (ok-button cancel-button) - (gui-utils:ok/cancel-buttons bp confirm-callback cancel-callback (string-constant ok) (string-constant cancel))) - (send f show #t) - answers) - - (define stupid-internal-definition-syntax1 - (mk-list-box 'framework:square-bracket:letrec "Letrec" values (get-new-simple-keyword "Letrec"))) - (define stupid-internal-definition-syntax3 - (mk-list-box 'framework:square-bracket:local - "Local" - values - (get-new-simple-keyword "Local"))) - (define stupid-internal-definition-syntax2 - (mk-list-box 'framework:square-bracket:cond/offset - "Cond" - (λ (l) (format "~a (~a)" (car l) (cadr l))) - get-new-cond-keyword)) - - (define check-box (new check-box% - [parent main-panel] - [label (string-constant fixup-open-brackets)] - [value (preferences:get 'framework:fixup-open-parens)] - [callback - (λ (x y) - (preferences:set 'framework:fixup-open-parens (send check-box get-value)))])) - (preferences:add-callback - 'framework:fixup-open-parens - (λ (p v) - (send check-box set-value v))) - - main-panel) + (and (symbol? parsed) + (symbol->string parsed))))))) + + (define (get-new-cond-keyword) + (define f (new dialog% [label (format (string-constant enter-new-keyword) "Cond")])) + (define tb (keymap:call/text-keymap-initializer + (λ () + (new text-field% + [parent f] + [label #f])))) + (define number-panel (new horizontal-panel% [parent f] [stretchable-height #f])) + (define number-label (new message% [parent number-panel] [label (string-constant skip-subexpressions)])) + (define number + (keymap:call/text-keymap-initializer + (λ () + (new text-field% + [parent number-panel] + [init-value "1"] + [min-width 50] + [label #f])))) + (define answers #f) + (define bp (new horizontal-panel% + [parent f] + [stretchable-height #f] + [alignment '(right center)])) + (define (confirm-callback b e) + (let ([n (string->number (send number get-value))] + [sym (with-handlers ([exn:fail:read? (λ (x) #f)]) + (read (open-input-string (send tb get-value))))]) + (when (and (number? n) + (symbol? sym)) + (set! answers (list (symbol->string sym) n))) + (send f show #f))) + + (define (cancel-callback b e) + (send f show #f)) + + (define-values (ok-button cancel-button) + (gui-utils:ok/cancel-buttons bp confirm-callback cancel-callback (string-constant ok) (string-constant cancel))) + (send f show #t) + answers) + + (define stupid-internal-definition-syntax1 + (mk-list-box 'framework:square-bracket:letrec "Letrec" values (get-new-simple-keyword "Letrec"))) + (define stupid-internal-definition-syntax3 + (mk-list-box 'framework:square-bracket:local + "Local" + values + (get-new-simple-keyword "Local"))) + (define stupid-internal-definition-syntax2 + (mk-list-box 'framework:square-bracket:cond/offset + "Cond" + (λ (l) (format "~a (~a)" (car l) (cadr l))) + get-new-cond-keyword)) + + (define check-box (new check-box% + [parent main-panel] + [label (string-constant fixup-open-brackets)] + [value (preferences:get 'framework:fixup-open-parens)] + [callback + (λ (x y) + (preferences:set 'framework:fixup-open-parens (send check-box get-value)))])) + (preferences:add-callback + 'framework:fixup-open-parens + (λ (p v) + (send check-box set-value v))) + + main-panel) + (define (make-indenting-prefs-panel p) (define get-keywords (λ (hash-table) @@ -1750,6 +1750,6 @@ (preferences:add-callback 'framework:tabify (λ (p v) (update-gui v))) (update-gui (preferences:get 'framework:tabify)) main-panel) - - ) + + ) diff --git a/collects/framework/private/sig.ss b/collects/framework/private/sig.ss index 38981407..bcffaf19 100644 --- a/collects/framework/private/sig.ss +++ b/collects/framework/private/sig.ss @@ -1,20 +1,20 @@ (module sig mzscheme (require (lib "unit.ss")) - + (provide (prefix-all-defined-except framework: framework^) framework^) - + (define-signature number-snip-class^ (snip-class%)) (define-signature number-snip^ extends number-snip-class^ (make-repeating-decimal-snip make-fraction-snip)) - + (define-signature comment-box-class^ (snipclass snip%)) (define-signature comment-box^ extends comment-box-class^ ()) - + (define-signature menu-class^ (can-restore<%> can-restore-mixin @@ -25,73 +25,73 @@ can-restore-underscore-menu%)) (define-signature menu^ extends menu-class^ ()) - + (define-signature version-class^ ()) (define-signature version^ extends version-class^ (add-spec version)) - + (define-signature panel-class^ (single-mixin single<%> - + single-window<%> single-window-mixin - + ;;multi-view-mixin ;;multi-view<%> - + single% single-pane% ;;multi-view% - + dragable<%> dragable-mixin - + vertical-dragable<%> vertical-dragable-mixin vertical-dragable% - + horizontal-dragable<%> horizontal-dragable-mixin horizontal-dragable%)) (define-signature panel^ extends panel-class^ ()) - + (define-signature application-class^ ()) (define-signature application^ extends application-class^ (current-app-name)) - + (define-signature preferences-class^ ()) (define-signature preferences^ extends preferences-class^ (put-preferences/gui add-panel add-font-panel - + add-editor-checkbox-panel add-warnings-checkbox-panel add-scheme-checkbox-panel - + add-to-editor-checkbox-panel add-to-warnings-checkbox-panel add-to-scheme-checkbox-panel add-on-close-dialog-callback add-can-close-dialog-callback - + show-dialog hide-dialog)) - + (define-signature autosave-class^ (autosavable<%>)) (define-signature autosave^ extends autosave-class^ (register restore-autosave-files/gui)) - + (define-signature exit-class^ ()) (define-signature exit^ extends exit-class^ @@ -103,13 +103,13 @@ can-exit? on-exit exit)) - + (define-signature path-utils-class^ ()) (define-signature path-utils^ extends path-utils-class^ (generate-autosave-name generate-backup-name)) - + (define-signature finder-class^ ()) (define-signature finder^ extends finder-class^ @@ -123,7 +123,7 @@ common-get-file-list get-file put-file)) - + (define-signature editor-class^ (basic<%> standard-style-list<%> @@ -145,7 +145,7 @@ set-standard-style-list-delta set-default-font-color get-default-color-style-name)) - + (define-signature pasteboard-class^ (basic% standard-style-list% @@ -155,7 +155,7 @@ info%)) (define-signature pasteboard^ extends pasteboard-class^ ()) - + (define-signature text-class^ (basic<%> foreground-color<%> @@ -204,7 +204,7 @@ input-box-mixin)) (define-signature text^ extends text-class^ ()) - + (define-signature canvas-class^ (basic<%> color<%> @@ -217,7 +217,7 @@ info% delegate% wide-snip% - + basic-mixin color-mixin delegate-mixin @@ -225,7 +225,7 @@ wide-snip-mixin)) (define-signature canvas^ extends canvas-class^ ()) - + (define-signature frame-class^ (basic<%> size-pref<%> @@ -277,12 +277,12 @@ remove-empty-menus add-snip-menu-items setup-size-pref)) - + (define-signature group-class^ (%)) (define-signature group^ extends group-class^ (get-the-frame-group)) - + (define-signature handler-class^ ()) (define-signature handler^ extends handler-class^ @@ -301,7 +301,7 @@ set-recent-position set-recent-items-frame-superclass size-recently-opened-files)) - + (define-signature icon-class^ ()) (define-signature icon^ extends icon-class^ @@ -312,13 +312,13 @@ get-lock-bitmap get-unlock-bitmap get-anchor-bitmap - + get-left/right-cursor get-up/down-cursor get-gc-on-bitmap get-gc-off-bitmap)) - + (define-signature keymap-class^ (aug-keymap% aug-keymap<%> @@ -326,22 +326,22 @@ (define-signature keymap^ extends keymap-class^ (send-map-function-meta make-meta-prefix-list - + canonicalize-keybinding-string - + add-to-right-button-menu add-to-right-button-menu/before - + setup-global setup-search setup-file setup-editor - + get-global get-search get-file get-editor - + set-chained-keymaps remove-chained-keymap @@ -349,12 +349,12 @@ add-user-keybindings-file remove-user-keybindings-file)) - + (define-signature color-class^ (text<%> text-mixin text% - + text-mode<%> text-mode-mixin text-mode%)) @@ -382,7 +382,7 @@ text-mode% set-mode-mixin - + sexp-snip% sexp-snip<%>)) (define-signature scheme^ extends scheme-class^ @@ -399,17 +399,17 @@ short-sym->style-name text-balanced?)) - + (define-signature main-class^ ()) (define-signature main^ extends main-class^ ()) - + (define-signature mode-class^ (host-text-mixin host-text<%> surrogate-text% surrogate-text<%>)) (define-signature mode^ extends mode-class^ ()) - + (define-signature color-model-class^ ()) (define-signature color-model^ extends color-model-class^ diff --git a/collects/framework/private/text.ss b/collects/framework/private/text.ss index 51620da9..376183f6 100644 --- a/collects/framework/private/text.ss +++ b/collects/framework/private/text.ss @@ -7,16 +7,16 @@ WARNING: printf is rebound in the body of the unit to always (module text (lib "a-unit.ss") (require (lib "string-constant.ss" "string-constants") - (lib "class.ss") + (lib "class.ss") (lib "match.ss") - "sig.ss" - "../gui-utils.ss" - "../preferences.ss" + "sig.ss" + "../gui-utils.ss" + "../preferences.ss" (lib "mred-sig.ss" "mred") (lib "interactive-value-port.ss" "mrlib") - (lib "list.ss") - (lib "etc.ss")) - + (lib "list.ss") + (lib "etc.ss")) + (import mred^ [prefix icon: framework:icon^] [prefix editor: framework:editor^] @@ -29,949 +29,949 @@ WARNING: printf is rebound in the body of the unit to always (export (rename framework:text^ [-keymap% keymap%])) (init-depend framework:editor^) + + (define original-output-port (current-output-port)) + (define (printf . args) + (apply fprintf original-output-port args) + (void)) + + (define-struct range (start end b/w-bitmap color caret-space?)) + (define-struct rectangle (left top right bottom b/w-bitmap color)) + + ;; wx: `default-wrapping?', add as the initial value for auto-wrap bitmap, + ;; unless matthew makes it primitive + + (define basic<%> + (interface (editor:basic<%> (class->interface text%)) + highlight-range + unhighlight-range + get-highlighted-ranges + get-styles-fixed + get-fixed-style + set-styles-fixed + move/copy-to-edit + initial-autowrap-bitmap)) + + (define basic-mixin + (mixin (editor:basic<%> (class->interface text%)) (basic<%>) + (inherit get-canvas get-canvases get-admin split-snip get-snip-position + begin-edit-sequence end-edit-sequence + set-autowrap-bitmap + delete find-snip invalidate-bitmap-cache + set-file-format get-file-format + get-style-list is-modified? change-style set-modified + position-location get-extent) - (define original-output-port (current-output-port)) - (define (printf . args) - (apply fprintf original-output-port args) - (void)) + (define highlight-pen #f) + (define highlight-brush #f) - (define-struct range (start end b/w-bitmap color caret-space?)) - (define-struct rectangle (left top right bottom b/w-bitmap color)) + (define range-rectangles null) + (define ranges null) - ;; wx: `default-wrapping?', add as the initial value for auto-wrap bitmap, - ;; unless matthew makes it primitive + (define/public-final (get-highlighted-ranges) ranges) + (define/public (get-fixed-style) + (send (get-style-list) find-named-style "Standard")) - (define basic<%> - (interface (editor:basic<%> (class->interface text%)) - highlight-range - unhighlight-range - get-highlighted-ranges - get-styles-fixed - get-fixed-style - set-styles-fixed - move/copy-to-edit - initial-autowrap-bitmap)) - - (define basic-mixin - (mixin (editor:basic<%> (class->interface text%)) (basic<%>) - (inherit get-canvas get-canvases get-admin split-snip get-snip-position - begin-edit-sequence end-edit-sequence - set-autowrap-bitmap - delete find-snip invalidate-bitmap-cache - set-file-format get-file-format - get-style-list is-modified? change-style set-modified - position-location get-extent) - - (define highlight-pen #f) - (define highlight-brush #f) - - (define range-rectangles null) - (define ranges null) - - (define/public-final (get-highlighted-ranges) ranges) - (define/public (get-fixed-style) - (send (get-style-list) find-named-style "Standard")) - - (define/private (invalidate-rectangles rectangles) - (let ([b1 (box 0)] - [b2 (box 0)] - [b3 (box 0)] - [b4 (box 0)] - [canvases (get-canvases)]) - (let-values ([(min-left max-right) - (cond - [(null? canvases) - (let ([admin (get-admin)]) - (if admin - (begin - (send 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))) - (values #f #f)))] - [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 - (λ () - (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] - [right #f] - [bottom #f] - [rectangles rectangles]) - (cond - [(null? rectangles) - (when left - (let ([width (- right left)] - [height (- bottom top)]) - (when (and (> width 0) - (> height 0)) - (invalidate-bitmap-cache left top width height))))] - [else (let* ([r (car rectangles)] - - [rleft (rectangle-left r)] - [rright (rectangle-right r)] - [rtop (rectangle-top r)] - [rbottom (rectangle-bottom r)] - - [this-left (if (number? rleft) - rleft - min-left)] - [this-right (if (number? rright) - rright - max-right)] - [this-bottom rbottom] - [this-top rtop]) - (if (and left top right bottom) - (loop (min this-left left) - (min this-top top) - (max this-right right) - (max this-bottom bottom) - (cdr rectangles)) - (loop this-left - this-top - this-right - this-bottom - (cdr rectangles))))])))))) - - (define/private (recompute-range-rectangles) - (let* ([b1 (box 0)] - [b2 (box 0)] - [new-rectangles - (λ (range) - (let* ([start (range-start range)] - [end (range-end range)] - [b/w-bitmap (range-b/w-bitmap range)] - [color (range-color range)] - [caret-space? (range-caret-space? range)] - [start-eol? #f] - [end-eol? (if (= start end) - start-eol? - #t)]) - (let-values ([(start-x top-start-y) - (begin - (position-location start b1 b2 #t start-eol? #t) - (values (if caret-space? - (+ 1 (unbox b1)) - (unbox b1)) - (unbox b2)))] - [(end-x top-end-y) - (begin (position-location end b1 b2 #t end-eol? #t) - (values (unbox b1) (unbox b2)))] - [(bottom-start-y) - (begin (position-location start b1 b2 #f start-eol? #t) - (unbox b2))] - [(bottom-end-y) - (begin (position-location end b1 b2 #f end-eol? #t) - (unbox b2))]) - (cond - [(= top-start-y top-end-y) - (list - (make-rectangle start-x - top-start-y - (if (= end-x start-x) - (+ end-x 1) - end-x) - bottom-start-y - b/w-bitmap - color))] - [else - (list - (make-rectangle start-x - top-start-y - 'right-edge - bottom-start-y - b/w-bitmap - color) - (make-rectangle 'left-edge - bottom-start-y - 'max-width - top-end-y - b/w-bitmap - color) - (make-rectangle 'left-edge - top-end-y - end-x - bottom-end-y - b/w-bitmap - color))]))))] - [old-rectangles range-rectangles]) - - (set! range-rectangles - (foldl (λ (x l) (append (new-rectangles x) l)) - null ranges)))) - - (define/public highlight-range - (opt-lambda (start end color [bitmap #f] [caret-space? #f] [priority 'low]) - (unless (let ([exact-pos-int? - (λ (x) (and (integer? x) (exact? x) (x . >= . 0)))]) - (and (exact-pos-int? start) - (exact-pos-int? end))) - (error 'highlight-range "expected first two arguments to be non-negative exact integers, got: ~e ~e" - start end)) - (unless (or (eq? priority 'high) (eq? priority 'low)) - (error 'highlight-range "expected last argument to be either 'high or 'low, got: ~e" - priority)) - (let ([l (make-range start end bitmap color caret-space?)]) - (invalidate-rectangles range-rectangles) - (set! ranges (if (eq? priority 'high) (cons l ranges) (append ranges (list l)))) - (recompute-range-rectangles) - (invalidate-rectangles range-rectangles) - (λ () (unhighlight-range start end color bitmap caret-space?))))) - - (define/public unhighlight-range - (opt-lambda (start end color [bitmap #f] [caret-space? #f]) - (let ([old-rectangles range-rectangles]) - (set! ranges - (let loop ([r ranges]) + (define/private (invalidate-rectangles rectangles) + (let ([b1 (box 0)] + [b2 (box 0)] + [b3 (box 0)] + [b4 (box 0)] + [canvases (get-canvases)]) + (let-values ([(min-left max-right) (cond - [(null? r) r] - [else (if (matching-rectangle? (car r) start end color bitmap caret-space?) - (cdr r) - (cons (car r) (loop (cdr r))))]))) - (recompute-range-rectangles) - (invalidate-rectangles old-rectangles)))) + [(null? canvases) + (let ([admin (get-admin)]) + (if admin + (begin + (send 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))) + (values #f #f)))] + [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 + (λ () + (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] + [right #f] + [bottom #f] + [rectangles rectangles]) + (cond + [(null? rectangles) + (when left + (let ([width (- right left)] + [height (- bottom top)]) + (when (and (> width 0) + (> height 0)) + (invalidate-bitmap-cache left top width height))))] + [else (let* ([r (car rectangles)] + + [rleft (rectangle-left r)] + [rright (rectangle-right r)] + [rtop (rectangle-top r)] + [rbottom (rectangle-bottom r)] + + [this-left (if (number? rleft) + rleft + min-left)] + [this-right (if (number? rright) + rright + max-right)] + [this-bottom rbottom] + [this-top rtop]) + (if (and left top right bottom) + (loop (min this-left left) + (min this-top top) + (max this-right right) + (max this-bottom bottom) + (cdr rectangles)) + (loop this-left + this-top + this-right + this-bottom + (cdr rectangles))))])))))) + + (define/private (recompute-range-rectangles) + (let* ([b1 (box 0)] + [b2 (box 0)] + [new-rectangles + (λ (range) + (let* ([start (range-start range)] + [end (range-end range)] + [b/w-bitmap (range-b/w-bitmap range)] + [color (range-color range)] + [caret-space? (range-caret-space? range)] + [start-eol? #f] + [end-eol? (if (= start end) + start-eol? + #t)]) + (let-values ([(start-x top-start-y) + (begin + (position-location start b1 b2 #t start-eol? #t) + (values (if caret-space? + (+ 1 (unbox b1)) + (unbox b1)) + (unbox b2)))] + [(end-x top-end-y) + (begin (position-location end b1 b2 #t end-eol? #t) + (values (unbox b1) (unbox b2)))] + [(bottom-start-y) + (begin (position-location start b1 b2 #f start-eol? #t) + (unbox b2))] + [(bottom-end-y) + (begin (position-location end b1 b2 #f end-eol? #t) + (unbox b2))]) + (cond + [(= top-start-y top-end-y) + (list + (make-rectangle start-x + top-start-y + (if (= end-x start-x) + (+ end-x 1) + end-x) + bottom-start-y + b/w-bitmap + color))] + [else + (list + (make-rectangle start-x + top-start-y + 'right-edge + bottom-start-y + b/w-bitmap + color) + (make-rectangle 'left-edge + bottom-start-y + 'max-width + top-end-y + b/w-bitmap + color) + (make-rectangle 'left-edge + top-end-y + end-x + bottom-end-y + b/w-bitmap + color))]))))] + [old-rectangles range-rectangles]) - (define/private (matching-rectangle? r start end color bitmap caret-space?) - (and (equal? start (range-start r)) - (equal? end (range-end r)) - (eq? bitmap (range-b/w-bitmap r)) - (equal? color (range-color r)) - (equal? caret-space? (range-caret-space? r)))) - - (define/override (on-paint before dc left-margin top-margin right-margin bottom-margin dx dy draw-caret) - (super on-paint before dc left-margin top-margin right-margin bottom-margin dx dy draw-caret) + (set! range-rectangles + (foldl (λ (x l) (append (new-rectangles x) l)) + null ranges)))) + + (define/public highlight-range + (opt-lambda (start end color [bitmap #f] [caret-space? #f] [priority 'low]) + (unless (let ([exact-pos-int? + (λ (x) (and (integer? x) (exact? x) (x . >= . 0)))]) + (and (exact-pos-int? start) + (exact-pos-int? end))) + (error 'highlight-range "expected first two arguments to be non-negative exact integers, got: ~e ~e" + start end)) + (unless (or (eq? priority 'high) (eq? priority 'low)) + (error 'highlight-range "expected last argument to be either 'high or 'low, got: ~e" + priority)) + (let ([l (make-range start end bitmap color caret-space?)]) + (invalidate-rectangles range-rectangles) + (set! ranges (if (eq? priority 'high) (cons l ranges) (append ranges (list l)))) (recompute-range-rectangles) - (let ([b1 (box 0)] - [b2 (box 0)] - [b3 (box 0)] - [b4 (box 0)]) - (for-each - (λ (rectangle) - (let-values ([(view-x view-y view-width view-height) - (begin - (send (get-admin) get-view b1 b2 b3 b4) - (values (unbox b1) - (unbox b2) - (unbox b3) - (unbox b4)))]) - (let* ([old-pen (send dc get-pen)] - [old-brush (send dc get-brush)] - [b/w-bitmap (rectangle-b/w-bitmap rectangle)] - [color (let* ([rc (rectangle-color rectangle)] - [tmpc (make-object color% 0 0 0)]) - (if rc - (begin (send dc try-color rc tmpc) - (if (<= (color-model:rgb-color-distance - (send rc red) - (send rc green) - (send rc blue) - (send tmpc red) - (send tmpc green) - (send tmpc blue)) - 18) - rc - #f)) - rc))] - [first-number (λ (x y) (if (number? x) x y))] - [left (max left-margin (first-number (rectangle-left rectangle) view-x))] - [top (max top-margin (rectangle-top rectangle))] - [right (min right-margin - (first-number - (rectangle-right rectangle) - (+ view-x view-width)))] - [bottom (min bottom-margin (rectangle-bottom rectangle))] - [width (max 0 (- right left))] - [height (max 0 (- bottom top))]) - (let/ec k - (cond - [(and before color) - (send dc set-pen (send the-pen-list find-or-create-pen color 0 'solid)) - (send dc set-brush (send the-brush-list find-or-create-brush color 'solid))] - [(and (not before) (not color) b/w-bitmap) - (unless highlight-pen - (set! highlight-pen (make-object pen% "BLACK" 0 'solid))) - (unless highlight-brush - (set! highlight-brush (make-object brush% "black" 'solid))) - (send highlight-pen set-stipple b/w-bitmap) - (send highlight-brush set-stipple b/w-bitmap) - (send dc set-pen highlight-pen) - (send dc set-brush highlight-brush)] - [else (k (void))]) - (send dc draw-rectangle (+ left dx) (+ top dy) width height) - (send dc set-pen old-pen) - (send dc set-brush old-brush))))) - range-rectangles))) - - (define styles-fixed? #f) - (public get-styles-fixed set-styles-fixed) - (define (get-styles-fixed) styles-fixed?) - (define (set-styles-fixed b) (set! styles-fixed? b)) - - (define/augment (on-insert start len) - (begin-edit-sequence) - (inner (void) on-insert start len)) - (define/augment (after-insert start len) - (when styles-fixed? - (change-style (get-fixed-style) start (+ start len) #f)) - (inner (void) after-insert start len) - (end-edit-sequence)) - - (public move/copy-to-edit) - (define (move/copy-to-edit dest-edit start end dest-position) - (split-snip start) - (split-snip end) - (let loop ([snip (find-snip end 'before)]) - (cond - [(or (not snip) (< (get-snip-position snip) start)) - (void)] - [else - (let ([prev (send snip previous)] - [released/copied (if (send snip release-from-owner) - snip - (let* ([copy (send snip copy)] - [snip-start (get-snip-position snip)] - [snip-end (+ snip-start (send snip get-count))]) - (delete snip-start snip-end) - snip))]) - (send dest-edit insert released/copied dest-position dest-position) - (loop prev))]))) - - (public initial-autowrap-bitmap) - (define (initial-autowrap-bitmap) (icon:get-autowrap-bitmap)) - - (define/override (put-file directory default-name) - (let* ([canvas (get-canvas)] - [parent (and canvas (send canvas get-top-level-window))]) - (finder:put-file default-name - directory - #f - (string-constant select-file) - #f - "" - parent))) - - (super-new) - (set-autowrap-bitmap (initial-autowrap-bitmap)))) + (invalidate-rectangles range-rectangles) + (λ () (unhighlight-range start end color bitmap caret-space?))))) - (define foreground-color<%> - (interface (basic<%> editor:standard-style-list<%>) - )) - - (define foreground-color-mixin - (mixin (basic<%> editor:standard-style-list<%>) (foreground-color<%>) - (inherit begin-edit-sequence end-edit-sequence change-style get-style-list) - - (define/override (default-style-name) - (editor:get-default-color-style-name)) - - (define/override (get-fixed-style) - (send (editor:get-standard-style-list) - find-named-style - (editor:get-default-color-style-name))) - (super-new))) + (define/public unhighlight-range + (opt-lambda (start end color [bitmap #f] [caret-space? #f]) + (let ([old-rectangles range-rectangles]) + (set! ranges + (let loop ([r ranges]) + (cond + [(null? r) r] + [else (if (matching-rectangle? (car r) start end color bitmap caret-space?) + (cdr r) + (cons (car r) (loop (cdr r))))]))) + (recompute-range-rectangles) + (invalidate-rectangles old-rectangles)))) - (define hide-caret/selection<%> (interface (basic<%>))) - (define hide-caret/selection-mixin - (mixin (basic<%>) (hide-caret/selection<%>) - (inherit get-start-position get-end-position hide-caret) - (define/augment (after-set-position) - (hide-caret (= (get-start-position) (get-end-position))) - (inner (void) after-set-position)) - (super-new))) - - (define nbsp->space<%> (interface ((class->interface text%)))) - (define nbsp->space-mixin - (mixin ((class->interface text%)) (nbsp->space<%>) - (field [rewriting #f]) - (inherit begin-edit-sequence end-edit-sequence delete insert get-character) - (define/augment (on-insert start len) - (inner (void) on-insert start len) - (begin-edit-sequence)) - (inherit find-string) - (define/augment (after-insert start len) - (unless rewriting - (set! rewriting #t) - (let ([str (string (integer->char 160))] - [last-pos (+ start len)]) - (let loop ([pos start]) - (when (< pos last-pos) - (let ([next-pos (find-string str 'forward pos last-pos)]) - (when next-pos - (delete next-pos (+ next-pos 1) #f) - (insert " " next-pos next-pos #f) - (loop (+ next-pos 1))))))) - (set! rewriting #f)) - (end-edit-sequence) - (inner (void) after-insert start len)) - (super-instantiate ()))) + (define/private (matching-rectangle? r start end color bitmap caret-space?) + (and (equal? start (range-start r)) + (equal? end (range-end r)) + (eq? bitmap (range-b/w-bitmap r)) + (equal? color (range-color r)) + (equal? caret-space? (range-caret-space? r)))) - (define searching<%> (interface (editor:keymap<%> basic<%>))) - (define searching-mixin - (mixin (editor:keymap<%> basic<%>) (searching<%>) - (define/override (get-keymaps) - (cons (keymap:get-search) (super get-keymaps))) - (super-instantiate ()))) - - (define return<%> (interface ((class->interface text%)))) - (define return-mixin - (mixin ((class->interface text%)) (return<%>) - (init-field return) - (define/override (on-local-char key) - (let ([cr-code #\return] - [lf-code #\newline] - [code (send key get-key-code)]) - (or (and (char? code) - (or (char=? lf-code code) - (char=? cr-code code)) - (return)) - (super on-local-char key)))) - (super-new))) - - (define wide-snip<%> - (interface (basic<%>) - add-wide-snip - add-tall-snip)) - - (define wide-snip-mixin - (mixin (basic<%>) (wide-snip<%>) - (define wide-snips '()) - (define tall-snips '()) - (define/public (add-wide-snip s) (set! wide-snips (cons s wide-snips))) - (define/public (get-wide-snips) wide-snips) - (define/public (add-tall-snip s) (set! tall-snips (cons s tall-snips))) - (define/public (get-tall-snips) tall-snips) - (super-new))) - - (define delegate<%> (interface (basic<%>) - get-delegate - set-delegate)) - - (define small-version-of-snip% - (class snip% - (init-field big-snip) - (define width 0) - (define height 0) - (define/override (get-extent dc x y wb hb db sb lb rb) - (set/f! db 0) - (set/f! sb 0) - (set/f! lb 0) - (set/f! rb 0) - (let ([bwb (box 0)] - [bhb (box 0)]) - (send big-snip get-extent dc x y bwb bhb #f #f #f #f) - (let* ([cw (send dc get-char-width)] - [ch (send dc get-char-height)] - [w (floor (/ (unbox bwb) cw))] - [h (floor (/ (unbox bhb) ch))]) - (set/f! wb w) - (set/f! hb h) - (set! width w) - (set! height h)))) - - (define/override (draw dc x y left top right bottom dx dy draw-caret) - (send dc draw-rectangle x y width height)) - (define/override (copy) (instantiate small-version-of-snip% () (big-snip big-snip))) - (super-instantiate ()))) - - (define 1-pixel-string-snip% - (class string-snip% - (init-rest args) - (inherit get-text get-count set-count get-flags) - (define/override (split position first second) - (let* ([str (get-text 0 (get-count))] - [new-second (make-object 1-pixel-string-snip% - (substring str position (string-length str)))]) - (set-box! first this) - (set-box! second new-second) - (set-count position) - (void))) - (define/override (copy) - (let ([cpy (make-object 1-pixel-string-snip% - (get-text 0 (get-count)))]) - (send cpy set-flags (get-flags)))) - (define/override (get-extent dc x y wb hb db sb lb rb) - (cond - [(memq 'invisible (get-flags)) - (set/f! wb 0)] - [else - (set/f! wb (get-count))]) - (set/f! hb 1) - (set/f! db 0) - (set/f! sb 0) - (set/f! lb 0) - (set/f! rb 0)) - - (define cache-function #f) - - (define/override (insert s len pos) - (set! cache-function #f) - (super insert s len pos)) - - ;; for-each/sections : string -> dc number number -> void - (define/private (for-each/sections str) - (let loop ([n (string-length str)] - [len 0] - [blank? #t]) - (cond - [(zero? n) - (if blank? - (λ (dc x y) (void)) - (λ (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)))]) + (define/override (on-paint before dc left-margin top-margin right-margin bottom-margin dx dy draw-caret) + (super on-paint before dc left-margin top-margin right-margin bottom-margin dx dy draw-caret) + (recompute-range-rectangles) + (let ([b1 (box 0)] + [b2 (box 0)] + [b3 (box 0)] + [b4 (box 0)]) + (for-each + (λ (rectangle) + (let-values ([(view-x view-y view-width view-height) + (begin + (send (get-admin) get-view b1 b2 b3 b4) + (values (unbox b1) + (unbox b2) + (unbox b3) + (unbox b4)))]) + (let* ([old-pen (send dc get-pen)] + [old-brush (send dc get-brush)] + [b/w-bitmap (rectangle-b/w-bitmap rectangle)] + [color (let* ([rc (rectangle-color rectangle)] + [tmpc (make-object color% 0 0 0)]) + (if rc + (begin (send dc try-color rc tmpc) + (if (<= (color-model:rgb-color-distance + (send rc red) + (send rc green) + (send rc blue) + (send tmpc red) + (send tmpc green) + (send tmpc blue)) + 18) + rc + #f)) + rc))] + [first-number (λ (x y) (if (number? x) x y))] + [left (max left-margin (first-number (rectangle-left rectangle) view-x))] + [top (max top-margin (rectangle-top rectangle))] + [right (min right-margin + (first-number + (rectangle-right rectangle) + (+ view-x view-width)))] + [bottom (min bottom-margin (rectangle-bottom rectangle))] + [width (max 0 (- right left))] + [height (max 0 (- bottom top))]) + (let/ec k (cond - [(eq? white? blank?) - (loop (- n 1) (+ len 1) blank?)] - [else - (let ([res (loop (- n 1) 1 (not blank?))]) - (if blank? - res - (λ (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 dc x y)))) - (apply super-make-object args))) + [(and before color) + (send dc set-pen (send the-pen-list find-or-create-pen color 0 'solid)) + (send dc set-brush (send the-brush-list find-or-create-brush color 'solid))] + [(and (not before) (not color) b/w-bitmap) + (unless highlight-pen + (set! highlight-pen (make-object pen% "BLACK" 0 'solid))) + (unless highlight-brush + (set! highlight-brush (make-object brush% "black" 'solid))) + (send highlight-pen set-stipple b/w-bitmap) + (send highlight-brush set-stipple b/w-bitmap) + (send dc set-pen highlight-pen) + (send dc set-brush highlight-brush)] + [else (k (void))]) + (send dc draw-rectangle (+ left dx) (+ top dy) width height) + (send dc set-pen old-pen) + (send dc set-brush old-brush))))) + range-rectangles))) - (define 1-pixel-tab-snip% - (class tab-snip% - (init-rest args) - (inherit get-text get-count set-count get-flags) - (define/override (split position first second) - (let* ([str (get-text 0 (get-count))] - [new-second (make-object 1-pixel-string-snip% - (substring str position (string-length str)))]) - (set-box! first this) - (set-box! second new-second) - (set-count position) - (void))) - (define/override (copy) - (let ([cpy (make-object 1-pixel-tab-snip%)]) - (send cpy set-flags (get-flags)))) - - (inherit get-admin) - (define/override (get-extent dc x y wb hb db sb lb rb) - (set/f! wb 0) - (let ([admin (get-admin)]) - (when admin - (let ([ed (send admin get-editor)]) - (when (is-a? ed text%) - (let ([len-b (box 0)] - [tab-width-b (box 0)] - [in-units-b (box #f)]) - (send ed get-tabs len-b tab-width-b in-units-b) - (when (and (or (equal? (unbox len-b) 0) - (equal? (unbox len-b) null)) - (not (unbox in-units-b))) - (let ([tabspace (unbox tab-width-b)]) - (set/f! wb (tabspace . - . (x . modulo . tabspace)))))))))) - - (set/f! hb 0) - (set/f! db 0) - (set/f! sb 0) - (set/f! lb 0) - (set/f! rb 0)) - - (define/override (draw dc x y left top right bottom dx dy draw-caret) - (void)) - (apply super-make-object args))) - - (define (set/f! b n) - (when (box? b) - (set-box! b n))) - - (define delegate-mixin - (mixin (basic<%>) (delegate<%>) - (inherit split-snip find-snip get-snip-position - find-first-snip get-style-list set-tabs) - - (define linked-snips #f) - - (define/private (copy snip) - (let ([new-snip - (cond - [(is-a? snip tab-snip%) - (let ([new-snip (make-object 1-pixel-tab-snip%)]) - (send new-snip insert (string #\tab) 1) - new-snip)] - [(is-a? snip string-snip%) - (make-object 1-pixel-string-snip% - (send snip get-text 0 (send snip get-count)))] - [else - (let ([new-snip - (instantiate small-version-of-snip% () - (big-snip snip))]) - (hash-table-put! linked-snips snip new-snip) - new-snip)])]) - (send new-snip set-flags (send snip get-flags)) - (send new-snip set-style (send snip get-style)) - new-snip)) - - (define delegate #f) - (inherit get-highlighted-ranges) - (define/public-final (get-delegate) delegate) - (define/public-final (set-delegate _d) - (set! delegate _d) - (set! linked-snips (if _d - (make-hash-table) - #f)) - (refresh-delegate)) - - (define/private (refresh-delegate) - (when delegate - (send delegate begin-edit-sequence) - (send delegate lock #f) - (when (is-a? this scheme:text<%>) - (send delegate set-tabs null (send this get-tab-size) #f)) - (send delegate hide-caret #t) - (send delegate erase) - (send delegate set-style-list (get-style-list)) - (let loop ([snip (find-first-snip)]) - (when snip - (let ([copy-of-snip (copy snip)]) - (send delegate insert - copy-of-snip - (send delegate last-position) - (send delegate last-position)) - (loop (send snip next))))) - (for-each - (λ (range) - (send delegate unhighlight-range - (range-start range) - (range-end range) - (range-color range) - (range-b/w-bitmap range) - (range-caret-space? range))) - (send delegate get-highlighted-ranges)) - (for-each - (λ (range) - (send delegate highlight-range - (range-start range) - (range-end range) - (range-color range) - (range-b/w-bitmap range) - (range-caret-space? range) - 'high)) - (reverse (get-highlighted-ranges))) - (send delegate lock #t) - (send delegate end-edit-sequence))) - - (define/override highlight-range - (opt-lambda (start end color [bitmap #f] [caret-space? #f] [priority 'low]) - (when delegate - (send delegate highlight-range - start end color bitmap caret-space? priority)) - (super highlight-range start end color bitmap caret-space? priority))) - - (define/override unhighlight-range - (opt-lambda (start end color [bitmap #f] [caret-space? #f]) - (when delegate - (send delegate unhighlight-range start end color bitmap caret-space?)) - (super unhighlight-range start end color bitmap caret-space?))) - - (inherit get-canvases get-active-canvas has-focus?) - (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?) - (unless before? - (let ([active-canvas (get-active-canvas)]) - (when active-canvas - (send (send active-canvas get-top-level-window) delegate-moved))))) - - (define/augment (on-edit-sequence) - (when delegate - (send delegate begin-edit-sequence)) - (inner (void) on-edit-sequence)) - - (define/augment (after-edit-sequence) - (when delegate - (send delegate end-edit-sequence)) - (inner (void) after-edit-sequence)) - - (define/override (resized snip redraw-now?) - (super resized snip redraw-now?) - (when (and delegate - linked-snips - (not (is-a? snip string-snip%))) - (let ([delegate-copy (hash-table-get linked-snips snip (λ () #f))]) - (when delegate-copy - (send delegate resized delegate-copy redraw-now?))))) - - (define/augment (after-insert start len) - (when delegate - (send delegate begin-edit-sequence) - (send delegate lock #f) - (split-snip start) - (split-snip (+ start len)) - (let loop ([snip (find-snip (+ start len) 'before)]) - (when snip - (unless ((get-snip-position snip) . < . start) - (send delegate insert (copy snip) start start) - (loop (send snip previous))))) - (send delegate lock #t) - (send delegate end-edit-sequence)) - (inner (void) after-insert start len)) - - (define/augment (after-delete start len) - (when delegate - (send delegate lock #f) - (send delegate begin-edit-sequence) - (send delegate delete start (+ start len)) - (send delegate end-edit-sequence) - (send delegate lock #t)) - (inner (void) after-delete start len)) - - (define/augment (after-change-style start len) - (when delegate - (send delegate begin-edit-sequence) - (send delegate lock #f) - (split-snip start) - (let* ([snip (find-snip start 'after)] - [style (send snip get-style)] - [other-style - '(send (send delegate get-style-list) find-or-create-style - style delegate-style-delta)]) - (send delegate change-style style start (+ start len))) - (send delegate lock #f) - (send delegate end-edit-sequence)) - (inner (void) after-change-style start len)) - - (define filename #f) - (define format #f) - (define/augment (on-load-file _filename _format) - (set! filename _filename) - (set! format _format) - (inner (void) on-load-file _filename _format)) - (define/augment (after-load-file success?) - (when success? - (refresh-delegate)) - (inner (void) after-load-file success?)) - (super-instantiate ()))) - - (define info<%> (interface (basic<%>))) + (define styles-fixed? #f) + (public get-styles-fixed set-styles-fixed) + (define (get-styles-fixed) styles-fixed?) + (define (set-styles-fixed b) (set! styles-fixed? b)) - (define info-mixin - (mixin (editor:keymap<%> basic<%>) (info<%>) - (inherit get-start-position get-end-position get-canvas - run-after-edit-sequence) - (define/private (enqueue-for-frame call-method tag) - (run-after-edit-sequence - (rec from-enqueue-for-frame - (λ () - (call-with-frame call-method))) - tag)) - - ;; call-with-frame : ((is-a?/c frame:text-info<%>) -> void) -> void - ;; calls the argument thunk with the frame showing this editor. - (define/private (call-with-frame call-method) - (let ([canvas (get-canvas)]) - (when canvas - (let ([frame (send canvas get-top-level-window)]) - (when (is-a? frame frame:text-info<%>) - (call-method frame)))))) - - (define/override (set-anchor x) - (super set-anchor x) - (enqueue-for-frame - (λ (x) (send x anchor-status-changed)) - 'framework:anchor-status-changed)) - (define/override (set-overwrite-mode x) - (super set-overwrite-mode x) - (enqueue-for-frame - (λ (x) (send x overwrite-status-changed)) - 'framework:overwrite-status-changed)) - (define/augment (after-set-position) - (maybe-queue-editor-position-update) - (inner (void) after-set-position)) - - ;; maybe-queue-editor-position-update : -> void - ;; updates the editor-position in the frame, - ;; but delays it until the next low-priority event occurs. - (define callback-running? #f) - (define/private (maybe-queue-editor-position-update) - (enqueue-for-frame - (λ (frame) - (unless callback-running? - (set! callback-running? #t) - (queue-callback - (λ () - (send frame editor-position-changed) - (set! callback-running? #f)) - #f))) - 'framework:info-frame:update-editor-position)) - - (define/augment (after-insert start len) - (maybe-queue-editor-position-update) - (inner (void) after-insert start len)) - (define/augment (after-delete start len) - (maybe-queue-editor-position-update) - (inner (void) after-delete start len)) - (super-new))) + (define/augment (on-insert start len) + (begin-edit-sequence) + (inner (void) on-insert start len)) + (define/augment (after-insert start len) + (when styles-fixed? + (change-style (get-fixed-style) start (+ start len) #f)) + (inner (void) after-insert start len) + (end-edit-sequence)) - (define clever-file-format<%> (interface ((class->interface text%)))) + (public move/copy-to-edit) + (define (move/copy-to-edit dest-edit start end dest-position) + (split-snip start) + (split-snip end) + (let loop ([snip (find-snip end 'before)]) + (cond + [(or (not snip) (< (get-snip-position snip) start)) + (void)] + [else + (let ([prev (send snip previous)] + [released/copied (if (send snip release-from-owner) + snip + (let* ([copy (send snip copy)] + [snip-start (get-snip-position snip)] + [snip-end (+ snip-start (send snip get-count))]) + (delete snip-start snip-end) + snip))]) + (send dest-edit insert released/copied dest-position dest-position) + (loop prev))]))) - (define clever-file-format-mixin - (mixin ((class->interface text%)) (clever-file-format<%>) - (inherit get-file-format set-file-format find-first-snip) - (define/private (all-string-snips) - (let loop ([s (find-first-snip)]) - (cond - [(not s) #t] - [(is-a? s string-snip%) - (loop (send s next))] - [else #f]))) - (define/augment (on-save-file name format) - (let ([all-strings? (all-string-snips)]) - (cond - [(and all-strings? - (eq? format 'same) - (eq? 'standard (get-file-format)) - (or (not (preferences:get 'framework:verify-change-format)) - (gui-utils:get-choice - (string-constant save-as-plain-text) - (string-constant yes) - (string-constant no)))) - (set-file-format 'text)] - [(and (not all-strings?) - (eq? format 'same) - (eq? 'text (get-file-format)) - (or (not (preferences:get 'framework:verify-change-format)) - (gui-utils:get-choice - (string-constant save-in-drs-format) - (string-constant yes) - (string-constant no)))) - (set-file-format 'standard)] - [else (void)])) - (inner (void) on-save-file name format)) - (super-instantiate ()))) + (public initial-autowrap-bitmap) + (define (initial-autowrap-bitmap) (icon:get-autowrap-bitmap)) + (define/override (put-file directory default-name) + (let* ([canvas (get-canvas)] + [parent (and canvas (send canvas get-top-level-window))]) + (finder:put-file default-name + directory + #f + (string-constant select-file) + #f + "" + parent))) - (define file<%> - (interface (editor:file<%> basic<%>) - get-read-write?)) + (super-new) + (set-autowrap-bitmap (initial-autowrap-bitmap)))) + + (define foreground-color<%> + (interface (basic<%> editor:standard-style-list<%>) + )) + + (define foreground-color-mixin + (mixin (basic<%> editor:standard-style-list<%>) (foreground-color<%>) + (inherit begin-edit-sequence end-edit-sequence change-style get-style-list) - (define file-mixin - (mixin (editor:file<%> basic<%>) (file<%>) - (inherit get-filename) - (define read-write? #t) - (define/public (get-read-write?) read-write?) - (define/private (check-lock) - (let* ([filename (get-filename)] - [can-edit? (if (and filename - (file-exists? filename)) - (and (member 'write (file-or-directory-permissions filename)) - #t) - #t)]) - (set! read-write? can-edit?))) - - (define/augment (can-insert? x y) - (and read-write? (inner #t can-insert? x y))) - (define/augment (can-delete? x y) - (and read-write? (inner #t can-delete? x y))) - - (define/augment (after-save-file success) - (when success - (check-lock)) - (inner (void) after-save-file success)) - - (define/augment (after-load-file sucessful?) - (when sucessful? - (check-lock)) - (inner (void) after-load-file sucessful?)) - (super-new))) - + (define/override (default-style-name) + (editor:get-default-color-style-name)) - (define ports<%> - (interface () - delete/io - get-insertion-point - set-insertion-point - get-unread-start-point - set-unread-start-point - set-allow-edits - get-allow-edits - insert-between - insert-before - submit-to-port? - on-submit - send-eof-to-in-port - send-eof-to-box-in-port - reset-input-box - clear-output-ports - clear-input-port - clear-box-input-port - get-out-style-delta - get-err-style-delta - get-value-style-delta - get-in-port - get-in-box-port - get-out-port - get-err-port - get-value-port - after-io-insertion - get-box-input-editor-snip% - get-box-input-text%)) + (define/override (get-fixed-style) + (send (editor:get-standard-style-list) + find-named-style + (editor:get-default-color-style-name))) + (super-new))) + + (define hide-caret/selection<%> (interface (basic<%>))) + (define hide-caret/selection-mixin + (mixin (basic<%>) (hide-caret/selection<%>) + (inherit get-start-position get-end-position hide-caret) + (define/augment (after-set-position) + (hide-caret (= (get-start-position) (get-end-position))) + (inner (void) after-set-position)) + (super-new))) + + (define nbsp->space<%> (interface ((class->interface text%)))) + (define nbsp->space-mixin + (mixin ((class->interface text%)) (nbsp->space<%>) + (field [rewriting #f]) + (inherit begin-edit-sequence end-edit-sequence delete insert get-character) + (define/augment (on-insert start len) + (inner (void) on-insert start len) + (begin-edit-sequence)) + (inherit find-string) + (define/augment (after-insert start len) + (unless rewriting + (set! rewriting #t) + (let ([str (string (integer->char 160))] + [last-pos (+ start len)]) + (let loop ([pos start]) + (when (< pos last-pos) + (let ([next-pos (find-string str 'forward pos last-pos)]) + (when next-pos + (delete next-pos (+ next-pos 1) #f) + (insert " " next-pos next-pos #f) + (loop (+ next-pos 1))))))) + (set! rewriting #f)) + (end-edit-sequence) + (inner (void) after-insert start len)) + (super-instantiate ()))) + + (define searching<%> (interface (editor:keymap<%> basic<%>))) + (define searching-mixin + (mixin (editor:keymap<%> basic<%>) (searching<%>) + (define/override (get-keymaps) + (cons (keymap:get-search) (super get-keymaps))) + (super-instantiate ()))) + + (define return<%> (interface ((class->interface text%)))) + (define return-mixin + (mixin ((class->interface text%)) (return<%>) + (init-field return) + (define/override (on-local-char key) + (let ([cr-code #\return] + [lf-code #\newline] + [code (send key get-key-code)]) + (or (and (char? code) + (or (char=? lf-code code) + (char=? cr-code code)) + (return)) + (super on-local-char key)))) + (super-new))) + + (define wide-snip<%> + (interface (basic<%>) + add-wide-snip + add-tall-snip)) + + (define wide-snip-mixin + (mixin (basic<%>) (wide-snip<%>) + (define wide-snips '()) + (define tall-snips '()) + (define/public (add-wide-snip s) (set! wide-snips (cons s wide-snips))) + (define/public (get-wide-snips) wide-snips) + (define/public (add-tall-snip s) (set! tall-snips (cons s tall-snips))) + (define/public (get-tall-snips) tall-snips) + (super-new))) + + (define delegate<%> (interface (basic<%>) + get-delegate + set-delegate)) + + (define small-version-of-snip% + (class snip% + (init-field big-snip) + (define width 0) + (define height 0) + (define/override (get-extent dc x y wb hb db sb lb rb) + (set/f! db 0) + (set/f! sb 0) + (set/f! lb 0) + (set/f! rb 0) + (let ([bwb (box 0)] + [bhb (box 0)]) + (send big-snip get-extent dc x y bwb bhb #f #f #f #f) + (let* ([cw (send dc get-char-width)] + [ch (send dc get-char-height)] + [w (floor (/ (unbox bwb) cw))] + [h (floor (/ (unbox bhb) ch))]) + (set/f! wb w) + (set/f! hb h) + (set! width w) + (set! height h)))) - (define-struct peeker (bytes skip-count pe resp-chan nack polling?) (make-inspector)) - (define-struct committer (kr commit-peeker-evt done-evt resp-chan resp-nack)) + (define/override (draw dc x y left top right bottom dx dy draw-caret) + (send dc draw-rectangle x y width height)) + (define/override (copy) (instantiate small-version-of-snip% () (big-snip big-snip))) + (super-instantiate ()))) + + (define 1-pixel-string-snip% + (class string-snip% + (init-rest args) + (inherit get-text get-count set-count get-flags) + (define/override (split position first second) + (let* ([str (get-text 0 (get-count))] + [new-second (make-object 1-pixel-string-snip% + (substring str position (string-length str)))]) + (set-box! first this) + (set-box! second new-second) + (set-count position) + (void))) + (define/override (copy) + (let ([cpy (make-object 1-pixel-string-snip% + (get-text 0 (get-count)))]) + (send cpy set-flags (get-flags)))) + (define/override (get-extent dc x y wb hb db sb lb rb) + (cond + [(memq 'invisible (get-flags)) + (set/f! wb 0)] + [else + (set/f! wb (get-count))]) + (set/f! hb 1) + (set/f! db 0) + (set/f! sb 0) + (set/f! lb 0) + (set/f! rb 0)) - (define msec-timeout 500) - (define output-buffer-full 4096) + (define cache-function #f) - (define-local-member-name - new-box-input - box-input-not-used-anymore - set-port-text) + (define/override (insert s len pos) + (set! cache-function #f) + (super insert s len pos)) - (define (set-box/f! b v) (when (box? b) (set-box! b v))) + ;; for-each/sections : string -> dc number number -> void + (define/private (for-each/sections str) + (let loop ([n (string-length str)] + [len 0] + [blank? #t]) + (cond + [(zero? n) + (if blank? + (λ (dc x y) (void)) + (λ (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 + [(eq? white? blank?) + (loop (- n 1) (+ len 1) blank?)] + [else + (let ([res (loop (- n 1) 1 (not blank?))]) + (if blank? + res + (λ (dc x y) + (send dc draw-line (+ x n) y (+ x n (- len 1)) y) + (res dc x y))))]))]))) - (define arrow-cursor (make-object cursor% 'arrow)) + (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 dc x y)))) + (apply super-make-object args))) + + (define 1-pixel-tab-snip% + (class tab-snip% + (init-rest args) + (inherit get-text get-count set-count get-flags) + (define/override (split position first second) + (let* ([str (get-text 0 (get-count))] + [new-second (make-object 1-pixel-string-snip% + (substring str position (string-length str)))]) + (set-box! first this) + (set-box! second new-second) + (set-count position) + (void))) + (define/override (copy) + (let ([cpy (make-object 1-pixel-tab-snip%)]) + (send cpy set-flags (get-flags)))) - (define eof-snip% - (class image-snip% - (init-field port-text) - (define/override (get-extent dc x y w h descent space lspace rspace) - (super get-extent dc x y w h descent space lspace rspace) - (set-box/f! descent 7)) ;; depends on actual bitmap used ... - - (define/override (on-event dc x y editorx editory event) - (when (send event button-up? 'left) - (send port-text send-eof-to-box-in-port))) - (define/override (adjust-cursor dc x y edx edy e) - arrow-cursor) - (super-make-object (icon:get-eof-bitmap)) - (inherit set-flags get-flags) - (set-flags (list* 'handles-events (get-flags))))) + (inherit get-admin) + (define/override (get-extent dc x y wb hb db sb lb rb) + (set/f! wb 0) + (let ([admin (get-admin)]) + (when admin + (let ([ed (send admin get-editor)]) + (when (is-a? ed text%) + (let ([len-b (box 0)] + [tab-width-b (box 0)] + [in-units-b (box #f)]) + (send ed get-tabs len-b tab-width-b in-units-b) + (when (and (or (equal? (unbox len-b) 0) + (equal? (unbox len-b) null)) + (not (unbox in-units-b))) + (let ([tabspace (unbox tab-width-b)]) + (set/f! wb (tabspace . - . (x . modulo . tabspace)))))))))) + + (set/f! hb 0) + (set/f! db 0) + (set/f! sb 0) + (set/f! lb 0) + (set/f! rb 0)) + (define/override (draw dc x y left top right bottom dx dy draw-caret) + (void)) + (apply super-make-object args))) + + (define (set/f! b n) + (when (box? b) + (set-box! b n))) + + (define delegate-mixin + (mixin (basic<%>) (delegate<%>) + (inherit split-snip find-snip get-snip-position + find-first-snip get-style-list set-tabs) + + (define linked-snips #f) + + (define/private (copy snip) + (let ([new-snip + (cond + [(is-a? snip tab-snip%) + (let ([new-snip (make-object 1-pixel-tab-snip%)]) + (send new-snip insert (string #\tab) 1) + new-snip)] + [(is-a? snip string-snip%) + (make-object 1-pixel-string-snip% + (send snip get-text 0 (send snip get-count)))] + [else + (let ([new-snip + (instantiate small-version-of-snip% () + (big-snip snip))]) + (hash-table-put! linked-snips snip new-snip) + new-snip)])]) + (send new-snip set-flags (send snip get-flags)) + (send new-snip set-style (send snip get-style)) + new-snip)) + + (define delegate #f) + (inherit get-highlighted-ranges) + (define/public-final (get-delegate) delegate) + (define/public-final (set-delegate _d) + (set! delegate _d) + (set! linked-snips (if _d + (make-hash-table) + #f)) + (refresh-delegate)) + + (define/private (refresh-delegate) + (when delegate + (send delegate begin-edit-sequence) + (send delegate lock #f) + (when (is-a? this scheme:text<%>) + (send delegate set-tabs null (send this get-tab-size) #f)) + (send delegate hide-caret #t) + (send delegate erase) + (send delegate set-style-list (get-style-list)) + (let loop ([snip (find-first-snip)]) + (when snip + (let ([copy-of-snip (copy snip)]) + (send delegate insert + copy-of-snip + (send delegate last-position) + (send delegate last-position)) + (loop (send snip next))))) + (for-each + (λ (range) + (send delegate unhighlight-range + (range-start range) + (range-end range) + (range-color range) + (range-b/w-bitmap range) + (range-caret-space? range))) + (send delegate get-highlighted-ranges)) + (for-each + (λ (range) + (send delegate highlight-range + (range-start range) + (range-end range) + (range-color range) + (range-b/w-bitmap range) + (range-caret-space? range) + 'high)) + (reverse (get-highlighted-ranges))) + (send delegate lock #t) + (send delegate end-edit-sequence))) + + (define/override highlight-range + (opt-lambda (start end color [bitmap #f] [caret-space? #f] [priority 'low]) + (when delegate + (send delegate highlight-range + start end color bitmap caret-space? priority)) + (super highlight-range start end color bitmap caret-space? priority))) + + (define/override unhighlight-range + (opt-lambda (start end color [bitmap #f] [caret-space? #f]) + (when delegate + (send delegate unhighlight-range start end color bitmap caret-space?)) + (super unhighlight-range start end color bitmap caret-space?))) + + (inherit get-canvases get-active-canvas has-focus?) + (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?) + (unless before? + (let ([active-canvas (get-active-canvas)]) + (when active-canvas + (send (send active-canvas get-top-level-window) delegate-moved))))) + + (define/augment (on-edit-sequence) + (when delegate + (send delegate begin-edit-sequence)) + (inner (void) on-edit-sequence)) + + (define/augment (after-edit-sequence) + (when delegate + (send delegate end-edit-sequence)) + (inner (void) after-edit-sequence)) + + (define/override (resized snip redraw-now?) + (super resized snip redraw-now?) + (when (and delegate + linked-snips + (not (is-a? snip string-snip%))) + (let ([delegate-copy (hash-table-get linked-snips snip (λ () #f))]) + (when delegate-copy + (send delegate resized delegate-copy redraw-now?))))) + + (define/augment (after-insert start len) + (when delegate + (send delegate begin-edit-sequence) + (send delegate lock #f) + (split-snip start) + (split-snip (+ start len)) + (let loop ([snip (find-snip (+ start len) 'before)]) + (when snip + (unless ((get-snip-position snip) . < . start) + (send delegate insert (copy snip) start start) + (loop (send snip previous))))) + (send delegate lock #t) + (send delegate end-edit-sequence)) + (inner (void) after-insert start len)) + + (define/augment (after-delete start len) + (when delegate + (send delegate lock #f) + (send delegate begin-edit-sequence) + (send delegate delete start (+ start len)) + (send delegate end-edit-sequence) + (send delegate lock #t)) + (inner (void) after-delete start len)) + + (define/augment (after-change-style start len) + (when delegate + (send delegate begin-edit-sequence) + (send delegate lock #f) + (split-snip start) + (let* ([snip (find-snip start 'after)] + [style (send snip get-style)] + [other-style + '(send (send delegate get-style-list) find-or-create-style + style delegate-style-delta)]) + (send delegate change-style style start (+ start len))) + (send delegate lock #f) + (send delegate end-edit-sequence)) + (inner (void) after-change-style start len)) + + (define filename #f) + (define format #f) + (define/augment (on-load-file _filename _format) + (set! filename _filename) + (set! format _format) + (inner (void) on-load-file _filename _format)) + (define/augment (after-load-file success?) + (when success? + (refresh-delegate)) + (inner (void) after-load-file success?)) + (super-instantiate ()))) + + (define info<%> (interface (basic<%>))) + + (define info-mixin + (mixin (editor:keymap<%> basic<%>) (info<%>) + (inherit get-start-position get-end-position get-canvas + run-after-edit-sequence) + (define/private (enqueue-for-frame call-method tag) + (run-after-edit-sequence + (rec from-enqueue-for-frame + (λ () + (call-with-frame call-method))) + tag)) + + ;; call-with-frame : ((is-a?/c frame:text-info<%>) -> void) -> void + ;; calls the argument thunk with the frame showing this editor. + (define/private (call-with-frame call-method) + (let ([canvas (get-canvas)]) + (when canvas + (let ([frame (send canvas get-top-level-window)]) + (when (is-a? frame frame:text-info<%>) + (call-method frame)))))) + + (define/override (set-anchor x) + (super set-anchor x) + (enqueue-for-frame + (λ (x) (send x anchor-status-changed)) + 'framework:anchor-status-changed)) + (define/override (set-overwrite-mode x) + (super set-overwrite-mode x) + (enqueue-for-frame + (λ (x) (send x overwrite-status-changed)) + 'framework:overwrite-status-changed)) + (define/augment (after-set-position) + (maybe-queue-editor-position-update) + (inner (void) after-set-position)) + + ;; maybe-queue-editor-position-update : -> void + ;; updates the editor-position in the frame, + ;; but delays it until the next low-priority event occurs. + (define callback-running? #f) + (define/private (maybe-queue-editor-position-update) + (enqueue-for-frame + (λ (frame) + (unless callback-running? + (set! callback-running? #t) + (queue-callback + (λ () + (send frame editor-position-changed) + (set! callback-running? #f)) + #f))) + 'framework:info-frame:update-editor-position)) + + (define/augment (after-insert start len) + (maybe-queue-editor-position-update) + (inner (void) after-insert start len)) + (define/augment (after-delete start len) + (maybe-queue-editor-position-update) + (inner (void) after-delete start len)) + (super-new))) + + (define clever-file-format<%> (interface ((class->interface text%)))) + + (define clever-file-format-mixin + (mixin ((class->interface text%)) (clever-file-format<%>) + (inherit get-file-format set-file-format find-first-snip) + (define/private (all-string-snips) + (let loop ([s (find-first-snip)]) + (cond + [(not s) #t] + [(is-a? s string-snip%) + (loop (send s next))] + [else #f]))) + (define/augment (on-save-file name format) + (let ([all-strings? (all-string-snips)]) + (cond + [(and all-strings? + (eq? format 'same) + (eq? 'standard (get-file-format)) + (or (not (preferences:get 'framework:verify-change-format)) + (gui-utils:get-choice + (string-constant save-as-plain-text) + (string-constant yes) + (string-constant no)))) + (set-file-format 'text)] + [(and (not all-strings?) + (eq? format 'same) + (eq? 'text (get-file-format)) + (or (not (preferences:get 'framework:verify-change-format)) + (gui-utils:get-choice + (string-constant save-in-drs-format) + (string-constant yes) + (string-constant no)))) + (set-file-format 'standard)] + [else (void)])) + (inner (void) on-save-file name format)) + (super-instantiate ()))) + + + (define file<%> + (interface (editor:file<%> basic<%>) + get-read-write?)) + + (define file-mixin + (mixin (editor:file<%> basic<%>) (file<%>) + (inherit get-filename) + (define read-write? #t) + (define/public (get-read-write?) read-write?) + (define/private (check-lock) + (let* ([filename (get-filename)] + [can-edit? (if (and filename + (file-exists? filename)) + (and (member 'write (file-or-directory-permissions filename)) + #t) + #t)]) + (set! read-write? can-edit?))) + + (define/augment (can-insert? x y) + (and read-write? (inner #t can-insert? x y))) + (define/augment (can-delete? x y) + (and read-write? (inner #t can-delete? x y))) + + (define/augment (after-save-file success) + (when success + (check-lock)) + (inner (void) after-save-file success)) + + (define/augment (after-load-file sucessful?) + (when sucessful? + (check-lock)) + (inner (void) after-load-file sucessful?)) + (super-new))) + + + (define ports<%> + (interface () + delete/io + get-insertion-point + set-insertion-point + get-unread-start-point + set-unread-start-point + set-allow-edits + get-allow-edits + insert-between + insert-before + submit-to-port? + on-submit + send-eof-to-in-port + send-eof-to-box-in-port + reset-input-box + clear-output-ports + clear-input-port + clear-box-input-port + get-out-style-delta + get-err-style-delta + get-value-style-delta + get-in-port + get-in-box-port + get-out-port + get-err-port + get-value-port + after-io-insertion + get-box-input-editor-snip% + get-box-input-text%)) + + (define-struct peeker (bytes skip-count pe resp-chan nack polling?) (make-inspector)) + (define-struct committer (kr commit-peeker-evt done-evt resp-chan resp-nack)) + + (define msec-timeout 500) + (define output-buffer-full 4096) + + (define-local-member-name + new-box-input + box-input-not-used-anymore + set-port-text) + + (define (set-box/f! b v) (when (box? b) (set-box! b v))) + + (define arrow-cursor (make-object cursor% 'arrow)) + + (define eof-snip% + (class image-snip% + (init-field port-text) + (define/override (get-extent dc x y w h descent space lspace rspace) + (super get-extent dc x y w h descent space lspace rspace) + (set-box/f! descent 7)) ;; depends on actual bitmap used ... + + (define/override (on-event dc x y editorx editory event) + (when (send event button-up? 'left) + (send port-text send-eof-to-box-in-port))) + (define/override (adjust-cursor dc x y edx edy e) + arrow-cursor) + (super-make-object (icon:get-eof-bitmap)) + (inherit set-flags get-flags) + (set-flags (list* 'handles-events (get-flags))))) + (define out-style-name "text:ports out") (define error-style-name "text:ports err") (define value-style-name "text:ports value") @@ -993,1067 +993,1067 @@ WARNING: printf is rebound in the body of the unit to always (send value-sd set-delta-foreground (make-object color% 0 0 175)) (create-style-name value-style-name value-sd))) - (define ports-mixin - (mixin (wide-snip<%>) (ports<%>) - (inherit begin-edit-sequence - change-style - delete - end-edit-sequence - find-snip - insert - get-canvas - get-start-position - get-end-position - get-snip-position - get-style-list - is-locked? - last-position - lock - paragraph-start-position - position-paragraph - release-snip - set-caret-owner - split-snip - get-focus-snip - get-view-size - scroll-to-position - position-location) - - ;; private field - (define eventspace (current-eventspace)) - - ;; insertion-point : number - ;; the place where the output ports insert data - ;; only updated in `eventspace' (above)'s main thread - (define insertion-point 0) - - ;; unread-start-points : number - ;; from this position to the end of the buffer is the - ;; users editing that has not been committed to the - ;; port. - ;; only updated in `eventspace' (above)'s main thread - (define unread-start-point 0) - - ;; box-input : (union #f (is-a?/c editor-snip%)) - ;; the snip where the user's input is typed for the box input port - (define box-input #f) - (define eof-button (new eof-snip% (port-text this))) - - ;; allow-edits? : boolean - ;; when this flag is set, only insert/delete after the - ;; insertion-point are allowed. - (define allow-edits? #f) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; - ;; public interface - ;; - - ;; insert-between : string/snp -> void - ;; inserts something between the insertion point and the unread region - (define/public-final (insert-between str/snp) - (insert str/snp unread-start-point unread-start-point) - (set! unread-start-point (+ unread-start-point - (amt-of-space str/snp)))) - - ;; insert-before : string/snp -> void - ;; inserts something before both the insertion point and the unread region - (define/public-final (insert-before str/snp) - (insert str/snp insertion-point insertion-point) - (let ([amt (amt-of-space str/snp)]) - (set! insertion-point (+ insertion-point amt)) - (set! unread-start-point (+ unread-start-point amt)))) - - (define/private (amt-of-space str/snp) - (cond - [(string? str/snp) (string-length str/snp)] - [(is-a? str/snp snip%) - (send str/snp get-count)])) - - (define/public-final (get-insertion-point) insertion-point) - (define/public-final (set-insertion-point ip) (set! insertion-point ip)) - (define/public-final (get-unread-start-point) - unread-start-point) - (define/public-final (set-unread-start-point u) - (unless (<= u (last-position)) - (error 'set-unread-start-point "~e is too large, last-position is ~e" - unread-start-point - (last-position))) - (set! unread-start-point u)) - - (define/public-final (set-allow-edits allow?) (set! allow-edits? allow?)) - (define/public-final (get-allow-edits) allow-edits?) - - (define/public-final (send-eof-to-in-port) - (channel-put read-chan (cons eof (position->line-col-pos unread-start-point)))) - (define/public-final (send-eof-to-box-in-port) - (channel-put box-read-chan (cons eof (position->line-col-pos unread-start-point)))) - (define/public-final (clear-input-port) (channel-put clear-input-chan (void))) - (define/public-final (clear-box-input-port) (channel-put box-clear-input-chan (void))) - (define/public-final (clear-output-ports) - (channel-put clear-output-chan (void)) - (init-output-ports)) - - ;; delete/io: number number -> void - (define/public-final (delete/io start end) - (unless (<= start end insertion-point) - (error 'delete/io "expected start (~a) <= end (~a) <= insertion-point (~a)" - start end insertion-point)) - - (let ([dist (- end start)]) - (set! insertion-point (- insertion-point dist)) - (set! unread-start-point (- unread-start-point dist))) - - (let ([before-allowed? allow-edits?]) - (set! allow-edits? #t) - (delete start end #f) - (set! allow-edits? before-allowed?))) - - (define/public-final (get-in-port) - (unless in-port (error 'get-in-port "not ready")) - in-port) - (define/public-final (get-in-box-port) - (unless in-port (error 'get-in-box-port "not ready")) - in-box-port) - (define/public-final (get-out-port) - (unless out-port (error 'get-out-port "not ready")) - out-port) - (define/public-final (get-err-port) - (unless err-port (error 'get-err-port "not ready")) - err-port) - (define/public-final (get-value-port) - (unless value-port (error 'get-value-port "not ready")) - value-port) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; - ;; specialization interface - ;; - - (define/pubment (submit-to-port? key) (inner #t submit-to-port? key)) - (define/pubment (on-submit) (inner (void) on-submit)) - (define/public (get-out-style-delta) out-style-name) - (define/public (get-err-style-delta) error-style-name) - (define/public (get-value-style-delta) value-style-name) - - (define/public (get-box-input-editor-snip%) editor-snip%) - (define/public (get-box-input-text%) input-box%) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; - ;; editor integration - ;; - - (define/augment (can-insert? start len) - (and (or allow-edits? - (start . >= . unread-start-point)) - (inner #t can-insert? start len))) - - (define/augment (can-delete? start len) - (and (or allow-edits? - (start . >= . unread-start-point)) - (inner #t can-delete? start len))) - - (define/override (on-local-char key) - (let ([start (get-start-position)] - [end (get-end-position)] - [code (send key get-key-code)]) - (cond - [(not (or (eq? code 'numpad-enter) - (equal? code #\return) - (equal? code #\newline))) - (super on-local-char key)] - [(and (insertion-point . <= . start) - (= start end) - (submit-to-port? key)) - (insert "\n") - (for-each/snips-chars - unread-start-point - (last-position) - (λ (s/c line-col-pos) - (cond - [(is-a? s/c snip%) - (channel-put read-chan (cons s/c line-col-pos))] - [(char? s/c) - (for-each (λ (b) (channel-put read-chan (cons b line-col-pos))) - (bytes->list (string->bytes/utf-8 (string s/c))))]))) - (set! unread-start-point (last-position)) - (set! insertion-point (last-position)) - (on-submit)] - [else - (super on-local-char key)]))) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; - ;; box input port management - ;; - - (define/public-final (reset-input-box) - (when box-input - (let ([l? (is-locked?)] - [old-allow-edits? allow-edits?]) - (lock #f) - (set! allow-edits? #t) - (send box-input release-from-owner) - (send eof-button release-from-owner) - (set! unread-start-point (- unread-start-point 2)) - (set! allow-edits? old-allow-edits?) - (lock l?)) - (set! box-input #f))) - - (define/private (adjust-box-input-width) - (when box-input - (let ([w (box 0)] - [x (box 0)] - [bw (send (icon:get-eof-bitmap) get-width)]) - (get-view-size w #f) - (let ([pos (- (last-position) 2)]) - (position-location pos x #f #t - (not (= pos (paragraph-start-position (position-paragraph pos)))))) - (let ([size (- (unbox w) (unbox x) bw 24)]) - (when (positive? size) - (send box-input set-min-width size)))))) - - (define/augment (on-display-size) + (define ports-mixin + (mixin (wide-snip<%>) (ports<%>) + (inherit begin-edit-sequence + change-style + delete + end-edit-sequence + find-snip + insert + get-canvas + get-start-position + get-end-position + get-snip-position + get-style-list + is-locked? + last-position + lock + paragraph-start-position + position-paragraph + release-snip + set-caret-owner + split-snip + get-focus-snip + get-view-size + scroll-to-position + position-location) + + ;; private field + (define eventspace (current-eventspace)) + + ;; insertion-point : number + ;; the place where the output ports insert data + ;; only updated in `eventspace' (above)'s main thread + (define insertion-point 0) + + ;; unread-start-points : number + ;; from this position to the end of the buffer is the + ;; users editing that has not been committed to the + ;; port. + ;; only updated in `eventspace' (above)'s main thread + (define unread-start-point 0) + + ;; box-input : (union #f (is-a?/c editor-snip%)) + ;; the snip where the user's input is typed for the box input port + (define box-input #f) + (define eof-button (new eof-snip% (port-text this))) + + ;; allow-edits? : boolean + ;; when this flag is set, only insert/delete after the + ;; insertion-point are allowed. + (define allow-edits? #f) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; + ;; public interface + ;; + + ;; insert-between : string/snp -> void + ;; inserts something between the insertion point and the unread region + (define/public-final (insert-between str/snp) + (insert str/snp unread-start-point unread-start-point) + (set! unread-start-point (+ unread-start-point + (amt-of-space str/snp)))) + + ;; insert-before : string/snp -> void + ;; inserts something before both the insertion point and the unread region + (define/public-final (insert-before str/snp) + (insert str/snp insertion-point insertion-point) + (let ([amt (amt-of-space str/snp)]) + (set! insertion-point (+ insertion-point amt)) + (set! unread-start-point (+ unread-start-point amt)))) + + (define/private (amt-of-space str/snp) + (cond + [(string? str/snp) (string-length str/snp)] + [(is-a? str/snp snip%) + (send str/snp get-count)])) + + (define/public-final (get-insertion-point) insertion-point) + (define/public-final (set-insertion-point ip) (set! insertion-point ip)) + (define/public-final (get-unread-start-point) + unread-start-point) + (define/public-final (set-unread-start-point u) + (unless (<= u (last-position)) + (error 'set-unread-start-point "~e is too large, last-position is ~e" + unread-start-point + (last-position))) + (set! unread-start-point u)) + + (define/public-final (set-allow-edits allow?) (set! allow-edits? allow?)) + (define/public-final (get-allow-edits) allow-edits?) + + (define/public-final (send-eof-to-in-port) + (channel-put read-chan (cons eof (position->line-col-pos unread-start-point)))) + (define/public-final (send-eof-to-box-in-port) + (channel-put box-read-chan (cons eof (position->line-col-pos unread-start-point)))) + (define/public-final (clear-input-port) (channel-put clear-input-chan (void))) + (define/public-final (clear-box-input-port) (channel-put box-clear-input-chan (void))) + (define/public-final (clear-output-ports) + (channel-put clear-output-chan (void)) + (init-output-ports)) + + ;; delete/io: number number -> void + (define/public-final (delete/io start end) + (unless (<= start end insertion-point) + (error 'delete/io "expected start (~a) <= end (~a) <= insertion-point (~a)" + start end insertion-point)) + + (let ([dist (- end start)]) + (set! insertion-point (- insertion-point dist)) + (set! unread-start-point (- unread-start-point dist))) + + (let ([before-allowed? allow-edits?]) + (set! allow-edits? #t) + (delete start end #f) + (set! allow-edits? before-allowed?))) + + (define/public-final (get-in-port) + (unless in-port (error 'get-in-port "not ready")) + in-port) + (define/public-final (get-in-box-port) + (unless in-port (error 'get-in-box-port "not ready")) + in-box-port) + (define/public-final (get-out-port) + (unless out-port (error 'get-out-port "not ready")) + out-port) + (define/public-final (get-err-port) + (unless err-port (error 'get-err-port "not ready")) + err-port) + (define/public-final (get-value-port) + (unless value-port (error 'get-value-port "not ready")) + value-port) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; + ;; specialization interface + ;; + + (define/pubment (submit-to-port? key) (inner #t submit-to-port? key)) + (define/pubment (on-submit) (inner (void) on-submit)) + (define/public (get-out-style-delta) out-style-name) + (define/public (get-err-style-delta) error-style-name) + (define/public (get-value-style-delta) value-style-name) + + (define/public (get-box-input-editor-snip%) editor-snip%) + (define/public (get-box-input-text%) input-box%) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; + ;; editor integration + ;; + + (define/augment (can-insert? start len) + (and (or allow-edits? + (start . >= . unread-start-point)) + (inner #t can-insert? start len))) + + (define/augment (can-delete? start len) + (and (or allow-edits? + (start . >= . unread-start-point)) + (inner #t can-delete? start len))) + + (define/override (on-local-char key) + (let ([start (get-start-position)] + [end (get-end-position)] + [code (send key get-key-code)]) + (cond + [(not (or (eq? code 'numpad-enter) + (equal? code #\return) + (equal? code #\newline))) + (super on-local-char key)] + [(and (insertion-point . <= . start) + (= start end) + (submit-to-port? key)) + (insert "\n") + (for-each/snips-chars + unread-start-point + (last-position) + (λ (s/c line-col-pos) + (cond + [(is-a? s/c snip%) + (channel-put read-chan (cons s/c line-col-pos))] + [(char? s/c) + (for-each (λ (b) (channel-put read-chan (cons b line-col-pos))) + (bytes->list (string->bytes/utf-8 (string s/c))))]))) + (set! unread-start-point (last-position)) + (set! insertion-point (last-position)) + (on-submit)] + [else + (super on-local-char key)]))) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; + ;; box input port management + ;; + + (define/public-final (reset-input-box) + (when box-input + (let ([l? (is-locked?)] + [old-allow-edits? allow-edits?]) + (lock #f) + (set! allow-edits? #t) + (send box-input release-from-owner) + (send eof-button release-from-owner) + (set! unread-start-point (- unread-start-point 2)) + (set! allow-edits? old-allow-edits?) + (lock l?)) + (set! box-input #f))) + + (define/private (adjust-box-input-width) + (when box-input + (let ([w (box 0)] + [x (box 0)] + [bw (send (icon:get-eof-bitmap) get-width)]) + (get-view-size w #f) + (let ([pos (- (last-position) 2)]) + (position-location pos x #f #t + (not (= pos (paragraph-start-position (position-paragraph pos)))))) + (let ([size (- (unbox w) (unbox x) bw 24)]) + (when (positive? size) + (send box-input set-min-width size)))))) + + (define/augment (on-display-size) + (adjust-box-input-width) + (inner (void) on-display-size)) + + (define/private (on-box-peek) + (unless box-input + (let* ([ed (new (get-box-input-text%))] + [es (new (get-box-input-editor-snip%) + (editor ed))] + [locked? (is-locked?)]) + (begin-edit-sequence) + (send ed set-port-text this) + (lock #f) + #;(unless (= unread-start-point (paragraph-start-position (position-paragraph unread-start-point))) + (insert-between "\n")) + (insert-between es) + (insert-between eof-button) + #;(send (get-canvas) add-wide-snip es) + (set! box-input es) (adjust-box-input-width) - (inner (void) on-display-size)) - - (define/private (on-box-peek) - (unless box-input - (let* ([ed (new (get-box-input-text%))] - [es (new (get-box-input-editor-snip%) - (editor ed))] - [locked? (is-locked?)]) - (begin-edit-sequence) - (send ed set-port-text this) - (lock #f) - #;(unless (= unread-start-point (paragraph-start-position (position-paragraph unread-start-point))) - (insert-between "\n")) - (insert-between es) - (insert-between eof-button) - #;(send (get-canvas) add-wide-snip es) - (set! box-input es) - (adjust-box-input-width) - (set-caret-owner es 'display) - (lock locked?) - (end-edit-sequence)))) - - (define/public (new-box-input ed) - (when (eq? ed (send box-input get-editor)) ;; just in case things get out of sync. - (let ([locked? (is-locked?)]) - (begin-edit-sequence) - (send box-input set-min-width 'none) - (lock #f) - - (let ([old-insertion-point insertion-point]) - (let loop ([snip (send (send box-input get-editor) find-first-snip)]) - (when snip - (let ([next (send snip next)]) - (send snip release-from-owner) - (do-insertion - (list (cons (cond - [(is-a? snip string-snip%) - (send snip get-text 0 (send snip get-count))] - [else snip]) - (make-object style-delta%))) - #t) - (loop next)))) - - ;; this is copied code ... - (for-each/snips-chars - old-insertion-point - insertion-point - (λ (s/c line-col-pos) - (cond - [(is-a? s/c snip%) - (channel-put box-read-chan (cons s/c line-col-pos))] - [(char? s/c) - (for-each (λ (b) (channel-put box-read-chan (cons b line-col-pos))) - (bytes->list (string->bytes/utf-8 (string s/c))))])))) - - (lock locked?) - (adjust-box-input-width) - (end-edit-sequence)))) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; - ;; output port syncronization code - ;; - - ;; flush-chan : (channel (evt void)) - ;; signals that the buffer-thread should flush pending output - ;; the evt inside is waited on to indicate the flush has occurred - (define flush-chan (make-channel)) - - ;; clear-output-chan : (channel void) - (define clear-output-chan (make-channel)) - - ;; write-chan : (channel (cons (union snip bytes) style)) - ;; send output to the editor - (define write-chan (make-channel)) - - ;; readers-chan : (channel (list (channel (union byte snip)) - ;; (channel ...))) - (define readers-chan (make-channel)) - - ;; queue-insertion : (listof (cons (union string snip) style)) evt -> void - ;; txt is in the reverse order of the things to be inserted. - ;; the evt is waited on when the text has actually been inserted - ;; thread: any thread, except the eventspace main thread - (define/private (queue-insertion txts signal) - (parameterize ([current-eventspace eventspace]) - (queue-callback - (λ () - (do-insertion txts #f) - (sync signal))))) - - ;; do-insertion : (listof (cons (union string snip) style-delta)) boolean -> void - ;; thread: eventspace main thread - (define/private (do-insertion txts showing-input?) - (let ([locked? (is-locked?)]) - (begin-edit-sequence) - (lock #f) - (set! allow-edits? #t) - (let loop ([txts txts]) - (cond - [(null? txts) (void)] - [else - (let* ([fst (car txts)] - [str/snp (car fst)] - [style (cdr fst)]) - - (let ([inserted-count - (if (is-a? str/snp snip%) - (send str/snp get-count) - (string-length str/snp))] - [old-insertion-point insertion-point]) - (set! insertion-point (+ insertion-point inserted-count)) - (set! unread-start-point (+ unread-start-point inserted-count)) - - (insert (if (is-a? str/snp snip%) - (send str/snp copy) - str/snp) - old-insertion-point - old-insertion-point - #t) - - ;; the idea here is that if you made a string snip, you - ;; could have made a string and gotten the style, so you - ;; must intend to have your own style. - (unless (is-a? str/snp string-snip%) - (change-style style old-insertion-point insertion-point)))) - (loop (cdr txts))])) - (set! allow-edits? #f) - (lock locked?) - (unless showing-input? - (when box-input - (adjust-box-input-width) - (when (eq? box-input (get-focus-snip)) - (scroll-to-position (last-position))))) - (end-edit-sequence) - (unless (null? txts) - (after-io-insertion)))) - - (define/public (after-io-insertion) (void)) - - (define output-buffer-thread - (let ([converter (bytes-open-converter "UTF-8-permissive" "UTF-8")]) - (thread - (λ () - (let loop (;; text-to-insert : (queue (cons (union snip bytes) style)) - [text-to-insert (empty-queue)] - [last-flush (current-inexact-milliseconds)]) + (set-caret-owner es 'display) + (lock locked?) + (end-edit-sequence)))) + + (define/public (new-box-input ed) + (when (eq? ed (send box-input get-editor)) ;; just in case things get out of sync. + (let ([locked? (is-locked?)]) + (begin-edit-sequence) + (send box-input set-min-width 'none) + (lock #f) + + (let ([old-insertion-point insertion-point]) + (let loop ([snip (send (send box-input get-editor) find-first-snip)]) + (when snip + (let ([next (send snip next)]) + (send snip release-from-owner) + (do-insertion + (list (cons (cond + [(is-a? snip string-snip%) + (send snip get-text 0 (send snip get-count))] + [else snip]) + (make-object style-delta%))) + #t) + (loop next)))) + + ;; this is copied code ... + (for-each/snips-chars + old-insertion-point + insertion-point + (λ (s/c line-col-pos) + (cond + [(is-a? s/c snip%) + (channel-put box-read-chan (cons s/c line-col-pos))] + [(char? s/c) + (for-each (λ (b) (channel-put box-read-chan (cons b line-col-pos))) + (bytes->list (string->bytes/utf-8 (string s/c))))])))) + + (lock locked?) + (adjust-box-input-width) + (end-edit-sequence)))) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; + ;; output port syncronization code + ;; + + ;; flush-chan : (channel (evt void)) + ;; signals that the buffer-thread should flush pending output + ;; the evt inside is waited on to indicate the flush has occurred + (define flush-chan (make-channel)) + + ;; clear-output-chan : (channel void) + (define clear-output-chan (make-channel)) + + ;; write-chan : (channel (cons (union snip bytes) style)) + ;; send output to the editor + (define write-chan (make-channel)) + + ;; readers-chan : (channel (list (channel (union byte snip)) + ;; (channel ...))) + (define readers-chan (make-channel)) + + ;; queue-insertion : (listof (cons (union string snip) style)) evt -> void + ;; txt is in the reverse order of the things to be inserted. + ;; the evt is waited on when the text has actually been inserted + ;; thread: any thread, except the eventspace main thread + (define/private (queue-insertion txts signal) + (parameterize ([current-eventspace eventspace]) + (queue-callback + (λ () + (do-insertion txts #f) + (sync signal))))) + + ;; do-insertion : (listof (cons (union string snip) style-delta)) boolean -> void + ;; thread: eventspace main thread + (define/private (do-insertion txts showing-input?) + (let ([locked? (is-locked?)]) + (begin-edit-sequence) + (lock #f) + (set! allow-edits? #t) + (let loop ([txts txts]) + (cond + [(null? txts) (void)] + [else + (let* ([fst (car txts)] + [str/snp (car fst)] + [style (cdr fst)]) + + (let ([inserted-count + (if (is-a? str/snp snip%) + (send str/snp get-count) + (string-length str/snp))] + [old-insertion-point insertion-point]) + (set! insertion-point (+ insertion-point inserted-count)) + (set! unread-start-point (+ unread-start-point inserted-count)) - (sync - (if (queue-empty? text-to-insert) - never-evt - (handle-evt - (alarm-evt (+ last-flush msec-timeout)) - (λ (_) - (let-values ([(viable-bytes remaining-queue) (split-queue converter text-to-insert)]) - (queue-insertion viable-bytes always-evt) - (loop remaining-queue (current-inexact-milliseconds)))))) - (handle-evt - flush-chan - (λ (return-evt) - (let-values ([(viable-bytes remaining-queue) (split-queue converter text-to-insert)]) - (queue-insertion viable-bytes return-evt) - (loop remaining-queue (current-inexact-milliseconds))))) - (handle-evt - clear-output-chan - (λ (_) - (loop (empty-queue) (current-inexact-milliseconds)))) - (handle-evt - write-chan - (λ (pr) - (let ([new-text-to-insert (enqueue pr text-to-insert)]) - (cond - [((queue-size text-to-insert) . < . output-buffer-full) - (loop new-text-to-insert last-flush)] - [else - (let ([chan (make-channel)]) - (let-values ([(viable-bytes remaining-queue) - (split-queue converter new-text-to-insert)]) - (queue-insertion viable-bytes (channel-put-evt chan (void))) - (channel-get chan) - (loop remaining-queue (current-inexact-milliseconds))))])))))))))) - - (field [in-port-args #f] - [out-port #f] - [err-port #f] - [value-port #f]) - - (define/private (init-output-ports) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; - ;; the following must be able to run - ;; in any thread (even concurrently) - ;; - (define (make-write-bytes-proc style) - (λ (to-write start end block/buffer? enable-breaks?) - (cond - [(= start end) (flush-proc)] - [(eq? (current-thread) (eventspace-handler-thread eventspace)) - (error 'write-bytes-proc "cannot write to port on eventspace main thread")] - [else - (channel-put write-chan (cons (subbytes to-write start end) style))]) - (- end start))) - - (define (flush-proc) - (cond - [(eq? (current-thread) (eventspace-handler-thread eventspace)) - (error 'flush-proc "cannot flush port on eventspace main thread")] - [else - (sync - (nack-guard-evt - (λ (fail-channel) - (let* ([return-channel (make-channel)] - [return-evt - (choice-evt - fail-channel - (channel-put-evt return-channel (void)))]) - (channel-put flush-chan return-evt) - return-channel))))])) - - (define (out-close-proc) - (void)) - - (define (make-write-special-proc style) - (λ (special can-buffer? enable-breaks?) - (cond - [(eq? (current-thread) (eventspace-handler-thread eventspace)) - (error 'write-bytes-proc "cannot write to port on eventspace main thread")] - [else - (let ([str/snp (cond - [(string? special) special] - [(is-a? special snip%) special] - [else (format "~s" special)])]) - (channel-put - write-chan - (cons str/snp style)))]) - #t)) - - (let* ([add-standard - (λ (sd) - (cond - [(string? sd) - (let ([style-list (get-style-list)]) - (or (send style-list find-named-style sd) - (send style-list find-named-style "Standard") - (send style-list find-named-style "Basic")))] - [sd - (let* ([style-list (get-style-list)] - [std (send style-list find-named-style "Standard")]) - (if std - (send style-list find-or-create-style std sd) - (let ([basic (send style-list find-named-style "Basic")]) - (send style-list find-or-create-style basic sd))))]))] - [out-style (add-standard (get-out-style-delta))] - [err-style (add-standard (get-err-style-delta))] - [value-style (add-standard (get-value-style-delta))]) - (set! out-port (make-output-port #f - always-evt - (make-write-bytes-proc out-style) - out-close-proc - (make-write-special-proc out-style))) - (set! err-port (make-output-port #f - always-evt - (make-write-bytes-proc err-style) - out-close-proc - (make-write-special-proc err-style))) - (set! value-port (make-output-port #f - always-evt - (make-write-bytes-proc value-style) - out-close-proc - (make-write-special-proc value-style))) - (let ([install-handlers - (λ (port) - ;; don't want to set the port-print-handler here; - ;; instead drscheme sets the global-port-print-handler - ;; to catch fractions and the like - (set-interactive-write-handler port) - (set-interactive-display-handler port))]) - (install-handlers out-port) - (install-handlers err-port) - (install-handlers value-port)))) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; - ;; helpers - ;; - - ;; type line-col-pos = (list (union #f fixnum) (union #f fixnum) (union #f fixnum))) - - ;; position->line-col-pos : number -> (list number number number) - (define/private (position->line-col-pos pos) - (let* ([para (position-paragraph pos)] - [para-start (paragraph-start-position para)]) - (list (+ para 1) - (- pos para-start) - (+ pos 1)))) - - ;; for-each/snips-chars : number number ((union char snip) line-col-pos -> void) -> void - (define/private (for-each/snips-chars start end func) - (split-snip start) - (split-snip end) - (let loop ([snip (find-snip start 'after-or-none)]) - (cond - [(not snip) (void)] - [(< (get-snip-position snip) end) - (let ([line-col-pos (position->line-col-pos (get-snip-position snip))]) - (cond - [(is-a? snip string-snip%) - (let ([str (send snip get-text 0 (send snip get-count))]) - (let loop ([i 0]) - (when (< i (string-length str)) - (func (string-ref str i) - (list (car line-col-pos) - (+ i (cadr line-col-pos)) - (+ i (caddr line-col-pos)))) - (loop (+ i 1))))) - (loop (send snip next))] - [else - (func (send snip copy) line-col-pos) - (loop (send snip next))]))] - [else (void)]))) - - - ;; split-queue : converter (queue (cons (union snip bytes) style) - ;; -> (values (listof (queue (cons (union snip bytes) style)) queue) - ;; this function must only be called on the output-buffer-thread - ;; extracts the viable bytes (and other stuff) from the front of the queue - ;; and returns them as strings (and other stuff). - (define/private (split-queue converter q) - (let ([lst (queue->list q)]) - (let loop ([lst lst] - [acc null]) - (if (null? lst) - (values (reverse acc) - (empty-queue)) - (let-values ([(front rest) (peel lst)]) - (cond - [(not front) (values (reverse acc) - (empty-queue))] - [(bytes? (car front)) - (let ([the-bytes (car front)] - [key (cdr front)]) - (if (null? rest) - (let-values ([(converted-bytes src-read-k termination) - (bytes-convert converter the-bytes)]) - (if (eq? termination 'aborts) - (values (reverse (cons (cons (bytes->string/utf-8 converted-bytes) key) acc)) - (enqueue - (cons (subbytes the-bytes - (- (bytes-length the-bytes) src-read-k) - (bytes-length the-bytes)) - key) - (empty-queue))) - (values (reverse (cons (cons (bytes->string/utf-8 converted-bytes) key) acc)) - (empty-queue)))) - (let-values ([(converted-bytes src-read-k termination) - (bytes-convert converter the-bytes)] - [(more-bytes more-termination) (bytes-convert-end converter)]) - (loop rest - (cons (cons (bytes->string/utf-8 (bytes-append converted-bytes more-bytes)) - key) - acc)))))] - [else (loop rest - (cons front acc))])))))) - - ;; peel : (cons (cons (union snip bytes) X) (listof (cons (union snip bytes) X)) - ;; -> (values (cons (union snip bytes) X) (listof (cons (union snip bytes) X) - ;; finds the first segment of bytes with the same style and combines them, - ;; otherwise a lot like (define (peel x) (values (car x) (cdr x))) - (define/private (peel lst) - (let loop ([lst lst] - [acc #f] - [key #f]) - (cond - [(null? lst) (values (cons acc key) null)] - [else - (let* ([fst (car lst)] - [fst-key (cdr fst)] - [fst-val (car fst)]) - (cond - [(and (not key) (bytes? fst-val)) - (loop (cdr lst) - fst-val - fst-key)] - [(and key (bytes? fst-val) (eq? key fst-key)) - (loop (cdr lst) - (bytes-append acc fst-val) - key)] - [(not key) - (values fst (cdr lst))] - [else (if acc - (values (cons acc key) lst) - (values fst (cdr lst)))]))]))) - - (super-new) - (init-output-ports) - (define-values (in-port read-chan clear-input-chan) - (start-text-input-port this #f)) - (define-values (in-box-port box-read-chan box-clear-input-chan) - (start-text-input-port this (lambda () (on-box-peek)))))) - - (define input-box<%> - (interface ((class->interface text%)) - )) + (insert (if (is-a? str/snp snip%) + (send str/snp copy) + str/snp) + old-insertion-point + old-insertion-point + #t) + + ;; the idea here is that if you made a string snip, you + ;; could have made a string and gotten the style, so you + ;; must intend to have your own style. + (unless (is-a? str/snp string-snip%) + (change-style style old-insertion-point insertion-point)))) + (loop (cdr txts))])) + (set! allow-edits? #f) + (lock locked?) + (unless showing-input? + (when box-input + (adjust-box-input-width) + (when (eq? box-input (get-focus-snip)) + (scroll-to-position (last-position))))) + (end-edit-sequence) + (unless (null? txts) + (after-io-insertion)))) - (define input-box-mixin - (mixin ((class->interface text%)) (input-box<%>) - (inherit erase lock) - - (define port-text #f) - (define/public (set-port-text pt) (set! port-text pt)) - - (define in-use? #t) - (define/public (box-input-not-used-anymore) - (lock #t) - (set! in-use? #f)) - - (define/override (on-default-char kevt) - (super on-default-char kevt) - (when in-use? - (case (send kevt get-key-code) - [(numpad-enter #\return) - (send port-text new-box-input this)] - [else (void)]))) - - (super-new))) + (define/public (after-io-insertion) (void)) - (define (start-text-input-port source on-peek) - - ;; eventspace at the time this function was called. used for peek callbacks - (define eventspace (current-eventspace)) - - ;; read-chan : (channel (cons (union byte snip eof) line-col-pos)) - ;; send input from the editor - (define read-chan (make-channel)) - - ;; clear-input-chan : (channel void) - (define clear-input-chan (make-channel)) - - ;; progress-event-chan : (channel (cons (channel event) nack-evt))) - (define progress-event-chan (make-channel)) - - ;; peek-chan : (channel peeker) - (define peek-chan (make-channel)) - - ;; commit-chan : (channel committer) - (define commit-chan (make-channel)) - - ;; position-chan : (channel (cons (channel void) (channel line-col-pos))) - (define position-chan (make-channel)) - - (define input-buffer-thread + (define output-buffer-thread + (let ([converter (bytes-open-converter "UTF-8-permissive" "UTF-8")]) (thread (λ () - - ;; these vars are like arguments to the loop function - ;; they are only set right before loop is called. - ;; This is done to avoid passing the same arguments - ;; over and over to loop. - (define peeker-sema (make-semaphore 0)) - (define peeker-evt (semaphore-peek-evt peeker-sema)) - (define bytes-peeked 0) - (define response-evts '()) - (define peekers '()) ;; waiting for a peek - (define committers '()) ;; waiting for a commit - (define positioners '()) ;; waiting for a position - (define data (empty-queue)) ;; (queue (cons (union byte snip eof) line-col-pos)) - (define position #f) - - ;; loop : -> alpha - ;; the main loop for this thread - (define (loop) - (let-values ([(not-ready-peekers new-peek-response-evts) - (separate peekers service-waiter)] - [(potential-commits new-commit-response-evts) - (separate - committers - (service-committer data peeker-evt))]) - (when (and on-peek - (not (null? not-ready-peekers))) - (parameterize ([current-eventspace eventspace]) - (queue-callback on-peek))) - (set! peekers not-ready-peekers) - (set! committers potential-commits) - (set! response-evts - (append response-evts - new-peek-response-evts - new-commit-response-evts)) - (sync - (handle-evt - position-chan - (λ (pr) - (let ([nack-chan (car pr)] - [resp-chan (cdr pr)]) - (set! positioners (cons pr positioners)) - (loop)))) - (apply choice-evt (map service-positioner positioners)) - (handle-evt - read-chan - (λ (ent) - (set! data (enqueue ent data)) - (unless position - (set! position (cdr ent))) - (loop))) - (handle-evt - clear-input-chan - (λ (_) - (semaphore-post peeker-sema) - (set! peeker-sema (make-semaphore 0)) - (set! peeker-evt (semaphore-peek-evt peeker-sema)) - (set! data (empty-queue)) - (set! position #f) - (loop))) - (handle-evt - progress-event-chan - (λ (return-pr) - (let ([return-chan (car return-pr)] - [return-nack (cdr return-pr)]) - (set! response-evts - (cons (choice-evt - return-nack - (channel-put-evt return-chan peeker-evt)) - response-evts)) - (loop)))) - (handle-evt - peek-chan - (λ (peeker) - (set! peekers (cons peeker peekers)) - (loop))) - (handle-evt - commit-chan - (λ (committer) - (set! committers (cons committer committers)) - (loop))) - (apply - choice-evt - (map - (λ (a-committer) - (match a-committer - [($ committer - kr - commit-peeker-evt - done-evt - resp-chan - resp-nack) - (choice-evt - (handle-evt - commit-peeker-evt - (λ (_) - ;; this committer will be thrown out in next iteration - (loop))) - (handle-evt - done-evt - (λ (v) - (let ([nth-pos (cdr (peek-n data (- kr 1)))]) - (set! position - (list (car nth-pos) - (+ 1 (cadr nth-pos)) - (+ 1 (caddr nth-pos))))) - (set! data (dequeue-n data kr)) - (semaphore-post peeker-sema) - (set! peeker-sema (make-semaphore 0)) - (set! peeker-evt (semaphore-peek-evt peeker-sema)) - (set! committers (remq a-committer committers)) - (set! response-evts - (cons - (choice-evt - resp-nack - (channel-put-evt resp-chan #t)) - response-evts)) - (loop))))])) - committers)) - (apply choice-evt - (map (λ (resp-evt) - (handle-evt - resp-evt - (λ (_) - (set! response-evts (remq resp-evt response-evts)) - (loop)))) - response-evts))))) - - ;; service-positioner : (cons (channel void) (channel line-col-pos)) -> evt - (define (service-positioner pr) - (let ([nack-evt (car pr)] - [resp-evt (cdr pr)]) - (handle-evt - (choice-evt nack-evt - (channel-put-evt resp-evt (or position - - ;; a bogus position for when - ;; nothing has happened yet. - (list 1 0 1)))) - (let ([sent-position position]) - (λ (_) - (set! positioners (remq pr positioners)) - (loop)))))) - - ;; service-committer : queue evt -> committer -> (union #f evt) - ;; if the committer can be dumped, return an evt that - ;; does the dumping. otherwise, return #f - (define ((service-committer data peeker-evt) a-committer) - (match a-committer - [($ committer - kr commit-peeker-evt - done-evt resp-chan resp-nack) - (let ([size (queue-size data)]) - (cond - [(not (eq? peeker-evt commit-peeker-evt)) - (choice-evt - resp-nack - (channel-put-evt resp-chan #f))] - [(< size kr) - (choice-evt - resp-nack - (channel-put-evt resp-chan 'commit-failure))] - [else ;; commit succeeds - #f]))])) - - ;; service-waiter : peeker -> (union #f evt) - ;; if the peeker can be serviced, build an event to service it - ;; otherwise return #f - (define (service-waiter a-peeker) - (match a-peeker - [($ peeker bytes skip-count pe resp-chan nack-evt polling?) - (cond - [(and pe (not (eq? pe peeker-evt))) - (choice-evt (channel-put-evt resp-chan #f) - nack-evt)] - [((queue-size data) . > . skip-count) - (let ([nth (car (peek-n data skip-count))]) - (choice-evt - nack-evt - (cond - [(byte? nth) - (bytes-set! bytes 0 nth) - (channel-put-evt resp-chan 1)] - [(eof-object? nth) - (channel-put-evt resp-chan nth)] - [else - (channel-put-evt - resp-chan - (λ (src line col pos) - (if (is-a? nth readable-snip<%>) - (send nth read-special src line col pos) - nth)))])))] - [polling? - (choice-evt - nack-evt - (channel-put-evt resp-chan 0))] - [else - #f])])) - - ;; separate (listof X) (X -> (union #f Y)) -> (values (listof X) (listof Y)) - ;; separates `eles' into two lists -- those that `f' returns #f for - ;; and then the results of calling `f' for those where `f' doesn't return #f - (define (separate eles f) - (let loop ([eles eles] - [transformed '()] - [left-alone '()]) - (cond - [(null? eles) (values left-alone transformed)] - [else (let* ([ele (car eles)] - [maybe (f ele)]) - (if maybe - (loop (cdr eles) - (cons maybe transformed) - left-alone) - (loop (cdr eles) - transformed - (cons ele left-alone))))]))) - - ;;; start things going - (loop)))) + (let loop (;; text-to-insert : (queue (cons (union snip bytes) style)) + [text-to-insert (empty-queue)] + [last-flush (current-inexact-milliseconds)]) + + (sync + (if (queue-empty? text-to-insert) + never-evt + (handle-evt + (alarm-evt (+ last-flush msec-timeout)) + (λ (_) + (let-values ([(viable-bytes remaining-queue) (split-queue converter text-to-insert)]) + (queue-insertion viable-bytes always-evt) + (loop remaining-queue (current-inexact-milliseconds)))))) + (handle-evt + flush-chan + (λ (return-evt) + (let-values ([(viable-bytes remaining-queue) (split-queue converter text-to-insert)]) + (queue-insertion viable-bytes return-evt) + (loop remaining-queue (current-inexact-milliseconds))))) + (handle-evt + clear-output-chan + (λ (_) + (loop (empty-queue) (current-inexact-milliseconds)))) + (handle-evt + write-chan + (λ (pr) + (let ([new-text-to-insert (enqueue pr text-to-insert)]) + (cond + [((queue-size text-to-insert) . < . output-buffer-full) + (loop new-text-to-insert last-flush)] + [else + (let ([chan (make-channel)]) + (let-values ([(viable-bytes remaining-queue) + (split-queue converter new-text-to-insert)]) + (queue-insertion viable-bytes (channel-put-evt chan (void))) + (channel-get chan) + (loop remaining-queue (current-inexact-milliseconds))))])))))))))) + + (field [in-port-args #f] + [out-port #f] + [err-port #f] + [value-port #f]) + + (define/private (init-output-ports) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; the following must be able to run ;; in any thread (even concurrently) ;; - (define (read-bytes-proc bstr) - (let* ([progress-evt (progress-evt-proc)] - [v (peek-proc bstr 0 progress-evt)]) + (define (make-write-bytes-proc style) + (λ (to-write start end block/buffer? enable-breaks?) (cond - [(sync/timeout 0 progress-evt) - 0] - [else - (wrap-evt - v - (λ (v) - (if (and (number? v) (zero? v)) - 0 - (if (commit-proc (if (number? v) v 1) - progress-evt - always-evt) - v - 0))))]))) + [(= start end) (flush-proc)] + [(eq? (current-thread) (eventspace-handler-thread eventspace)) + (error 'write-bytes-proc "cannot write to port on eventspace main thread")] + [else + (channel-put write-chan (cons (subbytes to-write start end) style))]) + (- end start))) - (define (peek-proc bstr skip-count progress-evt) - (poll-guard-evt - (lambda (polling?) - (let ([evt - (nack-guard-evt - (λ (nack) - (let ([chan (make-channel)]) - (channel-put peek-chan (make-peeker bstr skip-count progress-evt chan nack polling?)) - chan)))]) - (if polling? - (let ([v (sync evt)]) - (if (eq? v 0) - ;; Don't return 0, because that means something is - ;; probably ready. We want to indicate that nothing is - ;; ready. - never-evt - ;; Even on success, package it as an event, because - ;; `read-bytes-proc' expects an event - (wrap-evt always-evt (lambda (_) v)))) - evt))))) - - (define (progress-evt-proc) - (sync - (nack-guard-evt - (λ (nack) - (let ([chan (make-channel)]) - (channel-put progress-event-chan (cons chan nack)) - chan))))) - - (define (commit-proc kr progress-evt done-evt) - (sync - (nack-guard-evt - (λ (nack) - (let ([chan (make-channel)]) - (channel-put commit-chan (make-committer kr progress-evt done-evt chan nack)) - chan))))) - - (define (close-proc) (void)) - - (define (position-proc) - (let ([chan (make-channel)]) - (apply - values + (define (flush-proc) + (cond + [(eq? (current-thread) (eventspace-handler-thread eventspace)) + (error 'flush-proc "cannot flush port on eventspace main thread")] + [else (sync (nack-guard-evt - (λ (fail) - (channel-put position-chan (cons fail chan)) - chan)))))) - (let ([p (make-input-port source - read-bytes-proc - peek-proc - close-proc - progress-evt-proc - commit-proc - position-proc)]) - (port-count-lines! p) - (values p read-chan clear-input-chan))) + (λ (fail-channel) + (let* ([return-channel (make-channel)] + [return-evt + (choice-evt + fail-channel + (channel-put-evt return-channel (void)))]) + (channel-put flush-chan return-evt) + return-channel))))])) + + (define (out-close-proc) + (void)) + + (define (make-write-special-proc style) + (λ (special can-buffer? enable-breaks?) + (cond + [(eq? (current-thread) (eventspace-handler-thread eventspace)) + (error 'write-bytes-proc "cannot write to port on eventspace main thread")] + [else + (let ([str/snp (cond + [(string? special) special] + [(is-a? special snip%) special] + [else (format "~s" special)])]) + (channel-put + write-chan + (cons str/snp style)))]) + #t)) + + (let* ([add-standard + (λ (sd) + (cond + [(string? sd) + (let ([style-list (get-style-list)]) + (or (send style-list find-named-style sd) + (send style-list find-named-style "Standard") + (send style-list find-named-style "Basic")))] + [sd + (let* ([style-list (get-style-list)] + [std (send style-list find-named-style "Standard")]) + (if std + (send style-list find-or-create-style std sd) + (let ([basic (send style-list find-named-style "Basic")]) + (send style-list find-or-create-style basic sd))))]))] + [out-style (add-standard (get-out-style-delta))] + [err-style (add-standard (get-err-style-delta))] + [value-style (add-standard (get-value-style-delta))]) + (set! out-port (make-output-port #f + always-evt + (make-write-bytes-proc out-style) + out-close-proc + (make-write-special-proc out-style))) + (set! err-port (make-output-port #f + always-evt + (make-write-bytes-proc err-style) + out-close-proc + (make-write-special-proc err-style))) + (set! value-port (make-output-port #f + always-evt + (make-write-bytes-proc value-style) + out-close-proc + (make-write-special-proc value-style))) + (let ([install-handlers + (λ (port) + ;; don't want to set the port-print-handler here; + ;; instead drscheme sets the global-port-print-handler + ;; to catch fractions and the like + (set-interactive-write-handler port) + (set-interactive-display-handler port))]) + (install-handlers out-port) + (install-handlers err-port) + (install-handlers value-port)))) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; - ;; queues + ;; helpers ;; - (define-struct queue (front back count)) - (define (empty-queue) (make-queue '() '() 0)) - (define (enqueue e q) (make-queue - (cons e (queue-front q)) - (queue-back q) - (+ (queue-count q) 1))) - (define (queue-first q) - (flip-around q) - (let ([back (queue-back q)]) - (if (null? back) - (error 'queue-first "empty queue") - (car back)))) - (define (queue-rest q) - (flip-around q) - (let ([back (queue-back q)]) - (if (null? back) - (error 'queue-rest "empty queue") - (make-queue (queue-front q) - (cdr back) - (- (queue-count q) 1))))) - (define (flip-around q) - (when (null? (queue-back q)) - (set-queue-back! q (reverse (queue-front q))) - (set-queue-front! q '()))) - (define (queue-empty? q) (zero? (queue-count q))) - (define (queue-size q) (queue-count q)) + ;; type line-col-pos = (list (union #f fixnum) (union #f fixnum) (union #f fixnum))) - ;; queue->list : (queue x) -> (listof x) - ;; returns the elements in the order that successive deq's would have - (define (queue->list q) - (let ([ans (append (queue-back q) (reverse (queue-front q)))]) - (set-queue-back! q ans) - (set-queue-front! q '()) - ans)) + ;; position->line-col-pos : number -> (list number number number) + (define/private (position->line-col-pos pos) + (let* ([para (position-paragraph pos)] + [para-start (paragraph-start-position para)]) + (list (+ para 1) + (- pos para-start) + (+ pos 1)))) - ;; dequeue-n : queue number -> queue - (define (dequeue-n queue n) - (let loop ([q queue] - [n n]) + ;; for-each/snips-chars : number number ((union char snip) line-col-pos -> void) -> void + (define/private (for-each/snips-chars start end func) + (split-snip start) + (split-snip end) + (let loop ([snip (find-snip start 'after-or-none)]) (cond - [(zero? n) q] - [(queue-empty? q) (error 'dequeue-n "not enough!")] - [else (loop (queue-rest q) (- n 1))]))) + [(not snip) (void)] + [(< (get-snip-position snip) end) + (let ([line-col-pos (position->line-col-pos (get-snip-position snip))]) + (cond + [(is-a? snip string-snip%) + (let ([str (send snip get-text 0 (send snip get-count))]) + (let loop ([i 0]) + (when (< i (string-length str)) + (func (string-ref str i) + (list (car line-col-pos) + (+ i (cadr line-col-pos)) + (+ i (caddr line-col-pos)))) + (loop (+ i 1))))) + (loop (send snip next))] + [else + (func (send snip copy) line-col-pos) + (loop (send snip next))]))] + [else (void)]))) - ;; peek-n : queue number -> queue - (define (peek-n queue init-n) - (let loop ([q queue] - [n init-n]) + + ;; split-queue : converter (queue (cons (union snip bytes) style) + ;; -> (values (listof (queue (cons (union snip bytes) style)) queue) + ;; this function must only be called on the output-buffer-thread + ;; extracts the viable bytes (and other stuff) from the front of the queue + ;; and returns them as strings (and other stuff). + (define/private (split-queue converter q) + (let ([lst (queue->list q)]) + (let loop ([lst lst] + [acc null]) + (if (null? lst) + (values (reverse acc) + (empty-queue)) + (let-values ([(front rest) (peel lst)]) + (cond + [(not front) (values (reverse acc) + (empty-queue))] + [(bytes? (car front)) + (let ([the-bytes (car front)] + [key (cdr front)]) + (if (null? rest) + (let-values ([(converted-bytes src-read-k termination) + (bytes-convert converter the-bytes)]) + (if (eq? termination 'aborts) + (values (reverse (cons (cons (bytes->string/utf-8 converted-bytes) key) acc)) + (enqueue + (cons (subbytes the-bytes + (- (bytes-length the-bytes) src-read-k) + (bytes-length the-bytes)) + key) + (empty-queue))) + (values (reverse (cons (cons (bytes->string/utf-8 converted-bytes) key) acc)) + (empty-queue)))) + (let-values ([(converted-bytes src-read-k termination) + (bytes-convert converter the-bytes)] + [(more-bytes more-termination) (bytes-convert-end converter)]) + (loop rest + (cons (cons (bytes->string/utf-8 (bytes-append converted-bytes more-bytes)) + key) + acc)))))] + [else (loop rest + (cons front acc))])))))) + + ;; peel : (cons (cons (union snip bytes) X) (listof (cons (union snip bytes) X)) + ;; -> (values (cons (union snip bytes) X) (listof (cons (union snip bytes) X) + ;; finds the first segment of bytes with the same style and combines them, + ;; otherwise a lot like (define (peel x) (values (car x) (cdr x))) + (define/private (peel lst) + (let loop ([lst lst] + [acc #f] + [key #f]) (cond - [(zero? n) - (when (queue-empty? q) - (error 'peek-n "not enough; asked for ~a but only ~a available" - init-n - (queue-size queue))) - (queue-first q)] + [(null? lst) (values (cons acc key) null)] [else - (when (queue-empty? q) - (error 'dequeue-n "not enough!")) - (loop (queue-rest q) (- n 1))]))) + (let* ([fst (car lst)] + [fst-key (cdr fst)] + [fst-val (car fst)]) + (cond + [(and (not key) (bytes? fst-val)) + (loop (cdr lst) + fst-val + fst-key)] + [(and key (bytes? fst-val) (eq? key fst-key)) + (loop (cdr lst) + (bytes-append acc fst-val) + key)] + [(not key) + (values fst (cdr lst))] + [else (if acc + (values (cons acc key) lst) + (values fst (cdr lst)))]))]))) - ;; - ;; end queue abstraction - ;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (super-new) + (init-output-ports) + (define-values (in-port read-chan clear-input-chan) + (start-text-input-port this #f)) + (define-values (in-box-port box-read-chan box-clear-input-chan) + (start-text-input-port this (lambda () (on-box-peek)))))) + + (define input-box<%> + (interface ((class->interface text%)) + )) + + (define input-box-mixin + (mixin ((class->interface text%)) (input-box<%>) + (inherit erase lock) - (define basic% (basic-mixin (editor:basic-mixin text%))) - (define hide-caret/selection% (hide-caret/selection-mixin basic%)) - (define nbsp->space% (nbsp->space-mixin basic%)) - (define delegate% (delegate-mixin basic%)) - (define wide-snip% (wide-snip-mixin basic%)) - (define standard-style-list% (editor:standard-style-list-mixin wide-snip%)) - (define input-box% (input-box-mixin standard-style-list%)) - (define -keymap% (editor:keymap-mixin standard-style-list%)) - (define return% (return-mixin -keymap%)) - (define autowrap% (editor:autowrap-mixin -keymap%)) - (define file% (file-mixin (editor:file-mixin autowrap%))) - (define clever-file-format% (clever-file-format-mixin file%)) - (define backup-autosave% (editor:backup-autosave-mixin clever-file-format%)) - (define searching% (searching-mixin backup-autosave%)) - (define info% (info-mixin (editor:info-mixin searching%)))) + (define port-text #f) + (define/public (set-port-text pt) (set! port-text pt)) + + (define in-use? #t) + (define/public (box-input-not-used-anymore) + (lock #t) + (set! in-use? #f)) + + (define/override (on-default-char kevt) + (super on-default-char kevt) + (when in-use? + (case (send kevt get-key-code) + [(numpad-enter #\return) + (send port-text new-box-input this)] + [else (void)]))) + + (super-new))) + + (define (start-text-input-port source on-peek) + + ;; eventspace at the time this function was called. used for peek callbacks + (define eventspace (current-eventspace)) + + ;; read-chan : (channel (cons (union byte snip eof) line-col-pos)) + ;; send input from the editor + (define read-chan (make-channel)) + + ;; clear-input-chan : (channel void) + (define clear-input-chan (make-channel)) + + ;; progress-event-chan : (channel (cons (channel event) nack-evt))) + (define progress-event-chan (make-channel)) + + ;; peek-chan : (channel peeker) + (define peek-chan (make-channel)) + + ;; commit-chan : (channel committer) + (define commit-chan (make-channel)) + + ;; position-chan : (channel (cons (channel void) (channel line-col-pos))) + (define position-chan (make-channel)) + + (define input-buffer-thread + (thread + (λ () + + ;; these vars are like arguments to the loop function + ;; they are only set right before loop is called. + ;; This is done to avoid passing the same arguments + ;; over and over to loop. + (define peeker-sema (make-semaphore 0)) + (define peeker-evt (semaphore-peek-evt peeker-sema)) + (define bytes-peeked 0) + (define response-evts '()) + (define peekers '()) ;; waiting for a peek + (define committers '()) ;; waiting for a commit + (define positioners '()) ;; waiting for a position + (define data (empty-queue)) ;; (queue (cons (union byte snip eof) line-col-pos)) + (define position #f) + + ;; loop : -> alpha + ;; the main loop for this thread + (define (loop) + (let-values ([(not-ready-peekers new-peek-response-evts) + (separate peekers service-waiter)] + [(potential-commits new-commit-response-evts) + (separate + committers + (service-committer data peeker-evt))]) + (when (and on-peek + (not (null? not-ready-peekers))) + (parameterize ([current-eventspace eventspace]) + (queue-callback on-peek))) + (set! peekers not-ready-peekers) + (set! committers potential-commits) + (set! response-evts + (append response-evts + new-peek-response-evts + new-commit-response-evts)) + (sync + (handle-evt + position-chan + (λ (pr) + (let ([nack-chan (car pr)] + [resp-chan (cdr pr)]) + (set! positioners (cons pr positioners)) + (loop)))) + (apply choice-evt (map service-positioner positioners)) + (handle-evt + read-chan + (λ (ent) + (set! data (enqueue ent data)) + (unless position + (set! position (cdr ent))) + (loop))) + (handle-evt + clear-input-chan + (λ (_) + (semaphore-post peeker-sema) + (set! peeker-sema (make-semaphore 0)) + (set! peeker-evt (semaphore-peek-evt peeker-sema)) + (set! data (empty-queue)) + (set! position #f) + (loop))) + (handle-evt + progress-event-chan + (λ (return-pr) + (let ([return-chan (car return-pr)] + [return-nack (cdr return-pr)]) + (set! response-evts + (cons (choice-evt + return-nack + (channel-put-evt return-chan peeker-evt)) + response-evts)) + (loop)))) + (handle-evt + peek-chan + (λ (peeker) + (set! peekers (cons peeker peekers)) + (loop))) + (handle-evt + commit-chan + (λ (committer) + (set! committers (cons committer committers)) + (loop))) + (apply + choice-evt + (map + (λ (a-committer) + (match a-committer + [($ committer + kr + commit-peeker-evt + done-evt + resp-chan + resp-nack) + (choice-evt + (handle-evt + commit-peeker-evt + (λ (_) + ;; this committer will be thrown out in next iteration + (loop))) + (handle-evt + done-evt + (λ (v) + (let ([nth-pos (cdr (peek-n data (- kr 1)))]) + (set! position + (list (car nth-pos) + (+ 1 (cadr nth-pos)) + (+ 1 (caddr nth-pos))))) + (set! data (dequeue-n data kr)) + (semaphore-post peeker-sema) + (set! peeker-sema (make-semaphore 0)) + (set! peeker-evt (semaphore-peek-evt peeker-sema)) + (set! committers (remq a-committer committers)) + (set! response-evts + (cons + (choice-evt + resp-nack + (channel-put-evt resp-chan #t)) + response-evts)) + (loop))))])) + committers)) + (apply choice-evt + (map (λ (resp-evt) + (handle-evt + resp-evt + (λ (_) + (set! response-evts (remq resp-evt response-evts)) + (loop)))) + response-evts))))) + + ;; service-positioner : (cons (channel void) (channel line-col-pos)) -> evt + (define (service-positioner pr) + (let ([nack-evt (car pr)] + [resp-evt (cdr pr)]) + (handle-evt + (choice-evt nack-evt + (channel-put-evt resp-evt (or position + + ;; a bogus position for when + ;; nothing has happened yet. + (list 1 0 1)))) + (let ([sent-position position]) + (λ (_) + (set! positioners (remq pr positioners)) + (loop)))))) + + ;; service-committer : queue evt -> committer -> (union #f evt) + ;; if the committer can be dumped, return an evt that + ;; does the dumping. otherwise, return #f + (define ((service-committer data peeker-evt) a-committer) + (match a-committer + [($ committer + kr commit-peeker-evt + done-evt resp-chan resp-nack) + (let ([size (queue-size data)]) + (cond + [(not (eq? peeker-evt commit-peeker-evt)) + (choice-evt + resp-nack + (channel-put-evt resp-chan #f))] + [(< size kr) + (choice-evt + resp-nack + (channel-put-evt resp-chan 'commit-failure))] + [else ;; commit succeeds + #f]))])) + + ;; service-waiter : peeker -> (union #f evt) + ;; if the peeker can be serviced, build an event to service it + ;; otherwise return #f + (define (service-waiter a-peeker) + (match a-peeker + [($ peeker bytes skip-count pe resp-chan nack-evt polling?) + (cond + [(and pe (not (eq? pe peeker-evt))) + (choice-evt (channel-put-evt resp-chan #f) + nack-evt)] + [((queue-size data) . > . skip-count) + (let ([nth (car (peek-n data skip-count))]) + (choice-evt + nack-evt + (cond + [(byte? nth) + (bytes-set! bytes 0 nth) + (channel-put-evt resp-chan 1)] + [(eof-object? nth) + (channel-put-evt resp-chan nth)] + [else + (channel-put-evt + resp-chan + (λ (src line col pos) + (if (is-a? nth readable-snip<%>) + (send nth read-special src line col pos) + nth)))])))] + [polling? + (choice-evt + nack-evt + (channel-put-evt resp-chan 0))] + [else + #f])])) + + ;; separate (listof X) (X -> (union #f Y)) -> (values (listof X) (listof Y)) + ;; separates `eles' into two lists -- those that `f' returns #f for + ;; and then the results of calling `f' for those where `f' doesn't return #f + (define (separate eles f) + (let loop ([eles eles] + [transformed '()] + [left-alone '()]) + (cond + [(null? eles) (values left-alone transformed)] + [else (let* ([ele (car eles)] + [maybe (f ele)]) + (if maybe + (loop (cdr eles) + (cons maybe transformed) + left-alone) + (loop (cdr eles) + transformed + (cons ele left-alone))))]))) + + ;;; start things going + (loop)))) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; + ;; the following must be able to run + ;; in any thread (even concurrently) + ;; + (define (read-bytes-proc bstr) + (let* ([progress-evt (progress-evt-proc)] + [v (peek-proc bstr 0 progress-evt)]) + (cond + [(sync/timeout 0 progress-evt) + 0] + [else + (wrap-evt + v + (λ (v) + (if (and (number? v) (zero? v)) + 0 + (if (commit-proc (if (number? v) v 1) + progress-evt + always-evt) + v + 0))))]))) + + (define (peek-proc bstr skip-count progress-evt) + (poll-guard-evt + (lambda (polling?) + (let ([evt + (nack-guard-evt + (λ (nack) + (let ([chan (make-channel)]) + (channel-put peek-chan (make-peeker bstr skip-count progress-evt chan nack polling?)) + chan)))]) + (if polling? + (let ([v (sync evt)]) + (if (eq? v 0) + ;; Don't return 0, because that means something is + ;; probably ready. We want to indicate that nothing is + ;; ready. + never-evt + ;; Even on success, package it as an event, because + ;; `read-bytes-proc' expects an event + (wrap-evt always-evt (lambda (_) v)))) + evt))))) + + (define (progress-evt-proc) + (sync + (nack-guard-evt + (λ (nack) + (let ([chan (make-channel)]) + (channel-put progress-event-chan (cons chan nack)) + chan))))) + + (define (commit-proc kr progress-evt done-evt) + (sync + (nack-guard-evt + (λ (nack) + (let ([chan (make-channel)]) + (channel-put commit-chan (make-committer kr progress-evt done-evt chan nack)) + chan))))) + + (define (close-proc) (void)) + + (define (position-proc) + (let ([chan (make-channel)]) + (apply + values + (sync + (nack-guard-evt + (λ (fail) + (channel-put position-chan (cons fail chan)) + chan)))))) + (let ([p (make-input-port source + read-bytes-proc + peek-proc + close-proc + progress-evt-proc + commit-proc + position-proc)]) + (port-count-lines! p) + (values p read-chan clear-input-chan))) + + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; + ;; queues + ;; + (define-struct queue (front back count)) + (define (empty-queue) (make-queue '() '() 0)) + (define (enqueue e q) (make-queue + (cons e (queue-front q)) + (queue-back q) + (+ (queue-count q) 1))) + (define (queue-first q) + (flip-around q) + (let ([back (queue-back q)]) + (if (null? back) + (error 'queue-first "empty queue") + (car back)))) + (define (queue-rest q) + (flip-around q) + (let ([back (queue-back q)]) + (if (null? back) + (error 'queue-rest "empty queue") + (make-queue (queue-front q) + (cdr back) + (- (queue-count q) 1))))) + (define (flip-around q) + (when (null? (queue-back q)) + (set-queue-back! q (reverse (queue-front q))) + (set-queue-front! q '()))) + + (define (queue-empty? q) (zero? (queue-count q))) + (define (queue-size q) (queue-count q)) + + ;; queue->list : (queue x) -> (listof x) + ;; returns the elements in the order that successive deq's would have + (define (queue->list q) + (let ([ans (append (queue-back q) (reverse (queue-front q)))]) + (set-queue-back! q ans) + (set-queue-front! q '()) + ans)) + + ;; dequeue-n : queue number -> queue + (define (dequeue-n queue n) + (let loop ([q queue] + [n n]) + (cond + [(zero? n) q] + [(queue-empty? q) (error 'dequeue-n "not enough!")] + [else (loop (queue-rest q) (- n 1))]))) + + ;; peek-n : queue number -> queue + (define (peek-n queue init-n) + (let loop ([q queue] + [n init-n]) + (cond + [(zero? n) + (when (queue-empty? q) + (error 'peek-n "not enough; asked for ~a but only ~a available" + init-n + (queue-size queue))) + (queue-first q)] + [else + (when (queue-empty? q) + (error 'dequeue-n "not enough!")) + (loop (queue-rest q) (- n 1))]))) + + ;; + ;; end queue abstraction + ;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (define basic% (basic-mixin (editor:basic-mixin text%))) + (define hide-caret/selection% (hide-caret/selection-mixin basic%)) + (define nbsp->space% (nbsp->space-mixin basic%)) + (define delegate% (delegate-mixin basic%)) + (define wide-snip% (wide-snip-mixin basic%)) + (define standard-style-list% (editor:standard-style-list-mixin wide-snip%)) + (define input-box% (input-box-mixin standard-style-list%)) + (define -keymap% (editor:keymap-mixin standard-style-list%)) + (define return% (return-mixin -keymap%)) + (define autowrap% (editor:autowrap-mixin -keymap%)) + (define file% (file-mixin (editor:file-mixin autowrap%))) + (define clever-file-format% (clever-file-format-mixin file%)) + (define backup-autosave% (editor:backup-autosave-mixin clever-file-format%)) + (define searching% (searching-mixin backup-autosave%)) + (define info% (info-mixin (editor:info-mixin searching%)))) diff --git a/collects/framework/private/version.ss b/collects/framework/private/version.ss index f82a881b..6211a8cc 100644 --- a/collects/framework/private/version.ss +++ b/collects/framework/private/version.ss @@ -1,22 +1,22 @@ (module version (lib "a-unit.ss") (require "sig.ss" - (lib "mred-sig.ss" "mred") - (lib "string.ss") - (lib "list.ss")) + (lib "mred-sig.ss" "mred") + (lib "string.ss") + (lib "list.ss")) (import) (export (rename framework:version^ [-version version])) - - (define specs null) - - (define (-version) - (foldr (lambda (entry sofar) - (let ([sep (first entry)] - [num (second entry)]) - (string-append sofar sep num))) - (version) - specs)) - - (define (add-spec sep num) - (set! specs (cons (list (expr->string sep) (format "~a" num)) - specs)))) + + (define specs null) + + (define (-version) + (foldr (lambda (entry sofar) + (let ([sep (first entry)] + [num (second entry)]) + (string-append sofar sep num))) + (version) + specs)) + + (define (add-spec sep num) + (set! specs (cons (list (expr->string sep) (format "~a" num)) + specs))))