...
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%)))
|
||||
|
|
@ -255,57 +255,10 @@
|
|||
|
||||
(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 ppanels null)
|
||||
|
||||
(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
|
||||
(define (add-general-panel)
|
||||
(add-panel
|
||||
"General"
|
||||
(lambda (parent)
|
||||
(let* ([main (make-object vertical-panel% parent)]
|
||||
|
|
@ -350,9 +303,58 @@
|
|||
'(when (eq? (system-type) 'windows)
|
||||
(make-check 'framework:windows-mdi "Use MDI Windows" id id))
|
||||
|
||||
main))
|
||||
#f)
|
||||
(make-ppanel
|
||||
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)]
|
||||
|
|
@ -470,75 +472,53 @@
|
|||
#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 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)))])))
|
||||
(append ppanels (list (make-ppanel title container #f))))
|
||||
(when preferences-dialog
|
||||
(send preferences-dialog added-pane)))))))
|
||||
(send preferences-dialog added-pane))))
|
||||
|
||||
(define hide-dialog
|
||||
(lambda ()
|
||||
(run-once
|
||||
(lambda ()
|
||||
(when preferences-dialog
|
||||
(send preferences-dialog show #f))))))
|
||||
(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)))))))
|
||||
(make-preferences-dialog)))))
|
||||
|
||||
(define make-preferences-dialog
|
||||
(lambda ()
|
||||
(letrec ([frame
|
||||
(make-object (class-asi frame%
|
||||
(public [added-pane
|
||||
(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)))))))]))
|
||||
(sub1 (length ppanels))))))))]))
|
||||
"Preferences")]
|
||||
[panel (make-object vertical-panel% frame)]
|
||||
[popup-callback
|
||||
(lambda (choice command-event)
|
||||
(unless (null? ppanels)
|
||||
(send single-panel active-child
|
||||
(ppanel-panel (list-ref ppanels (send choice get-selection)))))]
|
||||
(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