...
original commit: 4c7ada17b2135c1f987c9bdf0df37c2aa95ac695
This commit is contained in:
Robby Findler
parent
ada73b4de9
commit
758a31663b
|
|
@ -27,9 +27,8 @@
|
|||
(lambda (m)
|
||||
(super-set-editor m)
|
||||
(let ([tlw (get-top-level-window)])
|
||||
(cond
|
||||
[(eq? this (send tlw get-info-canvas))
|
||||
(send tlw update-info)])))])
|
||||
(when (eq? this (send tlw get-info-canvas))
|
||||
(send tlw update-info))))])
|
||||
(sequence
|
||||
(apply super-init parent editor args)
|
||||
(unless (is-a? (get-top-level-window) frame:info<%>)
|
||||
|
|
|
|||
|
|
@ -171,8 +171,7 @@
|
|||
[on-close
|
||||
(lambda ()
|
||||
(super-on-close)
|
||||
(send (get-editor) on-close))]
|
||||
[get-area-container% (lambda () panel:vertical-editor%)])
|
||||
(send (get-editor) on-close))])
|
||||
(private
|
||||
[label (if file-name
|
||||
(let-values ([(base name dir?) (split-path file-name)])
|
||||
|
|
@ -211,8 +210,8 @@
|
|||
(set! label t)
|
||||
(do-label)))])
|
||||
(public
|
||||
[get-canvas% (lambda () editor-canvas<%>)]
|
||||
[get-canvas<%> (lambda () editor-canvas%)]
|
||||
[get-canvas% (lambda () editor-canvas%)]
|
||||
[get-canvas<%> (lambda () editor-canvas<%>)]
|
||||
[make-canvas (lambda ()
|
||||
(let ([% (get-canvas%)]
|
||||
[<%> (get-canvas<%>)])
|
||||
|
|
@ -273,24 +272,6 @@
|
|||
(send (get-editor) save-file)
|
||||
#t)]
|
||||
[file-menu:save-as (lambda (item control) (save-as) #t)]
|
||||
[file-menu:between-print-and-close
|
||||
(lambda (file-menu)
|
||||
(make-object separator-menu-item% file-menu)
|
||||
(let ([split
|
||||
(lambda (panel%)
|
||||
(lambda (item control)
|
||||
(let ([win (get-edit-target-object)])
|
||||
(when (and win
|
||||
(is-a? win canvas<%>))
|
||||
(send (get-area-container) split win panel%)))))])
|
||||
(make-object (get-menu-item%) "Split Horizontally" file-menu (split horizontal-panel%))
|
||||
(make-object (get-menu-item%) "Split Vertically" file-menu (split vertical-panel%))
|
||||
(make-object (get-menu-item%) "Collapse" file-menu
|
||||
(lambda (item control)
|
||||
(let ([canvas (get-edit-target-window)])
|
||||
(when canvas
|
||||
(send (get-area-container) collapse canvas))))))
|
||||
(make-object separator-menu-item% file-menu))]
|
||||
[file-menu:print (lambda (item control)
|
||||
(send (get-editor) print
|
||||
#t
|
||||
|
|
|
|||
|
|
@ -21,12 +21,7 @@
|
|||
single-window<%>
|
||||
single-window-mixin
|
||||
single%
|
||||
single-pane%
|
||||
|
||||
editor-mixin
|
||||
editor<%>
|
||||
horizontal-editor%
|
||||
vertical-editor%))
|
||||
single-pane%))
|
||||
|
||||
(define-signature framework:exn^
|
||||
((struct exn ())
|
||||
|
|
@ -48,6 +43,8 @@
|
|||
restore-defaults
|
||||
|
||||
add-panel
|
||||
add-font-panel
|
||||
add-general-panel
|
||||
show-dialog
|
||||
hide-dialog))
|
||||
|
||||
|
|
@ -202,10 +199,7 @@
|
|||
open-file))
|
||||
|
||||
(define-signature framework:icon^
|
||||
(get
|
||||
get-mask
|
||||
|
||||
get-paren-highlight-bitmap
|
||||
(get-paren-highlight-bitmap
|
||||
get-autowrap-bitmap
|
||||
|
||||
get-lock-bitmap
|
||||
|
|
@ -247,7 +241,8 @@
|
|||
setup-keymap
|
||||
text-mixin
|
||||
text<%>
|
||||
text%))
|
||||
text%
|
||||
add-preferences-panel))
|
||||
|
||||
(define-signature framework:paren^
|
||||
(balanced?
|
||||
|
|
|
|||
|
|
@ -47,8 +47,8 @@
|
|||
(set! icon (make-object bitmap% p type))
|
||||
icon)))))
|
||||
|
||||
(define get (make-get/mask "plt16x16.bmp" 'bmp))
|
||||
(define get-mask (make-get/mask "dot16x16.xbm" 'xbm))
|
||||
;(define get (make-get/mask "plt16x16.bmp" 'bmp))
|
||||
;(define get-mask (make-get/mask "dot16x16.xbm" 'xbm))
|
||||
|
||||
(define gc-on-bitmap #f)
|
||||
|
||||
|
|
|
|||
|
|
@ -2,8 +2,7 @@
|
|||
(import mred-interfaces^
|
||||
[preferences : framework:preferences^]
|
||||
[exit : framework:exit^]
|
||||
[group : framework:group^]
|
||||
[mzlib:function : mzlib:function^])
|
||||
[group : framework:group^])
|
||||
|
||||
;; preferences
|
||||
|
||||
|
|
@ -83,83 +82,6 @@
|
|||
(or (eq? x 'common)
|
||||
(eq? x 'std))))
|
||||
|
||||
(preferences:add-panel
|
||||
"Indenting"
|
||||
(lambda (p)
|
||||
(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))]))])
|
||||
(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 (preferences:get 'framework:tabify))])
|
||||
(let* ([add-callback
|
||||
(lambda (keyword-type keyword-symbol list-box)
|
||||
(lambda (button command)
|
||||
(let ([new-one (get-text-from-user
|
||||
(string-append "Enter new " keyword-type "-like keyword:")
|
||||
(string-append keyword-type " Keyword"))])
|
||||
(when new-one
|
||||
(let ([parsed (with-handlers ((exn:read? (lambda (x) #f)))
|
||||
(read (open-input-string new-one)))])
|
||||
(cond
|
||||
[(and (symbol? parsed)
|
||||
(hash-table-get (preferences:get 'framework:tabify)
|
||||
parsed
|
||||
(lambda () #f)))
|
||||
(message-box "Error"
|
||||
(format "\"~a\" is already a specially indented keyword" parsed))]
|
||||
[(symbol? parsed)
|
||||
(hash-table-put! (preferences:get 'framework:tabify)
|
||||
parsed keyword-symbol)
|
||||
(send list-box append (symbol->string parsed))]
|
||||
[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 (preferences:get 'framework:tabify)])
|
||||
(for-each (lambda (x) (hash-table-remove! ht x)) symbols)))))]
|
||||
[main-panel (make-object horizontal-panel% p)]
|
||||
[make-column
|
||||
(lambda (string symbol keywords)
|
||||
(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 void '(multiple))]
|
||||
[button-panel (make-object horizontal-panel% vert)]
|
||||
[add-button (make-object button% "Add" button-panel (add-callback string symbol box))]
|
||||
[delete-button (make-object button% "Remove" button-panel (delete-callback box))])
|
||||
(send* button-panel
|
||||
(set-alignment 'center 'center)
|
||||
(stretchable-height #f))
|
||||
(send add-button min-width (send delete-button get-width))
|
||||
box))]
|
||||
[begin-list-box (make-column "Begin" 'begin begin-keywords)]
|
||||
[define-list-box (make-column "Define" 'define define-keywords)]
|
||||
[lambda-list-box (make-column "Lambda" 'lambda lambda-keywords)]
|
||||
[update-list-boxes
|
||||
(lambda (hash-table)
|
||||
(let-values ([(begin-keywords define-keywords lambda-keywords) (get-keywords hash-table)]
|
||||
[(reset) (lambda (list-box keywords)
|
||||
(send list-box clear)
|
||||
(for-each (lambda (x) (send list-box append x)) keywords))])
|
||||
(reset begin-list-box begin-keywords)
|
||||
(reset define-list-box define-keywords)
|
||||
(reset lambda-list-box lambda-keywords)
|
||||
#t))])
|
||||
(preferences:add-callback 'framework:tabify (lambda (p v) (update-list-boxes v)))
|
||||
main-panel))))
|
||||
|
||||
;; groups
|
||||
|
||||
(preferences:set-default 'framework:exit-when-no-frames #t boolean?)
|
||||
|
|
|
|||
|
|
@ -79,88 +79,4 @@
|
|||
(apply super-init args))))
|
||||
|
||||
(define single% (single-window-mixin (single-mixin panel%)))
|
||||
(define single-pane% (single-mixin pane%))
|
||||
|
||||
(define -editor<%>
|
||||
(interface ()
|
||||
get-canvas%
|
||||
collapse
|
||||
split))
|
||||
|
||||
(define editor-mixin
|
||||
(mixin (panel<%>) (-editor<%>) args
|
||||
(rename [super-change-children change-children])
|
||||
(inherit get-parent change-children get-children)
|
||||
(public [get-canvas% (lambda () editor-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)
|
||||
(let ([children (get-children)])
|
||||
(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))))])
|
||||
(bell))
|
||||
(let* ([parent (send canvas/panel get-parent)]
|
||||
[parents-children (send parent get-children)]
|
||||
[num-children (length parents-children)])
|
||||
(if (<= num-children 1)
|
||||
(helper parent)
|
||||
(begin (send parent delete-child canvas/panel)
|
||||
(send (car (send parent get-children)) focus))))))])
|
||||
(send media remove-canvas canvas)
|
||||
(helper canvas))
|
||||
(bell))))]
|
||||
[split
|
||||
(opt-lambda (canvas [panel% 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 (mzlib:function: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) (focus))
|
||||
(send* right-split (set-media media))))])
|
||||
(sequence (apply super-init args))))
|
||||
|
||||
(define horizontal-editor%
|
||||
(editor-mixin horizontal-panel%))
|
||||
(define vertical-editor%
|
||||
(editor-mixin vertical-panel%)))
|
||||
(define single-pane% (single-mixin pane%)))
|
||||
|
|
@ -254,291 +254,271 @@
|
|||
[else (err input "expected a pair")])))))))))
|
||||
|
||||
(define-struct ppanel (title container panel))
|
||||
|
||||
(define font-families-name/const
|
||||
(list (list "Default" 'default)
|
||||
(list "Decorative" 'decorative)
|
||||
(list "Roman" 'roman)
|
||||
(list "Decorative" 'script)
|
||||
(list "Swiss" 'swiss)
|
||||
(list "Modern" 'modern)))
|
||||
|
||||
(define font-families (map car font-families-name/const))
|
||||
|
||||
(define font-size-entry "defaultFontSize")
|
||||
(define font-default-string "Default Value")
|
||||
(define font-default-size 12)
|
||||
(define font-section "mred")
|
||||
(define build-font-entry (lambda (x) (string-append "Screen" x "__")))
|
||||
(define font-file (find-graphical-system-path 'setup-file))
|
||||
(define (build-font-preference-symbol family)
|
||||
(string->symbol (string-append "framework:" family)))
|
||||
|
||||
(let ([set-default
|
||||
(lambda (build-font-entry default pred)
|
||||
(lambda (family)
|
||||
(let ([name (build-font-preference-symbol family)]
|
||||
[font-entry (build-font-entry family)])
|
||||
(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
|
||||
font-section
|
||||
font-entry
|
||||
(if (and (string? new-value)
|
||||
(string=? font-default-string new-value))
|
||||
""
|
||||
new-value)
|
||||
font-file))))))])
|
||||
(for-each (set-default build-font-entry font-default-string string?)
|
||||
font-families)
|
||||
((set-default (lambda (x) x)
|
||||
font-default-size
|
||||
number?)
|
||||
font-size-entry))
|
||||
|
||||
(define ppanels
|
||||
(list
|
||||
(make-ppanel
|
||||
"General"
|
||||
(lambda (parent)
|
||||
(let* ([main (make-object vertical-panel% parent)]
|
||||
[make-check
|
||||
(lambda (pref title bool->pref pref->bool)
|
||||
(let* ([callback
|
||||
(lambda (check-box _)
|
||||
(set pref (bool->pref (send check-box get-value))))]
|
||||
[pref-value (get pref)]
|
||||
[initial-value (pref->bool pref-value)]
|
||||
[c (make-object check-box% title main callback)])
|
||||
(send c set-value initial-value)
|
||||
(add-callback pref
|
||||
(lambda (p v)
|
||||
(send c set-value (pref->bool v))))))]
|
||||
[id (lambda (x) x)])
|
||||
(send main set-alignment 'left 'center)
|
||||
(make-check 'framework:highlight-parens "Highlight between matching parens" id id)
|
||||
(make-check 'framework:fixup-parens "Correct parens" id id)
|
||||
(make-check 'framework:paren-match "Flash paren match" id id)
|
||||
(make-check 'framework:autosaving-on? "Auto-save files" id id)
|
||||
(make-check 'framework:delete-forward? "Map delete to backspace" not not)
|
||||
(make-check 'framework:file-dialogs "Use platform-specific file dialogs"
|
||||
(lambda (x) (if x 'std 'common))
|
||||
(lambda (x) (eq? x 'std)))
|
||||
|
||||
(make-check 'framework:verify-exit "Verify exit" id id)
|
||||
(make-check 'framework:verify-change-format "Ask before changing save format" id id)
|
||||
(make-check 'framework:auto-set-wrap? "Wordwrap editor buffers" id id)
|
||||
|
||||
(make-check 'framework:show-status-line "Show status-line" id id)
|
||||
(make-check 'framework:line-offsets "Count line and column numbers from one" id id)
|
||||
(make-check 'framework:menu-bindings "Enable keybindings in menus" id id)
|
||||
(unless (eq? (system-type) 'unix)
|
||||
(make-check 'framework:print-output-mode "Automatically print to postscript file"
|
||||
(lambda (b)
|
||||
(if b 'postscript 'standard))
|
||||
(lambda (n) (eq? 'postscript n))))
|
||||
(define ppanels null)
|
||||
|
||||
|
||||
(make-check 'framework:display-line-numbers "Display line numbers in buffer; not character offsets" id id)
|
||||
'(when (eq? (system-type) 'windows)
|
||||
(define (add-general-panel)
|
||||
(add-panel
|
||||
"General"
|
||||
(lambda (parent)
|
||||
(let* ([main (make-object vertical-panel% parent)]
|
||||
[make-check
|
||||
(lambda (pref title bool->pref pref->bool)
|
||||
(let* ([callback
|
||||
(lambda (check-box _)
|
||||
(set pref (bool->pref (send check-box get-value))))]
|
||||
[pref-value (get pref)]
|
||||
[initial-value (pref->bool pref-value)]
|
||||
[c (make-object check-box% title main callback)])
|
||||
(send c set-value initial-value)
|
||||
(add-callback pref
|
||||
(lambda (p v)
|
||||
(send c set-value (pref->bool v))))))]
|
||||
[id (lambda (x) x)])
|
||||
(send main set-alignment 'left 'center)
|
||||
(make-check 'framework:highlight-parens "Highlight between matching parens" id id)
|
||||
(make-check 'framework:fixup-parens "Correct parens" id id)
|
||||
(make-check 'framework:paren-match "Flash paren match" id id)
|
||||
(make-check 'framework:autosaving-on? "Auto-save files" id id)
|
||||
(make-check 'framework:delete-forward? "Map delete to backspace" not not)
|
||||
(make-check 'framework:file-dialogs "Use platform-specific file dialogs"
|
||||
(lambda (x) (if x 'std 'common))
|
||||
(lambda (x) (eq? x 'std)))
|
||||
|
||||
(make-check 'framework:verify-exit "Verify exit" id id)
|
||||
(make-check 'framework:verify-change-format "Ask before changing save format" id id)
|
||||
(make-check 'framework:auto-set-wrap? "Wordwrap editor buffers" id id)
|
||||
|
||||
(make-check 'framework:show-status-line "Show status-line" id id)
|
||||
(make-check 'framework:line-offsets "Count line and column numbers from one" id id)
|
||||
(make-check 'framework:menu-bindings "Enable keybindings in menus" id id)
|
||||
(unless (eq? (system-type) 'unix)
|
||||
(make-check 'framework:print-output-mode "Automatically print to postscript file"
|
||||
(lambda (b)
|
||||
(if b 'postscript 'standard))
|
||||
(lambda (n) (eq? 'postscript n))))
|
||||
|
||||
|
||||
(make-check 'framework:display-line-numbers "Display line numbers in buffer; not character offsets" id id)
|
||||
'(when (eq? (system-type) 'windows)
|
||||
(make-check 'framework:windows-mdi "Use MDI Windows" id id))
|
||||
|
||||
main))
|
||||
#f)
|
||||
(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 (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 text%)]
|
||||
[_ (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% name horiz)]
|
||||
|
||||
[message (make-object message%
|
||||
(let ([b (box "")])
|
||||
(if (and (get-resource
|
||||
font-section
|
||||
(build-font-entry name)
|
||||
b)
|
||||
(not (string=? (unbox b)
|
||||
"")))
|
||||
(unbox b)
|
||||
font-default-string))
|
||||
horiz)]
|
||||
[button
|
||||
(make-object button%
|
||||
"Change"
|
||||
horiz
|
||||
(lambda (button evt)
|
||||
(let ([new-value
|
||||
(get-choices-from-user
|
||||
"Fonts"
|
||||
(format "Please choose a new ~a font"
|
||||
name)
|
||||
fonts)])
|
||||
(when new-value
|
||||
(set pref-sym (list-ref fonts (car new-value)))
|
||||
(set-edit-font (get font-size-pref-sym))))))]
|
||||
[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%
|
||||
new-value
|
||||
horiz)])
|
||||
(set! message new-message)
|
||||
(update-message-sizes font-message-get-widths
|
||||
font-message-user-min-sizes)
|
||||
(list label
|
||||
new-message
|
||||
button
|
||||
canvas))))))
|
||||
(send canvas set-line-count 1)
|
||||
(vector set-edit-font
|
||||
(lambda () (send message get-width))
|
||||
(lambda (width) (send message min-width width))
|
||||
(lambda () (send label get-width))
|
||||
(lambda (width) (send label 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))]
|
||||
[initial-font-size
|
||||
(let ([b (box 0)])
|
||||
(if (get-resource font-section
|
||||
font-size-entry
|
||||
b)
|
||||
(unbox b)
|
||||
font-default-size))]
|
||||
[size-slider
|
||||
(make-object slider%
|
||||
"Size"
|
||||
1 127
|
||||
size-panel
|
||||
(lambda (slider evt)
|
||||
(set font-size-pref-sym (send slider get-value)))
|
||||
initial-font-size)])
|
||||
(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-callback
|
||||
font-size-pref-sym
|
||||
(lambda (p value)
|
||||
(for-each (lambda (f) (f value)) set-edit-fonts)
|
||||
(unless (= value (send size-slider get-value))
|
||||
(send size-slider set-value value))
|
||||
#t))
|
||||
(for-each (lambda (f) (f initial-font-size)) set-edit-fonts)
|
||||
(make-object message% "Restart to see font changes" main)
|
||||
main))
|
||||
#f)))
|
||||
|
||||
(define make-run-once
|
||||
(lambda ()
|
||||
(let ([semaphore (make-semaphore 1)])
|
||||
(lambda (t)
|
||||
(dynamic-wind (lambda () (semaphore-wait semaphore))
|
||||
t
|
||||
(lambda () (semaphore-post semaphore)))))))
|
||||
|
||||
(define run-once (make-run-once))
|
||||
main))))
|
||||
|
||||
(define (add-font-panel)
|
||||
(let* ([font-families-name/const
|
||||
(list (list "Default" 'default)
|
||||
(list "Decorative" 'decorative)
|
||||
(list "Modern" 'modern)
|
||||
(list "Roman" 'roman)
|
||||
(list "Swiss" 'swiss))]
|
||||
|
||||
[font-families (map car font-families-name/const)]
|
||||
|
||||
[font-size-entry "defaultFontSize"]
|
||||
[font-default-string "Default Value"]
|
||||
[font-default-size 12]
|
||||
[font-section "mred"]
|
||||
[build-font-entry (lambda (x) (string-append "Screen" x "__"))]
|
||||
[font-file (find-graphical-system-path 'setup-file)]
|
||||
[build-font-preference-symbol
|
||||
(lambda (family)
|
||||
(string->symbol (string-append "framework:" family)))]
|
||||
|
||||
[set-default
|
||||
(lambda (build-font-entry default pred)
|
||||
(lambda (family)
|
||||
(let ([name (build-font-preference-symbol family)]
|
||||
[font-entry (build-font-entry family)])
|
||||
(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
|
||||
font-section
|
||||
font-entry
|
||||
(if (and (string? new-value)
|
||||
(string=? font-default-string new-value))
|
||||
""
|
||||
new-value)
|
||||
font-file))))))])
|
||||
|
||||
(for-each (set-default build-font-entry font-default-string string?)
|
||||
font-families)
|
||||
((set-default (lambda (x) x)
|
||||
font-default-size
|
||||
number?)
|
||||
font-size-entry)
|
||||
(add-panel
|
||||
"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 (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 text%)]
|
||||
[_ (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% name horiz)]
|
||||
|
||||
[message (make-object message%
|
||||
(let ([b (box "")])
|
||||
(if (and (get-resource
|
||||
font-section
|
||||
(build-font-entry name)
|
||||
b)
|
||||
(not (string=? (unbox b)
|
||||
"")))
|
||||
(unbox b)
|
||||
font-default-string))
|
||||
horiz)]
|
||||
[button
|
||||
(make-object button%
|
||||
"Change"
|
||||
horiz
|
||||
(lambda (button evt)
|
||||
(let ([new-value
|
||||
(get-choices-from-user
|
||||
"Fonts"
|
||||
(format "Please choose a new ~a font"
|
||||
name)
|
||||
fonts)])
|
||||
(when new-value
|
||||
(set pref-sym (list-ref fonts (car new-value)))
|
||||
(set-edit-font (get font-size-pref-sym))))))]
|
||||
[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%
|
||||
new-value
|
||||
horiz)])
|
||||
(set! message new-message)
|
||||
(update-message-sizes font-message-get-widths
|
||||
font-message-user-min-sizes)
|
||||
(list label
|
||||
new-message
|
||||
button
|
||||
canvas))))))
|
||||
(send canvas set-line-count 1)
|
||||
(vector set-edit-font
|
||||
(lambda () (send message get-width))
|
||||
(lambda (width) (send message min-width width))
|
||||
(lambda () (send label get-width))
|
||||
(lambda (width) (send label 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))]
|
||||
[initial-font-size
|
||||
(let ([b (box 0)])
|
||||
(if (get-resource font-section
|
||||
font-size-entry
|
||||
b)
|
||||
(unbox b)
|
||||
font-default-size))]
|
||||
[size-slider
|
||||
(make-object slider%
|
||||
"Size"
|
||||
1 127
|
||||
size-panel
|
||||
(lambda (slider evt)
|
||||
(set font-size-pref-sym (send slider get-value)))
|
||||
initial-font-size)])
|
||||
(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-callback
|
||||
font-size-pref-sym
|
||||
(lambda (p value)
|
||||
(for-each (lambda (f) (f value)) set-edit-fonts)
|
||||
(unless (= value (send size-slider get-value))
|
||||
(send size-slider set-value value))
|
||||
#t))
|
||||
(for-each (lambda (f) (f initial-font-size)) set-edit-fonts)
|
||||
(make-object message% "Restart to see font changes" main)
|
||||
main)))))
|
||||
|
||||
(define preferences-dialog #f)
|
||||
|
||||
(define add-panel
|
||||
(lambda (title container)
|
||||
(run-once
|
||||
(lambda ()
|
||||
(let ([new-ppanel (make-ppanel title container #f)])
|
||||
(set! ppanels
|
||||
(let loop ([ppanels ppanels])
|
||||
(cond
|
||||
[(null? ppanels) (list new-ppanel)]
|
||||
[(string=? (ppanel-title (car ppanels))
|
||||
title)
|
||||
(loop (cdr ppanels))]
|
||||
[else (cons (car ppanels)
|
||||
(loop (cdr ppanels)))])))
|
||||
(when preferences-dialog
|
||||
(send preferences-dialog added-pane)))))))
|
||||
(set! ppanels
|
||||
(append ppanels (list (make-ppanel title container #f))))
|
||||
(when preferences-dialog
|
||||
(send preferences-dialog added-pane))))
|
||||
|
||||
(define hide-dialog
|
||||
(lambda ()
|
||||
(run-once
|
||||
(lambda ()
|
||||
(when preferences-dialog
|
||||
(send preferences-dialog show #f))))))
|
||||
(when preferences-dialog
|
||||
(send preferences-dialog show #f))))
|
||||
|
||||
(define show-dialog
|
||||
(lambda ()
|
||||
(run-once
|
||||
(lambda ()
|
||||
(save)
|
||||
(if preferences-dialog
|
||||
(send preferences-dialog show #t)
|
||||
(set! preferences-dialog
|
||||
(make-preferences-dialog)))))))
|
||||
(save)
|
||||
(if preferences-dialog
|
||||
(send preferences-dialog show #t)
|
||||
(set! preferences-dialog
|
||||
(make-preferences-dialog)))))
|
||||
|
||||
(define make-preferences-dialog
|
||||
(lambda ()
|
||||
(letrec ([frame
|
||||
(make-object (class-asi frame%
|
||||
(public [added-pane
|
||||
(lambda ()
|
||||
(ensure-constructed)
|
||||
(refresh-menu)
|
||||
(send popup-menu set-selection (sub1 (length ppanels)))
|
||||
(send single-panel active-child
|
||||
(ppanel-panel
|
||||
(car
|
||||
(list-tail ppanels
|
||||
(sub1 (length ppanels)))))))]))
|
||||
(public
|
||||
[added-pane
|
||||
(lambda ()
|
||||
(ensure-constructed)
|
||||
(refresh-menu)
|
||||
(unless (null? ppanels)
|
||||
(send popup-menu set-selection (sub1 (length ppanels)))
|
||||
(send single-panel active-child
|
||||
(ppanel-panel
|
||||
(car
|
||||
(list-tail ppanels
|
||||
(sub1 (length ppanels))))))))]))
|
||||
"Preferences")]
|
||||
[panel (make-object vertical-panel% frame)]
|
||||
[popup-callback
|
||||
(lambda (choice command-event)
|
||||
(send single-panel active-child
|
||||
(ppanel-panel (list-ref ppanels (send choice get-selection)))))]
|
||||
(unless (null? ppanels)
|
||||
(send single-panel active-child
|
||||
(ppanel-panel (list-ref ppanels (send choice get-selection))))))]
|
||||
[make-popup-menu
|
||||
(lambda ()
|
||||
(let ([menu (make-object choice% "Category"
|
||||
|
|
@ -563,11 +543,14 @@
|
|||
(set-ppanel-panel! ppanel panel))))
|
||||
ppanels)
|
||||
(send single-panel change-children (lambda (l) (map ppanel-panel ppanels)))
|
||||
(send single-panel active-child (ppanel-panel (car ppanels))))]
|
||||
(unless (null? ppanels)
|
||||
(send single-panel active-child (ppanel-panel (car ppanels)))))]
|
||||
[refresh-menu
|
||||
(lambda ()
|
||||
(let ([new-popup (make-popup-menu)])
|
||||
(send new-popup set-selection (send popup-menu get-selection))
|
||||
(let ([new-popup (make-popup-menu)]
|
||||
[old-selection (send popup-menu get-selection)])
|
||||
(when old-selection
|
||||
(send new-popup set-selection old-selection))
|
||||
(set! popup-menu new-popup)
|
||||
(send panel change-children
|
||||
(lambda (l) (list new-popup
|
||||
|
|
@ -587,6 +570,7 @@
|
|||
(stretchable-height #f)
|
||||
(set-alignment 'right 'center))
|
||||
(ensure-constructed)
|
||||
(send popup-menu set-selection 0)
|
||||
(unless (null? ppanels)
|
||||
(send popup-menu set-selection 0))
|
||||
(send frame show #t)
|
||||
frame))))
|
||||
|
|
|
|||
|
|
@ -13,7 +13,8 @@
|
|||
[keymap : framework:keymap^]
|
||||
[text : framework:text^]
|
||||
[frame : framework:frame^]
|
||||
[mzlib:thread : mzlib:thread^])
|
||||
[mzlib:thread : mzlib:thread^]
|
||||
[mzlib:function : mzlib:function^])
|
||||
|
||||
(rename [-text% text%]
|
||||
[-text<%> text<%>])
|
||||
|
|
@ -894,4 +895,84 @@
|
|||
|
||||
(define keymap (make-object keymap%))
|
||||
(setup-keymap keymap)
|
||||
(define (get-keymap) keymap))
|
||||
(define (get-keymap) keymap)
|
||||
|
||||
(define (add-preferences-panel)
|
||||
(preferences:add-panel
|
||||
"Indenting"
|
||||
(lambda (p)
|
||||
(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))]))])
|
||||
(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 (preferences:get 'framework:tabify))])
|
||||
(let* ([add-callback
|
||||
(lambda (keyword-type keyword-symbol list-box)
|
||||
(lambda (button command)
|
||||
(let ([new-one (get-text-from-user
|
||||
(string-append "Enter new " keyword-type "-like keyword:")
|
||||
(string-append keyword-type " Keyword"))])
|
||||
(when new-one
|
||||
(let ([parsed (with-handlers ((exn:read? (lambda (x) #f)))
|
||||
(read (open-input-string new-one)))])
|
||||
(cond
|
||||
[(and (symbol? parsed)
|
||||
(hash-table-get (preferences:get 'framework:tabify)
|
||||
parsed
|
||||
(lambda () #f)))
|
||||
(message-box "Error"
|
||||
(format "\"~a\" is already a specially indented keyword" parsed))]
|
||||
[(symbol? parsed)
|
||||
(hash-table-put! (preferences:get 'framework:tabify)
|
||||
parsed keyword-symbol)
|
||||
(send list-box append (symbol->string parsed))]
|
||||
[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 (preferences:get 'framework:tabify)])
|
||||
(for-each (lambda (x) (hash-table-remove! ht x)) symbols)))))]
|
||||
[main-panel (make-object horizontal-panel% p)]
|
||||
[make-column
|
||||
(lambda (string symbol keywords)
|
||||
(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 void '(multiple))]
|
||||
[button-panel (make-object horizontal-panel% vert)]
|
||||
[add-button (make-object button% "Add" button-panel (add-callback string symbol box))]
|
||||
[delete-button (make-object button% "Remove" button-panel (delete-callback box))])
|
||||
(send* button-panel
|
||||
(set-alignment 'center 'center)
|
||||
(stretchable-height #f))
|
||||
(send add-button min-width (send delete-button get-width))
|
||||
box))]
|
||||
[begin-list-box (make-column "Begin" 'begin begin-keywords)]
|
||||
[define-list-box (make-column "Define" 'define define-keywords)]
|
||||
[lambda-list-box (make-column "Lambda" 'lambda lambda-keywords)]
|
||||
[update-list-boxes
|
||||
(lambda (hash-table)
|
||||
(let-values ([(begin-keywords define-keywords lambda-keywords) (get-keywords hash-table)]
|
||||
[(reset) (lambda (list-box keywords)
|
||||
(send list-box clear)
|
||||
(for-each (lambda (x) (send list-box append x)) keywords))])
|
||||
(reset begin-list-box begin-keywords)
|
||||
(reset define-list-box define-keywords)
|
||||
(reset lambda-list-box lambda-keywords)
|
||||
#t))])
|
||||
(preferences:add-callback 'framework:tabify (lambda (p v) (update-list-boxes v)))
|
||||
main-panel)))))
|
||||
|
||||
)
|
||||
|
|
|
|||
|
|
@ -79,7 +79,6 @@
|
|||
[height (- bottom top)])
|
||||
(when (and (> width 0)
|
||||
(> height 0))
|
||||
(printf "invalidating ~a ~a ~a ~a~n" left top width height)
|
||||
(invalidate-bitmap-cache left top width height))))]
|
||||
[else (let* ([r (car rectangles)]
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
(require-library "errortrace.ss" "errortrace") (error-print-width 80)
|
||||
(require-library "errortrace.ss" "errortrace") (error-print-width 80) (error-context-display-depth 3)
|
||||
|
||||
(let* ([errs null]
|
||||
[sema (make-semaphore 1)]
|
||||
|
|
|
|||
|
|
@ -235,7 +235,8 @@
|
|||
|
||||
(define (wait-for-frame name)
|
||||
(wait-for `(let ([win (get-top-level-focus-window)])
|
||||
(and win (string=? (send win get-label) ,name)))))))
|
||||
(and win
|
||||
(string=? (send win get-label) ,name)))))))
|
||||
|
||||
(define Engine
|
||||
(unit/sig Engine^
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user