(module frame mzscheme (require (lib "string-constant.ss" "string-constants") (lib "unitsig.ss") (lib "class.ss") (lib "include.ss") "sig.ss" "../gui-utils.ss" "bday.ss" (lib "mred-sig.ss" "mred") (lib "list.ss") (lib "file.ss") (lib "etc.ss")) (provide frame@) (define frame@ (unit/sig framework:frame^ (import mred^ [group : framework:group^] [preferences : framework:preferences^] [icon : framework:icon^] [handler : framework:handler^] [application : framework:application^] [panel : framework:panel^] [finder : framework:finder^] [keymap : framework:keymap^] [text : framework:text^] [pasteboard : framework:pasteboard^] [editor : framework:editor^] [canvas : framework:canvas^] [menu : framework:menu^] [scheme : framework:scheme^] [exit : framework:exit^] [comment-box : framework:comment-box^]) (rename [-editor<%> editor<%>] [-pasteboard% pasteboard%] [-text% text%]) (define (reorder-menus frame) (let* ([items (send (send frame get-menu-bar) get-items)] [move-to-back (λ (name items) (let loop ([items items] [back null]) (cond [(null? items) back] [else (let ([item (car items)]) (if (string=? (send item get-plain-label) name) (loop (cdr items) (cons item back)) (cons item (loop (cdr items) back))))])))] [move-to-front (λ (name items) (reverse (move-to-back name (reverse items))))] [re-ordered (move-to-front (string-constant file-menu) (move-to-front (string-constant edit-menu) (move-to-back (string-constant help-menu) (move-to-back (string-constant windows-menu) items))))]) (for-each (λ (item) (send item delete)) items) (for-each (λ (item) (send item restore)) re-ordered))) (define (add-snip-menu-items edit-menu c%) (let* ([get-edit-target-object (λ () (let ([menu-bar (let loop ([p (send edit-menu get-parent)]) (cond [(is-a? p menu-bar%) p] [(is-a? p menu%) (loop (send p get-parent))] [else #f]))]) (and menu-bar (let ([frame (send menu-bar get-frame)]) (send frame get-edit-target-object)))))] [edit-menu:do (λ (const) (λ (menu evt) (let ([edit (get-edit-target-object)]) (when (and edit (is-a? edit editor<%>)) (send edit do-edit-operation const))) #t))] [on-demand (λ (menu-item) (let ([edit (get-edit-target-object)]) (send menu-item enable (and edit (is-a? edit editor<%>)))))] [insert-comment-box (λ () (let ([text (get-edit-target-object)]) (when text (let ([snip (make-object comment-box:snip%)]) (send text insert snip) (send text set-caret-owner snip 'global)))))]) (make-object c% (string-constant insert-comment-box-menu-item-label) edit-menu (λ (x y) (insert-comment-box)) #f #f on-demand) (make-object c% (string-constant insert-image-item) edit-menu (edit-menu:do 'insert-image) #f #f on-demand) (void))) (define frame-width 600) (define frame-height 650) (let ([window-trimming-upper-bound-width 20] [window-trimming-upper-bound-height 50]) (let-values ([(w h) (get-display-size)]) (set! frame-width (min frame-width (- w window-trimming-upper-bound-width))) (set! frame-height (min frame-height (- h window-trimming-upper-bound-height))))) (define basic<%> (interface ((class->interface frame%)) get-area-container% get-area-container get-menu-bar% make-root-area-container close editing-this-file? get-filename make-visible)) (define basic-mixin (mixin ((class->interface frame%)) (basic<%>) (define/override (show on?) (if on? (send (group:get-the-frame-group) insert-frame this) (send (group:get-the-frame-group) remove-frame this)) (super show on?)) (define/override (can-exit?) (and (exit:user-oks-exit) (begin (exit:set-exiting #t) (let ([res (exit:can-exit?)]) (unless res (exit:set-exiting #f)) res)))) (define/override (on-exit) (exit:on-exit) (queue-callback (λ () (exit) (exit:set-exiting #f)))) (define/public (make-visible filename) (void)) (define/public get-filename (case-lambda [() (get-filename #f)] [(b) #f])) (define/public (editing-this-file? filename) #f) (define/override (on-superwindow-show shown?) (send (group:get-the-frame-group) frame-shown/hidden this) (super on-superwindow-show shown?)) (define after-init? #f) (define/override on-drop-file (λ (filename) (handler:edit-file filename))) ;; added call to set label here to hopefully work around a problem in mac mred (inherit set-label change-children) (define/override after-new-child (λ (child) (when after-init? (change-children (λ (l) (remq child l))) (error 'frame:basic-mixin "do not add children directly to a frame:basic (unless using make-root-area-container); use the get-area-container method instead" )))) (define/public get-area-container% (λ () vertical-panel%)) (define/public get-menu-bar% (λ () menu-bar%)) (define/public make-root-area-container (λ (% parent) (make-object % parent))) (inherit can-close? on-close) (define/public close (λ () (when (can-close?) (on-close) (show #f)))) (inherit accept-drop-files) (super-new) (accept-drop-files #t) (let ([mb (make-object (get-menu-bar%) this)]) (when (or (eq? (system-type) 'macos) (eq? (system-type) 'macosx)) (make-object menu:can-restore-underscore-menu% (string-constant windows-menu-label) mb))) (reorder-menus this) [define panel (make-root-area-container (get-area-container%) this)] (define/public (get-area-container) panel) (set! after-init? #t))) (define size-pref<%> (interface (basic<%>))) (define size-pref-mixin (mixin (basic<%>) (size-pref<%>) (init-field size-preferences-key) (define/override (on-size w h) (preferences:set size-preferences-key (list w h))) (let ([lst (preferences:get size-preferences-key)]) (super-new [width (car lst)] [height (cadr lst)])))) (define (setup-size-pref size-preferences-key w h) (preferences:set-default size-preferences-key (list w h) (λ (x) (and (pair? x) (pair? (cdr x)) (null? (cddr x)) (number? (car x)) (number? (cadr x)))))) (define register-group<%> (interface ())) (define register-group-mixin (mixin (basic<%>) (register-group<%>) (define/augment (can-close?) (let ([number-of-frames (length (send (group:get-the-frame-group) get-frames))]) (and (inner #t can-close?) (or (not (preferences:get 'framework:exit-when-no-frames)) (exit:exiting?) (not (= 1 number-of-frames)) (exit:user-oks-exit))))) (define/augment (on-close) (send (group:get-the-frame-group) remove-frame this) (inner (void) on-close) (when (preferences:get 'framework:exit-when-no-frames) (unless (exit:exiting?) (when (null? (send (group:get-the-frame-group) get-frames)) (exit:exit))))) (define/override (on-activate on?) (super on-activate on?) (when on? (send (group:get-the-frame-group) set-active-frame this))) (super-new) (send (group:get-the-frame-group) insert-frame this))) (define locked-message (string-constant read-only)) (define unlocked-message (string-constant read/write)) (define lock-canvas% (class canvas% (field [locked? #f]) (define/public (set-locked l) (set! locked? l) (on-paint)) (inherit get-client-size get-dc) (define/override (on-paint) (let* ([dc (get-dc)] [draw (λ (str bg-color bg-style line-color line-style) (send dc set-font normal-control-font) (let-values ([(w h) (get-client-size)] [(tw th ta td) (send dc get-text-extent str)]) (send dc set-pen (send the-pen-list find-or-create-pen line-color 1 line-style)) (send dc set-brush (send the-brush-list find-or-create-brush bg-color bg-style)) (send dc draw-rectangle 0 0 w h) (send dc draw-text str (- (/ w 2) (/ tw 2)) (- (/ h 2) (/ th 2)))))]) (if locked? (draw locked-message "yellow" 'solid "black" 'solid) (draw unlocked-message (get-panel-background) 'transparent (get-panel-background) 'transparent)))) (inherit get-parent min-width min-height stretchable-width stretchable-height) (super-new [style '(transparent)]) (let ([dc (get-dc)]) (send dc set-font normal-control-font) (let-values ([(w1 h1 _1 _2) (send dc get-text-extent locked-message)] [(w2 h2 _3 _4) (send dc get-text-extent unlocked-message)]) (stretchable-width #f) (stretchable-height #t) (min-width (inexact->exact (floor (max w1 w2)))) (min-height (inexact->exact (floor (+ 4 (max h1 h2))))))))) (define status-line<%> (interface (basic<%>) open-status-line close-status-line update-status-line)) ;; status-line : (make-status-line symbol number) (define-struct status-line (id count)) ;; status-line-msg : (make-status-line-msg (is-a?/c message%) (union symbol #f)) (define-struct status-line-msg (message id)) (define status-line-mixin (mixin (basic<%>) (status-line<%>) (field [status-line-container-panel #f] ;; status-lines : (listof status-line) [status-lines null] ;; status-line-msgs : (listof status-line-msg) [status-line-msgs null]) (define/override (make-root-area-container % parent) (let* ([s-root (super make-root-area-container vertical-panel% parent)] [r-root (make-object % s-root)]) (set! status-line-container-panel (instantiate vertical-panel% () (parent s-root) (stretchable-height #f))) r-root)) (define/public (open-status-line id) (do-main-thread (λ () (when status-line-container-panel (set! status-lines (let loop ([status-lines status-lines]) (cond [(null? status-lines) (list (make-status-line id 1))] [else (let ([status-line (car status-lines)]) (if (eq? id (status-line-id status-line)) (cons (make-status-line id (+ (status-line-count status-line) 1)) (cdr status-lines)) (cons status-line (loop (cdr status-lines)))))]))))))) (define/public (close-status-line id) (do-main-thread (λ () (when status-line-container-panel ;; decrement counter in for status line, or remove it if ;; counter goes to zero. (set! status-lines (let loop ([status-lines status-lines]) (cond [(null? status-lines) (error 'close-status-line "status line not open ~e" id)] [else (let* ([status-line (car status-lines)] [this-line? (eq? (status-line-id status-line) id)]) (cond [(and this-line? (= 1 (status-line-count status-line))) (cdr status-lines)] [this-line? (cons (make-status-line id (- (status-line-count status-line) 1)) (cdr status-lines))] [else (cons status-line (loop (cdr status-lines)))]))]))) ;; make sure that there are only as many messages as different status lines, in total (let ([status-line-msg (find-status-line-msg id)]) (when status-line-msg (send (status-line-msg-message status-line-msg) set-label "") (set-status-line-msg-id! status-line-msg #f))) (let* ([msgs-that-can-be-removed (filter (λ (x) (not (status-line-msg-id x))) status-line-msgs)] [max-to-include (length status-lines)] [msgs-to-remove (let loop ([n max-to-include] [l msgs-that-can-be-removed]) (cond [(null? l) l] [(zero? n) l] [else (loop (- n 1) (cdr l))]))]) (send status-line-container-panel change-children (λ (old-children) (foldl (λ (status-line-msg l) (remq (status-line-msg-message status-line-msg) l)) old-children msgs-to-remove))) (set! status-line-msgs (let loop ([l msgs-to-remove] [status-line-msgs status-line-msgs]) (cond [(null? l) status-line-msgs] [else (loop (cdr l) (remq (car l) status-line-msgs))])))))))) ;; update-status-line : symbol (union #f string) (define/public (update-status-line id msg-txt) (do-main-thread (λ () (unless (open-status-line? id) (error 'update-status-line "unknown id ~e, other arg ~e" id msg-txt)) (if msg-txt (cond [(find-status-line-msg id) => (λ (existing-status-line-msg) (let ([msg (status-line-msg-message existing-status-line-msg)]) (unless (equal? (send msg get-label) msg-txt) (send msg set-label msg-txt))))] [(find-available-status-line-msg) => (λ (available-status-line-msg) (send (status-line-msg-message available-status-line-msg) set-label msg-txt) (set-status-line-msg-id! available-status-line-msg id))] [else (set! status-line-msgs (cons (make-new-status-line-msg id msg-txt) status-line-msgs))]) (let ([status-line-msg (find-status-line-msg id)]) (when status-line-msg (send (status-line-msg-message status-line-msg) set-label "") (set-status-line-msg-id! status-line-msg #f))))))) ;; open-status-line? : symbol -> boolean (define/private (open-status-line? id) (let loop ([status-lines status-lines]) (cond [(null? status-lines) #f] [else (let ([status-line (car status-lines)]) (or (eq? (status-line-id status-line) id) (loop (cdr status-lines))))]))) ;; find-available-status-line-msg : -> (union #f status-line-msg) (define/private (find-available-status-line-msg) (let loop ([status-line-msgs status-line-msgs]) (cond [(null? status-line-msgs) #f] [else (let ([status-line-msg (car status-line-msgs)]) (if (status-line-msg-id status-line-msg) (loop (cdr status-line-msgs)) status-line-msg))]))) ;; find-status-line-msg : symbol -> (union #f status-line-msg) (define/private (find-status-line-msg id) (let loop ([status-line-msgs status-line-msgs]) (cond [(null? status-line-msgs) #f] [else (let ([status-line-msg (car status-line-msgs)]) (if (eq? id (status-line-msg-id status-line-msg)) status-line-msg (loop (cdr status-line-msgs))))]))) ;; make-new-status-line-msg : symbol string -> status-line-msg (define/private (make-new-status-line-msg id msg-txt) (make-status-line-msg (instantiate message% () (parent status-line-container-panel) (stretchable-width #t) (label msg-txt)) id)) (field [eventspace-main-thread (current-thread)]) ;; replace by using new primitive in 203.5 called eventspace-main-thread (inherit get-eventspace) (define/private (do-main-thread t) (if (eq? (current-thread) eventspace-main-thread) (t) (parameterize ([current-eventspace (get-eventspace)]) ;; need high priority callbacks to ensure ordering wrt other callbacks (queue-callback t #t)))) (super-instantiate ()))) (define info<%> (interface (basic<%>) determine-width lock-status-changed update-info set-info-canvas get-info-canvas get-info-editor get-info-panel show-info hide-info is-info-hidden?)) (define magic-space 25) (define info-mixin (mixin (basic<%>) (info<%>) [define rest-panel 'uninitialized-root] [define super-root 'uninitialized-super-root] (define/override (make-root-area-container % parent) (let* ([s-root (super make-root-area-container vertical-panel% parent)] [r-root (make-object % s-root)]) (set! super-root s-root) (set! rest-panel r-root) r-root)) [define info-canvas #f] (public get-info-canvas set-info-canvas get-info-editor) [define get-info-canvas (λ () info-canvas)] [define set-info-canvas (λ (c) (set! info-canvas c))] [define get-info-editor (λ () (and info-canvas (send info-canvas get-editor)))] (public determine-width) [define determine-width (λ (string canvas edit) (send edit set-autowrap-bitmap #f) (send canvas call-as-primary-owner (λ () (let ([lb (box 0)] [rb (box 0)]) (send edit erase) (send edit insert string) (send edit position-location (send edit last-position) rb) (send edit position-location 0 lb) (send canvas min-width (+ magic-space (- (inexact->exact (floor (unbox rb))) (inexact->exact (floor (unbox lb))))))))))] [define outer-info-panel 'top-info-panel-uninitialized] ;; this flag is specific to this frame ;; the true state of the info panel is ;; the combination of this flag and the ;; the 'framework:show-status-line preference ;; as shown in update-info-visibility (define info-hidden? #f) (define/public (hide-info) (set! info-hidden? #t) (update-info-visibility (preferences:get 'framework:show-status-line))) (define/public (show-info) (set! info-hidden? #f) (update-info-visibility (preferences:get 'framework:show-status-line))) (define/public (is-info-hidden?) info-hidden?) (define/private (update-info-visibility pref-value) (cond [(or info-hidden? (not pref-value)) (send super-root change-children (λ (l) (if (memq outer-info-panel l) (begin (unregister-collecting-blit gc-canvas) (list rest-panel)) l)))] [else (send super-root change-children (λ (l) (if (memq outer-info-panel l) l (begin (register-gc-blit) (list rest-panel outer-info-panel)))))])) [define close-panel-callback (preferences:add-callback 'framework:show-status-line (λ (p v) (update-info-visibility v)))] (define memory-cleanup void) ;; only for checkouts and nightly build users; used with memory-text (define/augment (on-close) (unregister-collecting-blit gc-canvas) (close-panel-callback) (memory-cleanup) (inner (void) on-close)) (define icon-currently-locked? 'uninit) (define/public (lock-status-changed) (let ([info-edit (get-info-editor)]) (cond [(not (object? lock-canvas)) (void)] [(is-a? info-edit editor:file<%>) (unless (send lock-canvas is-shown?) (send lock-canvas show #t)) (let ([locked-now? (not (send info-edit get-read-write?))]) (unless (eq? locked-now? icon-currently-locked?) (set! icon-currently-locked? locked-now?) (when (object? lock-canvas) (send lock-canvas set-locked locked-now?))))] [else (when (send lock-canvas is-shown?) (send lock-canvas show #f))]))) (public update-info) [define update-info (λ () (lock-status-changed))] (super-new) (set! outer-info-panel (make-object horizontal-panel% super-root)) (send outer-info-panel stretchable-height #f) [define info-panel (make-object horizontal-panel% outer-info-panel)] (make-object grow-box-spacer-pane% outer-info-panel) (public get-info-panel) [define get-info-panel (λ () info-panel)] (public update-memory-text) [define update-memory-text (λ () (when show-memory-text? (send memory-text begin-edit-sequence) (send memory-text lock #f) (send memory-text erase) (send memory-text insert (format-number (current-memory-use))) (send memory-text lock #t) (send memory-text end-edit-sequence)))] (define/private (format-number n) (let loop ([n n]) (cond [(<= n 1000) (number->string n)] [else (string-append (loop (quotient n 1000)) "," (pad-to-3 (modulo n 1000)))]))) (define/private (pad-to-3 n) (cond [(<= n 9) (format "00~a" n)] [(<= n 99) (format "0~a" n)] [else (number->string n)])) ; only for checkouts and nightly build users (when show-memory-text? (let* ([panel (make-object horizontal-panel% (get-info-panel) '(border))] [button (make-object button% (string-constant collect-button-label) panel (λ x (collect-garbage) (update-memory-text)))] [ec (make-object editor-canvas% panel memory-text '(no-hscroll no-vscroll))]) (determine-width "0,000,000,000" ec memory-text) (update-memory-text) (set! memory-cleanup (λ () (send ec set-editor #f))) (send panel stretchable-width #f))) [define lock-canvas (make-object lock-canvas% (get-info-panel))] [define gc-canvas (make-object bday-click-canvas% (get-info-panel) '(border))] (define/private (register-gc-blit) (let ([onb (icon:get-gc-on-bitmap)] [offb (icon:get-gc-off-bitmap)]) (when (and (send onb ok?) (send offb ok?)) (register-collecting-blit gc-canvas 0 0 (send onb get-width) (send onb get-height) onb offb)))) (unless (preferences:get 'framework:show-status-line) (send super-root change-children (λ (l) (list rest-panel)))) (register-gc-blit) (let* ([gcb (icon:get-gc-on-bitmap)] [gc-width (if (send gcb ok?) (send gcb get-width) 10)] [gc-height (if (send gcb ok?) (send gcb get-height) 10)]) (send* gc-canvas (min-client-width (max (send gc-canvas min-width) gc-width)) (min-client-height (max (send gc-canvas min-height) gc-height)) (stretchable-width #f) (stretchable-height #f))) (send* (get-info-panel) (set-alignment 'right 'center) (stretchable-height #f) (spacing 3) (border 3)))) (define text-info<%> (interface (info<%>) set-macro-recording overwrite-status-changed anchor-status-changed editor-position-changed)) (define text-info-mixin (mixin (info<%>) (text-info<%>) (inherit get-info-editor) [define remove-first (preferences:add-callback 'framework:col-offsets (λ (p v) (editor-position-changed-offset/numbers v (preferences:get 'framework:display-line-numbers)) #t))] [define remove-second (preferences:add-callback 'framework:display-line-numbers (λ (p v) (editor-position-changed-offset/numbers (preferences:get 'framework:col-offsets) v) #t))] (define/augment (on-close) (remove-first) (remove-second) (inner (void) on-close)) [define last-start #f] [define last-end #f] [define last-params #f] (define/private (editor-position-changed-offset/numbers offset? line-numbers?) (let* ([edit (get-info-editor)] [make-one (λ (pos) (let* ([line (send edit position-paragraph pos)] [col (find-col edit line pos)]) (if line-numbers? (format "~a:~a" (add1 line) (if offset? (add1 col) col)) (format "~a" pos))))]) (cond [(not (object? position-canvas)) (void)] [edit (unless (send position-canvas is-shown?) (send position-canvas show #t)) (let ([start (send edit get-start-position)] [end (send edit get-end-position)]) (unless (and last-start (equal? last-params (list offset? line-numbers?)) (= last-start start) (= last-end end)) (set! last-params (list offset? line-numbers?)) (set! last-start start) (set! last-end end) (when (object? position-edit) (send* position-edit (lock #f) (erase) (insert (if (= start end) (make-one start) (string-append (make-one start) "-" (make-one end)))) (lock #t)))))] [else (when (send position-canvas is-shown?) (send position-canvas show #f))]))) ;; find-col : text number number -> number ;; given a line number and a position, finds the ;; column number for that position (define/private (find-col text line pos) (let ([line-start (send text paragraph-start-position line)]) (if (= line-start pos) 0 (let loop ([col 0] [snip (send text find-snip line-start 'after-or-none)]) (cond [(and snip (is-a? snip tab-snip%)) ;; assume cursor isn't in the middle of the tab snip ;; and that there is no tab array (let ([twb (box 0)]) (send text get-tabs #f twb #f) (let ([tw (floor (inexact->exact (unbox twb)))]) (loop (+ col (- tw (modulo col tw))) (send snip next))))] [snip (let ([snip-position (send text get-snip-position snip)] [snip-length (send snip get-count)]) (if (<= snip-position pos (+ snip-position snip-length)) (+ col (- pos snip-position)) (loop (+ col snip-length) (send snip next))))] [else col]))))) [define anchor-last-state? #f] [define overwrite-last-state? #f] (field (macro-recording? #f)) (define/private (update-macro-recording-icon) (unless (eq? (send macro-recording-message is-shown?) macro-recording?) (send macro-recording-message show macro-recording?))) (define/public (set-macro-recording on?) (set! macro-recording? on?) (update-macro-recording-icon)) (define/public (anchor-status-changed) (let ([info-edit (get-info-editor)] [failed (λ () (unless (eq? anchor-last-state? #f) (set! anchor-last-state? #f) (send anchor-message show #f)))]) (cond [info-edit (let ([anchor-now? (send info-edit get-anchor)]) (unless (eq? anchor-now? anchor-last-state?) (cond [(object? anchor-message) (send anchor-message show anchor-now?) (set! anchor-last-state? anchor-now?)] [else (failed)])))] [else (failed)]))) (define/public (editor-position-changed) (editor-position-changed-offset/numbers (preferences:get 'framework:col-offsets) (preferences:get 'framework:display-line-numbers))) [define/public overwrite-status-changed (λ () (let ([info-edit (get-info-editor)] [failed (λ () (set! overwrite-last-state? #f) (send overwrite-message show #f))]) (cond [info-edit (let ([overwrite-now? (send info-edit get-overwrite-mode)]) (unless (eq? overwrite-now? overwrite-last-state?) (cond [(object? overwrite-message) (send overwrite-message show overwrite-now?) (set! overwrite-last-state? overwrite-now?)] [else (failed)])))] [else (failed)])))] (define/override (update-info) (super update-info) (update-macro-recording-icon) (overwrite-status-changed) (anchor-status-changed) (editor-position-changed)) (super-new) (inherit get-info-panel) [define anchor-message (make-object message% (let ([b (icon:get-anchor-bitmap)]) (if (and #f (send b ok?)) b (string-constant auto-extend-selection))) (get-info-panel))] [define overwrite-message (make-object message% (string-constant overwrite) (get-info-panel))] [define position-canvas (make-object editor-canvas% (get-info-panel) #f '(no-hscroll no-vscroll))] [define position-edit (make-object text%)] (define macro-recording-message (instantiate message% () (label "c-x;(") (parent (get-info-panel)))) (inherit determine-width) (let ([move-front (λ (x l) (cons x (remq x l)))]) (send (get-info-panel) change-children (λ (l) (move-front macro-recording-message (move-front anchor-message (move-front overwrite-message (move-front position-canvas l))))))) (send macro-recording-message show #f) (send anchor-message show #f) (send overwrite-message show #f) (send* position-canvas (set-line-count 1) (set-editor position-edit) (stretchable-width #f) (stretchable-height #f)) (determine-width "0000:000-0000:000" position-canvas position-edit) (editor-position-changed) (send position-edit hide-caret #t) (send position-edit lock #t))) (define pasteboard-info<%> (interface (info<%>))) (define pasteboard-info-mixin (mixin (basic<%>) (pasteboard-info<%>) (super-instantiate ()))) (include "standard-menus.ss") (define -editor<%> (interface (standard-menus<%>) get-entire-label get-label-prefix set-label-prefix get-canvas% get-canvas<%> get-editor% get-editor<%> make-editor revert save save-as get-canvas get-editor)) (define editor-mixin (mixin (standard-menus<%>) (-editor<%>) (init (filename #f)) (inherit get-area-container get-client-size show get-edit-target-window get-edit-target-object) (define/override get-filename (case-lambda [() (get-filename #f)] [(b) (let ([e (get-editor)]) (and e (send e get-filename b)))])) (define/override (editing-this-file? filename) (let ([path-equal? (λ (x y) (equal? (normal-case-path (normalize-path x)) (normal-case-path (normalize-path y))))]) (let ([this-fn (get-filename)]) (and this-fn (path-equal? filename (get-filename)))))) (define/augment (on-close) (send (get-editor) on-close) (inner (void) on-close)) (define/augment (can-close?) (and (send (get-editor) can-close?) (inner #t can-close?))) [define label ""] [define label-prefix (application:current-app-name)] (define/private (do-label) (super set-label (gui-utils:trim-string (get-entire-label) 200)) (send (group:get-the-frame-group) frame-label-changed this)) (public get-entire-label get-label-prefix set-label-prefix) [define get-entire-label (λ () (cond [(string=? "" label) label-prefix] [(string=? "" label-prefix) label] [else (string-append label " - " label-prefix)]))] [define get-label-prefix (λ () label-prefix)] [define set-label-prefix (λ (s) (when (and (string? s) (not (string=? s label-prefix))) (set! label-prefix s) (do-label)))] [define/override get-label (λ () label)] [define/override set-label (λ (t) (when (and (string? t) (not (string=? t label))) (set! label t) (do-label)))] (define/public (get-canvas%) editor-canvas%) (define/public (get-canvas<%>) (class->interface editor-canvas%)) (define/public (make-canvas) (let ([% (get-canvas%)] [<%> (get-canvas<%>)]) (unless (implementation? % <%>) (error 'frame:editor% "result of get-canvas% method must match ~e interface; got: ~e" <%> %)) (instantiate % () (parent (get-area-container))))) (define/public (get-editor%) (error 'editor-frame% "abstract method: no editor% class specified")) (define/public (get-editor<%>) editor:basic<%>) (define/public (make-editor) (let ([% (get-editor%)] [<%> (get-editor<%>)]) (unless (implementation? % <%>) (error 'frame:editor% "result of get-editor% method must match ~e interface; got: ~e" <%> %)) (make-object %))) (define/public save (opt-lambda ([format 'same]) (let* ([ed (get-editor)] [filename (send ed get-filename)]) (if filename (send ed save-file/gui-error filename format) (save-as format))))) (define/public save-as (opt-lambda ([format 'same]) (let* ([editor (get-editor)] [name (send editor get-filename)]) (let-values ([(base name) (if name (let-values ([(base name dir?) (split-path name)]) (values base name)) (values #f #f))]) (let ([file (send editor put-file base name)]) (if file (send editor save-file/gui-error file format) #f)))))) (define/private (basename str) (let-values ([(base name dir?) (split-path str)]) base)) (inherit get-checkable-menu-item% get-menu-item%) (define/override (file-menu:revert-on-demand item) (send item enable (not (send (get-editor) is-locked?)))) (define/override file-menu:revert-callback (λ (item control) (let* ([edit (get-editor)] [b (box #f)] [filename (send edit get-filename b)]) (if (or (not filename) (unbox b)) (bell) (when (gui-utils:get-choice (string-constant are-you-sure-revert) (string-constant yes) (string-constant no) (string-constant are-you-sure-revert-title) #f this) (revert)))) #t)) (define/public (revert) (let* ([edit (get-editor)] [b (box #f)] [filename (send edit get-filename b)]) (when (and filename (not (unbox b))) (let ([start (if (is-a? edit text%) (send edit get-start-position) #f)]) (send edit begin-edit-sequence) (let ([status (send edit load-file/gui-error filename 'same #f)]) (if status (begin (when (is-a? edit text%) (send edit set-position start start)) (send edit end-edit-sequence)) (send edit end-edit-sequence))))))) (define/override file-menu:create-revert? (λ () #t)) (define/override file-menu:save-callback (λ (item control) (save) #t)) (define/override file-menu:create-save? (λ () #t)) (define/override file-menu:save-as-callback (λ (item control) (save-as) #t)) (define/override file-menu:create-save-as? (λ () #t)) (define/override file-menu:print-callback (λ (item control) (send (get-editor) print #t #t (preferences:get 'framework:print-output-mode)) #t)) (define/override file-menu:create-print? (λ () #t)) (define/override edit-menu:between-select-all-and-find (λ (edit-menu) (let* ([c% (get-checkable-menu-item%)] [on-demand (λ (menu-item) (let ([edit (get-edit-target-object)]) (if (and edit (is-a? edit editor<%>)) (begin (send menu-item enable #t) (send menu-item check (send edit auto-wrap))) (begin (send menu-item check #f) (send menu-item enable #f)))))] [callback (λ (item event) (let ([edit (get-edit-target-object)]) (when (and edit (is-a? edit editor<%>)) (let ([new-pref (not (send edit auto-wrap))]) (preferences:set 'framework:auto-set-wrap? new-pref) (send edit auto-wrap new-pref)))))]) (make-object c% (string-constant wrap-text-item) edit-menu callback #f #f on-demand)) (make-object separator-menu-item% edit-menu))) (define/override help-menu:about-callback (λ (menu evt) (message-box (application:current-app-name) (format (string-constant welcome-to-something) (application:current-app-name)) #f '(ok app)))) (define/override help-menu:about-string (λ () (application:current-app-name))) (define/override help-menu:create-about? (λ () #t)) (super-new (label (get-entire-label))) (define canvas #f) (define editor #f) (public get-canvas get-editor) (define get-canvas (λ () (unless canvas (set! canvas (make-canvas)) (send canvas set-editor (get-editor))) canvas)) (define get-editor (λ () (unless editor (set! editor (make-editor)) (send (get-canvas) set-editor editor)) editor)) (cond [(and filename (file-exists? filename)) (let ([ed (get-editor)]) (send ed begin-edit-sequence) (send ed load-file/gui-error filename 'guess) (send ed end-edit-sequence))] [filename (send (get-editor) set-filename filename)] [else (void)]) (let ([ed-fn (send (get-editor) get-filename)]) (set! label (or (and ed-fn (path->string (file-name-from-path ed-fn))) (send (get-editor) get-filename/untitled-name)))) (do-label) (let ([canvas (get-canvas)]) (when (is-a? canvas editor-canvas%) ;; when get-canvas is overridden, ;; it might not yet be implemented (send canvas focus))))) (define open-here<%> (interface (-editor<%>) get-open-here-editor open-here)) (define open-here-mixin (mixin (-editor<%>) (open-here<%>) (define/override (file-menu:new-on-demand item) (super file-menu:new-on-demand item) (send item set-label (if (preferences:get 'framework:open-here?) (string-constant new-...-menu-item) (string-constant new-menu-item)))) (define/override (file-menu:new-callback item event) (cond [(preferences:get 'framework:open-here?) (let ([clear-current (ask-about-new-here)]) (cond [(eq? clear-current 'cancel) (void)] [clear-current (let* ([editor (get-editor)] [canceled? (cancel-due-to-unsaved-changes editor)]) (unless canceled? (send editor begin-edit-sequence) (send editor lock #f) (send editor set-filename #f) (send editor erase) (send editor set-modified #f) (send editor clear-undos) (send editor end-edit-sequence)))] [else ((handler:current-create-new-window) #f)]))] [else ((handler:current-create-new-window) #f)])) ;; cancel-due-to-unsaved-changes : -> boolean ;; returns #t if the action should be cancelled (define/private (cancel-due-to-unsaved-changes editor) (and (send editor is-modified?) (let ([save (gui-utils:unsaved-warning (or (send editor get-filename) (get-label)) (string-constant clear-anyway) #t this)]) (case save [(continue) #f] [(save) (not (send editor save-file/gui-error))] [(cancel) #t])))) ;; ask-about-new-here : -> (union 'cancel boolean?) ;; prompts the user about creating a new window ;; or "reusing" the current one. (define/private (ask-about-new-here) (gui-utils:get-choice (string-constant create-new-window-or-clear-current) (string-constant clear-current) (string-constant new-window) (string-constant warning) 'cancel this)) (define/override (file-menu:open-on-demand item) (super file-menu:open-on-demand item) (send item set-label (if (preferences:get 'framework:open-here?) (string-constant open-here-menu-item) (string-constant open-menu-item)))) (define/augment (on-close) (let ([group (group:get-the-frame-group)]) (when (eq? this (send group get-open-here-frame)) (send group set-open-here-frame #f))) (inner (void) on-close)) (define/override (on-activate on?) (super on-activate on?) (when on? (send (group:get-the-frame-group) set-open-here-frame this))) (inherit get-editor) (define/public (get-open-here-editor) (get-editor)) (define/public (open-here filename) (let* ([editor (get-open-here-editor)] [okay-to-switch? (user-okays-switch? editor)]) (when okay-to-switch? (when (is-a? editor text%) (let* ([b (box #f)] [filename (send editor get-filename b)]) (unless (unbox b) (when filename (handler:set-recent-position filename (send editor get-start-position) (send editor get-end-position)))))) (send editor begin-edit-sequence) (send editor lock #f) (send editor load-file/gui-error filename) (send editor end-edit-sequence) (void)))) (inherit get-label) (define/private (user-okays-switch? ed) (or (not (send ed is-modified?)) (let ([answer (gui-utils:unsaved-warning (or (send ed get-filename) (get-label)) (string-constant switch-anyway) #t)]) (case answer [(continue) #t] [(save) (send ed save-file/gui-error)] [(cancel) #f])))) (super-new))) (define text<%> (interface (-editor<%>))) (define text-mixin (mixin (-editor<%>) (text<%>) (define/override (get-editor<%>) (class->interface text%)) (define/override (get-editor%) text:keymap%) (super-new))) (define pasteboard<%> (interface (-editor<%>))) (define pasteboard-mixin (mixin (-editor<%>) (pasteboard<%>) [define/override get-editor<%> (λ () (class->interface pasteboard%))] [define/override get-editor% (λ () pasteboard:keymap%)] (super-new))) (define delegate<%> (interface (status-line<%> text<%>) get-delegated-text delegated-text-shown? hide-delegated-text show-delegated-text delegate-moved)) (define delegatee-editor-canvas% (class editor-canvas% (init-field delegate-frame) (inherit get-editor get-dc) (define/override (on-event evt) (super on-event evt) (when delegate-frame (let ([text (get-editor)]) (when (is-a? text text%) (cond [(send evt button-down?) (let-values ([(editor-x editor-y) (send text dc-location-to-editor-location (send evt get-x) (send evt get-y))]) (send delegate-frame click-in-overview (send text find-position editor-x editor-y)))] [(or (send evt entering?) (send evt moving?)) (let-values ([(editor-x editor-y) (send text dc-location-to-editor-location (send evt get-x) (send evt get-y))]) (let* ([b (box #f)] [pos (send text find-position editor-x editor-y #f b)]) (cond [(unbox b) (let* ([para (send text position-paragraph pos)] [start-pos (send text paragraph-start-position para)] [end-pos (send text paragraph-end-position para)]) (send delegate-frame update-status-line 'plt:delegate (send text get-text start-pos end-pos)))] [else (send delegate-frame update-status-line 'plt:delegate #f)])))] [(send evt leaving?) (send delegate-frame update-status-line 'plt:delegate #f)]))))) (super-instantiate ()))) (define delegatee-text<%> (interface () set-start/end-para)) (define delegatee-text% (class* text:basic% (delegatee-text<%>) (inherit get-admin) (define start-para #f) (define end-para #f) (define view-x-b (box 0)) (define view-width-b (box 0)) (inherit paragraph-start-position paragraph-end-position position-location invalidate-bitmap-cache scroll-to-position get-visible-position-range position-paragraph last-position) (define/override (on-new-string-snip) (instantiate text:1-pixel-string-snip% ())) (define/override (on-new-tab-snip) (instantiate text:1-pixel-tab-snip% ())) ;; set-start/end-para : (union (#f #f -> void) (number number -> void)) (define/public (set-start/end-para _start-para _end-para) (unless (and (equal? _start-para start-para) (equal? _end-para end-para)) (let ([old-start-para start-para] [old-end-para end-para]) (cond [else (set! start-para _start-para) (set! end-para _end-para)]) (when (and start-para end-para) (let-values ([(v-start v-end) (let ([bs (box 0)] [bf (box 0)]) (get-visible-position-range bs bf) (values (unbox bs) (unbox bf)))]) (let ([v-start-para (position-paragraph v-start)] [v-end-para (position-paragraph v-end)]) (cond [(v-start-para . >= . start-para) (scroll-to-position (paragraph-start-position start-para))] [(v-end-para . <= . end-para) (scroll-to-position (paragraph-end-position end-para))] [else (void)])))) (when (and old-start-para old-end-para) (let-values ([(x y w h) (get-rectangle old-start-para old-end-para)]) (when x (invalidate-bitmap-cache x y w h)))) (when (and start-para end-para) (let-values ([(x y w h) (get-rectangle start-para end-para)]) (when x (invalidate-bitmap-cache x y w h))))))) (define/override (on-paint before? dc left top right bottom dx dy draw-caret) (super on-paint before? dc left top right bottom dx dy draw-caret) (when (and before? start-para end-para) (let ([old-pen (send dc get-pen)] [old-brush (send dc get-brush)]) (send dc set-pen (send the-pen-list find-or-create-pen "light blue" 1 'solid)) (send dc set-brush (send the-brush-list find-or-create-brush "light blue" 'solid)) (let-values ([(x y w h) (get-rectangle start-para end-para)]) (when x (send dc draw-rectangle (+ dx x) (+ dy y) w h))) (send dc set-pen old-pen) (send dc set-brush old-brush)))) ;; get-rectangle : number number -> ;; (values (union #f number) (union #f number) (union #f number) (union #f number)) ;; computes the rectangle corresponding the input paragraphs (define/private (get-rectangle start-para end-para) (let ([start (get-line-y start-para #t)] [end (get-line-y end-para #f)] [admin (get-admin)]) (cond [(not admin) (values #f #f #f #f)] [(= 0 (last-position)) (values #f #f #f #f)] [else (send admin get-view view-x-b #f view-width-b #f) (send admin get-view view-x-b #f view-width-b #f) (values (unbox view-x-b) start (unbox view-width-b) (- end start))]))) (define/private (get-line-y para top?) (let ([pos (paragraph-start-position para)] [b (box 0)]) (position-location pos #f b top? #f #t) (unbox b))) (super-new) (inherit set-cursor) (set-cursor (make-object cursor% 'arrow)) (inherit set-line-spacing) (set-line-spacing 0))) (define delegate-mixin (mixin (status-line<%> text<%>) (delegate<%>) (define/public (get-delegated-text) (get-editor)) [define rest-panel 'uninitialized-root] [define super-root 'uninitialized-super-root] [define/override make-root-area-container (λ (% parent) (let* ([s-root (super make-root-area-container horizontal-panel% parent)] [r-root (make-object % s-root)]) (set! super-root s-root) (set! rest-panel r-root) r-root))] (define/override (get-editor<%>) text:delegate<%>) (define/override (get-editor%) (text:delegate-mixin (super get-editor%))) (field (shown? (preferences:get 'framework:show-delegate?))) (define/public (delegated-text-shown?) shown?) (inherit close-status-line open-status-line) (define/public (hide-delegated-text) (close-status-line 'plt:delegate) (set! shown? #f) (send (get-delegated-text) set-delegate #f) (send super-root change-children (λ (l) (list rest-panel)))) (define/public (show-delegated-text) (open-status-line 'plt:delegate) (set! shown? #t) (send (get-delegated-text) set-delegate delegatee) (send super-root change-children (λ (l) (list rest-panel delegate-ec)))) (define/public (click-in-overview pos) (when shown? (let* ([d-text (get-delegated-text)] [d-canvas (send d-text get-canvas)] [bx (box 0)] [by (box 0)]) (let-values ([(cw ch) (send d-canvas get-client-size)]) (send d-text position-location pos bx by) (send d-canvas focus) (send d-canvas scroll-to (- (unbox bx) (/ cw 2)) (- (unbox by) (/ ch 2)) cw ch #t))))) (define/public (delegate-moved) (let ([startb (box 0)] [endb (box 0)] [delegate-text (get-delegated-text)]) (send delegate-text get-visible-position-range startb endb #f) (send delegatee set-start/end-para (send delegate-text position-paragraph (unbox startb)) (send delegate-text position-paragraph (unbox endb))))) (define/public (get-delegatee) delegatee) (super-instantiate ()) (define delegatee (instantiate delegatee-text% ())) (define delegate-ec (instantiate delegatee-editor-canvas% () (editor delegatee) (parent super-root) (delegate-frame this) (min-width 150) (stretchable-width #f))) (inherit get-editor) (if (preferences:get 'framework:show-delegate?) (begin (open-status-line 'plt:delegate) (send (get-delegated-text) set-delegate delegatee) (send super-root change-children (λ (l) (list rest-panel delegate-ec)))) (begin (send (get-delegated-text) set-delegate #f) (send super-root change-children (λ (l) (list rest-panel))))))) (define (search-dialog frame) (init-find/replace-edits) (keymap:call/text-keymap-initializer (λ () (let* ([to-be-searched-text (send frame get-text-to-search)] [to-be-searched-canvas (send to-be-searched-text get-canvas)] [allow-replace? (not (send to-be-searched-text is-locked?))] [dialog (make-object dialog% (if allow-replace? (string-constant find-and-replace) (string-constant find)) frame)] [copy-text (λ (from to) (send to erase) (let loop ([snip (send from find-first-snip)]) (when snip (send to insert (send snip copy)) (loop (send snip next)))))] [text-keymap/editor% (class text:keymap% (define/override (get-keymaps) (if (preferences:get 'framework:menu-bindings) (append (list (keymap:get-editor)) (super get-keymaps)) (append (super get-keymaps) (list (keymap:get-editor))))) (inherit set-styles-fixed) (super-new) (set-styles-fixed #t))] [find-panel (make-object horizontal-panel% dialog)] [find-message (make-object message% (string-constant find) find-panel)] [f-text (make-object text-keymap/editor%)] [find-canvas (make-object editor-canvas% find-panel f-text '(hide-hscroll hide-vscroll))] [replace-panel (make-object horizontal-panel% dialog)] [replace-message (make-object message% (string-constant replace) replace-panel)] [r-text (make-object text-keymap/editor%)] [replace-canvas (make-object editor-canvas% replace-panel r-text '(hide-hscroll hide-vscroll))] [button-panel (make-object horizontal-panel% dialog)] [update-texts (λ () (send find-edit stop-searching) (copy-text f-text find-edit) (send find-edit start-searching) (copy-text r-text replace-edit))] [find-button (make-object button% (string-constant find) button-panel (λ x (update-texts) (send frame search-again)) '(border))] [replace-button (make-object button% (string-constant replace) button-panel (λ x (update-texts) (send frame replace)))] [replace-and-find-button (make-object button% (string-constant replace&find-again) button-panel (λ x (update-texts) (send frame replace&search)))] [replace-to-end-button (make-object button% (string-constant replace-to-end) button-panel (λ x (update-texts) (send frame replace-all)))] [dock-button (make-object button% (string-constant dock) button-panel (λ (btn evt) (update-texts) (preferences:set 'framework:search-using-dialog? #f) (send frame unhide-search)))] [close (λ () (when to-be-searched-canvas (send to-be-searched-canvas force-display-focus #f)) (send dialog show #f))] [close-button (make-object button% (string-constant close) button-panel (λ (x y) (close)))] [remove-pref-callback (preferences:add-callback 'framework:search-using-dialog? (λ (p v) (unless v (close))))]) (unless allow-replace? (send button-panel change-children (λ (l) (remq replace-button (remq replace-and-find-button (remq replace-to-end-button l))))) (send dialog change-children (λ (l) (remq replace-panel l)))) (copy-text find-edit f-text) (copy-text replace-edit r-text) (send find-canvas min-width 400) (send find-canvas set-line-count 2) (send find-canvas stretchable-height #f) (send find-canvas allow-tab-exit #t) (send replace-canvas min-width 400) (send replace-canvas set-line-count 2) (send replace-canvas stretchable-height #f) (send replace-canvas allow-tab-exit #t) (let ([msg-width (max (send find-message get-width) (send replace-message get-width))]) (send find-message min-width msg-width) (send replace-message min-width msg-width)) (send find-canvas focus) (send f-text set-position 0 (send f-text last-position)) (send button-panel set-alignment 'right 'center) (send dialog center 'both) (when to-be-searched-canvas (send to-be-searched-canvas force-display-focus #t)) (send dialog show #t) (remove-pref-callback))))) (define searchable<%> (interface (basic<%>) get-text-to-search hide-search unhide-search set-search-direction replace&search replace-all replace can-replace? toggle-search-focus move-to-search-or-search move-to-search-or-reverse-search search-again)) (define search-anchor 0) (define searching-direction 'forward) (define (set-searching-direction x) (unless (or (eq? x 'forward) (eq? x 'backward)) (error 'set-searching-direction "expected ~e or ~e, got ~e" 'forward 'backward x)) (set! searching-direction x)) (define old-search-highlight void) (define clear-search-highlight (λ () (begin (old-search-highlight) (set! old-search-highlight void)))) (define reset-search-anchor (let ([color (make-object color% "BLUE")]) (λ (edit) (old-search-highlight) (let ([position (if (eq? 'forward searching-direction) (send edit get-end-position) (send edit get-start-position))]) (set! search-anchor position) ;; don't draw the anchor '(set! old-search-highlight (send edit highlight-range position position color #f)))))) (define find-string-embedded (opt-lambda (edit str [direction 'forward] [start 'start] [end 'eof] [get-start #t] [case-sensitive? #t] [pop-out? #f]) (unless (member direction '(forward backward)) (error 'find-string-embedded "expected ~e or ~e as first argument, got: ~e" 'forward 'backward direction)) (let/ec k (let* ([start (if (eq? start 'start) (send edit get-start-position) start)] [end (if (eq? 'eof end) (if (eq? direction 'forward) (send edit last-position) 0) end)] [flat (send edit find-string str direction start end get-start case-sensitive?)] [pop-out (λ () (let ([admin (send edit get-admin)]) (if (is-a? admin editor-snip-editor-admin<%>) (let* ([snip (send admin get-snip)] [edit-above (send (send snip get-admin) get-editor)] [pos (send edit-above get-snip-position snip)] [pop-out-pos (if (eq? direction 'forward) (add1 pos) pos)]) (find-string-embedded edit-above str direction pop-out-pos (if (eq? direction 'forward) 'eof 0) get-start case-sensitive? pop-out?)) (values edit #f))))]) (let loop ([current-snip (send edit find-snip start (if (eq? direction 'forward) 'after-or-none 'before-or-none))]) (let ([next-loop (λ () (if (eq? direction 'forward) (loop (send current-snip next)) (loop (send current-snip previous))))]) (cond [(or (not current-snip) (and flat (let* ([start (send edit get-snip-position current-snip)] [end (+ start (send current-snip get-count))]) (if (eq? direction 'forward) (and (<= start flat) (< flat end)) (and (< start flat) (<= flat end)))))) (if (and (not flat) pop-out?) (pop-out) (values edit flat))] [(is-a? current-snip editor-snip%) (let-values ([(embedded embedded-pos) (let ([media (send current-snip get-editor)]) (if (and media (is-a? media text%)) (begin (find-string-embedded media str direction (if (eq? 'forward direction) 0 (send media last-position)) 'eof get-start case-sensitive?)) (values #f #f)))]) (if (not embedded-pos) (next-loop) (values embedded embedded-pos)))] [else (next-loop)]))))))) (define searching-frame #f) (define (set-searching-frame frame) (set! searching-frame frame)) (define find-text% (class text:keymap% (inherit get-text) (define/private (get-searching-edit) (and searching-frame (send searching-frame get-text-to-search))) (define/public search (opt-lambda ([reset-search-anchor? #t] [beep? #t] [wrap? #t]) (when searching-frame (let* ([string (get-text)] [top-searching-edit (get-searching-edit)] [searching-edit (let ([focus-snip (send top-searching-edit get-focus-snip)]) (if focus-snip (send focus-snip get-editor) top-searching-edit))] [not-found (λ (found-edit skip-beep?) (send found-edit set-position search-anchor) (when (and beep? (not skip-beep?)) (bell)) #f)] [found (λ (edit first-pos) (let ([last-pos ((if (eq? searching-direction 'forward) + -) first-pos (string-length string))]) (send* edit (set-caret-owner #f 'display) (set-position (min first-pos last-pos) (max first-pos last-pos) #f #t 'local)) #t))]) (if (string=? string "") (not-found top-searching-edit #t) (begin (when reset-search-anchor? (reset-search-anchor searching-edit)) (let-values ([(found-edit first-pos) (find-string-embedded searching-edit string searching-direction search-anchor 'eof #t #t #t)]) (cond [(not first-pos) (if wrap? (let-values ([(found-edit pos) (find-string-embedded top-searching-edit string searching-direction (if (eq? 'forward searching-direction) 0 (send searching-edit last-position)))]) (if (not pos) (not-found found-edit #f) (found found-edit pos))) (not-found found-edit #f))] [else (found found-edit first-pos)])))))))) (field [dont-search #f]) (define/public (stop-searching) (set! dont-search #t)) (define/public (start-searching) (set! dont-search #f)) (define/override (on-focus on?) (when on? (let ([edit (get-searching-edit)]) (when edit (reset-search-anchor (get-searching-edit))))) (super on-focus on?)) (define/augment (after-insert x y) (unless dont-search (search #f)) (inner (void) after-insert x y)) (define/augment (after-delete x y) (unless dont-search (search #f)) (inner (void) after-delete x y)) (super-new) (inherit set-styles-fixed) (set-styles-fixed #t))) (define replace-text% (class text:keymap% (inherit set-styles-fixed) (super-instantiate ()) (set-styles-fixed #t))) (define find-edit #f) (define replace-edit #f) (define searchable-canvas% (class editor-canvas% (inherit get-top-level-window set-line-count) (define/override (on-focus x) (when x (set-searching-frame (get-top-level-window))) (super on-focus x)) (super-new (style '(hide-hscroll hide-vscroll))) (set-line-count 2))) (define (init-find/replace-edits) (unless find-edit (set! find-edit (make-object find-text%)) (set! replace-edit (make-object replace-text%)) (for-each (λ (keymap) (send keymap chain-to-keymap (keymap:get-search) #t)) (list (send find-edit get-keymap) (send replace-edit get-keymap))))) (define searchable-mixin (mixin (standard-menus<%>) (searchable<%>) (init-find/replace-edits) (define super-root 'unitiaialized-super-root) (define/override edit-menu:find-callback (λ (menu evt) (move-to-search-or-search) #t)) (define/override edit-menu:create-find? (λ () #t)) (define/override edit-menu:find-again-callback (λ (menu evt) (search-again) #t)) (define/override edit-menu:create-find-again? (λ () #t)) (define/override edit-menu:replace-and-find-again-callback (λ (menu evt) (replace&search) #t)) (define/override edit-menu:replace-and-find-again-on-demand (λ (item) (send item enable (can-replace?)))) (define/override edit-menu:create-replace-and-find-again? (λ () #t)) (define/override make-root-area-container (λ (% parent) (let* ([s-root (super make-root-area-container vertical-panel% parent)] [root (make-object % s-root)]) (set! super-root s-root) root))) (define/override (on-activate on?) (unless hidden? (if on? (reset-search-anchor (get-text-to-search)) (clear-search-highlight))) (super on-activate on?)) (define/public (get-text-to-search) (error 'get-text-to-search "abstract method in searchable-mixin")) (define/public hide-search (opt-lambda ([startup? #f]) (when search-gui-built? (send super-root change-children (λ (l) (remove search-panel l)))) (clear-search-highlight) (unless startup? (let ([canvas (send (get-text-to-search) get-canvas)]) (when canvas (send canvas force-display-focus #f) (send canvas focus)))) (set! hidden? #t))) (define/public (unhide-search) (when (and hidden? (not (preferences:get 'framework:search-using-dialog?))) (set! hidden? #f) (build-search-gui-in-frame) (let ([canvas (send (get-text-to-search) get-canvas)]) (when canvas (send canvas force-display-focus #t))) (show/hide-replace (send (get-text-to-search) is-locked?)) (send search-panel focus) (send find-edit set-position 0 (send find-edit last-position)) (unless (memq search-panel (send super-root get-children)) (send super-root add-child search-panel)) (reset-search-anchor (get-text-to-search)))) (define/private (undock) (preferences:set 'framework:search-using-dialog? #t) (hide-search) (search-dialog this)) ;; pre-condition : search-gui-built? is #t (define/private (show/hide-replace hide?) (cond [hide? (send replace-canvas-panel change-children (λ (l) null)) (send replace-button-panel change-children (λ (l) null)) (send middle-middle-panel change-children (λ (l) null))] [else (send replace-canvas-panel change-children (λ (l) (list replace-canvas))) (send replace-button-panel change-children (λ (l) (list replace-button))) (send middle-middle-panel change-children (λ (l) (list replace&search-button replace-all-button)))])) (define remove-callback (preferences:add-callback 'framework:search-using-dialog? (λ (p v) (when p (hide-search))))) (define/augment (on-close) (remove-callback) (let ([close-canvas (λ (canvas edit) (send canvas set-editor #f))]) (when search-gui-built? (close-canvas find-canvas find-edit) (close-canvas replace-canvas replace-edit))) (when (eq? this searching-frame) (set-searching-frame #f)) (inner (void) on-close)) (public set-search-direction can-replace? replace&search replace-all replace toggle-search-focus move-to-search-or-search move-to-search-or-reverse-search search-again) (define set-search-direction (λ (x) (set-searching-direction x) (when dir-radio (send dir-radio set-selection (if (eq? x 'forward) 0 1))))) (define can-replace? (λ () (let ([tx (get-text-to-search)]) (and tx (not (= 0 (send replace-edit last-position))) (string=? (send tx get-text (send tx get-start-position) (send tx get-end-position)) (send find-edit get-text 0 (send find-edit last-position))))))) (define replace&search (λ () (let ([text (get-text-to-search)]) (send text begin-edit-sequence) (when (replace) (search-again)) (send text end-edit-sequence)))) (define (replace-all) (let* ([replacee-edit (get-text-to-search)] [embeded-replacee-edit (find-embedded-focus-editor replacee-edit)] [pos (if (eq? searching-direction 'forward) (send embeded-replacee-edit get-start-position) (send embeded-replacee-edit get-end-position))] [done? (if (eq? 'forward searching-direction) (λ (x) (>= x (send replacee-edit last-position))) (λ (x) (<= x 0)))]) (send replacee-edit begin-edit-sequence) (when (search-again) (send embeded-replacee-edit set-position pos) (let loop () (when (send find-edit search #t #f #f) (replace) (loop)))) (send replacee-edit end-edit-sequence))) (define (replace) (let* ([search-text (send find-edit get-text)] [replacee-edit (find-embedded-focus-editor (get-text-to-search))] [replacee-start (send replacee-edit get-start-position)] [new-text (send replace-edit get-text)] [replacee (send replacee-edit get-text replacee-start (send replacee-edit get-end-position))]) (if (string=? replacee search-text) (begin (send replacee-edit insert new-text) (send replacee-edit set-position replacee-start (+ replacee-start (string-length new-text))) #t) #f))) (define/private (find-embedded-focus-editor editor) (let loop ([editor editor]) (let ([s (send editor get-focus-snip)]) (cond [(and s (is-a? s editor-snip%)) (let ([next-ed (send s get-editor)]) (if next-ed (loop next-ed) editor))] [else editor])))) (define (toggle-search-focus) (when find-canvas (set-searching-frame this) (unhide-search) (send (cond [(send find-canvas has-focus?) replace-canvas] [(send replace-canvas has-focus?) (send (get-text-to-search) get-canvas)] [else find-canvas]) focus))) (define move-to-search-or-search (λ () (set-searching-frame this) (unhide-search) (cond [(preferences:get 'framework:search-using-dialog?) (search-dialog this)] [else (if (or (send find-canvas has-focus?) (send replace-canvas has-focus?)) (search-again 'forward) (send find-canvas focus))]))) (define move-to-search-or-reverse-search (λ () (set-searching-frame this) (unhide-search) (cond [(preferences:get 'framework:search-using-dialog?) (search-again 'backward) (set-searching-direction 'forward)] [else (if (or (send find-canvas has-focus?) (send replace-canvas has-focus?)) (search-again 'backward) (send find-canvas focus))]))) (define search-again (opt-lambda ([direction searching-direction] [beep? #t]) (set-searching-frame this) (unhide-search) (set-search-direction direction) (send find-edit search #t beep?))) (define search-panel #f) (define search-gui-built? #f) (define dir-radio #f) (define replace-canvas-panel #f) (define find-canvas #f) (define replace-canvas #f) (define hidden? #t) (define replace-button-panel #f) (define middle-middle-panel #f) (define replace-button #f) (define replace&search-button #f) (define replace-all-button #f) (inherit begin-container-sequence end-container-sequence) (define/private (build-search-gui-in-frame) (unless search-gui-built? (set! search-gui-built? #t) (begin-container-sequence) (let () (define _0 (set! search-panel (make-object horizontal-panel% super-root '(border)))) (define left-panel (make-object vertical-panel% search-panel)) (define _1 (set! find-canvas (make-object searchable-canvas% left-panel))) (define _2 (set! replace-canvas-panel (instantiate vertical-panel% () (parent left-panel) (stretchable-width #t) (stretchable-height #f)))) (define _3 (set! replace-canvas (make-object searchable-canvas% replace-canvas-panel))) (define middle-left-panel (make-object vertical-pane% search-panel)) (define _4 (set! middle-middle-panel (make-object vertical-pane% search-panel))) (define middle-right-panel (make-object vertical-pane% search-panel)) (define search-button (make-object button% (string-constant find) middle-left-panel (λ args (search-again)))) (define _5 (set! replace-button-panel (instantiate vertical-panel% () (parent middle-left-panel) (stretchable-width #f) (stretchable-height #f)))) (define _6 (set! replace-button (make-object button% (string-constant replace) replace-button-panel (λ x (replace))))) (define _7 (set! replace&search-button (make-object button% (string-constant replace&find-again) middle-middle-panel (λ x (replace&search))))) (define _8 (set! replace-all-button (make-object button% (string-constant replace-to-end) middle-middle-panel (λ x (replace-all))))) (define _9 (set! dir-radio (make-object radio-box% #f (list (string-constant forward) (string-constant backward)) middle-right-panel (λ (dir-radio evt) (let ([forward (if (= (send dir-radio get-selection) 0) 'forward 'backward)]) (set-search-direction forward) (reset-search-anchor (get-text-to-search))))))) (define hide/undock-pane (make-object horizontal-panel% middle-right-panel)) (define hide-button (make-object button% (string-constant hide) hide/undock-pane (λ args (hide-search)))) (define undock-button (make-object button% (string-constant undock) hide/undock-pane (λ args (undock)))) (let ([align (λ (x y) (let ([m (max (send x get-width) (send y get-width))]) (send x min-width m) (send y min-width m)))]) (align search-button replace-button) (align replace&search-button replace-all-button)) (for-each (λ (x) (send x set-alignment 'center 'center)) (list middle-left-panel middle-middle-panel)) (for-each (λ (x) (send x stretchable-height #f)) (list search-panel middle-left-panel middle-middle-panel middle-right-panel)) (for-each (λ (x) (send x stretchable-width #f)) (list middle-left-panel middle-middle-panel middle-right-panel)) (send find-canvas set-editor find-edit) (send find-canvas stretchable-height #t) (send replace-canvas set-editor replace-edit)) (end-container-sequence))) (super-instantiate ()) (hide-search #t))) (define searchable-text<%> (interface (searchable<%> text<%>))) (define searchable-text-mixin (mixin (text<%> searchable<%>) (searchable-text<%>) (inherit get-editor) (define/override (get-text-to-search) (get-editor)) (define/override (get-editor<%>) text:searching<%>) (define/override (get-editor%) text:searching%) (super-instantiate ()))) (define memory-text% (class text% (super-new))) (define memory-text (make-object memory-text%)) (send memory-text hide-caret #t) (define show-memory-text? (or (with-handlers ([exn:fail:filesystem? (λ (x) #f)]) (directory-exists? (collection-path "repos-time-stamp"))) (let ([fw (collection-path "framework")]) (with-handlers ([exn:fail:filesystem? (λ (x) #f)]) (or (directory-exists? (build-path fw ".svn")) (directory-exists? (build-path fw "CVS"))))))) (define bday-click-canvas% (class canvas% (define/override (on-event evt) (cond [(and (mrf-bday?) (send evt button-up?)) (message-box (string-constant drscheme) (string-constant happy-birthday-matthew))] [else (super on-event evt)])) (super-instantiate ()))) (define basic% (register-group-mixin (basic-mixin frame%))) (define size-pref% (size-pref-mixin basic%)) (define info% (info-mixin basic%)) (define text-info% (text-info-mixin info%)) (define pasteboard-info% (pasteboard-info-mixin text-info%)) (define status-line% (status-line-mixin text-info%)) (define standard-menus% (standard-menus-mixin status-line%)) (define editor% (editor-mixin standard-menus%)) (define open-here% (open-here-mixin editor%)) (define -text% (text-mixin open-here%)) (define searchable% (searchable-text-mixin (searchable-mixin -text%))) (define delegate% (delegate-mixin searchable%)) (define -pasteboard% (pasteboard-mixin open-here%)))))