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

.

Browse Source 
original commit: eca8bf7cc52a128657d2f227bcbf82ce9e966849
This commit is contained in:
Robby Findler 2004-03-07 00:09:09 +00:00
parent 6606c64184
commit 984fb468b7
5 changed files with 166 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
collects/framework/framework.ss
View File

@ -37,6 +37,29 @@
mred^)
(provide/contract/docs
(number-snip:make-repeating-decimal-snip
(number? boolean? . -> . (is-a?/c snip%))
(num show-prefix?)
"Makes a number snip that shows the decimal expansion for \\var{number}"
"The boolean indicates if a {\\tt \\#e} prefix appears"
"on the number."
""
"See also"
"@flink number-snip:number-snip:make-fraction-snip %"
".")
(number-snip:make-fraction-snip
(number? boolean? . -> . (is-a?/c snip%))
(num show-prefix-in-decimal-view?)
"Makes a number snip that shows a fractional view of \\var{number}."
"The boolean indicates if a {\\tt \\#e} prefix appears"
"on the number, when shown in the decimal state."
""
"See also"
"@flink drscheme:number-snip:make-repeating-decimal-snip %"
".")
(version:add-spec
(any? any? . -> . void?)
(spec revision)

14
collects/framework/private/frame.ss
View File

@ -554,7 +554,7 @@
'framework:show-status-line
(lambda (p v)
(update-info-visibility v)))]
[define memory-cleanup void] ;; only for CVSers; used with memory-text
[define memory-cleanup void] ;; only for CVSers and nightly build users; used with memory-text
(rename [super-on-close on-close])
[define/override on-close
@ -626,7 +626,7 @@
[(<= n 99) (format "0~a" n)]
[else (number->string n)]))
; only for CVSers
; only for CVSers and nightly build users
(when show-memory-text?
(let* ([panel (make-object horizontal-panel% (get-info-panel) '(border))]
[button (make-object button% (string-constant collect-button-label) panel
@ -2310,14 +2310,16 @@
(define (get-editor%) text:searching%)
(super-instantiate ())))
; to see printouts in memory debugging better.
(define memory-text% (class text% (super-new)))
(define memory-text (make-object memory-text%))
(send memory-text hide-caret #t)
(define show-memory-text?
(with-handlers ([not-break-exn?
(lambda (x) #f)])
(directory-exists? (build-path (collection-path "framework") "CVS"))))
(or (with-handlers ([not-break-exn?
(lambda (x) #f)])
(directory-exists? (collection-path "cvs-time-stamp")))
(with-handlers ([not-break-exn?
(lambda (x) #f)])
(directory-exists? (build-path (collection-path "framework") "CVS")))))
(define bday-click-canvas%
(class canvas%

2
collects/framework/private/main.ss
View File

@ -22,6 +22,8 @@
(application-preferences-handler (lambda () (preferences:show-dialog)))
(preferences:set-default 'framework:fraction-snip-style 'mixed (lambda (x) (memq x '(mixed improper))))
(preferences:set-default 'framework:standard-style-list:font-name
(get-family-builtin-face 'modern)
string?)

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

@ -79,8 +79,20 @@
framework:color-model-fun^
framework:comment-box-fun^
framework:comment-box-class^
framework:comment-box^)
framework:comment-box^
framework:number-snip^
framework:number-snip-fun^
framework:number-snip-class^)
(define-signature framework:number-snip-fun^
(make-repeating-decimal-snip
make-fraction-snip))
(define-signature framework:number-snip-class^
(snip-class%))
(define-signature framework:number-snip^
((open framework:number-snip-fun^)
(open framework:number-snip-class^)))
(define-signature framework:comment-box-fun^
())
(define-signature framework:comment-box-class^

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

@ -20,7 +20,8 @@
[keymap : framework:keymap^]
[color-model : framework:color-model^]
[frame : framework:frame^]
[scheme : framework:scheme^])
[scheme : framework:scheme^]
[number-snip : framework:number-snip^])
(rename [-keymap% keymap%])
@ -943,10 +944,10 @@
(super-on-local-char key)])))
(define allow-tabify? #t)
(rename [super-tabify-on-return? tabify-on-return?])
(define/override (tabify-on-return?)
(and (super-tabify-on-return?)
allow-tabify?))
; (rename [super-tabify-on-return? tabify-on-return?])
; (define/override (tabify-on-return?)
; (and (super-tabify-on-return?)
; allow-tabify?))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
@ -1163,7 +1164,6 @@
(define (out-close-proc)
(void))
;; disable set-styles-sticky?
(define out-sd (make-object style-delta% 'change-normal))
(define err-sd (make-object style-delta% 'change-italic))
(define value-sd (make-object style-delta% 'change-normal))
@ -1171,10 +1171,21 @@
(send err-sd set-delta-foreground (make-object color% 255 0 0))
(send value-sd set-delta-foreground (make-object color% 0 0 175))
(set! in-port (make-custom-input-port read-string-proc #f in-close-proc))
(set! out-port (make-custom-output-port #f (make-write-string-proc out-sd) flush-proc out-close-proc))
(set! err-port (make-custom-output-port #f (make-write-string-proc err-sd) flush-proc out-close-proc))
(set! value-port (make-custom-output-port #f (make-write-string-proc value-sd) flush-proc out-close-proc)))
(set! in-port (make-custom-input-port read-string-proc
#f
in-close-proc))
(set! out-port (make-custom-output-port #f
(make-write-string-proc out-sd)
flush-proc
out-close-proc))
(set! err-port (make-custom-output-port #f
(make-write-string-proc err-sd)
flush-proc
out-close-proc))
(set! value-port (make-custom-output-port #f
(make-write-string-proc value-sd)
flush-proc
out-close-proc)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -1264,7 +1275,105 @@
(values fst (cdr lst)))]))])))
(super-new)))
#|
(define (drscheme-pretty-print-size-hook x _ port)
(and (or (eq? port this-out)
(eq? port this-err)
(eq? port this-result))
(cond
[(is-a? x sized-snip<%>) (send x get-character-width)]
[(is-a? x snip%)
(let ([dc (get-dc)]
[wbox (box 0)])
(send x get-extent dc 0 0 wbox #f #f #f #f #f)
(let-values ([(xw xh xa xd) (send dc get-text-extent "x")])
(max 1 (inexact->exact (ceiling (/ (unbox wbox) xw))))))]
[(syntax? x)
;; two spaces is about how big the turn down triangle
;; and the extra space accounts for. Of course, when
;; it is opened, this will be all wrong.
(+ 2 (string-length (format "~s" x)))]
[((use-number-snip) x)
(let ([number-snip-type ((which-number-snip) x)])
(cond
[(memq number-snip-type '(repeating-decimal
repeating-decimal-e
mixed-fraction
mixed-fraction-e))
1] ;; no idea of size yet
[else
(error 'which-number-snip
"unexpected result from parameter: ~e"
number-snip-type)]))]
[else #f])))
(define (drscheme-pretty-print-print-hook x _ port)
(let ([port-out-write
(cond
[(eq? port this-out) (lambda (x) (this-out-write x))]
[(eq? port this-err) (lambda (x) (this-err-write x))]
[(eq? port this-result) (lambda (x) (this-result-write x))]
;; this case should only happen if the user's program overrides the pretty-print-size-hook
;; and doesnt' override the pretty-print-print-hook to match.
[else #f])])
(if port-out-write
(let ([snip/str
(cond
[(syntax? x) (render-syntax/snip x)]
[((use-number-snip) x)
(let ([number-snip-type ((which-number-snip) x)])
(cond
[(eq? number-snip-type 'repeating-decimal)
(drscheme:number-snip:make-repeating-decimal-snip x #f)]
[(eq? number-snip-type 'repeating-decimal-e)
(drscheme:number-snip:make-repeating-decimal-snip x #t)]
[(eq? number-snip-type 'mixed-fraction)
(drscheme:number-snip:make-fraction-snip x #f)]
[(eq? number-snip-type 'mixed-fraction-e)
(drscheme:number-snip:make-fraction-snip x #t)]
[else
(error 'which-number-snip
"expected either 'repeating-decimal, 'repeating-decimal-e, 'mixed-fraction, or 'mixed-fraction-e got : ~e"
number-snip-type)]))]
[else x])])
(port-out-write snip/str))
(display x))))
;; setup-display/write-handlers : -> void
;; sets the port-display-handler and the port-write-handler
;; for the initial output port, initial error port and the
;; value port.
(define (setup-display/write-handlers)
(let* ([make-setup-handler
(lambda (port port-out-write)
(lambda (port-handler pretty)
(let ([original-handler (port-handler port)])
(port-handler
port
(rec drscheme-port-handler
(lambda (v p)
;; avoid looping by calling original-handler
;; for strings, since `pretty' calls write/display with
;; strings
(if (string? v)
(original-handler v p)
(parameterize ([pretty-print-columns 'infinity])
(pretty v p)))))))))]
[setup-handlers
(lambda (setup-handler)
(setup-handler port-display-handler pretty-display)
(setup-handler port-write-handler pretty-print))]
[setup-out-handler (make-setup-handler this-out (lambda (x) (this-out-write x)))]
[setup-err-handler (make-setup-handler this-err (lambda (x) (this-err-write x)))]
[setup-value-handler (make-setup-handler this-result (lambda (x) (this-result-write x)))])
(setup-handlers setup-out-handler)
(setup-handlers setup-err-handler)
(setup-handlers setup-value-handler)))
|#
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; queues