diff --git a/collects/embedded-gui/private/tests/test-case-box.rkt b/collects/embedded-gui/private/tests/test-case-box.rkt index 4b966bec..d97f855c 100644 --- a/collects/embedded-gui/private/tests/test-case-box.rkt +++ b/collects/embedded-gui/private/tests/test-case-box.rkt @@ -161,7 +161,7 @@ ;; a locked text hightlighted to show that it is inactive (define actual-text% (class (grey-editor-mixin - (text:hide-caret/selection-mixin scheme:text%)) + (text:hide-caret/selection-mixin racket:text%)) (inherit hide-caret lock) (super-new) (hide-caret true) diff --git a/collects/framework/framework-unit.rkt b/collects/framework/framework-unit.rkt index d4eead12..c7580da4 100644 --- a/collects/framework/framework-unit.rkt +++ b/collects/framework/framework-unit.rkt @@ -1,4 +1,4 @@ -#lang scheme/base +#lang racket/base (require racket/unit mred/mred-sig) @@ -27,7 +27,7 @@ "private/canvas.rkt" "private/panel.rkt" "private/frame.rkt" - "private/scheme.rkt" + "private/racket.rkt" "private/main.rkt" "private/mode.rkt" "private/early-init.rkt") @@ -60,14 +60,14 @@ framework:panel^ framework:frame^ framework:handler^ - framework:scheme^ + framework:racket^ framework:main^) (link preferences@ early-init@ application@ version@ color-model@ mode@ exit@ menu@ number-snip@ autosave@ path-utils@ icon@ keymap@ editor@ pasteboard@ text@ color@ color-prefs@ comment-box@ - finder@ group@ canvas@ panel@ frame@ handler@ scheme@ main@)) + finder@ group@ canvas@ panel@ frame@ handler@ racket@ main@)) (define-unit/new-import-export framework@ (import mred^) (export framework^) (((prefix application: framework:application^) @@ -94,6 +94,6 @@ (prefix panel: framework:panel^) (prefix frame: framework:frame^) (prefix handler: framework:handler^) - (prefix scheme: framework:scheme^) + (prefix racket: framework:racket^) (prefix main: framework:main^)) framework-separate@ mred^)) diff --git a/collects/framework/main.rkt b/collects/framework/main.rkt index e015ef3f..1f5501d9 100644 --- a/collects/framework/main.rkt +++ b/collects/framework/main.rkt @@ -8,7 +8,8 @@ framework/framework-unit framework/private/sig (for-syntax scheme/base) - scribble/srcdoc) + scribble/srcdoc + (for-syntax "private/scheme.rkt")) ;; these next two lines do a little dance to make the ;; require/doc setup work out properly @@ -54,7 +55,7 @@ (prefix panel: framework:panel-class^) (prefix frame: framework:frame-class^) (prefix handler: framework:handler-class^) - (prefix scheme: framework:scheme-class^) + (prefix racket: framework:racket-class^) (prefix main: framework:main-class^)) (define-values/invoke-unit/infer @@ -1376,7 +1377,7 @@ cover the eol ambiguity)}]}) (proc-doc/names - scheme:text-balanced? + racket:text-balanced? (->* ((is-a?/c text%)) (number? (or/c false/c number?)) boolean?) @@ -1395,78 +1396,78 @@ range of the buffer.}) (proc-doc/names - scheme:add-preferences-panel + racket:add-preferences-panel (-> void?) () @{Adds a tabbing preferences panel to the preferences dialog.}) (proc-doc/names - scheme:get-keymap + racket:get-keymap (-> (is-a?/c keymap%)) () @{Returns a keymap with binding suitable for Racket.}) (proc-doc/names - scheme:add-coloring-preferences-panel + racket:add-coloring-preferences-panel (-> any) () @{Installs the ``Racket'' preferences panel in the ``Syntax Coloring'' section.}) (proc-doc/names - scheme:get-color-prefs-table + racket:get-color-prefs-table (-> (listof (list/c symbol? (is-a?/c color%)))) () @{Returns a table mapping from symbols (naming the categories that the online colorer uses for Racket mode coloring) to their colors. These symbols are suitable for input to - @racket[scheme:short-sym->pref-name] and - @racket[scheme:short-sym->style-name]. + @racket[racket:short-sym->pref-name] and + @racket[racket:short-sym->style-name]. - See also @racket[scheme:get-white-on-black-color-prefs-table].}) + See also @racket[racket:get-white-on-black-color-prefs-table].}) (proc-doc/names - scheme:get-white-on-black-color-prefs-table + racket:get-white-on-black-color-prefs-table (-> (listof (list/c symbol? (is-a?/c color%)))) () @{Returns a table mapping from symbols (naming the categories that the online colorer uses for Racket mode coloring) to their colors when the user chooses the white-on-black mode in the preferences dialog. - See also @racket[scheme:get-color-prefs-table].}) + See also @racket[racket:get-color-prefs-table].}) (proc-doc/names - scheme:short-sym->pref-name + racket:short-sym->pref-name (symbol? . -> . symbol?) (short-sym) @{Builds the symbol naming the preference from one of the symbols in the - table returned by @racket[scheme:get-color-prefs-table].}) + table returned by @racket[racket:get-color-prefs-table].}) (proc-doc/names - scheme:short-sym->style-name + racket:short-sym->style-name (symbol? . -> . string?) (short-sym) @{Builds the symbol naming the editor style from one of the symbols in the - table returned by @racket[scheme:get-color-prefs-table]. This style is a + table returned by @racket[racket:get-color-prefs-table]. This style is a named style in the style list returned by @racket[editor:get-standard-style-list].}) (proc-doc/names - scheme:get-wordbreak-map + racket:get-wordbreak-map (-> (is-a?/c editor-wordbreak-map%)) () @{This method returns a @racket[editor-wordbreak-map%] that is suitable for Racket.}) (proc-doc/names - scheme:init-wordbreak-map + racket:init-wordbreak-map ((is-a?/c keymap%) . -> . void?) (key) @{Initializes the workdbreak map for @racket[keymap].}) (proc-doc/names - scheme:setup-keymap + racket:setup-keymap ((is-a?/c keymap%) . -> . void?) (keymap) @{Initializes @racket[keymap] with Racket-mode keybindings.}) @@ -1716,3 +1717,11 @@ () @{Sets the colors registered by @racket[color-prefs:register-color-preference] to their black-on-white variety.})) + +(define-syntax (racket:-reprovides stx) + #`(provide + (rename-out #,@(for/list ([suffix (in-list racket:ids)]) + (define rkt (string->symbol (format "racket:~a" suffix))) + (define scm (string->symbol (format "scheme:~a" suffix))) + #`[#,rkt #,scm])))) +(racket:-reprovides) diff --git a/collects/framework/private/autosave.rkt b/collects/framework/private/autosave.rkt index e5145483..04e91a9f 100644 --- a/collects/framework/private/autosave.rkt +++ b/collects/framework/private/autosave.rkt @@ -11,7 +11,7 @@ (import mred^ [prefix exit: framework:exit^] [prefix frame: framework:frame^] - [prefix scheme: framework:scheme^] + [prefix racket: framework:racket^] [prefix editor: framework:editor^] [prefix text: framework:text^] [prefix finder: framework:finder^] diff --git a/collects/framework/private/color-prefs.rkt b/collects/framework/private/color-prefs.rkt index aaac0602..502642a8 100644 --- a/collects/framework/private/color-prefs.rkt +++ b/collects/framework/private/color-prefs.rkt @@ -9,7 +9,7 @@ [prefix editor: framework:editor^] [prefix panel: framework:panel^] [prefix canvas: framework:canvas^] - [prefix scheme: framework:scheme^] + [prefix racket: framework:racket^] [prefix color: framework:color^]) (export framework:color-prefs^) (init-depend framework:editor^) diff --git a/collects/framework/private/color.rkt b/collects/framework/private/color.rkt index cc5da6a1..b64be91b 100644 --- a/collects/framework/private/color.rkt +++ b/collects/framework/private/color.rkt @@ -20,7 +20,7 @@ added get-regions [prefix mode: framework:mode^] [prefix text: framework:text^] [prefix color-prefs: framework:color-prefs^] - [prefix scheme: framework:scheme^]) + [prefix racket: framework:racket^]) (export (rename framework:color^ (-text<%> text<%>) diff --git a/collects/framework/private/comment-box.rkt b/collects/framework/private/comment-box.rkt index c4778455..23cc6d3f 100644 --- a/collects/framework/private/comment-box.rkt +++ b/collects/framework/private/comment-box.rkt @@ -15,7 +15,7 @@ (define-unit comment-box@ (import [prefix text: framework:text^] - [prefix scheme: framework:scheme^] + [prefix racket: framework:racket^] [prefix keymap: framework:keymap^]) (export (rename framework:comment-box^ (-snip% snip%))) @@ -36,7 +36,7 @@ (define (get-scheme+copy-self%) (unless scheme+copy-self% (set! scheme+copy-self% - (class scheme:text% + (class racket:text% (inherit copy-self-to) (define/override (copy-self) (let ([ed (new scheme+copy-self%)]) diff --git a/collects/framework/private/frame.rkt b/collects/framework/private/frame.rkt index 6767e678..6a8d9ded 100644 --- a/collects/framework/private/frame.rkt +++ b/collects/framework/private/frame.rkt @@ -28,7 +28,7 @@ [prefix editor: framework:editor^] [prefix canvas: framework:canvas^] [prefix menu: framework:menu^] - [prefix scheme: framework:scheme^] + [prefix racket: framework:racket^] [prefix exit: framework:exit^] [prefix comment-box: framework:comment-box^]) diff --git a/collects/framework/private/main.rkt b/collects/framework/private/main.rkt index 0b85867a..24113760 100644 --- a/collects/framework/private/main.rkt +++ b/collects/framework/private/main.rkt @@ -11,11 +11,11 @@ [prefix handler: framework:handler^] [prefix editor: framework:editor^] [prefix color-prefs: framework:color-prefs^] - [prefix scheme: framework:scheme^] + [prefix racket: framework:racket^] [prefix early-init: framework:early-init^]) (export framework:main^) (init-depend framework:preferences^ framework:exit^ framework:editor^ - framework:color-prefs^ framework:scheme^ framework:early-init^) + framework:color-prefs^ framework:racket^ framework:early-init^) (preferences:low-level-get-preference preferences:get-preference/gui) (preferences:low-level-put-preferences preferences:put-preferences/gui) @@ -344,12 +344,12 @@ [color (cadr line)] [white-on-black-color (cadr white-on-black-line)]) (color-prefs:register-color-preference - (scheme:short-sym->pref-name sym) - (scheme:short-sym->style-name sym) + (racket:short-sym->pref-name sym) + (racket:short-sym->style-name sym) color white-on-black-color))) - (scheme:get-color-prefs-table) - (scheme:get-white-on-black-color-prefs-table)) + (racket:get-color-prefs-table) + (racket:get-white-on-black-color-prefs-table)) (preferences:set-default 'framework:coloring-active #t boolean?) (color-prefs:set-default/color-scheme 'framework:default-text-color "black" "white") diff --git a/collects/framework/private/racket.rkt b/collects/framework/private/racket.rkt new file mode 100644 index 00000000..92456ca3 --- /dev/null +++ b/collects/framework/private/racket.rkt @@ -0,0 +1,2011 @@ +#lang racket/unit + +;; originally by Dan Grossman +;; 6/30/95 + +(require string-constants + racket/class + mred/mred-sig + syntax-color/module-lexer + "collapsed-snipclass-helpers.rkt" + "sig.rkt" + "../gui-utils.rkt" + "../preferences.rkt" + racket/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:racket^ + [-text-mode<%> text-mode<%>] + [-text<%> text<%>] + [-text% text%])) + +(init-depend mred^ framework:keymap^ framework:color^ framework:mode^ + framework:text^ framework:editor^) + +(define-local-member-name + stick-to-next-sexp? + get-private-racket-container-keymap) + +(define (racket-paren:get-paren-pairs) + '(("(" . ")") + ("[" . "]") + ("{" . "}"))) + +(define text-balanced? + (lambda (text [start 0] [in-end #f]) + (let* ([end (or in-end (send text last-position))] + [port (open-input-text-editor text start end)]) + (with-handlers ([exn:fail:read:eof? (λ (x) #f)] + [exn:fail:read? (λ (x) #t)]) + (let ([first (read port)]) + (cond + [(eof-object? first) #f] + [else + (let loop () + (let ([s (read port)]) + (cond + [(eof-object? s) #t] + [else (loop)])))])))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ;; +;; Sexp Snip ;; +;; ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (set-box/f! b v) (when (box? b) (set-box! b v))) + +(define sexp-snip<%> + (interface () + get-saved-snips)) + +(define sexp-snip% + (class* snip% (sexp-snip<%> readable-snip<%>) + (init-field left-bracket right-bracket saved-snips) + (define/public (get-saved-snips) saved-snips) + (field [sizing-text (format "~a ~a" left-bracket right-bracket)]) + + (define/public (read-special file line col pos) + (let ([text (make-object text:basic%)]) + (for-each + (λ (s) (send text insert (send s copy) + (send text last-position) + (send text last-position))) + saved-snips) + (datum->syntax + #f + (read (open-input-text-editor text)) + (list file line col pos 1)))) + + (define/override get-text + (lambda (offset num [flattened? #f]) + (if flattened? + (apply string-append + (map (λ (snip) + (send snip get-text 0 (send snip get-count) flattened?)) + saved-snips)) + (super get-text offset num flattened?)))) + + (define/override (copy) + (instantiate sexp-snip% () + (left-bracket left-bracket) + (right-bracket right-bracket) + (saved-snips saved-snips))) + + (define/override (write stream-out) + (send stream-out put (bytes (char->integer left-bracket))) + (send stream-out put (bytes (char->integer right-bracket))) + (send stream-out put (length saved-snips)) + (let loop ([snips saved-snips]) + (cond + [(null? snips) (void)] + [else + (let* ([snip (car snips)] + [snipclass (send snip get-snipclass)]) + (send stream-out put (string->bytes/utf-8 (send snipclass get-classname))) + (send snip write stream-out)) + (loop (cdr snips))]))) + + (define/override (draw dc x y left top right bottom dx dy draw-caret) + (send dc draw-text sizing-text x y) + (let-values ([(lpw lph lpa lpd) (send dc get-text-extent (string left-bracket))] + [(rpw rph rpa rpd) (send dc get-text-extent (string right-bracket))] + [(sw sh sa sd) (send dc get-text-extent sizing-text)]) + (let* ([dtw (- sw lpw rpw)] + [dot-start (+ x lpw)] + [dt1x (+ dot-start (* dtw 1/5))] + [dt2x (+ dot-start (* dtw 1/2))] + [dt3x (+ dot-start (* dtw 4/5))] + [dty (+ y (/ sh 2))]) + (send dc draw-rectangle dt1x dty 2 2) + (send dc draw-rectangle dt2x dty 2 2) + (send dc draw-rectangle dt3x dty 2 2)))) + + (inherit get-style) + (define/override (get-extent dc x y wb hb descentb spaceb lspaceb rspaceb) + (let-values ([(w h d a) (send dc get-text-extent sizing-text (send (get-style) get-font))]) + (set-box/f! wb w) + (set-box/f! hb h) + (set-box/f! descentb d) + (set-box/f! spaceb a) + (set-box/f! lspaceb 0) + (set-box/f! rspaceb 0))) + (super-instantiate ()) + (inherit set-snipclass) + (set-snipclass lib-snip-class))) + +(define sexp-snipclass% (make-sexp-snipclass% sexp-snip%)) + +;; old snips (from old versions of drracket) use this snipclass +(define lib-snip-class (make-object sexp-snipclass%)) +(send lib-snip-class set-classname (format "~s" '((lib "collapsed-snipclass.ss" "framework") + (lib "collapsed-snipclass-wxme.ss" "framework")))) +(send lib-snip-class set-version 0) +(send (get-the-snip-class-list) add lib-snip-class) + +;; new snips use this snipclass +(define old-snip-class (make-object sexp-snipclass%)) +(send old-snip-class set-classname "drscheme:sexp-snip") +(send old-snip-class set-version 0) +(send (get-the-snip-class-list) add old-snip-class) + +(keymap:add-to-right-button-menu + (let ([old (keymap:add-to-right-button-menu)]) + (λ (menu text event) + (old menu text event) + (split/collapse-text menu text event) + (void)))) + +;; split/collapse-text : (instanceof menu%) (instanceof editor<%>) (instanceof mouse-event%) -> void +(define (split/collapse-text menu text event) + (when (and (is-a? text -text<%>) + (not (send text is-stopped?))) + (let* ([on-it-box (box #f)] + [click-pos + (call-with-values + (λ () + (send text dc-location-to-editor-location + (send event get-x) + (send event get-y))) + (λ (x y) + (send text find-position x y #f on-it-box)))] + [snip (send text find-snip click-pos 'after)] + [char (send text get-character click-pos)] + [left? (memq char '(#\( #\{ #\[))] + [right? (memq char '(#\) #\} #\]))]) + (cond + [(and snip (is-a? snip sexp-snip<%>)) + (make-expand-item text snip menu)] + [(not (unbox on-it-box)) + ;; clicking in nowhere land, just ignore + (void)] + [(or left? right?) + ;; clicking on left or right paren + (let* ([pos (if left? + click-pos + (+ click-pos 1))] + [other-pos (if left? + (send text get-forward-sexp pos) + (send text get-backward-sexp pos))]) + (when other-pos + (let ([left-pos (min pos other-pos)] + [right-pos (max pos other-pos)]) + (make-collapse-item text left-pos right-pos menu))))] + [else + ;; clicking on some other text -> collapse containing sexp + (let ([up-sexp (send text find-up-sexp click-pos)]) + (when up-sexp + (let ([fwd (send text get-forward-sexp up-sexp)]) + (when fwd + (make-collapse-item text up-sexp fwd menu)))))])))) + +;; make-expand-item : (instanceof text%) (instanceof sexp-snip<%>) (instanceof menu%) -> void +(define (make-expand-item text snip menu) + (instantiate separator-menu-item% () + (parent menu)) + (instantiate menu-item% () + (parent menu) + (label (string-constant expand-sexp)) + (callback (λ (item evt) (expand-from text snip))))) + +;; expand-from : (instanceof text%) (instanceof sexp-snip<%>) -> void +(define (expand-from text snip) + (let ([snips (send snip get-saved-snips)]) + (send text begin-edit-sequence) + (let ([pos (send text get-snip-position snip)]) + (send text delete pos (+ pos 1)) + (let loop ([snips (reverse snips)]) + (cond + [(null? snips) (void)] + [else (send text insert (send (car snips) copy) pos pos) + (loop (cdr snips))]))) + (send text end-edit-sequence))) + +;; make-collapse-item : (instanceof text%) number number (instanceof menu%) -> void +;; adds a collapse menu item to the menu +(define (make-collapse-item text left-pos right-pos menu) + (instantiate separator-menu-item% () + (parent menu)) + (instantiate menu-item% () + (parent menu) + (label (string-constant collapse-sexp)) + (callback (λ (item evt) + (collapse-from text left-pos right-pos))))) + +(define (collapse-from text left-pos right-pos) + (let ([left-bracket (send text get-character left-pos)] + [right-bracket (send text get-character (- right-pos 1))]) + (send text begin-edit-sequence) + (send text split-snip left-pos) + (send text split-snip right-pos) + (let ([snips (let loop ([snip (send text find-snip left-pos 'after)]) + (cond + [(not snip) null] + [((send text get-snip-position snip) . >= . right-pos) + null] + [else (cons (send snip copy) (loop (send snip next)))]))]) + (send text delete left-pos right-pos) + (send text insert (instantiate sexp-snip% () + (left-bracket left-bracket) + (right-bracket right-bracket) + (saved-snips snips)) + left-pos left-pos) + (send text end-edit-sequence)))) + + +; +; +; +; ; ;;;; +; ;; ;;;; +; ;;;; ;;;;; ;;;; ;;; ;;; ;;; ;;; +; ;;;;;; ;;;;;; ;;;;;;;;; ;;;;; ;;;;;;; +; ;;;;;;;; ;;;; ;;;; ;;;; ;;;; ;; ;;;; ;; +; ;;;; ;;; ;;;; ;;;; ;;;; ;;;;;;; ;;;; +; ;;;;;;;; ;;;;; ;;;; ;;;; ;;;;; ;;;; +; ;;;;;; ;;;;; ;;;; ;;;; ;;;;;; ;;;; +; ;;;; ;;;; ;;;; ;;;; ;;;; ;;;; +; +; +; + + +(define color-prefs-table + (let ([constant-green (make-object color% 41 128 38)] + [symbol-blue (make-object color% 38 38 128)]) + `((symbol ,symbol-blue ,(string-constant scheme-mode-color-symbol)) + (keyword ,symbol-blue ,(string-constant scheme-mode-color-keyword)) + (comment ,(make-object color% 194 116 31) ,(string-constant scheme-mode-color-comment)) + (string ,constant-green ,(string-constant scheme-mode-color-string)) + (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<%> editor:keymap<%>) (-text<%>) + (inherit begin-edit-sequence + delete + end-edit-sequence + local-edit-sequence? + find-string + extend-position + get-character + get-extend-end-position + get-extend-start-position + get-keymap + get-text + get-start-position + get-style-list + get-end-position + flash-on + insert + is-stopped? + kill + last-position + paragraph-start-position + paragraph-end-position + position-paragraph + set-keymap + set-load-overwrites-styles + set-position + set-wordbreak-map + set-tabs + set-style-list + set-styles-fixed + change-style + get-snip-position + backward-match + backward-containing-sexp + forward-match + skip-whitespace + insert-close-paren + classify-position) + + (inherit get-styles-fixed) + (inherit has-focus? find-snip split-snip + position-location get-dc) + + (define private-racket-container-keymap (new keymap:aug-keymap%)) + (define/public (get-private-racket-container-keymap) private-racket-container-keymap) + + (define/override (get-keymaps) + (editor:add-after-user-keymap private-racket-container-keymap + (super get-keymaps))) + + (define/override (get-word-at current-pos) + (let ([no-word ""]) + (cond + [(is-stopped?) + no-word] + [else + (let ([type (classify-position (max 0 (- current-pos 1)))]) + (cond + [(memq type '(symbol keyword)) + (get-text (look-for-non-symbol/non-kwd (max 0 (- current-pos 1))) + current-pos)] + [else no-word]))]))) + + (define/private (look-for-non-symbol/non-kwd start) + (let loop ([i start]) + (cond + [(< i 0) + 0] + [(memq (classify-position i) '(symbol keyword)) + (loop (- i 1))] + [else + (+ i 1)]))) + + (public tabify-all insert-return calc-last-para + box-comment-out-selection comment-out-selection uncomment-selection + flash-forward-sexp + flash-backward-sexp backward-sexp find-up-sexp up-sexp find-down-sexp down-sexp + remove-parens-forward) + + (define/public (get-limit pos) 0) + + (define/public (balance-parens key-event) + (insert-close-paren (get-start-position) + (send key-event get-key-code) + (preferences:get 'framework:paren-match) + (preferences:get 'framework:fixup-parens))) + + (define/public (tabify-on-return?) #t) + (define/public (tabify [pos (get-start-position)]) + (unless (is-stopped?) + (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) + (define tab-char? #f) + (define end-pos + (let loop ([p start-pos]) + (let ([c (get-character p)]) + (cond + [(char=? c #\tab) + (set! tab-char? #t) + (loop (add1 p))] + [(char=? c #\newline) + p] + [(char-whitespace? c) + (loop (add1 p))] + [else + p])))) + (define start-x (box 0)) + (define end-x (box 0)) + (position-location start-pos start-x #f #t #t) + (position-location end-pos end-x #f #t #t) + (define-values (w _1 _2 _3) + (send (get-dc) get-text-extent "x" + (send (send (get-style-list) + find-named-style "Standard") + get-font))) + (values (inexact->exact (floor (/ (- (unbox end-x) (unbox start-x)) w))) + end-pos + tab-char?))] + + [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) + (define pos-start end) + (define-values (gwidth curr-offset tab-char?) (find-offset pos-start)) + (unless (and (not tab-char?) (= amt (- curr-offset pos-start))) + (delete pos-start 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))))] + [curley-brace-sexp? + (λ () + (define up-p (find-up-sexp pos)) + (and up-p + (equal? #\{ (get-character up-p))))] + + [indent-first-arg (λ (start) + (define-values (gwidth curr-offset tab-char?) (find-offset start)) + gwidth)]) + (when (and is-tabbable? + (not (char=? (get-character (sub1 end)) + #\newline))) + (insert #\newline (paragraph-start-position para))) + (cond + [(not is-tabbable?) + (when (= para 0) + (do-indent 0))] + [(let-values ([(gwidth real-start tab-char?) (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)] + #; ;; disable this to accommodate PLAI programs; return to this when a #lang capability is set up. + [(curley-brace-sexp?) + ;; when we are directly inside an sexp that uses {}s, + ;; we indent in a more C-like fashion (to help Scribble) + (define first-curley (find-up-sexp pos)) + (define containing-curleys + (let loop ([pos first-curley]) + (let ([next (find-up-sexp pos)]) + (if (and next + (equal? (get-character next) #\{)) + (+ (loop next) 1) + 1)))) + (define close-first-curley (get-forward-sexp first-curley)) + (define para (position-paragraph pos)) + (when (and close-first-curley + (<= (paragraph-start-position para) close-first-curley (paragraph-end-position para))) + (set! containing-curleys (max 0 (- containing-curleys 1)))) + (do-indent (* containing-curleys 2))] + [(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)]) + (if enclosing + (do-indent (+ (visual-offset enclosing) 1)) + (do-indent 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 [start-pos (get-start-position)] + [end-pos (get-end-position)]) + (unless (is-stopped?) + (define first-para (position-paragraph start-pos)) + (define end-para (position-paragraph end-pos)) + (with-handlers ([exn:break? + (λ (x) #t)]) + (dynamic-wind + (λ () + (when (< first-para end-para) + (begin-busy-cursor)) + (begin-edit-sequence)) + (λ () + (let loop ([para first-para]) + (when (<= para end-para) + (tabify (paragraph-start-position para)) + (parameterize-break #t (void)) + (loop (add1 para)))) + (when (and (>= (position-paragraph start-pos) end-para) + (<= (skip-whitespace (get-start-position) 'backward #f) + (paragraph-start-position first-para))) + (set-position + (let loop ([new-pos (get-start-position)]) + (if (let ([next (get-character new-pos)]) + (and (char-whitespace? next) + (not (char=? next #\newline)))) + (loop (add1 new-pos)) + new-pos))))) + (λ () + (end-edit-sequence) + (when (< first-para end-para) + (end-busy-cursor))))))) + + (define (tabify-all) (tabify-selection 0 (last-position))) + (define (insert-return) + (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/public (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 (racket-paren:get-paren-pairs)]) + (cond + [(null? parens) null] + [else + (let ([pos (paren-pos (car parens))]) + (if pos + (cons pos (loop (cdr parens))) + (loop (cdr parens))))]))]) + (if (null? poss) ;; all finds failed + #f + (- (apply max poss) 1)))) ;; subtract one to move outside the paren + #f)))] + [define up-sexp + (λ (start-pos) + (let ([exp-pos (find-up-sexp start-pos)]) + (if exp-pos + (set-position exp-pos) + (bell)) + #t))] + [define find-down-sexp + (λ (start-pos) + (let loop ([pos start-pos]) + (let ([next-pos (get-forward-sexp pos)]) + (if (and next-pos (> next-pos pos)) + (let ([back-pos + (backward-containing-sexp (sub1 next-pos) pos)]) + (if (and back-pos + (> back-pos pos)) + back-pos + (loop next-pos))) + #f))))] + [define down-sexp + (λ (start-pos) + (let ([pos (find-down-sexp start-pos)]) + (if pos + (set-position pos) + (bell)) + #t))] + [define remove-parens-forward + (λ (start-pos) + (let* ([pos (skip-whitespace start-pos 'forward #f)] + [first-char (get-character pos)] + [paren? (or (char=? first-char #\( ) + (char=? first-char #\[ ))] + [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?) + (define start-pos (get-start-position)) + (define end-pos (get-end-position)) + (define new-pos + (if forward? + (if (= (get-extend-start-position) start-pos) + (f end-pos) + (f start-pos)) + (if (= (get-extend-end-position) end-pos) + (f start-pos) + (f end-pos)))) + (if new-pos + (extend-position new-pos) + (bell)) + #t) + (public select-forward-sexp select-backward-sexp select-up-sexp select-down-sexp) + [define select-forward-sexp (λ () (select-text (λ (x) (get-forward-sexp x)) #t))] + [define select-backward-sexp (λ () (select-text (λ (x) (get-backward-sexp x)) #f))] + [define select-up-sexp (λ () (select-text (λ (x) (find-up-sexp x)) #f))] + [define select-down-sexp (λ () (select-text (λ (x) (find-down-sexp x)) #t))] + + (define/public (introduce-let-ans pos) + (dynamic-wind + (λ () (begin-edit-sequence)) + (λ () + (let ([before-text "(let ([ans "] + [after-text "])\n"] + [after-text2 "(printf \"~s\\n\" ans)\nans)"] + [end-l (get-forward-sexp pos)]) + (cond + [end-l + (insert after-text2 end-l end-l) + (insert after-text end-l end-l) + (insert before-text pos pos) + (let ([blank-line-pos (+ end-l (string-length after-text) (string-length before-text))]) + (set-position blank-line-pos blank-line-pos)) + (tabify-selection + pos + (+ end-l + (string-length before-text) + (string-length after-text) + (string-length after-text2)))] + [else + (bell)]))) + (λ () + (end-edit-sequence)))) + + (define/public (move-sexp-out begin-inner) + (begin-edit-sequence) + (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 (racket-paren:get-paren-pairs))] + [close-parens (map cdr (racket-paren:get-paren-pairs))]) + (when (member (string (get-character pos)) open-parens) + (let ([end (get-forward-sexp pos)]) + (when (and end + (member (string (get-character (- end 1))) close-parens)) + (let ([start-style (send (find-snip pos 'after) get-style)] + [end-style (send (find-snip end 'before) get-style)]) + (cond + [(and (eq? matching-parenthesis-style start-style) + (eq? matching-parenthesis-style end-style)) + (let ([fixed-style (get-fixed-style)]) + (change-style fixed-style pos (+ pos 1)) + (change-style fixed-style (- end 1) end))] + [else + (change-style matching-parenthesis-style pos (+ pos 1)) + (change-style matching-parenthesis-style (- end 1) end)]))))))) + + ;; get-snips/rev: start end -> (listof snip) + ;; Returns a list of the snips in reverse order between + ;; start and end. + (define/private (get-snips/rev start end) + (split-snip start) + (split-snip end) + (let loop ([snips/rev '()] + [a-snip (find-snip start 'after-or-none)]) + (cond + [(or (not a-snip) + (>= (get-snip-position a-snip) + end)) + snips/rev] + [else + (loop (cons (send a-snip copy) snips/rev) + (send a-snip next))]))) + + (define/public (transpose-sexp pos) + (let ([start-1 (get-backward-sexp pos)]) + (if (not start-1) + (bell) + (let ([end-1 (get-forward-sexp start-1)]) + (if (not end-1) + (bell) + (let ([end-2 (get-forward-sexp end-1)]) + (if (not end-2) + (bell) + (let ([start-2 (get-backward-sexp end-2)]) + (if (or (not start-2) + (< start-2 end-1)) + (bell) + (let ([snips-1/rev (get-snips/rev start-1 end-1)] + [snips-2/rev (get-snips/rev start-2 end-2)]) + (begin-edit-sequence) + (delete start-2 end-2) + (for-each (λ (s) (insert s start-2)) snips-1/rev) + (delete start-1 end-1) + (for-each (λ (s) (insert s start-1)) snips-2/rev) + (set-position end-2) + (end-edit-sequence))))))))))) + [define tab-size 8] + (public get-tab-size set-tab-size) + [define get-tab-size (λ () tab-size)] + [define set-tab-size (λ (s) (set! tab-size s))] + + (define/override (get-start-of-line pos) + (define para (position-paragraph pos)) + (define para-start (paragraph-start-position para)) + (define para-end (paragraph-end-position para)) + (define first-non-whitespace + (let loop ([i para-start]) + (cond + [(= i para-end) #f] + [(char-whitespace? (get-character i)) + (loop (+ i 1))] + [else i]))) + (define new-pos + (cond + [(not first-non-whitespace) para-start] + [(= pos para-start) first-non-whitespace] + [(<= pos first-non-whitespace) para-start] + [else first-non-whitespace])) + new-pos) + + (super-new))) + +(define -text-mode<%> + (interface () + )) + +(define 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-private-racket-container-keymap) chain-to-keymap keymap #f) + + ;; I don't know about these editor flag settings. + ;; maybe they belong in drracket? + (send text set-load-overwrites-styles #f) + (send text set-wordbreak-map wordbreak-map) + (let ([bw (box 0)] + [bu (box #f)] + [tab-size (send text get-tab-size)]) + (unless (and (null? (send text get-tabs #f bw bu)) + (= tab-size (unbox bw)) + (not (unbox bu))) + (send text set-tabs null (send text get-tab-size) #f))) + (send text set-styles-fixed #t) + (send text end-edit-sequence)) + + (define tabify-pref (preferences:get 'framework:tabify)) + (preferences:add-callback + 'framework:tabify + (lambda (k v) (set! tabify-pref v))) + (define/private (racket-lexer-wrapper in offset mode) + (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"] + #; ; no need for the following, since it's the default + [finder:default-filters '(["Racket Sources" "*.rkt;*.scrbl;*.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) (racket-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) + (define (add-edit-function name f) + (send keymap add-function name (λ (edit event) (f edit)))) + (define (add-pos-function name f) + (send keymap add-function name + (λ (edit event) + (f edit (send edit get-start-position))))) + (add-pos-function "remove-sexp" (λ (e p) (send e remove-sexp p))) + (add-pos-function "forward-sexp" (λ (e p) (send e forward-sexp p))) + (add-pos-function "backward-sexp" (λ (e p) (send e backward-sexp p))) + (add-pos-function "up-sexp" (λ (e p) (send e up-sexp p))) + (add-pos-function "down-sexp" (λ (e p) (send e down-sexp p))) + (add-pos-function "flash-backward-sexp" (λ (e p) (send e flash-backward-sexp p))) + (add-pos-function "flash-forward-sexp" (λ (e p) (send e flash-forward-sexp p))) + (add-pos-function "remove-parens-forward" (λ (e p) (send e remove-parens-forward p))) + (add-pos-function "transpose-sexp" (λ (e p) (send e transpose-sexp p))) + (add-pos-function "mark-matching-parenthesis" + (λ (e p) (send e mark-matching-parenthesis p))) + (add-pos-function "introduce-let-ans" + (λ (e p) (send e introduce-let-ans p))) + (add-pos-function "move-sexp-out" + (λ (e p) (send e move-sexp-out p))) + (add-pos-function "kill-enclosing-parens" + (lambda (e p) (send e kill-enclosing-parens p))) + (add-pos-function "toggle-round-square-parens" + (lambda (e p) (send e toggle-round-square-parens p))) + + (add-edit-function "select-forward-sexp" + (λ (x) (send x select-forward-sexp))) + (add-edit-function "select-backward-sexp" + (λ (x) (send x select-backward-sexp))) + (add-edit-function "select-down-sexp" + (λ (x) (send x select-down-sexp))) + (add-edit-function "select-up-sexp" + (λ (x) (send x select-up-sexp))) + (add-edit-function "tabify-at-caret" + (λ (x) (send x tabify-selection))) + (add-edit-function "do-return" + (λ (x) (send x insert-return))) + (add-edit-function "comment-out" + (λ (x) (send x comment-out-selection))) + (add-edit-function "box-comment-out" + (λ (x) (send x box-comment-out-selection))) + (add-edit-function "uncomment" + (λ (x) (send x uncomment-selection))) + + (send keymap add-function "paren-double-select" + (λ (text event) + (keymap:region-click + text event + (λ (click-pos eol?) + (define str1 (string (send text get-character click-pos))) + (define sexp-based-start/end + (cond + [(ormap (λ (pr) (equal? (cdr pr) str1)) + (racket-paren:get-paren-pairs)) + (define start (send text get-backward-sexp (+ click-pos 1))) + (and start + (cons start (+ click-pos 1)))] + [else + (let ([end (send text get-forward-sexp click-pos)]) + (and end + (let ([beginning (send text get-backward-sexp end)]) + (and beginning + (cons beginning end)))))])) + (cond + [sexp-based-start/end + (send text set-position + (car sexp-based-start/end) + (cdr sexp-based-start/end))] + [else + (define start-box (box click-pos)) + (define end-box (box click-pos)) + (send text find-wordbreak start-box end-box 'selection) + (send text set-position (unbox start-box) (unbox end-box))]))))) + + + (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 "leftbuttondouble" "paren-double-select") + + (define (insert-brace-pair text open-brace close-brace) + (define selection-start (send text get-start-position)) + (send text set-position (send text get-end-position)) + (send text insert close-brace) + (send text set-position selection-start) + (send text insert open-brace)) + + (define (maybe-insert-brace-pair text open-brace close-brace) + (cond + [(preferences:get 'framework:automatic-parens) + (insert-brace-pair text open-brace close-brace)] + [else + (send text insert open-brace)])) + + (add-edit-function "insert-()-pair" (λ (text) (insert-brace-pair text #\( #\)))) + (add-edit-function "insert-[]-pair" (λ (text) (insert-brace-pair text #\[ #\]))) + (add-edit-function "insert-{}-pair" (λ (text) (insert-brace-pair text #\{ #\}))) + (add-edit-function "insert-\"\"-pair" (λ (text) (insert-brace-pair text #\" #\"))) + (add-edit-function "insert-||-pair" (λ (text) (insert-brace-pair text #\| #\|))) + + (add-edit-function "maybe-insert-()-pair" (λ (text) (maybe-insert-brace-pair text #\( #\)))) + (add-edit-function "maybe-insert-[]-pair" (λ (text) (maybe-insert-brace-pair text #\[ #\]))) + (add-edit-function "maybe-insert-{}-pair" (λ (text) (maybe-insert-brace-pair text #\{ #\}))) + (add-edit-function "maybe-insert-\"\"-pair" (λ (text) (maybe-insert-brace-pair text #\" #\"))) + (add-edit-function "maybe-insert-||-pair" (λ (text) (maybe-insert-brace-pair text #\| #\|))) + + (add-edit-function "maybe-insert-[]-pair-maybe-fixup-[]" + (λ (text) + (cond + [(or (not (preferences:get 'framework:fixup-open-parens)) + (send text is-stopped?)) + (maybe-insert-brace-pair text #\[ #\])] + [else + (insert-paren text)]))) + + (define (insert-lambda-template edit) + (send edit begin-edit-sequence) + (let ([selection-start (send edit get-start-position)]) + (send edit set-position (send edit get-end-position)) + (send edit insert ")") + (send edit set-position selection-start) + (send edit insert ") ") + (send edit set-position selection-start) + (send edit insert "(λ (")) + (send edit end-edit-sequence)) + + (add-edit-function "insert-lambda-template" insert-lambda-template) + + (define (map-meta key func) (keymap:send-map-function-meta keymap key func)) + (define (map key func) (send keymap map-function key func)) + + (map-meta "up" "up-sexp") + (map-meta "c:u" "up-sexp") + (map "a:up" "up-sexp") + (map-meta "s:up" "select-up-sexp") + (map "a:s:up" "select-up-sexp") + (map-meta "s:c:u" "select-up-sexp") + + (map-meta "down" "down-sexp") + (map "a:down" "down-sexp") + (map-meta "s:down" "select-down-sexp") + (map "a:s:down" "select-down-sexp") + (map-meta "s:c:down" "select-down-sexp") + + (map-meta "right" "forward-sexp") + (map "a:right" "forward-sexp") + (map "m:right" "forward-sexp") + (map-meta "s:right" "select-forward-sexp") + (map "a:s:right" "select-forward-sexp") + (map "m:s:right" "select-forward-sexp") + + (map-meta "left" "backward-sexp") + (map "a:left" "backward-sexp") + (map "m:left" "backward-sexp") + (map-meta "s:left" "select-backward-sexp") + (map "a:s:left" "select-backward-sexp") + (map "m:s:left" "select-backward-sexp") + + (map-meta "return" "do-return") + (map-meta "s:return" "do-return") + (map-meta "s:c:return" "do-return") + (map-meta "a:return" "do-return") + (map-meta "s:a:return" "do-return") + (map-meta "c:a:return" "do-return") + (map-meta "c:s:a:return" "do-return") + (map-meta "c:return" "do-return") + + (map-meta "c:semicolon" "comment-out") + (map-meta "c:=" "uncomment") + (map-meta "c:k" "remove-sexp") + + (map-meta "c:f" "forward-sexp") + (map-meta "s:c:f" "select-forward-sexp") + + (map-meta "c:b" "backward-sexp") + (map-meta "s:c:b" "select-backward-sexp") + + (map-meta "c:p" "flash-backward-sexp") + (map-meta "s:c:n" "flash-forward-sexp") + + (map-meta "c:space" "select-forward-sexp") + (map-meta "c:t" "transpose-sexp") + + ;(map-meta "c:m" "mark-matching-parenthesis") + ; this keybinding doesn't interact with the paren colorer + + (map-meta "(" "insert-()-pair") + (map-meta "[" "insert-[]-pair") + (map-meta "{" "insert-{}-pair") + (map-meta "\"" "insert-\"\"-pair") + (map-meta "|" "insert-||-pair") + + (map "(" "maybe-insert-()-pair") + (map "[" "maybe-insert-[]-pair-maybe-fixup-[]") + (map "{" "maybe-insert-{}-pair") + (map "\"" "maybe-insert-\"\"-pair") + (map "|" "maybe-insert-||-pair") + + (map-meta "s:l" "insert-lambda-template") + + (map "c:c;c:b" "remove-parens-forward") + (map "c:c;c:l" "introduce-let-ans") + (map "c:c;c:o" "move-sexp-out") + (map "c:c;c:e" "kill-enclosing-parens") + (map "c:c;c:[" "toggle-round-square-parens")) + +(define keymap (make-object keymap:aug-keymap%)) +(setup-keymap keymap) +(define (get-keymap) keymap) + +;; choose-paren : racket-text number -> character +;; returns the character to replace a #\[ with, based +;; on the context where it is typed in. +(define (insert-paren text) + (let* ([pos (send text get-start-position)] + [real-char #\[] + [change-to (λ (i c) + ;(printf "change-to, case ~a\n" i) + (set! real-char c))] + [start-pos (send text get-start-position)] + [end-pos (send text get-end-position)] + [letrec-like-forms (preferences:get 'framework:square-bracket:letrec)]) + (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 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) + (cond + [(preferences:get 'framework:automatic-parens) + (send text insert (case real-char + [(#\() #\)] + [(#\[) #\]] + [(#\{) #\}]) + end-pos end-pos) + (send text insert real-char start-pos start-pos) + (send text set-position (+ start-pos 1))] + [else + (send text insert real-char start-pos end-pos)]))) + +;; find-keyword-and-distance : -> (union #f (cons string number)) +(define (find-keyword-and-distance before-whitespace-pos text) + ;; searches backwards for the keyword in the sequence at this level. + ;; if found, it counts how many sexps back it was + (let loop ([pos before-whitespace-pos] + [n 0]) + (let ([backward-match (send text backward-match pos 0)]) + (cond + [backward-match + (let ([before-whitespace-pos (send text skip-whitespace backward-match 'backward #t)]) + (loop before-whitespace-pos + (if (send text stick-to-next-sexp? backward-match) + n + (+ n 1))))] + [else + (let* ([afterwards (send text get-forward-sexp pos)] + [keyword + (and afterwards + (send text get-text pos afterwards))]) + (and keyword + (list keyword (- n 1))))])))) + +;; beginning-of-sequence? : text number -> boolean +;; determines if this position is at the beginning of a sequence +;; that begins with a parenthesis. +(define (beginning-of-sequence? text start) + (let ([before-space (send text skip-whitespace start 'backward #t)]) + (cond + [(zero? before-space) #t] + [else + (equal? (send text get-character (- before-space 1)) + #\()]))) + +(define (text-between-equal? str text start end) + (and (= (string-length str) (- end start)) + (let loop ([i (string-length str)]) + (cond + [(= i 0) #t] + [else + (and (char=? (string-ref str (- i 1)) + (send text get-character (+ i start -1))) + (loop (- i 1)))])))) + + +; ;;; ;;; +; ; ; +; ; ; +; ;;; ; ;;; ;;; ;;;;; ;;; ; ;;; ;;;; ; ;;; ;;; ; +;; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; +;; ; ; ;;;;; ; ;;; ; ; ;;;; ; ; ;;;;; ; +;; ; ; ; ; ; ; ; ; ; ; ; ; ; +;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; +;;;;; ;;;; ;;; ;;;; ;;; ;;;; ;;; ;;;; ;; ;;; ;;;;;; +;; ; +;; ; +;;;; ;;; + + +(define (add-preferences-panel) + (preferences:add-panel + (list (string-constant editor-prefs-panel-label) + (string-constant indenting-prefs-panel-label)) + make-indenting-prefs-panel) + (preferences:add-panel + (list (string-constant editor-prefs-panel-label) + (string-constant square-bracket-prefs-panel-label)) + make-square-bracket-prefs-panel)) + +(define (make-square-bracket-prefs-panel p) + (define main-panel (make-object vertical-panel% p)) + (define boxes-panel (new horizontal-panel% [parent main-panel])) + + (define (mk-list-box sym keyword-type pref->string get-new-one) + (letrec ([vp (new vertical-panel% [parent boxes-panel])] + [_ (new message% + [label (format (string-constant x-like-keywords) keyword-type)] + [parent vp])] + [lb + (new list-box% + [label #f] + [parent vp] + [choices (map pref->string (preferences:get sym))] + [callback + (λ (lb evt) + (send remove-button enable (pair? (send lb get-selections))))])] + [bp (new horizontal-panel% [parent vp] [stretchable-height #f])] + [add + (new button% + [label (string-constant add-keyword)] + [parent bp] + [callback + (λ (x y) + (let ([new-one (get-new-one)]) + (when new-one + (preferences:set sym (append (preferences:get sym) + (list new-one))))))])] + [remove-button + (new button% + [label (string-constant remove-keyword)] + [parent bp] + [callback + (λ (x y) + (let ([n (send lb get-selections)]) + (when (pair? n) + (preferences:set + sym + (let loop ([i 0] + [prefs (preferences:get sym)]) + (cond + [(= i (car n)) (cdr prefs)] + [else (cons (car prefs) + (loop (+ i 1) + (cdr prefs)))]))) + (cond + [(= 0 (send lb get-number)) + (send remove-button enable #f)] + [else + (send lb set-selection + (if (= (car n) (send lb get-number)) + (- (send lb get-number) 1) + (car n)))]))))])]) + (unless (pair? (send lb get-selections)) + (send remove-button enable #f)) + (preferences:add-callback sym + (λ (p v) + (send lb clear) + (for-each (λ (x) (send lb append (pref->string x))) v))))) + + (define (get-new-simple-keyword label) + (λ () + (let ([new-one + (keymap:call/text-keymap-initializer + (λ () + (get-text-from-user + (format (string-constant enter-new-keyword) label) + (format (string-constant x-keyword) label))))]) + (and new-one + (let ([parsed (with-handlers ((exn:fail:read? (λ (x) #f))) + (read (open-input-string new-one)))]) + + (and (symbol? parsed) + (symbol->string parsed))))))) + + (define (get-new-cond-keyword) + (define f (new dialog% [label (format (string-constant enter-new-keyword) "Cond")])) + (define tb (keymap:call/text-keymap-initializer + (λ () + (new text-field% + [parent f] + [label #f])))) + (define number-panel (new horizontal-panel% [parent f] [stretchable-height #f])) + (define number-label (new message% [parent number-panel] [label (string-constant skip-subexpressions)])) + (define number + (keymap:call/text-keymap-initializer + (λ () + (new text-field% + [parent number-panel] + [init-value "1"] + [min-width 50] + [label #f])))) + + (define answers #f) + (define bp (new horizontal-panel% + [parent f] + [stretchable-height #f] + [alignment '(right center)])) + (define (confirm-callback b e) + (let ([n (string->number (send number get-value))] + [sym (with-handlers ([exn:fail:read? (λ (x) #f)]) + (read (open-input-string (send tb get-value))))]) + (when (and (number? n) + (symbol? sym)) + (set! answers (list (symbol->string sym) n))) + (send f show #f))) + + (define (cancel-callback b e) + (send f show #f)) + + (define-values (ok-button cancel-button) + (gui-utils:ok/cancel-buttons bp confirm-callback cancel-callback (string-constant ok) (string-constant cancel))) + (send tb focus) + (send f show #t) + answers) + + (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) diff --git a/collects/framework/private/scheme.rkt b/collects/framework/private/scheme.rkt index 873306b1..bbd3a3e1 100644 --- a/collects/framework/private/scheme.rkt +++ b/collects/framework/private/scheme.rkt @@ -1,2011 +1,35 @@ -#lang scheme/unit +#lang racket/base -;; originally by Dan Grossman -;; 6/30/95 +;; these are the names that used to be a part +;; of the framework with the `scheme:' prefix +;; and now are primarily used with the `racket:' +;; prefix. This list is used to build documentation +;; and renaming exports -(require string-constants - racket/class - mred/mred-sig - syntax-color/module-lexer - "collapsed-snipclass-helpers.rkt" - "sig.rkt" - "../gui-utils.rkt" - "../preferences.rkt" - racket/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-local-member-name - stick-to-next-sexp? - get-private-scheme-container-keymap) - -(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)]) +(provide racket:ids) +(define racket:ids + '(text<%> + text-mixin + text% - (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)))) + text-mode<%> + text-mode-mixin + text-mode% - (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?)))) + set-mode-mixin - (define/override (copy) - (instantiate sexp-snip% () - (left-bracket left-bracket) - (right-bracket right-bracket) - (saved-snips saved-snips))) + sexp-snip% + sexp-snip<%> + get-wordbreak-map + init-wordbreak-map + get-keymap + setup-keymap + add-preferences-panel + add-coloring-preferences-panel - (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))]))) + get-color-prefs-table + get-white-on-black-color-prefs-table + short-sym->pref-name + short-sym->style-name - (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") - (lib "collapsed-snipclass-wxme.ss" "framework")))) -(send lib-snip-class set-version 0) -(send (get-the-snip-class-list) add lib-snip-class) - -;; new snips use this snipclass -(define old-snip-class (make-object sexp-snipclass%)) -(send old-snip-class set-classname "drscheme:sexp-snip") -(send old-snip-class set-version 0) -(send (get-the-snip-class-list) add old-snip-class) - -(keymap:add-to-right-button-menu - (let ([old (keymap:add-to-right-button-menu)]) - (λ (menu text event) - (old menu text event) - (split/collapse-text menu text event) - (void)))) - -;; split/collapse-text : (instanceof menu%) (instanceof editor<%>) (instanceof mouse-event%) -> void -(define (split/collapse-text menu text event) - (when (and (is-a? text -text<%>) - (not (send text is-stopped?))) - (let* ([on-it-box (box #f)] - [click-pos - (call-with-values - (λ () - (send text dc-location-to-editor-location - (send event get-x) - (send event get-y))) - (λ (x y) - (send text find-position x y #f on-it-box)))] - [snip (send text find-snip click-pos 'after)] - [char (send text get-character click-pos)] - [left? (memq char '(#\( #\{ #\[))] - [right? (memq char '(#\) #\} #\]))]) - (cond - [(and snip (is-a? snip sexp-snip<%>)) - (make-expand-item text snip menu)] - [(not (unbox on-it-box)) - ;; clicking in nowhere land, just ignore - (void)] - [(or left? right?) - ;; clicking on left or right paren - (let* ([pos (if left? - click-pos - (+ click-pos 1))] - [other-pos (if left? - (send text get-forward-sexp pos) - (send text get-backward-sexp pos))]) - (when other-pos - (let ([left-pos (min pos other-pos)] - [right-pos (max pos other-pos)]) - (make-collapse-item text left-pos right-pos menu))))] - [else - ;; clicking on some other text -> collapse containing sexp - (let ([up-sexp (send text find-up-sexp click-pos)]) - (when up-sexp - (let ([fwd (send text get-forward-sexp up-sexp)]) - (when fwd - (make-collapse-item text up-sexp fwd menu)))))])))) - -;; make-expand-item : (instanceof text%) (instanceof sexp-snip<%>) (instanceof menu%) -> void -(define (make-expand-item text snip menu) - (instantiate separator-menu-item% () - (parent menu)) - (instantiate menu-item% () - (parent menu) - (label (string-constant expand-sexp)) - (callback (λ (item evt) (expand-from text snip))))) - -;; expand-from : (instanceof text%) (instanceof sexp-snip<%>) -> void -(define (expand-from text snip) - (let ([snips (send snip get-saved-snips)]) - (send text begin-edit-sequence) - (let ([pos (send text get-snip-position snip)]) - (send text delete pos (+ pos 1)) - (let loop ([snips (reverse snips)]) - (cond - [(null? snips) (void)] - [else (send text insert (send (car snips) copy) pos pos) - (loop (cdr snips))]))) - (send text end-edit-sequence))) - -;; make-collapse-item : (instanceof text%) number number (instanceof menu%) -> void -;; adds a collapse menu item to the menu -(define (make-collapse-item text left-pos right-pos menu) - (instantiate separator-menu-item% () - (parent menu)) - (instantiate menu-item% () - (parent menu) - (label (string-constant collapse-sexp)) - (callback (λ (item evt) - (collapse-from text left-pos right-pos))))) - -(define (collapse-from text left-pos right-pos) - (let ([left-bracket (send text get-character left-pos)] - [right-bracket (send text get-character (- right-pos 1))]) - (send text begin-edit-sequence) - (send text split-snip left-pos) - (send text split-snip right-pos) - (let ([snips (let loop ([snip (send text find-snip left-pos 'after)]) - (cond - [(not snip) null] - [((send text get-snip-position snip) . >= . right-pos) - null] - [else (cons (send snip copy) (loop (send snip next)))]))]) - (send text delete left-pos right-pos) - (send text insert (instantiate sexp-snip% () - (left-bracket left-bracket) - (right-bracket right-bracket) - (saved-snips snips)) - left-pos left-pos) - (send text end-edit-sequence)))) - - -; -; -; -; ; ;;;; -; ;; ;;;; -; ;;;; ;;;;; ;;;; ;;; ;;; ;;; ;;; -; ;;;;;; ;;;;;; ;;;;;;;;; ;;;;; ;;;;;;; -; ;;;;;;;; ;;;; ;;;; ;;;; ;;;; ;; ;;;; ;; -; ;;;; ;;; ;;;; ;;;; ;;;; ;;;;;;; ;;;; -; ;;;;;;;; ;;;;; ;;;; ;;;; ;;;;; ;;;; -; ;;;;;; ;;;;; ;;;; ;;;; ;;;;;; ;;;; -; ;;;; ;;;; ;;;; ;;;; ;;;; ;;;; -; -; -; - - -(define color-prefs-table - (let ([constant-green (make-object color% 41 128 38)] - [symbol-blue (make-object color% 38 38 128)]) - `((symbol ,symbol-blue ,(string-constant scheme-mode-color-symbol)) - (keyword ,symbol-blue ,(string-constant scheme-mode-color-keyword)) - (comment ,(make-object color% 194 116 31) ,(string-constant scheme-mode-color-comment)) - (string ,constant-green ,(string-constant scheme-mode-color-string)) - (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<%> editor:keymap<%>) (-text<%>) - (inherit begin-edit-sequence - delete - end-edit-sequence - local-edit-sequence? - find-string - extend-position - get-character - get-extend-end-position - get-extend-start-position - get-keymap - get-text - get-start-position - get-style-list - get-end-position - flash-on - insert - is-stopped? - kill - last-position - paragraph-start-position - paragraph-end-position - position-paragraph - set-keymap - set-load-overwrites-styles - set-position - set-wordbreak-map - set-tabs - set-style-list - set-styles-fixed - change-style - get-snip-position - backward-match - backward-containing-sexp - forward-match - skip-whitespace - insert-close-paren - classify-position) - - (inherit get-styles-fixed) - (inherit has-focus? find-snip split-snip - position-location get-dc) - - (define private-scheme-container-keymap (new keymap:aug-keymap%)) - (define/public (get-private-scheme-container-keymap) private-scheme-container-keymap) - - (define/override (get-keymaps) - (editor:add-after-user-keymap private-scheme-container-keymap - (super get-keymaps))) - - (define/override (get-word-at current-pos) - (let ([no-word ""]) - (cond - [(is-stopped?) - no-word] - [else - (let ([type (classify-position (max 0 (- current-pos 1)))]) - (cond - [(memq type '(symbol keyword)) - (get-text (look-for-non-symbol/non-kwd (max 0 (- current-pos 1))) - current-pos)] - [else no-word]))]))) - - (define/private (look-for-non-symbol/non-kwd start) - (let loop ([i start]) - (cond - [(< i 0) - 0] - [(memq (classify-position i) '(symbol keyword)) - (loop (- i 1))] - [else - (+ i 1)]))) - - (public tabify-all insert-return calc-last-para - box-comment-out-selection comment-out-selection uncomment-selection - flash-forward-sexp - flash-backward-sexp backward-sexp find-up-sexp up-sexp find-down-sexp down-sexp - remove-parens-forward) - - (define/public (get-limit pos) 0) - - (define/public (balance-parens key-event) - (insert-close-paren (get-start-position) - (send key-event get-key-code) - (preferences:get 'framework:paren-match) - (preferences:get 'framework:fixup-parens))) - - (define/public (tabify-on-return?) #t) - (define/public (tabify [pos (get-start-position)]) - (unless (is-stopped?) - (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) - (define tab-char? #f) - (define end-pos - (let loop ([p start-pos]) - (let ([c (get-character p)]) - (cond - [(char=? c #\tab) - (set! tab-char? #t) - (loop (add1 p))] - [(char=? c #\newline) - p] - [(char-whitespace? c) - (loop (add1 p))] - [else - p])))) - (define start-x (box 0)) - (define end-x (box 0)) - (position-location start-pos start-x #f #t #t) - (position-location end-pos end-x #f #t #t) - (define-values (w _1 _2 _3) - (send (get-dc) get-text-extent "x" - (send (send (get-style-list) - find-named-style "Standard") - get-font))) - (values (inexact->exact (floor (/ (- (unbox end-x) (unbox start-x)) w))) - end-pos - tab-char?))] - - [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) - (define pos-start end) - (define-values (gwidth curr-offset tab-char?) (find-offset pos-start)) - (unless (and (not tab-char?) (= amt (- curr-offset pos-start))) - (delete pos-start 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))))] - [curley-brace-sexp? - (λ () - (define up-p (find-up-sexp pos)) - (and up-p - (equal? #\{ (get-character up-p))))] - - [indent-first-arg (λ (start) - (define-values (gwidth curr-offset tab-char?) (find-offset start)) - gwidth)]) - (when (and is-tabbable? - (not (char=? (get-character (sub1 end)) - #\newline))) - (insert #\newline (paragraph-start-position para))) - (cond - [(not is-tabbable?) - (when (= para 0) - (do-indent 0))] - [(let-values ([(gwidth real-start tab-char?) (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)] - #; ;; disable this to accommodate PLAI programs; return to this when a #lang capability is set up. - [(curley-brace-sexp?) - ;; when we are directly inside an sexp that uses {}s, - ;; we indent in a more C-like fashion (to help Scribble) - (define first-curley (find-up-sexp pos)) - (define containing-curleys - (let loop ([pos first-curley]) - (let ([next (find-up-sexp pos)]) - (if (and next - (equal? (get-character next) #\{)) - (+ (loop next) 1) - 1)))) - (define close-first-curley (get-forward-sexp first-curley)) - (define para (position-paragraph pos)) - (when (and close-first-curley - (<= (paragraph-start-position para) close-first-curley (paragraph-end-position para))) - (set! containing-curleys (max 0 (- containing-curleys 1)))) - (do-indent (* containing-curleys 2))] - [(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)]) - (if enclosing - (do-indent (+ (visual-offset enclosing) 1)) - (do-indent 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 [start-pos (get-start-position)] - [end-pos (get-end-position)]) - (unless (is-stopped?) - (define first-para (position-paragraph start-pos)) - (define end-para (position-paragraph end-pos)) - (with-handlers ([exn:break? - (λ (x) #t)]) - (dynamic-wind - (λ () - (when (< first-para end-para) - (begin-busy-cursor)) - (begin-edit-sequence)) - (λ () - (let loop ([para first-para]) - (when (<= para end-para) - (tabify (paragraph-start-position para)) - (parameterize-break #t (void)) - (loop (add1 para)))) - (when (and (>= (position-paragraph start-pos) end-para) - (<= (skip-whitespace (get-start-position) 'backward #f) - (paragraph-start-position first-para))) - (set-position - (let loop ([new-pos (get-start-position)]) - (if (let ([next (get-character new-pos)]) - (and (char-whitespace? next) - (not (char=? next #\newline)))) - (loop (add1 new-pos)) - new-pos))))) - (λ () - (end-edit-sequence) - (when (< first-para end-para) - (end-busy-cursor))))))) - - (define (tabify-all) (tabify-selection 0 (last-position))) - (define (insert-return) - (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/public (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?) - (define start-pos (get-start-position)) - (define end-pos (get-end-position)) - (define new-pos - (if forward? - (if (= (get-extend-start-position) start-pos) - (f end-pos) - (f start-pos)) - (if (= (get-extend-end-position) end-pos) - (f start-pos) - (f end-pos)))) - (if new-pos - (extend-position new-pos) - (bell)) - #t) - (public select-forward-sexp select-backward-sexp select-up-sexp select-down-sexp) - [define select-forward-sexp (λ () (select-text (λ (x) (get-forward-sexp x)) #t))] - [define select-backward-sexp (λ () (select-text (λ (x) (get-backward-sexp x)) #f))] - [define select-up-sexp (λ () (select-text (λ (x) (find-up-sexp x)) #f))] - [define select-down-sexp (λ () (select-text (λ (x) (find-down-sexp x)) #t))] - - (define/public (introduce-let-ans pos) - (dynamic-wind - (λ () (begin-edit-sequence)) - (λ () - (let ([before-text "(let ([ans "] - [after-text "])\n"] - [after-text2 "(printf \"~s\\n\" ans)\nans)"] - [end-l (get-forward-sexp pos)]) - (cond - [end-l - (insert after-text2 end-l end-l) - (insert after-text end-l end-l) - (insert before-text pos pos) - (let ([blank-line-pos (+ end-l (string-length after-text) (string-length before-text))]) - (set-position blank-line-pos blank-line-pos)) - (tabify-selection - pos - (+ end-l - (string-length before-text) - (string-length after-text) - (string-length after-text2)))] - [else - (bell)]))) - (λ () - (end-edit-sequence)))) - - (define/public (move-sexp-out begin-inner) - (begin-edit-sequence) - (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))] - - (define/override (get-start-of-line pos) - (define para (position-paragraph pos)) - (define para-start (paragraph-start-position para)) - (define para-end (paragraph-end-position para)) - (define first-non-whitespace - (let loop ([i para-start]) - (cond - [(= i para-end) #f] - [(char-whitespace? (get-character i)) - (loop (+ i 1))] - [else i]))) - (define new-pos - (cond - [(not first-non-whitespace) para-start] - [(= pos para-start) first-non-whitespace] - [(<= pos first-non-whitespace) para-start] - [else first-non-whitespace])) - new-pos) - - (super-new))) - -(define -text-mode<%> - (interface () - )) - -(define 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-private-scheme-container-keymap) 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"] - #; ; no need for the following, since it's the default - [finder:default-filters '(["Racket Sources" "*.rkt;*.scrbl;*.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) - (define (add-edit-function name f) - (send keymap add-function name (λ (edit event) (f edit)))) - (define (add-pos-function name f) - (send keymap add-function name - (λ (edit event) - (f edit (send edit get-start-position))))) - (add-pos-function "remove-sexp" (λ (e p) (send e remove-sexp p))) - (add-pos-function "forward-sexp" (λ (e p) (send e forward-sexp p))) - (add-pos-function "backward-sexp" (λ (e p) (send e backward-sexp p))) - (add-pos-function "up-sexp" (λ (e p) (send e up-sexp p))) - (add-pos-function "down-sexp" (λ (e p) (send e down-sexp p))) - (add-pos-function "flash-backward-sexp" (λ (e p) (send e flash-backward-sexp p))) - (add-pos-function "flash-forward-sexp" (λ (e p) (send e flash-forward-sexp p))) - (add-pos-function "remove-parens-forward" (λ (e p) (send e remove-parens-forward p))) - (add-pos-function "transpose-sexp" (λ (e p) (send e transpose-sexp p))) - (add-pos-function "mark-matching-parenthesis" - (λ (e p) (send e mark-matching-parenthesis p))) - (add-pos-function "introduce-let-ans" - (λ (e p) (send e introduce-let-ans p))) - (add-pos-function "move-sexp-out" - (λ (e p) (send e move-sexp-out p))) - (add-pos-function "kill-enclosing-parens" - (lambda (e p) (send e kill-enclosing-parens p))) - (add-pos-function "toggle-round-square-parens" - (lambda (e p) (send e toggle-round-square-parens p))) - - (add-edit-function "select-forward-sexp" - (λ (x) (send x select-forward-sexp))) - (add-edit-function "select-backward-sexp" - (λ (x) (send x select-backward-sexp))) - (add-edit-function "select-down-sexp" - (λ (x) (send x select-down-sexp))) - (add-edit-function "select-up-sexp" - (λ (x) (send x select-up-sexp))) - (add-edit-function "tabify-at-caret" - (λ (x) (send x tabify-selection))) - (add-edit-function "do-return" - (λ (x) (send x insert-return))) - (add-edit-function "comment-out" - (λ (x) (send x comment-out-selection))) - (add-edit-function "box-comment-out" - (λ (x) (send x box-comment-out-selection))) - (add-edit-function "uncomment" - (λ (x) (send x uncomment-selection))) - - (send keymap add-function "paren-double-select" - (λ (text event) - (keymap:region-click - text event - (λ (click-pos eol?) - (define str1 (string (send text get-character click-pos))) - (define sexp-based-start/end - (cond - [(ormap (λ (pr) (equal? (cdr pr) str1)) - (scheme-paren:get-paren-pairs)) - (define start (send text get-backward-sexp (+ click-pos 1))) - (and start - (cons start (+ click-pos 1)))] - [else - (let ([end (send text get-forward-sexp click-pos)]) - (and end - (let ([beginning (send text get-backward-sexp end)]) - (and beginning - (cons beginning end)))))])) - (cond - [sexp-based-start/end - (send text set-position - (car sexp-based-start/end) - (cdr sexp-based-start/end))] - [else - (define start-box (box click-pos)) - (define end-box (box click-pos)) - (send text find-wordbreak start-box end-box 'selection) - (send text set-position (unbox start-box) (unbox end-box))]))))) - - - (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 "leftbuttondouble" "paren-double-select") - - (define (insert-brace-pair text open-brace close-brace) - (define selection-start (send text get-start-position)) - (send text set-position (send text get-end-position)) - (send text insert close-brace) - (send text set-position selection-start) - (send text insert open-brace)) - - (define (maybe-insert-brace-pair text open-brace close-brace) - (cond - [(preferences:get 'framework:automatic-parens) - (insert-brace-pair text open-brace close-brace)] - [else - (send text insert open-brace)])) - - (add-edit-function "insert-()-pair" (λ (text) (insert-brace-pair text #\( #\)))) - (add-edit-function "insert-[]-pair" (λ (text) (insert-brace-pair text #\[ #\]))) - (add-edit-function "insert-{}-pair" (λ (text) (insert-brace-pair text #\{ #\}))) - (add-edit-function "insert-\"\"-pair" (λ (text) (insert-brace-pair text #\" #\"))) - (add-edit-function "insert-||-pair" (λ (text) (insert-brace-pair text #\| #\|))) - - (add-edit-function "maybe-insert-()-pair" (λ (text) (maybe-insert-brace-pair text #\( #\)))) - (add-edit-function "maybe-insert-[]-pair" (λ (text) (maybe-insert-brace-pair text #\[ #\]))) - (add-edit-function "maybe-insert-{}-pair" (λ (text) (maybe-insert-brace-pair text #\{ #\}))) - (add-edit-function "maybe-insert-\"\"-pair" (λ (text) (maybe-insert-brace-pair text #\" #\"))) - (add-edit-function "maybe-insert-||-pair" (λ (text) (maybe-insert-brace-pair text #\| #\|))) - - (add-edit-function "maybe-insert-[]-pair-maybe-fixup-[]" - (λ (text) - (cond - [(or (not (preferences:get 'framework:fixup-open-parens)) - (send text is-stopped?)) - (maybe-insert-brace-pair text #\[ #\])] - [else - (insert-paren text)]))) - - (define (insert-lambda-template edit) - (send edit begin-edit-sequence) - (let ([selection-start (send edit get-start-position)]) - (send edit set-position (send edit get-end-position)) - (send edit insert ")") - (send edit set-position selection-start) - (send edit insert ") ") - (send edit set-position selection-start) - (send edit insert "(λ (")) - (send edit end-edit-sequence)) - - (add-edit-function "insert-lambda-template" insert-lambda-template) - - (define (map-meta key func) (keymap:send-map-function-meta keymap key func)) - (define (map key func) (send keymap map-function key func)) - - (map-meta "up" "up-sexp") - (map-meta "c:u" "up-sexp") - (map "a:up" "up-sexp") - (map-meta "s:up" "select-up-sexp") - (map "a:s:up" "select-up-sexp") - (map-meta "s:c:u" "select-up-sexp") - - (map-meta "down" "down-sexp") - (map "a:down" "down-sexp") - (map-meta "s:down" "select-down-sexp") - (map "a:s:down" "select-down-sexp") - (map-meta "s:c:down" "select-down-sexp") - - (map-meta "right" "forward-sexp") - (map "a:right" "forward-sexp") - (map "m:right" "forward-sexp") - (map-meta "s:right" "select-forward-sexp") - (map "a:s:right" "select-forward-sexp") - (map "m:s:right" "select-forward-sexp") - - (map-meta "left" "backward-sexp") - (map "a:left" "backward-sexp") - (map "m:left" "backward-sexp") - (map-meta "s:left" "select-backward-sexp") - (map "a:s:left" "select-backward-sexp") - (map "m:s:left" "select-backward-sexp") - - (map-meta "return" "do-return") - (map-meta "s:return" "do-return") - (map-meta "s:c:return" "do-return") - (map-meta "a:return" "do-return") - (map-meta "s:a:return" "do-return") - (map-meta "c:a:return" "do-return") - (map-meta "c:s:a:return" "do-return") - (map-meta "c:return" "do-return") - - (map-meta "c:semicolon" "comment-out") - (map-meta "c:=" "uncomment") - (map-meta "c:k" "remove-sexp") - - (map-meta "c:f" "forward-sexp") - (map-meta "s:c:f" "select-forward-sexp") - - (map-meta "c:b" "backward-sexp") - (map-meta "s:c:b" "select-backward-sexp") - - (map-meta "c:p" "flash-backward-sexp") - (map-meta "s:c:n" "flash-forward-sexp") - - (map-meta "c:space" "select-forward-sexp") - (map-meta "c:t" "transpose-sexp") - - ;(map-meta "c:m" "mark-matching-parenthesis") - ; this keybinding doesn't interact with the paren colorer - - (map-meta "(" "insert-()-pair") - (map-meta "[" "insert-[]-pair") - (map-meta "{" "insert-{}-pair") - (map-meta "\"" "insert-\"\"-pair") - (map-meta "|" "insert-||-pair") - - (map "(" "maybe-insert-()-pair") - (map "[" "maybe-insert-[]-pair-maybe-fixup-[]") - (map "{" "maybe-insert-{}-pair") - (map "\"" "maybe-insert-\"\"-pair") - (map "|" "maybe-insert-||-pair") - - (map-meta "s:l" "insert-lambda-template") - - (map "c:c;c:b" "remove-parens-forward") - (map "c:c;c:l" "introduce-let-ans") - (map "c:c;c:o" "move-sexp-out") - (map "c:c;c:e" "kill-enclosing-parens") - (map "c:c;c:[" "toggle-round-square-parens")) - -(define keymap (make-object keymap:aug-keymap%)) -(setup-keymap keymap) -(define (get-keymap) keymap) - -;; choose-paren : 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 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) - (cond - [(preferences:get 'framework:automatic-parens) - (send text insert (case real-char - [(#\() #\)] - [(#\[) #\]] - [(#\{) #\}]) - end-pos end-pos) - (send text insert real-char start-pos start-pos) - (send text set-position (+ start-pos 1))] - [else - (send text insert real-char start-pos end-pos)]))) - -;; find-keyword-and-distance : -> (union #f (cons string number)) -(define (find-keyword-and-distance before-whitespace-pos text) - ;; searches backwards for the keyword in the sequence at this level. - ;; if found, it counts how many sexps back it was - (let loop ([pos before-whitespace-pos] - [n 0]) - (let ([backward-match (send text backward-match pos 0)]) - (cond - [backward-match - (let ([before-whitespace-pos (send text skip-whitespace backward-match 'backward #t)]) - (loop before-whitespace-pos - (if (send text stick-to-next-sexp? backward-match) - n - (+ n 1))))] - [else - (let* ([afterwards (send text get-forward-sexp pos)] - [keyword - (and afterwards - (send text get-text pos afterwards))]) - (and keyword - (list keyword (- n 1))))])))) - -;; beginning-of-sequence? : text number -> boolean -;; determines if this position is at the beginning of a sequence -;; that begins with a parenthesis. -(define (beginning-of-sequence? text start) - (let ([before-space (send text skip-whitespace start 'backward #t)]) - (cond - [(zero? before-space) #t] - [else - (equal? (send text get-character (- before-space 1)) - #\()]))) - -(define (text-between-equal? str text start end) - (and (= (string-length str) (- end start)) - (let loop ([i (string-length str)]) - (cond - [(= i 0) #t] - [else - (and (char=? (string-ref str (- i 1)) - (send text get-character (+ i start -1))) - (loop (- i 1)))])))) - - -; ;;; ;;; -; ; ; -; ; ; -; ;;; ; ;;; ;;; ;;;;; ;;; ; ;;; ;;;; ; ;;; ;;; ; -;; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; -;; ; ; ;;;;; ; ;;; ; ; ;;;; ; ; ;;;;; ; -;; ; ; ; ; ; ; ; ; ; ; ; ; ; -;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; -;;;;; ;;;; ;;; ;;;; ;;; ;;;; ;;; ;;;; ;; ;;; ;;;;;; -;; ; -;; ; -;;;; ;;; - - -(define (add-preferences-panel) - (preferences:add-panel - (list (string-constant editor-prefs-panel-label) - (string-constant indenting-prefs-panel-label)) - make-indenting-prefs-panel) - (preferences:add-panel - (list (string-constant editor-prefs-panel-label) - (string-constant square-bracket-prefs-panel-label)) - make-square-bracket-prefs-panel)) - -(define (make-square-bracket-prefs-panel p) - (define main-panel (make-object vertical-panel% p)) - (define boxes-panel (new horizontal-panel% [parent main-panel])) - - (define (mk-list-box sym keyword-type pref->string get-new-one) - (letrec ([vp (new vertical-panel% [parent boxes-panel])] - [_ (new message% - [label (format (string-constant x-like-keywords) keyword-type)] - [parent vp])] - [lb - (new list-box% - [label #f] - [parent vp] - [choices (map pref->string (preferences:get sym))] - [callback - (λ (lb evt) - (send remove-button enable (pair? (send lb get-selections))))])] - [bp (new horizontal-panel% [parent vp] [stretchable-height #f])] - [add - (new button% - [label (string-constant add-keyword)] - [parent bp] - [callback - (λ (x y) - (let ([new-one (get-new-one)]) - (when new-one - (preferences:set sym (append (preferences:get sym) - (list new-one))))))])] - [remove-button - (new button% - [label (string-constant remove-keyword)] - [parent bp] - [callback - (λ (x y) - (let ([n (send lb get-selections)]) - (when (pair? n) - (preferences:set - sym - (let loop ([i 0] - [prefs (preferences:get sym)]) - (cond - [(= i (car n)) (cdr prefs)] - [else (cons (car prefs) - (loop (+ i 1) - (cdr prefs)))]))) - (cond - [(= 0 (send lb get-number)) - (send remove-button enable #f)] - [else - (send lb set-selection - (if (= (car n) (send lb get-number)) - (- (send lb get-number) 1) - (car n)))]))))])]) - (unless (pair? (send lb get-selections)) - (send remove-button enable #f)) - (preferences:add-callback sym - (λ (p v) - (send lb clear) - (for-each (λ (x) (send lb append (pref->string x))) v))))) - - (define (get-new-simple-keyword label) - (λ () - (let ([new-one - (keymap:call/text-keymap-initializer - (λ () - (get-text-from-user - (format (string-constant enter-new-keyword) label) - (format (string-constant x-keyword) label))))]) - (and new-one - (let ([parsed (with-handlers ((exn:fail:read? (λ (x) #f))) - (read (open-input-string new-one)))]) - - (and (symbol? parsed) - (symbol->string parsed))))))) - - (define (get-new-cond-keyword) - (define f (new dialog% [label (format (string-constant enter-new-keyword) "Cond")])) - (define tb (keymap:call/text-keymap-initializer - (λ () - (new text-field% - [parent f] - [label #f])))) - (define number-panel (new horizontal-panel% [parent f] [stretchable-height #f])) - (define number-label (new message% [parent number-panel] [label (string-constant skip-subexpressions)])) - (define number - (keymap:call/text-keymap-initializer - (λ () - (new text-field% - [parent number-panel] - [init-value "1"] - [min-width 50] - [label #f])))) - - (define answers #f) - (define bp (new horizontal-panel% - [parent f] - [stretchable-height #f] - [alignment '(right center)])) - (define (confirm-callback b e) - (let ([n (string->number (send number get-value))] - [sym (with-handlers ([exn:fail:read? (λ (x) #f)]) - (read (open-input-string (send tb get-value))))]) - (when (and (number? n) - (symbol? sym)) - (set! answers (list (symbol->string sym) n))) - (send f show #f))) - - (define (cancel-callback b e) - (send f show #f)) - - (define-values (ok-button cancel-button) - (gui-utils:ok/cancel-buttons bp confirm-callback cancel-callback (string-constant ok) (string-constant cancel))) - (send tb focus) - (send f show #t) - answers) - - (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) + text-balanced?)) diff --git a/collects/framework/private/sig.rkt b/collects/framework/private/sig.rkt index a4aa0167..9f46f22f 100644 --- a/collects/framework/private/sig.rkt +++ b/collects/framework/private/sig.rkt @@ -411,7 +411,7 @@ white-on-black black-on-white)) - (define-signature scheme-class^ + (define-signature racket-class^ (text<%> text-mixin text% @@ -424,7 +424,7 @@ sexp-snip% sexp-snip<%>)) - (define-signature scheme^ extends scheme-class^ + (define-signature racket^ extends racket-class^ (get-wordbreak-map init-wordbreak-map get-keymap @@ -487,5 +487,5 @@ (open (prefix panel: panel^)) (open (prefix frame: frame^)) (open (prefix handler: handler^)) - (open (prefix scheme: scheme^)) + (open (prefix racket: racket^)) (open (prefix main: main^)))) diff --git a/collects/framework/private/text.rkt b/collects/framework/private/text.rkt index 19424b4f..1b148fda 100644 --- a/collects/framework/private/text.rkt +++ b/collects/framework/private/text.rkt @@ -20,7 +20,7 @@ [prefix keymap: framework:keymap^] [prefix color-model: framework:color-model^] [prefix frame: framework:frame^] - [prefix scheme: framework:scheme^] + [prefix racket: framework:racket^] [prefix number-snip: framework:number-snip^] [prefix finder: framework:finder^]) (export (rename framework:text^ @@ -1564,7 +1564,7 @@ (define/private (refresh-delegate/do-work) (send delegate begin-edit-sequence) (send delegate lock #f) - (when (is-a? this scheme:text<%>) + (when (is-a? this racket:text<%>) (send delegate set-tabs null (send this get-tab-size) #f)) (send delegate hide-caret #t) (send delegate erase) diff --git a/collects/scribblings/framework/comment-box.scrbl b/collects/scribblings/framework/comment-box.scrbl index 946ebe21..48cf52ce 100644 --- a/collects/scribblings/framework/comment-box.scrbl +++ b/collects/scribblings/framework/comment-box.scrbl @@ -10,7 +10,7 @@ @defmethod*[#:mode override (((make-editor) (is-a?/c text%)))]{ Makes an instance of - @racketblock[(scheme:text-mixin text:keymap%)]} + @racketblock[(racket:text-mixin text:keymap%)]} @defmethod*[#:mode override (((make-snip) (is-a?/c comment-snip%)))]{ Returns an instance of the @racket[comment-snip%] class.} diff --git a/collects/scribblings/framework/framework.scrbl b/collects/scribblings/framework/framework.scrbl index 9eb895f5..1d729e7d 100644 --- a/collects/scribblings/framework/framework.scrbl +++ b/collects/scribblings/framework/framework.scrbl @@ -1,7 +1,8 @@ #lang scribble/doc -@(require (for-label framework framework/framework-unit framework/framework-sig racket/gui)) -@(require scribble/manual) +@(require (for-label framework framework/framework-unit framework/framework-sig racket/gui) + (for-syntax framework/private/scheme racket/base) + scribble/manual) @title{Framework: Racket GUI Application Framework} @(defmodule framework) @@ -103,12 +104,22 @@ the @secref["editor-snip"] section. @include-section["path-utils.scrbl"] @include-section["preferences.scrbl"] @include-section["preferences-text.scrbl"] -@include-section["scheme.scrbl"] +@include-section["racket.scrbl"] @include-section["text.scrbl"] @include-section["splash.scrbl"] @include-section["test.scrbl"] @include-section["version.scrbl"] +@section{Backwards Compatibility} + +@(define-syntax (scheme:-docs stx) + #`(begin + #,@(for/list ([suffix (in-list racket:ids)]) + (define scheme:id (string->symbol (format "scheme:~a" suffix))) + (define racket:id (string->symbol (format "racket:~a" suffix))) + #`@defidform[#,scheme:id]{An alias for @racket[#,racket:id].}))) +@(scheme:-docs) + @section{Signatures} @defmodule[framework/framework-sig] diff --git a/collects/scribblings/framework/scheme.scrbl b/collects/scribblings/framework/racket.scrbl similarity index 90% rename from collects/scribblings/framework/scheme.scrbl rename to collects/scribblings/framework/racket.scrbl index da1b48cd..6364f77d 100644 --- a/collects/scribblings/framework/scheme.scrbl +++ b/collects/scribblings/framework/racket.scrbl @@ -4,19 +4,19 @@ @(require (for-label scheme/gui)) @title{Racket} -@definterface[scheme:sexp-snip<%> ()]{ +@definterface[racket:sexp-snip<%> ()]{ @defmethod*[(((get-saved-snips) (listof (is-a?/c snip%))))]{ This returns the list of snips hidden by the sexp snip. } } -@defclass[scheme:sexp-snip% snip% (scheme:sexp-snip<%> readable-snip<%>)]{ +@defclass[racket:sexp-snip% snip% (racket:sexp-snip<%> readable-snip<%>)]{ @defmethod*[#:mode override (((get-text (offset number?) (num number?) (flattened? boolean? #f)) string?))]{ Returns the concatenation of the text for all of the hidden snips. } - @defmethod*[#:mode override (((copy) (is-a?/c scheme:sexp-snip%)))]{ + @defmethod*[#:mode override (((copy) (is-a?/c racket:sexp-snip%)))]{ Returns a copy of this snip that includes the hidden snips. } @defmethod*[#:mode override (((write (stream-out (is-a?/c editor-stream-out%))) void?))]{ @@ -41,7 +41,7 @@ Returns a size corresponding to what this snip draws. } } -@definterface[scheme:text<%> (text:basic<%> mode:host-text<%> color:text<%>)]{ +@definterface[racket:text<%> (text:basic<%> mode:host-text<%> color:text<%>)]{ Texts matching this interface support Racket mode operations. @defmethod*[(((get-limit (start exact-integer?)) exact-integer?))]{ @@ -84,7 +84,7 @@ } @defmethod*[(((insert-return) void?))]{ - Inserts a newline into the buffer. If @method[scheme:text<%> + Inserts a newline into the buffer. If @method[racket:text<%> tabify-on-return?] returns @racket[#t], this will tabify the new line. } @@ -209,7 +209,7 @@ @defmethod*[(((get-tab-size) exact-integer?))]{ This method returns the current size of the tabs for scheme mode. - See also @method[scheme:text<%> set-tab-size]. + See also @method[racket:text<%> set-tab-size]. } @defmethod*[(((set-tab-size (new-size exact-integer?)) void?))]{ @@ -226,9 +226,9 @@ sexpression following the insertion point. } } -@defmixin[scheme:text-mixin +@defmixin[racket:text-mixin (text:basic<%> mode:host-text<%> color:text<%> text:autocomplete<%>) - (scheme:text<%>)]{ + (racket:text<%>)]{ This mixin adds functionality for editing Racket files. The result of this mixin uses the same initialization arguments as the @@ -248,41 +248,41 @@ } } -@definterface[scheme:text-mode<%> ()]{ - The result of @racket[scheme:text-mode-mixin] implements this +@definterface[racket:text-mode<%> ()]{ + The result of @racket[racket:text-mode-mixin] implements this interface. } -@defmixin[scheme:text-mode-mixin +@defmixin[racket:text-mode-mixin (color:text-mode<%> mode:surrogate-text<%>) - (scheme:text-mode<%>)]{ + (racket:text-mode<%>)]{ This mixin adds Racket mode functionality to the mode that it is mixed into. The resulting mode assumes that it is only set to an editor that is the - result of @racket[scheme:text-mixin]. + result of @racket[racket:text-mixin]. @defmethod*[#:mode override (((on-disable-surrogate) void?))]{ - Removes the scheme keymap (see also @racket[scheme:get-keymap]) and + Removes the scheme keymap (see also @racket[racket:get-keymap]) and disables any parenthesis highlighting in the host editor. } @defmethod*[#:mode override (((on-enable-surrogate) void?))]{ - Adds the scheme keymap (see also @racket[scheme:get-keymap]) and enables a + Adds the scheme keymap (see also @racket[racket:get-keymap]) and enables a parenthesis highlighting in the host editor. } } -@defmixin[scheme:set-mode-mixin (scheme:text<%> mode:host-text<%>) ()]{ - This mixin creates a new instance of @racket[scheme:text-mode%] and installs +@defmixin[racket:set-mode-mixin (racket:text<%> mode:host-text<%>) ()]{ + This mixin creates a new instance of @racket[racket:text-mode%] and installs it, by calling its own @method[mode:host-text<%> set-surrogate] method with the object. } -@defclass[scheme:text% - (scheme:set-mode-mixin - (scheme:text-mixin +@defclass[racket:text% + (racket:set-mode-mixin + (racket:text-mixin (text:autocomplete-mixin (mode:host-text-mixin color:text%)))) ()]{} -@defclass[scheme:text-mode% (scheme:text-mode-mixin color:text-mode%) ()]{} +@defclass[racket:text-mode% (racket:text-mode-mixin color:text-mode%) ()]{} -@(include-previously-extracted "main-extracts.rkt" #rx"^scheme:") +@(include-previously-extracted "main-extracts.rkt" #rx"^racket:") diff --git a/collects/scribblings/framework/text.scrbl b/collects/scribblings/framework/text.scrbl index 83899a11..9f5fe7e9 100644 --- a/collects/scribblings/framework/text.scrbl +++ b/collects/scribblings/framework/text.scrbl @@ -471,7 +471,7 @@ When it is set, all of the snips are copied from this object to @racket[delegate]. Additionally, if this object implements - @racket[scheme:text<%>] the tab settings of @racket[delegate] are updated + @racket[racket:text<%>] the tab settings of @racket[delegate] are updated to match this objects. } } diff --git a/collects/tests/framework/README b/collects/tests/framework/README index 48bfcd11..a039bfa3 100644 --- a/collects/tests/framework/README +++ b/collects/tests/framework/README @@ -74,7 +74,7 @@ signal failures when there aren't any. | Tests the scheme: section - |# scheme.rkt #| + |# racket.rkt #| - panel tests: diff --git a/collects/tests/framework/keys.rkt b/collects/tests/framework/keys.rkt index e955f58f..560d52ca 100644 --- a/collects/tests/framework/keys.rkt +++ b/collects/tests/framework/keys.rkt @@ -137,7 +137,7 @@ (list (list (list #\[))) (list (list (list #\[))))) - ;; the keybindings test cases applied to scheme:text% editors + ;; the keybindings test cases applied to racket:text% editors (define scheme-specs (list (make-key-spec (make-buff-spec "(abc (def))" 4 4) @@ -327,13 +327,13 @@ (test-specs "global keybindings test" 'frame:text% global-specs) (test-specs "scheme mode keybindings test" '(class frame:editor% - (define/override (get-editor%) scheme:text%) + (define/override (get-editor%) racket:text%) (super-new)) scheme-specs) (queue-sexp-to-mred `(preferences:set 'framework:automatic-parens #t)) (queue-sexp-to-mred `(preferences:set 'framework:fixup-open-parens #f)) (test-specs "scheme mode automatic-parens on keybindings test" '(class frame:editor% - (define/override (get-editor%) scheme:text%) + (define/override (get-editor%) racket:text%) (super-new)) automatic-scheme-specs) diff --git a/collects/tests/framework/mem.rkt b/collects/tests/framework/mem.rkt index 8eab3fe8..a1cc5485 100644 --- a/collects/tests/framework/mem.rkt +++ b/collects/tests/framework/mem.rkt @@ -152,7 +152,7 @@ (test-editor-allocate 'pasteboard:backup-autosave%) (test-editor-allocate 'pasteboard:info%) -(test-editor-allocate 'scheme:text%) +(test-editor-allocate 'racket:text%) (test-allocate "text:return%" '(lambda () (make-object text:return% void)) diff --git a/collects/tests/framework/scheme.rkt b/collects/tests/framework/racket.rkt similarity index 89% rename from collects/tests/framework/scheme.rkt rename to collects/tests/framework/racket.rkt index e8dc6162..5e8d7e73 100644 --- a/collects/tests/framework/scheme.rkt +++ b/collects/tests/framework/racket.rkt @@ -10,14 +10,14 @@ (define (test-text-balanced? number str start end expected) (test - (string->symbol (format "scheme:text-balanced?-~a" number)) + (string->symbol (format "racket:text-balanced?-~a" number)) (lambda (x) (equal? x expected)) (λ () (queue-sexp-to-mred - `(let ([t (new scheme:text%)]) + `(let ([t (new racket:text%)]) (send t insert ,str) - (scheme:text-balanced? t ,start ,end)))))) + (racket:text-balanced? t ,start ,end)))))) (test-text-balanced? 0 "" 0 #f #f) (test-text-balanced? 1 " \n " 0 #f #f) @@ -32,11 +32,11 @@ (define (test-indentation which before after) (test - (string->symbol (format "scheme:test-indentation-~a" which)) + (string->symbol (format "racket:test-indentation-~a" which)) (λ (x) (equal? x after)) (λ () (queue-sexp-to-mred - `(let* ([t (new scheme:text%)] + `(let* ([t (new racket:text%)] [f (new frame% [label ""] [width 600] [height 600])] [ec (new editor-canvas% [parent f] [editor t])]) (send f reflow-container) @@ -57,16 +57,16 @@ (define (test-magic-square-bracket which before after) (test - (string->symbol (format "scheme:test-magic-square-bracket-~a" which)) + (string->symbol (format "racket:test-magic-square-bracket-~a" which)) (λ (x) (equal? x after)) (λ () (queue-sexp-to-mred - `(let* ([t (new scheme:text%)] + `(let* ([t (new racket:text%)] [f (new frame% [label ""] [width 600] [height 600])] [ec (new editor-canvas% [parent f] [editor t])]) (send f reflow-container) (send t insert ,before) - (send (scheme:get-keymap) call-function "maybe-insert-[]-pair-maybe-fixup-[]" t (new event%)) + (send (racket:get-keymap) call-function "maybe-insert-[]-pair-maybe-fixup-[]" t (new event%)) (send t get-text)))))) (queue-sexp-to-mred `(preferences:set 'framework:automatic-parens #f))