diff --git a/collects/framework/framework.ss b/collects/framework/framework.ss index 40c749d3..c042d5ac 100644 --- a/collects/framework/framework.ss +++ b/collects/framework/framework.ss @@ -858,6 +858,14 @@ "This returns the parenthesis highlight " "@link bitmap %" ". It is only used on black and white screens.") + (icon:get-eof-bitmap + (-> (is-a?/c bitmap%)) + () + "This returns the" + "@link bitmap %" + "used for the clickable ``eof'' icon from" + "@ilink text:ports %" + ".") (icon:get-autowrap-bitmap (-> (is-a?/c bitmap%)) () @@ -1499,5 +1507,16 @@ "@flink editor:get-standard-style-list" "and \\var{example-text} is shown in the panel so users can see" "the results of their configuration.") + + (color-prefs:marshall-style + (-> (is-a?/c style-delta%) printable/c) + (style-delta) + "Builds a printed representation for a style-delta.") + + (color-prefs:unmarshall-style + (-> printable/c (union false/c (is-a?/c style-delta%))) + (marshalled-style-delta) + "Builds a style delta from its printed representation." + "Returns \\scheme|#f| if the printed form cannot be parsed.") )) diff --git a/collects/framework/private/editor.ss b/collects/framework/private/editor.ss index 7170e72f..281d1966 100644 --- a/collects/framework/private/editor.ss +++ b/collects/framework/private/editor.ss @@ -41,7 +41,8 @@ load-file/gui-error on-close can-close? - close)) + close + get-filename/untitled-name)) (define basic-mixin (mixin (editor<%>) (basic<%>) @@ -52,6 +53,19 @@ (begin (on-close) #t) #f)) + ;; get-filename/untitled-name : -> string + ;; returns a string representing the visible name for this file, + ;; or "Untitled " for some n. + (define untitled-name #f) + (define/public (get-filename/untitled-name) + (let ([filename (get-filename)]) + (if filename + (path->string filename) + (begin + (unless untitled-name + (set! untitled-name (gui-utils:next-untitled-name))) + untitled-name)))) + (inherit get-filename save-file) (define/public save-file/gui-error (opt-lambda ([input-filename #f] @@ -402,7 +416,6 @@ (define file<%> (interface (-keymap<%>) - get-filename/untitled-name get-can-close-parent update-frame-filename allow-close-with-no-filename?)) @@ -413,7 +426,7 @@ is-modified? set-modified get-top-level-window) - (inherit get-canvases) + (inherit get-canvases get-filename/untitled-name) (define/public (update-frame-filename) (let* ([filename (get-filename)] [name (if filename @@ -426,19 +439,6 @@ (send tlw set-label name)))) (get-canvases)))) - ;; get-filename/untitled-name : -> string - ;; returns a string representing the visible name for this file, - ;; or "Untitled " for some n. - (define untitled-name #f) - (define/public (get-filename/untitled-name) - (let ([filename (get-filename)]) - (if filename - (path->string filename) - (begin - (unless untitled-name - (set! untitled-name (gui-utils:next-untitled-name))) - untitled-name)))) - (define/override set-filename (case-lambda [(name) (set-filename name #f)] diff --git a/collects/framework/private/frame.ss b/collects/framework/private/frame.ss index 96f81ef2..4f4e5d5d 100644 --- a/collects/framework/private/frame.ss +++ b/collects/framework/private/frame.ss @@ -995,22 +995,21 @@ (set! label t) (do-label)))] - (public get-canvas% get-canvas<%> make-canvas get-editor% get-editor<%> make-editor) - [define get-canvas% (λ () editor-canvas%)] - [define get-canvas<%> (λ () (class->interface editor-canvas%))] - [define make-canvas (λ () - (let ([% (get-canvas%)] - [<%> (get-canvas<%>)]) - (unless (implementation? % <%>) - (error 'frame:editor% - "result of get-canvas% method must match ~e interface; got: ~e" - <%> %)) - (instantiate % () (parent (get-area-container)))))] - (define (get-editor%) + (define/public (get-canvas%) editor-canvas%) + (define/public (get-canvas<%>) (class->interface editor-canvas%)) + (define/public (make-canvas) + (let ([% (get-canvas%)] + [<%> (get-canvas<%>)]) + (unless (implementation? % <%>) + (error 'frame:editor% + "result of get-canvas% method must match ~e interface; got: ~e" + <%> %)) + (instantiate % () (parent (get-area-container))))) + (define/public (get-editor%) (error 'editor-frame% "abstract method: no editor% class specified")) - (define (get-editor<%>) - editor<%>) - (define (make-editor) + (define/public (get-editor<%>) + editor:basic<%>) + (define/public (make-editor) (let ([% (get-editor%)] [<%> (get-editor<%>)]) (unless (implementation? % <%>) @@ -1296,13 +1295,13 @@ [(cancel) #f])))) - (super-instantiate ()))) + (super-new))) (define text<%> (interface (-editor<%>))) (define text-mixin (mixin (-editor<%>) (text<%>) - [define/override get-editor<%> (λ () (class->interface text%))] - [define/override get-editor% (λ () text:keymap%)] + (define/override (get-editor<%>) (class->interface text%)) + (define/override (get-editor%) text:keymap%) (super-new))) (define pasteboard<%> (interface (-editor<%>))) diff --git a/collects/framework/private/sig.ss b/collects/framework/private/sig.ss index 85d4ba60..26a2b514 100644 --- a/collects/framework/private/sig.ss +++ b/collects/framework/private/sig.ss @@ -314,6 +314,7 @@ 1-pixel-string-snip% 1-pixel-tab-snip% delegate% + wide-snip% standard-style-list% keymap% return% diff --git a/collects/framework/private/text.ss b/collects/framework/private/text.ss index 9a35b6ec..0377d1d1 100644 --- a/collects/framework/private/text.ss +++ b/collects/framework/private/text.ss @@ -995,7 +995,8 @@ WARNING: printf is rebound in the body of the unit to always (define/public-final (get-insertion-point) insertion-point) (define/public-final (set-insertion-point ip) (set! insertion-point ip)) - (define/public-final (get-unread-start-point) unread-start-point) + (define/public-final (get-unread-start-point) + unread-start-point) (define/public-final (set-unread-start-point u) (unless (<= u (last-position)) (error 'set-unread-start-point "~e is too large, last-position is ~e" @@ -1076,7 +1077,7 @@ WARNING: printf is rebound in the body of the unit to always ;; (define/augment (can-insert? start len) - (and (or allow-edits? + (and (or allow-edits? (start . >= . unread-start-point)) (inner #t can-insert? start len))) @@ -1929,7 +1930,8 @@ WARNING: printf is rebound in the body of the unit to always (define hide-caret/selection% (hide-caret/selection-mixin basic%)) (define nbsp->space% (nbsp->space-mixin basic%)) (define delegate% (delegate-mixin basic%)) - (define standard-style-list% (editor:standard-style-list-mixin (wide-snip-mixin basic%))) + (define wide-snip% (wide-snip-mixin basic%)) + (define standard-style-list% (editor:standard-style-list-mixin wide-snip%)) (define input-box% (input-box-mixin standard-style-list%)) (define -keymap% (editor:keymap-mixin standard-style-list%)) (define return% (return-mixin -keymap%)) diff --git a/collects/tests/framework/canvas.ss b/collects/tests/framework/canvas.ss index 6dd251bf..767a292a 100644 --- a/collects/tests/framework/canvas.ss +++ b/collects/tests/framework/canvas.ss @@ -9,7 +9,7 @@ (send-sexp-to-mred `(let* ([f (make-object frame:basic% "test canvas" #f 300 300)] [c (make-object ,class (send f get-area-container))]) - (send c set-editor (make-object text:basic%)) + (send c set-editor (make-object text:wide-snip%)) (send f show #t))) (wait-for-frame "test canvas") (send-sexp-to-mred diff --git a/collects/tests/framework/exit.ss b/collects/tests/framework/exit.ss index 4154fdf8..00e59713 100644 --- a/collects/tests/framework/exit.ss +++ b/collects/tests/framework/exit.ss @@ -22,7 +22,7 @@ (with-handlers ([eof-result? (lambda (x) 'passed)]) (send-sexp-to-mred `(begin - (exit:insert-can?-callback (lambda () (call-with-output-file ,tmp-file void) #t)) + (exit:insert-can?-callback (lambda () (call-with-output-file (bytes->path ,(path->bytes tmp-file)) void) #t)) (begin (exit:exit) (sleep/yield 1))))))) (test 'exit-callback-removed diff --git a/collects/tests/framework/frame.ss b/collects/tests/framework/frame.ss index 5be0150d..13a8b9c1 100644 --- a/collects/tests/framework/frame.ss +++ b/collects/tests/framework/frame.ss @@ -85,10 +85,6 @@ 'searchable-mixin '(frame:searchable-mixin frame:text%)) - (test-creation - 'text-info-file%-creation - 'frame:text-info-file%) - (test-creation 'pasteboard-mixin-creation '(frame:pasteboard-mixin frame:editor%)) @@ -99,10 +95,6 @@ 'pasteboard%-creation 'frame:pasteboard%) - (test-creation - 'pasteboard-info-file%-creation - 'frame:pasteboard-info-file%) - (define (test-open name class-expression) (let* ([test-file-contents "test"] [tmp-file-name "framework-tmp"] @@ -117,7 +109,7 @@ (lambda () (let ([frame-name (send-sexp-to-mred - `(let ([frame (instantiate ,class-expression ())]) + `(let ([frame (new ,class-expression)]) (preferences:set 'framework:file-dialogs 'common) (send frame show #t) (send frame get-label)))]) @@ -137,7 +129,7 @@ [(windows) `(test:keystroke #\a '(control))] [else (error 'file-open-dialog "unknown system type: ~a" (system-type))]) (for-each test:keystroke - (string->list ,tmp-file)) + (string->list ,(path->string tmp-file))) (test:keystroke #\return))) (wait-for-frame tmp-file-name) (begin0 @@ -150,6 +142,5 @@ (queue-sexp-to-mred `(send (get-top-level-focus-window) close)))))))) - (test-open "frame:editor open" 'frame:text%) (test-open "frame:searchable open" 'frame:searchable%) - (test-open "frame:text-info open" 'frame:text-info-file%)) + (test-open "frame:text open" 'frame:text%)) diff --git a/collects/tests/framework/load.ss b/collects/tests/framework/load.ss index 0be7c732..56d1dbc5 100644 --- a/collects/tests/framework/load.ss +++ b/collects/tests/framework/load.ss @@ -25,15 +25,13 @@ (test/load "gui-utils.ss" 'gui-utils:next-untitled-name) (test/load "test.ss" 'test:run-interval) - (test/load "macro.ss" '(mixin () () ())) (test/load "splash.ss" 'start-splash) (test/load "framework-sig.ss" '(begin (eval '(require (lib "unitsig.ss"))) (eval '(define-signature dummy-signature^ framework^)))) (test/load "framework-unit.ss" 'framework@) (test/load "framework.ss" '(list test:button-push gui-utils:next-untitled-name - frame:basic-mixin - (mixin () () ()))) + frame:basic-mixin)) ;; ensures that all of the names in the signature are provided ;; by (require (lib "framework.ss" "framework")) diff --git a/collects/tests/framework/mem.ss b/collects/tests/framework/mem.ss index 5274ba64..0bf6ee72 100644 --- a/collects/tests/framework/mem.ss +++ b/collects/tests/framework/mem.ss @@ -111,7 +111,7 @@ (send f show #t))))) (define (test-frame-allocate %) - (let ([name (symbol->string %)]) + (let ([name (format "~s" %)]) (send-sexp-to-mred '(preferences:set 'framework:exit-when-no-frames #f)) (test-allocate name `(lambda () (let ([f (make-object ,% ,name)]) @@ -159,6 +159,7 @@ '(lambda () (make-object text:return% void)) '(lambda (t) (void))) + (test-frame-allocate '(class frame% (inherit show) (define/public (close) (show #f)) (super-new))) (test-frame-allocate 'frame:basic%) (test-frame-allocate 'frame:info%) (test-frame-allocate 'frame:text-info%) @@ -166,9 +167,7 @@ (test-frame-allocate 'frame:standard-menus%) (test-frame-allocate 'frame:text%) - (test-frame-allocate 'frame:text-info-file%) (test-frame-allocate 'frame:searchable%) (test-frame-allocate 'frame:pasteboard%) - (test-frame-allocate 'frame:pasteboard-info-file%) (done)) diff --git a/collects/tests/framework/panel.ss b/collects/tests/framework/panel.ss index 044f69c7..4b3a7b1f 100644 --- a/collects/tests/framework/panel.ss +++ b/collects/tests/framework/panel.ss @@ -7,9 +7,8 @@ `(let* ([semaphore (make-semaphore 0)] [semaphore-frame% (class frame% - (override on-close) - [define on-close (lambda () (semaphore-post semaphore))] - (super-instantiate ()))] + (define/augment (on-close) (semaphore-post semaphore)) + (super-new))] [f (make-object semaphore-frame% "Single Panel Test")] [blue-brush (send the-brush-list find-or-create-brush "BLUE" 'solid)] [green-brush (send the-brush-list find-or-create-brush "FOREST GREEN" 'solid)] diff --git a/collects/tests/framework/text.ss b/collects/tests/framework/text.ss index f656c4d1..a4ddc082 100644 --- a/collects/tests/framework/text.ss +++ b/collects/tests/framework/text.ss @@ -23,8 +23,12 @@ (send-sexp-to-mred `(test:keystroke #\a)) (wait-for `(string=? "a" (send (send (get-top-level-focus-window) get-editor) get-text))) (send-sexp-to-mred - `(begin (send (send (get-top-level-focus-window) get-editor) lock #t) - (send (send (get-top-level-focus-window) get-editor) lock #f))) + `(begin + ;; remove the `a' to avoid save dialog boxes (and test them, I suppose) + (send (send (get-top-level-focus-window) get-editor) undo) + + (send (send (get-top-level-focus-window) get-editor) lock #t) + (send (send (get-top-level-focus-window) get-editor) lock #f))) (queue-sexp-to-mred `(send (get-top-level-focus-window) close)) (send-sexp-to-mred `(map (lambda (x) (send x get-label)) (get-top-level-windows)))))))