suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

MrEd-less reading of WXME files (work in progress, but it's mostly there)

Browse Source 
svn: r5393
This commit is contained in:
Matthew Flatt 2007-01-18 12:20:57 +00:00
parent 05faf4f7d3
commit 208d160a1b
13 changed files with 844 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

41
collects/mred/private/snipfile.ss
View File

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

7
collects/mred/wxme.ss Normal file
View File

@ -0,0 +1,7 @@
(module wxme mzscheme
(require "wxme/wxme.ss")
(provide (rename wxme:read read)
(rename wxme:read-syntax read-syntax)))

20
collects/mred/wxme/comment.ss Normal file
View File

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

1
collects/mred/wxme/compiled/wxme.dep Normal file
View File

@ -0,0 +1 @@
("369.5" (collects . #"mzlib/port.ss") (collects . #"mzlib/string.ss") (collects . #"mzlib/kw.ss") (collects . #"mzlib/class.ss"))

BIN
collects/mred/wxme/compiled/wxme.zo Normal file
View File

Binary file not shown.

29
collects/mred/wxme/nested.ss Normal file
View File

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

23
collects/mred/wxme/number.ss Normal file
View File

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

23
collects/mred/wxme/scheme.ss Normal file
View File

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

18
collects/mred/wxme/text.ss Normal file
View File

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

595
collects/mred/wxme/wxme.ss Normal file
View File

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

52
collects/mred/wxme/xml.ss Normal file
View File

@ -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]))))

39
collects/mred/wxmecompat.ss Normal file
View File

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

6
collects/mred/wxmefile.ss Normal file
View File

@ -0,0 +1,6 @@
(module wxmefile mzscheme
(require "wxme/wxme.ss")
(provide (all-from-except "wxme/wxme.ss"
wxme:read
wxme:read-syntax)))