126 lines
4.5 KiB
Scheme
126 lines
4.5 KiB
Scheme
|
|
#lang scheme/unit
|
|
|
|
(require mzlib/class
|
|
mzlib/etc
|
|
mred
|
|
"sig.ss"
|
|
"../decorated-editor-snip.ss"
|
|
(lib "include-bitmap.ss" "mrlib")
|
|
string-constants)
|
|
|
|
(import [prefix text: framework:text^]
|
|
[prefix scheme: framework:scheme^]
|
|
[prefix keymap: framework:keymap^])
|
|
(export (rename framework:comment-box^
|
|
(-snip% snip%)))
|
|
|
|
(define snipclass%
|
|
(class decorated-editor-snipclass%
|
|
(define/override (make-snip stream-in) (instantiate -snip% ()))
|
|
(super-instantiate ())))
|
|
|
|
(define snipclass (make-object snipclass%))
|
|
(send snipclass set-version 1)
|
|
(send snipclass set-classname (format "~s" '(lib "comment-snip.ss" "framework")))
|
|
(send (get-the-snip-class-list) add snipclass)
|
|
|
|
(define bm (include-bitmap (lib "semicolon.gif" "icons")))
|
|
|
|
(define (editor-keymap-mixin %)
|
|
(class %
|
|
(define/override (get-keymaps)
|
|
(cons (keymap:get-file) (super get-keymaps)))
|
|
(super-instantiate ())))
|
|
|
|
(define scheme+copy-self% #f)
|
|
(define (get-scheme+copy-self%)
|
|
(unless scheme+copy-self%
|
|
(set! scheme+copy-self%
|
|
(class scheme:text%
|
|
(inherit copy-self-to)
|
|
(define/override (copy-self)
|
|
(let ([ed (new scheme+copy-self%)])
|
|
(copy-self-to ed)
|
|
ed))
|
|
(super-new))))
|
|
scheme+copy-self%)
|
|
|
|
(define -snip%
|
|
(class* decorated-editor-snip% (readable-snip<%>)
|
|
(inherit get-editor get-style)
|
|
|
|
(define/override (make-editor) (new (get-scheme+copy-self%)))
|
|
(define/override (make-snip) (make-object -snip%))
|
|
(define/override (get-corner-bitmap) bm)
|
|
(define/override (get-position) 'left-top)
|
|
|
|
(define/override get-text
|
|
(opt-lambda (offset num [flattened? #t])
|
|
(let* ([super-res (super get-text offset num flattened?)]
|
|
[replaced (string-append "; " (regexp-replace* "\n" super-res "\n; "))])
|
|
(if (char=? #\newline (string-ref replaced (- (string-length replaced) 1)))
|
|
replaced
|
|
(string-append replaced "\n")))))
|
|
|
|
|
|
(define/override (get-menu)
|
|
(let ([menu (make-object popup-menu%)])
|
|
(make-object menu-item%
|
|
(string-constant convert-to-semicolon-comment)
|
|
menu
|
|
(λ (x y)
|
|
(let ([to-ed (find-containing-editor)])
|
|
(when to-ed
|
|
(let ([this-pos (find-this-position)])
|
|
(when this-pos
|
|
(let ([from-ed (get-editor)])
|
|
(send to-ed begin-edit-sequence)
|
|
(send from-ed begin-edit-sequence)
|
|
(copy-contents-with-semicolons-to-position to-ed from-ed (+ this-pos 1))
|
|
(send to-ed delete this-pos (+ this-pos 1))
|
|
(send to-ed end-edit-sequence)
|
|
(send from-ed end-edit-sequence))))))))
|
|
menu))
|
|
|
|
(inherit get-admin)
|
|
;; find-containing-editor : -> (union #f editor)
|
|
(define/private (find-containing-editor)
|
|
(let ([admin (get-admin)])
|
|
(and admin
|
|
(send admin get-editor))))
|
|
|
|
;; find-this-position : -> (union #f number)
|
|
(define/private (find-this-position)
|
|
(let ([ed (find-containing-editor)])
|
|
(and ed
|
|
(send ed get-snip-position this))))
|
|
|
|
;; copy-contents-with-semicolons-to-position : (is-a? text%) number -> void
|
|
(define/private (copy-contents-with-semicolons-to-position to-ed from-ed pos)
|
|
(let loop ([snip (find-last-snip from-ed)])
|
|
(cond
|
|
[snip
|
|
(when (or (memq 'hard-newline (send snip get-flags))
|
|
(memq 'newline (send snip get-flags)))
|
|
(send to-ed insert "; " pos))
|
|
(send to-ed insert (send snip copy) pos)
|
|
(loop (send snip previous))]
|
|
[else
|
|
(send to-ed insert "; " pos)])))
|
|
|
|
;; find-last-snip : editor -> snip
|
|
;; returns the last snip in the editor
|
|
(define/private (find-last-snip ed)
|
|
(let loop ([snip (send ed find-first-snip)]
|
|
[acc (send ed find-first-snip)])
|
|
(cond
|
|
[snip (loop (send snip next) snip)]
|
|
[else acc])))
|
|
|
|
(define/public (read-special source line column position)
|
|
(make-special-comment "comment"))
|
|
(super-instantiate ())
|
|
(inherit set-snipclass)
|
|
(set-snipclass snipclass)))
|