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

116
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,7 +1367,92 @@
(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)
(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 (define get-keywords
(λ (hash-table) (λ (hash-table)
(letrec ([all-keywords (hash-table-map hash-table list)] (letrec ([all-keywords (hash-table-map hash-table list)]
@ -1489,4 +1571,6 @@
(send define-regexp-text set-value (or (object-name (caddr pref)) "")) (send define-regexp-text set-value (or (object-name (caddr pref)) ""))
(send lambda-regexp-text set-value (or (object-name (cadddr pref)) "")))) (send lambda-regexp-text set-value (or (object-name (cadddr pref)) ""))))
(preferences:add-callback 'framework:tabify (λ (p v) (update-gui v))) (preferences:add-callback 'framework:tabify (λ (p v) (update-gui v)))
main-panel)))))) main-panel)
)))