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

clean up and add test-case support

Browse Source 
svn: r5406
This commit is contained in:
Matthew Flatt 2007-01-19 02:05:17 +00:00
parent 4baff4e975
commit f7e85c5045
15 changed files with 620 additions and 137 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

35
collects/wxme/cache-image.ss
View File

@ -1,15 +1,26 @@
(module cache-image mzscheme (module cache-image mzscheme
(require (lib "class.ss")) (require (lib "class.ss")
"wxme.ss")
(provide reader (provide reader
(struct cache-image (argb width height pin-x pin-y))) cache-image%)
(define-struct cache-image (argb width height pin-x pin-y)) (define cache-image%
(class object%
(init-field argb width height pin-x pin-y)
(define (get-argb) argb)
(define (get-width) width)
(define (get-height) height)
(define (get-pin-x) pin-x)
(define (get-pin-y) pin-y)
(super-new)))
(define reader (define reader
(new (new
(class object% (class* object% (snip-reader<%>)
(define/public (read-header vers stream) (define/public (read-header vers stream)
(void)) (void))
(define/public (read-snip text? cvers stream) (define/public (read-snip text? cvers stream)
@ -17,14 +28,10 @@
(if text? (if text?
#"." #"."
(let ([l (read (open-input-bytes content))]) (let ([l (read (open-input-bytes content))])
(make-cache-image (car l) (make-object cache-image%
(cadr l) (car l)
(/ (vector-length (car l)) (cadr l) 4) (cadr l)
(caddr l) (/ (vector-length (car l)) (cadr l) 4)
(cadddr l)))))) (caddr l)
(cadddr l))))))
(super-new))))) (super-new)))))

10
collects/wxme/comment.ss
View File

@ -5,12 +5,16 @@
"wxme.ss" "wxme.ss"
"private/readable-editor.ss") "private/readable-editor.ss")
(provide reader) (provide reader
comment-editor%)
(define comment-editor% (class readable-editor% (super-new)))
(define reader (define reader
(new (class editor-reader% (new (class* editor-reader% (snip-reader<%>)
(inherit read-editor-snip)
(define/override (read-snip text? vers stream) (define/override (read-snip text? vers stream)
(let ([s (super read-snip text? vers stream)]) (let ([s (read-editor-snip text? vers stream #f comment-editor%)])
(if text? (if text?
(apply bytes-append (apply bytes-append
(map (lambda (s) (map (lambda (s)

39
collects/wxme/compat.ss
View File

@ -1,39 +0,0 @@
(module compat mzscheme
(require "wxme.ss")
(register-lib-mapping!
"(lib \"comment-snip.ss\" \"framework\")"
"(lib \"comment.ss\" \"wxme\")")
(register-lib-mapping!
"drscheme:number"
"(lib \"number.ss\" \"wxme\")")
(register-lib-mapping!
"(lib \"number-snip.ss\" \"drscheme\" \"private\")"
"(lib \"number.ss\" \"wxme\")")
(register-lib-mapping!
"drscheme:xml-snip"
"(lib \"xml.ss\" \"wxme\")")
(register-lib-mapping!
"(lib \"xml-snipclass.ss\" \"xml\")"
"(lib \"xml.ss\" \"wxme\")")
(register-lib-mapping!
"drscheme:scheme-snip"
"(lib \"scheme.ss\" \"wxme\")")
(register-lib-mapping!
"(lib \"scheme-snipclass.ss\" \"xml\")"
"(lib \"scheme.ss\" \"wxme\")")
(register-lib-mapping!
"text-box%"
"(lib \"text.ss\" \"wxme\")")
(register-lib-mapping!
"(lib \"text-snipclass.ss\" \"xml\")"
"(lib \"text.ss\" \"wxme\")")
(register-lib-mapping!
"(lib \"cache-image-snip.ss\" \"mrlib\")"
"(lib \"cache-image.ss\" \"wxme\")"))

316
collects/wxme/doc.txt
View File

@ -1,22 +1,318 @@
_wxme.ss_ in mred/wxme ======================================================================
_wxme.ss_ --- reading PLT graphical format (WXME) files without MrEd
======================================================================
Utilities for reading PLT graphical format files without MrEd. > (is-wxme-stream? input-port)
> (wxme-port->port input-port [snip-filter-proc-or-false]) Peeks from `input-port' and returns #t if it starts with magic bytes
indicating a WXME-format stream, #f otherwise.
If `snip-filter-proc-or-false' is #f, then the generated port is pure The magic bytes are "WXME01<n><m> ##" for digits <n> and <n>, followed
text. Otherwise, the generated port may return "special" values for by either a space, carriage return, or newline, and optionally
non-text items in the original stream. prefixed with "#reader(\"read.ss\"\"wxme\")".
> (wxme-port->text-port input-port [close?])
Takes an import port whose stream starts with WXME-format data and
returns an input port that produces a text form of the WXME content,
like the result of opening a WXME file in DrScheme and saving it as
text.
If `close?' is true (the default), then closing the result port close
the original port.
See "Snip Class Mapping" (below) for information about the kinds of
non-text content that can be read.
> (wxme-port->port input-port [close? snip-filter-proc-or-false])
Takes an import port whose stream starts with WXME-format data and
returns an input port that produces text content converted to bytes,
and non-text content as "special" values.
If `close?' is true (the default), then closing the result port close
the original port.
The `snip-filter-proc' is applied to any special value generated for
the stream, and its result is used as an alternate special value. The
default `snip-filter-proc' is the identity function.
If a special value (possibly produced by the filter procedure) is an
object implementing the `readable<%>' interface provided by "wxme.ss",
then the object's `read-special' method is called to produce the
special value.
See "Snip Class Mapping" (below) for information about the kinds of
non-text content that can be read.
> (register-lib-mapping! string quoted-module-path)
Maps a snip-class name to a quoted module path that provides a reader%
implementation. The module path must have the form '(lib <str> ...),
where each <str> contains only alpha-numeric ASCII characters, ".",
"_", "-", and spaces.
> unknown-extensions-skip-enabled
A parameter. When set to #f (the default), an exception is raised when
an unrecognized snip class is encountered in a WXME stream. When set to
a true value, instances of unrecognized snip classes are simply
omitted from the transformed stream.
> (wxme-read port) > (wxme-read port)
Like `read', but for a WXME format input stream. Like `read', but for a stream that starts with WXME-format data. If
multiple S-expressions are in the WXME data, they are all read and
combined with `begin'.
> (wxme-read-syntax source-v port) > (wxme-read-syntax source-v port)
Like `read-syntax', but for a WXME format input stream. Like `read-syntax', but for a WXME format input stream. If multiple
S-expressions are in the WXME data, they are all read and combined
with `begin'.
> prop:readable
A property for a structure representation of a snip. > snip-reader<%>
An interface to be implemented by a reader for a specific kind of data
in a WXME stream.
The interface has two methods:
> (read-header version-k stream-object)
> (read-snip text-only? version-k stream-object)
The first method is called at most once per WXME stream to initialize
the data type's stream-specific information. This method usually does
nothing.
The second method is called when an instance of the data type is
encountered in the stream. This method reads the data and returns
either bytes to be returned as part of the decoded stream or any other
kind of value to be returned as a "special" value from the decoded
stream.
> readable<%>
An interface to be implemented by values returned from a snip reader.
The only method is `read-special', which takes four arguments related
to source location: a value indicating the source, the line (positive
integer or #f), column (non-negative integer or #f), and position
(positive integer or #f).
When a value implements this interface, its `read-special' method is
called with source-location information to obtain the "special" result
from the WXME-decoding port.
------------------------------------------------------------
Snip Class Mapping
------------------------------------------------------------
When graphical data is marshaled to the WXME format, it is associated
with a snip-class name to be matched with an implementation at load
time.
Ideally, the snip-class name is generated as
(format "~s" (list '(lib <str> ...)
'(lib <str> ...)))
where each element of the list is a quoted module path. The <str>s
must contain only alpha-numeric ASCII characters, plus ".", "-", "_",
or space, and must not be "." or "..".
In that case, the first quoted module path is used by MrEd for loading
WXME files in graphical mode; the corresponding module must provide
`snip-class' object that implements MrEd's `snip-class%' class. the
second quoted module path is used by the "wxme.ss" library for
converting WXME streams without MrEd support; the corresponding module
must provide a `reader' object that implements `reader<%>' interface
described above. Of course, the `snip-class%' instance and `reader<%>'
instance are expected to parse the same format, but generate different
results suitable for the different contexts (graphical or not).
If a snip-class name is generated as
(format "~s" '(lib <str> ...))
then MrEd uses the sole module path, and the "wxme.ss" needs a
compatibility mapping. Install one with `register-lib-mapping!'.
If a snip-class name has neither of the above formats, then MrEd can
use the data only if a snip class is registered for the name, or if it
the name of one of the built-in classes: "wxtext", "wxtab", "wximage",
or "wxmedia" (for nested editors). The "wxme.ss" library needs a
compatibility mapping installed with `register-lib-mapping!' if it is
not one of the built-in classes.
Several compatibility mappings are installed automatically for the
"wxme.ss" library. They correspond to popular graphical elements
supported by various versions of DrScheme, including comment boxes,
fractions, XML boxes, Scheme boxes, text boxes, and images generated
by the "world.ss" and "image.ss" teachpacks (or, more generally, from
"cache-image-snip.ss" in "mrlib"), and test-case boxes.
For a port created by `wxme-port->port', nested editors are
represented by instances of the `editor%' class provided by the
"editor.ss" library of the "wxme" collection. This class provides a
single method, `get-content-port', which returns a port for the
editor's content. Images are represented as instances of the `image%'
class provided by the "image.ss" library (see below).
Comment boxes are represented as instances of a class that extends
`editor%' to implement `readable<%>' (see "comment.ss"); the read form
produces a special comment (created by `make-special-comment'), so
that the comment box disappears when `read' is used to read the
stream; the special-comment content is the readable instance. XML,
Scheme, and text boxes similarly produce instances of `editor%' and
`readable<%>' that expand in the usual way (see "xml.ss", "scheme.ss",
and "text.ss"). Images from the "world.ss" and "image.ss" teachpacks
are packaged as instances of `cache-image%' from the "cache-image.ss"
library (see below). Test-case boxes are packaged as instances of
`test-case%' from the "test-case.ss" library (see below).
======================================================================
_editor.ss_ --- MrEd nested editors
======================================================================
Provides
> editor%
that is instantiated for plain nested editors in a WXME stream.
The class has one method:
> (get-content-port)
which returns a port (like the one from `wxme-port->port') for the
editor's content.
======================================================================
_image.ss_ --- MrEd images
======================================================================
Provides
> image%
that is instantiated for MrEd images in a WXME stream. The class
provides several methods:
> (get-filename) - returns a filename as bytes, or #f if
data is available instead
> (get-data) - returns bytes for a PNG, XBM,or XPM file for the
image
> (get-width) - returns the display width of the image, which may
differ from the width of the actual image secified
as data or by a filename
> (get-height) - returns the display height of the image, which may
differ from the width of the actual image secified
as data or by a filename
> (get-x-offset) - returns an offset into the actual image to be used
as the left of the display image
> (get-y-offset) - returns an offset into the actual image to be used
as the top of the display image
======================================================================
_comment.ss_ --- DrScheme comment boxes
======================================================================
In addition to `reader', an instance of `snip-reader<%>', this library
provides
> comment-editor%
which is a sub-class of `editor%' and implementation of `readable<%>'
that is instantiated for Drscheme comment boxes in a WXME stream. The
class includes a `get-data' method that always returns #f.
======================================================================
_xml.ss_ --- DrScheme XML boxes
======================================================================
In addition to `reader', an instance of `snip-reader<%>', this library
provides
> xml-editor%
which is a sub-class of `editor%' and implementation of `readable<%>'
that is instantiated for Drscheme XML boxes in a WXME stream. The
class includes a `get-data' method that returns #t if whitespace is
elimited from the contained XML literal, #f otherwise.
======================================================================
_scheme.ss_ --- DrScheme Scheme boxes
======================================================================
In addition to `reader', an instance of `snip-reader<%>', this library
provides
> scheme-editor%
which is a sub-class of `editor%' and implementation of `readable<%>'
that is instantiated for Drscheme Scheme boxes in a WXME stream. The
class includes a `get-data' method that returns #t if the box
corresponds to a spliciing unquote, #f for a non-splicing unquote.
======================================================================
_text.ss_ --- DrScheme text boxes
======================================================================
In addition to `reader', an instance of `snip-reader<%>', this library
provides
> text-editor%
which is a sub-class of `editor%' and implementation of `readable<%>'
that is instantiated for DrScheme text boxes in a WXME stream. The
class includes a `get-data' method that always returns #f.
======================================================================
_number.ss_ --- DrScheme fractions
======================================================================
This library provides just `reader', which an instance of
`snip-reader<%>' that converts DrScheme fractions in a WXME stream to
exact numbers.
======================================================================
_cache-image.ss_ --- DrScheme teachpack images
======================================================================
In addition to `reader', an instance of `snip-reader<%>', this library
provides
> cache-image%
which is instantiated for images in a WXME stream generated by the
"image.ss" and "world.ss" teachpacks (or, more generally, by
"cache-image-snip.ss" of "mrlib". The class provides several methods:
> (get-argb) - returns a vector of integersin [0,255] representing
the content of the image
> (get-width) - returns the width of the image
> (get-height) - returns the height of the image
> (get-pin-x) - returns an offset into the image for the pinhole
> (get-pin-y) - returns an offset into the image for the pinhole
======================================================================
_test-case.ss_ --- DrScheme test-case boxes
======================================================================
In addition to `reader', an instance of `snip-reader<%>', this library
provides
> test-case%
which is instantiated for DrScheme test-case boxes in a WXME stream.
The class provides several methods:
> (get-comment) - returns a port or #f for the comment field (if any)
> (get-test) - returns a port for the "test" field
> (get-expected) - returns a port for the "expected" field
> (get-should-raise) - returns a port/#f for the "should raise" field
> (get-error-message) - returns a port/#f for the "error msg" field
> (get-enabled?) - returns #t if the test is enabled
> (get-collapsed?) - returns #t if the test is collapsed
> (get-error-box?) - return #t if the test is for an exception

9
collects/wxme/editor.ss
View File

@ -1,6 +1,11 @@
(module editor mzscheme (module editor mzscheme
(define-struct editor (content-port)) (require (lib "class.ss")
(provide (struct editor (content-port)))) "private/class-help.ss")
(provide editor%)
(define editor%
(class object%
(init-accessible content-port)
(super-new))))

11
collects/wxme/image.ss
View File

@ -1,4 +1,11 @@
(module image mzscheme (module image mzscheme
(define-struct image (filename data w h dx dy)) (require (lib "class.ss")
(provide (struct image (filename data w h dx dy)))) "private/class-help.ss")
(provide image%)
(define image%
(class object%
(init-accessible filename data w h dx dy)
(super-new))))

5
collects/wxme/number.ss
View File

@ -1,12 +1,13 @@
(module number mzscheme (module number mzscheme
(require (lib "class.ss")) (require (lib "class.ss")
"wxme.ss")
(provide reader) (provide reader)
(define reader (define reader
(new (new
(class object% (class* object% (snip-reader<%>)
(define/public (read-header vers stream) (define/public (read-header vers stream)
(void)) (void))
(define/public (read-snip text? cvers stream) (define/public (read-snip text? cvers stream)

25
collects/wxme/private/class-help.ss Normal file
View File

@ -0,0 +1,25 @@
(module class-help mzscheme
(require (lib "class.ss"))
(provide init-accessible)
;; like `init-field', but makes a `get-' public method
;; instead of a public field
(define-syntax (init-accessible stx)
(syntax-case stx ()
[(_ id)
(identifier? #'id)
#'(init-accessible [id])]
[(_ [id . val])
(with-syntax ([get-id (datum->syntax-object
#'id
(string->symbol (format "get-~a" (syntax-e #'id)))
#'id)])
#'(begin
(init [(internal-id id) . val])
(define private-id internal-id)
(define/public (get-id) private-id)))]
[(_ binding ...)
#'(begin (init-accessible binding) ...)])))

44
collects/wxme/private/compat.ss Normal file
View File

@ -0,0 +1,44 @@
(module compat mzscheme
(provide register-compatibility-mappings!)
(define (register-compatibility-mappings! register-lib-mapping!)
(register-lib-mapping!
"(lib \"comment-snip.ss\" \"framework\")"
'(lib "comment.ss" "wxme"))
(register-lib-mapping!
"drscheme:number"
'(lib "number.ss" "wxme"))
(register-lib-mapping!
"(lib \"number-snip.ss\" \"drscheme\" \"private\")"
'(lib "number.ss" "wxme"))
(register-lib-mapping!
"drscheme:xml-snip"
'(lib "xml.ss" "wxme"))
(register-lib-mapping!
"(lib \"xml-snipclass.ss\" \"xml\")"
'(lib "xml.ss" "wxme"))
(register-lib-mapping!
"drscheme:scheme-snip"
'(lib "scheme.ss" "wxme"))
(register-lib-mapping!
"(lib \"scheme-snipclass.ss\" \"xml\")"
'(lib "scheme.ss" "wxme"))
(register-lib-mapping!
"text-box%"
'(lib "text.ss" "wxme"))
(register-lib-mapping!
"(lib \"text-snipclass.ss\" \"xml\")"
'(lib "text.ss" "wxme"))
(register-lib-mapping!
"(lib \"cache-image-snip.ss\" \"mrlib\")"
'(lib "cache-image.ss" "wxme"))
(register-lib-mapping!
"test-case-box%"
'(lib "test-case.ss" "wxme"))))

30
collects/wxme/private/readable-editor.ss
View File

@ -5,24 +5,34 @@
"../wxme.ss" "../wxme.ss"
"../editor.ss") "../editor.ss")
(provide editor-reader% (provide readable-editor%
(struct readable-editor (reader data))) editor-reader%)
(define-struct/properties (readable-editor editor) (reader data) (define readable-editor%
([prop:readable (lambda (this src line col pos) (class* editor% (readable<%>)
(send (readable-editor-reader this) generate-special this src line col pos))])) (init content reader data)
(define the-reader reader)
(define the-data data)
(define/public (read-special src line col pos)
(send the-reader generate-special this src line col pos))
(define/public (get-data)
the-data)
(super-make-object content)))
(define editor-reader% (define editor-reader%
(class object% (class* object% (snip-reader<%>)
(define/public (read-header vers stream) (define/public (read-header vers stream)
(void)) (void))
(define/public (read-editor-snip text? vers stream data) (define/public (read-editor-snip text? vers stream data %)
(let ([s (send stream read-editor-snip)]) (let ([s (send stream read-editor-snip "box content")])
(if text? (if text?
s s
(make-readable-editor s this data)))) (make-object % s this data))))
(define/public (read-snip text? vers stream) (define/public (read-snip text? vers stream)
(read-editor-snip text? vers stream #f)) (read-editor-snip text? vers stream #f readable-editor%))
(define/public (generate-special editor src line col pos) (define/public (generate-special editor src line col pos)
(make-special-comment editor)) (make-special-comment editor))

11
collects/wxme/scheme.ss
View File

@ -5,7 +5,10 @@
"editor.ss" "editor.ss"
"private/readable-editor.ss") "private/readable-editor.ss")
(provide reader) (provide reader
scheme-editor%)
(define scheme-editor% (class readable-editor% (super-new)))
(define reader (define reader
(new (new
@ -13,12 +16,12 @@
(inherit read-editor-snip) (inherit read-editor-snip)
(define/override (read-snip text? vers stream) (define/override (read-snip text? vers stream)
(let ([splice? (zero? (send stream read-integer "splice?"))]) (let ([splice? (zero? (send stream read-integer "splice?"))])
(read-editor-snip text? vers stream splice?))) (read-editor-snip text? vers stream splice? scheme-editor%)))
(define/override (generate-special editor src line col pos) (define/override (generate-special editor src line col pos)
(list (if (readable-editor-data editor) (list (if (send editor get-data)
'unquote-splicing 'unquote-splicing
'unquote) 'unquote)
(read (editor-content-port editor)))) (read (send editor get-content-port))))
(super-new))))) (super-new)))))

65
collects/wxme/test-case.ss Normal file
View File

@ -0,0 +1,65 @@
(module test-case mzscheme
(require (lib "class.ss")
"wxme.ss"
"private/class-help.ss")
(provide reader
test-case%)
(define test-case%
(class object%
(init-accessible test
expected
[comment #f]
[predicate #f]
[should-raise #f]
[error-message #f]
[enabled? #t]
[collapsed? #f]
[error-box? #f])
(super-new)))
(define (concat port)
(if port
(let loop ([accum null])
(let ([s (read-bytes 4096 port)])
(if (eof-object? s)
(apply bytes-append (reverse accum))
(loop (cons s accum)))))
#""))
(define reader
(new
(class* object% (snip-reader<%>)
(define/public (read-header vers stream)
(void))
(define/public (read-snip text? cvers stream)
(let ([v (cond
[(= cvers 1)
(new test-case%
[comment (send stream read-editor-snip "test-case-box content")]
[test (send stream read-editor-snip "test-case-box test")]
[expected (send stream read-editor-snip "test-case-box expected")])]
[else
(new test-case%
[test (send stream read-editor-snip "test-case-box test")]
[expected (send stream read-editor-snip "test-case-box expected")]
[predicate (send stream read-editor-snip "test-case-box predicate")]
[should-raise (send stream read-editor-snip "test-case-box should-raise")]
[error-message (send stream read-editor-snip "test-case-box error-message")]
[enabled? (= 1 (send stream read-integer "test-case-box enabled?"))]
[collapsed? (= 1 (send stream read-integer "test-case-box collapsed?"))]
[error-box? (= 1 (send stream read-integer "test-case-box error-box?"))])])])
(if text?
(apply
bytes-append
(map concat
(send v get-comment)
(send v get-test)
(send v get-expected)
(send v get-predicate)
(send v get-should-raise)
(send v error-message)))
v)))
(super-new)))))

10
collects/wxme/text.ss
View File

@ -5,12 +5,18 @@
"editor.ss" "editor.ss"
"private/readable-editor.ss") "private/readable-editor.ss")
(provide reader) (provide reader
text-editor%)
(define text-editor% (class readable-editor% (super-new)))
(define reader (define reader
(new (class editor-reader% (new (class editor-reader%
(inherit read-editor-snip)
(define/override (read-snip text? vers stream)
(read-editor-snip text? vers stream #f text-editor%))
(define/override (generate-special editor src line col pos) (define/override (generate-special editor src line col pos)
(let ([port (editor-content-port editor)]) (let ([port (send editor get-content-port)])
(let loop ([accum null]) (let loop ([accum null])
(let ([s (read-bytes 4096 port)]) (let ([s (read-bytes 4096 port)])
(if (eof-object? s) (if (eof-object? s)

136
collects/wxme/wxme.ss
View File

@ -4,16 +4,12 @@
(lib "string.ss") (lib "string.ss")
(lib "kw.ss") (lib "kw.ss")
(lib "class.ss") (lib "class.ss")
(lib "contract.ss")
"image.ss" "image.ss"
"editor.ss") "editor.ss"
"private/compat.ss")
(define (expect rx port who msg) (define (decode who port snip-filter close?)
(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#"^WXME" port who "does not start with \"WXME\"")
(expect #rx#"^01" port who "unrecognized format (not \"01\")") (expect #rx#"^01" port who "unrecognized format (not \"01\")")
(let ([vers (string->number (let ([vers (string->number
@ -22,7 +18,15 @@
(unless (vers . < . 4) (unless (vers . < . 4)
(expect #rx#"^ ##[ \r\n]" port who "missing \" ## \" tag in the expected place")) (expect #rx#"^ ##[ \r\n]" port who "missing \" ## \" tag in the expected place"))
(let ([header (read-header who port vers snip-filter)]) (let ([header (read-header who port vers snip-filter)])
(port->decoded-port who port vers header)))) (port->decoded-port who port vers header close?))))
(define (expect rx port who msg)
(let ([m (regexp-match rx port)])
(unless m
(error who "bad WXME stream; ~a" msg))
(car m)))
;; ----------------------------------------
(define-struct header (classes data-classes styles snip-filter skip-unknown? snips-to-go stream)) (define-struct header (classes data-classes styles snip-filter skip-unknown? snips-to-go stream))
(define (header-plain-text? h) (define (header-plain-text? h)
@ -66,7 +70,8 @@
(and (pair? results) (and (pair? results)
(begin0 (begin0
(car results) (car results)
(set! results (cdr results))))))))) (set! results (cdr results))))))
void)))
(loop (sub1 cnt) (loop (sub1 cnt)
(cons (read-snip who port vers header) (cons (read-snip who port vers header)
accum)))))) accum))))))
@ -182,23 +187,37 @@
(let ([len (and (or (not class) (let ([len (and (or (not class)
(not (snip-class-required? class))) (not (snip-class-required? class)))
(read-fixed-integer who port vers "snip length"))]) (read-fixed-integer who port vers "snip length"))])
(if class (if (and class
(snip-class-manager class))
(let ([style (read-integer who port vers "snip style index")] (let ([style (read-integer who port vers "snip style index")]
[m (snip-class-manager class)] [m (snip-class-manager class)]
[cvers (snip-class-version class)]) [cvers (snip-class-version class)])
(let ([s (if (procedure? m) (let ([s (if (procedure? m)
;; Built-in snip class:
(m who port vers cvers header) (m who port vers cvers header)
(send m read-snip ;; Extension snip class:
(header-plain-text? header) (let* ([text? (header-plain-text? header)]
cvers [s (send m read-snip
(header-stream header)))]) text?
cvers
(header-stream header))])
(if (and text?
(not (bytes? s)))
(error 'read-snip
"reader for ~a in text-only mode produced something other than bytes: ~e"
(snip-class-name class)
s)
s)))])
(read-buffer-data who port vers header) (read-buffer-data who port vers header)
(if (bytes? s) (if (bytes? s)
;; Return bytes for the stream:
s s
;; Filter the non-bytes result, and then wrap it as
;; a special stream result:
(let ([s ((header-snip-filter header) s)]) (let ([s ((header-snip-filter header) s)])
(lambda (src line col pos) (lambda (src line col pos)
(if (readable? s) (if (s . is-a? . readable<%>)
((readable-ref s) s src line col pos) (send s read-special src line col pos)
s)))))) s))))))
(begin (begin
(skip-data port vers len) (skip-data port vers len)
@ -319,8 +338,14 @@
;; ---------------------------------------- ;; ----------------------------------------
(define-values (prop:readable readable? readable-ref) (define snip-reader<%>
(make-struct-type-property 'readable)) (interface ()
read-header
read-snip))
(define readable<%>
(interface ()
read-special))
(define (find-class pos header who port vers) (define (find-class pos header who port vers)
(define classes (header-classes header)) (define classes (header-classes header))
@ -372,7 +397,7 @@
(let ([n (read-editor-snip who port vers header)]) (let ([n (read-editor-snip who port vers header)])
(if (header-plain-text? header) (if (header-plain-text? header)
n n
(make-editor n))))] (make-object editor% n))))]
[(equal? name #"wximage") [(equal? name #"wximage")
(lambda (who port vers cvers header) (lambda (who port vers cvers header)
(let ([filename (read-a-string who port vers "image-snip filename")] (let ([filename (read-a-string who port vers "image-snip filename")]
@ -398,12 +423,14 @@
(loop (add1 i))))))))]) (loop (add1 i))))))))])
(if (header-plain-text? header) (if (header-plain-text? header)
#"." #"."
(make-image (if data #f filename) data w h dx dy)))))] (make-object image% (if data #f filename) data w h dx dy)))))]
[else [else
;; Load a manager for this snip class? ;; Load a manager for this snip class?
(let ([lib (string->lib-path (bytes->string/latin-1 name))]) (let ([lib (string->lib-path (bytes->string/latin-1 name))])
(if lib (if lib
(let ([mgr (dynamic-require lib 'reader)]) (let ([mgr (dynamic-require lib 'reader)])
(unless (mgr . is-a? . snip-reader<%>)
(error who "reader provided by ~s is not an instance of snip-reader<%>" lib))
mgr) mgr)
(if (header-skip-unknown? header) (if (header-skip-unknown? header)
#f #f
@ -450,7 +477,7 @@
(read-a-string who port vers what)) (read-a-string who port vers what))
(public [rne read-editor-snip]) (public [rne read-editor-snip])
(define (rne) (define (rne what)
(read-editor-snip who port vers header)) (read-editor-snip who port vers header))
(super-new))) (super-new)))
@ -473,11 +500,9 @@
(andmap ok-string-element? (cdr m)))) (andmap ok-string-element? (cdr m))))
(define (register-lib-mapping! str target) (define (register-lib-mapping! str target)
(let ([lib (with-handlers ([exn:fail? (lambda (x) #f)]) (unless (ok-lib-path? target)
(read (open-input-string target)))]) (error 'register-lib-mapping! "given target is not a valid marshalable lib path: ~s" target))
(unless (ok-lib-path? lib) (hash-table-put! lib-mapping str target))
(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) (define (string->lib-path str)
(or (let ([m (and (regexp-match #rx"^[(].*[)]$" str) (or (let ([m (and (regexp-match #rx"^[(].*[)]$" str)
@ -492,6 +517,8 @@
(cadr m))) (cadr m)))
(hash-table-get lib-mapping str #f))) (hash-table-get lib-mapping str #f)))
(register-compatibility-mappings! register-lib-mapping!)
;; ---------------------------------------- ;; ----------------------------------------
(define plain-params (define plain-params
@ -516,7 +543,7 @@
;; ---------------------------------------- ;; ----------------------------------------
(define (port->decoded-port who port vers header) (define (port->decoded-port who port vers header close?)
(snip-results->port (snip-results->port
(object-name port) (object-name port)
(lambda () (lambda ()
@ -525,9 +552,12 @@
[(zero? snips-to-go) #f] [(zero? snips-to-go) #f]
[else [else
(set-header-snips-to-go! header (sub1 snips-to-go)) (set-header-snips-to-go! header (sub1 snips-to-go))
(read-snip who port vers header)]))))) (read-snip who port vers header)])))
(if close?
(lambda () (close-input-port port))
void)))
(define (snip-results->port name next-item!) (define (snip-results->port name next-item! close)
(define-values (r w) (make-pipe)) (define-values (r w) (make-pipe))
(define (read-proc buffer) (define (read-proc buffer)
(if (char-ready? r) (if (char-ready? r)
@ -545,20 +575,31 @@
name name
read-proc read-proc
#f #f
void)) close))
;; ----------------------------------------
(define (wxme-convert-port port close? snip-filter)
;; read optional #reader header:
(regexp-match/fail-without-reading #rx#"^#reader[(]lib\"read.ss\"\"wxme\"[)]" port)
;; decode:
(decode 'read-bytes port snip-filter close?))
;; ---------------------------------------- ;; ----------------------------------------
(define unknown-extensions-skip-enabled (make-parameter #f)) (define unknown-extensions-skip-enabled (make-parameter #f))
(define/kw (wxme-port->port port #:optional [snip-filter (lambda (x) x)]) (define (is-wxme-stream? p)
;; read optional #reader header: (regexp-match-peek #rx#"^(?:#reader(lib\"read[.]ss\"\"wxme\"))?WXME01[0-9][0-9] ##[ \r\n]" p))
(regexp-match/fail-without-reading #rx#"^#reader[(]lib\"wxme.ss\"\"mred\"[)]" port)
;; decode: (define/kw (wxme-port->port port #:optional [close? #t] [snip-filter (lambda (x) x)])
(decode 'read-bytes port snip-filter)) (wxme-convert-port port close? snip-filter))
(define/kw (wxme-port->text-port port #:optional [close? #t])
(wxme-convert-port port close? #f))
(define (do-read port who read) (define (do-read port who read)
(let ([port (decode who port #t)]) (let ([port (decode who port #t #f)])
(let ([v (read port)]) (let ([v (read port)])
(let ([v2 (let loop () (let ([v2 (let loop ()
(let ([v2 (read port)]) (let ([v2 (read port)])
@ -579,14 +620,19 @@
(do-read port 'read read)) (do-read port 'read read))
(define (wxme-read-syntax source-name-v port) (define (wxme-read-syntax source-name-v port)
(do-read port 'read-syntax (datum->syntax-object
(lambda (port) #f
(read-syntax source-name-v port)))) (do-read port 'read-syntax
(lambda (port)
(read-syntax source-name-v port)))))
(provide wxme-port->port (provide/contract [is-wxme-stream? (input-port? . -> . any)]
register-lib-mapping! [wxme-port->text-port ((input-port?) (any/c) . opt-> . input-port?)]
unknown-extensions-skip-enabled [wxme-port->port ((input-port?) (any/c (any/c . -> . any)) . opt-> . input-port?)]
prop:readable [register-lib-mapping! (string? string? . -> . void?)])
(provide unknown-extensions-skip-enabled
snip-reader<%>
readable<%>
wxme-read wxme-read
wxme-read-syntax)) wxme-read-syntax))

11
collects/wxme/xml.ss
View File

@ -7,20 +7,23 @@
"editor.ss" "editor.ss"
"private/readable-editor.ss") "private/readable-editor.ss")
(provide reader) (provide reader
xml-editor%)
(define xml-editor% (class readable-editor% (super-new)))
(define reader (define reader
(new (class editor-reader% (new (class editor-reader%
(inherit read-editor-snip) (inherit read-editor-snip)
(define/override (read-snip text? vers stream) (define/override (read-snip text? vers stream)
(let ([elim-whitespace? (zero? (send stream read-integer "elim-whitespace?"))]) (let ([elim-whitespace? (zero? (send stream read-integer "elim-whitespace?"))])
(read-editor-snip text? vers stream elim-whitespace?))) (read-editor-snip text? vers stream elim-whitespace? xml-editor%)))
(define/override (generate-special editor src line col pos) (define/override (generate-special editor src line col pos)
(let* ([port (editor-content-port editor)] (let* ([port (send editor get-content-port)]
[xml (read-xml port)] [xml (read-xml port)]
[xexpr (xml->xexpr (document-element xml))] [xexpr (xml->xexpr (document-element xml))]
[clean-xexpr (if (readable-editor-data editor) [clean-xexpr (if (send editor get-data)
(eliminate-whitespace-in-empty-tags xexpr) (eliminate-whitespace-in-empty-tags xexpr)
xexpr)]) xexpr)])
(list 'quasiquote clean-xexpr))) (list 'quasiquote clean-xexpr)))