"
""
"")
'()
'(*TOP* (urn:loc.gov:books:book
(urn:loc.gov:books:title "Cheaper by the Dozen")
(urn:ISBN:0-395-36341-6:number "1568491379")
(urn:loc.gov:books:notes
(urn:w3-org-ns:HTML:p
"This is a "
(urn:w3-org-ns:HTML:i "funny")
" book!")))))
(_test_44
(string-append
""
""
"
"
"
Name
Origin
Description
"
"
"
""
"
Huntsman
"
"
Bath, UK
"
"
"
"BitterFuggles"
"Wonderful hop, light alcohol, good summer beer"
"Fragile; excessive variance pub to pub"
""
"
"
"
"
"
"
"")
'((html . "http://www.w3.org/TR/REC-html40"))
'(*TOP* (@ (*NAMESPACES* (html "http://www.w3.org/TR/REC-html40")))
(Beers (html:table
(html:th (html:td "Name")
(html:td "Origin")
(html:td "Description"))
(html:tr (html:td (brandName "Huntsman"))
(html:td (origin "Bath, UK"))
(html:td (details (class "Bitter")
(hop "Fuggles")
(pro "Wonderful hop, light alcohol, good summer beer")
(con "Fragile; excessive variance pub to pub"))))))))
(_test_44
(string-append
""
"Layman, A"
"33B"
"Check Status"
"1997-05-24T07:55:00+1")
'((HTML . "http://www.w3.org/TR/REC-html40"))
'(*TOP* (@ (*NAMESPACES* (HTML "http://www.w3.org/TR/REC-html40")))
(RESERVATION
(NAME (@ (HTML:CLASS "largeSansSerif")) "Layman, A")
(SEAT (@ (HTML:CLASS "largeMonotype") (CLASS "Y")) "33B")
(HTML:A (@ (HREF "/cgi-bin/ResStatus")) "Check Status")
(DEPARTURE "1997-05-24T07:55:00+1"))))
(_test_44
(string-concatenate/shared
(list-intersperse
'(""
""
""
""
""
""
""
""
""
""
""
""
""
""
""
""
""
""
""
""
""
"")
(string #\newline)))
'((RDF . "http://www.w3.org/1999/02/22-rdf-syntax-ns#")
(RDFS . "http://www.w3.org/2000/01/rdf-schema#")
(ISET . "http://www.w3.org/2001/02/infoset#"))
'(*TOP* (@ (*NAMESPACES*
(RDF "http://www.w3.org/1999/02/22-rdf-syntax-ns#")
(RDFS "http://www.w3.org/2000/01/rdf-schema#")
(ISET "http://www.w3.org/2001/02/infoset#")))
(*PI* xml "version='1.0' encoding='utf-8' standalone='yes'")
(RDF:RDF (RDFS:Class (@ (ID "Boolean")))
(ISET:Boolean (@ (ID "Boolean.true")))
(ISET:Boolean (@ (ID "Boolean.false")))
(RDFS:Class (@ (ID "InfoItem")))
(RDFS:Class
(@ (RDFS:subClassOf "#InfoItem") (ID "Document")))
(RDFS:Class
(@ (RDFS:subClassOf "#InfoItem") (ID "Element")))
(RDFS:Class
(@ (RDFS:subClassOf "#InfoItem") (ID "Attribute")))
(RDFS:Class
(@ (RDFS:subClassOf
"http://www.w3.org/1999/02/22-rdf-syntax-ns#Bag")
(ID "InfoItemSet")))
(RDFS:Class
(@ (RDFS:subClassOf "#InfoItemSet")
(ID "AttributeSet")))
(RDFS:Property
(@ (ID "allDeclarationsProcessed"))
(RDFS:domain (@ (resource "#Document")))
(RDFS:range (@ (resource "#Boolean"))))
(RDFS:Property
(@ (ID "attributes"))
(RDFS:domain (@ (resource "#Element")))
(RDFS:range (@ (resource "#AttributeSet")))))))
(_test_44
(string-concatenate/shared
(list-intersperse
'(""
""
"Daemon News Mall"
"http://mall.daemonnews.org/"
"Central source for all your BSD needs"
""
""
"Daemon News Jan/Feb Issue NOW Available! Subscribe $24.95"
"http://mall.daemonnews.org/?page=shop/flypage&product_id=880"
""
""
"The Design and Implementation of the 4.4BSD Operating System $54.95"
"http://mall.daemonnews.org/?page=shop/flypage&product_id=912&category_id=1761"
""
"")
(string #\newline)))
'((RDF . "http://www.w3.org/1999/02/22-rdf-syntax-ns#")
(RSS . "http://my.netscape.com/rdf/simple/0.9/")
(ISET . "http://www.w3.org/2001/02/infoset#"))
'(*TOP* (@ (*NAMESPACES*
(RDF "http://www.w3.org/1999/02/22-rdf-syntax-ns#")
(RSS "http://my.netscape.com/rdf/simple/0.9/")
(ISET "http://www.w3.org/2001/02/infoset#")))
(*PI* xml "version='1.0'")
(RDF:RDF (RSS:channel
(RSS:title "Daemon News Mall")
(RSS:link "http://mall.daemonnews.org/")
(RSS:description
"Central source for all your BSD needs"))
(RSS:item
(RSS:title
"Daemon News Jan/Feb Issue NOW Available! Subscribe $24.95")
(RSS:link
"http://mall.daemonnews.org/?page=shop/flypage&product_id=880"))
(RSS:item
(RSS:title
"The Design and Implementation of the 4.4BSD Operating System $54.95")
(RSS:link
"http://mall.daemonnews.org/?page=shop/flypage&product_id=912&category_id=1761")))))
(_test_44
(string-concatenate/shared
(list-intersperse
'(""
""
"111730Z 111818"
""
"31010KT P6SM FEW030"
""
""
"29016KT P6SM FEW040"
""
""
"29010KT P6SM SCT200"
"VRB05KT"
""
"")
(string #\newline)))
'()
'(*TOP* (Forecasts
(@ (TStamp "958082142"))
(TAF (@ (TStamp "958066200")
(SName "KMRY, MONTEREY PENINSULA")
(LatLon "36.583, -121.850")
(BId "724915"))
(VALID (@ (TRange "958068000, 958154400"))
"111730Z 111818")
(PERIOD (@ (TRange "958068000, 958078800"))
(PREVAILING "31010KT P6SM FEW030"))
(PERIOD (@ (Title "FM2100")
(TRange "958078800, 958104000"))
(PREVAILING "29016KT P6SM FEW040"))
(PERIOD (@ (Title "FM0400")
(TRange "958104000, 958154400"))
(PREVAILING "29010KT P6SM SCT200")
(VAR (@ (Title "BECMG 0708")
(TRange "958114800, 958118400"))
"VRB05KT"))))))))
(newline)
(display "All tests passed")
(newline)
guile-lib-0.2.2/src/sxml/upstream/SSAX.scm 0000644 0001750 0001750 00000364541 11573632156 015227 0000000 0000000 ; Functional XML parsing framework: SAX/DOM and SXML parsers
; with support for XML Namespaces and validation
;
; This is a package of low-to-high level lexing and parsing procedures
; that can be combined to yield a SAX, a DOM, a validating parsers, or
; a parser intended for a particular document type. The procedures in
; the package can be used separately to tokenize or parse various
; pieces of XML documents. The package supports XML Namespaces,
; internal and external parsed entities, user-controlled handling of
; whitespace, and validation. This module therefore is intended to be
; a framework, a set of "Lego blocks" you can use to build a parser
; following any discipline and performing validation to any degree. As
; an example of the parser construction, this file includes a
; semi-validating SXML parser.
; The present XML framework has a "sequential" feel of SAX yet a
; "functional style" of DOM. Like a SAX parser, the framework scans
; the document only once and permits incremental processing. An
; application that handles document elements in order can run as
; efficiently as possible. _Unlike_ a SAX parser, the framework does
; not require an application register stateful callbacks and surrender
; control to the parser. Rather, it is the application that can drive
; the framework -- calling its functions to get the current lexical or
; syntax element. These functions do not maintain or mutate any state
; save the input port. Therefore, the framework permits parsing of XML
; in a pure functional style, with the input port being a monad (or a
; linear, read-once parameter).
; Besides the PORT, there is another monad -- SEED. Most of the
; middle- and high-level parsers are single-threaded through the
; seed. The functions of this framework do not process or affect the
; SEED in any way: they simply pass it around as an instance of an
; opaque datatype. User functions, on the other hand, can use the
; seed to maintain user's state, to accumulate parsing results, etc. A
; user can freely mix his own functions with those of the
; framework. On the other hand, the user may wish to instantiate a
; high-level parser: ssax:make-elem-parser or ssax:make-parser. In
; the latter case, the user must provide functions of specific
; signatures, which are called at predictable moments during the
; parsing: to handle character data, element data, or processing
; instructions (PI). The functions are always given the SEED, among
; other parameters, and must return the new SEED.
; From a functional point of view, XML parsing is a combined
; pre-post-order traversal of a "tree" that is the XML document
; itself. This down-and-up traversal tells the user about an element
; when its start tag is encountered. The user is notified about the
; element once more, after all element's children have been
; handled. The process of XML parsing therefore is a fold over the
; raw XML document. Unlike a fold over trees defined in [1], the
; parser is necessarily single-threaded -- obviously as elements
; in a text XML document are laid down sequentially. The parser
; therefore is a tree fold that has been transformed to accept an
; accumulating parameter [1,2].
; Formally, the denotational semantics of the parser can be expressed
; as
; parser:: (Start-tag -> Seed -> Seed) ->
; (Start-tag -> Seed -> Seed -> Seed) ->
; (Char-Data -> Seed -> Seed) ->
; XML-text-fragment -> Seed -> Seed
; parser fdown fup fchar " content " seed
; = fup "" seed
; (parser fdown fup fchar "content" (fdown "" seed))
;
; parser fdown fup fchar "char-data content" seed
; = parser fdown fup fchar "content" (fchar "char-data" seed)
;
; parser fdown fup fchar "elem-content content" seed
; = parser fdown fup fchar "content" (
; parser fdown fup fchar "elem-content" seed)
; Compare the last two equations with the left fold
; fold-left kons elem:list seed = fold-left kons list (kons elem seed)
; The real parser created my ssax:make-parser is slightly more complicated,
; to account for processing instructions, entity references, namespaces,
; processing of document type declaration, etc.
; The XML standard document referred to in this module is
; http://www.w3.org/TR/1998/REC-xml-19980210.html
;
; The present file also defines a procedure that parses the text of an
; XML document or of a separate element into SXML, an
; S-expression-based model of an XML Information Set. SXML is also an
; Abstract Syntax Tree of an XML document. SXML is similar
; but not identical to DOM; SXML is particularly suitable for
; Scheme-based XML/HTML authoring, SXPath queries, and tree
; transformations. See SXML.html for more details.
; SXML is a term implementation of evaluation of the XML document [3].
; The other implementation is context-passing.
; The present frameworks fully supports the XML Namespaces Recommendation:
; http://www.w3.org/TR/REC-xml-names/
; Other links:
; [1] Jeremy Gibbons, Geraint Jones, "The Under-appreciated Unfold,"
; Proc. ICFP'98, 1998, pp. 273-279.
; [2] Richard S. Bird, The promotion and accumulation strategies in
; transformational programming, ACM Trans. Progr. Lang. Systems,
; 6(4):487-504, October 1984.
; [3] Ralf Hinze, "Deriving Backtracking Monad Transformers,"
; Functional Pearl. Proc ICFP'00, pp. 186-197.
; IMPORT
; parser-error ssax:warn, see Handling of errors, below
; functions declared in files util.scm, input-parse.scm and look-for-str.scm
; char-encoding.scm for various platform-specific character-encoding functions.
; From SRFI-13: string-concatenate/shared and string-concatenate-reverse/shared
; If a particular implementation lacks SRFI-13 support, please
; include the file srfi-13-local.scm
; Handling of errors
; This package relies on a function parser-error, which must be defined
; by a user of the package. The function has the following signature:
; parser-error PORT MESSAGE SPECIALISING-MSG*
; Many procedures of this package call 'parser-error' whenever a
; parsing, well-formedness or validation error is encountered. The
; first argument is a port, which typically points to the offending
; character or its neighborhood. Most of the Scheme systems let the
; user query a PORT for the current position. The MESSAGE argument
; indicates a failed XML production or a failed XML constraint. The
; latter is referred to by its anchor name in the XML Recommendation
; or XML Namespaces Recommendation. The parsing library (e.g.,
; next-token, assert-curr-char) invoke 'parser-error' as well, in
; exactly the same way. See input-parse.scm for more details.
; See
; http://pair.com/lisovsky/download/parse-error.scm
; for an excellent example of such a redefined parser-error function.
;
; In addition, the present code invokes a function ssax:warn
; ssax:warn PORT MESSAGE SPECIALISING-MSG*
; to notify the user about warnings that are NOT errors but still
; may alert the user.
;
; Again, parser-error and ssax:warn are supposed to be defined by the
; user. However, if a run-test macro below is set to include
; self-tests, this present code does provide the definitions for these
; functions to allow tests to run.
; Misc notes
; It seems it is highly desirable to separate tests out in a dedicated
; file.
;
; Jim Bender wrote on Mon, 9 Sep 2002 20:03:42 EDT on the SSAX-SXML
; mailing list (message A fine-grained "lego")
; The task was to record precise source location information, as PLT
; does with its current XML parser. That parser records the start and
; end location (filepos, line#, column#) for pi, elements, attributes,
; chuncks of "pcdata".
; As suggested above, though, in some cases I needed to be able force
; open an interface that did not yet exist. For instance, I added an
; "end-char-data-hook", which would be called at the end of char-data
; fragment. This returns a function of type (seed -> seed) which is
; invoked on the current seed only if read-char-data has indeed reached
; the end of a block of char data (after reading a new token.
; But the deepest interface that I needed to expose was that of reading
; attributes. In the official distribution, this is not even a separate
; function. Instead, it is embedded within SSAX:read-attributes. This
; required some small re-structuring as well.
; This definitely will not be to everyone's taste (nor needed by most).
; Certainly, the existing make-parser interface addresses most custom
; needs. And likely 80-90 lines of a "link specification" to create a
; parser from many tiny little lego blocks may please only a few, while
; appalling others.
; The code is available at http://celtic.benderweb.net/ssax-lego.plt or
; http://celtic.benderweb.net/ssax-lego.tar.gz
; In the examples directory, I provide:
; - a unit version of the make-parser interface,
; - a simple SXML parser using that interface,
; - an SXML parser which directly uses the "new lego",
; - a pseudo-SXML parser, which records source location information
; - and lastly a parser which returns the structures used in PLT's xml
; collection, with source location information
; $Id: SSAX.scm,v 5.1 2004/07/07 16:02:30 sperber Exp $
;^^^^^^^^^
; See the Makefile in the ../tests directory
; (in particular, the rule vSSAX) for an example of how
; to run this code on various Scheme systems.
; See SSAX examples for many samples of using this code,
; again, on a variety of Scheme systems.
; See http://ssax.sf.net/
; The following macro runs built-in test cases -- or does not run,
; depending on which of the two cases below you commented out
; Case 1: no tests:
;(define-macro run-test (lambda body '(begin #f)))
;(define-syntax run-test (syntax-rules () ((run-test . args) (begin #f))))
; Case 2: with tests.
; The following macro could've been defined just as
; (define-macro run-test (lambda body `(begin (display "\n-->Test\n") ,@body)))
;
; Instead, it's more involved, to make up for case-insensitivity of
; symbols on some Scheme systems. In Gambit, symbols are case
; sensitive: (eq? 'A 'a) is #f and (eq? 'Aa (string->symbol "Aa")) is
; #t. On some systems, symbols are case-insensitive and just the
; opposite is true. Therefore, we introduce a notation '"ASymbol" (a
; quoted string) that stands for a case-_sensitive_ ASymbol -- on any
; R5RS Scheme system. This notation is valid only within the body of
; run-test.
; The notation is implemented by scanning the run-test's
; body and replacing every occurrence of (quote "str") with the result
; of (string->symbol "str"). We can do such a replacement at macro-expand
; time (rather than at run time).
; Here's the previous version of run-test, implemented as a low-level
; macro.
; (define-macro run-test
; (lambda body
; (define (re-write body)
; (cond
; ((vector? body)
; (list->vector (re-write (vector->list body))))
; ((not (pair? body)) body)
; ((and (eq? 'quote (car body)) (pair? (cdr body))
; (string? (cadr body)))
; (string->symbol (cadr body)))
; (else (cons (re-write (car body)) (re-write (cdr body))))))
; (cons 'begin (re-write body))))
;
; For portability, it is re-written as syntax-rules. The syntax-rules
; version is less powerful: for example, it can't handle
; (case x (('"Foo") (do-on-Foo))) whereas the low-level macro
; could correctly place a case-sensitive symbol at the right place.
; We also do not scan vectors (because we don't use them here).
; Twice-deep quasiquotes aren't handled either.
; Still, the syntax-rules version satisfies our immediate needs.
; Incidentally, I originally didn't believe that the macro below
; was at all possible.
;
; The macro is written in a continuation-passing style. A continuation
; typically has the following structure: (k-head ! . args)
; When the continuation is invoked, we expand into
; (k-head . arg). That is, the dedicated symbol !
; is the placeholder for the result.
;
; It seems that the most modular way to write the run-test macro would
; be the following
;
; (define-syntax run-test
; (syntax-rules ()
; ((run-test . ?body)
; (letrec-syntax
; ((scan-exp ; (scan-exp body k)
; (syntax-rules (quote quasiquote !)
; ((scan-exp (quote (hd . tl)) k)
; (scan-lit-lst (hd . tl) (do-wrap ! quasiquote k)))
; ((scan-exp (quote x) (k-head ! . args))
; (k-head
; (if (string? (quote x)) (string->symbol (quote x)) (quote x))
; . args))
; ((scan-exp (hd . tl) k)
; (scan-exp hd (do-tl ! scan-exp tl k)))
; ((scan-exp x (k-head ! . args))
; (k-head x . args))))
; (do-tl
; (syntax-rules (!)
; ((do-tl processed-hd fn () (k-head ! . args))
; (k-head (processed-hd) . args))
; ((do-tl processed-hd fn old-tl k)
; (fn old-tl (do-cons ! processed-hd k)))))
; ...
; (do-finish
; (syntax-rules ()
; ((do-finish (new-body)) new-body)
; ((do-finish new-body) (begin . new-body))))
; ...
; (scan-exp ?body (do-finish !))
; ))))
;
; Alas, that doesn't work on all systems. We hit yet another dark
; corner of the R5RS macros. The reason is that run-test is used in
; the code below to introduce definitions. For example:
; (run-test
; (define (ssax:warn port msg . other-msg)
; (apply cerr (cons* nl "Warning: " msg other-msg)))
; )
; This code expands to
; (begin
; (define (ssax:warn port msg . other-msg) ...))
; so the definition gets spliced in into the top level. Right?
; Well, On Petite Chez Scheme it is so. However, many other systems
; don't like this approach. The reason is that the invocation of
; (run-test (define (ssax:warn port msg . other-msg) ...))
; first expands into
; (letrec-syntax (...)
; (scan-exp ((define (ssax:warn port msg . other-msg) ...)) ...))
; because of the presence of (letrec-syntax ...), the begin form that
; is generated eventually is no longer at the top level! The begin
; form in Scheme is an overloading of two distinct forms: top-level
; begin and the other begin. The forms have different rules: for example,
; (begin (define x 1)) is OK for a top-level begin but not OK for
; the other begin. Some Scheme systems see the that the macro
; (run-test ...) expands into (letrec-syntax ...) and decide right there
; that any further (begin ...) forms are NOT top-level begin forms.
; The only way out is to make sure all our macros are top-level.
; The best approach seems to be to make run-test one huge
; top-level macro.
(define-syntax run-test
(syntax-rules (define)
((run-test "scan-exp" (define vars body))
(define vars (run-test "scan-exp" body)))
((run-test "scan-exp" ?body)
(letrec-syntax
((scan-exp ; (scan-exp body k)
(syntax-rules (quote quasiquote !)
((scan-exp '() (k-head ! . args))
(k-head '() . args))
((scan-exp (quote (hd . tl)) k)
(scan-lit-lst (hd . tl) (do-wrap ! quasiquote k)))
((scan-exp (quasiquote (hd . tl)) k)
(scan-lit-lst (hd . tl) (do-wrap ! quasiquote k)))
((scan-exp (quote x) (k-head ! . args))
(k-head
(if (string? (quote x)) (string->symbol (quote x)) (quote x))
. args))
((scan-exp (hd . tl) k)
(scan-exp hd (do-tl ! scan-exp tl k)))
((scan-exp x (k-head ! . args))
(k-head x . args))))
(do-tl
(syntax-rules (!)
((do-tl processed-hd fn () (k-head ! . args))
(k-head (processed-hd) . args))
((do-tl processed-hd fn old-tl k)
(fn old-tl (do-cons ! processed-hd k)))))
(do-cons
(syntax-rules (!)
((do-cons processed-tl processed-hd (k-head ! . args))
(k-head (processed-hd . processed-tl) . args))))
(do-wrap
(syntax-rules (!)
((do-wrap val fn (k-head ! . args))
(k-head (fn val) . args))))
(do-finish
(syntax-rules ()
((do-finish new-body) new-body)))
(scan-lit-lst ; scan literal list
(syntax-rules (quote unquote unquote-splicing !)
((scan-lit-lst '() (k-head ! . args))
(k-head '() . args))
((scan-lit-lst (quote (hd . tl)) k)
(do-tl quote scan-lit-lst ((hd . tl)) k))
((scan-lit-lst (unquote x) k)
(scan-exp x (do-wrap ! unquote k)))
((scan-lit-lst (unquote-splicing x) k)
(scan-exp x (do-wrap ! unquote-splicing k)))
((scan-lit-lst (quote x) (k-head ! . args))
(k-head
,(if (string? (quote x)) (string->symbol (quote x)) (quote x))
. args))
((scan-lit-lst (hd . tl) k)
(scan-lit-lst hd (do-tl ! scan-lit-lst tl k)))
((scan-lit-lst x (k-head ! . args))
(k-head x . args))))
)
(scan-exp ?body (do-finish !))))
((run-test body ...)
(begin
(run-test "scan-exp" body) ...))
))
;========================================================================
; Data Types
; TAG-KIND
; a symbol 'START, 'END, 'PI, 'DECL, 'COMMENT, 'CDSECT
; or 'ENTITY-REF that identifies a markup token
; UNRES-NAME
; a name (called GI in the XML Recommendation) as given in an xml
; document for a markup token: start-tag, PI target, attribute name.
; If a GI is an NCName, UNRES-NAME is this NCName converted into
; a Scheme symbol. If a GI is a QName, UNRES-NAME is a pair of
; symbols: (PREFIX . LOCALPART)
; RES-NAME
; An expanded name, a resolved version of an UNRES-NAME.
; For an element or an attribute name with a non-empty namespace URI,
; RES-NAME is a pair of symbols, (URI-SYMB . LOCALPART).
; Otherwise, it's a single symbol.
; ELEM-CONTENT-MODEL
; A symbol:
; ANY - anything goes, expect an END tag.
; EMPTY-TAG - no content, and no END-tag is coming
; EMPTY - no content, expect the END-tag as the next token
; PCDATA - expect character data only, and no children elements
; MIXED
; ELEM-CONTENT
; URI-SYMB
; A symbol representing a namespace URI -- or other symbol chosen
; by the user to represent URI. In the former case,
; URI-SYMB is created by %-quoting of bad URI characters and
; converting the resulting string into a symbol.
; NAMESPACES
; A list representing namespaces in effect. An element of the list
; has one of the following forms:
; (PREFIX URI-SYMB . URI-SYMB) or
; (PREFIX USER-PREFIX . URI-SYMB)
; USER-PREFIX is a symbol chosen by the user
; to represent the URI.
; (#f USER-PREFIX . URI-SYMB)
; Specification of the user-chosen prefix and a URI-SYMBOL.
; (*DEFAULT* USER-PREFIX . URI-SYMB)
; Declaration of the default namespace
; (*DEFAULT* #f . #f)
; Un-declaration of the default namespace. This notation
; represents overriding of the previous declaration
; A NAMESPACES list may contain several elements for the same PREFIX.
; The one closest to the beginning of the list takes effect.
; ATTLIST
; An ordered collection of (NAME . VALUE) pairs, where NAME is
; a RES-NAME or an UNRES-NAME. The collection is an ADT
; STR-HANDLER
; A procedure of three arguments: STRING1 STRING2 SEED
; returning a new SEED
; The procedure is supposed to handle a chunk of character data
; STRING1 followed by a chunk of character data STRING2.
; STRING2 is a short string, often "\n" and even ""
; ENTITIES
; An assoc list of pairs:
; (named-entity-name . named-entity-body)
; where named-entity-name is a symbol under which the entity was
; declared, named-entity-body is either a string, or
; (for an external entity) a thunk that will return an
; input port (from which the entity can be read).
; named-entity-body may also be #f. This is an indication that a
; named-entity-name is currently being expanded. A reference to
; this named-entity-name will be an error: violation of the
; WFC nonrecursion.
; XML-TOKEN -- a record
; In Gambit, you can use the following declaration:
; (define-structure xml-token kind head)
; The following declaration is "standard" as it follows SRFI-9:
;;(define-record-type xml-token (make-xml-token kind head) xml-token?
;; (kind xml-token-kind)
;; (head xml-token-head) )
; No field mutators are declared as SSAX is a pure functional parser
;
; But to make the code more portable, we define xml-token simply as
; a pair. It suffices for us. Furthermore, xml-token-kind and xml-token-head
; can be defined as simple procedures. However, they are declared as
; macros below for efficiency.
(define (make-xml-token kind head) (cons kind head))
(define xml-token? pair?)
(define-syntax xml-token-kind
(syntax-rules () ((xml-token-kind token) (car token))))
(define-syntax xml-token-head
(syntax-rules () ((xml-token-head token) (cdr token))))
; (define-macro xml-token-kind (lambda (token) `(car ,token)))
; (define-macro xml-token-head (lambda (token) `(cdr ,token)))
; This record represents a markup, which is, according to the XML
; Recommendation, "takes the form of start-tags, end-tags, empty-element tags,
; entity references, character references, comments, CDATA section delimiters,
; document type declarations, and processing instructions."
;
; kind -- a TAG-KIND
; head -- an UNRES-NAME. For xml-tokens of kinds 'COMMENT and
; 'CDSECT, the head is #f
;
; For example,
;
=> kind='START, head='P
;
=> kind='END, head='P
; => kind='EMPTY-EL, head='BR
; => kind='DECL, head='DOCTYPE
; => kind='PI, head='xml
; &my-ent; => kind = 'ENTITY-REF, head='my-ent
;
; Character references are not represented by xml-tokens as these references
; are transparently resolved into the corresponding characters.
;
; XML-DECL -- a record
; The following is Gambit-specific, see below for a portable declaration
;(define-structure xml-decl elems entities notations)
; The record represents a datatype of an XML document: the list of
; declared elements and their attributes, declared notations, list of
; replacement strings or loading procedures for parsed general
; entities, etc. Normally an xml-decl record is created from a DTD or
; an XML Schema, although it can be created and filled in in many other
; ways (e.g., loaded from a file).
;
; elems: an (assoc) list of decl-elem or #f. The latter instructs
; the parser to do no validation of elements and attributes.
;
; decl-elem: declaration of one element:
; (elem-name elem-content decl-attrs)
; elem-name is an UNRES-NAME for the element.
; elem-content is an ELEM-CONTENT-MODEL.
; decl-attrs is an ATTLIST, of (ATTR-NAME . VALUE) associations
; !!!This element can declare a user procedure to handle parsing of an
; element (e.g., to do a custom validation, or to build a hash of
; IDs as they're encountered).
;
; decl-attr: an element of an ATTLIST, declaration of one attribute
; (attr-name content-type use-type default-value)
; attr-name is an UNRES-NAME for the declared attribute
; content-type is a symbol: CDATA, NMTOKEN, NMTOKENS, ...
; or a list of strings for the enumerated type.
; use-type is a symbol: REQUIRED, IMPLIED, FIXED
; default-value is a string for the default value, or #f if not given.
;
;
; see a function make-empty-xml-decl to make a XML declaration entry
; suitable for a non-validating parsing.
;-------------------------
; Utilities
; ssax:warn PORT MESSAGE SPECIALISING-MSG*
; to notify the user about warnings that are NOT errors but still
; may alert the user.
; Result is unspecified.
; We need to define the function to allow the self-tests to run.
; Normally the definition of ssax:warn is to be provided by the user.
(run-test
(define (ssax:warn port msg . other-msg)
(apply cerr (cons* nl "Warning: " msg other-msg)))
)
; parser-error PORT MESSAGE SPECIALISING-MSG*
; to let the user know of a syntax error or a violation of a
; well-formedness or validation constraint.
; Result is unspecified.
; We need to define the function to allow the self-tests to run.
; Normally the definition of parser-error is to be provided by the user.
(run-test
(define (parser-error port msg . specializing-msgs)
(apply error (cons msg specializing-msgs)))
)
; The following is a function that is often used in validation tests,
; to make sure that the computed result matches the expected one.
; This function is a standard equal? predicate with one exception.
; On Scheme systems where (string->symbol "A") and a symbol A
; are the same, equal_? is precisely equal?
; On other Scheme systems, we compare symbols disregarding their case.
; Since this function is used only in tests, we don't have to
; strive to make it efficient.
(run-test
(define (equal_? e1 e2)
(if (eq? 'A (string->symbol "A")) (equal? e1 e2)
(cond
((symbol? e1)
(and (symbol? e2)
(string-ci=? (symbol->string e1) (symbol->string e2))))
((pair? e1)
(and (pair? e2)
(equal_? (car e1) (car e2)) (equal_? (cdr e1) (cdr e2))))
((vector? e1)
(and (vector? e2) (equal_? (vector->list e1) (vector->list e2))))
(else
(equal? e1 e2)))))
)
; The following function, which is often used in validation tests,
; lets us conveniently enter newline, CR and tab characters in a character
; string.
; unesc-string: ESC-STRING -> STRING
; where ESC-STRING is a character string that may contain
; %n -- for #\newline
; %r -- for #\return
; %t -- for #\tab
; %% -- for #\%
;
; The result of unesc-string is a character string with all %-combinations
; above replaced with their character equivalents
(run-test
(define (unesc-string str)
(call-with-input-string str
(lambda (port)
(let loop ((frags '()))
(let* ((token (next-token '() '(#\% *eof*) "unesc-string" port))
(cterm (read-char port))
(frags (cons token frags)))
(if (eof-object? cterm) (string-concatenate-reverse/shared frags)
(let ((cchar (read-char port))) ; char after #\%
(if (eof-object? cchar)
(error "unexpected EOF after reading % in unesc-string:" str)
(loop
(cons
(case cchar
((#\n) (string #\newline))
((#\r) (string char-return))
((#\t) (string char-tab))
((#\%) "%")
(else (error "bad %-char in unesc-string:" cchar)))
frags))))))))))
)
; Test if a string is made of only whitespace
; An empty string is considered made of whitespace as well
(define (string-whitespace? str)
(let ((len (string-length str)))
(cond
((zero? len) #t)
((= 1 len) (char-whitespace? (string-ref str 0)))
((= 2 len) (and (char-whitespace? (string-ref str 0))
(char-whitespace? (string-ref str 1))))
(else
(let loop ((i 0))
(or (>= i len)
(and (char-whitespace? (string-ref str i))
(loop (inc i)))))))))
; Find val in alist
; Return (values found-el remaining-alist) or
; (values #f alist)
(define (assq-values val alist)
(let loop ((alist alist) (scanned '()))
(cond
((null? alist) (values #f scanned))
((equal? val (caar alist))
(values (car alist) (append scanned (cdr alist))))
(else
(loop (cdr alist) (cons (car alist) scanned))))))
; From SRFI-1
(define (fold-right kons knil lis1)
(let recur ((lis lis1))
(if (null? lis) knil
(let ((head (car lis)))
(kons head (recur (cdr lis)))))))
; Left fold combinator for a single list
(define (fold kons knil lis1)
(let lp ((lis lis1) (ans knil))
(if (null? lis) ans
(lp (cdr lis) (kons (car lis) ans)))))
;========================================================================
; Lower-level parsers and scanners
;
; They deal with primitive lexical units (Names, whitespaces, tags)
; and with pieces of more generic productions. Most of these parsers
; must be called in appropriate context. For example, ssax:complete-start-tag
; must be called only when the start-tag has been detected and its GI
; has been read.
;------------------------------------------------------------------------
; Low-level parsing code
; Skip the S (whitespace) production as defined by
; [3] S ::= (#x20 | #x9 | #xD | #xA)
; The procedure returns the first not-whitespace character it
; encounters while scanning the PORT. This character is left
; on the input stream.
(define ssax:S-chars (map ascii->char '(32 10 9 13)))
(define (ssax:skip-S port)
(skip-while ssax:S-chars port))
; Read a Name lexem and return it as string
; [4] NameChar ::= Letter | Digit | '.' | '-' | '_' | ':'
; | CombiningChar | Extender
; [5] Name ::= (Letter | '_' | ':') (NameChar)*
;
; This code supports the XML Namespace Recommendation REC-xml-names,
; which modifies the above productions as follows:
;
; [4] NCNameChar ::= Letter | Digit | '.' | '-' | '_'
; | CombiningChar | Extender
; [5] NCName ::= (Letter | '_') (NCNameChar)*
; As the Rec-xml-names says,
; "An XML document conforms to this specification if all other tokens
; [other than element types and attribute names] in the document which
; are required, for XML conformance, to match the XML production for
; Name, match this specification's production for NCName."
; Element types and attribute names must match the production QName,
; defined below.
; Check to see if a-char may start a NCName
(define (ssax:ncname-starting-char? a-char)
(and (char? a-char)
(or
(char-alphabetic? a-char)
(char=? #\_ a-char))))
; Read a NCName starting from the current position in the PORT and
; return it as a symbol.
(define (ssax:read-NCName port)
(let ((first-char (peek-char port)))
(or (ssax:ncname-starting-char? first-char)
(parser-error port "XMLNS [4] for '" first-char "'")))
(string->symbol
(next-token-of
(lambda (c)
(cond
((eof-object? c) #f)
((char-alphabetic? c) c)
((string-index "0123456789.-_" c) c)
(else #f)))
port)))
; Read a (namespace-) Qualified Name, QName, from the current
; position in the PORT.
; From REC-xml-names:
; [6] QName ::= (Prefix ':')? LocalPart
; [7] Prefix ::= NCName
; [8] LocalPart ::= NCName
; Return: an UNRES-NAME
(define (ssax:read-QName port)
(let ((prefix-or-localpart (ssax:read-NCName port)))
(case (peek-char port)
((#\:) ; prefix was given after all
(read-char port) ; consume the colon
(cons prefix-or-localpart (ssax:read-NCName port)))
(else prefix-or-localpart) ; Prefix was omitted
)))
; The prefix of the pre-defined XML namespace
(define ssax:Prefix-XML (string->symbol "xml"))
(run-test
(assert (eq? '_
(call-with-input-string "_" ssax:read-NCName)))
(assert (eq? '_
(call-with-input-string "_" ssax:read-QName)))
(assert (eq? (string->symbol "_abc_")
(call-with-input-string "_abc_;" ssax:read-NCName)))
(assert (eq? (string->symbol "_abc_")
(call-with-input-string "_abc_;" ssax:read-QName)))
(assert (eq? (string->symbol "_a.b")
(call-with-input-string "_a.b " ssax:read-QName)))
(assert (equal? (cons (string->symbol "_a.b") (string->symbol "d.1-ef-"))
(call-with-input-string "_a.b:d.1-ef-;" ssax:read-QName)))
(assert (equal? (cons (string->symbol "a") (string->symbol "b"))
(call-with-input-string "a:b:c" ssax:read-QName)))
(assert (failed? (call-with-input-string ":abc" ssax:read-NCName)))
(assert (failed? (call-with-input-string "1:bc" ssax:read-NCName)))
)
; Compare one RES-NAME or an UNRES-NAME with the other.
; Return a symbol '<, '>, or '= depending on the result of
; the comparison.
; Names without PREFIX are always smaller than those with the PREFIX.
(define name-compare
(letrec ((symbol-compare
(lambda (symb1 symb2)
(cond
((eq? symb1 symb2) '=)
((string (symbol->string symb1) (symbol->string symb2))
'<)
(else '>)))))
(lambda (name1 name2)
(cond
((symbol? name1) (if (symbol? name2) (symbol-compare name1 name2)
'<))
((symbol? name2) '>)
((eq? name2 ssax:largest-unres-name) '<)
((eq? name1 ssax:largest-unres-name) '>)
((eq? (car name1) (car name2)) ; prefixes the same
(symbol-compare (cdr name1) (cdr name2)))
(else (symbol-compare (car name1) (car name2)))))))
; An UNRES-NAME that is postulated to be larger than anything that can occur in
; a well-formed XML document.
; name-compare enforces this postulate.
(define ssax:largest-unres-name (cons
(string->symbol "#LARGEST-SYMBOL")
(string->symbol "#LARGEST-SYMBOL")))
(run-test
(assert (eq? '= (name-compare 'ABC 'ABC)))
(assert (eq? '< (name-compare 'ABC 'ABCD)))
(assert (eq? '> (name-compare 'XB 'ABCD)))
(assert (eq? '> (name-compare '(HTML . PRE) 'PRE)))
(assert (eq? '< (name-compare 'HTML '(HTML . PRE))))
(assert (eq? '= (name-compare '(HTML . PRE) '(HTML . PRE))))
(assert (eq? '< (name-compare '(HTML . PRE) '(XML . PRE))))
(assert (eq? '> (name-compare '(HTML . PRE) '(HTML . P))))
(assert (eq? '< (name-compare '(HTML . PRE) ssax:largest-unres-name)))
(assert (eq? '< (name-compare '(ZZZZ . ZZZ) ssax:largest-unres-name)))
(assert (eq? '> (name-compare ssax:largest-unres-name '(ZZZZ . ZZZ) )))
)
; procedure: ssax:read-markup-token PORT
; This procedure starts parsing of a markup token. The current position
; in the stream must be #\<. This procedure scans enough of the input stream
; to figure out what kind of a markup token it is seeing. The procedure returns
; an xml-token structure describing the token. Note, generally reading
; of the current markup is not finished! In particular, no attributes of
; the start-tag token are scanned.
;
; Here's a detailed break out of the return values and the position in the PORT
; when that particular value is returned:
; PI-token: only PI-target is read.
; To finish the Processing Instruction and disregard it,
; call ssax:skip-pi. ssax:read-attributes may be useful
; as well (for PIs whose content is attribute-value
; pairs)
; END-token: The end tag is read completely; the current position
; is right after the terminating #\> character.
; COMMENT is read and skipped completely. The current position
; is right after "-->" that terminates the comment.
; CDSECT The current position is right after "" port))
(parser-error port "XML [15], no -->"))
(make-xml-token 'COMMENT #f))
; we have read ") "XML [42]" port)))
((#\?) (read-char port) (make-xml-token 'PI (ssax:read-NCName port)))
((#\!)
(case (peek-next-char port)
((#\-) (read-char port) (skip-comment port))
((#\[) (read-char port) (read-cdata port))
(else (make-xml-token 'DECL (ssax:read-NCName port)))))
(else (make-xml-token 'START (ssax:read-QName port)))))
))
; The current position is inside a PI. Skip till the rest of the PI
(define (ssax:skip-pi port)
(if (not (find-string-from-port? "?>" port))
(parser-error port "Failed to find ?> terminating the PI")))
; The current position is right after reading the PITarget. We read the
; body of PI and return is as a string. The port will point to the
; character right after '?>' combination that terminates PI.
; [16] PI ::= '' PITarget (S (Char* - (Char* '?>' Char*)))? '?>'
(define (ssax:read-pi-body-as-string port)
(ssax:skip-S port) ; skip WS after the PI target name
(string-concatenate/shared
(let loop ()
(let ((pi-fragment
(next-token '() '(#\?) "reading PI content" port)))
(if (eqv? #\> (peek-next-char port))
(begin
(read-char port)
(cons pi-fragment '()))
(cons* pi-fragment "?" (loop)))))))
(run-test
(assert (equal? "p1 content "
(call-with-input-string ""
(lambda (port)
(ssax:read-markup-token port)
(ssax:read-pi-body-as-string port)))))
(assert (equal? "pi2? content? ?"
(call-with-input-string ""
(lambda (port)
(ssax:read-markup-token port)
(ssax:read-pi-body-as-string port)))))
)
;(define (ssax:read-pi-body-as-name-values port)
; The current pos in the port is inside an internal DTD subset
; (e.g., after reading #\[ that begins an internal DTD subset)
; Skip until the "]>" combination that terminates this DTD
(define (ssax:skip-internal-dtd port)
(if (not (find-string-from-port? "]>" port))
(parser-error port
"Failed to find ]> terminating the internal DTD subset")))
; procedure+: ssax:read-cdata-body PORT STR-HANDLER SEED
;
; This procedure must be called after we have read a string "" combination is the end of the CDATA section.
; > is treated as an embedded #\> character
; Note, < and & are not specially recognized (and are not expanded)!
(define ssax:read-cdata-body
(let ((cdata-delimiters (list char-return #\newline #\] #\&)))
(lambda (port str-handler seed)
(let loop ((seed seed))
(let ((fragment (next-token '() cdata-delimiters
"reading CDATA" port)))
; that is, we're reading the char after the 'fragment'
(case (read-char port)
((#\newline) (loop (str-handler fragment nl seed)))
((#\])
(if (not (eqv? (peek-char port) #\]))
(loop (str-handler fragment "]" seed))
(let check-after-second-braket
((seed (if (string-null? fragment) seed
(str-handler fragment "" seed))))
(case (peek-next-char port) ; after the second bracket
((#\>) (read-char port) seed) ; we have read "]]>"
((#\]) (check-after-second-braket
(str-handler "]" "" seed)))
(else (loop (str-handler "]]" "" seed)))))))
((#\&) ; Note that #\& within CDATA may stand for itself
(let ((ent-ref ; it does not have to start an entity ref
(next-token-of (lambda (c)
(and (not (eof-object? c)) (char-alphabetic? c) c)) port)))
(cond ; ">" is to be replaced with #\>
((and (string=? "gt" ent-ref) (eqv? (peek-char port) #\;))
(read-char port)
(loop (str-handler fragment ">" seed)))
(else
(loop
(str-handler ent-ref ""
(str-handler fragment "&" seed)))))))
(else ; Must be CR: if the next char is #\newline, skip it
(if (eqv? (peek-char port) #\newline) (read-char port))
(loop (str-handler fragment nl seed)))
))))))
; a few lines of validation code
(run-test (letrec
((consumer (lambda (fragment foll-fragment seed)
(cons* (if (equal? foll-fragment (string #\newline))
" NL" foll-fragment) fragment seed)))
(test (lambda (str expected-result)
(newline) (display "body: ") (write str)
(newline) (display "Result: ")
(let ((result
(reverse
(call-with-input-string (unesc-string str)
(lambda (port) (ssax:read-cdata-body port consumer '()))
))))
(write result)
(assert (equal? result expected-result)))))
)
(test "]]>" '())
(test "abcd]]>" '("abcd" ""))
(test "abcd]]]>" '("abcd" "" "]" ""))
(test "abcd]]]]>" '("abcd" "" "]" "" "]" ""))
(test "abcd]]]]]>" '("abcd" "" "]" "" "]" "" "]" ""))
(test "abcd]]]a]]>" '("abcd" "" "]" "" "]]" "" "a" ""))
(test "abc%r%ndef%n]]>" '("abc" " NL" "def" " NL"))
(test "%r%n%r%n]]>" '("" " NL" "" " NL"))
(test "%r%n%r%na]]>" '("" " NL" "" " NL" "a" ""))
(test "%r%r%r%na]]>" '("" " NL" "" " NL" "" " NL" "a" ""))
(test "abc&!!!]]>" '("abc" "&" "" "" "!!!" ""))
(test "abc]]>>&]]]>and]]>"
'("abc" "" "]]" "" "" ">" "" "&" "gt" "" "" "&" "amp" "" ";" "" "]" ""
"]]" "" "" ">" "and" ""))
))
; procedure+: ssax:read-char-ref PORT
;
; [66] CharRef ::= '' [0-9]+ ';'
; | '' [0-9a-fA-F]+ ';'
;
; This procedure must be called after we we have read ""
; that introduces a char reference.
; The procedure reads this reference and returns the corresponding char
; The current position in PORT will be after ";" that terminates
; the char reference
; Faults detected:
; WFC: XML-Spec.html#wf-Legalchar
;
; According to Section "4.1 Character and Entity References"
; of the XML Recommendation:
; "[Definition: A character reference refers to a specific character
; in the ISO/IEC 10646 character set, for example one not directly
; accessible from available input devices.]"
; Therefore, we use a ucscode->string function to convert a character
; code into the character -- *regardless* of the current character
; encoding of the input stream.
(define (ssax:read-char-ref port)
(let* ((base
(cond ((eqv? (peek-char port) #\x) (read-char port) 16)
(else 10)))
(name (next-token '() '(#\;) "XML [66]" port))
(char-code (string->number name base)))
(read-char port) ; read the terminating #\; char
(if (integer? char-code) (ucscode->string char-code)
(parser-error port "[wf-Legalchar] broken for '" name "'"))))
; procedure+: ssax:handle-parsed-entity PORT NAME ENTITIES
; CONTENT-HANDLER STR-HANDLER SEED
;
; Expand and handle a parsed-entity reference
; port - a PORT
; name - the name of the parsed entity to expand, a symbol
; entities - see ENTITIES
; content-handler -- procedure PORT ENTITIES SEED
; that is supposed to return a SEED
; str-handler - a STR-HANDLER. It is called if the entity in question
; turns out to be a pre-declared entity
;
; The result is the one returned by CONTENT-HANDLER or STR-HANDLER
; Faults detected:
; WFC: XML-Spec.html#wf-entdeclared
; WFC: XML-Spec.html#norecursion
(define ssax:predefined-parsed-entities
`(
(,(string->symbol "amp") . "&")
(,(string->symbol "lt") . "<")
(,(string->symbol "gt") . ">")
(,(string->symbol "apos") . "'")
(,(string->symbol "quot") . "\"")))
(define (ssax:handle-parsed-entity port name entities
content-handler str-handler seed)
(cond ; First we check the list of the declared entities
((assq name entities) =>
(lambda (decl-entity)
(let ((ent-body (cdr decl-entity)) ; mark the list to prevent recursion
(new-entities (cons (cons name #f) entities)))
(cond
((string? ent-body)
(call-with-input-string ent-body
(lambda (port) (content-handler port new-entities seed))))
((procedure? ent-body)
(let ((port (ent-body)))
(begin0
(content-handler port new-entities seed)
(close-input-port port))))
(else
(parser-error port "[norecursion] broken for " name))))))
((assq name ssax:predefined-parsed-entities)
=> (lambda (decl-entity)
(str-handler (cdr decl-entity) "" seed)))
(else (parser-error port "[wf-entdeclared] broken for " name))))
; The ATTLIST Abstract Data Type
; Currently is implemented as an assoc list sorted in the ascending
; order of NAMES.
(define (make-empty-attlist) '())
; Add a name-value pair to the existing attlist preserving the order
; Return the new list, in the sorted ascending order.
; Return #f if a pair with the same name already exists in the attlist
(define (attlist-add attlist name-value)
(if (null? attlist) (cons name-value attlist)
(case (name-compare (car name-value) (caar attlist))
((=) #f)
((<) (cons name-value attlist))
(else (cons (car attlist) (attlist-add (cdr attlist) name-value)))
)))
(define attlist-null? null?)
; Given an non-null attlist, return a pair of values: the top and the rest
(define (attlist-remove-top attlist)
(values (car attlist) (cdr attlist)))
(define (attlist->alist attlist) attlist)
(define attlist-fold fold)
; procedure+: ssax:read-attributes PORT ENTITIES
;
; This procedure reads and parses a production Attribute*
; [41] Attribute ::= Name Eq AttValue
; [10] AttValue ::= '"' ([^<&"] | Reference)* '"'
; | "'" ([^<&'] | Reference)* "'"
; [25] Eq ::= S? '=' S?
;
;
; The procedure returns an ATTLIST, of Name (as UNRES-NAME), Value (as string)
; pairs. The current character on the PORT is a non-whitespace character
; that is not an ncname-starting character.
;
; Note the following rules to keep in mind when reading an 'AttValue'
; "Before the value of an attribute is passed to the application
; or checked for validity, the XML processor must normalize it as follows:
; - a character reference is processed by appending the referenced
; character to the attribute value
; - an entity reference is processed by recursively processing the
; replacement text of the entity [see ENTITIES]
; [named entities amp lt gt quot apos are assumed pre-declared]
; - a whitespace character (#x20, #xD, #xA, #x9) is processed by appending #x20
; to the normalized value, except that only a single #x20 is appended for a
; "#xD#xA" sequence that is part of an external parsed entity or the
; literal entity value of an internal parsed entity
; - other characters are processed by appending them to the normalized value "
;
;
; Faults detected:
; WFC: XML-Spec.html#CleanAttrVals
; WFC: XML-Spec.html#uniqattspec
(define ssax:read-attributes ; ssax:read-attributes port entities
(let ((value-delimeters (append ssax:S-chars '(#\< #\&))))
; Read the AttValue from the PORT up to the delimiter
; (which can be a single or double-quote character,
; or even a symbol *eof*)
; 'prev-fragments' is the list of string fragments, accumulated
; so far, in reverse order.
; Return the list of fragments with newly read fragments
; prepended.
(define (read-attrib-value delimiter port entities prev-fragments)
(let* ((new-fragments
(cons (next-token '() (cons delimiter value-delimeters)
"XML [10]" port)
prev-fragments))
(cterm (read-char port)))
(cond
((or (eof-object? cterm) (eqv? cterm delimiter))
new-fragments)
((eqv? cterm char-return) ; treat a CR and CRLF as a LF
(if (eqv? (peek-char port) #\newline) (read-char port))
(read-attrib-value delimiter port entities
(cons " " new-fragments)))
((memv cterm ssax:S-chars)
(read-attrib-value delimiter port entities
(cons " " new-fragments)))
((eqv? cterm #\&)
(cond
((eqv? (peek-char port) #\#)
(read-char port)
(read-attrib-value delimiter port entities
(cons (ssax:read-char-ref port) new-fragments)))
(else
(read-attrib-value delimiter port entities
(read-named-entity port entities new-fragments)))))
(else (parser-error port "[CleanAttrVals] broken")))))
; we have read "&" that introduces a named entity reference.
; read this reference and return the result of
; normalizing of the corresponding string
; (that is, read-attrib-value is applied to the replacement
; text of the entity)
; The current position will be after ";" that terminates
; the entity reference
(define (read-named-entity port entities fragments)
(let ((name (ssax:read-NCName port)))
(assert-curr-char '(#\;) "XML [68]" port)
(ssax:handle-parsed-entity port name entities
(lambda (port entities fragments)
(read-attrib-value '*eof* port entities fragments))
(lambda (str1 str2 fragments)
(if (equal? "" str2) (cons str1 fragments)
(cons* str2 str1 fragments)))
fragments)))
(lambda (port entities)
(let loop ((attr-list (make-empty-attlist)))
(if (not (ssax:ncname-starting-char? (ssax:skip-S port))) attr-list
(let ((name (ssax:read-QName port)))
(ssax:skip-S port)
(assert-curr-char '(#\=) "XML [25]" port)
(ssax:skip-S port)
(let ((delimiter
(assert-curr-char '(#\' #\" ) "XML [10]" port)))
(loop
(or (attlist-add attr-list
(cons name
(string-concatenate-reverse/shared
(read-attrib-value delimiter port entities
'()))))
(parser-error port "[uniqattspec] broken for " name))))))))
))
; a few lines of validation code
(run-test (letrec
((test (lambda (str decl-entities expected-res)
(newline) (display "input: ") (write str)
(newline) (display "Result: ")
(let ((result
(call-with-input-string (unesc-string str)
(lambda (port)
(ssax:read-attributes port decl-entities)))))
(write result) (newline)
(assert (equal? result expected-res))))))
(test "" '() '())
(test "href='http://a%tb%r%n%r%n%nc'" '()
`((,(string->symbol "href") . "http://a b c")))
(test "href='http://a%tb%r%r%n%rc'" '()
`((,(string->symbol "href") . "http://a b c")))
(test "_1 ='12&' _2= \"%r%n%t12
3\">" '()
`((_1 . "12&") (_2 . ,(unesc-string " 12%n3"))))
(test "%tAbc='<&>
'%nNext='12&ent;34' />"
'((ent . "<xx>"))
`((,(string->symbol "Abc") . ,(unesc-string "<&>%n"))
(,(string->symbol "Next") . "1234")))
(test "%tAbc='<&>
'%nNext='12&ent;34' />"
'((ent . "<xx>"))
`((,(string->symbol "Abc") . ,(unesc-string "<&>%r"))
(,(string->symbol "Next") . "1234")))
(test "%tAbc='<&>
'%nNext='12&en;34' />"
`((en . ,(lambda () (open-input-string ""xx'"))))
`((,(string->symbol "Abc") . ,(unesc-string "<&>%n"))
(,(string->symbol "Next") . "12\"xx'34")))
(test "%tAbc='<&>
'%nNext='12&ent;34' />"
'((ent . "<&ent1;T;>") (ent1 . "&"))
`((,(string->symbol "Abc") . ,(unesc-string "<&>%n"))
(,(string->symbol "Next") . "12<&T;>34")))
(assert (failed?
(test "%tAbc='<&>
'%nNext='12&ent;34' />"
'((ent . "<&ent1;T;>") (ent1 . "&")) '())))
(assert (failed?
(test "%tAbc='<&>
'%nNext='12&ent;34' />"
'((ent . "<&ent;T;>") (ent1 . "&")) '())))
(assert (failed?
(test "%tAbc='<&>
'%nNext='12&ent;34' />"
'((ent . "<&ent1;T;>") (ent1 . "&ent;")) '())))
(test "html:href='http://a%tb%r%n%r%n%nc'" '()
`(((,(string->symbol "html") . ,(string->symbol "href"))
. "http://a b c")))
(test "html:href='ref1' html:src='ref2'" '()
`(((,(string->symbol "html") . ,(string->symbol "href"))
. "ref1")
((,(string->symbol "html") . ,(string->symbol "src"))
. "ref2")))
(test "html:href='ref1' xml:html='ref2'" '()
`(((,(string->symbol "html") . ,(string->symbol "href"))
. "ref1")
((,ssax:Prefix-XML . ,(string->symbol "html"))
. "ref2")))
(assert (failed? (test "html:href='ref1' html:href='ref2'" '() '())))
(assert (failed? (test "html:href='<' html:href='ref2'" '() '())))
(assert (failed? (test "html:href='ref1' html:href='&ref2;'" '() '())))
))
; ssax:resolve-name PORT UNRES-NAME NAMESPACES apply-default-ns?
;
; Convert an UNRES-NAME to a RES-NAME given the appropriate NAMESPACES
; declarations.
; the last parameter apply-default-ns? determines if the default
; namespace applies (for instance, it does not for attribute names)
;
; Per REC-xml-names/#nsc-NSDeclared, "xml" prefix is considered pre-declared
; and bound to the namespace name "http://www.w3.org/XML/1998/namespace".
;
; This procedure tests for the namespace constraints:
; http://www.w3.org/TR/REC-xml-names/#nsc-NSDeclared
(define (ssax:resolve-name port unres-name namespaces apply-default-ns?)
(cond
((pair? unres-name) ; it's a QNAME
(cons
(cond
((assq (car unres-name) namespaces) => cadr)
((eq? (car unres-name) ssax:Prefix-XML) ssax:Prefix-XML)
(else
(parser-error port "[nsc-NSDeclared] broken; prefix " (car unres-name))))
(cdr unres-name)))
(apply-default-ns? ; Do apply the default namespace, if any
(let ((default-ns (assq '*DEFAULT* namespaces)))
(if (and default-ns (cadr default-ns))
(cons (cadr default-ns) unres-name)
unres-name))) ; no default namespace declared
(else unres-name))) ; no prefix, don't apply the default-ns
(run-test
(let* ((namespaces
'((HTML UHTML . URN-HTML)
(HTML UHTML-1 . URN-HTML)
(A UHTML . URN-HTML)))
(namespaces-def
(cons
'(*DEFAULT* DEF . URN-DEF) namespaces))
(namespaces-undef
(cons
'(*DEFAULT* #f . #f) namespaces-def))
(port (current-input-port)))
(assert (equal? 'ABC
(ssax:resolve-name port 'ABC namespaces #t)))
(assert (equal? '(DEF . ABC)
(ssax:resolve-name port 'ABC namespaces-def #t)))
(assert (equal? 'ABC
(ssax:resolve-name port 'ABC namespaces-def #f)))
(assert (equal? 'ABC
(ssax:resolve-name port 'ABC namespaces-undef #t)))
(assert (equal? '(UHTML . ABC)
(ssax:resolve-name port '(HTML . ABC) namespaces-def #t)))
(assert (equal? '(UHTML . ABC)
(ssax:resolve-name port '(HTML . ABC) namespaces-def #f)))
(assert (equal? `(,ssax:Prefix-XML . space)
(ssax:resolve-name port
`(,(string->symbol "xml") . space) namespaces-def #f)))
(assert (failed?
(ssax:resolve-name port '(XXX . ABC) namespaces-def #f)))
))
; procedure+: ssax:uri-string->symbol URI-STR
; Convert a URI-STR to an appropriate symbol
(define (ssax:uri-string->symbol uri-str)
(string->symbol uri-str))
; procedure+: ssax:complete-start-tag TAG PORT ELEMS ENTITIES NAMESPACES
;
; This procedure is to complete parsing of a start-tag markup. The
; procedure must be called after the start tag token has been
; read. TAG is an UNRES-NAME. ELEMS is an instance of xml-decl::elems;
; it can be #f to tell the function to do _no_ validation of elements
; and their attributes.
;
; This procedure returns several values:
; ELEM-GI: a RES-NAME.
; ATTRIBUTES: element's attributes, an ATTLIST of (RES-NAME . STRING)
; pairs. The list does NOT include xmlns attributes.
; NAMESPACES: the input list of namespaces amended with namespace
; (re-)declarations contained within the start-tag under parsing
; ELEM-CONTENT-MODEL
; On exit, the current position in PORT will be the first character after
; #\> that terminates the start-tag markup.
;
; Faults detected:
; VC: XML-Spec.html#enum
; VC: XML-Spec.html#RequiredAttr
; VC: XML-Spec.html#FixedAttr
; VC: XML-Spec.html#ValueType
; WFC: XML-Spec.html#uniqattspec (after namespaces prefixes are resolved)
; VC: XML-Spec.html#elementvalid
; WFC: REC-xml-names/#dt-NSName
; Note, although XML Recommendation does not explicitly say it,
; xmlns and xmlns: attributes don't have to be declared (although they
; can be declared, to specify their default value)
; Procedure: ssax:complete-start-tag tag-head port elems entities namespaces
(define ssax:complete-start-tag
(let ((xmlns (string->symbol "xmlns"))
(largest-dummy-decl-attr (list ssax:largest-unres-name #f #f #f)))
; Scan through the attlist and validate it, against decl-attrs
; Return an assoc list with added fixed or implied attrs.
; Note that both attlist and decl-attrs are ATTLISTs, and therefore,
; sorted
(define (validate-attrs port attlist decl-attrs)
; Check to see decl-attr is not of use type REQUIRED. Add
; the association with the default value, if any declared
(define (add-default-decl decl-attr result)
(let*-values
(((attr-name content-type use-type default-value)
(apply values decl-attr)))
(and (eq? use-type 'REQUIRED)
(parser-error port "[RequiredAttr] broken for" attr-name))
(if default-value
(cons (cons attr-name default-value) result)
result)))
(let loop ((attlist attlist) (decl-attrs decl-attrs) (result '()))
(if (attlist-null? attlist)
(attlist-fold add-default-decl result decl-attrs)
(let*-values
(((attr attr-others)
(attlist-remove-top attlist))
((decl-attr other-decls)
(if (attlist-null? decl-attrs)
(values largest-dummy-decl-attr decl-attrs)
(attlist-remove-top decl-attrs)))
)
(case (name-compare (car attr) (car decl-attr))
((<)
(if (or (eq? xmlns (car attr))
(and (pair? (car attr)) (eq? xmlns (caar attr))))
(loop attr-others decl-attrs (cons attr result))
(parser-error port "[ValueType] broken for " attr)))
((>)
(loop attlist other-decls
(add-default-decl decl-attr result)))
(else ; matched occurrence of an attr with its declaration
(let*-values
(((attr-name content-type use-type default-value)
(apply values decl-attr)))
; Run some tests on the content of the attribute
(cond
((eq? use-type 'FIXED)
(or (equal? (cdr attr) default-value)
(parser-error port "[FixedAttr] broken for " attr-name)))
((eq? content-type 'CDATA) #t) ; everything goes
((pair? content-type)
(or (member (cdr attr) content-type)
(parser-error port "[enum] broken for " attr-name "="
(cdr attr))))
(else
(ssax:warn port "declared content type " content-type
" not verified yet")))
(loop attr-others other-decls (cons attr result)))))
))))
; Add a new namespace declaration to namespaces.
; First we convert the uri-str to a uri-symbol and search namespaces for
; an association (_ user-prefix . uri-symbol).
; If found, we return the argument namespaces with an association
; (prefix user-prefix . uri-symbol) prepended.
; Otherwise, we prepend (prefix uri-symbol . uri-symbol)
(define (add-ns port prefix uri-str namespaces)
(and (equal? "" uri-str)
(parser-error port "[dt-NSName] broken for " prefix))
(let ((uri-symbol (ssax:uri-string->symbol uri-str)))
(let loop ((nss namespaces))
(cond
((null? nss)
(cons (cons* prefix uri-symbol uri-symbol) namespaces))
((eq? uri-symbol (cddar nss))
(cons (cons* prefix (cadar nss) uri-symbol) namespaces))
(else (loop (cdr nss)))))))
; partition attrs into proper attrs and new namespace declarations
; return two values: proper attrs and the updated namespace declarations
(define (adjust-namespace-decl port attrs namespaces)
(let loop ((attrs attrs) (proper-attrs '()) (namespaces namespaces))
(cond
((null? attrs) (values proper-attrs namespaces))
((eq? xmlns (caar attrs)) ; re-decl of the default namespace
(loop (cdr attrs) proper-attrs
(if (equal? "" (cdar attrs)) ; un-decl of the default ns
(cons (cons* '*DEFAULT* #f #f) namespaces)
(add-ns port '*DEFAULT* (cdar attrs) namespaces))))
((and (pair? (caar attrs)) (eq? xmlns (caaar attrs)))
(loop (cdr attrs) proper-attrs
(add-ns port (cdaar attrs) (cdar attrs) namespaces)))
(else
(loop (cdr attrs) (cons (car attrs) proper-attrs) namespaces)))))
; The body of the function
(lambda (tag-head port elems entities namespaces)
(let*-values
(((attlist) (ssax:read-attributes port entities))
((empty-el-tag?)
(begin
(ssax:skip-S port)
(and
(eqv? #\/
(assert-curr-char '(#\> #\/) "XML [40], XML [44], no '>'" port))
(assert-curr-char '(#\>) "XML [44], no '>'" port))))
((elem-content decl-attrs) ; see xml-decl for their type
(if elems ; elements declared: validate!
(cond
((assoc tag-head elems) =>
(lambda (decl-elem) ; of type xml-decl::decl-elem
(values
(if empty-el-tag? 'EMPTY-TAG (cadr decl-elem))
(caddr decl-elem))))
(else
(parser-error port "[elementvalid] broken, no decl for " tag-head)))
(values ; non-validating parsing
(if empty-el-tag? 'EMPTY-TAG 'ANY)
#f) ; no attributes declared
))
((merged-attrs) (if decl-attrs (validate-attrs port attlist decl-attrs)
(attlist->alist attlist)))
((proper-attrs namespaces)
(adjust-namespace-decl port merged-attrs namespaces))
)
;(cerr "proper attrs: " proper-attrs nl)
; build the return value
(values
(ssax:resolve-name port tag-head namespaces #t)
(fold-right
(lambda (name-value attlist)
(or
(attlist-add attlist
(cons (ssax:resolve-name port (car name-value) namespaces #f)
(cdr name-value)))
(parser-error port "[uniqattspec] after NS expansion broken for "
name-value)))
(make-empty-attlist)
proper-attrs)
namespaces
elem-content)))))
(run-test
(let* ((urn-a (string->symbol "urn:a"))
(urn-b (string->symbol "urn:b"))
(urn-html (string->symbol "http://w3c.org/html"))
(namespaces
`((#f '"UHTML" . ,urn-html)
('"A" '"UA" . ,urn-a)))
(test
(lambda (tag-head-name elems str)
(call-with-input-string str
(lambda (port)
(call-with-values
(lambda ()
(ssax:complete-start-tag
(call-with-input-string tag-head-name
(lambda (port) (ssax:read-QName port)))
port
elems '() namespaces))
list))))))
; First test with no validation of elements
;(test "TAG1" #f "")
(assert (equal? `('"TAG1" () ,namespaces ANY)
(test "TAG1" #f ">")))
(assert (equal? `('"TAG1" () ,namespaces EMPTY-TAG)
(test "TAG1" #f "/>")))
(assert (equal? `('"TAG1" (('"HREF" . "a")) ,namespaces EMPTY-TAG)
(test "TAG1" #f "HREF='a'/>")))
(assert (equal? `(('"UA" . '"TAG1") (('"HREF" . "a"))
,(cons `(*DEFAULT* '"UA" . ,urn-a) namespaces) ANY)
(test "TAG1" #f "HREF='a' xmlns='urn:a'>")))
(assert (equal? `('"TAG1" (('"HREF" . "a"))
,(cons '(*DEFAULT* #f . #f) namespaces) ANY)
(test "TAG1" #f "HREF='a' xmlns=''>")))
(assert (failed? (test "UA:TAG1" #f "HREF='a' xmlns=''/>")))
(assert (equal? `(('"UA" . '"TAG1") ((('"UA" . '"HREF") . "a"))
,(cons '(*DEFAULT* #f . #f) namespaces) ANY)
(test "A:TAG1" #f "A:HREF='a' xmlns=''>")))
(assert (equal? `(('"UA" . '"TAG1") ((('"UA" . '"HREF") . "a"))
,(cons `(*DEFAULT* ,urn-b . ,urn-b) namespaces) ANY)
(test "A:TAG1" #f "A:HREF='a' xmlns='urn:b'>")))
(assert (failed? (test "B:TAG1" #f "A:HREF='a' xmlns:b=''/>")))
(assert (equal? `((,urn-b . '"TAG1") ((('"UA" . '"HREF") . "a"))
,(cons `('"B" ,urn-b . ,urn-b) namespaces) ANY)
(test "B:TAG1" #f "A:HREF='a' xmlns:B='urn:b'>")))
(assert (equal? `((,urn-b . '"TAG1") ((('"UA" . '"HREF") . "a")
((,urn-b . '"SRC") . "b"))
,(cons `('"B" ,urn-b . ,urn-b) namespaces) ANY)
(test "B:TAG1" #f
"B:SRC='b' A:HREF='a' xmlns:B='urn:b'>")))
(assert (equal? `((,urn-b . '"TAG1") ((('"UA" . '"HREF") . "a")
((,urn-b . '"HREF") . "b"))
,(cons `('"B" ,urn-b . ,urn-b) namespaces) ANY)
(test "B:TAG1" #f
"B:HREF=\"b\" A:HREF='a' xmlns:B='urn:b'>")))
; must be an error! Duplicate attr
(assert (failed? (test "B:TAG1" #f
"HREF=\"b\" HREF='a' xmlns:B='urn:a'/>")))
; must be an error! Duplicate attr after ns expansion
(assert (failed? (test "B:TAG1" #f
"B:HREF=\"b\" A:HREF='a' xmlns:B='urn:a'/>")))
(assert (equal? `(('"UA" . '"TAG1") (('"HREF" . "a")
(('"UA" . '"HREF") . "b"))
,(cons `(*DEFAULT* '"UA" . ,urn-a) namespaces) ANY)
(test "TAG1" #f
"A:HREF=\"b\" HREF='a' xmlns='urn:a'>")))
(assert (equal? `('"TAG1" ((('"UHTML" . '"HREF") . "a")
((,urn-b . '"HREF") . "b"))
,(append `(
('"HTML" '"UHTML" . ,urn-html)
('"B" ,urn-b . ,urn-b))
namespaces) ANY)
(test "TAG1" #f
"B:HREF=\"b\" xmlns:B='urn:b' xmlns:HTML='http://w3c.org/html' HTML:HREF='a' >")))
; Now test the validating parsing
; No decl for tag1
(assert (failed? (test "TAG1" '((TAG2 ANY ()))
"B:HREF='b' xmlns:B='urn:b'>")))
; No decl for HREF elem
;; (cond-expand
;; ((not (or scm mit-scheme)) ; Regretfully, SCM treats '() as #f
;; (assert (failed?
;; (test "TAG1" '(('"TAG1" ANY ()))
;; "B:HREF='b' xmlns:B='urn:b'>"))))
;; (else #t))
; No decl for HREF elem
(assert (failed?
(test "TAG1" '(('"TAG1" ANY (('"HREF1" CDATA IMPLIED #f))))
"B:HREF='b' xmlns:B='urn:b'>")))
(assert (equal? `('"TAG1" (('"HREF" . "b")) ,namespaces EMPTY-TAG)
(test "TAG1" '(('"TAG1" PCDATA (('"HREF" CDATA REQUIRED #f))))
"HREF='b'/>")))
(assert (equal? `('"TAG1" (('"HREF" . "b")) ,namespaces PCDATA)
(test "TAG1" '(('"TAG1" PCDATA (('"HREF" CDATA REQUIRED #f))))
"HREF='b'>")))
; Req'd attribute not given error
(assert (failed?
(test "TAG1" '(('"TAG1" PCDATA (('"HREF" CDATA REQUIRED #f))))
">")))
; Wrong content-type of the attribute
(assert (failed?
(test "TAG1" '(('"TAG1" PCDATA (('"HREF" ("c") REQUIRED #f))))
"HREF='b'>")))
(assert (equal? `('"TAG1" (('"HREF" . "b")) ,namespaces PCDATA)
(test "TAG1" '(('"TAG1" PCDATA (('"HREF" ("c" "b") IMPLIED #f))))
"HREF='b'>")))
(assert (equal? `('"TAG1" (('"HREF" . "b")) ,namespaces PCDATA)
(test "TAG1" '(('"TAG1" PCDATA (('"HREF" CDATA IMPLIED "c"))))
"HREF='b'>")))
; Bad fixed attribute
(assert (failed?
(test "TAG1" '(('"TAG1" PCDATA (('"HREF" CDATA FIXED "c"))))
"HREF='b'>")))
(assert (equal? `('"TAG1" (('"HREF" . "b")) ,namespaces PCDATA)
(test "TAG1" '(('"TAG1" PCDATA (('"HREF" CDATA FIXED "b"))))
"HREF='b'>")))
(assert (equal? `('"TAG1" (('"HREF" . "b")) ,namespaces PCDATA)
(test "TAG1" '(('"TAG1" PCDATA (('"HREF" CDATA FIXED "b")))) ">")))
(assert (equal? `('"TAG1" (('"HREF" . "b")) ,namespaces PCDATA)
(test "TAG1" '(('"TAG1" PCDATA (('"HREF" CDATA IMPLIED "b")))) ">")))
(assert (equal? `('"TAG1" () ,namespaces PCDATA)
(test "TAG1" '(('"TAG1" PCDATA (('"HREF" CDATA IMPLIED #f)))) ">")))
; Undeclared attr
(assert (failed?
(test "TAG1"
'(('"TAG1" PCDATA ((('"A" . '"HREF") CDATA IMPLIED "c"))))
"HREF='b'>")))
(assert (equal? `('"TAG1" (('"HREF" . "b") (('"UA" . '"HREF") . "c"))
,namespaces PCDATA)
(test "TAG1" '(('"TAG1" PCDATA (('"HREF" CDATA REQUIRED #f)
(('"A" . '"HREF") CDATA IMPLIED "c"))))
"HREF='b'>")))
(assert (equal? `(('"UA" . '"TAG1")
(('"HREF" . "b") (('"UA" . '"HREF") . "c"))
,namespaces PCDATA)
(test "A:TAG1" '((('"A" . '"TAG1") PCDATA
(('"HREF" NMTOKEN REQUIRED #f)
(('"A" . '"HREF") CDATA IMPLIED "c"))))
"HREF='b'>")))
(assert (equal? `((,urn-b . '"TAG1") (('"HREF" . "b"))
,(cons `('"B" ,urn-b . ,urn-b) namespaces) PCDATA)
(test "B:TAG1" '((('"B" . '"TAG1") PCDATA (('"HREF" CDATA REQUIRED #f)
(('"xmlns" . '"B") CDATA IMPLIED "urn:b"))))
"HREF='b'>")))
(assert (equal? `((,urn-b . '"TAG1") (((,urn-b . '"HREF") . "b"))
,(cons `('"B" ,urn-b . ,urn-b) namespaces) PCDATA)
(test "B:TAG1" '((('"B" . '"TAG1") PCDATA
((('"B" . '"HREF") CDATA REQUIRED #f)
(('"xmlns" . '"B") CDATA IMPLIED "urn:b"))))
"B:HREF='b'>")))
(assert (equal? `((,urn-b . '"TAG1") (('"HREF" . "b"))
,(cons `(*DEFAULT* ,urn-b . ,urn-b) namespaces) PCDATA)
(test "TAG1" '(('"TAG1" PCDATA (('"HREF" CDATA REQUIRED #f)
('"xmlns" CDATA IMPLIED "urn:b"))))
"HREF='b'>")))
; xmlns not declared
(assert (equal? `((,urn-b . '"TAG1") (('"HREF" . "b"))
,(cons `(*DEFAULT* ,urn-b . ,urn-b) namespaces) PCDATA)
(test "TAG1" '(('"TAG1" PCDATA (('"HREF" CDATA REQUIRED #f)
)))
"HREF='b' xmlns='urn:b'>")))
; xmlns:B not declared
(assert (equal? `((,urn-b . '"TAG1") (((,urn-b . '"HREF") . "b"))
,(cons `('"B" ,urn-b . ,urn-b) namespaces) PCDATA)
(test "B:TAG1" '((('"B" . '"TAG1") PCDATA
((('"B" . '"HREF") CDATA REQUIRED #f)
)))
"B:HREF='b' xmlns:B='urn:b'>")))
))
; procedure+: ssax:read-external-id PORT
;
; This procedure parses an ExternalID production:
; [75] ExternalID ::= 'SYSTEM' S SystemLiteral
; | 'PUBLIC' S PubidLiteral S SystemLiteral
; [11] SystemLiteral ::= ('"' [^"]* '"') | ("'" [^']* "'")
; [12] PubidLiteral ::= '"' PubidChar* '"' | "'" (PubidChar - "'")* "'"
; [13] PubidChar ::= #x20 | #xD | #xA | [a-zA-Z0-9]
; | [-'()+,./:=?;!*#@$_%]
;
; This procedure is supposed to be called when an ExternalID is expected;
; that is, the current character must be either #\S or #\P that start
; correspondingly a SYSTEM or PUBLIC token. This procedure returns the
; SystemLiteral as a string. A PubidLiteral is disregarded if present.
(define (ssax:read-external-id port)
(let ((discriminator (ssax:read-NCName port)))
(assert-curr-char ssax:S-chars "space after SYSTEM or PUBLIC" port)
(ssax:skip-S port)
(let ((delimiter
(assert-curr-char '(#\' #\" ) "XML [11], XML [12]" port)))
(cond
((eq? discriminator (string->symbol "SYSTEM"))
(begin0
(next-token '() (list delimiter) "XML [11]" port)
(read-char port) ; reading the closing delim
))
((eq? discriminator (string->symbol "PUBLIC"))
(skip-until (list delimiter) port)
(assert-curr-char ssax:S-chars "space after PubidLiteral" port)
(ssax:skip-S port)
(let* ((delimiter
(assert-curr-char '(#\' #\" ) "XML [11]" port))
(systemid
(next-token '() (list delimiter) "XML [11]" port)))
(read-char port) ; reading the closing delim
systemid))
(else
(parser-error port "XML [75], " discriminator
" rather than SYSTEM or PUBLIC"))))))
;-----------------------------------------------------------------------------
; Higher-level parsers and scanners
;
; They parse productions corresponding to the whole (document) entity
; or its higher-level pieces (prolog, root element, etc).
; Scan the Misc production in the context
; [1] document ::= prolog element Misc*
; [22] prolog ::= XMLDecl? Misc* (doctypedec l Misc*)?
; [27] Misc ::= Comment | PI | S
;
; The following function should be called in the prolog or epilog contexts.
; In these contexts, whitespaces are completely ignored.
; The return value from ssax:scan-Misc is either a PI-token,
; a DECL-token, a START token, or EOF.
; Comments are ignored and not reported.
(define (ssax:scan-Misc port)
(let loop ((c (ssax:skip-S port)))
(cond
((eof-object? c) c)
((not (char=? c #\<))
(parser-error port "XML [22], char '" c "' unexpected"))
(else
(let ((token (ssax:read-markup-token port)))
(case (xml-token-kind token)
((COMMENT) (loop (ssax:skip-S port)))
((PI DECL START) token)
(else
(parser-error port "XML [22], unexpected token of kind "
(xml-token-kind token)
))))))))
; procedure+: ssax:read-char-data PORT EXPECT-EOF? STR-HANDLER SEED
;
; This procedure is to read the character content of an XML document
; or an XML element.
; [43] content ::=
; (element | CharData | Reference | CDSect | PI
; | Comment)*
; To be more precise, the procedure reads CharData, expands CDSect
; and character entities, and skips comments. The procedure stops
; at a named reference, EOF, at the beginning of a PI or a start/end tag.
;
; port
; a PORT to read
; expect-eof?
; a boolean indicating if EOF is normal, i.e., the character
; data may be terminated by the EOF. EOF is normal
; while processing a parsed entity.
; str-handler
; a STR-HANDLER
; seed
; an argument passed to the first invocation of STR-HANDLER.
;
; The procedure returns two results: SEED and TOKEN.
; The SEED is the result of the last invocation of STR-HANDLER, or the
; original seed if STR-HANDLER was never called.
;
; TOKEN can be either an eof-object (this can happen only if
; expect-eof? was #t), or:
; - an xml-token describing a START tag or an END-tag;
; For a start token, the caller has to finish reading it.
; - an xml-token describing the beginning of a PI. It's up to an
; application to read or skip through the rest of this PI;
; - an xml-token describing a named entity reference.
;
; CDATA sections and character references are expanded inline and
; never returned. Comments are silently disregarded.
;
; As the XML Recommendation requires, all whitespace in character data
; must be preserved. However, a CR character (#xD) must be disregarded
; if it appears before a LF character (#xA), or replaced by a #xA character
; otherwise. See Secs. 2.10 and 2.11 of the XML Recommendation. See also
; the canonical XML Recommendation.
; ssax:read-char-data port expect-eof? str-handler seed
(define ssax:read-char-data
(let
((terminators-usual (list #\< #\& char-return))
(terminators-usual-eof (list #\< '*eof* #\& char-return))
(handle-fragment
(lambda (fragment str-handler seed)
(if (string-null? fragment) seed
(str-handler fragment "" seed))))
)
(lambda (port expect-eof? str-handler seed)
; Very often, the first character we encounter is #\<
; Therefore, we handle this case in a special, fast path
(if (eqv? #\< (peek-char port))
; The fast path
(let ((token (ssax:read-markup-token port)))
(case (xml-token-kind token)
((START END) ; The most common case
(values seed token))
((CDSECT)
(let ((seed (ssax:read-cdata-body port str-handler seed)))
(ssax:read-char-data port expect-eof? str-handler seed)))
((COMMENT) (ssax:read-char-data port expect-eof?
str-handler seed))
(else
(values seed token))))
; The slow path
(let ((char-data-terminators
(if expect-eof? terminators-usual-eof terminators-usual)))
(let loop ((seed seed))
(let* ((fragment
(next-token '() char-data-terminators
"reading char data" port))
(term-char (peek-char port)) ; one of char-data-terminators
)
(if (eof-object? term-char)
(values
(handle-fragment fragment str-handler seed)
term-char)
(case term-char
((#\<)
(let ((token (ssax:read-markup-token port)))
(case (xml-token-kind token)
((CDSECT)
(loop
(ssax:read-cdata-body port str-handler
(handle-fragment fragment str-handler seed))))
((COMMENT)
(loop (handle-fragment fragment str-handler seed)))
(else
(values
(handle-fragment fragment str-handler seed)
token)))))
((#\&)
(case (peek-next-char port)
((#\#) (read-char port)
(loop (str-handler fragment
(ssax:read-char-ref port)
seed)))
(else
(let ((name (ssax:read-NCName port)))
(assert-curr-char '(#\;) "XML [68]" port)
(values
(handle-fragment fragment str-handler seed)
(make-xml-token 'ENTITY-REF name))))))
(else ; This must be a CR character
(if (eqv? (peek-next-char port) #\newline)
(read-char port))
(loop (str-handler fragment (string #\newline) seed))))
))))))))
; a few lines of validation code
(run-test (letrec
((a-tag (make-xml-token 'START (string->symbol "BR")))
(a-ref (make-xml-token 'ENTITY-REF (string->symbol "lt")))
(eof-object (lambda () eof-object)) ; a unique value
(str-handler (lambda (fragment foll-fragment seed)
(if (string-null? foll-fragment) (cons fragment seed)
(cons* foll-fragment fragment seed))))
(test (lambda (str expect-eof? expected-data expected-token)
(newline) (display "body: ") (write str)
(newline) (display "Result: ")
(let*-values
(((seed token)
(call-with-input-string (unesc-string str)
(lambda (port)
(ssax:read-char-data port expect-eof? str-handler '()))))
((result) (reverse seed)))
(write result)
(display " ")
(display token)
(assert (equal? result (map unesc-string expected-data))
(if (eq? expected-token eof-object)
(eof-object? token)
(equal? token expected-token))))))
)
(test "" #t '() eof-object)
(assert (failed? (test "" #f '() eof-object)))
(test " " #t '(" ") eof-object)
(test " " #f '() a-tag)
(test " " #f '(" ") a-tag)
(test " <" #f '(" ") a-ref)
(test " a<" #f '(" a") a-ref)
(test " a <" #f '(" a ") a-ref)
(test " a a " #f '(" " " a a") a-tag)
(test " %ra a " #f '(" " "" "%n" "a a") a-tag)
(test " %r%na a " #f '(" " "" "%n" "a a") a-tag)
(test " %r%na%t%r%r%na " #f
'(" " "" "%n" "a%t" "%n" "" "%n" "a") a-tag)
(test "a a a " #f '("a" " a a") a-tag)
(test "! " #f '("" "!") a-tag)
(test "!%n " #f '("" "!" "%n") a-tag)
(test "%t!%n " #f '("%t" "!" "%n") a-tag)
(test "%t!%na a " #f '("%t" "!" "%na a") a-tag)
(test "%t!%ra a " #f '("%t" "!" "" "%n" "a a") a-tag)
(test "%t!%r%na a " #f '("%t" "!" "" "%n" "a a") a-tag)
(test " %ta ! b " #f '(" %ta " "!" " b ") a-tag)
(test " %ta b " #f '(" %ta " " " " b ") a-tag)
(test " " #f '("<") a-tag)
(test " " #f '("]") a-tag)
(test "%t " #f '("%t" "<") a-tag)
(test "%ta b " #f '("%t" "<" "a b") a-tag)
(test "%t a b " #f '("%t" "<" " a b") a-tag)
(test "%td a b " #f
'("%td " " <" "%n" "" "%n" " a b") a-tag)
))
; procedure+: ssax:assert-token TOKEN KIND GI
; Make sure that TOKEN is of anticipated KIND and has anticipated GI
; Note GI argument may actually be a pair of two symbols, Namespace
; URI or the prefix, and of the localname.
; If the assertion fails, error-cont is evaluated by passing it
; three arguments: token kind gi. The result of error-cont is returned.
(define (ssax:assert-token token kind gi error-cont)
(or
(and (xml-token? token)
(eq? kind (xml-token-kind token))
(equal? gi (xml-token-head token)))
(error-cont token kind gi)))
;========================================================================
; Highest-level parsers: XML to SXML
; These parsers are a set of syntactic forms to instantiate a SSAX parser.
; A user can instantiate the parser to do the full validation, or
; no validation, or any particular validation. The user specifies
; which PI he wants to be notified about. The user tells what to do
; with the parsed character and element data. The latter handlers
; determine if the parsing follows a SAX or a DOM model.
; syntax: ssax:make-pi-parser my-pi-handlers
; Create a parser to parse and process one Processing Element (PI).
; my-pi-handlers
; An assoc list of pairs (PI-TAG . PI-HANDLER)
; where PI-TAG is an NCName symbol, the PI target, and
; PI-HANDLER is a procedure PORT PI-TAG SEED
; where PORT points to the first symbol after the PI target.
; The handler should read the rest of the PI up to and including
; the combination '?>' that terminates the PI. The handler should
; return a new seed.
; One of the PI-TAGs may be the symbol *DEFAULT*. The corresponding
; handler will handle PIs that no other handler will. If the
; *DEFAULT* PI-TAG is not specified, ssax:make-pi-parser will assume
; the default handler that skips the body of the PI
;
; The output of the ssax:make-pi-parser is a procedure
; PORT PI-TAG SEED
; that will parse the current PI according to the user-specified handlers.
;
; The previous version of ssax:make-pi-parser was a low-level macro:
; (define-macro ssax:make-pi-parser
; (lambda (my-pi-handlers)
; `(lambda (port target seed)
; (case target
; ; Generate the body of the case statement
; ,@(let loop ((pi-handlers my-pi-handlers) (default #f))
; (cond
; ((null? pi-handlers)
; (if default `((else (,default port target seed)))
; '((else
; (ssax:warn port "Skipping PI: " target nl)
; (ssax:skip-pi port)
; seed))))
; ((eq? '*DEFAULT* (caar pi-handlers))
; (loop (cdr pi-handlers) (cdar pi-handlers)))
; (else
; (cons
; `((,(caar pi-handlers)) (,(cdar pi-handlers) port target seed))
; (loop (cdr pi-handlers) default)))))))))
(define-syntax ssax:make-pi-parser
(syntax-rules ()
((ssax:make-pi-parser orig-handlers)
(letrec-syntax
; Generate the clauses of the case statement
((loop
(syntax-rules (*DEFAULT*)
((loop () #f accum port target seed) ; no default
(make-case
((else
(ssax:warn port "Skipping PI: " target nl)
(ssax:skip-pi port)
seed)
. accum)
() target))
((loop () default accum port target seed)
(make-case
((else (default port target seed)) . accum)
() target))
((loop ((*DEFAULT* . default) . handlers) old-def accum
port target seed)
(loop handlers default accum port target seed))
((loop ((tag . handler) . handlers) default accum port target seed)
(loop handlers default
(((tag) (handler port target seed)) . accum)
port target seed))
))
(make-case ; Reverse the clauses, make the 'case'
(syntax-rules ()
((make-case () clauses target)
(case target . clauses))
((make-case (clause . clauses) accum target)
(make-case clauses (clause . accum) target)))
))
(lambda (port target seed)
(loop orig-handlers #f () port target seed))
))))
(run-test
(pp (ssax:make-pi-parser ()))
(pp (ssax:make-pi-parser ((xml . (lambda (port target seed) seed)))))
(pp (ssax:make-pi-parser ((xml . (lambda (port target seed) seed))
(html . list)
(*DEFAULT* . ssax:warn))))
)
; syntax: ssax:make-elem-parser my-new-level-seed my-finish-element
; my-char-data-handler my-pi-handlers
; Create a parser to parse and process one element, including its
; character content or children elements. The parser is typically
; applied to the root element of a document.
; my-new-level-seed
; procedure ELEM-GI ATTRIBUTES NAMESPACES EXPECTED-CONTENT SEED
; where ELEM-GI is a RES-NAME of the element
; about to be processed.
; This procedure is to generate the seed to be passed
; to handlers that process the content of the element.
; This is the function identified as 'fdown' in the denotational
; semantics of the XML parser given in the title comments to this
; file.
;
; my-finish-element
; procedure ELEM-GI ATTRIBUTES NAMESPACES PARENT-SEED SEED
; This procedure is called when parsing of ELEM-GI is finished.
; The SEED is the result from the last content parser (or
; from my-new-level-seed if the element has the empty content).
; PARENT-SEED is the same seed as was passed to my-new-level-seed.
; The procedure is to generate a seed that will be the result
; of the element parser.
; This is the function identified as 'fup' in the denotational
; semantics of the XML parser given in the title comments to this
; file.
;
; my-char-data-handler
; A STR-HANDLER
;
; my-pi-handlers
; See ssax:make-pi-handler above
;
; The generated parser is a
; procedure START-TAG-HEAD PORT ELEMS ENTITIES
; NAMESPACES PRESERVE-WS? SEED
; The procedure must be called after the start tag token has been
; read. START-TAG-HEAD is an UNRES-NAME from the start-element tag.
; ELEMS is an instance of xml-decl::elems.
; See ssax:complete-start-tag::preserve-ws?
; Faults detected:
; VC: XML-Spec.html#elementvalid
; WFC: XML-Spec.html#GIMatch
(define-syntax ssax:make-elem-parser
(syntax-rules ()
((ssax:make-elem-parser my-new-level-seed my-finish-element
my-char-data-handler my-pi-handlers)
(lambda (start-tag-head port elems entities namespaces
preserve-ws? seed)
(define xml-space-gi (cons ssax:Prefix-XML
(string->symbol "space")))
(let handle-start-tag ((start-tag-head start-tag-head)
(port port) (entities entities)
(namespaces namespaces)
(preserve-ws? preserve-ws?) (parent-seed seed))
(let*-values
(((elem-gi attributes namespaces expected-content)
(ssax:complete-start-tag start-tag-head port elems
entities namespaces))
((seed)
(my-new-level-seed elem-gi attributes
namespaces expected-content parent-seed)))
(case expected-content
((EMPTY-TAG)
(my-finish-element
elem-gi attributes namespaces parent-seed seed))
((EMPTY) ; The end tag must immediately follow
(ssax:assert-token
(and (eqv? #\< (ssax:skip-S port)) (ssax:read-markup-token port))
'END start-tag-head
(lambda (token exp-kind exp-head)
(parser-error port "[elementvalid] broken for " token
" while expecting "
exp-kind exp-head)))
(my-finish-element
elem-gi attributes namespaces parent-seed seed))
(else ; reading the content...
(let ((preserve-ws? ; inherit or set the preserve-ws? flag
(cond
((assoc xml-space-gi attributes) =>
(lambda (name-value)
(equal? "preserve" (cdr name-value))))
(else preserve-ws?))))
(let loop ((port port) (entities entities)
(expect-eof? #f) (seed seed))
(let*-values
(((seed term-token)
(ssax:read-char-data port expect-eof?
my-char-data-handler seed)))
(if (eof-object? term-token)
seed
(case (xml-token-kind term-token)
((END)
(ssax:assert-token term-token 'END start-tag-head
(lambda (token exp-kind exp-head)
(parser-error port "[GIMatch] broken for "
term-token " while expecting "
exp-kind exp-head)))
(my-finish-element
elem-gi attributes namespaces parent-seed seed))
((PI)
(let ((seed
((ssax:make-pi-parser my-pi-handlers)
port (xml-token-head term-token) seed)))
(loop port entities expect-eof? seed)))
((ENTITY-REF)
(let ((seed
(ssax:handle-parsed-entity
port (xml-token-head term-token)
entities
(lambda (port entities seed)
(loop port entities #t seed))
my-char-data-handler
seed))) ; keep on reading the content after ent
(loop port entities expect-eof? seed)))
((START) ; Start of a child element
(if (eq? expected-content 'PCDATA)
(parser-error port "[elementvalid] broken for "
elem-gi
" with char content only; unexpected token "
term-token))
; Do other validation of the element content
(let ((seed
(handle-start-tag
(xml-token-head term-token)
port entities namespaces
preserve-ws? seed)))
(loop port entities expect-eof? seed)))
(else
(parser-error port "XML [43] broken for "
term-token))))))))
)))
))))
; syntax: ssax:make-parser user-handler-tag user-handler-proc ...
;
; Create an XML parser, an instance of the XML parsing framework.
; This will be a SAX, a DOM, or a specialized parser depending
; on the supplied user-handlers.
; user-handler-tag is a symbol that identifies a procedural expression
; that follows the tag. Given below are tags and signatures of the
; corresponding procedures. Not all tags have to be specified. If some
; are omitted, reasonable defaults will apply.
;
; tag: DOCTYPE
; handler-procedure: PORT DOCNAME SYSTEMID INTERNAL-SUBSET? SEED
; If internal-subset? is #t, the current position in the port
; is right after we have read #\[ that begins the internal DTD subset.
; We must finish reading of this subset before we return
; (or must call skip-internal-subset if we aren't interested in reading it).
; The port at exit must be at the first symbol after the whole
; DOCTYPE declaration.
; The handler-procedure must generate four values:
; ELEMS ENTITIES NAMESPACES SEED
; See xml-decl::elems for ELEMS. It may be #f to switch off the validation.
; NAMESPACES will typically contain USER-PREFIXes for selected URI-SYMBs.
; The default handler-procedure skips the internal subset,
; if any, and returns (values #f '() '() seed)
; tag: UNDECL-ROOT
; handler-procedure: ELEM-GI SEED
; where ELEM-GI is an UNRES-NAME of the root element. This procedure
; is called when an XML document under parsing contains _no_ DOCTYPE
; declaration.
; The handler-procedure, as a DOCTYPE handler procedure above,
; must generate four values:
; ELEMS ENTITIES NAMESPACES SEED
; The default handler-procedure returns (values #f '() '() seed)
; tag: DECL-ROOT
; handler-procedure: ELEM-GI SEED
; where ELEM-GI is an UNRES-NAME of the root element. This procedure
; is called when an XML document under parsing does contains the DOCTYPE
; declaration.
; The handler-procedure must generate a new SEED (and verify
; that the name of the root element matches the doctype, if the handler
; so wishes).
; The default handler-procedure is the identity function.
; tag: NEW-LEVEL-SEED
; handler-procedure: see ssax:make-elem-parser, my-new-level-seed
; tag: FINISH-ELEMENT
; handler-procedure: see ssax:make-elem-parser, my-finish-element
; tag: CHAR-DATA-HANDLER
; handler-procedure: see ssax:make-elem-parser, my-char-data-handler
; tag: PI
; handler-procedure: see ssax:make-pi-parser
; The default value is '()
; The generated parser is a
; procedure PORT SEED
; This procedure parses the document prolog and then exits to
; an element parser (created by ssax:make-elem-parser) to handle
; the rest.
;
; [1] document ::= prolog element Misc*
; [22] prolog ::= XMLDecl? Misc* (doctypedec | Misc*)?
; [27] Misc ::= Comment | PI | S
;
; [28] doctypedecl ::= ''
; [29] markupdecl ::= elementdecl | AttlistDecl
; | EntityDecl
; | NotationDecl | PI
; | Comment
;
; This is ssax:make-parser with all the (specialization) handlers given
; as positional arguments. It is called by ssax:make-parser, see below
(define-syntax ssax:make-parser/positional-args
(syntax-rules ()
((ssax:make-parser/positional-args
*handler-DOCTYPE
*handler-UNDECL-ROOT
*handler-DECL-ROOT
*handler-NEW-LEVEL-SEED
*handler-FINISH-ELEMENT
*handler-CHAR-DATA-HANDLER
*handler-PI)
(lambda (port seed)
; We must've just scanned the DOCTYPE token
; Handle the doctype declaration and exit to
; scan-for-significant-prolog-token-2, and eventually, to the
; element parser.
(define (handle-decl port token-head seed)
(or (eq? (string->symbol "DOCTYPE") token-head)
(parser-error port "XML [22], expected DOCTYPE declaration, found "
token-head))
(assert-curr-char ssax:S-chars "XML [28], space after DOCTYPE" port)
(ssax:skip-S port)
(let*-values
(((docname) (ssax:read-QName port))
((systemid)
(and (ssax:ncname-starting-char? (ssax:skip-S port))
(ssax:read-external-id port)))
((internal-subset?)
(begin (ssax:skip-S port)
(eqv? #\[ (assert-curr-char '(#\> #\[)
"XML [28], end-of-DOCTYPE" port))))
((elems entities namespaces seed)
(*handler-DOCTYPE port docname systemid
internal-subset? seed))
)
(scan-for-significant-prolog-token-2 port elems entities namespaces
seed)))
; Scan the leading PIs until we encounter either a doctype declaration
; or a start token (of the root element)
; In the latter two cases, we exit to the appropriate continuation
(define (scan-for-significant-prolog-token-1 port seed)
(let ((token (ssax:scan-Misc port)))
(if (eof-object? token)
(parser-error port "XML [22], unexpected EOF")
(case (xml-token-kind token)
((PI)
(let ((seed
((ssax:make-pi-parser *handler-PI)
port (xml-token-head token) seed)))
(scan-for-significant-prolog-token-1 port seed)))
((DECL) (handle-decl port (xml-token-head token) seed))
((START)
(let*-values
(((elems entities namespaces seed)
(*handler-UNDECL-ROOT (xml-token-head token) seed)))
(element-parser (xml-token-head token) port elems
entities namespaces #f seed)))
(else (parser-error port "XML [22], unexpected markup "
token))))))
; Scan PIs after the doctype declaration, till we encounter
; the start tag of the root element. After that we exit
; to the element parser
(define (scan-for-significant-prolog-token-2 port elems entities
namespaces seed)
(let ((token (ssax:scan-Misc port)))
(if (eof-object? token)
(parser-error port "XML [22], unexpected EOF")
(case (xml-token-kind token)
((PI)
(let ((seed
((ssax:make-pi-parser *handler-PI)
port (xml-token-head token) seed)))
(scan-for-significant-prolog-token-2 port elems entities
namespaces seed)))
((START)
(element-parser (xml-token-head token) port elems
entities namespaces #f
(*handler-DECL-ROOT (xml-token-head token) seed)))
(else (parser-error port "XML [22], unexpected markup "
token))))))
; A procedure start-tag-head port elems entities namespaces
; preserve-ws? seed
(define element-parser
(ssax:make-elem-parser *handler-NEW-LEVEL-SEED
*handler-FINISH-ELEMENT
*handler-CHAR-DATA-HANDLER
*handler-PI))
; Get the ball rolling ...
(scan-for-significant-prolog-token-1 port seed)
))))
; The following meta-macro turns a regular macro (with positional
; arguments) into a form with keyword (labeled) arguments. We later
; use the meta-macro to convert ssax:make-parser/positional-args into
; ssax:make-parser. The latter provides a prettier (with labeled
; arguments and defaults) interface to
; ssax:make-parser/positional-args
;
; ssax:define-labeled-arg-macro LABELED-ARG-MACRO-NAME
; (POS-MACRO-NAME ARG-DESCRIPTOR ...)
; expands into the definition of a macro
; LABELED-ARG-MACRO-NAME KW-NAME KW-VALUE KW-NAME1 KW-VALUE1 ...
; which, in turn, expands into
; POS-MACRO-NAME ARG1 ARG2 ...
; where each ARG1 etc. comes either from KW-VALUE or from
; the deafult part of ARG-DESCRIPTOR. ARG1 corresponds to the first
; ARG-DESCRIPTOR, ARG2 corresponds to the second descriptor, etc.
; Here ARG-DESCRIPTOR describes one argument of the positional macro.
; It has the form
; (ARG-NAME DEFAULT-VALUE)
; or
; (ARG-NAME)
; In the latter form, the default value is not given, so that the invocation of
; LABELED-ARG-MACRO-NAME must mention the corresponding parameter.
; ARG-NAME can be anything: an identifier, a string, or even a number.
(define-syntax ssax:define-labeled-arg-macro
(syntax-rules ()
((ssax:define-labeled-arg-macro
labeled-arg-macro-name
(positional-macro-name
(arg-name . arg-def) ...))
(define-syntax labeled-arg-macro-name
(syntax-rules ()
((labeled-arg-macro-name . kw-val-pairs)
(letrec-syntax
((find
(syntax-rules (arg-name ...)
((find k-args (arg-name . default) arg-name
val . others) ; found arg-name among kw-val-pairs
(next val . k-args)) ...
((find k-args key arg-no-match-name val . others)
(find k-args key . others))
((find k-args (arg-name default)) ; default must be here
(next default . k-args)) ...
))
(next ; pack the continuation to find
(syntax-rules ()
((next val vals key . keys)
(find ((val . vals) . keys) key . kw-val-pairs))
((next val vals) ; processed all arg-descriptors
(rev-apply (val) vals))))
(rev-apply
(syntax-rules ()
((rev-apply form (x . xs))
(rev-apply (x . form) xs))
((rev-apply form ()) form))))
(next positional-macro-name ()
(arg-name . arg-def) ...))))))))
; The definition of ssax:make-parser
(ssax:define-labeled-arg-macro ssax:make-parser
(ssax:make-parser/positional-args
(DOCTYPE
(lambda (port docname systemid internal-subset? seed)
(when internal-subset?
(ssax:warn port "Internal DTD subset is not currently handled ")
(ssax:skip-internal-dtd port))
(ssax:warn port "DOCTYPE DECL " docname " "
systemid " found and skipped")
(values #f '() '() seed)
))
(UNDECL-ROOT
(lambda (elem-gi seed) (values #f '() '() seed)))
(DECL-ROOT
(lambda (elem-gi seed) seed))
(NEW-LEVEL-SEED) ; required
(FINISH-ELEMENT) ; required
(CHAR-DATA-HANDLER) ; required
(PI ())
))
(run-test
(letrec ((simple-parser
(lambda (str doctype-fn)
(call-with-input-string str
(lambda (port)
((ssax:make-parser
NEW-LEVEL-SEED
(lambda (elem-gi attributes namespaces
expected-content seed)
'())
FINISH-ELEMENT
(lambda (elem-gi attributes namespaces parent-seed seed)
(let
((seed (if (null? namespaces) (reverse seed)
(cons (list '*NAMESPACES* namespaces)
(reverse seed)))))
(let ((seed (if (attlist-null? attributes) seed
(cons
(cons '@
(map (lambda (attr)
(list (car attr) (cdr attr)))
(attlist->alist attributes)))
seed))))
(cons (cons elem-gi seed) parent-seed))))
CHAR-DATA-HANDLER
(lambda (string1 string2 seed)
(if (string-null? string2) (cons string1 seed)
(cons* string2 string1 seed)))
DOCTYPE
(lambda (port docname systemid internal-subset? seed)
(when internal-subset?
(ssax:warn port
"Internal DTD subset is not currently handled ")
(ssax:skip-internal-dtd port))
(ssax:warn port "DOCTYPE DECL " docname " "
systemid " found and skipped")
(doctype-fn docname seed))
UNDECL-ROOT
(lambda (elem-gi seed)
(doctype-fn elem-gi seed))
)
port '())))))
(dummy-doctype-fn (lambda (elem-gi seed) (values #f '() '() seed)))
(test
(lambda (str doctype-fn expected)
(cout nl "Parsing: " str nl)
(let ((result (simple-parser (unesc-string str) doctype-fn)))
(write result)
(assert (equal? result expected)))))
)
(test " " dummy-doctype-fn '(('"BR")))
(assert (failed? (test " " dummy-doctype-fn '())))
(test " " dummy-doctype-fn '(('"BR")))
(assert (failed? (test " " dummy-doctype-fn '())))
(test " link itlink &"
dummy-doctype-fn
'(('"A" (@ ('"HREF" "URL")) " link " ('"I" "itlink ")
" " "&" "amp;")))
(test
" link itlink &" dummy-doctype-fn
'(('"A" (@ ('"HREF" "URL") (('"xml" . '"space") "preserve"))
" link " ('"I" "itlink ") " " "&" "amp;")))
(test " link itlink &" dummy-doctype-fn
'(('"A" (@ ('"HREF" "URL") (('"xml" . '"space") "preserve"))
" link "
('"I" (@ (('"xml" . '"space") "default")) "itlink ")
" " "&" "amp;")))
(test "This is item 1 %nItem 2%n " dummy-doctype-fn
`(('"itemize" ('"item" "This is item 1 ")
,(unesc-string "%n") ('"item" "Item 2") ,(unesc-string "%n "))))
(test "
An ampersand (&) may be escaped numerically (&) or with a general entity (&).
")) '() seed))
'(('"DIV" "Example: \""
('"P" "An ampersand (" "&" ") may be escaped numerically (" "&" "#38;) or with a general entity (" "&" "amp;).") "\"")))
(test "
" '((UA . "URI1"))
'(*TOP* (@ (*NAMESPACES* (UA "URI1")))
(UA:DIV (@ (UA:B "A") (B "B")) (UA:P (BR)))))
; A few tests from XML Namespaces Recommendation
(test (string-append
""
""
"Baby food" nl
"") '()
`(*TOP*
(x (lineItem
(@ (http://ecommerce.org/schema:taxClass "exempt"))
"Baby food") ,nl)))
(test (string-append
""
""
"Baby food"
"") '((EDI . "http://ecommerce.org/schema"))
'(*TOP*
(@ (*NAMESPACES* (EDI "http://ecommerce.org/schema")))
(x (lineItem
(@ (EDI:taxClass "exempt"))
"Baby food"))))
(test (string-append
""
"Cheaper by the Dozen"
"1568491379")
'()
'(*TOP* (urn:loc.gov:books:book
(urn:loc.gov:books:title "Cheaper by the Dozen")
(urn:ISBN:0-395-36341-6:number "1568491379"))))
(test (string-append
""
""
"Cheaper by the Dozen"
"1568491379"
""
""
"
"
"This is a funny book!"
"
"
""
"") '()
'(*TOP* (urn:loc.gov:books:book
(urn:loc.gov:books:title "Cheaper by the Dozen")
(urn:ISBN:0-395-36341-6:number "1568491379")
(urn:loc.gov:books:notes
(urn:w3-org-ns:HTML:p
"This is a " (urn:w3-org-ns:HTML:i "funny")
" book!")))))
(test (string-append
""
""
"
"
"
Name
Origin
Description
"
"
"
""
"
Huntsman
"
"
Bath, UK
"
"
"
"BitterFuggles"
"Wonderful hop, light alcohol, good summer beer"
"Fragile; excessive variance pub to pub"
""
"
"
"
"
"
"
"")
'((html . "http://www.w3.org/TR/REC-html40"))
'(*TOP*
(@ (*NAMESPACES* (html "http://www.w3.org/TR/REC-html40")))
(Beers (html:table
(html:th (html:td "Name")
(html:td "Origin")
(html:td "Description"))
(html:tr (html:td (brandName "Huntsman"))
(html:td (origin "Bath, UK"))
(html:td
(details
(class "Bitter")
(hop "Fuggles")
(pro "Wonderful hop, light alcohol, good summer beer")
(con "Fragile; excessive variance pub to pub"))))))))
(test (string-append
""
"Layman, A"
"33B"
"Check Status"
"1997-05-24T07:55:00+1")
'((HTML . "http://www.w3.org/TR/REC-html40"))
'(*TOP*
(@ (*NAMESPACES* (HTML "http://www.w3.org/TR/REC-html40")))
(RESERVATION
(NAME (@ (HTML:CLASS "largeSansSerif")) "Layman, A")
(SEAT (@ (HTML:CLASS "largeMonotype") (CLASS "Y")) "33B")
(HTML:A (@ (HREF "/cgi-bin/ResStatus")) "Check Status")
(DEPARTURE "1997-05-24T07:55:00+1"))))
; Part of RDF from the XML Infoset
(test (string-concatenate/shared '(
""
""
""
""
""
""
""
""
""
""
""
""
""
""
""
""
""
""
""
""
""
""))
'((RDF . "http://www.w3.org/1999/02/22-rdf-syntax-ns#")
(RDFS . "http://www.w3.org/2000/01/rdf-schema#")
(ISET . "http://www.w3.org/2001/02/infoset#"))
'(*TOP* (@ (*NAMESPACES*
(RDF "http://www.w3.org/1999/02/22-rdf-syntax-ns#")
(RDFS "http://www.w3.org/2000/01/rdf-schema#")
(ISET "http://www.w3.org/2001/02/infoset#")))
(*PI* xml "version='1.0' encoding='utf-8' standalone='yes'")
(RDF:RDF
(RDFS:Class (@ (ID "Boolean")))
(ISET:Boolean (@ (ID "Boolean.true")))
(ISET:Boolean (@ (ID "Boolean.false")))
(RDFS:Class (@ (ID "InfoItem")))
(RDFS:Class (@ (RDFS:subClassOf "#InfoItem") (ID "Document")))
(RDFS:Class (@ (RDFS:subClassOf "#InfoItem") (ID "Element")))
(RDFS:Class (@ (RDFS:subClassOf "#InfoItem") (ID "Attribute")))
(RDFS:Class
(@ (RDFS:subClassOf
"http://www.w3.org/1999/02/22-rdf-syntax-ns#Bag")
(ID "InfoItemSet")))
(RDFS:Class
(@ (RDFS:subClassOf "#InfoItemSet") (ID "AttributeSet")))
(RDFS:Property
(@ (ID "allDeclarationsProcessed"))
(RDFS:domain (@ (resource "#Document")))
(RDFS:range (@ (resource "#Boolean"))))
(RDFS:Property
(@ (ID "attributes"))
(RDFS:domain (@ (resource "#Element")))
(RDFS:range (@ (resource "#AttributeSet")))))))
; Part of RDF from RSS of the Daemon News Mall
(test (string-concatenate/shared (list-intersperse '(
""
""
"Daemon News Mall"
"http://mall.daemonnews.org/"
"Central source for all your BSD needs"
""
""
"Daemon News Jan/Feb Issue NOW Available! Subscribe $24.95"
"http://mall.daemonnews.org/?page=shop/flypage&product_id=880"
""
""
"The Design and Implementation of the 4.4BSD Operating System $54.95"
"http://mall.daemonnews.org/?page=shop/flypage&product_id=912&category_id=1761"
""
"")
(string #\newline)
))
'((RDF . "http://www.w3.org/1999/02/22-rdf-syntax-ns#")
(RSS . "http://my.netscape.com/rdf/simple/0.9/")
(ISET . "http://www.w3.org/2001/02/infoset#"))
`(*TOP* (@ (*NAMESPACES*
(RDF "http://www.w3.org/1999/02/22-rdf-syntax-ns#")
(RSS "http://my.netscape.com/rdf/simple/0.9/")
(ISET "http://www.w3.org/2001/02/infoset#")))
(*PI* xml "version='1.0'")
(RDF:RDF ,nl
(RSS:channel ,nl
(RSS:title "Daemon News Mall") ,nl
(RSS:link "http://mall.daemonnews.org/") ,nl
(RSS:description "Central source for all your BSD needs") ,nl) ,nl
(RSS:item ,nl
(RSS:title
"Daemon News Jan/Feb Issue NOW Available! Subscribe $24.95") ,nl
(RSS:link
"http://mall.daemonnews.org/?page=shop/flypage&product_id=880") ,nl) ,nl
(RSS:item ,nl
(RSS:title
"The Design and Implementation of the 4.4BSD Operating System $54.95") ,nl
(RSS:link
"http://mall.daemonnews.org/?page=shop/flypage&product_id=912&category_id=1761") ,nl) ,nl)))
(test (string-concatenate/shared
'(""
""
"111730Z 111818"
""
"31010KT P6SM FEW030"
""
""
"29016KT P6SM FEW040"
""
""
"29010KT P6SM SCT200"
"VRB05KT"
""
""))
'()
'(*TOP* (Forecasts
(@ (TStamp "958082142"))
(TAF (@ (TStamp "958066200")
(SName "KMRY, MONTEREY PENINSULA")
(LatLon "36.583, -121.850")
(BId "724915"))
(VALID (@ (TRange "958068000, 958154400")) "111730Z 111818")
(PERIOD (@ (TRange "958068000, 958078800"))
(PREVAILING "31010KT P6SM FEW030"))
(PERIOD (@ (Title "FM2100") (TRange "958078800, 958104000"))
(PREVAILING "29016KT P6SM FEW040"))
(PERIOD (@ (Title "FM0400") (TRange "958104000, 958154400"))
(PREVAILING "29010KT P6SM SCT200")
(VAR (@ (Title "BECMG 0708")
(TRange "958114800, 958118400"))
"VRB05KT"))))))
))
(run-test
(newline)
(display "All tests passed")
(newline)
)
guile-lib-0.2.2/src/sxml/upstream/assert.scm 0000644 0001750 0001750 00000002563 11573632155 015742 0000000 0000000 ;
; syntax: assert ?expr ?expr ... [report: ?r-exp ?r-exp ...]
;
; If (and ?expr ?expr ...) evaluates to anything but #f, the result
; is the value of that expression.
; If (and ?expr ?expr ...) evaluates to #f, an error is reported.
; The error message will show the failed expressions, as well
; as the values of selected variables (or expressions, in general).
; The user may explicitly specify the expressions whose
; values are to be printed upon assertion failure -- as ?r-exp that
; follow the identifier 'report:'
; Typically, ?r-exp is either a variable or a string constant.
; If the user specified no ?r-exp, the values of variables that are
; referenced in ?expr will be printed upon the assertion failure.
(define-syntax assert
(syntax-rules (report:)
((assert "doit" (expr ...) (r-exp ...))
(cond
((and expr ...) => (lambda (x) x))
(else
(error "assertion failure: ~a" (list '(and expr ...) r-exp ...)))))
((assert "collect" (expr ...))
(assert "doit" (expr ...) ()))
((assert "collect" (expr ...) report: r-exp ...)
(assert "doit" (expr ...) (r-exp ...)))
((assert "collect" (expr ...) expr1 stuff ...)
(assert "collect" (expr ... expr1) stuff ...))
((assert stuff ...)
(assert "collect" () stuff ...))))
(define-syntax assure
(syntax-rules ()
((assure exp error-msg)
(assert exp report: error-msg)))) guile-lib-0.2.2/src/sxml/upstream/SXPath-old.scm 0000644 0001750 0001750 00000121450 11573632156 016362 0000000 0000000 ; XML processing in Scheme
; SXPath -- SXML Query Language
;
; SXPath is a query language for SXML, an instance of XML Information
; set (Infoset) in the form of s-expressions. See SSAX.scm for the
; definition of SXML and more details. SXPath is also a translation into
; Scheme of an XML Path Language, XPath:
; http://www.w3.org/TR/xpath
; XPath and SXPath describe means of selecting a set of Infoset's items
; or their properties.
;
; To facilitate queries, XPath maps the XML Infoset into an explicit
; tree, and introduces important notions of a location path and a
; current, context node. A location path denotes a selection of a set of
; nodes relative to a context node. Any XPath tree has a distinguished,
; root node -- which serves as the context node for absolute location
; paths. Location path is recursively defined as a location step joined
; with a location path. A location step is a simple query of the
; database relative to a context node. A step may include expressions
; that further filter the selected set. Each node in the resulting set
; is used as a context node for the adjoining location path. The result
; of the step is a union of the sets returned by the latter location
; paths.
;
; The SXML representation of the XML Infoset (see SSAX.scm) is rather
; suitable for querying as it is. Bowing to the XPath specification,
; we will refer to SXML information items as 'Nodes':
; ::= | |
; | "text string" |
; This production can also be described as
; ::= (name . ) | "text string"
; An (ordered) set of nodes is just a list of the constituent nodes:
; ::= ( ...)
; Nodesets, and Nodes other than text strings are both lists. A
; however is either an empty list, or a list whose head is not
; a symbol. A symbol at the head of a node is either an XML name (in
; which case it's a tag of an XML element), or an administrative name
; such as '@'. This uniform list representation makes processing rather
; simple and elegant, while avoiding confusion. The multi-branch tree
; structure formed by the mutually-recursive datatypes and
; lends itself well to processing by functional languages.
;
; A location path is in fact a composite query over an XPath tree or
; its branch. A singe step is a combination of a projection, selection
; or a transitive closure. Multiple steps are combined via join and
; union operations. This insight allows us to _elegantly_ implement
; XPath as a sequence of projection and filtering primitives --
; converters -- joined by _combinators_. Each converter takes a node
; and returns a nodeset which is the result of the corresponding query
; relative to that node. A converter can also be called on a set of
; nodes. In that case it returns a union of the corresponding queries over
; each node in the set. The union is easily implemented as a list
; append operation as all nodes in a SXML tree are considered
; distinct, by XPath conventions. We also preserve the order of the
; members in the union. Query combinators are high-order functions:
; they take converter(s) (which is a Node|Nodeset -> Nodeset function)
; and compose or otherwise combine them. We will be concerned with
; only relative location paths [XPath]: an absolute location path is a
; relative path applied to the root node.
;
; Similarly to XPath, SXPath defines full and abbreviated notations
; for location paths. In both cases, the abbreviated notation can be
; mechanically expanded into the full form by simple rewriting
; rules. In case of SXPath the corresponding rules are given as
; comments to a sxpath function, below. The regression test suite at
; the end of this file shows a representative sample of SXPaths in
; both notations, juxtaposed with the corresponding XPath
; expressions. Most of the samples are borrowed literally from the
; XPath specification, while the others are adjusted for our running
; example, tree1.
;
; To do:
; Rename filter to node-filter or ns-filter
; Use ;=== for chapters, ;--- for sections, and ;^^^ for end sections
;
; $Id: SXPath-old.scm,v 1.4 2004/07/07 16:02:31 sperber Exp $
; See http://pobox.com/~oleg/ftp/Scheme/myenv.scm
; See http://pobox.com/~oleg/ftp/Scheme/myenv-scm.scm
; See http://pobox.com/~oleg/ftp/Scheme/myenv-bigloo.scm
;(module SXPath
; (include "myenv-bigloo.scm")) ; For use with Bigloo 2.2b
;(load "myenv-scm.scm") ; For use with SCM v5d2
;(include "myenv.scm") ; For use with Gambit-C 3.0
(define (nodeset? x)
(or (and (pair? x) (not (symbol? (car x)))) (null? x)))
;-------------------------
; Basic converters and applicators
; A converter is a function
; type Converter = Node|Nodeset -> Nodeset
; A converter can also play a role of a predicate: in that case, if a
; converter, applied to a node or a nodeset, yields a non-empty
; nodeset, the converter-predicate is deemed satisfied. Throughout
; this file a nil nodeset is equivalent to #f in denoting a failure.
; The following function implements a 'Node test' as defined in
; Sec. 2.3 of XPath document. A node test is one of the components of a
; location step. It is also a converter-predicate in SXPath.
;
; The function node-typeof? takes a type criterion and returns a function,
; which, when applied to a node, will tell if the node satisfies
; the test.
; node-typeof? :: Crit -> Node -> Boolean
;
; The criterion 'crit' is a symbol, one of the following:
; id - tests if the Node has the right name (id)
; @ - tests if the Node is an
; * - tests if the Node is an
; *text* - tests if the Node is a text node
; *PI* - tests if the Node is a PI node
; *any* - #t for any type of Node
(define (node-typeof? crit)
(lambda (node)
(case crit
((*) (and (pair? node) (not (memq (car node) '(@ *PI*)))))
((*any*) #t)
((*text*) (string? node))
(else
(and (pair? node) (eq? crit (car node))))
)))
; Curried equivalence converter-predicates
(define (node-eq? other)
(lambda (node)
(eq? other node)))
(define (node-equal? other)
(lambda (node)
(equal? other node)))
; node-pos:: N -> Nodeset -> Nodeset, or
; node-pos:: N -> Converter
; Select the N'th element of a Nodeset and return as a singular Nodeset;
; Return an empty nodeset if the Nth element does not exist.
; ((node-pos 1) Nodeset) selects the node at the head of the Nodeset,
; if exists; ((node-pos 2) Nodeset) selects the Node after that, if
; exists.
; N can also be a negative number: in that case the node is picked from
; the tail of the list.
; ((node-pos -1) Nodeset) selects the last node of a non-empty nodeset;
; ((node-pos -2) Nodeset) selects the last but one node, if exists.
(define (node-pos n)
(lambda (nodeset)
(cond
((not (nodeset? nodeset)) '())
((null? nodeset) nodeset)
((eqv? n 1) (list (car nodeset)))
((negative? n) ((node-pos (+ n 1 (length nodeset))) nodeset))
(else
(assert (positive? n))
((node-pos (dec n)) (cdr nodeset))))))
; filter:: Converter -> Converter
; A filter applicator, which introduces a filtering context. The argument
; converter is considered a predicate, with either #f or nil result meaning
; failure.
(define (filter pred?)
(lambda (lst) ; a nodeset or a node (will be converted to a singleton nset)
(let loop ((lst (if (nodeset? lst) lst (list lst))) (res '()))
(if (null? lst)
(reverse res)
(let ((pred-result (pred? (car lst))))
(loop (cdr lst)
(if (and pred-result (not (null? pred-result)))
(cons (car lst) res)
res)))))))
; take-until:: Converter -> Converter, or
; take-until:: Pred -> Node|Nodeset -> Nodeset
; Given a converter-predicate and a nodeset, apply the predicate to
; each element of the nodeset, until the predicate yields anything but #f or
; nil. Return the elements of the input nodeset that have been processed
; till that moment (that is, which fail the predicate).
; take-until is a variation of the filter above: take-until passes
; elements of an ordered input set till (but not including) the first
; element that satisfies the predicate.
; The nodeset returned by ((take-until (not pred)) nset) is a subset --
; to be more precise, a prefix -- of the nodeset returned by
; ((filter pred) nset)
(define (take-until pred?)
(lambda (lst) ; a nodeset or a node (will be converted to a singleton nset)
(let loop ((lst (if (nodeset? lst) lst (list lst))))
(if (null? lst) lst
(let ((pred-result (pred? (car lst))))
(if (and pred-result (not (null? pred-result)))
'()
(cons (car lst) (loop (cdr lst)))))
))))
; take-after:: Converter -> Converter, or
; take-after:: Pred -> Node|Nodeset -> Nodeset
; Given a converter-predicate and a nodeset, apply the predicate to
; each element of the nodeset, until the predicate yields anything but #f or
; nil. Return the elements of the input nodeset that have not been processed:
; that is, return the elements of the input nodeset that follow the first
; element that satisfied the predicate.
; take-after along with take-until partition an input nodeset into three
; parts: the first element that satisfies a predicate, all preceding
; elements and all following elements.
(define (take-after pred?)
(lambda (lst) ; a nodeset or a node (will be converted to a singleton nset)
(let loop ((lst (if (nodeset? lst) lst (list lst))))
(if (null? lst) lst
(let ((pred-result (pred? (car lst))))
(if (and pred-result (not (null? pred-result)))
(cdr lst)
(loop (cdr lst))))
))))
; Apply proc to each element of lst and return the list of results.
; if proc returns a nodeset, splice it into the result
;
; From another point of view, map-union is a function Converter->Converter,
; which places an argument-converter in a joining context.
(define (map-union proc lst)
(if (null? lst) lst
(let ((proc-res (proc (car lst))))
((if (nodeset? proc-res) append cons)
proc-res (map-union proc (cdr lst))))))
; node-reverse :: Converter, or
; node-reverse:: Node|Nodeset -> Nodeset
; Reverses the order of nodes in the nodeset
; This basic converter is needed to implement a reverse document order
; (see the XPath Recommendation).
(define node-reverse
(lambda (node-or-nodeset)
(if (not (nodeset? node-or-nodeset)) (list node-or-nodeset)
(reverse node-or-nodeset))))
; node-trace:: String -> Converter
; (node-trace title) is an identity converter. In addition it prints out
; a node or nodeset it is applied to, prefixed with the 'title'.
; This converter is very useful for debugging.
(define (node-trace title)
(lambda (node-or-nodeset)
(cout nl "-->")
(display title)
(display " :")
(pretty-print node-or-nodeset)
node-or-nodeset))
;-------------------------
; Converter combinators
;
; Combinators are higher-order functions that transmogrify a converter
; or glue a sequence of converters into a single, non-trivial
; converter. The goal is to arrive at converters that correspond to
; XPath location paths.
;
; From a different point of view, a combinator is a fixed, named
; _pattern_ of applying converters. Given below is a complete set of
; such patterns that together implement XPath location path
; specification. As it turns out, all these combinators can be built
; from a small number of basic blocks: regular functional composition,
; map-union and filter applicators, and the nodeset union.
; select-kids:: Pred -> Node -> Nodeset
; Given a Node, return an (ordered) subset its children that satisfy
; the Pred (a converter, actually)
; select-kids:: Pred -> Nodeset -> Nodeset
; The same as above, but select among children of all the nodes in
; the Nodeset
;
; More succinctly, the signature of this function is
; select-kids:: Converter -> Converter
(define (select-kids test-pred?)
(lambda (node) ; node or node-set
(cond
((null? node) node)
((not (pair? node)) '()) ; No children
((symbol? (car node))
((filter test-pred?) (cdr node))) ; it's a single node
(else (map-union (select-kids test-pred?) node)))))
; node-self:: Pred -> Node -> Nodeset, or
; node-self:: Converter -> Converter
; Similar to select-kids but apply to the Node itself rather
; than to its children. The resulting Nodeset will contain either one
; component, or will be empty (if the Node failed the Pred).
(define node-self filter)
; node-join:: [LocPath] -> Node|Nodeset -> Nodeset, or
; node-join:: [Converter] -> Converter
; join the sequence of location steps or paths as described
; in the title comments above.
(define (node-join . selectors)
(lambda (nodeset) ; Nodeset or node
(let loop ((nodeset nodeset) (selectors selectors))
(if (null? selectors) nodeset
(loop
(if (nodeset? nodeset)
(map-union (car selectors) nodeset)
((car selectors) nodeset))
(cdr selectors))))))
; node-reduce:: [LocPath] -> Node|Nodeset -> Nodeset, or
; node-reduce:: [Converter] -> Converter
; A regular functional composition of converters.
; From a different point of view,
; ((apply node-reduce converters) nodeset)
; is equivalent to
; (foldl apply nodeset converters)
; i.e., folding, or reducing, a list of converters with the nodeset
; as a seed.
(define (node-reduce . converters)
(lambda (nodeset) ; Nodeset or node
(let loop ((nodeset nodeset) (converters converters))
(if (null? converters) nodeset
(loop ((car converters) nodeset) (cdr converters))))))
; node-or:: [Converter] -> Converter
; This combinator applies all converters to a given node and
; produces the union of their results.
; This combinator corresponds to a union, '|' operation for XPath
; location paths.
; (define (node-or . converters)
; (lambda (node-or-nodeset)
; (if (null? converters) node-or-nodeset
; (append
; ((car converters) node-or-nodeset)
; ((apply node-or (cdr converters)) node-or-nodeset)))))
; More optimal implementation follows
(define (node-or . converters)
(lambda (node-or-nodeset)
(let loop ((result '()) (converters converters))
(if (null? converters) result
(loop (append result (or ((car converters) node-or-nodeset) '()))
(cdr converters))))))
; node-closure:: Converter -> Converter
; Select all _descendants_ of a node that satisfy a converter-predicate.
; This combinator is similar to select-kids but applies to
; grand... children as well.
; This combinator implements the "descendant::" XPath axis
; Conceptually, this combinator can be expressed as
; (define (node-closure f)
; (node-or
; (select-kids f)
; (node-reduce (select-kids (node-typeof? '*)) (node-closure f))))
; This definition, as written, looks somewhat like a fixpoint, and it
; will run forever. It is obvious however that sooner or later
; (select-kids (node-typeof? '*)) will return an empty nodeset. At
; this point further iterations will no longer affect the result and
; can be stopped.
(define (node-closure test-pred?)
(lambda (node) ; Nodeset or node
(let loop ((parent node) (result '()))
(if (null? parent) result
(loop ((select-kids (node-typeof? '*)) parent)
(append result
((select-kids test-pred?) parent)))
))))
; node-parent:: RootNode -> Converter
; (node-parent rootnode) yields a converter that returns a parent of a
; node it is applied to. If applied to a nodeset, it returns the list
; of parents of nodes in the nodeset. The rootnode does not have
; to be the root node of the whole SXML tree -- it may be a root node
; of a branch of interest.
; Given the notation of Philip Wadler's paper on semantics of XSLT,
; parent(x) = { y | y=subnode*(root), x=subnode(y) }
; Therefore, node-parent is not the fundamental converter: it can be
; expressed through the existing ones. Yet node-parent is a rather
; convenient converter. It corresponds to a parent:: axis of SXPath.
; Note that the parent:: axis can be used with an attribute node as well!
(define (node-parent rootnode)
(lambda (node) ; Nodeset or node
(if (nodeset? node) (map-union (node-parent rootnode) node)
(let ((pred
(node-or
(node-reduce
(node-self (node-typeof? '*))
(select-kids (node-eq? node)))
(node-join
(select-kids (node-typeof? '@))
(select-kids (node-eq? node))))))
((node-or
(node-self pred)
(node-closure pred))
rootnode)))))
;-------------------------
; Evaluate an abbreviated SXPath
; sxpath:: AbbrPath -> Converter, or
; sxpath:: AbbrPath -> Node|Nodeset -> Nodeset
; AbbrPath is a list. It is translated to the full SXPath according
; to the following rewriting rules
; (sxpath '()) -> (node-join)
; (sxpath '(path-component ...)) ->
; (node-join (sxpath1 path-component) (sxpath '(...)))
; (sxpath1 '//) -> (node-or
; (node-self (node-typeof? '*any*))
; (node-closure (node-typeof? '*any*)))
; (sxpath1 '(equal? x)) -> (select-kids (node-equal? x))
; (sxpath1 '(eq? x)) -> (select-kids (node-eq? x))
; (sxpath1 ?symbol) -> (select-kids (node-typeof? ?symbol)
; (sxpath1 procedure) -> procedure
; (sxpath1 '(?symbol ...)) -> (sxpath1 '((?symbol) ...))
; (sxpath1 '(path reducer ...)) ->
; (node-reduce (sxpath path) (sxpathr reducer) ...)
; (sxpathr number) -> (node-pos number)
; (sxpathr path-filter) -> (filter (sxpath path-filter))
(define (sxpath path)
(lambda (nodeset)
(let loop ((nodeset nodeset) (path path))
(cond
((null? path) nodeset)
((nodeset? nodeset)
(map-union (sxpath path) nodeset))
((procedure? (car path))
(loop ((car path) nodeset) (cdr path)))
((eq? '// (car path))
(loop
((if (nodeset? nodeset) append cons) nodeset
((node-closure (node-typeof? '*any*)) nodeset))
(cdr path)))
((symbol? (car path))
(loop ((select-kids (node-typeof? (car path))) nodeset)
(cdr path)))
((and (pair? (car path)) (eq? 'equal? (caar path)))
(loop ((select-kids (apply node-equal? (cdar path))) nodeset)
(cdr path)))
((and (pair? (car path)) (eq? 'eq? (caar path)))
(loop ((select-kids (apply node-eq? (cdar path))) nodeset)
(cdr path)))
((pair? (car path))
(let reducer ((nodeset
(if (symbol? (caar path))
((select-kids (node-typeof? (caar path))) nodeset)
(loop nodeset (caar path))))
(reducing-path (cdar path)))
(cond
((null? reducing-path) (loop nodeset (cdr path)))
((number? (car reducing-path))
(reducer ((node-pos (car reducing-path)) nodeset)
(cdr reducing-path)))
(else
(reducer ((filter (sxpath (car reducing-path))) nodeset)
(cdr reducing-path))))))
(else
(error "Invalid path step: " (car path)))
))))
;------------------------------------------------------------------------
; Sample XPath/SXPath expressions: regression test suite for the
; implementation above.
; A running example
(define tree1
'(html
(head (title "Slides"))
(body
(p (@ (align "center"))
(table (@ (style "font-size: x-large"))
(tr
(td (@ (align "right")) "Talks ")
(td (@ (align "center")) " = ")
(td " slides + transition"))
(tr (td)
(td (@ (align "center")) " = ")
(td " data + control"))
(tr (td)
(td (@ (align "center")) " = ")
(td " programs"))))
(ul
(li (a (@ (href "slides/slide0001.gif")) "Introduction"))
(li (a (@ (href "slides/slide0010.gif")) "Summary")))
)))
; Example from a posting "Re: DrScheme and XML",
; Shriram Krishnamurthi, comp.lang.scheme, Nov. 26. 1999.
; http://www.deja.com/getdoc.xp?AN=553507805
(define tree3
'(poem (@ (title "The Lovesong of J. Alfred Prufrock")
(poet "T. S. Eliot"))
(stanza
(line "Let us go then, you and I,")
(line "When the evening is spread out against the sky")
(line "Like a patient etherized upon a table:"))
(stanza
(line "In the room the women come and go")
(line "Talking of Michaelangelo."))))
; Validation Test harness
(define-syntax run-test
(syntax-rules (define)
((run-test "scan-exp" (define vars body))
(define vars (run-test "scan-exp" body)))
((run-test "scan-exp" ?body)
(letrec-syntax
((scan-exp ; (scan-exp body k)
(syntax-rules (quote quasiquote !)
((scan-exp '() (k-head ! . args))
(k-head '() . args))
((scan-exp (quote (hd . tl)) k)
(scan-lit-lst (hd . tl) (do-wrap ! quasiquote k)))
((scan-exp (quasiquote (hd . tl)) k)
(scan-lit-lst (hd . tl) (do-wrap ! quasiquote k)))
((scan-exp (quote x) (k-head ! . args))
(k-head
(if (string? (quote x)) (string->symbol (quote x)) (quote x))
. args))
((scan-exp (hd . tl) k)
(scan-exp hd (do-tl ! scan-exp tl k)))
((scan-exp x (k-head ! . args))
(k-head x . args))))
(do-tl
(syntax-rules (!)
((do-tl processed-hd fn () (k-head ! . args))
(k-head (processed-hd) . args))
((do-tl processed-hd fn old-tl k)
(fn old-tl (do-cons ! processed-hd k)))))
(do-cons
(syntax-rules (!)
((do-cons processed-tl processed-hd (k-head ! . args))
(k-head (processed-hd . processed-tl) . args))))
(do-wrap
(syntax-rules (!)
((do-wrap val fn (k-head ! . args))
(k-head (fn val) . args))))
(do-finish
(syntax-rules ()
((do-finish new-body) new-body)))
(scan-lit-lst ; scan literal list
(syntax-rules (quote unquote unquote-splicing !)
((scan-lit-lst '() (k-head ! . args))
(k-head '() . args))
((scan-lit-lst (quote (hd . tl)) k)
(do-tl quote scan-lit-lst ((hd . tl)) k))
((scan-lit-lst (unquote x) k)
(scan-exp x (do-wrap ! unquote k)))
((scan-lit-lst (unquote-splicing x) k)
(scan-exp x (do-wrap ! unquote-splicing k)))
((scan-lit-lst (quote x) (k-head ! . args))
(k-head
,(if (string? (quote x)) (string->symbol (quote x)) (quote x))
. args))
((scan-lit-lst (hd . tl) k)
(scan-lit-lst hd (do-tl ! scan-lit-lst tl k)))
((scan-lit-lst x (k-head ! . args))
(k-head x . args))))
)
(scan-exp ?body (do-finish !))))
((run-test body ...)
(begin
(run-test "scan-exp" body) ...))
))
; Overwrite the above macro to switch the tests off
; (define-macro (run-test selector node expected-result) #f)
; Location path, full form: child::para
; Location path, abbreviated form: para
; selects the para element children of the context node
(let ((tree
'(elem (@) (para (@) "para") (br (@)) "cdata" (para (@) "second par"))
)
(expected '((para (@) "para") (para (@) "second par")))
)
(run-test (select-kids (node-typeof? 'para)) tree expected)
(run-test (sxpath '(para)) tree expected)
)
; Location path, full form: child::*
; Location path, abbreviated form: *
; selects all element children of the context node
(let ((tree
'(elem (@) (para (@) "para") (br (@)) "cdata" (para "second par"))
)
(expected
'((para (@) "para") (br (@)) (para "second par")))
)
(run-test (select-kids (node-typeof? '*)) tree expected)
(run-test (sxpath '(*)) tree expected)
)
; Location path, full form: child::text()
; Location path, abbreviated form: text()
; selects all text node children of the context node
(let ((tree
'(elem (@) (para (@) "para") (br (@)) "cdata" (para "second par"))
)
(expected
'("cdata"))
)
(run-test (select-kids (node-typeof? '*text*)) tree expected)
(run-test (sxpath '(*text*)) tree expected)
)
; Location path, full form: child::node()
; Location path, abbreviated form: node()
; selects all the children of the context node, whatever their node type
(let* ((tree
'(elem (@) (para (@) "para") (br (@)) "cdata" (para "second par"))
)
(expected (cdr tree))
)
(run-test (select-kids (node-typeof? '*any*)) tree expected)
(run-test (sxpath '(*any*)) tree expected)
)
; Location path, full form: child::*/child::para
; Location path, abbreviated form: */para
; selects all para grandchildren of the context node
(let ((tree
'(elem (@) (para (@) "para") (br (@)) "cdata" (para "second par")
(div (@ (name "aa")) (para "third para")))
)
(expected
'((para "third para")))
)
(run-test
(node-join (select-kids (node-typeof? '*))
(select-kids (node-typeof? 'para)))
tree expected)
(run-test (sxpath '(* para)) tree expected)
)
; Location path, full form: attribute::name
; Location path, abbreviated form: @name
; selects the 'name' attribute of the context node
(let ((tree
'(elem (@ (name "elem") (id "idz"))
(para (@) "para") (br (@)) "cdata" (para (@) "second par")
(div (@ (name "aa")) (para (@) "third para")))
)
(expected
'((name "elem")))
)
(run-test
(node-join (select-kids (node-typeof? '@))
(select-kids (node-typeof? 'name)))
tree expected)
(run-test (sxpath '(@ name)) tree expected)
)
; Location path, full form: attribute::*
; Location path, abbreviated form: @*
; selects all the attributes of the context node
(let ((tree
'(elem (@ (name "elem") (id "idz"))
(para (@) "para") (br (@)) "cdata" (para "second par")
(div (@ (name "aa")) (para (@) "third para")))
)
(expected
'((name "elem") (id "idz")))
)
(run-test
(node-join (select-kids (node-typeof? '@))
(select-kids (node-typeof? '*)))
tree expected)
(run-test (sxpath '(@ *)) tree expected)
)
; Location path, full form: descendant::para
; Location path, abbreviated form: .//para
; selects the para element descendants of the context node
(let ((tree
'(elem (@ (name "elem") (id "idz"))
(para (@) "para") (br (@)) "cdata" (para "second par")
(div (@ (name "aa")) (para (@) "third para")))
)
(expected
'((para (@) "para") (para "second par") (para (@) "third para")))
)
(run-test
(node-closure (node-typeof? 'para))
tree expected)
(run-test (sxpath '(// para)) tree expected)
)
; Location path, full form: self::para
; Location path, abbreviated form: _none_
; selects the context node if it is a para element; otherwise selects nothing
(let ((tree
'(elem (@ (name "elem") (id "idz"))
(para (@) "para") (br (@)) "cdata" (para "second par")
(div (@ (name "aa")) (para (@) "third para")))
)
)
(run-test (node-self (node-typeof? 'para)) tree '())
(run-test (node-self (node-typeof? 'elem)) tree (list tree))
)
; Location path, full form: descendant-or-self::node()
; Location path, abbreviated form: //
; selects the context node, all the children (including attribute nodes)
; of the context node, and all the children of all the (element)
; descendants of the context node.
; This is _almost_ a powerset of the context node.
(let* ((tree
'(para (@ (name "elem") (id "idz"))
(para (@) "para") (br (@)) "cdata" (para "second par")
(div (@ (name "aa")) (para (@) "third para")))
)
(expected
(cons tree
(append (cdr tree)
'((@) "para" (@) "second par"
(@ (name "aa")) (para (@) "third para")
(@) "third para"))))
)
(run-test
(node-or
(node-self (node-typeof? '*any*))
(node-closure (node-typeof? '*any*)))
tree expected)
(run-test (sxpath '(//)) tree expected)
)
; Location path, full form: ancestor::div
; Location path, abbreviated form: _none_
; selects all div ancestors of the context node
; This Location expression is equivalent to the following:
; /descendant-or-self::div[descendant::node() = curr_node]
; This shows that the ancestor:: axis is actually redundant. Still,
; it can be emulated as the following SXPath expression demonstrates.
; The insight behind "ancestor::div" -- selecting all "div" ancestors
; of the current node -- is
; S[ancestor::div] context_node =
; { y | y=subnode*(root), context_node=subnode(subnode*(y)),
; isElement(y), name(y) = "div" }
; We observe that
; { y | y=subnode*(root), pred(y) }
; can be expressed in SXPath as
; ((node-or (node-self pred) (node-closure pred)) root-node)
; The composite predicate 'isElement(y) & name(y) = "div"' corresponds to
; (node-self (node-typeof? 'div)) in SXPath. Finally, filter
; context_node=subnode(subnode*(y)) is tantamount to
; (node-closure (node-eq? context-node)), whereas node-reduce denotes the
; the composition of converters-predicates in the filtering context.
(let*
((root
'(div (@ (name "elem") (id "idz"))
(para (@) "para") (br (@)) "cdata" (para (@) "second par")
(div (@ (name "aa")) (para (@) "third para"))))
(context-node ; /descendant::any()[child::text() == "third para"]
(car
((node-closure
(select-kids
(node-equal? "third para")))
root)))
(pred
(node-reduce (node-self (node-typeof? 'div))
(node-closure (node-eq? context-node))
))
)
(run-test
(node-or
(node-self pred)
(node-closure pred))
root
(cons root
'((div (@ (name "aa")) (para (@) "third para")))))
)
; Location path, full form: child::div/descendant::para
; Location path, abbreviated form: div//para
; selects the para element descendants of the div element
; children of the context node
(let ((tree
'(elem (@ (name "elem") (id "idz"))
(para (@) "para") (br (@)) "cdata" (para "second par")
(div (@ (name "aa")) (para (@) "third para")
(div (para "fourth para"))))
)
(expected
'((para (@) "third para") (para "fourth para")))
)
(run-test
(node-join
(select-kids (node-typeof? 'div))
(node-closure (node-typeof? 'para)))
tree expected)
(run-test (sxpath '(div // para)) tree expected)
)
; Location path, full form: /descendant::olist/child::item
; Location path, abbreviated form: //olist/item
; selects all the item elements that have an olist parent (which is not root)
; and that are in the same document as the context node
; See the following test.
; Location path, full form: /descendant::td/attribute::align
; Location path, abbreviated form: //td/@align
; Selects 'align' attributes of all 'td' elements in tree1
(let ((tree tree1)
(expected
'((align "right") (align "center") (align "center") (align "center"))
))
(run-test
(node-join
(node-closure (node-typeof? 'td))
(select-kids (node-typeof? '@))
(select-kids (node-typeof? 'align)))
tree expected)
(run-test (sxpath '(// td @ align)) tree expected)
)
; Location path, full form: /descendant::td[attribute::align]
; Location path, abbreviated form: //td[@align]
; Selects all td elements that have an attribute 'align' in tree1
(let ((tree tree1)
(expected
'((td (@ (align "right")) "Talks ") (td (@ (align "center")) " = ")
(td (@ (align "center")) " = ") (td (@ (align "center")) " = "))
))
(run-test
(node-reduce
(node-closure (node-typeof? 'td))
(filter
(node-join
(select-kids (node-typeof? '@))
(select-kids (node-typeof? 'align)))))
tree expected)
(run-test (sxpath `(// td ,(node-self (sxpath '(@ align))))) tree expected)
(run-test (sxpath '(// (td (@ align)))) tree expected)
(run-test (sxpath '(// ((td) (@ align)))) tree expected)
; note! (sxpath ...) is a converter. Therefore, it can be used
; as any other converter, for example, in the full-form SXPath.
; Thus we can mix the full and abbreviated form SXPath's freely.
(run-test
(node-reduce
(node-closure (node-typeof? 'td))
(filter
(sxpath '(@ align))))
tree expected)
)
; Location path, full form: /descendant::td[attribute::align = "right"]
; Location path, abbreviated form: //td[@align = "right"]
; Selects all td elements that have an attribute align = "right" in tree1
(let ((tree tree1)
(expected
'((td (@ (align "right")) "Talks "))
))
(run-test
(node-reduce
(node-closure (node-typeof? 'td))
(filter
(node-join
(select-kids (node-typeof? '@))
(select-kids (node-equal? '(align "right"))))))
tree expected)
(run-test (sxpath '(// (td (@ (equal? (align "right")))))) tree expected)
)
; Location path, full form: child::para[position()=1]
; Location path, abbreviated form: para[1]
; selects the first para child of the context node
(let ((tree
'(elem (@ (name "elem") (id "idz"))
(para (@) "para") (br (@)) "cdata" (para "second par")
(div (@ (name "aa")) (para (@) "third para")))
)
(expected
'((para (@) "para"))
))
(run-test
(node-reduce
(select-kids (node-typeof? 'para))
(node-pos 1))
tree expected)
(run-test (sxpath '((para 1))) tree expected)
)
; Location path, full form: child::para[position()=last()]
; Location path, abbreviated form: para[last()]
; selects the last para child of the context node
(let ((tree
'(elem (@ (name "elem") (id "idz"))
(para (@) "para") (br (@)) "cdata" (para "second par")
(div (@ (name "aa")) (para (@) "third para")))
)
(expected
'((para "second par"))
))
(run-test
(node-reduce
(select-kids (node-typeof? 'para))
(node-pos -1))
tree expected)
(run-test (sxpath '((para -1))) tree expected)
)
; Illustrating the following Note of Sec 2.5 of XPath:
; "NOTE: The location path //para[1] does not mean the same as the
; location path /descendant::para[1]. The latter selects the first
; descendant para element; the former selects all descendant para
; elements that are the first para children of their parents."
(let ((tree
'(elem (@ (name "elem") (id "idz"))
(para (@) "para") (br (@)) "cdata" (para "second par")
(div (@ (name "aa")) (para (@) "third para")))
)
)
(run-test
(node-reduce ; /descendant::para[1] in SXPath
(node-closure (node-typeof? 'para))
(node-pos 1))
tree '((para (@) "para")))
(run-test (sxpath '(// (para 1))) tree
'((para (@) "para") (para (@) "third para")))
)
; Location path, full form: parent::node()
; Location path, abbreviated form: ..
; selects the parent of the context node. The context node may be
; an attribute node!
; For the last test:
; Location path, full form: parent::*/attribute::name
; Location path, abbreviated form: ../@name
; Selects the name attribute of the parent of the context node
(let* ((tree
'(elem (@ (name "elem") (id "idz"))
(para (@) "para") (br (@)) "cdata" (para "second par")
(div (@ (name "aa")) (para (@) "third para")))
)
(para1 ; the first para node
(car ((sxpath '(para)) tree)))
(para3 ; the third para node
(car ((sxpath '(div para)) tree)))
(div ; div node
(car ((sxpath '(// div)) tree)))
)
(run-test
(node-parent tree)
para1 (list tree))
(run-test
(node-parent tree)
para3 (list div))
(run-test ; checking the parent of an attribute node
(node-parent tree)
((sxpath '(@ name)) div) (list div))
(run-test
(node-join
(node-parent tree)
(select-kids (node-typeof? '@))
(select-kids (node-typeof? 'name)))
para3 '((name "aa")))
(run-test
(sxpath `(,(node-parent tree) @ name))
para3 '((name "aa")))
)
; Location path, full form: following-sibling::chapter[position()=1]
; Location path, abbreviated form: none
; selects the next chapter sibling of the context node
; The path is equivalent to
; let cnode = context-node
; in
; parent::* / child::chapter [take-after node_eq(self::*,cnode)]
; [position()=1]
(let* ((tree
'(document
(preface "preface")
(chapter (@ (id "one")) "Chap 1 text")
(chapter (@ (id "two")) "Chap 2 text")
(chapter (@ (id "three")) "Chap 3 text")
(chapter (@ (id "four")) "Chap 4 text")
(epilogue "Epilogue text")
(appendix (@ (id "A")) "App A text")
(References "References"))
)
(a-node ; to be used as a context node
(car ((sxpath '(// (chapter (@ (equal? (id "two")))))) tree)))
(expected
'((chapter (@ (id "three")) "Chap 3 text")))
)
(run-test
(node-reduce
(node-join
(node-parent tree)
(select-kids (node-typeof? 'chapter)))
(take-after (node-eq? a-node))
(node-pos 1)
)
a-node expected)
)
; preceding-sibling::chapter[position()=1]
; selects the previous chapter sibling of the context node
; The path is equivalent to
; let cnode = context-node
; in
; parent::* / child::chapter [take-until node_eq(self::*,cnode)]
; [position()=-1]
(let* ((tree
'(document
(preface "preface")
(chapter (@ (id "one")) "Chap 1 text")
(chapter (@ (id "two")) "Chap 2 text")
(chapter (@ (id "three")) "Chap 3 text")
(chapter (@ (id "four")) "Chap 4 text")
(epilogue "Epilogue text")
(appendix (@ (id "A")) "App A text")
(References "References"))
)
(a-node ; to be used as a context node
(car ((sxpath '(// (chapter (@ (equal? (id "three")))))) tree)))
(expected
'((chapter (@ (id "two")) "Chap 2 text")))
)
(run-test
(node-reduce
(node-join
(node-parent tree)
(select-kids (node-typeof? 'chapter)))
(take-until (node-eq? a-node))
(node-pos -1)
)
a-node expected)
)
; /descendant::figure[position()=42]
; selects the forty-second figure element in the document
; See the next example, which is more general.
; Location path, full form:
; child::table/child::tr[position()=2]/child::td[position()=3]
; Location path, abbreviated form: table/tr[2]/td[3]
; selects the third td of the second tr of the table
(let ((tree ((node-closure (node-typeof? 'p)) tree1))
(expected
'((td " data + control"))
))
(run-test
(node-join
(select-kids (node-typeof? 'table))
(node-reduce (select-kids (node-typeof? 'tr))
(node-pos 2))
(node-reduce (select-kids (node-typeof? 'td))
(node-pos 3)))
tree expected)
(run-test (sxpath '(table (tr 2) (td 3))) tree expected)
)
; Location path, full form:
; child::para[attribute::type='warning'][position()=5]
; Location path, abbreviated form: para[@type='warning'][5]
; selects the fifth para child of the context node that has a type
; attribute with value warning
(let ((tree
'(chapter
(para "para1")
(para (@ (type "warning")) "para 2")
(para (@ (type "warning")) "para 3")
(para (@ (type "warning")) "para 4")
(para (@ (type "warning")) "para 5")
(para (@ (type "warning")) "para 6"))
)
(expected
'((para (@ (type "warning")) "para 6"))
))
(run-test
(node-reduce
(select-kids (node-typeof? 'para))
(filter
(node-join
(select-kids (node-typeof? '@))
(select-kids (node-equal? '(type "warning")))))
(node-pos 5))
tree expected)
(run-test (sxpath '( (((para (@ (equal? (type "warning"))))) 5 ) ))
tree expected)
(run-test (sxpath '( (para (@ (equal? (type "warning"))) 5 ) ))
tree expected)
)
; Location path, full form:
; child::para[position()=5][attribute::type='warning']
; Location path, abbreviated form: para[5][@type='warning']
; selects the fifth para child of the context node if that child has a 'type'
; attribute with value warning
(let ((tree
'(chapter
(para "para1")
(para (@ (type "warning")) "para 2")
(para (@ (type "warning")) "para 3")
(para (@ (type "warning")) "para 4")
(para (@ (type "warning")) "para 5")
(para (@ (type "warning")) "para 6"))
)
(expected
'((para (@ (type "warning")) "para 5"))
))
(run-test
(node-reduce
(select-kids (node-typeof? 'para))
(node-pos 5)
(filter
(node-join
(select-kids (node-typeof? '@))
(select-kids (node-equal? '(type "warning"))))))
tree expected)
(run-test (sxpath '( (( (para 5)) (@ (equal? (type "warning"))))))
tree expected)
(run-test (sxpath '( (para 5 (@ (equal? (type "warning")))) ))
tree expected)
)
; Location path, full form:
; child::*[self::chapter or self::appendix]
; Location path, semi-abbreviated form: *[self::chapter or self::appendix]
; selects the chapter and appendix children of the context node
(let ((tree
'(document
(preface "preface")
(chapter (@ (id "one")) "Chap 1 text")
(chapter (@ (id "two")) "Chap 2 text")
(chapter (@ (id "three")) "Chap 3 text")
(epilogue "Epilogue text")
(appendix (@ (id "A")) "App A text")
(References "References"))
)
(expected
'((chapter (@ (id "one")) "Chap 1 text")
(chapter (@ (id "two")) "Chap 2 text")
(chapter (@ (id "three")) "Chap 3 text")
(appendix (@ (id "A")) "App A text"))
))
(run-test
(node-join
(select-kids (node-typeof? '*))
(filter
(node-or
(node-self (node-typeof? 'chapter))
(node-self (node-typeof? 'appendix)))))
tree expected)
(run-test (sxpath `(* ,(node-or (node-self (node-typeof? 'chapter))
(node-self (node-typeof? 'appendix)))))
tree expected)
)
; Location path, full form: child::chapter[child::title='Introduction']
; Location path, abbreviated form: chapter[title = 'Introduction']
; selects the chapter children of the context node that have one or more
; title children with string-value equal to Introduction
; See a similar example: //td[@align = "right"] above.
; Location path, full form: child::chapter[child::title]
; Location path, abbreviated form: chapter[title]
; selects the chapter children of the context node that have one or
; more title children
; See a similar example //td[@align] above.
(cerr nl "Example with tree3: extracting the first lines of every stanza" nl)
(let ((tree tree3)
(expected
'("Let us go then, you and I," "In the room the women come and go")
))
(run-test
(node-join
(node-closure (node-typeof? 'stanza))
(node-reduce
(select-kids (node-typeof? 'line)) (node-pos 1))
(select-kids (node-typeof? '*text*)))
tree expected)
(run-test (sxpath '(// stanza (line 1) *text*)) tree expected)
)
guile-lib-0.2.2/src/sxml/upstream/input-parse.scm 0000644 0001750 0001750 00000032521 11573632155 016705 0000000 0000000 ;****************************************************************************
; Simple Parsing of input
;
; The following simple functions surprisingly often suffice to parse
; an input stream. They either skip, or build and return tokens,
; according to inclusion or delimiting semantics. The list of
; characters to expect, include, or to break at may vary from one
; invocation of a function to another. This allows the functions to
; easily parse even context-sensitive languages.
;
; EOF is generally frowned on, and thrown up upon if encountered.
; Exceptions are mentioned specifically. The list of expected characters
; (characters to skip until, or break-characters) may include an EOF
; "character", which is to be coded as symbol *eof*
;
; The input stream to parse is specified as a PORT, which is usually
; the last (and optional) argument. It defaults to the current input
; port if omitted.
;
; IMPORT
; This package relies on a function parser-error, which must be defined
; by a user of the package. The function has the following signature:
; parser-error PORT MESSAGE SPECIALISING-MSG*
; Many procedures of this package call parser-error to report a parsing
; error. The first argument is a port, which typically points to the
; offending character or its neighborhood. Most of the Scheme systems
; let the user query a PORT for the current position. MESSAGE is the
; description of the error. Other arguments supply more details about
; the problem.
; myenv.scm, myenv-bigloo.scm or a similar prelude is assumed.
; From SRFI-13, string-concatenate-reverse
; If a particular implementation lacks SRFI-13 support, please
; include the file srfi-13-local.scm
;
; $Id: input-parse.scm,v 1.7 2004/07/07 16:02:31 sperber Exp $
;------------------------------------------------------------------------
; -- procedure+: peek-next-char [PORT]
; advances to the next character in the PORT and peeks at it.
; This function is useful when parsing LR(1)-type languages
; (one-char-read-ahead).
; The optional argument PORT defaults to the current input port.
(define-opt (peek-next-char (optional (port (current-input-port))))
(read-char port)
(peek-char port))
;------------------------------------------------------------------------
; -- procedure+: assert-curr-char CHAR-LIST STRING [PORT]
; Reads a character from the PORT and looks it up
; in the CHAR-LIST of expected characters
; If the read character was found among expected, it is returned
; Otherwise, the procedure writes a nasty message using STRING
; as a comment, and quits.
; The optional argument PORT defaults to the current input port.
;
(define-opt (assert-curr-char expected-chars comment
(optional (port (current-input-port))))
(let ((c (read-char port)))
(if (memv c expected-chars) c
(parser-error port "Wrong character " c
" (0x" (if (eof-object? c) "*eof*"
(number->string (char->integer c) 16)) ") "
comment ". " expected-chars " expected"))))
; -- procedure+: skip-until CHAR-LIST [PORT]
; Reads and skips characters from the PORT until one of the break
; characters is encountered. This break character is returned.
; The break characters are specified as the CHAR-LIST. This list
; may include EOF, which is to be coded as a symbol *eof*
;
; -- procedure+: skip-until NUMBER [PORT]
; Skips the specified NUMBER of characters from the PORT and returns #f
;
; The optional argument PORT defaults to the current input port.
(define-opt (skip-until arg (optional (port (current-input-port))) )
(cond
((number? arg) ; skip 'arg' characters
(do ((i arg (dec i)))
((not (positive? i)) #f)
(if (eof-object? (read-char port))
(parser-error port "Unexpected EOF while skipping "
arg " characters"))))
(else ; skip until break-chars (=arg)
(let loop ((c (read-char port)))
(cond
((memv c arg) c)
((eof-object? c)
(if (memq '*eof* arg) c
(parser-error port "Unexpected EOF while skipping until " arg)))
(else (loop (read-char port))))))))
; -- procedure+: skip-while CHAR-LIST [PORT]
; Reads characters from the PORT and disregards them,
; as long as they are mentioned in the CHAR-LIST.
; The first character (which may be EOF) peeked from the stream
; that is NOT a member of the CHAR-LIST is returned. This character
; is left on the stream.
; The optional argument PORT defaults to the current input port.
(define-opt (skip-while skip-chars (optional (port (current-input-port))) )
(do ((c (peek-char port) (peek-char port)))
((not (memv c skip-chars)) c)
(read-char port)))
; whitespace const
;------------------------------------------------------------------------
; Stream tokenizers
; -- procedure+:
; next-token PREFIX-CHAR-LIST BREAK-CHAR-LIST [COMMENT-STRING] [PORT]
; skips any number of the prefix characters (members of the
; PREFIX-CHAR-LIST), if any, and reads the sequence of characters
; up to (but not including) a break character, one of the
; BREAK-CHAR-LIST.
; The string of characters thus read is returned.
; The break character is left on the input stream
; The list of break characters may include EOF, which is to be coded as
; a symbol *eof*. Otherwise, EOF is fatal, generating an error message
; including a specified COMMENT-STRING (if any)
;
; The optional argument PORT defaults to the current input port.
;
; Note: since we can't tell offhand how large the token being read is
; going to be, we make a guess, pre-allocate a string, and grow it by
; quanta if necessary. The quantum is always the length of the string
; before it was extended the last time. Thus the algorithm does
; a Fibonacci-type extension, which has been proven optimal.
; Note, explicit port specification in read-char, peek-char helps.
; Procedure: input-parse:init-buffer
; returns an initial buffer for next-token* procedures.
; The input-parse:init-buffer may allocate a new buffer per each invocation:
; (define (input-parse:init-buffer) (make-string 32))
; Size 32 turns out to be fairly good, on average.
; That policy is good only when a Scheme system is multi-threaded with
; preemptive scheduling, or when a Scheme system supports shared substrings.
; In all the other cases, it's better for input-parse:init-buffer to
; return the same static buffer. next-token* functions return a copy
; (a substring) of accumulated data, so the same buffer can be reused.
; We shouldn't worry about an incoming token being too large:
; next-token will use another chunk automatically. Still,
; the best size for the static buffer is to allow most of the tokens to fit in.
; Using a static buffer _dramatically_ reduces the amount of produced garbage
; (e.g., during XML parsing).
(define input-parse:init-buffer
(let ((buffer (make-string 512)))
(lambda () buffer)))
; See a better version below
(define-opt (next-token-old prefix-skipped-chars break-chars
(optional (comment "") (port (current-input-port))) )
(let* ((buffer (input-parse:init-buffer))
(curr-buf-len (string-length buffer))
(quantum curr-buf-len))
(let loop ((i 0) (c (skip-while prefix-skipped-chars port)))
(cond
((memv c break-chars) (substring buffer 0 i))
((eof-object? c)
(if (memq '*eof* break-chars)
(substring buffer 0 i) ; was EOF expected?
(parser-error port "EOF while reading a token " comment)))
(else
(if (>= i curr-buf-len) ; make space for i-th char in buffer
(begin ; -> grow the buffer by the quantum
(set! buffer (string-append buffer (make-string quantum)))
(set! quantum curr-buf-len)
(set! curr-buf-len (string-length buffer))))
(string-set! buffer i c)
(read-char port) ; move to the next char
(loop (inc i) (peek-char port))
)))))
; A better version of next-token, which accumulates the characters
; in chunks, and later on reverse-concatenates them, using
; SRFI-13 if available.
; The overhead of copying characters is only 100% (or even smaller: bulk
; string copying might be well-optimised), compared to the (hypothetical)
; circumstance if we had known the size of the token beforehand.
; For small tokens, the code performs just as above. For large
; tokens, we expect an improvement. Note, the code also has no
; assignments.
; See next-token-comp.scm
(define-opt (next-token prefix-skipped-chars break-chars
(optional (comment "") (port (current-input-port))) )
(let outer ((buffer (input-parse:init-buffer)) (filled-buffer-l '())
(c (skip-while prefix-skipped-chars port)))
(let ((curr-buf-len (string-length buffer)))
(let loop ((i 0) (c c))
(cond
((memv c break-chars)
(if (null? filled-buffer-l) (substring buffer 0 i)
(string-concatenate-reverse filled-buffer-l buffer i)))
((eof-object? c)
(if (memq '*eof* break-chars) ; was EOF expected?
(if (null? filled-buffer-l) (substring buffer 0 i)
(string-concatenate-reverse filled-buffer-l buffer i))
(parser-error port "EOF while reading a token " comment)))
((>= i curr-buf-len)
(outer (make-string curr-buf-len)
(cons buffer filled-buffer-l) c))
(else
(string-set! buffer i c)
(read-char port) ; move to the next char
(loop (inc i) (peek-char port))))))))
; -- procedure+: next-token-of INC-CHARSET [PORT]
; Reads characters from the PORT that belong to the list of characters
; INC-CHARSET. The reading stops at the first character which is not
; a member of the set. This character is left on the stream.
; All the read characters are returned in a string.
;
; -- procedure+: next-token-of PRED [PORT]
; Reads characters from the PORT for which PRED (a procedure of one
; argument) returns non-#f. The reading stops at the first character
; for which PRED returns #f. That character is left on the stream.
; All the results of evaluating of PRED up to #f are returned in a
; string.
;
; PRED is a procedure that takes one argument (a character
; or the EOF object) and returns a character or #f. The returned
; character does not have to be the same as the input argument
; to the PRED. For example,
; (next-token-of (lambda (c)
; (cond ((eof-object? c) #f)
; ((char-alphabetic? c) (char-downcase c))
; (else #f))))
; will try to read an alphabetic token from the current
; input port, and return it in lower case.
;
; The optional argument PORT defaults to the current input port.
;
; This procedure is similar to next-token but only it implements
; an inclusion rather than delimiting semantics.
(define-opt (next-token-of incl-list/pred
(optional (port (current-input-port))) )
(let* ((buffer (input-parse:init-buffer))
(curr-buf-len (string-length buffer)))
(if (procedure? incl-list/pred)
(let outer ((buffer buffer) (filled-buffer-l '()))
(let loop ((i 0))
(if (>= i curr-buf-len) ; make sure we have space
(outer (make-string curr-buf-len) (cons buffer filled-buffer-l))
(let ((c (incl-list/pred (peek-char port))))
(if c
(begin
(string-set! buffer i c)
(read-char port) ; move to the next char
(loop (inc i)))
; incl-list/pred decided it had had enough
(if (null? filled-buffer-l) (substring buffer 0 i)
(string-concatenate-reverse filled-buffer-l buffer i)))))))
; incl-list/pred is a list of allowed characters
(let outer ((buffer buffer) (filled-buffer-l '()))
(let loop ((i 0))
(if (>= i curr-buf-len) ; make sure we have space
(outer (make-string curr-buf-len) (cons buffer filled-buffer-l))
(let ((c (peek-char port)))
(cond
((not (memv c incl-list/pred))
(if (null? filled-buffer-l) (substring buffer 0 i)
(string-concatenate-reverse filled-buffer-l buffer i)))
(else
(string-set! buffer i c)
(read-char port) ; move to the next char
(loop (inc i))))))))
)))
; -- procedure+: read-text-line [PORT]
; Reads one line of text from the PORT, and returns it as a string.
; A line is a (possibly empty) sequence of characters terminated
; by CR, CRLF or LF (or even the end of file).
; The terminating character (or CRLF combination) is removed from
; the input stream. The terminating character(s) is not a part
; of the return string either.
; If EOF is encountered before any character is read, the return
; value is EOF.
;
; The optional argument PORT defaults to the current input port.
(define *read-line-breaks* (list char-newline char-return '*eof*))
(define-opt (read-text-line (optional (port (current-input-port))) )
(if (eof-object? (peek-char port)) (peek-char port)
(let* ((line
(next-token '() *read-line-breaks*
"reading a line" port))
(c (read-char port))) ; must be either \n or \r or EOF
(and (eqv? c char-return) (eqv? (peek-char port) #\newline)
(read-char port)) ; skip \n that follows \r
line)))
; -- procedure+: read-string N [PORT]
; Reads N characters from the PORT, and returns them in a string.
; If EOF is encountered before N characters are read, a shorter string
; will be returned.
; If N is not positive, an empty string will be returned.
; The optional argument PORT defaults to the current input port.
(define-opt (read-string n (optional (port (current-input-port))) )
(if (not (positive? n)) ""
(let ((buffer (make-string n)))
(let loop ((i 0) (c (read-char port)))
(if (eof-object? c) (substring buffer 0 i)
(let ((i1 (inc i)))
(string-set! buffer i c)
(if (= i1 n) buffer
(loop i1 (read-char port)))))))))
guile-lib-0.2.2/src/sxml/simple.scm 0000644 0001750 0001750 00000013135 11573632155 014067 0000000 0000000 ;; (sxml simple) -- a simple interface to the SSAX parser
;; Originally written by Oleg Kiselyov as SXML-to-HTML.scm.
;; Modified 2004 by Andy Wingo .
;; This file is in the public domain.
;;; Commentary:
;;
;;A simple interface to XML parsing and serialization.
;;
;;; Code:
(define-module (sxml simple)
#:use-module (sxml ssax-simple)
#:use-module (sxml transform)
#:use-module (ice-9 optargs)
#:use-module (srfi srfi-13)
#:use-module (scheme documentation)
#:export (xml->sxml sxml->xml sxml->string universal-sxslt-rules))
(define* (xml->sxml #:optional (port (current-input-port)))
"Use SSAX to parse an XML document into SXML. Takes one optional
argument, @var{port}, which defaults to the current input port."
(ssax:xml->sxml port '()))
;; Universal transformation rules. Works for all XML.
(define-with-docs universal-sxslt-rules
"A set of @code{pre-post-order} rules that transform any SXML tree
into a form suitable for XML serialization by @code{(sxml transform)}'s
@code{SRV:send-reply}. Used internally by @code{sxml->xml}."
`((@
((*default* . ,(lambda (attr-key . value) ((enattr attr-key) value))))
. ,(lambda (trigger . value) (list '@ value)))
(*ENTITY* . ,(lambda (tag name) (list "&" name ";")))
(*PI* . ,(lambda (pi tag str) (list "" tag " " str "?>")))
;; Is this right for entities? I don't have a reference for
;; public-id/system-id at the moment...
(*default* . ,(lambda (tag . elems) (apply (entag tag) elems)))
(*text* . ,(lambda (trigger str)
(if (string? str) (string->escaped-xml str) str)))))
(define* (sxml->xml tree #:optional (port (current-output-port)))
"Serialize the sxml tree @var{tree} as XML. The output will be written
to the current output port, unless the optional argument @var{port} is
present."
(with-output-to-port port
(lambda ()
(SRV:send-reply
(post-order
tree
universal-sxslt-rules)))))
(define (sxml->string sxml)
"Detag an sxml tree @var{sxml} into a string. Does not perform any
formatting."
(string-concatenate-reverse
(foldts
(lambda (seed tree) ; fdown
'())
(lambda (seed kid-seed tree) ; fup
(append! kid-seed seed))
(lambda (seed tree) ; fhere
(if (string? tree) (cons tree seed) seed))
'()
sxml)))
;; The following two functions serialize tags and attributes. They are
;; being used in the node handlers for the post-order function, see
;; above.
(define (check-name name)
(let* ((str (symbol->string name))
(i (string-index str #\:))
(head (or (and i (substring str 0 i)) str))
(tail (and i (substring str (1+ i)))))
(and i (string-index (substring str (1+ i)) #\:)
(error "Invalid QName: more than one colon" name))
(for-each
(lambda (s)
(and s
(or (char-alphabetic? (string-ref s 0))
(eq? (string-ref s 0) #\_)
(error "Invalid name starting character" s name))
(string-for-each
(lambda (c)
(or (char-alphabetic? c) (string-index "0123456789.-_" c)
(error "Invalid name character" c s name)))
s)))
(list head tail))))
(define (entag tag)
(check-name tag)
(lambda elems
(if (and (pair? elems) (pair? (car elems)) (eq? '@ (caar elems)))
(list #\< tag (cdar elems)
(if (pair? (cdr elems))
(list #\> (cdr elems) "" tag #\>)
" />"))
(list #\< tag
(if (pair? elems)
(list #\> elems "" tag #\>)
" />")))))
(define (enattr attr-key)
(check-name attr-key)
(let ((attr-str (symbol->string attr-key)))
(lambda (value)
(list #\space attr-str
"=\"" (and (not (null? value)) value) #\"))))
(define (make-char-quotator char-encoding)
(let ((bad-chars (map car char-encoding)))
;; Check to see if str contains one of the characters in charset,
;; from the position i onward. If so, return that character's index.
;; otherwise, return #f
(define (index-cset str i charset)
(let loop ((i i))
(and (< i (string-length str))
(if (memv (string-ref str i) charset) i
(loop (+ 1 i))))))
;; The body of the function
(lambda (str)
(let ((bad-pos (index-cset str 0 bad-chars)))
(if (not bad-pos) str ; str had all good chars
(string-concatenate-reverse
(let loop ((from 0) (to bad-pos) (out '()))
(cond
((>= from (string-length str)) out)
((not to)
(cons (substring str from (string-length str)) out))
(else
(let ((quoted-char
(cdr (assv (string-ref str to) char-encoding)))
(new-to
(index-cset str (+ 1 to) bad-chars)))
(loop (1+ to) new-to
(if (< from to)
(cons* quoted-char (substring str from to) out)
(cons quoted-char out)))))))))))))
;; Given a string, check to make sure it does not contain characters
;; such as '<' or '&' that require encoding. Return either the original
;; string, or a list of string fragments with special characters
;; replaced by appropriate character entities.
(define string->escaped-xml
(make-char-quotator
'((#\< . "<") (#\> . ">") (#\& . "&") (#\" . """))))
;;; arch-tag: 9c853b25-d82f-42ef-a959-ae26fdc7d1ac
;;; simple.scm ends here
guile-lib-0.2.2/src/sxml/unicode.scm 0000644 0001750 0001750 00000003626 11573632155 014230 0000000 0000000 ;; (sxml unicode) -- rendering unicode to byte strings
;; Copyright (C) 2008 Andy Wingo
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see .
;;; Commentary:
;;
;; Routines for encoding unicode codepoints into byte strings.
;;
;;; Code:
(define-module (sxml unicode)
#:export (unichar->utf-8))
(define (unichar->utf-8 u)
(define (byte header mask shift)
(integer->char (logior header (logand mask (ash u shift)))))
(cond
((< u #x000000) (error "bad unicode code point" u))
((< u #x000080) (string (integer->char u)))
((< u #x000800) (string (byte #b11000000 #b11111 -6)
(byte #b10000000 #b111111 0)))
((< u #x00d800) (string (byte #b11100000 #b1111 -12)
(byte #b10000000 #b111111 -6)
(byte #b10000000 #b111111 0)))
((< u #x00e000) (error "bad unicode code point" u))
((< u #x010000) (string (byte #b11100000 #b1111 -12)
(byte #b10000000 #b111111 -6)
(byte #b10000000 #b111111 0)))
((< u #x110000) (string (byte #b11110000 #b111 -18)
(byte #b10000000 #b111111 -12)
(byte #b10000000 #b111111 -6)
(byte #b10000000 #b111111 0)))
(else (error "bad unicode code point" u))))
guile-lib-0.2.2/src/sxml/ssax/ 0000755 0001750 0001750 00000000000 12102442377 013117 5 0000000 0000000 guile-lib-0.2.2/src/sxml/ssax/input-parse.scm 0000644 0001750 0001750 00000007176 11573632156 016034 0000000 0000000 ;; (sxml ssax input-parse) -- a simple lexer
;; Written 2003 by Oleg Kiselyov as input-parse.scm.
;; Modified 2004 by Andy Wingo .
;; This file is in the public domain.
;;; Commentary:
;;
;; A simple lexer.
;;
;; The procedures in this module surprisingly often suffice to parse an
;; input stream. They either skip, or build and return tokens, according
;; to inclusion or delimiting semantics. The list of characters to
;; expect, include, or to break at may vary from one invocation of a
;; function to another. This allows the functions to easily parse even
;; context-sensitive languages.
;;
;; EOF is generally frowned on, and thrown up upon if encountered.
;; Exceptions are mentioned specifically. The list of expected
;; characters (characters to skip until, or break-characters) may
;; include an EOF "character", which is to be coded as the symbol,
;; @code{*eof*}.
;;
;; The input stream to parse is specified as a @dfn{port}, which is
;; usually the last (and optional) argument. It defaults to the current
;; input port if omitted.
;;
;; If the parser encounters an error, it will throw an exception to the
;; key @code{parser-error}. The arguments will be of the form
;; @code{(@var{port} @var{message} @var{specialising-msg}*)}.
;;
;; The first argument is a port, which typically points to the offending
;; character or its neighborhood. You can then use @code{port-column}
;; and @code{port-line} to query the current position. @var{message} is
;; the description of the error. Other arguments supply more details
;; about the problem.
;;
;;; Code:
(define-module (sxml ssax input-parse)
#:use-module (ice-9 optargs)
#:use-module (ice-9 rdelim)
#:export (peek-next-char
assert-curr-char
skip-until
skip-while
next-token
next-token-of
read-text-line
read-string))
(define ascii->char integer->char)
(define char->ascii char->integer)
(define char-newline #\newline)
(define char-return #\return)
(define inc 1+)
(define dec 1-)
;; rewrite oleg's define-opt into define* style
(define-macro (define-opt bindings body . body-rest)
(let* ((rev-bindings (reverse bindings))
(opt-bindings
(and (pair? rev-bindings) (pair? (car rev-bindings))
(eq? 'optional (caar rev-bindings))
(cdar rev-bindings))))
(if opt-bindings
`(define* ,(append (reverse (cons #:optional (cdr rev-bindings)))
opt-bindings)
,body ,@body-rest)
`(define* ,bindings ,body ,@body-rest))))
(define (parser-error port message . rest)
(apply throw 'parser-error port message rest))
(load-from-path "sxml/upstream/input-parse.scm")
;; This version for guile is quite speedy, due to read-delimited (which
;; is implemented in C).
(define-opt (next-token prefix-skipped-chars break-chars
(optional (comment "") (port (current-input-port))) )
(let ((delims (list->string (delete '*eof* break-chars))))
(if (eof-object? (if (null? prefix-skipped-chars)
(peek-char port)
(skip-while prefix-skipped-chars port)))
(if (memq '*eof* break-chars)
""
(parser-error port "EOF while reading a token " comment))
(let ((token (read-delimited delims port 'peek)))
(if (and (eof-object? (peek-char port))
(not (memq '*eof* break-chars)))
(parser-error port "EOF while reading a token " comment)
token)))))
(define-opt (read-text-line (optional (port (current-input-port))) )
(read-line port))
;;; arch-tag: 73fa0dc1-9f01-45e1-80fa-4d9a7ab83f92
;;; input-parse.scm ends here
guile-lib-0.2.2/src/sxml/xpath.scm 0000644 0001750 0001750 00000045051 11573632155 013724 0000000 0000000 ;; (sxml xpath) -- SXPath
;; Written 2001 by Oleg Kiselyov SXPath.scm.
;; Modified 2004 by Andy Wingo .
;; This file is in the public domain.
;;; Commentary:
;;
;;@heading SXPath: SXML Query Language
;;
;; SXPath is a query language for SXML, an instance of XML Information
;; set (Infoset) in the form of s-expressions. See @code{(sxml ssax)}
;; for the definition of SXML and more details. SXPath is also a
;; translation into Scheme of an XML Path Language,
;; @uref{http://www.w3.org/TR/xpath,XPath}. XPath and SXPath describe
;; means of selecting a set of Infoset's items or their properties.
;;
;; To facilitate queries, XPath maps the XML Infoset into an explicit
;; tree, and introduces important notions of a location path and a
;; current, context node. A location path denotes a selection of a set of
;; nodes relative to a context node. Any XPath tree has a distinguished,
;; root node -- which serves as the context node for absolute location
;; paths. Location path is recursively defined as a location step joined
;; with a location path. A location step is a simple query of the
;; database relative to a context node. A step may include expressions
;; that further filter the selected set. Each node in the resulting set
;; is used as a context node for the adjoining location path. The result
;; of the step is a union of the sets returned by the latter location
;; paths.
;;
;; The SXML representation of the XML Infoset (see SSAX.scm) is rather
;; suitable for querying as it is. Bowing to the XPath specification,
;; we will refer to SXML information items as 'Nodes':
;;@example
;; ::= | |
;; | "text string" |
;;@end example
;; This production can also be described as
;;@example
;; ::= (name . ) | "text string"
;;@end example
;; An (ordered) set of nodes is just a list of the constituent nodes:
;;@example
;; ::= ( ...)
;;@end example
;; Nodesets, and Nodes other than text strings are both lists. A
;; however is either an empty list, or a list whose head is not
;; a symbol. A symbol at the head of a node is either an XML name (in
;; which case it's a tag of an XML element), or an administrative name
;; such as '@@'. This uniform list representation makes processing rather
;; simple and elegant, while avoiding confusion. The multi-branch tree
;; structure formed by the mutually-recursive datatypes and
;; lends itself well to processing by functional languages.
;;
;; A location path is in fact a composite query over an XPath tree or
;; its branch. A singe step is a combination of a projection, selection
;; or a transitive closure. Multiple steps are combined via join and
;; union operations. This insight allows us to @emph{elegantly}
;; implement XPath as a sequence of projection and filtering primitives
;; -- converters -- joined by @dfn{combinators}. Each converter takes a
;; node and returns a nodeset which is the result of the corresponding
;; query relative to that node. A converter can also be called on a set
;; of nodes. In that case it returns a union of the corresponding
;; queries over each node in the set. The union is easily implemented as
;; a list append operation as all nodes in a SXML tree are considered
;; distinct, by XPath conventions. We also preserve the order of the
;; members in the union. Query combinators are high-order functions:
;; they take converter(s) (which is a Node|Nodeset -> Nodeset function)
;; and compose or otherwise combine them. We will be concerned with only
;; relative location paths [XPath]: an absolute location path is a
;; relative path applied to the root node.
;;
;; Similarly to XPath, SXPath defines full and abbreviated notations
;; for location paths. In both cases, the abbreviated notation can be
;; mechanically expanded into the full form by simple rewriting
;; rules. In case of SXPath the corresponding rules are given as
;; comments to a sxpath function, below. The regression test suite at
;; the end of this file shows a representative sample of SXPaths in
;; both notations, juxtaposed with the corresponding XPath
;; expressions. Most of the samples are borrowed literally from the
;; XPath specification, while the others are adjusted for our running
;; example, tree1.
;;
;;; Code:
(define-module (sxml xpath)
#:export (nodeset? node-typeof? node-eq? node-equal? node-pos
filter take-until take-after map-union node-reverse
node-trace select-kids node-self node-join node-reduce
node-or node-closure node-parent
sxpath))
;; Upstream version:
; $Id: SXPath.scm,v 3.5 2001/01/12 23:20:35 oleg Exp oleg $
(define (nodeset? x)
(or (and (pair? x) (not (symbol? (car x)))) (null? x)))
;-------------------------
; Basic converters and applicators
; A converter is a function
; type Converter = Node|Nodeset -> Nodeset
; A converter can also play a role of a predicate: in that case, if a
; converter, applied to a node or a nodeset, yields a non-empty
; nodeset, the converter-predicate is deemed satisfied. Throughout
; this file a nil nodeset is equivalent to #f in denoting a failure.
; The following function implements a 'Node test' as defined in
; Sec. 2.3 of XPath document. A node test is one of the components of a
; location step. It is also a converter-predicate in SXPath.
;
; The function node-typeof? takes a type criterion and returns a function,
; which, when applied to a node, will tell if the node satisfies
; the test.
; node-typeof? :: Crit -> Node -> Boolean
;
; The criterion 'crit' is a symbol, one of the following:
; id - tests if the Node has the right name (id)
; @ - tests if the Node is an
; * - tests if the Node is an
; *text* - tests if the Node is a text node
; *PI* - tests if the Node is a PI node
; *any* - #t for any type of Node
(define (node-typeof? crit)
(lambda (node)
(case crit
((*) (and (pair? node) (not (memq (car node) '(@ *PI*)))))
((*any*) #t)
((*text*) (string? node))
(else
(and (pair? node) (eq? crit (car node))))
)))
; Curried equivalence converter-predicates
(define (node-eq? other)
(lambda (node)
(eq? other node)))
(define (node-equal? other)
(lambda (node)
(equal? other node)))
; node-pos:: N -> Nodeset -> Nodeset, or
; node-pos:: N -> Converter
; Select the N'th element of a Nodeset and return as a singular Nodeset;
; Return an empty nodeset if the Nth element does not exist.
; ((node-pos 1) Nodeset) selects the node at the head of the Nodeset,
; if exists; ((node-pos 2) Nodeset) selects the Node after that, if
; exists.
; N can also be a negative number: in that case the node is picked from
; the tail of the list.
; ((node-pos -1) Nodeset) selects the last node of a non-empty nodeset;
; ((node-pos -2) Nodeset) selects the last but one node, if exists.
(define (node-pos n)
(lambda (nodeset)
(cond
((not (nodeset? nodeset)) '())
((null? nodeset) nodeset)
((eqv? n 1) (list (car nodeset)))
((negative? n) ((node-pos (+ n 1 (length nodeset))) nodeset))
(else
(or (positive? n) (error "yikes!"))
((node-pos (1- n)) (cdr nodeset))))))
; filter:: Converter -> Converter
; A filter applicator, which introduces a filtering context. The argument
; converter is considered a predicate, with either #f or nil result meaning
; failure.
(define (filter pred?)
(lambda (lst) ; a nodeset or a node (will be converted to a singleton nset)
(let loop ((lst (if (nodeset? lst) lst (list lst))) (res '()))
(if (null? lst)
(reverse res)
(let ((pred-result (pred? (car lst))))
(loop (cdr lst)
(if (and pred-result (not (null? pred-result)))
(cons (car lst) res)
res)))))))
; take-until:: Converter -> Converter, or
; take-until:: Pred -> Node|Nodeset -> Nodeset
; Given a converter-predicate and a nodeset, apply the predicate to
; each element of the nodeset, until the predicate yields anything but #f or
; nil. Return the elements of the input nodeset that have been processed
; till that moment (that is, which fail the predicate).
; take-until is a variation of the filter above: take-until passes
; elements of an ordered input set till (but not including) the first
; element that satisfies the predicate.
; The nodeset returned by ((take-until (not pred)) nset) is a subset --
; to be more precise, a prefix -- of the nodeset returned by
; ((filter pred) nset)
(define (take-until pred?)
(lambda (lst) ; a nodeset or a node (will be converted to a singleton nset)
(let loop ((lst (if (nodeset? lst) lst (list lst))))
(if (null? lst) lst
(let ((pred-result (pred? (car lst))))
(if (and pred-result (not (null? pred-result)))
'()
(cons (car lst) (loop (cdr lst)))))
))))
; take-after:: Converter -> Converter, or
; take-after:: Pred -> Node|Nodeset -> Nodeset
; Given a converter-predicate and a nodeset, apply the predicate to
; each element of the nodeset, until the predicate yields anything but #f or
; nil. Return the elements of the input nodeset that have not been processed:
; that is, return the elements of the input nodeset that follow the first
; element that satisfied the predicate.
; take-after along with take-until partition an input nodeset into three
; parts: the first element that satisfies a predicate, all preceding
; elements and all following elements.
(define (take-after pred?)
(lambda (lst) ; a nodeset or a node (will be converted to a singleton nset)
(let loop ((lst (if (nodeset? lst) lst (list lst))))
(if (null? lst) lst
(let ((pred-result (pred? (car lst))))
(if (and pred-result (not (null? pred-result)))
(cdr lst)
(loop (cdr lst))))
))))
; Apply proc to each element of lst and return the list of results.
; if proc returns a nodeset, splice it into the result
;
; From another point of view, map-union is a function Converter->Converter,
; which places an argument-converter in a joining context.
(define (map-union proc lst)
(if (null? lst) lst
(let ((proc-res (proc (car lst))))
((if (nodeset? proc-res) append cons)
proc-res (map-union proc (cdr lst))))))
; node-reverse :: Converter, or
; node-reverse:: Node|Nodeset -> Nodeset
; Reverses the order of nodes in the nodeset
; This basic converter is needed to implement a reverse document order
; (see the XPath Recommendation).
(define node-reverse
(lambda (node-or-nodeset)
(if (not (nodeset? node-or-nodeset)) (list node-or-nodeset)
(reverse node-or-nodeset))))
; node-trace:: String -> Converter
; (node-trace title) is an identity converter. In addition it prints out
; a node or nodeset it is applied to, prefixed with the 'title'.
; This converter is very useful for debugging.
(define (node-trace title)
(lambda (node-or-nodeset)
(display "\n-->")
(display title)
(display " :")
(pretty-print node-or-nodeset)
node-or-nodeset))
;-------------------------
; Converter combinators
;
; Combinators are higher-order functions that transmogrify a converter
; or glue a sequence of converters into a single, non-trivial
; converter. The goal is to arrive at converters that correspond to
; XPath location paths.
;
; From a different point of view, a combinator is a fixed, named
; _pattern_ of applying converters. Given below is a complete set of
; such patterns that together implement XPath location path
; specification. As it turns out, all these combinators can be built
; from a small number of basic blocks: regular functional composition,
; map-union and filter applicators, and the nodeset union.
; select-kids:: Pred -> Node -> Nodeset
; Given a Node, return an (ordered) subset its children that satisfy
; the Pred (a converter, actually)
; select-kids:: Pred -> Nodeset -> Nodeset
; The same as above, but select among children of all the nodes in
; the Nodeset
;
; More succinctly, the signature of this function is
; select-kids:: Converter -> Converter
(define (select-kids test-pred?)
(lambda (node) ; node or node-set
(cond
((null? node) node)
((not (pair? node)) '()) ; No children
((symbol? (car node))
((filter test-pred?) (cdr node))) ; it's a single node
(else (map-union (select-kids test-pred?) node)))))
; node-self:: Pred -> Node -> Nodeset, or
; node-self:: Converter -> Converter
; Similar to select-kids but apply to the Node itself rather
; than to its children. The resulting Nodeset will contain either one
; component, or will be empty (if the Node failed the Pred).
(define node-self filter)
; node-join:: [LocPath] -> Node|Nodeset -> Nodeset, or
; node-join:: [Converter] -> Converter
; join the sequence of location steps or paths as described
; in the title comments above.
(define (node-join . selectors)
(lambda (nodeset) ; Nodeset or node
(let loop ((nodeset nodeset) (selectors selectors))
(if (null? selectors) nodeset
(loop
(if (nodeset? nodeset)
(map-union (car selectors) nodeset)
((car selectors) nodeset))
(cdr selectors))))))
; node-reduce:: [LocPath] -> Node|Nodeset -> Nodeset, or
; node-reduce:: [Converter] -> Converter
; A regular functional composition of converters.
; From a different point of view,
; ((apply node-reduce converters) nodeset)
; is equivalent to
; (foldl apply nodeset converters)
; i.e., folding, or reducing, a list of converters with the nodeset
; as a seed.
(define (node-reduce . converters)
(lambda (nodeset) ; Nodeset or node
(let loop ((nodeset nodeset) (converters converters))
(if (null? converters) nodeset
(loop ((car converters) nodeset) (cdr converters))))))
; node-or:: [Converter] -> Converter
; This combinator applies all converters to a given node and
; produces the union of their results.
; This combinator corresponds to a union, '|' operation for XPath
; location paths.
; (define (node-or . converters)
; (lambda (node-or-nodeset)
; (if (null? converters) node-or-nodeset
; (append
; ((car converters) node-or-nodeset)
; ((apply node-or (cdr converters)) node-or-nodeset)))))
; More optimal implementation follows
(define (node-or . converters)
(lambda (node-or-nodeset)
(let loop ((result '()) (converters converters))
(if (null? converters) result
(loop (append result (or ((car converters) node-or-nodeset) '()))
(cdr converters))))))
; node-closure:: Converter -> Converter
; Select all _descendants_ of a node that satisfy a converter-predicate.
; This combinator is similar to select-kids but applies to
; grand... children as well.
; This combinator implements the "descendant::" XPath axis
; Conceptually, this combinator can be expressed as
; (define (node-closure f)
; (node-or
; (select-kids f)
; (node-reduce (select-kids (node-typeof? '*)) (node-closure f))))
; This definition, as written, looks somewhat like a fixpoint, and it
; will run forever. It is obvious however that sooner or later
; (select-kids (node-typeof? '*)) will return an empty nodeset. At
; this point further iterations will no longer affect the result and
; can be stopped.
(define (node-closure test-pred?)
(lambda (node) ; Nodeset or node
(let loop ((parent node) (result '()))
(if (null? parent) result
(loop ((select-kids (node-typeof? '*)) parent)
(append result
((select-kids test-pred?) parent)))
))))
; node-parent:: RootNode -> Converter
; (node-parent rootnode) yields a converter that returns a parent of a
; node it is applied to. If applied to a nodeset, it returns the list
; of parents of nodes in the nodeset. The rootnode does not have
; to be the root node of the whole SXML tree -- it may be a root node
; of a branch of interest.
; Given the notation of Philip Wadler's paper on semantics of XSLT,
; parent(x) = { y | y=subnode*(root), x=subnode(y) }
; Therefore, node-parent is not the fundamental converter: it can be
; expressed through the existing ones. Yet node-parent is a rather
; convenient converter. It corresponds to a parent:: axis of SXPath.
; Note that the parent:: axis can be used with an attribute node as well!
(define (node-parent rootnode)
(lambda (node) ; Nodeset or node
(if (nodeset? node) (map-union (node-parent rootnode) node)
(let ((pred
(node-or
(node-reduce
(node-self (node-typeof? '*))
(select-kids (node-eq? node)))
(node-join
(select-kids (node-typeof? '@))
(select-kids (node-eq? node))))))
((node-or
(node-self pred)
(node-closure pred))
rootnode)))))
;-------------------------
; Evaluate an abbreviated SXPath
; sxpath:: AbbrPath -> Converter, or
; sxpath:: AbbrPath -> Node|Nodeset -> Nodeset
; AbbrPath is a list. It is translated to the full SXPath according
; to the following rewriting rules
; (sxpath '()) -> (node-join)
; (sxpath '(path-component ...)) ->
; (node-join (sxpath1 path-component) (sxpath '(...)))
; (sxpath1 '//) -> (node-or
; (node-self (node-typeof? '*any*))
; (node-closure (node-typeof? '*any*)))
; (sxpath1 '(equal? x)) -> (select-kids (node-equal? x))
; (sxpath1 '(eq? x)) -> (select-kids (node-eq? x))
; (sxpath1 ?symbol) -> (select-kids (node-typeof? ?symbol)
; (sxpath1 procedure) -> procedure
; (sxpath1 '(?symbol ...)) -> (sxpath1 '((?symbol) ...))
; (sxpath1 '(path reducer ...)) ->
; (node-reduce (sxpath path) (sxpathr reducer) ...)
; (sxpathr number) -> (node-pos number)
; (sxpathr path-filter) -> (filter (sxpath path-filter))
(define (sxpath path)
(lambda (nodeset)
(let loop ((nodeset nodeset) (path path))
(cond
((null? path) nodeset)
((nodeset? nodeset)
(map-union (sxpath path) nodeset))
((procedure? (car path))
(loop ((car path) nodeset) (cdr path)))
((eq? '// (car path))
(loop
((if (nodeset? nodeset) append cons) nodeset
((node-closure (node-typeof? '*any*)) nodeset))
(cdr path)))
((symbol? (car path))
(loop ((select-kids (node-typeof? (car path))) nodeset)
(cdr path)))
((and (pair? (car path)) (eq? 'equal? (caar path)))
(loop ((select-kids (apply node-equal? (cdar path))) nodeset)
(cdr path)))
((and (pair? (car path)) (eq? 'eq? (caar path)))
(loop ((select-kids (apply node-eq? (cdar path))) nodeset)
(cdr path)))
((pair? (car path))
(let reducer ((nodeset
(if (symbol? (caar path))
((select-kids (node-typeof? (caar path))) nodeset)
(loop nodeset (caar path))))
(reducing-path (cdar path)))
(cond
((null? reducing-path) (loop nodeset (cdr path)))
((number? (car reducing-path))
(reducer ((node-pos (car reducing-path)) nodeset)
(cdr reducing-path)))
(else
(reducer ((filter (sxpath (car reducing-path))) nodeset)
(cdr reducing-path))))))
(else
(error "Invalid path step: " (car path)))))))
;;; arch-tag: c4e57abf-6b61-4612-a6aa-d1536d440774
;;; xpath.scm ends here
guile-lib-0.2.2/src/sxml/ssax.scm 0000644 0001750 0001750 00000022202 11573632155 013547 0000000 0000000 ;; (sxml ssax) -- the SSAX parser
;; Written 2001,2002,2003,2004 by Oleg Kiselyov as SSAX.scm.
;; Modified 2004 by Andy Wingo .
;; This file is in the public domain.
;;; Commentary:
;;
;@subheading Functional XML parsing framework
;@subsubheading SAX/DOM and SXML parsers with support for XML Namespaces and validation
;
; This is a package of low-to-high level lexing and parsing procedures
; that can be combined to yield a SAX, a DOM, a validating parser, or
; a parser intended for a particular document type. The procedures in
; the package can be used separately to tokenize or parse various
; pieces of XML documents. The package supports XML Namespaces,
; internal and external parsed entities, user-controlled handling of
; whitespace, and validation. This module therefore is intended to be
; a framework, a set of "Lego blocks" you can use to build a parser
; following any discipline and performing validation to any degree. As
; an example of the parser construction, this file includes a
; semi-validating SXML parser.
; The present XML framework has a "sequential" feel of SAX yet a
; "functional style" of DOM. Like a SAX parser, the framework scans the
; document only once and permits incremental processing. An application
; that handles document elements in order can run as efficiently as
; possible. @emph{Unlike} a SAX parser, the framework does not require
; an application register stateful callbacks and surrender control to
; the parser. Rather, it is the application that can drive the framework
; -- calling its functions to get the current lexical or syntax element.
; These functions do not maintain or mutate any state save the input
; port. Therefore, the framework permits parsing of XML in a pure
; functional style, with the input port being a monad (or a linear,
; read-once parameter).
; Besides the @var{port}, there is another monad -- @var{seed}. Most of
; the middle- and high-level parsers are single-threaded through the
; @var{seed}. The functions of this framework do not process or affect
; the @var{seed} in any way: they simply pass it around as an instance
; of an opaque datatype. User functions, on the other hand, can use the
; seed to maintain user's state, to accumulate parsing results, etc. A
; user can freely mix his own functions with those of the framework. On
; the other hand, the user may wish to instantiate a high-level parser:
; @code{SSAX:make-elem-parser} or @code{SSAX:make-parser}. In the latter
; case, the user must provide functions of specific signatures, which
; are called at predictable moments during the parsing: to handle
; character data, element data, or processing instructions (PI). The
; functions are always given the @var{seed}, among other parameters, and
; must return the new @var{seed}.
; From a functional point of view, XML parsing is a combined
; pre-post-order traversal of a "tree" that is the XML document
; itself. This down-and-up traversal tells the user about an element
; when its start tag is encountered. The user is notified about the
; element once more, after all element's children have been
; handled. The process of XML parsing therefore is a fold over the
; raw XML document. Unlike a fold over trees defined in [1], the
; parser is necessarily single-threaded -- obviously as elements
; in a text XML document are laid down sequentially. The parser
; therefore is a tree fold that has been transformed to accept an
; accumulating parameter [1,2].
; Formally, the denotational semantics of the parser can be expressed
; as
;@smallexample
; parser:: (Start-tag -> Seed -> Seed) ->
; (Start-tag -> Seed -> Seed -> Seed) ->
; (Char-Data -> Seed -> Seed) ->
; XML-text-fragment -> Seed -> Seed
; parser fdown fup fchar " content " seed
; = fup "" seed
; (parser fdown fup fchar "content" (fdown "" seed))
;
; parser fdown fup fchar "char-data content" seed
; = parser fdown fup fchar "content" (fchar "char-data" seed)
;
; parser fdown fup fchar "elem-content content" seed
; = parser fdown fup fchar "content" (
; parser fdown fup fchar "elem-content" seed)
;@end smallexample
; Compare the last two equations with the left fold
;@smallexample
; fold-left kons elem:list seed = fold-left kons list (kons elem seed)
;@end smallexample
; The real parser created by @code{SSAX:make-parser} is slightly more
; complicated, to account for processing instructions, entity
; references, namespaces, processing of document type declaration, etc.
; The XML standard document referred to in this module is
; @uref{http://www.w3.org/TR/1998/REC-xml-19980210.html}
;
; The present file also defines a procedure that parses the text of an
; XML document or of a separate element into SXML, an S-expression-based
; model of an XML Information Set. SXML is also an Abstract Syntax Tree
; of an XML document. SXML is similar but not identical to DOM; SXML is
; particularly suitable for Scheme-based XML/HTML authoring, SXPath
; queries, and tree transformations. See SXML.html for more details.
; SXML is a term implementation of evaluation of the XML document [3].
; The other implementation is context-passing.
; The present frameworks fully supports the XML Namespaces Recommendation:
; @uref{http://www.w3.org/TR/REC-xml-names/}
; Other links:
;@table @asis
;@item [1]
; Jeremy Gibbons, Geraint Jones, "The Under-appreciated Unfold,"
; Proc. ICFP'98, 1998, pp. 273-279.
;@item [2]
; Richard S. Bird, The promotion and accumulation strategies in
; transformational programming, ACM Trans. Progr. Lang. Systems,
; 6(4):487-504, October 1984.
;@item [3]
; Ralf Hinze, "Deriving Backtracking Monad Transformers,"
; Functional Pearl. Proc ICFP'00, pp. 186-197.
;@end table
;;
;;; Code:
(define-module (sxml ssax)
#:use-module (sxml ssax input-parse)
#:use-module (sxml unicode)
#:use-module (io string)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-13)
#:export (xml-token? xml-token-kind xml-token-head
make-empty-attlist attlist-add
attlist-null?
attlist-remove-top
attlist->alist attlist-fold
ssax:uri-string->symbol
ssax:skip-internal-dtd
ssax:read-pi-body-as-string
ssax:reverse-collect-str-drop-ws
ssax:read-markup-token
ssax:read-cdata-body
ssax:read-char-ref
ssax:read-attributes
ssax:complete-start-tag
ssax:read-external-id
ssax:read-char-data
ssax:xml->sxml)
#:export-syntax (ssax:make-parser ssax:make-pi-parser ssax:make-elem-parser))
;; #:use-syntax doesn't work, see boot-9.scm:1761
(cond-expand
(guile-2 (begin))
(else
(use-syntax (ice-9 syncase))
;; hack around lack of hygiene regarding modules in guile 1.8
(let ((mod (current-module)))
(set-module-binder!
(module-public-interface mod)
(lambda (interface sym define?)
(let ((var (module-local-variable mod sym)))
(if var (module-add! interface sym var))
var))))))
(define (parser-error port message . rest)
(apply throw 'parser-error port message rest))
(define ascii->char integer->char)
(define char->ascii char->integer)
(define (ssax:warn port msg . args)
(warn msg port args))
;; Well, so this isn't correct for other unicode encodings. Something to
;; fix in the future, I guess.
(define ucscode->string unichar->utf-8)
(define char-newline #\newline)
(define char-return #\return)
(define char-tab #\tab)
(define nl "\n")
(define (load-filtered accept-list file)
(with-input-from-file (%search-load-path file)
(lambda ()
(let loop ((sexp (read)))
(cond
((eof-object? sexp))
((and (pair? sexp) (memq (car sexp) accept-list))
(primitive-eval sexp)
(loop (read)))
(else
(loop (read))))))))
;; if condition is true, execute stmts in turn and return the result of
;; the last statement otherwise, return #f
(define-syntax when
(syntax-rules ()
((when condition . stmts)
(and condition (begin . stmts)))))
;; Execute a sequence of forms and return the result of the _first_ one.
;; Like PROG1 in Lisp. Typically used to evaluate one or more forms with
;; side effects and return a value that must be computed before some or
;; all of the side effects happen.
(define-syntax begin0
(syntax-rules ()
((begin0 form form1 ... )
(let ((val form)) form1 ... val))))
; Like let* but allowing for multiple-value bindings
(define-syntax let*-values
(syntax-rules ()
((let*-values () . bodies) (begin . bodies))
((let*-values (((var) initializer) . rest) . bodies)
(let ((var initializer)) ; a single var optimization
(let*-values rest . bodies)))
((let*-values ((vars initializer) . rest) . bodies)
(call-with-values (lambda () initializer) ; the most generic case
(lambda vars (let*-values rest . bodies))))))
;; needed for some dumb reason
(define inc 1+)
(define dec 1-)
(load-from-path "sxml/upstream/assert.scm")
(load-filtered '(define define-syntax ssax:define-labeled-arg-macro)
"sxml/upstream/SSAX.scm")
;;; arch-tag: c30e0855-8f4c-4e8c-ab41-ec24ec391e44
;;; ssax.scm ends here
guile-lib-0.2.2/src/sxml/apply-templates.scm 0000644 0001750 0001750 00000006102 11573632156 015714 0000000 0000000 ;; (sxml apply-templates) -- xslt-like transformation for sxml
;; Written 2003 by Oleg Kiselyov as apply-templates.scm.
;; Modified 2004 by Andy Wingo .
;; This file is in the public domain.
;;; Commentary:
;;
;; Pre-order traversal of a tree and creation of a new tree:
;;
;;@smallexample
;; apply-templates:: tree x ->
;;@end smallexample
;; where
;;@smallexample
;; ::= ( ...)
;; ::= ( ... . )
;; ::= an argument to node-typeof? above
;; ::= ->
;;@end smallexample
;;
;; This procedure does a @emph{normal}, pre-order traversal of an SXML
;; tree. It walks the tree, checking at each node against the list of
;; matching templates.
;;
;; If the match is found (which must be unique, i.e., unambiguous), the
;; corresponding handler is invoked and given the current node as an
;; argument. The result from the handler, which must be a @code{},
;; takes place of the current node in the resulting tree.
;;
;; The name of the function is not accidental: it resembles rather
;; closely an @code{apply-templates} function of XSLT.
;;
;;; Code:
(define-module (sxml apply-templates)
#:use-module (sxml ssax)
#:use-module ((sxml xpath) :hide (filter))
#:export (apply-templates))
(define (apply-templates tree templates)
; Filter the list of templates. If a template does not
; contradict the given node (that is, its head matches
; the type of the node), chop off the head and keep the
; rest as the result. All contradicting templates are removed.
(define (filter-templates node templates)
(cond
((null? templates) templates)
((not (pair? (car templates))) ; A good template must be a list
(filter-templates node (cdr templates)))
(((node-typeof? (caar templates)) node)
(cons (cdar templates) (filter-templates node (cdr templates))))
(else
(filter-templates node (cdr templates)))))
; Here ::= [ | ]
; If there is a in the above list, it must
; be only one. If found, return it; otherwise, return #f
(define (find-handler templates)
(and (pair? templates)
(cond
((procedure? (car templates))
(if (find-handler (cdr templates))
(error "ambiguous template match"))
(car templates))
(else (find-handler (cdr templates))))))
(let loop ((tree tree) (active-templates '()))
;(cout "active-templates: " active-templates nl "tree: " tree nl)
(if (nodeset? tree)
(map-union (lambda (a-tree) (loop a-tree active-templates)) tree)
(let ((still-active-templates
(append
(filter-templates tree active-templates)
(filter-templates tree templates))))
(cond
;((null? still-active-templates) '())
((find-handler still-active-templates) =>
(lambda (handler) (handler tree)))
((not (pair? tree)) '())
(else
(loop (cdr tree) still-active-templates)))))))
;;; arch-tag: 88cd87de-8825-4ab3-9721-cf99694fb787
;;; templates.scm ends here
guile-lib-0.2.2/src/sxml/transform.scm 0000644 0001750 0001750 00000026050 11573632156 014612 0000000 0000000 ;; (sxml transform) -- pre- and post-order sxml transformation
;; Written 2003 by Oleg Kiselyov as SXML-tree-trans.scm.
;; Modified 2004 by Andy Wingo .
;; This file is in the public domain.
;;; Commentary:
;;
;;@heading SXML expression tree transformers
;
;@subheading Pre-Post-order traversal of a tree and creation of a new tree
;@smallexample
;pre-post-order:: x ->
;@end smallexample
; where
;@smallexample
; ::= ( ...)
; ::= ( *preorder* . ) |
; ( *macro* . ) |
; ( . ) |
; ( . )
; ::= XMLname | *text* | *default*
; :: x [] ->
;@end smallexample
;
; The pre-post-order function visits the nodes and nodelists
; pre-post-order (depth-first). For each @code{} of the form
; @code{(@var{name} ...)}, it looks up an association with the
; given @var{name} among its @var{}. If failed,
; @code{pre-post-order} tries to locate a @code{*default*} binding. It's
; an error if the latter attempt fails as well. Having found a binding,
; the @code{pre-post-order} function first checks to see if the binding
; is of the form
;@smallexample
; ( *preorder* . )
;@end smallexample
;
; If it is, the handler is 'applied' to the current node. Otherwise, the
; pre-post-order function first calls itself recursively for each child
; of the current node, with @var{} prepended to the
; @var{} in effect. The result of these calls is passed to the
; @var{} (along with the head of the current @var{}). To
; be more precise, the handler is _applied_ to the head of the current
; node and its processed children. The result of the handler, which
; should also be a @code{}, replaces the current @var{}. If
; the current @var{} is a text string or other atom, a special
; binding with a symbol @code{*text*} is looked up.
;
; A binding can also be of a form
;@smallexample
; ( *macro* . )
;@end smallexample
; This is equivalent to @code{*preorder*} described above. However, the
; result is re-processed again, with the current stylesheet.
;;
;;; Code:
(define-module (sxml transform)
#:export (SRV:send-reply
foldts
post-order
pre-post-order
replace-range))
;; Upstream version:
; $Id: SXML-tree-trans.scm,v 1.8 2003/04/24 19:39:53 oleg Exp oleg $
; Like let* but allowing for multiple-value bindings
(define-macro (let*-values bindings . body)
(if (null? bindings) (cons 'begin body)
(apply
(lambda (vars initializer)
(let ((cont
(cons 'let*-values
(cons (cdr bindings) body))))
(cond
((not (pair? vars)) ; regular let case, a single var
`(let ((,vars ,initializer)) ,cont))
((null? (cdr vars)) ; single var, see the prev case
`(let ((,(car vars) ,initializer)) ,cont))
(else ; the most generic case
`(call-with-values (lambda () ,initializer)
(lambda ,vars ,cont))))))
(car bindings))))
(define (SRV:send-reply . fragments)
"Output the @var{fragments} to the current output port.
The fragments are a list of strings, characters, numbers, thunks,
@code{#f}, @code{#t} -- and other fragments. The function traverses the
tree depth-first, writes out strings and characters, executes thunks,
and ignores @code{#f} and @code{'()}. The function returns @code{#t} if
anything was written at all; otherwise the result is @code{#f} If
@code{#t} occurs among the fragments, it is not written out but causes
the result of @code{SRV:send-reply} to be @code{#t}."
(let loop ((fragments fragments) (result #f))
(cond
((null? fragments) result)
((not (car fragments)) (loop (cdr fragments) result))
((null? (car fragments)) (loop (cdr fragments) result))
((eq? #t (car fragments)) (loop (cdr fragments) #t))
((pair? (car fragments))
(loop (cdr fragments) (loop (car fragments) result)))
((procedure? (car fragments))
((car fragments))
(loop (cdr fragments) #t))
(else
(display (car fragments))
(loop (cdr fragments) #t)))))
;------------------------------------------------------------------------
; Traversal of an SXML tree or a grove:
; a or a
;
; A and a are mutually-recursive datatypes that
; underlie the SXML tree:
; ::= (name . ) | "text string"
; An (ordered) set of nodes is just a list of the constituent nodes:
; ::= ( ...)
; Nodelists, and Nodes other than text strings are both lists. A
; however is either an empty list, or a list whose head is
; not a symbol (an atom in general). A symbol at the head of a node is
; either an XML name (in which case it's a tag of an XML element), or
; an administrative name such as '@'.
; See SXPath.scm and SSAX.scm for more information on SXML.
;; see the commentary for docs
(define (pre-post-order tree bindings)
(let* ((default-binding (assq '*default* bindings))
(text-binding (or (assq '*text* bindings) default-binding))
(text-handler ; Cache default and text bindings
(and text-binding
(if (procedure? (cdr text-binding))
(cdr text-binding) (cddr text-binding)))))
(let loop ((tree tree))
(cond
((null? tree) '())
((not (pair? tree))
(let ((trigger '*text*))
(if text-handler (text-handler trigger tree)
(error "Unknown binding for " trigger " and no default"))))
((not (symbol? (car tree))) (map loop tree)) ; tree is a nodelist
(else ; tree is an SXML node
(let* ((trigger (car tree))
(binding (or (assq trigger bindings) default-binding)))
(cond
((not binding)
(error "Unknown binding for " trigger " and no default"))
((not (pair? (cdr binding))) ; must be a procedure: handler
(apply (cdr binding) trigger (map loop (cdr tree))))
((eq? '*preorder* (cadr binding))
(apply (cddr binding) tree))
((eq? '*macro* (cadr binding))
(loop (apply (cddr binding) tree)))
(else ; (cadr binding) is a local binding
(apply (cddr binding) trigger
(pre-post-order (cdr tree) (append (cadr binding) bindings)))
))))))))
; post-order is a strict subset of pre-post-order without *preorder*
; (let alone *macro*) traversals.
; Now pre-post-order is actually faster than the old post-order.
; The function post-order is deprecated and is aliased below for
; backward compatibility.
(define post-order pre-post-order)
;------------------------------------------------------------------------
; Extended tree fold
; tree = atom | (node-name tree ...)
;
; foldts fdown fup fhere seed (Leaf str) = fhere seed str
; foldts fdown fup fhere seed (Nd kids) =
; fup seed $ foldl (foldts fdown fup fhere) (fdown seed) kids
; procedure fhere: seed -> atom -> seed
; procedure fdown: seed -> node -> seed
; procedure fup: parent-seed -> last-kid-seed -> node -> seed
; foldts returns the final seed
(define (foldts fdown fup fhere seed tree)
(cond
((null? tree) seed)
((not (pair? tree)) ; An atom
(fhere seed tree))
(else
(let loop ((kid-seed (fdown seed tree)) (kids (cdr tree)))
(if (null? kids)
(fup seed kid-seed tree)
(loop (foldts fdown fup fhere kid-seed (car kids))
(cdr kids)))))))
;------------------------------------------------------------------------
; Traverse a forest depth-first and cut/replace ranges of nodes.
;
; The nodes that define a range don't have to have the same immediate
; parent, don't have to be on the same level, and the end node of a
; range doesn't even have to exist. A replace-range procedure removes
; nodes from the beginning node of the range up to (but not including)
; the end node of the range. In addition, the beginning node of the
; range can be replaced by a node or a list of nodes. The range of
; nodes is cut while depth-first traversing the forest. If all
; branches of the node are cut a node is cut as well. The procedure
; can cut several non-overlapping ranges from a forest.
; replace-range:: BEG-PRED x END-PRED x FOREST -> FOREST
; where
; type FOREST = (NODE ...)
; type NODE = Atom | (Name . FOREST) | FOREST
;
; The range of nodes is specified by two predicates, beg-pred and end-pred.
; beg-pred:: NODE -> #f | FOREST
; end-pred:: NODE -> #f | FOREST
; The beg-pred predicate decides on the beginning of the range. The node
; for which the predicate yields non-#f marks the beginning of the range
; The non-#f value of the predicate replaces the node. The value can be a
; list of nodes. The replace-range procedure then traverses the tree and skips
; all the nodes, until the end-pred yields non-#f. The value of the end-pred
; replaces the end-range node. The new end node and its brothers will be
; re-scanned.
; The predicates are evaluated pre-order. We do not descend into a node that
; is marked as the beginning of the range.
(define (replace-range beg-pred end-pred forest)
; loop forest keep? new-forest
; forest is the forest to traverse
; new-forest accumulates the nodes we will keep, in the reverse
; order
; If keep? is #t, keep the curr node if atomic. If the node is not atomic,
; traverse its children and keep those that are not in the skip range.
; If keep? is #f, skip the current node if atomic. Otherwise,
; traverse its children. If all children are skipped, skip the node
; as well.
(define (loop forest keep? new-forest)
(if (null? forest) (values (reverse new-forest) keep?)
(let ((node (car forest)))
(if keep?
(cond ; accumulate mode
((beg-pred node) => ; see if the node starts the skip range
(lambda (repl-branches) ; if so, skip/replace the node
(loop (cdr forest) #f
(append (reverse repl-branches) new-forest))))
((not (pair? node)) ; it's an atom, keep it
(loop (cdr forest) keep? (cons node new-forest)))
(else
(let*-values
(((node?) (symbol? (car node))) ; or is it a nodelist?
((new-kids keep?) ; traverse its children
(loop (if node? (cdr node) node) #t '())))
(loop (cdr forest) keep?
(cons
(if node? (cons (car node) new-kids) new-kids)
new-forest)))))
; skip mode
(cond
((end-pred node) => ; end the skip range
(lambda (repl-branches) ; repl-branches will be re-scanned
(loop (append repl-branches (cdr forest)) #t
new-forest)))
((not (pair? node)) ; it's an atom, skip it
(loop (cdr forest) keep? new-forest))
(else
(let*-values
(((node?) (symbol? (car node))) ; or is it a nodelist?
((new-kids keep?) ; traverse its children
(loop (if node? (cdr node) node) #f '())))
(loop (cdr forest) keep?
(if (or keep? (pair? new-kids))
(cons
(if node? (cons (car node) new-kids) new-kids)
new-forest)
new-forest) ; if all kids are skipped
)))))))) ; skip the node too
(let*-values (((new-forest keep?) (loop forest #t '())))
new-forest))
;;; arch-tag: 6c814f4b-38f7-42c1-b8ef-ce3447edefc7
;;; transform.scm ends here
guile-lib-0.2.2/src/graph/ 0000755 0001750 0001750 00000000000 12102442377 012257 5 0000000 0000000 guile-lib-0.2.2/src/graph/topological-sort.scm 0000644 0001750 0001750 00000005531 11573632155 016216 0000000 0000000 ;; (graph topological-sort) -- topological sorting
;; Written 1995 by Mikael Durfeldt.
;; This file is based on tsort.scm from SLIB, and is in the public domain.
;;; Commentary:
;; The algorithm is inspired by Cormen, Leiserson and Rivest (1990)
;; ``Introduction to Algorithms'', chapter 23.
;;; Code:
(define-module (graph topological-sort)
#:export (topological-sort
topological-sortq
topological-sortv)
#:use-module (math primes))
(define (topological-sort-helper dag insert lookup)
(if (null? dag)
'()
(let* ((adj-table (make-hash-table
(car (primes> (length dag) 1))))
(sorted '()))
(letrec ((visit
(lambda (u adj-list)
;; Color vertex u
(insert adj-table u 'colored)
;; Visit uncolored vertices which u connects to
(for-each (lambda (v)
(let ((val (lookup adj-table v)))
(if (not (eq? val 'colored))
(visit v (or val '())))))
adj-list)
;; Since all vertices downstream u are visited
;; by now, we can safely put u on the output list
(set! sorted (cons u sorted)))))
;; Hash adjacency lists
(for-each (lambda (def)
(insert adj-table (car def) (cdr def)))
(cdr dag))
;; Visit vertices
(visit (caar dag) (cdar dag))
(for-each (lambda (def)
(let ((val (lookup adj-table (car def))))
(if (not (eq? val 'colored))
(visit (car def) (cdr def)))))
(cdr dag)))
sorted)))
(define (topological-sort dag)
"Returns a list of the objects in the directed acyclic graph, @var{dag}, topologically sorted. Objects are
compared using @code{equal?}. The graph has the form:
@lisp
(list (obj1 . (dependents-of-obj1))
(obj2 . (dependents-of-obj2)) ...)
@end lisp
...specifying, for example, that @code{obj1} must come before all the objects in @code{(dependents-of-obj1)} in
the sort."
(topological-sort-helper dag hash-set! hash-ref))
(define (topological-sortq dag)
"Returns a list of the objects in the directed acyclic graph, @var{dag}, topologically sorted. Objects are
compared using @code{eq?}. The graph has the form:
@lisp
(list (obj1 . (dependents-of-obj1))
(obj2 . (dependents-of-obj2)) ...)
@end lisp
...specifying, for example, that @code{obj1} must come before all the objects in @code{(dependents-of-obj1)} in
the sort."
(topological-sort-helper dag hashq-set! hashq-ref))
(define (topological-sortv dag)
"Returns a list of the objects in the directed acyclic graph, @var{dag}, topologically sorted. Objects are
compared using @code{eqv?}. The graph has the form:
@lisp
(list (obj1 . (dependents-of-obj1))
(obj2 . (dependents-of-obj2)) ...)
@end lisp
...specifying, for example, that @code{obj1} must come before all the objects in @code{(dependents-of-obj1)} in
the sort."
(topological-sort-helper dag hashv-set! hashv-ref))
;;; arch-tag: 9ef30b53-688a-43fc-b208-df78d5b38c74
guile-lib-0.2.2/src/htmlprag.scm 0000644 0001750 0001750 00000304017 11573632156 013434 0000000 0000000 ;; (htmlprag) -- pragmatic parsing of real-world HTML
;; Copyright (C) 2003-2004 Neil W. Van Dyke
;; Modified 2004 by Andy Wingo to fit in with guile-lib.
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU Lesser General Public License as
;; published by the Free Software Foundation, either version 3 of the
;; License, or (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this program. If not, see
;; .
;; The license of the code that this is based on, when it came from Neil
;; W. Van Dyke, was the LGPL version 2.1. Neil notes that other
;; licensing options for his code are available; interested parties
;; should contact him directly.
;;; Commentary:
;;
;;; HtmlPrag provides permissive HTML parsing capability to Scheme programs,
;;; which is useful for software agent extraction of information from Web
;;; pages, for programmatically transforming HTML files, and for implementing
;;; interactive Web browsers. HtmlPrag emits ``SHTML,'' which is an encoding
;;; of HTML in [SXML], so that conventional HTML may be processed with XML
;;; tools such as [SXPath] and [SXML-Tools]. Like [SSAX-HTML], HtmlPrag
;;; provides a permissive tokenizer, but also attempts to recover structure.
;;; HtmlPrag also includes procedures for encoding SHTML in HTML syntax.
;;;
;;; The HtmlPrag parsing behavior is permissive in that it accepts erroneous
;;; HTML, handling several classes of HTML syntax errors gracefully, without
;;; yielding a parse error. This is crucial for parsing arbitrary real-world
;;; Web pages, since many pages actually contain syntax errors that would
;;; defeat a strict or validating parser. HtmlPrag's handling of errors is
;;; intended to generally emulate popular Web browsers' interpretation of the
;;; structure of erroneous HTML. We euphemistically term this kind of parse
;;; ``pragmatic.''
;;;
;;; HtmlPrag also has some support for [XHTML], although XML namespace
;;; qualifiers [XML-Names] are currently accepted but stripped from the
;;; resulting SHTML. Note that valid XHTML input is of course better handled
;;; by a validating XML parser like [SSAX].
;;;
;;; To receive notification of new versions of HtmlPrag, and to be polled for
;;; input on changes to HtmlPrag being considered, ask the author to add you to
;;; the moderated, announce-only email list, @code{htmlprag-announce}.
;;;
;;; Thanks to Oleg Kiselyov and Kirill Lisovsky for their help with SXML.
;;
;;; Code:
(define-module (htmlprag))
;; Exports defined at the end of the file
;; THIS FILE GENERATED Thu May 13 21:41:40 EDT 2004 -- DO NOT EDIT MANUALLY
;; ############# BEGIN CANONICAL htmlprag.scm #############
;;; @Package HtmlPrag
;;; @Subtitle Pragmatic Parsing of HTML to SHTML and SXML
;;; @HomePage http://www.neilvandyke.org/htmlprag/
;;; @Author Neil W. Van Dyke
;;; @AuthorEmail neil@@neilvandyke.org
;;; @Version 0.11
;;; @Date 13 May 2004
;; $Id: htmlprag.scm,v 1.304 2004/05/14 01:28:51 neil Exp $
;;; @legal
;;; Copyright @copyright{} 2003-2004 Neil W. Van Dyke. This program is Free
;;; Software; you can redistribute it and/or modify it under the terms of the
;;; GNU Lesser General Public License as published by the Free Software
;;; Foundation; either version 2.1 of the License, or (at your option) any
;;; later version. This program is distributed in the hope that it will be
;;; useful, but without any warranty; without even the implied warranty of
;;; merchantability or fitness for a particular purpose. See the GNU Lesser
;;; General Public License [LGPL] for more details. For other license options
;;; and commercial consulting, contact the author.
;;; @end legal
;;; @section Introduction
;;; HtmlPrag provides permissive HTML parsing capability to Scheme programs,
;;; which is useful for software agent extraction of information from Web
;;; pages, for programmatically transforming HTML files, and for implementing
;;; interactive Web browsers. HtmlPrag emits ``SHTML,'' which is an encoding
;;; of HTML in [SXML], so that conventional HTML may be processed with XML
;;; tools such as [SXPath] and [SXML-Tools]. Like [SSAX-HTML], HtmlPrag
;;; provides a permissive tokenizer, but also attempts to recover structure.
;;; HtmlPrag also includes procedures for encoding SHTML in HTML syntax.
;;;
;;; The HtmlPrag parsing behavior is permissive in that it accepts erroneous
;;; HTML, handling several classes of HTML syntax errors gracefully, without
;;; yielding a parse error. This is crucial for parsing arbitrary real-world
;;; Web pages, since many pages actually contain syntax errors that would
;;; defeat a strict or validating parser. HtmlPrag's handling of errors is
;;; intended to generally emulate popular Web browsers' interpretation of the
;;; structure of erroneous HTML. We euphemistically term this kind of parse
;;; ``pragmatic.''
;;;
;;; HtmlPrag also has some support for [XHTML], although XML namespace
;;; qualifiers [XML-Names] are currently accepted but stripped from the
;;; resulting SHTML. Note that valid XHTML input is of course better handled
;;; by a validating XML parser like [SSAX].
;;;
;;; To receive notification of new versions of HtmlPrag, and to be polled for
;;; input on changes to HtmlPrag being considered, ask the author to add you to
;;; the moderated, announce-only email list, @code{htmlprag-announce}.
;;;
;;; Thanks to Oleg Kiselyov and Kirill Lisovsky for their help with SXML.
;;; @section Portability
;;; HtmlPrag officially requires R5RS, [SRFI-6], and [SRFI-23], but is known to
;;; also work on some non-R5RS implementations. The current version tests
;;; successfully under Bigloo 2.6d, Chicken 1.22, Gauche 0.7.4.2, Guile 1.6.4,
;;; MIT Scheme 7.7.90, PLT MzScheme 206p1, RScheme 0.7.3.3-b20, SISC 1.8.7
;;; (using Kaffe 1.1.4), and STklos 0.55. With a minor change to the source
;;; code, HtmlPrag also tests successfully under Scheme 48 0.57 and Scsh 0.6.3.
;;;
;;; Kawa has been removed temporarily from the test list, but should run if
;;; Sun's Java implementation can be used. SXM has removed temporarily from
;;; the test list, until the test suite code can be adjusted to not exceed
;;; SXM's limit on literals.
;; TODO: Note about packagings.
;;
;; Some packagings of HtmlPrag for particular Scheme implementations are
;; available from the HtmlPrag Web page and elsewhere.
;; TODO: Note conventional prefix option with module systems that support it.
;;
;; @lisp
;; (require (prefix htmlprag: (lib "htmlprag.ss" "htmlprag")))
;; @end lisp
;;; In addition to the documented public bindings, the HtmlPrag source code
;;; includes some internal-use-only toplevel bindings. The names of these
;;; begin with the ``@code{htmlprag-internal:}'' prefix. Packagings of
;;; HtmlPrag for particular Scheme implementations should suppress these
;;; bindings from export when possible.
;; The following bindings are used internally by HtmlPrag for portability,
;; with the intention that packagings of HtmlPrag use faster or more
;; appropriate bindings for the particular Scheme implementation.
;; @defproc htmlprag-internal:a2c num
;;
;; Returns the character with ASCII value @var{num}. In most Scheme
;; implementations, this is the same as @code{integer->char}. Two exceptions
;; are Scheme 48 0.57 and Scsh 0.6.3, for which the user must manually edit
;; file @code{htmlprag.scm} to bind this variable to @code{ascii->char}. A
;; future version of HtmlPrag will automatically use @code{ascii->char} where
;; available.
(define htmlprag-internal:a2c integer->char)
;; @defproc htmlprag-internal:append! a b
;;
;; Returns a concatenation of lists @var{a} and @var{b}, modifying the tail of
;; @var{a} to point to the head of @var{b} if both lists are non-null. A
;; future version should use the more general @code{append!} where available.
(define (htmlprag-internal:append! a b)
(cond ((null? a) b)
((null? b) a)
(else (let loop ((sub a))
(if (null? (cdr sub))
(begin (set-cdr! sub b)
a)
(loop (cdr sub)))))))
;; @defproc htmlprag-internal:reverse!ok lst
;;
;; Returns a reversed list @var{lst}, possibly destructive. A future version
;; will use @code{reverse!} where available, and @code{reverse} elsewhere.
(define htmlprag-internal:reverse!ok reverse)
;; @defproc htmlprag-internal:down str
;;
;; Returns a string that is equivalent to @var{str} with all characters mapped
;; to lowercase, as if by @code{char-downcase}, without mutating @var{str}. A
;; future version should use the Scheme implementation's native nondestructive
;; procedure where available.
(define (htmlprag-internal:down s)
(list->string (map char-downcase (string->list s))))
;; @defproc htmlprag-internal:error proc-str msg obj
;;
;; For Bigloo, this is changed to:
;;
;; @lisp
;; (define htmlprag-internal:error error)
;; @end lisp
(define (htmlprag-internal:error p m o) (error (string-append p " - " m) o))
;; TODO: Make htmlprag-internal:error be syntax.
;; @defproc htmlprag-internal:down!ok str
;;
;; Returns a string that is equivalent to @var{str} with all characters mapped
;; to lowercase, as if by @code{char-downcase}, possibly mutating @var{str}.
;; A future version should use the Scheme implementation's native destructive
;; or nondestructive procedure where available.
(define htmlprag-internal:down!ok htmlprag-internal:down)
;; @defproc htmlprag-internal:gosc os
;;
;; One-shot version of the conventional @code{get-output-string}. The result
;; of any subsequent attempt to write to the port or get the output string is
;; undefined. This may or may not free up resources.
(define (htmlprag-internal:gosc os)
(let ((str (get-output-string os)))
;; Note: By default, we don't call close-output-port, since at least one
;; tested Scheme implementation barfs on that.
;;
;; (close-output-port os)
str))
;; @defvar htmlprag-internal:at
;;
;; Constant bound to the symbol @code{@@}. This is to make code portable to
;; Scheme implementations with readers that cannot read @code{@@} as a symbol.
;; (Actually, RScheme can now read @code{@@}, which leaves Stalin as the only
;; one the author knows of, so we'll probably go back to just using literal
;; @code{@@} symbols.
(define htmlprag-internal:at (string->symbol "@"))
;;; @section SHTML and SXML
;; TODO: Introduce SHTML.
;;; Some constants and a procedure are defined for convenience and portability
;;; when examining the SHTML produced by the tokenizer and parser.
;;; @defvar shtml-comment-symbol
;;; @defvarx shtml-decl-symbol
;;; @defvarx shtml-empty-symbol
;;; @defvarx shtml-end-symbol
;;; @defvarx shtml-entity-symbol
;;; @defvarx shtml-pi-symbol
;;; @defvarx shtml-start-symbol
;;; @defvarx shtml-text-symbol
;;; @defvarx shtml-top-symbol
;;;
;;; These variables are bound to the following case-sensitive symbols used in
;;; SHTML, respectively: @code{*COMMENT*}, @code{*DECL*}, @code{*EMPTY*},
;;; @code{*END*}, @code{*ENTITY*}, @code{*PI*}, @code{*START*}, @code{*TEXT*},
;;; and @code{*TOP*}. These can be used in lieu of the literal symbols in
;;; programs read by a case-insensitive Scheme reader.
(define shtml-comment-symbol (string->symbol "*COMMENT*"))
(define shtml-decl-symbol (string->symbol "*DECL*"))
(define shtml-empty-symbol (string->symbol "*EMPTY*"))
(define shtml-end-symbol (string->symbol "*END*"))
(define shtml-entity-symbol (string->symbol "*ENTITY*"))
(define shtml-pi-symbol (string->symbol "*PI*"))
(define shtml-start-symbol (string->symbol "*START*"))
(define shtml-text-symbol (string->symbol "*TEXT*"))
(define shtml-top-symbol (string->symbol "*TOP*"))
;;; @defvar shtml-named-char-id
;;; @defvarx shtml-numeric-char-id
;;;
;;; These variables are bound to the SHTML entity public identifier strings
;;; for symbolic and numeric character entities. These strings are currently
;;; @code{"additional"} and @code{"additional-char"}, respectively, but are
;;; likely to change in a future version of HtmlPrag, so programs should use
;;; the bindings rather than the literal strings directly.
(define shtml-named-char-id "additional")
(define shtml-numeric-char-id "additional-char")
;; TODO: Make public procedures for creating character entities, since the
;; current SHTML syntax for them is pretty nasty.
;;; @defproc shtml-entity-value entity
;;;
;;; Yields the value for the SHTML entity. Values of named entities are
;;; symbols, and values of numeric entities are numbers. For example:
;;;
;;; @lisp
;;; (define (f s) (shtml-entity-value (car (cdr (html->shtml s)))))
;;; (f " ") @result{} nbsp
;;; (f "ߐ") @result{} 2000
;;; @end lisp
(define (shtml-entity-value entity)
(if (and (list? entity)
(= (length entity) 3)
(eqv? (car entity) shtml-entity-symbol))
(let ((public-id (list-ref entity 1))
(system-id (list-ref entity 2)))
(cond ((equal? public-id shtml-named-char-id)
(string->symbol system-id))
((equal? public-id shtml-numeric-char-id)
(string->number system-id))
(else (htmlprag-internal:error "shtml-entity-value"
"invalid entity public id"
public-id))))
(htmlprag-internal:error "shtml-entity-value"
"not an entity"
entity)))
;;; @section Tokenizing
;;; The tokenizer is used by the higher-level structural parser, but can also
;;; be called directly for debugging purposes or unusual applications. Some of
;;; the list structure of tokens, such as for start tag tokens, is mutated and
;;; incorporated into the SHTML list structure emitted by the parser.
;; TODO: Document the token format.
;;; @defproc make-html-tokenizer in normalized?
;;;
;;; Constructs an HTML tokenizer procedure on input port @var{in}. If boolean
;;; @var{normalized?} is true, then tokens will be in a format conducive to use
;;; with a parser emitting normalized SXML. Each call to the resulting
;;; procedure yields a successive token from the input. When the tokens have
;;; been exhausted, the procedure returns the null list. For example:
;;;
;;; @lisp
;;; (define input (open-input-string "bar"))
;;; (define next (make-html-tokenizer input #f))
;;; (next) @result{} (a (@@ (href "foo")))
;;; (next) @result{} "bar"
;;; (next) @result{} (*END* a)
;;; (next) @result{} ()
;;; (next) @result{} ()
;;; @end lisp
(define make-html-tokenizer
;; TODO: Have the tokenizer replace contiguous whitespace within individual
;; text tokens with single space characters (except for when in `pre'
;; and verbatim elements). The parser will introduce new contiguous
;; whitespace (e.g., when text tokens are concatenated, invalid end
;; tags are removed, whitespace is irrelevant between certain
;; elements), but then the parser only has to worry about the first and
;; last character of each string. Perhaps the text tokens should have
;; both leading and trailing whitespace stripped, and contain flags for
;; whether or not leading and trailing whitespace occurred.
(letrec ((no-token '())
;; TODO: Maybe make this an option.
(verbatim-to-eof-elems '(plaintext))
;; TODO: Implement proper parsing of `verbatim-pair-elems' elements.
;; Note that we must support invalid termination like this:
(verbatim-pair-elems '(script server style xmp))
(ws-chars (list #\space
(htmlprag-internal:a2c 9)
(htmlprag-internal:a2c 10)
(htmlprag-internal:a2c 11)
(htmlprag-internal:a2c 12)
(htmlprag-internal:a2c 13)))
(output-string->string-or-false
(lambda (os)
(let ((s (htmlprag-internal:gosc os)))
(if (string=? s "") #f s))))
(output-string->symbol-or-false
(lambda (os)
(let ((s (output-string->string-or-false os)))
(if s (string->symbol s) #f))))
)
(lambda (in normalized?)
;; TODO: Make a tokenizer option that causes XML namespace qualifiers to
;; be ignored.
(letrec
(
;; Port buffer with inexpensive unread of one character and slightly
;; more expensive pushback of second character to unread. The
;; procedures themselves do no consing. The tokenizer currently
;; needs two-symbol lookahead, due to ambiguous "/" while parsing
;; element and attribute names, which could be either empty-tag
;; syntax or XML qualified names.
(c #f)
(next-c #f)
(c-consumed? #t)
(read-c (lambda ()
(if c-consumed?
(if next-c
(begin (set! c next-c)
(set! next-c #f))
(set! c (read-char in)))
(set! c-consumed? #t))))
(unread-c (lambda ()
(if c-consumed?
(set! c-consumed? #f)
;; TODO: Procedure name in error message really
;; isn't "make-html-tokenizer"...
(htmlprag-internal:error "make-html-tokenizer"
"already unread"
c))))
(push-c (lambda (new-c)
(if c-consumed?
(begin (set! c new-c)
(set! c-consumed? #f))
(if next-c
(htmlprag-internal:error
"make-html-tokenizer"
"pushback full"
c)
(begin (set! next-c c)
(set! c new-c)
(set! c-consumed? #f))))))
;; TODO: These procedures are a temporary convenience for
;; enumerating the pertinent character classes, with an eye
;; towards removing redundant tests of character class. These
;; procedures should be eliminated in a future version.
(c-eof? (lambda () (eof-object? c)))
(c-amp? (lambda () (eqv? c #\&)))
(c-apos? (lambda () (eqv? c #\')))
(c-bang? (lambda () (eqv? c #\!)))
(c-colon? (lambda () (eqv? c #\:)))
(c-quot? (lambda () (eqv? c #\")))
(c-equals? (lambda () (eqv? c #\=)))
(c-gt? (lambda () (eqv? c #\>)))
(c-lt? (lambda () (eqv? c #\<)))
(c-minus? (lambda () (eqv? c #\-)))
(c-pound? (lambda () (eqv? c #\#)))
(c-ques? (lambda () (eqv? c #\?)))
(c-semi? (lambda () (eqv? c #\;)))
(c-slash? (lambda () (eqv? c #\/)))
(c-splat? (lambda () (eqv? c #\*)))
(c-lf? (lambda () (eqv? c #\newline)))
(c-angle? (lambda () (memv c '(#\< #\>))))
(c-ws? (lambda () (memv c ws-chars)))
(c-alpha? (lambda () (char-alphabetic? c)))
(c-digit? (lambda () (char-numeric? c)))
(c-alphanum? (lambda () (or (c-alpha?) (c-digit?))))
(c-hexlet? (lambda () (memv c '(#\a #\b #\c #\d #\e #\f
#\A #\B #\C #\D #\E #\F))))
(skip-ws (lambda () (read-c) (if (c-ws?) (skip-ws) (unread-c))))
(make-start-token
(if normalized?
(lambda (name ns attrs)
(list name (cons htmlprag-internal:at attrs)))
(lambda (name ns attrs)
(if (null? attrs)
(list name)
(list name (cons htmlprag-internal:at attrs))))))
(make-empty-token
(lambda (name ns attrs)
(cons shtml-empty-symbol
(make-start-token name ns attrs))))
(make-end-token
(if normalized?
(lambda (name ns attrs)
(list shtml-end-symbol
name
(cons htmlprag-internal:at attrs)))
(lambda (name ns attrs)
(if (null? attrs)
(list shtml-end-symbol name)
(list shtml-end-symbol
name
(cons htmlprag-internal:at attrs))))))
(make-named-char-token
(lambda (name-str)
(list shtml-entity-symbol
shtml-named-char-id
name-str)))
(make-numeric-char-token
(lambda (number)
(list shtml-entity-symbol
shtml-numeric-char-id
(number->string number))))
(make-comment-token
(lambda (str) (list shtml-comment-symbol str)))
(make-decl-token
(lambda (parts) (cons shtml-decl-symbol parts)))
(scan-qname
;; TODO: Make sure we don't accept local names that have "*", since
;; this can break SXML tools. Have to validate this
;; afterwards if "verbatim-safe?". Also check for "@" and
;; maybe "@@". Check qname parsing code, especially for
;; verbatim mode. This is important!
(lambda (verbatim-safe?)
;; Note: If we accept some invalid local names, we only need two
;; symbols of lookahead to determine the end of a qname.
(letrec ((os #f)
(ns '())
(vcolons 0)
(good-os (lambda ()
(or os
(begin (set! os (open-output-string))
os)))))
(let loop ()
(read-c)
(cond ((c-eof?) #f)
((or (c-ws?) (c-splat?))
(if verbatim-safe?
(unread-c)))
((or (c-angle?) (c-equals?) (c-quot?) (c-apos?))
(unread-c))
((c-colon?)
(or (null? ns)
(set! ns (cons ":" ns)))
(if os
(begin
(set! ns (cons (htmlprag-internal:gosc os)
ns))
(set! os #f)))
(loop))
((c-slash?)
(read-c)
(cond ((or (c-eof?)
(c-ws?)
(c-equals?)
(c-apos?)
(c-quot?)
(c-angle?)
(c-splat?))
(unread-c)
(push-c #\/))
(else (write-char #\/ (good-os))
(write-char c os)
(loop))))
(else (write-char c (good-os))
(loop))))
(let ((ns (if (null? ns)
#f
(apply string-append
(htmlprag-internal:reverse!ok ns))))
(local (if os (htmlprag-internal:gosc os) #f)))
(if verbatim-safe?
;; TODO: Make sure we don't have ambiguous ":" or drop
;; any characters!
(cons ns local)
;; Note: We represent "xmlns:" syntax as normal qnames,
;; for lack of something better to do with them when we
;; don't support XML namespaces.
;;
;; TODO: Local names are currently forced to lowercase,
;; since HTML is usually case-insensitive. If XML
;; namespaces are used, we might wish to keep local
;; names case-sensitive.
(if local
(if ns
(if (string=? ns "xmlns")
(string->symbol (string-append ns ":" local))
(cons ns
(string->symbol
(htmlprag-internal:down!ok
local))))
(string->symbol
(htmlprag-internal:down!ok local)))
(if ns
(string->symbol
(htmlprag-internal:down!ok ns))
;; TODO: Ensure that it's OK to return #f as a
;; name.
#f)))))))
(scan-tag
(lambda (start?)
(skip-ws)
(let ((tag-name (scan-qname #f))
(tag-ns #f)
(tag-attrs #f)
(tag-empty? #f))
;; Scan element name.
(if (pair? tag-name)
(begin (set! tag-ns (car tag-name))
(set! tag-name (cdr tag-name))))
;; TODO: Ensure there's no case in which a #f tag-name isn't
;; compensated for later.
;;
;; Scan element attributes.
(set! tag-attrs
(let scan-attr-list ()
(read-c)
(cond ((c-eof?) '())
((c-angle?) (unread-c) '())
((c-slash?)
(set! tag-empty? #t)
(scan-attr-list))
((c-alpha?)
(unread-c)
(let ((attr (scan-attr)))
(cons attr (scan-attr-list))))
(else (scan-attr-list)))))
;; Find ">" or unnatural end.
(let loop ()
(read-c)
(cond ((c-eof?) no-token)
((c-slash?) (set! tag-empty? #t) (loop))
((c-gt?) #f)
((c-ws?) (loop))
(else (unread-c))))
;; Change the tokenizer mode if necessary.
(cond ((not start?) #f)
(tag-empty? #f)
;; TODO: Maybe make one alist lookup here, instead of
;; two.
((memq tag-name verbatim-to-eof-elems)
(set! nexttok verbeof-nexttok))
((memq tag-name verbatim-pair-elems)
(set! nexttok (make-verbpair-nexttok tag-name))))
;; Return a token object.
(if start?
(if tag-empty?
(make-empty-token tag-name tag-ns tag-attrs)
(make-start-token tag-name tag-ns tag-attrs))
(make-end-token tag-name tag-ns tag-attrs)))))
(scan-attr
(lambda ()
(let ((name (scan-qname #f))
(val #f))
(if (pair? name)
(set! name (cdr name)))
(let loop-equals-or-end ()
(read-c)
(cond ((c-eof?) no-token)
((c-ws?) (loop-equals-or-end))
((c-equals?)
(let loop-quote-or-unquoted ()
(read-c)
(cond ((c-eof?) no-token)
((c-ws?) (loop-quote-or-unquoted))
((or (c-apos?) (c-quot?))
(let ((term c))
(set! val (open-output-string))
(let loop-quoted-val ()
(read-c)
(cond ((c-eof?) #f)
((eqv? c term) #f)
(else (write-char c val)
(loop-quoted-val))))))
((c-angle?) (unread-c))
(else
(set! val (open-output-string))
(write-char c val)
(let loop-unquoted-val ()
(read-c)
(cond ((c-eof?) no-token)
((c-apos?) #f)
((c-quot?) #f)
((or (c-ws?) (c-angle?) (c-slash?))
(unread-c))
(else (write-char c val)
(loop-unquoted-val))))))))
(else (unread-c))))
(if normalized?
(list name (if val
(htmlprag-internal:gosc val)
(symbol->string name)))
(if val
(list name (htmlprag-internal:gosc val))
(list name))))))
(scan-comment
;; TODO: Rewrite this to use tail recursion rather than a state
;; variable.
(lambda ()
(let ((os (open-output-string))
(state 'start-minus))
(let loop ()
(read-c)
(cond ((c-eof?) #f)
((c-minus?)
(set! state
(case state
((start-minus) 'start-minus-minus)
((start-minus-minus body) 'end-minus)
((end-minus) 'end-minus-minus)
((end-minus-minus)
(write-char #\- os)
state)
(else (htmlprag-internal:error
"make-html-tokenizer"
"invalid state"
state))))
(loop))
((and (c-gt?) (eq? state 'end-minus-minus)) #f)
(else (case state
((end-minus) (write-char #\- os))
((end-minus-minus) (display "--" os)))
(set! state 'body)
(write-char c os)
(loop))))
(make-comment-token (htmlprag-internal:gosc os)))))
(scan-pi
(lambda ()
(skip-ws)
(let ((name (open-output-string))
(val (open-output-string)))
(let scan-name ()
(read-c)
(cond ((c-eof?) #f)
((c-ws?) #f)
((c-alpha?) (write-char c name) (scan-name))
(else (unread-c))))
;; TODO: Do we really want to emit #f for PI name?
(set! name (output-string->symbol-or-false name))
(let scan-val ()
(read-c)
(cond ((c-eof?) #f)
;; ((c-amp?) (display (scan-entity) val)
;; (scan-val))
((c-ques?)
(read-c)
(cond ((c-eof?) (write-char #\? val))
((c-gt?) #f)
(else (write-char #\? val)
(unread-c)
(scan-val))))
(else (write-char c val) (scan-val))))
(list shtml-pi-symbol
name
(htmlprag-internal:gosc val)))))
(scan-decl
;; TODO: Find if SXML includes declaration forms, and if so,
;; use whatever format SXML wants.
;;
;; TODO: Rewrite to eliminate state variables.
(letrec
((scan-parts
(lambda ()
(let ((part (open-output-string))
(nonsymbol? #f)
(state 'before)
(last? #f))
(let loop ()
(read-c)
(cond ((c-eof?) #f)
((c-ws?)
(case state
((before) (loop))
((quoted) (write-char c part) (loop))))
((and (c-gt?) (not (eq? state 'quoted)))
(set! last? #t))
((and (c-lt?) (not (eq? state 'quoted)))
(unread-c))
((c-quot?)
(case state
((before) (set! state 'quoted) (loop))
((unquoted) (unread-c))
((quoted) #f)))
(else
(if (eq? state 'before)
(set! state 'unquoted))
(set! nonsymbol? (or nonsymbol?
(not (c-alphanum?))))
(write-char c part)
(loop))))
(set! part (htmlprag-internal:gosc part))
(if (string=? part "")
'()
(cons (if (or (eq? state 'quoted) nonsymbol?)
part
;; TODO: Normalize case of things we make
;; into symbols here.
(string->symbol part))
(if last?
'()
(scan-parts))))))))
(lambda () (make-decl-token (scan-parts)))))
(scan-entity
(lambda ()
(read-c)
(cond ((c-eof?) "&")
((c-alpha?)
;; TODO: Do entity names have a maximum length?
(let ((name (open-output-string)))
(write-char c name)
(let loop ()
(read-c)
(cond ((c-eof?) #f)
((c-alpha?) (write-char c name) (loop))
((c-semi?) #f)
(else (unread-c))))
(set! name (htmlprag-internal:gosc name))
;; TODO: Make the entity map an option.
(let ((pair (assoc name '(("amp" . "&")
("apos" . "'")
("gt" . ">")
("lt" . "<")
("quot" . "\"")))))
(if pair
(cdr pair)
(make-named-char-token name)))))
((c-pound?)
(let ((num (open-output-string))
(hex? #f))
(read-c)
(cond ((c-eof?) #f)
((memv c '(#\x #\X)) (set! hex? #t) (read-c)))
(let loop ()
(cond ((c-eof?) #f)
((c-semi?) #f)
((or (c-digit?) (and hex? (c-hexlet?)))
(write-char c num)
(read-c)
(loop))
(else (unread-c))))
(set! num (htmlprag-internal:gosc num))
(if (string=? num "")
""
(let ((n (string->number num (if hex? 16 10))))
(if (and (<= 32 n 255) (not (= n 127)))
(string (htmlprag-internal:a2c n))
(make-numeric-char-token n))))))
(else (unread-c) "&"))))
(normal-nexttok
(lambda ()
(read-c)
(cond ((c-eof?) no-token)
((c-lt?)
(let loop ()
(read-c)
(cond ((c-eof?) "<")
((c-ws?) (loop))
((c-slash?) (scan-tag #f))
((c-ques?) (scan-pi))
((c-bang?) (let loop ()
(read-c)
(cond ((c-eof?) no-token)
((c-ws?) (loop))
((c-minus?) (scan-comment))
(else (unread-c)
(scan-decl)))))
((c-alpha?) (unread-c) (scan-tag #t))
(else (unread-c) "<"))))
((c-gt?) ">")
(else (let ((os (open-output-string)))
(let loop ()
(cond ((c-eof?) #f)
((c-angle?) (unread-c))
((c-amp?)
(let ((entity (scan-entity)))
(if (string? entity)
(begin (display entity os)
(read-c)
(loop))
(let ((saved-nexttok nexttok))
(set! nexttok
(lambda ()
(set! nexttok
saved-nexttok)
entity))))))
(else (write-char c os)
(or (c-lf?)
(begin (read-c) (loop))))))
(let ((text (htmlprag-internal:gosc os)))
(if (equal? text "")
(nexttok)
text)))))))
(verbeof-nexttok
(lambda ()
(read-c)
(if (c-eof?)
no-token
(let ((os (open-output-string)))
(let loop ()
(or (c-eof?)
(begin (write-char c os)
(or (c-lf?)
(begin (read-c) (loop))))))
(htmlprag-internal:gosc os)))))
(make-verbpair-nexttok
(lambda (elem-name)
(lambda ()
(let ((os (open-output-string)))
;; Accumulate up to a newline-terminated line.
(let loop ()
(read-c)
(cond ((c-eof?)
;; Got EOF in verbatim context, so set the normal
;; nextok procedure, then fall out of loop.
(set! nexttok normal-nexttok))
((c-lt?)
;; Got "<" in verbatim context, so get next
;; character.
(read-c)
(cond ((c-eof?)
;; Got "<" then EOF, so set to the normal
;; nexttok procedure, add the "<" to the
;; verbatim string, and fall out of loop.
(set! nexttok normal-nexttok)
(write-char #\< os))
((c-slash?)
;; Got "", so...
(read-c)
(cond
((c-eof?)
(display "" os))
((c-alpha?)
;; Got "" followed by alpha, so unread
;; the alpha, scan qname, compare...
(unread-c)
(let* ((vqname (scan-qname #t))
(ns (car vqname))
(local (cdr vqname)))
;; Note: We ignore XML namespace
;; qualifier for purposes of comparison.
;;
;; Note: We're interning strings here for
;; comparison when in theory there could
;; be many such unique interned strings
;; in a valid HTML document, although in
;; practice this should not be a problem.
(if (and local
(eqv? (string->symbol
(htmlprag-internal:down
local))
elem-name))
;; This is the terminator tag, so
;; scan to the end of it, set the
;; nexttok, and fall out of the loop.
(begin
(let scan-to-end ()
(read-c)
(cond ((c-eof?) #f)
((c-gt?) #f)
((c-lt?) (unread-c))
((c-alpha?)
(unread-c)
;; Note: This is an
;; expensive way to skip
;; over an attribute, but
;; in practice more
;; verbatim end tags will
;; not have attributes.
(scan-attr)
(scan-to-end))
(else (scan-to-end))))
(set! nexttok
(lambda ()
(set! nexttok
normal-nexttok)
(make-end-token
elem-name #f '()))))
;; This isn't the terminator tag, so
;; add to the verbatim string the
;; "" and the characters of what we
;; were scanning as a qname, and
;; recurse in the loop.
(begin
(display "" os)
(if ns
(begin (display ns os)
(display ":" os)))
(if local
(display local os))
(loop)))))
(else
;; Got "" and non-alpha, so unread new
;; character, add the "" to verbatim
;; string, then loop.
(unread-c)
(display "" os)
(loop))))
(else
;; Got "<" and non-slash, so unread the new
;; character, write the "<" to the verbatim
;; string, then loop.
(unread-c)
(write-char #\< os)
(loop))))
(else
;; Got non-"<" in verbatim context, so just add it
;; to the buffer, then, if it's not a linefeed, fall
;; out of the loop so that the token can be
;; returned.
(write-char c os)
(or (c-lf?) (loop)))))
;; Return the accumulated line string, if non-null, or call
;; nexttok.
(or (output-string->string-or-false os) (nexttok))))))
(nexttok #f))
(set! nexttok normal-nexttok)
(lambda () (nexttok))))))
;;; @defproc tokenize-html in normalized?
;;;
;;; Returns a list of tokens from input port @var{in}, normalizing according to
;;; boolean @var{normalized?}. This is probably most useful as a debugging
;;; convenience. For example:
;;;
;;; @lisp
;;; (tokenize-html (open-input-string "bar") #f)
;;; @result{} ((a (@@ (href "foo"))) "bar" (*END* a))
;;; @end lisp
(define (tokenize-html in normalized?)
(let ((next-tok (make-html-tokenizer in normalized?)))
(let loop ((tok (next-tok)))
(if (null? tok)
'()
(cons tok (loop (next-tok)))))))
;;; @defproc shtml-token-kind token
;;;
;;; Returns a symbol indicating the kind of tokenizer @var{token}:
;;; @code{*COMMENT*}, @code{*DECL*}, @code{*EMPTY*}, @code{*END*},
;;; @code{*ENTITY*}, @code{*PI*}, @code{*START*}, @code{*TEXT*}.
;;; This is used by higher-level parsing code. For example:
;;;
;;; @lisp
;;; (map shtml-token-kind
;;; (tokenize-html (open-input-string ">shtml} rather than calling the tokenizer directly.
;; @defvar htmlprag-internal:empty-elements
;;
;; List of names of HTML element types that have no content, represented as a
;; list of symbols. This is used internally by the parser and encoder. The
;; effect of mutating this list is undefined.
;; TODO: Document exactly which elements these are, after we make the new
;; parameterized parser constructor.
(define htmlprag-internal:empty-elements
'(area base br frame hr img input isindex keygen link meta object param
spacer wbr))
;;; @defproc parse-html/tokenizer tokenizer normalized?
;;;
;;; Emits a parse tree like @code{html->shtml} and related procedures, except
;;; using @var{tokenizer} as a source of tokens, rather than tokenizing from an
;;; input port. This procedure is used internally, and generally should not be
;;; called directly.
(define parse-html/tokenizer
;; TODO: Document the algorithm, then see if rewriting as idiomatic Scheme
;; can make it more clear.
(letrec ((empty-elements
;; TODO: Maybe make this an option. This might also be an
;; acceptable way to parse old HTML that uses the `p' element
;; as a paragraph terminator.
htmlprag-internal:empty-elements)
(parent-constraints
;; TODO: Maybe make this an option.
'((area . (map))
(body . (html))
(caption . (table))
(colgroup . (table))
(dd . (dl))
(dt . (dl))
(frame . (frameset))
(head . (html))
(isindex . (head))
(li . (dir menu ol ul))
(meta . (head))
(noframes . (frameset))
(option . (select))
(p . (body td th))
(param . (applet))
(tbody . (table))
(td . (tr))
(th . (tr))
(thead . (table))
(title . (head))
(tr . (table tbody thead))))
(start-tag-name (lambda (tag-token) (car tag-token)))
(end-tag-name (lambda (tag-token) (list-ref tag-token 1))))
(lambda (tokenizer normalized?)
;; Example `begs' value:
;;
;; ( ((head ...) . ( (title ...) ))
;; ((html ...) . ( (head ...) (*COMMENT* ...) ))
;; (#f . ( (html ...) (*DECL* doctype ...) )) )
(let ((begs (list (cons #f '()))))
(letrec ((add-to-current-beg
(lambda (tok)
(set-cdr! (car begs) (cons tok (cdr (car begs))))))
(finish-all-begs
(lambda ()
(let ((toplist #f))
(map (lambda (beg) (set! toplist (finish-beg beg)))
begs)
toplist)))
(finish-beg
(lambda (beg)
(let ((start-tok (car beg)))
(if start-tok
(htmlprag-internal:append!
(car beg)
(htmlprag-internal:reverse!ok (cdr beg)))
(htmlprag-internal:reverse!ok (cdr beg))))))
(finish-begs-to
(lambda (name lst)
(let* ((top (car lst))
(starttag (car top)))
(cond ((not starttag) #f)
((eqv? name (start-tag-name starttag))
(set! begs (cdr lst))
(finish-beg top)
#t)
(else (if (finish-begs-to name (cdr lst))
(begin (finish-beg top) #t)
#f))))))
(finish-begs-upto
(lambda (parents lst)
(let* ((top (car lst))
(starttag (car top)))
(cond ((not starttag) #f)
((memq (start-tag-name starttag) parents)
(set! begs lst)
#t)
(else (if (finish-begs-upto parents (cdr lst))
(begin (finish-beg top) #t)
#f)))))))
(let loop ()
(let ((tok (tokenizer)))
(if (null? tok)
(finish-all-begs)
(let ((kind (shtml-token-kind tok)))
(cond ((memv kind `(,shtml-comment-symbol
,shtml-decl-symbol
,shtml-entity-symbol
,shtml-pi-symbol
,shtml-text-symbol))
(add-to-current-beg tok))
((eqv? kind shtml-start-symbol)
(let* ((name (start-tag-name tok))
(cell (assq name parent-constraints)))
(and cell (finish-begs-upto (cdr cell) begs))
(add-to-current-beg tok)
(or (memq name empty-elements)
(set! begs (cons (cons tok '()) begs)))))
((eqv? kind shtml-empty-symbol)
;; Empty tag token, so just add it to current
;; beginning while stripping off leading `*EMPTY*'
;; symbol so that the token becomes normal SXML
;; element syntax.
(add-to-current-beg (cdr tok)))
((eqv? kind shtml-end-symbol)
(let ((name (end-tag-name tok)))
(if name
;; Try to finish to a start tag matching this
;; end tag. If none, just drop the token,
;; though we used to add it to the current
;; beginning.
(finish-begs-to name begs)
;; We have an anonymous end tag, so match it
;; with the most recent beginning. If no
;; beginning to match, then just drop the
;; token, though we used to add it to the
;; current beginning.
(and (car (car begs))
(begin (finish-beg (car begs))
(set! begs (cdr begs)))))))
(else (htmlprag-internal:error "parse-html/tokenizer"
"unknown tag kind"
kind)))
(loop))))))))))
;; @defproc htmlprag-internal:parse-html input normalized? top?
;;
;; This procedure is now used internally by @code{html->shtml} and its
;; variants, and should not be used directly by programs. The interface is
;; likely to change in future versions of HtmlPrag.
(define (htmlprag-internal:parse-html input normalized? top?)
(let ((parse
(lambda ()
(parse-html/tokenizer
(make-html-tokenizer
(cond ((input-port? input) input)
((string? input) (open-input-string input))
(else (htmlprag-internal:error
"htmlprag-internal:parse-html"
"invalid input type"
input)))
normalized?)
normalized?))))
(if top?
(cons shtml-top-symbol (parse))
(parse))))
;;; @defproc html->sxml-0nf input
;;; @defprocx html->sxml-1nf input
;;; @defprocx html->sxml-2nf input
;;; @defprocx html->sxml input
;;;
;;; Permissively parse HTML from @var{input}, which is either an input port or
;;; a string, and emit an SHTML equivalent or approximation. To borrow and
;;; slightly modify an example from [SSAX-HTML]:
;;;
;;; @lisp
;;; (html->shtml
;;; "whatever
;;; link
;;;
BLah italic bold ened
;;; still < bold
But not done yet...")
;;; @result{}
;;; (*TOP* (html (head (title) (title "whatever"))
;;; (body "\n"
;;; (a (@@ (href "url")) "link")
;;; (p (@@ (align "center"))
;;; (ul (@@ (compact) (style "aa")) "\n"))
;;; (p "BLah"
;;; (*COMMENT* " comment ")
;;; " "
;;; (i " italic " (b " bold " (tt " ened")))
;;; "\n"
;;; "still < bold "))
;;; (p " But not done yet...")))
;;; @end lisp
;;;
;;; Note that in the emitted SHTML the text token @code{"still < bold"} is
;;; @emph{not} inside the @code{b} element, which represents an unfortunate
;;; failure to emulate all the quirks-handling behavior of some popular Web
;;; browsers.
;;;
;;; The procedures @code{html->sxml-@var{n}nf} for @var{n} 0 through 2
;;; correspond to 0th through 2nd normal forms of SXML as specified in [SXML],
;;; and indicate the minimal requirements of the emitted SXML.
;;;
;;; @code{html->sxml} and @code{html->shtml} are currently aliases for
;;; @code{html->sxml-0nf}, and can be used in scripts and interactively, when
;;; terseness is important and any normal form of SXML would suffice.
(define (html->sxml-0nf input) (htmlprag-internal:parse-html input #f #t))
(define (html->sxml-1nf input) (htmlprag-internal:parse-html input #f #t))
(define (html->sxml-2nf input) (htmlprag-internal:parse-html input #t #t))
(define html->sxml html->sxml-0nf)
(define html->shtml html->sxml-0nf)
;;; @section HTML Encoding
;;; Two procedures encode the SHTML representation as conventional HTML,
;;; @code{write-shtml-as-html} and @code{shtml->html}. These are perhaps most
;;; useful for emitting the result of parsed and transformed input HTML. They
;;; can also be used for emitting HTML from generated or handwritten SHTML.
;;; @defproc write-shtml-as-html shtml out
;;;
;;; Writes a conventional HTML transliteration of the SHTML @var{shtml} to
;;; output port @var{out}. HTML elements of types that are always empty are
;;; written using HTML4-compatible XHTML tag syntax. No inter-tag whitespace
;;; or line breaks not explicit in @var{shtml} is emitted. The @var{shtml}
;;; should normally include a newline at the end of the document. For example
;;; (which might not work verbatim in all Scheme implementations):
;;;
;;; @lisp
;;; (write-shtml-as-html
;;; '((html (head (title "My Title"))
;;; (body (@@ (bgcolor "white"))
;;; (h1 "My Heading")
;;; (p "This is a paragraph.")
;;; (p "This is another paragraph."))))
;;; (current-output-port))
;;; @print{} My Title
My Heading
This is a paragraph.
This is
;;; @print{} another paragraph.
;;; @end lisp
(define (write-shtml-as-html shtml out)
(letrec
((write-shtml-text
(lambda (str out)
(let ((len (string-length str)))
(let loop ((i 0))
(if (< i len)
(begin (display (let ((c (string-ref str i)))
(case c
;; ((#\") """)
((#\&) "&")
((#\<) "<")
((#\>) ">")
(else c)))
out)
(loop (+ 1 i))))))))
(write-dquote-ampified
(lambda (str out)
;; TODO: If we emit """, we really should parse it, and HTML
;; 4.01 says we should, but anachronisms in HTML create the
;; potential for nasty mutilation of URI in attribute values.
(let ((len (string-length str)))
(let loop ((i 0))
(if (< i len)
(begin (display (let ((c (string-ref str i)))
(if (eqv? c #\") """ c))
out)
(loop (+ 1 i))))))))
(do-thing
(lambda (thing)
(cond ((string? thing) (write-shtml-text thing out))
((list? thing) (if (not (null? thing))
(do-list-thing thing)))
(else (htmlprag-internal:error "write-shtml-as-html"
"invalid SHTML thing"
thing)))))
(do-list-thing
(lambda (thing)
(let ((head (car thing)))
(cond ((symbol? head)
;; Head is a symbol, so...
(cond ((eq? head shtml-comment-symbol)
;; TODO: Make sure the comment text doesn't contain a
;; comment end sequence.
(display "" out))
((eq? head shtml-decl-symbol)
(let ((head (car (cdr thing))))
(display "string head) out)
(for-each
(lambda (n)
(cond ((symbol? n)
(display #\space out)
(display (symbol->string n) out))
((string? n)
(display " \"" out)
(write-dquote-ampified n out)
(display #\" out))
(else (htmlprag-internal:error
"write-shtml-as-html"
"invalid SHTML decl"
thing))))
(cdr (cdr thing)))
(display #\> out)))
((eq? head shtml-entity-symbol)
(let ((val (shtml-entity-value thing)))
(display #\& out)
(if (integer? val)
(display #\# out))
(display val out))
(display #\; out))
((eq? head shtml-pi-symbol)
(display "" out)
(display (symbol->string (car (cdr thing))) out)
(display #\space out)
(display (car (cdr (cdr thing))) out)
;; TODO: Error-check that no more rest of PI.
(display "?>" out))
((eq? head shtml-top-symbol)
(for-each do-thing (cdr thing)))
((eq? head shtml-empty-symbol)
#f)
((memq head `(,shtml-end-symbol
,shtml-start-symbol
,shtml-text-symbol))
(htmlprag-internal:error "write-shtml-as-html"
"invalid SHTML symbol"
head))
((eq? head htmlprag-internal:at)
(htmlprag-internal:error
"write-shtml-as-html"
"illegal position of SHTML attributes"
thing))
(else
(display #\< out)
(display head out)
(let* ((rest (cdr thing)))
(if (not (null? rest))
(let ((second (car rest)))
(and (list? second)
(not (null? second))
(eq? (car second) htmlprag-internal:at)
(begin (for-each do-attr (cdr second))
(set! rest (cdr rest))))))
(if (memq head
htmlprag-internal:empty-elements)
;; TODO: Error-check to make sure the element
;; has no content other than attributes.
;; We have to test for cases like:
;; (br (@) () (()))
(display " />" out)
(begin (display #\> out)
(for-each do-thing rest)
(display "" out)
(display (symbol->string head) out)
(display #\> out)))))))
((or (list? head) (string? head))
;; Head is a list or string, which might occur as the result
;; of an SXML transform, so we'll cope.
(for-each do-thing thing))
(else
;; Head is NOT a symbol, list, or string, so error.
(htmlprag-internal:error "write-shtml-as-html"
"invalid SHTML list"
thing))))))
(write-attr-val-dquoted
(lambda (str out)
(display #\" out)
(display str out)
(display #\" out)))
(write-attr-val-squoted
(lambda (str out)
(display #\' out)
(display str out)
(display #\' out)))
(write-attr-val-dquoted-and-amped
(lambda (str out)
(display #\" out)
(write-dquote-ampified str out)
(display #\" out)))
(write-attr-val
(lambda (str out)
(let ((len (string-length str)))
(let find-dquote-and-squote ((i 0))
(if (= i len)
(write-attr-val-dquoted str out)
(let ((c (string-ref str i)))
(cond ((eqv? c #\")
(let find-squote ((i (+ 1 i)))
(if (= i len)
(write-attr-val-squoted str out)
(if (eqv? (string-ref str i) #\')
(write-attr-val-dquoted-and-amped str out)
(find-squote (+ 1 i))))))
((eqv? c #\')
(let find-dquote ((i (+ 1 i)))
(if (= i len)
(write-attr-val-dquoted str out)
(if (eqv? (string-ref str i) #\")
(write-attr-val-dquoted-and-amped str out)
(find-dquote (+ 1 i))))))
(else (find-dquote-and-squote (+ 1 i))))))))))
(do-attr
(lambda (attr)
(or (list? attr)
(htmlprag-internal:error "write-shtml-as-html"
"invalid SHTML attribute"
attr))
(if (not (null? attr))
(let ((name (car attr)))
(or (symbol? name)
(htmlprag-internal:error "write-shtml-as-html"
"invalid name in SHTML attribute"
attr))
(if (not (eq? name htmlprag-internal:at))
(begin
(display #\space out)
(display name out)
(let ((rest (cdr attr)))
(or (list? rest)
(htmlprag-internal:error
"write-shtml-as-html"
"malformed SHTML attribute"
attr))
(if (not (null? rest))
(let ((value (car rest)))
(cond ((string? value)
(display #\= out)
(write-attr-val value out))
((eq? value #t)
;; Note: This is not valid SXML, but
;; perhaps should be.
#f)
(else
(htmlprag-internal:error
"write-shtml-as-html"
"invalid value in SHTML attribute"
attr)))))))))))))
(do-thing shtml)
(if #f #f)))
;;; @defproc shtml->html shtml
;;;
;;; Yields an HTML encoding of SHTML @var{shtml} as a string. For example:
;;;
;;; @lisp
;;; (shtml->html
;;; (html->shtml
;;; "
This is bold italic b > text.
"))
;;; @result{} "
This is bold italic text.
"
;;; @end lisp
;;;
;;; Note that, since this procedure constructs a string, it should normally
;;; only be used when the HTML is relatively small. When encoding HTML
;;; documents of conventional size and larger, @var{write-shtml-as-html} is
;;; much more efficient.
(define (shtml->html shtml)
(let ((os (open-output-string)))
(write-shtml-as-html shtml os)
(htmlprag-internal:gosc os)))
;;; @section Deprecated
;;; As HtmlPrag evolves towards version 1.0,
;;; The equivalences below show the deprecated expressions below, the code on
;;; the left is deprecated and should be replaced with the code on the right.
;;; @lisp
;;; sxml->html @equiv{} shtml->html
;;; write-sxml-html @equiv{} write-shtml-as-html
;;; @end lisp
(define sxml->html shtml->html)
(define write-sxml-html write-shtml-as-html)
;;; @section Tests
;;; A regression test suite is defined as procedure @code{test-htmlprag} in the
;;; source file. The test suite can be run under various Scheme
;;; implementations with Unix shell commands like:
;;;
;;; @itemize @
;;;
;;; @item Bigloo
;;; @example
;;; bigloo -eval '(load "htmlprag.scm") (test-htmlprag) (exit)'
;;; @end example
;;;
;;; @item Chicken
;;; @example
;;; csi -batch -eval '(load "htmlprag.scm") (test-htmlprag)'
;;; @end example
;;;
;;; @item Gauche
;;; @example
;;; gosh -l./htmlprag.scm -e"(begin (test-htmlprag) (exit))"
;;; @end example
;;;
;;; @item Guile
;;; @example
;;; guile -l htmlprag.scm -c "(test-htmlprag)"
;;; @end example
;;;
;;; @c @item Kawa
;;; @c @example
;;; @c kawa -f htmlprag.scm -e "(test-htmlprag)"
;;; @c @end example
;;;
;;; @item MIT Scheme
;;; @example
;;; mit-scheme <input-port)
;;; (define open-output-string make-accumulator-output-port)
;;; (define get-output-string get-output-from-accumulator)
;;; (load "htmlprag.scm") (test-htmlprag)
;;; EOH
;;; @end example
;;;
;;; @item PLT MzScheme
;;; @example
;;; mzscheme -qfe htmlprag.scm "(begin (test-htmlprag) (exit))"
;;; @end example
;;;
;;; @item RScheme
;;; @example
;;; rs -e '(load "htmlprag.scm") (test-htmlprag)' -exit
;;; @end example
;;;
;;; @item Scheme 48 @ (requires edit of @code{htmlprag-internal:a2c})
;;; @example
;;; scheme48 < ")
(write result)
(newline)
(if (equal? result expected)
(begin (set! passed (+ 1 passed))
(display ";; Passed.")
(newline))
(begin (set! failed (+ 1 failed))
(display ";; ***FAILED*** Expected:")
(newline)
(display ";; ")
(write expected)
(newline))))))
(t1 (lambda (input expected)
(test html->shtml
'html->shtml
(list input)
(cons shtml-top-symbol expected))))
(t2 (lambda (input expected)
(test shtml->html
'shtml->html
(list input)
expected)))
(at htmlprag-internal:at)
(comment shtml-comment-symbol)
(decl shtml-decl-symbol)
(entity shtml-entity-symbol)
(pi shtml-pi-symbol)
(lf (string (htmlprag-internal:a2c 10))))
(tests-begin)
(t1 ">" '((a ">")))
(t1 "" '((a "<" ">")))
(t1 "<>" '("<" ">"))
(t1 "< >" '("<" ">"))
(t1 "< a>" '((a)))
(t1 "< a / >" '((a)))
(t1 "" '(">" (a)))
(t1 ">" '())
(t1 "<\">" '("<" "\"" ">"))
(t1 (string-append "xxxaaa" lf "bbb" lf "cbbb" `("aaa" (,comment " xxx ") "bbb"))
(t1 "aaabbb" `("aaa" (,comment " xxx ") "bbb"))
(t1 "aaabbb" `("aaa" (,comment " xxx -") "bbb"))
(t1 "aaabbb" `("aaa" (,comment " xxx --") "bbb"))
(t1 "aaabbb" `("aaa" (,comment " xxx -y") "bbb"))
(t1 "aaabbb" `("aaa" (,comment "-") "bbb"))
(t1 "aaabbb" `("aaa" (,comment "") "bbb"))
(t1 "aaabbb" `("aaa" (,comment "->bbb")))
(t1 "" '((hr)))
(t1 "" '((hr)))
(t1 "" '((hr)))
(t1 "" `((hr (,at (noshade)))))
(t1 "" `((hr (,at (noshade)))))
(t1 "" `((hr (,at (noshade)))))
(t1 "" `((hr (,at (noshade)))))
(t1 "" `((hr (,at (noshade "1")))))
(t1 "" `((hr (,at (noshade "1")))))
(t1 "aaabbbccc
")
expected))
(t1 "ax" '((xmp "a") "x"))
(t1 (string-append "a" lf "x") `((xmp ,(string-append "a" lf))
"x"))
(t1 "x" '((xmp) "x"))
(t1 "aaaa" '((xmp "a")))
(t1 "a<" '((xmp "a<")))
(t1 "a" '((xmp "a")))
(t1 "" '((xmp)))
(t1 "xxx" '((script "xxx")))
(t1 "xxx" '((script) "xxx"))
;; TODO: Add verbatim-pair cases with attributes in the end tag.
(t2 '(p) "")
(t2 '(p "CONTENT") "
CONTENT
")
(t2 '(br) " ")
(t2 '(br "CONTENT") " ")
(t2 `(hr (,at (clear "all"))) "")
(t2 `(hr (,at (noshade))) "")
(t2 `(hr (,at (noshade #t))) "")
(t2 `(hr (,at (noshade "noshade"))) "")
(t2 `(hr (,at (aaa "bbbccc"))) "")
(t2 `(hr (,at (aaa "bbb'ccc"))) "")
(t2 `(hr (,at (aaa "bbb\"ccc"))) "")
(t2 `(hr (,at (aaa "bbb\"ccc'ddd"))) "")
(t2 `(,pi xml "version=\"1.0\" encoding=\"UTF-8\"")
"")
(t2 `(,decl ,(string->symbol "DOCTYPE")
html
,(string->symbol "PUBLIC")
"-//W3C//DTD XHTML 1.0 Strict//EN"
"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd")
(string-append
""))
;; TODO: Write more test cases for HTML encoding.
;; TODO: Document this.
;;
;; (define html-1 "")
;; (define shtml (html->shtml html-1))
;; shtml
;; (define html-2 (shtml->html shtml))
;; html-2
(tests-end)))
;;; @unnumberedsec History
;;; @table @asis
;;;
;;; @item Version 0.11 --- 13 May 2004
;;; To reduce likely namespace collisions with SXML tools, and in anticipation
;;; of a forthcoming set of new features, introduced the concept of ``SHTML,''
;;; which will be elaborated upon in a future version of HtmlPrag. Renamed
;;; @code{sxml-@var{x}-symbol} to @code{shtml-@var{x}-symbol},
;;; @code{sxml-html-@var{x}} to @code{shtml-@var{x}}, and
;;; @code{sxml-token-kind} to @code{shtml-token-kind}. @code{html->shtml},
;;; @code{shtml->html}, and @code{write-shtml-as-html} have been added as
;;; names. Considered deprecated but still defined (see the ``Deprecated''
;;; section of this documentation) are @code{sxml->html} and
;;; @code{write-sxml-html}. The growing pains should now be all but over.
;;; Internally, @code{htmlprag-internal:error} introduced for Bigloo
;;; portability. SISC returned to the test list; thanks to Scott G. Miller
;;; for his help. Fixed a new character @code{eq?} bug, thanks to SISC.
;;;
;;; @item Version 0.10 --- 11 May 2004
;;; All public identifiers have been renamed to drop the ``@code{htmlprag:}''
;;; prefix. The portability identifiers have been renamed to begin with an
;;; @code{htmlprag-internal:} prefix, are now considered strictly
;;; internal-use-only, and have otherwise been changed. @code{parse-html} and
;;; @code{always-empty-html-elements} are no longer public.
;;; @code{test-htmlprag} now tests @code{html->sxml} rather than
;;; @code{parse-html}. SISC temporarily removed from the test list, until an
;;; open source Java that works correctly is found.
;;;
;;; @item Version 0.9 --- 7 May 2004
;;; HTML encoding procedures added. Added
;;; @code{htmlprag:sxml-html-entity-value}. Upper-case @code{X} in hexadecimal
;;; character entities is now parsed, in addition to lower-case @code{x}.
;;; Added @code{htmlprag:always-empty-html-elements}. Added additional
;;; portability bindings. Added more test cases.
;;;
;;; @item Version 0.8 --- 27 April 2004
;;; Entity references (symbolic, decimal numeric, hexadecimal numeric) are now
;;; parsed into @code{*ENTITY*} SXML. SXML symbols like @code{*TOP*} are now
;;; always upper-case, regardless of the Scheme implementation. Identifiers
;;; such as @code{htmlprag:sxml-top-symbol} are bound to the upper-case
;;; symbols. Procedures @code{htmlprag:html->sxml-0nf},
;;; @code{htmlprag:html->sxml-1nf}, and @code{htmlprag:html->sxml-2nf} have
;;; been added. @code{htmlprag:html->sxml} now an alias for
;;; @code{htmlprag:html->sxml-0nf}. @code{htmlprag:parse} has been refashioned
;;; as @code{htmlprag:parse-html} and should no longer be directly. A number
;;; of identifiers have been renamed to be more appropriate when the
;;; @code{htmlprag:} prefix is dropped in some implementation-specific
;;; packagings of HtmlPrag: @code{htmlprag:make-tokenizer} to
;;; @code{htmlprag:make-html-tokenizer}, @code{htmlprag:parse/tokenizer} to
;;; @code{htmlprag:parse-html/tokenizer}, @code{htmlprag:html->token-list} to
;;; @code{htmlprag:tokenize-html}, @code{htmlprag:token-kind} to
;;; @code{htmlprag:sxml-token-kind}, and @code{htmlprag:test} to
;;; @code{htmlprag:test-htmlprag}. Verbatim elements with empty-element tag
;;; syntax are handled correctly. New versions of Bigloo and RScheme tested.
;;;
;;; @item Version 0.7 --- 10 March 2004
;;; Verbatim pair elements like @code{script} and @code{xmp} are now parsed
;;; correctly. Two Scheme implementations have temporarily been dropped from
;;; regression testing: Kawa, due to a Java bytecode verifier error likely due
;;; to a Java installation problem on the test machine; and SXM 1.1, due to
;;; hitting a limit on the number of literals late in the test suite code.
;;; Tested newer versions of Bigloo, Chicken, Gauche, Guile, MIT Scheme, PLT
;;; MzScheme, RScheme, SISC, and STklos. RScheme no longer requires the
;;; ``@code{(define get-output-string close-output-port)}'' workaround.
;;;
;;; @item Version 0.6 --- 3 July 2003
;;; Fixed uses of @code{eq?} in character comparisons, thanks to Scott G.
;;; Miller. Added @code{htmlprag:html->normalized-sxml} and
;;; @code{htmlprag:html->nonnormalized-sxml}. Started to add
;;; @code{close-output-port} to uses of output strings, then reverted due to
;;; bug in one of the supported dialects. Tested newer versions of Bigloo,
;;; Gauche, PLT MzScheme, RScheme.
;;;
;;; @item Version 0.5 --- 26 February 2003
;;; Removed uses of @code{call-with-values}. Re-ordered top-level definitions,
;;; for portability. Now tests under Kawa 1.6.99, RScheme 0.7.3.2, Scheme 48
;;; 0.57, SISC 1.7.4, STklos 0.54, and SXM 1.1.
;;;
;;; @item Version 0.4 --- 19 February 2003
;;; Apostrophe-quoted element attribute values are now handled. A bug that
;;; incorrectly assumed left-to-right term evaluation order has been fixed
;;; (thanks to MIT Scheme for confronting us with this). Now also tests OK
;;; under Gauche 0.6.6 and MIT Scheme 7.7.1. Portability improvement for
;;; implementations (e.g., RScheme 0.7.3.2.b6, Stalin 0.9) that cannot read
;;; @code{@@} as a symbol (although those implementations tend to present other
;;; portability issues, as yet unresolved).
;;;
;;; @item Version 0.3 --- 5 February 2003
;;; A test suite with 66 cases has been added, and necessary changes have been
;;; made for the suite to pass on five popular Scheme implementations. XML
;;; processing instructions are now parsed. Parent constraints have been added
;;; for @code{colgroup}, @code{tbody}, and @code{thead} elements. Erroneous
;;; input, including invalid hexadecimal entity reference syntax and extraneous
;;; double quotes in element tags, is now parsed better.
;;; @code{htmlprag:token-kind} emits symbols more consistent with SXML.
;;;
;;; @item Version 0.2 --- 2 February 2003
;;; Portability improvements.
;;;
;;; @item Version 0.1 --- 31 January 2003
;;; Dusted off old Guile-specific code from April 2001, converted to emit SXML,
;;; mostly ported to R5RS and SRFI-6, added some XHTML support and
;;; documentation. A little preliminary testing has been done, and the package
;;; is already useful for some applications, but this release should be
;;; considered a preview to invite comments.
;;;
;;; @end table
;;; @unnumberedsec References
;;; @table @asis
;;;
;;; @item [HTML]
;;; Dave Raggett, Arnaud Le Hors, Ian Jacobs, eds., ``HTML 4.01
;;; Specification,'' W3C Recommendation, 24 December 1999.@*
;;; @uref{http://www.w3.org/TR/1999/REC-html401-19991224/}
;;;
;;; @item [LGPL]
;;; Free Software Foundation, ``GNU Lesser General Public License,'' Version
;;; 2.1, February 1999, 59 Temple Place, Suite 330, Boston, MA 02111-1307
;;; USA.@*
;;; @uref{http://www.gnu.org/copyleft/lesser.html}
;;;
;;; @item [SRFI-6]
;;; William D. Clinger, ``Basic String Ports,'' SRFI 6, 1 July 1999.@*
;;; @uref{http://srfi.schemers.org/srfi-6/srfi-6.html}
;;;
;;; @item [SRFI-23]
;;; Stephan Houben, ``Error reporting mechanism,'' SRFI 23, 26 April 2001.@*
;;; @uref{http://srfi.schemers.org/srfi-23/srfi-23.html}
;;;
;;; @item [SSAX]
;;; Oleg Kiselyov, ``A functional-style framework to parse XML documents,''
;;; 5 September 2002.@*
;;; @uref{http://pobox.com/~oleg/ftp/Scheme/xml.html#XML-parser}
;;;
;;; @item [SSAX-HTML]
;;; Oleg Kiselyov, ``Permissive parsing of perhaps invalid HTML,'' Version 1.1,
;;; 3 November 2001.@*
;;; @uref{http://pobox.com/~oleg/ftp/Scheme/xml.html#HTML-parser}
;;;
;;; @item [SXML]
;;; Oleg Kiselyov, ``SXML,'' revision 3.0.@*
;;; @uref{http://pobox.com/~oleg/ftp/Scheme/SXML.html}
;;;
;;; @item [SXML-Tools]
;;; Kirill Lisovsky, ``SXPath and SXPointer,''@*
;;; @uref{http://pair.com/lisovsky/query/sxpath/}
;;;
;;; @item [SXPath]
;;; Oleg Kiselyov, ``SXPath,'' version 3.5, 12 January 2001.@*
;;; @uref{http://pobox.com/~oleg/ftp/Scheme/xml.html#SXPath}
;;;
;;; @item [XHTML]
;;; ``XHTML 1.0: The Extensible HyperText Markup Language: A Reformulation of
;;; HTML 4 in XML 1.0,'' W3C Recommendation, 26 January 2000.@*
;;; @uref{http://www.w3.org/TR/2000/REC-xhtml1-20000126/}
;;;
;;; @item [XML-Names]
;;; Tim Bray, Dave Hollander, Andrew Layman, eds., ``Namespaces in XML,'' W3C
;;; Recommendation, 14 January 1999.@*
;;; @uref{http://www.w3.org/TR/1999/REC-xml-names-19990114/}
;;;
;;; @end table
;; ############## END CANONICAL htmlprag.scm ##############
(export
shtml-comment-symbol
shtml-decl-symbol
shtml-empty-symbol
shtml-end-symbol
shtml-entity-symbol
shtml-pi-symbol
shtml-start-symbol
shtml-text-symbol
shtml-top-symbol
shtml-named-char-id
shtml-numeric-char-id
shtml-entity-value
make-html-tokenizer
tokenize-html
shtml-token-kind
parse-html/tokenizer
html->sxml-0nf
html->sxml-1nf
html->sxml-2nf
html->sxml
html->shtml
write-shtml-as-html
shtml->html
sxml->html
write-sxml-html
test-htmlprag
)
;;; arch-tag: 491d7e61-5690-4b76-bc8f-d70315c10ed5
;;; htmlprag.scm ends here
guile-lib-0.2.2/src/unit-test.scm 0000644 0001750 0001750 00000023411 11573632155 013545 0000000 0000000 ;; (unit-test) -- a JUnit-like testing framework for Guile
;; Original code by John Maxwell
;; Copyright (C) 2003 Richard Todd
;; Copyright (C) 2004,2005 Andreas Rottmann
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see .
;; This code originally came from
;; http://article.gmane.org/gmane.lisp.guile.user/1728.
(define-module (unit-test)
#:use-module (oop goops)
#:use-module (srfi srfi-1)
#:use-module (ice-9 format)
#:use-module (ice-9 pretty-print)
#:export (assert-equal
assert-true
assert-numeric-=
tests-run
tests-failed
tests-log
failure-messages
test-started
test-failed
summary
name
set-up-test
tear-down-test
run
tests
add
run-all-defined-test-cases
exit-with-summary)
#:export-syntax (assert-exception))
;; Utility method for finding an object's method given its name. The
;; equivalent probably already exists somewhere in the MOP, but the doc
;; is a little sketchy.
(define-method (lookup-method (object