;;;
;;; sxml.sxpath - SXML Query Language
;;;
;;;   This file is mechanically translated for Gauche from
;;;   Oleg Kiselyov's SXPATH SXML query language, with
;;;   Kirill Lisovsky and Dmitry Lizorkin's improvements.
;;;   The original files are:
;;;      sxpathlib.scm,v 3.915
;;;      sxpath.scm,v 1.1
;;;      sxpath-ext.scm,v 1.911
;;;   Public domain.
;;;
;;; $Id: sxpath.scm.in,v 1.6 2003/11/05 12:38:33 shirok Exp $
;;;

(define-module sxml.sxpath
  (use srfi-1)
  (use srfi-2)
  (use srfi-11)
  (use srfi-13)
  (use text.parse)
  (use sxml.adaptor)
  (export sxpath nodeset? as-nodeset sxml:element? ntype-names??
          ntype?? ntype-namespace-id?? sxml:invert node-eq? node-equal?
          node-pos sxml:filter take-until take-after map-union
          node-reverse node-trace select-kids node-self node-join
          node-reduce node-or node-closure
          if-sxpath if-car-sxpath car-sxpath
          sxml:id-alist
          sxml:string sxml:boolean sxml:number sxml:string-value
          sxml:node? sxml:attr-list sxml:id sxml:equality-cmp
          sxml:equal? sxml:not-equal? sxml:relational-cmp
          sxml:attribute sxml:child sxml:parent sxml:ancestor
          sxml:ancestor-or-self sxml:descendant sxml:descendant-or-self
          sxml:following sxml:following-sibling sxml:namespace
          sxml:preceding sxml:preceding-sibling
          sxml:child-nodes sxml:child-elements
          ))
(select-module sxml.sxpath)

;;; Generated from Oleg Kiselyov's "sxpathlib.scm"
(define (nodeset? x) (or (and (pair? x) (not (symbol? (car x)))) (null? x)))
(define (as-nodeset x) (if (nodeset? x) x (list x)))
(define (sxml:element? obj) (and (pair? obj) (symbol? (car obj)) (not (memq (car obj) '(|@| |@@| *PI* *COMMENT* *ENTITY*)))))
(define (ntype-names?? crit) (lambda (node) (and (pair? node) (memq (car node) crit))))
(define (ntype?? crit) (case crit ((*) sxml:element?) ((*any*) (lambda (node) #t)) ((*text*) (lambda (node) (string? node))) ((*data*) (lambda (node) (not (pair? node)))) (else (lambda (node) (and (pair? node) (eq? crit (car node)))))))
(define (ntype-namespace-id?? ns-id) (lambda (node) (and (pair? node) (not (memq (car node) '(|@| |@@| *PI* *COMMENT* *ENTITY*))) (let ((nm (symbol->string (car node)))) (cond ((string-rindex nm #\:) => (lambda (pos) (and (= pos (string-length ns-id)) (string-prefix? ns-id nm)))) (else (not ns-id)))))))
(define (sxml:invert pred) (lambda (node) (case (pred node) ((#f '()) node) (else #f))))
(define (node-eq? other) (lambda (node) (eq? other node)))
(define (node-equal? other) (lambda (node) (equal? other node)))
(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 (|--| n)) (cdr nodeset))))))
(define (sxml:filter pred?) (lambda (lst) (let loop ((lst (as-nodeset 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)))))))
(define (take-until pred?) (lambda (lst) (let loop ((lst (as-nodeset 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)))))))))
(define (take-after pred?) (lambda (lst) (let loop ((lst (as-nodeset lst))) (if (null? lst) lst (let ((pred-result (pred? (car lst)))) (if (and pred-result (not (null? pred-result))) (cdr lst) (loop (cdr lst))))))))
(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))))))
(define node-reverse (lambda (node-or-nodeset) (if (not (nodeset? node-or-nodeset)) (list node-or-nodeset) (reverse node-or-nodeset))))
(define (node-trace title) (lambda (node-or-nodeset) (cout nl "-->" title " :") (pp node-or-nodeset) node-or-nodeset))
(define (select-kids test-pred?) (lambda (node) (cond ((null? node) node) ((not (pair? node)) '()) ((symbol? (car node)) ((sxml:filter test-pred?) (cdr node))) (else (map-union (select-kids test-pred?) node)))))
(define node-self sxml:filter)
(define (node-join . selectors) (lambda (nodeset) (let loop ((nodeset nodeset) (selectors selectors)) (if (null? selectors) nodeset (loop (if (nodeset? nodeset) (map-union (car selectors) nodeset) ((car selectors) nodeset)) (cdr selectors))))))
(define (node-reduce . converters) (lambda (nodeset) (let loop ((nodeset nodeset) (converters converters)) (if (null? converters) nodeset (loop ((car converters) nodeset) (cdr converters))))))
(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))))))
(define (node-closure test-pred?) (lambda (node) (let loop ((parent node) (result '())) (if (null? parent) result (loop (sxml:child-elements parent) (append result ((select-kids test-pred?) parent)))))))
(define (sxml:node? node) (not (and (pair? node) (memq (car node) '(|@| |@@|)))))
(define (sxml:attr-list obj) (if (and (sxml:element? obj) (not (null? (cdr obj))) (pair? (cadr obj)) (eq? '|@| (caadr obj))) (cdadr obj) '()))
(define (sxml:attribute test-pred?) (let ((fltr (sxml:filter test-pred?))) (lambda (node) (fltr (apply append (map sxml:attr-list (as-nodeset node)))))))
(define (sxml:child test-pred?) (lambda (node) (cond ((null? node) node) ((not (pair? node)) '()) ((memq (car node) '(*PI* *COMMENT* *ENTITY*)) '()) ((symbol? (car node)) ((sxml:filter test-pred?) (cdr node))) (else (map-union (sxml:child test-pred?) node)))))
(define (sxml:parent test-pred?) (lambda (root-node) (lambda (node) (if (nodeset? node) (map-union ((sxml:parent test-pred?) root-node) node) (let rpt ((pairs (apply append (map (lambda (root-n) (map (lambda (arg) (cons arg root-n)) (append (sxml:attr-list root-n) (sxml:child-nodes root-n)))) (as-nodeset root-node))))) (if (null? pairs) '() (let ((pair (car pairs))) (if (eq? (car pair) node) ((sxml:filter test-pred?) (list (cdr pair))) (rpt (append (map (lambda (arg) (cons arg (car pair))) (append (sxml:attr-list (car pair)) (sxml:child-nodes (car pair)))) (cdr pairs)))))))))))
(define node-parent (sxml:parent (ntype?? '*any*)))
(define sxml:child-nodes (sxml:child sxml:node?))
(define sxml:child-elements (select-kids sxml:element?))
;;; Generated from Oleg Kiselyov's "sxpath.scm"
(define (sxpath path . ns-binding) (let loop ((converters '()) (root-vars '()) (path (if (string? path) (list path) path))) (cond ((null? path) (lambda (node . root-var-binding) (let ((root-node (if (null? root-var-binding) node (car root-var-binding))) (var-binding (if (or (null? root-var-binding) (null? (cdr root-var-binding))) '() (cadr root-var-binding)))) (let rpt ((nodeset (if (nodeset? node) node (list node))) (conv (reverse converters)) (r-v (reverse root-vars))) (if (null? conv) nodeset (rpt (if (car r-v) ((car conv) nodeset root-node var-binding) ((car conv) nodeset)) (cdr conv) (cdr r-v))))))) ((and (pair? (car path)) (not (null? (car path))) (eq? 'or@ (caar path))) (loop (cons (select-kids (ntype-names?? (cdar path))) converters) (cons #f root-vars) (cdr path))) ((and (pair? (car path)) (not (null? (car path))) (eq? 'not@ (caar path))) (loop (cons (select-kids (sxml:invert (ntype-names?? (cdar path)))) converters) (cons #f root-vars) (cdr path))) ((procedure? (car path)) (loop (cons (car path) converters) (cons #t root-vars) (cdr path))) ((eq? '// (car path)) (loop (cons (node-or (node-self (ntype?? '*any*)) (node-closure (ntype?? '*any*))) converters) (cons #f root-vars) (cdr path))) ((symbol? (car path)) (loop (cons (select-kids (ntype?? (car path))) converters) (cons #f root-vars) (cdr path))) ((string? (car path)) (and-let* ((f (txpath (car path) ns-binding))) (loop (cons f converters) (cons #t root-vars) (cdr path)))) ((and (pair? (car path)) (eq? 'equal? (caar path))) (loop (cons (select-kids (apply node-equal? (cdar path))) converters) (cons #f root-vars) (cdr path))) ((and (pair? (car path)) (eq? 'ns-id:* (caar path))) (loop (cons (select-kids (ntype-namespace-id?? (cadar path))) converters) (cons #f root-vars) (cdr path))) ((and (pair? (car path)) (eq? 'eq? (caar path))) (loop (cons (select-kids (apply node-eq? (cdar path))) converters) (cons #f root-vars) (cdr path))) ((pair? (car path)) (and-let* ((select (if (symbol? (caar path)) (lambda (node root-node . var-binding) ((select-kids (ntype?? (caar path))) node)) (sxpath (caar path))))) (let reducer ((reducing-path (cdar path)) (filters '())) (cond ((null? reducing-path) (loop (cons (lambda (node root-node var-binding) (map-union (lambda (node) (let label ((nodeset (select node root-node var-binding)) (fs (reverse filters))) (if (null? fs) nodeset (label ((car fs) nodeset root-node var-binding) (cdr fs))))) (if (nodeset? node) node (list node)))) converters) (cons #t root-vars) (cdr path))) ((number? (car reducing-path)) (reducer (cdr reducing-path) (cons (lambda (node root-node var-binding) ((node-pos (car reducing-path)) node)) filters))) (else (and-let* ((func (sxpath (car reducing-path)))) (reducer (cdr reducing-path) (cons (lambda (node root-node var-binding) ((sxml:filter (lambda (n) (func n root-node var-binding))) node)) filters)))))))) (else (cerr "Invalid path step: " (car path)) #f))))
(define (if-sxpath path) (lambda (obj) (let ((x ((sxpath path) obj))) (if (null? x) #f x))))
(define (if-car-sxpath path) (lambda (obj) (let ((x ((sxpath path) obj))) (if (null? x) #f (car x)))))
(define (car-sxpath path) (lambda (obj) (let ((x ((sxpath path) obj))) (if (null? x) '() (car x)))))
(define (sxml:id-alist node . lpaths) (apply append (map (lambda (lp) (let ((lpr (reverse lp))) (map (lambda (nd) (cons (sxml:attr nd (car lpr)) nd)) ((sxpath (reverse (cons (node-self (sxpath `(|@| ,(car lpr)))) (cddr lpr)))) node)))) lpaths)))
;;; Generated from Oleg Kiselyov's "sxpath-ext.scm"
(define (sxml:string object) (cond ((string? object) object) ((nodeset? object) (if (null? object) "" (sxml:string-value (car object)))) ((number? object) (number->string object)) ((boolean? object) (if object "true" "false")) (else "")))
(define (sxml:boolean object) (cond ((boolean? object) object) ((number? object) (not (= object 0))) ((string? object) (> (string-length object) 0)) ((nodeset? object) (not (null? object))) (else #f)))
(define (sxml:number obj) (cond ((number? obj) obj) ((string? obj) (let ((nmb (call-with-input-string obj read))) (if (number? nmb) nmb 0))) ((boolean? obj) (if obj 1 0)) ((nodeset? obj) (sxml:number (sxml:string obj))) (else 0)))
(define (sxml:string-value node) (if (not (pair? node)) (if (string? node) node "") (apply string-append (cons "" (map sxml:string-value ((cond ((null? (cdr node)) cdr) ((not (pair? (cadr node))) cdr) ((not (equal? (caadr node) '|@|)) cdr) (else cddr)) node))))))
(define (sxml:id id-index) (lambda (object) (if (nodeset? object) (let loop ((str-lst (map sxml:string-value object)) (res '())) (if (null? str-lst) (reverse res) (let ((node (sxml:lookup (car str-lst) id-index))) (if (not node) (loop (cdr str-lst) res) (loop (cdr str-lst) (cons node res)))))) (let rpt ((lst (string->list (sxml:string object))) (tmp '()) (res '())) (cond ((null? lst) (if (null? tmp) (reverse res) (let ((node (sxml:lookup (list->string (reverse tmp)) id-index))) (if (not node) (reverse res) (reverse (cons node res)))))) ((member (car lst) '(#\space #\return #\newline #\tab)) (if (null? tmp) (rpt (cdr lst) tmp res) (let ((node (sxml:lookup (list->string (reverse tmp)) id-index))) (if (not node) (rpt (cdr lst) '() res) (rpt (cdr lst) '() (cons node res)))))) (else (rpt (cdr lst) (cons (car lst) tmp) res)))))))
(define (sxml:equality-cmp bool-op number-op string-op) (lambda (obj1 obj2) (cond ((and (not (nodeset? obj1)) (not (nodeset? obj2))) (cond ((boolean? obj1) (bool-op obj1 (sxml:boolean obj2))) ((boolean? obj2) (bool-op (sxml:boolean obj1) obj2)) ((number? obj1) (number-op obj1 (sxml:number obj2))) ((number? obj2) (number-op (sxml:number obj1) obj2)) (else (string-op obj1 obj2)))) ((and (nodeset? obj1) (nodeset? obj2)) (let first ((str-set1 (map sxml:string-value obj1)) (str-set2 (map sxml:string-value obj2))) (cond ((null? str-set1) #f) ((let second ((elem (car str-set1)) (set2 str-set2)) (cond ((null? set2) #f) ((string-op elem (car set2)) #t) (else (second elem (cdr set2))))) #t) (else (first (cdr str-set1) str-set2))))) (else (let*-values (((nset elem) (if (nodeset? obj1) (values obj1 obj2) (values obj2 obj1)))) (cond ((boolean? elem) (bool-op elem (sxml:boolean nset))) ((number? elem) (let loop ((nset (map (lambda (node) (sxml:number (sxml:string-value node))) nset))) (cond ((null? nset) #f) ((number-op elem (car nset)) #t) (else (loop (cdr nset)))))) ((string? elem) (let loop ((nset (map sxml:string-value nset))) (cond ((null? nset) #f) ((string-op elem (car nset)) #t) (else (loop (cdr nset)))))) (else (cerr "Unknown datatype: " elem nl) #f)))))))
(define sxml:equal? (sxml:equality-cmp eq? = string=?))
(define sxml:not-equal? (sxml:equality-cmp (lambda (bool1 bool2) (not (eq? bool1 bool2))) (lambda (num1 num2) (not (= num1 num2))) (lambda (str1 str2) (not (string=? str1 str2)))))
(define (sxml:relational-cmp op) (lambda (obj1 obj2) (cond ((not (or (nodeset? obj1) (nodeset? obj2))) (op (sxml:number obj1) (sxml:number obj2))) ((boolean? obj1) (op (sxml:number obj1) (sxml:number (sxml:boolean obj2)))) ((boolean? obj2) (op (sxml:number (sxml:boolean obj1)) (sxml:number obj2))) ((or (null? obj1) (null? obj2)) #f) (else (op (cond ((nodeset? obj1) (let ((nset1 (map (lambda (node) (sxml:number (sxml:string-value node))) obj1))) (let first ((num1 (car nset1)) (nset1 (cdr nset1))) (cond ((null? nset1) num1) ((op num1 (car nset1)) (first num1 (cdr nset1))) (else (first (car nset1) (cdr nset1))))))) ((string? obj1) (sxml:number obj1)) (else obj1)) (cond ((nodeset? obj2) (let ((nset2 (map (lambda (node) (sxml:number (sxml:string-value node))) obj2))) (let second ((num2 (car nset2)) (nset2 (cdr nset2))) (cond ((null? nset2) num2) ((op num2 (car nset2)) (second (car nset2) (cdr nset2))) (else (second num2 (cdr nset2))))))) ((string? obj2) (sxml:number obj2)) (else obj2)))))))
(define (sxml:ancestor test-pred?) (lambda (root-node) (lambda (node) (if (nodeset? node) (map-union ((sxml:ancestor test-pred?) root-node) node) (let rpt ((paths (if (nodeset? root-node) (map list root-node) (list (list root-node))))) (if (null? paths) '() (let ((path (car paths))) (if (eq? (car path) node) ((sxml:filter test-pred?) (cdr path)) (rpt (append (map (lambda (arg) (cons arg path)) (append ((sxml:attribute (ntype?? '*)) (car path)) ((sxml:child sxml:node?) (car path)))) (cdr paths)))))))))))
(define (sxml:ancestor-or-self test-pred?) (lambda (root-node) (lambda (node) (if (nodeset? node) (map-union ((sxml:ancestor-or-self test-pred?) root-node) node) (let rpt ((paths (if (nodeset? root-node) (map list root-node) (list (list root-node))))) (if (null? paths) ((sxml:filter test-pred?) (list node)) (let ((path (car paths))) (if (eq? (car path) node) ((sxml:filter test-pred?) path) (rpt (append (map (lambda (arg) (cons arg path)) (append ((sxml:attribute (ntype?? '*)) (car path)) ((sxml:child sxml:node?) (car path)))) (cdr paths)))))))))))
(define (sxml:descendant test-pred?) (lambda (node) (if (nodeset? node) (map-union (sxml:descendant test-pred?) node) (let rpt ((res '()) (more ((sxml:child sxml:node?) node))) (if (null? more) (reverse res) (rpt (if (test-pred? (car more)) (cons (car more) res) res) (append ((sxml:child sxml:node?) (car more)) (cdr more))))))))
(define (sxml:descendant-or-self test-pred?) (lambda (node) (if (nodeset? node) (map-union (sxml:descendant-or-self test-pred?) node) (let rpt ((res '()) (more (list node))) (if (null? more) (reverse res) (rpt (if (test-pred? (car more)) (cons (car more) res) res) (append ((sxml:child sxml:node?) (car more)) (cdr more))))))))
(define (sxml:following test-pred?) (lambda (root-node) (lambda (node) (if (nodeset? node) (map-union ((sxml:following test-pred?) root-node) node) (let loop ((seq (if (nodeset? root-node) (list root-node) (list (list root-node))))) (cond ((null? seq) '()) ((null? (car seq)) (loop (cdr seq))) ((eq? (caar seq) node) (let rpt ((seq (cdr (apply append seq))) (res '())) (if (null? seq) res (rpt (cdr seq) (append res ((sxml:descendant-or-self test-pred?) (car seq))))))) ((and (sxml:element? (caar seq)) (memq node (sxml:attr-list (caar seq)))) (let rpt ((sq (cdr (apply append seq))) (res ((sxml:descendant test-pred?) (caar seq)))) (if (null? sq) res (rpt (cdr sq) (append res ((sxml:descendant-or-self test-pred?) (car sq))))))) (else (loop (cons ((sxml:child sxml:node?) (caar seq)) (cons (cdar seq) (cdr seq)))))))))))
(define (sxml:following-sibling test-pred?) (lambda (root-node) (lambda (node) (if (nodeset? node) (map-union ((sxml:following-sibling test-pred?) root-node) node) (let loop ((seqs (if (nodeset? root-node) (list root-node) (list (list root-node))))) (if (null? seqs) '() (let rpt ((seq (car seqs))) (cond ((null? seq) (loop (append (map (sxml:child sxml:node?) (car seqs)) (cdr seqs)))) ((eq? (car seq) node) ((sxml:filter test-pred?) (cdr seq))) (else (rpt (cdr seq)))))))))))
(define (sxml:namespace test-pred?) (lambda (node) ((sxml:filter test-pred?) (sxml:ns-list node))))
(define (sxml:preceding test-pred?) (lambda (root-node) (lambda (node) (if (nodeset? node) (map-union ((sxml:preceding test-pred?) root-node) node) (let loop ((seq (if (nodeset? root-node) (list (reverse root-node)) (list (list root-node))))) (cond ((null? seq) '()) ((null? (car seq)) (loop (cdr seq))) ((or (eq? (caar seq) node) (not (null? ((sxml:attribute (lambda (n) (eq? n node))) (caar seq))))) (let rpt ((seq (cdr (apply append seq))) (res '())) (if (null? seq) res (rpt (cdr seq) (append res (reverse ((sxml:descendant-or-self test-pred?) (car seq)))))))) (else (loop (cons (reverse ((sxml:child sxml:node?) (caar seq))) (cons (cdar seq) (cdr seq)))))))))))
(define (sxml:preceding-sibling test-pred?) (lambda (root-node) (lambda (node) (if (nodeset? node) (map-union ((sxml:preceding-sibling test-pred?) root-node) node) (let loop ((seqs (if (nodeset? root-node) (list root-node) (list (list root-node))))) (if (null? seqs) '() (let rpt ((seq (car seqs))) (cond ((null? seq) (loop (append (map (lambda (n) (reverse ((sxml:child sxml:node?) n))) (car seqs)) (cdr seqs)))) ((eq? (car seq) node) ((sxml:filter test-pred?) (cdr seq))) (else (rpt (cdr seq)))))))))))
;;; Generated from Oleg Kiselyov's "txpath.scm"
(define (sxml:xpointer-parse-error . text) (apply cerr (append (list nl "XPointer parser error: ") text (list nl))) #f)
(define (sxml:xpointer-parse-warning . text) (apply cerr (append (list nl "XPointer parser warning: ") text (list nl))))
(define (sxml:xpointer-runtime-error . text) (apply cerr (append (list nl "XPointer runtime error: ") text (list nl))) (exit -1))
(define sxml:whitespace '(#\space #\return #\newline #\tab))
(define sxml:delimiter (append sxml:whitespace '(#\( #\) #\< #\> #\[ #\] #\: #\/ #\+ #\* #\, #\= #\| #\! #\" #\' #\@ #\$)))
(define (sxml:non-first? ch) (or (char-numeric? ch) (memv ch sxml:delimiter) (memv ch '(#\. #\-))))
(define (sxml:skip-ws path) (if (or (null? path) (not (memv (car path) sxml:whitespace))) path (sxml:skip-ws (cdr path))))
(define (sxml:parse-check str path . char-list) (let loop ((lst (string->list str)) (p (sxml:skip-ws path))) (cond ((null? lst) (if (or (null? p) (null? char-list) (memv (car p) (car char-list))) p #f)) ((null? p) #f) ((char=? (car lst) (car p)) (loop (cdr lst) (cdr p))) (else #f))))
(define (sxml:parse-check-sequence str-seq path . char-list) (let ((char-list (if (null? char-list) #f (car char-list)))) (let loop ((str-seq str-seq) (path path)) (cond ((null? str-seq) path) ((if char-list (sxml:parse-check (car str-seq) path char-list) (sxml:parse-check (car str-seq) path)) => (lambda (new-path) (loop (cdr str-seq) new-path))) (else #f)))))
(define (sxml:parse-assert str path) (let loop ((lst (string->list str)) (p (sxml:skip-ws path))) (cond ((null? lst) p) ((null? p) (sxml:xpointer-parse-error "unexpected end of XPointer path. " "Expected - \"" str "\", given - \"" (list->string path) "\"")) ((char=? (car lst) (car p)) (loop (cdr lst) (cdr p))) (else (sxml:xpointer-parse-error "expected - \"" str "\", given - \"" (list->string path) "\"")))))
(define (sxml:parse-ncname path) (let ((path (sxml:skip-ws path))) (cond ((null? path) (sxml:xpointer-parse-error "unexpected end of XPointer path. Expected - NCName")) ((sxml:non-first? (car path)) (sxml:xpointer-parse-error "expected - NCName instead of " (car path))) (else (let loop ((ncname (list (car path))) (path (cdr path))) (cond ((null? path) (list (list->string (reverse ncname)) path)) ((memv (car path) sxml:delimiter) (list (list->string (reverse ncname)) path)) (else (loop (cons (car path) ncname) (cdr path)))))))))
(define (sxml:parse-name path) (let ((path (sxml:skip-ws path))) (cond ((null? path) (sxml:xpointer-parse-error "unexpected end of XPointer path. Expected - Name")) ((and (sxml:non-first? (car path)) (not (char=? (car path) #\:))) (sxml:xpointer-parse-error "expected - Name instead of " (car path))) (else (let loop ((ncname (list (car path))) (path (cdr path))) (cond ((null? path) (list (list->string (reverse ncname)) path)) ((and (memv (car path) sxml:delimiter) (not (char=? (car path) #\:))) (list (list->string (reverse ncname)) path)) (else (loop (cons (car path) ncname) (cdr path)))))))))
(define (sxml:parse-qname path) (and-let* ((r1 (sxml:parse-ncname path))) (let ((first (car r1)) (path2 (cadr r1))) (cond ((null? path2) (list first path2)) ((not (char=? (car path2) #\:)) (list first path2)) ((null? (cdr path2)) (sxml:xpointer-parse-error "no local part of a qualified name")) ((char=? (cadr path2) #\:) (list first path2)) (else (and-let* ((r2 (sxml:parse-ncname (cdr path2)))) (list (cons first (car r2)) (cadr r2))))))))
(define (sxml:parse-natural path) (let ((path (sxml:skip-ws path))) (cond ((null? path) (sxml:xpointer-parse-error "unexpected end of XPointer path. Expected - number")) ((or (char<? (car path) #\1) (char>? (car path) #\9)) (sxml:xpointer-parse-error "expected - number instead of " (car path))) (else (let loop ((res (- (char->integer (car path)) 48)) (path (cdr path))) (cond ((null? path) (list res path)) ((char-numeric? (car path)) (loop (+ (* res 10) (- (char->integer (car path)) 48)) (cdr path))) (else (list res path))))))))
(define (sxml:parse-literal path) (let ((ch (if (sxml:parse-check "\"" path) #\" #\'))) (let loop ((res '()) (path (sxml:parse-assert (if (char=? ch #\") "\"" "'") path))) (cond ((not path) #f) ((null? path) (sxml:parse-assert (if (char=? ch #\") "\"" "'") path) #f) ((char=? (car path) ch) (list (list->string (reverse res)) (cdr path))) (else (loop (cons (car path) res) (cdr path)))))))
(define (sxml:parse-number path) (define (digits path) (let loop ((n-lst '()) (path path)) (cond ((and (null? path) (null? n-lst)) (sxml:xpointer-parse-error "unexpected end of XPointer path. Expected - number")) ((null? path) (list n-lst path)) ((and (or (char<? (car path) #\0) (char>? (car path) #\9)) (null? n-lst)) (sxml:xpointer-parse-error "expected - number instead of " (car path))) ((or (char<? (car path) #\0) (char>? (car path) #\9)) (list n-lst path)) (else (loop (cons (- (char->integer (car path)) (char->integer #\0)) n-lst) (cdr path)))))) (let ((path (sxml:skip-ws path))) (cond ((null? path) (sxml:xpointer-parse-error "unexpected end of XPointer path. Expected - number")) ((char=? (car path) #\.) (and-let* ((lst (digits (cdr path)))) (let rpt ((res 0) (n-lst (car lst)) (path (cadr lst))) (if (null? n-lst) (list (/ res 10) path) (rpt (+ (/ res 10) (car n-lst)) (cdr n-lst) path))))) (else (and-let* ((lst (digits path))) (let loop ((num1 0) (n-lst (reverse (car lst))) (path (cadr lst))) (if (null? n-lst) (cond ((null? path) (list num1 path)) ((not (char=? (car path) #\.)) (list num1 path)) (else (and-let* ((lst2 (digits (cdr path)))) (let rpt ((num2 0) (n-lst (car lst2)) (path (cadr lst2))) (if (null? n-lst) (list (+ num1 (/ num2 10)) path) (rpt (+ (/ num2 10) (car n-lst)) (cdr n-lst) path)))))) (loop (+ (* num1 10) (car n-lst)) (cdr n-lst) path))))))))
(define (sxml:parse-axis-specifier path) (let loop ((triples `((("ancestor" "::") ,sxml:ancestor #t) (("ancestor-or-self" "::") ,sxml:ancestor-or-self #t) (("attribute" "::") ,sxml:attribute #f) (("child" "::") ,sxml:child #f) (("descendant" "::") ,sxml:descendant #f) (("descendant-or-self" "::") ,sxml:descendant-or-self #f) (("following" "::") ,sxml:following #t) (("following-sibling" "::") ,sxml:following-sibling #t) (("namespace" "::") ,sxml:namespace #f) (("parent" "::") ,sxml:parent #t) (("preceding" "::") ,sxml:preceding #t) (("preceding-sibling" "::") ,sxml:preceding-sibling #t) (("self" "::") ,sxml:filter #f) (("@") ,sxml:attribute #f)))) (if (null? triples) (list sxml:child path #f) (let rpt ((pattern (caar triples)) (p path)) (cond ((null? pattern) (list (cadar triples) p (caddar triples))) ((sxml:parse-check (car pattern) p) => (lambda (new-path) (rpt (cdr pattern) new-path))) (else (loop (cdr triples))))))))
(define (sxml:parse-node-test path ns-binding) (define (brackets path) (and-let* ((path (sxml:parse-assert "(" path))) (sxml:parse-assert ")" path))) (cond ((sxml:parse-check-sequence '("comment" "(") path) => (lambda (path) (and-let* ((path (sxml:parse-assert ")" path))) (list (ntype?? '*COMMENT*) path)))) ((sxml:parse-check-sequence '("text" "(") path) => (lambda (path) (and-let* ((path (sxml:parse-assert ")" path))) (list (ntype?? '*text*) path)))) ((sxml:parse-check-sequence '("node" "(") path) => (lambda (path) (and-let* ((path (sxml:parse-assert ")" path))) (list sxml:node? path)))) ((sxml:parse-check-sequence '("processing-instruction" "(") path) => (lambda (path) (cond ((sxml:parse-check ")" path) (list (lambda (node) (and (pair? node) (eq? (car node) '*PI*))) (sxml:parse-assert ")" path))) (else (and-let* ((lst (sxml:parse-literal path)) (name (string->symbol (car lst))) (path (sxml:parse-assert ")" (cadr lst)))) (list (lambda (node) (and (pair? node) (eq? (car node) '*PI*) (equal? (cadr node) name))) path)))))) ((sxml:parse-check-sequence '("point" "(") path) => (lambda (path) (and-let* ((path (sxml:parse-assert ")" path))) (sxml:xpointer-parse-warning "'point()' NodeTest is not supported by this implementation. " "It is defaulted to an predicate which is always false") (list (lambda (node) #f) path)))) ((sxml:parse-check-sequence '("range" "(") path) => (lambda (path) (and-let* ((path (sxml:parse-assert ")" path))) (sxml:xpointer-parse-warning "'range()' NodeTest is not supported by this implementation. " "It is defaulted to an predicate which is always false") (list (lambda (node) #f) path)))) ((sxml:parse-check "*" path) (list (ntype?? '*) (sxml:parse-assert "*" path))) (else (and-let* ((lst (sxml:parse-ncname path))) (let ((name (string->symbol (car lst))) (path (cadr lst))) (if (and (not (null? path)) (char=? (car path) #\:)) (let ((path (sxml:parse-assert ":" path)) (pair (assq name ns-binding))) (cond ((not pair) (sxml:xpointer-parse-error "unknown namespace prefix - " name)) ((and (not (null? path)) (char=? (car path) #\*)) (list (ntype-namespace-id?? (cdr pair)) (sxml:parse-assert "*" path))) (else (and-let* ((lst (sxml:parse-ncname path))) (list (ntype?? (string->symbol (string-append (cdr pair) ":" (car lst)))) (cadr lst)))))) (list (ntype?? name) path)))))))
(define (sxml:xpath-nodeset-filter preds-list nodeset root-node var-binding) (let rpt ((nodeset nodeset) (ps (reverse preds-list))) (if (null? ps) nodeset (let ((size (length nodeset))) (let lab ((nset nodeset) (res '()) (pos 1)) (if (null? nset) (rpt (reverse res) (cdr ps)) (let ((val ((car ps) (list (car nset)) root-node (cons pos size) var-binding))) (lab (cdr nset) (if (if (number? val) (= val pos) (sxml:boolean val)) (cons (car nset) res) res) (+ pos 1)))))))))
(define (sxml:parse-step path ns-binding) (cond ((sxml:parse-check ".." path) (list (lambda (nodeset root-node context var-binding) (((sxml:parent sxml:node?) root-node) nodeset)) (sxml:parse-assert ".." path) #f)) ((sxml:parse-check "." path) (list (lambda (nodeset root-node context var-binding) ((sxml:filter sxml:node?) nodeset)) (sxml:parse-assert "." path) #f)) ((sxml:parse-check "range-to" path) (and-let* ((path0 (sxml:parse-assert "(" (sxml:parse-assert "range-to" path))) (lst (sxml:parse-expr path0 ns-binding)) (path (sxml:parse-assert ")" (cadr lst)))) (let loop ((path path)) (cond ((sxml:parse-check "[" path) (and-let* ((lst (sxml:parse-predicate path ns-binding))) (loop (cadr lst)))) (else (sxml:xpointer-parse-warning "range-to function not implemented. " "Defaulting to an empty nodeset") (list (lambda (nodeset root-node context var-binding) '()) path #f)))))) (else (and-let* ((lst (sxml:parse-axis-specifier path))) (let ((axis (car lst)) (root-node-required (caddr lst))) (and-let* ((lst (sxml:parse-node-test (cadr lst) ns-binding))) (let ((test (car lst))) (let loop ((preds '()) (path (cadr lst)) (index-required #f)) (cond ((sxml:parse-check "[" path) (and-let* ((lst (sxml:parse-predicate path ns-binding))) (loop (cons (car lst) preds) (cadr lst) (or index-required (caddr lst))))) ((null? preds) (list (lambda (nodeset root-node context var-binding) (if root-node-required (((axis test) root-node) nodeset) ((axis test) nodeset))) path index-required)) (else (list (lambda (nodeset root-node context var-binding) (sxml:xpath-nodeset-filter preds ((if root-node-required ((axis test) root-node) (axis test)) nodeset) root-node var-binding)) path index-required)))))))))))
(define (sxml:parse-relative-location-path path ns-binding) (let loop ((funcs '()) (path path) (index-required #f)) (and-let* ((lst (sxml:parse-step path ns-binding))) (let ((func (car lst)) (path (cadr lst))) (cond ((sxml:parse-check "//" path) (loop (cons (lambda (nodeset root-node context var-binding) ((sxml:descendant-or-self sxml:node?) nodeset)) (cons func funcs)) (sxml:parse-assert "//" path) (or index-required (caddr lst)))) ((sxml:parse-check "/" path) (loop (cons func funcs) (sxml:parse-assert "/" path) (or index-required (caddr lst)))) ((null? funcs) lst) (else (list (lambda (nodeset root-node context var-binding) (let rpt ((nset nodeset) (fs (reverse (cons func funcs)))) (if (null? fs) nset (rpt ((car fs) nset root-node context var-binding) (cdr fs))))) path (or index-required (caddr lst)))))))))
(define (sxml:parse-xpath path ns-binding) (and-let* ((res (sxml:parse-location-path path ns-binding)) (path (sxml:skip-ws (cadr res)))) (if (not (null? path)) (sxml:xpointer-parse-error "unexpected - \"" (list->string path) "\"") res)))
(define (sxml:parse-location-path path ns-binding) (define (nothing? path) (let ((path (sxml:skip-ws path))) (cond ((null? path) #t) ((memv (car path) '(#\| #\+ #\- #\< #\> #\= #\) #\] #\,)) #t) ((or (sxml:parse-check "mod" path sxml:delimiter) (sxml:parse-check "div" path sxml:delimiter) (sxml:parse-check "!=" path) (sxml:parse-check "and" path sxml:delimiter) (sxml:parse-check "or" path sxml:delimiter)) #t) (else #f)))) (cond ((sxml:parse-check "//" path) (and-let* ((lst (sxml:parse-relative-location-path (sxml:parse-assert "//" path) ns-binding))) (let ((func (car lst)) (path (cadr lst)) (index-required (caddr lst))) (list (lambda (nodeset root-node context var-binding) (func ((sxml:descendant-or-self sxml:node?) root-node) root-node context var-binding)) path index-required)))) ((sxml:parse-check "/" path) (let ((path (sxml:parse-assert "/" path))) (if (nothing? path) (list (lambda (nodeset root-node context var-binding) root-node) path #f) (let ((lst (sxml:parse-relative-location-path path ns-binding))) (if (null? lst) #f (let ((func (car lst)) (path (cadr lst)) (index-required (caddr lst))) (list (lambda (nodeset root-node context var-binding) (func root-node root-node context var-binding)) path index-required))))))) (else (sxml:parse-relative-location-path path ns-binding))))
(define (sxml:parse-predicate path ns-binding) (and-let* ((path0 (sxml:parse-assert "[" path)) (lst (sxml:parse-expr path0 ns-binding)) (path (sxml:parse-assert "]" (cadr lst)))) (list (car lst) path (caddr lst))))
(define (sxml:parse-variable-reference path ns-binding) (and-let* ((path (sxml:parse-assert "$" path)) (lst (sxml:parse-qname path))) (let ((name (string->symbol (if (pair? (car lst)) (string-append (caar lst) ":" (cdar lst)) (car lst))))) (list (lambda (nodeset root-node context var-binding) (cond ((assoc name var-binding) => cdr) (else (sxml:xpointer-runtime-error "Unbound variable - " name ". Defaulting to an empty nodeset") '()))) (cadr lst) #f))))
(define (sxml:parse-function-call path ns-binding) (define (sxml:parse-arguments min max path ns-binding) (let ((path (sxml:parse-assert "(" path))) (cond ((not path) #f) ((= max 0) (and-let* ((path (sxml:parse-assert ")" path))) (list '() path #f))) ((and (= min 0) (sxml:parse-check ")" path)) (list '() (sxml:parse-assert ")" path) #f)) (else (let back ((n 1) (funcs '()) (path path) (index-required #f)) (and-let* ((lst (sxml:parse-expr path ns-binding))) (let ((func (car lst)) (path (cadr lst)) (bool (or index-required (caddr lst)))) (cond ((= n max) (and-let* ((path (sxml:parse-assert ")" path))) (list (reverse (cons func funcs)) path bool))) ((and (>= n min) (sxml:parse-check ")" path)) (list (reverse (cons func funcs)) (sxml:parse-assert ")" path) bool)) (else (and-let* ((path (sxml:parse-assert "," path))) (back (+ n 1) (cons func funcs) path bool))))))))))) (and-let* ((lst (sxml:parse-qname path))) (let ((name (car lst)) (path (cadr lst))) (cond ((equal? name "last") (and-let* ((lst2 (sxml:parse-arguments 0 0 path ns-binding))) (list (lambda (nodeset root-node context var-binding) (cdr context)) (cadr lst2) #f))) ((equal? name "position") (and-let* ((lst2 (sxml:parse-arguments 0 0 path ns-binding))) (list (lambda (nodeset root-node context var-binding) (car context)) (cadr lst2) #f))) ((equal? name "count") (and-let* ((lst2 (sxml:parse-arguments 1 1 path ns-binding))) (let ((func (caar lst2)) (path (cadr lst2)) (index-required (caddr lst2))) (list (lambda (nodeset root-node context var-binding) (let ((res (func nodeset root-node context var-binding))) (cond ((nodeset? res) (length res)) (else (sxml:xpointer-runtime-error "'count' function - an argument is not a nodeset. " "Returning zero") 0)))) path index-required)))) ((equal? name "id") (and-let* ((lst2 (sxml:parse-arguments 1 1 path ns-binding))) (let ((func (caar lst2)) (path (cadr lst2))) (list (lambda (nodeset root-node context var-binding) (let* ((id-nset ((sxml:child (ntype?? 'id-index)) ((sxml:child (ntype?? '|@@|)) root-node)))) (if (null? id-nset) '() ((sxml:id (cdar id-nset)) (func nodeset root-node context var-binding))))) path #t)))) ((equal? name "local-name") (and-let* ((lst2 (sxml:parse-arguments 0 1 path ns-binding))) (cons (if (null? (car lst2)) (lambda (nodeset root-node context var-binding) (cond ((null? nodeset) "") ((not (pair? (car nodeset))) "") (else (let ((name (symbol->string (caar nodeset)))) (cond ((string-rindex name #\:) => (lambda (pos) (substring name (+ pos 1) (string-length name)))) (else name)))))) (let ((func (caar lst2))) (lambda (nodeset root-node context var-binding) (let ((obj (func nodeset root-node context var-binding))) (cond ((null? obj) "") ((not (nodeset? obj)) (sxml:xpointer-runtime-error "NAME function - an argument is not a nodeset. " "Returning an empty string") "") ((not (pair? (car obj))) "") (else (let ((name (symbol->string (caar obj)))) (cond ((string-rindex name #\:) => (lambda (pos) (substring name (+ pos 1) (string-length name)))) (else name))))))))) (cdr lst2)))) ((equal? name "namespace-uri") (and-let* ((lst2 (sxml:parse-arguments 0 1 path ns-binding))) (cons (if (null? (car lst2)) (lambda (nodeset root-node context var-binding) (cond ((null? nodeset) "") ((not (pair? (car nodeset))) "") (else (let ((name (symbol->string (caar nodeset)))) (cond ((string-rindex name #\:) => (lambda (pos) (substring name 0 pos))) (else "")))))) (let ((func (caar lst2))) (lambda (nodeset root-node context var-binding) (let ((obj (func nodeset root-node context var-binding))) (cond ((null? obj) "") ((not (nodeset? obj)) (sxml:xpointer-runtime-error "NAME function - an argument is not a nodeset. " "Returning an empty string") "") ((not (pair? (car obj))) "") (else (let ((name (symbol->string (caar obj)))) (cond ((string-rindex name #\:) => (lambda (pos) (substring name 0 pos))) (else ""))))))))) (cdr lst2)))) ((equal? name "name") (and-let* ((lst2 (sxml:parse-arguments 0 1 path ns-binding))) (cons (if (null? (car lst2)) (lambda (nodeset root-node context var-binding) (cond ((null? nodeset) "") ((not (pair? (car nodeset))) "") (else (symbol->string (caar nodeset))))) (let ((func (caar lst2))) (lambda (nodeset root-node context var-binding) (let ((obj (func nodeset root-node context var-binding))) (cond ((null? obj) "") ((not (nodeset? obj)) (sxml:xpointer-runtime-error "NAME function - an argument is not a nodeset. " "Returning an empty string") "") ((not (pair? (car obj))) "") (else (symbol->string (caar obj)))))))) (cdr lst2)))) ((equal? name "string") (and-let* ((lst2 (sxml:parse-arguments 0 1 path ns-binding))) (let ((funcs (car lst2)) (path (cadr lst2)) (index-required (caddr lst2))) (if (null? funcs) (list (lambda (nodeset root-node context var-binding) (sxml:string nodeset)) path #f) (list (lambda (nodeset root-node context var-binding) (sxml:string ((car funcs) nodeset root-node context var-binding))) path index-required))))) ((equal? name "concat") (and-let* ((lst2 (sxml:parse-arguments 2 -1 path ns-binding))) (let ((funcs (car lst2))) (cons (lambda (nodeset root-node context var-binding) (apply string-append (map (lambda (f) (sxml:string (f nodeset root-node context var-binding))) funcs))) (cdr lst2))))) ((equal? name "starts-with") (and-let* ((lst2 (sxml:parse-arguments 2 2 path ns-binding))) (let ((func1 (caar lst2)) (func2 (cadar lst2))) (cons (lambda (nodeset root-node context var-binding) (let ((str1 (sxml:string (func1 nodeset root-node context var-binding))) (str2 (sxml:string (func2 nodeset root-node context var-binding)))) (string-prefix? str2 str1))) (cdr lst2))))) ((equal? name "contains") (and-let* ((lst2 (sxml:parse-arguments 2 2 path ns-binding))) (let ((func1 (caar lst2)) (func2 (cadar lst2)) (path (cadr lst2)) (index-required (caddr lst2))) (list (lambda (nodeset root-node context var-binding) (let ((str1 (sxml:string (func1 nodeset root-node context var-binding))) (str2 (sxml:string (func2 nodeset root-node context var-binding)))) (if (substring? str1 str2) #t #f))) path index-required)))) ((equal? name "substring-before") (and-let* ((lst2 (sxml:parse-arguments 2 2 path ns-binding))) (let ((func1 (caar lst2)) (func2 (cadar lst2))) (cons (lambda (nodeset root-node context var-binding) (let* ((str1 (sxml:string (func1 nodeset root-node context var-binding))) (str2 (sxml:string (func2 nodeset root-node context var-binding))) (pos (substring? str2 str1))) (if (not pos) "" (substring str1 0 pos)))) (cdr lst2))))) ((equal? name "substring-after") (and-let* ((lst2 (sxml:parse-arguments 2 2 path ns-binding))) (let ((func1 (caar lst2)) (func2 (cadar lst2))) (cons (lambda (nodeset root-node context var-binding) (let* ((str1 (sxml:string (func1 nodeset root-node context var-binding))) (str2 (sxml:string (func2 nodeset root-node context var-binding))) (pos (substring? str2 str1))) (if (not pos) "" (substring str1 (+ pos (string-length str2)) (string-length str1))))) (cdr lst2))))) ((equal? name "substring") (and-let* ((lst2 (sxml:parse-arguments 2 3 path ns-binding))) (let ((func1 (caar lst2)) (func2 (cadar lst2))) (if (= (length (car lst2)) 2) (cons (lambda (nodeset root-node context var-binding) (let ((str (sxml:string (func1 nodeset root-node context var-binding))) (num1 (sxml:number (func2 nodeset root-node context var-binding)))) (let ((len (string-length str)) (start (- (inexact->exact (round num1)) 1))) (if (> start len) "" (substring str (if (< start 0) 0 start) len))))) (cdr lst2)) (let ((func3 (caddar lst2))) (cons (lambda (nodeset root-node context var-binding) (let ((str (sxml:string (func1 nodeset root-node context var-binding))) (num1 (sxml:number (func2 nodeset root-node context var-binding))) (num2 (sxml:number (func3 nodeset root-node context var-binding)))) (let* ((len (string-length str)) (start (- (inexact->exact (round num1)) 1)) (fin (+ start (inexact->exact (round num2))))) (if (or (> start len) (< fin 0) (< fin start)) "" (substring str (if (< start 0) 0 start) (if (> fin len) len fin)))))) (cdr lst2))))))) ((equal? name "string-length") (and-let* ((lst2 (sxml:parse-arguments 0 1 path ns-binding))) (cons (if (null? (car lst2)) (lambda (nodeset root-node context var-binding) (string-length (sxml:string nodeset))) (let ((func (caar lst2))) (lambda (nodeset root-node context var-binding) (string-length (sxml:string (func nodeset root-node context var-binding)))))) (cdr lst2)))) ((equal? name "normalize-space") (and-let* ((lst2 (sxml:parse-arguments 0 1 path ns-binding))) (cons (if (null? (car lst2)) (lambda (nodeset root-node context var-binding) (let rpt ((src (string-split (sxml:string nodeset) sxml:whitespace)) (res '())) (cond ((null? src) (apply string-append (reverse res))) ((= (string-length (car src)) 0) (rpt (cdr src) res)) ((null? res) (rpt (cdr src) (cons (car src) res))) (else (rpt (cdr src) (cons (car src) (cons " " res))))))) (let ((func (caar lst2))) (lambda (nodeset root-node context var-binding) (let rpt ((src (string-split (sxml:string (func nodeset root-node context var-binding)) sxml:whitespace)) (res '())) (cond ((null? src) (apply string-append (reverse res))) ((= (string-length (car src)) 0) (rpt (cdr src) res)) ((null? res) (rpt (cdr src) (cons (car src) res))) (else (rpt (cdr src) (cons (car src) (cons " " res))))))))) (cdr lst2)))) ((equal? name "translate") (and-let* ((lst2 (sxml:parse-arguments 3 3 path ns-binding))) (let ((func1 (caar lst2)) (func2 (cadar lst2)) (func3 (caddar lst2))) (cons (lambda (nodeset root-node context var-binding) (let ((str1 (sxml:string (func1 nodeset root-node context var-binding))) (str2 (sxml:string (func2 nodeset root-node context var-binding))) (str3 (sxml:string (func3 nodeset root-node context var-binding)))) (let ((alist (let while ((lst2 (string->list str2)) (lst3 (string->list str3)) (alist '())) (cond ((null? lst2) (reverse alist)) ((null? lst3) (append (reverse alist) (map (lambda (ch) (cons ch #f)) lst2))) (else (while (cdr lst2) (cdr lst3) (cons (cons (car lst2) (car lst3)) alist))))))) (let rpt ((lst1 (string->list str1)) (res '())) (cond ((null? lst1) (list->string (reverse res))) ((assoc (car lst1) alist) => (lambda (pair) (if (cdr pair) (rpt (cdr lst1) (cons (cdr pair) res)) (rpt (cdr lst1) res)))) (else (rpt (cdr lst1) (cons (car lst1) res)))))))) (cdr lst2))))) ((equal? name "boolean") (and-let* ((lst2 (sxml:parse-arguments 1 1 path ns-binding))) (let ((func (caar lst2)) (path (cadr lst2)) (index-required (caddr lst2))) (list (lambda (nodeset root-node context var-binding) (sxml:boolean (func nodeset root-node context var-binding))) path index-required)))) ((equal? name "not") (and-let* ((lst2 (sxml:parse-arguments 1 1 path ns-binding))) (let ((func (caar lst2)) (path (cadr lst2)) (index-required (caddr lst2))) (list (lambda (nodeset root-node context var-binding) (not (sxml:boolean (func nodeset root-node context var-binding)))) path index-required)))) ((equal? name "true") (and-let* ((lst2 (sxml:parse-arguments 0 0 path ns-binding))) (list (lambda (nodeset root-node context var-binding) #t) (cadr lst2) #f))) ((equal? name "false") (and-let* ((lst2 (sxml:parse-arguments 0 0 path ns-binding))) (list (lambda (nodeset root-node context var-binding) #f) (cadr lst2) #f))) ((equal? name "lang") (and-let* ((lst2 (sxml:parse-arguments 1 1 path ns-binding))) (let ((func (caar lst2))) (cons (lambda (nodeset root-node context var-binding) (if (null? nodeset) #f (let ((arg (sxml:string (func nodeset root-node context var-binding))) (context-node (car nodeset))) (let rpt ((pairs (map (lambda (node) (cons node #f)) root-node))) (if (null? pairs) #f (let* ((lng ((sxml:child (ntype?? '*text*)) ((sxml:attribute (ntype?? 'xml:lang)) (caar pairs)))) (lng (if (null? lng) (cdar pairs) (car lng)))) (if (eq? context-node (caar pairs)) (and lng (or (string-ci=? arg lng) (string-prefix-ci? (string-append arg "-") lng))) (rpt (append (map (lambda (node) (cons node lng)) ((sxml:attribute (ntype?? '*)) (caar pairs))) (map (lambda (node) (cons node lng)) ((sxml:child sxml:node?) (caar pairs))) (cdr pairs)))))))))) (cdr lst2))))) ((equal? name "number") (and-let* ((lst2 (sxml:parse-arguments 0 1 path ns-binding))) (let ((funcs (car lst2)) (path (cadr lst2)) (index-required (caddr lst2))) (if (null? funcs) (list (lambda (nodeset root-node context var-binding) (sxml:number nodeset)) path #f) (list (lambda (nodeset root-node context var-binding) (sxml:number ((car funcs) nodeset root-node context var-binding))) path index-required))))) ((equal? name "sum") (and-let* ((lst2 (sxml:parse-arguments 1 1 path ns-binding))) (let ((func (caar lst2))) (cons (lambda (nodeset root-node context var-binding) (let ((res (func nodeset root-node context var-binding))) (cond ((nodeset? res) (apply + (map (lambda (node) (sxml:number (sxml:string-value node))) res))) (else (sxml:xpointer-runtime-error "SUM function - an argument is not a nodeset. " "Returning zero") 0)))) (cdr lst2))))) ((equal? name "floor") (and-let* ((lst2 (sxml:parse-arguments 1 1 path ns-binding))) (let ((func (caar lst2)) (path (cadr lst2)) (index-required (caddr lst2))) (list (lambda (nodeset root-node context var-binding) (inexact->exact (floor (sxml:number (func nodeset root-node context var-binding))))) path index-required)))) ((equal? name "ceiling") (and-let* ((lst2 (sxml:parse-arguments 1 1 path ns-binding))) (let ((func (caar lst2)) (path (cadr lst2)) (index-required (caddr lst2))) (list (lambda (nodeset root-node context var-binding) (inexact->exact (ceiling (sxml:number (func nodeset root-node context var-binding))))) path index-required)))) ((equal? name "round") (and-let* ((lst2 (sxml:parse-arguments 1 1 path ns-binding))) (let ((func (caar lst2)) (path (cadr lst2)) (index-required (caddr lst2))) (list (lambda (nodeset root-node context var-binding) (inexact->exact (round (sxml:number (func nodeset root-node context var-binding))))) path index-required)))) (else (and-let* ((lst (sxml:parse-arguments 0 -1 path ns-binding))) (let ((path (cadr lst))) (sxml:xpointer-parse-warning "function not implemented - " (if (pair? name) (string-append (car name) ":" (cdr name)) name)) (list (lambda (nodeset root-node context var-binding) '()) path #f))))))))
(define (sxml:parse-primary-expr path ns-binding) (cond ((sxml:parse-check "$" path) (sxml:parse-variable-reference path ns-binding)) ((sxml:parse-check "(" path) (and-let* ((lst (sxml:parse-expr (sxml:parse-assert "(" path) ns-binding)) (path (sxml:parse-assert ")" (cadr lst)))) (let ((func (car lst)) (index-required (caddr lst))) (list func path index-required)))) ((or (sxml:parse-check "\"" path) (sxml:parse-check "'" path)) (and-let* ((lst (sxml:parse-literal path))) (list (lambda (nodeset root-node context var-binding) (car lst)) (cadr lst) #f))) ((let ((p (sxml:skip-ws path))) (cond ((null? p) #f) ((char=? (car p) #\.) #t) ((and (char>=? (car p) #\0) (char<=? (car p) #\9)) #t) (else #f))) (and-let* ((lst (sxml:parse-number path))) (list (lambda (nodeset root-node context var-binding) (car lst)) (cadr lst) #f))) (else (sxml:parse-function-call path ns-binding))))
(define (sxml:parse-filter-expr path ns-binding) (and-let* ((lst (sxml:parse-primary-expr path ns-binding))) (let ((prim (car lst))) (let loop ((preds '()) (path (cadr lst)) (index-required (caddr lst))) (if (sxml:parse-check "[" path) (and-let* ((lst (sxml:parse-predicate path ns-binding))) (loop (cons (car lst) preds) (cadr lst) (or index-required (caddr lst)))) (if (null? preds) (list prim path index-required) (list (lambda (nodeset root-node context var-binding) (let ((nodeset (prim nodeset root-node context var-binding))) (sxml:xpath-nodeset-filter preds (cond ((nodeset? nodeset) nodeset) (else (sxml:xpointer-runtime-error "expected - nodeset instead of " nodeset ". Converting to an empty nodeset") '())) root-node var-binding))) path index-required)))))))
(define (sxml:parse-path-expr path ns-binding) (define (filter-expr? path) (let ((path (sxml:skip-ws path))) (cond ((null? path) #f) ((member (car path) '(#\$ #\( #\" #\' #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)) #t) ((char=? (car path) #\.) (cond ((null? (cdr path)) #f) ((member (cadr path) '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)) #t) (else #f))) ((member (car path) '(#\) #\< #\> #\[ #\] #\/ #\+ #\* #\, #\= #\| #\! #\@ #\-)) #f) (else (let ((lst (sxml:parse-ncname path))) (cond ((not lst) #f) ((sxml:parse-check "::" (cadr lst)) #f) (else (and-let* ((lst (sxml:parse-name path))) (let ((name (car lst)) (new-path (sxml:skip-ws (cadr lst)))) (cond ((string=? name "range-to") #f) ((string=? name "comment") #f) ((string=? name "text") #f) ((string=? name "processing-instruction") #f) ((string=? name "node") #f) ((string=? name "point") #f) ((string=? name "range") #f) ((null? new-path) #f) ((char=? (car new-path) #\() #t) (else #f))))))))))) (if (not (filter-expr? path)) (sxml:parse-location-path path ns-binding) (and-let* ((lst (sxml:parse-filter-expr path ns-binding))) (let ((f-ex (car lst)) (path (cadr lst)) (index-required (caddr lst))) (cond ((sxml:parse-check "//" path) (and-let* ((lst2 (sxml:parse-relative-location-path (sxml:parse-assert "//" path) ns-binding))) (let ((f-rel (car lst2)) (path (cadr lst2)) (bool (or index-required (caddr lst2)))) (list (lambda (nodeset root-node context var-binding) (let ((nset (f-ex nodeset root-node context var-binding))) (let ((nset (cond ((nodeset? nset) nset) (else (sxml:xpointer-runtime-error "expected - nodeset instead of " nset ". Converting to an empty nodeset") '())))) (let ((nset ((sxml:descendant-or-self sxml:node?) nset))) (f-rel nset root-node context var-binding))))) path bool)))) ((sxml:parse-check "/" path) (and-let* ((lst2 (sxml:parse-relative-location-path (sxml:parse-assert "/" path) ns-binding))) (let ((f-rel (car lst2)) (path (cadr lst2)) (bool (or index-required (caddr lst2)))) (list (lambda (nodeset root-node context var-binding) (let ((nset (f-ex nodeset root-node context var-binding))) (let ((nset (cond ((nodeset? nset) nset) (else (sxml:xpointer-runtime-error "expected - nodeset instead of " nset ". Converting to an empty nodeset") '())))) (f-rel nset root-node context var-binding)))) path bool)))) (else lst))))))
(define (sxml:parse-union-expr path ns-binding) (let loop ((funcs '()) (path path) (index-required #f)) (and-let* ((lst (sxml:parse-path-expr path ns-binding))) (let ((func (car lst)) (path (cadr lst)) (id-ind? (or index-required (caddr lst)))) (let ((new-path (sxml:parse-check "|" path))) (if (not new-path) (if (null? funcs) (list func path id-ind?) (list (lambda (nodeset root-node context var-binding) (let rpt ((res '()) (fs (reverse (cons func funcs)))) (if (null? fs) res (let ((nset ((car fs) nodeset root-node context var-binding))) (rpt (append res (cond ((not (nodeset? nset)) (sxml:xpointer-runtime-error "expected - nodeset instead of " nset ". Ignoring") '()) (else nset))) (cdr fs)))))) path id-ind?)) (loop (cons func funcs) new-path id-ind?)))))))
(define (sxml:parse-unary-expr path ns-binding) (if (not (sxml:parse-check "-" path)) (sxml:parse-union-expr path ns-binding) (let loop ((minu #f) (path path)) (let ((new-path (sxml:parse-check "-" path))) (if (not new-path) (and-let* ((lst (sxml:parse-union-expr path ns-binding))) (let ((func (car lst)) (path2 (cadr lst)) (index-required (caddr lst))) (list (lambda (nodeset root-node context var-binding) (if minu (- 0 (sxml:number (func nodeset root-node context var-binding))) (sxml:number (func nodeset root-node context var-binding)))) path2 index-required))) (loop (not minu) new-path))))))
(define (sxml:no-more-exprs funcs func path id-ind? opers) (if (null? funcs) (list func path id-ind?) (let ((flst (reverse (cons func funcs)))) (list (lambda (nodeset root-node context var-binding) (let rpt ((res (sxml:number ((car flst) nodeset root-node context var-binding))) (fs (cdr flst)) (ops (reverse opers))) (if (null? fs) res (rpt ((car ops) res (sxml:number ((car fs) nodeset root-node context var-binding))) (cdr fs) (cdr ops))))) path id-ind?))))
(define (sxml:parse-multiplicative-expr path ns-binding) (let loop ((funcs '()) (opers '()) (path path) (index-required #f)) (and-let* ((lst (sxml:parse-unary-expr path ns-binding))) (let ((func (car lst)) (path (cadr lst)) (id-ind? (or index-required (caddr lst)))) (cond ((sxml:parse-check "*" path) (loop (cons func funcs) (cons * opers) (sxml:parse-assert "*" path) id-ind?)) ((sxml:parse-check "div" path sxml:delimiter) (loop (cons func funcs) (cons / opers) (sxml:parse-assert "div" path) id-ind?)) ((sxml:parse-check "mod" path sxml:delimiter) (loop (cons func funcs) (cons remainder opers) (sxml:parse-assert "mod" path) id-ind?)) (else (sxml:no-more-exprs funcs func path id-ind? opers)))))))
(define (sxml:parse-additive-expr path ns-binding) (let loop ((funcs '()) (opers '()) (path path) (index-required #f)) (and-let* ((lst (sxml:parse-multiplicative-expr path ns-binding))) (let ((func (car lst)) (path (cadr lst)) (id-ind? (or index-required (caddr lst)))) (cond ((sxml:parse-check "+" path) (loop (cons func funcs) (cons + opers) (sxml:parse-assert "+" path) id-ind?)) ((sxml:parse-check "-" path) (loop (cons func funcs) (cons - opers) (sxml:parse-assert "-" path) id-ind?)) (else (sxml:no-more-exprs funcs func path id-ind? opers)))))))
(define (sxml:parse-relational-expr path ns-binding) (let loop ((funcs '()) (opers '()) (path path) (index-required #f)) (let ((lst (sxml:parse-additive-expr path ns-binding))) (if (not lst) #f (let ((func (car lst)) (path (cadr lst)) (bool (or index-required (caddr lst)))) (cond ((sxml:parse-check "<=" path) (loop (cons func funcs) (cons (sxml:relational-cmp <=) opers) (sxml:parse-assert "<=" path) bool)) ((sxml:parse-check ">=" path) (loop (cons func funcs) (cons (sxml:relational-cmp >=) opers) (sxml:parse-assert ">=" path) bool)) ((sxml:parse-check "<" path) (loop (cons func funcs) (cons (sxml:relational-cmp <) opers) (sxml:parse-assert "<" path) bool)) ((sxml:parse-check ">" path) (loop (cons func funcs) (cons (sxml:relational-cmp >) opers) (sxml:parse-assert ">" path) bool)) (else (if (null? funcs) (list func path bool) (let ((flst (reverse (cons func funcs)))) (list (lambda (nodeset root-node context var-binding) (let rpt ((res ((car flst) nodeset root-node context var-binding)) (fs (cdr flst)) (ops (reverse opers))) (if (null? fs) res (rpt ((car ops) res ((car fs) nodeset root-node context var-binding)) (cdr fs) (cdr ops))))) path bool))))))))))
(define (sxml:parse-equality-expr path ns-binding) (let loop ((funcs '()) (opers '()) (path path) (index-required #f)) (and-let* ((lst (sxml:parse-relational-expr path ns-binding))) (let ((func (car lst)) (path (cadr lst)) (id-ind? (or index-required (caddr lst)))) (cond ((sxml:parse-check "=" path) (loop (cons func funcs) (cons sxml:equal? opers) (sxml:parse-assert "=" path) id-ind?)) ((sxml:parse-check "!=" path) (loop (cons func funcs) (cons sxml:not-equal? opers) (sxml:parse-assert "!=" path) id-ind?)) (else (if (null? funcs) (list func path id-ind?) (let ((flst (reverse (cons func funcs)))) (list (lambda (nodeset root-node context var-binding) (let rpt ((res ((car flst) nodeset root-node context var-binding)) (fs (cdr flst)) (ops (reverse opers))) (if (null? fs) res (rpt ((car ops) res ((car fs) nodeset root-node context var-binding)) (cdr fs) (cdr ops))))) path id-ind?)))))))))
(define (sxml:parse-and-expr path ns-binding) (let loop ((funcs '()) (path path) (index-required #f)) (and-let* ((lst (sxml:parse-equality-expr path ns-binding))) (let ((func (car lst)) (path (cadr lst)) (id-ind? (or index-required (caddr lst)))) (let ((new-path (sxml:parse-check "and" path sxml:delimiter))) (if (not new-path) (if (null? funcs) (list func path id-ind?) (list (lambda (nodeset root-node context var-binding) (let rpt ((fs (reverse (cons func funcs)))) (cond ((null? fs) #t) ((not (sxml:boolean ((car fs) nodeset root-node context var-binding))) #f) (else (rpt (cdr fs)))))) path id-ind?)) (loop (cons func funcs) new-path id-ind?)))))))
(define (sxml:parse-expr path ns-binding) (let loop ((funcs '()) (path path) (index-required #f)) (and-let* ((lst (sxml:parse-and-expr path ns-binding))) (let ((func (car lst)) (path (cadr lst)) (id-ind? (or index-required (caddr lst)))) (let ((new-path (sxml:parse-check "or" path sxml:delimiter))) (if (not new-path) (if (null? funcs) (list func path id-ind?) (list (lambda (nodeset root-node context var-binding) (let rpt ((fs (reverse (cons func funcs)))) (cond ((null? fs) #f) ((sxml:boolean ((car fs) nodeset root-node context var-binding)) #t) (else (rpt (cdr fs)))))) path id-ind?)) (loop (cons func funcs) new-path id-ind?)))))))
(define (sxml:parse-full-xptr path ns-binding) (let loop ((funcs '()) (ns-binding ns-binding) (path path) (index-required #f)) (if (null? (sxml:skip-ws path)) (if (= (length funcs) 1) (list (car funcs) path index-required) (list (lambda (nodeset root-node context var-binding) (let rpt ((fs (reverse funcs))) (if (null? fs) '() (let ((nset ((car fs) nodeset root-node context var-binding))) (if (null? nset) (rpt (cdr fs)) nset))))) path index-required)) (and-let* ((lst (sxml:parse-name path)) (name (car lst)) (path (cadr lst))) (cond ((string=? name "xpointer") (and-let* ((path (sxml:parse-assert "(" path)) (lst2 (sxml:parse-expr path ns-binding))) (let ((func (car lst2)) (path (cadr lst2)) (bool (caddr lst2))) (and-let* ((path (sxml:parse-assert ")" path))) (loop (cons func funcs) ns-binding path (or index-required bool)))))) ((string=? name "xmlns") (and-let* ((path0 (sxml:parse-assert "(" path)) (lst2 (sxml:parse-ncname path0)) (prefix (string->symbol (car lst2))) (path (sxml:parse-assert "=" (cadr lst2)))) (let rpt2 ((path (sxml:skip-ws path)) (uri '())) (cond ((null? path) (sxml:parse-assert ")" path) #f) ((and (char=? (car path) #\)) (null? uri)) (sxml:xpointer-parse-error "namespace URI cannot be empty")) ((char=? (car path) #\)) (loop funcs (cons (cons prefix (list->string (reverse uri))) ns-binding) (cdr path) index-required)) (else (rpt2 (cdr path) (cons (car path) uri))))))) (else (and-let* ((path (sxml:parse-assert "(" path))) (let rpt3 ((n 1) (path path)) (cond ((= n 0) (sxml:xpointer-parse-warning "unknown xpointer schema - " name ". Ignoring") (loop funcs ns-binding path index-required)) ((null? path) (sxml:parse-assert ")" path) #f) ((char=? (car path) #\() (rpt3 (+ n 1) (cdr path))) ((char=? (car path) #\)) (rpt3 (- n 1) (cdr path))) (else (rpt3 n (cdr path))))))))))))
(define (sxml:parse-child-seq path) (define (helper path) (let loop ((funcs '()) (path path)) (let ((path2 (sxml:parse-check "/" path))) (if (not path2) (if (null? (sxml:skip-ws path)) (reverse funcs) (sxml:parse-assert "/" path)) (and-let* ((lst (sxml:parse-natural path2))) (loop (cons (node-pos (car lst)) (cons (sxml:child (ntype?? '*)) funcs)) (cadr lst))))))) (let ((path2 (sxml:parse-check "/" path))) (if (not path2) (and-let* ((lst (sxml:parse-name path)) (name (car lst)) (funcs (helper (cadr lst)))) (list (lambda (nodeset root-node context var-binding) (let* ((id-nset ((sxml:child (ntype?? 'id-index)) ((sxml:child (ntype?? '|@@|)) root-node)))) (if (null? id-nset) '() (let ((nd (sxml:lookup name (cdar id-nset)))) (if (not nd) '() (let rpt ((nset (list nd)) (fs funcs)) (if (null? fs) nset (rpt ((car fs) nset) (cdr fs))))))))) '() #t)) (and-let* ((funcs (helper path))) (list (lambda (nodeset root-node context var-binding) (if (nodeset? nodeset) (let rpt ((nodeset nodeset) (res '())) (if (null? nodeset) res (let rpt2 ((nset (list (car nodeset))) (fs funcs)) (if (null? fs) (rpt (cdr nodeset) (append res nset)) (rpt2 ((car fs) nset) (cdr fs)))))) (let rpt ((nodeset nodeset) (fs funcs)) (if (null? fs) nodeset (rpt ((car fs) nodeset) (cdr fs)))))) '() #f)))))
(define (sxml:parse-xpointer path ns-binding) (if (sxml:parse-check "/" path) (sxml:parse-child-seq path) (and-let* ((lst (sxml:parse-name path)) (new-path (cadr lst))) (if (sxml:parse-check "(" new-path) (sxml:parse-full-xptr path ns-binding) (sxml:parse-child-seq path)))))
(define (sxml:api-helper parse-proc) (lambda (xpath-string . ns-binding) (and-let* ((res (parse-proc (string->list xpath-string) (if (null? ns-binding) ns-binding (car ns-binding))))) (let ((func (car res))) (lambda (node) (let ((node (if (nodeset? node) node (list node)))) (func node node (cons 1 1) '())))))))
(define sxml:xpath (sxml:api-helper sxml:parse-xpath))
(define sxml:xpointer (sxml:api-helper sxml:parse-xpointer))
(define (sxml:api-index-helper parse-proc) (lambda (xpath-string . ns-binding) (and-let* ((res (parse-proc (string->list xpath-string) (if (null? ns-binding) ns-binding (car ns-binding))))) (let ((func (car res))) (cons (lambda (node) (let ((node (if (nodeset? node) node (list node)))) (func node node (cons 1 1) '()))) (caddr res))))))
(define sxml:xpath+index (sxml:api-index-helper sxml:parse-xpath))
(define sxml:xpointer+index (sxml:api-index-helper sxml:parse-xpointer))
(define (sxml:api-root-vars-helper parse-proc) (lambda (xpath-string . ns-binding) (and-let* ((res (parse-proc (string->list xpath-string) (if (null? ns-binding) ns-binding (car ns-binding))))) (let ((func (car res))) (lambda (node . root-var-binding) (let ((root-node (if (null? root-var-binding) node (car root-var-binding)))) (func (if (nodeset? node) node (list node)) (if (nodeset? root-node) root-node (list root-node)) (cons 1 1) (if (or (null? root-var-binding) (null? (cdr root-var-binding))) '() (cadr root-var-binding)))))))))
(define sxml:xpath+root+vars (sxml:api-root-vars-helper sxml:parse-xpath))
(define sxml:xpointer+root+vars (sxml:api-root-vars-helper sxml:parse-xpointer))
(define sxml:xpath+root sxml:xpath+root+vars)
(define txpath sxml:xpath+root+vars)

(provide "sxml/sxpath")

          
;; Local variables:
;; mode: scheme
;; end:
