..
original commit: a7c7a9b92554dfa59fda081e1bc9fd29d9d51757
This commit is contained in:
Robby Findler
parent
87c01f5700
commit
cfb3034350
|
|
@ -30,6 +30,13 @@
|
|||
;; when clicking in the top part of the snip.
|
||||
(define/public (get-menu) #f)
|
||||
|
||||
;; get-position : -> (union 'top-right 'left-top)
|
||||
;; returns the location of the image and the clickable
|
||||
;; region. 'top-right indicates top portion is clickable
|
||||
;; and icon on right. 'left-top means left portion is
|
||||
;; clickable and icon on top.
|
||||
(define/public (get-position) 'top-right)
|
||||
|
||||
[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)]
|
||||
|
||||
|
|
@ -49,18 +56,26 @@
|
|||
[bml (box 0)]
|
||||
[bmt (box 0)]
|
||||
[bmr (box 0)]
|
||||
[bmb (box 0)])
|
||||
[bmb (box 0)]
|
||||
[menu (get-menu)])
|
||||
(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)])
|
||||
(let ([in-range
|
||||
(case (get-position)
|
||||
[(top-right)
|
||||
(and (<= 0 sx (unbox bw))
|
||||
(<= 0 sy (unbox bmt)))]
|
||||
[(left-top)
|
||||
(and (<= 0 sx (unbox bml))
|
||||
(<= 0 sy (unbox bh)))]
|
||||
[else #f])])
|
||||
(cond
|
||||
[(and menu
|
||||
(<= 0 sx (unbox bw))
|
||||
(<= 0 sy (unbox bmt)))
|
||||
[(and menu in-range)
|
||||
(let ([admin (get-admin)])
|
||||
(send admin popup-menu menu this (+ sx 1) (+ sy 1)))]
|
||||
[else (super-on-event dc x y editorx editory evt)])))]
|
||||
(when 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)]))
|
||||
|
||||
|
|
@ -87,11 +102,19 @@
|
|||
|
||||
(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))
|
||||
(send dc draw-rectangle
|
||||
(+ x (unbox bml))
|
||||
(+ y (unbox bit))
|
||||
(max 0 (- (unbox bw) (unbox bml) (unbox bmr)))
|
||||
(- (unbox bmt) (unbox bit)))
|
||||
(case (get-position)
|
||||
[(top-right)
|
||||
(send dc draw-rectangle
|
||||
(+ x (unbox bml))
|
||||
(+ y (unbox bit))
|
||||
(max 0 (- (unbox bw) (unbox bml) (unbox bmr)))
|
||||
(- (unbox bmt) (unbox bit)))]
|
||||
[(left-top)
|
||||
(send dc draw-rectangle
|
||||
(+ x (unbox bil))
|
||||
(+ y (unbox bmt))
|
||||
(- (unbox bml) (unbox bil))
|
||||
(max 0 (- (unbox bh) (unbox bmt) (unbox bmb))))])
|
||||
|
||||
(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))
|
||||
|
|
@ -99,14 +122,22 @@
|
|||
(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))))
|
||||
(case (get-position)
|
||||
[(top-right)
|
||||
(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))]
|
||||
[(left-top)
|
||||
(send dc draw-bitmap
|
||||
bm
|
||||
;; leave two pixels left and two right (see super-instantiate below)
|
||||
(+ x (unbox bil) 2)
|
||||
(+ y (unbox bmt)))])))
|
||||
|
||||
(send dc set-pen (get-pen))
|
||||
(send dc set-brush (get-brush))
|
||||
|
|
@ -129,29 +160,41 @@
|
|||
(send snip set-style (get-style))
|
||||
snip))
|
||||
|
||||
(inherit set-min-width get-margin)
|
||||
(define/public (reset-min-width)
|
||||
(let ([lib (box 0)]
|
||||
[rib (box 0)]
|
||||
[lmb (box 0)]
|
||||
[rmb (box 0)])
|
||||
(get-inset lib (box 0) rib (box 0))
|
||||
(get-margin lmb (box 0) rmb (box 0))
|
||||
(let ([bm (get-corner-bitmap)])
|
||||
(when bm
|
||||
(set-min-width
|
||||
(max 0 (send bm get-width)))))))
|
||||
(inherit set-min-width set-min-height get-margin)
|
||||
(define/public (reset-min-sizes)
|
||||
(let ([bm (get-corner-bitmap)])
|
||||
(when bm
|
||||
(case (get-position)
|
||||
[(top-right)
|
||||
(set-min-width (+ 4 (send bm get-width)))]
|
||||
[(left-top)
|
||||
(set-min-height (+ 4 (send bm get-height)))]))))
|
||||
|
||||
(super-instantiate ()
|
||||
(editor (make-editor))
|
||||
(with-border? #f)
|
||||
(top-margin (+ 4
|
||||
(let ([bm (get-corner-bitmap)])
|
||||
(if bm
|
||||
(send bm get-height)
|
||||
0)))))
|
||||
(let ([top-margin
|
||||
(case (get-position)
|
||||
[(top-right)
|
||||
(+ 4
|
||||
(let ([bm (get-corner-bitmap)])
|
||||
(if bm
|
||||
(send bm get-height)
|
||||
0)))]
|
||||
[else 4])]
|
||||
[left-margin
|
||||
(case (get-position)
|
||||
[(left-top)
|
||||
(+ 4
|
||||
(let ([bm (get-corner-bitmap)])
|
||||
(if bm
|
||||
(send bm get-width)
|
||||
0)))]
|
||||
[else 4])])
|
||||
(super-instantiate ()
|
||||
(editor (make-editor))
|
||||
(with-border? #f)
|
||||
(top-margin top-margin)
|
||||
(left-margin left-margin)))
|
||||
|
||||
(reset-min-width)))
|
||||
(reset-min-sizes)))
|
||||
|
||||
(define decorated-editor-snipclass%
|
||||
(class snip-class%
|
||||
|
|
|
|||
|
|
@ -13,8 +13,10 @@
|
|||
(define comment-box@
|
||||
(unit/sig framework:comment-box^
|
||||
(import [text : framework:text^]
|
||||
[scheme : framework:scheme^])
|
||||
(rename [-snip% snip%])
|
||||
[scheme : framework:scheme^]
|
||||
[keymap : framework:keymap^])
|
||||
(rename [-snip% snip%]
|
||||
[-text% text%])
|
||||
|
||||
(define snipclass%
|
||||
(class decorated-editor-snipclass%
|
||||
|
|
@ -32,13 +34,21 @@
|
|||
(and (send bm ok?)
|
||||
bm)))))
|
||||
|
||||
(define (editor-keymap-mixin %)
|
||||
(class %
|
||||
(rename [super-get-keymaps get-keymaps])
|
||||
(define/override (get-keymaps)
|
||||
(cons (keymap:get-file) (super-get-keymaps)))
|
||||
(super-instantiate ())))
|
||||
|
||||
(define -snip%
|
||||
(class* decorated-editor-snip% (readable-snip<%>)
|
||||
(inherit get-editor get-style)
|
||||
|
||||
(define/override (make-editor) (make-object (scheme:text-mixin text:keymap%)))
|
||||
(define/override (make-editor) (make-object (scheme:text-mixin (editor-keymap-mixin text:keymap%))))
|
||||
(define/override (make-snip) (make-object -snip%))
|
||||
(define/override (get-corner-bitmap) bm)
|
||||
(define/override (get-position) 'left-top)
|
||||
|
||||
(rename [super-get-text get-text])
|
||||
(define/override get-text
|
||||
|
|
|
|||
|
|
@ -1843,89 +1843,97 @@
|
|||
(send tx get-start-position)
|
||||
(send tx get-end-position))
|
||||
(send find-edit get-text 0 (send find-edit last-position)))))))
|
||||
(define replace&search
|
||||
(lambda ()
|
||||
(let ([text (get-text-to-search)])
|
||||
(send text begin-edit-sequence)
|
||||
(when (replace)
|
||||
(search-again))
|
||||
(send text end-edit-sequence))))
|
||||
(define replace-all
|
||||
(lambda ()
|
||||
(let* ([replacee-edit (get-text-to-search)]
|
||||
[pos (if (eq? searching-direction 'forward)
|
||||
(send replacee-edit get-start-position)
|
||||
(send replacee-edit get-end-position))]
|
||||
[done? (if (eq? 'forward 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-again)
|
||||
(send replacee-edit set-position pos)
|
||||
(let loop ()
|
||||
(when (send find-edit search #t #f #f)
|
||||
(replace)
|
||||
(loop))))
|
||||
(send replacee-edit end-edit-sequence))))
|
||||
(define replace
|
||||
(lambda ()
|
||||
(let* ([search-text (send find-edit get-text)]
|
||||
[replacee-edit (get-text-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))))
|
||||
(define toggle-search-focus
|
||||
(lambda ()
|
||||
(set-searching-frame this)
|
||||
(unhide-search)
|
||||
(send (cond
|
||||
[(send find-canvas has-focus?)
|
||||
replace-canvas]
|
||||
[(send replace-canvas has-focus?)
|
||||
(send (get-text-to-search) get-canvas)]
|
||||
[else
|
||||
find-canvas])
|
||||
focus)))
|
||||
(define move-to-search-or-search
|
||||
(lambda ()
|
||||
(set-searching-frame this)
|
||||
(unhide-search)
|
||||
(cond
|
||||
[(preferences:get 'framework:search-using-dialog?)
|
||||
(search-dialog this)]
|
||||
[else
|
||||
(if (or (send find-canvas has-focus?)
|
||||
(send replace-canvas has-focus?))
|
||||
(search-again 'forward)
|
||||
(send find-canvas focus))])))
|
||||
(define move-to-search-or-reverse-search
|
||||
(lambda ()
|
||||
(set-searching-frame this)
|
||||
(unhide-search)
|
||||
(if (or (send find-canvas has-focus?)
|
||||
(send replace-canvas has-focus?))
|
||||
(search-again 'backward)
|
||||
(send find-canvas focus))))
|
||||
(define search-again
|
||||
(opt-lambda ([direction searching-direction] [beep? #t])
|
||||
(set-searching-frame this)
|
||||
(unhide-search)
|
||||
(set-search-direction direction)
|
||||
(send find-edit search #t beep?)))
|
||||
(define replace&search
|
||||
(lambda ()
|
||||
(let ([text (get-text-to-search)])
|
||||
(send text begin-edit-sequence)
|
||||
(when (replace)
|
||||
(search-again))
|
||||
(send text end-edit-sequence))))
|
||||
(define (replace-all)
|
||||
(let* ([replacee-edit (get-text-to-search)]
|
||||
[embeded-replacee-edit (find-embedded-focus-editor replacee-edit)]
|
||||
[pos (if (eq? searching-direction 'forward)
|
||||
(send embeded-replacee-edit get-start-position)
|
||||
(send embeded-replacee-edit get-end-position))]
|
||||
[done? (if (eq? 'forward searching-direction)
|
||||
(lambda (x) (>= x (send replacee-edit last-position)))
|
||||
(lambda (x) (<= x 0)))])
|
||||
(send replacee-edit begin-edit-sequence)
|
||||
(when (search-again)
|
||||
(send embeded-replacee-edit set-position pos)
|
||||
(let loop ()
|
||||
(when (send find-edit search #t #f #f)
|
||||
(replace)
|
||||
(loop))))
|
||||
(send replacee-edit end-edit-sequence)))
|
||||
(define (replace)
|
||||
(let* ([search-text (send find-edit get-text)]
|
||||
[replacee-edit (find-embedded-focus-editor (get-text-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)))
|
||||
|
||||
(define/private (find-embedded-focus-editor editor)
|
||||
(let loop ([editor editor])
|
||||
(let ([s (send editor get-focus-snip)])
|
||||
(cond
|
||||
[(and s (is-a? s editor-snip%))
|
||||
(let ([next-ed (send s get-editor)])
|
||||
(if next-ed
|
||||
(loop next-ed)
|
||||
editor))]
|
||||
[else editor]))))
|
||||
|
||||
(define (toggle-search-focus)
|
||||
(set-searching-frame this)
|
||||
(unhide-search)
|
||||
(send (cond
|
||||
[(send find-canvas has-focus?)
|
||||
replace-canvas]
|
||||
[(send replace-canvas has-focus?)
|
||||
(send (get-text-to-search) get-canvas)]
|
||||
[else
|
||||
find-canvas])
|
||||
focus))
|
||||
(define move-to-search-or-search
|
||||
(lambda ()
|
||||
(set-searching-frame this)
|
||||
(unhide-search)
|
||||
(cond
|
||||
[(preferences:get 'framework:search-using-dialog?)
|
||||
(search-dialog this)]
|
||||
[else
|
||||
(if (or (send find-canvas has-focus?)
|
||||
(send replace-canvas has-focus?))
|
||||
(search-again 'forward)
|
||||
(send find-canvas focus))])))
|
||||
(define move-to-search-or-reverse-search
|
||||
(lambda ()
|
||||
(set-searching-frame this)
|
||||
(unhide-search)
|
||||
(if (or (send find-canvas has-focus?)
|
||||
(send replace-canvas has-focus?))
|
||||
(search-again 'backward)
|
||||
(send find-canvas focus))))
|
||||
(define search-again
|
||||
(opt-lambda ([direction searching-direction] [beep? #t])
|
||||
(set-searching-frame this)
|
||||
(unhide-search)
|
||||
(set-search-direction direction)
|
||||
(send find-edit search #t beep?)))
|
||||
|
||||
(super-instantiate ())
|
||||
|
||||
|
||||
(define search-panel (make-object horizontal-panel% super-root '(border)))
|
||||
|
||||
(define left-panel (make-object vertical-panel% search-panel))
|
||||
|
|
@ -1944,7 +1952,7 @@
|
|||
(string-constant find)
|
||||
middle-left-panel
|
||||
(lambda args (search-again))))
|
||||
|
||||
|
||||
(define replace-button-panel
|
||||
(instantiate vertical-panel% ()
|
||||
(parent middle-left-panel)
|
||||
|
|
@ -1959,7 +1967,7 @@
|
|||
(string-constant replace&find-again)
|
||||
middle-middle-panel
|
||||
(lambda x (replace&search))))
|
||||
|
||||
|
||||
(define replace-all-button (make-object button%
|
||||
(string-constant replace-to-end)
|
||||
middle-middle-panel
|
||||
|
|
@ -1978,13 +1986,13 @@
|
|||
(reset-search-anchor (get-text-to-search))))))
|
||||
(define hide/undock-pane (make-object horizontal-panel% middle-right-panel))
|
||||
(define hide-button (make-object button% (string-constant hide)
|
||||
hide/undock-pane
|
||||
(lambda args (hide-search))))
|
||||
hide/undock-pane
|
||||
(lambda args (hide-search))))
|
||||
(define undock-button (make-object button% (string-constant undock)
|
||||
hide/undock-pane
|
||||
(lambda args (undock))))
|
||||
(define hidden? #f)
|
||||
|
||||
|
||||
(let ([align
|
||||
(lambda (x y)
|
||||
(let ([m (max (send x get-width)
|
||||
|
|
|
|||
|
|
@ -886,6 +886,24 @@
|
|||
(end-edit-sequence)
|
||||
#t)))
|
||||
|
||||
;; uncomment-box/selection : -> void
|
||||
;; uncomments a comment box, if the focus is inside one.
|
||||
;; otherwise, calls uncomment selection to uncomment
|
||||
;; something else.
|
||||
(inherit get-focus-snip)
|
||||
(define/public (uncomment-box/selection)
|
||||
(begin-edit-sequence)
|
||||
(let ([focus-snip (get-focus-snip)])
|
||||
(cond
|
||||
[(not focus-snip) (uncomment-selection)]
|
||||
[(is-a? focus-snip comment-box:snip%)
|
||||
(extract-contents
|
||||
(get-snip-position focus-snip)
|
||||
focus-snip)]
|
||||
[else (uncomment-selection)]))
|
||||
(end-edit-sequence)
|
||||
#t)
|
||||
|
||||
(define uncomment-selection
|
||||
(opt-lambda ([start-pos (get-start-position)]
|
||||
[end-pos (get-end-position)])
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user