Separate snip% from the gui

original commit: 8a8a8dbe4ba0eb9ece3ca7dabe0e278de64e467e

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")

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<%>

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!)

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%)))

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)

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 

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%

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"

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))
+  )

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%!))

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"

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

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)

collects/mrlib/private/image-core-bitmap.rkt

@@ -1,5 +1,5 @@
 #lang scheme/base
-(require scheme/gui/base
+(require racket/draw
          scheme/class)