(module wxcanvas racket/base (require racket/class (prefix-in wx: "kernel.rkt") (prefix-in wx: "wxme/text.rkt") (prefix-in wx: "wxme/editor-canvas.rkt") "lock.rkt" "helper.rkt" "wx.rkt" "wxwindow.rkt" "wxitem.rkt") (provide (protect-out make-canvas-glue% wx-canvas% wx-editor-canvas%)) (define (make-canvas-glue% default-tabable? %) ; implies make-window-glue% (class (make-window-glue% %) (init mred proxy) (init-rest args) (inherit get-mred get-top-level clear-margins) (public* [do-on-char (lambda (e) (super on-char e))] [do-on-event (lambda (e) (super on-event e))] [do-on-scroll (lambda (e) (super on-scroll e))] [do-on-paint (lambda () (super on-paint))]) (define tabable? default-tabable?) (define on-popup-callback void) (public* [get-tab-focus (lambda () tabable?)] [set-tab-focus (lambda (v) (set! tabable? v))] [on-tab-in (lambda () (let ([mred (wx->mred this)]) (when mred (send mred on-tab-in))))] [set-on-popup (lambda (proc) (set! on-popup-callback proc))]) (override* [gets-focus? (lambda () tabable?)] [handles-key-code (lambda (code alpha? meta?) (if default-tabable? (super handles-key-code code alpha? meta?) (or meta? (not tabable?))))]) (define clear-and-on-paint (lambda (mred) (clear-margins) (send mred on-paint))) (override* [on-char (entry-point (lambda (e) (let ([mred (get-mred)]) (if mred (as-exit (lambda () (send mred on-char e))) (super on-char e)))))] [on-event (entry-point (lambda (e) (let ([mred (get-mred)]) (if mred (as-exit (lambda () (send mred on-event e))) (as-exit (lambda () (super on-event e)))))))] ;; only called for canvas%, not editor-canvas%: [on-scroll (entry-point (lambda (e) (let ([mred (get-mred)]) (if mred (as-exit (lambda () (send mred on-scroll e))) (as-exit (lambda () (super on-scroll e)))))))] [on-paint (entry-point (lambda () (let ([mred (get-mred)]) (if mred (as-exit (lambda () (clear-and-on-paint mred))) (as-exit (lambda () (clear-margins) (super on-paint)))))))] ;; for 'combo canvases: [on-popup (lambda () (on-popup-callback))]) (apply super-make-object mred proxy args))) (define wx-canvas% (make-canvas-glue% #f (class (make-control% wx:canvas% 0 0 #t #t) (init parent x y w h style gl-config) (inherit get-top-level) (public* [clear-margins (lambda () (void))]) (super-make-object style parent x y w h (cons 'deleted style) "canvas" gl-config) (unless (memq 'deleted style) (send (get-top-level) show-control this #t))))) (define (make-editor-canvas% %) (class % (init parent x y w h name style spp init-buffer) (inherit get-editor force-redraw call-as-primary-owner min-height get-size get-hard-minimum-size set-min-height get-top-level) (define fixed-height? #f) (define fixed-height-lines 0) (define orig-hard #f) (define single-line-canvas? #f) (define tabable? #f) (override* [on-container-resize (lambda () (let ([edit (get-editor)]) (when edit (as-exit (lambda () (send edit on-display-size-when-ready))))))] [on-scroll-on-change (lambda () (queue-window-callback this (lambda () (let ([edit (get-editor)]) (when edit (send edit on-display-size-when-ready))))))] [on-set-focus (entry-point (lambda () (as-exit (lambda () (super on-set-focus))) (let ([m (get-editor)]) (when m (let ([mred (wx->mred this)]) (when mred (as-exit (lambda () (send m set-active-canvas mred)))))))))] [set-editor (letrec ([l (case-lambda [(edit) (l edit #t)] [(edit redraw?) (let ([old-edit (get-editor)]) ;; An exception here means we end up in a bad state: (as-exit (lambda () ;; set-editor can invoke callbacks: (super set-editor edit redraw?))) (let ([mred (wx->mred this)]) (when mred (when old-edit (as-exit (lambda () (send old-edit remove-canvas mred)))) (when edit (as-exit (lambda () (send edit add-canvas mred)))))) (update-size) ;; force-redraw causes on-container-resize to be called, ;; but only when the size of the canvas really matters ;; (i.e., when it is shown) (force-redraw))])]) l)] [handles-key-code (lambda (x alpha? meta?) (case x [(#\tab #\return escape) (and (not tabable?) (not single-line-canvas?))] [else (not meta?)]))] [popup-for-editor (entry-point (lambda (e m) (let ([mwx (mred->wx m)]) (and (send mwx popup-grab e) (as-exit (lambda () (send m on-demand) #t)) mwx))))]) (public* [set-tabable (lambda (on?) (set! tabable? on?))] [is-tabable? (lambda () tabable?)] [set-single-line (lambda () (set! single-line-canvas? #t))] [is-single-line? (lambda () single-line-canvas?)] [set-line-count (lambda (n) (if n (begin (unless orig-hard (let-values ([(hmw hmh) (get-hard-minimum-size)]) (set! orig-hard hmh))) (set! fixed-height? #t) (set! fixed-height-lines n)) (when orig-hard (set! fixed-height? #f) (set-min-height orig-hard))) (update-size))] [get-line-count (lambda () (and fixed-height? fixed-height-lines))] [update-size (lambda () (let ([edit (get-editor)]) (when (and edit fixed-height?) (let* ([top (if (is-a? edit wx:text%) (send edit line-location 0 #t) 0)] [bottom (if (is-a? edit wx:text%) (send edit line-location 0 #f) 14)] [height (- bottom top)]) (let* ([ch (box 0)] [h (box 0)]) (call-as-primary-owner (lambda () (send (send edit get-admin) get-view #f #f #f ch))) (get-size (box 0) h) (let ([new-min-height (+ (* fixed-height-lines height) (- (unbox h) (unbox ch)))]) (set-min-height (inexact->exact (round new-min-height))) (force-redraw)))))))]) (override* [set-y-margin (lambda (m) (super set-y-margin m) (when fixed-height? (update-size)))]) (super-make-object style parent x y w h (or name "") (cons 'deleted style) spp init-buffer) (unless (memq 'deleted style) (send (get-top-level) show-control this #t)) (when init-buffer (let ([mred (wx->mred this)]) (when mred (as-exit (lambda () (send init-buffer add-canvas mred)))))))) (define wx-editor-canvas% (class (make-canvas-glue% #t (make-editor-canvas% (make-control% wx:editor-canvas% 0 0 #t #t))) (inherit editor-canvas-on-scroll set-no-expose-focus) (define/override (on-scroll e) (editor-canvas-on-scroll)) (super-new) #;(set-no-expose-focus))))