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

...

Browse Source 
original commit: 7a28d175a09a0a6d9eab3fb68e333a92a919851d
This commit is contained in:
Robby Findler 2001-12-20 04:37:33 +00:00
parent 975cb7a047
commit 51940dd2f4
3 changed files with 117 additions and 89 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

141
collects/framework/private/preferences.ss
View File

@ -3,6 +3,7 @@
(require (lib "string-constant.ss" "string-constants")
(lib "unitsig.ss")
(lib "class.ss")
(lib "file.ss")
(lib "class100.ss")
"sig.ss"
"../prefs-file-sig.ss"
@ -21,6 +22,7 @@
(rename [-read read])
;; default-preferences-filename
(define default-preferences-filename
(build-path (collection-path "defaults") "prefs.ss"))
@ -223,81 +225,96 @@
(hash-table-map preferences marshall-pref) p))
'truncate 'text)))))
(define (err input msg)
(message-box
(string-constant preferences)
(let* ([max-len 150]
[s1 (format "~s" input)]
[ell "..."]
[s2 (if (<= (string-length s1) max-len)
s1
(string-append
(substring s1 0 (- max-len
(string-length ell)))
ell))])
(string-append
(string-constant error-reading-preferences)
"\n"
msg
s2))))
(define (for-each-pref-in-file parse-pref preferences-filename)
(let/ec k
(let ([err
(lambda (input msg)
(message-box
(string-constant preferences)
(let* ([max-len 150]
[s1 (format "~s" input)]
[ell "..."]
[s2 (if (<= (string-length s1) max-len)
s1
(string-append
(substring s1 0 (- max-len
(string-length ell)))
ell))])
(string-append
(format (string-constant found-bad-pref) preferences-filename)
"\n"
msg
s2)))
(k #f))])
(let ([input (with-handlers
([not-break-exn?
(lambda (exn)
(message-box
(string-constant error-reading-preferences)
(string-append
(string-constant error-reading-preferences)
(format "\n~a" (exn-message exn))))
(k #f))])
(call-with-input-file preferences-filename
read
'text))])
(if (eof-object? input)
(void)
(let loop ([input input])
(when (pair? input)
(let ([pre-pref (car input)])
(if (and (list? pre-pref)
(= 2 (length pre-pref)))
(parse-pref (car pre-pref) (cadr pre-pref))
(err input (string-constant expected-list-of-length2))))
(loop (cdr input)))))))))
(let ([input (with-handlers
([not-break-exn?
(lambda (exn)
(message-box
(string-constant error-reading-preferences)
(string-append
(string-constant error-reading-preferences)
(format "\n~a" (exn-message exn))))
(k #f))])
(call-with-input-file preferences-filename read 'text))])
(if (eof-object? input)
(void)
(for-each-pref-in-sexp input parse-pref)))))
;; for-each-pref-in-sexp : sexp (symbol TST -> void) -> void
(define (for-each-pref-in-sexp input parse-pref)
(let/ec k
(let loop ([input input])
(when (pair? input)
(let ([pre-pref (car input)])
(if (and (list? pre-pref)
(= 2 (length pre-pref)))
(parse-pref (car pre-pref) (cadr pre-pref))
(begin (err input (string-constant expected-list-of-length2))
(k #f))))
(loop (cdr input))))))
;; read-from-file-to-ht : string hash-table -> void
(define (read-from-file-to-ht filename ht)
(let* ([parse-pref
(lambda (p marshalled)
(let* ([ht-pref (hash-table-get ht p (lambda () #f))]
[unmarshall-struct (hash-table-get marshall-unmarshall p (lambda () #f))])
(cond
[unmarshall-struct
(set p ((un/marshall-unmarshall unmarshall-struct) marshalled))]
;; in this case, assume that no marshalling/unmarshalling
;; is going to take place with the pref, since an unmarshalled
;; pref was already there.
[(pref? ht-pref)
(set p marshalled)]
[(marshalled? ht-pref)
(set-marshalled-data! ht-pref marshalled)]
[(and (not ht-pref) unmarshall-struct)
(set p ((un/marshall-unmarshall unmarshall-struct) marshalled))]
[(not ht-pref)
(hash-table-put! ht p (make-marshalled marshalled))]
[else (error 'prefs.ss "robby error.3: ~a" ht-pref)])))])
(add-raw-pref-to-ht ht p marshalled))])
(when (file-exists? filename)
(for-each-pref-in-file parse-pref filename))))
;; add-raw-pref-to-ht : hash-table symbol marshalled-preference -> void
(define (add-raw-pref-to-ht ht p marshalled)
(let* ([ht-pref (hash-table-get ht p (lambda () #f))]
[unmarshall-struct (hash-table-get marshall-unmarshall p (lambda () #f))])
(cond
[unmarshall-struct
(set p ((un/marshall-unmarshall unmarshall-struct) marshalled))]
;; in this case, assume that no marshalling/unmarshalling
;; is going to take place with the pref, since an unmarshalled
;; pref was already there.
[(pref? ht-pref)
(set p marshalled)]
[(marshalled? ht-pref)
(set-marshalled-data! ht-pref marshalled)]
[(and (not ht-pref) unmarshall-struct)
(set p ((un/marshall-unmarshall unmarshall-struct) marshalled))]
[(not ht-pref)
(hash-table-put! ht p (make-marshalled marshalled))]
[else (error 'prefs.ss "robby error.3: ~a" ht-pref)])))
;; read : -> void
(define (-read)
(read-from-file-to-ht (prefs-file:get-preferences-filename) preferences))
(let/ec k
(let ([sexp (get-preference
'drscheme:preferences
(lambda ()
(k #f)))])
(for-each-pref-in-sexp
sexp
(lambda (p marshalled)
(add-raw-pref-to-ht preferences p marshalled)))))
;(read-from-file-to-ht (prefs-file:get-preferences-filename) preferences)
)
;; read in the saved defaults. These should override the
;; values used with set-default.

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

@ -400,47 +400,57 @@
(define/override (get-extent dc x y wb hb db sb lb rb)
(cond
[(memq 'invisible (get-flags))
(set/f! wb 0)
(set/f! hb 0)]
(set/f! wb 0)]
[else
(set/f! wb (get-count))
(set/f! hb 1)])
(set/f! wb (get-count))])
(set/f! hb 1)
(set/f! db 0)
(set/f! sb 0)
(set/f! lb 0)
(set/f! rb 0))
(define (for-each/sections f str)
(field (cache-function #f))
(rename [super-insert insert])
(define/override (insert s len pos)
(set! cache-function #f)
(super-insert s len pos))
;; for-each/sections : string -> (number number -> void) -> void
(define (for-each/sections make-f str)
(let loop ([n (string-length str)]
[len 0]
[blank? #t])
(cond
[(zero? n)
(unless blank?
(f n len))]
(if blank?
(lambda (f) (void))
(lambda (f) (f n len)))]
[else
(let ([white? (char-whitespace? (string-ref str (- n 1)))])
(cond
[(eq? white? blank?)
(loop (- n 1) (+ len 1) blank?)]
[else
(unless blank?
(f n len))
(loop (- n 1)
1
(not blank?))]))])))
(let ([res (loop (- n 1) 1 (not blank?))])
(if blank?
res
(lambda (f)
(f n len)
(res f))))]))])))
(define/override (draw dc x y left top right bottom dx dy draw-caret)
(let ([str (get-text 0 (get-count))])
(unless cache-function
(set! cache-function (for-each/sections str)))
(when (<= top y bottom)
(for-each/sections
(cache-function
(lambda (start len)
(send dc draw-line
(+ x start)
y
(+ x start (- len 1))
y))
str))))
y))))))
(apply super-make-object args)))
(define 1-pixel-tab-snip%

23
collects/framework/splash.ss
View File

@ -1,7 +1,7 @@
(module splash mzscheme
(require (lib "class.ss")
(lib "etc.ss")
(lib "file.ss")
(lib "mred.ss" "mred"))
(provide get-splash-bitmap get-splash-canvas get-splash-eventspace get-dropped-files
@ -20,7 +20,7 @@
(define (start-splash _splash-filename _splash-title width-default)
(set! splash-title _splash-title)
(set! splash-filename _splash-filename)
(set! splash-max-width (max 1 (splash-get-resource (get-splash-width-resource) width-default)))
(set! splash-max-width (max 1 (splash-get-preference (get-splash-width-preference-name) width-default)))
(send gauge set-range splash-max-width)
(send splash-frame set-label splash-title)
(let/ec k
@ -53,12 +53,13 @@
(define splash-current-width 0)
(define (get-splash-width-resource) (format "~a-splash-max-width" splash-title))
(define (get-splash-width-preference-name)
(string->symbol (format "plt:~a-splash-max-width" splash-title)))
(define splash-max-width 1)
(define (close-splash)
(unless (= splash-max-width splash-current-width)
(splash-set-resource (get-splash-width-resource) (max 1 splash-current-width)))
(splash-set-preference (get-splash-width-preference-name) (max 1 splash-current-width)))
(set! quit-on-close? #f)
(when splash-frame
(send splash-frame show #f)))
@ -129,13 +130,13 @@
(stretchable-width #f)
(stretchable-height #f)))
(define (splash-get-resource name default)
(let ([b (box 0)])
(if (get-resource "mred" name b #f)
(unbox b)
default)))
(define (splash-set-resource name value)
(write-resource "mred" name value (find-graphical-system-path 'setup-file)))
(define (splash-get-preference name default)
(get-preference
name
(lambda ()
default)))
(define (splash-set-preference name value)
(put-preferences (list name) (list value)))
(define (splitup-path f)
(let*-values ([(absf) (if (relative-path? f)