...
original commit: d43fbc8c217a8e5363c9affd1dd93119d96af45b
This commit is contained in:
Robby Findler
parent
403afced7c
commit
f33da86a3a
|
|
@ -39,20 +39,33 @@
|
||||||
|
|
||||||
(define (set-box/f! b v) (when (box? b) (set-box! b v)))
|
(define (set-box/f! b v) (when (box? b) (set-box! b v)))
|
||||||
|
|
||||||
|
(define sexp-snip<%>
|
||||||
|
(interface ()
|
||||||
|
get-saved-snips))
|
||||||
|
|
||||||
(define sexp-snip%
|
(define sexp-snip%
|
||||||
(class snip%
|
(class* snip% (sexp-snip<%>)
|
||||||
(field [sizing-text "( )"])
|
(init-field left-bracket right-bracket saved-snips)
|
||||||
|
(define/public (get-saved-snips) saved-snips)
|
||||||
|
(field [sizing-text (format "~a ~a" left-bracket right-bracket)])
|
||||||
|
|
||||||
|
(define/override (copy)
|
||||||
|
(instantiate sexp-snip% ()
|
||||||
|
(left-bracket left-bracket)
|
||||||
|
(right-bracket right-bracket)
|
||||||
|
(saved-snips saved-snips)))
|
||||||
|
|
||||||
(define/override (draw dc x y left top right bottom dx dy draw-caret)
|
(define/override (draw dc x y left top right bottom dx dy draw-caret)
|
||||||
(send dc draw-text sizing-text x y)
|
(send dc draw-text sizing-text x y)
|
||||||
(let-values ([(lpw lph lpa lpd) (send dc get-text-extent "(")]
|
(let-values ([(lpw lph lpa lpd) (send dc get-text-extent (string left-bracket))]
|
||||||
[(rpw rph rpa rpd) (send dc get-text-extent ")")]
|
[(rpw rph rpa rpd) (send dc get-text-extent (string right-bracket))]
|
||||||
[(sw sh sa sd) (send dc get-text-extent sizing-text)])
|
[(sw sh sa sd) (send dc get-text-extent sizing-text)])
|
||||||
(let* ([dtw (- sw lpw rpw)]
|
(let* ([dtw (- sw lpw rpw)]
|
||||||
[dot-start (+ x lpw)]
|
[dot-start (+ x lpw)]
|
||||||
[dt1x (+ dot-start (* dtw 1/5))]
|
[dt1x (+ dot-start (* dtw 1/5))]
|
||||||
[dt2x (+ dot-start (* dtw 1/2))]
|
[dt2x (+ dot-start (* dtw 1/2))]
|
||||||
[dt3x (+ dot-start (* dtw 4/5))]
|
[dt3x (+ dot-start (* dtw 4/5))]
|
||||||
[dty (/ sh 2)])
|
[dty (+ y (/ sh 2))])
|
||||||
(send dc draw-rectangle dt1x dty 2 2)
|
(send dc draw-rectangle dt1x dty 2 2)
|
||||||
(send dc draw-rectangle dt2x dty 2 2)
|
(send dc draw-rectangle dt2x dty 2 2)
|
||||||
(send dc draw-rectangle dt3x dty 2 2))))
|
(send dc draw-rectangle dt3x dty 2 2))))
|
||||||
|
|
@ -80,43 +93,105 @@
|
||||||
(send sexp-snipclass set-version 0)
|
(send sexp-snipclass set-version 0)
|
||||||
(send (get-the-snip-class-list) add sexp-snipclass)
|
(send (get-the-snip-class-list) add sexp-snipclass)
|
||||||
|
|
||||||
;; leave this for next version...
|
(keymap:add-to-right-button-menu
|
||||||
'(keymap:add-to-right-button-menu
|
|
||||||
(let ([old (keymap:add-to-right-button-menu)])
|
(let ([old (keymap:add-to-right-button-menu)])
|
||||||
(lambda (menu text event)
|
(lambda (menu text event)
|
||||||
(old menu text event)
|
(old menu text event)
|
||||||
(when (is-a? text -text<%>)
|
(split/collapse-text menu text event))))
|
||||||
(let* ([pos
|
|
||||||
(call-with-values
|
;; split/collapse-text : (instanceof menu%) (instanceof editor<%>) (instanceof mouse-event%) -> void
|
||||||
(lambda ()
|
(define (split/collapse-text menu text event)
|
||||||
(send text dc-location-to-editor-location
|
(when (is-a? text -text<%>)
|
||||||
(send event get-x)
|
(let* ([on-it-box (box #f)]
|
||||||
(send event get-y)))
|
[click-pos
|
||||||
(lambda (x y)
|
(call-with-values
|
||||||
(send text find-position x y)))]
|
(lambda ()
|
||||||
[char (send text get-character pos)]
|
(send text dc-location-to-editor-location
|
||||||
[left? (memq char '(#\( #\{ #\[))]
|
(send event get-x)
|
||||||
[right? (memq char '(#\) #\} #\]))])
|
(send event get-y)))
|
||||||
(when (or left? right?)
|
(lambda (x y)
|
||||||
(let* ([other-pos (if left?
|
(send text find-position x y #f on-it-box)))]
|
||||||
(send text get-forward-sexp pos)
|
[snip (send text find-snip click-pos 'after)]
|
||||||
(send text get-backward-sexp (+ pos 1)))])
|
[char (send text get-character click-pos)]
|
||||||
(when other-pos
|
[left? (memq char '(#\( #\{ #\[))]
|
||||||
(let ([left-pos (min pos other-pos)]
|
[right? (memq char '(#\) #\} #\]))])
|
||||||
[right-pos (max pos other-pos)])
|
(cond
|
||||||
(instantiate separator-menu-item% ()
|
[(and snip (is-a? snip sexp-snip<%>))
|
||||||
(parent menu))
|
(make-expand-item text snip menu)]
|
||||||
(instantiate menu-item% ()
|
[(not (unbox on-it-box))
|
||||||
(parent menu)
|
;; clicking in nowhere land, just ignore
|
||||||
(label "Collapse sexp")
|
(void)]
|
||||||
(callback (lambda (item evt)
|
[(or left? right?)
|
||||||
(collapse-from text left-pos right-pos)))))))))))))
|
;; clicking on left or right paren
|
||||||
|
(let* ([pos (if left?
|
||||||
|
click-pos
|
||||||
|
(+ click-pos 1))]
|
||||||
|
[other-pos (if left?
|
||||||
|
(send text get-forward-sexp pos)
|
||||||
|
(send text get-backward-sexp pos))])
|
||||||
|
(when other-pos
|
||||||
|
(let ([left-pos (min pos other-pos)]
|
||||||
|
[right-pos (max pos other-pos)])
|
||||||
|
(make-collapse-item text left-pos right-pos menu))))]
|
||||||
|
[else
|
||||||
|
;; clicking on some other text -> collapse containing sexp
|
||||||
|
(let ([up-sexp (send text find-up-sexp click-pos)])
|
||||||
|
(when up-sexp
|
||||||
|
(let ([fwd (send text get-forward-sexp up-sexp)])
|
||||||
|
(make-collapse-item text up-sexp fwd menu))))]))))
|
||||||
|
|
||||||
|
;; make-expand-item : (instanceof text%) (instanceof sexp-snip<%>) (instanceof menu%) -> void
|
||||||
|
(define (make-expand-item text snip menu)
|
||||||
|
(instantiate separator-menu-item% ()
|
||||||
|
(parent menu))
|
||||||
|
(instantiate menu-item% ()
|
||||||
|
(parent menu)
|
||||||
|
(label (string-constant expand-sexp))
|
||||||
|
(callback (lambda (item evt) (expand-from text snip)))))
|
||||||
|
|
||||||
|
;; expand-from : (instanceof text%) (instanceof sexp-snip<%>) -> void
|
||||||
|
(define (expand-from text snip)
|
||||||
|
(let ([snips (send snip get-saved-snips)])
|
||||||
|
(send text begin-edit-sequence)
|
||||||
|
(let ([pos (send text get-snip-position snip)])
|
||||||
|
(send text delete pos (+ pos 1))
|
||||||
|
(let loop ([snips (reverse snips)])
|
||||||
|
(cond
|
||||||
|
[(null? snips) (void)]
|
||||||
|
[else (send text insert (car snips) pos pos)
|
||||||
|
(loop (cdr snips))])))
|
||||||
|
(send text end-edit-sequence)))
|
||||||
|
|
||||||
|
;; make-collapse-item : (instanceof text%) number number (instanceof menu%) -> void
|
||||||
|
;; adds a collapse menu item to the menu
|
||||||
|
(define (make-collapse-item text left-pos right-pos menu)
|
||||||
|
(instantiate separator-menu-item% ()
|
||||||
|
(parent menu))
|
||||||
|
(instantiate menu-item% ()
|
||||||
|
(parent menu)
|
||||||
|
(label (string-constant collapse-sexp))
|
||||||
|
(callback (lambda (item evt)
|
||||||
|
(collapse-from text left-pos right-pos)))))
|
||||||
|
|
||||||
(define (collapse-from text left-pos right-pos)
|
(define (collapse-from text left-pos right-pos)
|
||||||
(send text begin-edit-sequence)
|
(let ([left-bracket (send text get-character left-pos)]
|
||||||
(send text delete left-pos right-pos)
|
[right-bracket (send text get-character (- right-pos 1))])
|
||||||
(send text insert (make-object sexp-snip%) left-pos left-pos)
|
(send text begin-edit-sequence)
|
||||||
(send text end-edit-sequence))
|
(send text split-snip left-pos)
|
||||||
|
(send text split-snip right-pos)
|
||||||
|
(let ([snips (let loop ([snip (send text find-snip left-pos 'after)])
|
||||||
|
(cond
|
||||||
|
[(not snip) null]
|
||||||
|
[((send text get-snip-position snip) . >= . right-pos)
|
||||||
|
null]
|
||||||
|
[else (cons (send snip copy) (loop (send snip next)))]))])
|
||||||
|
(send text delete left-pos right-pos)
|
||||||
|
(send text insert (instantiate sexp-snip% ()
|
||||||
|
(left-bracket left-bracket)
|
||||||
|
(right-bracket right-bracket)
|
||||||
|
(saved-snips snips))
|
||||||
|
left-pos left-pos)
|
||||||
|
(send text end-edit-sequence))))
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
;; ;;
|
;; ;;
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user