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

fix for/fold indentation

Browse Source 
inspired by Greg's RacketCon talk

also, Rackety
This commit is contained in:
Robby Findler 2014-09-28 15:16:17 -05:00
parent a41cc0c3c0
commit c03c02bccb
3 changed files with 337 additions and 325 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -177,7 +177,7 @@
(let () (let ()
(define base-fors (define base-fors
'(for for/list for/hash for/hasheq for/hasheqv for/and for/or '(for for/list for/hash for/hasheq for/hasheqv for/and for/or
for/lists for/first for/last for/fold for/vector for/flvector for/lists for/first for/last for/vector for/flvector
for/sum for/product for/set)) for/sum for/product for/set))
(define untyped-fors (define untyped-fors
(append base-fors (append base-fors
@ -363,6 +363,8 @@
(preferences:set-default 'framework:fixup-open-parens #f boolean?) (preferences:set-default 'framework:fixup-open-parens #f boolean?)
(preferences:set-default 'framework:paren-match #t boolean?) (preferences:set-default 'framework:paren-match #t boolean?)
(let ([defaults-ht (make-hasheq)]) (let ([defaults-ht (make-hasheq)])
(for-each (λ (x) (hash-set! defaults-ht x 'for/fold))
'(for/fold for/fold: for*/fold for*/fold:))
(for-each (λ (x) (hash-set! defaults-ht x 'define)) (for-each (λ (x) (hash-set! defaults-ht x 'define))
'(struct '(struct
local local
@ -441,21 +443,25 @@
type-case)) type-case))
(preferences:set-default (preferences:set-default
'framework:tabify 'framework:tabify
(list defaults-ht #rx"^begin" #rx"^def" #f) (list defaults-ht #rx"^begin" #rx"^def" #f #f)
(list/c hash? (or/c #f regexp?) (or/c #f regexp?) (or/c #f regexp?))) (list/c (hash/c symbol? (or/c 'for/fold 'define 'begin 'lambda) #:flat? #t)
(or/c #f regexp?) (or/c #f regexp?) (or/c #f regexp?) (or/c #f regexp?)))
(define old-style-pred? (listof (list/c symbol? symbol?))) (define old-style-pred? (listof (list/c symbol? symbol?)))
(define new-style-pred?
(list/c (listof (list/c symbol? symbol?)) ;; additions to defaults
(listof (list/c symbol? symbol?)))) ;; deletions
(define pref-pred? (define pref-pred?
(list/c (or/c (or/c (list/c new-style-pred?
;; old-style prefs (or/c regexp? #f)
old-style-pred? (or/c regexp? #f)
(or/c regexp? #f)
;; new-style prefs (or/c regexp? #f))
(list/c (listof (list/c symbol? symbol?)) ;; additions to defaults (list/c (or/c old-style-pred? new-style-pred?)
(listof (list/c symbol? symbol?)))) ;; deletions (or/c regexp? #f)
(or/c regexp? #f)
(or/c regexp? #f) (or/c regexp? #f))))
(or/c regexp? #f)
(or/c regexp? #f)))
(define (ht->addition/deletion-lists ht) (define (ht->addition/deletion-lists ht)
(define additions '()) (define additions '())
@ -483,6 +489,11 @@
(hash-set! ht k v)) (hash-set! ht k v))
ht) ht)
(define (pad-to len lst)
(cond
[(null? lst) (build-list len (λ (x) #f))]
[else (cons (car lst) (pad-to (- len 1) (cdr lst)))]))
(preferences:set-un/marshall (preferences:set-un/marshall
'framework:tabify 'framework:tabify
(λ (t) (cons (ht->addition/deletion-lists (list-ref t 0)) (λ (t) (cons (ht->addition/deletion-lists (list-ref t 0))
@ -503,7 +514,7 @@
(cdr l))] (cdr l))]
[else [else
(cons (addition/deletion-lists->ht (list-ref l 0)) (cons (addition/deletion-lists->ht (list-ref l 0))
(cdr l))]))))) (pad-to 4 (cdr l)))])))))
(preferences:set-default 'framework:autosave-delay 30 number?) (preferences:set-default 'framework:autosave-delay 30 number?)

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

@ -522,199 +522,187 @@
(define/public (tabify-on-return?) #t) (define/public (tabify-on-return?) #t)
(define/public (tabify [pos (get-start-position)]) (define/public (tabify [pos (get-start-position)])
(unless (is-stopped?) (unless (is-stopped?)
(let* ([tabify-prefs (preferences:get 'framework:tabify)] (define tabify-prefs (preferences:get 'framework:tabify))
[last-pos (last-position)] (define last-pos (last-position))
[para (position-paragraph pos)] (define para (position-paragraph pos))
[is-tabbable? (and (> para 0) (define is-tabbable?
(not (memq (classify-position (- (paragraph-start-position para) 1)) (and (> para 0)
'(comment string error))))] (not (memq (classify-position (- (paragraph-start-position para) 1))
[end (if is-tabbable? (paragraph-start-position para) 0)] '(comment string error)))))
[limit (get-limit pos)] (define end (if is-tabbable? (paragraph-start-position para) 0))
;; "contains" is the start of the initial sub-S-exp (define limit (get-limit pos))
;; in the S-exp that contains "pos". If pos is outside
;; all S-exps, this will be the start of the initial ;; "contains" is the start of the initial sub-S-exp
;; S-exp ;; in the S-exp that contains "pos". If pos is outside
[contains ;; all S-exps, this will be the start of the initial
(if is-tabbable? ;; S-exp
(backward-containing-sexp end limit) (define contains
#f)] (if is-tabbable?
[contain-para (and contains (backward-containing-sexp end limit)
(position-paragraph contains))] #f))
;; "last" is the start of the S-exp just before "pos" (define contain-para (and contains
[last (position-paragraph contains)))
(if contains
(let ([p (get-backward-sexp end)]) ;; last is the start of the S-exp just before "pos"
(if (and p (p . >= . limit)) (define last
p (if contains
(backward-match end limit))) (let ([p (get-backward-sexp end)])
#f)] (if (and p (p . >= . limit))
[last-para (and last p
(position-paragraph last))]) (backward-match end limit)))
(define sizing-dc (or (get-dc) (make-object bitmap-dc% (make-bitmap 1 1)))) #f))
(letrec (define last-para (and last (position-paragraph last)))
([find-offset
(λ (start-pos) ;; last2 is the start of the S-exp just before the one before "pos"
(define tab-char? #f) (define last2
(define end-pos (if contains
(let loop ([p start-pos]) (let ([p (get-backward-sexp last)])
(let ([c (get-character p)]) (if (and p (p . >= . limit))
(cond p
[(char=? c #\tab) (backward-match last limit)))
(set! tab-char? #t) #f))
(loop (add1 p))]
[(char=? c #\newline) (define sizing-dc (or (get-dc) (make-object bitmap-dc% (make-bitmap 1 1))))
p] (define (find-offset start-pos)
[(char-whitespace? c) (define tab-char? #f)
(loop (add1 p))] (define end-pos
[else (let loop ([p start-pos])
p])))) (let ([c (get-character p)])
(define start-x (box 0)) (cond
(define end-x (box 0)) [(char=? c #\tab)
(position-location start-pos start-x #f #t #t) (set! tab-char? #t)
(position-location end-pos end-x #f #t #t) (loop (add1 p))]
(define-values (w _1 _2 _3) [(char=? c #\newline)
(send sizing-dc get-text-extent "x" p]
(send (send (get-style-list) [(char-whitespace? c)
find-named-style "Standard") (loop (add1 p))]
get-font))) [else
(values (inexact->exact (floor (/ (- (unbox end-x) (unbox start-x)) w))) p]))))
end-pos (define start-x (box 0))
tab-char?))] (define end-x (box 0))
(position-location start-pos start-x #f #t #t)
[visual-offset (position-location end-pos end-x #f #t #t)
(λ (pos) (define-values (w _1 _2 _3)
(let loop ([p (sub1 pos)]) (send sizing-dc get-text-extent "x"
(if (= p -1) (send (send (get-style-list)
0 find-named-style "Standard")
(let ([c (get-character p)]) get-font)))
(cond (values (inexact->exact (floor (/ (- (unbox end-x) (unbox start-x)) w)))
[(char=? c #\null) 0] end-pos
[(char=? c #\tab) tab-char?))
(let ([o (loop (sub1 p))])
(+ o (- 8 (modulo o 8))))] (define (visual-offset pos)
[(char=? c #\newline) 0] (let loop ([p (sub1 pos)])
[else (add1 (loop (sub1 p)))])))))] (if (= p -1)
[do-indent 0
(λ (amt) (let ([c (get-character p)])
(define pos-start end) (cond
(define-values (gwidth curr-offset tab-char?) (find-offset pos-start)) [(char=? c #\null) 0]
(unless (and (not tab-char?) (= amt (- curr-offset pos-start))) [(char=? c #\tab)
(delete pos-start curr-offset) (let ([o (loop (sub1 p))])
(insert (make-string amt #\space) pos-start)))] (+ o (- 8 (modulo o 8))))]
[get-proc [(char=? c #\newline) 0]
(λ () [else (add1 (loop (sub1 p)))])))))
(let ([id-end (get-forward-sexp contains)])
(and (and id-end (> id-end contains)) (define (do-indent amt)
(let* ([text (get-text contains id-end)]) (define pos-start end)
(or (get-keyword-type text tabify-prefs) (define-values (gwidth curr-offset tab-char?) (find-offset pos-start))
'other)))))] (unless (and (not tab-char?) (= amt (- curr-offset pos-start)))
[procedure-indent (delete pos-start curr-offset)
(λ () (insert (make-string amt #\space) pos-start)))
(case (get-proc) (define (get-proc)
[(begin define) 1] (define id-end (get-forward-sexp contains))
[(lambda) 3] (and (and id-end (> id-end contains))
[else 0]))] (let ([text (get-text contains id-end)])
[special-check (or (get-keyword-type text tabify-prefs)
(λ () 'other))))
(let* ([proc-name (get-proc)]) (define (procedure-indent)
(or (eq? proc-name 'define) (case (get-proc)
(eq? proc-name 'lambda))))] [(begin define) 1]
[curley-brace-sexp? [(lambda) 3]
(λ () [else 0]))
(define up-p (find-up-sexp pos)) (define (define-or-lambda-style?)
(and up-p (define proc-name (get-proc))
(equal? #\{ (get-character up-p))))] (or (equal? proc-name 'define)
(equal? proc-name 'lambda)))
[indent-first-arg (λ (start) (define (for/fold-style?)
(define-values (gwidth curr-offset tab-char?) (find-offset start)) (define proc-name (get-proc))
gwidth)]) (equal? proc-name 'for/fold))
(when (and is-tabbable?
(not (char=? (get-character (sub1 end)) (define (indent-first-arg start)
#\newline))) (define-values (gwidth curr-offset tab-char?) (find-offset start))
(insert #\newline (paragraph-start-position para))) gwidth)
(cond
[(not is-tabbable?) (when (and is-tabbable?
(when (= para 0) (not (char=? (get-character (sub1 end))
(do-indent 0))] #\newline)))
[(let-values ([(gwidth real-start tab-char?) (find-offset end)]) (insert #\newline (paragraph-start-position para)))
(and (<= (+ 3 real-start) (last-position))
(string=? ";;;" (cond
(get-text real-start [(not is-tabbable?)
(+ 2 real-start))))) (when (= para 0)
(void)] (do-indent 0))]
[(not contains) [(let-values ([(gwidth real-start tab-char?) (find-offset end)])
;; Something went wrong matching. Should we get here? (and (<= (+ 3 real-start) (last-position))
(do-indent 0)] (string=? ";;;"
;; disable this to accommodate PLAI programs; (get-text real-start
;; return to this when a #lang capability is set up. (+ 2 real-start)))))
#; (void)]
[(curley-brace-sexp?) [(not contains)
;; when we are directly inside an sexp that uses {}s, ;; Something went wrong matching. Should we get here?
;; we indent in a more C-like fashion (to help Scribble) (do-indent 0)]
(define first-curley (find-up-sexp pos)) [(not last)
(define containing-curleys ;; We can't find a match backward from pos,
(let loop ([pos first-curley]) ;; but we seem to be inside an S-exp, so
(let ([next (find-up-sexp pos)]) ;; go "up" an S-exp, and move forward past
(if (and next ;; the associated paren
(equal? (get-character next) #\{)) (define enclosing (find-up-sexp pos))
(+ (loop next) 1) (if enclosing
1)))) (do-indent (+ (visual-offset enclosing) 1))
(define close-first-curley (get-forward-sexp first-curley)) (do-indent 0))]
(define para (position-paragraph pos)) [(= contains last)
(when (and close-first-curley ;; this is the first expression in the define
(<= (paragraph-start-position para) (do-indent (+ (visual-offset contains)
close-first-curley (procedure-indent)))]
(paragraph-end-position para))) [(and (for/fold-style?)
(set! containing-curleys (max 0 (- containing-curleys 1)))) (= contains last2))
(do-indent (* containing-curleys 2))] (do-indent (- last (paragraph-start-position last-para)))]
[(not last) [(or (define-or-lambda-style?)
;; We can't find a match backward from pos, (for/fold-style?))
;; but we seem to be inside an S-exp, so ;; In case of "define", etc., ignore the position of last
;; go "up" an S-exp, and move forward past ;; and just indent under the "define"
;; the associated paren (do-indent (add1 (visual-offset contains)))]
(let ([enclosing (find-up-sexp pos)]) [(= contain-para last-para)
(if enclosing ;; So far, the S-exp containing "pos" was all on
(do-indent (+ (visual-offset enclosing) 1)) ;; one line (possibly not counting the opening paren),
(do-indent 0)))] ;; so indent to follow the first S-exp's end
[(= contains last) ;; unless there are just two sexps and the second is an ellipsis.
;; There's only one S-expr in the S-expr ;; in that case, we just ignore the ellipsis
;; containing "pos" (define id-end (get-forward-sexp contains))
(do-indent (+ (visual-offset contains) (define name-length
(procedure-indent)))] (if id-end
[(special-check) (- id-end contains)
;; In case of "define", etc., ignore the position of last 0))
;; and just indent under the "define" (cond
(do-indent (add1 (visual-offset contains)))] [(second-sexp-is-ellipsis? contains)
[(= contain-para last-para) (do-indent (visual-offset contains))]
;; So far, the S-exp containing "pos" was all on [(not (find-up-sexp pos))
;; one line (possibly not counting the opening paren), (do-indent (visual-offset contains))]
;; so indent to follow the first S-exp's end [else
;; unless there are just two sexps and the second is an ellipsis. (do-indent (+ (visual-offset contains)
;; in that case, we just ignore the ellipsis name-length
(let ([name-length (let ([id-end (get-forward-sexp contains)]) (indent-first-arg (+ contains
(if id-end name-length))))])]
(- id-end contains) [else
0))]) ;; No particular special case, so indent to match first
(cond ;; S-expr that starts on the previous line
[(second-sexp-is-ellipsis? contains) (let loop ([last last][last-para last-para])
(do-indent (visual-offset contains))] (let* ([next-to-last (backward-match last limit)]
[(not (find-up-sexp pos)) [next-to-last-para (and next-to-last
(do-indent (visual-offset contains))] (position-paragraph next-to-last))])
[else (if (equal? last-para next-to-last-para)
(do-indent (+ (visual-offset contains) (loop next-to-last next-to-last-para)
name-length (do-indent (visual-offset last)))))])))
(indent-first-arg (+ contains
name-length))))]))]
[else
;; No particular special case, so indent to match first
;; S-expr that start on the previous line
(let loop ([last last][last-para last-para])
(let* ([next-to-last (backward-match last limit)]
[next-to-last-para (and next-to-last
(position-paragraph next-to-last))])
(if (equal? last-para next-to-last-para)
(loop next-to-last next-to-last-para)
(do-indent (visual-offset last)))))])))))
;; returns #t if `contains' is at a position on a line with an sexp, an ellipsis and nothing else. ;; returns #t if `contains' is at a position on a line with an sexp, an ellipsis and nothing else.
;; otherwise, returns #f ;; otherwise, returns #f
@ -1341,22 +1329,24 @@
(|{| |}|)))))) (|{| |}|))))))
;; get-keyword-type : string (list ht regexp regexp regexp) ;; get-keyword-type : string (list ht regexp regexp regexp)
;; -> (union #f 'lambda 'define 'begin) ;; -> (or/c #f 'lambda 'define 'begin 'for/fold)
(define (get-keyword-type text pref) (define (get-keyword-type text pref)
(let* ([ht (car pref)] (define ht (car pref))
[beg-reg (cadr pref)] (define beg-reg (list-ref pref 1))
[def-reg (caddr pref)] (define def-reg (list-ref pref 2))
[lam-reg (cadddr pref)]) (define lam-reg (list-ref pref 3))
(hash-ref (define for/fold-reg (list-ref pref 4))
ht (hash-ref
(with-handlers ((exn:fail:read? (λ (x) #f))) ht
(read (open-input-string text))) (with-handlers ((exn:fail:read? (λ (x) #f)))
(λ () (read (open-input-string text)))
(cond (λ ()
[(and beg-reg (regexp-match beg-reg text)) 'begin] (cond
[(and def-reg (regexp-match def-reg text)) 'define] [(and beg-reg (regexp-match beg-reg text)) 'begin]
[(and lam-reg (regexp-match lam-reg text)) 'lambda] [(and def-reg (regexp-match def-reg text)) 'define]
[else #f]))))) [(and lam-reg (regexp-match lam-reg text)) 'lambda]
[(and for/fold-reg (regexp-match for/fold-reg text)) 'for/fold]
[else #f]))))
;; in-position? : text (list symbol) -> boolean ;; in-position? : text (list symbol) -> boolean
@ -2104,88 +2094,84 @@
(define (make-indenting-prefs-panel p) (define (make-indenting-prefs-panel p)
(define get-keywords (define get-keywords
(λ (hash-table) (λ (hash-table)
(letrec ([all-keywords (hash-map hash-table list)] (define all-keywords (hash-map hash-table list))
[pick-out (λ (wanted in out) (define (pick-out wanted in out)
(cond (cond
[(null? in) (sort out string<=?)] [(null? in) (sort out string<?)]
[else (if (eq? wanted (cadr (car in))) [else (if (eq? wanted (cadr (car in)))
(pick-out wanted (cdr in) (pick-out wanted (cdr in)
(cons (format "~s" (car (car in))) out)) (cons (format "~s" (car (car in))) out))
(pick-out wanted (cdr in) out))]))]) (pick-out wanted (cdr in) out))]))
(values (pick-out 'begin all-keywords null) (values (pick-out 'begin all-keywords null)
(pick-out 'define all-keywords null) (pick-out 'define all-keywords null)
(pick-out 'lambda all-keywords null))))) (pick-out 'lambda all-keywords null)
(define-values (begin-keywords define-keywords lambda-keywords) (pick-out 'for/fold all-keywords null))))
(define-values (begin-keywords define-keywords lambda-keywords for/fold-keywords)
(get-keywords (car (preferences:get 'framework:tabify)))) (get-keywords (car (preferences:get 'framework:tabify))))
(define add-button-callback (define ((add-button-callback keyword-type keyword-symbol list-box) button command)
(λ (keyword-type keyword-symbol list-box) (define new-one
(λ (button command) (keymap:call/text-keymap-initializer
(let ([new-one (λ ()
(keymap:call/text-keymap-initializer (get-text-from-user
(λ () (format (string-constant enter-new-keyword) keyword-type)
(get-text-from-user (format (string-constant x-keyword) keyword-type)))))
(format (string-constant enter-new-keyword) keyword-type) (when new-one
(format (string-constant x-keyword) keyword-type))))]) (let ([parsed (with-handlers ((exn:fail:read? (λ (x) #f)))
(when new-one (read (open-input-string new-one)))])
(let ([parsed (with-handlers ((exn:fail:read? (λ (x) #f))) (cond
(read (open-input-string new-one)))]) [(and (symbol? parsed)
(cond (hash-ref (car (preferences:get 'framework:tabify))
[(and (symbol? parsed) parsed
(hash-ref (car (preferences:get 'framework:tabify)) (λ () #f)))
parsed (message-box (string-constant error)
(λ () #f))) (format (string-constant already-used-keyword) parsed))]
(message-box (string-constant error) [(symbol? parsed)
(format (string-constant already-used-keyword) parsed))] (let* ([pref (preferences:get 'framework:tabify)]
[(symbol? parsed) [ht (car pref)])
(let* ([pref (preferences:get 'framework:tabify)] (hash-set! ht parsed keyword-symbol)
[ht (car pref)]) (preferences:set 'framework:tabify pref)
(hash-set! ht parsed keyword-symbol) (update-list-boxes ht))]
(preferences:set 'framework:tabify pref) [else (message-box
(update-list-boxes ht))] (string-constant error)
[else (message-box (format (string-constant expected-a-symbol) new-one))]))))
(string-constant error) (define ((delete-callback list-box) button command)
(format (string-constant expected-a-symbol) new-one))]))))))) (define selections (send list-box get-selections))
(define delete-callback (define symbols
(λ (list-box) (map (λ (x) (read (open-input-string (send list-box get-string x)))) selections))
(λ (button command) (for-each (λ (x) (send list-box delete x)) (reverse selections))
(define selections (send list-box get-selections)) (define pref (preferences:get 'framework:tabify))
(define symbols (define ht (car pref))
(map (λ (x) (read (open-input-string (send list-box get-string x)))) selections)) (for-each (λ (x) (hash-remove! ht x)) symbols)
(for-each (λ (x) (send list-box delete x)) (reverse selections)) (preferences:set 'framework:tabify pref))
(define pref (preferences:get 'framework:tabify))
(define ht (car pref))
(for-each (λ (x) (hash-remove! ht x)) symbols)
(preferences:set 'framework:tabify pref))))
(define main-panel (make-object horizontal-panel% p)) (define main-panel (make-object horizontal-panel% p))
(define make-column (define (make-column string symbol keywords bang-regexp)
(λ (string symbol keywords bang-regexp) (define vert (make-object vertical-panel% main-panel))
(let* ([vert (make-object vertical-panel% main-panel)] (make-object message% (format (string-constant x-like-keywords) string) vert)
[_ (make-object message% (format (string-constant x-like-keywords) string) vert)] (define box (make-object list-box% #f keywords vert void '(multiple)))
[box (make-object list-box% #f keywords vert void '(multiple))] (define button-panel (make-object horizontal-panel% vert))
[button-panel (make-object horizontal-panel% vert)] (define text (new text-field%
[text (new text-field% (label (string-constant indenting-prefs-extra-regexp))
(label (string-constant indenting-prefs-extra-regexp)) (callback (λ (tf evt)
(callback (λ (tf evt) (define str (send tf get-value))
(let ([str (send tf get-value)]) (cond
(cond [(equal? str "")
[(equal? str "") (bang-regexp #f)]
(bang-regexp #f)] [else
[else (with-handlers ([exn:fail?
(with-handlers ([exn:fail? (λ (x)
(λ (x) (color-yellow (send tf get-editor)))])
(color-yellow (send tf get-editor)))]) (bang-regexp (regexp str))
(bang-regexp (regexp str)) (clear-color (send tf get-editor)))])))
(clear-color (send tf get-editor)))])))) (parent vert)))
(parent vert))] (define add-button (make-object button% (string-constant add-keyword)
[add-button (make-object button% (string-constant add-keyword) button-panel (add-button-callback string symbol box)))
button-panel (add-button-callback string symbol box))] (define delete-button (make-object button% (string-constant remove-keyword)
[delete-button (make-object button% (string-constant remove-keyword) button-panel (delete-callback box)))
button-panel (delete-callback box))]) (send* button-panel
(send* button-panel (set-alignment 'center 'center)
(set-alignment 'center 'center) (stretchable-height #f))
(stretchable-height #f)) (send add-button min-width (send delete-button get-width))
(send add-button min-width (send delete-button get-width)) (values box text))
(values box text))))
(define (color-yellow text) (define (color-yellow text)
(let ([sd (make-object style-delta%)]) (let ([sd (make-object style-delta%)])
(send sd set-delta-background "yellow") (send sd set-delta-background "yellow")
@ -2217,21 +2203,29 @@
'lambda 'lambda
lambda-keywords lambda-keywords
(λ (x) (update-pref 3 x)))) (λ (x) (update-pref 3 x))))
(define-values (for/fold-list-box for/fold-regexp-text)
(make-column "For/fold"
'for/fold
for/fold-keywords
(λ (x) (update-pref 4 x))))
(define (update-list-boxes hash-table) (define (update-list-boxes hash-table)
(let-values ([(begin-keywords define-keywords lambda-keywords) (get-keywords hash-table)] (define-values (begin-keywords define-keywords lambda-keywords for/fold-keywords)
[(reset) (λ (list-box keywords) (get-keywords hash-table))
(send list-box clear) (define (reset list-box keywords)
(for-each (λ (x) (send list-box append x)) keywords))]) (send list-box clear)
(reset begin-list-box begin-keywords) (for-each (λ (x) (send list-box append x)) keywords))
(reset define-list-box define-keywords) (reset begin-list-box begin-keywords)
(reset lambda-list-box lambda-keywords) (reset define-list-box define-keywords)
#t)) (reset lambda-list-box lambda-keywords)
(reset for/fold-list-box for/fold-keywords)
#t)
(define update-gui (define update-gui
(λ (pref) (λ (pref)
(update-list-boxes (car pref)) (update-list-boxes (car pref))
(send begin-regexp-text set-value (or (object-name (cadr pref)) "")) (send begin-regexp-text set-value (or (object-name (list-ref pref 1)) ""))
(send define-regexp-text set-value (or (object-name (caddr pref)) "")) (send define-regexp-text set-value (or (object-name (list-ref pref 2)) ""))
(send lambda-regexp-text set-value (or (object-name (cadddr pref)) "")))) (send lambda-regexp-text set-value (or (object-name (list-ref pref 3)) ""))
(send for/fold-regexp-text set-value (or (object-name (list-ref pref 4)) ""))))
(preferences:add-callback 'framework:tabify (λ (p v) (update-gui v))) (preferences:add-callback 'framework:tabify (λ (p v) (update-gui v)))
(update-gui (preferences:get 'framework:tabify)) (update-gui (preferences:get 'framework:tabify))
main-panel) main-panel)

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

@ -31,9 +31,15 @@
(test-text-balanced? 8 "{foo} ((bar) [5.9])" 0 #f #t) (test-text-balanced? 8 "{foo} ((bar) [5.9])" 0 #f #t)
(test-text-balanced? 9 "#(1 2 . 3)" 0 #f #t) (test-text-balanced? 9 "#(1 2 . 3)" 0 #f #t)
(define (test-indentation which before after) (define-syntax (test-indentation stx)
(syntax-case stx ()
[(_ . args)
(with-syntax ([line (syntax-line stx)])
#'(test-indentation/proc line . args))]))
(define (test-indentation/proc line before after)
(test (test
(string->symbol (format "racket:test-indentation-~a" which)) (string->symbol (format "racket:test-indentation-line-~a" line))
(λ (x) (equal? x after)) (λ (x) (equal? x after))
(λ () (λ ()
(queue-sexp-to-mred (queue-sexp-to-mred
@ -45,16 +51,17 @@
(send t tabify-all) (send t tabify-all)
(send t get-text)))))) (send t get-text))))))
(test-indentation 1 "a" "a") (test-indentation "a" "a")
(test-indentation 2 "(a\n b)" "(a\n b)") (test-indentation "(a\n b)" "(a\n b)")
(test-indentation 3 "(a\nb)" "(a\n b)") (test-indentation "(a\nb)" "(a\n b)")
(test-indentation 3 "(a b\nc)" "(a b\n c)") (test-indentation "(a b\nc)" "(a b\n c)")
(test-indentation 3 "(a ...\nb)" "(a ...\n b)") (test-indentation "(a ...\nb)" "(a ...\n b)")
(test-indentation 4 "(lambda (x)\nb)" "(lambda (x)\n b)") (test-indentation "(lambda (x)\nb)" "(lambda (x)\n b)")
(test-indentation 5 "(lambdaa (x)\nb)" "(lambdaa (x)\n b)") (test-indentation "(lambdaa (x)\nb)" "(lambdaa (x)\n b)")
(test-indentation 6 (test-indentation "(define x\n (let/ec return\n (when 1\n (when 2\n\t\t 3))\n 2))"
"(define x\n (let/ec return\n (when 1\n (when 2\n\t\t 3))\n 2))"
"(define x\n (let/ec return\n (when 1\n (when 2\n 3))\n 2))") "(define x\n (let/ec return\n (when 1\n (when 2\n 3))\n 2))")
(test-indentation "(for/fold ([x 1])\n([y 2])\n3\n4)"
"(for/fold ([x 1])\n ([y 2])\n 3\n 4)")
(define (test-magic-square-bracket which before after) (define (test-magic-square-bracket which before after)
(test (test