suzanne.soy/gui
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

.

Browse Source 
original commit: 004f5216150743c424414e93204ec2f981f1a9b7
This commit is contained in:
Robby Findler 2005-02-06 00:17:54 +00:00
parent c06aba84fd
commit 30f6a3f81d
5 changed files with 63 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
collects/framework/private/canvas.ss
View File

@ -99,14 +99,12 @@
(let loop ([s s])
(cond
[(not s) 0]
[(member 'hard-newline (send s get-flags)) 0]
[(member 'newline (send s get-flags)) 0]
[(member 'hard-newline (send s get-flags)) (get-width s)]
[(member 'newline (send s get-flags)) (get-width s)]
[else
(if s
(+ (get-width s)
2 ;; for the caret
(loop (send s next)))
0)]))))])
(+ (get-width s)
2 ;; for the caret
(loop (send s next)))]))))])
(when edit
(send edit
run-after-edit-sequence
@ -122,8 +120,7 @@
;; console printer
(let ([fallback
(λ ()
(send edit get-snip-location
s left-edge-box top-edge-box))])
(send edit get-snip-location s left-edge-box top-edge-box))])
(cond
[(not width?) (fallback)]
[(let ([prev (send s previous)])

3
collects/framework/private/icon.ss
View File

@ -12,6 +12,9 @@
(unit/sig framework:icon^
(import mred^)
(define eof-bitmap (delay (include-bitmap (lib "eof.gif" "icons"))))
(define (get-eof-bitmap) (force eof-bitmap))
(define anchor-bitmap (delay (include-bitmap (lib "anchor.gif" "icons"))))
(define (get-anchor-bitmap) (force anchor-bitmap))

3
collects/framework/private/sig.ss
View File

@ -458,7 +458,8 @@
(define-signature framework:icon-fun^
(get-paren-highlight-bitmap
get-autowrap-bitmap
get-eof-bitmap
get-lock-bitmap
get-unlock-bitmap
get-anchor-bitmap

52
collects/framework/private/text.ss
View File

@ -886,6 +886,7 @@ WARNING: printf is rebound in the body of the unit to always
submit-to-port?
on-submit
send-eof-to-in-port
send-eof-to-box-in-port
reset-input-box
clear-output-ports
clear-input-port
@ -913,6 +914,22 @@ WARNING: printf is rebound in the body of the unit to always
box-input-not-used-anymore
set-port-text)
(define (set-box/f! b v) (when (box? b) (set-box! b v)))
(define eof-snip%
(class image-snip%
(init-field port-text)
(define/override (get-extent dc x y w h descent space lspace rspace)
(super get-extent dc x y w h descent space lspace rspace)
(set-box/f! descent 7)) ;; depends on actual bitmap used ...
(define/override (on-event dc x y editorx editory event)
(when (send event button-up? 'left)
(send port-text send-eof-to-box-in-port)))
(super-make-object (icon:get-eof-bitmap))
(inherit set-flags get-flags)
(set-flags (list* 'handles-events 'hard-newline (get-flags)))))
(define ports-mixin
(mixin (wide-snip<%>) (ports<%>)
(inherit begin-edit-sequence
@ -953,6 +970,7 @@ WARNING: printf is rebound in the body of the unit to always
;; box-input : (union #f (is-a?/c editor-snip%))
;; the snip where the user's input is typed for the box input port
(define box-input #f)
(define eof-button (new eof-snip% (port-text this)))
;; allow-edits? : boolean
;; when this flag is set, only insert/delete after the
@ -978,13 +996,20 @@ WARNING: printf is rebound in the body of the unit to always
(define/public-final (get-insertion-point) insertion-point)
(define/public-final (set-insertion-point ip) (set! insertion-point ip))
(define/public-final (get-unread-start-point) unread-start-point)
(define/public-final (set-unread-start-point u) (set! unread-start-point u))
(define/public-final (set-unread-start-point u)
(unless (<= u (last-position))
(error 'set-unread-start-point "~e is too large, last-position is ~e"
unread-start-point
(last-position)))
(set! unread-start-point u))
(define/public-final (set-allow-edits allow?) (set! allow-edits? allow?))
(define/public-final (get-allow-edits) allow-edits?)
(define/public-final (send-eof-to-in-port)
(channel-put read-chan (cons eof (position->line-col-pos unread-start-point))))
(define/public-final (send-eof-to-box-in-port)
(channel-put box-read-chan (cons eof (position->line-col-pos unread-start-point))))
(define/public-final (clear-input-port) (channel-put clear-input-chan (void)))
(define/public-final (clear-box-input-port) (channel-put box-clear-input-chan (void)))
(define/public-final (clear-output-ports)
@ -996,13 +1021,15 @@ WARNING: printf is rebound in the body of the unit to always
(unless (<= start end insertion-point)
(error 'delete/io "expected start (~a) <= end (~a) <= insertion-point (~a)"
start end insertion-point))
(let ([dist (- end start)])
(set! insertion-point (- insertion-point dist))
(set! unread-start-point (- unread-start-point dist)))
(let ([before-allowed? allow-edits?])
(set! allow-edits? #t)
(delete start end #f)
(set! allow-edits? before-allowed?)
(let ([dist (- end start)])
(set! insertion-point (- insertion-point dist))
(set! unread-start-point (- unread-start-point dist)))))
(set! allow-edits? before-allowed?)))
(define/public-final (get-in-port)
(unless in-port (error 'get-in-port "not ready"))
@ -1099,7 +1126,8 @@ WARNING: printf is rebound in the body of the unit to always
(lock #f)
(set! allow-edits? #t)
(send box-input release-from-owner)
(set! unread-start-point (- unread-start-point 1))
(send eof-button release-from-owner)
(set! unread-start-point (- unread-start-point 2))
(set! allow-edits? old-allow-edits?)
(lock l?))
(set! box-input #f)))
@ -1112,10 +1140,10 @@ WARNING: printf is rebound in the body of the unit to always
[locked? (is-locked?)])
(send ed set-port-text this)
(lock #f)
(send es set-flags (cons 'hard-newline (send es get-flags)))
(unless (= unread-start-point (paragraph-start-position (position-paragraph unread-start-point)))
(insert-between "\n"))
(insert-between es)
(insert-between eof-button)
(send (get-canvas) add-wide-snip es)
(set! box-input es)
(set-caret-owner es 'display)
@ -1712,7 +1740,9 @@ WARNING: printf is rebound in the body of the unit to always
(send nth read-special src line col pos)
nth)))])))]
[polling?
(wrap-evt always-evt (λ (_) 0))]
(choice-evt
nack-evt
(channel-put-evt resp-chan 0))]
[else
#f])]))
@ -1744,19 +1774,15 @@ WARNING: printf is rebound in the body of the unit to always
;; in any thread (even concurrently)
;;
(define (read-bytes-proc bstr)
;(when on-peek (printf "read-bytes-proc\n"))
(let* ([progress-evt (progress-evt-proc)]
[v (peek-proc bstr 0 progress-evt)])
(cond
[(sync/timeout 0 progress-evt)
;(when on-peek (printf "read-bytes-proc.1\n"))
0]
[else
;(when on-peek (printf "read-bytes-proc.2\n"))
(wrap-evt
v
(λ (v)
;(when on-peek (printf "read-bytes.3 v ~s\n" v))
(if (and (number? v) (zero? v))
0
(if (commit-proc (if (number? v) v 1)
@ -1768,8 +1794,6 @@ WARNING: printf is rebound in the body of the unit to always
(define (peek-proc bstr skip-count progress-evt)
(poll-guard-evt
(lambda (polling?)
(when polling?
(printf "polling\n"))
(if polling?
(let ([answer
(sync

22
collects/mrlib/text-string-style-desc.ss
View File

@ -1,21 +1,27 @@
(module text-string-style-desc mzscheme
(provide get-string/style-desc)
(require (lib "mred.ss" "mred")
(lib "etc.ss")
(lib "class.ss"))
;; get-string/style-desc : text -> (listof str/ann)
(define (get-string/style-desc text)
(let* ([snips (get-snips text)]
[str/ann (map snip->str/ann snips)]
[joined-str/ann (join-like str/ann)])
joined-str/ann))
(define get-string/style-desc
(opt-lambda (text [start 0] [end (send text last-position)])
(let* ([snips (get-snips text start end)]
[str/ann (map snip->str/ann snips)]
[joined-str/ann (join-like str/ann)])
joined-str/ann)))
;; get-snips : text -> (listof snip)
;; extracts the snips from a text
(define (get-snips text)
(let loop ([snip (send text find-first-snip)])
(define (get-snips text start end)
(send text split-snip start)
(send text split-snip end)
(let loop ([snip (send text find-snip start 'after-or-none)])
(cond
[snip (cons snip (loop (send snip next)))]
[(not snip) null]
[(< (send text get-snip-position snip) end)
(cons snip (loop (send snip next)))]
[else null])))
;; snip->str/ann : snip -> str/ann