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

added local-like category to square bracketing magic

Browse Source 
svn: r6886
This commit is contained in:
Robby Findler 2007-07-10 16:13:09 +00:00
parent 4ed3f9bb6c
commit 867ae7b56d
3 changed files with 58 additions and 38 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -35,8 +35,9 @@
(number? (cadr x)) (number? (cadr x))
(null? (cddr x)))) (null? (cddr x))))
x)))) x))))
(preferences:set-default 'framework:white-on-black? #f boolean?) (preferences:set-default 'framework:square-bracket:local
'("local")
(λ (x) (and (list? x) (andmap string? 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"
@ -47,6 +48,8 @@
"with-syntax") "with-syntax")
(λ (x) (and (list? x) (andmap string? x)))) (λ (x) (and (list? x) (andmap string? x))))
(preferences:set-default 'framework:white-on-black? #f boolean?)
(preferences:set-default 'framework:case-sensitive-search? (preferences:set-default 'framework:case-sensitive-search?
#f #f
boolean?) boolean?)

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

@ -1316,30 +1316,18 @@
(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)]
[matched-cond-like-keyword [keyword/distance (find-keyword-and-distance before-whitespace-pos text)])
;; 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 get-forward-sexp pos)]
[keyword
(and afterwards
(send text get-text pos afterwards))])
(and keyword
(member (list keyword (- n 1))
(preferences:get 'framework:square-bracket:cond/offset))))])))])
(cond (cond
[matched-cond-like-keyword [(and keyword/distance
(member keyword/distance
(preferences:get 'framework:square-bracket:cond/offset)))
;; just leave the square backet in, in this case ;; just leave the square backet in, in this case
(void)] (void)]
[(and keyword/distance
(member (car keyword/distance)
(preferences:get 'framework:square-bracket:local)))
(unless (= (cadr keyword/distance) 0)
(change-to 7 #\())]
[else [else
(let* ([backward-match (send text backward-match before-whitespace-pos 0)] (let* ([backward-match (send text backward-match before-whitespace-pos 0)]
[b-m-char (and (number? backward-match) (send text get-character backward-match))]) [b-m-char (and (number? backward-match) (send text get-character backward-match))])
@ -1411,6 +1399,26 @@
(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)))
;; find-keyword-and-distance : -> (union #f (cons string number))
(define (find-keyword-and-distance before-whitespace-pos text)
;; searches backwards for the keyword in the sequence at this level.
;; if found, it counts how many sexps back it was
(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 get-forward-sexp pos)]
[keyword
(and afterwards
(send text get-text pos afterwards))])
(and keyword
(list keyword (- n 1))))]))))
;; beginning-of-sequence? : text number -> boolean ;; beginning-of-sequence? : text number -> boolean
;; determines if this position is at the beginning of a sequence ;; determines if this position is at the beginning of a sequence
@ -1518,19 +1526,20 @@
(send lb clear) (send lb clear)
(for-each (λ (x) (send lb append (pref->string x))) v))))) (for-each (λ (x) (send lb append (pref->string x))) v)))))
(define (get-new-letrec-keyword) (define (get-new-simple-keyword label)
(let ([new-one (λ ()
(keymap:call/text-keymap-initializer (let ([new-one
(λ () (keymap:call/text-keymap-initializer
(get-text-from-user (λ ()
(format (string-constant enter-new-keyword) "Letrec") (get-text-from-user
(format (string-constant x-keyword) "Letrec"))))]) (format (string-constant enter-new-keyword) label)
(and new-one (format (string-constant x-keyword) label))))])
(let ([parsed (with-handlers ((exn:fail:read? (λ (x) #f))) (and new-one
(read (open-input-string new-one)))]) (let ([parsed (with-handlers ((exn:fail:read? (λ (x) #f)))
(read (open-input-string new-one)))])
(and (symbol? parsed)
(symbol->string parsed)))))) (and (symbol? parsed)
(symbol->string parsed)))))))
(define (get-new-cond-keyword) (define (get-new-cond-keyword)
(define f (new dialog% [label (format (string-constant enter-new-keyword) "Cond")])) (define f (new dialog% [label (format (string-constant enter-new-keyword) "Cond")]))
@ -1573,7 +1582,12 @@
answers) answers)
(define stupid-internal-definition-syntax1 (define stupid-internal-definition-syntax1
(mk-list-box 'framework:square-bracket:letrec "Letrec" values get-new-letrec-keyword)) (mk-list-box 'framework:square-bracket:letrec "Letrec" values (get-new-simple-keyword "Letrec")))
(define stupid-internal-definition-syntax3
(mk-list-box 'framework:square-bracket:local
"Local"
values
(get-new-simple-keyword "Local")))
(define stupid-internal-definition-syntax2 (define stupid-internal-definition-syntax2
(mk-list-box 'framework:square-bracket:cond/offset (mk-list-box 'framework:square-bracket:cond/offset
"Cond" "Cond"

5
collects/tests/framework/keys.ss
View File

@ -156,7 +156,10 @@
(build-open-bracket-spec "(let loop (" 11 #\[) (build-open-bracket-spec "(let loop (" 11 #\[)
(build-open-bracket-spec "(case x " 8 #\[) (build-open-bracket-spec "(case x " 8 #\[)
(build-open-bracket-spec "(case x [" 9 #\() (build-open-bracket-spec "(case x [" 9 #\()
(build-open-bracket-spec "(let ([])(" 10 #\())) (build-open-bracket-spec "(let ([])(" 10 #\()
(build-open-bracket-spec "(local " 7 #\[)
(build-open-bracket-spec "(local []" 9 #\()
))
(send-sexp-to-mred `(send (make-object frame:basic% "dummy to trick frame group") show #t)) (send-sexp-to-mred `(send (make-object frame:basic% "dummy to trick frame group") show #t))