diff --git a/collects/framework/app.ss b/collects/framework/app.ss index b9a30ccd..b45fa71d 100644 --- a/collects/framework/app.ss +++ b/collects/framework/app.ss @@ -1,4 +1,4 @@ -(unit/sig framework:application^ +(dunit/sig framework:application^ (import) (define current-app-name (make-parameter diff --git a/collects/framework/autosave.ss b/collects/framework/autosave.ss index fda0548d..30f944c8 100644 --- a/collects/framework/autosave.ss +++ b/collects/framework/autosave.ss @@ -1,44 +1,47 @@ -(unit/sig framework:autosave^ +(dunit/sig framework:autosave^ (import mred-interfaces^ [exit : framework:exit^] [preferences : framework:preferences^]) + (define objects null) + + (define autosave-timer% + (class timer% () + (inherit start) + (override + [notify + (lambda () + (when (preferences:get 'framework:autosaving-on?) + (set! objects + (let loop ([list objects]) + (if (null? list) + null + (let ([object (weak-box-value (car list))]) + (if object + (begin + (send object do-autosave) + (cons (car list) (loop (cdr list)))) + (loop (cdr list)))))))) + (let ([seconds (preferences:get 'framework:autosave-delay)]) + (start (* 1000 seconds) #t)))]) + (sequence + (super-init) + (let ([seconds (preferences:get 'framework:autosave-delay)]) + (start (* 1000 seconds) #t))))) + + (define timer #f) + (define register - (let* ([objects null] - [autosave-timer% - (class timer% () - (inherit start) - (override - [notify - (lambda () - (when (preferences:get 'framework:autosaving-on?) - (set! objects - (let loop ([list objects]) - (if (null? list) - null - (let ([object (weak-box-value (car list))]) - (if object - (begin - (send object do-autosave) - (cons (car list) (loop (cdr list)))) - (loop (cdr list)))))))) - (let ([seconds (preferences:get 'framework:autosave-delay)]) - (start (* 1000 seconds) #t)))]) - (sequence - (super-init) - (let ([seconds (preferences:get 'framework:autosave-delay)]) - (start (* 1000 seconds) #t))))] - [timer #f]) - (lambda (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))))]))))))) + (lambda (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))))])))))) diff --git a/collects/framework/canvas.ss b/collects/framework/canvas.ss index f1d03860..d2c3da0f 100644 --- a/collects/framework/canvas.ss +++ b/collects/framework/canvas.ss @@ -1,95 +1,100 @@ -(unit/sig framework:canvas^ +(dunit/sig framework:canvas^ (import mred-interfaces^ [preferences : framework:preferences^]) + (define wide-snip<%> (interface (editor-canvas<%>) + add-wide-snip + add-tall-snip)) + ;; wx: this need to collude with ;; the edit, since the edit has the right callbacks. - - (define make-wide-snip% - (lambda (super%) - (class-asi super% - (inherit get-media) - (rename [super-on-size on-size]) - (private - [wide-snips null] - [tall-snips null] - [update-snip-size - (lambda (width?) - (lambda (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-this-media)] - [edit (get-media)]) - (when edit - (send edit - run-after-edit-sequence - (lambda () - (let ([admin (send edit get-admin)]) - (send admin get-view #f #f width height) - (send s get-margin leftm topm rightm bottomm) + (define wide-snip-mixin + (mixin (editor-canvas<%>) (wide-snip<%>) args + (inherit get-editor) + (rename [super-on-size on-size]) + (private + [wide-snips null] + [tall-snips null] + [update-snip-size + (lambda (width?) + (lambda (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-this-media)] + [edit (get-editor)]) + (when edit + (send edit + run-after-edit-sequence + (lambda () + (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 - (lambda () - (send edit get-snip-position-and-location - s #f left-edge-box top-edge-box))]) - (cond - [(not width?) (fallback)] - [(let ([prev (send s previous)]) - (and (not prev - (member 'hard-newline (send prev get-flags))))) - (set-box! left-edge-box 0)] - [else (fallback)])) + ;; 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 + (lambda () + (send edit get-snip-position-and-location + s #f left-edge-box top-edge-box))]) + (cond + [(not width?) (fallback)] + [(let ([prev (send s previous)]) + (and (not prev + (member 'hard-newline (send prev get-flags))))) + (set-box! left-edge-box 0)] + [else (fallback)])) - (if width? - (let ([snip-width (- (unbox width) - (unbox left-edge-box) - (unbox leftm) - (unbox rightm) - - ;; 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 (- (unbox height) - (unbox top-edge-box) - (unbox topm) - (unbox bottomm))]) - (send* s - (set-min-height snip-height) - (set-max-height snip-height)))))))))))]) - (public - [add-wide-snip - (lambda (snip) - (set! wide-snips (cons snip wide-snips)) - ((update-snip-size #t) snip))] - [add-tall-snip - (lambda (snip) - (set! tall-snips (cons snip tall-snips)) - ((update-snip-size #f) snip))] - [on-size - (lambda (width height) - (super-on-size width height) - (for-each (update-snip-size #t) wide-snips) - (for-each (update-snip-size #f) tall-snips))])))) + (if width? + (let ([snip-width (- (unbox width) + (unbox left-edge-box) + (unbox leftm) + (unbox rightm) + + ;; 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 (- (unbox height) + (unbox top-edge-box) + (unbox topm) + (unbox bottomm))]) + (send* s + (set-min-height snip-height) + (set-max-height snip-height)))))))))))]) + (public + [add-wide-snip + (lambda (snip) + (set! wide-snips (cons snip wide-snips)) + ((update-snip-size #t) snip))] + [add-tall-snip + (lambda (snip) + (set! tall-snips (cons snip tall-snips)) + ((update-snip-size #f) snip))]) + (override + [on-size + (lambda (width height) + (super-on-size width height) + (for-each (update-snip-size #t) wide-snips) + (for-each (update-snip-size #f) tall-snips))]) + (sequence + (apply super-init args)))) - (define wide-snip% (make-wide-snip% editor-canvas%))) \ No newline at end of file + (define wide-snip% (wide-snip-mixin editor-canvas%))) \ No newline at end of file diff --git a/collects/framework/editor.ss b/collects/framework/editor.ss index fd642d4d..91d1d773 100644 --- a/collects/framework/editor.ss +++ b/collects/framework/editor.ss @@ -1,4 +1,4 @@ -(unit/sig framework:editor^ +(dunit/sig framework:editor^ (import mred-interfaces^ [autosave : framework:autosave^] [finder : framework:finder^] @@ -6,18 +6,20 @@ [keymap : framework:keymap^] [icon : framework:icon^] [preferences : framework:preferences^] - [gui-utils : framework:gui-utils^]) + [text : framework:text^] + [pasteboard : framework:pasteboard^]) (define basic<%> (interface (editor<%>) editing-this-file? local-edit-sequence? run-after-edit-sequence - get-text-snip - get-pasteboard-snip - default-auto-wrap?)) + default-auto-wrap? + get-top-level-window + locked? + on-close)) - (define make-basic% + (define basic-mixin (mixin (editor<%>) (basic<%>) args (inherit get-filename save-file refresh-delayed? @@ -25,62 +27,47 @@ get-keymap get-max-width get-admin set-filename) (rename [super-set-modified set-modified] - [super-on-save-file on-save-file] [super-on-focus on-focus] - [super-load-file load-file] [super-lock lock]) - (public [editing-this-file? #f]) + (public + [on-close void] + [get-top-level-window + (lambda () + (let ([c (get-canvas)]) + (and c + (send c get-top-level-window))))]) - (override - [load-file - (opt-lambda ([filename #f] - [the-format 'guess] - [show-dialog? #t]) - (let ([filename (or filename - (parameterize ([finder:dialog-parent-parameter - (let ([canvas (get-canvas)]) - (and canvas - (send canvas get-top-level-window)))]) - (finder:get-file)))]) - (and filename - (if (file-exists? filename) - (let ([res (super-load-file filename the-format #f)]) - (when (and (not res) - show-dialog?) - (message-box - "Error Loading File" - (format "Error loading file ~a" filename)) - res)) - (set-filename filename)))))]) + (public [editing-this-file? (lambda () #f)]) (private [edit-sequence-queue null] [edit-sequence-ht (make-hash-table)]) + (private + [in-local-edit-sequence? #f]) (public - [local-edit-sequence? #f] + [local-edit-sequence? (lambda () in-local-edit-sequence?)] [run-after-edit-sequence - (rec run-after-edit-sequence - (case-lambda - [(t) (run-after-edit-sequence t #f)] - [(t sym) - (unless (and (procedure? t) - (= 0 (arity t))) - (error 'media-buffer::run-after-edit-sequence - "expected procedure of arity zero, got: ~s~n" t)) - (unless (or (symbol? sym) (not sym)) - (error 'media-buffer::run-after-edit-sequence - "expected second argument to be a symbol, got: ~s~n" - sym)) - (if (refresh-delayed?) - (cond - [(symbol? sym) - (hash-table-put! edit-sequence-ht sym t)] - [else (set! edit-sequence-queue - (cons t edit-sequence-queue))]) - (t)) - (void)]))] + (case-lambda + [(t) (run-after-edit-sequence t #f)] + [(t sym) + (unless (and (procedure? t) + (= 0 (arity t))) + (error 'media-buffer::run-after-edit-sequence + "expected procedure of arity zero, got: ~s~n" t)) + (unless (or (symbol? sym) (not sym)) + (error 'media-buffer::run-after-edit-sequence + "expected second argument to be a symbol, got: ~s~n" + sym)) + (if (refresh-delayed?) + (cond + [(symbol? sym) + (hash-table-put! edit-sequence-ht sym t)] + [else (set! edit-sequence-queue + (cons t edit-sequence-queue))]) + (t)) + (void)])] [extend-edit-sequence-queue (lambda (l ht) (hash-table-for-each ht (lambda (k t) @@ -95,10 +82,10 @@ [on-edit-sequence (lambda () (super-on-edit-sequence) - (set! local-edit-sequence? #t))] + (set! in-local-edit-sequence? #t))] [after-edit-sequence (lambda () - (set! local-edit-sequence? #f) + (set! in-local-edit-sequence? #f) (super-after-edit-sequence) (let ([queue edit-sequence-queue] [ht edit-sequence-ht] @@ -115,67 +102,56 @@ (set! edit-sequence-ht (make-hash-table)) (let loop ([edit (find-enclosing-edit this)]) (cond - [(and edit (not (ivar edit local-edit-sequence?))) + [(and edit (not (send edit local-edit-sequence?))) (loop (find-enclosing-edit edit))] [edit (send edit extend-edit-sequence-queue queue ht)] [else (hash-table-for-each ht (lambda (k t) (t))) (for-each (lambda (t) (t)) queue)]))))]) + (private + [is-locked? #f]) (public - [locked? #f]) + [locked? (lambda () is-locked?)]) (override - [lock + [lock (lambda (x) - (set! locked? x) - (super-lock x))]) - - (public - [get-text-snip (lambda () (make-object editor-snip% (make-object text%)))] - [get-pasteboard-snip (lambda () (make-object editor-snip% (make-object pasteboard%)))]) - (override + (set! is-locked? x) + (super-lock x))] [on-new-box (lambda (type) (cond - [(eq? type 'text) (get-text-snip)] - [else (get-pasteboard-snip)]))]) + [(eq? type 'text) (make-object editor-snip% (make-object text:basic%))] + [else (make-object editor-snip% (make-object pasteboard:basic%))]))]) - (public + (override [get-file (lambda (d) - (let ([v (parameterize ([finder:dialog-parent-parameter - (and (get-canvas) - (send (get-canvas) get-top-level-window))]) - (finder:get-file d))]) - (if v - v - null)))] - [put-file (lambda (d f) (let ([v (parameterize ([finder:dialog-parent-parameter - (and (get-canvas) - (send (get-canvas) get-top-level-window))]) - (finder:put-file f d))]) - (if v - v - null)))]) + (parameterize ([finder:dialog-parent-parameter + (get-top-level-window)]) + (finder:get-file d)))] + [put-file (lambda (d f) (parameterize ([finder:dialog-parent-parameter + (get-top-level-window)]) + (finder:put-file f d)))]) (public - [default-auto-wrap? #t]) + [default-auto-wrap? (lambda () #t)]) (inherit auto-wrap) (sequence (apply super-init args) - (auto-wrap default-auto-wrap?)))) + (auto-wrap (default-auto-wrap?))))) (define file<%> (interface (basic<%>))) - (define make-file% + (define file-mixin (mixin (basic<%>) (file<%>) args (inherit get-keymap get-filename lock get-style-list is-modified? change-style set-modified - get-frame) + get-top-level-window) (rename [super-after-save-file after-save-file] [super-after-load-file after-load-file]) - (override [editing-this-file? #t]) + (override [editing-this-file? (lambda () #t)]) (private [check-lock (lambda () @@ -213,15 +189,14 @@ do-autosave remove-autosave)) - ; wx: when should autosave files be removed? - ; also, what about checking the autosave files when a file is + ; wx: what about checking the autosave files when a file is ; opened? - (define make-backup-autosave% + (define backup-autosave-mixin (mixin (basic<%>) (backup-autosave<%>) args (inherit is-modified? get-filename save-file) (rename [super-on-save-file on-save-file] [super-on-change on-change] - [super-do-close do-close] + [super-on-close on-close] [super-set-modified set-modified]) (private [freshen-backup? #t] @@ -229,30 +204,29 @@ [auto-save-out-of-date? #t] [auto-save-error? #f]) (public - [auto-save? #t] - [backup? #t]) + [backup? (lambda () #t)]) (override [on-save-file (lambda (name format) (set! auto-save-error? #f) (and (super-on-save-file name format) (begin - (when (and backup? + (when (and (backup?) + freshen-backup? (not (eq? format 'copy)) (file-exists? name)) (let ([back-name (path-utils:generate-backup-name name)]) - (when freshen-backup? - (set! freshen-backup? #f) - (when (file-exists? back-name) - (delete-file back-name))) + (set! freshen-backup? #f) + (when (file-exists? back-name) + (delete-file back-name)) (with-handlers ([(lambda (x) #t) void]) (copy-file name back-name)))) #t)))] - [do-close + [on-close (lambda () - (super-do-close) + (super-on-close) (remove-autosave) - (set! auto-save? #f))] + (set! autosave? (lambda () #f)))] [on-change (lambda () (super-on-change) @@ -267,10 +241,10 @@ (set! auto-saved-name #f)))) (super-set-modified modified?))]) (public - [autosave? #t] + [autosave? (lambda () #t)] [do-autosave (lambda () - (when (and auto-save? + (when (and (autosave?) (not auto-save-error?) (is-modified?) (or (not auto-saved-name) @@ -302,9 +276,9 @@ (autosave:register this)))) (define info<%> (interface (basic<%>))) - (define make-info% + (define info-mixin (mixin (basic<%>) (info<%>) args - (inherit get-frame run-after-edit-sequence) + (inherit get-top-level-window run-after-edit-sequence) (rename [super-lock lock]) (override [lock @@ -313,57 +287,8 @@ (run-after-edit-sequence (rec send-frame-update-lock-icon (lambda () - (let ([frame (get-frame)]) + (let ([frame (get-top-level-window)]) (when frame (send frame lock-status-changed))))) 'framework:update-lock-icon))]) - (sequence (apply super-init args)))) - - (define make-clever-file-format% - (mixin (editor<%>) (editor<%>) args - (inherit get-file-format set-file-format ;find-first-snip wx: - ) - (rename [super-on-save-file on-save-file] - [super-after-save-file after-save-file]) - - (private [restore-file-format void]) - - (override - [after-save-file - (lambda (success) - (restore-file-format) - (super-after-save-file success))] - [on-save-file - (let ([has-non-string-snips - (lambda () - (let loop ([s (if (is-a? this pasteboard%) - (send this find-first-snip) - (send this find-snip 0 'after))]) ;; wx: - (cond - [(null? s) #f] - [(is-a? s string-snip%) - (loop (send s next))] - [else #t])))]) - (lambda (name format) - (when (and (or (eq? format 'same) - (eq? format 'copy)) - (not (eq? (get-file-format) - 'std))) - (cond - [(eq? format 'copy) - (set! restore-file-format - (let ([f (get-file-format)]) - (lambda () - (set! restore-file-format void) - (set-file-format f)))) - (set-file-format 'std)] - [(and (has-non-string-snips) - (or (not (preferences:get 'framework:verify-change-format)) - (gui-utils:get-choice "Save this file as plain text?" "No" "Yes"))) - (set-file-format 'std)] - [else (void)])) - (or (super-on-save-file name format) - (begin - (restore-file-format) - #f))))]) (sequence (apply super-init args))))) \ No newline at end of file diff --git a/collects/framework/exit.ss b/collects/framework/exit.ss index 09378d6d..b210f082 100644 --- a/collects/framework/exit.ss +++ b/collects/framework/exit.ss @@ -1,4 +1,4 @@ -(unit/sig framework:exit^ +(dunit/sig framework:exit^ (import [preferences : framework:preferences^] [gui-utils : framework:gui-utils^]) (rename (-exit exit)) diff --git a/collects/framework/fileutil.ss b/collects/framework/fileutil.ss index e6d3ea30..7bd57d4d 100644 --- a/collects/framework/fileutil.ss +++ b/collects/framework/fileutil.ss @@ -1,5 +1,5 @@ -(unit/sig framework:path-utils^ +(dunit/sig framework:path-utils^ (import) (define generate-autosave-name diff --git a/collects/framework/finder.ss b/collects/framework/finder.ss index 1b9108f8..83ea2098 100644 --- a/collects/framework/finder.ss +++ b/collects/framework/finder.ss @@ -2,7 +2,7 @@ ;;; Authors: Matthew Flatt, Robby Findler, Paul Steckler -(unit/sig framework:finder^ +(dunit/sig framework:finder^ (import mred-interfaces^ [preferences : framework:preferences^] [gui-utils : framework:gui-utils^] @@ -62,8 +62,7 @@ file-filter file-filter-msg) - (inherit new-line tab fit center - popup-menu show) + (inherit center show) (private [WIDTH 500] @@ -310,8 +309,9 @@ [do-cancel (lambda args (set-box! result-box #f) - (show #f))] + (show #f))]) + (override [on-close (lambda () #f)]) (sequence diff --git a/collects/framework/frame.ss b/collects/framework/frame.ss index 0b7774fa..95b87fb5 100644 --- a/collects/framework/frame.ss +++ b/collects/framework/frame.ss @@ -1,4 +1,4 @@ -(unit/sig framework:frame^ +(dunit/sig framework:frame^ (import mred-interfaces^ [group : framework:group^] [preferences : framework:preferences^] @@ -26,13 +26,13 @@ (when (< w frame-height) (set! frame-height (- (unbox h) 65)))) - (define basic<%> (interface () - get-panel% - make-root-panel)) - (define make-basic% + (define basic<%> (interface (frame<%>) + get-area-container% + get-area-container + get-menu-bar% + make-root-area-container)) + (define basic-mixin (mixin (frame<%>) (basic<%>) args - (rename [super-on-activate on-activate]) - (override [can-close? (lambda () @@ -45,325 +45,50 @@ remove-frame this))]) (public - [get-panel% (lambda () vertical-panel%)] + [get-area-container% (lambda () vertical-panel%)] [get-menu-bar% (lambda () menu-bar%)] - [make-root-panel + [make-root-area-container (lambda (% parent) (make-object % parent))]) - (rename [super-show show]) - (override - [show - (lambda (on?) - (super-show on?) - (when on? - '(unless (member this (send group:the-frame-group - get-frames)) - (send group:the-frame-group - insert-frame this))))] - [on-activate - (lambda (active?) - (super-on-activate active?) - '(when active? - (send group:the-frame-group set-active-frame this)))]) - (sequence - (apply super-init args)) + (apply super-init args) + (make-object (get-menu-bar%) this)) + (private + [panel (make-root-area-container (get-area-container%) this)]) (public - [menu-bar (make-object (get-menu-bar%) this)] - [panel (make-root-panel (get-panel%) this)]))) + [get-area-container (lambda () panel)]))) - (define standard-menus<%> - (interface (basic<%>) - get-menu% - get-menu-item% - - edit-menu - edit-menu:after-standard-items - edit-menu:between-clear-and-select-all - edit-menu:between-copy-and-paste - edit-menu:between-cut-and-copy - edit-menu:between-paste-and-clear - edit-menu:between-redo-and-cut - edit-menu:between-find-and-preferences - edit-menu:between-select-all-and-find - edit-menu:clear - edit-menu:clear-help-string - edit-menu:clear-menu - edit-menu:clear-string - edit-menu:copy - edit-menu:copy-help-string - edit-menu:copy-menu - edit-menu:copy-string - edit-menu:cut - edit-menu:cut-help-string - edit-menu:cut-menu - edit-menu:cut-string - edit-menu:find - edit-menu:find-help-string - edit-menu:find-menu - edit-menu:find-string - edit-menu:paste - edit-menu:paste-help-string - edit-menu:paste-menu - edit-menu:paste-string - edit-menu:preferences - edit-menu:preferences-help-string - edit-menu:preferences-menu - edit-menu:redo - edit-menu:redo-help-string - edit-menu:redo-menu - edit-menu:redo-string - edit-menu:select-all - edit-menu:select-all-help-string - edit-menu:select-all-menu - edit-menu:select-all-string - edit-menu:undo - edit-menu:undo-help-string - edit-menu:undo-menu - edit-menu:undo-string - file-menu - file-menu:after-quit - file-menu:between-close-and-quit - file-menu:between-new-and-open - file-menu:between-open-and-revert - file-menu:between-revert-and-save - file-menu:between-print-and-close - file-menu:between-save-and-print - file-menu:close - file-menu:close-help-string - file-menu:close-menu - file-menu:close-string - file-menu:new - file-menu:new-help-string - file-menu:new-menu - file-menu:new-string - file-menu:open - file-menu:open-help-string - file-menu:open-menu - file-menu:open-string - file-menu:print - file-menu:print-help-string - file-menu:print-menu - file-menu:print-string - file-menu:quit - file-menu:quit-help-string - file-menu:quit-menu - file-menu:quit-string - file-menu:revert - file-menu:revert-help-string - file-menu:revert-menu - file-menu:revert-string - file-menu:save - file-menu:save-as - file-menu:save-as-help-string - file-menu:save-as-menu - file-menu:save-as-string - file-menu:save-help-string - file-menu:save-menu - file-menu:save-string - help-menu - help-menu:about - help-menu:about-help-string - help-menu:about-menu - help-menu:about-string - help-menu:after-about - windows-menu)) - - (define make-standard-menus% - (begin-elaboration-time - (let-struct between (menu name procedure) - (let-struct an-item (name help-string proc key menu-string-before menu-string-after) - (letrec ([build-id - (lambda (name post) - (let* ([name-string (symbol->string name)] - [answer (string->symbol (string-append name-string post))]) - answer))] - [menu-name->id - (lambda (name-string) - (let ([file-menu? (string=? (substring name-string 0 9) "file-menu")] - [edit-menu? (string=? (substring name-string 0 9) "edit-menu")] - [windows-menu? (string=? (substring name-string 0 9) "windows-m")] - [help-menu? (string=? (substring name-string 0 9) "help-menu")]) - (cond - [file-menu? 'file-menu] - [edit-menu? 'edit-menu] - [windows-menu? 'windows-menu] - [help-menu? 'help-menu] - [else (printf "WARNING: defaulting item to file-menu ~s~n" name-string) - 'file-menu])))] - - [build-fill-in-item-clause - (lambda (item) - (let ([name (an-item-name item)] - [help-string (an-item-help-string item)] - [proc (an-item-proc item)]) - `(public - [,name ,proc] - [,(build-id name "-string") ""] - [,(build-id name "-help-string") ,help-string])))] - [build-fill-in-between-clause - (lambda (between) - (let ([menu (between-menu between)] - [name (between-name between)] - [procedure (between-procedure between)]) - `(public - [,(string->symbol - (string-append - (symbol->string menu) - ":" - (symbol->string name))) - ,procedure])))] - [build-item-menu-clause - (lambda (item) - (let* ([name (an-item-name item)] - [name-string (symbol->string name)] - [menu-before-string (an-item-menu-string-before item)] - [menu-after-string (an-item-menu-string-after item)] - [key (an-item-key item)] - [join (lambda (base special suffix) - (if (string=? special "") - (string-append base suffix) - (string-append base " " special suffix)))]) - `(public - [,(build-id name "-menu") - (and ,name - (make-object - (get-menu-item%) - (,join ,menu-before-string - ,(build-id name "-string") - ,menu-after-string) - ,(menu-name->id name-string) - ,name - ,key - ,(build-id name "-help-string")))])))] - [build-between-menu-clause - (lambda (between) - `(sequence - (,(string->symbol - (string-append - (symbol->string (between-menu between)) - ":" - (symbol->string (between-name between)))) - ,(between-menu between))))] - [items - (let ([between-nothing (lambda (menu) (void))] - [between-separator (lambda (menu) (make-object separator-menu-item% menu))]) - (list (make-an-item 'file-menu:new "Open a new file" - '(lambda (item control) (handler:edit-file #f) #t) - #\n "&New" "") - (make-between 'file-menu 'between-new-and-open between-nothing) - (make-an-item 'file-menu:open "Open a file from disk" - '(lambda (item control) (handler:open-file) #t) - #\o "&Open" "...") - (make-between 'file-menu 'between-open-and-revert between-nothing) - (make-an-item 'file-menu:revert - "Revert this file to the copy on disk" - #f #f "&Revert" "") - (make-between 'file-menu 'between-revert-and-save between-nothing) - (make-an-item 'file-menu:save "" #f "s" "&Save" "") - (make-an-item 'file-menu:save-as "" #f #f "Save" " &As...") - (make-between 'file-menu 'between-save-and-print between-separator) - (make-an-item 'file-menu:print "" #f "p" "&Print" "...") - (make-between 'file-menu 'between-print-and-close between-separator) - (make-an-item 'file-menu:close "" - '(lambda (item control) (when (on-close) (show #f)) #t) - #\w "&Close" "") - (make-between 'file-menu 'between-close-and-quit between-nothing) - (make-an-item 'file-menu:quit "" '(lambda (item control) (exit:exit)) - #\q - '(if (eq? (system-type) 'windows) "E&xit" "Quit") - "") - (make-between 'file-menu 'after-quit between-nothing) - - (make-an-item 'edit-menu:undo "" #f #\z "&Undo" "") - (make-an-item 'edit-menu:redo "" #f #\y "&Redo" "") - (make-between 'edit-menu 'between-redo-and-cut between-nothing) - (make-an-item 'edit-menu:cut "" #f #\x "Cu&t" "") - (make-between 'edit-menu 'between-cut-and-copy between-nothing) - (make-an-item 'edit-menu:copy "" #f #\c "&Copy" "") - (make-between 'edit-menu 'between-copy-and-paste between-nothing) - (make-an-item 'edit-menu:paste "" #f #\v "&Paste" "") - (make-between 'edit-menu 'between-paste-and-clear between-nothing) - (make-an-item 'edit-menu:clear "" #f #f - '(if (eq? (system-type) 'macos) - "Clear" - "&Delete") - "") - (make-between 'edit-menu 'between-clear-and-select-all between-nothing) - (make-an-item 'edit-menu:select-all "" #f #\a "Select A&ll" "") - (make-between 'edit-menu 'between-select-all-and-find between-nothing) - (make-an-item 'edit-menu:find "Search for a string in the buffer" - '(lambda (item control) (send this move-to-search-or-search) #t) - #\f "Find" "") - (make-between 'edit-menu 'between-find-and-preferences between-separator) - (make-an-item 'edit-menu:preferences "Configure your preferences" - '(lambda (item control) (preferences:show-dialog) #t) - #f "Preferences..." "") - (make-between 'edit-menu 'after-standard-items between-nothing) - - (make-an-item 'help-menu:about "About this application" - #f - #f - "About " - "...") - (make-between 'help-menu 'after-about between-nothing)))]) - `(mixin (basic<%>) (standard-menus<%>) args - (inherit menu-bar on-close show) - (public [get-menu% (lambda () menu%)] - [get-menu-item% (lambda () menu-item%)]) - ,@(append - (map (lambda (x) - (if (between? x) - (build-fill-in-between-clause x) - (build-fill-in-item-clause x))) - items) - (list `(sequence (apply super-init args)) - `(public - [file-menu (make-object (get-menu%) - (if (eq? (system-type) 'windows) - "&File" "F&ile") - menu-bar)] - - [edit-menu (make-object (get-menu%) "&Edit" menu-bar)] - [windows-menu (make-object (get-menu%) "&Windows" menu-bar)] - [help-menu (make-object (get-menu%) "&Help" menu-bar)])) - (map (lambda (x) - (if (between? x) - (build-between-menu-clause x) - (build-item-menu-clause x))) - items)))))))) + (include "standard-menus.ss") (define -editor<%> (interface (standard-menus<%>) - WIDTH - HEIGHT + get-init-width + get-init-height get-entire-label get-label-prefix set-label-prefix get-canvas% get-editor% - make-edit + make-editor save-as get-canvas get-editor)) - (define make-editor% + (define editor-mixin (mixin (standard-menus<%>) (-editor<%>) (file-name) - (inherit panel get-client-size set-icon get-menu-bar - make-menu show active-edit active-canvas) - (rename [super-can-close? can-close?] - [super-make-menu-bar make-menu-bar] + (inherit get-area-container get-client-size set-icon show get-edit-target-window get-edit-target-object) + (rename [super-on-close on-close] [super-set-label set-label]) (public - [WIDTH frame-width] - [HEIGHT frame-height]) + [get-init-width (lambda () frame-width)] + [get-init-height (lambda () frame-height)]) (override - [can-close? + [on-close (lambda () - (and (send (get-editor) do-close) - (super-can-close?)))] - [get-panel% (lambda () panel:vertical-edit%)]) + (super-on-close) + (send (get-editor) on-close))] + [get-area-container% (lambda () panel:vertical-editor%)]) (private [label file-name] [label-prefix (application:current-app-name)] @@ -441,22 +166,24 @@ [file-menu:save-as (lambda () (save-as) #t)] [file-menu:between-print-and-close (lambda (file-menu) - (send file-menu append-separator) + (make-object separator-menu-item% file-menu) (let ([split (lambda (panel%) (lambda () - (when (active-canvas) - (send panel split (active-canvas) panel%))))]) + (let ([win (get-edit-target-object)]) + (when (and win + (is-a? win canvas<%>)) + (send (get-area-container) split win panel%)))))]) (send file-menu append-item "Split Horizontally" (split horizontal-panel%)) (send file-menu append-item "Split Vertically" (split vertical-panel%)) (send file-menu append-item "Collapse" (lambda () - (when (active-canvas) - (send panel collapse (active-canvas)))))) - (send file-menu append-separator))] + (let ([canvas (get-edit-target-window)]) + (when canvas + (send (get-area-container) collapse canvas)))))) + (make-object separator-menu-item% file-menu))] [file-menu:print (lambda () (send (get-editor) print - #f #t #t (preferences:get 'framework:print-output-mode)) @@ -465,8 +192,9 @@ (private [edit-menu:do (lambda (const) (lambda (menu evt) - (let ([edit (active-edit)]) - (when edit + (let ([edit (get-edit-target-object)]) + (when (and edit + (is-a? edit editor<%>)) (send edit do-edit-operation const))) #t))]) @@ -490,22 +218,23 @@ (edit-menu:do 'insert-image)) (send edit-menu append-item "Toggle Wrap Text" (lambda () - (let ([edit (active-edit)]) - (when edit + (let ([edit (get-edit-target-object)]) + (when (and edit + (is-a? edit editor<%>)) (send edit auto-wrap (not (send edit auto-wrap))))))) (send edit-menu append-separator))]) (override [help-menu:about (lambda (menu evt) (message-box (format "Welcome to ~a" (application:current-app-name))))] - [help-menu:about-string (application:current-app-name)]) + [help-menu:about-string (lambda () (application:current-app-name))]) - (sequence (super-init (get-entire-label) #f WIDTH HEIGHT)) + (sequence (super-init (get-entire-label) #f (get-init-width) (get-init-height))) (public [get-canvas (let ([c #f]) (lambda () (unless c - (set! c (make-object (get-canvas%) panel)) + (set! c (make-object (get-canvas%) (get-area-container))) (send c set-media (get-editor))) c))] [get-editor (let ([e #f]) @@ -523,19 +252,21 @@ (send (get-editor) load-file file-name) (send canvas focus))))) - (define make-text/pasteboard% - (lambda (% <%>) - (mixin (editor<%>) (<%>) args - (override - [get-editor% (lambda () %)]) - (sequence (apply super-init args))))) - (define -text<%> (interface (editor<%>))) - (define make-text% (make-text/pasteboard% -text% -text<%>)) - (define -pasteboard<%> (interface (pasteboard<%>))) - (define make-pasteboard% (make-text/pasteboard% -pasteboard% -pasteboard<%>)) + (define -text<%> (interface (-editor<%>))) + (define text-mixin + (mixin (-editor<%>) (-text<%>) args + (override + [get-editor% (lambda () text%)]) + (sequence (apply super-init args)))) + (define -pasteboard<%> (interface (-editor<%>))) + (define pasteboard-mixin + (mixin (-editor<%>) (-pasteboard<%>) args + (override + [get-editor% (lambda () pasteboard%)]) + (sequence (apply super-init args)))) - (define searchable<%> (interface () + (define searchable<%> (interface (-text<%>) get-text-to-search hide-search unhide-search @@ -544,586 +275,589 @@ replace-all replace toggle-search-focus - move-to-search-or-show-search + move-to-search-or-search move-to-search-or-reverse-search search)) - (define make-searchable% - (let* ([anchor 0] - [searching-direction 1] - [old-highlight void] - [get-active-embedded-edit - (lambda (edit) - (let loop ([edit edit]) - (let ([snip (send edit get-focus-snip)]) - (if (or (not snip) - (not (is-a? snip editor-snip%))) - edit - (loop (send snip get-this-media))))))] - [clear-highlight - (lambda () - (begin (old-highlight) - (set! old-highlight void)))] - [reset-anchor - (let ([color (make-object color% "BLUE")]) - (lambda (edit) - (old-highlight) - (let ([position - (if (= 1 searching-direction) - (send edit get-end-position) - (send edit get-start-position))]) - (set! anchor position) - (set! old-highlight - (send edit highlight-range position position color #f)))))] - [replace-edit (make-object text%)] - [find-edit - (make-object - (class-asi text% - (inherit get-text) - (rename [super-after-insert after-insert] - [super-after-delete after-delete] - [super-on-focus on-focus]) - (public - [searching-frame #f] - [set-searching-frame - (lambda (frame) - (set! searching-frame frame))] - [get-searching-edit - (lambda () - (get-active-embedded-edit - (send searching-frame get-text-to-search)))] - [search - (opt-lambda ([reset-anchor? #t] [beep? #t] [wrap? #t]) - (when searching-frame - (let* ([string (get-text)] - [searching-edit (get-searching-edit)] - [not-found - (lambda (found-edit) - (send found-edit set-position anchor) - (when beep? - (bell)) - #f)] - [found - (lambda (edit first-pos) - (let ([last-pos (+ first-pos (* searching-direction - (string-length string)))]) - (send* edit - (set-caret-owner #f 'display) - (set-position - (min first-pos last-pos) - (max first-pos last-pos))) - #t))]) - (when reset-anchor? - (reset-anchor searching-edit)) - (let-values ([(found-edit first-pos) + (define search-anchor 0) + (define searching-direction 1) + (define old-search-highlight void) + (define get-active-embedded-edit + (lambda (edit) + (let loop ([edit edit]) + (let ([snip (send edit get-focus-snip)]) + (if (or (not snip) + (not (is-a? snip editor-snip%))) + edit + (loop (send snip get-this-media))))))) + (define clear-search-highlight + (lambda () + (begin (old-search-highlight) + (set! old-search-highlight void)))) + (define reset-search-anchor + (let ([color (make-object color% "BLUE")]) + (lambda (edit) + (old-search-highlight) + (let ([position + (if (= 1 searching-direction) + (send edit get-end-position) + (send edit get-start-position))]) + (set! search-anchor position) + (set! old-search-highlight + (send edit highlight-range position position color #f)))))) + + (define find-text% + (class-asi text% + (inherit get-text) + (rename [super-after-insert after-insert] + [super-after-delete after-delete] + [super-on-focus on-focus]) + (public + [searching-frame #f] + [set-searching-frame + (lambda (frame) + (set! searching-frame frame))] + [get-searching-edit + (lambda () + (get-active-embedded-edit + (send searching-frame get-text-to-search)))] + [search + (opt-lambda ([reset-search-anchor? #t] [beep? #t] [wrap? #t]) + (when searching-frame + (let* ([string (get-text)] + [searching-edit (get-searching-edit)] + [not-found + (lambda (found-edit) + (send found-edit set-position search-anchor) + (when beep? + (bell)) + #f)] + [found + (lambda (edit first-pos) + (let ([last-pos (+ first-pos (* searching-direction + (string-length string)))]) + (send* edit + (set-caret-owner #f 'display) + (set-position + (min first-pos last-pos) + (max first-pos last-pos))) + #t))]) + (when reset-search-anchor? + (reset-search-anchor searching-edit)) + (let-values ([(found-edit first-pos) + (send searching-edit + find-string-embedded + string + searching-direction + search-anchor + -1 #t #t #t)]) + (cond + [(= -1 first-pos) + (if wrap? + (let-values ([(found-edit pos) (send searching-edit find-string-embedded - string + string searching-direction - anchor - -1 #t #t #t)]) - (cond - [(= -1 first-pos) - (if wrap? - (let-values ([(found-edit pos) - (send searching-edit - find-string-embedded - string - searching-direction - (if (= 1 searching-direction) - 0 - (send searching-edit last-position)))]) - (if (= -1 pos) - (not-found found-edit) - (found found-edit - ((if (= searching-direction 1) - + - -) - pos - (string-length string))))) - (not-found found-edit))] - [else - (found found-edit first-pos)])))))] - [on-focus - (lambda (on?) - (when on? - (reset-anchor (get-searching-edit))) - (super-on-focus on?))] - [after-insert - (lambda args - (apply super-after-insert args) - (search #f))] - [after-delete - (lambda args - (apply super-after-delete args) - (search #f))])))] - [canvas% - (class editor-canvas% args - (inherit get-parent frame set-line-count) - (rename [super-on-set-focus on-set-focus]) - (override - [style-flags '(h-scroll)] - [on-set-focus - (lambda () - (send find-edit set-searching-frame frame) - (super-on-set-focus))]) - (sequence - (apply super-init args) - (set-line-count 2)))]) + (if (= 1 searching-direction) + 0 + (send searching-edit last-position)))]) + (if (= -1 pos) + (not-found found-edit) + (found found-edit + ((if (= searching-direction 1) + + + -) + pos + (string-length string))))) + (not-found found-edit))] + [else + (found found-edit first-pos)])))))]) + (override + [on-focus + (lambda (on?) + (when on? + (reset-search-anchor (get-searching-edit))) + (super-on-focus on?))] + [after-insert + (lambda args + (apply super-after-insert args) + (search #f))] + [after-delete + (lambda args + (apply super-after-delete args) + (search #f))]))) + + (define find-edit #f) + (define replace-edit #f) + + (define searchable-canvas% + (class editor-canvas% (parent) + (inherit get-top-level-window set-line-count) + (rename [super-on-focus on-focus]) + (override + [on-focus + (lambda (x) + (when x + (send find-edit set-searching-frame (get-top-level-window))) + (on-focus x))]) + (sequence + (super-init parent #f '(h-scroll)) + (set-line-count 2)))) + + (define (init-find/replace-edits) + (unless find-edit + (set! find-edit (make-object find-text%)) + (set! replace-edit (make-object text%)) (for-each (lambda (keymap) (send keymap chain-to-keymap keymap:search #t)) (list (send find-edit get-keymap) - (send replace-edit get-keymap))) - (mixin (-text<%>) (searchable<%>) args - (inherit active-edit active-canvas get-editor) - (rename [super-make-root-panel make-root-panel] - [super-on-activate on-activate] - [super-do-close do-close]) - (private - [super-root 'unitiaialized-super-root]) - (override - [edit-menu:find (lambda (menu evt) (search))]) - (override - [make-root-panel - (lambda (% parent) - (let* ([s-root (super-make-root-panel - vertical-panel% - parent)] - [root (make-object % s-root)]) - (set! super-root s-root) - root))]) - (override - [on-activate - (lambda (on?) - (unless hidden? - (if on? - (reset-anchor (get-text-to-search)) - (clear-highlight))) - (super-on-activate on?))]) - (public - [get-text-to-search - (lambda () - (get-editor))] - [hide-search - (opt-lambda ([startup? #f]) - (send super-root delete-child search-panel) - (clear-highlight) - (unless startup? - (send - (send (get-text-to-search) get-canvas) - focus)) - (set! hidden? #t))] - [unhide-search - (lambda () + (send replace-edit get-keymap))))) + + (define searchable-mixin + (mixin (-text<%>) (searchable<%>) args + (sequence (init-find/replace-edits)) + (inherit get-editor) + (rename [super-make-root-area-container make-root-area-container] + [super-on-activate on-activate] + [super-on-close on-close]) + (private + [super-root 'unitiaialized-super-root]) + (override + [edit-menu:find (lambda (menu evt) (search))]) + (override + [make-root-area-container + (lambda (% parent) + (let* ([s-root (super-make-root-area-container + vertical-panel% + parent)] + [root (make-object % s-root)]) + (set! super-root s-root) + root))]) + (override + [on-activate + (lambda (on?) + (unless hidden? + (if on? + (reset-search-anchor (get-text-to-search)) + (clear-search-highlight))) + (super-on-activate on?))]) + (public + [get-text-to-search + (lambda () + (get-editor))] + [hide-search + (opt-lambda ([startup? #f]) + (send super-root delete-child search-panel) + (clear-search-highlight) + (unless startup? + (send + (send (get-text-to-search) get-canvas) + focus)) + (set! hidden? #t))] + [unhide-search + (lambda () + (when hidden? (set! hidden? #f) (send super-root add-child search-panel) - (reset-anchor (get-text-to-search)))]) - (override - [do-close - (lambda () - (super-do-close) - (let ([close-canvas - (lambda (canvas edit) - (send edit remove-canvas canvas) - (send canvas set-media #f))]) - (close-canvas find-canvas find-edit) - (close-canvas replace-canvas replace-edit)) - (when (eq? this (ivar find-edit searching-frame)) - (send find-edit set-searching-frame #f)))]) - (public - [set-search-direction - (lambda (x) - (set! searching-direction x) - (send dir-radio set-selection (if (= x 1) 0 1)))] - [replace&search - (lambda () - (when (replace) - (search)))] - [replace-all - (lambda () - (let* ([replacee-edit (get-text-to-search)] - [pos (if (= searching-direction 1) - (send replacee-edit get-start-position) - (send replacee-edit get-end-position))] - [get-pos - (if (= searching-direction 1) - (ivar replacee-edit get-end-position) - (ivar replacee-edit get-start-position))] - [done? (if (= 1 searching-direction) - (lambda (x) (>= x (send replacee-edit last-position))) - (lambda (x) (<= x 0)))]) - (send* replacee-edit - (begin-edit-sequence) - (set-position pos)) - (when (search) - (send replacee-edit set-position pos) - (let loop () - (when (send find-edit search #t #f #f) - (replace) - (loop)))) - (send replacee-edit end-edit-sequence)))] - [replace - (lambda () - (let* ([search-text (send find-edit get-text)] - [replacee-edit (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))]) - (if (string=? 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)))] - [toggle-search-focus - (lambda () - (when hidden? - (unhide-search)) - (send (cond - [(send find-canvas is-focus-on?) - replace-canvas] - [(send replace-canvas is-focus-on?) - (send (get-text-to-search) get-canvas)] - [else - find-canvas]) - focus))] - [move-to-search-or-search - (lambda () - (when hidden? - (unhide-search)) - (if (or (send find-canvas is-focus-on?) - (send replace-canvas is-focus-on?)) - (search 1) - (send find-canvas focus)))] - [move-to-search-or-reverse-search - (lambda () - (when hidden? - (unhide-search)) - (if (or (send find-canvas is-focus-on?) - (send replace-canvas is-focus-on?)) - (search -1) - (send find-canvas focus)))] - [search - (opt-lambda ([direction searching-direction] [beep? #t]) - - (send find-edit set-searching-frame this) - (when hidden? - (unhide-search)) - (set-search-direction direction) - (send find-edit search #t beep?))]) - (sequence - (apply super-init args)) - (private - [search-panel (make-object horizontal-panel% super-root)] - - [left-panel (make-object vertical-panel% search-panel)] - [find-canvas (make-object canvas% left-panel)] - [replace-canvas (make-object canvas% left-panel)] - - [middle-left-panel (make-object vertical-panel% search-panel)] - [middle-middle-panel (make-object vertical-panel% search-panel)] - [middle-right-panel (make-object vertical-panel% search-panel)] - - [search-button (make-object button% - "Search" - middle-left-panel - (lambda args (search)))] - - [replace&search-button (make-object button% - "Replace && Search" - middle-middle-panel - (lambda x (replace&search)))] - [replace-button (make-object button% "Replace" middle-left-panel (lambda x (replace)))] - [replace-all-button (make-object button% - "Replace To End" - middle-middle-panel - (lambda x (replace-all)))] - - [dir-radio (make-object radio-box% - #f - (list "Forward" "Backward") - middle-right-panel - (lambda (dir-radio evt) - (let ([forward (if (= 0 (send evt get-command-int)) - 1 - -1)]) - (set-search-direction forward) - (reset-anchor (get-text-to-search)))))] - [close-button (make-object button% middle-right-panel - (lambda args (hide-search)) "Hide")] - [hidden? #f]) - (sequence - (let ([align - (lambda (x y) - (let ([m (max (send x get-width) - (send y get-width))]) - (send x user-min-width m) - (send y user-min-width m)))]) - (align search-button replace-button) - (align replace&search-button replace-all-button)) - (for-each (lambda (x) (send x major-align-center)) - (list middle-left-panel middle-middle-panel)) - (for-each (lambda (x) (send x stretchable-in-y #f)) - (list search-panel left-panel middle-left-panel middle-middle-panel middle-right-panel)) - (for-each (lambda (x) (send x stretchable-in-x #f)) - (list middle-left-panel middle-middle-panel middle-right-panel)) - (send find-canvas set-media find-edit) - (send replace-canvas set-media replace-edit) - (send find-edit add-canvas find-canvas) - (send replace-edit add-canvas replace-canvas) - (hide-search #t))))) + (reset-search-anchor (get-text-to-search))))]) + (override + [on-close + (lambda () + (super-on-close) + (let ([close-canvas + (lambda (canvas edit) + (send edit remove-canvas canvas) + (send canvas set-media #f))]) + (close-canvas find-canvas find-edit) + (close-canvas replace-canvas replace-edit)) + (when (eq? this (ivar find-edit searching-frame)) + (send find-edit set-searching-frame #f)))]) + (public + [set-search-direction + (lambda (x) + (set! searching-direction x) + (send dir-radio set-selection (if (= x 1) 0 1)))] + [replace&search + (lambda () + (when (replace) + (search)))] + [replace-all + (lambda () + (let* ([replacee-edit (get-text-to-search)] + [pos (if (= searching-direction 1) + (send replacee-edit get-start-position) + (send replacee-edit get-end-position))] + [get-pos + (if (= searching-direction 1) + (ivar replacee-edit get-end-position) + (ivar replacee-edit get-start-position))] + [done? (if (= 1 searching-direction) + (lambda (x) (>= x (send replacee-edit last-position))) + (lambda (x) (<= x 0)))]) + (send* replacee-edit + (begin-edit-sequence) + (set-position pos)) + (when (search) + (send replacee-edit set-position pos) + (let loop () + (when (send find-edit search #t #f #f) + (replace) + (loop)))) + (send replacee-edit end-edit-sequence)))] + [replace + (lambda () + (let* ([search-text (send find-edit get-text)] + [replacee-edit (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))]) + (if (string=? 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)))] + [toggle-search-focus + (lambda () + (unhide-search) + (send (cond + [(send find-canvas is-focus-on?) + replace-canvas] + [(send replace-canvas is-focus-on?) + (send (get-text-to-search) get-canvas)] + [else + find-canvas]) + focus))] + [move-to-search-or-search + (lambda () + (unhide-search) + (if (or (send find-canvas is-focus-on?) + (send replace-canvas is-focus-on?)) + (search 1) + (send find-canvas focus)))] + [move-to-search-or-reverse-search + (lambda () + (unhide-search) + (if (or (send find-canvas is-focus-on?) + (send replace-canvas is-focus-on?)) + (search -1) + (send find-canvas focus)))] + [search + (opt-lambda ([direction searching-direction] [beep? #t]) + + (send find-edit set-searching-frame this) + (unhide-search) + (set-search-direction direction) + (send find-edit search #t beep?))]) + (sequence + (apply super-init args)) + (private + [search-panel (make-object horizontal-panel% super-root)] + + [left-panel (make-object vertical-panel% search-panel)] + [find-canvas (make-object searchable-canvas% left-panel)] + [replace-canvas (make-object searchable-canvas% left-panel)] + + [middle-left-panel (make-object vertical-panel% search-panel)] + [middle-middle-panel (make-object vertical-panel% search-panel)] + [middle-right-panel (make-object vertical-panel% search-panel)] + + [search-button (make-object button% + "Search" + middle-left-panel + (lambda args (search)))] + + [replace&search-button (make-object button% + "Replace && Search" + middle-middle-panel + (lambda x (replace&search)))] + [replace-button (make-object button% "Replace" middle-left-panel (lambda x (replace)))] + [replace-all-button (make-object button% + "Replace To End" + middle-middle-panel + (lambda x (replace-all)))] + + [dir-radio (make-object radio-box% + #f + (list "Forward" "Backward") + middle-right-panel + (lambda (dir-radio evt) + (let ([forward (if (= 0 (send evt get-command-int)) + 1 + -1)]) + (set-search-direction forward) + (reset-search-anchor (get-text-to-search)))))] + [close-button (make-object button% middle-right-panel + (lambda args (hide-search)) "Hide")] + [hidden? #f]) + (sequence + (let ([align + (lambda (x y) + (let ([m (max (send x get-width) + (send y get-width))]) + (send x user-min-width m) + (send y user-min-width m)))]) + (align search-button replace-button) + (align replace&search-button replace-all-button)) + (for-each (lambda (x) (send x major-align-center)) + (list middle-left-panel middle-middle-panel)) + (for-each (lambda (x) (send x stretchable-in-y #f)) + (list search-panel left-panel middle-left-panel middle-middle-panel middle-right-panel)) + (for-each (lambda (x) (send x stretchable-in-x #f)) + (list middle-left-panel middle-middle-panel middle-right-panel)) + (send find-canvas set-media find-edit) + (send replace-canvas set-media replace-edit) + (send find-edit add-canvas find-canvas) + (send replace-edit add-canvas replace-canvas) + (hide-search #t)))) - (define info<%> (interface (editor<%>) + (define info<%> (interface (-editor<%>) determine-width - get-info-edit + get-info-editor lock-status-changed update-info - info-panel)) - (define make-info% - (let* ([time-edit (make-object text%)] - [time-semaphore (make-semaphore 1)] - [wide-time "00:00pm"] - [_ (send time-edit lock #t)] - [update-time - (lambda () - (dynamic-wind - (lambda () - (semaphore-wait time-semaphore) - (send time-edit lock #f)) - (lambda () - (send* time-edit - (erase) - (insert - (let* ([date (seconds->date - (current-seconds))] - [hours (date-hour date)] - [minutes (date-minute date)]) - (format "~a:~a~a~a" - (cond - [(= hours 0) 12] - [(<= hours 12) hours] - [else (- hours 12)]) - (quotient minutes 10) - (modulo minutes 10) - (if (< hours 12) "am" "pm")))))) - (lambda () - (send time-edit lock #t) - (semaphore-post time-semaphore))))] - [time-thread - (thread - (rec loop - (lambda () - (update-time) - (sleep 30) - (loop))))]) - (mixin (-editor<%>) (info<%>) args - (rename [super-make-root-panel make-root-panel]) - (private - [rest-panel 'uninitialized-root] - [super-root 'uninitialized-super-root]) - (override - [make-root-panel - (lambda (% parent) - (let* ([s-root (super-make-root-panel - vertical-panel% - parent)] - [r-root (make-object % s-root)]) - (set! super-root s-root) - (set! rest-panel r-root) - r-root))]) - - (public - [determine-width - (let ([magic-space 25]) - (lambda (string canvas edit) - (send edit set-autowrap-bitmap #f) - (send canvas call-as-primary-owner - (lambda () - (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 - (+ magic-space (- (unbox rb) (unbox lb)))))))))]) - - (rename [super-do-close do-close]) - (private - [close-panel-callback - (preferences:add-callback - 'framework:show-status-line - (lambda (p v) - (if v - (register-gc-blit) - (unregister-collecting-blit gc-canvas)) - (send super-root change-children - (lambda (l) - (if v - (list rest-panel info-panel) - (list rest-panel))))))]) - (override - [do-close - (lambda () - (super-do-close) - (send time-canvas set-media #f) - (unregister-collecting-blit gc-canvas) - (close-panel-callback))]) - - (inherit get-editor) - (public - [get-info-edit - (lambda () - (and (procedure? get-editor) - (get-editor)))]) - - (public - [lock-status-changed - (let ([icon-currently-locked? #f]) - (lambda () - (let ([info-edit (get-info-edit)]) - (when info-edit - (let ([locked-now? (ivar info-edit locked?)]) - (unless (eq? locked-now? icon-currently-locked?) - (set! icon-currently-locked? locked-now?) - (let ([label - (if locked-now? - (cons (icon:get-lock-mdc) - (icon:get-lock-bitmap)) - (cons (icon:get-unlock-mdc) - (icon:get-unlock-bitmap)))]) - (send lock-message - set-label - (if (send (car label) ok?) - label - (if locked-now? "Locked" "Unlocked"))))))))))]) - (public - [update-info - (lambda () - (lock-status-changed))]) - (sequence - (apply super-init args)) - - (public - [info-panel (make-object horizontal-panel% - super-root)]) - (private - [lock-message (make-object message% - (let ([b (icon:get-unlock-bitmap)]) - (if (send b ok?) - (cons (icon:get-unlock-mdc) b) - "Unlocked")) - info-panel - '(border))] - [time-canvas (make-object editor-canvas% info-panel)] - [_ (send time-canvas set-line-count 1)] - [gc-canvas (make-object canvas% info-panel '(border))] - [register-gc-blit - (lambda () - (let ([mdc (icon:get-gc-on-dc)]) - (when (send mdc ok?) - (register-collecting-blit gc-canvas - 0 0 - (icon:get-gc-width) - (icon:get-gc-height) - (icon:get-gc-on-dc) - (icon:get-gc-off-dc)))))]) - - (sequence - (unless (preferences:get 'framework:show-status-line) - (send super-root change-children - (lambda (l) - (list rest-panel)))) - (register-gc-blit) - - (let ([bw (box 0)] - [bh (box 0)] - [gc-width (icon:get-gc-width)] - [gc-height (icon:get-gc-height)]) - (send* gc-canvas - (set-size 0 0 gc-width gc-height) - (get-client-size bw bh)) - (send* gc-canvas - (user-min-client-width gc-width) - (user-min-client-height gc-height) - (stretchable-in-x #f) - (stretchable-in-y #f))) - (send* info-panel - (major-align-right) - (stretchable-in-y #f) - (spacing 3) - (border 3)) - (send* time-canvas - (set-media time-edit) - (stretchable-in-x #f)) - (semaphore-wait time-semaphore) - (determine-width wide-time time-canvas time-edit) - (semaphore-post time-semaphore) - (update-time))))) + get-info-panel)) - (define edit-info<%> (interface (info<%>) - overwrite-status-changed - anchor-status-changed - edit-position-changed-offset - edit-position-changed)) - (define make-edit-info% - (mixin (info<%>) (edit-info<%>) args - (inherit get-info-edit) - (rename [super-do-close do-close]) + (define time-edit (make-object text%)) + (define time-semaphore (make-semaphore 1)) + (define wide-time "00:00pm") + (send time-edit lock #t) + (define update-time + (lambda () + (dynamic-wind + (lambda () + (semaphore-wait time-semaphore) + (send time-edit lock #f)) + (lambda () + (send* time-edit + (erase) + (insert + (let* ([date (seconds->date + (current-seconds))] + [hours (date-hour date)] + [minutes (date-minute date)]) + (format "~a:~a~a~a" + (cond + [(= hours 0) 12] + [(<= hours 12) hours] + [else (- hours 12)]) + (quotient minutes 10) + (modulo minutes 10) + (if (< hours 12) "am" "pm")))))) + (lambda () + (send time-edit lock #t) + (semaphore-post time-semaphore))))) + (define time-thread + (thread + (rec loop + (lambda () + (update-time) + (sleep 30) + (loop))))) + + (define info-mixin + (mixin (-editor<%>) (info<%>) args + (rename [super-make-root-area-container make-root-area-container]) (private - [remove-pref-callback - (preferences:add-callback - 'framework:line-offsets - (lambda (p v) - (edit-position-changed-offset v) - #t))]) + [rest-panel 'uninitialized-root] + [super-root 'uninitialized-super-root]) (override - [do-close - (lambda () - (super-do-close) - (remove-pref-callback))]) + [make-root-area-container + (lambda (% 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))]) (public - [overwrite-status-changed - (let ([last-state? #f]) + [determine-width + (let ([magic-space 25]) + (lambda (string canvas edit) + (send edit set-autowrap-bitmap #f) + (send canvas call-as-primary-owner + (lambda () + (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 + (+ magic-space (- (unbox rb) (unbox lb)))))))))]) + + (rename [super-on-close on-close]) + (private + [close-panel-callback + (preferences:add-callback + 'framework:show-status-line + (lambda (p v) + (if v + (register-gc-blit) + (unregister-collecting-blit gc-canvas)) + (send super-root change-children + (lambda (l) + (if v + (list rest-panel (get-info-panel)) + (list rest-panel))))))]) + (override + [on-close + (lambda () + (super-on-close) + (send time-canvas set-media #f) + (unregister-collecting-blit gc-canvas) + (close-panel-callback))]) + + (inherit get-editor) + (public + [get-info-editor + (lambda () + (and (procedure? get-editor) + (get-editor)))]) + + (public + [lock-status-changed + (let ([icon-currently-locked? #f]) (lambda () - (let ([info-edit (get-info-edit)]) + (let ([info-edit (get-info-editor)]) (when info-edit - (let ([overwrite-now? (send info-edit get-overwrite-mode)]) - (unless (eq? overwrite-now? last-state?) - (send overwrite-message - show - overwrite-now?) - (set! last-state? overwrite-now?)))))))] - [anchor-status-changed - (let ([last-state? #f]) + (let ([locked-now? (ivar info-edit locked?)]) + (unless (eq? locked-now? icon-currently-locked?) + (set! icon-currently-locked? locked-now?) + (let ([label + (if locked-now? + (cons (icon:get-lock-bdc) + (icon:get-lock-bitmap)) + (cons (icon:get-unlock-bdc) + (icon:get-unlock-bitmap)))]) + (send lock-message + set-label + (if (send (car label) ok?) + label + (if locked-now? "Locked" "Unlocked"))))))))))]) + (public + [update-info + (lambda () + (lock-status-changed))]) + (sequence + (apply super-init args)) + + (public + [get-info-panel + (let ([info-panel (make-object horizontal-panel% + super-root)]) (lambda () - (let ([info-edit (get-info-edit)]) - (when info-edit - (let ([anchor-now? (send info-edit get-anchor)]) - (unless (eq? anchor-now? last-state?) - (send anchor-message - show - anchor-now?) - (set! last-state? anchor-now?)))))))] + info-panel))]) + (private + [lock-message (make-object message% + (let ([b (icon:get-unlock-bitmap)]) + (if (send b ok?) + (cons (icon:get-unlock-bdc) b) + "Unlocked")) + (get-info-panel) + '(border))] + [time-canvas (make-object editor-canvas% (get-info-panel))] + [_ (send time-canvas set-line-count 1)] + [gc-canvas (make-object canvas% (get-info-panel) '(border))] + [register-gc-blit + (lambda () + (let ([bdc (icon:get-gc-on-dc)]) + (when (send bdc ok?) + (register-collecting-blit gc-canvas + 0 0 + (icon:get-gc-width) + (icon:get-gc-height) + (icon:get-gc-on-dc) + (icon:get-gc-off-dc)))))]) + + (sequence + (unless (preferences:get 'framework:show-status-line) + (send super-root change-children + (lambda (l) + (list rest-panel)))) + (register-gc-blit) - [edit-position-changed-offset + (let ([bw (box 0)] + [bh (box 0)] + [gc-width (icon:get-gc-width)] + [gc-height (icon:get-gc-height)]) + (send* gc-canvas + (set-size 0 0 gc-width gc-height) + (get-client-size bw bh)) + (send* gc-canvas + (user-min-client-width gc-width) + (user-min-client-height gc-height) + (stretchable-in-x #f) + (stretchable-in-y #f))) + (send* (get-info-panel) + (major-align-right) + (stretchable-in-y #f) + (spacing 3) + (border 3)) + (send* time-canvas + (set-media time-edit) + (stretchable-in-x #f)) + (semaphore-wait time-semaphore) + (determine-width wide-time time-canvas time-edit) + (semaphore-post time-semaphore) + (update-time)))) + + (define editor-info<%> (interface (info<%>) + overwrite-status-changed + anchor-status-changed + editor-position-changed)) + (define editor-info-mixin + (mixin (info<%>) (editor-info<%>) args + (inherit get-info-editor) + (rename [super-on-close on-close]) + (private + [remove-pref-callback + (let ([one + (preferences:add-callback + 'framework:line-offsets + (lambda (p v) + (editor-position-changed-offset/numbers + v + (preferences:get 'framework:display-line-numbers)) + #t))] + [two + (preferences:add-callback + 'framework:display-line-numbers + (lambda (p v) + (editor-position-changed-offset/numbers + (preferences:get 'framework:line-offsets) + v) + #t))]) + (lambda () + (one) + (two)))]) + (override + [on-close + (lambda () + (super-on-close) + (remove-pref-callback))]) + + (private + [editor-position-changed-offset/numbers (let ([last-start #f] [last-end #f]) - (lambda (offset?) - (let* ([edit (get-info-edit)] + (lambda (offset? line-numbers?) + (let* ([edit (get-info-editor)] [make-one (lambda (pos) (let* ([line (send edit position-line pos)] [line-start (send edit line-start-position line)] [char (- pos line-start)]) - (if (preferences:get 'framework:display-line-numbers) + (if line-numbers? (format "~a:~a" (if offset? (add1 line) @@ -1153,11 +887,35 @@ (string-append (make-one start) "-" (make-one end)))) - (lock #t)))))))))] - [edit-position-changed + (lock #t)))))))))]) + (public + [anchor-status-changed + (let ([last-state? #f]) + (lambda () + (let ([info-edit (get-info-editor)]) + (when info-edit + (let ([anchor-now? (send info-edit get-anchor)]) + (unless (eq? anchor-now? last-state?) + (send anchor-message + show + anchor-now?) + (set! last-state? anchor-now?)))))))] + [editor-position-changed (lambda () - (edit-position-changed-offset - (preferences:get 'framework:line-offsets)))]) + (editor-position-changed-offset/numbers + (preferences:get 'framework:line-offsets) + (preferences:get 'framework:display-line-numbers)))] + [overwrite-status-changed + (let ([last-state? #f]) + (lambda () + (let ([info-edit (get-info-editor)]) + (when info-edit + (let ([overwrite-now? (send info-edit get-overwrite-mode)]) + (unless (eq? overwrite-now? last-state?) + (send overwrite-message + show + overwrite-now?) + (set! last-state? overwrite-now?)))))))]) (rename [super-update-info update-info]) (override [update-info @@ -1165,25 +923,25 @@ (super-update-info) (overwrite-status-changed) (anchor-status-changed) - (edit-position-changed))]) + (editor-position-changed))]) (sequence (apply super-init args)) - (inherit info-panel) + (inherit get-info-panel) (private [anchor-message (make-object message% (let ([b (icon:get-anchor-bitmap)]) (if (send b ok?) - (cons (icon:get-anchor-mdc) b) + (cons (icon:get-anchor-bdc) b) "Anchor")) - info-panel '(border))] + (get-info-panel) '(border))] [overwrite-message (make-object message% "Overwrite" - info-panel + (get-info-panel) '(border))] - [position-canvas (make-object editor-canvas% info-panel)] + [position-canvas (make-object editor-canvas% (get-info-panel))] [_2 (send position-canvas set-line-count 1)] [position-edit (make-object text%)]) @@ -1192,7 +950,7 @@ (let ([move-front (lambda (x l) (cons x (mzlib:function:remq x l)))]) - (send info-panel change-children + (send (get-info-panel) change-children (lambda (l) (move-front anchor-message @@ -1209,16 +967,16 @@ (determine-width "0000:000-0000:000" position-canvas position-edit) - (edit-position-changed) + (editor-position-changed) (send position-edit lock #t)))) (define file<%> (interface (-editor<%>))) - (define make-file% - (mixin (editor<%>) (file<%>) args + (define file-mixin + (mixin (-editor<%>) (file<%>) args (inherit get-editor) (rename [super-can-close? can-close?]) (override - [on-close? + [can-close? (lambda () (let* ([edit (get-editor)] [user-allowed-or-not-modified @@ -1237,17 +995,17 @@ (super-can-close?))))]) (sequence (apply super-init args)))) - (define empty% (make-basic% frame%)) - (define standard-menus% (make-standard-menus% empty%)) - (define editor% (make-editor% standard-menus%)) + (define empty% (basic-mixin frame%)) + (define standard-menus% (standard-menus-mixin empty%)) + (define editor% (editor-mixin standard-menus%)) - (define -text% (make-text% editor%)) - (define searchable% (make-searchable% editor%)) - (define text-info% (make-info% searchable%)) - (define text-info-file% (make-file% text-info%)) + (define -text% (text-mixin editor%)) + (define searchable% (searchable-mixin -text%)) + (define text-info% (info-mixin searchable%)) + (define text-info-file% (file-mixin text-info%)) - (define -pasteboard% (make-pasteboard% editor%)) - (define pasteboard-info% (make-info% -pasteboard%)) - (define pasteboard-info-file% (make-file% pasteboard-info%))) + (define -pasteboard% (pasteboard-mixin editor%)) + (define pasteboard-info% (info-mixin -pasteboard%)) + (define pasteboard-info-file% (file-mixin pasteboard-info%))) \ No newline at end of file diff --git a/collects/framework/group.ss b/collects/framework/group.ss index 054cd80c..2ae4c704 100644 --- a/collects/framework/group.ss +++ b/collects/framework/group.ss @@ -1,199 +1,200 @@ -(unit/sig framework:group^ +(dunit/sig framework:group^ (import mred-interfaces^ [exit : framework:exit^] [frame : framework:frame^] [mzlib:function : mzlib:function^] [mzlib:file : mzlib:file^]) + + (define-struct frame (frame id)) (define % - (let-struct frame (frame id) - (class null () - (private - [active-frame #f] - [frame-counter 0] - [frames null] - [todo-to-new-frames void] - [empty-close-down (lambda () (void))] - [empty-test (lambda () #t)] - - [windows-menus null]) + (class null () + (private + [active-frame #f] + [frame-counter 0] + [frames null] + [todo-to-new-frames void] + [empty-close-down (lambda () (void))] + [empty-test (lambda () #t)] - (private - [get-windows-menu - (lambda (frame) - (and (ivar-in-class? 'windows-menu (object-class frame)) - (ivar frame windows-menu)))] - [insert-windows-menu - (lambda (frame) - (let ([menu (get-windows-menu frame)]) - (when menu - (set! windows-menus (cons (list menu) windows-menus)))))] - [remove-windows-menu - (lambda (frame) - (let* ([menu (get-windows-menu frame)]) - (set! windows-menus - (mzlib:function:remove - menu - windows-menus - (lambda (x y) - (eq? x (car y)))))))] + [windows-menus null]) + + (private + [get-windows-menu + (lambda (frame) + (and (ivar-in-class? 'windows-menu (object-class frame)) + (ivar frame windows-menu)))] + [insert-windows-menu + (lambda (frame) + (let ([menu (get-windows-menu frame)]) + (when menu + (set! windows-menus (cons (list menu) windows-menus)))))] + [remove-windows-menu + (lambda (frame) + (let* ([menu (get-windows-menu frame)]) + (set! windows-menus + (mzlib:function:remove + menu + windows-menus + (lambda (x y) + (eq? x (car y)))))))] - [update-windows-menus - (lambda () - (let* ([windows (length windows-menus)] - [get-name (lambda (frame) (send (frame-frame frame) get-label))] - [sorted-frames - (mzlib:function:quicksort - frames - (lambda (f1 f2) - (string-ci<=? (get-name f1) - (get-name f2))))]) - (set! - windows-menus - (map - (lambda (menu-list) - (let ([menu (car menu-list)] - [old-ids (cdr menu-list)]) - (for-each (lambda (id) (send menu delete id)) - old-ids) - (let ([new-ids - (map - (lambda (frame) - (let ([frame (frame-frame frame)] - [default-name "Untitled"]) - (send menu append-item - (let ([label (send frame get-label)]) - (if (string=? label "") - (if (ivar-in-class? 'get-entire-label (object-class frame)) - (let ([label (send frame get-entire-label)]) - (if (string=? label "") - default-name - label)) - default-name) - label)) - (lambda () - (send frame show #t))))) - sorted-frames)]) - (cons menu new-ids)))) - windows-menus))))]) - - (private - [update-close-menu-item-state - (lambda () - (let* ([set-close-menu-item-state! - (lambda (frame state) - (when (is-a? frame frame:standard-menus<%>) - (let ([close-menu-item (ivar frame file-menu:close-menu)]) - (when close-menu-item - (send close-menu-item enable state)))))]) + [update-windows-menus + (lambda () + (let* ([windows (length windows-menus)] + [get-name (lambda (frame) (send (frame-frame frame) get-label))] + [sorted-frames + (mzlib:function:quicksort + frames + (lambda (f1 f2) + (string-ci<=? (get-name f1) + (get-name f2))))]) + (set! + windows-menus + (map + (lambda (menu-list) + (let ([menu (car menu-list)] + [old-ids (cdr menu-list)]) + (for-each (lambda (id) (send menu delete id)) + old-ids) + (let ([new-ids + (map + (lambda (frame) + (let ([frame (frame-frame frame)] + [default-name "Untitled"]) + (send menu append-item + (let ([label (send frame get-label)]) + (if (string=? label "") + (if (ivar-in-class? 'get-entire-label (object-class frame)) + (let ([label (send frame get-entire-label)]) + (if (string=? label "") + default-name + label)) + default-name) + label)) + (lambda () + (send frame show #t))))) + sorted-frames)]) + (cons menu new-ids)))) + windows-menus))))]) + + (private + [update-close-menu-item-state + (lambda () + (let* ([set-close-menu-item-state! + (lambda (frame state) + (when (is-a? frame frame:standard-menus<%>) + (let ([close-menu-item (ivar frame file-menu: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 (lambda (a-frame) (set-close-menu-item-state! a-frame #t)) frames))))]) - (public - [set-empty-callbacks - (lambda (test close-down) - (set! empty-test test) - (set! empty-close-down close-down))] - [get-frames (lambda () (map frame-frame frames))] - - [frame-label-changed - (lambda (frame) - (when (member frame (map frame-frame frames)) - (update-windows-menus)))] - - [for-each-frame - (lambda (f) - (for-each (lambda (x) (f (frame-frame x))) frames) - (set! todo-to-new-frames - (let ([old todo-to-new-frames]) - (lambda (frame) (old frame) (f frame)))))] - [get-active-frame - (lambda () - (cond - [active-frame active-frame] - [(null? frames) #f] - [else (frame-frame (car frames))]))] - [set-active-frame - (lambda (f) - (set! active-frame f))] - [insert-frame - (lambda (f) - (set! frame-counter (add1 frame-counter)) - (let ([new-frames (cons (make-frame f frame-counter) - frames)]) - (set! frames new-frames) - (update-close-menu-item-state) - (insert-windows-menu f) - (update-windows-menus)) - (todo-to-new-frames f))] - - [can-remove-frame? - (opt-lambda (f) - (let ([new-frames - (mzlib:function:remove - f frames - (lambda (f fr) (eq? f (frame-frame fr))))]) - (if (null? new-frames) - (empty-test) - #t)))] - [remove-frame - (opt-lambda (f) - (when (eq? f active-frame) - (set! active-frame #f)) - (let ([new-frames - (mzlib:function:remove - f frames - (lambda (f fr) (eq? f (frame-frame fr))))]) - (set! frames new-frames) - (update-close-menu-item-state) - (remove-windows-menu f) - (update-windows-menus) - (when (null? frames) - (empty-close-down))))] - [clear - (lambda () - (and (empty-test) - (begin (set! frames null) - (empty-close-down) - #t)))] - [close-all - (lambda () - (let/ec escape - (for-each (lambda (f) - (let ([frame (frame-frame f)]) - (if (send frame on-close) - (send frame show #f) - (escape #f)))) - frames) - #t))] - [locate-file - (lambda (name) - (let* ([normalized - ;; allow for the possiblity of filenames that are urls - (with-handlers ([(lambda (x) #t) - (lambda (x) name)]) - (mzlib:file:normalize-path name))] - [test-frame - (lambda (frame) - (and (ivar-in-class? 'get-edit (object-class frame)) - (let* ([edit (send frame get-edit)] - [filename (send edit get-filename)]) - (and (ivar edit editing-this-file?) - (string? filename) - (string=? normalized - (with-handlers ([(lambda (x) #t) - (lambda (x) filename)]) - (mzlib:file:normalize-path - filename)))))))]) - (let loop ([frames frames]) - (cond - [(null? frames) #f] - [else - (let* ([frame (frame-frame (car frames))]) - (if (test-frame frame) - frame - (loop (cdr frames))))]))))])))) + (public + [set-empty-callbacks + (lambda (test close-down) + (set! empty-test test) + (set! empty-close-down close-down))] + [get-frames (lambda () (map frame-frame frames))] + + [frame-label-changed + (lambda (frame) + (when (member frame (map frame-frame frames)) + (update-windows-menus)))] + + [for-each-frame + (lambda (f) + (for-each (lambda (x) (f (frame-frame x))) frames) + (set! todo-to-new-frames + (let ([old todo-to-new-frames]) + (lambda (frame) (old frame) (f frame)))))] + [get-active-frame + (lambda () + (cond + [active-frame active-frame] + [(null? frames) #f] + [else (frame-frame (car frames))]))] + [set-active-frame + (lambda (f) + (set! active-frame f))] + [insert-frame + (lambda (f) + (set! frame-counter (add1 frame-counter)) + (let ([new-frames (cons (make-frame f frame-counter) + frames)]) + (set! frames new-frames) + (update-close-menu-item-state) + (insert-windows-menu f) + (update-windows-menus)) + (todo-to-new-frames f))] + + [can-remove-frame? + (opt-lambda (f) + (let ([new-frames + (mzlib:function:remove + f frames + (lambda (f fr) (eq? f (frame-frame fr))))]) + (if (null? new-frames) + (empty-test) + #t)))] + [remove-frame + (opt-lambda (f) + (when (eq? f active-frame) + (set! active-frame #f)) + (let ([new-frames + (mzlib:function:remove + f frames + (lambda (f fr) (eq? f (frame-frame fr))))]) + (set! frames new-frames) + (update-close-menu-item-state) + (remove-windows-menu f) + (update-windows-menus) + (when (null? frames) + (empty-close-down))))] + [clear + (lambda () + (and (empty-test) + (begin (set! frames null) + (empty-close-down) + #t)))] + [close-all + (lambda () + (let/ec escape + (for-each (lambda (f) + (let ([frame (frame-frame f)]) + (if (send frame on-close) + (send frame show #f) + (escape #f)))) + frames) + #t))] + [locate-file + (lambda (name) + (let* ([normalized + ;; allow for the possiblity of filenames that are urls + (with-handlers ([(lambda (x) #t) + (lambda (x) name)]) + (mzlib:file:normalize-path name))] + [test-frame + (lambda (frame) + (and (ivar-in-class? 'get-edit (object-class frame)) + (let* ([edit (send frame get-edit)] + [filename (send edit get-filename)]) + (and (send edit editing-this-file?) + (string? filename) + (string=? normalized + (with-handlers ([(lambda (x) #t) + (lambda (x) filename)]) + (mzlib:file:normalize-path + filename)))))))]) + (let loop ([frames frames]) + (cond + [(null? frames) #f] + [else + (let* ([frame (frame-frame (car frames))]) + (if (test-frame frame) + frame + (loop (cdr frames))))]))))]))) (define the-frame-group (make-object %))) \ No newline at end of file diff --git a/collects/framework/guiutils.ss b/collects/framework/guiutils.ss index 838f499e..7cf9f648 100644 --- a/collects/framework/guiutils.ss +++ b/collects/framework/guiutils.ss @@ -1,4 +1,4 @@ -(unit/sig framework:gui-utils^ +(dunit/sig framework:gui-utils^ (import mred-interfaces^) (define cursor-delay diff --git a/collects/framework/handler.ss b/collects/framework/handler.ss index 6440778b..8fa801ac 100644 --- a/collects/framework/handler.ss +++ b/collects/framework/handler.ss @@ -1,4 +1,4 @@ -(unit/sig framework:handler^ +(dunit/sig framework:handler^ (import mred-interfaces^ [gui-utils : framework:gui-utils^] [finder : framework:finder^] diff --git a/collects/framework/icon.ss b/collects/framework/icon.ss index 1e1420d4..43f06c3a 100644 --- a/collects/framework/icon.ss +++ b/collects/framework/icon.ss @@ -1,4 +1,4 @@ -(unit/sig framework:icon^ +(dunit/sig framework:icon^ (import mred-interfaces^) (define icon-path @@ -16,16 +16,16 @@ (begin (set! bitmap (make-object % p type)) bitmap))))) - (define (load-bitmap/mdc % name type) + (define (load-bitmap/bdc % name type) (let* ([p (build-path icon-path name)] [bitmap #f] - [memory-dc #f] + [bitmap-dc #f] [force (lambda () (set! bitmap (make-object % p type)) - (set! memory-dc (make-object memory-dc%)) + (set! bitmap-dc (make-object bitmap-dc%)) (when (send bitmap ok?) - (send memory-dc select-object bitmap)))]) + (send bitmap-dc select-object bitmap)))]) (unless (file-exists? p) (fprintf (current-error-port) "WARNING: couldn't find ~a~n" p)) (values @@ -34,16 +34,16 @@ (begin (force) bitmap))) (lambda () - (or memory-dc + (or bitmap-dc (begin (force) - memory-dc)))))) + bitmap-dc)))))) - (define-values (get-anchor-bitmap get-anchor-mdc) - (load-bitmap/mdc bitmap% "anchor.gif" 'gif)) - (define-values (get-lock-bitmap get-lock-mdc) - (load-bitmap/mdc bitmap% "lock.gif" 'gif)) - (define-values (get-unlock-bitmap get-unlock-mdc) - (load-bitmap/mdc bitmap% "unlock.gif" 'gif)) + (define-values (get-anchor-bitmap get-anchor-bdc) + (load-bitmap/bdc bitmap% "anchor.gif" 'gif)) + (define-values (get-lock-bitmap get-lock-bdc) + (load-bitmap/bdc bitmap% "lock.gif" 'gif)) + (define-values (get-unlock-bitmap get-unlock-bdc) + (load-bitmap/bdc bitmap% "unlock.gif" 'gif)) (define get-autowrap-bitmap (load-icon bitmap% "return.xbm" 'xbm)) (define get-paren-highlight-bitmap (load-icon bitmap% "paren.xbm" 'xbm)) @@ -57,7 +57,7 @@ (lambda () (or icon (begin - (set! icon (make-object icon% p 'xbm)) + (set! icon (make-object bitmap% p 'xbm)) icon))))) (define-values (get-gc-on-dc get-gc-width get-gc-height) @@ -65,14 +65,14 @@ "recycle.gif" 'gif)] [bitmap #f] - [mdc #f] + [bdc #f] [fetch (lambda () - (unless mdc - (set! mdc (make-object memory-dc%)) + (unless bdc + (set! bdc (make-object bitmap-dc%)) (set! bitmap (get-bitmap)) - (send mdc select-object bitmap)))]) - (values (lambda () (fetch) mdc) + (send bdc select-object bitmap)))]) + (values (lambda () (fetch) bdc) (lambda () (fetch) (if (send bitmap ok?) (send bitmap get-width) 10)) @@ -81,15 +81,15 @@ 10))))) (define get-gc-off-dc - (let ([mdc #f]) + (let ([bdc #f]) (lambda () - (if mdc - mdc + (if bdc + bdc (begin - (set! mdc (make-object memory-dc%)) - (send mdc select-object + (set! bdc (make-object bitmap-dc%)) + (send bdc select-object (make-object bitmap% (get-gc-width) (get-gc-height))) - (send mdc clear) - mdc)))))) + (send bdc clear) + bdc)))))) diff --git a/collects/framework/keys.ss b/collects/framework/keys.ss index a6f368c4..6e37361d 100644 --- a/collects/framework/keys.ss +++ b/collects/framework/keys.ss @@ -1,4 +1,4 @@ -(unit/sig framework:keymap^ +(dunit/sig framework:keymap^ (import mred-interfaces^ [preferences : framework:preferences^] [finder : framework:finder^] diff --git a/collects/framework/main.ss b/collects/framework/main.ss index 4080b3df..55a94ec7 100644 --- a/collects/framework/main.ss +++ b/collects/framework/main.ss @@ -1,4 +1,4 @@ -(unit/sig () +(dunit/sig framework:main^ (import mred-interfaces^ [preferences : framework:preferences^] [exit : framework:exit^] @@ -16,14 +16,10 @@ (preferences:set-default 'framework:show-status-line #t boolean?) (preferences:set-default 'framework:line-offsets #t boolean?) - - - - (preferences:set 'framework:print-output-mode - 'standard - (lambda (x) (or (eq? x 'standard) (eq? x 'postscript)))) - - + (preferences:set-default + 'framework:print-output-mode + 'standard + (lambda (x) (or (eq? x 'standard) (eq? x 'postscript)))) (preferences:set-default 'framework:highlight-parens #t boolean?) (preferences:set-default 'framework:fixup-parens #t boolean?) @@ -75,14 +71,15 @@ (preferences:set-default 'framework:delete-forward? (not (eq? (system-type) 'unix)) boolean?) - (preferences:set 'framework:show-periods-in-dirlist #f boolean?) - (preferences:set 'framework:file-dialogs - (if (eq? (system-type) 'unix) - 'common - 'std) - (lambda (x) - (or (eq? x 'common) - (eq? x 'std)))) + (preferences:set-default 'framework:show-periods-in-dirlist #f boolean?) + (preferences:set-default + 'framework:file-dialogs + (if (eq? (system-type) 'unix) + 'common + 'std) + (lambda (x) + (or (eq? x 'common) + (eq? x 'std)))) (preferences:add-panel "Indenting" diff --git a/collects/framework/panel.ss b/collects/framework/panel.ss index 5026e34b..afd6fba4 100644 --- a/collects/framework/panel.ss +++ b/collects/framework/panel.ss @@ -1,24 +1,26 @@ -(unit/sig framework:panel^ +(dunit/sig framework:panel^ (import mred-interfaces^ [mzlib:function : mzlib:function^]) - (define single<%> (interface (panel%))) - (define make-single% + (rename [-editor<%> editor<%>]) + + (define single<%> (interface (panel<%>))) + (define single-mixin (mixin (panel<%>) (single<%>) args (sequence (apply super-init args)))) - (define single% vertical-panel%) + (define single% (single-mixin vertical-panel%)) - (define edit<%> + (define -editor<%> (interface () get-canvas% collapse split)) - (define make-edit% - (mixin (panel<%>) (edit<%>) args + (define editor-mixin + (mixin (panel<%>) (-editor<%>) args (rename [super-change-children change-children]) - (inherit get-parent change-children children) + (inherit get-parent change-children get-children) (public [get-canvas% (lambda () editor-canvas%)]) (private [split-edits null]) @@ -30,26 +32,27 @@ (letrec ([helper (lambda (canvas/panel) (if (eq? canvas/panel this) - (begin (cond - [(and (= (length children) 1) - (eq? canvas (car children))) - (void)] - [(member canvas children) - (change-children (lambda (l) (list canvas)))] - [else - (change-children - (lambda (l) - (let ([c (make-object (object-class canvas) this)]) - (send c set-media media) - (list c))))]) + (let ([children (get-children)]) + (cond + [(and (= (length children) 1) + (eq? canvas (car children))) + (void)] + [(member canvas children) + (change-children (lambda (l) (list canvas)))] + [else + (change-children + (lambda (l) + (let ([c (make-object (object-class canvas) this)]) + (send c set-media media) + (list c))))]) (bell)) (let* ([parent (send canvas/panel get-parent)] - [parents-children (ivar parent children)] + [parents-children (send parent get-children)] [num-children (length parents-children)]) (if (<= num-children 1) (helper parent) (begin (send parent delete-child canvas/panel) - (send (car (ivar parent children)) focus))))))]) + (send (car (send parent get-children)) focus))))))]) (send media remove-canvas canvas) (helper canvas)) (bell))))] @@ -87,7 +90,7 @@ (send* right-split (set-media media))))]) (sequence (apply super-init args)))) - (define horizontal-edit% - (make-edit% horizontal-panel%)) - (define vertical-edit% - (make-edit% vertical-panel%))) \ No newline at end of file + (define horizontal-editor% + (editor-mixin horizontal-panel%)) + (define vertical-editor% + (editor-mixin vertical-panel%))) \ No newline at end of file