.
original commit: eb8561bb851e12c113aabac364a26cd4c446364c
This commit is contained in:
Robby Findler
parent
ccb86c681f
commit
eb7bfa19bb
|
|
@ -11,7 +11,8 @@
|
|||
(unit/sig framework:canvas^
|
||||
(import mred^
|
||||
[preferences : framework:preferences^]
|
||||
[frame : framework:frame^])
|
||||
[frame : framework:frame^]
|
||||
[text : framework:text^])
|
||||
|
||||
(rename [-color% color%])
|
||||
|
||||
|
|
@ -71,111 +72,111 @@
|
|||
add-wide-snip
|
||||
add-tall-snip))
|
||||
|
||||
;; wx: this needs to collude with
|
||||
;; the edit, since the edit has the right callbacks.
|
||||
(define wide-snip-mixin
|
||||
(mixin (basic<%>) (wide-snip<%>)
|
||||
(inherit get-editor)
|
||||
[define wide-snips null]
|
||||
[define tall-snips null]
|
||||
[define update-snip-size
|
||||
(lambda (width?)
|
||||
(lambda (s)
|
||||
(let* ([width (box 0)]
|
||||
[height (box 0)]
|
||||
[leftm (box 0)]
|
||||
[rightm (box 0)]
|
||||
[topm (box 0)]
|
||||
[bottomm (box 0)]
|
||||
[left-edge-box (box 0)]
|
||||
[top-edge-box (box 0)]
|
||||
[snip-media (send s get-editor)]
|
||||
[edit (get-editor)]
|
||||
[get-width
|
||||
(let ([bl (box 0)]
|
||||
[br (box 0)])
|
||||
(lambda (s)
|
||||
(send edit get-snip-location s bl #f #f)
|
||||
(send edit get-snip-location s br #f #t)
|
||||
(- (unbox br) (unbox bl))))]
|
||||
[calc-after-width
|
||||
(lambda (s)
|
||||
(+ 4 ;; this is compensate for an autowrapping bug
|
||||
(let loop ([s s])
|
||||
(cond
|
||||
[(not s) 0]
|
||||
[(member 'hard-newline (send s get-flags)) 0]
|
||||
[(member 'newline (send s get-flags)) 0]
|
||||
[else
|
||||
(if s
|
||||
(+ (get-width s)
|
||||
2 ;; for the caret
|
||||
(loop (send s next)))
|
||||
0)]))))])
|
||||
(when edit
|
||||
(send edit
|
||||
run-after-edit-sequence
|
||||
(lambda ()
|
||||
(let ([admin (send edit get-admin)])
|
||||
(send admin get-view #f #f width height)
|
||||
(send s get-margin leftm topm rightm bottomm)
|
||||
|
||||
|
||||
;; when the width is to be maximized and there is a
|
||||
;; newline just behind the snip, we know that the left
|
||||
;; edge is zero. Special case for efficiency in the
|
||||
;; console printer
|
||||
(let ([fallback
|
||||
(lambda ()
|
||||
(send edit get-snip-location
|
||||
s left-edge-box top-edge-box))])
|
||||
(cond
|
||||
[(not width?) (fallback)]
|
||||
[(let ([prev (send s previous)])
|
||||
(and prev
|
||||
(member 'hard-newline (send prev get-flags))))
|
||||
(set-box! left-edge-box 0)]
|
||||
[else (fallback)]))
|
||||
|
||||
(if width?
|
||||
(let* ([after-width (calc-after-width (send s next))]
|
||||
[snip-width (max 0 (- (unbox width)
|
||||
(unbox left-edge-box)
|
||||
(unbox leftm)
|
||||
(unbox rightm)
|
||||
after-width
|
||||
;; this two is the space that
|
||||
;; the caret needs at the right of
|
||||
;; a buffer.
|
||||
2))])
|
||||
(send* s
|
||||
(set-min-width snip-width)
|
||||
(set-max-width snip-width))
|
||||
(when snip-media
|
||||
(send snip-media set-max-width
|
||||
(if (send snip-media auto-wrap)
|
||||
snip-width
|
||||
0))))
|
||||
(let ([snip-height (max 0 (- (unbox height)
|
||||
(unbox top-edge-box)
|
||||
(unbox topm)
|
||||
(unbox bottomm)))])
|
||||
(send* s
|
||||
(set-min-height snip-height)
|
||||
(set-max-height snip-height)))))))))))]
|
||||
(public recalc-snips add-wide-snip add-tall-snip)
|
||||
[define recalc-snips
|
||||
(lambda ()
|
||||
(for-each (update-snip-size #t) wide-snips)
|
||||
(for-each (update-snip-size #f) tall-snips))]
|
||||
[define add-wide-snip
|
||||
(lambda (snip)
|
||||
(set! wide-snips (cons snip wide-snips))
|
||||
((update-snip-size #t) snip))]
|
||||
[define add-tall-snip
|
||||
(lambda (snip)
|
||||
(set! tall-snips (cons snip tall-snips))
|
||||
((update-snip-size #f) snip))]
|
||||
(define/private ((update-snip-size width?) s)
|
||||
(let* ([width (box 0)]
|
||||
[height (box 0)]
|
||||
[leftm (box 0)]
|
||||
[rightm (box 0)]
|
||||
[topm (box 0)]
|
||||
[bottomm (box 0)]
|
||||
[left-edge-box (box 0)]
|
||||
[top-edge-box (box 0)]
|
||||
[snip-media (send s get-editor)]
|
||||
[edit (get-editor)]
|
||||
[get-width
|
||||
(let ([bl (box 0)]
|
||||
[br (box 0)])
|
||||
(lambda (s)
|
||||
(send edit get-snip-location s bl #f #f)
|
||||
(send edit get-snip-location s br #f #t)
|
||||
(- (unbox br) (unbox bl))))]
|
||||
[calc-after-width
|
||||
(lambda (s)
|
||||
(+ 4 ;; this is compensate for an autowrapping bug
|
||||
(let loop ([s s])
|
||||
(cond
|
||||
[(not s) 0]
|
||||
[(member 'hard-newline (send s get-flags)) 0]
|
||||
[(member 'newline (send s get-flags)) 0]
|
||||
[else
|
||||
(if s
|
||||
(+ (get-width s)
|
||||
2 ;; for the caret
|
||||
(loop (send s next)))
|
||||
0)]))))])
|
||||
(when edit
|
||||
(send edit
|
||||
run-after-edit-sequence
|
||||
(lambda ()
|
||||
(let ([admin (send edit get-admin)])
|
||||
(send admin get-view #f #f width height)
|
||||
(send s get-margin leftm topm rightm bottomm)
|
||||
|
||||
|
||||
;; when the width is to be maximized and there is a
|
||||
;; newline just behind the snip, we know that the left
|
||||
;; edge is zero. Special case for efficiency in the
|
||||
;; console printer
|
||||
(let ([fallback
|
||||
(lambda ()
|
||||
(send edit get-snip-location
|
||||
s left-edge-box top-edge-box))])
|
||||
(cond
|
||||
[(not width?) (fallback)]
|
||||
[(let ([prev (send s previous)])
|
||||
(and prev
|
||||
(member 'hard-newline (send prev get-flags))))
|
||||
(set-box! left-edge-box 0)]
|
||||
[else (fallback)]))
|
||||
|
||||
(if width?
|
||||
(let* ([after-width (calc-after-width (send s next))]
|
||||
[snip-width (max 0 (- (unbox width)
|
||||
(unbox left-edge-box)
|
||||
(unbox leftm)
|
||||
(unbox rightm)
|
||||
after-width
|
||||
;; this two is the space that
|
||||
;; the caret needs at the right of
|
||||
;; a buffer.
|
||||
2))])
|
||||
(send* s
|
||||
(set-min-width snip-width)
|
||||
(set-max-width snip-width))
|
||||
(when snip-media
|
||||
(send snip-media set-max-width
|
||||
(if (send snip-media auto-wrap)
|
||||
snip-width
|
||||
0))))
|
||||
(let ([snip-height (max 0 (- (unbox height)
|
||||
(unbox top-edge-box)
|
||||
(unbox topm)
|
||||
(unbox bottomm)))])
|
||||
(send* s
|
||||
(set-min-height snip-height)
|
||||
(set-max-height snip-height))))))))))
|
||||
(define/public (recalc-snips)
|
||||
(let ([editor (get-editor)])
|
||||
(unless (is-a? editor text:wide-snip<%>)
|
||||
(error 'recalc-snips "expected a text:wide-snip<%> editor, instead ~e" editor))
|
||||
(when (eq? (send editor get-canvas) this)
|
||||
(for-each (update-snip-size #t) (send editor get-wide-snips))
|
||||
(for-each (update-snip-size #f) (send editor get-tall-snips)))))
|
||||
(define/public (add-wide-snip snip)
|
||||
(let ([editor (get-editor)])
|
||||
(unless (is-a? editor text:wide-snip<%>)
|
||||
(error 'add-wide-snip "expected to have a text:wide-snip<%> editor, instead ~e" editor))
|
||||
(send editor add-wide-snip snip))
|
||||
((update-snip-size #t) snip))
|
||||
(define/public (add-tall-snip snip)
|
||||
(let ([editor (get-editor)])
|
||||
(unless (is-a? editor text:wide-snip<%>)
|
||||
(error 'add-wide-snip "expected to have a text:wide-snip<%> editor, instead ~e" editor))
|
||||
(send editor add-tall-snip snip))
|
||||
((update-snip-size #f) snip))
|
||||
(define/override (on-size width height)
|
||||
(recalc-snips)
|
||||
(super on-size width height))
|
||||
|
|
|
|||
|
|
@ -300,6 +300,7 @@
|
|||
hide-caret/selection<%>
|
||||
nbsp->space<%>
|
||||
delegate<%>
|
||||
wide-snip<%>
|
||||
searching<%>
|
||||
return<%>
|
||||
info<%>
|
||||
|
|
@ -327,6 +328,7 @@
|
|||
foreground-color-mixin
|
||||
hide-caret/selection-mixin
|
||||
nbsp->space-mixin
|
||||
wide-snip-mixin
|
||||
delegate-mixin
|
||||
searching-mixin
|
||||
return-mixin
|
||||
|
|
|
|||
|
|
@ -429,7 +429,22 @@ WARNING: printf is rebound in the body of the unit to always
|
|||
(char=? cr-code code))
|
||||
(return))
|
||||
(super on-local-char key))))
|
||||
(super-instantiate ())))
|
||||
(super-new)))
|
||||
|
||||
(define wide-snip<%>
|
||||
(interface (basic<%>)
|
||||
add-wide-snip
|
||||
add-tall-snip))
|
||||
|
||||
(define wide-snip-mixin
|
||||
(mixin (basic<%>) (wide-snip<%>)
|
||||
(define wide-snips '())
|
||||
(define tall-snips '())
|
||||
(define/public (add-wide-snip s) (set! wide-snips (cons s wide-snips)))
|
||||
(define/public (get-wide-snips) wide-snips)
|
||||
(define/public (add-tall-snip s) (set! tall-snips (cons s tall-snips)))
|
||||
(define/public (get-tall-snips) tall-snips)
|
||||
(super-new)))
|
||||
|
||||
(define delegate<%> (interface (basic<%>)
|
||||
get-delegate
|
||||
|
|
@ -1772,7 +1787,7 @@ WARNING: printf is rebound in the body of the unit to always
|
|||
(define hide-caret/selection% (hide-caret/selection-mixin basic%))
|
||||
(define nbsp->space% (nbsp->space-mixin basic%))
|
||||
(define delegate% (delegate-mixin basic%))
|
||||
(define standard-style-list% (editor:standard-style-list-mixin basic%))
|
||||
(define standard-style-list% (editor:standard-style-list-mixin (wide-snip-mixin basic%)))
|
||||
(define -keymap% (editor:keymap-mixin standard-style-list%))
|
||||
(define return% (return-mixin -keymap%))
|
||||
(define autowrap% (editor:autowrap-mixin -keymap%))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user