...
original commit: 7f0d11f8dbfd546616ed236afc779497145f20e4
This commit is contained in:
Robby Findler
parent
b77d7e324f
commit
c4c5e6ea9a
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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)])
|
||||
|
|
|
|||
68
collects/framework/doc.txt
Normal file
68
collects/framework/doc.txt
Normal file
|
|
@ -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.
|
||||
Loading…
Reference in New Issue
Block a user