From c4c5e6ea9ad33dc92503a0d8f4867f1ac10fa463 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 19 Aug 2002 20:00:18 +0000 Subject: [PATCH] ... original commit: 7f0d11f8dbfd546616ed236afc779497145f20e4 --- collects/framework/comment-snip.ss | 78 ++++++++++--- collects/framework/decorated-editor-snip.ss | 123 ++++++++++---------- collects/framework/doc.txt | 68 +++++++++++ 3 files changed, 196 insertions(+), 73 deletions(-) create mode 100644 collects/framework/doc.txt diff --git a/collects/framework/comment-snip.ss b/collects/framework/comment-snip.ss index 06783bc1..df9aa3a4 100644 --- a/collects/framework/comment-snip.ss +++ b/collects/framework/comment-snip.ss @@ -1,15 +1,14 @@ (module comment-snip mzscheme (require (lib "class.ss") - (lib "mred.ss" "mred")) + (lib "mred.ss" "mred") + "decorated-editor-snip.ss" + (lib "string-constant.ss" "string-constants")) (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)) + (class decorated-editor-snipclass% + (define/override (make-snip stream-in) (instantiate comment-box-snip% ())) (super-instantiate ()))) (define snip-class (make-object comment-box-snipclass%)) @@ -17,16 +16,67 @@ (send snip-class set-classname (format "~s" '(lib "comment-snip.ss" "framework"))) (send (get-the-snip-class-list) add snip-class) + (define bm (let ([file (build-path (collection-path "icons") "semicolon.gif")]) + (and (file-exists? file) + (let ([bm (make-object bitmap% file)]) + (and (send bm ok?) + bm))))) + (define comment-box-snip% - (class* editor-snip% (readable-snip<%>) + (class* decorated-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/override (make-snip) (make-object comment-box-snip%)) + (define/override (get-corner-bitmap) bm) + + (define/override (make-menu) + (let ([menu (make-object popup-menu%)]) + (make-object menu-item% + (string-constant convert-to-semicolon-comment) + menu + (lambda (x y) + (let ([editor (find-containing-editor)]) + (when editor + (let ([this-pos (find-this-position)]) + (when this-pos + (move-contents-with-semicolons-to-position editor (+ this-pos 1)) + (send editor delete this-pos (+ this-pos 1)))))))))) + + (inherit get-admin) + ;; find-containing-editor : -> (union #f editor) + (define/private (find-containing-editor) + (let ([admin (get-admin)]) + (and admin + (send admin get-editor)))) + + ;; find-this-position : -> (union #f number) + (define (find-this-position) + (let ([ed (find-containing-editor)]) + (and ed + (send ed get-snip-position this)))) + + ;; move-contents-with-semicolons-to-position : (is-a? text%) number -> void + (define (move-contents-with-semicolons-to-position to-ed pos) + (let ([from-ed (get-editor)]) + (let loop ([snip (find-last-snip)]) + (cond + [snip + (when (or (memq 'hard-newline (send snip get-flags)) + (memq 'newline (send snip get-flags))) + (send to-ed insert ";" pos)) + (send from-ed release-snip) + (send to-ed insert snip pos) + (loop (send snip prev))] + [else (void)])))) + + ;; find-last-snip : editor -> snip + ;; returns the last snip in the editor + (define (find-last-snip ed) + (let loop ([snip (send ed find-first-snip)] + [acc (send ed find-first-snip)]) + (cond + [snip (loop (send snip next) snip)] + [else acc]))) + (define/public (read-one-special index source line column position) (raise (make-exn:special-comment "msg" diff --git a/collects/framework/decorated-editor-snip.ss b/collects/framework/decorated-editor-snip.ss index 14e70b9b..60ab4d50 100644 --- a/collects/framework/decorated-editor-snip.ss +++ b/collects/framework/decorated-editor-snip.ss @@ -9,65 +9,65 @@ (class editor-snip% (inherit get-editor get-style) - ;; get-color : -> (union string (is-a?/c color%)) - (define/public (get-color) (error 'get-color "abstract method")) - - ;; get-menu : -> (is-a?/c popup-menu%) - ;; returns the popup menu that should appear - ;; when clicking in the top part of the snip. - (define/public (get-menu) - (error 'get-menu "absract method")) - ;; make-snip : -> this% ;; returns an instance of this class. used in the copy method - (define/public (make-snip) - (error 'make-snip "abstract method")) + (define/public (make-snip) (make-object decorated-editor-snip%)) ;; make-editor : -> editor<%> ;; returns the editor to be used in this snip. - (define/public (make-editor) - (error 'make-editor "abstract method in XML/Scheme box superclass")) + (define/public (make-editor) (make-object text%)) - ;; get-corner-bitmap : -> (is-a?/c bitmap%) + ;; get-corner-bitmap : -> (union #f (is-a?/c bitmap%)) ;; returns the bitmap to be shown in the top right corner. - (define/public (get-corner-bitmap) - (error 'get-corner-bitmap "abstract method")) + (define/public (get-corner-bitmap) #f) + ;; get-color : -> (union string (is-a?/c color%)) + (define/public (get-color) "black") + + ;; get-menu : -> (union #f (is-a?/c popup-menu%)) + ;; returns the popup menu that should appear + ;; when clicking in the top part of the snip. + (define/public (get-menu) #f) + [define/private (get-pen) (send the-pen-list find-or-create-pen (get-color) 1 'solid)] [define/private (get-brush) (send the-brush-list find-or-create-brush "BLACK" 'transparent)] (inherit get-admin) (rename [super-on-event on-event]) (define/override (on-event dc x y editorx editory evt) - (let ([sx (- (send evt get-x) x)] - [sy (- (send evt get-y) y)] - [bil (box 0)] - [bit (box 0)] - [bir (box 0)] - [bib (box 0)] - [bw (box 0)] - [bh (box 0)] - [bml (box 0)] - [bmt (box 0)] - [bmr (box 0)] - [bmb (box 0)]) - (get-extent dc x y bw bh #f #f #f #f) - (get-inset bil bit bir bib) - (get-margin bml bmt bmr bmb) - (cond - [(and (send evt get-right-down) - (<= 0 sx (unbox bw)) - (<= 0 sy (unbox bmt))) - (let ([admin (get-admin)] - [menu (get-menu)]) - (send admin popup-menu menu this (+ sx 1) (+ sy 1)))] - [else - (super-on-event dc x y editorx editory evt)]))) + (cond + [(send evt get-right-down) + (let ([sx (- (send evt get-x) x)] + [sy (- (send evt get-y) y)] + [bil (box 0)] + [bit (box 0)] + [bir (box 0)] + [bib (box 0)] + [bw (box 0)] + [bh (box 0)] + [bml (box 0)] + [bmt (box 0)] + [bmr (box 0)] + [bmb (box 0)]) + (get-extent dc x y bw bh #f #f #f #f) + (get-inset bil bit bir bib) + (get-margin bml bmt bmr bmb) + (let ([menu (get-menu)]) + (cond + [(and menu + (<= 0 sx (unbox bw)) + (<= 0 sy (unbox bmt))) + (let ([admin (get-admin)]) + (send admin popup-menu menu this (+ sx 1) (+ sy 1)))] + [else (super-on-event dc x y editorx editory evt)])))] + [else + (super-on-event dc x y editorx editory evt)])) (inherit get-extent get-inset) (rename [super-draw draw]) (define/override (draw dc x y left top right bottom dx dy draw-caret) - (let ([bil (box 0)] + (let ([bm (get-corner-bitmap)] + [bil (box 0)] [bit (box 0)] [bir (box 0)] [bib (box 0)] @@ -82,10 +82,7 @@ (get-margin bml bmt bmr bmb) (super-draw dc x y left top right bottom dx dy draw-caret) (let* ([old-pen (send dc get-pen)] - [old-brush (send dc get-brush)] - [bm (get-corner-bitmap)] - [bm-w (send bm get-width)] - [bm-h (send bm get-height)]) + [old-brush (send dc get-brush)]) (send dc set-pen (send the-pen-list find-or-create-pen "white" 1 'transparent)) (send dc set-brush (send the-brush-list find-or-create-brush "white" 'solid)) @@ -97,14 +94,18 @@ (send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'solid)) (send dc set-brush (send the-brush-list find-or-create-brush "black" 'solid)) - (send dc draw-bitmap - bm - (+ x (max 0 - (- (unbox bw) - (unbox bmr) - bm-w))) - ;; leave two pixels above and two below (see super-instantiate below) - (+ y (unbox bit) 2)) + + (when bm + (let ([bm-w (send bm get-width)] + [bm-h (send bm get-height)]) + (send dc draw-bitmap + bm + (+ x (max 0 + (- (unbox bw) + (unbox bmr) + bm-w))) + ;; leave two pixels above and two below (see super-instantiate below) + (+ y (unbox bit) 2)))) (send dc set-pen (get-pen)) (send dc set-brush (get-brush)) @@ -114,7 +115,6 @@ (max 0 (- (unbox bw) (unbox bil) (unbox bir))) (max 0 (- (unbox bh) (unbox bit) (unbox bib)))) - (send dc set-pen old-pen) (send dc set-brush old-brush)))) @@ -136,13 +136,19 @@ [rmb (box 0)]) (get-inset lib (box 0) rib (box 0)) (get-margin lmb (box 0) rmb (box 0)) - (set-min-width - (max 0 (send (get-corner-bitmap) get-width))))) + (let ([bm (get-corner-bitmap)]) + (when bm + (set-min-width + (max 0 (send bm get-width))))))) (super-instantiate () (editor (make-editor)) (with-border? #f) - (top-margin (+ 4 (send (get-corner-bitmap) get-height)))) + (top-margin (+ 4 + (let ([bm (get-corner-bitmap)]) + (if bm + (send bm get-height) + 0))))) (reset-min-width))) @@ -151,8 +157,7 @@ ;; make-snip : stream-in -> (is-a?/c snip%) ;; returns an unfilled version of the snip - (define/public (make-snip stream-in) - (error 'create-snip "abstract method")) + (define/public (make-snip stream-in) (make-object decorated-editor-snip%)) (define/override (read stream-in) (let ([snip (make-snip stream-in)]) diff --git a/collects/framework/doc.txt b/collects/framework/doc.txt new file mode 100644 index 00000000..8f65c128 --- /dev/null +++ b/collects/framework/doc.txt @@ -0,0 +1,68 @@ + +_Framework Extras_ + +_hierlist-editor-snip.ss_ defines two classes: + +-------------------------------------------------- + +> decorated-editor-snip%, derived from editor-snip% + +This class operated just like a regular editor snip, except +that it has a color and an icon in the top right hand corner. + +Overridable methods: + +Each of these methods must be overridden in a derived class +to specify this class's behavior. + +> make-snip :: (send a-des make-snip) - returns an instance + of one of these snips. Defaults to returning an + instance of decorated-editor-snip%. Override this when + deriving a new class from decorated-editor-snip%. + +> make-editor :: (send a-des make-editor) - returns the + editor to be used in the snip. Defaultly returns an + instance of text%. + +> get-color :: (send a-des get-color) - returns a color% + object or a string in the color-database% + that is used for the border of the snip. Defaults to + return "black". + +> get-corner-bitmap :: (send a-des get-corner-bitmap) - + returns the bitmap to be used in the corner of the + snip, or #f. Defaults to returning #f. + +> get-menu :: (send a-des get-menu) - returns the menu to be + used when someone clicks on the top portion of the + snip, or #f (in which case there is no menu). Defaults + to return #f. + +Overridden methods: + +> write : writes the editor's contents to the file. + +> copy : uses the `make-snip' method to copy the + snip. Creates a copy of the editor in the snip using + the `copy-self' method and sets the style of the + copy to be the style of the original. + +> on-event : handles the popup menu + +> draw : draws the icon + +-------------------------------------------------- + +> decorated-editor-snipclass%, derived from snip-class% + +Overridable method: + +> make-snip :: (send a-desc make-snip stream-in) - returns + an instance of the snip to be created by this snipclass. + +Overridden method: + +> write : This method matches decorated-editor-snip%'s + `write' method. It first calls `make-snip' to + create the snip and then reads the editor from + the stream.