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

bring down below 102 columns

Browse Source 
original commit: 735c465eff1bd0a1c0b845406c5ba20b4e08dee4
This commit is contained in:
Robby Findler 2013-07-06 10:38:13 -05:00
parent 6546d4c781
commit 95f271deff
1 changed files with 51 additions and 37 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -298,7 +298,8 @@
(comment ,(make-object color% 194 116 31) ,(string-constant scheme-mode-color-comment)) (comment ,(make-object color% 194 116 31) ,(string-constant scheme-mode-color-comment))
(string ,constant-green ,(string-constant scheme-mode-color-string)) (string ,constant-green ,(string-constant scheme-mode-color-string))
(constant ,constant-green ,(string-constant scheme-mode-color-constant)) (constant ,constant-green ,(string-constant scheme-mode-color-constant))
(hash-colon-keyword ,(make-object color% "brown") ,(string-constant scheme-mode-color-hash-colon-keyword)) (hash-colon-keyword ,(make-object color% "brown")
,(string-constant scheme-mode-color-hash-colon-keyword))
(parenthesis ,(make-object color% "brown") ,(string-constant scheme-mode-color-parenthesis)) (parenthesis ,(make-object color% "brown") ,(string-constant scheme-mode-color-parenthesis))
(error ,(make-object color% "red") ,(string-constant scheme-mode-color-error)) (error ,(make-object color% "red") ,(string-constant scheme-mode-color-error))
(other ,(make-object color% "black") ,(string-constant scheme-mode-color-other))))) (other ,(make-object color% "black") ,(string-constant scheme-mode-color-other)))))
@ -424,7 +425,8 @@
(send style-list find-named-style "Matching Parenthesis Style"))) (send style-list find-named-style "Matching Parenthesis Style")))
(define text-mixin (define text-mixin
(mixin (text:basic<%> mode:host-text<%> color:text<%> text:autocomplete<%> editor:keymap<%>) (-text<%>) (mixin (text:basic<%> mode:host-text<%> color:text<%> text:autocomplete<%> editor:keymap<%>)
(-text<%>)
(inherit begin-edit-sequence (inherit begin-edit-sequence
delete delete
end-edit-sequence end-edit-sequence
@ -522,7 +524,7 @@
[last-pos (last-position)] [last-pos (last-position)]
[para (position-paragraph pos)] [para (position-paragraph pos)]
[is-tabbable? (and (> para 0) [is-tabbable? (and (> para 0)
(not (memq (classify-position (sub1 (paragraph-start-position para))) (not (memq (classify-position (- (paragraph-start-position para) 1))
'(comment string error))))] '(comment string error))))]
[end (if is-tabbable? (paragraph-start-position para) 0)] [end (if is-tabbable? (paragraph-start-position para) 0)]
[limit (get-limit pos)] [limit (get-limit pos)]
@ -641,7 +643,9 @@
[(not contains) [(not contains)
;; Something went wrong matching. Should we get here? ;; Something went wrong matching. Should we get here?
(do-indent 0)] (do-indent 0)]
#; ;; disable this to accommodate PLAI programs; return to this when a #lang capability is set up. ;; disable this to accommodate PLAI programs;
;; return to this when a #lang capability is set up.
#;
[(curley-brace-sexp?) [(curley-brace-sexp?)
;; when we are directly inside an sexp that uses {}s, ;; when we are directly inside an sexp that uses {}s,
;; we indent in a more C-like fashion (to help Scribble) ;; we indent in a more C-like fashion (to help Scribble)
@ -656,7 +660,9 @@
(define close-first-curley (get-forward-sexp first-curley)) (define close-first-curley (get-forward-sexp first-curley))
(define para (position-paragraph pos)) (define para (position-paragraph pos))
(when (and close-first-curley (when (and close-first-curley
(<= (paragraph-start-position para) close-first-curley (paragraph-end-position para))) (<= (paragraph-start-position para)
close-first-curley
(paragraph-end-position para)))
(set! containing-curleys (max 0 (- containing-curleys 1)))) (set! containing-curleys (max 0 (- containing-curleys 1))))
(do-indent (* containing-curleys 2))] (do-indent (* containing-curleys 2))]
[(not last) [(not last)
@ -1305,13 +1311,14 @@
'framework:tabify 'framework:tabify
(lambda (k v) (set! tabify-pref v))) (lambda (k v) (set! tabify-pref v)))
(define/private (racket-lexer-wrapper in offset mode) (define/private (racket-lexer-wrapper in offset mode)
(let-values (((lexeme type paren start end backup-delta mode) (module-lexer/waived in offset mode))) (define-values (lexeme type paren start end backup-delta mode)
(module-lexer/waived in offset mode))
(cond (cond
((and (eq? type 'symbol) [(and (eq? type 'symbol)
(get-keyword-type lexeme tabify-pref)) (get-keyword-type lexeme tabify-pref))
(values lexeme 'keyword paren start end backup-delta mode)) (values lexeme 'keyword paren start end backup-delta mode)]
(else [else
(values lexeme type paren start end backup-delta mode))))) (values lexeme type paren start end backup-delta mode)]))
(define/override (put-file text sup directory default-name) (define/override (put-file text sup directory default-name)
(parameterize ([finder:default-extension "rkt"] (parameterize ([finder:default-extension "rkt"]
@ -1587,7 +1594,8 @@
(send text classify-position (send text get-start-position))) (send text classify-position (send text get-start-position)))
(cond (cond
; insert paren pair if it results valid parenthesis token... ; insert paren pair if it results valid parenthesis token...
[(member open-brace open-parens) (insert-brace-pair text open-brace close-brace 'parenthesis)] [(member open-brace open-parens)
(insert-brace-pair text open-brace close-brace 'parenthesis)]
; ASSUME: from here on, open-brace is either " or | ; ASSUME: from here on, open-brace is either " or |
[else [else
@ -1626,9 +1634,9 @@
[else (define selection-length (- end-position start-position)) [else (define selection-length (- end-position start-position))
(insert-brace-pair text "\" \"" "\" \"") (insert-brace-pair text "\" \"" "\" \"")
(define cur-position (send text get-start-position)) (define cur-position (send text get-start-position))
(send text set-position (- cur-position 1) (+ cur-position selection-length 1))]) (send text set-position
] (- cur-position 1)
)] (+ cur-position selection-length 1))])])]
[_ (insert-brace-pair text open-brace close-brace)]) ])])) [_ (insert-brace-pair text open-brace close-brace)]) ])]))
@ -1788,16 +1796,16 @@
(cond (cond
[backward-match [backward-match
;; there is an expression before this, at this layer ;; there is an expression before this, at this layer
(let* ([before-whitespace-pos2 (send text skip-whitespace backward-match 'backward #t)] (define before-whitespace-pos2
[backward-match2 (send text backward-match before-whitespace-pos2 0)]) (send text skip-whitespace backward-match 'backward #t))
(define backward-match2 (send text backward-match before-whitespace-pos2 0))
(cond (cond
[(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
;; otherwise, we switch to ( ;; otherwise, we switch to (
(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
;; pop out one layer and look for a keyword. ;; pop out one layer and look for a keyword.
@ -2017,7 +2025,9 @@
[parent f] [parent f]
[label #f])))) [label #f]))))
(define number-panel (new horizontal-panel% [parent f] [stretchable-height #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-label (new message%
[parent number-panel]
[label (string-constant skip-subexpressions)]))
(define number (define number
(keymap:call/text-keymap-initializer (keymap:call/text-keymap-initializer
(λ () (λ ()
@ -2045,7 +2055,8 @@
(send f show #f)) (send f show #f))
(define-values (ok-button cancel-button) (define-values (ok-button cancel-button)
(gui-utils:ok/cancel-buttons bp confirm-callback cancel-callback (string-constant ok) (string-constant cancel))) (gui-utils:ok/cancel-buttons bp confirm-callback cancel-callback
(string-constant ok) (string-constant cancel)))
(send tb focus) (send tb focus)
(send f show #t) (send f show #t)
answers) answers)
@ -2069,7 +2080,8 @@
[value (preferences:get 'framework:fixup-open-parens)] [value (preferences:get 'framework:fixup-open-parens)]
[callback [callback
(λ (x y) (λ (x y)
(preferences:set 'framework:fixup-open-parens (send check-box get-value)))])) (preferences:set 'framework:fixup-open-parens
(send check-box get-value)))]))
(preferences:add-callback (preferences:add-callback
'framework:fixup-open-parens 'framework:fixup-open-parens
(λ (p v) (λ (p v)
@ -2085,7 +2097,8 @@
(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) (cons (format "~s" (car (car in))) out)) (pick-out wanted (cdr in)
(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)
@ -2123,13 +2136,14 @@
(define delete-callback (define delete-callback
(λ (list-box) (λ (list-box)
(λ (button command) (λ (button command)
(let* ([selections (send list-box get-selections)] (define selections (send list-box get-selections))
[symbols (map (λ (x) (read (open-input-string (send list-box get-string x)))) selections)]) (define symbols
(map (λ (x) (read (open-input-string (send list-box get-string x)))) selections))
(for-each (λ (x) (send list-box delete x)) (reverse selections)) (for-each (λ (x) (send list-box delete x)) (reverse selections))
(let* ([pref (preferences:get 'framework:tabify)] (define pref (preferences:get 'framework:tabify))
[ht (car pref)]) (define ht (car pref))
(for-each (λ (x) (hash-remove! ht x)) symbols) (for-each (λ (x) (hash-remove! ht x)) symbols)
(preferences:set 'framework:tabify pref)))))) (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)