1866 lines
78 KiB
Racket
1866 lines
78 KiB
Racket
#lang scheme/unit
|
|
|
|
;; originally by Dan Grossman
|
|
;; 6/30/95
|
|
|
|
(require string-constants
|
|
scheme/class
|
|
mred/mred-sig
|
|
syntax-color/module-lexer
|
|
"collapsed-snipclass-helpers.ss"
|
|
"sig.ss"
|
|
"../gui-utils.ss"
|
|
"../preferences.ss"
|
|
scheme/match)
|
|
|
|
(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:scheme^
|
|
[-text-mode<%> text-mode<%>]
|
|
[-text<%> text<%>]
|
|
[-text% text%]))
|
|
|
|
(init-depend mred^ framework:keymap^ framework:color^ framework:mode^
|
|
framework:text^ framework:editor^)
|
|
|
|
(define (scheme-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-instantiate ())
|
|
(inherit set-snipclass)
|
|
(set-snipclass lib-snip-class)))
|
|
|
|
(define sexp-snipclass% (make-sexp-snipclass% sexp-snip%))
|
|
|
|
;; old snips (from old versions of drscheme) 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-frozen?))
|
|
(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)])
|
|
(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))
|
|
(constant ,constant-green ,(string-constant scheme-mode-color-constant))
|
|
(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))
|
|
(constant ,(make-object color% 60 194 57))
|
|
(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)
|
|
(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))
|
|
|
|
(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<%>) (-text<%>)
|
|
(inherit begin-edit-sequence
|
|
delete
|
|
end-edit-sequence
|
|
local-edit-sequence?
|
|
find-string
|
|
get-character
|
|
get-keymap
|
|
get-text
|
|
get-start-position
|
|
get-style-list
|
|
get-end-position
|
|
flash-on
|
|
insert
|
|
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/override (get-word-at current-pos)
|
|
(let ([no-word ""])
|
|
(cond
|
|
[(or (is-stopped?) (is-frozen?))
|
|
no-word]
|
|
[else
|
|
(let ([type (classify-position (max 0 (- current-pos 1)))])
|
|
(cond
|
|
[(eq? 'symbol type)
|
|
(get-text (look-for-non-symbol (max 0 (- current-pos 1)))
|
|
current-pos)]
|
|
[else no-word]))])))
|
|
|
|
(define/private (look-for-non-symbol start)
|
|
(let loop ([i start])
|
|
(cond
|
|
[(< i 0)
|
|
0]
|
|
[(eq? (classify-position i) 'symbol)
|
|
(loop (- i 1))]
|
|
[else
|
|
(+ i 1)])))
|
|
|
|
(public tabify-on-return? tabify
|
|
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)
|
|
(insert-close-paren (get-start-position)
|
|
(send key-event get-key-code)
|
|
(preferences:get 'framework:paren-match)
|
|
(preferences:get 'framework:fixup-parens)))
|
|
|
|
(define (tabify-on-return?) #t)
|
|
(define tabify
|
|
(lambda ([pos (get-start-position)])
|
|
(let* ([tabify-prefs (preferences:get 'framework:tabify)]
|
|
[last-pos (last-position)]
|
|
[para (position-paragraph pos)]
|
|
[is-tabbable? (and (> para 0)
|
|
(not (memq (classify-position (sub1 (paragraph-start-position para)))
|
|
'(comment string error))))]
|
|
[end (if is-tabbable? (paragraph-start-position para) 0)]
|
|
[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
|
|
[contains
|
|
(if is-tabbable?
|
|
(backward-containing-sexp end limit)
|
|
#f)]
|
|
[contain-para (and contains
|
|
(position-paragraph contains))]
|
|
;; "last" is the start of the S-exp just before "pos"
|
|
[last
|
|
(if contains
|
|
(let ([p (get-backward-sexp end)])
|
|
(if (and p (p . >= . limit))
|
|
p
|
|
(backward-match end limit)))
|
|
#f)]
|
|
[last-para (and last
|
|
(position-paragraph last))])
|
|
(letrec
|
|
([find-offset
|
|
(λ (start-pos)
|
|
(let ([end-pos
|
|
(let loop ([p start-pos])
|
|
(let ([c (get-character p)])
|
|
(cond
|
|
[(char=? c #\tab)
|
|
(loop (add1 p))]
|
|
[(char=? c #\newline)
|
|
p]
|
|
[(char-whitespace? c)
|
|
(loop (add1 p))]
|
|
[else
|
|
p])))]
|
|
[start-x (box 0)]
|
|
[end-x (box 0)])
|
|
(position-location start-pos start-x #f #t #t)
|
|
(position-location end-pos end-x #f #t #t)
|
|
(let-values ([(w _1 _2 _3) (send (get-dc) get-text-extent "x"
|
|
(send (send (get-style-list)
|
|
find-named-style "Standard")
|
|
get-font))])
|
|
(cons (inexact->exact (floor (/ (- (unbox end-x) (unbox start-x)) w)))
|
|
end-pos))))]
|
|
|
|
[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)))])))))]
|
|
[do-indent
|
|
(λ (amt)
|
|
(let* ([pos-start end]
|
|
[curr-offset (find-offset pos-start)])
|
|
(unless (= amt (- (cdr curr-offset) pos-start))
|
|
(delete pos-start (cdr curr-offset))
|
|
(insert (make-string amt #\space)
|
|
pos-start))))]
|
|
[get-proc
|
|
(λ ()
|
|
(let ([id-end (get-forward-sexp contains)])
|
|
(and (and id-end (> id-end contains))
|
|
(let* ([text (get-text contains id-end)])
|
|
(or (get-keyword-type text tabify-prefs)
|
|
'other)))))]
|
|
[procedure-indent
|
|
(λ ()
|
|
(case (get-proc)
|
|
[(begin define) 1]
|
|
[(lambda) 3]
|
|
[else 0]))]
|
|
[special-check
|
|
(λ ()
|
|
(let* ([proc-name (get-proc)])
|
|
(or (eq? proc-name 'define)
|
|
(eq? proc-name 'lambda))))]
|
|
[indent-first-arg (λ (start) (car (find-offset start)))])
|
|
(when (and is-tabbable?
|
|
(not (char=? (get-character (sub1 end))
|
|
#\newline)))
|
|
(insert #\newline (paragraph-start-position para)))
|
|
(cond
|
|
[(not is-tabbable?)
|
|
(when (= para 0)
|
|
(do-indent 0))]
|
|
[(let ([real-start (cdr (find-offset end))])
|
|
(and (<= (+ 3 real-start) (last-position))
|
|
(string=? ";;;"
|
|
(get-text real-start
|
|
(+ 2 real-start)))))
|
|
(void)]
|
|
[(not contains)
|
|
;; Something went wrong matching. Should we get here?
|
|
(do-indent 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
|
|
(let ([enclosing (find-up-sexp pos)])
|
|
(do-indent (if enclosing
|
|
(+ (visual-offset enclosing) 1)
|
|
0)))]
|
|
[(= contains last)
|
|
;; There's only one S-expr in the S-expr
|
|
;; containing "pos"
|
|
(do-indent (+ (visual-offset contains)
|
|
(procedure-indent)))]
|
|
[(special-check)
|
|
;; In case of "define", etc., ignore the position of last
|
|
;; and just indent under the "define"
|
|
(do-indent (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
|
|
(let ([name-length (let ([id-end (get-forward-sexp contains)])
|
|
(if id-end
|
|
(- id-end contains)
|
|
0))])
|
|
(cond
|
|
[(second-sexp-is-ellipsis? contains)
|
|
(do-indent (visual-offset contains))]
|
|
[(not (find-up-sexp pos))
|
|
(do-indent (visual-offset contains))]
|
|
[else
|
|
(do-indent (+ (visual-offset contains)
|
|
name-length
|
|
(indent-first-arg (+ contains
|
|
name-length))))]))]
|
|
[else
|
|
;; No particular special case, so indent to match first
|
|
;; S-expr that start on the previous line
|
|
(let loop ([last last][last-para last-para])
|
|
(let* ([next-to-last (backward-match last limit)]
|
|
[next-to-last-para (and next-to-last
|
|
(position-paragraph next-to-last))])
|
|
(if (equal? last-para next-to-last-para)
|
|
(loop next-to-last next-to-last-para)
|
|
(do-indent (visual-offset last)))))])))))
|
|
|
|
;; returns #t if `contains' is at a position on a line with an sexp, an ellipsis and nothing else.
|
|
;; 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
|
|
(lambda ([start-pos (get-start-position)]
|
|
[end-pos (get-end-position)])
|
|
(let ([first-para (position-paragraph start-pos)]
|
|
[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)
|
|
(if (tabify-on-return?)
|
|
(begin
|
|
(begin-edit-sequence)
|
|
(insert #\newline)
|
|
(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))
|
|
(insert #\newline)))
|
|
|
|
(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)))
|
|
|
|
(define/private (stick-to-next-sexp? start-pos)
|
|
(let ([end-pos (forward-match start-pos (last-position))])
|
|
(and end-pos
|
|
(member (get-text start-pos end-pos)
|
|
'("'" "," ",@" "`"
|
|
"#'" "#," "#`" "#,@"
|
|
"#&" "#;"
|
|
"#hash" "#hasheq"
|
|
"#ci" "#cs")))))
|
|
|
|
(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 (scheme-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 #\[ ))]
|
|
[closer (and paren?
|
|
(get-forward-sexp pos))])
|
|
(if (and paren? closer)
|
|
(begin (begin-edit-sequence)
|
|
(delete pos (add1 pos))
|
|
(delete (- closer 2) (- closer 1))
|
|
(end-edit-sequence))
|
|
(bell))
|
|
#t))]
|
|
|
|
(define/private (select-text f forward?)
|
|
(let* ([start-pos (get-start-position)]
|
|
[end-pos (get-end-position)])
|
|
(let-values ([(new-start new-end)
|
|
(if forward?
|
|
(values start-pos (f end-pos))
|
|
(values (f start-pos) end-pos))])
|
|
(if (and new-start new-end)
|
|
(set-position new-start new-end)
|
|
(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)
|
|
(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)
|
|
(let ([begin-outer (find-up-sexp begin-inner)])
|
|
(cond
|
|
[begin-outer
|
|
(let ([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)
|
|
(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 (scheme-paren:get-paren-pairs))]
|
|
[close-parens (map cdr (scheme-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))]
|
|
|
|
(inherit is-frozen? is-stopped?)
|
|
(define/public (rewrite-square-paren)
|
|
(cond
|
|
[(or (not (preferences:get 'framework:fixup-open-parens))
|
|
(is-frozen?)
|
|
(is-stopped?))
|
|
(insert #\[
|
|
(get-start-position)
|
|
(get-end-position))]
|
|
[else
|
|
(insert-paren this)]))
|
|
|
|
(super-new)))
|
|
|
|
(define -text-mode<%>
|
|
(interface ()
|
|
))
|
|
|
|
(define text-mode-mixin
|
|
(mixin (color:text-mode<%> mode:surrogate-text<%>) (-text-mode<%>)
|
|
|
|
(define/override (on-disable-surrogate text)
|
|
(keymap:remove-chained-keymap text keymap)
|
|
(super on-disable-surrogate text))
|
|
|
|
(define/override (on-enable-surrogate text)
|
|
(send text begin-edit-sequence)
|
|
(super on-enable-surrogate text)
|
|
(let ([km (send text get-keymap)])
|
|
(when km
|
|
(send km chain-to-keymap keymap #f)))
|
|
|
|
;; I don't know about these editor flag settings.
|
|
;; maybe they belong in drscheme?
|
|
(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 (scheme-lexer-wrapper in offset mode)
|
|
(let-values (((lexeme type paren start end backup-delta mode) (module-lexer in offset mode)))
|
|
(cond
|
|
((and (eq? type 'symbol)
|
|
(get-keyword-type lexeme tabify-pref))
|
|
(values lexeme 'keyword paren start end backup-delta mode))
|
|
(else
|
|
(values lexeme type paren start end backup-delta mode)))))
|
|
|
|
(define/override (put-file text sup directory default-name)
|
|
(parameterize ([finder:default-extension "rkt"]
|
|
[finder:default-filters '(["Racket Sources" "*.rkt;*.ss;*.scm"]
|
|
["Any" "*.*"])])
|
|
;; don't call the surrogate's super, since it sets the default extension
|
|
(sup directory default-name)))
|
|
|
|
(super-new (get-token (lambda (in offset mode) (scheme-lexer-wrapper in offset mode)))
|
|
(token-sym->style short-sym->style-name)
|
|
(matches '((|(| |)|)
|
|
(|[| |]|)
|
|
(|{| |}|))))))
|
|
|
|
;; get-keyword-type : string (list ht regexp regexp regexp)
|
|
;; -> (union #f 'lambda 'define 'begin)
|
|
(define (get-keyword-type text pref)
|
|
(let* ([ht (car pref)]
|
|
[beg-reg (cadr pref)]
|
|
[def-reg (caddr pref)]
|
|
[lam-reg (cadddr pref)])
|
|
(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]
|
|
[else #f])))))
|
|
|
|
(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)
|
|
(let ([add-pos-function
|
|
(λ (name call-method)
|
|
(send keymap add-function name
|
|
(λ (edit event)
|
|
(call-method
|
|
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)))
|
|
|
|
(let ([add-edit-function
|
|
(λ (name call-method)
|
|
(send keymap add-function name
|
|
(λ (edit event)
|
|
(call-method edit))))])
|
|
(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)))
|
|
(add-edit-function "rewrite-square-paren"
|
|
(λ (x) (send x rewrite-square-paren)))
|
|
|
|
(let ([add/map-non-clever
|
|
(λ (name keystroke char)
|
|
(add-edit-function
|
|
name
|
|
(λ (e) (send e insert char (send e get-start-position) (send e get-end-position))))
|
|
(send keymap map-function keystroke name))])
|
|
(add/map-non-clever "non-clever-open-square-bracket" "c:[" #\[)
|
|
(add/map-non-clever "non-clever-close-square-bracket" "c:]" #\])
|
|
(add/map-non-clever "non-clever-close-curley-bracket" "c:}" #\})
|
|
(add/map-non-clever "non-clever-close-round-paren" "c:)" #\))))
|
|
|
|
(send keymap add-function "balance-parens"
|
|
(λ (edit event)
|
|
(send edit balance-parens event)))
|
|
|
|
(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 "[" "rewrite-square-paren")
|
|
|
|
(let ([map-meta
|
|
(λ (key func)
|
|
(keymap:send-map-function-meta keymap key func))]
|
|
[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
|
|
)
|
|
(send keymap map-function "c:c;c:b" "remove-parens-forward")
|
|
(send keymap map-function "c:c;c:l" "introduce-let-ans")
|
|
(send keymap map-function "c:c;c:o" "move-sexp-out")
|
|
(send keymap map-function "c:c;c:e" "kill-enclosing-parens")
|
|
(send keymap map-function "c:c;c:[" "toggle-round-square-parens")))
|
|
|
|
(define keymap (make-object keymap:aug-keymap%))
|
|
(setup-keymap keymap)
|
|
(define (get-keymap) keymap)
|
|
|
|
;; choose-paren : scheme-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)])
|
|
(send text begin-edit-sequence #f #f)
|
|
(send text insert "[" start-pos 'same #f)
|
|
(when (eq? (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
|
|
(let* ([before-whitespace-pos2 (send text skip-whitespace backward-match 'backward #t)]
|
|
[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.
|
|
(let ([b-w-p-char (send text get-character (- before-whitespace-pos 1))])
|
|
(cond
|
|
[(equal? b-w-p-char #\()
|
|
(let* ([second-before-whitespace-pos (send text skip-whitespace
|
|
(- before-whitespace-pos 1)
|
|
'backward
|
|
#t)]
|
|
[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
|
|
(let* ([second-before-whitespace-pos2 (send text skip-whitespace
|
|
second-backwards-match
|
|
'backward
|
|
#t)]
|
|
[second-backwards-match2 (send text backward-match
|
|
second-before-whitespace-pos2
|
|
0)])
|
|
(cond
|
|
[(and second-backwards-match2
|
|
(eq? (send text classify-position second-backwards-match)
|
|
;;; otherwise, this isn't a `let loop', it is a regular let!
|
|
'symbol)
|
|
(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)
|
|
(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
|
|
(+ 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)
|
|
|
|
(define stupid-internal-definition-syntax1
|
|
(mk-list-box 'framework:square-bracket:letrec "Letrec" values (get-new-simple-keyword "Letrec")))
|
|
(define stupid-internal-definition-syntax3
|
|
(mk-list-box 'framework:square-bracket:local
|
|
"Local"
|
|
values
|
|
(get-new-simple-keyword "Local")))
|
|
(define stupid-internal-definition-syntax2
|
|
(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)
|
|
(letrec ([all-keywords (hash-map hash-table list)]
|
|
[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)))))
|
|
(define-values (begin-keywords define-keywords lambda-keywords)
|
|
(get-keywords (car (preferences:get 'framework:tabify))))
|
|
(define add-button-callback
|
|
(λ (keyword-type keyword-symbol list-box)
|
|
(λ (button command)
|
|
(let ([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)
|
|
(let* ([selections (send list-box get-selections)]
|
|
[symbols (map (λ (x) (read (open-input-string (send list-box get-string x)))) selections)])
|
|
(for-each (λ (x) (send list-box delete x)) (reverse selections))
|
|
(let* ([pref (preferences:get 'framework:tabify)]
|
|
[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)
|
|
(let* ([vert (make-object vertical-panel% main-panel)]
|
|
[_ (make-object message% (format (string-constant x-like-keywords) string) vert)]
|
|
[box (make-object list-box% #f keywords vert void '(multiple))]
|
|
[button-panel (make-object horizontal-panel% vert)]
|
|
[text (new text-field%
|
|
(label (string-constant indenting-prefs-extra-regexp))
|
|
(callback (λ (tf evt)
|
|
(let ([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))]
|
|
[add-button (make-object button% (string-constant add-keyword)
|
|
button-panel (add-button-callback string symbol box))]
|
|
[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 (update-list-boxes hash-table)
|
|
(let-values ([(begin-keywords define-keywords lambda-keywords) (get-keywords hash-table)]
|
|
[(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)
|
|
#t))
|
|
(define update-gui
|
|
(λ (pref)
|
|
(update-list-boxes (car pref))
|
|
(send begin-regexp-text set-value (or (object-name (cadr pref)) ""))
|
|
(send define-regexp-text set-value (or (object-name (caddr pref)) ""))
|
|
(send lambda-regexp-text set-value (or (object-name (cadddr pref)) ""))))
|
|
(preferences:add-callback 'framework:tabify (λ (p v) (update-gui v)))
|
|
(update-gui (preferences:get 'framework:tabify))
|
|
main-panel)
|