1291 lines
58 KiB
Scheme
1291 lines
58 KiB
Scheme
;; originally by Dan Grossman
|
|
;; 6/30/95
|
|
|
|
(module scheme mzscheme
|
|
(require "collapsed-snipclass-helpers.ss"
|
|
(lib "string-constant.ss" "string-constants")
|
|
(lib "unitsig.ss")
|
|
(lib "class.ss")
|
|
"sig.ss"
|
|
(lib "mred-sig.ss" "mred")
|
|
(lib "mred.ss" "mred")
|
|
(lib "list.ss")
|
|
(lib "thread.ss")
|
|
(lib "etc.ss")
|
|
(lib "surrogate.ss")
|
|
(lib "scheme-lexer.ss" "syntax-color"))
|
|
|
|
(provide scheme@)
|
|
|
|
(define (scheme-paren:get-paren-pairs)
|
|
'(("(" . ")")
|
|
("[" . "]")
|
|
("{" . "}")))
|
|
|
|
|
|
(define scheme@
|
|
(unit/sig framework:scheme^
|
|
(import mred^
|
|
[preferences : framework:preferences^]
|
|
[icon : framework:icon^]
|
|
[keymap : framework:keymap^]
|
|
[text : framework:text^]
|
|
[editor : framework:editor^]
|
|
[frame : framework:frame^]
|
|
[comment-box : framework:comment-box^]
|
|
[mode : framework:mode^]
|
|
[color : framework:color^]
|
|
[color-prefs : framework:color-prefs^])
|
|
|
|
(rename [-text-mode<%> text-mode<%>]
|
|
[-text<%> text<%>]
|
|
[-text% text%])
|
|
|
|
(define text-balanced?
|
|
(opt-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 loop ()
|
|
(let ([s (read port)])
|
|
(or (eof-object? s)
|
|
(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-object
|
|
#f
|
|
(read (open-input-text-editor text))
|
|
(list file line col pos 1))))
|
|
|
|
(define/override get-text
|
|
(opt-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 (is-a? text -text<%>)
|
|
(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 (car snips) 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 (get-color-prefs-table) color-prefs-table)
|
|
|
|
(define (short-sym->pref-name sym) (string->symbol (short-sym->style-name sym)))
|
|
(define sn-hash (make-hash-table))
|
|
(define (short-sym->style-name sym)
|
|
(hash-table-get sn-hash sym
|
|
(λ ()
|
|
(let ([s (format "framework:syntax-coloring:scheme:~a" sym)])
|
|
(hash-table-put! sn-hash sym s)
|
|
s))))
|
|
|
|
(define (add-coloring-preferences-panel)
|
|
(color-prefs:add-to-preferences-panel
|
|
"Scheme"
|
|
(λ (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)
|
|
(format "~a" sym))))
|
|
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))
|
|
|
|
(define init-wordbreak-map
|
|
(λ (map)
|
|
(let ([v (send map get-map #\-)])
|
|
(send map set-map
|
|
#\-
|
|
'(line)))))
|
|
(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<%>)
|
|
(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)
|
|
|
|
(public get-limit balance-parens tabify-on-return? tabify tabify-selection
|
|
tabify-all insert-return calc-last-para
|
|
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)
|
|
(define (get-limit pos) 0)
|
|
|
|
(define (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
|
|
(opt-lambda ([pos (get-start-position)])
|
|
(let* ([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))))]
|
|
[okay (and is-tabbable? (> para 0))]
|
|
[end (if okay (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 okay
|
|
(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
|
|
(backward-match end limit)
|
|
#f)]
|
|
[last-para (and last
|
|
(position-paragraph last))])
|
|
(letrec
|
|
([find-offset
|
|
(λ (pos)
|
|
(let loop ([p pos][o 0])
|
|
(let ([c (get-character p)])
|
|
(cond
|
|
[(char=? c #\tab)
|
|
(loop (add1 p) (+ o (- 8 (modulo o 8))))]
|
|
[(char=? c #\newline)
|
|
(cons o p)]
|
|
[(char-whitespace? c)
|
|
(loop (add1 p) (add1 o))]
|
|
[else
|
|
(cons o p)]))))]
|
|
[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 (car curr-offset))
|
|
(delete pos-start (cdr curr-offset))
|
|
(insert
|
|
(make-string amt #\space)
|
|
pos-start))))]
|
|
[get-proc
|
|
(λ ()
|
|
(let ([id-end (forward-match contains (last-position))])
|
|
(if (and id-end (> id-end contains))
|
|
(let* ([text (get-text contains id-end)])
|
|
(or (get-keyword-type text)
|
|
'other)))))]
|
|
[procedure-indent
|
|
(λ ()
|
|
(case (get-proc)
|
|
[(define) 1]
|
|
[(begin) 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 okay
|
|
(not (char=? (get-character (sub1 end))
|
|
#\newline)))
|
|
(insert #\newline (paragraph-start-position para)))
|
|
(cond
|
|
[(not is-tabbable?) (void)]
|
|
[(let ([real-start (cdr (find-offset end))])
|
|
(and (<= (+ 3 real-start) (last-position))
|
|
(string=? ";;;"
|
|
(get-text real-start
|
|
(+ 2 real-start)))))
|
|
(void)]
|
|
[(= para 0) (do-indent 0)]
|
|
[(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
|
|
(let ([name-length (let ([id-end (forward-match contains (last-position))])
|
|
(if id-end
|
|
(- id-end contains)
|
|
0))])
|
|
(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)))))])))))
|
|
|
|
(define tabify-selection
|
|
(opt-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
|
|
(opt-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])
|
|
(if (<= 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
|
|
(opt-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
|
|
(opt-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 get-forward-sexp
|
|
(λ (start-pos)
|
|
(forward-match start-pos (last-position)))]
|
|
[define remove-sexp
|
|
(λ (start-pos)
|
|
(let ([end-pos (get-forward-sexp start-pos)])
|
|
(if end-pos
|
|
(kill 0 start-pos end-pos)
|
|
(bell)))
|
|
#t)]
|
|
[define 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 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)]
|
|
[ans
|
|
(if (and end-pos
|
|
(or (not min-pos)
|
|
(>= end-pos min-pos)))
|
|
end-pos
|
|
#f)])
|
|
ans))]
|
|
[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 ([last (last-position)])
|
|
(let loop ([pos start-pos])
|
|
(let ([next-pos (forward-match pos last)])
|
|
(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 (if paren?
|
|
(forward-match pos (last-position)))])
|
|
(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
|
|
transpose-sexp mark-matching-parenthesis)
|
|
|
|
[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))]
|
|
|
|
(inherit get-fixed-style)
|
|
(define (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)])))))))
|
|
|
|
[define 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 ([text-1
|
|
(get-text start-1 end-1)]
|
|
[text-2
|
|
(get-text start-2 end-2)])
|
|
(begin-edit-sequence)
|
|
(insert text-1 start-2 end-2)
|
|
(insert text-2 start-1 end-1)
|
|
(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))]
|
|
|
|
(super-instantiate ())))
|
|
|
|
(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)
|
|
(send (send text get-keymap) chain-to-keymap keymap #t)
|
|
|
|
;; 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))
|
|
|
|
(super-new (get-token scheme-lexer-wrapper)
|
|
(token-sym->style short-sym->style-name)
|
|
(matches '((|(| |)|)
|
|
(|[| |]|)
|
|
(|{| |}|))))))
|
|
|
|
(define (scheme-lexer-wrapper in)
|
|
(let-values (((lexeme type paren start end) (scheme-lexer in)))
|
|
(cond
|
|
((and (eq? type 'symbol)
|
|
(get-keyword-type lexeme))
|
|
(values lexeme 'keyword paren start end))
|
|
(else
|
|
(values lexeme type paren start end)))))
|
|
|
|
;; get-keyword-type : string -> (union #f 'lambda 'define 'begin)
|
|
(define (get-keyword-type text)
|
|
(let* ([pref (preferences:get 'framework:tabify)]
|
|
[ht (car pref)]
|
|
[beg-reg (cadr pref)]
|
|
[def-reg (caddr pref)]
|
|
[lam-reg (cadddr pref)])
|
|
(hash-table-get
|
|
ht
|
|
(string->symbol 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
|
|
(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))))
|
|
|
|
(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))))
|
|
|
|
(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")
|
|
|
|
(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-meta "s:right" "select-forward-sexp")
|
|
(map "a:s:right" "select-forward-sexp")
|
|
|
|
(map-meta "left" "backward-sexp")
|
|
(map "a:left" "backward-sexp")
|
|
(map-meta "s:left" "select-backward-sexp")
|
|
(map "a: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")))
|
|
|
|
(define keymap (make-object keymap:aug-keymap%))
|
|
(setup-keymap keymap)
|
|
(define (get-keymap) keymap)
|
|
|
|
|
|
;;; ;;;
|
|
; ;
|
|
; ;
|
|
; ;;; ; ;;; ;;; ;;;;; ;;; ; ;;; ;;;; ; ;;; ;;; ;
|
|
; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ;
|
|
; ; ; ;;;;; ; ;;; ; ; ;;;; ; ; ;;;;; ;
|
|
; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
|
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
|
;;;; ;;;; ;;; ;;;; ;;; ;;;; ;;; ;;;; ;; ;;; ;;;;;;
|
|
; ;
|
|
; ;
|
|
;;; ;;;
|
|
|
|
|
|
(define (add-preferences-panel)
|
|
(preferences:add-panel
|
|
(list (string-constant editor-prefs-panel-label)
|
|
(string-constant indenting-prefs-panel-label))
|
|
(λ (p)
|
|
(define get-keywords
|
|
(λ (hash-table)
|
|
(letrec ([all-keywords (hash-table-map hash-table list)]
|
|
[pick-out (λ (wanted in out)
|
|
(cond
|
|
[(null? in) (quicksort out string<=?)]
|
|
[else (if (eq? wanted (cadr (car in)))
|
|
(pick-out wanted (cdr in) (cons (symbol->string (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-table-get (car (preferences:get 'framework:tabify))
|
|
parsed
|
|
(λ () #f)))
|
|
(message-box (string-constant error)
|
|
(format (string-constant already-used-keyword) parsed))]
|
|
[(symbol? parsed)
|
|
(let ([ht (car (preferences:get 'framework:tabify))])
|
|
(hash-table-put! ht parsed keyword-symbol)
|
|
(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) (string->symbol (send list-box get-string x))) selections)])
|
|
(for-each (λ (x) (send list-box delete x)) (reverse selections))
|
|
(let ([ht (car (preferences:get 'framework:tabify))])
|
|
(for-each (λ (x) (hash-table-remove! ht x)) symbols))))))
|
|
(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-values (begin-list-box begin-regexp-text)
|
|
(make-column "Begin"
|
|
'begin
|
|
begin-keywords
|
|
(λ (x) (set-car! (cdr (preferences:get 'framework:tabify)) x))))
|
|
(define-values (define-list-box define-regexp-text)
|
|
(make-column "Define"
|
|
'define
|
|
define-keywords
|
|
(λ (x) (set-car! (cddr (preferences:get 'framework:tabify)) x))))
|
|
(define-values (lambda-list-box lambda-regexp-text)
|
|
(make-column "Lambda"
|
|
'lambda
|
|
lambda-keywords
|
|
(λ (x) (set-car! (cdddr (preferences:get 'framework:tabify)) 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)))
|
|
main-panel))))))
|