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

improved magic square bracket stuff

Browse Source 
svn: r4496
This commit is contained in:
Robby Findler 2006-10-05 21:32:58 +00:00
parent 8ecb66ec3c
commit c1350ef9d8
3 changed files with 194 additions and 106 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -29,6 +29,23 @@
'("case-lambda" "cond" "field" "provide/contract") '("case-lambda" "cond" "field" "provide/contract")
(λ (x) (and (list? x) (andmap string? x)))) (λ (x) (and (list? x) (andmap string? x))))
(preferences:set-default 'framework:square-bracket:cond/offset
'(("case-lambda" 0)
("cond" 0)
("field" 0)
("provide/contract" 0)
("new" 1)
("case" 1)
("syntax-case" 2)
("syntax-case*" 3))
(λ (x) (and (list? x) (andmap (λ (x) (and (pair? x)
(string? (car x))
(pair? (cdr x))
(number? (cadr x))
(null? (cddr x))))
x))))
(preferences:set-default 'framework:square-bracket:letrec (preferences:set-default 'framework:square-bracket:letrec
'("let" '("let"
"let*" "let-values" "let*-values" "let*" "let-values" "let*-values"

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

@ -13,7 +13,8 @@
(lib "thread.ss") (lib "thread.ss")
(lib "etc.ss") (lib "etc.ss")
(lib "surrogate.ss") (lib "surrogate.ss")
(lib "scheme-lexer.ss" "syntax-color")) (lib "scheme-lexer.ss" "syntax-color")
"../gui-utils.ss")
(provide scheme@) (provide scheme@)
@ -1235,15 +1236,38 @@
(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)]) [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)
(let* ([before-whitespace-pos (send text skip-whitespace pos 'backward #t)] (let* ([before-whitespace-pos (send text skip-whitespace pos 'backward #t)]
[backward-match (send text backward-match before-whitespace-pos 0)]) [matched-cond-like-keyword
(let ([b-m-char (and (number? backward-match) (send text get-character backward-match))]) ;; searches backwards for the keyword in the sequence at this level.
;; if found, it counts how many sexps back it was and then uses that to
;; check the preferences.
(let loop ([pos before-whitespace-pos]
[n 0])
(let ([backward-match (send text backward-match pos 0)])
(cond
[backward-match
(let ([before-whitespace-pos (send text skip-whitespace backward-match 'backward #t)])
(loop before-whitespace-pos
(+ n 1)))]
[else
(let* ([afterwards (send text forward-match pos (send text last-position))]
[keyword
(and afterwards
(send text get-text pos afterwards))])
(and keyword
(member (list keyword (- n 1))
(preferences:get 'framework:square-bracket:cond/offset))))])))])
(cond
[matched-cond-like-keyword
;; just leave the square backet in, in this case
(void)]
[else
(let* ([backward-match (send text backward-match before-whitespace-pos 0)]
[b-m-char (and (number? backward-match) (send text get-character backward-match))])
(cond (cond
[backward-match [backward-match
;; there is an expression before this, at this layer ;; there is an expression before this, at this layer
@ -1251,26 +1275,12 @@
[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 '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))
case-like-forms))
(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.
(change-to 1 b-m-char)] (change-to 1 b-m-char)]
[else [else
;; there is a sexp before this, but it isn't parenthesized. ;; otherwise, we switch to (
;; if it is the `cond' keyword, we get a square bracket. otherwise not. (change-to 2 #\()]))]
(unless (and (beginning-of-sequence? text backward-match)
(ormap
(λ (x)
(text-between-equal? x text backward-match before-whitespace-pos))
cond-like-forms))
(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
;; pop out one layer and look for a keyword. ;; pop out one layer and look for a keyword.
@ -1296,7 +1306,7 @@
;; 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' / 'case' pattern ;; go back one more sexp in the same row, looking for `let loop' 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
@ -1314,7 +1324,7 @@
text text
second-backwards-match2 second-backwards-match2
second-before-whitespace-pos2)) second-before-whitespace-pos2))
;; found the `(let loop (' or `case' so we keep the [ ;; found the `(let loop (' so we keep the [
(void)] (void)]
[else [else
;; otherwise, round. ;; otherwise, round.
@ -1322,7 +1332,7 @@
[else [else
(change-to 5 #\()]))] (change-to 5 #\()]))]
[else [else
(change-to 6 #\()])))) (change-to 6 #\()]))])))
(send text delete pos (+ pos 1) #f) (send text delete pos (+ pos 1) #f)
(send text end-edit-sequence) (send text end-edit-sequence)
(send text insert real-char start-pos end-pos))) (send text insert real-char start-pos end-pos)))
@ -1381,7 +1391,7 @@
'framework:square-bracket:letrec)) 'framework:square-bracket:letrec))
(define pref-prefixes '("Case" "Cond" "Letrec")) (define pref-prefixes '("Case" "Cond" "Letrec"))
(define (mk-list-box sym keyword-type) (define (mk-list-box sym keyword-type pref->string get-new-one)
(letrec ([vp (new vertical-panel% [parent boxes-panel])] (letrec ([vp (new vertical-panel% [parent boxes-panel])]
[_ (new message% [_ (new message%
[label (format (string-constant x-like-keywords) keyword-type)] [label (format (string-constant x-like-keywords) keyword-type)]
@ -1390,7 +1400,7 @@
(new list-box% (new list-box%
[label #f] [label #f]
[parent vp] [parent vp]
[choices (preferences:get sym)] [choices (map pref->string (preferences:get sym))]
[callback [callback
(λ (lb evt) (λ (lb evt)
(send remove-button enable (pair? (send lb get-selections))))])] (send remove-button enable (pair? (send lb get-selections))))])]
@ -1401,43 +1411,101 @@
[parent bp] [parent bp]
[callback [callback
(λ (x y) (λ (x y)
(let ([new-one (let ([new-one (get-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 (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) (preferences:set sym (append (preferences:get sym)
(list new-one))))))))])] (list new-one))))))])]
[remove-button [remove-button
(new button% (new button%
[label (string-constant remove-keyword)] [label (string-constant remove-keyword)]
[parent bp] [parent bp]
[callback [callback
(λ (x y) (λ (x y)
(let ([s (send lb get-string-selection)] (let ([n (send lb get-selections)])
[n (send lb get-selections)]) (when (pair? n)
(when s (preferences:set
(preferences:set sym (remove s (preferences:get sym))) sym
(let loop ([i 0]
[prefs (preferences:get sym)])
(cond
[(= i (car n)) (cdr prefs)]
[else (cons (car prefs)
(loop (+ i 1)
(cdr prefs)))])))
(cond (cond
[(= 0 (send lb get-number)) [(= 0 (send lb get-number))
(send remove-button enable #f)] (send remove-button enable #f)]
[else [else
(send lb set-selection (send lb set-selection
(max (- (send lb get-number) 1) (if (= (car n) (send lb get-number))
(- (send lb get-number) 1)
(car n)))]))))])]) (car n)))]))))])])
(unless (pair? (send lb get-selections)) (unless (pair? (send lb get-selections))
(send remove-button enable #f)) (send remove-button enable #f))
(preferences:add-callback sym (preferences:add-callback sym
(λ (p v) (λ (p v)
(send lb clear) (send lb clear)
(for-each (λ (x) (send lb append x)) v))))) (for-each (λ (x) (send lb append (pref->string x))) v)))))
(define (get-new-letrec-keyword)
(let ([new-one
(keymap:call/text-keymap-initializer
(λ ()
(get-text-from-user
(format (string-constant enter-new-keyword) "Letrec")
(format (string-constant x-keyword) "Letrec"))))])
(and new-one
(let ([parsed (with-handlers ((exn:fail:read? (λ (x) #f)))
(read (open-input-string new-one)))])
parsed))))
(define (get-new-cond-keyword)
(define f (new dialog% [label (format (string-constant enter-new-keyword) "Cond")]))
(define tb (keymap:call/text-keymap-initializer
(λ ()
(new text-field%
[parent f]
[label #f]))))
(define number-panel (new horizontal-panel% [parent f] [stretchable-height #f]))
(define number-label (new message% [parent number-panel] [label (string-constant skip-subexpressions)]))
(define number
(keymap:call/text-keymap-initializer
(λ ()
(new text-field%
[parent number-panel]
[init-value "1"]
[min-width 50]
[label #f]))))
(define answers #f)
(define bp (new horizontal-panel%
[parent f]
[stretchable-height #f]
[alignment '(right center)]))
(define (confirm-callback b e)
(let ([n (string->number (send number get-value))]
[sym (with-handlers ([exn:fail:read? (λ (x) #f)])
(read (open-input-string (send tb get-value))))])
(when (and (number? n)
(symbol? sym))
(set! answers (list (symbol->string sym) n)))
(send f show #f)))
(define (cancel-callback b e)
(send f show #f))
(define-values (ok-button cancel-button)
(gui-utils:ok/cancel-buttons bp confirm-callback cancel-callback (string-constant ok) (string-constant cancel)))
(send f show #t)
answers)
(define stupid-internal-definition-syntax1 (define stupid-internal-definition-syntax1
(for-each mk-list-box pref-syms pref-prefixes)) (mk-list-box 'framework:square-bracket:letrec "Letrec" values get-new-letrec-keyword))
(define stupid-internal-definition-syntax2
(mk-list-box 'framework:square-bracket:cond/offset
"Cond"
(λ (l) (format "~a (~a)" (car l) (cadr l)))
get-new-cond-keyword))
(define check-box (new check-box% (define check-box (new check-box%
[parent main-panel] [parent main-panel]

5
collects/string-constants/english-string-constants.ss
View File

@ -452,13 +452,16 @@ please adhere to these guidelines:
(indenting-prefs-panel-label "Indenting") (indenting-prefs-panel-label "Indenting")
(indenting-prefs-extra-regexp "Extra regexp") (indenting-prefs-extra-regexp "Extra regexp")
(square-bracket-prefs-panel-label "Square bracket") (square-bracket-prefs-panel-label "Square Bracket")
; filled with define, lambda, or begin ; filled with define, lambda, or begin
(enter-new-keyword "Enter new ~a-like keyword:") (enter-new-keyword "Enter new ~a-like keyword:")
(x-keyword "~a Keyword") (x-keyword "~a Keyword")
(x-like-keywords "~a-like Keywords") (x-like-keywords "~a-like Keywords")
; used in Square bracket panel
(skip-subexpressions "Number of sub-expressions to skip")
(expected-a-symbol "expected a symbol, found: ~a") (expected-a-symbol "expected a symbol, found: ~a")
(already-used-keyword "\"~a\" is already a specially indented keyword") (already-used-keyword "\"~a\" is already a specially indented keyword")
(add-keyword "Add") (add-keyword "Add")