From 594bdab54dd4f348560af6546a94b57dca26eecd Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Fri, 12 Jul 1996 13:57:02 +0000 Subject: [PATCH] updated to container classes original commit: 959f6449ffbad9488272027ac817c2c1b05fb002 --- collects/mred/edit.ss | 2 +- collects/mred/keys.ss | 19 +++++---- collects/mred/prefs.ss | 90 ++++++++++++++++++++++++++---------------- 3 files changed, 68 insertions(+), 43 deletions(-) diff --git a/collects/mred/edit.ss b/collects/mred/edit.ss index 28267110..b3275f0f 100644 --- a/collects/mred/edit.ss +++ b/collects/mred/edit.ss @@ -140,7 +140,7 @@ (lambda () (let ([c (get-canvas)]) (if c - (let ([f (send c get-parent)]) + (let ([f (ivar c frame)]) (if (null? f) #f f)) diff --git a/collects/mred/keys.ss b/collects/mred/keys.ss index 3b9f5aac..68f27123 100644 --- a/collects/mred/keys.ss +++ b/collects/mred/keys.ss @@ -116,12 +116,13 @@ [ring-bell (lambda (edit event) - (send (let loop ([p (send event get-event-object)]) - (let ([parent (send p get-parent)]) - (if (null? parent) - p - (loop parent)))) - clear-mini-panel%) + (let ([c (send edit get-canvas)]) + (when c + (let ([f (let loop ([f c]) + (if (is-a? f wx:frame%) + f + (loop (send f get-parent))))]) + (send f hide-search)))) (wx:bell))] [save-file-as (lambda (edit event) @@ -813,23 +814,27 @@ (map-meta ">" "end-of-file") (map "d:DOWN" "end-of-file") - (map "c:DOWN" "end-of-file") + (map "c:end" "end-of-file") (map "s:c:end" "select-to-end-of-file") (map "s:d:down" "select-to-end-of-file") (map "c:v" "next-page") (map "a:DOWN" "next-page") (map "pagedown" "next-page") + (map "c:DOWN" "next-page") (map "s:c:v" "select-page-down") (map "a:s:DOWN" "select-page-down") (map "s:pagedown" "select-page-down") + (map "s:c:DOWN" "select-page-down") (map-meta "v" "previous-page") (map "a:up" "previous-page") (map "pageup" "previous-page") + (map "c:up" "previous-page") (map-meta "s:v" "select-page-up") (map "s:a:up" "select-page-up") (map "s:pageup" "select-page-up") + (map "s:c:up" "select-page-up") (map "c:h" "delete-previous-character") (map "c:d" "delete-next-character") diff --git a/collects/mred/prefs.ss b/collects/mred/prefs.ss index ac662b80..a185a0d8 100644 --- a/collects/mred/prefs.ss +++ b/collects/mred/prefs.ss @@ -25,46 +25,67 @@ (define-struct un/marshall (marshall unmarshall)) (define-struct marshalled (data)) - - (define get-preference-box + (define-struct pref (value callbacks)) + + (define unmarshall + (lambda (p marshalled) + (let/ec k + (let ([unmarshall (un/marshall-unmarshall (hash-table-get marshall-unmarshall + p + (lambda () (k marshalled))))]) + (unmarshall (marshalled-data marshalled)))))) + + (define add-preference-callback + (lambda (p callback) + (let ([ans (hash-table-get preferences p (lambda () #f))]) + (cond + [(marshalled? ans) (let* ([value (unmarshall p ans)] + [pref (make-pref value (list callback))]) + (hash-table-put! preferences p pref) + (callback p value) + (lambda () + (set-pref-callbacks! pref (mzlib:function:remove callback (pref-callbacks pref) eq?))))] + [(pref? ans) + (set-pref-callbacks! ans (cons callback (pref-callbacks ans))) + (lambda () + (set-pref-callbacks! ans (mzlib:function:remove callback (pref-callbacks ans) eq?)))] + [(not ans) (raise (mred:exn:make-exn:unknown-preference + (format "adding callback to unknown preference: ~a" p) + ((debug-info-handler))))] + [else (error 'prefs.ss "robby error.4: ~a ~a" p ans)])))) + + (define get-preference (lambda (p) (let ([ans (hash-table-get preferences p (lambda () (raise (mred:exn:make-exn:unknown-preference - (format "unknown preference: ~a" p) + (format "attempted to get unknown preference: ~a" p) ((debug-info-handler))))))]) (cond [(marshalled? ans) (let* ([marshalled (marshalled-data ans)] - [unmarshalled - (let/ec k - ((un/marshall-unmarshall - (hash-table-get marshall-unmarshall p - (lambda () (k marshalled)))) - marshalled))] - [boxed (box unmarshalled)]) - (hash-table-put! preferences p boxed) - boxed)] - [(box? ans) ans] + [unmarshalled (unmarshall p marshalled)] + [pref (make-pref unmarshalled null)]) + (hash-table-put! preferences p pref) + unmarshalled)] + [(pref? ans) (pref-value ans)] [else (error 'prefs.ss "robby error.1: ~a" ans)])))) - (define get-preference (mzlib:function:compose unbox get-preference-box)) - (define set-preference (lambda (p value) (let/ec k - (set-box! (hash-table-get preferences p - (lambda () - (let ([box (box value)]) - (hash-table-put! preferences p box) - (k box)))) - value)))) + (let ([pref (hash-table-get preferences p + (lambda () + (let ([pref (make-pref value null)]) + (k (hash-table-put! preferences p pref)))))]) + (set-pref-value! pref value) + (for-each (lambda (x) (x p value)) (pref-callbacks pref)))))) (define set-preference-default (lambda (p value) (hash-table-get preferences p (lambda () - (hash-table-put! preferences p (box value)))) + (hash-table-put! preferences p (make-pref value null)))) (set! defaults (cons (list p value) defaults)))) (define set-preference-un/marshall @@ -75,16 +96,15 @@ (define restore-defaults (lambda () - (for-each (lambda (x) (apply set-preference x)) - defaults))) + (for-each (lambda (x) (apply set-preference x)) defaults))) (define save-user-preferences (let ([marshall-pref (lambda (p ht-value) (cond [(marshalled? ht-value) (list p (marshalled-data ht-value))] - [(box? ht-value) - (let* ([value (unbox ht-value)] + [(pref? ht-value) + (let* ([value (pref-value ht-value)] [marshalled (let/ec k ((un/marshall-marshall @@ -108,18 +128,18 @@ (let ([parse-pref (lambda (p marshalled) (let/ec k - (let* ([ht-pref (hash-table-get preferences p (lambda () 'not-in-table))] + (let* ([ht-pref (hash-table-get preferences p (lambda () #f))] [unmarshall-struct (hash-table-get marshall-unmarshall p (lambda () #f))]) (cond - [(box? ht-pref) - (if unmarshall-struct - (set-box! ht-pref ((un/marshall-unmarshall unmarshall-struct) marshalled)) - (set-box! ht-pref marshalled))] + [(and (pref? ht-pref) unmarshall-struct) + (set-preference p ((un/marshall-unmarshall unmarshall-struct) marshalled))] + [(pref? ht-pref) + (hash-table-put! preferences p (make-marshalled marshalled))] [(marshalled? ht-pref) (set-marshalled-data! ht-pref marshalled)] - [(eq? 'not-in-table ht-pref) - (if unmarshall-struct - (hash-table-put! preferences p (box ((un/marshall-unmarshall unmarshall-struct) marshalled))) - (hash-table-put! preferences p (make-marshalled marshalled)))] + [(and (not ht-pref) unmarshall-struct) + (set-preference p ((un/marshall-unmarshall unmarshall-struct) marshalled))] + [(not ht-pref) + (hash-table-put! preferences p (make-marshalled marshalled))] [else (error 'prefs.ss "robby error.3: ~a" ht-pref)]))))]) (lambda () (mred:debug:printf 'startup "reading user preferences")