Parser for XML documents that contain XLink elements
This software is in Public Domain.
IT IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND.
Please send bug reports and comments to:
lisovsky@acm.org Kirill Lisovsky
lizorkin@hotbox.ru Dmitry Lizorkin
Returns an SXML presentation for a document plus additional information
extracted from XLink markup (described below)
'SSAX:XML->SXML+xlink' function is the core of the programme. This funcion
is a modified Oleg Kiselyov's 'SSAX:XML->SXML' function.
'SSAX:XML->SXML+xlink' has a complicated seed which consists of ten elements:
xlink:seed = (list mode sxlink-arcs sxpointer stack
locators+resources arcs declared-labels)
1. mode = 'general, 'extended or 'none. They have the following meaning:
- 'general - there are no XLink elements among current element's ancestors.
So, 'extended' or 'simple' elements are expected (others don't have any XLink
semantical meaning)
- 'extended - for elements that are direct children of an extended link
element, i.e. 'locator', 'resource' or 'arc'
- 'none - no XLink elements are expected niether in the current element
nor in any of its descendants
2. sxlink-arcs - contains information extracted from XLink elements.
sxlink-arcs = (list sxlink-arc
sxlink-arc
...)
sxlink-arc - as defined in the SXLink Specification
3. Reverse S-expression representation for XPointer ChildSeq for a currently
processed element
sxpointer ::= (listof number)
For example, '(5 4 1) corresponds to "/1/4/5"
4. stack - a list of stack-elements. This list has the following semantics:
- new stack-element is added when the beginning of each element is processed
- the stack-element is consumed at the finish-element (of the same element)
stack = (list stack-element
stack-element
...)
stack-element = (list position xlink-values)
position - a position within a file
xlink-values = (list type href role arcrole show actuate label from to)
where, for example, 'type' is the value of xlink:type attribute or #f if
there is no such attribute
The other parameters of the seed are presented when an extended link is
processed
5. locators+resources - locator and resource elements defined within an
extended link. They are temporarily stored in this parameter. This info
is converted into an 'sxlink-arcs' parameter when the end-tag for an
extended link element is encountered
locators+resources = (list locator-or-resource
locator-or-resource
...)
locator-or-resource = (list uri fragment role label
position element)
label - a string representing the value of xlink:label attribute, or #f if
this attribute was omitted
6. arcs - information about arce defined within an extended link. This info
is converted into an 'sxlink-arcs' parameter when the end-tag for an
extended link element is encountered
arcs = (list arc-info
arc-info
...)
arc-info = (list arcrole show actuate from to
position element)
from - a string representing the value of xlink:from attribute, or #f if
this attribute was omitted
to - the same for an xlink:to attribute
7. declared-labels - labels declared within an extended link. This parameter
is used for constraint checking
declared-labels = (list label label ...)
label - a string
Some global constants
xlink:seed = (list mode sxlink-arcs sxpointer stack
locators+resources arcs declared-labels)
The last three parameters are optional. See a head comment for details
They are introducted in order to control (possible) future modifications of a 'seed' list
This function constructs a seed consisting only of six compulsory elements
The similar function which makes a full-length seed
We assume that the seed has the full length for the latter four functions
Adds the arc defined by the XLink simple link to 'sxlink-arcs'
This function appends information to 'sxlink-arcs' according to 'locators+resources' and 'arcs' parameters. The function is called at the end-tag of an extended link element.
Reverse S-expression representation for XPointer ChildSeq for a currently processed element sxpointer ::= (listof number) For example, '(5 4 1) corresponds to "/1/4/5"
Forms sxpointer for the following sibling element of the current element
locators+resources - locator and resource elements defined within an
extended link. They are temporarily stored in this parameter. This info
is converted into an 'sxlink-arcs' parameter when the end-tag for an
extended link element is encountered
locators+resources = (list locator-or-resource
locator-or-resource
...)
locator-or-resource = (list label resource-data)
resource-data - whatever required to describe the resource in terms of
the SXLink Specification
Constructor
Accessors NOTE: We don't apply teta-reduction for the sake of easier bug detection
If the following XLink constraint is fulfilled, adds information about the XLink locator element to 'locators+resources'. Otherwise, displays an error message and doesn't add anything. Constraint: Attributes on Locator Element The locator-type element must have the locator attribute (see 5.4 Locator Attribute (href)). The locator attribute (href) must have a value supplied.
Adds information concerning XLink resource element to 'locators+resources'
arcs - information about arce defined within an extended link. This info
is converted into an 'sxlink-arcs' parameter when the end-tag for an
extended link element is encountered
arcs = (list arc-info
arc-info
...)
arc-info = (list from to linkbase position data)
linkbase - a boolean: whether a linkbase arc
arc-data - whatever required to describe the arc in terms of the SXLink
Specification
Constructor
Accessors NOTE: We don't apply teta-reduction for the sake of easier bug detection
Adds arc information to 'arcs' datatype. A side effect - checks the following XLink constraint: Constraint: No Arc Duplication Each arc-type element must have a pair of from and to xlink-values that does not repeat the from and to xlink-values (respectively) for any other arc-type element in the same extended link; that is, each pair in a link must be unique.
XLink specification, 5.1.3: If no arc-type elements are provided in an extended link, then by extension the missing from and to xlink-values are interpreted as standing for all the labels in that link. Inserts such a default arc if 'arcs' are empty
declared-labels - labels declared within an extended link. This parameter is used for constraint checking declared-labels = (list label label ...) label - a string
If an xlink:label attribute is presented in 'xlink-values', it's value is added to 'declared-labels'. Otherwise, 'declared-labels' remain unchainged
The function checks the following XLink constraint Constraint: label, from, and to xlink-values The value of a label, from, or to attribute must be an NCName. If a value is supplied for a from or to attribute, it must correspond to the same value for some label attribute on a locator- or resource-type element that appears as a direct child inside the same extended-type element as does the arc-type element. Error message is displayed if some label was undeclared. The function always returns #t. It is called at the end-tag of an extended link element
xlink-values = (list
type href role arcrole title show actuate label from to)
These functions are used as a level of abstraction
Constructs a datatype (just a list in a current implementation) which contains xlink-values of all xlink-related attributes. For example, 'type' is the value of xlink:type attribute or #f if there is no such attribute. This datatype will be called 'xlink-values' in the latter text
Accessors NOTE: We don't apply teta-reduction for the sake of easier bug detection
The function is given a list called 'attributes' (in SSAX parser). This list
has the form
attributes = (list attribute
attribute
...)
attribute = (cons (cons namespace-prefix attribute-name)
attribute-value )
or (cons attribute-name attribute-value )
namespaces - defined in "ssax.scm"
reads XLink attributes' values and returns a 'xlink-values' datatype
(the result of 'xlink:construct-xlink-values' function)
Reads SXML element's attributes
element - an SXML node representing an element
ns-prefixes = (list (list prefix namespace-uri)
(list prefix namespace-uri)
...)
prefix - a symbol
namespace-uri - a string
An 'xlink-values' datatype is returned
A helper function which is used by the next one value - a value of an attribute (#f if there is no such attribute) valid-xlink-values - a list of xlink-values which are allowed for this attribute attr-name - a string denotating a name of an attribute (for a message) position - position within a file Function always returns #t. Side effects: function "cerr"s a message if 'value' is not #f and not within 'valid-xlink-values'
xlink-values = (type href role arcrole show actuate label from to) where, for example, 'type' is the value of xlink:type attribute or #f if there is no such attribute (this datatype is a result of 'read-xlink-attributes' function) position - position within a file The function checks the three similar XLink constraints: 1. Constraint: type Value The value of the type attribute must be supplied. The value must be one of "simple", "extended", "locator", "arc", "resource", "title", or "none". 2. Constraint: show Value If a value is supplied for a show attribute, it must be one of the xlink-values "new", "replace", "embed", "other", and "none". 3. Constraint: actuate Value If a value is supplied for an actuate attribute, it must be be one of the xlink-values "onLoad", "onRequest", "other", and "none". The result is always #t Side effects - error messages (printed by an 'xlink:check-helper' function above)
All these functions have the same signature:
(smth-start position xlink-values xlink:seed)
position - position within a file
xlink-values = (list type href role arcrole show actuate label from to)
where, for example, 'type' is the value of xlink:type attribute or #f if
there is no such attribute
xlink:seed = (list mode sxlink-arcs sxpointer stack
locators+resources arcs declared-labels)
See a head comment for details
(smth-end xlink:parent-seed xlink:seed element)
element - the SXML presentation of the current element
All the functions return a new 'xlink:seed'
It is the element which doesn't have any XLink meaning, but its descendants might have such a meaning
Returns posiotion of a port NOTE: Specific for different Scheme implementations
This function displays an error message. #t is returned position - position within a file text - a message to display
Helper is used by the following functions in this section action-on-branch ::= (lambda (elem content-nodeset) ...) elem - SXML element that corresponds to the branch content-nodeset - new content The lambda should return the new elem
Replaces the content of the branch with a new content document - SXML document branch-lpath ::= (listof symbol) branch-lpath - is like an sxpath location path. There must be no more than one branch in an SXML tree with this location path. If this branch doesn't exist, it will be created as the first branch in a document content-nodeset ::= (listof node) content-nodeset - defines the content of the branch
Appends 'content-nodeset' to the content of the given branch
(borrowed from "xlink.scm")
Given a document, returns its URI (a string) #f is returned if there is no "@@/uri" subtree in the document
Adds the URI of the document where the arcs were declared, to sxlink-arcs Returns modified sxlink-arcs
This function is called by the NEW-LEVEL-SEED handler A new 'xlink:seed' is returned
This function is called by the FINISH-ELEMENT handler A new 'xlink:seed' is returned
Constructs the member of an axuiliary list
document - an SXML document The function emulates a 'fold-ts' operation. A new SXML document is returned. It contains an auxiliary list with an 'sxlink' subtree. If the source document already contains such a subtree, it will be replaced. Other subtrees in an auxiliary list will remain unchanged.
Some global constants
(define xlink:namespace-uri 'http://www.w3.org/1999/xlink)
(define xlink:linkbase-uri "http://www.w3.org/1999/xlink/properties/linkbase")
This function constructs a seed consisting only of six compulsory elements
(define (xlink:make-small-seed mode sxlink-arcs sxpointer stack) (list mode sxlink-arcs sxpointer stack))
The similar function which makes a full-length seed
(define (xlink:make-full-seed mode sxlink-arcs sxpointer stack
locators+resources arcs declared-labels)
(list mode sxlink-arcs sxpointer stack
locators+resources arcs declared-labels))
(define (xlink:seed-mode seed) (car seed))
(define (xlink:seed-sxlink-arcs seed) (cadr seed))
(define (xlink:seed-sxpointer seed) (list-ref seed 2))
(define (xlink:seed-stack seed) (list-ref seed 3))
We assume that the seed has the full length for the latter four functions
(define (xlink:seed-locators+resources seed) (list-ref seed 4))
(define (xlink:seed-arcs seed) (list-ref seed 5))
(define (xlink:seed-declared-labels seed) (list-ref seed 6))
Adds the arc defined by the XLink simple link to 'sxlink-arcs'
(define (xlink:add-simple
xlink-values element position sxpointer sxlink-arcs)
(let ((href (xlink:values-href xlink-values))
(role (xlink:values-role xlink-values))
(arcrole (xlink:values-arcrole xlink-values))
(title (xlink:values-title xlink-values))
(show (xlink:values-show xlink-values))
(actuate (xlink:values-actuate xlink-values)))
(if
(not href) ; the link is untraversable
sxlink-arcs ; no arc added
(call-with-values
(lambda ()
(let ((lst (string-split href (list #\#) 2)))
(cond
((= (length lst) 1) ; no XPointer fragment identifier
(values (car lst) #f))
((= (string-length (car lst)) 0) ; addresses the same document
(values #f (cadr lst)))
(else
(values (car lst) (cadr lst))))))
(lambda (uri-ending fragment)
(cons
`(,(if (equal? arcrole xlink:linkbase-uri)
'linkbase 'simple)
(from
(uri) ; goes from this document
(nodes ,element)
(xpointer ,(xlink:sxpointer->childseq sxpointer)))
(to
(uri ,@(if uri-ending (list uri-ending) '()))
,@(if fragment `((xpointer ,fragment)) '())
,@(if role `((role ,role)) '())
,@(if title `((title ,title)) '()))
,@(if arcrole `((arcrole ,arcrole)) '())
,@(if show `((show ,show)) '())
,@(if actuate `((actuate ,actuate)) '())
(declaration
(uri) ; in this document
(nodes ,element)
(xpointer ,(xlink:sxpointer->childseq sxpointer))
(position ,position)))
sxlink-arcs))))))
This function appends information to 'sxlink-arcs' according to 'locators+resources' and 'arcs' parameters. The function is called at the end-tag of an extended link element.
(define (xlink:add-extended
locators+resources arcs sxlink-arcs declaration)
(let (; like map, but applies the function to each pair of the arguments
(map-join
(lambda (func arg-lst1 arg-lst2)
(let ((arg-lst1 (reverse arg-lst1)))
(let iterate-second ((lst2 (reverse arg-lst2))
(res '()))
(if
(null? lst2) ; everyone processed
res
(let iterate-first ((lst1 arg-lst1)
(res res))
(if
(null? lst1) ; the iteration loop finished
(iterate-second (cdr lst2) res)
(iterate-first
(cdr lst1)
(cons (func (car lst1) (car lst2)) res)))))))))
; a stub for determining whether a locator-or-resouces is a local
; or remote one
(resource?
(lambda (locator-or-resource)
; Resource iff info contains subelement 'nodes
(assq 'nodes (xlink:resource-data locator-or-resource)))))
(let loop ((arcs arcs)
(sxlink-arcs sxlink-arcs))
(if
(null? arcs) ; all arcs processed
sxlink-arcs
(loop
(cdr arcs)
(let ((arc-info (car arcs)))
(append
(map-join
(lambda (starting ending)
`(,(cond ; determining arc name
((xlink:arc-info-linkbase arc-info)
'linkbase)
((and (resource? starting)
(not (resource? ending)))
'outbound)
((and (not (resource? starting))
(resource? ending))
'inbound)
((and (resource? starting) (resource? ending))
'local-to-local)
(else
'third-party))
(from ,@(xlink:resource-data starting))
(to ,@(xlink:resource-data ending))
,@(xlink:arc-info-data arc-info)
,declaration))
(let ((from (xlink:arc-info-from arc-info)))
(if
(not from) ; arc outgoes from every resource
locators+resources
(filter
(lambda (locator-or-resource)
(equal? from
(xlink:resource-label locator-or-resource)))
locators+resources)))
(let ((to (xlink:arc-info-to arc-info)))
(if
(not to) ; arc comes to every resource
locators+resources
(filter
(lambda (locator-or-resource)
(equal? to
(xlink:resource-label locator-or-resource)))
locators+resources))))
sxlink-arcs)))))))
(define (xlink:sxpointer->childseq sxpointer)
(apply
string-append
(map
(lambda (num) (string-append "/" (number->string num)))
(reverse sxpointer))))
Forms sxpointer for the following sibling element of the current element
(define (xlink:sxpointer4sibling sxpointer) (cons (+ 1 (car sxpointer)) (cdr sxpointer)))
Constructor
(define (xlink:make-locator-or-resource label resource-info) (list label resource-info))
Accessors NOTE: We don't apply teta-reduction for the sake of easier bug detection
(define (xlink:resource-label locator-or-resource) (car locator-or-resource))
(define (xlink:resource-data locator-or-resource) (cadr locator-or-resource))
If the following XLink constraint is fulfilled, adds information about the XLink locator element to 'locators+resources'. Otherwise, displays an error message and doesn't add anything. Constraint: Attributes on Locator Element The locator-type element must have the locator attribute (see 5.4 Locator Attribute (href)). The locator attribute (href) must have a value supplied.
(define (xlink:add-locator xlink-values position element locators+resources)
(let ((href (xlink:values-href xlink-values))
(role (xlink:values-role xlink-values))
(title (xlink:values-title xlink-values))
(label (xlink:values-label xlink-values)))
(cond
((not href)
(xlink:parser-error
position "locator element doesn't have an xlink:href attribute")
locators+resources)
(else
(let ((lst (string-split href (list #\#) 2)))
(call-with-values
(lambda ()
(cond
((= (length lst) 1) (values (car lst) #f))
((= (string-length (car lst)) 0) (values #f (cadr lst)))
(else (values (car lst) (cadr lst)))))
(lambda (uri fragment)
(cons
(xlink:make-locator-or-resource
label
`((uri ,@(if uri (list uri) '()))
,@(if fragment `((xpointer ,fragment)) '())
,@(if role `((role ,role)) '())
,@(if title `((title ,title)) '())))
locators+resources))))))))
Adds information concerning XLink resource element to 'locators+resources'
(define (xlink:add-resource xlink-values element sxpointer locators+resources)
(let ((role (xlink:values-role xlink-values))
(label (xlink:values-label xlink-values))
(title (xlink:values-title xlink-values)))
(cons
(xlink:make-locator-or-resource
label
`((uri)
(nodes ,element)
(xpointer ,(xlink:sxpointer->childseq sxpointer))
,@(if role `((role ,role)) '())
,@(if title `((title ,title)) '())))
locators+resources)))
Constructor
(define (xlink:make-arc-info from to linkbase position data) (list from to linkbase position data))
Accessors NOTE: We don't apply teta-reduction for the sake of easier bug detection
(define (xlink:arc-info-from arc-info) (car arc-info))
(define (xlink:arc-info-to arc-info) (cadr arc-info))
(define (xlink:arc-info-linkbase arc-info) (list-ref arc-info 2))
(define (xlink:arc-info-position arc-info) (list-ref arc-info 3))
(define (xlink:arc-info-data arc-info) (list-ref arc-info 4))
Adds arc information to 'arcs' datatype. A side effect - checks the following XLink constraint: Constraint: No Arc Duplication Each arc-type element must have a pair of from and to xlink-values that does not repeat the from and to xlink-values (respectively) for any other arc-type element in the same extended link; that is, each pair in a link must be unique.
(define (xlink:add-arc xlink-values position element arcs)
(let ((arcrole (xlink:values-arcrole xlink-values))
(title (xlink:values-title xlink-values))
(show (xlink:values-show xlink-values))
(actuate (xlink:values-actuate xlink-values))
(from (xlink:values-from xlink-values))
(to (xlink:values-to xlink-values)))
(let loop ((as arcs))
(if
(null? as)
(cons
(xlink:make-arc-info
from to
(equal? arcrole xlink:linkbase-uri)
position
`(,@(if arcrole `((arcrole ,arcrole)) '())
,@(if title `((title ,title)) '())
,@(if show `((show ,show)) '())
,@(if actuate `((actuate ,actuate)) '())))
arcs)
(let ((from2 (xlink:arc-info-from (car as)))
(to2 (xlink:arc-info-to (car as))))
(when
(and (or (not from) (not from2) (equal? from from2))
(or (not to) (not to2) (equal? to to2)))
(xlink:parser-error position "duplicate arcs - xlink:from"
(if from (string-append "=" from) " - omitted")
", xlink:to"
(if to (string-append "=" to) " - omitted")))
(loop (cdr as)))))))
XLink specification, 5.1.3: If no arc-type elements are provided in an extended link, then by extension the missing from and to xlink-values are interpreted as standing for all the labels in that link. Inserts such a default arc if 'arcs' are empty
(define (xlink:add-default-arc element arcs)
(if (null? arcs)
(list (xlink:make-arc-info
#f #f #f
0 ; position is dummy here, since it will never be used
'() ; none of the attributes arcrole, title, show, actuate
))
arcs))
If an xlink:label attribute is presented in 'xlink-values', it's value is added to 'declared-labels'. Otherwise, 'declared-labels' remain unchainged
(define (xlink:add-declared-label xlink-values declared-labels)
(let((label (xlink:values-label xlink-values)))
(if(not label)
declared-labels
(cons label declared-labels))))
The function checks the following XLink constraint Constraint: label, from, and to xlink-values The value of a label, from, or to attribute must be an NCName. If a value is supplied for a from or to attribute, it must correspond to the same value for some label attribute on a locator- or resource-type element that appears as a direct child inside the same extended-type element as does the arc-type element. Error message is displayed if some label was undeclared. The function always returns #t. It is called at the end-tag of an extended link element
(define (xlink:all-labels-declared arcs declared-labels)
(let loop ((arcs arcs))
(if
(null? arcs)
#t
(let((arc-info (car arcs)))
(let((from (xlink:arc-info-from arc-info))
(to (xlink:arc-info-to arc-info))
(position (xlink:arc-info-position arc-info)))
(when (and from (not (member from declared-labels)))
(xlink:parser-error position "label not defined - xlink:from=" from))
(when (and to (not (member to declared-labels)))
(xlink:parser-error position "label not defined - xlink:to=" to))
(loop (cdr arcs)))))))
Constructs a datatype (just a list in a current implementation) which contains xlink-values of all xlink-related attributes. For example, 'type' is the value of xlink:type attribute or #f if there is no such attribute. This datatype will be called 'xlink-values' in the latter text
(define (xlink:construct-xlink-values
type href role arcrole title show actuate label from to)
(list type href role arcrole title show actuate label from to))
Accessors NOTE: We don't apply teta-reduction for the sake of easier bug detection
(define (xlink:values-type xlink-values) (car xlink-values))
(define (xlink:values-href xlink-values) (cadr xlink-values))
(define (xlink:values-role xlink-values) (list-ref xlink-values 2))
(define (xlink:values-arcrole xlink-values) (list-ref xlink-values 3))
(define (xlink:values-title xlink-values) (list-ref xlink-values 4))
(define (xlink:values-show xlink-values) (list-ref xlink-values 5))
(define (xlink:values-actuate xlink-values) (list-ref xlink-values 6))
(define (xlink:values-label xlink-values) (list-ref xlink-values 7))
(define (xlink:values-from xlink-values) (list-ref xlink-values 8))
(define (xlink:values-to xlink-values) (list-ref xlink-values 9))
The function is given a list called 'attributes' (in SSAX parser). This list
has the form
attributes = (list attribute
attribute
...)
attribute = (cons (cons namespace-prefix attribute-name)
attribute-value )
or (cons attribute-name attribute-value )
namespaces - defined in "ssax.scm"
reads XLink attributes' values and returns a 'xlink-values' datatype
(the result of 'xlink:construct-xlink-values' function)
(define (xlink:read-attributes attributes namespaces)
(let loop ((attributes attributes)
(type #f) (href #f) (role #f) (arcrole #f) (title #f) (show #f)
(actuate #f) (label #f) (from #f) (to #f))
(if(null? attributes) ; the attribute list is over
(xlink:construct-xlink-values
type href role arcrole title show actuate label from to)
(let ((attribute (car attributes)))
(if
(not (pair? (car attribute))) ; attribute doesn't have namespace
(loop (cdr attributes)
type href role arcrole title show actuate label from to)
(let ((namespace-prefix (caar attribute))
(attribute-name (cdar attribute))
(attribute-value (cdr attribute)))
(let ((namespace-uri
(let rpt ((ns namespaces))
(cond
((null? ns) namespace-prefix)
((equal? (cadar ns) namespace-prefix) (cddar ns))
(else (rpt (cdr ns)))))))
(if
(not (equal? namespace-uri xlink:namespace-uri))
(loop (cdr attributes)
type href role arcrole title show actuate label from to)
(case attribute-name
((type) (loop (cdr attributes) attribute-value href role
arcrole title show actuate label from to))
((href) (loop (cdr attributes) type attribute-value role
arcrole title show actuate label from to))
((role) (loop (cdr attributes) type href attribute-value
arcrole title show actuate label from to))
((arcrole)
(loop (cdr attributes) type href role attribute-value title
show actuate label from to))
((title) (loop (cdr attributes) type href role arcrole
attribute-value show actuate label from to))
((show) (loop (cdr attributes) type href role arcrole title
attribute-value actuate label from to))
((actuate) (loop (cdr attributes) type href role arcrole
title show attribute-value label from to))
((label) (loop (cdr attributes) type href role arcrole title
show actuate attribute-value from to))
((from) (loop (cdr attributes) type href role arcrole title
show actuate label attribute-value to))
((to) (loop (cdr attributes) type href role arcrole title
show actuate label from attribute-value))
(else (loop (cdr attributes) type href role arcrole title
show actuate label from to)))))))))))
Reads SXML element's attributes
element - an SXML node representing an element
ns-prefixes = (list (list prefix namespace-uri)
(list prefix namespace-uri)
...)
prefix - a symbol
namespace-uri - a string
An 'xlink-values' datatype is returned
(define (xlink:read-SXML-attributes element ns-prefixes)
(let ((attr-node ((select-kids (ntype?? '@)) element)))
(if
(null? attr-node) ; no attributes
(xlink:construct-xlink-values #f #f #f #f #f #f #f #f #f #f)
(let loop ((attr-list (cdar attr-node))
(type #f) (href #f) (role #f) (arcrole #f) (title #f)
(show #f) (actuate #f) (label #f) (from #f) (to #f))
(if
(null? attr-list)
(xlink:construct-xlink-values
type href role arcrole title show actuate label from to)
(let ((attribute-name (symbol->string (caar attr-list)))
(attribute-value (cadar attr-list)))
(call-with-values
(lambda ()
(cond
((string-rindex attribute-name #\:)
=> (lambda (pos)
(values
(string->symbol (substring attribute-name 0 pos))
(string->symbol
(substring attribute-name (+ pos 1)
(string-length attribute-name))))))
(else
(values #f attribute-name))))
(lambda (prefix local)
(if
(not prefix) ; this is a non-qualified name
(loop (cdr attr-list)
type href role arcrole title show actuate label from to)
(let ((namespace-uri
(cond
((assoc prefix ns-prefixes)
=> (lambda (pair)
(string->symbol (cadr pair))))
(else
prefix))))
(if
(not (equal? namespace-uri xlink:namespace-uri))
(loop (cdr attr-list)
type href role arcrole title show actuate label from to)
(case local
((type) (loop (cdr attr-list) attribute-value href role
arcrole title show actuate label from to))
((href) (loop (cdr attr-list) type attribute-value role
arcrole title show actuate label from to))
((role) (loop (cdr attr-list) type href attribute-value
arcrole title show actuate label from to))
((arcrole)
(loop (cdr attr-list) type href role attribute-value title
show actuate label from to))
((title) (loop (cdr attr-list) type href role arcrole
attribute-value show actuate label from to))
((show) (loop (cdr attr-list) type href role arcrole title
attribute-value actuate label from to))
((actuate) (loop (cdr attr-list) type href role arcrole title
show attribute-value label from to))
((label) (loop (cdr attr-list) type href role arcrole title
show actuate attribute-value from to))
((from) (loop (cdr attr-list) type href role arcrole title
show actuate label attribute-value to))
((to) (loop (cdr attr-list) type href role arcrole title show
actuate label from attribute-value))
(else (loop (cdr attr-list) type href role arcrole title show
actuate label from to))))))))))))))
A helper function which is used by the next one value - a value of an attribute (#f if there is no such attribute) valid-xlink-values - a list of xlink-values which are allowed for this attribute attr-name - a string denotating a name of an attribute (for a message) position - position within a file Function always returns #t. Side effects: function "cerr"s a message if 'value' is not #f and not within 'valid-xlink-values'
(define (xlink:check-helper value valid-xlink-values attr-name position)
(cond
((not value) ) ; a value is #f - a correct situation
((not (member value valid-xlink-values))
(xlink:parser-error position "unexpected attribute value - "
attr-name "=" value))
(else #t)))
xlink-values = (type href role arcrole show actuate label from to) where, for example, 'type' is the value of xlink:type attribute or #f if there is no such attribute (this datatype is a result of 'read-xlink-attributes' function) position - position within a file The function checks the three similar XLink constraints: 1. Constraint: type Value The value of the type attribute must be supplied. The value must be one of "simple", "extended", "locator", "arc", "resource", "title", or "none". 2. Constraint: show Value If a value is supplied for a show attribute, it must be one of the xlink-values "new", "replace", "embed", "other", and "none". 3. Constraint: actuate Value If a value is supplied for an actuate attribute, it must be be one of the xlink-values "onLoad", "onRequest", "other", and "none". The result is always #t Side effects - error messages (printed by an 'xlink:check-helper' function above)
(define (xlink:check-type-show-actuate-constraints xlink-values position)
(xlink:check-helper (xlink:values-type xlink-values)
'("simple" "extended" "locator" "arc" "resource"
"title" "none")
"xlink:type"
position)
(xlink:check-helper (xlink:values-show xlink-values)
'("new" "replace" "embed" "other" "none")
"xlink:show"
position)
(xlink:check-helper (xlink:values-actuate xlink-values)
'("onLoad" "onRequest" "other" "none")
"xlink:actuate"
position))
(define (xlink:general-start position xlink-values seed)
(let((sxlink-arcs (xlink:seed-sxlink-arcs seed))
(sxpointer (xlink:seed-sxpointer seed))
(stack (cons (list position xlink-values) (xlink:seed-stack seed))))
(xlink:make-small-seed
'general sxlink-arcs (cons 1 sxpointer) stack)))
(define (xlink:general-end parent-seed seed element)
(let ((mode (xlink:seed-mode parent-seed))
(sxlink-arcs (xlink:seed-sxlink-arcs seed))
(sxpointer
(xlink:sxpointer4sibling (xlink:seed-sxpointer parent-seed)))
(stack (xlink:seed-stack parent-seed)))
(xlink:make-small-seed mode sxlink-arcs sxpointer stack)))
(define (xlink:none-start position xlink-values seed)
(let ((stack (cons (list position xlink-values) (xlink:seed-stack seed))))
(xlink:make-small-seed 'none '() '() stack)))
(define (xlink:none-end parent-seed seed element) parent-seed)
(define (xlink:simple-start position xlink-values seed)
(let ((stack (cons (list position xlink-values) (xlink:seed-stack seed))))
(xlink:make-small-seed 'none '() '() stack)))
(define (xlink:simple-end parent-seed seed element)
(let ((stack-element (car (xlink:seed-stack seed))))
(let ((position (car stack-element))
(xlink-values (cadr stack-element)))
(let ((mode (xlink:seed-mode parent-seed))
(sxlink-arcs (xlink:add-simple
xlink-values element position
(xlink:seed-sxpointer parent-seed)
(xlink:seed-sxlink-arcs parent-seed)))
(sxpointer
(xlink:sxpointer4sibling (xlink:seed-sxpointer parent-seed)))
(stack (xlink:seed-stack parent-seed)))
(xlink:make-small-seed
mode sxlink-arcs sxpointer stack)))))
(define (xlink:extended-start position xlink-values seed)
(let ((sxlink-arcs (xlink:seed-sxlink-arcs seed))
(sxpointer (cons 1 (xlink:seed-sxpointer seed)))
(stack (cons (list position xlink-values) (xlink:seed-stack seed))))
(xlink:make-full-seed 'extended sxlink-arcs sxpointer stack
'() '() '())))
(define (xlink:extended-end parent-seed seed element)
(let ((stack-element (car (xlink:seed-stack seed))))
(let ((position (car stack-element))
(xlink-values (cadr stack-element)))
(let ((locators+resources (xlink:seed-locators+resources seed))
(arcs (xlink:add-default-arc element (xlink:seed-arcs seed)))
(declared-labels (xlink:seed-declared-labels seed)))
(xlink:all-labels-declared arcs declared-labels)
(let ((mode (xlink:seed-mode parent-seed))
(sxlink-arcs
(xlink:add-extended
locators+resources arcs (xlink:seed-sxlink-arcs seed)
`(declaration
(uri) ; declared in this document
(nodes ,element)
(xpointer ,(xlink:sxpointer->childseq
(xlink:seed-sxpointer parent-seed)))
(position ,position))))
(sxpointer
(xlink:sxpointer4sibling (xlink:seed-sxpointer parent-seed)))
(stack (xlink:seed-stack parent-seed)))
(xlink:make-small-seed mode sxlink-arcs sxpointer stack))))))
(define (xlink:locator-start position xlink-values seed)
(let ((stack (cons (list position xlink-values) (xlink:seed-stack seed))))
(xlink:make-small-seed 'none '() '() stack)))
(define (xlink:locator-end parent-seed seed element)
(let ((stack-element (car (xlink:seed-stack seed))))
(let ((position (car stack-element))
(xlink-values (cadr stack-element)))
(let ((mode (xlink:seed-mode parent-seed))
(sxlink-arcs (xlink:seed-sxlink-arcs parent-seed))
(sxpointer
(xlink:sxpointer4sibling (xlink:seed-sxpointer parent-seed)))
(stack (xlink:seed-stack parent-seed))
(locators+resources
(xlink:add-locator xlink-values position element
(xlink:seed-locators+resources parent-seed)))
(arcs (xlink:seed-arcs parent-seed))
(declared-labels
(xlink:add-declared-label
xlink-values (xlink:seed-declared-labels parent-seed))))
(xlink:make-full-seed mode sxlink-arcs sxpointer stack
locators+resources arcs declared-labels)))))
(define (xlink:resource-start position xlink-values seed)
(let ((stack (cons (list position xlink-values) (xlink:seed-stack seed))))
(xlink:make-small-seed 'none '() '() stack)))
(define (xlink:resource-end parent-seed seed element)
(let((stack-element (car (xlink:seed-stack seed))))
(let ((position (car stack-element))
(xlink-values (cadr stack-element)))
(let* ((mode (xlink:seed-mode parent-seed))
(sxlink-arcs (xlink:seed-sxlink-arcs parent-seed))
(sxpointer
(xlink:sxpointer4sibling (xlink:seed-sxpointer parent-seed)))
(stack (xlink:seed-stack parent-seed))
(locators+resources
(xlink:add-resource xlink-values element sxpointer
(xlink:seed-locators+resources parent-seed)))
(arcs (xlink:seed-arcs parent-seed))
(declared-labels
(xlink:add-declared-label
xlink-values (xlink:seed-declared-labels parent-seed))))
(xlink:make-full-seed mode sxlink-arcs sxpointer stack
locators+resources arcs declared-labels)))))
(define (xlink:arc-start position xlink-values seed)
(let ((stack (cons (list position xlink-values) (xlink:seed-stack seed))))
(xlink:make-small-seed 'none '() '() stack)))
(define (xlink:arc-end parent-seed seed element)
(let ((stack-element (car (xlink:seed-stack seed))))
(let ((position (car stack-element))
(xlink-values (cadr stack-element)))
(let ((mode (xlink:seed-mode parent-seed))
(sxlink-arcs (xlink:seed-sxlink-arcs parent-seed))
(sxpointer
(xlink:sxpointer4sibling (xlink:seed-sxpointer parent-seed)))
(stack (xlink:seed-stack parent-seed))
(locators+resources (xlink:seed-locators+resources parent-seed))
(arcs (xlink:add-arc xlink-values position element
(xlink:seed-arcs parent-seed)))
(declared-labels
(xlink:seed-declared-labels parent-seed)))
(xlink:make-full-seed mode sxlink-arcs sxpointer stack
locators+resources arcs declared-labels)))))
Returns posiotion of a port NOTE: Specific for different Scheme implementations
(define (xlink:get-port-position port)
(cond-expand
(bigloo
(string-append "position " (number->string (input-port-position port))))
(chicken
(string-append
"line " (number->string (receive (row col) (port-position port) row))))
(gambit
; DL: was
;(string-append "line " (number->string (port-input-line-count port)))
(string-append "position "
(number->string (input-port-byte-position port))))
(guile
(string-append "line " (number->string (port-line port))))
(plt
(string-append "position " (number->string (file-position port))))
(else "unknown")))
This function displays an error message. #t is returned position - position within a file text - a message to display
(define (xlink:parser-error position . text)
(apply
cerr
(if
(string=? position "unknown")
(append (list nl "XLink error:" nl) text (list nl))
(append (list nl "XLink error in " position ":" nl) text (list nl)))))
Helper is used by the following functions in this section action-on-branch ::= (lambda (elem content-nodeset) ...) elem - SXML element that corresponds to the branch content-nodeset - new content The lambda should return the new elem
(define (xlink:branch-helper action-on-branch)
(lambda (document branch-lpath content-nodeset)
(letrec
(; Constructs a new branch if it doesn't exist in a document
(make-new-branch
(lambda (lpath)
(if (null? (cdr lpath)) ; lpath consists of a single member
(cons (car lpath) content-nodeset)
(list (car lpath) (make-new-branch (cdr lpath))))))
; Walks a document
(tree-walk
(lambda (elem lpath)
(if
(null? lpath) ; we have reached the desired node
(action-on-branch elem content-nodeset)
(let loop ((foll-siblings elem)
(prec-siblings '()))
(cond
((null? foll-siblings) ; no such branch
(cons*
(car elem)
(make-new-branch lpath)
(cdr elem)))
((and (pair? (car foll-siblings))
(eq? (caar foll-siblings) (car lpath)))
; match found
(append
(reverse prec-siblings)
(list
(tree-walk (car foll-siblings) (cdr lpath)))
(cdr foll-siblings)))
(else
(loop (cdr foll-siblings)
(cons (car foll-siblings) prec-siblings)))))))))
(tree-walk document branch-lpath))))
Replaces the content of the branch with a new content document - SXML document branch-lpath ::= (listof symbol) branch-lpath - is like an sxpath location path. There must be no more than one branch in an SXML tree with this location path. If this branch doesn't exist, it will be created as the first branch in a document content-nodeset ::= (listof node) content-nodeset - defines the content of the branch
(define xlink:replace-branch (xlink:branch-helper (lambda (elem content-nodeset) (cons (car elem) content-nodeset))))
Appends 'content-nodeset' to the content of the given branch
(define xlink:append-branch (xlink:branch-helper (lambda (elem content-nodeset) (append elem content-nodeset))))
Given a document, returns its URI (a string) #f is returned if there is no "@@/uri" subtree in the document
(define (xlink:get-uri doc)
(let ((nodeset ((select-kids (ntype?? 'uri))
((select-kids (ntype?? '@@)) doc))))
(if (null? nodeset) ; there is no "@@/uri" subtree
#f
(cadar nodeset))))
Adds the URI of the document where the arcs were declared, to sxlink-arcs Returns modified sxlink-arcs
(define (xlink:set-uri-for-sxlink-arcs uri sxlink-arcs)
(letrec
((process-arc
; uri-alist ::= (listof (cons uri resolved-uri))
; association between the URI and the corresponding resolved one
; Returns: (values new-node new-uri-alist)
(lambda (node uri-alist)
(case (car node) ; a node is always an SXML element
((linkbase simple inbound outbound third-party local-to-local
from to declaration)
; Recursive application to children
(call-with-values
(lambda () (process-nodeset (cdr node) uri-alist))
(lambda (new-children new-uri-alist)
(values (cons (car node) new-children)
new-uri-alist))))
((uri)
(cond
((null? (cdr node)) ; no URI is set
(values `(uri ,uri) uri-alist))
((assoc (cadr node) uri-alist)
=> (lambda (pair)
(values `(uri ,(cdr pair)) uri-alist)))
(else
(let ((resolved-uri
(ar:resolve-uri-according-base uri (cadr node))))
(values `(uri ,resolved-uri)
(cons
(cons (cadr node) resolved-uri)
uri-alist))))))
(else
(values node uri-alist)))))
; Applies the previous function to a nodeset
(process-nodeset
(lambda (nodeset uri-alist)
(let loop ((nset nodeset)
(res '())
(uri-alist uri-alist))
(if
(null? nset)
(values (reverse res) uri-alist)
(call-with-values
(lambda () (process-arc (car nset) uri-alist))
(lambda (new-node new-uri-alist)
(loop (cdr nset)
(cons new-node res)
new-uri-alist))))))))
(call-with-values
(lambda () (process-nodeset sxlink-arcs '()))
(lambda (new-sxlink-arcs dummy)
new-sxlink-arcs))))
This function is called by the NEW-LEVEL-SEED handler A new 'xlink:seed' is returned
(define (xlink:new-level-seed-handler port attributes namespaces seed)
(let ((position (xlink:get-port-position port))
(xlink-values (xlink:read-attributes attributes namespaces)))
(xlink:check-type-show-actuate-constraints xlink-values position)
(let((mode (xlink:seed-mode seed))
(type (xlink:values-type xlink-values)))
(case mode
((general)
(case (if type (string->symbol type) type)
((simple) (xlink:simple-start position xlink-values seed))
((extended) (xlink:extended-start position xlink-values seed))
((none) (xlink:none-start position xlink-values seed))
(else (xlink:general-start position xlink-values seed))))
((extended)
(case (if type (string->symbol type) type)
((locator) (xlink:locator-start position xlink-values seed))
((resource) (xlink:resource-start position xlink-values seed))
((arc) (xlink:arc-start position xlink-values seed))
(else (xlink:none-start position xlink-values seed))))
((none) (xlink:none-start position xlink-values seed))
(else
(xlink:parser-error position "internal processor error - mode="
mode)
(xlink:none-start position xlink-values seed))))))
This function is called by the FINISH-ELEMENT handler A new 'xlink:seed' is returned
(define (xlink:finish-element-handler parent-seed seed element)
(let((xlink-values (cadar (xlink:seed-stack seed))))
(let((mode (xlink:seed-mode parent-seed))
(type (xlink:values-type xlink-values)))
(case mode
((general)
(case (if type (string->symbol type) type)
((simple) (xlink:simple-end parent-seed seed element))
((extended) (xlink:extended-end parent-seed
seed element))
((none) (xlink:none-end parent-seed seed element))
(else (xlink:general-end parent-seed seed element))))
((extended)
(case (if type (string->symbol type) type)
((locator) (xlink:locator-end parent-seed
seed element))
((resource) (xlink:resource-end parent-seed
seed element))
((arc) (xlink:arc-end parent-seed seed element))
(else (xlink:none-end parent-seed seed element))))
((none) (xlink:none-end parent-seed seed element))
(else
(xlink:parser-error 0 "internal processor error - mode="
mode)
(xlink:none-end parent-seed seed element))))))
Constructs the member of an axuiliary list
(define (xlink:ending-action xlink:seed)
(let ((sxlink-arcs (reverse (xlink:seed-sxlink-arcs xlink:seed))))
`(sxlink
(declared-here ,@sxlink-arcs))))
document - an SXML document The function emulates a 'fold-ts' operation. A new SXML document is returned. It contains an auxiliary list with an 'sxlink' subtree. If the source document already contains such a subtree, it will be replaced. Other subtrees in an auxiliary list will remain unchanged.
(define (SXML->SXML+xlink document)
(letrec
((fold-ts
(lambda (node ns-prefixes seed)
(let ((xlink-values (xlink:read-SXML-attributes node ns-prefixes)))
(let ((mode (xlink:seed-mode seed))
(type (xlink:values-type xlink-values))
(pos "unknown"))
(let rpt
((kids ((select-kids (ntype?? '*)) node))
(new-seed
(case mode
((general)
(case (if type (string->symbol type) type)
((simple)
(xlink:simple-start pos xlink-values seed))
((extended)
(xlink:extended-start pos xlink-values seed))
((none)
(xlink:none-start pos xlink-values seed))
(else
(xlink:general-start pos xlink-values seed))))
((extended)
(case (if type (string->symbol type) type)
((locator)
(xlink:locator-start pos xlink-values seed))
((resource)
(xlink:resource-start pos xlink-values seed))
((arc)
(xlink:arc-start pos xlink-values seed))
(else
(xlink:none-start pos xlink-values seed))))
((none)
(xlink:none-start pos xlink-values seed))
(else
(xlink:parser-error pos "internal processor error - mode=" mode)
(xlink:none-start pos xlink-values seed)))))
(if
(not (null? kids))
(rpt (cdr kids)
(fold-ts (car kids) ns-prefixes new-seed))
(case mode
((general)
(case (if type (string->symbol type) type)
((simple) (xlink:simple-end seed new-seed node))
((extended) (xlink:extended-end seed new-seed node))
((none) (xlink:none-end seed new-seed node))
(else (xlink:general-end seed new-seed node))))
((extended)
(case (if type (string->symbol type) type)
((locator) (xlink:locator-end seed new-seed node))
((resource) (xlink:resource-end seed new-seed node))
((arc) (xlink:arc-end seed new-seed node))
(else (xlink:none-end seed new-seed node))))
((none) (xlink:none-end seed new-seed node))
(else
(xlink:parser-error pos
"internal processor error - mode=" mode)
(xlink:none-end seed new-seed node))))))))))
(let* ((ns-prefixes
(let ((ns-node ((select-kids (ntype?? '*NAMESPACES*))
((select-kids (ntype?? '@@)) document))))
(if (null? ns-node)
'()
(cdar ns-node))))
(sxlink-arcs
(xlink:seed-sxlink-arcs
(fold-ts ((select-kids (ntype?? '*)) document)
ns-prefixes
(xlink:make-small-seed 'general '() '(1) '()))))
(uri (xlink:get-uri document)))
(xlink:append-branch
document
'(@@ sxlink declared-here)
(if uri ; URI for the document supplied
(xlink:set-uri-for-sxlink-arcs uri sxlink-arcs)
sxlink-arcs)))))
(define (SHTML->SHTML+xlink document)
(letrec
((tree-walk
; Returns (listof sxlink-arc)
(lambda (node sxpointer)
(let loop
((sxlink-arcs
(if
(not (and (pair? node) (eq? (car node) 'a)))
'() ; it is not an <A> element
(let ((href ((select-kids (ntype?? '*text*))
((select-kids (ntype?? 'href))
((select-kids (ntype?? '@)) node)))))
(if
(null? href) ; <A> doesn't contain href attribute
'()
(call-with-values
(lambda ()
(let ((lst (string-split (car href) (list #\#) 2)))
(cond
((null? lst) ; (car href)="" - the real situation
(values (car href) #f))
((= (length lst) 1) ; no anchor
(values (car lst) #f))
((= (string-length (car lst)) 0)
(values #f (cadr lst)))
(else
(values (car lst) (cadr lst))))))
(lambda (uri-ending fragment)
`((simple
(from
(uri) ; from this document
(nodes ,node)
(xpointer ,(xlink:sxpointer->childseq sxpointer)))
(to
(uri ,@(if uri-ending (list uri-ending) '()))
,@(if fragment
`((xpointer
,(string-append
"xpointer(descendant::*[a/@name='"
fragment "'])")))
'()))
(declaration
(uri)
(nodes ,node)
(xpointer
,(xlink:sxpointer->childseq sxpointer))))))
)))))
(kids ((select-kids (ntype?? '*)) node))
(kid-pos 1))
(if (null? kids) ; every child node processed
sxlink-arcs
(loop
(append sxlink-arcs
(tree-walk (car kids) (cons kid-pos sxpointer)))
(cdr kids)
(+ kid-pos 1)))))))
(let ((sxlink-arcs (tree-walk document '()))
(uri (xlink:get-uri document)))
(xlink:append-branch
document
'(@@ sxlink declared-here)
(if uri ; URI for the document supplied
(xlink:set-uri-for-sxlink-arcs uri sxlink-arcs)
sxlink-arcs)))))