racket.rkt
1 #lang racket/unit 2 3 ;; originally by Dan Grossman 4 ;; 6/30/95 5 6 (require string-constants 7 racket/class 8 racket/string 9 mred/mred-sig 10 syntax-color/module-lexer 11 "collapsed-snipclass-helpers.rkt" 12 "sig.rkt" 13 "srcloc-panel.rkt" 14 "../gui-utils.rkt" 15 "../preferences.rkt" 16 racket/match 17 racket/contract/option) 18 19 (import mred^ 20 [prefix preferences: framework:preferences^] 21 [prefix icon: framework:icon^] 22 [prefix keymap: framework:keymap^] 23 [prefix text: framework:text^] 24 [prefix editor: framework:editor^] 25 [prefix frame: framework:frame^] 26 [prefix comment-box: framework:comment-box^] 27 [prefix mode: framework:mode^] 28 [prefix color: framework:color^] 29 [prefix color-prefs: framework:color-prefs^] 30 [prefix finder: framework:finder^]) 31 32 (export (rename framework:racket^ 33 [-text-mode<%> text-mode<%>] 34 [-text<%> text<%>] 35 [-text% text%])) 36 37 (init-depend mred^ framework:keymap^ framework:color^ framework:mode^ 38 framework:text^ framework:editor^) 39 40 (define-local-member-name 41 stick-to-next-sexp? 42 get-private-racket-container-keymap) 43 44 (define (racket-paren:get-paren-pairs) 45 '(("(" . ")") 46 ("[" . "]") 47 ("{" . "}"))) 48 49 (define text-balanced? 50 (lambda (text [start 0] [in-end #f]) 51 (let* ([end (or in-end (send text last-position))] 52 [port (open-input-text-editor text start end)]) 53 (with-handlers ([exn:fail:read:eof? (λ (x) #f)] 54 [exn:fail:read? (λ (x) #t)]) 55 (let ([first (read port)]) 56 (cond 57 [(eof-object? first) #f] 58 [else 59 (let loop () 60 (let ([s (read port)]) 61 (cond 62 [(eof-object? s) #t] 63 [else (loop)])))])))))) 64 65 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 66 ;; ;; 67 ;; Sexp Snip ;; 68 ;; ;; 69 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 70 71 (define (set-box/f! b v) (when (box? b) (set-box! b v))) 72 73 (define sexp-snip<%> 74 (interface () 75 get-saved-snips)) 76 77 (define sexp-snip% 78 (class* snip% (sexp-snip<%> readable-snip<%>) 79 (init-field left-bracket right-bracket saved-snips) 80 (define/public (get-saved-snips) saved-snips) 81 (field [sizing-text (format "~a ~a" left-bracket right-bracket)]) 82 83 (define/public (read-special file line col pos) 84 (let ([text (make-object text:basic%)]) 85 (for-each 86 (λ (s) (send text insert (send s copy) 87 (send text last-position) 88 (send text last-position))) 89 saved-snips) 90 (datum->syntax 91 #f 92 (read (open-input-text-editor text)) 93 (list file line col pos 1)))) 94 95 (define/override get-text 96 (lambda (offset num [flattened? #f]) 97 (if flattened? 98 (apply string-append 99 (map (λ (snip) 100 (send snip get-text 0 (send snip get-count) flattened?)) 101 saved-snips)) 102 (super get-text offset num flattened?)))) 103 104 (define/override (copy) 105 (instantiate sexp-snip% () 106 (left-bracket left-bracket) 107 (right-bracket right-bracket) 108 (saved-snips saved-snips))) 109 110 (define/override (write stream-out) 111 (send stream-out put (bytes (char->integer left-bracket))) 112 (send stream-out put (bytes (char->integer right-bracket))) 113 (send stream-out put (length saved-snips)) 114 (let loop ([snips saved-snips]) 115 (cond 116 [(null? snips) (void)] 117 [else 118 (let* ([snip (car snips)] 119 [snipclass (send snip get-snipclass)]) 120 (send stream-out put (string->bytes/utf-8 (send snipclass get-classname))) 121 (send snip write stream-out)) 122 (loop (cdr snips))]))) 123 124 (define/override (draw dc x y left top right bottom dx dy draw-caret) 125 (send dc draw-text sizing-text x y) 126 (let-values ([(lpw lph lpa lpd) (send dc get-text-extent (string left-bracket))] 127 [(rpw rph rpa rpd) (send dc get-text-extent (string right-bracket))] 128 [(sw sh sa sd) (send dc get-text-extent sizing-text)]) 129 (let* ([dtw (- sw lpw rpw)] 130 [dot-start (+ x lpw)] 131 [dt1x (+ dot-start (* dtw 1/5))] 132 [dt2x (+ dot-start (* dtw 1/2))] 133 [dt3x (+ dot-start (* dtw 4/5))] 134 [dty (+ y (/ sh 2))]) 135 (send dc draw-rectangle dt1x dty 2 2) 136 (send dc draw-rectangle dt2x dty 2 2) 137 (send dc draw-rectangle dt3x dty 2 2)))) 138 139 (inherit get-style) 140 (define/override (get-extent dc x y wb hb descentb spaceb lspaceb rspaceb) 141 (let-values ([(w h d a) (send dc get-text-extent sizing-text (send (get-style) get-font))]) 142 (set-box/f! wb w) 143 (set-box/f! hb h) 144 (set-box/f! descentb d) 145 (set-box/f! spaceb a) 146 (set-box/f! lspaceb 0) 147 (set-box/f! rspaceb 0))) 148 (super-new) 149 (inherit set-snipclass) 150 (set-snipclass 2lib-snip-class))) 151 152 (define sexp-snipclass% (make-sexp-snipclass% sexp-snip%)) 153 154 ;; old snips (from old versions of drracket) use this snipclass 155 (define 2lib-snip-class (make-object sexp-snipclass%)) 156 (send 2lib-snip-class set-classname (format "~s" '((lib "collapsed-snipclass.ss" "framework") 157 (lib "collapsed-snipclass-wxme.ss" "framework")))) 158 (send 2lib-snip-class set-version 0) 159 (send (get-the-snip-class-list) add 2lib-snip-class) 160 161 ;; old snips (from old versions of drracket) use this snipclass 162 (define lib-snip-class (make-object sexp-snipclass%)) 163 (send lib-snip-class set-classname (format "~s" '(lib "collapsed-snipclass.ss" "framework"))) 164 (send lib-snip-class set-version 0) 165 (send (get-the-snip-class-list) add lib-snip-class) 166 167 ;; new snips use this snipclass 168 (define old-snip-class (make-object sexp-snipclass%)) 169 (send old-snip-class set-classname "drscheme:sexp-snip") 170 (send old-snip-class set-version 0) 171 (send (get-the-snip-class-list) add old-snip-class) 172 173 (keymap:add-to-right-button-menu 174 (let ([old (keymap:add-to-right-button-menu)]) 175 (λ (menu text event) 176 (old menu text event) 177 (split/collapse-text menu text event) 178 (void)))) 179 180 ;; split/collapse-text : (instanceof menu%) (instanceof editor<%>) (instanceof mouse-event%) -> void 181 (define (split/collapse-text menu text event) 182 (when (and (is-a? text -text<%>) 183 (not (send text is-stopped?))) 184 (let* ([on-it-box (box #f)] 185 [click-pos 186 (call-with-values 187 (λ () 188 (send text dc-location-to-editor-location 189 (send event get-x) 190 (send event get-y))) 191 (λ (x y) 192 (send text find-position x y #f on-it-box)))] 193 [snip (send text find-snip click-pos 'after)] 194 [char (send text get-character click-pos)] 195 [left? (memq char '(#\( #\{ #\[))] 196 [right? (memq char '(#\) #\} #\]))]) 197 (cond 198 [(and snip (is-a? snip sexp-snip<%>)) 199 (make-expand-item text snip menu)] 200 [(not (unbox on-it-box)) 201 ;; clicking in nowhere land, just ignore 202 (void)] 203 [(or left? right?) 204 ;; clicking on left or right paren 205 (let* ([pos (if left? 206 click-pos 207 (+ click-pos 1))] 208 [other-pos (if left? 209 (send text get-forward-sexp pos) 210 (send text get-backward-sexp pos))]) 211 (when other-pos 212 (let ([left-pos (min pos other-pos)] 213 [right-pos (max pos other-pos)]) 214 (make-collapse-item text left-pos right-pos menu))))] 215 [else 216 ;; clicking on some other text -> collapse containing sexp 217 (let ([up-sexp (send text find-up-sexp click-pos)]) 218 (when up-sexp 219 (let ([fwd (send text get-forward-sexp up-sexp)]) 220 (when fwd 221 (make-collapse-item text up-sexp fwd menu)))))])))) 222 223 ;; make-expand-item : (instanceof text%) (instanceof sexp-snip<%>) (instanceof menu%) -> void 224 (define (make-expand-item text snip menu) 225 (instantiate separator-menu-item% () 226 (parent menu)) 227 (instantiate menu-item% () 228 (parent menu) 229 (label (string-constant expand-sexp)) 230 (callback (λ (item evt) (expand-from text snip))))) 231 232 ;; expand-from : (instanceof text%) (instanceof sexp-snip<%>) -> void 233 (define (expand-from text snip) 234 (let ([snips (send snip get-saved-snips)]) 235 (send text begin-edit-sequence) 236 (let ([pos (send text get-snip-position snip)]) 237 (send text delete pos (+ pos 1)) 238 (let loop ([snips (reverse snips)]) 239 (cond 240 [(null? snips) (void)] 241 [else (send text insert (send (car snips) copy) pos pos) 242 (loop (cdr snips))]))) 243 (send text end-edit-sequence))) 244 245 ;; make-collapse-item : (instanceof text%) number number (instanceof menu%) -> void 246 ;; adds a collapse menu item to the menu 247 (define (make-collapse-item text left-pos right-pos menu) 248 (instantiate separator-menu-item% () 249 (parent menu)) 250 (instantiate menu-item% () 251 (parent menu) 252 (label (string-constant collapse-sexp)) 253 (callback (λ (item evt) 254 (collapse-from text left-pos right-pos))))) 255 256 (define (collapse-from text left-pos right-pos) 257 (let ([left-bracket (send text get-character left-pos)] 258 [right-bracket (send text get-character (- right-pos 1))]) 259 (send text begin-edit-sequence) 260 (send text split-snip left-pos) 261 (send text split-snip right-pos) 262 (let ([snips (let loop ([snip (send text find-snip left-pos 'after)]) 263 (cond 264 [(not snip) null] 265 [((send text get-snip-position snip) . >= . right-pos) 266 null] 267 [else (cons (send snip copy) (loop (send snip next)))]))]) 268 (send text delete left-pos right-pos) 269 (send text insert (instantiate sexp-snip% () 270 (left-bracket left-bracket) 271 (right-bracket right-bracket) 272 (saved-snips snips)) 273 left-pos left-pos) 274 (send text end-edit-sequence)))) 275 276 277 ; 278 ; 279 ; 280 ; ; ;;;; 281 ; ;; ;;;; 282 ; ;;;; ;;;;; ;;;; ;;; ;;; ;;; ;;; 283 ; ;;;;;; ;;;;;; ;;;;;;;;; ;;;;; ;;;;;;; 284 ; ;;;;;;;; ;;;; ;;;; ;;;; ;;;; ;; ;;;; ;; 285 ; ;;;; ;;; ;;;; ;;;; ;;;; ;;;;;;; ;;;; 286 ; ;;;;;;;; ;;;;; ;;;; ;;;; ;;;;; ;;;; 287 ; ;;;;;; ;;;;; ;;;; ;;;; ;;;;;; ;;;; 288 ; ;;;; ;;;; ;;;; ;;;; ;;;; ;;;; 289 ; 290 ; 291 ; 292 293 294 (define color-prefs-table 295 (let ([constant-green (make-object color% 41 128 38)] 296 [symbol-blue (make-object color% 38 38 128)]) 297 `((symbol ,symbol-blue ,(string-constant scheme-mode-color-symbol)) 298 (keyword ,symbol-blue ,(string-constant scheme-mode-color-keyword)) 299 (comment ,(make-object color% 194 116 31) ,(string-constant scheme-mode-color-comment)) 300 (string ,constant-green ,(string-constant scheme-mode-color-string)) 301 (text ,constant-green ,(string-constant scheme-mode-color-text)) 302 (constant ,constant-green ,(string-constant scheme-mode-color-constant)) 303 (hash-colon-keyword ,(make-object color% "brown") 304 ,(string-constant scheme-mode-color-hash-colon-keyword)) 305 (parenthesis ,(make-object color% "brown") ,(string-constant scheme-mode-color-parenthesis)) 306 (error ,(make-object color% "red") ,(string-constant scheme-mode-color-error)) 307 (other ,(make-object color% "black") ,(string-constant scheme-mode-color-other))))) 308 309 (define white-on-black-color-prefs-table 310 (let* ([sym/kwd (make-object color% 157 157 250)] 311 [constant-green (make-object color% 140 212 140)] 312 [new-entries 313 `((symbol ,sym/kwd) 314 (keyword ,sym/kwd) 315 (comment ,(make-object color% 249 148 40)) 316 (string ,constant-green) 317 (text ,(make-object color% 51 174 51)) 318 (constant ,constant-green) 319 (hash-colon-keyword ,(make-object color% 151 69 43)) 320 (parenthesis ,(make-object color% 151 69 43)) 321 (other ,(make-object color% "white")))]) 322 (map 323 (λ (line) 324 (let ([new (assoc (car line) new-entries)]) 325 (if new 326 (list* (car line) 327 (cadr new) 328 (cddr line)) 329 line))) 330 color-prefs-table))) 331 332 (define (get-color-prefs-table) color-prefs-table) 333 (define (get-white-on-black-color-prefs-table) white-on-black-color-prefs-table) 334 335 (define (short-sym->pref-name sym) (string->symbol (short-sym->style-name sym))) 336 (define (xlate-sym-style sym) (case sym 337 [(sexp-comment) 'comment] 338 [else sym])) 339 (define sn-hash (make-hasheq)) 340 (define (short-sym->style-name _sym) 341 (define sym (if (eq? _sym 'white-space) 342 'parenthesis 343 _sym)) 344 (hash-ref sn-hash sym 345 (λ () 346 (let ([s (format "framework:syntax-color:scheme:~a" 347 (xlate-sym-style sym))]) 348 (hash-set! sn-hash sym s) 349 s)))) 350 351 (define (add-coloring-preferences-panel) 352 (color-prefs:add-to-preferences-panel 353 "Racket" 354 (λ (parent) 355 (for-each 356 (λ (line) 357 (let ([sym (car line)]) 358 (color-prefs:build-color-selection-panel 359 parent 360 (short-sym->pref-name sym) 361 (short-sym->style-name sym) 362 (caddr line)))) 363 color-prefs-table)))) 364 365 (define-struct string/pos (string pos)) 366 367 (define -text<%> 368 (interface (text:basic<%> mode:host-text<%> color:text<%>) 369 get-limit 370 balance-parens 371 tabify-on-return? 372 tabify 373 tabify-selection 374 tabify-all 375 insert-return 376 box-comment-out-selection 377 comment-out-selection 378 uncomment-selection 379 get-forward-sexp 380 remove-sexp 381 forward-sexp 382 flash-forward-sexp 383 get-backward-sexp 384 flash-backward-sexp 385 backward-sexp 386 find-up-sexp 387 up-sexp 388 find-down-sexp 389 down-sexp 390 remove-parens-forward 391 392 select-forward-sexp 393 select-backward-sexp 394 select-up-sexp 395 select-down-sexp 396 transpose-sexp 397 mark-matching-parenthesis 398 get-tab-size 399 set-tab-size 400 401 introduce-let-ans 402 move-sexp-out 403 kill-enclosing-parens 404 toggle-round-square-parens 405 406 compute-racket-amount-to-indent 407 compute-amount-to-indent)) 408 409 (define init-wordbreak-map 410 (λ (map) 411 (send map set-map #\< '(line selection)) ; interfaces e.g.the canvas<%> interface 412 (send map set-map #\> '(line selection)) ; interfaces, casts e.g. string->path 413 (send map set-map #\% '(line selection)) ; intefraces, classes 414 (send map set-map #\? '(line selection)) ; predicates 415 (send map set-map #\' '(line selection)) ; literal symbols 416 (send map set-map #\! '(line selection)) ; assignments e.g. set 417 (send map set-map #\- '(line selection)) ; hyphens 418 (send map set-map #\: '(line selection)))); valid identifiers with colons 419 420 (define wordbreak-map (make-object editor-wordbreak-map%)) 421 (define (get-wordbreak-map) wordbreak-map) 422 (init-wordbreak-map wordbreak-map) 423 424 (define matching-parenthesis-style 425 (let ([matching-parenthesis-delta (make-object style-delta% 'change-bold)] 426 [style-list (editor:get-standard-style-list)]) 427 (send matching-parenthesis-delta set-delta-foreground "forest green") 428 (send style-list new-named-style "Matching Parenthesis Style" 429 (send style-list find-or-create-style 430 (send style-list find-named-style "Standard") 431 matching-parenthesis-delta)) 432 (send style-list find-named-style "Matching Parenthesis Style"))) 433 434 (define text-mixin 435 (mixin (text:basic<%> mode:host-text<%> color:text<%> text:autocomplete<%> editor:keymap<%>) 436 (-text<%>) 437 (inherit begin-edit-sequence 438 delete 439 end-edit-sequence 440 local-edit-sequence? 441 find-string 442 extend-position 443 get-character 444 get-extend-end-position 445 get-extend-start-position 446 get-keymap 447 get-text 448 get-start-position 449 get-style-list 450 get-end-position 451 flash-on 452 insert 453 is-stopped? 454 kill 455 last-position 456 paragraph-start-position 457 paragraph-end-position 458 position-paragraph 459 set-keymap 460 set-load-overwrites-styles 461 set-position 462 set-wordbreak-map 463 set-tabs 464 set-style-list 465 set-styles-fixed 466 change-style 467 get-snip-position 468 backward-match 469 backward-containing-sexp 470 forward-match 471 skip-whitespace 472 insert-close-paren 473 classify-position) 474 475 (inherit get-styles-fixed) 476 (inherit has-focus? find-snip split-snip 477 position-location get-dc) 478 479 (define private-racket-container-keymap (new keymap:aug-keymap%)) 480 (define/public (get-private-racket-container-keymap) private-racket-container-keymap) 481 482 (define/override (get-keymaps) 483 (editor:add-after-user-keymap private-racket-container-keymap 484 (super get-keymaps))) 485 486 (define/override (get-word-at current-pos) 487 (let ([no-word ""]) 488 (cond 489 [(is-stopped?) 490 no-word] 491 [else 492 (let ([type (classify-position (max 0 (- current-pos 1)))]) 493 (cond 494 [(memq type '(symbol keyword)) 495 (get-text (look-for-non-symbol/non-kwd (max 0 (- current-pos 1))) 496 current-pos)] 497 [else no-word]))]))) 498 499 (define/private (look-for-non-symbol/non-kwd start) 500 (let loop ([i start]) 501 (cond 502 [(< i 0) 503 0] 504 [(memq (classify-position i) '(symbol keyword)) 505 (loop (- i 1))] 506 [else 507 (+ i 1)]))) 508 509 (define/public (get-limit pos) 0) 510 511 (define/public (balance-parens key-event [smart-skip #f]) 512 (insert-close-paren (get-start-position) 513 (send key-event get-key-code) 514 (preferences:get 'framework:paren-match) 515 (preferences:get 'framework:fixup-parens) 516 (or smart-skip 517 (and (preferences:get 'framework:automatic-parens) 518 (not (in-string/comment? this)) 519 'adjacent)))) 520 521 (define/public (tabify-on-return?) #t) 522 (define/public (tabify [pos (get-start-position)]) 523 (define amt (compute-amount-to-indent pos)) 524 (define (do-indent amt) 525 (define para (position-paragraph pos)) 526 (define end (paragraph-start-position para)) 527 (define-values (gwidth curr-offset tab-char?) (find-offset end)) 528 (unless (and (not tab-char?) (= amt (- curr-offset end))) 529 (delete end curr-offset) 530 (insert (make-string amt #\space) end))) 531 (when amt (do-indent amt))) 532 533 (define/private (find-offset start-pos) 534 (define tab-char? #f) 535 (define end-pos 536 (let loop ([p start-pos]) 537 (let ([c (get-character p)]) 538 (cond 539 [(char=? c #\tab) 540 (set! tab-char? #t) 541 (loop (add1 p))] 542 [(char=? c #\newline) 543 p] 544 [(char-whitespace? c) 545 (loop (add1 p))] 546 [else 547 p])))) 548 (define sizing-dc (get-dc)) 549 (define gwidth 550 (cond 551 [sizing-dc 552 (define start-x (box 0)) 553 (define end-x (box 0)) 554 (position-location start-pos start-x #f #t #t) 555 (position-location end-pos end-x #f #t #t) 556 (define-values (w _1 _2 _3) 557 (send sizing-dc get-text-extent "x" 558 (send (send (get-style-list) 559 find-named-style "Standard") 560 get-font))) 561 (inexact->exact (floor (/ (- (unbox end-x) (unbox start-x)) w)))] 562 [else 563 ;; if there is no display available, approximate the graphical 564 ;; width on the assumption that we are using a fixed-width font 565 (- end-pos start-pos)])) 566 (values gwidth end-pos tab-char?)) 567 568 (define/pubment (compute-amount-to-indent pos) 569 (inner (compute-racket-amount-to-indent pos) compute-amount-to-indent pos)) 570 (define/public-final (compute-racket-amount-to-indent pos [_get-head-sexp-type (λ (x) #f)]) 571 (cond 572 [(is-stopped?) #f] 573 [else 574 (define get-head-sexp-type 575 (let ([tabify-prefs (preferences:get 'framework:tabify)]) 576 (λ (text) 577 (or (_get-head-sexp-type text) 578 (get-head-sexp-type-from-prefs text tabify-prefs))))) 579 (define last-pos (last-position)) 580 (define para (position-paragraph pos)) 581 (define is-tabbable? 582 (and (> para 0) 583 (not (memq (classify-position (- (paragraph-start-position para) 1)) 584 '(comment string error))))) 585 (define end (if is-tabbable? (paragraph-start-position para) 0)) 586 (define limit (get-limit pos)) 587 588 ;; "contains" is the start of the initial sub-S-exp 589 ;; in the S-exp that contains "pos". If pos is outside 590 ;; all S-exps, this will be the start of the initial 591 ;; S-exp 592 (define contains 593 (if is-tabbable? 594 (backward-containing-sexp end limit) 595 #f)) 596 (define contain-para (and contains 597 (position-paragraph contains))) 598 599 ;; last is the start of the S-exp just before "pos" 600 (define last 601 (if contains 602 (let ([p (get-backward-sexp end)]) 603 (if (and p (p . >= . limit)) 604 p 605 (backward-match end limit))) 606 #f)) 607 (define last-para (and last (position-paragraph last))) 608 609 ;; last2 is the start of the S-exp just before the one before "pos" 610 (define last2 611 (if last 612 (let ([p (get-backward-sexp last)]) 613 (if (and p (p . >= . limit)) 614 p 615 (backward-match last limit))) 616 #f)) 617 618 (define (visual-offset pos) 619 (let loop ([p (sub1 pos)]) 620 (if (= p -1) 621 0 622 (let ([c (get-character p)]) 623 (cond 624 [(char=? c #\null) 0] 625 [(char=? c #\tab) 626 (let ([o (loop (sub1 p))]) 627 (+ o (- 8 (modulo o 8))))] 628 [(char=? c #\newline) 0] 629 [else (add1 (loop (sub1 p)))]))))) 630 631 (define (get-proc) 632 (define id-end (get-forward-sexp contains)) 633 (and (and id-end (> id-end contains)) 634 (let ([text (get-text contains id-end)]) 635 (cond 636 [(member (classify-position contains) '(keyword symbol)) 637 (get-head-sexp-type text)] 638 [else 639 'other])))) 640 (define (procedure-indent) 641 (case (get-proc) 642 [(begin define) 1] 643 [(lambda) 3] 644 [else 0])) 645 (define (define-or-lambda-style?) 646 (define proc-name (get-proc)) 647 (or (equal? proc-name 'define) 648 (equal? proc-name 'lambda))) 649 (define (for/fold-style?) 650 (define proc-name (get-proc)) 651 (equal? proc-name 'for/fold)) 652 653 (define (indent-first-arg start) 654 (define-values (gwidth curr-offset tab-char?) (find-offset start)) 655 gwidth) 656 657 (when (and is-tabbable? 658 (not (char=? (get-character (sub1 end)) 659 #\newline))) 660 (insert #\newline (paragraph-start-position para))) 661 662 (define amt-to-indent 663 (cond 664 [(not is-tabbable?) 665 (if (= para 0) 666 0 667 #f)] 668 [(let-values ([(gwidth real-start tab-char?) (find-offset end)]) 669 (and (<= (+ 3 real-start) (last-position)) 670 (string=? ";;;" 671 (get-text real-start 672 (+ 2 real-start))))) 673 #f] 674 [(not contains) 675 ;; Something went wrong matching. Should we get here? 676 0] 677 [(not last) 678 ;; We can't find a match backward from pos, 679 ;; but we seem to be inside an S-exp, so 680 ;; go "up" an S-exp, and move forward past 681 ;; the associated paren 682 (define enclosing (find-up-sexp pos)) 683 (if enclosing 684 (+ (visual-offset enclosing) 1) 685 0)] 686 [(= contains last) 687 ;; this is the first expression in the define 688 (+ (visual-offset contains) 689 (procedure-indent))] 690 [(and (for/fold-style?) 691 last2 692 (= contains last2)) 693 (- last (paragraph-start-position last-para))] 694 [(or (define-or-lambda-style?) 695 (for/fold-style?)) 696 ;; In case of "define", etc., ignore the position of last 697 ;; and just indent under the "define" 698 (add1 (visual-offset contains))] 699 [(= contain-para last-para) 700 ;; So far, the S-exp containing "pos" was all on 701 ;; one line (possibly not counting the opening paren), 702 ;; so indent to follow the first S-exp's end 703 ;; unless 704 ;; - there are just two sexps earlier and the second is an ellipsis. 705 ;; in that case, we just ignore the ellipsis or 706 ;; - the sexp we are indenting is a bunch of hypens; 707 ;; in that case, we match the opening paren 708 (define id-end (get-forward-sexp contains)) 709 (define name-length 710 (if id-end 711 (- id-end contains) 712 0)) 713 (cond 714 [(or (first-sexp-is-keyword? contains) 715 (sexp-is-all-hyphens? contains)) 716 (visual-offset contains)] 717 [(second-sexp-is-ellipsis? contains) 718 (visual-offset contains)] 719 [(sexp-is-all-hyphens? pos) 720 (visual-offset contains)] 721 [(not (find-up-sexp pos)) 722 (visual-offset contains)] 723 [else 724 (+ (visual-offset contains) 725 name-length 726 (indent-first-arg (+ contains 727 name-length)))])] 728 [else 729 ;; No particular special case, so indent to match first 730 ;; S-expr that starts on the previous line 731 (let loop ([last last][last-para last-para]) 732 (let* ([next-to-last (backward-match last limit)] 733 [next-to-last-para (and next-to-last 734 (position-paragraph next-to-last))]) 735 (if (equal? last-para next-to-last-para) 736 (loop next-to-last next-to-last-para) 737 (visual-offset last))))])) 738 amt-to-indent])) 739 740 ;; returns #t if `pos` is in a symbol (or keyword) that consists entirely 741 ;; of hyphens and has at least three hyphens; returns #f otherwise 742 (define/private (sexp-is-all-hyphens? pos) 743 (define fst-end (get-forward-sexp pos)) 744 (and fst-end 745 (let ([fst-start (get-backward-sexp fst-end)]) 746 (and fst-start 747 (memq (classify-position fst-start) '(symbol keyword)) 748 (>= (- fst-end fst-start) 3) 749 (let loop ([i fst-start]) 750 (cond 751 [(< i fst-end) 752 (and (equal? #\- (get-character i)) (loop (+ i 1)))] 753 [else #t])))))) 754 755 ;; returns #t if `contains' is at a position on a line with an sexp, an ellipsis and nothing else. 756 ;; otherwise, returns #f 757 (define/private (second-sexp-is-ellipsis? contains) 758 (let ([fst-end (get-forward-sexp contains)]) 759 (and fst-end 760 (let ([snd-end (get-forward-sexp fst-end)]) 761 (and snd-end 762 (let ([snd-start (get-backward-sexp snd-end)]) 763 (and snd-start 764 (equal? (get-text snd-start snd-end) 765 "...") 766 (let ([thrd-start (get-forward-sexp snd-end)]) 767 (and (or (not thrd-start) 768 (not (= (position-paragraph thrd-start) 769 (position-paragraph snd-start))))))))))))) 770 771 (define/private (first-sexp-is-keyword? contains) 772 (let ([fst-end (get-forward-sexp contains)]) 773 (and fst-end 774 (let ([fst-start (get-backward-sexp fst-end)]) 775 (and fst-start 776 (equal? (classify-position fst-start) 'hash-colon-keyword)))))) 777 778 (define/public (tabify-selection [start-pos (get-start-position)] 779 [end-pos (get-end-position)]) 780 (unless (is-stopped?) 781 (define first-para (position-paragraph start-pos)) 782 (define end-para (position-paragraph end-pos)) 783 (define tabifying-multiple-paras? (not (= first-para end-para))) 784 (with-handlers ([exn:break? 785 (λ (x) #t)]) 786 (dynamic-wind 787 (λ () 788 (when (< first-para end-para) 789 (begin-busy-cursor)) 790 (begin-edit-sequence)) 791 (λ () 792 (let loop ([para first-para]) 793 (when (<= para end-para) 794 (define start (paragraph-start-position para)) 795 (define end (paragraph-end-position para)) 796 (define skip-this-line? 797 (and tabifying-multiple-paras? 798 (for/and ([i (in-range start (+ end 1))]) 799 (char-whitespace? (get-character i))))) 800 (unless skip-this-line? 801 (tabify start)) 802 (parameterize-break #t (void)) 803 (loop (add1 para)))) 804 (when (and (>= (position-paragraph start-pos) end-para) 805 (<= (skip-whitespace (get-start-position) 'backward #f) 806 (paragraph-start-position first-para))) 807 (set-position 808 (let loop ([new-pos (get-start-position)]) 809 (if (let ([next (get-character new-pos)]) 810 (and (char-whitespace? next) 811 (not (char=? next #\newline)))) 812 (loop (add1 new-pos)) 813 new-pos))))) 814 (λ () 815 (end-edit-sequence) 816 (when (< first-para end-para) 817 (end-busy-cursor))))))) 818 819 (define/public (tabify-all) (tabify-selection 0 (last-position))) 820 (define/public (insert-return) 821 (begin-edit-sequence #t #f) 822 (define end-of-whitespace (get-start-position)) 823 (define start-cutoff 824 (paragraph-start-position (position-paragraph end-of-whitespace))) 825 (define start-of-whitespace 826 (let loop ([pos end-of-whitespace]) 827 (if (and (> pos start-cutoff) 828 (char-whitespace? (get-character (sub1 pos)))) 829 (loop (sub1 pos)) 830 pos))) 831 (delete start-of-whitespace end-of-whitespace) 832 (insert #\newline) 833 (when (and (tabify-on-return?) 834 (tabify (get-start-position))) 835 (set-position 836 (let loop ([new-pos (get-start-position)]) 837 (if (let ([next (get-character new-pos)]) 838 (and (char-whitespace? next) 839 (not (char=? next #\newline)))) 840 (loop (add1 new-pos)) 841 new-pos)))) 842 (end-edit-sequence)) 843 844 (define/public (calc-last-para last-pos) 845 (let ([last-para (position-paragraph last-pos #t)]) 846 (if (and (> last-pos 0) 847 (> last-para 0)) 848 (begin (split-snip last-pos) 849 (let ([snip (find-snip last-pos 'before)]) 850 (if (member 'hard-newline (send snip get-flags)) 851 (- last-para 1) 852 last-para))) 853 last-para))) 854 855 (define/public (comment-out-selection [start-pos (get-start-position)] 856 [end-pos (get-end-position)]) 857 (begin-edit-sequence) 858 (let ([first-pos-is-first-para-pos? 859 (= (paragraph-start-position (position-paragraph start-pos)) 860 start-pos)]) 861 (let* ([first-para (position-paragraph start-pos)] 862 [last-para (calc-last-para end-pos)]) 863 (let para-loop ([curr-para first-para]) 864 (when (<= curr-para last-para) 865 (let ([first-on-para (paragraph-start-position curr-para)]) 866 (insert #\; first-on-para) 867 (para-loop (add1 curr-para)))))) 868 (when first-pos-is-first-para-pos? 869 (set-position 870 (paragraph-start-position (position-paragraph (get-start-position))) 871 (get-end-position)))) 872 (end-edit-sequence) 873 #t) 874 875 (define/public (box-comment-out-selection [_start-pos 'start] 876 [_end-pos 'end]) 877 (let ([start-pos (if (eq? _start-pos 'start) 878 (get-start-position) 879 _start-pos)] 880 [end-pos (if (eq? _end-pos 'end) 881 (get-end-position) 882 _end-pos)]) 883 (begin-edit-sequence) 884 (split-snip start-pos) 885 (split-snip end-pos) 886 (let* ([cb (instantiate comment-box:snip% ())] 887 [text (send cb get-editor)]) 888 (let loop ([snip (find-snip start-pos 'after-or-none)]) 889 (cond 890 [(not snip) (void)] 891 [((get-snip-position snip) . >= . end-pos) (void)] 892 [else 893 (send text insert (send snip copy) 894 (send text last-position) 895 (send text last-position)) 896 (loop (send snip next))])) 897 (delete start-pos end-pos) 898 (insert cb start-pos) 899 (set-position start-pos start-pos)) 900 (end-edit-sequence) 901 #t)) 902 903 ;; uncomment-box/selection : -> void 904 ;; uncomments a comment box, if the focus is inside one. 905 ;; otherwise, calls uncomment selection to uncomment 906 ;; something else. 907 (inherit get-focus-snip) 908 (define/public (uncomment-box/selection) 909 (begin-edit-sequence) 910 (let ([focus-snip (get-focus-snip)]) 911 (cond 912 [(not focus-snip) (uncomment-selection)] 913 [(is-a? focus-snip comment-box:snip%) 914 (extract-contents 915 (get-snip-position focus-snip) 916 focus-snip)] 917 [else (uncomment-selection)])) 918 (end-edit-sequence) 919 #t) 920 921 (define/public (uncomment-selection [start-pos (get-start-position)] 922 [end-pos (get-end-position)]) 923 (let ([snip-before (find-snip start-pos 'before-or-none)] 924 [snip-after (find-snip start-pos 'after-or-none)]) 925 926 (begin-edit-sequence) 927 (cond 928 [(and (= start-pos end-pos) 929 snip-before 930 (is-a? snip-before comment-box:snip%)) 931 (extract-contents start-pos snip-before)] 932 [(and (= start-pos end-pos) 933 snip-after 934 (is-a? snip-after comment-box:snip%)) 935 (extract-contents start-pos snip-after)] 936 [(and (= (+ start-pos 1) end-pos) 937 snip-after 938 (is-a? snip-after comment-box:snip%)) 939 (extract-contents start-pos snip-after)] 940 [else 941 (let* ([last-pos (last-position)] 942 [first-para (position-paragraph start-pos)] 943 [last-para (calc-last-para end-pos)]) 944 (let para-loop ([curr-para first-para]) 945 (when (<= curr-para last-para) 946 (let ([first-on-para 947 (skip-whitespace (paragraph-start-position curr-para) 948 'forward 949 #f)]) 950 (split-snip first-on-para) 951 (when (and (< first-on-para last-pos) 952 (char=? #\; (get-character first-on-para)) 953 (is-a? (find-snip first-on-para 'after-or-none) string-snip%)) 954 (delete first-on-para (+ first-on-para 1))) 955 (para-loop (add1 curr-para))))))]) 956 (end-edit-sequence)) 957 #t) 958 959 ;; extract-contents : number (is-a?/c comment-box:snip%) -> void 960 ;; copies the contents of the comment-box-snip out of the snip 961 ;; and into this editor as `pos'. Deletes the comment box snip 962 (define/private (extract-contents pos snip) 963 (let ([editor (send snip get-editor)]) 964 (let loop ([snip (send editor find-snip (send editor last-position) 'before-or-none)]) 965 (cond 966 [snip 967 (insert (send snip copy) pos) 968 (loop (send snip previous))] 969 [else (void)])) 970 (let ([snip-pos (get-snip-position snip)]) 971 (delete snip-pos (+ snip-pos 1))) 972 (set-position pos pos))) 973 974 975 ;; stick-to-next-sexp?: natural -> boolean 976 (define stick-to-patterns 977 '("'" "," ",@" "`" "#'" "#," "#`" "#,@" 978 "#&" "#;" "#hash" "#hasheq" "#ci" "#cs")) 979 (define stick-to-patterns-union 980 (regexp (string-append 981 "^(" 982 (string-join (map regexp-quote stick-to-patterns) "|") 983 ")"))) 984 (define stick-to-patterns-union-anchored 985 (regexp (string-append 986 "^(" 987 (string-join (map regexp-quote stick-to-patterns) "|") 988 ")$"))) 989 (define stick-to-max-pattern-length 990 (apply max (map string-length stick-to-patterns))) 991 (define/public (stick-to-next-sexp? start-pos) 992 ;; Optimization: speculatively check whether the string will 993 ;; match the patterns; at time of writing, forward-match can be 994 ;; really expensive. 995 (define snippet 996 (get-text start-pos 997 (min (last-position) 998 (+ start-pos stick-to-max-pattern-length)))) 999 (and (regexp-match stick-to-patterns-union snippet) 1000 (let ([end-pos (forward-match start-pos (last-position))]) 1001 (and end-pos 1002 (regexp-match stick-to-patterns-union-anchored 1003 (get-text start-pos end-pos)) 1004 #t)))) 1005 1006 (define/public (get-forward-sexp start-pos) 1007 ;; loop to work properly with quote, etc. 1008 (let loop ([one-forward (forward-match start-pos (last-position))]) 1009 (cond 1010 [(and one-forward (not (= 0 one-forward))) 1011 (let ([bw (backward-match one-forward 0)]) 1012 (cond 1013 [(and bw 1014 (stick-to-next-sexp? bw)) 1015 (let ([two-forward (forward-match one-forward (last-position))]) 1016 (if two-forward 1017 (loop two-forward) 1018 one-forward))] 1019 [else 1020 one-forward]))] 1021 [else one-forward]))) 1022 1023 (define/public (remove-sexp start-pos) 1024 (let ([end-pos (get-forward-sexp start-pos)]) 1025 (if end-pos 1026 (kill 0 start-pos end-pos) 1027 (bell))) 1028 #t) 1029 (define/public (forward-sexp start-pos) 1030 (let ([end-pos (get-forward-sexp start-pos)]) 1031 (if end-pos 1032 (set-position end-pos) 1033 (bell)) 1034 #t)) 1035 (define/public (flash-forward-sexp start-pos) 1036 (let ([end-pos (get-forward-sexp start-pos)]) 1037 (if end-pos 1038 (flash-on end-pos (add1 end-pos)) 1039 (bell)) 1040 #t)) 1041 (define/public (get-backward-sexp start-pos) 1042 (let* ([limit (get-limit start-pos)] 1043 [end-pos (backward-match start-pos limit)] 1044 [min-pos (backward-containing-sexp start-pos limit)]) 1045 (if (and end-pos 1046 (or (not min-pos) 1047 (end-pos . >= . min-pos))) 1048 ;; Can go backward, but check for preceding quote, unquote, etc. 1049 (let loop ([end-pos end-pos]) 1050 (let ([next-end-pos (backward-match end-pos limit)]) 1051 (if (and next-end-pos 1052 (or (not min-pos) 1053 (end-pos . >= . min-pos)) 1054 (stick-to-next-sexp? next-end-pos)) 1055 (loop next-end-pos) 1056 end-pos))) 1057 ;; can't go backward at all: 1058 #f))) 1059 (define/public (flash-backward-sexp start-pos) 1060 (let ([end-pos (get-backward-sexp start-pos)]) 1061 (if end-pos 1062 (flash-on end-pos (add1 end-pos)) 1063 (bell)) 1064 #t)) 1065 (define/public (backward-sexp start-pos) 1066 (let ([end-pos (get-backward-sexp start-pos)]) 1067 (if end-pos 1068 (set-position end-pos) 1069 (bell)) 1070 #t)) 1071 (define/public (find-up-sexp start-pos) 1072 (let* ([limit-pos (get-limit start-pos)] 1073 [exp-pos 1074 (backward-containing-sexp start-pos limit-pos)]) 1075 1076 (if (and exp-pos (> exp-pos limit-pos)) 1077 (let* ([in-start-pos (skip-whitespace exp-pos 'backward #t)] 1078 [paren-pos 1079 (λ (paren-pair) 1080 (find-string 1081 (car paren-pair) 1082 'backward 1083 in-start-pos 1084 limit-pos))]) 1085 (let ([poss (let loop ([parens (racket-paren:get-paren-pairs)]) 1086 (cond 1087 [(null? parens) null] 1088 [else 1089 (let ([pos (paren-pos (car parens))]) 1090 (if pos 1091 (cons pos (loop (cdr parens))) 1092 (loop (cdr parens))))]))]) 1093 (if (null? poss) ;; all finds failed 1094 #f 1095 (- (apply max poss) 1)))) ;; subtract one to move outside the paren 1096 #f))) 1097 (define/public (up-sexp start-pos) 1098 (let ([exp-pos (find-up-sexp start-pos)]) 1099 (if exp-pos 1100 (set-position exp-pos) 1101 (bell)) 1102 #t)) 1103 (define/public (find-down-sexp start-pos) 1104 (let loop ([pos start-pos]) 1105 (let ([next-pos (get-forward-sexp pos)]) 1106 (if (and next-pos (> next-pos pos)) 1107 (let ([back-pos 1108 (backward-containing-sexp (sub1 next-pos) pos)]) 1109 (if (and back-pos 1110 (> back-pos pos)) 1111 back-pos 1112 (loop next-pos))) 1113 #f)))) 1114 (define/public (down-sexp start-pos) 1115 (let ([pos (find-down-sexp start-pos)]) 1116 (if pos 1117 (set-position pos) 1118 (bell)) 1119 #t)) 1120 (define/public (remove-parens-forward start-pos) 1121 (let* ([pos (skip-whitespace start-pos 'forward #f)] 1122 [first-char (get-character pos)] 1123 [paren? (or (char=? first-char #\() 1124 (char=? first-char #\[) 1125 (char=? first-char #\{))] 1126 [closer (and paren? 1127 (get-forward-sexp pos))]) 1128 (if (and paren? closer) 1129 (begin (begin-edit-sequence #t #f) 1130 (delete pos (add1 pos)) 1131 (delete (- closer 2) (- closer 1)) 1132 (end-edit-sequence)) 1133 (bell)) 1134 #t)) 1135 1136 (define/private (select-text f forward?) 1137 (define start-pos (get-start-position)) 1138 (define end-pos (get-end-position)) 1139 (define new-pos 1140 (if forward? 1141 (if (= (get-extend-start-position) start-pos) 1142 (f end-pos) 1143 (f start-pos)) 1144 (if (= (get-extend-end-position) end-pos) 1145 (f start-pos) 1146 (f end-pos)))) 1147 (if new-pos 1148 (extend-position new-pos) 1149 (bell)) 1150 #t) 1151 1152 (define/public (select-forward-sexp) (select-text (λ (x) (get-forward-sexp x)) #t)) 1153 (define/public (select-backward-sexp) (select-text (λ (x) (get-backward-sexp x)) #f)) 1154 (define/public (select-up-sexp) (select-text (λ (x) (find-up-sexp x)) #f)) 1155 (define/public (select-down-sexp) (select-text (λ (x) (find-down-sexp x)) #t)) 1156 1157 (define/public (introduce-let-ans pos) 1158 (dynamic-wind 1159 (λ () (begin-edit-sequence)) 1160 (λ () 1161 (let ([before-text "(let ([ans "] 1162 [after-text "])\n"] 1163 [after-text2 "(printf \"~s\\n\" ans)\nans)"] 1164 [end-l (get-forward-sexp pos)]) 1165 (cond 1166 [end-l 1167 (insert after-text2 end-l end-l) 1168 (insert after-text end-l end-l) 1169 (insert before-text pos pos) 1170 (let ([blank-line-pos (+ end-l (string-length after-text) (string-length before-text))]) 1171 (set-position blank-line-pos blank-line-pos)) 1172 (tabify-selection 1173 pos 1174 (+ end-l 1175 (string-length before-text) 1176 (string-length after-text) 1177 (string-length after-text2)))] 1178 [else 1179 (bell)]))) 1180 (λ () 1181 (end-edit-sequence)))) 1182 1183 (define/public (move-sexp-out begin-inner) 1184 (begin-edit-sequence #t #f) 1185 (let ([end-inner (get-forward-sexp begin-inner)] 1186 [begin-outer (find-up-sexp begin-inner)]) 1187 (cond 1188 [(and end-inner begin-outer) 1189 (let ([end-outer (get-forward-sexp begin-outer)]) 1190 (cond 1191 [end-outer 1192 (delete end-inner end-outer) 1193 (delete begin-outer begin-inner) 1194 (tabify-selection begin-outer (+ begin-outer (- end-inner begin-inner)))] 1195 [else (bell)]))] 1196 [else (bell)])) 1197 (end-edit-sequence)) 1198 1199 (define/public (kill-enclosing-parens begin-inner) 1200 (begin-edit-sequence #t #f) 1201 (define begin-outer (find-up-sexp begin-inner)) 1202 (cond 1203 [begin-outer 1204 (define end-outer (get-forward-sexp begin-outer)) 1205 (cond 1206 [(and end-outer (>= (- end-outer begin-outer) 2)) 1207 (delete (- end-outer 1) end-outer) 1208 (delete begin-outer (+ begin-outer 1)) 1209 (tabify-selection begin-outer (- end-outer 2))] 1210 [else (bell)])] 1211 [else (bell)]) 1212 (end-edit-sequence)) 1213 1214 ;; change the parens following the cursor from () to [] or vice versa 1215 (define/public (toggle-round-square-parens start-pos) 1216 (begin-edit-sequence #t #f) 1217 (let* ([sexp-begin (skip-whitespace start-pos 'forward #f)] 1218 [sexp-end (get-forward-sexp sexp-begin)]) 1219 (cond [(and sexp-end 1220 (< (+ 1 sexp-begin) sexp-end)) 1221 ;; positions known to exist: start-pos <= x < sexp-end 1222 (match* ((get-character sexp-begin) (get-character (- sexp-end 1))) 1223 [(#\( #\)) (replace-char-at-posn sexp-begin "[") 1224 (replace-char-at-posn (- sexp-end 1) "]")] 1225 [(#\[ #\]) (replace-char-at-posn sexp-begin "(") 1226 (replace-char-at-posn (- sexp-end 1) ")")] 1227 [(_ _) (bell)])] 1228 [else (bell)])) 1229 (end-edit-sequence)) 1230 1231 ;; replace-char-at-posn: natural-number string -> 1232 ;; replace the char at the given posn with the given string. 1233 ;; 1234 ;; this abstraction exists because the duplicated code in toggle-round-square-parens was 1235 ;; just a little too much for comfort 1236 (define (replace-char-at-posn posn str) 1237 ;; insertions are performed before deletions in order to preserve the location of the cursor 1238 (insert str (+ posn 1) (+ posn 1)) 1239 (delete posn (+ posn 1))) 1240 1241 (inherit get-fixed-style) 1242 (define/public (mark-matching-parenthesis pos) 1243 (let ([open-parens (map car (racket-paren:get-paren-pairs))] 1244 [close-parens (map cdr (racket-paren:get-paren-pairs))]) 1245 (when (member (string (get-character pos)) open-parens) 1246 (let ([end (get-forward-sexp pos)]) 1247 (when (and end 1248 (member (string (get-character (- end 1))) close-parens)) 1249 (let ([start-style (send (find-snip pos 'after) get-style)] 1250 [end-style (send (find-snip end 'before) get-style)]) 1251 (cond 1252 [(and (eq? matching-parenthesis-style start-style) 1253 (eq? matching-parenthesis-style end-style)) 1254 (let ([fixed-style (get-fixed-style)]) 1255 (change-style fixed-style pos (+ pos 1)) 1256 (change-style fixed-style (- end 1) end))] 1257 [else 1258 (change-style matching-parenthesis-style pos (+ pos 1)) 1259 (change-style matching-parenthesis-style (- end 1) end)]))))))) 1260 1261 ;; get-snips/rev: start end -> (listof snip) 1262 ;; Returns a list of the snips in reverse order between 1263 ;; start and end. 1264 (define/private (get-snips/rev start end) 1265 (split-snip start) 1266 (split-snip end) 1267 (let loop ([snips/rev '()] 1268 [a-snip (find-snip start 'after-or-none)]) 1269 (cond 1270 [(or (not a-snip) 1271 (>= (get-snip-position a-snip) 1272 end)) 1273 snips/rev] 1274 [else 1275 (loop (cons (send a-snip copy) snips/rev) 1276 (send a-snip next))]))) 1277 1278 (define/public (transpose-sexp pos) 1279 (let ([start-1 (get-backward-sexp pos)]) 1280 (if (not start-1) 1281 (bell) 1282 (let ([end-1 (get-forward-sexp start-1)]) 1283 (if (not end-1) 1284 (bell) 1285 (let ([end-2 (get-forward-sexp end-1)]) 1286 (if (not end-2) 1287 (bell) 1288 (let ([start-2 (get-backward-sexp end-2)]) 1289 (if (or (not start-2) 1290 (< start-2 end-1)) 1291 (bell) 1292 (let ([snips-1/rev (get-snips/rev start-1 end-1)] 1293 [snips-2/rev (get-snips/rev start-2 end-2)]) 1294 (begin-edit-sequence) 1295 (delete start-2 end-2) 1296 (for-each (λ (s) (insert s start-2)) snips-1/rev) 1297 (delete start-1 end-1) 1298 (for-each (λ (s) (insert s start-1)) snips-2/rev) 1299 (set-position end-2) 1300 (end-edit-sequence))))))))))) 1301 (define tab-size 8) 1302 (define/public (get-tab-size) tab-size) 1303 (define/public (set-tab-size s) (set! tab-size s)) 1304 1305 (define/override (get-start-of-line pos) 1306 (define para (position-paragraph pos)) 1307 (define para-start (paragraph-start-position para)) 1308 (define para-end (paragraph-end-position para)) 1309 (define first-non-whitespace 1310 (let loop ([i para-start]) 1311 (cond 1312 [(= i para-end) #f] 1313 [(char-whitespace? (get-character i)) 1314 (loop (+ i 1))] 1315 [else i]))) 1316 (define new-pos 1317 (cond 1318 [(not first-non-whitespace) para-start] 1319 [(= pos para-start) first-non-whitespace] 1320 [(<= pos first-non-whitespace) para-start] 1321 [else first-non-whitespace])) 1322 new-pos) 1323 1324 (super-new))) 1325 1326 (define -text-mode<%> 1327 (interface () 1328 )) 1329 1330 (define module-lexer/waived (waive-option module-lexer)) 1331 1332 (define text-mode-mixin 1333 (mixin (color:text-mode<%> mode:surrogate-text<%>) (-text-mode<%>) 1334 1335 (define saved-wordbreak-map #f) 1336 1337 (define/override (on-disable-surrogate text) 1338 (keymap:remove-chained-keymap text keymap) 1339 (send text set-wordbreak-map saved-wordbreak-map) 1340 (super on-disable-surrogate text)) 1341 1342 (define/override (on-enable-surrogate text) 1343 (send text begin-edit-sequence) 1344 (super on-enable-surrogate text) 1345 (send (send text get-private-racket-container-keymap) chain-to-keymap keymap #f) 1346 1347 (set! saved-wordbreak-map (send text get-wordbreak-map)) 1348 1349 (send text set-load-overwrites-styles #f) 1350 (send text set-wordbreak-map wordbreak-map) 1351 (let ([bw (box 0)] 1352 [bu (box #f)] 1353 [tab-size (send text get-tab-size)]) 1354 (unless (and (null? (send text get-tabs #f bw bu)) 1355 (= tab-size (unbox bw)) 1356 (not (unbox bu))) 1357 (send text set-tabs null (send text get-tab-size) #f))) 1358 (send text set-styles-fixed #t) 1359 (send text end-edit-sequence)) 1360 1361 (define tabify-pref (preferences:get 'framework:tabify)) 1362 (define tabify-pref-callback (lambda (k v) (set! tabify-pref v))) 1363 (preferences:add-callback 1364 'framework:tabify 1365 tabify-pref-callback 1366 #t) 1367 1368 (define/override (put-file text sup directory default-name) 1369 ;; don't call the surrogate's super, since it sets the default extension 1370 (cond 1371 [(equal? (finder:default-extension) "") 1372 (parameterize ([finder:default-extension "rkt"]) 1373 (sup directory default-name))] 1374 [else (sup directory default-name)])) 1375 1376 (define/override (set-get-token get-token-) 1377 (super set-get-token (wrap-get-token get-token- (λ () tabify-pref)))) 1378 1379 (super-new (get-token (wrap-get-token module-lexer/waived (λ () tabify-pref))) 1380 (token-sym->style short-sym->style-name) 1381 (matches '((|(| |)|) 1382 (|[| |]|) 1383 (|{| |}|)))))) 1384 1385 (define (wrap-get-token get-token- get-tabify-pref) 1386 (define wrapped-get-token 1387 (cond 1388 [(procedure-arity-includes? get-token- 3) 1389 (λ (in offset mode) 1390 (define-values (lexeme type paren start end backup-delta new-mode) 1391 (get-token- in offset mode)) 1392 (cond 1393 [(and (eq? type 'symbol) 1394 (string? lexeme) 1395 (get-head-sexp-type-from-prefs lexeme (get-tabify-pref))) 1396 (values lexeme 'keyword paren start end backup-delta new-mode)] 1397 [else 1398 (values lexeme type paren start end backup-delta new-mode)]))] 1399 [else 1400 (λ (in) 1401 (define-values (lexeme type paren start end) (get-token- in)) 1402 (cond 1403 [(and (eq? type 'symbol) 1404 (string? lexeme) 1405 (get-head-sexp-type-from-prefs lexeme (get-tabify-pref))) 1406 (values lexeme 'keyword paren start end)] 1407 [else 1408 (values lexeme type paren start end)]))])) 1409 (procedure-rename wrapped-get-token 1410 (string->symbol 1411 (format "~a wrapped" (object-name get-token-))))) 1412 1413 ;; get-head-sexp-type-from-prefs : string (list ht regexp regexp regexp) 1414 ;; -> (or/c #f 'lambda 'define 'begin 'for/fold) 1415 (define (get-head-sexp-type-from-prefs text pref) 1416 (define ht (car pref)) 1417 (define beg-reg (list-ref pref 1)) 1418 (define def-reg (list-ref pref 2)) 1419 (define lam-reg (list-ref pref 3)) 1420 (define for/fold-reg (list-ref pref 4)) 1421 (hash-ref 1422 ht 1423 (with-handlers ((exn:fail:read? (λ (x) #f))) 1424 (read (open-input-string text))) 1425 (λ () 1426 (cond 1427 [(and beg-reg (regexp-match? beg-reg text)) 'begin] 1428 [(and def-reg (regexp-match? def-reg text)) 'define] 1429 [(and lam-reg (regexp-match? lam-reg text)) 'lambda] 1430 [(and for/fold-reg (regexp-match? for/fold-reg text)) 'for/fold] 1431 [else #f])))) 1432 1433 1434 ;; in-position? : text (list symbol) -> boolean 1435 ;; determines if the cursor is currently sitting in a particular 1436 ;; position. To make detection of whether the cursor is in 1437 ;; a string or comment more robust, check also the position 1438 ;; right before the cursor to make sure it matches. This handles 1439 ;; the situation ... |"blah blah" where | indicates cursor; in 1440 ;; this case, the cursor is _not_ in the string (although 1441 ;; classify-position characterizes it so). 1442 (define (in-position? text sym-list) 1443 (define selection-start (send text get-start-position)) 1444 (define class-right (send text classify-position selection-start)) 1445 (define class-left (and (> selection-start 0) 1446 (send text classify-position (- selection-start 1)))) 1447 ; By default, the position class is the class of the token at the r.h.s of the cursor. 1448 (define the-class class-right) 1449 ; Now for some special cases: 1450 ; 1451 ; Check if the cursor is right after a line comment, that is, on the newline character on the same 1452 ; line as the comment (which position is classified as 'white-space instead of 'comment). 1453 ; If so, a newly inserted character will still be in the line comment. 1454 (when (eq? 'comment class-left) ; right after a comment 1455 (define-values (token-start token-end) ; l.h.s. token 1456 (send text get-token-range (- selection-start 1))) 1457 ; Notice: This uses a racket-specific check, which is not ideal. Instead the tokenizer should 1458 ; be able to report the comment kind but that would likely be either messy or bwd incompatible. 1459 (when (eqv? #\; (send text get-character token-start)) ; line comment 1460 (set! the-class class-left))) 1461 ; Check if the cursor is right before a string or a comment; if so a newly inserted character 1462 ; will *not* be inside the string or comment, so we reclassify the position as 'white-space. 1463 (when (memq class-right '(comment string)) 1464 (define-values (token-start token-end) ; r.h.s. token 1465 (send text get-token-range selection-start)) 1466 (when (= token-start selection-start) 1467 (set! the-class 'white-space))) 1468 (and (member the-class sym-list) #t)) 1469 1470 ;; determines if the cursor is currently sitting in a string 1471 ;; literal or a comment. 1472 (define (in-string/comment? text) 1473 (in-position? text '(comment string))) 1474 1475 ;; produces the 1 character string immediately following 1476 ;; the cursor, if there is one and if there is not a current 1477 ;; selection, in which case produces #f 1478 (define (immediately-following-cursor text) 1479 (define selection-start (send text get-start-position)) 1480 (and (= selection-start (send text get-end-position)) ; nothing selected 1481 (< selection-start (send text last-position)) 1482 (send text get-text selection-start (+ selection-start 1)))) 1483 1484 1485 (define set-mode-mixin 1486 (mixin (-text<%> mode:host-text<%>) () 1487 (super-new) 1488 (inherit set-surrogate) 1489 (set-surrogate (new text-mode%)))) 1490 1491 (define -text% (set-mode-mixin 1492 (text-mixin 1493 (text:autocomplete-mixin 1494 (mode:host-text-mixin 1495 color:text%))))) 1496 1497 (define text-mode% (text-mode-mixin color:text-mode%)) 1498 1499 (define (setup-keymap keymap #:alt-as-meta-keymap [alt-as-meta-keymap #f]) 1500 (define (add-function name f) 1501 (send keymap add-function name f) 1502 (when alt-as-meta-keymap 1503 (send alt-as-meta-keymap add-function name f))) 1504 (define (add-edit-function name f) 1505 (send keymap add-function name (λ (edit event) (f edit))) 1506 (when alt-as-meta-keymap 1507 (send alt-as-meta-keymap add-function name (λ (edit event) (f edit))))) 1508 (define (add-pos-function name f) 1509 (define callback (λ (edit event) 1510 (f edit (send edit get-start-position)))) 1511 (send keymap add-function name callback) 1512 (when alt-as-meta-keymap 1513 (send alt-as-meta-keymap add-function name callback))) 1514 (add-pos-function "remove-sexp" (λ (e p) (send e remove-sexp p))) 1515 (add-pos-function "forward-sexp" (λ (e p) (send e forward-sexp p))) 1516 (add-pos-function "backward-sexp" (λ (e p) (send e backward-sexp p))) 1517 (add-pos-function "up-sexp" (λ (e p) (send e up-sexp p))) 1518 (add-pos-function "down-sexp" (λ (e p) (send e down-sexp p))) 1519 (add-pos-function "flash-backward-sexp" (λ (e p) (send e flash-backward-sexp p))) 1520 (add-pos-function "flash-forward-sexp" (λ (e p) (send e flash-forward-sexp p))) 1521 (add-pos-function "remove-parens-forward" (λ (e p) (send e remove-parens-forward p))) 1522 (add-pos-function "transpose-sexp" (λ (e p) (send e transpose-sexp p))) 1523 (add-pos-function "mark-matching-parenthesis" 1524 (λ (e p) (send e mark-matching-parenthesis p))) 1525 (add-pos-function "introduce-let-ans" 1526 (λ (e p) (send e introduce-let-ans p))) 1527 (add-pos-function "move-sexp-out" 1528 (λ (e p) (send e move-sexp-out p))) 1529 (add-pos-function "kill-enclosing-parens" 1530 (lambda (e p) (send e kill-enclosing-parens p))) 1531 (add-pos-function "toggle-round-square-parens" 1532 (lambda (e p) (send e toggle-round-square-parens p))) 1533 1534 (add-edit-function "select-forward-sexp" 1535 (λ (x) (send x select-forward-sexp))) 1536 (add-edit-function "select-backward-sexp" 1537 (λ (x) (send x select-backward-sexp))) 1538 (add-edit-function "select-down-sexp" 1539 (λ (x) (send x select-down-sexp))) 1540 (add-edit-function "select-up-sexp" 1541 (λ (x) (send x select-up-sexp))) 1542 (add-edit-function "tabify-at-caret" 1543 (λ (x) (send x tabify-selection))) 1544 (add-edit-function "do-return" 1545 (λ (x) (send x insert-return))) 1546 (add-edit-function "comment-out" 1547 (λ (x) (send x comment-out-selection))) 1548 (add-edit-function "box-comment-out" 1549 (λ (x) (send x box-comment-out-selection))) 1550 (add-edit-function "uncomment" 1551 (λ (x) (send x uncomment-selection))) 1552 1553 (add-function "paren-double-select" 1554 (λ (text event) 1555 (keymap:region-click 1556 text event 1557 (λ (click-pos eol?) 1558 (define (word-based) 1559 (define start-box (box click-pos)) 1560 (define end-box (box click-pos)) 1561 (send text find-wordbreak start-box end-box 'selection) 1562 (values (unbox start-box) (unbox end-box))) 1563 (define token (send text classify-position click-pos)) 1564 (define-values (start end) 1565 (cond 1566 [(memq token '(string comment text)) (word-based)] 1567 [(and (equal? token 'other) 1568 (let-values ([(start end) (send text get-token-range click-pos)]) 1569 (and start 1570 end 1571 (let ([str (send text get-text start end)]) 1572 (or (regexp-match? #rx"^#lang" str) 1573 (regexp-match? #rx"^#!" str)))))) 1574 (word-based)] 1575 [(and (equal? token 'parenthesis) 1576 (ormap (λ (pr) (equal? (cdr pr) (string (send text get-character click-pos)))) 1577 (racket-paren:get-paren-pairs))) 1578 (define start (send text get-backward-sexp (+ click-pos 1))) 1579 (if start 1580 (values start (+ click-pos 1)) 1581 (word-based))] 1582 [else 1583 (let ([end (send text get-forward-sexp click-pos)]) 1584 (if end 1585 (let ([beginning (send text get-backward-sexp end)]) 1586 (if beginning 1587 (values beginning end) 1588 (word-based))) 1589 (word-based)))])) 1590 (send text set-position start end))))) 1591 1592 (let ([add/map-non-clever 1593 (λ (name keystroke char [closer #f]) 1594 (add-edit-function 1595 name 1596 (λ (e) 1597 (send e begin-edit-sequence) 1598 (define start (send e get-start-position)) 1599 (define stop (send e get-end-position)) 1600 (send e insert char start stop) 1601 (when (and closer (preferences:get 'framework:automatic-parens)) 1602 (send e insert closer (+ start 1) (+ start 1))) 1603 (send e end-edit-sequence))) 1604 (send keymap map-function keystroke name))]) 1605 (add/map-non-clever "non-clever-open-square-bracket" "~g:c:[" #\[ #\]) 1606 (add/map-non-clever "non-clever-close-square-bracket" "~g:c:]" #\]) 1607 (add/map-non-clever "non-clever-close-curley-bracket" "~g:c:}" #\}) 1608 (add/map-non-clever "non-clever-close-round-paren" "~g:c:)" #\))) 1609 1610 (add-function "balance-parens" 1611 (λ (edit event) 1612 (send edit balance-parens event))) 1613 (add-function "balance-parens-forward" 1614 (λ (edit event) 1615 (send edit balance-parens event 'forward))) 1616 1617 (send keymap map-function "TAB" "tabify-at-caret") 1618 1619 (send keymap map-function "return" "do-return") 1620 (send keymap map-function "s:return" "do-return") 1621 (send keymap map-function "s:c:return" "do-return") 1622 (send keymap map-function "a:return" "do-return") 1623 (send keymap map-function "s:a:return" "do-return") 1624 (send keymap map-function "c:a:return" "do-return") 1625 (send keymap map-function "c:s:a:return" "do-return") 1626 (send keymap map-function "c:return" "do-return") 1627 (send keymap map-function "d:return" "do-return") 1628 1629 (send keymap map-function ")" "balance-parens") 1630 (send keymap map-function "]" "balance-parens") 1631 (send keymap map-function "}" "balance-parens") 1632 1633 (send keymap map-function "leftbuttondouble" "paren-double-select") 1634 1635 1636 ;(define (insert-brace-pair text open-brace close-brace [space-between? #f]) 1637 ; (insert/check/balance text open-brace close-brace #f space-between?)) 1638 #| 1639 (define selection-start (send text get-start-position)) 1640 (define hash-before? ; tweak to detect and correctly close block comments #| ... |# 1641 (and (< 0 selection-start) 1642 (string=? "#" (send text get-text (- selection-start 1) selection-start)))) 1643 (send text begin-edit-sequence) 1644 (send text set-position (send text get-end-position)) 1645 (when space-between? (send text insert " ")) 1646 (send text insert close-brace) 1647 (when (and (char? open-brace) (char=? #\| open-brace) hash-before?) 1648 (send text insert #\#)) 1649 (send text set-position selection-start) 1650 (send text insert open-brace) 1651 (when space-between? 1652 (send text set-position (+ (send text get-start-position) 1))) 1653 (send text end-edit-sequence))|# 1654 1655 ;; Inserts the open parens character and, if the resulting token 1656 ;; type satisfies checkp, then go ahead and insert the close parens 1657 ;; and set the cursor between them. 1658 ;; When space-between?, adds a space between the braces and places 1659 ;; the cursor after the space. 1660 ;; checkp: (or/c #f symbol (symbol -> boolean)) 1661 ;; When checkp is #f, always inserts both open and close braces 1662 ;; When checkp is a symbol, only inserts the closing brace if 1663 ;; the tokenizer identifies open-brace as that type of token 1664 ;; having inserted it 1665 ;; When checkp is a predicate, only inserts the closing brace if 1666 ;; the token type of the inserted open-brace satisfies it 1667 (define (insert-brace-pair text open-brace close-brace [checkp #f] [space-between? #f]) 1668 (define selection-start (send text get-start-position)) 1669 (define selection-end (send text get-end-position)) 1670 (define open-len (if (string? open-brace) (string-length open-brace) 1)) 1671 (send text begin-edit-sequence #t #f) 1672 (send text insert open-brace selection-start) 1673 (define tok-type (send text classify-position selection-start)) 1674 (when (or (not checkp) 1675 (and (symbol? checkp) (eq? checkp tok-type)) 1676 (and (procedure? checkp) (checkp tok-type))) 1677 (define hash-before? ; tweak to detect and correctly close block comments #| ... |# 1678 ; Notice: This is racket-specific and despite the name of the file we should instead rely 1679 ; on the lexer alone so as to be language-agnostic. 1680 ; Currently though the lexer does not provide enough information about the comment type. 1681 (and (< 0 selection-start) 1682 (string=? "#" (send text get-text (- selection-start 1) selection-start)))) 1683 (send text set-position (+ selection-end open-len)) 1684 (when space-between? (send text insert " ")) 1685 (send text insert close-brace) 1686 (when (and (char? open-brace) (char=? #\| open-brace) hash-before?) 1687 (send text insert #\#)) 1688 (send text set-position (+ selection-start open-len (if space-between? 1 0)))) 1689 (send text end-edit-sequence)) 1690 1691 1692 ;; only insert a pair if automatic-parens preference is on, depending 1693 ;; on other analyses of the state of the text (e.g. auto-parens shouldn't 1694 ;; affect typing literal characters inside a string constant, etc.) 1695 (define (maybe-insert-brace-pair text open-brace close-brace) 1696 (define open-parens 1697 (for/list ([x (racket-paren:get-paren-pairs)]) (string-ref (car x) 0))) 1698 (cond 1699 [(not (preferences:get 'framework:automatic-parens)) 1700 (define startpos (send text get-start-position)) 1701 (if (and (send text get-overwrite-mode) 1702 (= startpos (send text get-end-position))) 1703 (send text insert open-brace startpos (add1 startpos)) 1704 (send text insert open-brace))] 1705 1706 [else ; automatic-parens is enabled 1707 (define c (immediately-following-cursor text)) 1708 (define cur-token 1709 (send text classify-position (send text get-start-position))) 1710 (cond 1711 ; insert paren pair if it results valid parenthesis token... 1712 [(member open-brace open-parens) 1713 (insert-brace-pair text open-brace close-brace 'parenthesis)] 1714 1715 ; ASSUME: from here on, open-brace is either " or | 1716 [else 1717 ;(printf "tok ~a~n" cur-token) 1718 (match cur-token 1719 [(or 'error #f) (insert-brace-pair text open-brace close-brace 'error)] 1720 ['constant (insert-brace-pair text open-brace close-brace 1721 (λ (t) (not (equal? t 'constant))))] 1722 [(or 'symbol 'comment) 1723 (cond 1724 [(and c (char=? #\| open-brace) (string=? c "|")) ;; smart skip 1725 (send text set-position (+ 1 (send text get-end-position))) 1726 (define d (immediately-following-cursor text)) 1727 (when (and d (string=? d "#")) ; a block comment? 1728 (send text set-position (+ 1 (send text get-end-position))))] 1729 [(in-position? text '(comment)) (send text insert open-brace)] 1730 [else (insert-brace-pair text open-brace close-brace)])] 1731 ['string 1732 (cond 1733 [(not (char=? #\" open-brace)) 1734 (insert-brace-pair text open-brace close-brace 1735 (λ (t) (not (or (equal? 'comment t) (equal? 'string t)))))] 1736 [else 1737 (define start-position (send text get-start-position)) 1738 (define end-position (send text get-end-position)) 1739 (cond 1740 ; smart skip a " if it is the immediately following character (c) 1741 [(and c (string=? c "\"")) 1742 (send text set-position (+ 1 end-position))] 1743 1744 ; there is no current selection - split the string in two 1745 [(= start-position end-position) 1746 (insert-brace-pair text #\" #\" #f #t)] 1747 1748 ; there is a selection - split the selected text off as a 1749 ; separate string from the surrounding in an intelligent way 1750 ; and retain selection of the split-out string 1751 [else (define selection-length (- end-position start-position)) 1752 (insert-brace-pair text "\" \"" "\" \"") 1753 (define cur-position (send text get-start-position)) 1754 (send text set-position 1755 (- cur-position 1) 1756 (+ cur-position selection-length 1))])])] 1757 [_ (insert-brace-pair text open-brace close-brace 1758 (λ (t) (not (equal? 'comment t))))])])])) 1759 1760 1761 1762 1763 (add-edit-function "insert-()-pair" (λ (text) (insert-brace-pair text #\( #\)))) 1764 (add-edit-function "insert-[]-pair" (λ (text) (insert-brace-pair text #\[ #\]))) 1765 (add-edit-function "insert-{}-pair" (λ (text) (insert-brace-pair text #\{ #\}))) 1766 (add-edit-function "insert-\"\"-pair" (λ (text) (insert-brace-pair text #\" #\"))) 1767 (add-edit-function "insert-||-pair" (λ (text) (insert-brace-pair text #\| #\|))) 1768 1769 (add-edit-function "maybe-insert-()-pair" (λ (text) (maybe-insert-brace-pair text #\( #\)))) 1770 (add-edit-function "maybe-insert-[]-pair" (λ (text) (maybe-insert-brace-pair text #\[ #\]))) 1771 (add-edit-function "maybe-insert-{}-pair" (λ (text) (maybe-insert-brace-pair text #\{ #\}))) 1772 (add-edit-function "maybe-insert-\"\"-pair" (λ (text) (maybe-insert-brace-pair text #\" #\"))) 1773 (add-edit-function "maybe-insert-||-pair" (λ (text) (maybe-insert-brace-pair text #\| #\|))) 1774 1775 (add-edit-function "maybe-insert-[]-pair-maybe-fixup-[]" 1776 (λ (text) 1777 (cond 1778 [(or (not (preferences:get 'framework:fixup-open-parens)) 1779 (send text is-stopped?)) 1780 (maybe-insert-brace-pair text #\[ #\])] 1781 [else 1782 (insert-paren text)]))) 1783 1784 ;; Deletes empty brace pairs (including " and |) depending on context, in a manner intended 1785 ;; to be usually the inverse of auto-parens. 1786 ;; Dependent on Racket's parens being single characters. 1787 (define (maybe-delete-empty-brace-pair text) 1788 (cond 1789 [(not (preferences:get 'framework:automatic-parens)) (send text delete)] 1790 [else 1791 (define selection-start (send text get-start-position)) 1792 (define prev-position (- selection-start 1)) 1793 (define next-position (+ selection-start 1)) 1794 (define before-and-after 1795 (and (= selection-start (send text get-end-position)) ; nothing selected 1796 (< 0 selection-start) 1797 (< selection-start (send text last-position)) 1798 (send text get-text prev-position next-position))) 1799 (define (paren-pair? two-str) 1800 (and two-str 1801 (equal? (send text get-matching-paren-string (substring two-str 0 1) 'close) 1802 (substring two-str 1)))) 1803 (define cur-token (send text classify-position selection-start)) 1804 (define adj-tokens 1805 (and (< 0 selection-start) 1806 (equal? cur-token (send text classify-position prev-position)) 1807 cur-token)) 1808 (match* (before-and-after adj-tokens) 1809 [((? paren-pair?) 'parenthesis) 1810 (send text delete prev-position next-position)] 1811 [("\"\"" 'error) 1812 (send text delete prev-position next-position)] 1813 [("\"\"" 'string) 1814 (if (and (< 0 prev-position) 1815 (string=? "\\" (send text get-text (- selection-start 2) prev-position))) 1816 (send text delete) 1817 (send text delete prev-position next-position))] 1818 [("||" (or 'comment 'symbol 'error)) 1819 (cond 1820 [(and (< 0 prev-position) 1821 (< next-position (send text last-position)) 1822 (string=? "#||#" (send text get-text (- selection-start 2) (+ selection-start 2)))) 1823 (send text delete prev-position (+ selection-start 2))] 1824 [(equal? adj-tokens 'comment) (send text delete)] 1825 [else (send text delete prev-position next-position)])] 1826 [(_ _) (send text delete)])])) 1827 1828 (add-edit-function "maybe-delete-empty-brace-pair" maybe-delete-empty-brace-pair) 1829 1830 (define (insert-lambda-template edit) 1831 (send edit begin-edit-sequence) 1832 (let ([selection-start (send edit get-start-position)]) 1833 (send edit set-position (send edit get-end-position)) 1834 (send edit insert ")") 1835 (send edit set-position selection-start) 1836 (send edit insert ") ") 1837 (send edit set-position selection-start) 1838 (send edit insert "(λ (")) 1839 (send edit end-edit-sequence)) 1840 1841 (add-edit-function "insert-lambda-template" insert-lambda-template) 1842 1843 (define (map-meta key func) (keymap:send-map-function-meta keymap key func #:alt-as-meta-keymap alt-as-meta-keymap)) 1844 (define (map key func) (send keymap map-function key func)) 1845 1846 (map-meta "up" "up-sexp") 1847 (map-meta "c:u" "up-sexp") 1848 (map "a:up" "up-sexp") 1849 (map-meta "s:up" "select-up-sexp") 1850 (map "a:s:up" "select-up-sexp") 1851 (map-meta "s:c:u" "select-up-sexp") 1852 1853 (map-meta "down" "down-sexp") 1854 (map "a:down" "down-sexp") 1855 (map-meta "s:down" "select-down-sexp") 1856 (map "a:s:down" "select-down-sexp") 1857 (map-meta "s:c:down" "select-down-sexp") 1858 1859 (map-meta "right" "forward-sexp") 1860 (map "a:right" "forward-sexp") 1861 (map "m:right" "forward-sexp") 1862 (map-meta "s:right" "select-forward-sexp") 1863 (map "a:s:right" "select-forward-sexp") 1864 (map "m:s:right" "select-forward-sexp") 1865 1866 (map-meta "left" "backward-sexp") 1867 (map "a:left" "backward-sexp") 1868 (map "m:left" "backward-sexp") 1869 (map-meta "s:left" "select-backward-sexp") 1870 (map "a:s:left" "select-backward-sexp") 1871 (map "m:s:left" "select-backward-sexp") 1872 1873 (map-meta "return" "do-return") 1874 (map-meta "s:return" "do-return") 1875 (map-meta "s:c:return" "do-return") 1876 (map-meta "a:return" "do-return") 1877 (map-meta "s:a:return" "do-return") 1878 (map-meta "c:a:return" "do-return") 1879 (map-meta "c:s:a:return" "do-return") 1880 (map-meta "c:return" "do-return") 1881 1882 (map-meta "c:semicolon" "comment-out") 1883 (map-meta "c:=" "uncomment") 1884 (map-meta "c:k" "remove-sexp") 1885 1886 (map-meta "c:f" "forward-sexp") 1887 (map-meta "s:c:f" "select-forward-sexp") 1888 1889 (map-meta "c:b" "backward-sexp") 1890 (map-meta "s:c:b" "select-backward-sexp") 1891 1892 (map-meta "c:p" "flash-backward-sexp") 1893 (map-meta "s:c:n" "flash-forward-sexp") 1894 1895 (map-meta "c:space" "select-forward-sexp") 1896 (map-meta "c:t" "transpose-sexp") 1897 1898 ;(map-meta "c:m" "mark-matching-parenthesis") 1899 ; this keybinding doesn't interact with the paren colorer 1900 1901 (map-meta ")" "balance-parens-forward") 1902 (map-meta "]" "balance-parens-forward") 1903 (map-meta "}" "balance-parens-forward") 1904 1905 (map-meta "(" "insert-()-pair") 1906 (map-meta "[" "insert-[]-pair") 1907 (map-meta "{" "insert-{}-pair") 1908 (map-meta "\"" "insert-\"\"-pair") 1909 (map-meta "|" "insert-||-pair") 1910 1911 (map "(" "maybe-insert-()-pair") 1912 (map "[" "maybe-insert-[]-pair-maybe-fixup-[]") 1913 (map "{" "maybe-insert-{}-pair") 1914 (map "\"" "maybe-insert-\"\"-pair") 1915 (map "|" "maybe-insert-||-pair") 1916 1917 (map "~c:backspace" "maybe-delete-empty-brace-pair") 1918 1919 (map-meta "s:l" "insert-lambda-template") 1920 1921 (map "c:c;c:b" "remove-parens-forward") 1922 (map "c:c;c:l" "introduce-let-ans") 1923 (map "c:c;c:o" "move-sexp-out") 1924 (map "c:c;c:e" "kill-enclosing-parens") 1925 (map "c:c;c:[" "toggle-round-square-parens")) 1926 1927 (define keymap (make-object keymap:aug-keymap%)) 1928 (define alt-as-meta-keymap (make-object keymap:aug-keymap%)) 1929 (setup-keymap keymap #:alt-as-meta-keymap alt-as-meta-keymap) 1930 (define (get-keymap) keymap) 1931 1932 (define (adjust-alt-as-meta on?) 1933 (send keymap remove-chained-keymap alt-as-meta-keymap) 1934 (when on? 1935 (send keymap chain-to-keymap alt-as-meta-keymap #f))) 1936 (preferences:add-callback 'framework:alt-as-meta 1937 (λ (p v) (adjust-alt-as-meta v))) 1938 (adjust-alt-as-meta (preferences:get 'framework:alt-as-meta)) 1939 1940 ;; choose-paren : racket-text number -> character 1941 ;; returns the character to replace a #\[ with, based 1942 ;; on the context where it is typed in. 1943 (define (insert-paren text) 1944 (let* ([pos (send text get-start-position)] 1945 [real-char #\[] 1946 [change-to (λ (i c) 1947 ;(printf "change-to, case ~a\n" i) 1948 (set! real-char c))] 1949 [start-pos (send text get-start-position)] 1950 [end-pos (send text get-end-position)] 1951 [letrec-like-forms (preferences:get 'framework:square-bracket:letrec)] 1952 [for/fold-like-forms (preferences:get 'framework:square-bracket:for/fold)]) 1953 (send text begin-edit-sequence #f #f) 1954 (if (and (send text get-overwrite-mode) (= start-pos end-pos)) 1955 (send text insert "[" start-pos (add1 start-pos) #f) 1956 (send text insert "[" start-pos 'same #f)) 1957 (when (equal? (send text classify-position pos) 'parenthesis) 1958 (let* ([before-whitespace-pos (send text skip-whitespace pos 'backward #t)] 1959 [keyword/distance (find-keyword-and-distance before-whitespace-pos text)]) 1960 (cond 1961 [(and keyword/distance 1962 (member keyword/distance 1963 (preferences:get 'framework:square-bracket:cond/offset))) 1964 ;; just leave the square backet in, in this case 1965 (void)] 1966 [(and keyword/distance 1967 (member (car keyword/distance) 1968 (preferences:get 'framework:square-bracket:local))) 1969 (unless (= (cadr keyword/distance) 0) 1970 (change-to 7 #\())] 1971 [else 1972 (let* ([backward-match (send text backward-match before-whitespace-pos 0)] 1973 [b-m-char (and (number? backward-match) (send text get-character backward-match))]) 1974 (cond 1975 [backward-match 1976 ;; there is an expression before this, at this layer 1977 (define before-whitespace-pos2 1978 (send text skip-whitespace backward-match 'backward #t)) 1979 (define backward-match2 (send text backward-match before-whitespace-pos2 0)) 1980 (cond 1981 [(member b-m-char '(#\( #\[ #\{)) 1982 ;; found a "sibling" parenthesized sequence. use the parens it uses. 1983 (change-to 1 b-m-char)] 1984 [else 1985 ;; otherwise, we switch to ( 1986 (change-to 2 #\()])] 1987 [(not (zero? before-whitespace-pos)) 1988 ;; this is the first thing in the sequence 1989 ;; pop out one layer and look for a keyword. 1990 (define b-w-p-char (send text get-character (- before-whitespace-pos 1))) 1991 (cond 1992 [(equal? b-w-p-char #\() 1993 (define second-before-whitespace-pos (send text skip-whitespace 1994 (- before-whitespace-pos 1) 1995 'backward 1996 #t)) 1997 (define second-backwards-match (send text backward-match 1998 second-before-whitespace-pos 1999 0)) 2000 (cond 2001 [(not second-backwards-match) 2002 (change-to 3 #\()] 2003 [(and (beginning-of-sequence? text second-backwards-match) 2004 (ormap (λ (x) (text-between-equal? x 2005 text 2006 second-backwards-match 2007 second-before-whitespace-pos)) 2008 letrec-like-forms)) 2009 ;; we found a let<mumble> keyword, so we get a square bracket 2010 (void)] 2011 [else 2012 ;; go back one more sexp in the same row, looking for `let loop' pattern 2013 (define second-before-whitespace-pos2 (send text skip-whitespace 2014 second-backwards-match 2015 'backward 2016 #t)) 2017 (define second-backwards-match2 (send text backward-match 2018 second-before-whitespace-pos2 2019 0)) 2020 (cond 2021 [(and second-backwards-match2 2022 (ormap (λ (x) 2023 (text-between-equal? x 2024 text 2025 second-backwards-match2 2026 second-before-whitespace-pos2)) 2027 for/fold-like-forms)) 2028 ;; found a for/fold-like form, so we keep the [ 2029 (void)] 2030 [(and second-backwards-match2 2031 (member (send text classify-position second-backwards-match) 2032 ;;; otherwise, this isn't a `let loop', 2033 ;;; it is a regular let 2034 '(symbol keyword)) 2035 (member "let" letrec-like-forms) 2036 (text-between-equal? "let" 2037 text 2038 second-backwards-match2 2039 second-before-whitespace-pos2)) 2040 ;; found the `(let loop (' so we keep the [ 2041 (void)] 2042 [else 2043 ;; otherwise, round. 2044 (change-to 4 #\()])])] 2045 [else 2046 (change-to 5 #\()])] 2047 [else 2048 (change-to 6 #\()]))]))) 2049 (send text delete pos (+ pos 1) #f) 2050 (send text end-edit-sequence) 2051 (cond 2052 [(and (preferences:get 'framework:automatic-parens) 2053 (not (in-string/comment? text))) 2054 (send text insert real-char start-pos start-pos) 2055 (when (equal? (send text classify-position start-pos) 'parenthesis) 2056 (send text insert (case real-char 2057 [(#\() #\)] 2058 [(#\[) #\]] 2059 [(#\{) #\}]) 2060 (+ end-pos 1) (+ end-pos 1)) 2061 (send text set-position (+ start-pos 1)))] 2062 [else 2063 (send text insert real-char start-pos end-pos)]))) 2064 2065 ;; find-keyword-and-distance : -> (union #f (cons string number)) 2066 (define (find-keyword-and-distance before-whitespace-pos text) 2067 ;; searches backwards for the keyword in the sequence at this level. 2068 ;; if found, it counts how many sexps back it was 2069 (let loop ([pos before-whitespace-pos] 2070 [n 0]) 2071 (let ([backward-match (send text backward-match pos 0)]) 2072 (cond 2073 [backward-match 2074 (let ([before-whitespace-pos (send text skip-whitespace backward-match 'backward #t)]) 2075 (loop before-whitespace-pos 2076 (if (send text stick-to-next-sexp? backward-match) 2077 n 2078 (+ n 1))))] 2079 [else 2080 (let* ([afterwards (send text get-forward-sexp pos)] 2081 [keyword 2082 (and afterwards 2083 (send text get-text pos afterwards))]) 2084 (and keyword 2085 (list keyword (- n 1))))])))) 2086 2087 ;; beginning-of-sequence? : text number -> boolean 2088 ;; determines if this position is at the beginning of a sequence 2089 ;; that begins with a parenthesis. 2090 (define (beginning-of-sequence? text start) 2091 (let ([before-space (send text skip-whitespace start 'backward #t)]) 2092 (cond 2093 [(zero? before-space) #t] 2094 [else 2095 (equal? (send text get-character (- before-space 1)) 2096 #\()]))) 2097 2098 (define (text-between-equal? str text start end) 2099 (and (= (string-length str) (- end start)) 2100 (let loop ([i (string-length str)]) 2101 (cond 2102 [(= i 0) #t] 2103 [else 2104 (and (char=? (string-ref str (- i 1)) 2105 (send text get-character (+ i start -1))) 2106 (loop (- i 1)))])))) 2107 2108 2109 ; ;;; ;;; 2110 ; ; ; 2111 ; ; ; 2112 ; ;;; ; ;;; ;;; ;;;;; ;;; ; ;;; ;;;; ; ;;; ;;; ; 2113 ;; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; 2114 ;; ; ; ;;;;; ; ;;; ; ; ;;;; ; ; ;;;;; ; 2115 ;; ; ; ; ; ; ; ; ; ; ; ; ; ; 2116 ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; 2117 ;;;;; ;;;; ;;; ;;;; ;;; ;;;; ;;; ;;;; ;; ;;; ;;;;;; 2118 ;; ; 2119 ;; ; 2120 ;;;; ;;; 2121 2122 2123 (define (add-preferences-panel) 2124 (preferences:add-panel 2125 (list (string-constant editor-prefs-panel-label) 2126 (string-constant indenting-prefs-panel-label)) 2127 make-indenting-prefs-panel) 2128 (preferences:add-panel 2129 (list (string-constant editor-prefs-panel-label) 2130 (string-constant square-bracket-prefs-panel-label)) 2131 make-square-bracket-prefs-panel)) 2132 2133 (define (make-square-bracket-prefs-panel p) 2134 (define main-panel (make-object vertical-panel% p)) 2135 (define boxes-panel (new-horizontal-panel% [parent main-panel])) 2136 2137 (define (mk-list-box sym keyword-type pref->string get-new-one) 2138 (letrec ([vp (new-vertical-panel% [parent boxes-panel])] 2139 [_ (new message% 2140 [label (format (string-constant x-like-keywords) keyword-type)] 2141 [parent vp])] 2142 [lb 2143 (new list-box% 2144 [label #f] 2145 [parent vp] 2146 [choices (map pref->string (preferences:get sym))] 2147 [callback 2148 (λ (lb evt) 2149 (send remove-button enable (pair? (send lb get-selections))))])] 2150 [bp (new-horizontal-panel% [parent vp] [stretchable-height #f])] 2151 [add 2152 (new button% 2153 [label (string-constant add-keyword)] 2154 [parent bp] 2155 [callback 2156 (λ (x y) 2157 (let ([new-one (get-new-one)]) 2158 (when new-one 2159 (preferences:set sym (append (preferences:get sym) 2160 (list new-one))))))])] 2161 [remove-button 2162 (new button% 2163 [label (string-constant remove-keyword)] 2164 [parent bp] 2165 [callback 2166 (λ (x y) 2167 (let ([n (send lb get-selections)]) 2168 (when (pair? n) 2169 (preferences:set 2170 sym 2171 (let loop ([i 0] 2172 [prefs (preferences:get sym)]) 2173 (cond 2174 [(= i (car n)) (cdr prefs)] 2175 [else (cons (car prefs) 2176 (loop (+ i 1) 2177 (cdr prefs)))]))) 2178 (cond 2179 [(= 0 (send lb get-number)) 2180 (send remove-button enable #f)] 2181 [else 2182 (send lb set-selection 2183 (if (= (car n) (send lb get-number)) 2184 (- (send lb get-number) 1) 2185 (car n)))]))))])]) 2186 (unless (pair? (send lb get-selections)) 2187 (send remove-button enable #f)) 2188 (preferences:add-callback sym 2189 (λ (p v) 2190 (send lb clear) 2191 (for-each (λ (x) (send lb append (pref->string x))) v))))) 2192 2193 (define (get-new-simple-keyword label) 2194 (λ () 2195 (let ([new-one 2196 (keymap:call/text-keymap-initializer 2197 (λ () 2198 (get-text-from-user 2199 (format (string-constant enter-new-keyword) label) 2200 (format (string-constant x-keyword) label))))]) 2201 (and new-one 2202 (let ([parsed (with-handlers ((exn:fail:read? (λ (x) #f))) 2203 (read (open-input-string new-one)))]) 2204 2205 (and (symbol? parsed) 2206 (symbol->string parsed))))))) 2207 2208 (define (get-new-cond-keyword) 2209 (define f (new dialog% [label (format (string-constant enter-new-keyword) "Cond")])) 2210 (define tb (keymap:call/text-keymap-initializer 2211 (λ () 2212 (new text-field% 2213 [parent f] 2214 [label #f])))) 2215 (define number-panel (new-horizontal-panel% [parent f] [stretchable-height #f])) 2216 (define number-label (new message% 2217 [parent number-panel] 2218 [label (string-constant skip-subexpressions)])) 2219 (define number 2220 (keymap:call/text-keymap-initializer 2221 (λ () 2222 (new text-field% 2223 [parent number-panel] 2224 [init-value "1"] 2225 [min-width 50] 2226 [label #f])))) 2227 2228 (define answers #f) 2229 (define bp (new-horizontal-panel% 2230 [parent f] 2231 [stretchable-height #f] 2232 [alignment '(right center)])) 2233 (define (confirm-callback b e) 2234 (let ([n (string->number (send number get-value))] 2235 [sym (with-handlers ([exn:fail:read? (λ (x) #f)]) 2236 (read (open-input-string (send tb get-value))))]) 2237 (when (and (number? n) 2238 (symbol? sym)) 2239 (set! answers (list (symbol->string sym) n))) 2240 (send f show #f))) 2241 2242 (define (cancel-callback b e) 2243 (send f show #f)) 2244 2245 (define-values (ok-button cancel-button) 2246 (gui-utils:ok/cancel-buttons bp confirm-callback cancel-callback 2247 (string-constant ok) (string-constant cancel))) 2248 (send tb focus) 2249 (send f show #t) 2250 answers) 2251 2252 (mk-list-box 'framework:square-bracket:letrec "Letrec" values (get-new-simple-keyword "Letrec")) 2253 (mk-list-box 'framework:square-bracket:local 2254 "Local" 2255 values 2256 (get-new-simple-keyword "Local")) 2257 (mk-list-box 'framework:square-bracket:for/fold 2258 "For/fold" 2259 values 2260 (get-new-simple-keyword "For/fold")) 2261 (mk-list-box 'framework:square-bracket:cond/offset 2262 "Cond" 2263 (λ (l) (format "~a (~a)" (car l) (cadr l))) 2264 get-new-cond-keyword) 2265 2266 (define check-box (new check-box% 2267 [parent main-panel] 2268 [label (string-constant fixup-open-brackets)] 2269 [value (preferences:get 'framework:fixup-open-parens)] 2270 [callback 2271 (λ (x y) 2272 (preferences:set 'framework:fixup-open-parens 2273 (send check-box get-value)))])) 2274 (preferences:add-callback 2275 'framework:fixup-open-parens 2276 (λ (p v) 2277 (send check-box set-value v))) 2278 2279 main-panel) 2280 2281 (define (make-indenting-prefs-panel p) 2282 (define get-keywords 2283 (λ (hash-table) 2284 (define all-keywords (hash-map hash-table list)) 2285 (define (pick-out wanted in out) 2286 (cond 2287 [(null? in) (sort out string<?)] 2288 [else (if (eq? wanted (cadr (car in))) 2289 (pick-out wanted (cdr in) 2290 (cons (format "~s" (car (car in))) out)) 2291 (pick-out wanted (cdr in) out))])) 2292 (values (pick-out 'begin all-keywords null) 2293 (pick-out 'define all-keywords null) 2294 (pick-out 'lambda all-keywords null) 2295 (pick-out 'for/fold all-keywords null)))) 2296 (define-values (begin-keywords define-keywords lambda-keywords for/fold-keywords) 2297 (get-keywords (car (preferences:get 'framework:tabify)))) 2298 (define ((add-button-callback keyword-type keyword-symbol list-box) button command) 2299 (define new-one 2300 (keymap:call/text-keymap-initializer 2301 (λ () 2302 (get-text-from-user 2303 (format (string-constant enter-new-keyword) keyword-type) 2304 (format (string-constant x-keyword) keyword-type))))) 2305 (when new-one 2306 (let ([parsed (with-handlers ((exn:fail:read? (λ (x) #f))) 2307 (read (open-input-string new-one)))]) 2308 (cond 2309 [(and (symbol? parsed) 2310 (hash-ref (car (preferences:get 'framework:tabify)) 2311 parsed 2312 (λ () #f))) 2313 (message-box (string-constant error) 2314 (format (string-constant already-used-keyword) parsed))] 2315 [(symbol? parsed) 2316 (let* ([pref (preferences:get 'framework:tabify)] 2317 [ht (car pref)]) 2318 (hash-set! ht parsed keyword-symbol) 2319 (preferences:set 'framework:tabify pref) 2320 (update-list-boxes ht))] 2321 [else (message-box 2322 (string-constant error) 2323 (format (string-constant expected-a-symbol) new-one))])))) 2324 (define ((delete-callback list-box) button command) 2325 (define selections (send list-box get-selections)) 2326 (define symbols 2327 (map (λ (x) (read (open-input-string (send list-box get-string x)))) selections)) 2328 (for-each (λ (x) (send list-box delete x)) (reverse selections)) 2329 (define pref (preferences:get 'framework:tabify)) 2330 (define ht (car pref)) 2331 (for-each (λ (x) (hash-remove! ht x)) symbols) 2332 (preferences:set 'framework:tabify pref)) 2333 (define main-panel (make-object horizontal-panel% p)) 2334 (define (make-column string symbol keywords bang-regexp) 2335 (define vert (make-object vertical-panel% main-panel)) 2336 (make-object message% (format (string-constant x-like-keywords) string) vert) 2337 (define box (make-object list-box% #f keywords vert void '(multiple))) 2338 (define button-panel (make-object horizontal-panel% vert)) 2339 (define text (new text-field% 2340 (label (string-constant indenting-prefs-extra-regexp)) 2341 (callback (λ (tf evt) 2342 (define str (send tf get-value)) 2343 (cond 2344 [(equal? str "") 2345 (bang-regexp #f)] 2346 [else 2347 (with-handlers ([exn:fail? 2348 (λ (x) 2349 (color-yellow (send tf get-editor)))]) 2350 (bang-regexp (regexp str)) 2351 (clear-color (send tf get-editor)))]))) 2352 (parent vert))) 2353 (define add-button (make-object button% (string-constant add-keyword) 2354 button-panel (add-button-callback string symbol box))) 2355 (define delete-button (make-object button% (string-constant remove-keyword) 2356 button-panel (delete-callback box))) 2357 (send* button-panel 2358 (set-alignment 'center 'center) 2359 (stretchable-height #f)) 2360 (send add-button min-width (send delete-button get-width)) 2361 (values box text)) 2362 (define (color-yellow text) 2363 (let ([sd (make-object style-delta%)]) 2364 (send sd set-delta-background "yellow") 2365 (send text change-style sd 0 (send text last-position)))) 2366 (define (clear-color text) 2367 (let ([sd (make-object style-delta%)]) 2368 (send sd set-delta-background "white") 2369 (send text change-style sd 0 (send text last-position)))) 2370 (define (update-pref sel x) 2371 (let ([pref (preferences:get 'framework:tabify)]) 2372 (let ([pref 2373 (let loop ([pref pref][sel sel]) 2374 (if (zero? sel) 2375 (cons x (cdr pref)) 2376 (cons (car pref) (loop (cdr pref) (sub1 sel)))))]) 2377 (preferences:set 'framework:tabify pref)))) 2378 (define-values (begin-list-box begin-regexp-text) 2379 (make-column "Begin" 2380 'begin 2381 begin-keywords 2382 (λ (x) (update-pref 1 x)))) 2383 (define-values (define-list-box define-regexp-text) 2384 (make-column "Define" 2385 'define 2386 define-keywords 2387 (λ (x) (update-pref 2 x)))) 2388 (define-values (lambda-list-box lambda-regexp-text) 2389 (make-column "Lambda" 2390 'lambda 2391 lambda-keywords 2392 (λ (x) (update-pref 3 x)))) 2393 (define-values (for/fold-list-box for/fold-regexp-text) 2394 (make-column "For/fold" 2395 'for/fold 2396 for/fold-keywords 2397 (λ (x) (update-pref 4 x)))) 2398 (define (update-list-boxes hash-table) 2399 (define-values (begin-keywords define-keywords lambda-keywords for/fold-keywords) 2400 (get-keywords hash-table)) 2401 (define (reset list-box keywords) 2402 (send list-box clear) 2403 (for-each (λ (x) (send list-box append x)) keywords)) 2404 (reset begin-list-box begin-keywords) 2405 (reset define-list-box define-keywords) 2406 (reset lambda-list-box lambda-keywords) 2407 (reset for/fold-list-box for/fold-keywords) 2408 #t) 2409 (define update-gui 2410 (λ (pref) 2411 (update-list-boxes (car pref)) 2412 (send begin-regexp-text set-value (or (object-name (list-ref pref 1)) "")) 2413 (send define-regexp-text set-value (or (object-name (list-ref pref 2)) "")) 2414 (send lambda-regexp-text set-value (or (object-name (list-ref pref 3)) "")) 2415 (send for/fold-regexp-text set-value (or (object-name (list-ref pref 4)) "")))) 2416 (preferences:add-callback 'framework:tabify (λ (p v) (update-gui v))) 2417 (update-gui (preferences:get 'framework:tabify)) 2418 main-panel)