From 89a5e422e1be830ce26dd376e82bfe7a4ac9763e Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 9 Sep 1998 13:51:39 +0000 Subject: [PATCH] ... original commit: 6cd40de9ccf0d15a24d9590c875de9e822b99bef --- collects/framework/frame.ss | 692 +++++++++++++++++++++++++++++++++- collects/framework/group.ss | 39 +- collects/framework/main.ss | 105 ++++-- collects/framework/sig.ss | 198 ++++------ collects/framework/version.ss | 4 +- 5 files changed, 842 insertions(+), 196 deletions(-) diff --git a/collects/framework/frame.ss b/collects/framework/frame.ss index 13543a88..e0ad9364 100644 --- a/collects/framework/frame.ss +++ b/collects/framework/frame.ss @@ -393,10 +393,10 @@ (public [save-as - (opt-lambda ([format wx:const-media-ff-same]) + (opt-lambda ([format 'same]) (let ([file (parameterize ([mred:finder:dialog-parent-parameter this]) - (mred:finder:put-file))]) + (finder:put-file))]) (when file (send (get-edit) save-file file format))))] [file-menu:revert @@ -423,9 +423,9 @@ (send edit end-edit-sequence)) (begin (send edit end-edit-sequence) - (mred:gui-utils:message-box - (format "could not read ~a" filename) - "Error Reverting")))))) + (message-box + "Error Reverting" + (format "could not read ~a" filename))))))) #t))] [file-menu:save (lambda () (send (get-edit) save-file) @@ -439,8 +439,8 @@ (lambda () (when (active-canvas) (send panel split (active-canvas) panel%))))]) - (send file-menu append-item "Split Horizontally" (split mred:container:horizontal-panel%)) - (send file-menu append-item "Split Vertically" (split mred:container:vertical-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) @@ -451,7 +451,7 @@ '() #t #t - (mred:preferences:get-preference 'mred:print-output-mode)) + (preferences:get 'framework:print-output-mode)) #t)]) (private @@ -569,6 +569,682 @@ (do-title) (let ([canvas (get-canvas)]) (send canvas set-focus))))) + + (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 (null? snip) + (not (is-a? snip wx:media-snip%))) + edit + (loop (send snip get-this-media))))))] + [clear-highlight + (lambda () + (begin (old-highlight) + (set! old-highlight void)))] + [reset-anchor + (let ([color (make-object wx:colour% "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-edit-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? + (wx: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-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) + (send searching-edit + find-string-embedded + 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]) + (public + [lines 2] + [style-flags wx:const-mcanvas-hide-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)))]) + (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 + (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 + [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))]) + (public + [on-activate + (lambda (on?) + (unless hidden? + (if on? + (reset-anchor (get-edit-to-search)) + (clear-highlight))) + (super-on-activate on?))] + [get-edit-to-search + (lambda () + (get-edit))] + [hide-search + (opt-lambda ([startup? #f]) + (send super-root delete-child search-panel) + (clear-highlight) + (unless startup? + (send + (send (get-edit-to-search) get-canvas) + set-focus)) + (set! hidden? #t))] + [unhide-search + (lambda () + (set! hidden? #f) + (send super-root add-child search-panel) + (reset-anchor (get-edit-to-search)))]) + (public + [do-close + (lambda () + (super-do-close) + (let ([close-canvas + (lambda (canvas edit) + (send edit remove-canvas canvas) + (send canvas set-media ()))]) + (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)))] + [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-edit-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-edit-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-edit-to-search) get-canvas)] + [else + find-canvas]) + set-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 set-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 set-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% 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"))] + [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 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 frame:edit<%> frame:info<%> args + (rename [super-make-root-panel make-root-panel]) + (private + [rest-panel 'uninitialized-root] + [super-root 'uninitialized-super-root]) + (public + [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 null) + (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 user-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) + (wx:unregister-collecting-blit gc-canvas)) + (send super-root change-children + (lambda (l) + (if v + (list rest-panel info-panel) + (list rest-panel))))))]) + (public + [do-close + (lambda () + (super-do-close) + (send time-canvas set-media null) + (unregister-collecting-blit gc-canvas) + (close-panel-callback))]) + + (inherit get-edit) + (public + [get-info-edit + (lambda () + (and (procedure? get-edit) + (get-edit)))]) + + (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 (mred:icon:get-unlock-bitmap)]) + (if (send b ok?) + (cons (mred: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 (mred: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)))))]) + + (sequence + (unless (mred:preferences:get-preference 'mred: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))))) + + (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)))) + + (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?))))]))))) (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 a984978d..21fb9f6f 100644 --- a/collects/framework/group.ss +++ b/collects/framework/group.ss @@ -3,7 +3,7 @@ [mzlib:function : mzlib:function^] [mzlib:file : mzlib:file^]) - (define frame-group% + (define % (let-struct frame (frame id) (class null () (private @@ -194,39 +194,4 @@ frame (loop (cdr frames))))]))))])))) - (define the-frame-group (make-object frame-group%)) - - (define at-most-one-maker - (lambda () - (let ([s (make-semaphore 1)] - [test #f]) - (lambda (return thunk) - (semaphore-wait s) - (if test - (begin (semaphore-post s) - return) - (begin - (set! test #t) - (semaphore-post s) - (begin0 (thunk) - (semaphore-wait s) - (set! test #f) - (semaphore-post s)))))))) - - (define at-most-one (at-most-one-maker)) - - (send the-frame-group set-empty-callbacks - (lambda () - (at-most-one (void) - (lambda () (exit:exit #t)))) - (lambda () - (at-most-one #t - (lambda () - (exit:run-exit-callbacks))))) - - (exit:insert-exit-callback - (lambda () - (at-most-one - #t - (lambda () - (send the-frame-group close-all)))))) + (define the-frame-group (make-object %))) \ No newline at end of file diff --git a/collects/framework/main.ss b/collects/framework/main.ss index fba07b6f..ecbbdfb7 100644 --- a/collects/framework/main.ss +++ b/collects/framework/main.ss @@ -4,6 +4,25 @@ ;; preferences + + (preferences:set-default 'framework:display-line-numbers #t boolean?) + + (preferences:set-preference-default 'mred:show-status-line + #t + boolean?) + (preferences:set-preference-default 'mred:line-offsets + #t + boolean?) + + + + + (preferences:set 'framework:print-output-mode + 0 + (lambda (x) (or (= x 0) (= x 1)))) + + + (preferences:set-default 'framework:highlight-parens #t boolean?) (preferences:set-default 'framework:fixup-parens #t boolean?) (preferences:set-default 'framework:paren-match #t boolean?) @@ -23,22 +42,22 @@ sequence)) (for-each (lambda (x) (hash-table-put! hash-table x 'lambda)) '(lambda let let* letrec letrec* recur - let/cc let/ec letcc catch - let-syntax letrec-syntax syntax-case - let-signature fluid-let - let-struct let-macro let-values let*-values - case when unless match - let-enumerate - class class* class-asi class-asi* - define-some do opt-lambda send* - local catch shared - unit/sig - with-handlers with-parameterization - interface - parameterize - call-with-input-file with-input-from-file - with-input-from-port call-with-output-file - with-output-to-file with-output-to-port)) + let/cc let/ec letcc catch + let-syntax letrec-syntax syntax-case + let-signature fluid-let + let-struct let-macro let-values let*-values + case when unless match + let-enumerate + class class* class-asi class-asi* + define-some do opt-lambda send* + local catch shared + unit/sig + with-handlers with-parameterization + interface + parameterize + call-with-input-file with-input-from-file + with-input-from-port call-with-output-file + with-output-to-file with-output-to-port)) (mred:preferences:set-preference-un/marshall 'mred:tabify (lambda (t) (hash-table-map t list)) @@ -46,8 +65,8 @@ (for-each (lambda (x) (apply hash-table-put! h x)) l) h))) (mred:preferences:set-preference-default 'mred:tabify hash-table hash-table?)) - - + + (preferences:set-default 'framework:autosave-delay 300 number?) (preferences:set-default 'framework:autosaving-on? #t boolean?) (preferences:set-default 'framework:verify-exit #t boolean?) @@ -120,8 +139,8 @@ [add-button (make-object mred:button% button-panel (add-callback string symbol box) "Add")] [delete-button (make-object mred:button% button-panel (delete-callback box) "Remove")]) (send* button-panel - (major-align-center) - (stretchable-in-y #f)) + (major-align-center) + (stretchable-in-y #f)) (send add-button user-min-width (send delete-button get-width)) box))] [begin-list-box (make-column "Begin" 'begin begin-keywords)] @@ -139,11 +158,49 @@ #t))]) (mred:preferences:add-preference-callback 'mred:tabify (lambda (p v) (update-list-boxes v))) main-panel)))) - + (preferences:read) - + + ;; groups + + (define at-most-one-maker + (lambda () + (let ([s (make-semaphore 1)] + [test #f]) + (lambda (return thunk) + (semaphore-wait s) + (if test + (begin (semaphore-post s) + return) + (begin + (set! test #t) + (semaphore-post s) + (begin0 (thunk) + (semaphore-wait s) + (set! test #f) + (semaphore-post s)))))))) + + (let ([at-most-one (at-most-one-maker)]) + (send the-frame-group set-empty-callbacks + (lambda () + (at-most-one (void) + (lambda () (exit:exit #t)))) + (lambda () + (at-most-one #t + (lambda () + (exit:run-exit-callbacks))))) + + (exit:insert-exit-callback + (lambda () + (at-most-one + #t + (lambda () + (send the-frame-group close-all)))))) + + + ;; misc other stuff - + (exit:insert-callback (lambda () (with-handlers ([(lambda (x) #t) @@ -153,5 +210,5 @@ (exn-message exn)) "Saving Prefs"))]) (save-user-preferences)))) - + (wx:application-file-handler edit-file)) diff --git a/collects/framework/sig.ss b/collects/framework/sig.ss index e09a3d07..eda17f0c 100644 --- a/collects/framework/sig.ss +++ b/collects/framework/sig.ss @@ -32,51 +32,15 @@ pasteboard-info% pasteboard-info-file%)) -(define-signature mred:graph^ - (node-snip% - make-node-snip% - graph-pasteboard% - make-graph-pasteboard%)) - -(define-signature mred:connections^ - (connections-frame% - connections-dialog-box% - connections-media-edit% - connections-media-pasteboard% - connections-media-canvas% - connections-panel% - - make-connections-frame% - make-connections-media-buffer% - make-connections-media-canvas% - make-connections-panel%)) - -(define-signature mred:version^ - (add-version-spec +(define-signature framework:version^ + (add-spec version)) -(define-signature mred:html^ - (html-convert)) - (define-signature mred:panel^ - (make-edit-panel% - horizontal-edit-panel% - vertical-edit-panel%)) - -(define-signature mred:url^ - ((struct url (scheme host port path params query fragment)) - unixpath->path - get-pure-port ; url [x list (str)] -> in-port - get-impure-port ; url [x list (str)] -> in-port - display-pure-port ; in-port -> () - purify-port ; in-port -> list (mime-header) - netscape/string->url ; (string -> url) - string->url ; str -> url - url->string - call/input-url ; url x (url -> in-port) x - ; (in-port -> ()) - ; [x list (str)] -> () - combine-url/relative)) ; url x str -> url + (make-edit% + edit<%> + horizontal-edit% + vertical-edit%)) (define-signature framework:exn^ ((struct exn ()) @@ -84,17 +48,9 @@ (struct exn:during-preferences ()) (struct exn:url ()))) -(define-signature mred:hyper-loader^ - (open-hyper-make - open-hyper-view - hyper-text-require)) - (define-signature framework:application^ (current-app-name)) -(define-signature mred:exn-external^ - (exn? exn:unknown-preference? exn:during-preferences? exn:url?)) - (define-signature framework:preferences^ (get add-callback @@ -113,57 +69,26 @@ (define-signature framework:autosave^ (register)) -(define-signature mred:exit^ +(define-signature framework:exit^ (insert-callback remove-callback run-callbacks exit)) -(define-signature mred:gui-utils^ - (get-font-from-user - get-colour-from-user - get-text-from-user - message-box - cursor-delay +(define-signature framework:gui-utils^ + (cursor-delay show-busy-cursor delay-action local-busy-cursor - get-choice unsaved-warning read-snips/chars-from-buffer - open-input-buffer - print-paper-names - get-single-choice)) + open-input-buffer)) -(define-signature mred:console^ - (credits-proc - credits - copyright-string - welcome-message - - separator-snip% - - console-max-save-previous-exprs - - show-interactions-history - - make-scheme-mode-edit% - scheme-mode-edit% - - make-console-edit% - console-edit% - - transparent-io-edit% - make-transparent-io-edit% - - make-console-frame% - console-frame%)) - -(define-signature mred:path-utils^ +(define-signature framework:path-utils^ (generate-autosave-name generate-backup-name)) -(define-signature mred:finder^ +(define-signature framework:finder^ (filter-match? dialog-parent-parameter common-put-file @@ -175,12 +100,43 @@ get-file put-file)) -(define-signature mred:find-string^ - (make-find-frame% - find-frame% - find-string)) +(define framework:editor^ + (editor:basic<%> + editor:info<%> + editor:autosave<%> + + editor:make-basic% + editor:make-info% + editor:make-file% + editor:make-backup-autosave%)) -(define-signature mred:edit^ +(define-signature framework:text^ + (text:basic<%> + text:searching<%> + + text:make-basic% + text:make-return% + text:make-searching% + text:make-clever-file-format% + text:make-scheme% + + text:basic% + text:return% + text:searching% + text:info% + text:clever-file-format% + text:file% + text:backup-autosave% + text:scheme%)) + +(define-signature framework:pasteboard% + (pasteboard:basic% + pasteboard:info% + pasteboard:file% + pasteboard:backup-autosave%)) + + +(define-signature framework:edit^ (make-std-buffer% make-pasteboard% make-info-buffer% @@ -212,39 +168,33 @@ (make-wide-snip-canvas% wide-snip-canvas%)) -(define-signature mred:frame^ - (frame-width - frame-height +(define-signature framework:frame^ + (empty<%> + standard-menus<%> + empty-standard-menus<%> + edit<%> + searchable<%> + pasteboard<%> + info<%> + info-file<%> - make-simple-frame% - make-menu-frame% - make-standard-menus-frame% - make-searchable-frame% - - make-info-frame% - make-edit-info-frame% - - make-file-frame% - - make-pasteboard-frame% - make-pasteboard-file-frame% - make-pasteboard-info-frame% - - empty-frame% - menu-frame% - standard-menus-frame% - simple-menu-frame% - searchable-frame% - info-frame% - info-file-frame% - pasteboard-frame% - pasteboard-info-frame% - pasteboard-info-file-frame%)) - -(define-signature mred:editor-frame^ - (make-editor-frame% - editor-frame% - make-status-frame%)) + make-empty% + make-standard-menus% + make-edit% + make-searchable% + make-pasteboard% + make-info% + make-file% + + empty% + standard-menus% + edit% + searchable% + info% + info-file% + pasteboard% + pasteboard-info% + pasteboard-info-file%)) (define-signature mred:group^ (frame-group% diff --git a/collects/framework/version.ss b/collects/framework/version.ss index 62516208..db1538e7 100644 --- a/collects/framework/version.ss +++ b/collects/framework/version.ss @@ -1,7 +1,5 @@ (unit/sig mred:version^ - (import [wx : wx^] - [mzlib:function : mzlib:function^] - [mzlib:string^ : mzlib:string^]) + (import [mzlib:string^ : mzlib:string^]) (rename [-version version])