diff --git a/collects/mred/private/snipfile.ss b/collects/mred/private/snipfile.ss index ed990c4969..db4e61ae4f 100644 --- a/collects/mred/private/snipfile.ss +++ b/collects/mred/private/snipfile.ss @@ -15,18 +15,39 @@ ;; 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 ([void (lambda (x) #f)]) + (let ([m (with-handlers ([exn:fail:read? (lambda (x) #f)]) (and (regexp-match #rx"^[(].*[)]$" str) - (read (open-input-string str))))]) - (if (and (list? m) - (eq? 'lib (car m)) - (andmap string? (cdr m))) - (let ([result (dynamic-require m id)]) - (if (is-a? result %) - result - (error 'load-class "not a ~a% instance" id))) + (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-snip-class-getter @@ -233,7 +254,7 @@ (let ([p (open-input-file filename)]) (port-count-lines! p) (let ([p (cond - [(regexp-match-peek #rx#"^WXME01[0-9][0-9] ## " p) + [(regexp-match-peek #rx#"^(?:#reader(lib\"wxme[.]ss\"\"mred\"))?WXME01[0-9][0-9] ## " p) (let ([t (make-object text%)]) (send t insert-port p 'standard) (close-input-port p) diff --git a/collects/mred/wxme.ss b/collects/mred/wxme.ss new file mode 100644 index 0000000000..fe0aac6944 --- /dev/null +++ b/collects/mred/wxme.ss @@ -0,0 +1,7 @@ + +(module wxme mzscheme + (require "wxme/wxme.ss") + + (provide (rename wxme:read read) + (rename wxme:read-syntax read-syntax))) + diff --git a/collects/mred/wxme/comment.ss b/collects/mred/wxme/comment.ss new file mode 100644 index 0000000000..514cb95ad2 --- /dev/null +++ b/collects/mred/wxme/comment.ss @@ -0,0 +1,20 @@ + +(module comment mzscheme + (require (lib "class.ss") + (lib "string.ss") + "../wxmefile.ss" + "nested.ss") + + (provide reader) + + (define reader + (new (class nested-reader% + (define/override (read-snip text? vers stream) + (let ([s (super read-snip text? vers stream)]) + (if text? + (apply bytes-append + (map (lambda (s) + (bytes-append #"; " s #"\n")) + (regexp-split #rx#"\n" s))) + s))) + (super-new))))) diff --git a/collects/mred/wxme/compiled/wxme.dep b/collects/mred/wxme/compiled/wxme.dep new file mode 100644 index 0000000000..d945c8dcaf --- /dev/null +++ b/collects/mred/wxme/compiled/wxme.dep @@ -0,0 +1 @@ +("369.5" (collects . #"mzlib/port.ss") (collects . #"mzlib/string.ss") (collects . #"mzlib/kw.ss") (collects . #"mzlib/class.ss")) diff --git a/collects/mred/wxme/compiled/wxme.zo b/collects/mred/wxme/compiled/wxme.zo new file mode 100644 index 0000000000..d7b7b291c7 Binary files /dev/null and b/collects/mred/wxme/compiled/wxme.zo differ diff --git a/collects/mred/wxme/nested.ss b/collects/mred/wxme/nested.ss new file mode 100644 index 0000000000..b0fd00a1f5 --- /dev/null +++ b/collects/mred/wxme/nested.ss @@ -0,0 +1,29 @@ + +(module nested mzscheme + (require (lib "class.ss") + (lib "struct.ss") + "../wxmefile.ss") + + (provide nested-reader% + (struct readable-nested (reader data))) + + (define-struct/properties (readable-nested nested) (reader data) + ([prop:readable (lambda (this src line col pos) + (send (readable-nested-reader this) generate-special this src line col pos))])) + + (define nested-reader% + (class object% + (define/public (read-header vers stream) + (void)) + (define/public (read-nested-snip text? vers stream data) + (let ([s (send stream read-nested-editor)]) + (if text? + s + (make-readable-nested s this data)))) + (define/public (read-snip text? vers stream) + (read-nested-snip text? vers stream #f)) + + (define/public (generate-special nested src line col pos) + (make-special-comment nested)) + + (super-new)))) diff --git a/collects/mred/wxme/number.ss b/collects/mred/wxme/number.ss new file mode 100644 index 0000000000..c67f3fbd1b --- /dev/null +++ b/collects/mred/wxme/number.ss @@ -0,0 +1,23 @@ + +(module number mzscheme + (require (lib "class.ss")) + + (provide reader) + + (define reader + (new + (class object% + (define/public (read-header vers stream) + (void)) + (define/public (read-snip text? cvers stream) + (let ([number (send stream read-bytes "number")] + [decimal-prefix (send stream read-bytes "decimal prefix")] + [fraction-bytes (send stream read-bytes "fraction")] + [expansions (send stream read-bytes "expansions")]) + number)) + (super-new))))) + + + + + \ No newline at end of file diff --git a/collects/mred/wxme/scheme.ss b/collects/mred/wxme/scheme.ss new file mode 100644 index 0000000000..697f4c4f47 --- /dev/null +++ b/collects/mred/wxme/scheme.ss @@ -0,0 +1,23 @@ + +(module scheme mzscheme + (require (lib "class.ss") + "../wxmefile.ss" + "nested.ss") + + (provide reader) + + (define reader + (new + (class nested-reader% + (inherit read-nested-snip) + (define/override (read-snip text? vers stream) + (let ([splice? (zero? (send stream read-integer "splice?"))]) + (read-nested-snip text? vers stream splice?))) + + (define/override (generate-special nested src line col pos) + (list (if (readable-nested-data nested) + 'unquote-splicing + 'unquote) + (read (nested-content-port nested)))) + + (super-new))))) diff --git a/collects/mred/wxme/text.ss b/collects/mred/wxme/text.ss new file mode 100644 index 0000000000..4e3839a5b5 --- /dev/null +++ b/collects/mred/wxme/text.ss @@ -0,0 +1,18 @@ + +(module text mzscheme + (require (lib "class.ss") + "../wxmefile.ss" + "nested.ss") + + (provide reader) + + (define reader + (new (class nested-reader% + (define/override (generate-special nested src line col pos) + (let ([port (nested-content-port nested)]) + (let loop ([accum null]) + (let ([s (read-bytes 4096 port)]) + (if (eof-object? s) + (bytes->string/utf-8 (apply bytes-append (reverse accum))) + (loop (cons s accum))))))) + (super-new))))) diff --git a/collects/mred/wxme/wxme.ss b/collects/mred/wxme/wxme.ss new file mode 100644 index 0000000000..b44af9ea13 --- /dev/null +++ b/collects/mred/wxme/wxme.ss @@ -0,0 +1,595 @@ + +(module wxme mzscheme + (require (lib "port.ss") + (lib "string.ss") + (lib "kw.ss") + (lib "class.ss")) + + (define (expect rx port who msg) + (let ([m (regexp-match rx port)]) + (unless m + (error who "bad WXME stream; ~a" msg)) + (car m))) + + (define (decode who port snip-filter) + (expect #rx#"^WXME" port who "does not start with \"WXME\"") + (expect #rx#"^01" port who "unrecognized format (not \"01\")") + (let ([vers (string->number + (bytes->string/latin-1 + (expect #rx#"^0[1-8]" port who "unrecognized version")))]) + (unless (vers . < . 4) + (expect #rx#"^ ##[ \r\n]" port who "missing \" ## \" tag in the expected place")) + (let ([header (read-header who port vers snip-filter)]) + (port->decoded-port who port vers header)))) + + (define-struct header (classes data-classes styles snip-filter skip-unknown? snips-to-go stream)) + (define (header-plain-text? h) + (not (header-snip-filter h))) + + (define (read-header who port vers snip-filter) + (let* ([classes (read-snip-class-list who port vers)] + [data-classes (read-data-class-list who port vers)] + [header (make-header classes + data-classes + (make-hash-table) + snip-filter + (unknown-extensions-skip-enabled) + 0 + #f)]) + (set-header-stream! header (make-object stream% who port vers header)) + (let ([cnt (read-editor who port vers header)]) + (set-header-snips-to-go! header cnt)) + header)) + + (define (read-editor who port vers header) + (discard-headers/footers who port vers) + (read-styles who port vers (header-styles header)) + (read-class-headers who port vers header) + (read-integer who port vers "snip count")) + + (define (read-editor-footers who port vers header) + (discard-headers/footers who port vers)) + + (define (read-nested-editor who port vers header) + (let ([cnt (read-editor who port vers header)]) + (let loop ([cnt cnt][accum null]) + (if (zero? cnt) + (begin + (read-editor-footers who port vers header) + (if (header-plain-text? header) + (apply bytes-append (reverse accum)) + (snip-results->port 'nested-editor + (let ([results (reverse accum)]) + (lambda () + (and (pair? results) + (begin0 + (car results) + (set! results (cdr results))))))))) + (loop (sub1 cnt) + (cons (read-snip who port vers header) + accum)))))) + + (define-struct snip-class (name version required? manager)) + + (define (read-snip-class-list who port vers) + (let ([cnt (read-integer who port vers "snip-class count")]) + (list->vector + (let loop ([i 0]) + (if (= i cnt) + null + (cons + (let ([name (read-a-string who port vers "snip-class name")]) + (make-snip-class name + (read-integer who port vers "snip-class version") + (begin (read-integer who port vers "snip-class required?") + ;; required? value isn't actually used; only a few + ;; built-in classes are required + (member name '(#"wxtext" #"wxtab" #"wxmedia"))) + #f)) + (loop (add1 i)))))))) + + (define-struct data-class (name required? manager)) + + (define (read-data-class-list who port vers) + (let ([cnt (read-integer who port vers "data-class count")]) + (list->vector + (let loop ([i 0]) + (if (= i cnt) + null + (cons + (let ([name (read-a-string who port vers "data-class name")]) + (make-data-class name + (equal? name #"wxloc") + #f)) + (loop (add1 i)))))))) + + (define (discard-headers/footers who port vers) + (let ([cnt (read-fixed-integer who port vers "header/footer extension count")]) + (let loop ([i 0]) + (unless (= i cnt) + (let ([len (read-fixed-integer who port vers "header/footer extension length")]) + (skip-data port vers len) + (loop (add1 i))))))) + + (define (read-styles who port vers styles) + (let ([id (read-integer who port vers "style-list id")]) + (hash-table-get styles id + (lambda () + (let ([cnt (read-integer who port vers "style count")]) + (let loop ([i 1]) + (unless (= i cnt) + (unless ((read-integer who port vers "base-style id") . < . i) + (read-error who "integer less than current index" "base-style id" port)) + (read-a-string who port vers "style name") + (if (zero? (read-integer who port vers "style is-join?")) + (begin + (read-integer who port vers "style family") + (read-a-string who port vers "style face") + (read-inexact who port vers "style size multiply") + (read-integer who port vers "style size addition") + (read-integer who port vers "style weight on") + (read-integer who port vers "style weight off") + (read-integer who port vers "style slant on") + (read-integer who port vers "style slant off") + (unless (vers . < . 5) + (read-integer who port vers "style smoothing on") + (read-integer who port vers "style smoothing off")) + (read-integer who port vers "style underlined on") + (read-integer who port vers "style underlined off") + (unless (vers . < . 6) + (read-integer who port vers "style size-in-pixels on") + (read-integer who port vers "style size-in-pixels off")) + (unless (vers . < . 3) + (read-integer who port vers "style transparent on") + (read-integer who port vers "style transparent off")) + (read-inexact who port vers "style foreground multiply red") + (read-inexact who port vers "style foreground multiply green") + (read-inexact who port vers "style foreground multiply blue") + (read-inexact who port vers "style background multiply red") + (read-inexact who port vers "style background multiply green") + (read-inexact who port vers "style background multiply blue") + (read-integer who port vers "style foreground addition red") + (read-integer who port vers "style foreground addition green") + (read-integer who port vers "style foreground addition blue") + (read-integer who port vers "style background addition red") + (read-integer who port vers "style background addition green") + (read-integer who port vers "style background addition blue") + (read-integer who port vers "style alignment on") + (read-integer who port vers "style alignment off")) + (unless ((read-integer who port vers "shift-style id") . < . i) + (read-error who "integer less than current index" "shift-style id" port))) + (loop (add1 i))))) + (hash-table-put! styles id id))))) + + (define (read-class-headers who port vers header) + (let ([cnt (read-fixed-integer who port vers "class-header count")]) + (let loop ([i 0]) + (unless (= i cnt) + (let ([pos (read-integer who port vers "class-header class index")] + [len (read-fixed-integer who port vers "class-header length")]) + (let ([class (find-class pos header who port vers)]) + (if (and class + (object? (snip-class-manager class))) + (send (snip-class-manager class) read-header (snip-class-version class) (header-stream header)) + (skip-data port vers len))) + (loop (add1 i))))))) + + (define (read-snip who port vers header) + (let ([pos (read-integer who port vers "snip class index")]) + (let ([class (find-class pos header who port vers)]) + (let ([len (and (or (not class) + (not (snip-class-required? class))) + (read-fixed-integer who port vers "snip length"))]) + (if class + (let ([style (read-integer who port vers "snip style index")] + [m (snip-class-manager class)] + [cvers (snip-class-version class)]) + (let ([s (if (procedure? m) + (m who port vers cvers header) + (send m read-snip + (header-plain-text? header) + cvers + (header-stream header)))]) + (read-buffer-data who port vers header) + (if (bytes? s) + s + (let ([s ((header-snip-filter header) s)]) + (lambda (src line col pos) + (if (readable? s) + ((readable-ref s) s src line col pos) + s)))))) + (begin + (skip-data port vers len) + #"")))))) + + (define (read-buffer-data who port vers header) + (let loop () + (let ([pos (read-integer who port vers "data-class index")]) + (unless (zero? pos) + (let ([data-class (find-data-class pos header who port vers)]) + (let ([len (and (or (not data-class) + (not (data-class-required? data-class))) + (read-fixed-integer who port vers "data length"))]) + (if data-class + ((data-class-manager data-class) who port vers header) + (skip-data port vers len)))) + (loop))))) + + ;; ---------------------------------------- + + (define (read-raw-string who port vers what) + (let ([v (cond + [(vers . >= . 8) (plain-read port)] + [else (read-integer who port vers what)])]) + (unless (and (integer? v) + (exact? v) + (v . >= . 0)) + (read-error who "non-negative exact integer for string length" what port)) + (let ([s (cond + [(vers . >= . 8) (plain-read port)] + [else (read-bytes v port)])]) + (cond + [(bytes? s) + (unless (= (bytes-length s) v) + (read-error who "byte string whose length matches an integer count" what port)) + s] + [(and (list? s) + (andmap bytes? s)) + (let ([s (apply bytes-append s)]) + (unless (= (bytes-length s) v) + (read-error who "list of byte strings whose total length matches an integer count" what port)) + s)] + [else + (read-error who "byte string or byte-string list" what port)])))) + + (define (read-a-string who port vers what) + (let ([s (read-raw-string who port vers what)]) + (subbytes s 0 (sub1 (bytes-length s))))) + + (define (read-integer who port vers what) + (cond + [(vers . >= . 8) + (let ([v (plain-read port)]) + (unless (and (integer? v) + (exact? v) + (<= (- (expt 2 31)) v (expt 2 31))) + (read-error who "exact integer between [-2^31,2^31]" what port)) + v)] + [else + (let ([b (read-byte port)]) + (cond + [(not (zero? (bitwise-and b #x80))) + (cond + [(not (zero? (bitwise-and b #x40))) + (cond + [(bitwise-and b #x01) + (let ([b (read-byte port)]) + ;; convert to signed: + (if (b . > . 127) + (- b 256) + b))] + [(not (zero? (bitwise-and b #x02))) + (integer-bytes->integer (read-bytes 2 port) #t #t)] + [else + (integer-bytes->integer (read-bytes 4 port) #t #t)])] + [else + (bitwise-ior (arithmetic-shift (bitwise-and #x3F b) 8) + (read-byte port))])] + [else b]))])) + + (define (read-fixed-integer who port vers what) + (cond + [(vers . >= . 8) + (read-integer who port vers what)] + [else + (integer-bytes->integer (read-bytes 4 port) + #t + (if (vers . > . 1) + #t + (system-big-endian?)))])) + + (define (read-inexact who port vers what) + (cond + [(vers . >= . 8) + (let ([v (plain-read port)]) + (unless (and (number? v) + (real? v)) + (read-error who "real number" what port)) + v)] + [else + (floating-point-bytes->real (read-bytes 8 port) + (if (vers . > . 1) + #t + (system-big-endian?)))])) + + + (define (read-error who expected what port) + (error who "WXME format problem while reading for ~a (expected ~a) from port: ~v" + what expected port)) + + (define (skip-data port vers len) + (if (vers . >= . 8) + (let loop ([len len]) + (unless (zero? len) + (plain-read port) + (loop (sub1 len)))) + (read-bytes len port))) + + ;; ---------------------------------------- + + (define-values (prop:readable readable? readable-ref) + (make-struct-type-property 'readable)) + + (define-struct nested (content-port)) + (define-struct image (filename data w h dx dy)) + + (define (find-class pos header who port vers) + (define classes (header-classes header)) + (unless (< -1 pos (vector-length classes)) + (read-error who "integer less than class-list length" "class index" port)) + (let ([class (vector-ref classes pos)]) + (unless (snip-class-manager class) + (set-snip-class-manager! + class + (let ([name (snip-class-name class)]) + (cond + [(member name '(#"wxtext" #"wxtab")) + (lambda (who port vers cvers header) + (read-integer who port vers "string-snip flags") + (let ([s (read-raw-string who port vers "string-snip content")]) + (cond + [(= cvers 1) (string->bytes/utf-8 (bytes->string/latin-1 s))] + [(= cvers 2) + ;; UTF-32! + (unless (zero? (remainder (bytes-length s) 4)) + (read-error who "size of read byte string is not a multiple of 4" "string-snip content" port)) + (let loop ([pos 0][accum null]) + (if (= pos (bytes-length s)) + (string->bytes/utf-8 (apply string (reverse accum))) + (loop (+ pos 4) + (cons (integer-bytes->integer (subbytes s pos (+ pos 4))) + accum))))] + [(cvers . > . 2) s])))] + [(equal? name #"wxmedia") + (lambda (who port vers cvers header) + (read-integer who port vers "nested-editor type") + (read-integer who port vers "nested-editor border") + (read-integer who port vers "nested-editor left margin") + (read-integer who port vers "nested-editor top margin") + (read-integer who port vers "nested-editor right margin") + (read-integer who port vers "nested-editor bottom margin") + (read-integer who port vers "nested-editor left inset") + (read-integer who port vers "nested-editor top inset") + (read-integer who port vers "nested-editor right inset") + (read-integer who port vers "nested-editor bottom inset") + (read-inexact who port vers "nested-editor min width") + (read-inexact who port vers "nested-editor max width") + (read-inexact who port vers "nested-editor min height") + (read-inexact who port vers "nested-editor max height") + (when (cvers . > . 1) + (read-integer who port vers "nested-editor tight-fit?")) + (when (cvers . > . 2) + (read-integer who port vers "nested-editor alignment")) + (let ([n (read-nested-editor who port vers header)]) + (if (header-plain-text? header) + n + (make-nested n))))] + [(equal? name #"wximage") + (lambda (who port vers cvers header) + (let ([filename (read-a-string who port vers "image-snip filename")] + [type (read-integer who port vers "image-snip type")] + [w (read-inexact who port vers "image-snip width")] + [h (read-inexact who port vers "image-snip height")] + [dx (read-inexact who port vers "image-snip x-offset")] + [dy (read-inexact who port vers "image-snip y-offset")] + [rel? (read-integer who port vers "image-snip relative?")]) + (let ([data + (and (and (equal? filename #"") + (cvers . > . 1) + (not (zero? type))) + ;; inlined image + (apply + bytes-append + (let ([len (read-fixed-integer who port vers "image-snip image length")]) + (let loop ([i 0]) + (if (= i len) + null + (cons + (read-a-string who port vers "image-snip image content") + (loop (add1 i))))))))]) + (if (header-plain-text? header) + #"." + (make-image (if data #f filename) data w h dx dy)))))] + [else + ;; Load a manager for this snip class? + (let ([lib (string->lib-path (bytes->string/latin-1 name))]) + (if lib + (let ([mgr (dynamic-require lib 'reader)]) + mgr) + (if (header-skip-unknown? header) + #f + (error who "cannot load snip-class reader: ~s" name))))])))) + class)) + + (define (find-data-class pos header who port vers) + (define data-classes (header-data-classes header)) + (unless (< -1 pos (vector-length data-classes)) + (read-error who "integer less than data-class-list length" "data-class index" port)) + (let ([data-class (vector-ref data-classes pos)]) + (unless (data-class-manager data-class) + (set-data-class-manager! + data-class + (case (data-class-name data-class) + [(#"wxloc") + (lambda (who port vers header) + (read-inexact who port vers "location x") + (read-inexact who port vers "location y"))] + [else + ;; Load a manager for this data class? + (error who "cannot load data-class managers, yet")]))) + data-class)) + + (define stream% + (class object% + (init-field who port vers header) + + (public [rfi read-fixed-integer]) + (define (rfi what) + (read-fixed-integer who port vers what)) + + (public [ri read-integer]) + (define (ri what) + (read-integer who port vers what)) + + (public [rix read-inexact]) + (define (rix what) + (read-inexact who port vers what)) + + (define/public (read-raw-bytes what) + (read-raw-string who port vers what)) + (define/public (read-bytes what) + (read-a-string who port vers what)) + + (public [rne read-nested-editor]) + (define (rne) + (read-nested-editor who port vers header)) + + (super-new))) + + ;; ---------------------------------------- + + (define lib-mapping (make-hash-table 'equal)) + + (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)))) + + (define (register-lib-mapping! str target) + (let ([lib (with-handlers ([exn:fail? (lambda (x) #f)]) + (read (open-input-string target)))]) + (unless (ok-lib-path? lib) + (error 'register-lib-mapping! "given target is not a valid lib path: ~s" target)) + (hash-table-put! lib-mapping str lib))) + + (define (string->lib-path str) + (or (let ([m (and (regexp-match #rx"^[(].*[)]$" str) + (let* ([p (open-input-string str)] + [m (read p)]) + (and (eof-object? (read p)) + m)))]) + (and (and (list? m) + (= (length m) 2) + (ok-lib-path? (car m) + (ok-lib-path? (cadr m)))) + (cadr m))) + (hash-table-get lib-mapping str #f))) + + ;; ---------------------------------------- + + (define plain-params + (parameterize ([current-readtable #f] + [read-accept-reader #f] + [read-case-sensitive #t] + [read-accept-graph #f] + [read-accept-box #f] + [read-accept-bar-quote #t] + [read-decimal-as-inexact #t] + [read-accept-dot #t] + [read-accept-quasiquote #f] + [read-accept-compiled #f]) + (current-parameterization))) + + (define (plain-read port) + (call-with-parameterization + plain-params + (lambda () + (with-handlers ([exn:fail:read? (lambda () 'no-good)]) + (read port))))) + + ;; ---------------------------------------- + + (define (port->decoded-port who port vers header) + (snip-results->port + (object-name port) + (lambda () + (let ([snips-to-go (header-snips-to-go header)]) + (cond + [(zero? snips-to-go) #f] + [else + (set-header-snips-to-go! header (sub1 snips-to-go)) + (read-snip who port vers header)]))))) + + (define (snip-results->port name next-item!) + (define-values (r w) (make-pipe)) + (define (read-proc buffer) + (if (char-ready? r) + (read-bytes-avail! buffer r) + (let ([s (next-item!)]) + (cond + [(not s) + (close-output-port w) + eof] + [(bytes? s) + (write-bytes s w) + (read-proc buffer)] + [else s])))) + (make-input-port/read-to-peek + name + read-proc + #f + void)) + + ;; ---------------------------------------- + + (define unknown-extensions-skip-enabled (make-parameter #f)) + + (define/kw (decode-wxme-stream port #:optional [snip-filter (lambda (x) x)]) + ;; read optional #reader header: + (regexp-match/fail-without-reading #rx#"^#reader[(]lib\"wxme.ss\"\"mred\"[)]" port) + ;; decode: + (decode 'read-bytes port snip-filter)) + + (define (do-read port who read) + (let ([port (decode who port #t)]) + (let ([v (read port)]) + (let ([v2 (let loop () + (let ([v2 (read port)]) + (if (special-comment? v2) + (loop) + v2)))]) + (if (eof-object? v) + null + `(begin + ,@(list v v2 (let loop ([accum null]) + (let ([v (read port)]) + (cond + [(eof-object? v) (reverse accum)] + [(special-comment? v) (loop accum)] + [else (loop (cons v accum))])))))))))) + + (define (wxme:read port) + (do-read port 'read read)) + + (define (wxme:read-syntax source-name-v port) + (do-read port 'read-syntax + (lambda (port) + (read-syntax source-name-v port)))) + + (provide register-lib-mapping! + unknown-extensions-skip-enabled + decode-wxme-stream + (struct nested (content-port)) + (struct image (filename data w h dx dy)) + prop:readable + wxme:read + wxme:read-syntax)) + diff --git a/collects/mred/wxme/xml.ss b/collects/mred/wxme/xml.ss new file mode 100644 index 0000000000..c261fd530a --- /dev/null +++ b/collects/mred/wxme/xml.ss @@ -0,0 +1,52 @@ + +(module xml mzscheme + (require (lib "class.ss") + (lib "xml.ss" "xml") + (lib "list.ss") + "../wxmefile.ss" + "nested.ss") + + (provide reader) + + (define reader + (new (class nested-reader% + (inherit read-nested-snip) + (define/override (read-snip text? vers stream) + (let ([elim-whitespace? (zero? (send stream read-integer "elim-whitespace?"))]) + (read-nested-snip text? vers stream elim-whitespace?))) + + (define/override (generate-special nested src line col pos) + (let* ([port (nested-content-port nested)] + [xml (read-xml port)] + [xexpr (xml->xexpr (document-element xml))] + [clean-xexpr (if (readable-nested-data nested) + (eliminate-whitespace-in-empty-tags xexpr) + xexpr)]) + (list 'quasiquote clean-xexpr))) + + (super-new)))) + + ;; FIXME! Copied from xml-snip-helpers.ss verbatim + (define (eliminate-whitespace-in-empty-tags xexpr) + (cond + [(and (pair? xexpr) + (symbol? (car xexpr))) + (list* (car xexpr) + (cadr xexpr) + (map eliminate-whitespace-in-empty-tags + (eliminate-whitespace-in-list (cddr xexpr))))] + [else xexpr])) + (define (eliminate-whitespace-in-list xexprs) + (cond + [(andmap (lambda (x) (or (not (string? x)) + (string-whitespace? x))) + xexprs) + (filter (lambda (x) (not (string? x))) xexprs)] + [else xexprs])) + (define (string-whitespace? str) + (let loop ([i (string-length str)]) + (cond + [(zero? i) #t] + [(char-whitespace? (string-ref str (- i 1))) + (loop (- i 1))] + [else #f])))) diff --git a/collects/mred/wxmecompat.ss b/collects/mred/wxmecompat.ss new file mode 100644 index 0000000000..b13c0817b1 --- /dev/null +++ b/collects/mred/wxmecompat.ss @@ -0,0 +1,39 @@ + +(module wxmecompat mzscheme + (require "wxmefile.ss") + + (register-lib-mapping! + "(lib \"comment-snip.ss\" \"framework\")" + "(lib \"comment.ss\" \"mred\" \"wxme\")") + + (register-lib-mapping! + "drscheme:number" + "(lib \"number.ss\" \"mred\" \"wxme\")") + (register-lib-mapping! + "(lib \"number-snip.ss\" \"drscheme\" \"private\")" + "(lib \"number.ss\" \"mred\" \"wxme\")") + + (register-lib-mapping! + "drscheme:xml-snip" + "(lib \"xml.ss\" \"mred\" \"wxme\")") + (register-lib-mapping! + "(lib \"xml-snipclass.ss\" \"xml\")" + "(lib \"xml.ss\" \"mred\" \"wxme\")") + + (register-lib-mapping! + "drscheme:scheme-snip" + "(lib \"scheme.ss\" \"mred\" \"wxme\")") + (register-lib-mapping! + "(lib \"scheme-snipclass.ss\" \"xml\")" + "(lib \"scheme.ss\" \"mred\" \"wxme\")") + + (register-lib-mapping! + "text-box%" + "(lib \"text.ss\" \"mred\" \"wxme\")") + (register-lib-mapping! + "(lib \"text-snipclass.ss\" \"xml\")" + "(lib \"text.ss\" \"mred\" \"wxme\")") + + (register-lib-mapping! + "(lib \"cache-image-snip.ss\" \"mrlib\")" + "(lib \"image.ss\" \"mred\" \"wxme\")")) diff --git a/collects/mred/wxmefile.ss b/collects/mred/wxmefile.ss new file mode 100644 index 0000000000..54c071ca60 --- /dev/null +++ b/collects/mred/wxmefile.ss @@ -0,0 +1,6 @@ + +(module wxmefile mzscheme + (require "wxme/wxme.ss") + (provide (all-from-except "wxme/wxme.ss" + wxme:read + wxme:read-syntax)))