e9e2940138
special indentation (this could only come about if the regexp specification in the prefernces matched (the printed out) version of strings, so it wouldn't happen with the default preferences)
2277 lines
94 KiB
Racket
2277 lines
94 KiB
Racket
#lang racket/unit
|
|
|
|
;; originally by Dan Grossman
|
|
;; 6/30/95
|
|
|
|
(require string-constants
|
|
racket/class
|
|
racket/string
|
|
mred/mred-sig
|
|
syntax-color/module-lexer
|
|
"collapsed-snipclass-helpers.rkt"
|
|
"sig.rkt"
|
|
"../gui-utils.rkt"
|
|
"../preferences.rkt"
|
|
racket/match
|
|
racket/contract/option)
|
|
|
|
(import mred^
|
|
[prefix preferences: framework:preferences^]
|
|
[prefix icon: framework:icon^]
|
|
[prefix keymap: framework:keymap^]
|
|
[prefix text: framework:text^]
|
|
[prefix editor: framework:editor^]
|
|
[prefix frame: framework:frame^]
|
|
[prefix comment-box: framework:comment-box^]
|
|
[prefix mode: framework:mode^]
|
|
[prefix color: framework:color^]
|
|
[prefix color-prefs: framework:color-prefs^]
|
|
[prefix finder: framework:finder^])
|
|
|
|
(export (rename framework:racket^
|
|
[-text-mode<%> text-mode<%>]
|
|
[-text<%> text<%>]
|
|
[-text% text%]))
|
|
|
|
(init-depend mred^ framework:keymap^ framework:color^ framework:mode^
|
|
framework:text^ framework:editor^)
|
|
|
|
(define-local-member-name
|
|
stick-to-next-sexp?
|
|
get-private-racket-container-keymap)
|
|
|
|
(define (racket-paren:get-paren-pairs)
|
|
'(("(" . ")")
|
|
("[" . "]")
|
|
("{" . "}")))
|
|
|
|
(define text-balanced?
|
|
(lambda (text [start 0] [in-end #f])
|
|
(let* ([end (or in-end (send text last-position))]
|
|
[port (open-input-text-editor text start end)])
|
|
(with-handlers ([exn:fail:read:eof? (λ (x) #f)]
|
|
[exn:fail:read? (λ (x) #t)])
|
|
(let ([first (read port)])
|
|
(cond
|
|
[(eof-object? first) #f]
|
|
[else
|
|
(let loop ()
|
|
(let ([s (read port)])
|
|
(cond
|
|
[(eof-object? s) #t]
|
|
[else (loop)])))]))))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; ;;
|
|
;; Sexp Snip ;;
|
|
;; ;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (set-box/f! b v) (when (box? b) (set-box! b v)))
|
|
|
|
(define sexp-snip<%>
|
|
(interface ()
|
|
get-saved-snips))
|
|
|
|
(define sexp-snip%
|
|
(class* snip% (sexp-snip<%> readable-snip<%>)
|
|
(init-field left-bracket right-bracket saved-snips)
|
|
(define/public (get-saved-snips) saved-snips)
|
|
(field [sizing-text (format "~a ~a" left-bracket right-bracket)])
|
|
|
|
(define/public (read-special file line col pos)
|
|
(let ([text (make-object text:basic%)])
|
|
(for-each
|
|
(λ (s) (send text insert (send s copy)
|
|
(send text last-position)
|
|
(send text last-position)))
|
|
saved-snips)
|
|
(datum->syntax
|
|
#f
|
|
(read (open-input-text-editor text))
|
|
(list file line col pos 1))))
|
|
|
|
(define/override get-text
|
|
(lambda (offset num [flattened? #f])
|
|
(if flattened?
|
|
(apply string-append
|
|
(map (λ (snip)
|
|
(send snip get-text 0 (send snip get-count) flattened?))
|
|
saved-snips))
|
|
(super get-text offset num flattened?))))
|
|
|
|
(define/override (copy)
|
|
(instantiate sexp-snip% ()
|
|
(left-bracket left-bracket)
|
|
(right-bracket right-bracket)
|
|
(saved-snips saved-snips)))
|
|
|
|
(define/override (write stream-out)
|
|
(send stream-out put (bytes (char->integer left-bracket)))
|
|
(send stream-out put (bytes (char->integer right-bracket)))
|
|
(send stream-out put (length saved-snips))
|
|
(let loop ([snips saved-snips])
|
|
(cond
|
|
[(null? snips) (void)]
|
|
[else
|
|
(let* ([snip (car snips)]
|
|
[snipclass (send snip get-snipclass)])
|
|
(send stream-out put (string->bytes/utf-8 (send snipclass get-classname)))
|
|
(send snip write stream-out))
|
|
(loop (cdr snips))])))
|
|
|
|
(define/override (draw dc x y left top right bottom dx dy draw-caret)
|
|
(send dc draw-text sizing-text x y)
|
|
(let-values ([(lpw lph lpa lpd) (send dc get-text-extent (string left-bracket))]
|
|
[(rpw rph rpa rpd) (send dc get-text-extent (string right-bracket))]
|
|
[(sw sh sa sd) (send dc get-text-extent sizing-text)])
|
|
(let* ([dtw (- sw lpw rpw)]
|
|
[dot-start (+ x lpw)]
|
|
[dt1x (+ dot-start (* dtw 1/5))]
|
|
[dt2x (+ dot-start (* dtw 1/2))]
|
|
[dt3x (+ dot-start (* dtw 4/5))]
|
|
[dty (+ y (/ sh 2))])
|
|
(send dc draw-rectangle dt1x dty 2 2)
|
|
(send dc draw-rectangle dt2x dty 2 2)
|
|
(send dc draw-rectangle dt3x dty 2 2))))
|
|
|
|
(inherit get-style)
|
|
(define/override (get-extent dc x y wb hb descentb spaceb lspaceb rspaceb)
|
|
(let-values ([(w h d a) (send dc get-text-extent sizing-text (send (get-style) get-font))])
|
|
(set-box/f! wb w)
|
|
(set-box/f! hb h)
|
|
(set-box/f! descentb d)
|
|
(set-box/f! spaceb a)
|
|
(set-box/f! lspaceb 0)
|
|
(set-box/f! rspaceb 0)))
|
|
(super-new)
|
|
(inherit set-snipclass)
|
|
(set-snipclass 2lib-snip-class)))
|
|
|
|
(define sexp-snipclass% (make-sexp-snipclass% sexp-snip%))
|
|
|
|
;; old snips (from old versions of drracket) use this snipclass
|
|
(define 2lib-snip-class (make-object sexp-snipclass%))
|
|
(send 2lib-snip-class set-classname (format "~s" '((lib "collapsed-snipclass.ss" "framework")
|
|
(lib "collapsed-snipclass-wxme.ss" "framework"))))
|
|
(send 2lib-snip-class set-version 0)
|
|
(send (get-the-snip-class-list) add 2lib-snip-class)
|
|
|
|
;; old snips (from old versions of drracket) use this snipclass
|
|
(define lib-snip-class (make-object sexp-snipclass%))
|
|
(send lib-snip-class set-classname (format "~s" '(lib "collapsed-snipclass.ss" "framework")))
|
|
(send lib-snip-class set-version 0)
|
|
(send (get-the-snip-class-list) add lib-snip-class)
|
|
|
|
;; new snips use this snipclass
|
|
(define old-snip-class (make-object sexp-snipclass%))
|
|
(send old-snip-class set-classname "drscheme:sexp-snip")
|
|
(send old-snip-class set-version 0)
|
|
(send (get-the-snip-class-list) add old-snip-class)
|
|
|
|
(keymap:add-to-right-button-menu
|
|
(let ([old (keymap:add-to-right-button-menu)])
|
|
(λ (menu text event)
|
|
(old menu text event)
|
|
(split/collapse-text menu text event)
|
|
(void))))
|
|
|
|
;; split/collapse-text : (instanceof menu%) (instanceof editor<%>) (instanceof mouse-event%) -> void
|
|
(define (split/collapse-text menu text event)
|
|
(when (and (is-a? text -text<%>)
|
|
(not (send text is-stopped?)))
|
|
(let* ([on-it-box (box #f)]
|
|
[click-pos
|
|
(call-with-values
|
|
(λ ()
|
|
(send text dc-location-to-editor-location
|
|
(send event get-x)
|
|
(send event get-y)))
|
|
(λ (x y)
|
|
(send text find-position x y #f on-it-box)))]
|
|
[snip (send text find-snip click-pos 'after)]
|
|
[char (send text get-character click-pos)]
|
|
[left? (memq char '(#\( #\{ #\[))]
|
|
[right? (memq char '(#\) #\} #\]))])
|
|
(cond
|
|
[(and snip (is-a? snip sexp-snip<%>))
|
|
(make-expand-item text snip menu)]
|
|
[(not (unbox on-it-box))
|
|
;; clicking in nowhere land, just ignore
|
|
(void)]
|
|
[(or left? right?)
|
|
;; clicking on left or right paren
|
|
(let* ([pos (if left?
|
|
click-pos
|
|
(+ click-pos 1))]
|
|
[other-pos (if left?
|
|
(send text get-forward-sexp pos)
|
|
(send text get-backward-sexp pos))])
|
|
(when other-pos
|
|
(let ([left-pos (min pos other-pos)]
|
|
[right-pos (max pos other-pos)])
|
|
(make-collapse-item text left-pos right-pos menu))))]
|
|
[else
|
|
;; clicking on some other text -> collapse containing sexp
|
|
(let ([up-sexp (send text find-up-sexp click-pos)])
|
|
(when up-sexp
|
|
(let ([fwd (send text get-forward-sexp up-sexp)])
|
|
(when fwd
|
|
(make-collapse-item text up-sexp fwd menu)))))]))))
|
|
|
|
;; make-expand-item : (instanceof text%) (instanceof sexp-snip<%>) (instanceof menu%) -> void
|
|
(define (make-expand-item text snip menu)
|
|
(instantiate separator-menu-item% ()
|
|
(parent menu))
|
|
(instantiate menu-item% ()
|
|
(parent menu)
|
|
(label (string-constant expand-sexp))
|
|
(callback (λ (item evt) (expand-from text snip)))))
|
|
|
|
;; expand-from : (instanceof text%) (instanceof sexp-snip<%>) -> void
|
|
(define (expand-from text snip)
|
|
(let ([snips (send snip get-saved-snips)])
|
|
(send text begin-edit-sequence)
|
|
(let ([pos (send text get-snip-position snip)])
|
|
(send text delete pos (+ pos 1))
|
|
(let loop ([snips (reverse snips)])
|
|
(cond
|
|
[(null? snips) (void)]
|
|
[else (send text insert (send (car snips) copy) pos pos)
|
|
(loop (cdr snips))])))
|
|
(send text end-edit-sequence)))
|
|
|
|
;; make-collapse-item : (instanceof text%) number number (instanceof menu%) -> void
|
|
;; adds a collapse menu item to the menu
|
|
(define (make-collapse-item text left-pos right-pos menu)
|
|
(instantiate separator-menu-item% ()
|
|
(parent menu))
|
|
(instantiate menu-item% ()
|
|
(parent menu)
|
|
(label (string-constant collapse-sexp))
|
|
(callback (λ (item evt)
|
|
(collapse-from text left-pos right-pos)))))
|
|
|
|
(define (collapse-from text left-pos right-pos)
|
|
(let ([left-bracket (send text get-character left-pos)]
|
|
[right-bracket (send text get-character (- right-pos 1))])
|
|
(send text begin-edit-sequence)
|
|
(send text split-snip left-pos)
|
|
(send text split-snip right-pos)
|
|
(let ([snips (let loop ([snip (send text find-snip left-pos 'after)])
|
|
(cond
|
|
[(not snip) null]
|
|
[((send text get-snip-position snip) . >= . right-pos)
|
|
null]
|
|
[else (cons (send snip copy) (loop (send snip next)))]))])
|
|
(send text delete left-pos right-pos)
|
|
(send text insert (instantiate sexp-snip% ()
|
|
(left-bracket left-bracket)
|
|
(right-bracket right-bracket)
|
|
(saved-snips snips))
|
|
left-pos left-pos)
|
|
(send text end-edit-sequence))))
|
|
|
|
|
|
;
|
|
;
|
|
;
|
|
; ; ;;;;
|
|
; ;; ;;;;
|
|
; ;;;; ;;;;; ;;;; ;;; ;;; ;;; ;;;
|
|
; ;;;;;; ;;;;;; ;;;;;;;;; ;;;;; ;;;;;;;
|
|
; ;;;;;;;; ;;;; ;;;; ;;;; ;;;; ;; ;;;; ;;
|
|
; ;;;; ;;; ;;;; ;;;; ;;;; ;;;;;;; ;;;;
|
|
; ;;;;;;;; ;;;;; ;;;; ;;;; ;;;;; ;;;;
|
|
; ;;;;;; ;;;;; ;;;; ;;;; ;;;;;; ;;;;
|
|
; ;;;; ;;;; ;;;; ;;;; ;;;; ;;;;
|
|
;
|
|
;
|
|
;
|
|
|
|
|
|
(define color-prefs-table
|
|
(let ([constant-green (make-object color% 41 128 38)]
|
|
[symbol-blue (make-object color% 38 38 128)])
|
|
`((symbol ,symbol-blue ,(string-constant scheme-mode-color-symbol))
|
|
(keyword ,symbol-blue ,(string-constant scheme-mode-color-keyword))
|
|
(comment ,(make-object color% 194 116 31) ,(string-constant scheme-mode-color-comment))
|
|
(string ,constant-green ,(string-constant scheme-mode-color-string))
|
|
(text ,constant-green ,(string-constant scheme-mode-color-text))
|
|
(constant ,constant-green ,(string-constant scheme-mode-color-constant))
|
|
(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))
|
|
(error ,(make-object color% "red") ,(string-constant scheme-mode-color-error))
|
|
(other ,(make-object color% "black") ,(string-constant scheme-mode-color-other)))))
|
|
|
|
(define white-on-black-color-prefs-table
|
|
(let* ([sym/kwd (make-object color% 102 102 255)]
|
|
[new-entries
|
|
`((symbol ,sym/kwd)
|
|
(keyword ,sym/kwd)
|
|
(comment ,(make-object color% 249 148 40))
|
|
(string ,(make-object color% 51 174 51))
|
|
(text ,(make-object color% 51 174 51))
|
|
(constant ,(make-object color% 60 194 57))
|
|
(hash-colon-keyword ,(make-object color% 151 69 43))
|
|
(parenthesis ,(make-object color% 151 69 43))
|
|
(other ,(make-object color% "white")))])
|
|
(map
|
|
(λ (line)
|
|
(let ([new (assoc (car line) new-entries)])
|
|
(if new
|
|
(list* (car line)
|
|
(cadr new)
|
|
(cddr line))
|
|
line)))
|
|
color-prefs-table)))
|
|
|
|
(define (get-color-prefs-table) color-prefs-table)
|
|
(define (get-white-on-black-color-prefs-table) white-on-black-color-prefs-table)
|
|
|
|
(define (short-sym->pref-name sym) (string->symbol (short-sym->style-name sym)))
|
|
(define (xlate-sym-style sym) (case sym
|
|
[(sexp-comment) 'comment]
|
|
[else sym]))
|
|
(define sn-hash (make-hasheq))
|
|
(define (short-sym->style-name _sym)
|
|
(define sym (if (eq? _sym 'white-space)
|
|
'parenthesis
|
|
_sym))
|
|
(hash-ref sn-hash sym
|
|
(λ ()
|
|
(let ([s (format "framework:syntax-color:scheme:~a"
|
|
(xlate-sym-style sym))])
|
|
(hash-set! sn-hash sym s)
|
|
s))))
|
|
|
|
(define (add-coloring-preferences-panel)
|
|
(color-prefs:add-to-preferences-panel
|
|
"Racket"
|
|
(λ (parent)
|
|
(for-each
|
|
(λ (line)
|
|
(let ([sym (car line)])
|
|
(color-prefs:build-color-selection-panel
|
|
parent
|
|
(short-sym->pref-name sym)
|
|
(short-sym->style-name sym)
|
|
(caddr line))))
|
|
color-prefs-table))))
|
|
|
|
(define-struct string/pos (string pos))
|
|
|
|
(define -text<%>
|
|
(interface (text:basic<%> mode:host-text<%> color:text<%>)
|
|
get-limit
|
|
balance-parens
|
|
tabify-on-return?
|
|
tabify
|
|
tabify-selection
|
|
tabify-all
|
|
insert-return
|
|
box-comment-out-selection
|
|
comment-out-selection
|
|
uncomment-selection
|
|
get-forward-sexp
|
|
remove-sexp
|
|
forward-sexp
|
|
flash-forward-sexp
|
|
get-backward-sexp
|
|
flash-backward-sexp
|
|
backward-sexp
|
|
find-up-sexp
|
|
up-sexp
|
|
find-down-sexp
|
|
down-sexp
|
|
remove-parens-forward
|
|
|
|
select-forward-sexp
|
|
select-backward-sexp
|
|
select-up-sexp
|
|
select-down-sexp
|
|
transpose-sexp
|
|
mark-matching-parenthesis
|
|
get-tab-size
|
|
set-tab-size
|
|
|
|
introduce-let-ans
|
|
move-sexp-out
|
|
kill-enclosing-parens
|
|
toggle-round-square-parens
|
|
|
|
compute-racket-amount-to-indent
|
|
compute-amount-to-indent))
|
|
|
|
(define init-wordbreak-map
|
|
(λ (map)
|
|
(send map set-map #\< '(line selection)) ; interfaces e.g.the canvas<%> interface
|
|
(send map set-map #\> '(line selection)) ; interfaces, casts e.g. string->path
|
|
(send map set-map #\% '(line selection)) ; intefraces, classes
|
|
(send map set-map #\? '(line selection)) ; predicates
|
|
(send map set-map #\' '(line selection)) ; literal symbols
|
|
(send map set-map #\! '(line selection)) ; assignments e.g. set
|
|
(send map set-map #\- '(line selection)) ; hyphens
|
|
(send map set-map #\: '(line selection)))); valid identifiers with colons
|
|
|
|
(define wordbreak-map (make-object editor-wordbreak-map%))
|
|
(define (get-wordbreak-map) wordbreak-map)
|
|
(init-wordbreak-map wordbreak-map)
|
|
|
|
(define matching-parenthesis-style
|
|
(let ([matching-parenthesis-delta (make-object style-delta% 'change-bold)]
|
|
[style-list (editor:get-standard-style-list)])
|
|
(send matching-parenthesis-delta set-delta-foreground "forest green")
|
|
(send style-list new-named-style "Matching Parenthesis Style"
|
|
(send style-list find-or-create-style
|
|
(send style-list find-named-style "Standard")
|
|
matching-parenthesis-delta))
|
|
(send style-list find-named-style "Matching Parenthesis Style")))
|
|
|
|
(define text-mixin
|
|
(mixin (text:basic<%> mode:host-text<%> color:text<%> text:autocomplete<%> editor:keymap<%>)
|
|
(-text<%>)
|
|
(inherit begin-edit-sequence
|
|
delete
|
|
end-edit-sequence
|
|
local-edit-sequence?
|
|
find-string
|
|
extend-position
|
|
get-character
|
|
get-extend-end-position
|
|
get-extend-start-position
|
|
get-keymap
|
|
get-text
|
|
get-start-position
|
|
get-style-list
|
|
get-end-position
|
|
flash-on
|
|
insert
|
|
is-stopped?
|
|
kill
|
|
last-position
|
|
paragraph-start-position
|
|
paragraph-end-position
|
|
position-paragraph
|
|
set-keymap
|
|
set-load-overwrites-styles
|
|
set-position
|
|
set-wordbreak-map
|
|
set-tabs
|
|
set-style-list
|
|
set-styles-fixed
|
|
change-style
|
|
get-snip-position
|
|
backward-match
|
|
backward-containing-sexp
|
|
forward-match
|
|
skip-whitespace
|
|
insert-close-paren
|
|
classify-position)
|
|
|
|
(inherit get-styles-fixed)
|
|
(inherit has-focus? find-snip split-snip
|
|
position-location get-dc)
|
|
|
|
(define private-racket-container-keymap (new keymap:aug-keymap%))
|
|
(define/public (get-private-racket-container-keymap) private-racket-container-keymap)
|
|
|
|
(define/override (get-keymaps)
|
|
(editor:add-after-user-keymap private-racket-container-keymap
|
|
(super get-keymaps)))
|
|
|
|
(define/override (get-word-at current-pos)
|
|
(let ([no-word ""])
|
|
(cond
|
|
[(is-stopped?)
|
|
no-word]
|
|
[else
|
|
(let ([type (classify-position (max 0 (- current-pos 1)))])
|
|
(cond
|
|
[(memq type '(symbol keyword))
|
|
(get-text (look-for-non-symbol/non-kwd (max 0 (- current-pos 1)))
|
|
current-pos)]
|
|
[else no-word]))])))
|
|
|
|
(define/private (look-for-non-symbol/non-kwd start)
|
|
(let loop ([i start])
|
|
(cond
|
|
[(< i 0)
|
|
0]
|
|
[(memq (classify-position i) '(symbol keyword))
|
|
(loop (- i 1))]
|
|
[else
|
|
(+ i 1)])))
|
|
|
|
(public tabify-all insert-return calc-last-para
|
|
box-comment-out-selection comment-out-selection uncomment-selection
|
|
flash-forward-sexp
|
|
flash-backward-sexp backward-sexp find-up-sexp up-sexp find-down-sexp down-sexp
|
|
remove-parens-forward)
|
|
|
|
(define/public (get-limit pos) 0)
|
|
|
|
(define/public (balance-parens key-event [smart-skip #f])
|
|
(insert-close-paren (get-start-position)
|
|
(send key-event get-key-code)
|
|
(preferences:get 'framework:paren-match)
|
|
(preferences:get 'framework:fixup-parens)
|
|
(or smart-skip
|
|
(and (preferences:get 'framework:automatic-parens)
|
|
(not (in-string/comment? this))
|
|
'adjacent))))
|
|
|
|
(define/public (tabify-on-return?) #t)
|
|
(define/public (tabify [pos (get-start-position)])
|
|
(define amt (compute-amount-to-indent pos))
|
|
(define (do-indent amt)
|
|
(define para (position-paragraph pos))
|
|
(define end (paragraph-start-position para))
|
|
(define-values (gwidth curr-offset tab-char?) (find-offset end))
|
|
(unless (and (not tab-char?) (= amt (- curr-offset end)))
|
|
(delete end curr-offset)
|
|
(insert (make-string amt #\space) end)))
|
|
(when amt (do-indent amt)))
|
|
|
|
(define/private (find-offset start-pos)
|
|
(define tab-char? #f)
|
|
(define end-pos
|
|
(let loop ([p start-pos])
|
|
(let ([c (get-character p)])
|
|
(cond
|
|
[(char=? c #\tab)
|
|
(set! tab-char? #t)
|
|
(loop (add1 p))]
|
|
[(char=? c #\newline)
|
|
p]
|
|
[(char-whitespace? c)
|
|
(loop (add1 p))]
|
|
[else
|
|
p]))))
|
|
(define start-x (box 0))
|
|
(define end-x (box 0))
|
|
(position-location start-pos start-x #f #t #t)
|
|
(position-location end-pos end-x #f #t #t)
|
|
(define sizing-dc (or (get-dc) (make-object bitmap-dc% (make-bitmap 1 1))))
|
|
(define-values (w _1 _2 _3)
|
|
(send sizing-dc get-text-extent "x"
|
|
(send (send (get-style-list)
|
|
find-named-style "Standard")
|
|
get-font)))
|
|
(values (inexact->exact (floor (/ (- (unbox end-x) (unbox start-x)) w)))
|
|
end-pos
|
|
tab-char?))
|
|
(define/pubment (compute-amount-to-indent pos)
|
|
(inner (compute-racket-amount-to-indent pos) compute-amount-to-indent pos))
|
|
(define/public-final (compute-racket-amount-to-indent pos)
|
|
(cond
|
|
[(is-stopped?) #f]
|
|
[else
|
|
(define tabify-prefs (preferences:get 'framework:tabify))
|
|
(define last-pos (last-position))
|
|
(define para (position-paragraph pos))
|
|
(define is-tabbable?
|
|
(and (> para 0)
|
|
(not (memq (classify-position (- (paragraph-start-position para) 1))
|
|
'(comment string error)))))
|
|
(define end (if is-tabbable? (paragraph-start-position para) 0))
|
|
(define limit (get-limit pos))
|
|
|
|
;; "contains" is the start of the initial sub-S-exp
|
|
;; in the S-exp that contains "pos". If pos is outside
|
|
;; all S-exps, this will be the start of the initial
|
|
;; S-exp
|
|
(define contains
|
|
(if is-tabbable?
|
|
(backward-containing-sexp end limit)
|
|
#f))
|
|
(define contain-para (and contains
|
|
(position-paragraph contains)))
|
|
|
|
;; last is the start of the S-exp just before "pos"
|
|
(define last
|
|
(if contains
|
|
(let ([p (get-backward-sexp end)])
|
|
(if (and p (p . >= . limit))
|
|
p
|
|
(backward-match end limit)))
|
|
#f))
|
|
(define last-para (and last (position-paragraph last)))
|
|
|
|
;; last2 is the start of the S-exp just before the one before "pos"
|
|
(define last2
|
|
(if last
|
|
(let ([p (get-backward-sexp last)])
|
|
(if (and p (p . >= . limit))
|
|
p
|
|
(backward-match last limit)))
|
|
#f))
|
|
|
|
(define (visual-offset pos)
|
|
(let loop ([p (sub1 pos)])
|
|
(if (= p -1)
|
|
0
|
|
(let ([c (get-character p)])
|
|
(cond
|
|
[(char=? c #\null) 0]
|
|
[(char=? c #\tab)
|
|
(let ([o (loop (sub1 p))])
|
|
(+ o (- 8 (modulo o 8))))]
|
|
[(char=? c #\newline) 0]
|
|
[else (add1 (loop (sub1 p)))])))))
|
|
|
|
(define (get-proc)
|
|
(define id-end (get-forward-sexp contains))
|
|
(and (and id-end (> id-end contains))
|
|
(let ([text (get-text contains id-end)])
|
|
(cond
|
|
[(member (classify-position contains) '(keyword symbol))
|
|
(or (get-keyword-type text tabify-prefs)
|
|
'other)]
|
|
[else
|
|
'other]))))
|
|
(define (procedure-indent)
|
|
(case (get-proc)
|
|
[(begin define) 1]
|
|
[(lambda) 3]
|
|
[else 0]))
|
|
(define (define-or-lambda-style?)
|
|
(define proc-name (get-proc))
|
|
(or (equal? proc-name 'define)
|
|
(equal? proc-name 'lambda)))
|
|
(define (for/fold-style?)
|
|
(define proc-name (get-proc))
|
|
(equal? proc-name 'for/fold))
|
|
|
|
(define (indent-first-arg start)
|
|
(define-values (gwidth curr-offset tab-char?) (find-offset start))
|
|
gwidth)
|
|
|
|
(when (and is-tabbable?
|
|
(not (char=? (get-character (sub1 end))
|
|
#\newline)))
|
|
(insert #\newline (paragraph-start-position para)))
|
|
|
|
(define amt-to-indent
|
|
(cond
|
|
[(not is-tabbable?)
|
|
(if (= para 0)
|
|
0
|
|
#f)]
|
|
[(let-values ([(gwidth real-start tab-char?) (find-offset end)])
|
|
(and (<= (+ 3 real-start) (last-position))
|
|
(string=? ";;;"
|
|
(get-text real-start
|
|
(+ 2 real-start)))))
|
|
#f]
|
|
[(not contains)
|
|
;; Something went wrong matching. Should we get here?
|
|
0]
|
|
[(not last)
|
|
;; We can't find a match backward from pos,
|
|
;; but we seem to be inside an S-exp, so
|
|
;; go "up" an S-exp, and move forward past
|
|
;; the associated paren
|
|
(define enclosing (find-up-sexp pos))
|
|
(if enclosing
|
|
(+ (visual-offset enclosing) 1)
|
|
0)]
|
|
[(= contains last)
|
|
;; this is the first expression in the define
|
|
(+ (visual-offset contains)
|
|
(procedure-indent))]
|
|
[(and (for/fold-style?)
|
|
last2
|
|
(= contains last2))
|
|
(- last (paragraph-start-position last-para))]
|
|
[(or (define-or-lambda-style?)
|
|
(for/fold-style?))
|
|
;; In case of "define", etc., ignore the position of last
|
|
;; and just indent under the "define"
|
|
(add1 (visual-offset contains))]
|
|
[(= contain-para last-para)
|
|
;; So far, the S-exp containing "pos" was all on
|
|
;; one line (possibly not counting the opening paren),
|
|
;; so indent to follow the first S-exp's end
|
|
;; unless there are just two sexps and the second is an ellipsis.
|
|
;; in that case, we just ignore the ellipsis
|
|
(define id-end (get-forward-sexp contains))
|
|
(define name-length
|
|
(if id-end
|
|
(- id-end contains)
|
|
0))
|
|
(cond
|
|
[(second-sexp-is-ellipsis? contains)
|
|
(visual-offset contains)]
|
|
[(not (find-up-sexp pos))
|
|
(visual-offset contains)]
|
|
[else
|
|
(+ (visual-offset contains)
|
|
name-length
|
|
(indent-first-arg (+ contains
|
|
name-length)))])]
|
|
[else
|
|
;; No particular special case, so indent to match first
|
|
;; S-expr that starts on the previous line
|
|
(let loop ([last last][last-para last-para])
|
|
(let* ([next-to-last (backward-match last limit)]
|
|
[next-to-last-para (and next-to-last
|
|
(position-paragraph next-to-last))])
|
|
(if (equal? last-para next-to-last-para)
|
|
(loop next-to-last next-to-last-para)
|
|
(visual-offset last))))]))
|
|
amt-to-indent]))
|
|
|
|
;; returns #t if `contains' is at a position on a line with an sexp, an ellipsis and nothing else.
|
|
;; otherwise, returns #f
|
|
(define/private (second-sexp-is-ellipsis? contains)
|
|
(let ([fst-end (get-forward-sexp contains)])
|
|
(and fst-end
|
|
(let ([snd-end (get-forward-sexp fst-end)])
|
|
(and snd-end
|
|
(let ([snd-start (get-backward-sexp snd-end)])
|
|
(and snd-start
|
|
(equal? (get-text snd-start snd-end)
|
|
"...")
|
|
(let ([thrd-start (get-forward-sexp snd-end)])
|
|
(and (or (not thrd-start)
|
|
(not (= (position-paragraph thrd-start)
|
|
(position-paragraph snd-start)))))))))))))
|
|
|
|
(define/public (tabify-selection [start-pos (get-start-position)]
|
|
[end-pos (get-end-position)])
|
|
(unless (is-stopped?)
|
|
(define first-para (position-paragraph start-pos))
|
|
(define end-para (position-paragraph end-pos))
|
|
(with-handlers ([exn:break?
|
|
(λ (x) #t)])
|
|
(dynamic-wind
|
|
(λ ()
|
|
(when (< first-para end-para)
|
|
(begin-busy-cursor))
|
|
(begin-edit-sequence))
|
|
(λ ()
|
|
(let loop ([para first-para])
|
|
(when (<= para end-para)
|
|
(tabify (paragraph-start-position para))
|
|
(parameterize-break #t (void))
|
|
(loop (add1 para))))
|
|
(when (and (>= (position-paragraph start-pos) end-para)
|
|
(<= (skip-whitespace (get-start-position) 'backward #f)
|
|
(paragraph-start-position first-para)))
|
|
(set-position
|
|
(let loop ([new-pos (get-start-position)])
|
|
(if (let ([next (get-character new-pos)])
|
|
(and (char-whitespace? next)
|
|
(not (char=? next #\newline))))
|
|
(loop (add1 new-pos))
|
|
new-pos)))))
|
|
(λ ()
|
|
(end-edit-sequence)
|
|
(when (< first-para end-para)
|
|
(end-busy-cursor)))))))
|
|
|
|
(define (tabify-all) (tabify-selection 0 (last-position)))
|
|
(define (insert-return)
|
|
(begin-edit-sequence #t #f)
|
|
(define end-of-whitespace (get-start-position))
|
|
(define start-cutoff
|
|
(paragraph-start-position (position-paragraph end-of-whitespace)))
|
|
(define start-of-whitespace
|
|
(let loop ([pos end-of-whitespace])
|
|
(if (and (> pos start-cutoff)
|
|
(char-whitespace? (get-character (sub1 pos))))
|
|
(loop (sub1 pos))
|
|
pos)))
|
|
(delete start-of-whitespace end-of-whitespace)
|
|
(insert #\newline)
|
|
(when (and (tabify-on-return?)
|
|
(tabify (get-start-position)))
|
|
(set-position
|
|
(let loop ([new-pos (get-start-position)])
|
|
(if (let ([next (get-character new-pos)])
|
|
(and (char-whitespace? next)
|
|
(not (char=? next #\newline))))
|
|
(loop (add1 new-pos))
|
|
new-pos))))
|
|
(end-edit-sequence))
|
|
|
|
(define (calc-last-para last-pos)
|
|
(let ([last-para (position-paragraph last-pos #t)])
|
|
(if (and (> last-pos 0)
|
|
(> last-para 0))
|
|
(begin (split-snip last-pos)
|
|
(let ([snip (find-snip last-pos 'before)])
|
|
(if (member 'hard-newline (send snip get-flags))
|
|
(- last-para 1)
|
|
last-para)))
|
|
last-para)))
|
|
|
|
(define comment-out-selection
|
|
(lambda ([start-pos (get-start-position)]
|
|
[end-pos (get-end-position)])
|
|
(begin-edit-sequence)
|
|
(let ([first-pos-is-first-para-pos?
|
|
(= (paragraph-start-position (position-paragraph start-pos))
|
|
start-pos)])
|
|
(let* ([first-para (position-paragraph start-pos)]
|
|
[last-para (calc-last-para end-pos)])
|
|
(let para-loop ([curr-para first-para])
|
|
(when (<= curr-para last-para)
|
|
(let ([first-on-para (paragraph-start-position curr-para)])
|
|
(insert #\; first-on-para)
|
|
(para-loop (add1 curr-para))))))
|
|
(when first-pos-is-first-para-pos?
|
|
(set-position
|
|
(paragraph-start-position (position-paragraph (get-start-position)))
|
|
(get-end-position))))
|
|
(end-edit-sequence)
|
|
#t))
|
|
|
|
(define box-comment-out-selection
|
|
(lambda ([_start-pos 'start]
|
|
[_end-pos 'end])
|
|
(let ([start-pos (if (eq? _start-pos 'start)
|
|
(get-start-position)
|
|
_start-pos)]
|
|
[end-pos (if (eq? _end-pos 'end)
|
|
(get-end-position)
|
|
_end-pos)])
|
|
(begin-edit-sequence)
|
|
(split-snip start-pos)
|
|
(split-snip end-pos)
|
|
(let* ([cb (instantiate comment-box:snip% ())]
|
|
[text (send cb get-editor)])
|
|
(let loop ([snip (find-snip start-pos 'after-or-none)])
|
|
(cond
|
|
[(not snip) (void)]
|
|
[((get-snip-position snip) . >= . end-pos) (void)]
|
|
[else
|
|
(send text insert (send snip copy)
|
|
(send text last-position)
|
|
(send text last-position))
|
|
(loop (send snip next))]))
|
|
(delete start-pos end-pos)
|
|
(insert cb start-pos)
|
|
(set-position start-pos start-pos))
|
|
(end-edit-sequence)
|
|
#t)))
|
|
|
|
;; uncomment-box/selection : -> void
|
|
;; uncomments a comment box, if the focus is inside one.
|
|
;; otherwise, calls uncomment selection to uncomment
|
|
;; something else.
|
|
(inherit get-focus-snip)
|
|
(define/public (uncomment-box/selection)
|
|
(begin-edit-sequence)
|
|
(let ([focus-snip (get-focus-snip)])
|
|
(cond
|
|
[(not focus-snip) (uncomment-selection)]
|
|
[(is-a? focus-snip comment-box:snip%)
|
|
(extract-contents
|
|
(get-snip-position focus-snip)
|
|
focus-snip)]
|
|
[else (uncomment-selection)]))
|
|
(end-edit-sequence)
|
|
#t)
|
|
|
|
(define uncomment-selection
|
|
(lambda ([start-pos (get-start-position)]
|
|
[end-pos (get-end-position)])
|
|
(let ([snip-before (find-snip start-pos 'before-or-none)]
|
|
[snip-after (find-snip start-pos 'after-or-none)])
|
|
|
|
(begin-edit-sequence)
|
|
(cond
|
|
[(and (= start-pos end-pos)
|
|
snip-before
|
|
(is-a? snip-before comment-box:snip%))
|
|
(extract-contents start-pos snip-before)]
|
|
[(and (= start-pos end-pos)
|
|
snip-after
|
|
(is-a? snip-after comment-box:snip%))
|
|
(extract-contents start-pos snip-after)]
|
|
[(and (= (+ start-pos 1) end-pos)
|
|
snip-after
|
|
(is-a? snip-after comment-box:snip%))
|
|
(extract-contents start-pos snip-after)]
|
|
[else
|
|
(let* ([last-pos (last-position)]
|
|
[first-para (position-paragraph start-pos)]
|
|
[last-para (calc-last-para end-pos)])
|
|
(let para-loop ([curr-para first-para])
|
|
(when (<= curr-para last-para)
|
|
(let ([first-on-para
|
|
(skip-whitespace (paragraph-start-position curr-para)
|
|
'forward
|
|
#f)])
|
|
(split-snip first-on-para)
|
|
(when (and (< first-on-para last-pos)
|
|
(char=? #\; (get-character first-on-para))
|
|
(is-a? (find-snip first-on-para 'after-or-none) string-snip%))
|
|
(delete first-on-para (+ first-on-para 1)))
|
|
(para-loop (add1 curr-para))))))])
|
|
(end-edit-sequence))
|
|
#t))
|
|
|
|
;; extract-contents : number (is-a?/c comment-box:snip%) -> void
|
|
;; copies the contents of the comment-box-snip out of the snip
|
|
;; and into this editor as `pos'. Deletes the comment box snip
|
|
(define/private (extract-contents pos snip)
|
|
(let ([editor (send snip get-editor)])
|
|
(let loop ([snip (send editor find-snip (send editor last-position) 'before-or-none)])
|
|
(cond
|
|
[snip
|
|
(insert (send snip copy) pos)
|
|
(loop (send snip previous))]
|
|
[else (void)]))
|
|
(let ([snip-pos (get-snip-position snip)])
|
|
(delete snip-pos (+ snip-pos 1)))
|
|
(set-position pos pos)))
|
|
|
|
|
|
;; stick-to-next-sexp?: natural -> boolean
|
|
(define stick-to-patterns
|
|
'("'" "," ",@" "`" "#'" "#," "#`" "#,@"
|
|
"#&" "#;" "#hash" "#hasheq" "#ci" "#cs"))
|
|
(define stick-to-patterns-union
|
|
(regexp (string-append
|
|
"^("
|
|
(string-join (map regexp-quote stick-to-patterns) "|")
|
|
")")))
|
|
(define stick-to-patterns-union-anchored
|
|
(regexp (string-append
|
|
"^("
|
|
(string-join (map regexp-quote stick-to-patterns) "|")
|
|
")$")))
|
|
(define stick-to-max-pattern-length
|
|
(apply max (map string-length stick-to-patterns)))
|
|
(define/public (stick-to-next-sexp? start-pos)
|
|
;; Optimization: speculatively check whether the string will
|
|
;; match the patterns; at time of writing, forward-match can be
|
|
;; really expensive.
|
|
(define snippet
|
|
(get-text start-pos
|
|
(min (last-position)
|
|
(+ start-pos stick-to-max-pattern-length))))
|
|
(and (regexp-match stick-to-patterns-union snippet)
|
|
(let ([end-pos (forward-match start-pos (last-position))])
|
|
(and end-pos
|
|
(regexp-match stick-to-patterns-union-anchored
|
|
(get-text start-pos end-pos))
|
|
#t))))
|
|
|
|
(define/public (get-forward-sexp start-pos)
|
|
;; loop to work properly with quote, etc.
|
|
(let loop ([one-forward (forward-match start-pos (last-position))])
|
|
(cond
|
|
[(and one-forward (not (= 0 one-forward)))
|
|
(let ([bw (backward-match one-forward 0)])
|
|
(cond
|
|
[(and bw
|
|
(stick-to-next-sexp? bw))
|
|
(let ([two-forward (forward-match one-forward (last-position))])
|
|
(if two-forward
|
|
(loop two-forward)
|
|
one-forward))]
|
|
[else
|
|
one-forward]))]
|
|
[else one-forward])))
|
|
|
|
(define/public (remove-sexp start-pos)
|
|
(let ([end-pos (get-forward-sexp start-pos)])
|
|
(if end-pos
|
|
(kill 0 start-pos end-pos)
|
|
(bell)))
|
|
#t)
|
|
(define/public (forward-sexp start-pos)
|
|
(let ([end-pos (get-forward-sexp start-pos)])
|
|
(if end-pos
|
|
(set-position end-pos)
|
|
(bell))
|
|
#t))
|
|
[define flash-forward-sexp
|
|
(λ (start-pos)
|
|
(let ([end-pos (get-forward-sexp start-pos)])
|
|
(if end-pos
|
|
(flash-on end-pos (add1 end-pos))
|
|
(bell))
|
|
#t))]
|
|
(define/public (get-backward-sexp start-pos)
|
|
(let* ([limit (get-limit start-pos)]
|
|
[end-pos (backward-match start-pos limit)]
|
|
[min-pos (backward-containing-sexp start-pos limit)])
|
|
(if (and end-pos
|
|
(or (not min-pos)
|
|
(end-pos . >= . min-pos)))
|
|
;; Can go backward, but check for preceding quote, unquote, etc.
|
|
(let loop ([end-pos end-pos])
|
|
(let ([next-end-pos (backward-match end-pos limit)])
|
|
(if (and next-end-pos
|
|
(or (not min-pos)
|
|
(end-pos . >= . min-pos))
|
|
(stick-to-next-sexp? next-end-pos))
|
|
(loop next-end-pos)
|
|
end-pos)))
|
|
;; can't go backward at all:
|
|
#f)))
|
|
[define flash-backward-sexp
|
|
(λ (start-pos)
|
|
(let ([end-pos (get-backward-sexp start-pos)])
|
|
(if end-pos
|
|
(flash-on end-pos (add1 end-pos))
|
|
(bell))
|
|
#t))]
|
|
[define backward-sexp
|
|
(λ (start-pos)
|
|
(let ([end-pos (get-backward-sexp start-pos)])
|
|
(if end-pos
|
|
(set-position end-pos)
|
|
(bell))
|
|
#t))]
|
|
[define find-up-sexp
|
|
(λ (start-pos)
|
|
(let* ([limit-pos (get-limit start-pos)]
|
|
[exp-pos
|
|
(backward-containing-sexp start-pos limit-pos)])
|
|
|
|
(if (and exp-pos (> exp-pos limit-pos))
|
|
(let* ([in-start-pos (skip-whitespace exp-pos 'backward #t)]
|
|
[paren-pos
|
|
(λ (paren-pair)
|
|
(find-string
|
|
(car paren-pair)
|
|
'backward
|
|
in-start-pos
|
|
limit-pos))])
|
|
(let ([poss (let loop ([parens (racket-paren:get-paren-pairs)])
|
|
(cond
|
|
[(null? parens) null]
|
|
[else
|
|
(let ([pos (paren-pos (car parens))])
|
|
(if pos
|
|
(cons pos (loop (cdr parens)))
|
|
(loop (cdr parens))))]))])
|
|
(if (null? poss) ;; all finds failed
|
|
#f
|
|
(- (apply max poss) 1)))) ;; subtract one to move outside the paren
|
|
#f)))]
|
|
[define up-sexp
|
|
(λ (start-pos)
|
|
(let ([exp-pos (find-up-sexp start-pos)])
|
|
(if exp-pos
|
|
(set-position exp-pos)
|
|
(bell))
|
|
#t))]
|
|
[define find-down-sexp
|
|
(λ (start-pos)
|
|
(let loop ([pos start-pos])
|
|
(let ([next-pos (get-forward-sexp pos)])
|
|
(if (and next-pos (> next-pos pos))
|
|
(let ([back-pos
|
|
(backward-containing-sexp (sub1 next-pos) pos)])
|
|
(if (and back-pos
|
|
(> back-pos pos))
|
|
back-pos
|
|
(loop next-pos)))
|
|
#f))))]
|
|
[define down-sexp
|
|
(λ (start-pos)
|
|
(let ([pos (find-down-sexp start-pos)])
|
|
(if pos
|
|
(set-position pos)
|
|
(bell))
|
|
#t))]
|
|
[define remove-parens-forward
|
|
(λ (start-pos)
|
|
(let* ([pos (skip-whitespace start-pos 'forward #f)]
|
|
[first-char (get-character pos)]
|
|
[paren? (or (char=? first-char #\()
|
|
(char=? first-char #\[)
|
|
(char=? first-char #\{))]
|
|
[closer (and paren?
|
|
(get-forward-sexp pos))])
|
|
(if (and paren? closer)
|
|
(begin (begin-edit-sequence #t #f)
|
|
(delete pos (add1 pos))
|
|
(delete (- closer 2) (- closer 1))
|
|
(end-edit-sequence))
|
|
(bell))
|
|
#t))]
|
|
|
|
(define/private (select-text f forward?)
|
|
(define start-pos (get-start-position))
|
|
(define end-pos (get-end-position))
|
|
(define new-pos
|
|
(if forward?
|
|
(if (= (get-extend-start-position) start-pos)
|
|
(f end-pos)
|
|
(f start-pos))
|
|
(if (= (get-extend-end-position) end-pos)
|
|
(f start-pos)
|
|
(f end-pos))))
|
|
(if new-pos
|
|
(extend-position new-pos)
|
|
(bell))
|
|
#t)
|
|
(public select-forward-sexp select-backward-sexp select-up-sexp select-down-sexp)
|
|
[define select-forward-sexp (λ () (select-text (λ (x) (get-forward-sexp x)) #t))]
|
|
[define select-backward-sexp (λ () (select-text (λ (x) (get-backward-sexp x)) #f))]
|
|
[define select-up-sexp (λ () (select-text (λ (x) (find-up-sexp x)) #f))]
|
|
[define select-down-sexp (λ () (select-text (λ (x) (find-down-sexp x)) #t))]
|
|
|
|
(define/public (introduce-let-ans pos)
|
|
(dynamic-wind
|
|
(λ () (begin-edit-sequence))
|
|
(λ ()
|
|
(let ([before-text "(let ([ans "]
|
|
[after-text "])\n"]
|
|
[after-text2 "(printf \"~s\\n\" ans)\nans)"]
|
|
[end-l (get-forward-sexp pos)])
|
|
(cond
|
|
[end-l
|
|
(insert after-text2 end-l end-l)
|
|
(insert after-text end-l end-l)
|
|
(insert before-text pos pos)
|
|
(let ([blank-line-pos (+ end-l (string-length after-text) (string-length before-text))])
|
|
(set-position blank-line-pos blank-line-pos))
|
|
(tabify-selection
|
|
pos
|
|
(+ end-l
|
|
(string-length before-text)
|
|
(string-length after-text)
|
|
(string-length after-text2)))]
|
|
[else
|
|
(bell)])))
|
|
(λ ()
|
|
(end-edit-sequence))))
|
|
|
|
(define/public (move-sexp-out begin-inner)
|
|
(begin-edit-sequence #t #f)
|
|
(let ([end-inner (get-forward-sexp begin-inner)]
|
|
[begin-outer (find-up-sexp begin-inner)])
|
|
(cond
|
|
[(and end-inner begin-outer)
|
|
(let ([end-outer (get-forward-sexp begin-outer)])
|
|
(cond
|
|
[end-outer
|
|
(delete end-inner end-outer)
|
|
(delete begin-outer begin-inner)
|
|
(tabify-selection begin-outer (+ begin-outer (- end-inner begin-inner)))]
|
|
[else (bell)]))]
|
|
[else (bell)]))
|
|
(end-edit-sequence))
|
|
|
|
(define/public (kill-enclosing-parens begin-inner)
|
|
(begin-edit-sequence #t #f)
|
|
(define begin-outer (find-up-sexp begin-inner))
|
|
(cond
|
|
[begin-outer
|
|
(define end-outer (get-forward-sexp begin-outer))
|
|
(cond
|
|
[(and end-outer (>= (- end-outer begin-outer) 2))
|
|
(delete (- end-outer 1) end-outer)
|
|
(delete begin-outer (+ begin-outer 1))
|
|
(tabify-selection begin-outer (- end-outer 2))]
|
|
[else (bell)])]
|
|
[else (bell)])
|
|
(end-edit-sequence))
|
|
|
|
;; change the parens following the cursor from () to [] or vice versa
|
|
(define/public (toggle-round-square-parens start-pos)
|
|
(begin-edit-sequence #t #f)
|
|
(let* ([sexp-begin (skip-whitespace start-pos 'forward #f)]
|
|
[sexp-end (get-forward-sexp sexp-begin)])
|
|
(cond [(and sexp-end
|
|
(< (+ 1 sexp-begin) sexp-end))
|
|
;; positions known to exist: start-pos <= x < sexp-end
|
|
(match* ((get-character sexp-begin) (get-character (- sexp-end 1)))
|
|
[(#\( #\)) (replace-char-at-posn sexp-begin "[")
|
|
(replace-char-at-posn (- sexp-end 1) "]")]
|
|
[(#\[ #\]) (replace-char-at-posn sexp-begin "(")
|
|
(replace-char-at-posn (- sexp-end 1) ")")]
|
|
[(_ _) (bell)])]
|
|
[else (bell)]))
|
|
(end-edit-sequence))
|
|
|
|
;; replace-char-at-posn: natural-number string ->
|
|
;; replace the char at the given posn with the given string.
|
|
;;
|
|
;; this abstraction exists because the duplicated code in toggle-round-square-parens was
|
|
;; just a little too much for comfort
|
|
(define (replace-char-at-posn posn str)
|
|
;; insertions are performed before deletions in order to preserve the location of the cursor
|
|
(insert str (+ posn 1) (+ posn 1))
|
|
(delete posn (+ posn 1)))
|
|
|
|
(inherit get-fixed-style)
|
|
(define/public (mark-matching-parenthesis pos)
|
|
(let ([open-parens (map car (racket-paren:get-paren-pairs))]
|
|
[close-parens (map cdr (racket-paren:get-paren-pairs))])
|
|
(when (member (string (get-character pos)) open-parens)
|
|
(let ([end (get-forward-sexp pos)])
|
|
(when (and end
|
|
(member (string (get-character (- end 1))) close-parens))
|
|
(let ([start-style (send (find-snip pos 'after) get-style)]
|
|
[end-style (send (find-snip end 'before) get-style)])
|
|
(cond
|
|
[(and (eq? matching-parenthesis-style start-style)
|
|
(eq? matching-parenthesis-style end-style))
|
|
(let ([fixed-style (get-fixed-style)])
|
|
(change-style fixed-style pos (+ pos 1))
|
|
(change-style fixed-style (- end 1) end))]
|
|
[else
|
|
(change-style matching-parenthesis-style pos (+ pos 1))
|
|
(change-style matching-parenthesis-style (- end 1) end)])))))))
|
|
|
|
;; get-snips/rev: start end -> (listof snip)
|
|
;; Returns a list of the snips in reverse order between
|
|
;; start and end.
|
|
(define/private (get-snips/rev start end)
|
|
(split-snip start)
|
|
(split-snip end)
|
|
(let loop ([snips/rev '()]
|
|
[a-snip (find-snip start 'after-or-none)])
|
|
(cond
|
|
[(or (not a-snip)
|
|
(>= (get-snip-position a-snip)
|
|
end))
|
|
snips/rev]
|
|
[else
|
|
(loop (cons (send a-snip copy) snips/rev)
|
|
(send a-snip next))])))
|
|
|
|
(define/public (transpose-sexp pos)
|
|
(let ([start-1 (get-backward-sexp pos)])
|
|
(if (not start-1)
|
|
(bell)
|
|
(let ([end-1 (get-forward-sexp start-1)])
|
|
(if (not end-1)
|
|
(bell)
|
|
(let ([end-2 (get-forward-sexp end-1)])
|
|
(if (not end-2)
|
|
(bell)
|
|
(let ([start-2 (get-backward-sexp end-2)])
|
|
(if (or (not start-2)
|
|
(< start-2 end-1))
|
|
(bell)
|
|
(let ([snips-1/rev (get-snips/rev start-1 end-1)]
|
|
[snips-2/rev (get-snips/rev start-2 end-2)])
|
|
(begin-edit-sequence)
|
|
(delete start-2 end-2)
|
|
(for-each (λ (s) (insert s start-2)) snips-1/rev)
|
|
(delete start-1 end-1)
|
|
(for-each (λ (s) (insert s start-1)) snips-2/rev)
|
|
(set-position end-2)
|
|
(end-edit-sequence)))))))))))
|
|
[define tab-size 8]
|
|
(public get-tab-size set-tab-size)
|
|
[define get-tab-size (λ () tab-size)]
|
|
[define set-tab-size (λ (s) (set! tab-size s))]
|
|
|
|
(define/override (get-start-of-line pos)
|
|
(define para (position-paragraph pos))
|
|
(define para-start (paragraph-start-position para))
|
|
(define para-end (paragraph-end-position para))
|
|
(define first-non-whitespace
|
|
(let loop ([i para-start])
|
|
(cond
|
|
[(= i para-end) #f]
|
|
[(char-whitespace? (get-character i))
|
|
(loop (+ i 1))]
|
|
[else i])))
|
|
(define new-pos
|
|
(cond
|
|
[(not first-non-whitespace) para-start]
|
|
[(= pos para-start) first-non-whitespace]
|
|
[(<= pos first-non-whitespace) para-start]
|
|
[else first-non-whitespace]))
|
|
new-pos)
|
|
|
|
(super-new)))
|
|
|
|
(define -text-mode<%>
|
|
(interface ()
|
|
))
|
|
|
|
(define module-lexer/waived (waive-option module-lexer))
|
|
|
|
(define text-mode-mixin
|
|
(mixin (color:text-mode<%> mode:surrogate-text<%>) (-text-mode<%>)
|
|
|
|
(define saved-wordbreak-map #f)
|
|
|
|
(define/override (on-disable-surrogate text)
|
|
(keymap:remove-chained-keymap text keymap)
|
|
(send text set-wordbreak-map saved-wordbreak-map)
|
|
(super on-disable-surrogate text))
|
|
|
|
(define/override (on-enable-surrogate text)
|
|
(send text begin-edit-sequence)
|
|
(super on-enable-surrogate text)
|
|
(send (send text get-private-racket-container-keymap) chain-to-keymap keymap #f)
|
|
|
|
(set! saved-wordbreak-map (send text get-wordbreak-map))
|
|
|
|
(send text set-load-overwrites-styles #f)
|
|
(send text set-wordbreak-map wordbreak-map)
|
|
(let ([bw (box 0)]
|
|
[bu (box #f)]
|
|
[tab-size (send text get-tab-size)])
|
|
(unless (and (null? (send text get-tabs #f bw bu))
|
|
(= tab-size (unbox bw))
|
|
(not (unbox bu)))
|
|
(send text set-tabs null (send text get-tab-size) #f)))
|
|
(send text set-styles-fixed #t)
|
|
(send text end-edit-sequence))
|
|
|
|
(define tabify-pref (preferences:get 'framework:tabify))
|
|
(preferences:add-callback
|
|
'framework:tabify
|
|
(lambda (k v) (set! tabify-pref v)))
|
|
(define/private (racket-lexer-wrapper in offset mode)
|
|
(define-values (lexeme type paren start end backup-delta new-mode)
|
|
(module-lexer/waived in offset mode))
|
|
(cond
|
|
[(and (eq? type 'symbol)
|
|
(string? lexeme)
|
|
(get-keyword-type lexeme tabify-pref))
|
|
(values lexeme 'keyword paren start end backup-delta new-mode)]
|
|
[else
|
|
(values lexeme type paren start end backup-delta new-mode)]))
|
|
|
|
(define/override (put-file text sup directory default-name)
|
|
;; don't call the surrogate's super, since it sets the default extension
|
|
(cond
|
|
[(equal? (finder:default-extension) "")
|
|
(parameterize ([finder:default-extension "rkt"])
|
|
(sup directory default-name))]
|
|
[else (sup directory default-name)]))
|
|
|
|
(super-new (get-token (lambda (in offset mode) (racket-lexer-wrapper in offset mode)))
|
|
(token-sym->style short-sym->style-name)
|
|
(matches '((|(| |)|)
|
|
(|[| |]|)
|
|
(|{| |}|))))))
|
|
|
|
;; get-keyword-type : string (list ht regexp regexp regexp)
|
|
;; -> (or/c #f 'lambda 'define 'begin 'for/fold)
|
|
(define (get-keyword-type text pref)
|
|
(define ht (car pref))
|
|
(define beg-reg (list-ref pref 1))
|
|
(define def-reg (list-ref pref 2))
|
|
(define lam-reg (list-ref pref 3))
|
|
(define for/fold-reg (list-ref pref 4))
|
|
(hash-ref
|
|
ht
|
|
(with-handlers ((exn:fail:read? (λ (x) #f)))
|
|
(read (open-input-string text)))
|
|
(λ ()
|
|
(cond
|
|
[(and beg-reg (regexp-match beg-reg text)) 'begin]
|
|
[(and def-reg (regexp-match def-reg text)) 'define]
|
|
[(and lam-reg (regexp-match lam-reg text)) 'lambda]
|
|
[(and for/fold-reg (regexp-match for/fold-reg text)) 'for/fold]
|
|
[else #f]))))
|
|
|
|
|
|
;; in-position? : text (list symbol) -> boolean
|
|
;; determines if the cursor is currently sitting in a particular
|
|
;; position. To make detection of whether the cursor is in
|
|
;; a string or comment more robust, check also the position
|
|
;; right before the cursor to make sure it matches. This handles
|
|
;; the situation ... |"blah blah" where | indicates cursor; in
|
|
;; this case, the cursor is _not_ in the string (although
|
|
;; classify-position characterizes it so).
|
|
(define (in-position? text sym-list)
|
|
(define selection-start (send text get-start-position))
|
|
(define first-type (send text classify-position selection-start))
|
|
(define final-type
|
|
(if (and (member first-type '(string comment))
|
|
(or (= selection-start 0)
|
|
(not (eq? (send text classify-position (- selection-start 1))
|
|
first-type))))
|
|
'white-space
|
|
first-type))
|
|
(and (member final-type sym-list) #t))
|
|
|
|
;; determines if the cursor is currently sitting in a string
|
|
;; literal or a comment.
|
|
(define (in-string/comment? text)
|
|
(in-position? text '(comment string)))
|
|
|
|
;; produces the 1 character string immediately following
|
|
;; the cursor, if there is one and if there is not a current
|
|
;; selection, in which case produces #f
|
|
(define (immediately-following-cursor text)
|
|
(define selection-start (send text get-start-position))
|
|
(and (= selection-start (send text get-end-position)) ; nothing selected
|
|
(< selection-start (send text last-position))
|
|
(send text get-text selection-start (+ selection-start 1))))
|
|
|
|
|
|
(define set-mode-mixin
|
|
(mixin (-text<%> mode:host-text<%>) ()
|
|
(super-new)
|
|
(inherit set-surrogate)
|
|
(set-surrogate (new text-mode%))))
|
|
|
|
(define -text% (set-mode-mixin
|
|
(text-mixin
|
|
(text:autocomplete-mixin
|
|
(mode:host-text-mixin
|
|
color:text%)))))
|
|
|
|
(define text-mode% (text-mode-mixin color:text-mode%))
|
|
|
|
(define (setup-keymap keymap)
|
|
(define (add-edit-function name f)
|
|
(send keymap add-function name (λ (edit event) (f edit))))
|
|
(define (add-pos-function name f)
|
|
(send keymap add-function name
|
|
(λ (edit event)
|
|
(f edit (send edit get-start-position)))))
|
|
(add-pos-function "remove-sexp" (λ (e p) (send e remove-sexp p)))
|
|
(add-pos-function "forward-sexp" (λ (e p) (send e forward-sexp p)))
|
|
(add-pos-function "backward-sexp" (λ (e p) (send e backward-sexp p)))
|
|
(add-pos-function "up-sexp" (λ (e p) (send e up-sexp p)))
|
|
(add-pos-function "down-sexp" (λ (e p) (send e down-sexp p)))
|
|
(add-pos-function "flash-backward-sexp" (λ (e p) (send e flash-backward-sexp p)))
|
|
(add-pos-function "flash-forward-sexp" (λ (e p) (send e flash-forward-sexp p)))
|
|
(add-pos-function "remove-parens-forward" (λ (e p) (send e remove-parens-forward p)))
|
|
(add-pos-function "transpose-sexp" (λ (e p) (send e transpose-sexp p)))
|
|
(add-pos-function "mark-matching-parenthesis"
|
|
(λ (e p) (send e mark-matching-parenthesis p)))
|
|
(add-pos-function "introduce-let-ans"
|
|
(λ (e p) (send e introduce-let-ans p)))
|
|
(add-pos-function "move-sexp-out"
|
|
(λ (e p) (send e move-sexp-out p)))
|
|
(add-pos-function "kill-enclosing-parens"
|
|
(lambda (e p) (send e kill-enclosing-parens p)))
|
|
(add-pos-function "toggle-round-square-parens"
|
|
(lambda (e p) (send e toggle-round-square-parens p)))
|
|
|
|
(add-edit-function "select-forward-sexp"
|
|
(λ (x) (send x select-forward-sexp)))
|
|
(add-edit-function "select-backward-sexp"
|
|
(λ (x) (send x select-backward-sexp)))
|
|
(add-edit-function "select-down-sexp"
|
|
(λ (x) (send x select-down-sexp)))
|
|
(add-edit-function "select-up-sexp"
|
|
(λ (x) (send x select-up-sexp)))
|
|
(add-edit-function "tabify-at-caret"
|
|
(λ (x) (send x tabify-selection)))
|
|
(add-edit-function "do-return"
|
|
(λ (x) (send x insert-return)))
|
|
(add-edit-function "comment-out"
|
|
(λ (x) (send x comment-out-selection)))
|
|
(add-edit-function "box-comment-out"
|
|
(λ (x) (send x box-comment-out-selection)))
|
|
(add-edit-function "uncomment"
|
|
(λ (x) (send x uncomment-selection)))
|
|
|
|
(send keymap add-function "paren-double-select"
|
|
(λ (text event)
|
|
(keymap:region-click
|
|
text event
|
|
(λ (click-pos eol?)
|
|
(define (word-based)
|
|
(define start-box (box click-pos))
|
|
(define end-box (box click-pos))
|
|
(send text find-wordbreak start-box end-box 'selection)
|
|
(values (unbox start-box) (unbox end-box)))
|
|
(define token (send text classify-position click-pos))
|
|
(define-values (start end)
|
|
(cond
|
|
[(memq token '(string comment)) (word-based)]
|
|
[(and (equal? token 'other)
|
|
(let-values ([(start end) (send text get-token-range click-pos)])
|
|
(and start
|
|
end
|
|
(let ([str (send text get-text start end)])
|
|
(or (regexp-match? #rx"^#lang" str)
|
|
(regexp-match? #rx"^#!" str))))))
|
|
(word-based)]
|
|
[(and (equal? token 'parenthesis)
|
|
(ormap (λ (pr) (equal? (cdr pr) (string (send text get-character click-pos))))
|
|
(racket-paren:get-paren-pairs)))
|
|
(define start (send text get-backward-sexp (+ click-pos 1)))
|
|
(if start
|
|
(values start (+ click-pos 1))
|
|
(word-based))]
|
|
[else
|
|
(let ([end (send text get-forward-sexp click-pos)])
|
|
(if end
|
|
(let ([beginning (send text get-backward-sexp end)])
|
|
(if beginning
|
|
(values beginning end)
|
|
(word-based)))
|
|
(word-based)))]))
|
|
(send text set-position start end)))))
|
|
|
|
(let ([add/map-non-clever
|
|
(λ (name keystroke char [closer #f])
|
|
(add-edit-function
|
|
name
|
|
(λ (e)
|
|
(send e begin-edit-sequence)
|
|
(define start (send e get-start-position))
|
|
(define stop (send e get-end-position))
|
|
(send e insert char start stop)
|
|
(when (and closer (preferences:get 'framework:automatic-parens))
|
|
(send e insert closer (+ start 1) (+ start 1)))
|
|
(send e end-edit-sequence)))
|
|
(send keymap map-function keystroke name))])
|
|
(add/map-non-clever "non-clever-open-square-bracket" "~g:c:[" #\[ #\])
|
|
(add/map-non-clever "non-clever-close-square-bracket" "~g:c:]" #\])
|
|
(add/map-non-clever "non-clever-close-curley-bracket" "~g:c:}" #\})
|
|
(add/map-non-clever "non-clever-close-round-paren" "~g:c:)" #\)))
|
|
|
|
(send keymap add-function "balance-parens"
|
|
(λ (edit event)
|
|
(send edit balance-parens event)))
|
|
(send keymap add-function "balance-parens-forward"
|
|
(λ (edit event)
|
|
(send edit balance-parens event 'forward)))
|
|
|
|
(send keymap map-function "TAB" "tabify-at-caret")
|
|
|
|
(send keymap map-function "return" "do-return")
|
|
(send keymap map-function "s:return" "do-return")
|
|
(send keymap map-function "s:c:return" "do-return")
|
|
(send keymap map-function "a:return" "do-return")
|
|
(send keymap map-function "s:a:return" "do-return")
|
|
(send keymap map-function "c:a:return" "do-return")
|
|
(send keymap map-function "c:s:a:return" "do-return")
|
|
(send keymap map-function "c:return" "do-return")
|
|
(send keymap map-function "d:return" "do-return")
|
|
|
|
(send keymap map-function ")" "balance-parens")
|
|
(send keymap map-function "]" "balance-parens")
|
|
(send keymap map-function "}" "balance-parens")
|
|
|
|
(send keymap map-function "leftbuttondouble" "paren-double-select")
|
|
|
|
|
|
;(define (insert-brace-pair text open-brace close-brace [space-between? #f])
|
|
; (insert/check/balance text open-brace close-brace #f space-between?))
|
|
#|
|
|
(define selection-start (send text get-start-position))
|
|
(define hash-before? ; tweak to detect and correctly close block comments #| ... |#
|
|
(and (< 0 selection-start)
|
|
(string=? "#" (send text get-text (- selection-start 1) selection-start))))
|
|
(send text begin-edit-sequence)
|
|
(send text set-position (send text get-end-position))
|
|
(when space-between? (send text insert " "))
|
|
(send text insert close-brace)
|
|
(when (and (char? open-brace) (char=? #\| open-brace) hash-before?)
|
|
(send text insert #\#))
|
|
(send text set-position selection-start)
|
|
(send text insert open-brace)
|
|
(when space-between?
|
|
(send text set-position (+ (send text get-start-position) 1)))
|
|
(send text end-edit-sequence))|#
|
|
|
|
;; Inserts the open parens character and, if the resulting token
|
|
;; type satisfies checkp, then go ahead and insert the close parens
|
|
;; and set the cursor between them.
|
|
;; When space-between?, adds a space between the braces and places
|
|
;; the cursor after the space.
|
|
;; checkp: (or/c #f symbol (symbol -> boolean))
|
|
;; When checkp is #f, always inserts both open and close braces
|
|
;; When checkp is a symbol, only inserts the closing brace if
|
|
;; the tokenizer identifies open-brace as that type of token
|
|
;; having inserted it
|
|
;; When checkp is a predicate, only inserts the closing brace if
|
|
;; the token type of the inserted open-brace satisfies it
|
|
(define (insert-brace-pair text open-brace close-brace [checkp #f] [space-between? #f])
|
|
(define selection-start (send text get-start-position))
|
|
(define selection-end (send text get-end-position))
|
|
(define open-len (if (string? open-brace) (string-length open-brace) 1))
|
|
(send text begin-edit-sequence #t #f)
|
|
(send text insert open-brace selection-start)
|
|
(define tok-type (send text classify-position selection-start))
|
|
(when (or (not checkp)
|
|
(and (symbol? checkp) (eq? checkp tok-type))
|
|
(and (procedure? checkp) (checkp tok-type)))
|
|
(define hash-before? ; tweak to detect and correctly close block comments #| ... |#
|
|
(and (< 0 selection-start)
|
|
(string=? "#" (send text get-text (- selection-start 1) selection-start))))
|
|
(send text set-position (+ selection-end open-len))
|
|
(when space-between? (send text insert " "))
|
|
(send text insert close-brace)
|
|
(when (and (char? open-brace) (char=? #\| open-brace) hash-before?)
|
|
(send text insert #\#))
|
|
(send text set-position (+ selection-start open-len (if space-between? 1 0))))
|
|
(send text end-edit-sequence))
|
|
|
|
|
|
;; only insert a pair if automatic-parens preference is on, depending
|
|
;; on other analyses of the state of the text (e.g. auto-parens shouldn't
|
|
;; affect typing literal characters inside a string constant, etc.)
|
|
(define (maybe-insert-brace-pair text open-brace close-brace)
|
|
(define open-parens
|
|
(for/list ([x (racket-paren:get-paren-pairs)]) (string-ref (car x) 0)))
|
|
(cond
|
|
[(not (preferences:get 'framework:automatic-parens))
|
|
(define startpos (send text get-start-position))
|
|
(if (and (send text get-overwrite-mode)
|
|
(= startpos (send text get-end-position)))
|
|
(send text insert open-brace startpos (add1 startpos))
|
|
(send text insert open-brace))]
|
|
|
|
[else ; automatic-parens is enabled
|
|
(define c (immediately-following-cursor text))
|
|
(define cur-token
|
|
(send text classify-position (send text get-start-position)))
|
|
(cond
|
|
; insert paren pair if it results valid parenthesis token...
|
|
[(member open-brace open-parens)
|
|
(insert-brace-pair text open-brace close-brace 'parenthesis)]
|
|
|
|
; ASSUME: from here on, open-brace is either " or |
|
|
[else
|
|
;(printf "tok ~a~n" cur-token)
|
|
(match cur-token
|
|
[(or 'error #f) (insert-brace-pair text open-brace close-brace 'error)]
|
|
['constant (insert-brace-pair text open-brace close-brace
|
|
(λ(t) (not (eq? t 'constant))))]
|
|
[(or 'symbol 'comment)
|
|
(cond
|
|
[(and c (char=? #\| open-brace) (string=? c "|")) ;; smart skip
|
|
(send text set-position (+ 1 (send text get-end-position)))
|
|
(define d (immediately-following-cursor text))
|
|
(when (and d (string=? d "#")) ; a block comment?
|
|
(send text set-position (+ 1 (send text get-end-position))))]
|
|
[(eq? cur-token 'comment) (send text insert open-brace)]
|
|
[else (insert-brace-pair text open-brace close-brace)])]
|
|
['string
|
|
(cond
|
|
[(not (char=? #\" open-brace)) (send text insert open-brace)]
|
|
[else
|
|
(define start-position (send text get-start-position))
|
|
(define end-position (send text get-end-position))
|
|
(cond
|
|
; smart skip a " if it is the immediately following character (c)
|
|
[(and c (string=? c "\""))
|
|
(send text set-position (+ 1 end-position))]
|
|
|
|
; there is no current selection - split the string in two
|
|
[(= start-position end-position)
|
|
(insert-brace-pair text #\" #\" #f #t)]
|
|
|
|
; there is a selection - split the selected text off as a
|
|
; separate string from the surrounding in an intelligent way
|
|
; and retain selection of the split-out string
|
|
[else (define selection-length (- end-position start-position))
|
|
(insert-brace-pair text "\" \"" "\" \"")
|
|
(define cur-position (send text get-start-position))
|
|
(send text set-position
|
|
(- cur-position 1)
|
|
(+ cur-position selection-length 1))])])]
|
|
[_ (insert-brace-pair text open-brace close-brace)]) ])]))
|
|
|
|
|
|
|
|
|
|
(add-edit-function "insert-()-pair" (λ (text) (insert-brace-pair text #\( #\))))
|
|
(add-edit-function "insert-[]-pair" (λ (text) (insert-brace-pair text #\[ #\])))
|
|
(add-edit-function "insert-{}-pair" (λ (text) (insert-brace-pair text #\{ #\})))
|
|
(add-edit-function "insert-\"\"-pair" (λ (text) (insert-brace-pair text #\" #\")))
|
|
(add-edit-function "insert-||-pair" (λ (text) (insert-brace-pair text #\| #\|)))
|
|
|
|
(add-edit-function "maybe-insert-()-pair" (λ (text) (maybe-insert-brace-pair text #\( #\))))
|
|
(add-edit-function "maybe-insert-[]-pair" (λ (text) (maybe-insert-brace-pair text #\[ #\])))
|
|
(add-edit-function "maybe-insert-{}-pair" (λ (text) (maybe-insert-brace-pair text #\{ #\})))
|
|
(add-edit-function "maybe-insert-\"\"-pair" (λ (text) (maybe-insert-brace-pair text #\" #\")))
|
|
(add-edit-function "maybe-insert-||-pair" (λ (text) (maybe-insert-brace-pair text #\| #\|)))
|
|
|
|
(add-edit-function "maybe-insert-[]-pair-maybe-fixup-[]"
|
|
(λ (text)
|
|
(cond
|
|
[(or (not (preferences:get 'framework:fixup-open-parens))
|
|
(send text is-stopped?))
|
|
(maybe-insert-brace-pair text #\[ #\])]
|
|
[else
|
|
(insert-paren text)])))
|
|
|
|
(define (insert-lambda-template edit)
|
|
(send edit begin-edit-sequence)
|
|
(let ([selection-start (send edit get-start-position)])
|
|
(send edit set-position (send edit get-end-position))
|
|
(send edit insert ")")
|
|
(send edit set-position selection-start)
|
|
(send edit insert ") ")
|
|
(send edit set-position selection-start)
|
|
(send edit insert "(λ ("))
|
|
(send edit end-edit-sequence))
|
|
|
|
(add-edit-function "insert-lambda-template" insert-lambda-template)
|
|
|
|
(define (map-meta key func) (keymap:send-map-function-meta keymap key func))
|
|
(define (map key func) (send keymap map-function key func))
|
|
|
|
(map-meta "up" "up-sexp")
|
|
(map-meta "c:u" "up-sexp")
|
|
(map "a:up" "up-sexp")
|
|
(map-meta "s:up" "select-up-sexp")
|
|
(map "a:s:up" "select-up-sexp")
|
|
(map-meta "s:c:u" "select-up-sexp")
|
|
|
|
(map-meta "down" "down-sexp")
|
|
(map "a:down" "down-sexp")
|
|
(map-meta "s:down" "select-down-sexp")
|
|
(map "a:s:down" "select-down-sexp")
|
|
(map-meta "s:c:down" "select-down-sexp")
|
|
|
|
(map-meta "right" "forward-sexp")
|
|
(map "a:right" "forward-sexp")
|
|
(map "m:right" "forward-sexp")
|
|
(map-meta "s:right" "select-forward-sexp")
|
|
(map "a:s:right" "select-forward-sexp")
|
|
(map "m:s:right" "select-forward-sexp")
|
|
|
|
(map-meta "left" "backward-sexp")
|
|
(map "a:left" "backward-sexp")
|
|
(map "m:left" "backward-sexp")
|
|
(map-meta "s:left" "select-backward-sexp")
|
|
(map "a:s:left" "select-backward-sexp")
|
|
(map "m:s:left" "select-backward-sexp")
|
|
|
|
(map-meta "return" "do-return")
|
|
(map-meta "s:return" "do-return")
|
|
(map-meta "s:c:return" "do-return")
|
|
(map-meta "a:return" "do-return")
|
|
(map-meta "s:a:return" "do-return")
|
|
(map-meta "c:a:return" "do-return")
|
|
(map-meta "c:s:a:return" "do-return")
|
|
(map-meta "c:return" "do-return")
|
|
|
|
(map-meta "c:semicolon" "comment-out")
|
|
(map-meta "c:=" "uncomment")
|
|
(map-meta "c:k" "remove-sexp")
|
|
|
|
(map-meta "c:f" "forward-sexp")
|
|
(map-meta "s:c:f" "select-forward-sexp")
|
|
|
|
(map-meta "c:b" "backward-sexp")
|
|
(map-meta "s:c:b" "select-backward-sexp")
|
|
|
|
(map-meta "c:p" "flash-backward-sexp")
|
|
(map-meta "s:c:n" "flash-forward-sexp")
|
|
|
|
(map-meta "c:space" "select-forward-sexp")
|
|
(map-meta "c:t" "transpose-sexp")
|
|
|
|
;(map-meta "c:m" "mark-matching-parenthesis")
|
|
; this keybinding doesn't interact with the paren colorer
|
|
|
|
(map-meta ")" "balance-parens-forward")
|
|
(map-meta "]" "balance-parens-forward")
|
|
(map-meta "}" "balance-parens-forward")
|
|
|
|
(map-meta "(" "insert-()-pair")
|
|
(map-meta "[" "insert-[]-pair")
|
|
(map-meta "{" "insert-{}-pair")
|
|
(map-meta "\"" "insert-\"\"-pair")
|
|
(map-meta "|" "insert-||-pair")
|
|
|
|
(map "(" "maybe-insert-()-pair")
|
|
(map "[" "maybe-insert-[]-pair-maybe-fixup-[]")
|
|
(map "{" "maybe-insert-{}-pair")
|
|
(map "\"" "maybe-insert-\"\"-pair")
|
|
(map "|" "maybe-insert-||-pair")
|
|
|
|
(map-meta "s:l" "insert-lambda-template")
|
|
|
|
(map "c:c;c:b" "remove-parens-forward")
|
|
(map "c:c;c:l" "introduce-let-ans")
|
|
(map "c:c;c:o" "move-sexp-out")
|
|
(map "c:c;c:e" "kill-enclosing-parens")
|
|
(map "c:c;c:[" "toggle-round-square-parens"))
|
|
|
|
(define keymap (make-object keymap:aug-keymap%))
|
|
(setup-keymap keymap)
|
|
(define (get-keymap) keymap)
|
|
|
|
;; choose-paren : racket-text number -> character
|
|
;; returns the character to replace a #\[ with, based
|
|
;; on the context where it is typed in.
|
|
(define (insert-paren text)
|
|
(let* ([pos (send text get-start-position)]
|
|
[real-char #\[]
|
|
[change-to (λ (i c)
|
|
;(printf "change-to, case ~a\n" i)
|
|
(set! real-char c))]
|
|
[start-pos (send text get-start-position)]
|
|
[end-pos (send text get-end-position)]
|
|
[letrec-like-forms (preferences:get 'framework:square-bracket:letrec)]
|
|
[for/fold-like-forms (preferences:get 'framework:square-bracket:for/fold)])
|
|
(send text begin-edit-sequence #f #f)
|
|
(if (and (send text get-overwrite-mode) (= start-pos end-pos))
|
|
(send text insert "[" start-pos (add1 start-pos) #f)
|
|
(send text insert "[" start-pos 'same #f))
|
|
(when (equal? (send text classify-position pos) 'parenthesis)
|
|
(let* ([before-whitespace-pos (send text skip-whitespace pos 'backward #t)]
|
|
[keyword/distance (find-keyword-and-distance before-whitespace-pos text)])
|
|
(cond
|
|
[(and keyword/distance
|
|
(member keyword/distance
|
|
(preferences:get 'framework:square-bracket:cond/offset)))
|
|
;; just leave the square backet in, in this case
|
|
(void)]
|
|
[(and keyword/distance
|
|
(member (car keyword/distance)
|
|
(preferences:get 'framework:square-bracket:local)))
|
|
(unless (= (cadr keyword/distance) 0)
|
|
(change-to 7 #\())]
|
|
[else
|
|
(let* ([backward-match (send text backward-match before-whitespace-pos 0)]
|
|
[b-m-char (and (number? backward-match) (send text get-character backward-match))])
|
|
(cond
|
|
[backward-match
|
|
;; there is an expression before this, at this layer
|
|
(define before-whitespace-pos2
|
|
(send text skip-whitespace backward-match 'backward #t))
|
|
(define backward-match2 (send text backward-match before-whitespace-pos2 0))
|
|
(cond
|
|
[(member b-m-char '(#\( #\[ #\{))
|
|
;; found a "sibling" parenthesized sequence. use the parens it uses.
|
|
(change-to 1 b-m-char)]
|
|
[else
|
|
;; otherwise, we switch to (
|
|
(change-to 2 #\()])]
|
|
[(not (zero? before-whitespace-pos))
|
|
;; this is the first thing in the sequence
|
|
;; pop out one layer and look for a keyword.
|
|
(define b-w-p-char (send text get-character (- before-whitespace-pos 1)))
|
|
(cond
|
|
[(equal? b-w-p-char #\()
|
|
(define second-before-whitespace-pos (send text skip-whitespace
|
|
(- before-whitespace-pos 1)
|
|
'backward
|
|
#t))
|
|
(define second-backwards-match (send text backward-match
|
|
second-before-whitespace-pos
|
|
0))
|
|
(cond
|
|
[(not second-backwards-match)
|
|
(change-to 3 #\()]
|
|
[(and (beginning-of-sequence? text second-backwards-match)
|
|
(ormap (λ (x) (text-between-equal? x
|
|
text
|
|
second-backwards-match
|
|
second-before-whitespace-pos))
|
|
letrec-like-forms))
|
|
;; we found a let<mumble> keyword, so we get a square bracket
|
|
(void)]
|
|
[else
|
|
;; go back one more sexp in the same row, looking for `let loop' pattern
|
|
(define second-before-whitespace-pos2 (send text skip-whitespace
|
|
second-backwards-match
|
|
'backward
|
|
#t))
|
|
(define second-backwards-match2 (send text backward-match
|
|
second-before-whitespace-pos2
|
|
0))
|
|
(cond
|
|
[(and second-backwards-match2
|
|
(ormap (λ (x)
|
|
(text-between-equal? x
|
|
text
|
|
second-backwards-match2
|
|
second-before-whitespace-pos2))
|
|
for/fold-like-forms))
|
|
;; found a for/fold-like form, so we keep the [
|
|
(void)]
|
|
[(and second-backwards-match2
|
|
(member (send text classify-position second-backwards-match)
|
|
;;; otherwise, this isn't a `let loop',
|
|
;;; it is a regular let
|
|
'(symbol keyword))
|
|
(member "let" letrec-like-forms)
|
|
(text-between-equal? "let"
|
|
text
|
|
second-backwards-match2
|
|
second-before-whitespace-pos2))
|
|
;; found the `(let loop (' so we keep the [
|
|
(void)]
|
|
[else
|
|
;; otherwise, round.
|
|
(change-to 4 #\()])])]
|
|
[else
|
|
(change-to 5 #\()])]
|
|
[else
|
|
(change-to 6 #\()]))])))
|
|
(send text delete pos (+ pos 1) #f)
|
|
(send text end-edit-sequence)
|
|
(cond
|
|
[(and (preferences:get 'framework:automatic-parens)
|
|
(not (in-string/comment? text)))
|
|
(send text insert real-char start-pos start-pos)
|
|
(when (equal? (send text classify-position start-pos) 'parenthesis)
|
|
(send text insert (case real-char
|
|
[(#\() #\)]
|
|
[(#\[) #\]]
|
|
[(#\{) #\}])
|
|
(+ end-pos 1) (+ end-pos 1))
|
|
(send text set-position (+ start-pos 1)))]
|
|
[else
|
|
(send text insert real-char start-pos end-pos)])))
|
|
|
|
;; find-keyword-and-distance : -> (union #f (cons string number))
|
|
(define (find-keyword-and-distance before-whitespace-pos text)
|
|
;; searches backwards for the keyword in the sequence at this level.
|
|
;; if found, it counts how many sexps back it was
|
|
(let loop ([pos before-whitespace-pos]
|
|
[n 0])
|
|
(let ([backward-match (send text backward-match pos 0)])
|
|
(cond
|
|
[backward-match
|
|
(let ([before-whitespace-pos (send text skip-whitespace backward-match 'backward #t)])
|
|
(loop before-whitespace-pos
|
|
(if (send text stick-to-next-sexp? backward-match)
|
|
n
|
|
(+ n 1))))]
|
|
[else
|
|
(let* ([afterwards (send text get-forward-sexp pos)]
|
|
[keyword
|
|
(and afterwards
|
|
(send text get-text pos afterwards))])
|
|
(and keyword
|
|
(list keyword (- n 1))))]))))
|
|
|
|
;; beginning-of-sequence? : text number -> boolean
|
|
;; determines if this position is at the beginning of a sequence
|
|
;; that begins with a parenthesis.
|
|
(define (beginning-of-sequence? text start)
|
|
(let ([before-space (send text skip-whitespace start 'backward #t)])
|
|
(cond
|
|
[(zero? before-space) #t]
|
|
[else
|
|
(equal? (send text get-character (- before-space 1))
|
|
#\()])))
|
|
|
|
(define (text-between-equal? str text start end)
|
|
(and (= (string-length str) (- end start))
|
|
(let loop ([i (string-length str)])
|
|
(cond
|
|
[(= i 0) #t]
|
|
[else
|
|
(and (char=? (string-ref str (- i 1))
|
|
(send text get-character (+ i start -1)))
|
|
(loop (- i 1)))]))))
|
|
|
|
|
|
; ;;; ;;;
|
|
; ; ;
|
|
; ; ;
|
|
; ;;; ; ;;; ;;; ;;;;; ;;; ; ;;; ;;;; ; ;;; ;;; ;
|
|
;; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ;
|
|
;; ; ; ;;;;; ; ;;; ; ; ;;;; ; ; ;;;;; ;
|
|
;; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
|
;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
|
;;;;; ;;;; ;;; ;;;; ;;; ;;;; ;;; ;;;; ;; ;;; ;;;;;;
|
|
;; ;
|
|
;; ;
|
|
;;;; ;;;
|
|
|
|
|
|
(define (add-preferences-panel)
|
|
(preferences:add-panel
|
|
(list (string-constant editor-prefs-panel-label)
|
|
(string-constant indenting-prefs-panel-label))
|
|
make-indenting-prefs-panel)
|
|
(preferences:add-panel
|
|
(list (string-constant editor-prefs-panel-label)
|
|
(string-constant square-bracket-prefs-panel-label))
|
|
make-square-bracket-prefs-panel))
|
|
|
|
(define (make-square-bracket-prefs-panel p)
|
|
(define main-panel (make-object vertical-panel% p))
|
|
(define boxes-panel (new horizontal-panel% [parent main-panel]))
|
|
|
|
(define (mk-list-box sym keyword-type pref->string get-new-one)
|
|
(letrec ([vp (new vertical-panel% [parent boxes-panel])]
|
|
[_ (new message%
|
|
[label (format (string-constant x-like-keywords) keyword-type)]
|
|
[parent vp])]
|
|
[lb
|
|
(new list-box%
|
|
[label #f]
|
|
[parent vp]
|
|
[choices (map pref->string (preferences:get sym))]
|
|
[callback
|
|
(λ (lb evt)
|
|
(send remove-button enable (pair? (send lb get-selections))))])]
|
|
[bp (new horizontal-panel% [parent vp] [stretchable-height #f])]
|
|
[add
|
|
(new button%
|
|
[label (string-constant add-keyword)]
|
|
[parent bp]
|
|
[callback
|
|
(λ (x y)
|
|
(let ([new-one (get-new-one)])
|
|
(when new-one
|
|
(preferences:set sym (append (preferences:get sym)
|
|
(list new-one))))))])]
|
|
[remove-button
|
|
(new button%
|
|
[label (string-constant remove-keyword)]
|
|
[parent bp]
|
|
[callback
|
|
(λ (x y)
|
|
(let ([n (send lb get-selections)])
|
|
(when (pair? n)
|
|
(preferences:set
|
|
sym
|
|
(let loop ([i 0]
|
|
[prefs (preferences:get sym)])
|
|
(cond
|
|
[(= i (car n)) (cdr prefs)]
|
|
[else (cons (car prefs)
|
|
(loop (+ i 1)
|
|
(cdr prefs)))])))
|
|
(cond
|
|
[(= 0 (send lb get-number))
|
|
(send remove-button enable #f)]
|
|
[else
|
|
(send lb set-selection
|
|
(if (= (car n) (send lb get-number))
|
|
(- (send lb get-number) 1)
|
|
(car n)))]))))])])
|
|
(unless (pair? (send lb get-selections))
|
|
(send remove-button enable #f))
|
|
(preferences:add-callback sym
|
|
(λ (p v)
|
|
(send lb clear)
|
|
(for-each (λ (x) (send lb append (pref->string x))) v)))))
|
|
|
|
(define (get-new-simple-keyword label)
|
|
(λ ()
|
|
(let ([new-one
|
|
(keymap:call/text-keymap-initializer
|
|
(λ ()
|
|
(get-text-from-user
|
|
(format (string-constant enter-new-keyword) label)
|
|
(format (string-constant x-keyword) label))))])
|
|
(and new-one
|
|
(let ([parsed (with-handlers ((exn:fail:read? (λ (x) #f)))
|
|
(read (open-input-string new-one)))])
|
|
|
|
(and (symbol? parsed)
|
|
(symbol->string parsed)))))))
|
|
|
|
(define (get-new-cond-keyword)
|
|
(define f (new dialog% [label (format (string-constant enter-new-keyword) "Cond")]))
|
|
(define tb (keymap:call/text-keymap-initializer
|
|
(λ ()
|
|
(new text-field%
|
|
[parent f]
|
|
[label #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
|
|
(keymap:call/text-keymap-initializer
|
|
(λ ()
|
|
(new text-field%
|
|
[parent number-panel]
|
|
[init-value "1"]
|
|
[min-width 50]
|
|
[label #f]))))
|
|
|
|
(define answers #f)
|
|
(define bp (new horizontal-panel%
|
|
[parent f]
|
|
[stretchable-height #f]
|
|
[alignment '(right center)]))
|
|
(define (confirm-callback b e)
|
|
(let ([n (string->number (send number get-value))]
|
|
[sym (with-handlers ([exn:fail:read? (λ (x) #f)])
|
|
(read (open-input-string (send tb get-value))))])
|
|
(when (and (number? n)
|
|
(symbol? sym))
|
|
(set! answers (list (symbol->string sym) n)))
|
|
(send f show #f)))
|
|
|
|
(define (cancel-callback b e)
|
|
(send f show #f))
|
|
|
|
(define-values (ok-button cancel-button)
|
|
(gui-utils:ok/cancel-buttons bp confirm-callback cancel-callback
|
|
(string-constant ok) (string-constant cancel)))
|
|
(send tb focus)
|
|
(send f show #t)
|
|
answers)
|
|
|
|
(mk-list-box 'framework:square-bracket:letrec "Letrec" values (get-new-simple-keyword "Letrec"))
|
|
(mk-list-box 'framework:square-bracket:local
|
|
"Local"
|
|
values
|
|
(get-new-simple-keyword "Local"))
|
|
(mk-list-box 'framework:square-bracket:for/fold
|
|
"For/fold"
|
|
values
|
|
(get-new-simple-keyword "For/fold"))
|
|
(mk-list-box 'framework:square-bracket:cond/offset
|
|
"Cond"
|
|
(λ (l) (format "~a (~a)" (car l) (cadr l)))
|
|
get-new-cond-keyword)
|
|
|
|
(define check-box (new check-box%
|
|
[parent main-panel]
|
|
[label (string-constant fixup-open-brackets)]
|
|
[value (preferences:get 'framework:fixup-open-parens)]
|
|
[callback
|
|
(λ (x y)
|
|
(preferences:set 'framework:fixup-open-parens
|
|
(send check-box get-value)))]))
|
|
(preferences:add-callback
|
|
'framework:fixup-open-parens
|
|
(λ (p v)
|
|
(send check-box set-value v)))
|
|
|
|
main-panel)
|
|
|
|
(define (make-indenting-prefs-panel p)
|
|
(define get-keywords
|
|
(λ (hash-table)
|
|
(define all-keywords (hash-map hash-table list))
|
|
(define (pick-out wanted in out)
|
|
(cond
|
|
[(null? in) (sort out string<?)]
|
|
[else (if (eq? wanted (cadr (car in)))
|
|
(pick-out wanted (cdr in)
|
|
(cons (format "~s" (car (car in))) out))
|
|
(pick-out wanted (cdr in) out))]))
|
|
(values (pick-out 'begin all-keywords null)
|
|
(pick-out 'define all-keywords null)
|
|
(pick-out 'lambda all-keywords null)
|
|
(pick-out 'for/fold all-keywords null))))
|
|
(define-values (begin-keywords define-keywords lambda-keywords for/fold-keywords)
|
|
(get-keywords (car (preferences:get 'framework:tabify))))
|
|
(define ((add-button-callback keyword-type keyword-symbol list-box) button command)
|
|
(define new-one
|
|
(keymap:call/text-keymap-initializer
|
|
(λ ()
|
|
(get-text-from-user
|
|
(format (string-constant enter-new-keyword) keyword-type)
|
|
(format (string-constant x-keyword) keyword-type)))))
|
|
(when new-one
|
|
(let ([parsed (with-handlers ((exn:fail:read? (λ (x) #f)))
|
|
(read (open-input-string new-one)))])
|
|
(cond
|
|
[(and (symbol? parsed)
|
|
(hash-ref (car (preferences:get 'framework:tabify))
|
|
parsed
|
|
(λ () #f)))
|
|
(message-box (string-constant error)
|
|
(format (string-constant already-used-keyword) parsed))]
|
|
[(symbol? parsed)
|
|
(let* ([pref (preferences:get 'framework:tabify)]
|
|
[ht (car pref)])
|
|
(hash-set! ht parsed keyword-symbol)
|
|
(preferences:set 'framework:tabify pref)
|
|
(update-list-boxes ht))]
|
|
[else (message-box
|
|
(string-constant error)
|
|
(format (string-constant expected-a-symbol) new-one))]))))
|
|
(define ((delete-callback list-box) button command)
|
|
(define selections (send list-box get-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))
|
|
(define pref (preferences:get 'framework:tabify))
|
|
(define ht (car pref))
|
|
(for-each (λ (x) (hash-remove! ht x)) symbols)
|
|
(preferences:set 'framework:tabify pref))
|
|
(define main-panel (make-object horizontal-panel% p))
|
|
(define (make-column string symbol keywords bang-regexp)
|
|
(define vert (make-object vertical-panel% main-panel))
|
|
(make-object message% (format (string-constant x-like-keywords) string) vert)
|
|
(define box (make-object list-box% #f keywords vert void '(multiple)))
|
|
(define button-panel (make-object horizontal-panel% vert))
|
|
(define text (new text-field%
|
|
(label (string-constant indenting-prefs-extra-regexp))
|
|
(callback (λ (tf evt)
|
|
(define str (send tf get-value))
|
|
(cond
|
|
[(equal? str "")
|
|
(bang-regexp #f)]
|
|
[else
|
|
(with-handlers ([exn:fail?
|
|
(λ (x)
|
|
(color-yellow (send tf get-editor)))])
|
|
(bang-regexp (regexp str))
|
|
(clear-color (send tf get-editor)))])))
|
|
(parent vert)))
|
|
(define add-button (make-object button% (string-constant add-keyword)
|
|
button-panel (add-button-callback string symbol box)))
|
|
(define delete-button (make-object button% (string-constant remove-keyword)
|
|
button-panel (delete-callback box)))
|
|
(send* button-panel
|
|
(set-alignment 'center 'center)
|
|
(stretchable-height #f))
|
|
(send add-button min-width (send delete-button get-width))
|
|
(values box text))
|
|
(define (color-yellow text)
|
|
(let ([sd (make-object style-delta%)])
|
|
(send sd set-delta-background "yellow")
|
|
(send text change-style sd 0 (send text last-position))))
|
|
(define (clear-color text)
|
|
(let ([sd (make-object style-delta%)])
|
|
(send sd set-delta-background "white")
|
|
(send text change-style sd 0 (send text last-position))))
|
|
(define (update-pref sel x)
|
|
(let ([pref (preferences:get 'framework:tabify)])
|
|
(let ([pref
|
|
(let loop ([pref pref][sel sel])
|
|
(if (zero? sel)
|
|
(cons x (cdr pref))
|
|
(cons (car pref) (loop (cdr pref) (sub1 sel)))))])
|
|
(preferences:set 'framework:tabify pref))))
|
|
(define-values (begin-list-box begin-regexp-text)
|
|
(make-column "Begin"
|
|
'begin
|
|
begin-keywords
|
|
(λ (x) (update-pref 1 x))))
|
|
(define-values (define-list-box define-regexp-text)
|
|
(make-column "Define"
|
|
'define
|
|
define-keywords
|
|
(λ (x) (update-pref 2 x))))
|
|
(define-values (lambda-list-box lambda-regexp-text)
|
|
(make-column "Lambda"
|
|
'lambda
|
|
lambda-keywords
|
|
(λ (x) (update-pref 3 x))))
|
|
(define-values (for/fold-list-box for/fold-regexp-text)
|
|
(make-column "For/fold"
|
|
'for/fold
|
|
for/fold-keywords
|
|
(λ (x) (update-pref 4 x))))
|
|
(define (update-list-boxes hash-table)
|
|
(define-values (begin-keywords define-keywords lambda-keywords for/fold-keywords)
|
|
(get-keywords hash-table))
|
|
(define (reset list-box keywords)
|
|
(send list-box clear)
|
|
(for-each (λ (x) (send list-box append x)) keywords))
|
|
(reset begin-list-box begin-keywords)
|
|
(reset define-list-box define-keywords)
|
|
(reset lambda-list-box lambda-keywords)
|
|
(reset for/fold-list-box for/fold-keywords)
|
|
#t)
|
|
(define update-gui
|
|
(λ (pref)
|
|
(update-list-boxes (car pref))
|
|
(send begin-regexp-text set-value (or (object-name (list-ref pref 1)) ""))
|
|
(send define-regexp-text set-value (or (object-name (list-ref pref 2)) ""))
|
|
(send lambda-regexp-text set-value (or (object-name (list-ref pref 3)) ""))
|
|
(send for/fold-regexp-text set-value (or (object-name (list-ref pref 4)) ""))))
|
|
(preferences:add-callback 'framework:tabify (λ (p v) (update-gui v)))
|
|
(update-gui (preferences:get 'framework:tabify))
|
|
main-panel)
|