.
original commit: f658a15f1ccb9fb55dd6133a00d79203f716a1d5
This commit is contained in:
Robby Findler
parent
b5c6e65d04
commit
d945d6322f
|
|
@ -155,11 +155,13 @@
|
|||
(symbol value test)
|
||||
"This function must be called every time your application starts up, before any call to"
|
||||
"@flink preferences:get %"
|
||||
", "
|
||||
"@flink preferences:set %"
|
||||
"."
|
||||
""
|
||||
"If you use"
|
||||
"@flink preferences:set-un/marshall %"
|
||||
", you must also call it before calling this function."
|
||||
", you must call this function before calling it."
|
||||
""
|
||||
"This sets the default value of the preference \\var{symbol} to"
|
||||
"\\var{value}. If the user has chosen a different setting,"
|
||||
|
|
@ -173,11 +175,7 @@
|
|||
"used."
|
||||
""
|
||||
"If there is a site-wide default preferences file, the default"
|
||||
"preference in that file is used instead of \\var{value}."
|
||||
""
|
||||
"Once"
|
||||
"@flink preferences:start-writing-timer "
|
||||
"has been called, no more default preferences may be registered.")
|
||||
"preference in that file is used instead of \\var{value}.")
|
||||
(preferences:set-un/marshall
|
||||
(symbol? (any? . -> . printable?) (printable? . -> . any?) . -> . void?)
|
||||
(symbol marshall unmarshall)
|
||||
|
|
@ -203,9 +201,9 @@
|
|||
"by hand."
|
||||
""
|
||||
"\\rawscm{preference:set-un/marshall} must be called before calling"
|
||||
"@flink preferences:get "
|
||||
"or "
|
||||
"@flink preferences:set-default %"
|
||||
"@flink preferences:get %"
|
||||
", "
|
||||
"@flink preferences:set %"
|
||||
".")
|
||||
(preferences:save
|
||||
(-> boolean?)
|
||||
|
|
@ -223,13 +221,6 @@
|
|||
()
|
||||
"\\rawscm{(preferences:restore-defaults)} restores the users's configuration to the"
|
||||
"default preferences.")
|
||||
(preferences:start-writing-timer
|
||||
(-> void?)
|
||||
()
|
||||
"Starts a thread that periodically flushes the preferences"
|
||||
"to disk reads them from the disk (if the prefs have changed on the disk."
|
||||
""
|
||||
"Once this function has been called, no new preferences may be registered.")
|
||||
|
||||
(preferences:add-panel
|
||||
((union string? (cons/p string? (listof string?)))
|
||||
|
|
|
|||
|
|
@ -24,7 +24,10 @@
|
|||
|
||||
(define main-preferences-symbol 'plt:framework-prefs)
|
||||
|
||||
;; preferences : sym -o> (union marshalled pref)
|
||||
;; preferences : sym -o> (union marshalled any)
|
||||
;; for a given preference symbol, p,
|
||||
;; when the table maps to a marshalled struct, the
|
||||
;; preference has not been examined (via get or set)
|
||||
(define preferences (make-hash-table))
|
||||
|
||||
;; marshall-unmarshall : sym -o> un/marshall
|
||||
|
|
@ -40,96 +43,81 @@
|
|||
;; the mapped symbols are the ones that have changed
|
||||
;; but not yet written out to disk.
|
||||
(define changed (make-hash-table))
|
||||
|
||||
;; no-more-defaults? : boolean
|
||||
;; when #t, no more default prefs may be set.
|
||||
(define no-more-defaults? #f)
|
||||
|
||||
|
||||
;; type un/marshall = (make-un/marshall (any -> prinable) (printable -> any))
|
||||
(define-struct un/marshall (marshall unmarshall))
|
||||
|
||||
;; type marshalled = (make-marshalled printable)
|
||||
(define-struct marshalled (data))
|
||||
|
||||
;; type pref = (make-pref any)
|
||||
(define-struct pref (value))
|
||||
|
||||
;; type default = (make-default any (any -> bool))
|
||||
(define-struct default (value checker))
|
||||
|
||||
;; reset-changed : -> void
|
||||
;; resets the changed table to indicate no changes have occurred
|
||||
(define (reset-changed)
|
||||
(set! changed (make-hash-table)))
|
||||
|
||||
;; add-changed-pref : symbol -> void
|
||||
;; marks the pref p as changed
|
||||
(define (add-changed-pref p)
|
||||
(hash-table-put! changed p #t))
|
||||
|
||||
;; periodically checks to see if changes need to be written out.
|
||||
(define (start-writing-timer)
|
||||
(set! no-more-defaults? #t)
|
||||
;; don't actually start the timer anymore.
|
||||
;; turns out that preferences are set far too often
|
||||
;; and I need a better test for when things should be written out.
|
||||
'(new timer%
|
||||
[notify-callback (lambda () (maybe-flush-changes))]
|
||||
[interval (* 10 1000)])
|
||||
(void))
|
||||
|
||||
(define last-time-read #f)
|
||||
(define (maybe-flush-changes)
|
||||
|
||||
;; writing out changes
|
||||
(let ([changed-syms (hash-table-map changed (lambda (k v) k))])
|
||||
(unless (null? changed-syms)
|
||||
(let/ec k
|
||||
(let ([sexp (get-disk-prefs (lambda () (k #f)))])
|
||||
(install-stashed-preferences sexp changed-syms)
|
||||
(raw-save #t)
|
||||
(reset-changed)))))
|
||||
|
||||
;; reading in changes
|
||||
(let* ([filename (find-system-path 'pref-file)])
|
||||
(when (file-exists? filename)
|
||||
(let ([mod (file-or-directory-modify-seconds filename)])
|
||||
(when (or (not last-time-read)
|
||||
(last-time-read . < . mod))
|
||||
(let* ([failed? #f]
|
||||
[new-stuff (get-preference main-preferences-symbol (lambda () (set! failed? #t)))])
|
||||
(unless failed?
|
||||
(set! last-time-read mod)
|
||||
(install-stashed-preferences new-stuff '())
|
||||
(reset-changed))))))))
|
||||
;; pref-callback : (make-pref-callback (union (weak-box (sym tst -> void)) (sym tst -> void)))
|
||||
;; this is used as a wrapped to deal with the problem that different procedures might be eq?.
|
||||
(define-struct pref-callback (cb))
|
||||
|
||||
(define guard
|
||||
(lambda (when p value thunk)
|
||||
(with-handlers ([exn:fail?
|
||||
(lambda (exn)
|
||||
(error "excetion raised ~s, pref ~s val ~s, msg: ~a"
|
||||
when
|
||||
p
|
||||
value
|
||||
(if (exn? exn)
|
||||
(exn-message exn)
|
||||
(format "~s" exn))))])
|
||||
(thunk))))
|
||||
;; get : symbol -> any
|
||||
;; return the current value of the preference `p'
|
||||
;; exported
|
||||
(define (get p)
|
||||
(unless (hash-table-bound? defaults p)
|
||||
(raise-unknown-preference-error
|
||||
"preferences:get: tried to get a preference but no default set for ~e"
|
||||
p))
|
||||
(let ([res
|
||||
(hash-table-get preferences
|
||||
p
|
||||
(lambda ()
|
||||
(let ([def (hash-table-get defaults p)])
|
||||
(default-value def))))])
|
||||
(cond
|
||||
[(marshalled? res)
|
||||
(let ([unmarshalled (unmarshall p res)])
|
||||
(hash-table-put! preferences p unmarshalled)
|
||||
unmarshalled)]
|
||||
[else res])))
|
||||
|
||||
;; set : symbol any -> void
|
||||
;; updates the preference
|
||||
;; exported
|
||||
(define (set p value)
|
||||
(let ([default (hash-table-get
|
||||
defaults p
|
||||
(lambda ()
|
||||
(raise-unknown-preference-error
|
||||
"preferences:set: tried to set the preference ~e to ~e, but no default is set"
|
||||
p
|
||||
value)))])
|
||||
(unless ((default-checker default) value)
|
||||
(error 'preferences:set
|
||||
"tried to set preference ~e to ~e but it does not meet test from preferences:set-default"
|
||||
p value))
|
||||
(check-callbacks p value)
|
||||
(hash-table-put! preferences p value)))
|
||||
|
||||
(define (raise-unknown-preference-error fmt . args)
|
||||
(raise (exn:make-unknown-preference
|
||||
(string->immutable-string (apply format fmt args))
|
||||
(current-continuation-marks))))
|
||||
|
||||
;; unmarshall : symbol marshalled -> any
|
||||
;; unmarshalls a preference read from the disk
|
||||
(define (unmarshall p marshalled)
|
||||
(let/ec k
|
||||
(let* ([data (marshalled-data marshalled)]
|
||||
[unmarshall-fn (un/marshall-unmarshall
|
||||
(hash-table-get marshall-unmarshall
|
||||
p
|
||||
(lambda () (k data))))])
|
||||
(with-handlers ([exn:fail?
|
||||
(lambda (exn)
|
||||
(begin0
|
||||
(hash-table-get defaults p (lambda () (raise exn)))
|
||||
(message-box (format (string-constant error-unmarshalling) p)
|
||||
(if (exn? exn)
|
||||
(format "~a" (exn-message exn))
|
||||
(format "~s" exn)))))])
|
||||
(unmarshall-fn data)))))
|
||||
|
||||
;; pref-callback : (make-pref-callback (union (weak-box (sym tst -> void)) (sym tst -> void)))
|
||||
;; this is used as a wrapped to hack around the problem
|
||||
;; that different procedures might be eq?.
|
||||
(define-struct pref-callback (cb))
|
||||
(lambda () (k data))))]
|
||||
[default (hash-table-get defaults p)])
|
||||
(let ([result (unmarshall-fn data)])
|
||||
(if ((default-checker default) result)
|
||||
result
|
||||
(default-value default))))))
|
||||
|
||||
;; add-callback : sym (-> void) -> void
|
||||
(define add-callback
|
||||
|
|
@ -171,78 +159,30 @@
|
|||
(let ([v (weak-box-value cb)])
|
||||
(if v
|
||||
(begin
|
||||
(guard "calling callback" p value
|
||||
(lambda () (v p value)))
|
||||
(v p value)
|
||||
(cons callback (loop (cdr callbacks))))
|
||||
(loop (cdr callbacks))))]
|
||||
[else
|
||||
(guard "calling callback" p value
|
||||
(lambda () (cb p value)))
|
||||
(cb p value)
|
||||
(cons callback (loop (cdr callbacks)))]))]))])
|
||||
(if (null? new-callbacks)
|
||||
(hash-table-remove! callbacks p)
|
||||
(hash-table-put! callbacks p new-callbacks))))
|
||||
|
||||
(define (get p)
|
||||
(let ([ans (hash-table-get preferences p
|
||||
(lambda ()
|
||||
(raise (exn:make-unknown-preference
|
||||
(format "preferences:get: attempted to get unknown preference: ~e" p)
|
||||
(current-continuation-marks)))))])
|
||||
(cond
|
||||
[(marshalled? ans)
|
||||
(let* ([default-s
|
||||
(hash-table-get
|
||||
defaults p
|
||||
(lambda ()
|
||||
(raise (exn:make-unknown-preference
|
||||
(format "preferences:get: no default pref for: ~e" p)
|
||||
(current-continuation-marks)))))]
|
||||
[default (default-value default-s)]
|
||||
[checker (default-checker default-s)]
|
||||
[unmarshalled (let ([unmarsh (unmarshall p ans)])
|
||||
(if (checker unmarsh)
|
||||
unmarsh
|
||||
default))]
|
||||
[pref (begin (check-callbacks p unmarshalled)
|
||||
unmarshalled)])
|
||||
(hash-table-put! preferences p (make-pref pref))
|
||||
pref)]
|
||||
[(pref? ans)
|
||||
(pref-value ans)]
|
||||
[else (error 'prefs.ss "robby error.1: ~a" ans)])))
|
||||
|
||||
(define (default-set? p)
|
||||
(let/ec k
|
||||
(hash-table-get defaults p (lambda () (k #f)))
|
||||
#t))
|
||||
|
||||
;; set : symbol any -> void
|
||||
;; updates the preference
|
||||
(define (set p value)
|
||||
(add-changed-pref p)
|
||||
(let* ([pref (hash-table-get preferences p (lambda () #f))])
|
||||
(unless (default-set? p)
|
||||
(error 'preferences:set "tried to set a preference but no default set for ~e, with ~e"
|
||||
p value))
|
||||
(cond
|
||||
[(pref? pref)
|
||||
(check-callbacks p value)
|
||||
(set-pref-value! pref value)]
|
||||
[(or (marshalled? pref)
|
||||
(not pref))
|
||||
(check-callbacks p value)
|
||||
(hash-table-put! preferences p (make-pref value))]
|
||||
[else
|
||||
(error 'prefs.ss "robby error.0: ~a" pref)])))
|
||||
|
||||
(define set-un/marshall
|
||||
(lambda (p marshall unmarshall)
|
||||
(unless (default-set? p)
|
||||
(unless (hash-table-bound? defaults p)
|
||||
(error 'set-un/marshall "must call set-default for ~s before calling set-un/marshall for ~s"
|
||||
p p))
|
||||
(when (pref-has-value? p)
|
||||
(error 'preferences:set-un/marshall "a value for the preference ~e has already been looked up or set" p))
|
||||
(hash-table-put! marshall-unmarshall p (make-un/marshall marshall unmarshall))))
|
||||
|
||||
(define (hash-table-bound? ht s)
|
||||
(let/ec k
|
||||
(hash-table-get ht s (lambda () (k #f)))
|
||||
#t))
|
||||
|
||||
(define restore-defaults
|
||||
(lambda ()
|
||||
(hash-table-for-each
|
||||
|
|
@ -251,24 +191,31 @@
|
|||
|
||||
;; set-default : (sym TST (TST -> boolean) -> void
|
||||
(define (set-default p default-value checker)
|
||||
(when no-more-defaults?
|
||||
(error 'set-default "tried to register the pref ~e too late; preferences:start-writing-timer has already been called" p))
|
||||
(when (pref-has-value? p)
|
||||
(error 'preferences:set-default
|
||||
"tried to call set-default for preference ~e but it already has a value"
|
||||
p))
|
||||
(let ([default-okay? (checker default-value)])
|
||||
(unless default-okay?
|
||||
(error 'set-default "~s: checker (~s) returns ~s for ~s, expected #t~n"
|
||||
p checker default-okay? default-value))
|
||||
(hash-table-get preferences p
|
||||
(lambda ()
|
||||
(hash-table-put! preferences p (make-pref default-value))))
|
||||
(hash-table-put! defaults p (make-default default-value checker))))
|
||||
|
||||
;; pref-has-value? : symbol -> boolean
|
||||
;; returns #t if the preference's value has been examined with set or get
|
||||
(define (pref-has-value? p)
|
||||
(let/ec k
|
||||
(let ([b (hash-table-get preferences p (lambda () (k #f)))])
|
||||
(not (marshalled? b)))))
|
||||
|
||||
|
||||
(define (save) (raw-save #f))
|
||||
|
||||
;; raw-save : boolean -> boolean
|
||||
;; input determines if there is a dialog box showing the errors (and other msgs)
|
||||
;; and result indicates if there was an error
|
||||
(define (raw-save silent?)
|
||||
(with-handlers ([exn:fail?
|
||||
(with-handlers ([(lambda (x) #f) ;exn:fail?
|
||||
(lambda (exn)
|
||||
(unless silent?
|
||||
(message-box
|
||||
|
|
@ -299,23 +246,18 @@
|
|||
(format (string-constant pref-lock-not-gone) filename))))))))
|
||||
res)))
|
||||
|
||||
(define (marshall-pref p ht-value)
|
||||
(cond
|
||||
[(marshalled? ht-value) (list p (marshalled-data ht-value))]
|
||||
[(pref? ht-value)
|
||||
(let* ([value (pref-value ht-value)]
|
||||
[marshalled
|
||||
(let/ec k
|
||||
(guard "marshalling" p value
|
||||
(lambda ()
|
||||
((un/marshall-marshall
|
||||
(hash-table-get marshall-unmarshall p
|
||||
(lambda ()
|
||||
(k value))))
|
||||
value))))])
|
||||
(list p marshalled))]
|
||||
[else (error 'prefs.ss "robby error.2: ~a" ht-value)]))
|
||||
|
||||
;; marshall-pref : symbol any -> (list symbol printable)
|
||||
(define (marshall-pref p value)
|
||||
(if (marshalled? value)
|
||||
(list p (marshalled-data value))
|
||||
(let/ec k
|
||||
(let* ([marshaller
|
||||
(un/marshall-marshall
|
||||
(hash-table-get marshall-unmarshall p
|
||||
(lambda () (k (list p value)))))]
|
||||
[marshalled (marshaller value)])
|
||||
(list p marshalled)))))
|
||||
|
||||
(define (read-err input msg)
|
||||
(message-box
|
||||
(string-constant preferences)
|
||||
|
|
@ -332,12 +274,44 @@
|
|||
(string-constant error-reading-preferences)
|
||||
"\n"
|
||||
msg
|
||||
"\n"
|
||||
s2))))
|
||||
|
||||
;; read : -> void
|
||||
(define (-read) (get-disk-prefs/install void))
|
||||
|
||||
;; get-disk-prefs/install : (-> A) -> (union A sexp)
|
||||
(define (get-disk-prefs/install fail)
|
||||
(let/ec k
|
||||
(let ([sexp (get-disk-prefs (lambda () (k (fail))))])
|
||||
(install-stashed-preferences sexp '())
|
||||
sexp)))
|
||||
|
||||
;; get-disk-prefs : (-> A) -> (union A sexp)
|
||||
;; effect: updates the flag for the modified seconds
|
||||
;; (note: if this is not followed by actually installing
|
||||
;; the preferences, things break)
|
||||
(define (get-disk-prefs fail)
|
||||
(let/ec k
|
||||
(let* ([filename (find-system-path 'pref-file)]
|
||||
[mod (and (file-exists? filename) (file-or-directory-modify-seconds filename))]
|
||||
[sexp (get-preference main-preferences-symbol (lambda () (k (fail))))])
|
||||
sexp)))
|
||||
|
||||
;; install-stashed-preferences : sexp (listof symbol) -> void
|
||||
;; ensure that `prefs' is actuall a well-formed preferences
|
||||
;; table and installs them as the current preferences.
|
||||
(define (install-stashed-preferences prefs skip)
|
||||
(for-each-pref-in-sexp
|
||||
prefs
|
||||
(lambda (p marshalled)
|
||||
(unless (memq p skip)
|
||||
(hash-table-put! preferences p (make-marshalled marshalled))))))
|
||||
|
||||
(define (for-each-pref-in-file parse-pref preferences-filename)
|
||||
(let/ec k
|
||||
(let ([input (with-handlers
|
||||
([exn:fail?
|
||||
([(lambda (x) #f) ;exn:fail?
|
||||
(lambda (exn)
|
||||
(message-box
|
||||
(string-constant error-reading-preferences)
|
||||
|
|
@ -360,64 +334,11 @@
|
|||
(pair? (cdr pre-pref))
|
||||
(null? (cddr pre-pref)))
|
||||
(parse-pref (car pre-pref) (cadr pre-pref))
|
||||
(begin (read-err input (string-constant expected-list-of-length2))
|
||||
(begin (read-err pre-pref (string-constant expected-list-of-length2))
|
||||
(k #f))))
|
||||
(loop (cdr input))))))
|
||||
|
||||
;; 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) (get-disk-prefs/install void))
|
||||
|
||||
;; get-disk-prefs/install : (-> A) -> (union A sexp)
|
||||
(define (get-disk-prefs/install fail)
|
||||
(let/ec k
|
||||
(let ([sexp (get-disk-prefs (lambda () (k (fail))))])
|
||||
(install-stashed-preferences sexp '())
|
||||
(reset-changed)
|
||||
sexp)))
|
||||
|
||||
;; get-disk-prefs : (-> A) -> (union A sexp)
|
||||
;; effect: updates the flag for the modified seconds
|
||||
;; (note: if this is not followed by actually installing
|
||||
;; the preferences, things break)
|
||||
(define (get-disk-prefs fail)
|
||||
(let/ec k
|
||||
(let* ([filename (find-system-path 'pref-file)]
|
||||
[mod (and (file-exists? filename) (file-or-directory-modify-seconds filename))]
|
||||
[sexp (get-preference main-preferences-symbol (lambda () (k (fail))))])
|
||||
(set! last-time-read mod)
|
||||
sexp)))
|
||||
|
||||
;; install-stashed-preferences : sexp (listof symbol) -> void
|
||||
;; ensure that `prefs' is actuall a well-formed preferences
|
||||
;; table and installs them as the current preferences.
|
||||
(define (install-stashed-preferences prefs skip)
|
||||
(for-each-pref-in-sexp
|
||||
prefs
|
||||
(lambda (p marshalled)
|
||||
(unless (memq p skip)
|
||||
(add-raw-pref-to-ht preferences p marshalled)))))
|
||||
|
||||
|
||||
;; ; ;;;
|
||||
|
|
|
|||
|
|
@ -184,7 +184,6 @@
|
|||
save
|
||||
read
|
||||
restore-defaults
|
||||
start-writing-timer
|
||||
|
||||
add-panel
|
||||
add-font-panel
|
||||
|
|
|
|||
|
|
@ -9,7 +9,7 @@ WARNING: printf is rebound in the body of the unit to always
|
|||
(require (lib "string-constant.ss" "string-constants")
|
||||
(lib "unitsig.ss")
|
||||
(lib "class.ss")
|
||||
(lib "plt-match.ss")
|
||||
(lib "match.ss")
|
||||
"sig.ss"
|
||||
"../macro.ss"
|
||||
"../gui-utils.ss"
|
||||
|
|
@ -856,8 +856,8 @@ WARNING: printf is rebound in the body of the unit to always
|
|||
get-err-port
|
||||
get-value-port))
|
||||
|
||||
(define-struct peeker (bytes skip-count pe resp-chan))
|
||||
(define-struct peeker-req (bytes skip-count pe resp-chan resp-nack))
|
||||
(define-struct peeker (bytes skip-count pe resp-chan nack))
|
||||
(define-struct committer (kr commit-peeker-evt done-evt resp-chan resp-nack))
|
||||
|
||||
(define ports-mixin
|
||||
(mixin ((class->interface text%) #;scheme:text<%>) (ports<%>)
|
||||
|
|
@ -1118,7 +1118,7 @@ WARNING: printf is rebound in the body of the unit to always
|
|||
;; in any thread (even concurrently)
|
||||
;;
|
||||
(define (make-write-bytes-proc style)
|
||||
(lambda (to-write start end block/buffer?)
|
||||
(lambda (to-write start end block/buffer? enable-breaks?)
|
||||
(cond
|
||||
[(eq? (current-thread) (eventspace-handler-thread eventspace))
|
||||
(error 'write-bytes-proc "cannot write to port on eventspace main thread")]
|
||||
|
|
@ -1252,70 +1252,35 @@ WARNING: printf is rebound in the body of the unit to always
|
|||
(apply
|
||||
choice-evt
|
||||
(map
|
||||
(lambda (committer)
|
||||
(match (make-committer kr
|
||||
commit-peeker-evt
|
||||
done-evt
|
||||
resp-chan
|
||||
resp-nack)
|
||||
(choice-evt
|
||||
(handle-evt
|
||||
commit-peeker-evt
|
||||
(lambda (_)
|
||||
;; this committer will be thrown out in next iteration
|
||||
(loop)))
|
||||
(handle-evt
|
||||
done-evt
|
||||
(lambda (v)
|
||||
(set! data (drop-some-data data))
|
||||
(semaphore-post peeker-sema)
|
||||
(set! peeker-sema (make-semaphore 0))
|
||||
(set! peeker-evt (semaphore-peek-evt peeker-sema))
|
||||
(set! committers (remq committer committers))
|
||||
(set! resp-evts
|
||||
(cons
|
||||
(choice-evt
|
||||
resp-nack
|
||||
(channel-put-evt resp-chan #t))
|
||||
resp-evts))
|
||||
(loop))))))
|
||||
committers))
|
||||
(apply
|
||||
choice-evt
|
||||
(map
|
||||
(lambda (committer)
|
||||
(match (make-committer kr commit-peeker-evt
|
||||
done-evt resp-chan resp-nack)
|
||||
(let ([size (queue-size data)])
|
||||
(cond
|
||||
[(not (eq? peeker-evt commit-peeker-evt))
|
||||
(set! resp-evts
|
||||
(cons
|
||||
(choice-evt
|
||||
resp-nack
|
||||
(channel-put-evt resp-chan #f))
|
||||
resp-evts))
|
||||
(loop)]
|
||||
[(< size kr)
|
||||
(set! resp-evts
|
||||
(cons
|
||||
(choice-evt
|
||||
resp-nack
|
||||
(channel-put-evt resp-chan 'commit-failure))
|
||||
resp-evts))
|
||||
(loop)]
|
||||
[else ;; commit succeeds
|
||||
(lambda (a-committer)
|
||||
(match a-committer
|
||||
[($ committer
|
||||
kr
|
||||
commit-peeker-evt
|
||||
done-evt
|
||||
resp-chan
|
||||
resp-nack)
|
||||
(choice-evt
|
||||
(handle-evt
|
||||
commit-peeker-evt
|
||||
(lambda (_)
|
||||
;; this committer will be thrown out in next iteration
|
||||
(loop)))
|
||||
(handle-evt
|
||||
done-evt
|
||||
(lambda (v)
|
||||
(set! data (dequeue-n kr data))
|
||||
(semaphore-post peeker-sema)
|
||||
(set! peeker-sema (make-semaphore 0))
|
||||
(set! peeker-evt (semaphore-peek-evt peeker-sema))
|
||||
(set! data (dequeue-n kr data))
|
||||
(set! resp-evts
|
||||
(set! committers (remq a-committer committers))
|
||||
(set! response-evts
|
||||
(cons
|
||||
(choice-evt
|
||||
resp-nack
|
||||
(channel-put-evt resp-chan #t))
|
||||
resp-evts))
|
||||
(loop)]))))
|
||||
response-evts))
|
||||
(loop))))]))
|
||||
committers))
|
||||
(apply choice-evt
|
||||
(map (lambda (resp-evt)
|
||||
|
|
@ -1336,7 +1301,7 @@ WARNING: printf is rebound in the body of the unit to always
|
|||
[(null? eles) (values left-alone transformed)]
|
||||
[else (let* ([ele (car eles)]
|
||||
[maybe (f ele)])
|
||||
(if maybe-evt
|
||||
(if maybe
|
||||
(loop (cdr eles)
|
||||
(cons maybe transformed)
|
||||
left-alone)
|
||||
|
|
@ -1347,49 +1312,47 @@ WARNING: printf is rebound in the body of the unit to always
|
|||
;; service-committer : queue evt -> committer -> (union #f evt)
|
||||
;; if the committer can be dumped, return an evt that
|
||||
;; does the dumping. otherwise, return #f
|
||||
(define ((service-committer data peeker-evt) committer)
|
||||
(match (make-committer kr commit-peeker-evt
|
||||
done-evt resp-chan resp-nack)
|
||||
(let ([size (queue-size data)])
|
||||
(cond
|
||||
[(not (eq? peeker-evt commit-peeker-evt))
|
||||
(choice-evt
|
||||
resp-nack
|
||||
(channel-put-evt resp-chan #f))]
|
||||
[(< size kr)
|
||||
(choice-evt
|
||||
resp-nack
|
||||
(channel-put-evt resp-chan 'commit-failure))]
|
||||
[else ;; commit succeeds
|
||||
#f]))))
|
||||
(define ((service-committer data peeker-evt) a-committer)
|
||||
(match a-committer
|
||||
[($ committer
|
||||
kr commit-peeker-evt
|
||||
done-evt resp-chan resp-nack)
|
||||
(let ([size (queue-size data)])
|
||||
(cond
|
||||
[(not (eq? peeker-evt commit-peeker-evt))
|
||||
(choice-evt
|
||||
resp-nack
|
||||
(channel-put-evt resp-chan #f))]
|
||||
[(< size kr)
|
||||
(choice-evt
|
||||
resp-nack
|
||||
(channel-put-evt resp-chan 'commit-failure))]
|
||||
[else ;; commit succeeds
|
||||
#f]))]))
|
||||
|
||||
;; service-waiter : peeker -> (union #f evt)
|
||||
;; if the peeker can be serviced, build an event to service it
|
||||
;; otherwise return #f
|
||||
(define (service-waiter peeker)
|
||||
(let* ([bytes (peeker-bytes peeker)]
|
||||
[skip-count (peeker-count peeker)]
|
||||
[pe (peeker-pe peeker)]
|
||||
[resp-chan (peeker-resp-chan peeker)]
|
||||
[nack-evt (peeker-nack-evt peeker)]
|
||||
(cond
|
||||
[(not (eq? pe peeker-evt))
|
||||
(choice-evt (make-channel-put-evt resp-chan #f)
|
||||
nack-evt)]
|
||||
[(queue-has-n? data (+ skip-count 1))
|
||||
(let ([nth (queue-nth data (+ skip-count 1))])
|
||||
(choice-evt
|
||||
nack-evt
|
||||
(if (byte? nth)
|
||||
(begin
|
||||
(byte-set! bytes 0 fst)
|
||||
(make-channel-put-evt resp-chan 1))
|
||||
(build-answer-evt
|
||||
(make-channel-put-evt
|
||||
resp-chan
|
||||
(lambda (src line col pos)
|
||||
nth))))))]
|
||||
[else #f]))))
|
||||
(define (service-waiter a-peeker)
|
||||
(match a-peeker
|
||||
[($ peeker bytes skip-count pe resp-chan nack-evt)
|
||||
(cond
|
||||
[(not (eq? pe peeker-evt))
|
||||
(choice-evt (channel-put-evt resp-chan #f)
|
||||
nack-evt)]
|
||||
[((queue-size data) . > . skip-count)
|
||||
(let ([nth (peek-n data (+ skip-count 1))])
|
||||
(choice-evt
|
||||
nack-evt
|
||||
(if (byte? nth)
|
||||
(begin
|
||||
(bytes-set! bytes 0 nth)
|
||||
(channel-put-evt resp-chan 1))
|
||||
(channel-put-evt
|
||||
resp-chan
|
||||
(lambda (src line col pos)
|
||||
nth)))))]
|
||||
[else #f])]))
|
||||
|
||||
(loop))))
|
||||
|
||||
|
|
@ -1466,6 +1429,29 @@ WARNING: printf is rebound in the body of the unit to always
|
|||
(loop (send snip next))))]
|
||||
[else null])))
|
||||
|
||||
;; dequeue-n : queue number -> queue
|
||||
(define (dequeue-n queue n)
|
||||
(let loop ([q queue]
|
||||
[n n])
|
||||
(cond
|
||||
[(zero? n) queue]
|
||||
[(queue-empty? q) (error 'dequeue-n "not enough!")]
|
||||
[else (loop (queue-rest q) (- n 1))])))
|
||||
|
||||
;; peek-n : queue number -> queue
|
||||
(define (peek-n queue n)
|
||||
(let loop ([q queue]
|
||||
[n n])
|
||||
(cond
|
||||
[(zero? n)
|
||||
(when (queue-empty? q)
|
||||
(error 'peek-n "not enough!"))
|
||||
(queue-first q)]
|
||||
[else
|
||||
(when (queue-empty? q)
|
||||
(error 'dequeue-n "not enough!"))
|
||||
(loop (queue-rest q) (- n 1))])))
|
||||
|
||||
;; split-queue : converter (queue (cons (union snip bytes) style)
|
||||
;; -> (values (listof (queue (cons (union snip bytes) style)) queue)
|
||||
;; this function must only be called on the output-buffer-thread
|
||||
|
|
|
|||
|
|
@ -47,7 +47,7 @@
|
|||
(write
|
||||
(let ([these-errs (protect (lambda () (begin0 errs (set! errs null))))])
|
||||
(if (null? these-errs)
|
||||
(with-handlers ([not-break-exn?
|
||||
(with-handlers ([(lambda (x) #t)
|
||||
(lambda (x) (list 'error (exception->string x)))])
|
||||
(list 'normal (print-convert (eval sexp))))
|
||||
(list 'last-error
|
||||
|
|
|
|||
|
|
@ -10,7 +10,7 @@
|
|||
(define preferences-file (find-system-path 'pref-file))
|
||||
|
||||
(define old-preferences-file (let-values ([(base name _2) (split-path preferences-file)])
|
||||
(build-path base (string-append name ".save"))))
|
||||
(build-path base (string-append (path->string name) ".save"))))
|
||||
|
||||
|
||||
(define all-files
|
||||
|
|
|
|||
|
|
@ -3,70 +3,95 @@
|
|||
(lib "etc.ss")
|
||||
(lib "list.ss"))
|
||||
|
||||
|
||||
(local [(define pref-file (build-path (find-system-path 'pref-dir)
|
||||
(case (system-type)
|
||||
[(macos) "MrEd Preferences"]
|
||||
[(windows) "mred.pre"]
|
||||
[(unix) ".mred.prefs"]
|
||||
[else (error 'prefs.ss "unknown os: ~a~n" (system-type))])))
|
||||
(define old-prefs (if (file-exists? pref-file)
|
||||
(call-with-input-file pref-file read)
|
||||
null))
|
||||
(define (check-eq? s) (lambda (t) (eq? s t)))
|
||||
(define pref-sym 'framework:test-suite)]
|
||||
|
||||
(call-with-output-file pref-file
|
||||
(lambda (port) (write (filter (lambda (x) (not (eq? (car x) pref-sym)))
|
||||
old-prefs)
|
||||
port))
|
||||
'truncate)
|
||||
(define ((check-eq? x) y) (eq? x y))
|
||||
(define pref-sym 'plt:not-a-real-preference)
|
||||
(define marshalling-pref-sym 'plt:not-a-real-preference-marshalling)
|
||||
|
||||
(define saved-prefs-file
|
||||
(let loop ([n 0])
|
||||
(let ([candidate
|
||||
(build-path (this-expression-source-directory)
|
||||
(format "save-prefs.~a" n))])
|
||||
(if (file-exists? candidate)
|
||||
(loop (+ n 1))
|
||||
candidate))))
|
||||
|
||||
(define prefs-file (find-system-path 'pref-file))
|
||||
|
||||
(when (file-exists? prefs-file)
|
||||
(copy-file prefs-file saved-prefs-file)
|
||||
(delete-file prefs-file)
|
||||
(printf "saved preferences file from ~s to ~s\n" prefs-file saved-prefs-file))
|
||||
|
||||
(shutdown-mred)
|
||||
|
||||
|
||||
(test
|
||||
'preference-unbound
|
||||
(check-eq? 'passed)
|
||||
`(with-handlers ([exn:unknown-preference?
|
||||
(lambda (x)
|
||||
'passed)])
|
||||
(lambda (x)
|
||||
'passed)])
|
||||
(preferences:get ',pref-sym)))
|
||||
(test 'preference-set-default/get
|
||||
(check-eq? 'passed)
|
||||
`(begin (preferences:set-default ',pref-sym 'passed symbol?)
|
||||
(preferences:get ',pref-sym)))
|
||||
(check-eq? 'passed)
|
||||
`(begin (preferences:set-default ',pref-sym 'passed symbol?)
|
||||
(preferences:get ',pref-sym)))
|
||||
(test 'preference-set/get
|
||||
(check-eq? 'new-pref)
|
||||
`(begin (preferences:set ',pref-sym 'new-pref)
|
||||
(preferences:get ',pref-sym)))
|
||||
(check-eq? 'new-pref)
|
||||
`(begin (preferences:set ',pref-sym 'new-pref)
|
||||
(preferences:get ',pref-sym)))
|
||||
|
||||
(test 'preference-marshalling
|
||||
(check-eq? 'the-answer)
|
||||
`(begin (preferences:set-default ',marshalling-pref-sym (lambda () 'the-answer) procedure?)
|
||||
(preferences:set-un/marshall ',marshalling-pref-sym
|
||||
(lambda (f) (f))
|
||||
(lambda (v) (lambda () v)))
|
||||
(begin0 ((preferences:get ',marshalling-pref-sym))
|
||||
(preferences:set ',marshalling-pref-sym (lambda () 2))
|
||||
(preferences:save))))
|
||||
(shutdown-mred)
|
||||
(test 'preference-marshalling
|
||||
(check-eq? 2)
|
||||
`(begin (preferences:set-default ',marshalling-pref-sym (lambda () 'the-answer) procedure?)
|
||||
(preferences:set-un/marshall ',marshalling-pref-sym
|
||||
(lambda (f) (f))
|
||||
(lambda (v) (lambda () v)))
|
||||
((preferences:get ',marshalling-pref-sym))))
|
||||
|
||||
(with-handlers ([eof-result? (lambda (x) (void))])
|
||||
(send-sexp-to-mred '(begin (preferences:set 'framework:verify-exit #f)
|
||||
(exit:exit)
|
||||
|
||||
;; do this yield here so that exit:exit
|
||||
;; actually exits on this interaction.
|
||||
;; right now, exit:exit queue's a new event to exit
|
||||
;; instead of just exiting immediately.
|
||||
(yield (make-semaphore 0)))))
|
||||
|
||||
(exit:exit)
|
||||
|
||||
;; do this yield here so that exit:exit
|
||||
;; actually exits on this interaction.
|
||||
;; right now, exit:exit queue's a new event to exit
|
||||
;; instead of just exiting immediately.
|
||||
(yield (make-semaphore 0)))))
|
||||
|
||||
(test 'preference-get-after-restart
|
||||
(check-eq? 'new-pref)
|
||||
`(begin (preferences:set-default ',pref-sym 'passed symbol?)
|
||||
(preferences:get ',pref-sym))))
|
||||
|
||||
|
||||
(test 'dialog-appears
|
||||
(lambda (x) (eq? 'passed x))
|
||||
(lambda ()
|
||||
(send-sexp-to-mred '(begin (send (make-object frame:basic% "frame") show #t)
|
||||
(preferences:show-dialog)))
|
||||
(wait-for-frame "Preferences")
|
||||
(send-sexp-to-mred '(begin (preferences:hide-dialog)
|
||||
(let ([f (get-top-level-focus-window)])
|
||||
(if f
|
||||
(if (string=? "Preferences" (send f get-label))
|
||||
'failed
|
||||
'passed)
|
||||
'passed))))))
|
||||
)
|
||||
(check-eq? 'new-pref)
|
||||
`(begin (preferences:set-default ',pref-sym 'passed symbol?)
|
||||
(preferences:get ',pref-sym)))
|
||||
|
||||
(test 'dialog-appears
|
||||
(lambda (x) (eq? 'passed x))
|
||||
(lambda ()
|
||||
(send-sexp-to-mred '(begin (send (make-object frame:basic% "frame") show #t)
|
||||
(preferences:show-dialog)))
|
||||
(wait-for-frame "Preferences")
|
||||
(send-sexp-to-mred '(begin (preferences:hide-dialog)
|
||||
(let ([f (get-top-level-focus-window)])
|
||||
(if f
|
||||
(if (string=? "Preferences" (send f get-label))
|
||||
'failed
|
||||
'passed)
|
||||
'passed))))))
|
||||
|
||||
(when (file-exists? saved-prefs-file)
|
||||
(printf "restoring preferences file from ~s to ~s\n" saved-prefs-file prefs-file)
|
||||
(when (file-exists? prefs-file)
|
||||
(delete-file prefs-file))
|
||||
(copy-file saved-prefs-file prefs-file)
|
||||
(delete-file saved-prefs-file)))
|
||||
|
||||
|
|
|
|||
|
|
@ -67,7 +67,7 @@
|
|||
(define listener
|
||||
(let loop ()
|
||||
(let ([port (load port-filename)])
|
||||
(with-handlers ([not-break-exn?
|
||||
(with-handlers ([exn:fail?
|
||||
(lambda (x)
|
||||
(let ([next (+ port 1)])
|
||||
(call-with-output-file port-filename
|
||||
|
|
@ -87,32 +87,23 @@
|
|||
(define (restart-mred)
|
||||
(shutdown-mred)
|
||||
(case (system-type)
|
||||
[(macos) (system*
|
||||
(mred-program-launcher-path
|
||||
(if (use-3m)
|
||||
"Framework Test Engine3m"
|
||||
"Framework Test Engine")))]
|
||||
[(macosx)
|
||||
(thread
|
||||
(lambda ()
|
||||
(system*
|
||||
(build-path (collection-path "mzlib")
|
||||
'up
|
||||
'up
|
||||
"bin"
|
||||
(if (use-3m)
|
||||
"mred3m"
|
||||
"mred"))
|
||||
(path->string
|
||||
(build-path (collection-path "mzlib")
|
||||
'up
|
||||
'up
|
||||
"bin"
|
||||
(if (use-3m)
|
||||
"mred3m"
|
||||
"mred")))
|
||||
"-mvqt"
|
||||
(build-path (collection-path "tests" "framework")
|
||||
"framework-test-engine.ss"))))]
|
||||
[else (thread
|
||||
(lambda ()
|
||||
(system*
|
||||
(mred-program-launcher-path
|
||||
(if (use-3m)
|
||||
"Framework Test Engine3m"
|
||||
"Framework Test Engine")))))])
|
||||
(path->string
|
||||
(build-path (collection-path "tests" "framework")
|
||||
"framework-test-engine.ss")))))]
|
||||
[else (error 'test-suite-utils.ss "don't know how to start mred")])
|
||||
(debug-printf mz-tcp "accepting listener~n")
|
||||
(let-values ([(in out) (tcp-accept listener)])
|
||||
(set! in-port in)
|
||||
|
|
@ -141,9 +132,9 @@
|
|||
(lambda ()
|
||||
(when (and in-port
|
||||
out-port)
|
||||
(with-handlers ([not-break-exn? (lambda (x) (void))])
|
||||
(with-handlers ([exn:fail? (lambda (x) (void))])
|
||||
(close-output-port out-port))
|
||||
(with-handlers ([not-break-exn? (lambda (x) (void))])
|
||||
(with-handlers ([exn:fail? (lambda (x) (void))])
|
||||
(close-input-port in-port))
|
||||
(set! in-port #f)
|
||||
(set! in-port #f))))
|
||||
|
|
@ -196,7 +187,7 @@
|
|||
(restart-mred))
|
||||
(debug-printf messages " ~a // ~a: sending to mred:~n" section-name test-name)
|
||||
(show-text sexp)
|
||||
(with-handlers ([not-break-exn?
|
||||
(with-handlers ([exn:fail?
|
||||
(lambda (x)
|
||||
(cond
|
||||
;; this means that mred was closed
|
||||
|
|
@ -209,7 +200,7 @@
|
|||
(write sexp out-port)
|
||||
(newline out-port))
|
||||
(let ([answer
|
||||
(with-handlers ([not-break-exn?
|
||||
(with-handlers ([exn:fail?
|
||||
(lambda (x)
|
||||
(if (tcp-error? x);; assume tcp-error means app closed
|
||||
eof
|
||||
|
|
@ -256,7 +247,7 @@
|
|||
(when (or (not only-these-tests)
|
||||
(memq test-name only-these-tests))
|
||||
(let* ([result
|
||||
(with-handlers ([not-break-exn?
|
||||
(with-handlers ([exn:fail?
|
||||
(lambda (x)
|
||||
(if (exn? x)
|
||||
(exn-message x)
|
||||
|
|
@ -265,7 +256,7 @@
|
|||
(sexp/proc)
|
||||
(begin0 (send-sexp-to-mred sexp/proc)
|
||||
(send-sexp-to-mred ''check-for-errors))))]
|
||||
[failed (with-handlers ([not-break-exn?
|
||||
[failed (with-handlers ([exn:fail?
|
||||
(lambda (x)
|
||||
(string-append
|
||||
"passed? test raised exn: "
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user