source: project/release/4/nemo/tags/2.21/stx-engine.scm @ 15201

Last change on this file since 15201 was 15201, checked in by Ivan Raikov, 12 years ago

created release 2.21 of nemo

File size: 5.3 KB
Line 
1;; $Id: stx-engine.scm,v 1.9502 2004/01/22 01:11:45 kl Exp kl $
2
3;=============================================================================
4; Auxilliary
5
6
7(define (cerr . args)
8  (for-each (lambda (x)
9              (if (procedure? x) (x (current-error-port)) (display x (current-error-port))))
10            args))
11(define (stx:error . messages)
12  (cerr nl "STX: ")
13  (apply cerr messages)
14  (cerr nl)
15  (exit -1))
16
17
18;------------------------------------------------------------------------------
19; These macros provide support for abbreviated stylesheets:
20;
21;  <Stylesheet> ::= (stx:stylesheet <Template>+)
22;  <Template>   ::= (match <SXPath> <Handler>)
23;  <SXPath>     ::= SXPath expression
24;  <Handler>    ::= (lambda (current-node stx:templates current-root $) ...)
25;
26; For example:
27;  (stx:stylesheet
28;    (match "//element[state/@condition='standard']"
29;          (lambda (current-node stx:templates current-root $)
30;            (sxml:text current-node)))
31;    (match (table (tr 4))
32;          (lambda (current-node stx:templates current-root $)
33;            `(ol
34;               ,@(map
35;                   (lambda(x) `(li ,x))
36;               ,((sxpath '(td *text*)) current-node))))))
37
38(define-syntax  sxml:stylesheet
39   (syntax-rules  ()
40                 ((stx rule ...)
41                  (list
42                    ; default handler
43                    (list '*default* 
44                          (lambda (node bindings root environment)
45                             (stx:apply-templates (sxml:content node) 
46                                                  bindings 
47                                                  root environment)
48                             ))
49                    ; handler for textual nodes
50                    (list '*text* 
51                          (lambda(text) text)) 
52                    rule ...))))
53
54(define-syntax  sxml:match
55   (syntax-rules  ()
56                 ((match pattern handler)
57                   (list (if (symbol? pattern) pattern (sxpath pattern))
58                           handler))
59                 ))
60
61
62;=============================================================================
63; Tree transformation
64
65; stx:apply-templates:: <tree> x <templates> x <root> x <environment> -> <new-tree>
66; where
67; <templates> ::= <default-template> <text-template> <template>*
68; <default-template> ::= (*default* . <handler>)
69; <text-template> ::= (*text* . <handler>)
70; <template>  ::= (<matcher> <handler>) | ( XMLname <handler>)
71; <root>     ::= <document-root>
72; <environment> ::= <lambda-tuple>
73; <matcher>  ::= <node> <root> -> <nodeset>
74; <handler> :: <node> <templates> <root> <environment> -> <new-node>
75;
76; The stx:apply-templates function visits top-level nodes of a given tree and
77; process them in accordance with a list of templates given.
78; If a node is a textual one then it is processed usind 'text-template',
79; which has to be second element in given list of templates.
80; If a node is a pair then stx:apply-templates looks up a corresponding template
81; among  given <templates> using stx:find-template function.
82; If failed, stx:apply-templates tries to locate a *default* template,
83; which has to be first element in given list of templates. It's an
84; error if this latter attempt fails as well. 
85; Having found a template, its handler is applied to the current node.
86; The result of the handler application, which should
87; also be a <tree>, replaces the current node in output tree.
88;
89; This function is slightly similar to Oleg Kiselyov's "pre-post-order" function
90; with *preorder* bindings.
91(define (stx:apply-templates tree templates root environment)
92  (cond
93    ((nodeset? tree)
94     (map (lambda (a-tree) 
95            (stx:apply-templates a-tree templates root environment)) 
96          tree))
97    ((pair? tree) 
98     (cond
99       (;(tee-4 "Template: "
100        (stx:find-template tree 
101                      (cddr templates) ; *default* and *text* skipped
102                      root);)
103        => (lambda (template) 
104             ((cadr template) tree templates root environment)))
105       (else
106         (if (eq? '*default* (caar templates))
107           ((cadar templates) tree templates root environment)
108           (stx:error "stx:apply-templates: There is no template in: " templates
109                      nl "for: " tree
110                      )) 
111         )))
112    ((string? tree) ; for *text* , simple speed-up - just return 'tree'
113         (if (eq? '*text* (caadr templates))
114           ((cadadr templates) tree)
115           (stx:error "stx:apply-templates: There is no *text* templates for: " 
116                      templates))) 
117    (else (stx:error "Unexpected type of node: " tree))))
118
119;  stx:find-template: <node> x <templates> x <root> -> <template>
120;  This function returns first template in <templates> whouse <matcher>
121;  matches given <node>
122;  <matcher> matches node if:
123;    - if it is a symbol and its the same as the name of the node matched
124;    - if it is a procedure (sxpath/txpath generated one) then it is
125;     applyed (with respect to given <root>) sequentially to the matched node
126;     and its parents until the matched node is a member of a resulting nodeset
127;     or root node is reached. In the first case the node matches successfuly,
128;     in the second case it does not.
129(define (stx:find-template node templates root)
130  (let ((pattern-matches? 
131          (lambda (node pattern-test) 
132            (let rpt ((context-node node))
133              (cond
134                ((null? context-node) #f)
135 ;              ((memq node (pattern-test context-node root '()))
136                ((memq node (pattern-test context-node `((*root* . ,root))))
137                 #t)
138                (else ; try PARENT
139                  (rpt ((sxml:node-parent root) context-node)))))))) 
140    (let rpt ((bnd templates)) 
141      (cond ((null? bnd) #f)
142            ((and (symbol? (caar bnd)) (eq? (caar bnd) (car node)))
143             (car bnd))
144            ((and (procedure? (caar bnd)) ; redundant?
145                  (pattern-matches? node (caar bnd)))
146             (car bnd))
147            (else (rpt (cdr bnd)))))))
148
149
Note: See TracBrowser for help on using the repository browser.