diff --git a/collects/framework/app.ss b/collects/framework/app.ss index 222c5a15..b9a30ccd 100644 --- a/collects/framework/app.ss +++ b/collects/framework/app.ss @@ -1,4 +1,4 @@ -(unit/sig mred:application^ +(unit/sig framework:application^ (import) (define current-app-name (make-parameter diff --git a/collects/framework/exit.ss b/collects/framework/exit.ss index 64c7ef5d..09378d6d 100644 --- a/collects/framework/exit.ss +++ b/collects/framework/exit.ss @@ -1,4 +1,4 @@ -(unit/sig mred:exit^ +(unit/sig framework:exit^ (import [preferences : framework:preferences^] [gui-utils : framework:gui-utils^]) (rename (-exit exit)) @@ -36,14 +36,14 @@ (lambda () (set! exiting? #t)) (lambda () (if (and (let*-values ([(w capW) - (if (eq? wx:platform 'windows) + (if (eq? (system-type) 'windows) (values "exit" "Exit") (values "quit" "Quit"))] [(message) (string-append "Are you sure you want to " w "?")]) - (if (preferences:get-preference 'mred:verify-exit) + (if (preferences:get 'framework:verify-exit) (if (gui-utils:get-choice message capW "Cancel") #t #f) diff --git a/collects/framework/frame.ss b/collects/framework/frame.ss index e0ad9364..53f8bfef 100644 --- a/collects/framework/frame.ss +++ b/collects/framework/frame.ss @@ -1,11 +1,71 @@ (unit/sig framework:frame^ - (import [group framework:group^]) + (import mred^ + [group framework:group^] + [preferences : framework:preferences^] + [icon : framework:icon^] + [handler : framework:handler^] + [application : framework:application^] + [panel : framework:panel^] + [gui-utils : framework:gui-utils^] + [mzlib:function : mzlib:function^]) + + + (define frame-width 600) + (define frame-height 650) + (let-values ([(w h) (get-display-size)]) + (when (< w frame-width) + (set! frame-width (- (unbox w) 65))) + (when (< w frame-height) + (set! frame-height (- (unbox h) 65)))) (define empty<%> (interface () get-panel% make-root-panel)) + (define make-empty% + (mixin frame% empty<%> args + (rename [super-on-activate on-activate]) + + (override + [can-close? + (lambda () + (send group:the-frame-group + can-remove-frame? + this))] + [on-close + (lambda () + (send group:the-frame-group + remove-frame + this))]) + (public + [get-panel% (lambda () vertical-panel%)] + [get-menu-bar% (lambda () menu-bar%)] + [make-root-panel + (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)) + (public + [menu-bar (make-object (get-menu-bar%) this)] + [panel (make-root-panel (get-panel%) this)]))) + (define standard-menus<%> - (interface () + (interface (empty<%>) get-menu% get-menu-item% @@ -16,7 +76,7 @@ edit-menu:between-cut-and-copy edit-menu:between-paste-and-clear edit-menu:between-redo-and-cut - edit-menu:between-replace-and-preferences + edit-menu:between-find-and-preferences edit-menu:between-select-all-and-find edit-menu:clear edit-menu:clear-help-string @@ -45,10 +105,6 @@ edit-menu:redo-help-string edit-menu:redo-menu edit-menu:redo-string - edit-menu:replace - edit-menu:replace-help-string - edit-menu:replace-menu - edit-menu:replace-string edit-menu:select-all edit-menu:select-all-help-string edit-menu:select-all-menu @@ -108,66 +164,6 @@ help-menu:after-about windows-menu)) - (define empty-standard-menus<%> (interface (standard-menus<%> empty<%>))) - (define edit<%> (interface () FILL-ME-IN)) - (define searchable<%> (interface ())) - (define pasteboard<%> (interface ())) - (define info<%> (interface ())) - (define info-file<%> (interface ())) - - (define frame-width 600) - (define frame-height 650) - (let ([w (box 0)] - [h (box 0)]) - (wx:display-size w h) - (when (< (unbox w) frame-width) - (set! frame-width (- (unbox w) 65))) - (when (< (unbox h) frame-height) - (set! frame-height (- (unbox h) 65)))) - - (define make-empty% - (mixin frame% empty<%> args - (rename [super-on-activate on-activate]) - - (override - [can-close? - (lambda () - (send group:the-frame-group - can-remove-frame? - this))] - [on-close - (lambda () - (send group:the-frame-group - remove-frame - this))]) - (public - [get-panel% (lambda () vertical-panel%)] - [get-menu-bar% (lambda () menu-bar%)] - [make-root-panel - (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)) - (public - [menu-bar (make-object (get-menu-bar%) this)] - [panel (make-root-panel (get-panel%) this)]))) - (define make-standard-menus% (begin-elaboration-time (let-struct between (menu name procedure) @@ -248,14 +244,14 @@ (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) (mred:handler:edit-file #f) #t) + '(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) (mred:handler:open-file) #t) + '(lambda (item control) (handler:open-file) #t) #\o "&Open" "...") (make-an-item 'file-menu:open-url "Open a Uniform Resource Locater" - '(lambda (item control) (mred:handler:open-url) #t) + '(lambda (item control) (handler:open-url) #t) #f "Open &URL" "...") (make-an-item 'file-menu:revert "Revert this file to the copy on disk" @@ -296,16 +292,14 @@ (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-an-item 'edit-menu:replace "Search and replace a string in the buffer" - #f #f "Replace" "") - (make-between 'edit-menu 'between-replace-and-preferences between-separator) + (make-between 'edit-menu 'between-find-and-preferences between-separator) (make-an-item 'edit-menu:preferences "Configure your preferences" - '(lambda (item control) (mred:preferences:show-preferences-dialog) #t) + '(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" - '(lambda (item control) (mred:console:credits)) + #f #f "About " "...") @@ -336,8 +330,23 @@ (build-item-menu-clause x))) items)))))))) - (define make-edit% - (mixin empty-standard-menus<%> frame:simple-menu<%> ([name (mred:application:current-app-name)]) + (define editor<%> (interface (standard-menus<%>) + WIDTH + HEIGHT + title-prefix + get-entire-label + get-label-prefix + set-label-prefix + + get-canvas% + get-edit% + make-edit + save-as + get-canvas + get-edit)) + + (define make-editor% + (mixin standard-menus<%> simple-menu<%> (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?] @@ -352,9 +361,9 @@ (lambda () (and (send (get-edit) do-close) (super-can-close?)))] - [get-panel% (lambda () mred:panel:vertical-edit-panel%)]) + [get-panel% (lambda () panel:vertical-edit-panel%)]) (public - [title-prefix name]) + [title-prefix (application:current-app-name)]) (private [label ""] @@ -387,38 +396,38 @@ (set! label t) (do-label)))]) (public - [get-canvas% (lambda () mred:canvas:frame-title-canvas%)] - [get-edit% (lambda () mred:edit:media-edit%)] + [get-canvas% (lambda () editor-canvas%)] + [get-edit% (lambda () text%)] [make-edit (lambda () (make-object (get-edit%)))]) (public [save-as (opt-lambda ([format 'same]) - (let ([file (parameterize ([mred:finder:dialog-parent-parameter - this]) + (let ([file (parameterize ([finder:dialog-parent-parameter this]) (finder:put-file))]) (when file - (send (get-edit) save-file file format))))] + (send (get-edit) save-file file format))))]) + (override [file-menu:revert (lambda () (let* ([b (box #f)] [edit (get-edit)] [filename (send edit get-filename b)]) - (if (or (null? filename) (unbox b)) - (wx:bell) + (if (or (not filename) (unbox b)) + (bell) (let-values ([(start end) - (if (is-a? edit wx:media-edit%) + (if (is-a? edit text%) (values (send edit get-start-position) (send edit get-end-position)) (values #f #f))]) (send edit begin-edit-sequence) (let ([status (send edit load-file filename - wx:const-media-ff-same + 'same #f)]) (if status (begin - (when (is-a? edit wx:media-edit%) + (when (is-a? edit text%) (send edit set-position start end)) (send edit end-edit-sequence)) (begin @@ -448,7 +457,7 @@ (send file-menu append-separator))] [file-menu:print (lambda () (send (get-edit) print - '() + #f #t #t (preferences:get 'framework:print-output-mode)) @@ -459,95 +468,40 @@ (lambda (menu evt) (let ([edit (active-edit)]) (when edit - (send edit do-edit const))) + (send edit do-edit-operation const))) #t))]) - (public - [edit-menu:undo (edit-menu:do wx:const-edit-undo)] - [edit-menu:redo (edit-menu:do wx:const-edit-redo)] - [edit-menu:cut (edit-menu:do wx:const-edit-cut)] - [edit-menu:clear (edit-menu:do wx:const-edit-clear)] - [edit-menu:copy (edit-menu:do wx:const-edit-copy)] - [edit-menu:paste (edit-menu:do wx:const-edit-paste)] - [edit-menu:select-all (edit-menu:do wx:const-edit-select-all)] - [edit-menu:replace (lambda (menu evt) - (when (active-canvas) - (mred:find-string:find-string - (active-canvas) - (active-edit) - -1 -1 (list 'replace 'ignore-case))))] + (override + [edit-menu:undo (edit-menu:do 'undo)] + [edit-menu:redo (edit-menu:do 'redo)] + [edit-menu:cut (edit-menu:do 'cut)] + [edit-menu:clear (edit-menu:do 'clear)] + [edit-menu:copy (edit-menu:do 'copy)] + [edit-menu:paste (edit-menu:do 'paste)] + [edit-menu:select-all (edit-menu:do 'select-all)] - [edit-menu:between-replace-and-preferences + [edit-menu:between-find-and-preferences (lambda (edit-menu) (send edit-menu append-separator) (send edit-menu append-item "Insert Text Box" - (edit-menu:do wx:const-edit-insert-text-box)) + (edit-menu:do 'insert-text-box)) (send edit-menu append-item "Insert Graphic Box" - (edit-menu:do wx:const-edit-insert-graphic-box)) + (edit-menu:do 'insert-graphic-box)) (send edit-menu append-item "Insert Image..." - (edit-menu:do wx:const-edit-insert-image)) + (edit-menu:do 'insert-image)) (send edit-menu append-item "Toggle Wrap Text" (lambda () (let ([edit (active-edit)]) (when edit - (send edit set-auto-set-wrap (not (ivar edit auto-set-wrap?))) - (send (active-canvas) force-redraw))))) + (send edit auto-wrap (not (send edit auto-wrap))))))) (send edit-menu append-separator))]) - (public - [help-menu:about (lambda (menu evt) (mred:console:credits))] - [help-menu:about-string (mred:application:current-app-name)] - [help-menu:compare string-ci(.*)")]) - (lambda (help-menu) - (let* ([dir (with-handlers ([void (lambda (x) #f)]) (collection-path "doc"))]) - (if (and dir (directory-exists? dir)) - (let* ([dirs (directory-list dir)] - [find-title - (lambda (name) - (lambda (port) - (let loop ([l (read-line port)]) - (if (eof-object? l) - name - (let ([match (regexp-match reg l)]) - (if match - (cadr match) - (loop (read-line port))))))))] - [build-item - (lambda (local-dir output) - (let* ([f (build-path dir local-dir "index.htm")]) - (if (file-exists? f) - (let ([title (call-with-input-file f (find-title local-dir))]) - (cons - (list title - (lambda () - (let* ([f (make-object mred:hyper-frame:hyper-view-frame% - (string-append "file:" f))]) - (send f set-title-prefix title) - f))) - output)) - (begin (mred:debug:printf 'help-menu "couldn't find ~a" f) - output))))] - [item-pairs - (mzlib:function:quicksort - (mzlib:function:foldl build-item null dirs) - (lambda (x y) (help-menu:compare (car x) (car y))))]) - (unless (null? item-pairs) - (send help-menu append-separator)) - (help-menu:insert-items item-pairs)) - (mred:debug:printf 'help-menu "couldn't find PLTHOME/doc directory")))))]) + (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)]) (sequence - (mred:debug:printf 'super-init "before simple-frame%") - (super-init () name -1 -1 WIDTH HEIGHT - (+ wx:const-default-frame wx:const-sdi) - name) - (mred:debug:printf 'super-init "after simple-frame%")) + (super-init name #f WIDTH HEIGHT '(default-frame sdi))) (public [get-canvas (let ([c #f]) @@ -563,13 +517,26 @@ (send (get-canvas) set-media e)) e))]) (sequence - (let ([icon (mred:icon:get-icon)]) + (let ([icon (icon:get-icon)]) (when (send icon ok?) (set-icon icon))) (do-title) (let ([canvas (get-canvas)]) + (send (get-edit) load-file filename) (send canvas set-focus))))) + (define searchable<%> (interface () + get-edit-to-search + hide-search + unhide-search + set-search-direction + replace&search + replace-all + replace + toggle-search-focus + move-to-search-or-show-search + move-to-search-or-reverse-search + search)) (define make-searchable% (let* ([anchor 0] [searching-direction 1] @@ -578,8 +545,8 @@ (lambda (edit) (let loop ([edit edit]) (let ([snip (send edit get-focus-snip)]) - (if (or (null? snip) - (not (is-a? snip wx:media-snip%))) + (if (or (not snip) + (not (is-a? snip editor-snip%))) edit (loop (send snip get-this-media))))))] [clear-highlight @@ -587,7 +554,7 @@ (begin (old-highlight) (set! old-highlight void)))] [reset-anchor - (let ([color (make-object wx:colour% "BLUE")]) + (let ([color (make-object color% "BLUE")]) (lambda (edit) (old-highlight) (let ([position @@ -623,14 +590,14 @@ (lambda (found-edit) (send found-edit set-position anchor) (when beep? - (wx:bell)) + (bell)) #f)] [found (lambda (edit first-pos) (let ([last-pos (+ first-pos (* searching-direction (string-length string)))]) (send* edit - (set-caret-owner null wx:const-focus-display) + (set-caret-owner #f 'display) (set-position (min first-pos last-pos) (max first-pos last-pos))) @@ -683,30 +650,31 @@ (class editor-canvas% args (inherit get-parent frame set-line-count) (rename [super-on-set-focus on-set-focus]) - (public - [lines 2] - [style-flags wx:const-mcanvas-hide-h-scroll] + (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 1)))]) + (set-line-count 2)))]) (for-each (lambda (keymap) (send keymap chain-to-keymap keymap:global-search-keymap #t)) (list (send find-edit get-keymap) (send replace-edit get-keymap))) - (mixin frame:edit<%> frame:searchable<%> args + (mixin edit<%> searchable<%> args (inherit active-edit active-canvas get-edit) (rename [super-make-root-panel make-root-panel] [super-on-activate on-activate] [super-do-close do-close]) (private [super-root 'unitiaialized-super-root]) - (public + (override + [edit-menu:find (lambda (menu evt) (search))]) + (override [make-root-panel (lambda (% parent) (let* ([s-root (super-make-root-panel @@ -715,14 +683,15 @@ [root (make-object % s-root)]) (set! super-root s-root) root))]) - (public + (override [on-activate (lambda (on?) (unless hidden? (if on? (reset-anchor (get-edit-to-search)) (clear-highlight))) - (super-on-activate on?))] + (super-on-activate on?))]) + (public [get-edit-to-search (lambda () (get-edit))] @@ -740,18 +709,18 @@ (set! hidden? #f) (send super-root add-child search-panel) (reset-anchor (get-edit-to-search)))]) - (public + (override [do-close (lambda () (super-do-close) (let ([close-canvas (lambda (canvas edit) (send edit remove-canvas canvas) - (send canvas set-media ()))]) + (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)))] + (send find-edit set-searching-frame #f)))]) [set-search-direction (lambda (x) (set! searching-direction x) @@ -863,16 +832,16 @@ middle-middle-panel (lambda x (replace-all)))] - [dir-radio (make-object radio-box% 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-edit-to-search)))) - null - -1 -1 -1 -1 - (list "Forward" "Backward"))] + [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-edit-to-search)))))] [close-button (make-object button% middle-right-panel (lambda args (hide-search)) "Hide")] [hidden? #f]) @@ -897,6 +866,12 @@ (send replace-edit add-canvas replace-canvas) (hide-search #t))))) + (define info<%> (interface (edit<%>) + determine-width + get-info-edit + lock-status-changed + update-info + info-panel)) (define make-info% (let* ([time-edit (make-object text%)] [time-semaphore (make-semaphore 1)] @@ -934,12 +909,12 @@ (update-time) (sleep 30) (loop))))]) - (mixin frame:edit<%> frame:info<%> args + (mixin edit<%> info<%> args (rename [super-make-root-panel make-root-panel]) (private [rest-panel 'uninitialized-root] [super-root 'uninitialized-super-root]) - (public + (override [make-root-panel (lambda (% parent) (let* ([s-root (super-make-root-panel @@ -954,7 +929,7 @@ [determine-width (let ([magic-space 25]) (lambda (string canvas edit) - (send edit set-autowrap-bitmap null) + (send edit set-autowrap-bitmap #f) (send canvas call-as-primary-owner (lambda () (let ([lb (box 0)] @@ -965,7 +940,7 @@ (send edit last-position) rb) (send edit position-location 0 lb) - (send canvas user-min-width + (send canvas min-width (+ magic-space (- (unbox rb) (unbox lb)))))))))]) (rename [super-do-close do-close]) @@ -976,17 +951,17 @@ (lambda (p v) (if v (register-gc-blit) - (wx:unregister-collecting-blit gc-canvas)) + (unregister-collecting-blit gc-canvas)) (send super-root change-children (lambda (l) (if v (list rest-panel info-panel) (list rest-panel))))))]) - (public + (override [do-close (lambda () (super-do-close) - (send time-canvas set-media null) + (send time-canvas set-media #f) (unregister-collecting-blit gc-canvas) (close-panel-callback))]) @@ -1029,9 +1004,9 @@ super-root)]) (private [lock-message (make-object message% - (let ([b (mred:icon:get-unlock-bitmap)]) + (let ([b (icon:get-unlock-bitmap)]) (if (send b ok?) - (cons (mred:icon:get-unlock-mdc) b) + (cons (icon:get-unlock-mdc) b) "Unlocked")) info-panel '(border))] @@ -1040,17 +1015,17 @@ [gc-canvas (make-object canvas% info-panel '(border))] [register-gc-blit (lambda () - (let ([mdc (mred:icon:get-gc-on-dc)]) + (let ([mdc (icon:get-gc-on-dc)]) (when (send mdc ok?) (register-collecting-blit gc-canvas 0 0 - (mred:icon:get-gc-width) - (mred:icon:get-gc-height) - (mred:icon:get-gc-on-dc) - (mred:icon:get-gc-off-dc)))))]) + (icon:get-gc-width) + (icon:get-gc-height) + (icon:get-gc-on-dc) + (icon:get-gc-off-dc)))))]) (sequence - (unless (mred:preferences:get-preference 'mred:show-status-line) + (unless (preferences:get-preference 'framework:show-status-line) (send super-root change-children (lambda (l) (list rest-panel)))) @@ -1081,170 +1056,175 @@ (semaphore-post time-semaphore) (update-time))))) + (define edit-info<%> (interface (info<%>) + overwrite-status-changed + anchor-status-changed + edit-position-changed-offset + edit-position-changed)) (define make-edit-info% - (mixin (interface (frame:info<%> frame:edit<%>)) frame:edit-info<%> args - (inherit get-info-edit) - (rename [super-do-close do-close]) - (private - [remove-pref-callback - (preferences:add-callback - 'framework:line-offsets - (lambda (p v) - (edit-position-changed-offset v) - #t))]) - (public - [do-close - (lambda () - (super-do-close) - (remove-pref-callback))]) - - (public - [overwrite-status-changed - (let ([last-state? #f]) - (lambda () - (let ([info-edit (get-info-edit)]) - (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]) - (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?)))))))] - - [edit-position-changed-offset - (let ([last-start #f] - [last-end #f]) - (lambda (offset?) - (let* ([edit (get-info-edit)] - [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) - (format "~a:~a" - (if offset? - (add1 line) - line) - (if offset? - (add1 char) - char)) - (format "~a" - (if offset? - (+ pos 1) - pos)))))]) - (when edit - (let ([start (send edit get-start-position)] - [end (send edit get-end-position)]) - (unless (and last-start - (= last-start start) - (= last-end end)) - (set! last-start start) - (set! last-end end) - (when (object? position-edit) - (send* position-edit - (lock #f) - (erase) - (insert - (if (= start end) - (make-one start) - (string-append (make-one start) - "-" - (make-one end)))) - (lock #t)))))))))] - [edit-position-changed - (lambda () - (edit-position-changed-offset - (preferences:get 'framework:line-offsets)))]) - (rename [super-update-info update-info]) - (public - [update-info - (lambda () - (super-update-info) - (overwrite-status-changed) - (anchor-status-changed) - (edit-position-changed))]) - (sequence - (apply super-init args)) - - (inherit info-panel) - (private - [anchor-message - (make-object message% - (let ([b (mred:icon:get-anchor-bitmap)]) - (if (send b ok?) - (cons (mred:icon:get-anchor-mdc) b) - "Anchor")) - info-panel '(border))] - [overwrite-message - (make-object mred:container:canvas-message% - "Overwrite" - info-panel - '(border))] - [position-canvas (make-object editor-canvas% info-panel)] - [_2 (send position-canvas set-line-count 1)] - [position-edit (make-object text%)]) - - (inherit determine-width) - (sequence - (let ([move-front - (lambda (x l) - (cons x (mzlib:function:remq x l)))]) - (send info-panel change-children - (lambda (l) - (move-front - anchor-message - (move-front - overwrite-message - (move-front - position-canvas - l)))))) - (send anchor-message show #f) - (send overwrite-message show #f) - (send* position-canvas - (set-media position-edit) - (stretchable-in-x #f)) - (determine-width "0000:000-0000:000" - position-canvas - position-edit) - (edit-position-changed) - (send position-edit lock #t)))) + (mixin info<%> edit-info<%> args + (inherit get-info-edit) + (rename [super-do-close do-close]) + (private + [remove-pref-callback + (preferences:add-callback + 'framework:line-offsets + (lambda (p v) + (edit-position-changed-offset v) + #t))]) + (override + [do-close + (lambda () + (super-do-close) + (remove-pref-callback))]) + + (public + [overwrite-status-changed + (let ([last-state? #f]) + (lambda () + (let ([info-edit (get-info-edit)]) + (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]) + (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?)))))))] + + [edit-position-changed-offset + (let ([last-start #f] + [last-end #f]) + (lambda (offset?) + (let* ([edit (get-info-edit)] + [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) + (format "~a:~a" + (if offset? + (add1 line) + line) + (if offset? + (add1 char) + char)) + (format "~a" + (if offset? + (+ pos 1) + pos)))))]) + (when edit + (let ([start (send edit get-start-position)] + [end (send edit get-end-position)]) + (unless (and last-start + (= last-start start) + (= last-end end)) + (set! last-start start) + (set! last-end end) + (when (object? position-edit) + (send* position-edit + (lock #f) + (erase) + (insert + (if (= start end) + (make-one start) + (string-append (make-one start) + "-" + (make-one end)))) + (lock #t)))))))))] + [edit-position-changed + (lambda () + (edit-position-changed-offset + (preferences:get 'framework:line-offsets)))]) + (rename [super-update-info update-info]) + (override + [update-info + (lambda () + (super-update-info) + (overwrite-status-changed) + (anchor-status-changed) + (edit-position-changed))]) + (sequence + (apply super-init args)) + + (inherit info-panel) + (private + [anchor-message + (make-object message% + (let ([b (icon:get-anchor-bitmap)]) + (if (send b ok?) + (cons (icon:get-anchor-mdc) b) + "Anchor")) + info-panel '(border))] + [overwrite-message + (make-object message% + "Overwrite" + info-panel + '(border))] + [position-canvas (make-object editor-canvas% info-panel)] + [_2 (send position-canvas set-line-count 1)] + [position-edit (make-object text%)]) + + (inherit determine-width) + (sequence + (let ([move-front + (lambda (x l) + (cons x (mzlib:function:remq x l)))]) + (send info-panel change-children + (lambda (l) + (move-front + anchor-message + (move-front + overwrite-message + (move-front + position-canvas + l)))))) + (send anchor-message show #f) + (send overwrite-message show #f) + (send* position-canvas + (set-media position-edit) + (stretchable-in-x #f)) + (determine-width "0000:000-0000:000" + position-canvas + position-edit) + (edit-position-changed) + (send position-edit lock #t)))) + (define file<%> (interface (edit<%>))) (define make-file% - (lambda (super%) - (rec mred:file-frame% - (class-asi super% - (inherit get-edit) - (rename [super-can-close? can-close?]) - (public - [can-close? - (lambda () - (let* ([edit (get-edit)] - [user-allowed-or-not-modified - (or (not (send edit modified?)) - (case (mred:gui-utils:unsaved-warning - (let ([fn (send edit get-filename)]) - (if (string? fn) - fn - "Untitled")) - "Close" - #t) - [(continue) #t] - [(save) (send edit save-file)] - [else #f]))]) - (and user-allowed-or-not-modified - (super-can-close?))))]))))) + (mixin edit<%> file<%> args + (inherit get-edit) + (rename [super-can-close? can-close?]) + (override + [on-close? + (lambda () + (let* ([edit (get-edit)] + [user-allowed-or-not-modified + (or (not (send edit modified?)) + (case (gui-utils:unsaved-warning + (let ([fn (send edit get-filename)]) + (if (string? fn) + fn + "Untitled")) + "Close" + #t) + [(continue) #t] + [(save) (send edit save-file)] + [else #f]))]) + (and user-allowed-or-not-modified + (super-can-close?))))]) + (sequence (apply super-init args)))) (define empty% (make-empty% frame%)) (define standard-menus% (make-standard-menus% empty%)) diff --git a/collects/framework/group.ss b/collects/framework/group.ss index 21fb9f6f..290d8689 100644 --- a/collects/framework/group.ss +++ b/collects/framework/group.ss @@ -1,5 +1,6 @@ (unit/sig mred:group^ - (import [exit : framework:exit^] + (import mred^ + [exit : framework:exit^] [mzlib:function : mzlib:function^] [mzlib:file : mzlib:file^]) diff --git a/collects/framework/guiutils.ss b/collects/framework/guiutils.ss index d7b2d4a0..79f8d80a 100644 --- a/collects/framework/guiutils.ss +++ b/collects/framework/guiutils.ss @@ -1,155 +1,205 @@ +(unit/sig framework:gui-utils^ + (import mred^) - (unit/sig framework:gui-utils^ - (import) + (define cursor-delay + (let ([x 0.25]) + (case-lambda + [() x] + [(v) (set! x v) x]))) - (define cursor-delay - (let ([x 0.25]) - (case-lambda - [() x] - [(v) (set! x v) x]))) + (define show-busy-cursor + (lambda (thunk) + (local-busy-cursor #f thunk))) - (define show-busy-cursor - (lambda (thunk) - (local-busy-cursor #f thunk))) + (define delay-action + (lambda (delay-time open close) + (let ([semaphore (make-semaphore 1)] + [open? #f] + [skip-it? #f]) + (thread + (lambda () + (sleep delay-time) + (semaphore-wait semaphore) + (unless skip-it? + (set! open? #t) + (open)) + (semaphore-post semaphore))) + (lambda () + (semaphore-wait semaphore) + (set! skip-it? #t) + (when open? + (close)) + (semaphore-post semaphore))))) - (define delay-action - (lambda (delay-time open close) - (let ([semaphore (make-semaphore 1)] - [open? #f] - [skip-it? #f]) - (thread + (define local-busy-cursor + (let ([watch (make-object wx:cursor% wx:const-cursor-watch)]) + (opt-lambda (win thunk [delay (cursor-delay)]) + (let* ([old-cursor #f] + [cursor-off void]) + (dynamic-wind (lambda () - (sleep delay-time) - (semaphore-wait semaphore) - (unless skip-it? - (set! open? #t) - (open)) - (semaphore-post semaphore))) - (lambda () - (semaphore-wait semaphore) - (set! skip-it? #t) - (when open? - (close)) - (semaphore-post semaphore))))) + (set! cursor-off + (delay-action + delay + (lambda () + (if win + (set! old-cursor (send win set-cursor watch)) + (wx:begin-busy-cursor))) + (lambda () + (if win + (send win set-cursor old-cursor) + (wx:end-busy-cursor)))))) + (lambda () (thunk)) + (lambda () (cursor-off))))))) - (define local-busy-cursor - (let ([watch (make-object wx:cursor% wx:const-cursor-watch)]) - (opt-lambda (win thunk [delay (cursor-delay)]) - (let* ([old-cursor #f] - [cursor-off void]) - (dynamic-wind - (lambda () - (set! cursor-off - (delay-action - delay - (lambda () - (if win - (set! old-cursor (send win set-cursor watch)) - (wx:begin-busy-cursor))) - (lambda () - (if win - (send win set-cursor old-cursor) - (wx:end-busy-cursor)))))) - (lambda () (thunk)) - (lambda () (cursor-off))))))) + (define unsaved-warning + (opt-lambda (filename action [can-save-now? #f]) + (let* ([result (void)] + [dialog% + (class dialog-box% () + (inherit show new-line fit tab center set-size) + (private + [on-dont-save + (lambda args + (set! result 'continue) + (show #f))] + [on-save-now + (lambda rags + (set! result 'save) + (show #f))] + [on-cancel + (lambda args + (set! result 'cancel) + (show #f))]) + (sequence + (super-init "Warning") + (let* ([panel (make-object vertical-panel% this)] + [msg + (make-object message% + (string-append "The file \"" + filename + "\" is not saved.") + panel)] + [button-panel + (make-object horizontal-panel% panel)]) + (make-object button% + (string-append action " Anyway") + button-panel + on-dont-save) + (let ([now (make-object button% + "Save" + button-panel + on-save-now)] + [cancel (make-object button% + "Cancel" + button-panel + on-cancel)]) + (if (not can-save-now?) + (begin (send cancel set-focus) + (send now show #f)) + (send now set-focus))) + (send msg center wx:const-horizontal)) + + (set-size -1 -1 10 10) + (center wx:const-both) + + (show #t)))]) + (make-object dialog%) + result))) + + (define read-snips/chars-from-buffer + (opt-lambda (edit [start 0] [end (send edit last-position)]) + (let ([pos start] + [box (box 0)]) + (lambda () + (let* ([snip (send edit find-snip pos + wx:const-snip-after-or-null box)] + [ans + (cond + [(<= end pos) eof] + [(null? snip) eof] + [(is-a? snip wx:text-snip%) + (let ([t (send snip get-text (- pos (unbox box)) 1)]) + (unless (= (string-length t) 1) + (error 'read-snips/chars-from-buffer + "unexpected string, t: ~s; pos: ~a box: ~a" + t pos box)) + (string-ref t 0))] + [else snip])]) + (set! pos (add1 pos)) + ans))))) - (define unsaved-warning - (opt-lambda (filename action [can-save-now? #f]) - (let* ([result (void)] - [dialog% - (class dialog-box% () - (inherit show new-line fit tab center set-size) - (private - [on-dont-save - (lambda args - (set! result 'continue) - (show #f))] - [on-save-now - (lambda rags - (set! result 'save) - (show #f))] - [on-cancel - (lambda args - (set! result 'cancel) - (show #f))]) - (sequence - (super-init "Warning") - (let* ([panel (make-object vertical-panel% this)] - [msg - (make-object message% - (string-append "The file \"" - filename - "\" is not saved.") - panel)] - [button-panel - (make-object horizontal-panel% panel)]) - (make-object button% - (string-append action " Anyway") - button-panel - on-dont-save) - (let ([now (make-object button% - "Save" - button-panel - on-save-now)] - [cancel (make-object button% - "Cancel" - button-panel - on-cancel)]) - (if (not can-save-now?) - (begin (send cancel set-focus) - (send now show #f)) - (send now set-focus))) - (send msg center wx:const-horizontal)) + (define get-choice + (opt-lambda (message true-choice false-choice + [title "Warning"][x -1][y -1]) + (let* ([result (void)] + [dialog% + (class wx:dialog-box% () + (inherit show new-line fit tab center) + (private + [on-true + (lambda args + (set! result #t) + (show #f))] + [on-false + (lambda rags + (set! result #f) + (show #f))]) + (sequence + (super-init () title #t x y) + (let* ([messages + (let loop ([m message]) + (let ([match (regexp-match (format "([^~n]*)~n(.*)") + m)]) + (if match + (cons (cadr match) + (loop (caddr match))) + (list m))))] + [msgs (map + (lambda (message) + (begin0 + (make-object wx:message% this message) + (new-line))) + messages)]) - (set-size -1 -1 10 10) - (center wx:const-both) + (send (make-object wx:button% this + on-true true-choice) + set-focus) + (tab 50) + (make-object wx:button% this on-false false-choice) + (fit) - (show #t)))]) - (make-object dialog%) - result))) - - (define read-snips/chars-from-buffer - (opt-lambda (edit [start 0] [end (send edit last-position)]) - (let ([pos start] - [box (box 0)]) - (lambda () - (let* ([snip (send edit find-snip pos - wx:const-snip-after-or-null box)] - [ans - (cond - [(<= end pos) eof] - [(null? snip) eof] - [(is-a? snip wx:text-snip%) - (let ([t (send snip get-text (- pos (unbox box)) 1)]) - (unless (= (string-length t) 1) - (error 'read-snips/chars-from-buffer - "unexpected string, t: ~s; pos: ~a box: ~a" - t pos box)) - (string-ref t 0))] - [else snip])]) - (set! pos (add1 pos)) - ans))))) + (if (and (< x 0) (< y 0)) + (map (lambda (msg) + (send msg center wx:const-horizontal)) + msgs))) + + (center wx:const-both) + + (show #t)))]) + (make-object dialog%) + result))) - (define open-input-buffer - (lambda (buffer) - (let ([pos 0]) - (make-input-port - (lambda () - (let ([c (send buffer get-character pos)]) - (if (char=? c #\null) - eof - (begin - (set! pos (add1 pos)) - c)))) - (lambda () - #t) - (lambda () - (void)))))) - - ; For use with wx:set-print-paper-name - (define print-paper-names - (list - "A4 210 x 297 mm" - "A3 297 x 420 mm" - "Letter 8 1/2 x 11 in" - "Legal 8 1/2 x 14 in"))) + (define open-input-buffer + (lambda (buffer) + (let ([pos 0]) + (make-input-port + (lambda () + (let ([c (send buffer get-character pos)]) + (if (char=? c #\null) + eof + (begin + (set! pos (add1 pos)) + c)))) + (lambda () + #t) + (lambda () + (void)))))) + + ; For use with wx:set-print-paper-name + (define print-paper-names + (list + "A4 210 x 297 mm" + "A3 297 x 420 mm" + "Letter 8 1/2 x 11 in" + "Legal 8 1/2 x 14 in"))) diff --git a/collects/framework/handler.ss b/collects/framework/handler.ss index a9410c62..4a7e3dac 100644 --- a/collects/framework/handler.ss +++ b/collects/framework/handler.ss @@ -1,211 +1,142 @@ -; File Formats and Modes +(unit/sig framework:handler^ + (import mred^ + [gui-utils : framework:gui-utils^] + [finder : framework:finder^] + [group : framework:group^] + [text : framework:text^] + [preferences : framework:preferences^] + [mzlib:file : mzlib:file^]) + + (define-struct handler (name extension handler)) - (unit/sig framework:handler^ - (import [gui-utils : framework:gui-utils^] - [finder : framework:finder^] - [group : framework:group^] - [hyper:frame : framework:hyper:frame^] - [edit : framework:edit^] - [preferences : framework:preferences^] - [mzlib:file : mzlib:file^] - [mred:editor-frame : mred:editor-frame^]) - - (define-struct handler (name extension handler)) + (define format-handlers '()) - (define format-handlers '()) + (define make-insert-handler + (letrec ([string-list? + (lambda (l) + (cond + [(null? l) #t] + [(not (pair? l)) #f] + [else + (and (string? (car l)) + (string-list? (cdr l)))]))]) + (lambda (who name extension handler) + (cond + [(not (string? name)) + (error who "name was not a string")] + [(and (not (procedure? extension)) + (not (string? extension)) + (not (string-list? extension))) + (error who + "extension was not a string, list of strings, or a predicate")] + [(not (procedure? handler)) + (error who "handler was not a function")] + [else (make-handler name + extension + handler)])))) + + (define insert-format-handler + (lambda args + (set! format-handlers + (cons (apply make-insert-handler 'insert-format-handler args) + format-handlers)))) - (define make-insert-handler - (letrec ([string-list? - (lambda (l) - (cond - [(null? l) #t] - [(not (pair? l)) #f] - [else - (and (string? (car l)) - (string-list? (cdr l)))]))]) - (lambda (who name extension handler) - (cond - [(not (string? name)) - (error who "name was not a string")] - [(and (not (procedure? extension)) - (not (string? extension)) - (not (string-list? extension))) - (error who - "extension was not a string, list of strings, or a predicate")] - [(not (procedure? handler)) - (error who "handler was not a function")] - [else (make-handler name - extension - handler)])))) - - (define insert-format-handler - (lambda args - (set! format-handlers - (cons (apply make-insert-handler 'insert-format-handler args) - format-handlers)))) + (define find-handler + (lambda (name handlers) + (let/ec exit + (let ([extension (if (string? name) + (or (mzlib:file:filename-extension name) + "") + "")]) + (for-each + (lambda (handler) + (let ([ext (handler-extension handler)]) + (when (or (and (procedure? ext) + (ext name)) + (and (string? ext) + (string=? ext extension)) + (and (pair? ext) + (ormap (lambda (ext) + (string=? ext extension)) + ext))) + (exit (handler-handler handler))))) + handlers) + #f)))) + + (define find-format-handler + (lambda (name) + (find-handler name format-handlers))) - (define find-handler - (lambda (name handlers) - (let/ec exit - (let ([extension (if (string? name) - (or (mzlib:file:filename-extension name) - "") - "")]) - (for-each - (lambda (handler) - (let ([ext (handler-extension handler)]) - (when (or (and (procedure? ext) - (ext name)) - (and (string? ext) - (string=? ext extension)) - (and (pair? ext) - (ormap (lambda (ext) - (string=? ext extension)) - ext))) - (exit (handler-handler handler))))) - handlers) - #f)))) - - (define find-format-handler - (lambda (name) - (find-handler name format-handlers))) + ; Finding format & mode handlers by name + (define find-named-handler + (lambda (name handlers) + (let loop ([l handlers]) + (cond + [(null? l) #f] + [(string-ci=? (handler-name (car l)) name) + (handler-handler (car l))] + [else (loop (cdr l))])))) + + (define find-named-format-handler + (lambda (name) + (find-named-handler name format-handlers))) - ; Finding format & mode handlers by name - (define find-named-handler - (lambda (name handlers) - (let loop ([l handlers]) - (cond - [(null? l) #f] - [(string-ci=? (handler-name (car l)) name) - (handler-handler (car l))] - [else (loop (cdr l))])))) - - (define find-named-format-handler - (lambda (name) - (find-named-handler name format-handlers))) + (define edit-file-consult-group (make-parameter #t)) - (define edit-file-consult-group (make-parameter #t)) + ; Open a file for editing + (define edit-file + (opt-lambda (filename + [make-default + (lambda (filename) + (make-object frame:info-file-frame% filename))] + [consult-group? (edit-file-consult-group)]) + (gui-utils:show-busy-cursor + (lambda () + (if filename + (let ([already-open (and consult-group? + (send group:the-frame-group + locate-file + filename))]) + (if already-open + (begin + (send already-open show #t) + already-open) + (let ([handler + (if (string? filename) + (find-format-handler filename) + #f)]) + (if handler + (handler filename) + (make-default filename))))) + (make-default filename)))))) + + ; Query the user for a file and then edit it - ; Open a file for editing - (define edit-file - (opt-lambda (filename - [make-default - (lambda (filename) - (make-object mred:editor-frame:editor-frame% - filename #t))] - [consult-group? (edit-file-consult-group)]) - (gui-utils:show-busy-cursor - (lambda () - (if filename - (let ([already-open (and consult-group? - (send mred:group:the-frame-group - locate-file - filename))]) - (if already-open - (begin - (send already-open show #t) - already-open) - (let ([handler - (if (string? filename) - (find-format-handler filename) - #f)]) - (if handler - (handler filename) - (make-default filename))))) - (make-default filename)))))) - - (define get-url-from-user - (lambda () - (let* ([frame (make-object dialog-box% (get-top-level-focus-window) "Choose URL")] - [main (make-object vertical-panel% frame)] - [one-line (make-object editor-canvas% main)] - [_ (send one-line set-line-count 1)] - [valid? #f] - [ok-callback (lambda x (set! valid? #t) (send frame show #f))] - [answer (make-object edit:return% ok-callback)] - [bottom (make-object horizontal-panel% main)] - [space (make-object horizontal-panel% bottom)] - [bookmarks (preferences:get 'framework:bookmarks)] - [bk-choice - (make-object choice% bottom - (lambda (box evt) - (let ([which (send evt get-command-int)]) - (when (<= 0 which) - (send* answer - (begin-edit-sequence) - (erase) - (insert (list-ref bookmarks which)) - (end-edit-sequence))))) - "Bookmarks" -1 -1 -1 -1 bookmarks)] - [browse (make-object button% - bottom - (lambda x - (let ([ans (finder:get-file)]) - (when ans - (send* answer - (begin-edit-sequence) - (erase) - (insert "file:") - (insert ans) - (end-edit-sequence))))) - "Browse...")] - [cancel (make-object button% bottom - (lambda x - (send frame show #f)) - "Cancel")] - [ok (make-object button% bottom - ok-callback - "Ok")]) - (let ([w (max (send ok get-width) - (send cancel get-width) - (send browse get-width))]) - (send ok user-min-width w) - (send cancel user-min-width w) - (send browse user-min-width w)) - (unless (null? bookmarks) - (send answer insert (car bookmarks)) - (send answer set-position 0 -1)) - (send one-line set-focus) - (send one-line set-media answer) - (send frame set-size -1 -1 20 20) - (send frame center 'both) - (send frame show #t) - (and valid? - (send answer get-text))))) + (define *open-directory* ; object to remember last directory + (make-object + (class null () + (private + [the-dir #f]) + (public + [get (lambda () the-dir)] + [set-from-file! + (lambda (file) + (set! the-dir (mzlib:file:path-only file)))] + [set-to-default + (lambda () + (set! the-dir (current-directory)))]) + (sequence + (set-to-default))))) - (define open-url - (opt-lambda ([input-url #f]) - (let ([url (or input-url (get-url-from-user))]) - (and url - (make-object hyper:frame:hyper-view-frame% url))))) - - ; Query the user for a file and then edit it - - (define *open-directory* ; object to remember last directory - (make-object - (class null () - (private - [the-dir #f]) - (public - [get (lambda () the-dir)] - [set-from-file! - (lambda (file) - (set! the-dir (mzlib:file:path-only file)))] - [set-to-default - (lambda () - (set! the-dir (current-directory)))]) - (sequence - (set-to-default))))) - - (define open-file - (lambda () - (let ([file - (parameterize ([finder:dialog-parent-parameter - (get-top-level-focus-window)]) - (finder:get-file - (send *open-directory* get)))]) - (when file - (send *open-directory* - set-from-file! file)) - (and file - (edit-file file)))))) + (define open-file + (lambda () + (let ([file + (parameterize ([finder:dialog-parent-parameter + (get-top-level-focus-window)]) + (finder:get-file + (send *open-directory* get)))]) + (when file + (send *open-directory* + set-from-file! file)) + (and file + (edit-file file)))))) diff --git a/collects/framework/keys.ss b/collects/framework/keys.ss index cbcf38bd..46bc0f57 100644 --- a/collects/framework/keys.ss +++ b/collects/framework/keys.ss @@ -1,5 +1,6 @@ (unit/sig framework:keymap^ - (import [preferences : framework:preferences^] + (import mred^ + [preferences : framework:preferences^] [finder : framework:finder^] [handler : framework:handler^] [scheme-paren : framework:scheme-paren^]) @@ -37,101 +38,7 @@ (send keymap map-function key func)) (make-meta-prefix-list key)))) - (define setup-global-search-keymap - (let* ([send-frame - (lambda (method) - (lambda (edit event) - (let ([frame - (let ([frame - (cond - [(is-a? obj editor<%>) - (let ([canvas (send obj get-active-canvas)]) - (and canvas - (send canvas get-top-level-window)))] - [(is-a? obj area<%>) - (send obj get-top-level-window)] - [else #f])]))]) - (if frame - ((ivar/proc frame method)) - (bell)) - #t)))]) - (lambda (kmap) - (let* ([map (lambda (key func) - (send kmap map-function key func))] - [map-meta (lambda (key func) - (send-map-function-meta kmap key func))] - [add (lambda (name func) - (send kmap add-key-function name func))] - [add-m (lambda (name func) - (send kmap add-mouse-function name func))]) - - (add "move-to-search-or-search" (send-frame 'move-to-search-or-search)) ;; key 1 - (add "move-to-search-or-reverse-search" (send-frame 'move-to-search-or-reverse-search)) ;; key 1b, backwards - (add "find-string" (send-frame 'search)) ;; key 2 - (add "toggle-search-focus" (send-frame 'toggle-search-focus)) ;; key 3 - (add "hide-search" (send-frame '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") - (map "c:i" "toggle-search-focus") - (map "c:g" "hide-search")] - [(windows) - (map "c:f" "move-to-search-or-search") - (map "c:r" "move-to-search-or-reverse-search") - (map "f3" "find-string") - (map "c:g" "find-string") - (map "c:i" "toggle-search-focus")] - [(macos) - (map "c:s" "move-to-search-or-search") - (map "c:g" "hide-search") - (map "d:f" "move-to-search-or-search") - (map "d:r" "move-to-search-or-reverse-search") - (map "d:g" "find-string") - (map "d:o" "toggle-search-focus")]))))) - - (define setup-global-file-keymap - (let* ([save-file-as - (lambda (edit event) - (let ([file (finder:put-file)]) - (if file - (send edit save-file file))) - #t)] - [save-file - (lambda (edit event) - (if (send edit get-filename) - (send edit save-file) - (save-file-as edit event)) - #t)] - [load-file - (lambda (edit event) - (handler:open-file) - #t)]) - (lambda (kmap) - (map (lambda (k) (send kmap implies-shift k)) shifted-key-list) - (let* ([map (lambda (key func) - (send kmap map-function key func))] - [map-meta (lambda (key func) - (send-map-function-meta kmap key func))] - [add (lambda (name func) - (send kmap add-key-function name func))] - [add-m (lambda (name func) - (send kmap add-mouse-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"))))) - - ; This installs the standard keyboard mapping - (define setup-global-keymap + (define setup-global ; Define some useful keyboard functions (let* ([ring-bell (lambda (edit event) @@ -860,11 +767,104 @@ (map "middlebutton" "paste-click-region") (map "c:rightbutton" "copy-clipboard"))))) - (define global-keymap (make-object keymap%)) - (setup-global-keymap global-keymap) + (define setup-search + (let* ([send-frame + (lambda (method) + (lambda (edit event) + (let ([frame + (let ([frame + (cond + [(is-a? obj editor<%>) + (let ([canvas (send obj get-active-canvas)]) + (and canvas + (send canvas get-top-level-window)))] + [(is-a? obj area<%>) + (send obj get-top-level-window)] + [else #f])]))]) + (if frame + ((ivar/proc frame method)) + (bell)) + #t)))]) + (lambda (kmap) + (let* ([map (lambda (key func) + (send kmap map-function key func))] + [map-meta (lambda (key func) + (send-map-function-meta kmap key func))] + [add (lambda (name func) + (send kmap add-key-function name func))] + [add-m (lambda (name func) + (send kmap add-mouse-function name func))]) + + (add "move-to-search-or-search" (send-frame 'move-to-search-or-search)) ;; key 1 + (add "move-to-search-or-reverse-search" (send-frame 'move-to-search-or-reverse-search)) ;; key 1b, backwards + (add "find-string" (send-frame 'search)) ;; key 2 + (add "toggle-search-focus" (send-frame 'toggle-search-focus)) ;; key 3 + (add "hide-search" (send-frame '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") + (map "c:i" "toggle-search-focus") + (map "c:g" "hide-search")] + [(windows) + (map "c:f" "move-to-search-or-search") + (map "c:r" "move-to-search-or-reverse-search") + (map "f3" "find-string") + (map "c:g" "find-string") + (map "c:i" "toggle-search-focus")] + [(macos) + (map "c:s" "move-to-search-or-search") + (map "c:g" "hide-search") + (map "d:f" "move-to-search-or-search") + (map "d:r" "move-to-search-or-reverse-search") + (map "d:g" "find-string") + (map "d:o" "toggle-search-focus")]))))) - (define global-file-keymap (make-object keymap%)) - (setup-global-file-keymap global-file-keymap) + (define setup-file + (let* ([save-file-as + (lambda (edit event) + (let ([file (finder:put-file)]) + (if file + (send edit save-file file))) + #t)] + [save-file + (lambda (edit event) + (if (send edit get-filename) + (send edit save-file) + (save-file-as edit event)) + #t)] + [load-file + (lambda (edit event) + (handler:open-file) + #t)]) + (lambda (kmap) + (map (lambda (k) (send kmap implies-shift k)) shifted-key-list) + (let* ([map (lambda (key func) + (send kmap map-function key func))] + [map-meta (lambda (key func) + (send-map-function-meta kmap key func))] + [add (lambda (name func) + (send kmap add-key-function name func))] + [add-m (lambda (name func) + (send kmap add-mouse-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 global-search-keymap (make-object keymap%)) - (setup-global-search-keymap global-search-keymap)) + (define global (make-object keymap%)) + (setup-global global) + + (define file (make-object keymap%)) + (setup-file file) + + (define search (make-object keymap%)) + (setup-search search)) diff --git a/collects/framework/main.ss b/collects/framework/main.ss index ecbbdfb7..f564d72e 100644 --- a/collects/framework/main.ss +++ b/collects/framework/main.ss @@ -4,6 +4,9 @@ ;; preferences + (mred:preferences:set-preference-default 'mred:verify-change-format #f boolean?) + + (mred:preferences:set-preference-default 'mred:auto-set-wrap? #f boolean?) (preferences:set-default 'framework:display-line-numbers #t boolean?) @@ -18,8 +21,8 @@ (preferences:set 'framework:print-output-mode - 0 - (lambda (x) (or (= x 0) (= x 1)))) + 'standard + (lambda (x) (or (eq? x 'standard) (eq? x 'postscript)))) diff --git a/collects/framework/prefs.ss b/collects/framework/prefs.ss index 3ea00e3a..125ab260 100644 --- a/collects/framework/prefs.ss +++ b/collects/framework/prefs.ss @@ -1,5 +1,6 @@ (unit/sig framework:preferences^ - (import [exn : framework:exn^] + (import mred^ + [exn : framework:exn^] [exit : framework:exit^] [mzlib:pretty-print : mzlib:pretty-print^] [mzlib:function : mzlib:function^]) diff --git a/collects/framework/sig.ss b/collects/framework/sig.ss index eda17f0c..bbd1711a 100644 --- a/collects/framework/sig.ss +++ b/collects/framework/sig.ss @@ -1,3 +1,4 @@ + (require-library "refer.ss") (require-library "cores.ss") (require-library "match.ss") @@ -9,7 +10,7 @@ (empty<%> standard-menus<%> empty-standard-menus<%> - edit<%> + editor<%> searchable<%> pasteboard<%> info<%> @@ -17,14 +18,14 @@ make-empty% make-standard-menus% - make-edit% + make-editor% make-searchable% make-info% make-file% empty% standard-menus% - edit% + editor% searchable% info% info-file% @@ -36,7 +37,7 @@ (add-spec version)) -(define-signature mred:panel^ +(define-signature framework:panel^ (make-edit% edit<%> horizontal-edit% @@ -44,9 +45,8 @@ (define-signature framework:exn^ ((struct exn ()) - (struct exn:unknown-preference ()) - (struct exn:during-preferences ()) - (struct exn:url ()))) + (struct unknown-preference ()) + (struct during-preferences ()))) (define-signature framework:application^ (current-app-name)) @@ -82,6 +82,7 @@ local-busy-cursor unsaved-warning read-snips/chars-from-buffer + get-choice open-input-buffer)) (define-signature framework:path-utils^ @@ -100,7 +101,7 @@ get-file put-file)) -(define framework:editor^ +(define-signature framework:editor^ (editor:basic<%> editor:info<%> editor:autosave<%> @@ -110,6 +111,13 @@ editor:make-file% editor:make-backup-autosave%)) +(define-signature framework:pasteboard^ + (basic% + file% + clever-file-format% + backup-autosave% + info%)) + (define-signature framework:text^ (text:basic<%> text:searching<%> @@ -196,7 +204,7 @@ pasteboard-info% pasteboard-info-file%)) -(define-signature mred:group^ +(define-signature framework:group^ (frame-group% the-frame-group)) @@ -207,7 +215,6 @@ find-format-handler find-named-format-handler edit-file - open-url open-file)) (define-signature framework:icon^ @@ -229,21 +236,22 @@ get-gc-width get-gc-height)) -(define-signature mred:keymap^ - (keyerr +(define-signature framework:keymap^ + (shifted-key-list + + keyerr set-keymap-error-handler - shifted-key-list set-keymap-implied-shifts make-meta-prefix-list send-map-function-meta - setup-global-keymap - setup-global-search-keymap - setup-global-file-keymap + setup-global + setup-search + setup-file - global-keymap - global-search-keymap - global-file-keymap)) + global + search + file)) (define-signature framework:match-cache^ (%)) @@ -286,52 +294,34 @@ backward-match skip-whitespace)) - -(define-signature mred:hyper-edit^ - ((struct hypertag (name position)) - (struct hyperlink (anchor-start anchor-end url-string)) - hyper-buffer-data% - hyper-data-class - make-hyper-edit% - hyper-edit%)) - -(define-signature mred:hyper-dialog^ - (hyper-tag-dialog% - hyper-get-current-tags)) - -(define-signature mred:hyper-frame^ - (hyper-frame-group - make-hyper-canvas% - hyper-canvas% - make-hyper-basic-frame% - hyper-basic-frame% - make-hyper-view-frame% - hyper-view-frame% - make-hyper-make-frame% - hyper-make-frame% - open-hyper-view - open-hyper-make - hyper-text-require)) - (define-signature mred^ - ((unit constants : mred:constants^) - (open mred:version^) - (open mred:exn-external^) - (open mred:connections^) (open mred:container^) (open mred:preferences^) - (open mred:autoload^) (open mred:autosave^) (open mred:exit^) - (open mred:gui-utils^) (open mred:console^) (open mred:path-utils^) - (open mred:finder^) - (open mred:find-string^) (open mred:edit^) (open mred:canvas^) - (open mred:frame^) (open mred:editor-frame^) - (open mred:group^) (open mred:handler^) (open mred:icon^) (open mred:keymap^) - (open mred:match-cache^) (open mred:menu^) (open mred:mode^) - (open mred:panel^) (open mred:paren^) (open mred:project^) - (open mred:scheme-paren^) (open mred:scheme-mode^) - (open mred:hyper-edit^) (open mred:hyper-dialog^) (open mred:hyper-frame^) - (open mred:testable-window^) - (unit test : mred:self-test-export^) - (open mred:url^) - (open mred:graph^) - (open mred:application^) - (open mred:control^))) + ([unit application : framework:application^] + [unit version : framework:version^] + [unit exn : framework:exn^] + [unit exit : framework:exit^] + [unit preferences : framework:preferences^] + [unit autosave : framework:autosave^] + [unit handler : framework:handler^] + [unit keymap : framework:keymap^] + [unit match-cache : framework:match-cache^] + [unit paren : framework:paren^] + [unit scheme-paren : framework:scheme-paren^] + [unit path-utils : framework:path-utils^] + [unit icon : framework:icon^] + [unit editor : framework:editor^] + [unit pasteboard : framework:pasteboard^] + [unit text : framework:text^] + + [unit gui-utils : framework:gui-utils^] + + [unit finder : framework:finder^] + + [unit group : framework:group^] + + [unit canvas : framework:canvas^] + + [unit panel : framework:panel^] + + [unit frame : framework:frame^] + [unit scheme-mode : framework:scheme-mode^])) \ No newline at end of file diff --git a/collects/framework/version.ss b/collects/framework/version.ss index db1538e7..6222e236 100644 --- a/collects/framework/version.ss +++ b/collects/framework/version.ss @@ -1,15 +1,14 @@ - (unit/sig mred:version^ - (import [mzlib:string^ : mzlib:string^]) + (unit/sig framework:version^ + (import [mzlib:string : mzlib:string^] + [mzlib:function : mzlib:function^]) (rename [-version version]) - (mred:debug:printf 'invoke "mred:version@") - (define specs null) (define -version (lambda () - (mzlib:functionfoldr + (mzlib:function:foldr (lambda (entry sofar) (match entry [(sep num) (string-append sofar sep num)]))