Skip to content

Commit

Permalink
WIP: adjust the comment/uncomment support in DrRacket to be
Browse files Browse the repository at this point in the history 
sensitive to the #lang line

related to racket#634
  • Loading branch information
@rfindler
rfindler committed Sep 11, 2023
1 parent 03c5a12 commit 12a59da
Show file tree
Hide file tree
Showing 6 changed files with 188 additions and 47 deletions.
44 changes: 28 additions & 16 deletions drracket/drracket/private/in-irl-namespace.rkt
View file
Original file line number Diff line number Diff line change
Expand Up @@ -211,28 +211,40 @@
(-> object? any)
(or/c real? #f)))))]

[(drracket:opt-out-toolbar-buttons drscheme:opt-out-toolbar-buttons drracket:opt-in-toolbar-buttons)
[(drracket:opt-out-toolbar-buttons
drscheme:opt-out-toolbar-buttons
drracket:opt-in-toolbar-buttons)
(or/c #f (listof symbol?))]
[(drracket:paren-matches) (or/c #f (listof (list/c symbol? symbol?)))]
[(drracket:quote-matches) (or/c #f (listof char?))]
[(drracket:define-popup) (or/c #f
(non-empty-listof (list/c string? string? string?))
(non-empty-listof (list/c string? string? string?
(or/c #f
(-> read-only-text/c string? exact-integer?
(->* (read-only-text/c string? exact-integer?)
(#:case-sensitive? any/c
#:delimited? any/c)
(or/c exact-integer? #f))
(or/c exact-integer? #f)))
(or/c #f
(-> read-only-text/c exact-integer?
(-> read-only-text/c exact-integer?
string?)
string?)))))]
[(drracket:comment-delimiters)
(listof
(or/c (list/c 'line no-newline-string/c no-newline-string/c)
(list/c 'region
no-newline-string/c no-newline-string/c
no-newline-string/c no-newline-string/c)))]
[(drracket:define-popup)
(or/c #f
(non-empty-listof (list/c string? string? string?))
(non-empty-listof (list/c string? string? string?
(or/c #f
(-> read-only-text/c string? exact-integer?
(->* (read-only-text/c string? exact-integer?)
(#:case-sensitive? any/c
#:delimited? any/c)
(or/c exact-integer? #f))
(or/c exact-integer? #f)))
(or/c #f
(-> read-only-text/c exact-integer?
(-> read-only-text/c exact-integer?
string?)
string?)))))]
[else
(error 'key->contract "unknown key")]))

(define no-newline-string/c
(and/c string? (not/c #rx"[\r\n]")))

(define (get-read-language-last-position/inside) read-language-last-position)

(define (get-read-language-port-start+end/inside)
Expand Down
4 changes: 4 additions & 0 deletions drracket/drracket/private/insulated-read-language.rkt
View file
Original file line number Diff line number Diff line change
Expand Up @@ -44,6 +44,7 @@ Will not work with the definitions text surrogate interposition that
'definitions-text-surrogate
'drracket:paren-matches
'drracket:quote-matches
'drracket:comment-delimiters
'drracket:define-popup))

(provide
Expand Down Expand Up @@ -268,6 +269,9 @@ Will not work with the definitions text surrogate interposition that
(or val racket:default-paren-matches)]
[(drracket:quote-matches)
(or val (list #\" #\|))]
[(drracket:comment-delimiters)
(or val '((line ";;" " ")
(region "#|" "|#" " " " ")))]
[(drracket:define-popup)
(and val
(for/list ([val (in-list val)])
Expand Down
4 changes: 3 additions & 1 deletion drracket/drracket/private/local-member-names.rkt
View file
Original file line number Diff line number Diff line change
Expand Up @@ -63,7 +63,9 @@
set-oc-status

set-dep-paths
set-dirty-if-dep)
set-dirty-if-dep

update-comment-out-menu-items)

;; mode changing definitions text mixin
(define/provide-local-member-name
Expand Down
1 change: 1 addition & 0 deletions drracket/drracket/private/module-language-tools.rkt
View file
Original file line number Diff line number Diff line change
Expand Up @@ -541,6 +541,7 @@

(define frame (send (get-tab) get-frame))
(when (eq? (send (send frame get-current-tab) get-defs) this)
(send frame update-comment-out-menu-items)
(send frame when-initialized
(λ ()
(send frame update-func-defs)))))
Expand Down
178 changes: 150 additions & 28 deletions drracket/drracket/private/unit.rkt
View file
Original file line number Diff line number Diff line change
Expand Up @@ -2265,6 +2265,7 @@
(string-append " " (string-constant custom)))
" "))
(update-teachpack-menu)
(update-comment-out-menu-items)
(when (is-a? language-specific-menu menu%)
(define label (send language-specific-menu get-label))
(define new-label
Expand Down Expand Up @@ -3177,6 +3178,8 @@
(for-each (λ (ints-canvas) (send ints-canvas refresh))
interactions-canvases)
(set-color-status! (send definitions-text is-lexer-valid?))

(update-comment-out-menu-items)

(when (preferences:get 'drracket:save-files-on-tab-switch?)
(save-all-unsaved-files))
Expand Down Expand Up @@ -4639,34 +4642,8 @@
(f x 0 (send x last-position))))))]
[shortcut #\i]
[demand-callback (λ (m) (send m enable (cap-val)))]))

(make-object menu:can-restore-menu-item%
(string-constant box-comment-out-menu-item-label)
language-specific-menu
(send-method (λ (x) (send x box-comment-out-selection))))
(make-object menu:can-restore-menu-item%
(string-constant semicolon-comment-out-menu-item-label)
language-specific-menu
(send-method (λ (x) (send x comment-out-selection))))
(make-object menu:can-restore-menu-item%
(string-constant uncomment-menu-item-label)
language-specific-menu
(λ (x y)
(let ([text (get-focus-object)])
(when (is-a? text text%)
(let ([admin (send text get-admin)])
(cond
[(is-a? admin editor-snip-editor-admin<%>)
(let ([es (send admin get-snip)])
(cond
[(is-a? es comment-box:snip%)
(let ([es-admin (send es get-admin)])
(when es-admin
(let ([ed (send es-admin get-editor)])
(when (is-a? ed racket:text<%>)
(send ed uncomment-box/selection)))))]
[else (send text uncomment-selection)]))]
[else (send text uncomment-selection)]))))))

(update-comment-out-menu-items)

(set! insert-menu
(new (get-menu%)
Expand Down Expand Up @@ -4746,6 +4723,151 @@
(register-capability-menu-item 'drscheme:special:insert-lambda insert-menu))

(frame:reorder-menus this))

(define/public (update-comment-out-menu-items)
;; 1. clear out comment-related and following menu items,
;; saving the ones that follow
(define items-to-restore '())
(let loop ([items (send language-specific-menu get-items)]
[state 'found-nothing])
(cond
[(empty? items) (void)]
[else
(define item (car items))
(match state
['found-nothing
(cond
[(and (is-a? item labelled-menu-item<%>)
(equal? (string-constant box-comment-out-menu-item-label)
(send item get-label)))
(send item delete)
(loop (cdr items) 'found-comment-out-items)]
[else
(loop (cdr items) 'found-nothing)])]
['found-comment-out-items
(send item delete)
(loop (cdr items) (if (is-a? item separator-menu-item%)
'found-end-of-comment-out-items
'found-comment-out-items))]
['found-end-of-comment-out-items
(send item delete)
(set! items-to-restore (cons item items-to-restore))
(loop (cdr items) 'found-end-of-comment-out-items)])]))

;; 2. add box comment out
(make-object menu:can-restore-menu-item%
(string-constant box-comment-out-menu-item-label)
language-specific-menu
(λ (_1 _2)
(define text (get-edit-target-object))
(when (is-a? text racket:text<%>)
(send text box-comment-out-selection))))

;; 3. add comment-out directive menus from the language
(define line-comment-directives-found '())
(define (make-a-comment-out-menu-item comment-directive)
(define-values (menu-item-label callback comment-directive-key)
(match comment-directive
[(list 'line start padding)
(define lab (string-append start padding))
(values (format (string-constant comment-out-with-line-start)
lab)
(λ (text)
(send text comment-out-selection
#:start start
#:padding padding))
lab)]
[(list 'region start continue end padding)
(values (format (string-constant comment-out-with-region)
start end)
(λ (text)
(send text region-comment-out-selection
#:start start
#:continue continue
#:end end
#:padding padding))
(cons start end))]))
(unless (member comment-directive-key (map car line-comment-directives-found))
(set! line-comment-directives-found
(cons (cons comment-directive-key comment-directive)
line-comment-directives-found))
(new menu:can-restore-menu-item%
[label menu-item-label]
[parent language-specific-menu]
[callback
(λ (_1 _2)
(define text (get-edit-target-object))
(when (is-a? text racket:text<%>)
(callback text)))])))
(define all-comment-directives
(let* ([lang/config (send (get-definitions-text) get-next-settings)]
[lang (drracket:language-configuration:language-settings-language lang/config)])
(if (is-a? lang drracket:module-language:module-language<%>)
(call-read-language (send (get-definitions-text) get-irl)
'drracket:comment-delimiters
#f)
;; if we're not in the module language do what the old code used to do
(list (list 'line ";" "")))))
(for ([comment-directives (in-list all-comment-directives)]
#:when (< (length line-comment-directives-found) 5))
(make-a-comment-out-menu-item comment-directives))
(when (null? line-comment-directives-found)
;; would be better if this used the defaults
(make-a-comment-out-menu-item (list 'line ";" "")))
(set! line-comment-directives-found (reverse line-comment-directives-found))

;; 4. add uncomment menu item
(define (do-uncomment-selection text)
(when (is-a? text racket:text<%>)
(let/ec escape
(when (send text uncomment-selection/box)
(escape (void)))
(for ([comment-directive (in-list (map cdr line-comment-directives-found))])
(match comment-directive
[(list 'line start padding)
(when (send text commented-out/line?
#:start start
#:padding padding)
(send text uncomment-selection/line
#:start start
#:padding padding)
(escape (void)))]
[(list 'region start continue end padding)
(when (send text commented-out/region?
#:start start
#:end end
#:continue continue)
(send text uncomment-selection/region
#:start start
#:end end
#:continue continue
#:padding padding)
(escape (void)))])))))
(make-object menu:can-restore-menu-item%
(string-constant uncomment-menu-item-label)
language-specific-menu
(λ (x y)
(let ([text (get-focus-object)])
(when (is-a? text text%)
(let ([admin (send text get-admin)])
(cond
[(is-a? admin editor-snip-editor-admin<%>)
(let ([es (send admin get-snip)])
(cond
[(is-a? es comment-box:snip%)
(let ([es-admin (send es get-admin)])
(when es-admin
(let ([ed (send es-admin get-editor)])
(when (is-a? ed racket:text<%>)
(send ed uncomment-box/selection)))))]
[else (do-uncomment-selection text)]))]
[else (do-uncomment-selection text)]))))))
(new separator-menu-item% [parent language-specific-menu])

;; 5. restore removed menu items
(for ([item (in-list (reverse items-to-restore))])
(send item restore))
(void))

(define/public (jump-to-previous-error-loc)
(define-values (before after sorted) (find-before-and-after))
Expand Down
4 changes: 2 additions & 2 deletions drracket/info.rkt
View file
Original file line number Diff line number Diff line change
Expand Up @@ -18,10 +18,10 @@
"sandbox-lib"
("scribble-lib" #:version "1.11")
("snip-lib" #:version "1.2")
["string-constants-lib" #:version "1.44"]
["string-constants-lib" #:version "1.45"]
"typed-racket-lib"
"wxme-lib"
["gui-lib" #:version "1.69"]
["gui-lib" #:version "1.70"]
("racket-index" #:version "1.2")
["racket-doc" #:version "1.1"]
"html-lib"
Expand Down

0 comments on commit 12a59da

Please sign in to comment.