diff --git a/collects/framework/comment-snip.ss b/collects/framework/comment-snip.ss new file mode 100644 index 00000000..06783bc1 --- /dev/null +++ b/collects/framework/comment-snip.ss @@ -0,0 +1,37 @@ +(module comment-snip mzscheme + (require (lib "class.ss") + (lib "mred.ss" "mred")) + + (provide snip-class comment-box-snip%) + + (define comment-box-snipclass% + (class snip-class% + (define/override (read stream-in) + (let* ([snip (instantiate comment-box-snip% ())]) + (send (send snip get-editor) read-from-file stream-in) + snip)) + (super-instantiate ()))) + + (define snip-class (make-object comment-box-snipclass%)) + (send snip-class set-version 1) + (send snip-class set-classname (format "~s" '(lib "comment-snip.ss" "framework"))) + (send (get-the-snip-class-list) add snip-class) + + (define comment-box-snip% + (class* editor-snip% (readable-snip<%>) + (inherit get-editor get-style) + (define/override (write stream-out) + (send (get-editor) write-to-file stream-out 0 'eof)) + (define/override (copy) + (let ([snip (make-object comment-box-snip%)]) + (send snip set-editor (send (get-editor) copy-self)) + (send snip set-style (get-style)) + snip)) + (define/public (read-one-special index source line column position) + (raise (make-exn:special-comment + "msg" + (current-continuation-marks) + 1))) + (super-instantiate ()) + (inherit set-snipclass) + (set-snipclass snip-class)))) \ No newline at end of file diff --git a/collects/framework/private/frame.ss b/collects/framework/private/frame.ss index 6984074f..0ee3b2b7 100644 --- a/collects/framework/private/frame.ss +++ b/collects/framework/private/frame.ss @@ -11,7 +11,8 @@ (lib "mred-sig.ss" "mred") (lib "list.ss") (lib "file.ss") - (lib "etc.ss")) + (lib "etc.ss") + (prefix cb: "../comment-snip.ss")) (provide frame@) @@ -31,7 +32,8 @@ [pasteboard : framework:pasteboard^] [editor : framework:editor^] [canvas : framework:canvas^] - [menu : framework:menu^]) + [menu : framework:menu^] + [scheme : framework:scheme^]) (rename [-editor<%> editor<%>] [-pasteboard% pasteboard%] @@ -91,10 +93,25 @@ [on-demand (lambda (menu-item) (let ([edit (get-edit-target-object)]) - (send menu-item enable (and edit (is-a? edit editor<%>)))))]) + (send menu-item enable (and edit (is-a? edit editor<%>)))))] + [insert-comment-box + (lambda () + (let ([text (get-edit-target-object)]) + (when text + (let ([snip (make-object cb:comment-box-snip%)]) + + ;; we have to do this here to avoid cycles in the + ;; module imports + (send (send snip get-editor) set-style-list (scheme:get-style-list)) + + (send text insert snip) + (send text set-caret-owner snip 'global)))))]) - (make-object c% (string-constant insert-text-box-item) - edit-menu (edit-menu:do 'insert-text-box) #f #f on-demand) + (make-object c% (string-constant insert-comment-box-menu-item-label) + edit-menu + (lambda (x y) (insert-comment-box)) + #f #f + on-demand) (make-object c% (string-constant insert-image-item) edit-menu (edit-menu:do 'insert-image) #f #f on-demand) (void))) @@ -1934,7 +1951,10 @@ (define memory-text% (class100 text% args (sequence (apply super-init args)))) (define memory-text (make-object memory-text%)) (send memory-text hide-caret #t) - (define show-memory-text? (directory-exists? (build-path (collection-path "framework") "CVS"))) + (define show-memory-text? + (with-handlers ([not-break-exn? + (lambda (x) #f)]) + (directory-exists? (build-path (collection-path "framework") "CVS")))) (define file<%> (interface (-editor<%>))) (define file-mixin diff --git a/collects/framework/private/icon.ss b/collects/framework/private/icon.ss index 5b51fce9..0b71246f 100644 --- a/collects/framework/private/icon.ss +++ b/collects/framework/private/icon.ss @@ -12,7 +12,11 @@ (import mred^) (define icon-path - (with-handlers ([void (lambda (x) (collection-path "mzlib"))]) + (with-handlers ([not-break-exn? + (lambda (x) + (case (system-type) + [(windows) "C:"] ;; just avoid quering the floppy drive + [else (car (filesystem-root-list))]))]) (collection-path "icons"))) (define (load-icon name type) @@ -22,8 +26,6 @@ (let ([bitmap (make-object bitmap% p type)]) (set! f (lambda () bitmap)) bitmap))]) - (unless (file-exists? p) - (fprintf (current-error-port) "WARNING: couldn't find ~a~n" p)) (lambda () (f)))) @@ -34,8 +36,6 @@ (let ([bitmap (make-object bitmap% p type)]) (set! f (lambda () bitmap)) bitmap))]) - (unless (file-exists? p) - (fprintf (current-error-port) "WARNING: couldn't find ~a~n" p)) (lambda () (f)))) @@ -49,8 +49,6 @@ (define (make-get/mask filename type) (let ([icon #f] [p (build-path icon-path filename)]) - (unless (file-exists? p) - (fprintf (current-error-port) "WARNING: couldn't find ~a~n" p)) (lambda () (or icon (begin @@ -58,8 +56,8 @@ icon))))) (define (make-cursor name mask fallback) - (let* ([msk-b (make-object bitmap% (build-path (collection-path "icons") mask))] - [csr-b (make-object bitmap% (build-path (collection-path "icons") name))]) + (let* ([msk-b (make-object bitmap% (build-path icon-path mask))] + [csr-b (make-object bitmap% (build-path icon-path name))]) (if (and (send msk-b ok?) (send csr-b ok?)) (let ([csr (make-object cursor% msk-b csr-b 7 7)]) diff --git a/collects/framework/private/scheme.ss b/collects/framework/private/scheme.ss index b8d07850..c20b1191 100644 --- a/collects/framework/private/scheme.ss +++ b/collects/framework/private/scheme.ss @@ -6,6 +6,7 @@ (lib "string-constant.ss" "string-constants") (lib "unitsig.ss") (lib "class.ss") + (prefix cb: "../comment-snip.ss") "sig.ss" "../macro.ss" (lib "mred-sig.ss" "mred") @@ -358,7 +359,8 @@ set-tabs set-style-list set-styles-fixed - change-style) + change-style + get-snip-position) (rename [super-on-char on-char]) (define (in-single-line-comment? position) @@ -836,44 +838,79 @@ (opt-lambda ([start-pos (get-start-position)] [end-pos (get-end-position)]) (begin-edit-sequence) - (let ([first-pos-is-first-para-pos? - (= (paragraph-start-position (position-paragraph start-pos)) - start-pos)]) - (let* ([first-para (position-paragraph start-pos)] - [last-para (calc-last-para end-pos)]) - (let para-loop ([curr-para first-para]) - (if (<= curr-para last-para) - (let ([first-on-para (paragraph-start-position curr-para)]) - (insert #\; first-on-para) - (para-loop (add1 curr-para)))))) - (when first-pos-is-first-para-pos? - (set-position - (paragraph-start-position (position-paragraph (get-start-position))) - (get-end-position)))) + (split-snip start-pos) + (split-snip end-pos) + (let* ([cb (instantiate cb:comment-box-snip% ())] + [text (send cb get-editor)]) + (send text set-style-list style-list) + (let loop ([snip (find-snip start-pos 'after-or-none)]) + (cond + [(not snip) (void)] + [((get-snip-position snip) . >= . end-pos) (void)] + [else + (send text insert (send snip copy) + (send text last-position) + (send text last-position)) + (loop (send snip next))])) + (delete start-pos end-pos) + (insert cb start-pos) + (set-position start-pos start-pos)) (end-edit-sequence) - #t)) + #t)) (define uncomment-selection (opt-lambda ([start-pos (get-start-position)] [end-pos (get-end-position)]) - (begin-edit-sequence) - (let* ([last-pos (last-position)] - [first-para (position-paragraph start-pos)] - [last-para (calc-last-para end-pos)]) - (let para-loop ([curr-para first-para]) - (if (<= curr-para last-para) - (let ([first-on-para - (paren:skip-whitespace - this - (paragraph-start-position curr-para) - 'forward)]) - (when (and (< first-on-para last-pos) - (char=? #\; (get-character first-on-para))) - (delete first-on-para (+ first-on-para 1))) - (para-loop (add1 curr-para)))))) - (end-edit-sequence) + (let ([snip-before (find-snip start-pos 'before-or-none)] + [snip-after (find-snip start-pos 'after-or-none)]) + + (begin-edit-sequence) + (cond + [(and (= start-pos end-pos) + snip-before + (is-a? snip-before cb:comment-box-snip%)) + (extract-contents start-pos snip-before)] + [(and (= start-pos end-pos) + snip-after + (is-a? snip-after cb:comment-box-snip%)) + (extract-contents start-pos snip-after)] + [(and (= (+ start-pos 1) end-pos) + snip-after + (is-a? snip-after cb:comment-box-snip%)) + (extract-contents start-pos snip-after)] + [else + (let* ([last-pos (last-position)] + [first-para (position-paragraph start-pos)] + [last-para (calc-last-para end-pos)]) + (let para-loop ([curr-para first-para]) + (if (<= curr-para last-para) + (let ([first-on-para + (paren:skip-whitespace + this + (paragraph-start-position curr-para) + 'forward)]) + (when (and (< first-on-para last-pos) + (char=? #\; (get-character first-on-para))) + (delete first-on-para (+ first-on-para 1))) + (para-loop (add1 curr-para))))))]) + (end-edit-sequence)) #t)) + ;; extract-contents : number (is-a?/c cb:comment-box-snip%) -> void + ;; copies the contents of the comment-box-snip out of the snip + ;; and into this editor as `pos'. Deletes the comment box snip + (define/private (extract-contents pos snip) + (let ([editor (send snip get-editor)]) + (let loop ([snip (send editor find-snip (send editor last-position) 'before-or-none)]) + (cond + [snip + (insert (send snip copy) pos) + (loop (send snip previous))] + [else (void)])) + (let ([snip-pos (get-snip-position snip)]) + (delete snip-pos (+ snip-pos 1))) + (set-position pos pos))) + [define get-forward-sexp (lambda (start-pos) (scheme-paren:forward-match diff --git a/collects/framework/splash.ss b/collects/framework/splash.ss index bbd18757..7d3cd28b 100644 --- a/collects/framework/splash.ss +++ b/collects/framework/splash.ss @@ -69,8 +69,11 @@ (define funny? (let ([date (seconds->date (current-seconds))]) - (and (= (date-day date) 25) - (= (date-month date) 12)))) + (and (with-handlers ([not-break-exn? (lambda (x) #f)]) + (collection-path "icons") + #t) + (= (date-day date) 25) + (= (date-month date) 12)))) (define (splash-load-handler old-load f expected) (let ([finalf (splitup-path f)]) @@ -89,8 +92,8 @@ (inherit get-dc min-width min-height stretchable-width stretchable-height) (field [funny-value 0] - [funny-bitmap (make-object bitmap% - (build-path (collection-path "icons") "touch.bmp"))] + [funny-bitmap + (make-object bitmap% (build-path (collection-path "icons") "touch.bmp"))] [max-value 1]) [define/public set-range (lambda (r) (set! max-value r))] diff --git a/collects/hierlist/hierlist-unit.ss b/collects/hierlist/hierlist-unit.ss index c1204e47..d97dfe67 100644 --- a/collects/hierlist/hierlist-unit.ss +++ b/collects/hierlist/hierlist-unit.ss @@ -21,10 +21,18 @@ (define black-xor (make-object brush% "BLACK" 'xor)) (define arrow-cursor (make-object cursor% 'arrow)) - (define up-bitmap (make-object bitmap% (build-path (collection-path "icons") "turn-up.gif"))) - (define down-bitmap (make-object bitmap% (build-path (collection-path "icons") "turn-down.gif"))) - (define up-click-bitmap (make-object bitmap% (build-path (collection-path "icons") "turn-up-click.gif"))) - (define down-click-bitmap (make-object bitmap% (build-path (collection-path "icons") "turn-down-click.gif"))) + (define-values (up-bitmap down-bitmap up-click-bitmap down-click-bitmap) + (with-handlers ([not-break-exn? (lambda (x) + (values + (make-object bitmap% 10 10) + (make-object bitmap% 10 10) + (make-object bitmap% 10 10) + (make-object bitmap% 10 10)))]) + (values + (make-object bitmap% (build-path (collection-path "icons") "turn-up.gif")) + (make-object bitmap% (build-path (collection-path "icons") "turn-down.gif")) + (make-object bitmap% (build-path (collection-path "icons") "turn-up-click.gif")) + (make-object bitmap% (build-path (collection-path "icons") "turn-down-click.gif"))))) ;; Hack for implementing auto-wrapping items: (define arrow-size 0)