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

...

Browse Source 
original commit: 47bf9fbd00634b8f2d0b91e362b14bc398519fc2
This commit is contained in:
Robby Findler 2001-10-27 23:15:46 +00:00
parent 6145691ec6
commit 403afced7c
3 changed files with 123 additions and 40 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1,3 +1,4 @@
(module preferences mzscheme
(require (lib "string-constant.ss" "string-constants")
(lib "unitsig.ss")
@ -23,19 +24,19 @@
(define default-preferences-filename
(build-path (collection-path "defaults") "prefs.ss"))
;; preferences : sym -o> (union marshalled pref)
;; preferences : sym -o> (union marshalled pref)
(define preferences (make-hash-table))
;; marshall-unmarshall : sym -o> un/marshall
;; marshall-unmarshall : sym -o> un/marshall
(define marshall-unmarshall (make-hash-table))
;; callbacks : sym -o> (listof (sym TST -> boolean))
;; callbacks : sym -o> (listof (sym TST -> boolean))
(define callbacks (make-hash-table))
;; saved-defaults : sym -o> (union marshalled pref)
;; saved-defaults : sym -o> (union marshalled pref)
(define saved-defaults (make-hash-table))
;; defaults : sym -o> default
;; defaults : sym -o> default
(define defaults (make-hash-table))
(define-struct un/marshall (marshall unmarshall))
@ -69,25 +70,32 @@
(exn-message exn)
(format "~s" exn)))))))))
(define get-callbacks
(lambda (p)
(hash-table-get callbacks
p
(lambda () null))))
;; get-callbacks : sym -> (listof (-> void))
(define (get-callbacks p)
(hash-table-get callbacks
p
(lambda () null)))
(define add-callback
(lambda (p callback)
(hash-table-put! callbacks p (append (get-callbacks p) (list callback)))
(lambda ()
(hash-table-put!
callbacks
p
(let loop ([callbacks (get-callbacks p)])
(cond
[(null? callbacks) null]
[else (if (eq? (car callbacks) callback)
(loop (cdr callbacks))
(cons (car callbacks) (loop (cdr callbacks))))]))))))
;; add-callback : sym (-> void) -> void
(define (add-callback p callback)
(hash-table-put! callbacks p
(append
(hash-table-get callbacks p (lambda () null))
(list callback)))
(lambda ()
(hash-table-put!
callbacks
p
(let loop ([callbacks (hash-table-get callbacks p (lambda () null))])
(cond
[(null? callbacks) null]
[else
(let ([callback (car callbacks)])
(cond
[(eq? callback callback)
(loop (cdr callbacks))]
[else
(cons (car callbacks) (loop (cdr callbacks)))]))])))))
(define check-callbacks
(lambda (p value)
@ -154,7 +162,7 @@
defaults
(lambda (p v) (set p v)))))
;; set-default : (sym TST (TST -> boolean) -> void
;; set-default : (sym TST (TST -> boolean) -> void
(define (set-default p in-default-value checker)
(let* ([default-value
(let/ec k
@ -258,9 +266,9 @@
(parse-pref (car pre-pref) (cadr pre-pref))
(err input (string-constant expected-list-of-length2))))
(loop (cdr input)))))))))
;; read-from-file-to-ht : string hash-table -> void
;; read-from-file-to-ht : string hash-table -> void
(define (read-from-file-to-ht filename ht)
(let* ([parse-pref
(lambda (p marshalled)
@ -270,9 +278,9 @@
[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.
;; 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)]
@ -286,21 +294,21 @@
(when (file-exists? filename)
(for-each-pref-in-file parse-pref filename))))
;; read : -> void
;; read : -> void
(define (-read)
(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.
;; read in the saved defaults. These should override the
;; values used with set-default.
(read-from-file-to-ht default-preferences-filename saved-defaults)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; ;;;
;;; preferences dialog ;;;
;;; ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; ;;;
;;; preferences dialog ;;;
;;; ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-struct ppanel (title container panel))

80
collects/framework/private/scheme.ss
View File

@ -37,12 +37,86 @@
;; ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (set-box/f! b v) (when (box? b) (set-box! b v)))
(define sexp-snip%
(class snip%
(field [sizing-text "( )"])
(define/override (draw dc x y left top right bottom dx dy draw-caret)
(void))
(define/override (get-extent dc x y w h descent space lspace rspace)
(void))))
(send dc draw-text sizing-text x y)
(let-values ([(lpw lph lpa lpd) (send dc get-text-extent "(")]
[(rpw rph rpa rpd) (send dc get-text-extent ")")]
[(sw sh sa sd) (send dc get-text-extent sizing-text)])
(let* ([dtw (- sw lpw rpw)]
[dot-start (+ x lpw)]
[dt1x (+ dot-start (* dtw 1/5))]
[dt2x (+ dot-start (* dtw 1/2))]
[dt3x (+ dot-start (* dtw 4/5))]
[dty (/ sh 2)])
(send dc draw-rectangle dt1x dty 2 2)
(send dc draw-rectangle dt2x dty 2 2)
(send dc draw-rectangle dt3x dty 2 2))))
(define/override (get-extent dc x y wb hb descentb spaceb lspaceb rspaceb)
(let-values ([(w h d a) (send dc get-text-extent sizing-text)])
(set-box/f! wb w)
(set-box/f! hb h)
(set-box/f! descentb d)
(set-box/f! spaceb a)
(set-box/f! lspaceb 0)
(set-box/f! rspaceb 0)))
(super-instantiate ())
(inherit set-snipclass)
(set-snipclass sexp-snipclass)))
(define sexp-snipclass%
(class snip-class%
(define/override (read in)
(make-object sexp-snip%))
(super-instantiate ())))
(define sexp-snipclass (make-object sexp-snipclass%))
(send sexp-snipclass set-classname "drscheme:sexp-snip")
(send sexp-snipclass set-version 0)
(send (get-the-snip-class-list) add sexp-snipclass)
;; leave this for next version...
'(keymap:add-to-right-button-menu
(let ([old (keymap:add-to-right-button-menu)])
(lambda (menu text event)
(old menu text event)
(when (is-a? text -text<%>)
(let* ([pos
(call-with-values
(lambda ()
(send text dc-location-to-editor-location
(send event get-x)
(send event get-y)))
(lambda (x y)
(send text find-position x y)))]
[char (send text get-character pos)]
[left? (memq char '(#\( #\{ #\[))]
[right? (memq char '(#\) #\} #\]))])
(when (or left? right?)
(let* ([other-pos (if left?
(send text get-forward-sexp pos)
(send text get-backward-sexp (+ pos 1)))])
(when other-pos
(let ([left-pos (min pos other-pos)]
[right-pos (max pos other-pos)])
(instantiate separator-menu-item% ()
(parent menu))
(instantiate menu-item% ()
(parent menu)
(label "Collapse sexp")
(callback (lambda (item evt)
(collapse-from text left-pos right-pos)))))))))))))
(define (collapse-from text left-pos right-pos)
(send text begin-edit-sequence)
(send text delete left-pos right-pos)
(send text insert (make-object sexp-snip%) left-pos left-pos)
(send text end-edit-sequence))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;

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

@ -1,3 +1,4 @@
(module text mzscheme
(require (lib "string-constant.ss" "string-constants")
(lib "unitsig.ss")