...
original commit: a2affedce7595ecfae47105cfb20fb9fcabaded9
This commit is contained in:
Robby Findler
parent
30396db566
commit
bfa157d033
|
|
@ -1,4 +1,4 @@
|
|||
(unit/sig mred:canvas^
|
||||
(unit/sig framework:canvas^
|
||||
(import mred^
|
||||
[preferences : framework:preferences^])
|
||||
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
|
||||
;;; Authors: Matthew Flatt, Robby Findler, Paul Steckler
|
||||
|
||||
(unit/sig mred:finder^
|
||||
(unit/sig framework:finder^
|
||||
(import mred^
|
||||
[preferences : framework:preferences^]
|
||||
[gui-utils : framework:gui-utils^]
|
||||
|
|
@ -158,18 +158,10 @@
|
|||
(if (< which (length dirs))
|
||||
(set-directory (list-ref dirs which)))))]
|
||||
|
||||
[do-name
|
||||
(lambda (text event)
|
||||
(if (eq? (send event get-event-type)
|
||||
wx:const-event-type-text-enter-command)
|
||||
(do-ok)))]
|
||||
|
||||
[do-name-list
|
||||
(lambda (_ event)
|
||||
(if (and (eq? (send event get-event-type)
|
||||
wx:const-event-type-listbox-command)
|
||||
(send event is-selection?))
|
||||
(set-edit)))]
|
||||
(lambda (list-box _)
|
||||
(when (send list-box get-string-selections)
|
||||
(set-edit)))]
|
||||
|
||||
[do-result-list
|
||||
(lambda args #f)]
|
||||
|
|
@ -251,25 +243,25 @@
|
|||
(if (or (not save-mode?)
|
||||
(not (file-exists? file))
|
||||
replace-ok?
|
||||
(= (wx:message-box
|
||||
(string-append
|
||||
"The file "
|
||||
file
|
||||
" already exists. "
|
||||
"Replace it?")
|
||||
"Warning"
|
||||
wx:const-yes-no)
|
||||
wx:const-yes))
|
||||
(eq? (message-box "Warning"
|
||||
(string-append
|
||||
"The file "
|
||||
file
|
||||
" already exists. "
|
||||
"Replace it?")
|
||||
#f
|
||||
'yes-no)
|
||||
'yes))
|
||||
(let ([normal-path
|
||||
(with-handlers
|
||||
([(lambda (_) #t)
|
||||
(lambda (_)
|
||||
(wx:message-box
|
||||
(message-box
|
||||
"Warning"
|
||||
(string-append
|
||||
"The file "
|
||||
file
|
||||
" contains nonexistent directory or cycle.")
|
||||
"Warning")
|
||||
" contains nonexistent directory or cycle."))
|
||||
#f)])
|
||||
(mzlib:file:normalize-path file))])
|
||||
(when normal-path
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
(unit/sig mred:group^
|
||||
(unit/sig framework:group^
|
||||
(import mred^
|
||||
[exit : framework:exit^]
|
||||
[mzlib:function : mzlib:function^]
|
||||
|
|
|
|||
|
|
@ -32,7 +32,7 @@
|
|||
(semaphore-post semaphore)))))
|
||||
|
||||
(define local-busy-cursor
|
||||
(let ([watch (make-object wx:cursor% wx:const-cursor-watch)])
|
||||
(let ([watch (make-object cursor% 'watch)])
|
||||
(opt-lambda (win thunk [delay (cursor-delay)])
|
||||
(let* ([old-cursor #f]
|
||||
[cursor-off void])
|
||||
|
|
@ -44,11 +44,11 @@
|
|||
(lambda ()
|
||||
(if win
|
||||
(set! old-cursor (send win set-cursor watch))
|
||||
(wx:begin-busy-cursor)))
|
||||
(begin-busy-cursor)))
|
||||
(lambda ()
|
||||
(if win
|
||||
(send win set-cursor old-cursor)
|
||||
(wx:end-busy-cursor))))))
|
||||
(end-busy-cursor))))))
|
||||
(lambda () (thunk))
|
||||
(lambda () (cursor-off)))))))
|
||||
|
||||
|
|
@ -57,7 +57,7 @@
|
|||
(let* ([result (void)]
|
||||
[dialog%
|
||||
(class dialog-box% ()
|
||||
(inherit show new-line fit tab center set-size)
|
||||
(inherit show center)
|
||||
(private
|
||||
[on-dont-save
|
||||
(lambda args
|
||||
|
|
@ -97,45 +97,21 @@
|
|||
(if (not can-save-now?)
|
||||
(begin (send cancel set-focus)
|
||||
(send now show #f))
|
||||
(send now set-focus)))
|
||||
(send msg center wx:const-horizontal))
|
||||
(send now set-focus))))
|
||||
|
||||
(set-size -1 -1 10 10)
|
||||
(center wx:const-both)
|
||||
(center 'both)
|
||||
|
||||
(show #t)))])
|
||||
(make-object dialog%)
|
||||
result)))
|
||||
|
||||
(define read-snips/chars-from-buffer
|
||||
(opt-lambda (edit [start 0] [end (send edit last-position)])
|
||||
(let ([pos start]
|
||||
[box (box 0)])
|
||||
(lambda ()
|
||||
(let* ([snip (send edit find-snip pos
|
||||
wx:const-snip-after-or-null box)]
|
||||
[ans
|
||||
(cond
|
||||
[(<= end pos) eof]
|
||||
[(null? snip) eof]
|
||||
[(is-a? snip wx:text-snip%)
|
||||
(let ([t (send snip get-text (- pos (unbox box)) 1)])
|
||||
(unless (= (string-length t) 1)
|
||||
(error 'read-snips/chars-from-buffer
|
||||
"unexpected string, t: ~s; pos: ~a box: ~a"
|
||||
t pos box))
|
||||
(string-ref t 0))]
|
||||
[else snip])])
|
||||
(set! pos (add1 pos))
|
||||
ans)))))
|
||||
|
||||
(define get-choice
|
||||
(opt-lambda (message true-choice false-choice
|
||||
[title "Warning"][x -1][y -1])
|
||||
(let* ([result (void)]
|
||||
[dialog%
|
||||
(class wx:dialog-box% ()
|
||||
(inherit show new-line fit tab center)
|
||||
(class dialog-box% ()
|
||||
(inherit show center)
|
||||
(private
|
||||
[on-true
|
||||
(lambda args
|
||||
|
|
@ -158,28 +134,39 @@
|
|||
[msgs (map
|
||||
(lambda (message)
|
||||
(begin0
|
||||
(make-object wx:message% this message)
|
||||
(new-line)))
|
||||
(make-object message% this message)))
|
||||
messages)])
|
||||
|
||||
(send (make-object wx:button% this
|
||||
on-true true-choice)
|
||||
set-focus)
|
||||
(tab 50)
|
||||
(make-object wx:button% this on-false false-choice)
|
||||
(fit)
|
||||
(send (make-object button% true-choice this on-true) focus)
|
||||
(make-object button% false-choice this on-false)
|
||||
|
||||
(if (and (< x 0) (< y 0))
|
||||
(map (lambda (msg)
|
||||
(send msg center wx:const-horizontal))
|
||||
msgs)))
|
||||
(center 'both)
|
||||
|
||||
(center wx:const-both)
|
||||
|
||||
(show #t)))])
|
||||
(show #t))))])
|
||||
(make-object dialog%)
|
||||
result)))
|
||||
|
||||
(define read-snips/chars-from-buffer
|
||||
(opt-lambda (edit [start 0] [end (send edit last-position)])
|
||||
(let ([pos start]
|
||||
[box (box 0)])
|
||||
(lambda ()
|
||||
(let* ([snip (send edit find-snip pos 'after-or-none box)]
|
||||
[ans
|
||||
(cond
|
||||
[(<= end pos) eof]
|
||||
[(not snip) eof]
|
||||
[(is-a? snip text-snip%)
|
||||
(let ([t (send snip get-text (- pos (unbox box)) 1)])
|
||||
(unless (= (string-length t) 1)
|
||||
(error 'read-snips/chars-from-buffer
|
||||
"unexpected string, t: ~s; pos: ~a box: ~a"
|
||||
t pos box))
|
||||
(string-ref t 0))]
|
||||
[else snip])])
|
||||
(set! pos (add1 pos))
|
||||
ans)))))
|
||||
|
||||
(define open-input-buffer
|
||||
(lambda (buffer)
|
||||
(let ([pos 0])
|
||||
|
|
@ -194,12 +181,4 @@
|
|||
(lambda ()
|
||||
#t)
|
||||
(lambda ()
|
||||
(void))))))
|
||||
|
||||
; For use with wx:set-print-paper-name
|
||||
(define print-paper-names
|
||||
(list
|
||||
"A4 210 x 297 mm"
|
||||
"A3 297 x 420 mm"
|
||||
"Letter 8 1/2 x 11 in"
|
||||
"Legal 8 1/2 x 14 in")))
|
||||
(void)))))))
|
||||
|
|
|
|||
|
|
@ -4,18 +4,14 @@
|
|||
|
||||
;; preferences
|
||||
|
||||
(mred:preferences:set-preference-default 'mred:verify-change-format #f boolean?)
|
||||
(preferences:set-default 'framework:verify-change-format #f boolean?)
|
||||
|
||||
(mred:preferences:set-preference-default 'mred:auto-set-wrap? #f boolean?)
|
||||
(preferences:set-default 'framework:auto-set-wrap? #f boolean?)
|
||||
|
||||
(preferences:set-default 'framework:display-line-numbers #t boolean?)
|
||||
|
||||
(preferences:set-preference-default 'mred:show-status-line
|
||||
#t
|
||||
boolean?)
|
||||
(preferences:set-preference-default 'mred:line-offsets
|
||||
#t
|
||||
boolean?)
|
||||
(preferences:set-default 'framework:show-status-line #t boolean?)
|
||||
(preferences:set-default 'framework:line-offsets t boolean?)
|
||||
|
||||
|
||||
|
||||
|
|
@ -44,7 +40,7 @@
|
|||
share share-from
|
||||
sequence))
|
||||
(for-each (lambda (x) (hash-table-put! hash-table x 'lambda))
|
||||
'(lambda let let* letrec letrec* recur
|
||||
'(lambda let let* letrec recur
|
||||
let/cc let/ec letcc catch
|
||||
let-syntax letrec-syntax syntax-case
|
||||
let-signature fluid-let
|
||||
|
|
@ -61,13 +57,13 @@
|
|||
call-with-input-file with-input-from-file
|
||||
with-input-from-port call-with-output-file
|
||||
with-output-to-file with-output-to-port))
|
||||
(mred:preferences:set-preference-un/marshall
|
||||
'mred:tabify
|
||||
(preferences:set-un/marshall
|
||||
'framework:tabify
|
||||
(lambda (t) (hash-table-map t list))
|
||||
(lambda (l) (let ([h (make-hash-table)])
|
||||
(for-each (lambda (x) (apply hash-table-put! h x)) l)
|
||||
h)))
|
||||
(mred:preferences:set-preference-default 'mred:tabify hash-table hash-table?))
|
||||
(preferences:set-default 'framework:tabify hash-table hash-table?))
|
||||
|
||||
|
||||
(preferences:set-default 'framework:autosave-delay 300 number?)
|
||||
|
|
@ -78,7 +74,7 @@
|
|||
boolean?)
|
||||
(preferences:set 'framework:show-periods-in-dirlist #f boolean?)
|
||||
(preferences:set 'framework:file-dialogs
|
||||
(if (eq? wx:platform 'unix)
|
||||
(if (eq? (system-type) 'unix)
|
||||
'common
|
||||
'std)
|
||||
(lambda (x)
|
||||
|
|
@ -91,22 +87,22 @@
|
|||
(let*-values
|
||||
([(get-keywords)
|
||||
(lambda (hash-table)
|
||||
(letrec* ([all-keywords (hash-table-map hash-table list)]
|
||||
[pick-out (lambda (wanted in out)
|
||||
(cond
|
||||
[(null? in) (mzlib:function:quicksort out string<=?)]
|
||||
[else (if (eq? wanted (cadr (car in)))
|
||||
(pick-out wanted (cdr in) (cons (symbol->string (car (car in))) out))
|
||||
(pick-out wanted (cdr in) out))]))])
|
||||
(letrec ([all-keywords (hash-table-map hash-table list)]
|
||||
[pick-out (lambda (wanted in out)
|
||||
(cond
|
||||
[(null? in) (mzlib:function:quicksort out string<=?)]
|
||||
[else (if (eq? wanted (cadr (car in)))
|
||||
(pick-out wanted (cdr in) (cons (symbol->string (car (car in))) out))
|
||||
(pick-out wanted (cdr in) out))]))])
|
||||
(values (pick-out 'begin all-keywords null)
|
||||
(pick-out 'define all-keywords null)
|
||||
(pick-out 'lambda all-keywords null))))]
|
||||
[(begin-keywords define-keywords lambda-keywords)
|
||||
(get-keywords (mred:preferences:get-preference 'mred:tabify))])
|
||||
(get-keywords (preferences:get 'framework:tabify))])
|
||||
(let* ([add-callback
|
||||
(lambda (keyword-type keyword-symbol list-box)
|
||||
(lambda (button command)
|
||||
(let ([new-one (mred:gui-utils:get-text-from-user
|
||||
(let ([new-one (get-text-from-user
|
||||
(string-append "Enter new " keyword-type "-like keyword:")
|
||||
(string-append keyword-type " Keyword"))])
|
||||
(when new-one
|
||||
|
|
@ -114,33 +110,33 @@
|
|||
(read (open-input-string new-one)))])
|
||||
(cond
|
||||
[(and (symbol? parsed)
|
||||
(hash-table-get (mred:preferences:get-preference 'mred:tabify)
|
||||
(hash-table-get (preferences:get 'framework:tabify)
|
||||
parsed
|
||||
(lambda () #f)))
|
||||
(wx:message-box (format "\"~a\" is already a specially indented keyword" parsed)
|
||||
"Error")]
|
||||
(message-box "Error"
|
||||
(format "\"~a\" is already a specially indented keyword" parsed))]
|
||||
[(symbol? parsed)
|
||||
(hash-table-put! (mred:preferences:get-preference 'mred:tabify)
|
||||
(hash-table-put! (preferences:get 'framework:tabify)
|
||||
parsed keyword-symbol)
|
||||
(send list-box append (symbol->string parsed))]
|
||||
[else (wx:message-box (format "expected a symbol, found: ~a" new-one) "Error")]))))))]
|
||||
[else (message-box "Error" (format "expected a symbol, found: ~a" new-one))]))))))]
|
||||
[delete-callback
|
||||
(lambda (list-box)
|
||||
(lambda (button command)
|
||||
(let* ([selections (send list-box get-selections)]
|
||||
[symbols (map (lambda (x) (string->symbol (send list-box get-string x))) selections)])
|
||||
(for-each (lambda (x) (send list-box delete x)) (reverse selections))
|
||||
(let ([ht (mred:preferences:get-preference 'mred:tabify)])
|
||||
(let ([ht (preferences:get 'framework:tabify)])
|
||||
(for-each (lambda (x) (hash-table-remove! ht x)) symbols)))))]
|
||||
[main-panel (make-object mred:horizontal-panel% p)]
|
||||
[main-panel (make-object horizontal-panel% p)]
|
||||
[make-column
|
||||
(lambda (string symbol keywords)
|
||||
(let* ([vert (make-object mred:vertical-panel% main-panel)]
|
||||
[_ (make-object mred:message% vert (string-append string "-like Keywords"))]
|
||||
[box (make-object mred:list-box% vert null "" wx:const-multiple -1 -1 -1 -1 keywords)]
|
||||
[button-panel (make-object mred:horizontal-panel% vert)]
|
||||
[add-button (make-object mred:button% button-panel (add-callback string symbol box) "Add")]
|
||||
[delete-button (make-object mred:button% button-panel (delete-callback box) "Remove")])
|
||||
(let* ([vert (make-object vertical-panel% main-panel)]
|
||||
[_ (make-object message% (string-append string "-like Keywords") vert)]
|
||||
[box (make-object list-box% #f keywords vert #f 'multiple void)]
|
||||
[button-panel (make-object horizontal-panel% vert)]
|
||||
[add-button (make-object button% "Add" (add-callback string symbol box) button-panel)]
|
||||
[delete-button (make-object button% "Remove" (delete-callback box) button-panel)])
|
||||
(send* button-panel
|
||||
(major-align-center)
|
||||
(stretchable-in-y #f))
|
||||
|
|
@ -159,7 +155,7 @@
|
|||
(reset define-list-box define-keywords)
|
||||
(reset lambda-list-box lambda-keywords)
|
||||
#t))])
|
||||
(mred:preferences:add-preference-callback 'mred:tabify (lambda (p v) (update-list-boxes v)))
|
||||
(preferences:add-callback 'framework:tabify (lambda (p v) (update-list-boxes v)))
|
||||
main-panel))))
|
||||
|
||||
(preferences:read)
|
||||
|
|
@ -208,10 +204,11 @@
|
|||
(lambda ()
|
||||
(with-handlers ([(lambda (x) #t)
|
||||
(lambda (exn)
|
||||
(mred:gui-utils:message-box
|
||||
(message-box
|
||||
"Saving Prefs"
|
||||
(format "Error saving preferences: ~a"
|
||||
(exn-message exn))
|
||||
"Saving Prefs"))])
|
||||
(exn-message exn))))])
|
||||
(save-user-preferences))))
|
||||
|
||||
(wx:application-file-handler edit-file))
|
||||
;(wx:application-file-handler edit-file)
|
||||
)
|
||||
|
|
|
|||
|
|
@ -138,13 +138,13 @@
|
|||
(lambda ()
|
||||
(hash-table-for-each
|
||||
defaults
|
||||
(lambda (p v) (set-preference p v)))))
|
||||
(lambda (p v) (set p v)))))
|
||||
|
||||
(define set-default
|
||||
(lambda (p value checker)
|
||||
(let ([t (checker value)])
|
||||
(unless t
|
||||
(error 'set-preference-default "~s: checker (~s) returns ~s for ~s, expected #t~n" p checker t value)))
|
||||
(error 'set-default "~s: checker (~s) returns ~s for ~s, expected #t~n" p checker t value)))
|
||||
(hash-table-get preferences p
|
||||
(lambda ()
|
||||
(hash-table-put! preferences p (make-pref value))))
|
||||
|
|
@ -195,17 +195,17 @@
|
|||
[unmarshall-struct (hash-table-get marshall-unmarshall p (lambda () #f))])
|
||||
(cond
|
||||
[(and (pref? ht-pref) unmarshall-struct)
|
||||
(set-preference p ((un/marshall-unmarshall unmarshall-struct) marshalled))]
|
||||
(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-preference p marshalled)]
|
||||
(set p marshalled)]
|
||||
|
||||
[(marshalled? ht-pref) (set-marshalled-data! ht-pref marshalled)]
|
||||
[(and (not ht-pref) unmarshall-struct)
|
||||
(set-preference p ((un/marshall-unmarshall unmarshall-struct) marshalled))]
|
||||
(set 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)]))))])
|
||||
|
|
@ -215,7 +215,7 @@
|
|||
(let ([err
|
||||
(lambda (input msg)
|
||||
(message-box "Preferences"
|
||||
(let* ([max-len 150]
|
||||
(let* ([max-len 150]
|
||||
[s1 (format "~s" input)]
|
||||
[ell "..."]
|
||||
[s2 (if (<= (string-length s1) max-len)
|
||||
|
|
@ -284,13 +284,13 @@
|
|||
(lambda (family)
|
||||
(let ([name (build-font-preference-symbol family)]
|
||||
[font-entry (build-font-entry family)])
|
||||
(set-preference-default name
|
||||
default
|
||||
(cond
|
||||
[(string? default) string?]
|
||||
[(number? default) number?]
|
||||
[else (error 'internal-error.set-default "unrecognized default: ~a~n" default)]))
|
||||
(add-preference-callback
|
||||
(set-default name
|
||||
default
|
||||
(cond
|
||||
[(string? default) string?]
|
||||
[(number? default) number?]
|
||||
[else (error 'internal-error.set-default "unrecognized default: ~a~n" default)]))
|
||||
(add-callback
|
||||
name
|
||||
(lambda (p new-value)
|
||||
(write-resource
|
||||
|
|
@ -335,14 +335,14 @@
|
|||
(lambda (pref title bool->pref pref->bool)
|
||||
(let* ([callback
|
||||
(lambda (_ command)
|
||||
(set-preference pref (bool->pref (send command checked?))))]
|
||||
[pref-value (get-preference pref)]
|
||||
(set pref (bool->pref (send command checked?))))]
|
||||
[pref-value (get pref)]
|
||||
[initial-value (pref->bool pref-value)]
|
||||
[c (make-object check-box% main callback title)])
|
||||
(send c set-value initial-value)
|
||||
(add-preference-callback pref
|
||||
(lambda (p v)
|
||||
(send c set-value (pref->bool v))))))]
|
||||
(add-callback pref
|
||||
(lambda (p v)
|
||||
(send c set-value (pref->bool v))))))]
|
||||
[id (lambda (x) x)])
|
||||
(send main minor-align-left)
|
||||
(make-check 'framework:highlight-parens "Highlight between matching parens" id id)
|
||||
|
|
@ -374,113 +374,109 @@
|
|||
(make-ppanel
|
||||
"Default Fonts"
|
||||
(lambda (parent)
|
||||
(letrec* ([font-size-pref-sym (build-font-preference-symbol font-size-entry)]
|
||||
[ex-string "The quick brown fox jumped over the lazy dogs."]
|
||||
[main (make-object vertical-panel% parent)]
|
||||
[fonts (cons font-default-string (wx:get-font-list))]
|
||||
[make-family-panel
|
||||
(lambda (name)
|
||||
(let* ([pref-sym (build-font-preference-symbol name)]
|
||||
[family-const-pair (assoc name font-families-name/const)]
|
||||
|
||||
[edit (make-object edit%)]
|
||||
[_ (send edit insert ex-string)]
|
||||
[set-edit-font
|
||||
(lambda (size)
|
||||
(let ([delta (make-object style-delta% 'change-size size)]
|
||||
[face (get-preference pref-sym)])
|
||||
(if (and (string=? face font-default-string)
|
||||
family-const-pair)
|
||||
(send delta set-family (cadr family-const-pair))
|
||||
(send delta set-delta-face (get-preference pref-sym)))
|
||||
|
||||
(send edit change-style delta 0 (send edit last-position))))]
|
||||
|
||||
[horiz (make-object horizontal-panel% main '(border))]
|
||||
[label (make-object message% horiz name)]
|
||||
|
||||
[message (make-object message% horiz
|
||||
(let ([b (box "")])
|
||||
(if (and (get-resource
|
||||
font-section
|
||||
(build-font-entry name)
|
||||
b)
|
||||
(not (string=? (unbox b)
|
||||
"")))
|
||||
(unbox b)
|
||||
font-default-string)))]
|
||||
[button
|
||||
(make-object
|
||||
button% horiz
|
||||
(lambda (button evt)
|
||||
(let ([new-value
|
||||
(mred:gui-utils:get-single-choice
|
||||
(format "Please choose a new ~a font"
|
||||
name)
|
||||
"Fonts"
|
||||
fonts
|
||||
null -1 -1 #t 300 400)])
|
||||
(when new-value
|
||||
(set-preference pref-sym
|
||||
new-value)
|
||||
(set-edit-font (get-preference font-size-pref-sym)))))
|
||||
"Change")]
|
||||
;; WARNING!!! CHECK INIT ARGS wx:
|
||||
[canvas (make-object editor-canvas% horiz ""
|
||||
(list 'hide-hscroll
|
||||
'hide-vscroll))])
|
||||
(set-edit-font (get-preference font-size-pref-sym))
|
||||
(send canvas set-media edit)
|
||||
(add-preference-callback
|
||||
pref-sym
|
||||
(lambda (p new-value)
|
||||
(send horiz change-children
|
||||
(lambda (l)
|
||||
(let ([new-message (make-object
|
||||
message%
|
||||
(letrec ([font-size-pref-sym (build-font-preference-symbol font-size-entry)]
|
||||
[ex-string "The quick brown fox jumped over the lazy dogs."]
|
||||
[main (make-object vertical-panel% parent)]
|
||||
[fonts (cons font-default-string (get-face-list))]
|
||||
[make-family-panel
|
||||
(lambda (name)
|
||||
(let* ([pref-sym (build-font-preference-symbol name)]
|
||||
[family-const-pair (assoc name font-families-name/const)]
|
||||
|
||||
[edit (make-object edit%)]
|
||||
[_ (send edit insert ex-string)]
|
||||
[set-edit-font
|
||||
(lambda (size)
|
||||
(let ([delta (make-object style-delta% 'change-size size)]
|
||||
[face (get pref-sym)])
|
||||
(if (and (string=? face font-default-string)
|
||||
family-const-pair)
|
||||
(send delta set-family (cadr family-const-pair))
|
||||
(send delta set-delta-face (get pref-sym)))
|
||||
|
||||
(send edit change-style delta 0 (send edit last-position))))]
|
||||
|
||||
[horiz (make-object horizontal-panel% main '(border))]
|
||||
[label (make-object message% horiz name)]
|
||||
|
||||
[message (make-object message% horiz
|
||||
(let ([b (box "")])
|
||||
(if (and (get-resource
|
||||
font-section
|
||||
(build-font-entry name)
|
||||
b)
|
||||
(not (string=? (unbox b)
|
||||
"")))
|
||||
(unbox b)
|
||||
font-default-string)))]
|
||||
[button
|
||||
(make-object
|
||||
button% horiz
|
||||
(lambda (button evt)
|
||||
(let ([new-value
|
||||
(get-choice-from-user
|
||||
"Fonts"
|
||||
(format "Please choose a new ~a font"
|
||||
name)
|
||||
fonts)])
|
||||
(when new-value
|
||||
(set pref-sym new-value)
|
||||
(set-edit-font (get font-size-pref-sym)))))
|
||||
"Change")]
|
||||
[canvas (make-object editor-canvas% horiz
|
||||
edit
|
||||
(list 'hide-hscroll
|
||||
'hide-vscroll))])
|
||||
(set-edit-font (get font-size-pref-sym))
|
||||
(add-callback
|
||||
pref-sym
|
||||
(lambda (p new-value)
|
||||
(send horiz change-children
|
||||
(lambda (l)
|
||||
(let ([new-message (make-object
|
||||
message%
|
||||
horiz
|
||||
new-value)])
|
||||
(set! message new-message)
|
||||
(update-message-sizes font-message-get-widths
|
||||
font-message-user-min-sizes)
|
||||
(list label
|
||||
new-message
|
||||
button
|
||||
canvas))))))
|
||||
(vector set-edit-font
|
||||
(lambda () (send message get-width))
|
||||
(lambda (width) (send message user-min-width width))
|
||||
(lambda () (send label get-width))
|
||||
(lambda (width) (send label user-min-width width)))))]
|
||||
[set-edit-fonts/messages (map make-family-panel font-families)]
|
||||
[collect (lambda (n) (map (lambda (x) (vector-ref x n)) set-edit-fonts/messages))]
|
||||
[set-edit-fonts (collect 0)]
|
||||
[font-message-get-widths (collect 1)]
|
||||
[font-message-user-min-sizes (collect 2)]
|
||||
[category-message-get-widths (collect 3)]
|
||||
[category-message-user-min-sizes (collect 4)]
|
||||
[update-message-sizes
|
||||
(lambda (gets sets)
|
||||
(let ([width (mzlib:function:foldl (lambda (x l) (max l (x))) 0 gets)])
|
||||
(for-each (lambda (set) (set width)) sets)))]
|
||||
[size-panel (make-object horizontal-panel% main '(border))]
|
||||
[size-slider
|
||||
(make-object slider% size-panel
|
||||
(lambda (slider evt)
|
||||
(set-preference font-size-pref-sym
|
||||
(send slider get-value)))
|
||||
"Size"
|
||||
(let ([b (box 0)])
|
||||
(if (get-resource font-section
|
||||
font-size-entry
|
||||
b)
|
||||
(unbox b)
|
||||
font-default-size))
|
||||
1 127 50)]
|
||||
[guard-change-font (later-on)])
|
||||
(set! message new-message)
|
||||
(update-message-sizes font-message-get-widths
|
||||
font-message-user-min-sizes)
|
||||
(list label
|
||||
new-message
|
||||
button
|
||||
canvas))))))
|
||||
(vector set-edit-font
|
||||
(lambda () (send message get-width))
|
||||
(lambda (width) (send message user-min-width width))
|
||||
(lambda () (send label get-width))
|
||||
(lambda (width) (send label user-min-width width)))))]
|
||||
[set-edit-fonts/messages (map make-family-panel font-families)]
|
||||
[collect (lambda (n) (map (lambda (x) (vector-ref x n)) set-edit-fonts/messages))]
|
||||
[set-edit-fonts (collect 0)]
|
||||
[font-message-get-widths (collect 1)]
|
||||
[font-message-user-min-sizes (collect 2)]
|
||||
[category-message-get-widths (collect 3)]
|
||||
[category-message-user-min-sizes (collect 4)]
|
||||
[update-message-sizes
|
||||
(lambda (gets sets)
|
||||
(let ([width (mzlib:function:foldl (lambda (x l) (max l (x))) 0 gets)])
|
||||
(for-each (lambda (set) (set width)) sets)))]
|
||||
[size-panel (make-object horizontal-panel% main '(border))]
|
||||
[size-slider
|
||||
(make-object slider% size-panel
|
||||
(lambda (slider evt)
|
||||
(set font-size-pref-sym (send slider get-value)))
|
||||
"Size"
|
||||
(let ([b (box 0)])
|
||||
(if (get-resource font-section
|
||||
font-size-entry
|
||||
b)
|
||||
(unbox b)
|
||||
font-default-size))
|
||||
1 127 50)]
|
||||
[guard-change-font (later-on)])
|
||||
(update-message-sizes font-message-get-widths font-message-user-min-sizes)
|
||||
(update-message-sizes category-message-get-widths category-message-user-min-sizes)
|
||||
(add-preference-callback
|
||||
(add-callback
|
||||
font-size-pref-sym
|
||||
(lambda (p value)
|
||||
(guard-change-font
|
||||
|
|
@ -533,7 +529,7 @@
|
|||
(lambda ()
|
||||
(run-once
|
||||
(lambda ()
|
||||
(save-user-preferences)
|
||||
(save)
|
||||
(if preferences-dialog
|
||||
(send preferences-dialog show #t)
|
||||
(set! preferences-dialog
|
||||
|
|
@ -588,12 +584,12 @@
|
|||
single-panel
|
||||
bottom-panel)))))]
|
||||
[ok-callback (lambda args
|
||||
(save-user-preferences)
|
||||
(hide-preferences-dialog))]
|
||||
(save)
|
||||
(hide-dialog))]
|
||||
[ok-button (make-object button% bottom-panel ok-callback "OK")]
|
||||
[cancel-callback (lambda args
|
||||
(hide-preferences-dialog)
|
||||
(read-user-preferences))]
|
||||
(hide-dialog)
|
||||
(read))]
|
||||
[cancel-button (make-object button% bottom-panel cancel-callback "Cancel")])
|
||||
(send ok-button user-min-width (send cancel-button get-width))
|
||||
(send* bottom-panel
|
||||
|
|
|
|||
|
|
@ -312,22 +312,22 @@
|
|||
[balance-parens
|
||||
(let-struct string/pos (string pos)
|
||||
(lambda (key)
|
||||
(letrec* ([char (integer->char code)]
|
||||
[here (get-start-position)]
|
||||
[limit (get-limit here)]
|
||||
[paren-match? (preferences:get 'framework:paren-match)]
|
||||
[fixup-parens? (preferences:get 'framework:fixup-parens)]
|
||||
[find-match
|
||||
(lambda (pos)
|
||||
(let loop ([parens scheme-paren:scheme-paren-pairs])
|
||||
(cond
|
||||
[(null? parens) #f]
|
||||
[else (let* ([paren (car parens)]
|
||||
[left (car paren)]
|
||||
[right (cdr paren)])
|
||||
(if (string=? left (get-text pos (+ pos (string-length left))))
|
||||
right
|
||||
(loop (cdr parens))))])))])
|
||||
(letrec ([char (integer->char code)]
|
||||
[here (get-start-position)]
|
||||
[limit (get-limit here)]
|
||||
[paren-match? (preferences:get 'framework:paren-match)]
|
||||
[fixup-parens? (preferences:get 'framework:fixup-parens)]
|
||||
[find-match
|
||||
(lambda (pos)
|
||||
(let loop ([parens scheme-paren:scheme-paren-pairs])
|
||||
(cond
|
||||
[(null? parens) #f]
|
||||
[else (let* ([paren (car parens)]
|
||||
[left (car paren)]
|
||||
[right (cdr paren)])
|
||||
(if (string=? left (get-text pos (+ pos (string-length left))))
|
||||
right
|
||||
(loop (cdr parens))))])))])
|
||||
(cond
|
||||
[(in-single-line-comment? here)
|
||||
(insert char)]
|
||||
|
|
|
|||
|
|
@ -256,18 +256,7 @@
|
|||
(define-signature framework:match-cache^
|
||||
(%))
|
||||
|
||||
(define-signature mred:menu^
|
||||
(max-manual-menu-id
|
||||
generate-menu-id
|
||||
make-menu%
|
||||
menu%
|
||||
make-menu-bar%
|
||||
menu-bar%))
|
||||
|
||||
(define-signature mred:project^
|
||||
(project-frame-group%
|
||||
make-project-frame%
|
||||
project-frame%))
|
||||
|
||||
(define-signature framework:scheme-paren^
|
||||
(paren-pairs
|
||||
|
|
@ -294,7 +283,7 @@
|
|||
backward-match
|
||||
skip-whitespace))
|
||||
|
||||
(define-signature mred^
|
||||
(define-signature framework^
|
||||
([unit application : framework:application^]
|
||||
[unit version : framework:version^]
|
||||
[unit exn : framework:exn^]
|
||||
|
|
|
|||
|
|
@ -1,86 +0,0 @@
|
|||
|
||||
(unit/sig mred:panel^
|
||||
(import [wx : wx^]
|
||||
[mred:constants : mred:constants^]
|
||||
[mred:container : mred:container^]
|
||||
[mred:canvas : mred:canvas^]
|
||||
mzlib:function^)
|
||||
|
||||
(mred:debug:printf 'invoke "mred:panel@")
|
||||
|
||||
(define make-edit-panel%
|
||||
(lambda (super%)
|
||||
(class-asi super%
|
||||
(rename [super-change-children change-children])
|
||||
(inherit get-parent change-children children)
|
||||
(public [get-canvas% (lambda () mred:canvas:frame-title-canvas%)])
|
||||
(private
|
||||
[split-edits null])
|
||||
(public
|
||||
[collapse
|
||||
(lambda (canvas)
|
||||
(let ([media (send canvas get-media)])
|
||||
(if (memq media split-edits)
|
||||
(letrec ([helper
|
||||
(lambda (canvas/panel)
|
||||
(if (eq? canvas/panel this)
|
||||
(begin (cond
|
||||
[(and (= (length children) 1)
|
||||
(eq? canvas (car children)))
|
||||
(void)]
|
||||
[(member canvas children)
|
||||
(change-children (lambda (l) (list canvas)))]
|
||||
[else
|
||||
(change-children
|
||||
(lambda (l)
|
||||
(let ([c (make-object (object-class canvas) this)])
|
||||
(send c set-media media)
|
||||
(list c))))])
|
||||
(wx:bell))
|
||||
(let* ([parent (send canvas/panel get-parent)]
|
||||
[parents-children (ivar parent children)]
|
||||
[num-children (length parents-children)])
|
||||
(if (<= num-children 1)
|
||||
(helper parent)
|
||||
(begin (send parent delete-child canvas/panel)
|
||||
(send (car (ivar parent children)) set-focus))))))])
|
||||
(send media remove-canvas canvas)
|
||||
(helper canvas))
|
||||
(wx:bell))))]
|
||||
[split
|
||||
(opt-lambda (canvas [panel% mred:container:horizontal-panel%])
|
||||
(let* ([frame (ivar canvas frame)]
|
||||
[media (send canvas get-media)]
|
||||
[canvas% (object-class canvas)]
|
||||
[parent (send canvas get-parent)]
|
||||
[new-panel #f]
|
||||
[left-split #f]
|
||||
[right-split #f]
|
||||
[before #t])
|
||||
(set! split-edits (cons media split-edits))
|
||||
(dynamic-wind
|
||||
(lambda ()
|
||||
(set! before (send frame delay-updates))
|
||||
(send frame delay-updates #t))
|
||||
(lambda ()
|
||||
(set! new-panel (make-object panel% parent))
|
||||
(set! left-split (make-object canvas% new-panel))
|
||||
(set! right-split (make-object canvas% new-panel))
|
||||
(send parent change-children
|
||||
(lambda (l)
|
||||
(let ([before (remq new-panel l)])
|
||||
(map (lambda (x) (if (eq? x canvas)
|
||||
new-panel
|
||||
x))
|
||||
before)))))
|
||||
(lambda () (send frame delay-updates before)))
|
||||
(send* media (remove-canvas canvas)
|
||||
(add-canvas left-split)
|
||||
(add-canvas right-split))
|
||||
(send* left-split (set-media media) (set-focus))
|
||||
(send* right-split (set-media media))))]))))
|
||||
|
||||
(define horizontal-edit-panel%
|
||||
(make-edit-panel% mred:container:horizontal-panel%))
|
||||
(define vertical-edit-panel%
|
||||
(make-edit-panel% mred:container:vertical-panel%)))
|
||||
Loading…
Reference in New Issue
Block a user