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

added preferences for configuring behavior of magic square bracket

Browse Source 
svn: r4489

original commit: 0fcdc0aedd24bc64b4214a16bf51cae880fbcc93
This commit is contained in:
Robby Findler 2006-10-05 03:06:47 +00:00
parent 6a0dcbf4a5
commit 2a25ecbc8a
3 changed files with 239 additions and 138 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
collects/framework/private/main.ss
View File

@ -21,6 +21,23 @@
(application-preferences-handler (λ () (preferences:show-dialog))) (application-preferences-handler (λ () (preferences:show-dialog)))
(preferences:set-default 'framework:square-bracket:case
'("new" "case")
(λ (x) (and (list? x) (andmap string? x))))
(preferences:set-default 'framework:square-bracket:cond
'("case-lambda" "cond" "field" "provide/contract")
(λ (x) (and (list? x) (andmap string? x))))
(preferences:set-default 'framework:square-bracket:letrec
'("let"
"let*" "let-values" "let*-values"
"let-syntax" "let-struct" "let-syntaxes"
"letrec"
"letrec-syntaxes" "letrec-syntaxes+values" "letrec-values"
"parameterize")
(λ (x) (and (list? x) (andmap string? x))))
(preferences:set-default 'framework:case-sensitive-search? (preferences:set-default 'framework:case-sensitive-search?
#f #f
boolean?) boolean?)

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

@ -660,7 +660,7 @@ for the last one, need a global "no more initialization can happen" flag.
values values) values values)
(make-check scheme-panel (make-check scheme-panel
'framework:fixup-open-parens 'framework:fixup-open-parens
(string-constant fixup-open-parens) (string-constant fixup-open-brackets)
values values) values values)
(make-check scheme-panel (make-check scheme-panel
'framework:paren-match 'framework:paren-match

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

@ -1234,7 +1234,10 @@
;(printf "change-to, case ~a\n" i) ;(printf "change-to, case ~a\n" i)
(set! real-char c))] (set! real-char c))]
[start-pos (send text get-start-position)] [start-pos (send text get-start-position)]
[end-pos (send text get-end-position)]) [end-pos (send text get-end-position)]
[case-like-forms (preferences:get 'framework:square-bracket:case)]
[cond-like-forms (preferences:get 'framework:square-bracket:cond)]
[letrec-like-forms (preferences:get 'framework:square-bracket:letrec)])
(send text begin-edit-sequence #f #f) (send text begin-edit-sequence #f #f)
(send text insert "[" start-pos 'same #f) (send text insert "[" start-pos 'same #f)
(when (eq? (send text classify-position pos) 'parenthesis) (when (eq? (send text classify-position pos) 'parenthesis)
@ -1248,13 +1251,13 @@
[backward-match2 (send text backward-match before-whitespace-pos2 0)]) [backward-match2 (send text backward-match before-whitespace-pos2 0)])
(cond (cond
;; we found a new expression, two steps back, so we don't use the sibling ;; we found a 'case'-like expression, two steps back, so we don't use the sibling
;; check here -- we just go with square brackets. ;; check here -- we just go with square brackets.
[(and backward-match2 [(and backward-match2
(ormap (ormap
(λ (x) (λ (x)
(text-between-equal? x text backward-match2 before-whitespace-pos2)) (text-between-equal? x text backward-match2 before-whitespace-pos2))
'("new" "case"))) case-like-forms))
(void)] (void)]
[(member b-m-char '(#\( #\[ #\{)) [(member b-m-char '(#\( #\[ #\{))
;; found a "sibling" parenthesized sequence. use the parens it uses. ;; found a "sibling" parenthesized sequence. use the parens it uses.
@ -1266,7 +1269,7 @@
(ormap (ormap
(λ (x) (λ (x)
(text-between-equal? x text backward-match before-whitespace-pos)) (text-between-equal? x text backward-match before-whitespace-pos))
'("case-lambda" "cond" "field" "provide/contract"))) cond-like-forms))
(change-to 2 #\())]))] (change-to 2 #\())]))]
[(not (zero? before-whitespace-pos)) [(not (zero? before-whitespace-pos))
;; this is the first thing in the sequence ;; this is the first thing in the sequence
@ -1289,16 +1292,11 @@
text text
second-backwards-match second-backwards-match
second-before-whitespace-pos)) second-before-whitespace-pos))
'("let" letrec-like-forms))
"let*" "let-values" "let*-values"
"let-syntax" "let-struct" "let-syntaxes"
"letrec"
"letrec-syntaxes" "letrec-syntaxes+values" "letrec-values"
"parameterize")))
;; we found a let<mumble> keyword, so we get a square bracket ;; we found a let<mumble> keyword, so we get a square bracket
(void)] (void)]
[else [else
;; go back one more sexp in the same row, looking for `let loop' pattern ;; go back one more sexp in the same row, looking for `let loop' / 'case' pattern
(let* ([second-before-whitespace-pos2 (send text skip-whitespace (let* ([second-before-whitespace-pos2 (send text skip-whitespace
second-backwards-match second-backwards-match
'backward 'backward
@ -1311,12 +1309,11 @@
(eq? (send text classify-position second-backwards-match) (eq? (send text classify-position second-backwards-match)
;;; otherwise, this isn't a `let loop', it is a regular let! ;;; otherwise, this isn't a `let loop', it is a regular let!
'symbol) 'symbol)
(ormap (λ (x) (member "let" letrec-like-forms)
(text-between-equal? x (text-between-equal? "let"
text text
second-backwards-match2 second-backwards-match2
second-before-whitespace-pos2)) second-before-whitespace-pos2))
'("let")))
;; found the `(let loop (' or `case' so we keep the [ ;; found the `(let loop (' or `case' so we keep the [
(void)] (void)]
[else [else
@ -1370,123 +1367,210 @@
(preferences:add-panel (preferences:add-panel
(list (string-constant editor-prefs-panel-label) (list (string-constant editor-prefs-panel-label)
(string-constant indenting-prefs-panel-label)) (string-constant indenting-prefs-panel-label))
(λ (p) make-indenting-prefs-panel)
(define get-keywords (preferences:add-panel
(λ (hash-table) (list (string-constant editor-prefs-panel-label)
(letrec ([all-keywords (hash-table-map hash-table list)] (string-constant square-bracket-prefs-panel-label))
[pick-out (λ (wanted in out) make-square-bracket-prefs-panel))
(cond
[(null? in) (sort out string<=?)] (define (make-square-bracket-prefs-panel p)
[else (if (eq? wanted (cadr (car in))) (define main-panel (make-object vertical-panel% p))
(pick-out wanted (cdr in) (cons (symbol->string (car (car in))) out)) (define boxes-panel (new horizontal-panel% [parent main-panel]))
(pick-out wanted (cdr in) out))]))]) (define pref-syms (list 'framework:square-bracket:case
(values (pick-out 'begin all-keywords null) 'framework:square-bracket:cond
(pick-out 'define all-keywords null) 'framework:square-bracket:letrec))
(pick-out 'lambda all-keywords null))))) (define pref-prefixes '("Case" "Cond" "Letrec"))
(define-values (begin-keywords define-keywords lambda-keywords)
(get-keywords (car (preferences:get 'framework:tabify)))) (define (mk-list-box sym keyword-type)
(define add-button-callback (letrec ([vp (new vertical-panel% [parent boxes-panel])]
(λ (keyword-type keyword-symbol list-box) [_ (new message%
(λ (button command) [label (format (string-constant x-like-keywords) keyword-type)]
(let ([new-one [parent vp])]
(keymap:call/text-keymap-initializer [lb
(λ () (new list-box%
(get-text-from-user [label #f]
(format (string-constant enter-new-keyword) keyword-type) [parent vp]
(format (string-constant x-keyword) keyword-type))))]) [choices (preferences:get sym)]
(when new-one [callback
(let ([parsed (with-handlers ((exn:fail:read? (λ (x) #f))) (λ (lb evt)
(read (open-input-string new-one)))]) (send remove-button enable (pair? (send lb get-selections))))])]
(cond [bp (new horizontal-panel% [parent vp] [stretchable-height #f])]
[(and (symbol? parsed) [add
(hash-table-get (car (preferences:get 'framework:tabify)) (new button%
parsed [label (string-constant add-keyword)]
(λ () #f))) [parent bp]
(message-box (string-constant error) [callback
(format (string-constant already-used-keyword) parsed))] (λ (x y)
[(symbol? parsed) (let ([new-one
(let ([ht (car (preferences:get 'framework:tabify))]) (keymap:call/text-keymap-initializer
(hash-table-put! ht parsed keyword-symbol) (λ ()
(update-list-boxes ht))] (get-text-from-user
[else (message-box (format (string-constant enter-new-keyword) keyword-type)
(string-constant error) (format (string-constant x-keyword) keyword-type))))])
(format (string-constant expected-a-symbol) new-one))]))))))) (when new-one
(define delete-callback (let ([parsed (with-handlers ((exn:fail:read? (λ (x) #f)))
(λ (list-box) (read (open-input-string new-one)))])
(λ (button command) (when parsed
(let* ([selections (send list-box get-selections)] (preferences:set sym (append (preferences:get sym)
[symbols (map (λ (x) (string->symbol (send list-box get-string x))) selections)]) (list new-one))))))))])]
(for-each (λ (x) (send list-box delete x)) (reverse selections)) [remove-button
(let ([ht (car (preferences:get 'framework:tabify))]) (new button%
(for-each (λ (x) (hash-table-remove! ht x)) symbols)))))) [label (string-constant remove-keyword)]
(define main-panel (make-object horizontal-panel% p)) [parent bp]
(define make-column [callback
(λ (string symbol keywords bang-regexp) (λ (x y)
(let* ([vert (make-object vertical-panel% main-panel)] (let ([s (send lb get-string-selection)]
[_ (make-object message% (format (string-constant x-like-keywords) string) vert)] [n (send lb get-selections)])
[box (make-object list-box% #f keywords vert void '(multiple))] (when s
[button-panel (make-object horizontal-panel% vert)] (preferences:set sym (remove s (preferences:get sym)))
[text (new text-field% (cond
(label (string-constant indenting-prefs-extra-regexp)) [(= 0 (send lb get-number))
(callback (λ (tf evt) (send remove-button enable #f)]
(let ([str (send tf get-value)]) [else
(cond (send lb set-selection
[(equal? str "") (max (- (send lb get-number) 1)
(bang-regexp #f)] (car n)))]))))])])
[else (unless (pair? (send lb get-selections))
(with-handlers ([exn:fail? (send remove-button enable #f))
(λ (x) (preferences:add-callback sym
(color-yellow (send tf get-editor)))]) (λ (p v)
(bang-regexp (regexp str)) (send lb clear)
(clear-color (send tf get-editor)))])))) (for-each (λ (x) (send lb append x)) v)))))
(parent vert))] (define stupid-internal-definition-syntax1
[add-button (make-object button% (string-constant add-keyword) (for-each mk-list-box pref-syms pref-prefixes))
button-panel (add-button-callback string symbol box))]
[delete-button (make-object button% (string-constant remove-keyword) (define check-box (new check-box%
button-panel (delete-callback box))]) [parent main-panel]
(send* button-panel [label (string-constant fixup-open-brackets)]
(set-alignment 'center 'center) [callback
(stretchable-height #f)) (λ (x y)
(send add-button min-width (send delete-button get-width)) (preferences:set 'framework:fixup-open-parens (send check-box get-value)))]))
(values box text)))) (preferences:add-callback
(define (color-yellow text) 'framework:fixup-open-parens
(let ([sd (make-object style-delta%)]) (λ (p v)
(send sd set-delta-background "yellow") (send check-box set-value v)))
(send text change-style sd 0 (send text last-position))))
(define (clear-color text) main-panel)
(let ([sd (make-object style-delta%)])
(send sd set-delta-background "white") (define (make-indenting-prefs-panel p)
(send text change-style sd 0 (send text last-position)))) (define get-keywords
(define-values (begin-list-box begin-regexp-text) (λ (hash-table)
(make-column "Begin" (letrec ([all-keywords (hash-table-map hash-table list)]
'begin [pick-out (λ (wanted in out)
begin-keywords (cond
(λ (x) (set-car! (cdr (preferences:get 'framework:tabify)) x)))) [(null? in) (sort out string<=?)]
(define-values (define-list-box define-regexp-text) [else (if (eq? wanted (cadr (car in)))
(make-column "Define" (pick-out wanted (cdr in) (cons (symbol->string (car (car in))) out))
'define (pick-out wanted (cdr in) out))]))])
define-keywords (values (pick-out 'begin all-keywords null)
(λ (x) (set-car! (cddr (preferences:get 'framework:tabify)) x)))) (pick-out 'define all-keywords null)
(define-values (lambda-list-box lambda-regexp-text) (pick-out 'lambda all-keywords null)))))
(make-column "Lambda" (define-values (begin-keywords define-keywords lambda-keywords)
'lambda (get-keywords (car (preferences:get 'framework:tabify))))
lambda-keywords (define add-button-callback
(λ (x) (set-car! (cdddr (preferences:get 'framework:tabify)) x)))) (λ (keyword-type keyword-symbol list-box)
(define update-list-boxes (λ (button command)
(λ (hash-table) (let ([new-one
(let-values ([(begin-keywords define-keywords lambda-keywords) (get-keywords hash-table)] (keymap:call/text-keymap-initializer
[(reset) (λ (list-box keywords) (λ ()
(send list-box clear) (get-text-from-user
(for-each (λ (x) (send list-box append x)) keywords))]) (format (string-constant enter-new-keyword) keyword-type)
(reset begin-list-box begin-keywords) (format (string-constant x-keyword) keyword-type))))])
(reset define-list-box define-keywords) (when new-one
(reset lambda-list-box lambda-keywords) (let ([parsed (with-handlers ((exn:fail:read? (λ (x) #f)))
#t))) (read (open-input-string new-one)))])
(define update-gui (cond
(λ (pref) [(and (symbol? parsed)
(update-list-boxes (car pref)) (hash-table-get (car (preferences:get 'framework:tabify))
(send begin-regexp-text set-value (or (object-name (cadr pref)) "")) parsed
(send define-regexp-text set-value (or (object-name (caddr pref)) "")) (λ () #f)))
(send lambda-regexp-text set-value (or (object-name (cadddr pref)) "")))) (message-box (string-constant error)
(preferences:add-callback 'framework:tabify (λ (p v) (update-gui v))) (format (string-constant already-used-keyword) parsed))]
main-panel)))))) [(symbol? parsed)
(let ([ht (car (preferences:get 'framework:tabify))])
(hash-table-put! ht parsed keyword-symbol)
(update-list-boxes ht))]
[else (message-box
(string-constant error)
(format (string-constant expected-a-symbol) new-one))])))))))
(define delete-callback
(λ (list-box)
(λ (button command)
(let* ([selections (send list-box get-selections)]
[symbols (map (λ (x) (string->symbol (send list-box get-string x))) selections)])
(for-each (λ (x) (send list-box delete x)) (reverse selections))
(let ([ht (car (preferences:get 'framework:tabify))])
(for-each (λ (x) (hash-table-remove! ht x)) symbols))))))
(define main-panel (make-object horizontal-panel% p))
(define make-column
(λ (string symbol keywords bang-regexp)
(let* ([vert (make-object vertical-panel% main-panel)]
[_ (make-object message% (format (string-constant x-like-keywords) string) vert)]
[box (make-object list-box% #f keywords vert void '(multiple))]
[button-panel (make-object horizontal-panel% vert)]
[text (new text-field%
(label (string-constant indenting-prefs-extra-regexp))
(callback (λ (tf evt)
(let ([str (send tf get-value)])
(cond
[(equal? str "")
(bang-regexp #f)]
[else
(with-handlers ([exn:fail?
(λ (x)
(color-yellow (send tf get-editor)))])
(bang-regexp (regexp str))
(clear-color (send tf get-editor)))]))))
(parent vert))]
[add-button (make-object button% (string-constant add-keyword)
button-panel (add-button-callback string symbol box))]
[delete-button (make-object button% (string-constant remove-keyword)
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))
(values box text))))
(define (color-yellow text)
(let ([sd (make-object style-delta%)])
(send sd set-delta-background "yellow")
(send text change-style sd 0 (send text last-position))))
(define (clear-color text)
(let ([sd (make-object style-delta%)])
(send sd set-delta-background "white")
(send text change-style sd 0 (send text last-position))))
(define-values (begin-list-box begin-regexp-text)
(make-column "Begin"
'begin
begin-keywords
(λ (x) (set-car! (cdr (preferences:get 'framework:tabify)) x))))
(define-values (define-list-box define-regexp-text)
(make-column "Define"
'define
define-keywords
(λ (x) (set-car! (cddr (preferences:get 'framework:tabify)) x))))
(define-values (lambda-list-box lambda-regexp-text)
(make-column "Lambda"
'lambda
lambda-keywords
(λ (x) (set-car! (cdddr (preferences:get 'framework:tabify)) x))))
(define update-list-boxes
(λ (hash-table)
(let-values ([(begin-keywords define-keywords lambda-keywords) (get-keywords hash-table)]
[(reset) (λ (list-box keywords)
(send list-box clear)
(for-each (λ (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)))
(define update-gui
(λ (pref)
(update-list-boxes (car pref))
(send begin-regexp-text set-value (or (object-name (cadr pref)) ""))
(send define-regexp-text set-value (or (object-name (caddr pref)) ""))
(send lambda-regexp-text set-value (or (object-name (cadddr pref)) ""))))
(preferences:add-callback 'framework:tabify (λ (p v) (update-gui v)))
main-panel)
)))