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

improve magic opening square bracket for for/fold

Browse Source
This commit is contained in:
Robby Findler 2014-09-29 08:40:51 -05:00
parent 34d7c22740
commit 144fdb2a18
3 changed files with 77 additions and 62 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
pkgs/gui-pkgs/gui-lib/framework/private/main.rkt
View File

@ -169,7 +169,6 @@
(define deletions (list-ref marshed 1)) (define deletions (list-ref marshed 1))
(append additions (remove* deletions defaults))])))) (append additions (remove* deletions defaults))]))))
(set-square-bracket-nonum-pref 'framework:square-bracket:local (set-square-bracket-nonum-pref 'framework:square-bracket:local
'("local")) '("local"))
@ -189,9 +188,10 @@
untyped-fors))) untyped-fors)))
all-fors)) all-fors))
(define for/folds '("for/fold" "for/fold:" "for*/fold" "for*/fold:"))
(set-square-bracket-nonum-pref 'framework:square-bracket:letrec (set-square-bracket-nonum-pref 'framework:square-bracket:letrec
(append (map symbol->string all-fors) (append (map symbol->string all-fors)
'("for/fold" "for/fold:" "for*/fold" "for*/fold:") for/folds
'("let" '("let"
"let*" "let-values" "let*-values" "let*" "let-values" "let*-values"
"let-syntax" "let-struct" "let-syntaxes" "let-syntax" "let-struct" "let-syntaxes"
@ -201,6 +201,8 @@
"parameterize" "parameterize*" "parameterize" "parameterize*"
"with-syntax" "with-handlers"))) "with-syntax" "with-handlers")))
(set-square-bracket-nonum-pref 'framework:square-bracket:for/fold for/folds)
(preferences:set-default 'framework:white-on-black? #f boolean?) (preferences:set-default 'framework:white-on-black? #f boolean?)
(preferences:set-default 'framework:case-sensitive-search? (preferences:set-default 'framework:case-sensitive-search?

131
pkgs/gui-pkgs/gui-lib/framework/private/racket.rkt
View File

@ -1772,7 +1772,8 @@
(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)]
[letrec-like-forms (preferences:get 'framework:square-bracket:letrec)]) [letrec-like-forms (preferences:get 'framework:square-bracket:letrec)]
[for/fold-like-forms (preferences:get 'framework:square-bracket:for/fold)])
(send text begin-edit-sequence #f #f) (send text begin-edit-sequence #f #f)
(if (and (send text get-overwrite-mode) (= start-pos end-pos)) (if (and (send text get-overwrite-mode) (= start-pos end-pos))
(send text insert "[" start-pos (add1 start-pos) #f) (send text insert "[" start-pos (add1 start-pos) #f)
@ -1810,54 +1811,63 @@
[(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.
(let ([b-w-p-char (send text get-character (- before-whitespace-pos 1))]) (define b-w-p-char (send text get-character (- before-whitespace-pos 1)))
(cond (cond
[(equal? b-w-p-char #\() [(equal? b-w-p-char #\()
(let* ([second-before-whitespace-pos (send text skip-whitespace (define second-before-whitespace-pos (send text skip-whitespace
(- before-whitespace-pos 1) (- before-whitespace-pos 1)
'backward 'backward
#t)] #t))
[second-backwards-match (send text backward-match (define second-backwards-match (send text backward-match
second-before-whitespace-pos second-before-whitespace-pos
0)]) 0))
(cond (cond
[(not second-backwards-match) [(not second-backwards-match)
(change-to 3 #\()] (change-to 3 #\()]
[(and (beginning-of-sequence? text second-backwards-match) [(and (beginning-of-sequence? text second-backwards-match)
(ormap (λ (x) (text-between-equal? x (ormap (λ (x) (text-between-equal? x
text text
second-backwards-match
second-before-whitespace-pos))
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
(define second-before-whitespace-pos2 (send text skip-whitespace
second-backwards-match second-backwards-match
second-before-whitespace-pos)) 'backward
letrec-like-forms)) #t))
;; we found a let<mumble> keyword, so we get a square bracket (define second-backwards-match2 (send text backward-match
(void)] second-before-whitespace-pos2
[else 0))
;; go back one more sexp in the same row, looking for `let loop' pattern (cond
(let* ([second-before-whitespace-pos2 (send text skip-whitespace [(and second-backwards-match2
second-backwards-match (ormap (λ (x)
'backward (text-between-equal? x
#t)] text
[second-backwards-match2 (send text backward-match second-backwards-match2
second-before-whitespace-pos2 second-before-whitespace-pos2))
0)]) for/fold-like-forms))
(cond ;; found a for/fold-like form, so we keep the [
[(and second-backwards-match2 (void)]
(member (send text classify-position second-backwards-match) [(and second-backwards-match2
;;; otherwise, this isn't a `let loop', (member (send text classify-position second-backwards-match)
;;; it is a regular let ;;; otherwise, this isn't a `let loop',
'(symbol keyword)) ;;; it is a regular let
(member "let" letrec-like-forms) '(symbol keyword))
(text-between-equal? "let" (member "let" letrec-like-forms)
text (text-between-equal? "let"
second-backwards-match2 text
second-before-whitespace-pos2)) second-backwards-match2
;; found the `(let loop (' so we keep the [ second-before-whitespace-pos2))
(void)] ;; found the `(let loop (' so we keep the [
[else (void)]
;; otherwise, round. [else
(change-to 4 #\()]))]))] ;; otherwise, round.
[else (change-to 4 #\()])])]
(change-to 5 #\()]))] [else
(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)
@ -2063,18 +2073,19 @@
(send f show #t) (send f show #t)
answers) answers)
(define stupid-internal-definition-syntax1 (mk-list-box 'framework:square-bracket:letrec "Letrec" values (get-new-simple-keyword "Letrec"))
(mk-list-box 'framework:square-bracket:letrec "Letrec" values (get-new-simple-keyword "Letrec"))) (mk-list-box 'framework:square-bracket:local
(define stupid-internal-definition-syntax3 "Local"
(mk-list-box 'framework:square-bracket:local values
"Local" (get-new-simple-keyword "Local"))
values (mk-list-box 'framework:square-bracket:for/fold
(get-new-simple-keyword "Local"))) "For/fold"
(define stupid-internal-definition-syntax2 values
(mk-list-box 'framework:square-bracket:cond/offset (get-new-simple-keyword "For/fold"))
"Cond" (mk-list-box 'framework:square-bracket:cond/offset
(λ (l) (format "~a (~a)" (car l) (cadr l))) "Cond"
get-new-cond-keyword)) (λ (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]

2
pkgs/gui-pkgs/gui-test/framework/tests/racket.rkt
View File

@ -100,6 +100,8 @@
(test-magic-square-bracket 'local1 "(local " "(local [") (test-magic-square-bracket 'local1 "(local " "(local [")
(test-magic-square-bracket 'local2 "(local [" "(local [(") (test-magic-square-bracket 'local2 "(local [" "(local [(")
(test-magic-square-bracket 'local2 "(local [(define x 1)] " "(local [(define x 1)] (") (test-magic-square-bracket 'local2 "(local [(define x 1)] " "(local [(define x 1)] (")
(test-magic-square-bracket 'for/fold1 "(for/fold (" "(for/fold ([")
(test-magic-square-bracket 'for/fold2 "(for/fold ([x 1]) (" "(for/fold ([x 1]) ([")
(define (test-message-send/proc line before expected pos msg (define (test-message-send/proc line before expected pos msg