#lang scheme/gui (require framework embedded-gui srfi/2 ;; and-let* scheme/runtime-path ;; XXX -- the below is my own impl of scheme:text-balanced?, which ;; wasn't working properly for my purposes. "balanced-scheme-text.ss" ) (provide anno-snipclass% anno-snip%) ;; Icon for top-left of snip's visual rep: (define-runtime-path ICON-PATH '(lib "annotated-snip/expr.png")) (define ICON (make-object bitmap% ICON-PATH)) (define-runtime-path ICON2-PATH '(lib "annotated-snip/unbalanced-expr.png")) (define UNBALANCED-ICON (make-object bitmap% ICON2-PATH)) (define annotate-item-label-string "Annotate this S-expression") (define MIN-TEXT-WIDTH 40) ;; minimum width/ht of a code or anno editor (define MIN-TEXT-HEIGHT 18) ;;;;;;;;;; Snipclassery (for cut/paste) ;;;;;;;;;;; ; ; ; ; ; ;;; ; ; ; ; ; ;;;; ; ;;; ;;; ; ;;; ;;;; ; ;;;; ;;;; ;;;; ; ; ; ;; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ;; ;; ; ;; ; ; ; ; ; ; ; ; ; ;; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ;;;; ; ; ;;; ;;;; ;;;; ;;; ;;; ; ;;;; ;;;; ; ; ; ; ; ; ;; framework/private/comment-box.ss lines 23-31 (define anno-snipclass% (class decorated-editor-snipclass% (define/override (make-snip stream-in) (new anno-snip%)) ;; editor-stream-in% -> anno-snip% ;; Reads an anno-snip% (contents and show/hide-code state) from the stream. (define/override (read in) (let* ([s (new anno-snip%)] [pb (send s get-editor)]) (let ([code-ed (send pb get-code-editor)] [anno-ed (send pb get-anno-editor)] [show-code? (box -1)]) (send in get show-code?) ;; 0,1 <==> false,true (send code-ed read-from-file in 'start) (send anno-ed read-from-file in 'start) (send pb show-code (= (unbox show-code?) 1)) s))) (super-new))) (define snipclass (make-object anno-snipclass%)) (send snipclass set-version 1) (send snipclass set-classname (format "~s" '(lib annotated-snip/code-desc-snip))) (send (get-the-snip-class-list) add snipclass) ;; Snip representing an annotated chunk of code. (define anno-snip% (class* decorated-editor-snip% (readable-snip<%>) (inherit get-editor) (define/override (make-editor) (new anno-pb%)) (define/override (make-snip) (new anno-snip%)) ;;;;;;; icon ;; Generates the icon for the top-left of the snip; indicates whether ;; the contents of the code editor form a balanced s-exp. (define/override (get-corner-bitmap) (or (and-let* ([pb (get-editor)] [code (and (pb . is-a? . anno-pb%) (send pb get-code-editor))]) (and (send code contains-balanced-sexp?) ICON)) UNBALANCED-ICON)) (define/override (get-position) 'left-top) ;; get-text...see framework/private/comment-box.ss line 59 (define/override (get-text offset num [flattened? #t]) ; (printf "[get-text ~s ~s ~s]~n" offset num flattened?) (if flattened? (let ([pb (get-editor)]) (let ([code (send (send pb get-code-editor) get-text 0)] [anno (send (send pb get-anno-editor) get-text 0)]) (if (string=? anno "") code (let ([commented-anno (regexp-replace* "\n" anno "\n; ")]) (if (char=? #\newline (string-ref commented-anno (- (string-length commented-anno) 1))) (string-append code "\n; " commented-anno) (string-append code "\n; " commented-anno "\n")))))) ".")) ;; -> (is-a? popup-menu% ;; Generate a context menu with three options: show/hide code, ;; convert to commented text, or convert to unannotated code. (define/override (get-menu) (let ([menu (make-object popup-menu%)]) (define (copy-callback perform-copy) (λ (_ __) (let ([to-ed (find-containing-editor)]) (when to-ed (let ([this-pos (find-this-position)]) (when this-pos (let* ([from-ed (get-editor)] [from-code (send from-ed get-code-editor)] [from-anno (send from-ed get-anno-editor)]) (send to-ed begin-edit-sequence) (send from-ed begin-edit-sequence) (perform-copy to-ed from-code from-anno (+ this-pos 1)) (send to-ed delete this-pos (+ this-pos 1)) (send to-ed end-edit-sequence) (send from-ed end-edit-sequence)))))))) (make-show/hide-code-item (get-editor) menu) (make-object menu-item% "convert to commented text" menu (copy-callback (λ (to-ed from-code from-anno dest-pos) (if (newline-after-this?) (copy-contents-with-semicolons-to-position to-ed from-anno dest-pos) (begin ;; use inline comment (send to-ed insert "|#" dest-pos) (copy-contents-to-position to-ed from-anno dest-pos) (send to-ed insert "#|" dest-pos))) (send to-ed insert #\space dest-pos) (copy-contents-to-position to-ed from-code dest-pos)))) (make-object menu-item% "convert to un-annotated text" menu (copy-callback (λ (to-ed from-code from-anno dest-pos) (copy-contents-to-position to-ed from-code dest-pos)))) menu)) ;; -> bool ;; true iff a newline follows this snip (inherit get-flags) (define (newline-after-this?) (let ([flags (get-flags)]) (or (memq 'hard-newline flags) (memq 'newline flags)))) ;;;;;; Helpers from framework/private/comment-box.ss (lines 85&ff.) ;; (used by the above menu items) (inherit get-admin) ;; find-containing-editor : -> (union #f editor) ;; the editor containing this snip, or #f if none contains it (define/private (find-containing-editor) (let ([admin (get-admin)]) (and admin (send admin get-editor)))) ;; find-this-position : -> (union #f number) ;; index of this snip in the containing editor (or #f if none contains it) (define/private (find-this-position) (let ([ed (find-containing-editor)]) (and ed (send ed get-snip-position this)))) ;;;;;; readable-snip<%> implementation ;; returns the parsed contents of the code editor (define/public (read-special file line col pos) (let* ([ip (open-input-text-editor (send (get-editor) get-code-editor))] [expr (read ip)]) (close-input-port ip) (datum->syntax #f expr (list file line col pos 1)))) ;;;;;; copy+paste ;; editor-stream-out% -> void ;; Write this editor's state (i.e., showing-code? and contents) to the ;; given stream. (define/override (write stream-out) (let ([pb (get-editor)]) (let ([code (send pb get-code-editor)] [anno (send pb get-anno-editor)]) (send stream-out put (if (send pb showing-code?) 1 0)) (send code write-to-file stream-out) (send anno write-to-file stream-out)))) ;; -> anno-snip% ;; return a copy of this snip (define/override (copy) (let* ([s (new anno-snip%)] [pb (send (get-editor) copy-self)]) (send s set-editor pb) s)) (super-new) (inherit set-snipclass) (set-snipclass snipclass) )) ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ;;;; ; ;;; ; ;;; ;; ; ;;; ; ;;; ; ; ; ; ; ; ;; ; ;; ; ; ; ;; ; ;; ; ;; ; ; ; ; ; ; ; ; ; ; ;;;;;;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;; ; ; ; ; ; ;; ;;;; ;;;; ; ;; ; ; ; ; ; ; (define caches-balanced<%> (interface ((class->interface scheme:text%)) contains-balanced-sexp?)) (define anno-pb% (let () (define (find-owner-snip ed) ;; editor<%> -> (union #f editor-snip%) (let ([admin (send ed get-admin)]) (and admin (admin . is-a? . editor-snip-editor-admin<%>) (send admin get-snip)))) (define scheme+copy-self% ;; (From framework/private/comment-box.ss.) (class* scheme:text% (caches-balanced<%>) ;; class for the code editor. (define currently-balanced-expr #f) (inherit copy-self-to) (define/override (copy-self) (let ([ed (new scheme+copy-self%)]) (copy-self-to ed) ed)) (define/augment (after-edit-sequence) ;; FIXME replace text-balanced? when PLT fixes scheme:text-balanced?. (set! currently-balanced-expr (text-balanced? this))) (define/public (contains-balanced-sexp?) currently-balanced-expr) (super-new) (inherit set-max-undo-history) (set-max-undo-history 'forever))) (class aligned-pasteboard% (super-new) ;;;;;;; Component editors: ;; -> (union #f text%) (define/public (get-code-editor) code-editor) (define/public (make-code-editor) (new (tabbable-text-mixin scheme+copy-self%))) ;; -> (union #f text%) (define/public (get-anno-editor) anno-editor) (define/public (make-anno-editor) (new (tabbable-text-mixin (editor:keymap-mixin text:basic%)))) (define code-editor (make-code-editor)) ;; code box's editor (define anno-editor (make-anno-editor)) ;; annotation box's (set-tabbing code-editor anno-editor) ;;;;;;; Container snips for the text editors: (define val (new vertical-alignment% [parent this])) ;; Container for the code box. I'm using this for the ability to ;; show/hide the box: (define code-view (new vertical-alignment% [parent val] [show? #f])) ;; Installs stretchable editor snips, if none are already installed, ;; to contain the code and anno editors. ;; (Does nothing if they already are installed, and returns #f.) ;; Returns #t if successful. (define (init-snips) (define component-snip% (class stretchable-editor-snip% (super-new))) (if (not (or (find-owner-snip code-editor) (find-owner-snip anno-editor))) (let ([code-snip (new component-snip% [editor code-editor] [with-border? #t] [min-width 50])] [anno-snip (new component-snip% [editor anno-editor] [with-border? #f] [min-width 50])]) (make-object snip-wrapper% code-view code-snip) (make-object hline% code-view) (make-object snip-wrapper% val anno-snip) #t) #f)) (init-snips) ;;;;;;;;; show/hide code ;;;;;;;;; (define showing-code #f) (define/public (showing-code?) showing-code) (define/public (show-code on/off) (send code-view show on/off) (set! showing-code on/off)) ;;;;;;;;; copy+paste ;;;;;;;;; (define/override (copy-self) (let ([ed (new anno-pb%)]) (let ([ed-code (send ed get-code-editor)] [ed-anno (send ed get-anno-editor)]) (send (get-code-editor) copy-self-to ed-code) (send (get-anno-editor) copy-self-to ed-anno) (send ed show-code (showing-code?)) ed))) ))) ;; (is-a? anno-pb%) (is-a? popup-menu%) -> void ;; add an item to the given menu for showing/hiding the code portion of ;; the given object. (define (make-show/hide-code-item pb menu) (let ([showing-code-now? (send pb showing-code?)]) (new menu-item% [label (if showing-code-now? "Hide program text" "Show program text")] [parent menu] [callback (lambda (item evt) (send pb show-code (not showing-code-now?)))]))) ;; copy-contents-with-semicolons-to-position : (is-a? text%) (is-a? text%) number -> void ;; Copies from-ed to position pos in to-ed. ;; From framework/private/comment-box.ss (line 99). (define (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)]))) ;; copy-contents-to-position : (is-a? text%) (is-a? text%) number -> void ;; As above, but no semicolons. (define (copy-contents-to-position to-ed from-ed pos) (let loop ([snip (find-last-snip from-ed)]) (when snip (send to-ed insert (send snip copy) pos) (loop (send snip previous))))) ;; find-last-snip : editor -> snip ;; returns the last snip in the given editor. ;; From framework/private/comment-box.ss (line 112) (define (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]))) ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ;; ;;; ; ;;; ; ; ; ; ;; ;; ; ; ; ;; ;; ; ; ; ;; ; ; ; ; ;; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;;;;; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ;;;; ; ; ;;; ; ; ; ; ; ; ; ; ; ; #;(keymap:add-to-right-button-menu (let ([old (keymap:add-to-right-button-menu)]) (λ (menu ed event) (old menu ed event) ;; build preexisting menu items (add-annotate-to-menu menu ed event) (void)))) ;; add-annotate-to-menu : (instanceof menu%) (instanceof editor<%>) ;; (instanceof mouse-event%) -> void ;; Attaches an "annotate this s-exp" menu item to the given menu, for ;; annotating the s-exp under the mouse cursor. ;; (From framework/private/scheme.ss line 160ff.) (define (add-annotate-to-menu menu text event) (when (and (text . is-a? . scheme:text%) (not (send text is-frozen?)) (not (send text is-stopped?))) (let* ([on-it-box (box #f)] [click-pos (call-with-values (λ () (send text dc-location-to-editor-location (send event get-x) (send event get-y))) (λ (x y) (send text find-position x y #f on-it-box)))] [snip (send text find-snip click-pos 'after)] [char (send text get-character click-pos)] [left? (memq char '(#\( #\{ #\[))] [right? (memq char '(#\) #\} #\]))]) (cond ; [(and snip (snip . is-a? . anno-snip%)) ; ;; may be able to attach to hide/show menu options here. ; (void)] [(not (unbox on-it-box)) ;; clicking in nowhere land, just ignore (void)] [(or left? right?) ;; clicking on a 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-annotate-item text left-pos right-pos menu))))] [else ;; clicking on some other text: annotate the containing sexp (let ([up-sexp (send text find-up-sexp click-pos)]) (when up-sexp (let ([fwd (send text get-forward-sexp up-sexp)]) (make-annotate-item text up-sexp fwd menu))))])))) ;; make-annotate-item : (instanceof text%) num num (instanceof menu%) -> void ;; adds an "annotate this s-exp" item to the given menu (define (make-annotate-item text L R menu) (new separator-menu-item% [parent menu]) (new menu-item% [parent menu] [label annotate-item-label-string] [callback (λ (item evt) (convert-to-annotated-sexp text L R))])) ;; (instanceof text%) num num -> void ;; Replaces the contents of text between left-pos and right-pos with an ;; anno-snip% whose code-editor contains those contents. (define (convert-to-annotated-sexp text L R) (send text begin-edit-sequence) (send text split-snip L) (send text split-snip R) (let ([snips (let loop ([snip (send text find-snip L 'after)]) (cond [(not snip) null] [((send text get-snip-position snip) . >= . R) null] [else (cons (send snip copy) (loop (send snip next)))]))]) (send text delete L R) (let* ([ann-snip (new anno-snip%)] [pb (send ann-snip get-editor)] [code-ed (send pb get-code-editor)]) (for-each (lambda (snip) (send code-ed insert snip)) snips) (send pb show-code #t) (send text insert ann-snip L L) (send text end-edit-sequence) ;(send text set-caret-owner ann-snip) ))) ;;;;;;;;;;;;;;;;;;;;;;;;; DrScheme menus ;;;;;;;;;;;;;;;;;;;;;;;;; ;; Add an "Insert annotated expression" item to the Insert menu: #;(let () (define (text-box-mixin %) ;; based on xml/text-box-tool.ss lines 21ff. (class % (inherit get-insert-menu get-edit-target-object register-capability-menu-item) (super-new) (new menu-item% [label annotate-item-label-string] [parent (get-insert-menu)] [callback (λ (menu evt) (let ([anno-snip (new anno-snip%)] [text (get-edit-target-object)]) (send text insert anno-snip) (send text set-caret-owner anno-snip 'global)))]) (register-capability-menu-item 'drscheme:special:insert-anno-snip (get-insert-menu)) )) (drscheme:get/extend:extend-unit-frame text-box-mixin) (drscheme:language:register-capability 'drscheme:special:insert-text-box (flat-contract boolean?) #t)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; ; ; ; ; ; ; ; ; ;;; ;;;; ; ;;;; ; ;;;;;; ; ; ; ; ;;;;;; ; ; ; ; ; ; ; ; ; ; ; ;;;;;; ;; ; ;; ; ; ; ;; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;; ;;;; ;;;; ;;; ;;;; ; ; ; (define ts #f) ; test snip (define (test-w/text%) (define test-snip (new anno-snip%)) (define test-pb (send test-snip get-editor)) (define txt (new scheme:text%)) (define f (mk-test-frame)) (define c (new editor-canvas% [parent f][editor txt])) (send txt set-max-undo-history 'forever) (send txt insert "\n(* x 3)\n4))" 0) (send txt insert test-snip 0) (send txt insert "(define (f x)\n(+ " 0) (send txt tabify-all) (send f show #t) (set! ts test-snip) txt ) (define (mk-test-frame) (new frame% [label "Annotated code snip test"] [width 500] [height 300] [alignment '(center center)])) (define t (test-w/text%))