diff --git a/collects/mred/mred.rkt b/collects/mred/mred.rkt index 3c9e5ed1..15236cdc 100644 --- a/collects/mred/mred.rkt +++ b/collects/mred/mred.rkt @@ -14,6 +14,7 @@ (prefix wx: "private/wxme/snip.ss") (prefix wx: "private/wxme/keymap.ss") (prefix wx: "private/wxme/editor-admin.ss") + (prefix wx: "private/wxme/editor-data.ss") (prefix wx: "private/wxme/editor-snip.ss") (prefix wx: "private/wxme/stream.ss") (prefix wx: "private/wxme/wordbreak.ss") diff --git a/collects/mred/private/snipfile.rkt b/collects/mred/private/snipfile.rkt index 2a609cb2..593014bb 100644 --- a/collects/mred/private/snipfile.rkt +++ b/collects/mred/private/snipfile.rkt @@ -14,50 +14,6 @@ text-editor-load-handler open-output-text-editor ) - ;; snip-class% and editor-data-class% loaders - - (define (ok-string-element? m) - (and (string? m) - (regexp-match? #rx"^[-a-zA-Z0-9_. ]+$" m) - (not (string=? m "..")) - (not (string=? m ".")))) - - (define (ok-lib-path? m) - (and (pair? m) - (eq? 'lib (car m)) - (pair? (cdr m)) - (list? m) - (andmap ok-string-element? (cdr m)))) - - (let ([load-one - (lambda (str id %) - (let ([m (with-handlers ([exn:fail:read? (lambda (x) #f)]) - (and (regexp-match #rx"^[(].*[)]$" str) - (let* ([p (open-input-string str)] - [m (read p)]) - (and (eof-object? (read p)) - m))))]) - (if (or (ok-lib-path? m) - (and (list? m) - (= (length m) 2) - (ok-lib-path? (car m)) - (ok-lib-path? (cadr m)))) - (let ([m (if (ok-lib-path? m) - m - (car m))]) - (let ([result (dynamic-require m id)]) - (if (is-a? result %) - result - (error 'load-class "not a ~a% instance" id)))) - #f)))]) - ;; install the getters: - (wx:set-get-snip-class! - (lambda (name) - (load-one name 'snip-class wx:snip-class%))) - (wx:set-get-editor-data-class! - (lambda (name) - (load-one name 'editor-data-class wx:editor-data-class%)))) - ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define readable-snip<%> diff --git a/collects/mred/private/wxme/cycle.rkt b/collects/mred/private/wxme/cycle.rkt index ee30467e..c8fa72ec 100644 --- a/collects/mred/private/wxme/cycle.rkt +++ b/collects/mred/private/wxme/cycle.rkt @@ -18,7 +18,7 @@ (decl extended-text% set-extended-text%!) (decl extended-pasteboard% set-extended-pasteboard%!) -(decl get-snip-class set-get-snip-class!) +;(decl get-snip-class set-get-snip-class!) (decl get-editor-data-class set-get-editor-data-class!) (decl editor-get-file set-editor-get-file!) diff --git a/collects/mred/private/wxme/editor-data.rkt b/collects/mred/private/wxme/editor-data.rkt new file mode 100644 index 00000000..e2dca23a --- /dev/null +++ b/collects/mred/private/wxme/editor-data.rkt @@ -0,0 +1,171 @@ +#lang racket/base + +(require scheme/class + scheme/file file/convertible + "../syntax.ss" + "snip-flags.ss" + "private.ss" + "style.ss" + "load-one.rkt" + ;; used only in contracts + (only-in "cycle.ss" editor-stream-in% editor-stream-out% snip-admin%) + ;; used for real + (only-in "cycle.ss" get-editor-data-class set-get-editor-data-class!) + "../wx/common/event.rkt" + racket/draw + (only-in "wx.ss" begin-busy-cursor end-busy-cursor get-highlight-text-color)) + +(provide get-the-editor-data-class-list + editor-data% + editor-data-class% + location-editor-data% + editor-data-class-list<%> + the-editor-data-class-list ;; parameter + make-the-editor-data-class-list + (struct-out editor-data-class-link)) + +;; ------------------------------------------------------------ + +(defclass editor-data% object% + (properties [[(make-or-false editor-data-class%) dataclass] #f] + [[(make-or-false editor-data%) next] #f]) + (super-new) + (def/public (write [editor-stream-out% f]) + (error 'write "should have overridden")) + + (define/public (get-s-dataclass) dataclass) + (define/public (get-s-next) next) + (define/public (set-s-next v) (set! next v))) + + +(defclass location-editor-data% editor-data% + (inherit set-dataclass) + (init-field x y) + (super-new) + (set-dataclass the-location-editor-data-class) + + (define/public (get-x) x) + (define/public (get-y) y) + + (def/override (write [editor-stream-out% f]) + (send f put x) + (send f put y) + #t)) + +;; ------------------------------------------------------------ + +(defclass editor-data-class% object% + (define classname "wxbad") + (def/public (set-classname [string? s]) + (set! classname (string->immutable-string s))) + (def/public (get-classname) classname) + + (properties [[bool? required?] #f]) + (define/public (get-s-required?) required?) + + (def/public (read [editor-stream-in% f]) (void)) + + (super-new)) + +(defclass location-editor-data-class% editor-data-class% + (inherit set-classname + set-required?) + + (super-new) + + (set-classname "wxloc") + (set-required? #t) + + (def/override (read [editor-stream-in% f]) + (let ([x (send f get-inexact)] + [y (send f get-inexact)]) + (new location-editor-data% [x x][y y])))) + +(define the-location-editor-data-class + (new location-editor-data-class%)) + +;; ------------------------------------------------------------ + +(define-struct editor-data-class-link ([c #:mutable] [name #:mutable] map-position)) + +(defclass editor-data-class-list% object% + (define ht (make-hash)) + (define pos-ht (make-hash)) + (define rev-pos-ht (make-hash)) + + (super-new) + + (add the-location-editor-data-class) + + (def/public (find [string? name]) + (let ([c (hash-ref ht name #f)]) + (or c + (let ([c (get-editor-data-class name)]) + (when c (add c)) + c)))) + + (def/public (find-position [editor-data-class% c]) + (hash-ref pos-ht c 0)) + + (def/public (add [editor-data-class% c]) + (let ([name (send c get-classname)]) + (hash-set! ht name c) + (let ([n (add1 (hash-count pos-ht))]) + (hash-set! pos-ht c n) + (hash-set! rev-pos-ht n c)))) + + (def/public (number) (hash-count ht)) + + (def/public (nth [exact-nonnegative-integer? n]) (hash-ref rev-pos-ht n #f)) + + (def/public (write [editor-stream-out% f]) + (let ([n (number)]) + (send f put n) + (for ([i (in-range 1 (add1 n))]) + (let ([c (nth i)]) + (send f put (string->bytes/utf-8 (send c get-classname))) + + (send f add-dl (make-editor-data-class-link c + #f + i))))) + #t) + + (def/public (read [editor-stream-in% f]) + (let-boxes ([count 0]) + (send f get count) + (for/and ([i (in-range count)]) + (let ([s (send f get-bytes)]) + (and (send f ok?) + (send f add-dl (make-editor-data-class-link + #f + (bytes->string/utf-8 s #\?) + (add1 i))) + #t))))) + + (define/public (find-by-map-position f n) + (ormap (lambda (s) + (and (= n (editor-data-class-link-map-position s)) + (begin + (when (editor-data-class-link-name s) + (let ([c (find (editor-data-class-link-name s))]) + (when (not c) + ;; unknown class/version + (log-error (format "unknown editor data class: ~e" + (editor-data-class-link-name s)))) + (set-editor-data-class-link-name! s #f) + (set-editor-data-class-link-c! s c))) + (editor-data-class-link-c s)))) + (send f get-dl)))) + +(define editor-data-class-list<%> (class->interface editor-data-class-list%)) + +(define (make-the-editor-data-class-list) + (new editor-data-class-list%)) + +(define the-editor-data-class-list (make-parameter (make-the-editor-data-class-list))) +(define (get-the-editor-data-class-list) + (the-editor-data-class-list)) + +(set-get-editor-data-class! + (lambda (name) + (load-one name 'editor-data-class editor-data-class%))) \ No newline at end of file diff --git a/collects/mred/private/wxme/editor-snip-class.rkt b/collects/mred/private/wxme/editor-snip-class.rkt new file mode 100644 index 00000000..47e8cd61 --- /dev/null +++ b/collects/mred/private/wxme/editor-snip-class.rkt @@ -0,0 +1,77 @@ +#lang racket/base + +(require racket/class + racket/file file/convertible + "../syntax.ss" + "snip-flags.ss" + "private.ss" + "style.ss" + "snip.rkt" + ;; used only in contracts + (only-in "cycle.ss" editor-stream-in% editor-stream-out% snip-admin%) + ;; used for real + (only-in "cycle.ss" + extended-text% extended-pasteboard% extended-editor-snip% + get-editor-data-class) + "../wx/common/event.rkt" + racket/draw) + +(provide the-editor-snip-class) +;; ------------------------------------------------------------ + +(defclass editor-snip-class% snip-class% + (inherit set-classname + set-version) + (inherit-field s-required?) + + (super-new) + + (set-classname "wxmedia") + (set-version 4) + (set! s-required? #t) + + (def/override (read [editor-stream-in% f]) + (let ([vers (send f do-reading-version this)]) + (let ([ed% (case (send f get-exact) + [(1) extended-text%] + [(2) extended-pasteboard%] + [else #f])] + [border? (positive? (send f get-exact))] + [lm (max 0 (send f get-exact))] + [tm (max 0 (send f get-exact))] + [rm (max 0 (send f get-exact))] + [bm (max 0 (send f get-exact))] + [li (max 0 (send f get-exact))] + [ti (max 0 (send f get-exact))] + [ri (max 0 (send f get-exact))] + [bi (max 0 (send f get-exact))] + [min-w (send f get-inexact)] + [max-w (send f get-inexact)] + [min-h (send f get-inexact)] + [max-h (send f get-inexact)] + [tf? (and (vers . > . 1) + (positive? (send f get-exact)))] + [atl? (and (vers . > . 2) + (positive? (send f get-exact)))] + [ubs? (and (vers . > . 3) + (positive? (send f get-exact)))]) + (let ([e (and ed% (new ed%))]) + (let ([snip (make-object extended-editor-snip% + e + border? + lm tm rm bm li ti ri bi + (if (negative? min-w) 'none min-w) + (if (negative? max-w) 'none max-w) + (if (negative? min-h) 'none min-h) + (if (negative? max-h) 'none max-h))]) + (send snip do-set-graphics tf? atl? ubs?) + (if e + (begin + (send e get-style-list) + (send e read-from-file f #t)) + (send snip set-editor #f)) + snip)))))) + +(define the-editor-snip-class (new editor-snip-class%)) + +(send (get-the-snip-class-list) add the-editor-snip-class) diff --git a/collects/mred/private/wxme/editor-snip.rkt b/collects/mred/private/wxme/editor-snip.rkt index 0c74ec30..cc26fec5 100644 --- a/collects/mred/private/wxme/editor-snip.rkt +++ b/collects/mred/private/wxme/editor-snip.rkt @@ -7,6 +7,7 @@ "snip-flags.ss" "editor.ss" "editor-admin.ss" + "editor-snip-class.rkt" "snip-admin.ss" "text.ss" "pasteboard.ss" @@ -360,8 +361,8 @@ (when with-border? (let ([pen (send dc get-pen)]) (when (and (pair? caret) - selected-text-color) - (send dc set-pen selected-text-color 1 'solid)) + (send my-admin get-selected-text-color)) + (send dc set-pen (send my-admin get-selected-text-color) 1 'solid)) (let* ([l (+ orig-x left-inset)] [t (+ orig-y top-inset)] [r (+ l w left-margin right-margin diff --git a/collects/mred/private/wxme/editor.rkt b/collects/mred/private/wxme/editor.rkt index 4cffb161..3e865000 100644 --- a/collects/mred/private/wxme/editor.rkt +++ b/collects/mred/private/wxme/editor.rkt @@ -11,6 +11,7 @@ "stream.ss" "undo.ss" "keymap.ss" + "editor-data.rkt" (only-in "cycle.ss" text% pasteboard% diff --git a/collects/mred/private/wxme/pasteboard.rkt b/collects/mred/private/wxme/pasteboard.rkt index 4bb1e8d7..a84dff9e 100644 --- a/collects/mred/private/wxme/pasteboard.rkt +++ b/collects/mred/private/wxme/pasteboard.rkt @@ -6,6 +6,7 @@ "const.ss" "private.ss" "editor.ss" + "editor-data.rkt" "undo.ss" "style.ss" "snip.ss" diff --git a/collects/mred/private/wxme/snip-admin.rkt b/collects/mred/private/wxme/snip-admin.rkt index f794387d..3e9660bc 100644 --- a/collects/mred/private/wxme/snip-admin.rkt +++ b/collects/mred/private/wxme/snip-admin.rkt @@ -5,11 +5,13 @@ (only-in "cycle.ss" set-snip-admin%! popup-menu%) - "wx.ss") + (prefix-in wx: "wx.ss")) (provide snip-admin% standard-snip-admin%) +(define TAB-WIDTH 20) + (defclass snip-admin% object% (super-new) @@ -48,7 +50,19 @@ #f) (def/public (modified [snip% s] [any? modified?]) - (void))) + (void)) + + (def/public (get-line-spacing) + #f) + + (def/public (get-selected-text-color) + #f) + + (def/public (call-with-busy-cursor [procedure? thunk]) + (void)) + + (def/public (get-tabs [maybe-box? [length #f]] [maybe-box? [tab-width #f]] [maybe-box? [in-units #f]]) + #f)) (set-snip-admin%! snip-admin%) @@ -146,4 +160,27 @@ (def/override (modified [snip% s] [any? modified?]) (when (eq? (send s get-admin) this) - (send editor on-snip-modified s modified?)))) + (send editor on-snip-modified s modified?))) + + (def/override (get-line-spacing) + (if (object-method-arity-includes? editor 'get-line-spacing 0) + (send editor get-line-spacing) + 0)) + + (def/override (get-tabs [maybe-box? [length #f]] [maybe-box? [tab-width #f]] [maybe-box? [in-units #f]]) + (if (object-method-arity-includes? editor 'get-tabs 3) + (send editor get-tabs length tab-width in-units) + (begin (when length (set-box! length 0)) + (when tab-width (set-box! tab-width TAB-WIDTH)) + (when in-units (set-box! in-units #t)) + null))) + + (def/override (get-selected-text-color) + (wx:get-highlight-text-color)) + + (def/override (call-with-busy-cursor [procedure? thunk]) + (dynamic-wind + wx:begin-busy-cursor + thunk + wx:end-busy-cursor)) + ) diff --git a/collects/mred/private/wxme/stream.rkt b/collects/mred/private/wxme/stream.rkt index 429fb9f5..3273d025 100644 --- a/collects/mred/private/wxme/stream.rkt +++ b/collects/mred/private/wxme/stream.rkt @@ -3,6 +3,7 @@ "../syntax.ss" "private.ss" "snip.ss" + "editor-data.rkt" (only-in "cycle.ss" set-editor-stream-in%! set-editor-stream-out%!)) diff --git a/collects/mred/private/wxme/text.rkt b/collects/mred/private/wxme/text.rkt index be32c886..70e7aadf 100644 --- a/collects/mred/private/wxme/text.rkt +++ b/collects/mred/private/wxme/text.rkt @@ -8,6 +8,7 @@ "mline.ss" "private.ss" "editor.ss" + "editor-data.rkt" "undo.ss" "style.ss" "snip.ss" diff --git a/collects/mrlib/cache-image-snip.rkt b/collects/mrlib/cache-image-snip.rkt index 0e37ec1d..2dca534f 100644 --- a/collects/mrlib/cache-image-snip.rkt +++ b/collects/mrlib/cache-image-snip.rkt @@ -1,5 +1,6 @@ (module cache-image-snip mzscheme - (require mred + (require racket/draw + mred/private/wxme/snip mzlib/class mzlib/string mzlib/contract diff --git a/collects/mrlib/image-core.rkt b/collects/mrlib/image-core.rkt index 8d65e271..5f8b5d3a 100644 --- a/collects/mrlib/image-core.rkt +++ b/collects/mrlib/image-core.rkt @@ -29,16 +29,18 @@ has been moved out). (require racket/class racket/draw - racket/gui/base + (for-syntax racket/base) + file/convertible racket/math racket/contract - "private/image-core-bitmap.ss" - "image-core-wxme.ss" - "private/image-core-snipclass.rkt" - "private/regmk.rkt" - (prefix-in cis: "cache-image-snip.ss") - (for-syntax racket/base) - file/convertible) + "private/image-core-bitmap.ss" ;; safe + "image-core-wxme.ss" ;; safe + "private/image-core-snipclass.rkt" ;; safe + "private/regmk.rkt" ;; safe + ;; the hard cases + mred/private/wxme/snip + (prefix-in cis: "cache-image-snip.ss") ;; safe + ) @@ -220,7 +222,7 @@ has been moved out). (render-image img bdc 0 0) (begin0 (send bdc get-bitmap) - (send bdc set-bitmap #f))) + (send bdc set-bitmap #f)))) (define image% (class* snip% (png-convertible<%> equal<%> image<%>) @@ -285,10 +287,7 @@ has been moved out). (when standard (let ([dc (make-object bitmap-dc% (make-object bitmap% 1 1))]) (let-values ([(w h d a) (send dc get-text-extent "X" (send standard get-font))]) - (set! scroll-step (+ h - (if (is-a? ed text%) - (send ed get-line-spacing) - 0))))))))) + (set! scroll-step (+ h (send admin get-line-spacing))))))))) ;; if that didn't happen, set it to 12. (unless scroll-step (set! scroll-step 12)))) @@ -1170,7 +1169,8 @@ the mask bitmap and the original bitmap are all together in a single bytes! to-img bitmap->image - image-snip->image) + image-snip->image + image-snip%) ;; method names (provide get-shape get-bb get-pinhole get-normalized? get-normalized-shape) diff --git a/collects/mrlib/private/image-core-bitmap.rkt b/collects/mrlib/private/image-core-bitmap.rkt index 949acdcb..9b694af2 100644 --- a/collects/mrlib/private/image-core-bitmap.rkt +++ b/collects/mrlib/private/image-core-bitmap.rkt @@ -1,5 +1,5 @@ #lang scheme/base -(require scheme/gui/base +(require racket/draw scheme/class)