added preferences for configuring behavior of magic square bracket
svn: r4489 original commit: 0fcdc0aedd24bc64b4214a16bf51cae880fbcc93
This commit is contained in:
Robby Findler
parent
6a0dcbf4a5
commit
2a25ecbc8a
|
|
@ -21,6 +21,23 @@
|
|||
|
||||
(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?
|
||||
#f
|
||||
boolean?)
|
||||
|
|
|
|||
|
|
@ -660,7 +660,7 @@ for the last one, need a global "no more initialization can happen" flag.
|
|||
values values)
|
||||
(make-check scheme-panel
|
||||
'framework:fixup-open-parens
|
||||
(string-constant fixup-open-parens)
|
||||
(string-constant fixup-open-brackets)
|
||||
values values)
|
||||
(make-check scheme-panel
|
||||
'framework:paren-match
|
||||
|
|
|
|||
|
|
@ -1234,7 +1234,10 @@
|
|||
;(printf "change-to, case ~a\n" i)
|
||||
(set! real-char c))]
|
||||
[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 insert "[" start-pos 'same #f)
|
||||
(when (eq? (send text classify-position pos) 'parenthesis)
|
||||
|
|
@ -1248,13 +1251,13 @@
|
|||
[backward-match2 (send text backward-match before-whitespace-pos2 0)])
|
||||
|
||||
(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.
|
||||
[(and backward-match2
|
||||
(ormap
|
||||
(λ (x)
|
||||
(text-between-equal? x text backward-match2 before-whitespace-pos2))
|
||||
'("new" "case")))
|
||||
case-like-forms))
|
||||
(void)]
|
||||
[(member b-m-char '(#\( #\[ #\{))
|
||||
;; found a "sibling" parenthesized sequence. use the parens it uses.
|
||||
|
|
@ -1266,7 +1269,7 @@
|
|||
(ormap
|
||||
(λ (x)
|
||||
(text-between-equal? x text backward-match before-whitespace-pos))
|
||||
'("case-lambda" "cond" "field" "provide/contract")))
|
||||
cond-like-forms))
|
||||
(change-to 2 #\())]))]
|
||||
[(not (zero? before-whitespace-pos))
|
||||
;; this is the first thing in the sequence
|
||||
|
|
@ -1289,16 +1292,11 @@
|
|||
text
|
||||
second-backwards-match
|
||||
second-before-whitespace-pos))
|
||||
'("let"
|
||||
"let*" "let-values" "let*-values"
|
||||
"let-syntax" "let-struct" "let-syntaxes"
|
||||
"letrec"
|
||||
"letrec-syntaxes" "letrec-syntaxes+values" "letrec-values"
|
||||
"parameterize")))
|
||||
letrec-like-forms))
|
||||
;; we found a let<mumble> keyword, so we get a square bracket
|
||||
(void)]
|
||||
[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
|
||||
second-backwards-match
|
||||
'backward
|
||||
|
|
@ -1311,12 +1309,11 @@
|
|||
(eq? (send text classify-position second-backwards-match)
|
||||
;;; otherwise, this isn't a `let loop', it is a regular let!
|
||||
'symbol)
|
||||
(ormap (λ (x)
|
||||
(text-between-equal? x
|
||||
text
|
||||
second-backwards-match2
|
||||
second-before-whitespace-pos2))
|
||||
'("let")))
|
||||
(member "let" letrec-like-forms)
|
||||
(text-between-equal? "let"
|
||||
text
|
||||
second-backwards-match2
|
||||
second-before-whitespace-pos2))
|
||||
;; found the `(let loop (' or `case' so we keep the [
|
||||
(void)]
|
||||
[else
|
||||
|
|
@ -1370,123 +1367,210 @@
|
|||
(preferences:add-panel
|
||||
(list (string-constant editor-prefs-panel-label)
|
||||
(string-constant indenting-prefs-panel-label))
|
||||
(λ (p)
|
||||
(define get-keywords
|
||||
(λ (hash-table)
|
||||
(letrec ([all-keywords (hash-table-map hash-table list)]
|
||||
[pick-out (λ (wanted in out)
|
||||
(cond
|
||||
[(null? in) (sort 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)))))
|
||||
(define-values (begin-keywords define-keywords lambda-keywords)
|
||||
(get-keywords (car (preferences:get 'framework:tabify))))
|
||||
(define add-button-callback
|
||||
(λ (keyword-type keyword-symbol list-box)
|
||||
(λ (button command)
|
||||
(let ([new-one
|
||||
(keymap:call/text-keymap-initializer
|
||||
(λ ()
|
||||
(get-text-from-user
|
||||
(format (string-constant enter-new-keyword) keyword-type)
|
||||
(format (string-constant x-keyword) keyword-type))))])
|
||||
(when new-one
|
||||
(let ([parsed (with-handlers ((exn:fail:read? (λ (x) #f)))
|
||||
(read (open-input-string new-one)))])
|
||||
(cond
|
||||
[(and (symbol? parsed)
|
||||
(hash-table-get (car (preferences:get 'framework:tabify))
|
||||
parsed
|
||||
(λ () #f)))
|
||||
(message-box (string-constant error)
|
||||
(format (string-constant already-used-keyword) parsed))]
|
||||
[(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))))))
|
||||
make-indenting-prefs-panel)
|
||||
(preferences:add-panel
|
||||
(list (string-constant editor-prefs-panel-label)
|
||||
(string-constant square-bracket-prefs-panel-label))
|
||||
make-square-bracket-prefs-panel))
|
||||
|
||||
(define (make-square-bracket-prefs-panel p)
|
||||
(define main-panel (make-object vertical-panel% p))
|
||||
(define boxes-panel (new horizontal-panel% [parent main-panel]))
|
||||
(define pref-syms (list 'framework:square-bracket:case
|
||||
'framework:square-bracket:cond
|
||||
'framework:square-bracket:letrec))
|
||||
(define pref-prefixes '("Case" "Cond" "Letrec"))
|
||||
|
||||
(define (mk-list-box sym keyword-type)
|
||||
(letrec ([vp (new vertical-panel% [parent boxes-panel])]
|
||||
[_ (new message%
|
||||
[label (format (string-constant x-like-keywords) keyword-type)]
|
||||
[parent vp])]
|
||||
[lb
|
||||
(new list-box%
|
||||
[label #f]
|
||||
[parent vp]
|
||||
[choices (preferences:get sym)]
|
||||
[callback
|
||||
(λ (lb evt)
|
||||
(send remove-button enable (pair? (send lb get-selections))))])]
|
||||
[bp (new horizontal-panel% [parent vp] [stretchable-height #f])]
|
||||
[add
|
||||
(new button%
|
||||
[label (string-constant add-keyword)]
|
||||
[parent bp]
|
||||
[callback
|
||||
(λ (x y)
|
||||
(let ([new-one
|
||||
(keymap:call/text-keymap-initializer
|
||||
(λ ()
|
||||
(get-text-from-user
|
||||
(format (string-constant enter-new-keyword) keyword-type)
|
||||
(format (string-constant x-keyword) keyword-type))))])
|
||||
(when new-one
|
||||
(let ([parsed (with-handlers ((exn:fail:read? (λ (x) #f)))
|
||||
(read (open-input-string new-one)))])
|
||||
(when parsed
|
||||
(preferences:set sym (append (preferences:get sym)
|
||||
(list new-one))))))))])]
|
||||
[remove-button
|
||||
(new button%
|
||||
[label (string-constant remove-keyword)]
|
||||
[parent bp]
|
||||
[callback
|
||||
(λ (x y)
|
||||
(let ([s (send lb get-string-selection)]
|
||||
[n (send lb get-selections)])
|
||||
(when s
|
||||
(preferences:set sym (remove s (preferences:get sym)))
|
||||
(cond
|
||||
[(= 0 (send lb get-number))
|
||||
(send remove-button enable #f)]
|
||||
[else
|
||||
(send lb set-selection
|
||||
(max (- (send lb get-number) 1)
|
||||
(car n)))]))))])])
|
||||
(unless (pair? (send lb get-selections))
|
||||
(send remove-button enable #f))
|
||||
(preferences:add-callback sym
|
||||
(λ (p v)
|
||||
(send lb clear)
|
||||
(for-each (λ (x) (send lb append x)) v)))))
|
||||
(define stupid-internal-definition-syntax1
|
||||
(for-each mk-list-box pref-syms pref-prefixes))
|
||||
|
||||
(define check-box (new check-box%
|
||||
[parent main-panel]
|
||||
[label (string-constant fixup-open-brackets)]
|
||||
[callback
|
||||
(λ (x y)
|
||||
(preferences:set 'framework:fixup-open-parens (send check-box get-value)))]))
|
||||
(preferences:add-callback
|
||||
'framework:fixup-open-parens
|
||||
(λ (p v)
|
||||
(send check-box set-value v)))
|
||||
|
||||
main-panel)
|
||||
|
||||
(define (make-indenting-prefs-panel p)
|
||||
(define get-keywords
|
||||
(λ (hash-table)
|
||||
(letrec ([all-keywords (hash-table-map hash-table list)]
|
||||
[pick-out (λ (wanted in out)
|
||||
(cond
|
||||
[(null? in) (sort 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)))))
|
||||
(define-values (begin-keywords define-keywords lambda-keywords)
|
||||
(get-keywords (car (preferences:get 'framework:tabify))))
|
||||
(define add-button-callback
|
||||
(λ (keyword-type keyword-symbol list-box)
|
||||
(λ (button command)
|
||||
(let ([new-one
|
||||
(keymap:call/text-keymap-initializer
|
||||
(λ ()
|
||||
(get-text-from-user
|
||||
(format (string-constant enter-new-keyword) keyword-type)
|
||||
(format (string-constant x-keyword) keyword-type))))])
|
||||
(when new-one
|
||||
(let ([parsed (with-handlers ((exn:fail:read? (λ (x) #f)))
|
||||
(read (open-input-string new-one)))])
|
||||
(cond
|
||||
[(and (symbol? parsed)
|
||||
(hash-table-get (car (preferences:get 'framework:tabify))
|
||||
parsed
|
||||
(λ () #f)))
|
||||
(message-box (string-constant error)
|
||||
(format (string-constant already-used-keyword) parsed))]
|
||||
[(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)
|
||||
|
||||
)))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user