1;;; -*- mode:scheme; coding:utf-8; -*- 2;;; 3;;; text/xml/xpath/fn.scm - XPath Functions and Operators 4;;; 5;;; Copyright (c) 2020 Takashi Kato <ktakashi@ymail.com> 6;;; 7;;; Redistribution and use in source and binary forms, with or without 8;;; modification, are permitted provided that the following conditions 9;;; are met: 10;;; 11;;; 1. Redistributions of source code must retain the above copyright 12;;; notice, this list of conditions and the following disclaimer. 13;;; 14;;; 2. Redistributions in binary form must reproduce the above copyright 15;;; notice, this list of conditions and the following disclaimer in the 16;;; documentation and/or other materials provided with the distribution. 17;;; 18;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 24;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 25;;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 26;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 27;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29;;; 30 31;; ref: 32;; XPath and XQuery Functions and Operators 3.1 33;; https://www.w3.org/TR/xpath-functions-31/ 34 35#!nounbound 36(library (text xml xpath fn) 37 (export xpath-fn:node-name 38 xpath-fn:nilled 39 xpath-fn:string 40 xpath-fn:data 41 xpath-fn:base-uri 42 xpath-fn:document-uri 43 xpath-fn:error 44 xpath-fn:trace 45 xpath-op:numeric-add 46 xpath-op:numeric-subtract 47 xpath-op:numeric-multiply 48 xpath-op:numeric-divide 49 xpath-op:numeric-integer-divide 50 xpath-op:numeric-mod 51 xpath-op:numeric-unary-plus 52 xpath-op:numeric-unary-minus 53 xpath-op:numeric-equal 54 xpath-op:numeric-less-than 55 xpath-op:numeric-greater-than 56 xpath-fn:abs 57 xpath-fn:ceiling 58 xpath-fn:floor 59 xpath-fn:round 60 xpath-fn:round-half-to-even 61 xpath-fn:number 62 xpath-fn:format-integer 63 xpath-fn:format-number 64 xpath-math:pi 65 xpath-math:exp 66 xpath-math:exp10 67 xpath-math:log 68 xpath-math:log10 69 xpath-math:pow 70 xpath-math:sqrt 71 xpath-math:sin 72 xpath-math:cos 73 xpath-math:tan 74 xpath-math:asin 75 xpath-math:acos 76 xpath-math:atan 77 xpath-math:atan2 78 xpath-fn:random-number-generator 79 xpath-fn:codepoints-to-string 80 xpath-fn:string-to-codepoints 81 xpath-fn:compare 82 xpath-fn:codepoint-equal 83 xpath-fn:collation-key 84 xpath-fn:contains-token 85 xpath-fn:concat 86 xpath-fn:string-join 87 xpath-fn:substring 88 xpath-fn:string-length 89 xpath-fn:normalize-space 90 xpath-fn:normalize-unicode 91 xpath-fn:upper-case 92 xpath-fn:lower-case 93 xpath-fn:translate 94 xpath-fn:contains 95 xpath-fn:starts-with 96 xpath-fn:ends-with 97 xpath-fn:substring-before 98 xpath-fn:substring-after 99 xpath-fn:matches 100 xpath-fn:replace 101 xpath-fn:tokenize 102 xpath-fn:analyze-string 103 xpath-fn:resolve-uri 104 xpath-fn:encode-for-uri 105 xpath-fn:iri-to-uri 106 xpath-fn:escape-html-uri 107 xpath-fn:true 108 xpath-fn:false 109 xpath-op:boolean-equal 110 xpath-op:boolean-less-than 111 xpath-op:boolean-greater-than 112 xpath-fn:boolean 113 xpath-fn:not 114 xpath-op:year-month-duration-less-than 115 xpath-op:year-month-duration-greater-than 116 xpath-op:day-time-duration-less-than 117 xpath-op:day-time-duration-greater-than 118 xpath-op:duration-equal 119 xpath-fn:years-from-duration 120 xpath-fn:months-from-duration 121 xpath-fn:days-from-duration 122 xpath-fn:hours-from-duration 123 xpath-fn:minutes-from-duration 124 xpath-fn:seconds-from-duration 125 xpath-op:add-year-month-durations 126 xpath-op:subtract-year-month-durations 127 xpath-op:multiply-year-month-duration 128 xpath-op:divide-year-month-duration 129 xpath-op:divide-year-month-duration-by-year-month-duration 130 xpath-op:add-day-time-durations 131 xpath-op:subtract-day-time-durations 132 xpath-op:multiply-day-time-duration 133 xpath-op:divide-day-time-duration 134 xpath-op:divide-day-time-duration-by-day-time-duration 135 xpath-fn:datetime 136 xpath-op:datetime-equal 137 xpath-op:datetime-less-than 138 xpath-op:datetime-greater-than 139 xpath-op:date-equal 140 xpath-op:date-less-than 141 xpath-op:date-greater-than 142 xpath-op:time-equal 143 xpath-op:time-less-than 144 xpath-op:time-greater-than 145 xpath-op:g-year-month-equal 146 xpath-op:g-year-equal 147 xpath-op:g-month-day-equal 148 xpath-op:g-month-equal 149 xpath-op:g-day-equal 150 xpath-fn:year-from-datetime 151 xpath-fn:month-from-datetime 152 xpath-fn:day-from-datetime 153 xpath-fn:hours-from-datetime 154 xpath-fn:minutes-from-datetime 155 xpath-fn:seconds-from-datetime 156 xpath-fn:timezone-from-datetime 157 xpath-fn:year-from-date 158 xpath-fn:month-from-date 159 xpath-fn:day-from-date 160 xpath-fn:timezone-from-date 161 xpath-fn:hours-from-time 162 xpath-fn:minutes-from-time 163 xpath-fn:seconds-from-time 164 xpath-fn:timezone-from-time 165 166 xpath-fn:adjust-datetime-to-timezone 167 xpath-fn:adjust-date-to-timezone 168 xpath-fn:adjust-time-to-timezone 169 xpath-op:subtract-datetimes 170 xpath-op:subtract-dates 171 xpath-op:subtract-times 172 xpath-op:add-year-month-duration-to-datetime 173 xpath-op:add-day-time-duration-to-datetime 174 xpath-op:subtract-year-month-duration-from-datetime 175 xpath-op:subtract-day-time-duration-from-datetime 176 xpath-op:add-year-month-duration-to-date 177 xpath-op:add-day-time-duration-to-date 178 xpath-op:subtract-year-month-duration-from-date 179 xpath-op:subtract-day-time-duration-from-date 180 xpath-op:add-day-time-duration-to-time 181 xpath-op:subtract-day-time-duration-from-time 182 183 xpath-fn:format-datetime 184 xpath-fn:format-date 185 xpath-fn:format-time 186 xpath-fn:parse-ietf-date 187 xpath-fn:resolve-qname 188 xpath-fn:qname 189 xpath-op:qname-equal 190 xpath-fn:prefix-from-qname 191 xpath-fn:local-name-from-qname 192 xpath-fn:namespace-uri-from-qname 193 xpath-fn:namespace-uri-for-prefix 194 xpath-fn:in-scope-prefixes 195 xpath-op:hex-binary-equal 196 xpath-op:hex-binary-less-than 197 xpath-op:hex-binary-greater-than 198 xpath-op:base64-binary-equal 199 xpath-op:base64-binary-less-than 200 xpath-op:base64-binary-greater-than 201 xpath-op:notation-equal 202 xpath-fn:name 203 xpath-fn:local-name 204 xpath-fn:namespace-uri 205 xpath-fn:lang 206 xpath-fn:root 207 xpath-fn:path 208 xpath-fn:has-children 209 xpath-fn:outermost 210 xpath-fn:empty 211 xpath-fn:exists 212 xpath-fn:head 213 xpath-fn:tail 214 xpath-fn:insert-before 215 xpath-fn:remove 216 xpath-fn:reverse 217 xpath-fn:subsequence 218 xpath-fn:unordered 219 xpath-fn:distinct-values 220 xpath-fn:index-of 221 xpath-fn:deep-equal 222 xpath-fn:zero-or-one 223 xpath-fn:one-or-more 224 xpath-fn:exactly-one 225 xpath-fn:count 226 xpath-fn:avg 227 xpath-fn:max 228 xpath-fn:min 229 xpath-fn:sum 230 xpath-fn:id 231 xpath-fn:element-with-id 232 xpath-fn:idref 233 xpath-fn:generate-id 234 xpath-fn:doc 235 xpath-fn:doc-available 236 xpath-fn:collection 237 xpath-fn:uri-collection 238 xpath-fn:unparsed-text 239 xpath-fn:unparsed-text-lines 240 xpath-fn:environment-variable 241 xpath-fn:environment-variables 242 xpath-fn:parse-xml 243 xpath-fn:parse-xml-fragment 244 xpath-fn:serialize 245 xpath-fn:position 246 xpath-fn:last 247 xpath-fn:current-datetime 248 xpath-fn:current-date 249 xpath-fn:current-time 250 xpath-fn:implicit-timezone 251 xpath-fn:default-collation 252 xpath-fn:default-language 253 xpath-fn:static-base-uri 254 xpath-fn:function-lookup 255 xpath-fn:function-name 256 xpath-fn:function-arity 257 xpath-fn:for-each 258 xpath-fn:filter 259 xpath-fn:fold-left 260 xpath-fn:fold-right 261 xpath-fn:for-each-pair 262 xpath-fn:sort 263 xpath-fn:apply 264 xpath-fn:load-xquery-module 265 xpath-fn:transform 266 xpath-op:same-key 267 xpath-fn:map 268 xpath-map:merge 269 xpath-map:size 270 xpath-map:keys 271 xpath-map:contains 272 xpath-map:get 273 xpath-map:find 274 xpath-map:put 275 xpath-map:entry 276 xpath-map:remove 277 xpath-map:for-each 278 xpath-array:size 279 xpath-array:get 280 xpath-array:put 281 xpath-array:append 282 xpath-array:subarray 283 xpath-array:remove 284 xpath-array:insert-before 285 xpath-array:head 286 xpath-array:tail 287 xpath-array:reverse 288 xpath-array:join 289 xpath-array:for-each 290 xpath-array:filter 291 xpath-array:fold-left 292 xpath-array:fold-right 293 xpath-array:for-each-pair 294 xpath-array:sort 295 xpath-array:flatten 296 xpath-fn:parse-json 297 xpath-fn:json-doc 298 xpath-fn:json-to-xml 299 xpath-fn:xml-to-json) 300 (import (rnrs) 301 (rnrs r5rs) 302 (peg) 303 (peg chars) 304 (rfc uri) 305 (sagittarius) 306 (sagittarius calendar) 307 (sagittarius generators) 308 (sagittarius regex) 309 (sagittarius timezone) 310 (only (scheme base) read-line) 311 (srfi :1 lists) 312 (srfi :13 strings) 313 (srfi :14 char-sets) 314 (srfi :39 parameters) 315 (srfi :43 vectors) 316 (srfi :98 os-environment-variables) 317 (srfi :115 regexp) 318 (srfi :127 lseqs) 319 (srfi :144 flonums) 320 (text json parser) 321 (text xml errors) 322 (text xml dom) 323 (only (text xml dom parser) +xml:char-set+) 324 (text xml dom writer) 325 (text xml schema) 326 (text xml xpath dm) 327 (text xml xpath tools) 328 (util bytevector) 329 (util file) 330 (util hashtables) 331 (util vector)) 332 333;;; 2 Accessors 334;;; All accessor requires the $arg argument, the XPath evaluator 335;;; must handle the context item. 336(define (xpty0004-error who arg) 337 (xqt-error 'XPTY0004 who "Invalid argument" arg)) 338(define-syntax dm:delegate 339 (syntax-rules () 340 ((_ who delegate) 341 (let ((proc delegate)) 342 (lambda (arg) 343 (cond ((null? arg) '()) 344 ((not (node? arg)) 345 (xqt-error 'XPTY0004 'who "Not a node" arg)) 346 (else (proc arg)))))))) 347 348;;;; 2.1 fn:node-name 349;;;; fn:node-name($arg as node()?) as xs:QName? 350(define xpath-fn:node-name (dm:delegate xpath-fn:node-name xpath-dm:node-name)) 351 352;;;; 2.2 fn:nilled 353(define xpath-fn:nilled (dm:delegate xpath-fn:nilled xpath-dm:nilled)) 354 355;;;; 2.3 fn:string 356(define xpath-fn:string 357 (let ((delegate (dm:delegate xpath-fn:string xpath-dm:string-value))) 358 (lambda (arg) 359 (cond ((null? arg) "") 360 ((xs:any-atomic-type? arg) (atomic->string 'xpath-fn:string arg)) 361 (else (delegate arg)))))) 362 363;;;; 2.4 fn:data 364(define xpath-fn:data 365 (let ((delegate (dm:delegate xpath-fn:data xpath-dm:typed-value))) 366 (lambda (arg) 367 (cond ((pair? arg) (map xpath-fn:data arg)) 368 ;; ((array? args) ...) 369 ((xs:any-atomic-type? arg) arg) ;; correct? 370 (else (delegate arg)))))) 371 372;;;; 2.5 fn:base-uri 373(define xpath-fn:base-uri (dm:delegate xpath-fn:base-uri xpath-dm:base-uri)) 374 375;;;; 2.6 fn:document-uri 376(define xpath-fn:document-uri 377 (dm:delegate xpath-fn:document-uri xpath-dm:document-uri)) 378 379;;; 3 Errors and diagnostics 380;;;; 3.1.1 fn:error 381;;;; fn:error() as none 382;;;; fn:error($code as xs:QName?) as none 383;;;; fn:error($code as xs:QName?, $description as xs:string) as none 384;;;; fn:error($code as xs:QName?, 385;;;; $description as xs:string, 386;;;; $error-object as item()*) as none 387(define +default-error-code+ 388 (xs:make-qname "http://www.w3.org/2005/xqt-errors" "FOER0000" "err")) 389(define (search-error-description type) 390 (cond ((assq (string->symbol type) +xqt-errors+) => cadr) 391 (else "Unknown reason"))) 392(define xpath-fn:error 393 (case-lambda 394 (() (xpath-fn:error +default-error-code+)) 395 ((qname) 396 (xpath-fn:error qname 397 (search-error-description (xs:qname-local-part qname)) '())) 398 ((qname description error-object) 399 ;; TODO should we check the namespace? 400 (if (null? error-object) 401 (xqt-error (string->symbol (xs:qname-local-part qname)) 402 'xpath-fn:error description) 403 (xqt-error (string->symbol (xs:qname-local-part qname)) 404 'xpath-fn:error description error-object))))) 405 406;;;; 3.2.1 fn:trace 407(define (xpath-fn:trace . args) 408 (implementation-restriction-violation 'xpath-fn:trace 409 "xpath-fn:trace is not supported")) 410 411;;; 4 Functions and operators on numerics 412(define-syntax fn:delegate-numeric-op 413 (syntax-rules () 414 ((_ op) (lambda (v1 v2) (op v1 v2))))) 415;;;; 4.2.1 op:numeric-add 416(define xpath-op:numeric-add (fn:delegate-numeric-op +)) 417;;;; 4.2.2 op:numeric-subtract 418(define xpath-op:numeric-subtract (fn:delegate-numeric-op -)) 419;;;; 4.2.3 op:numeric-multiply 420(define xpath-op:numeric-multiply (fn:delegate-numeric-op *)) 421;;;; 4.2.4 op:numeric-divide 422(define (xpath-op:numeric-divide v1 v2) 423 (and (integer? v2) (zero? v2) 424 (xqt-error 'FOAR0001 'xpath-op:numeric-divide "Dividing by 0" v1 v2)) 425 (let ((r (/ v1 v2))) 426 (if (and (not (flonum? r)) (not (= (denominator r) 1))) 427 (inexact r) 428 r))) 429;;;; 4.2.5 op:numeric-integer-divide 430(define (xpath-op:numeric-integer-divide x y) 431 (when (zero? y) 432 (xqt-error 'FOAR0001 'xpath-op:numeric-integer-divide "Dividing by 0" x y)) 433 (when (infinite? x) 434 (xqt-error 'FOAR0002 'xpath-op:numeric-integer-divide "Argument is INF" x y)) 435 (if (infinite? x) 436 0 437 (let ((r (/ x y))) 438 (if (negative? r) 439 (exact (ceiling r)) 440 (exact (floor r)))))) 441;;;; 4.2.6 op:numeric-mod 442(define (xpath-op:numeric-mod v1 v2) 443 (and (zero? v2) 444 (xqt-error 'FOAR0001 'xpath-op:numeric-mod "Dividing by 0" v1 v2)) 445 (mod v1 v2)) 446 447;;;; 4.2.7 op:numeric-unary-plus 448(define (xpath-op:numeric-unary-plus x) (+ x)) 449;;;; 4.2.8 op:numeric-unary-minus 450(define (xpath-op:numeric-unary-minus x) (- x)) 451 452;;;; 4.3.1 op:numeric-equal 453(define xpath-op:numeric-equal (fn:delegate-numeric-op =)) 454;;;; 4.3.2 op:numeric-less-than 455(define xpath-op:numeric-less-than (fn:delegate-numeric-op <)) 456;;;; 4.3.3 op:numeric-greater-than 457(define xpath-op:numeric-greater-than (fn:delegate-numeric-op >)) 458 459(define-syntax fn:delegate-numeric-unary-fn 460 (syntax-rules () 461 ;; TODO type check but which error? 462 ((_ fn) (lambda (v1) (fn v1))))) 463;;;; 4.4.1 fn:abs 464(define xpath-fn:abs (fn:delegate-numeric-unary-fn abs)) 465;;;; 4.4.2 fn:ceiling 466(define xpath-fn:ceiling (fn:delegate-numeric-unary-fn ceiling)) 467;;;; 4.4.3 fn:floor 468(define xpath-fn:floor (fn:delegate-numeric-unary-fn floor)) 469;;;; 4.4.4 fn:round 470(define xpath-fn:round 471 (case-lambda 472 ((arg) (xpath-fn:round arg 0)) 473 ((arg precision) 474 ;; for now it's not a good way of doing it :( 475 (let ((lift (expt 10.0 precision))) 476 (let-values (((i f) (flinteger-fraction (* arg lift)))) 477 (/ (if (>= f 0.5) (+ i 1) i) lift)))))) 478;;;; 4.4.5 fn:round-half-to-even 479(define xpath-fn:round-half-to-even 480 (case-lambda 481 ((arg) (xpath-fn:round-half-to-even arg 0)) 482 ((arg precision) 483 (let ((lift (expt 10.0 precision))) 484 (/ (round (* arg lift)) lift))))) 485 486;;;; 4.5.1 fn:number 487;;;; fn:number($arg as xs:anyAtomicType?) as xs:double 488(define (xpath-fn:number arg) 489 (cond ((string->number (xpath-fn:string arg)) => inexact) 490 (else +nan.0))) 491 492;;;; 4.6.1 fn:format-integer 493(define xpath-fn:format-integer 494 (case-lambda 495 ((value picture) 496 (xpath-fn:format-integer value picture "en")) 497 ((value picture lang) 498 (implementation-restriction-violation 'xpath-fn:format-integer 499 "Not supported yet")))) 500 501;;;; 4.7.2 fn:format-number 502(define xpath-fn:format-number 503 (case-lambda 504 ((value picture) 505 (xpath-fn:format-number value picture "default")) 506 ((value picture decimal-format-name) 507 (implementation-restriction-violation 'xpath-fn:format-number 508 "Not supported yet")))) 509 510;;;; 4.8.1 math:pi 511(define (xpath-math:pi) fl-pi) 512 513;;;; 4.8.2 math:exp 514(define (xpath-math:exp x) (exp (inexact x))) 515;;;; 4.8.3 math:exp10 516(define (xpath-math:exp10 x) (expt 10.0 x)) 517(define-syntax ->nan 518 (syntax-rules () 519 ((_ exp) 520 (let ((r exp)) (if (real? r) r +nan.0))))) 521;;;; 4.8.4 math:log 522(define (xpath-math:log x) (->nan (log (inexact x)))) 523;;;; 4.8.5 math:log10 524(define (xpath-math:log10 x) (->nan (log (inexact x) 10))) 525;;;; 4.8.6 math:pow 526(define (xpath-math:pow x y) 527 (inexact (expt x y))) 528;;;; 4.8.7 math:sqrt 529(define (xpath-math:sqrt x) (->nan (inexact (sqrt x)))) 530;;;; 4.8.8 math:sin 531(define (xpath-math:sin x) (->nan (inexact (sin x)))) 532;;;; 4.8.9 math:cos 533(define (xpath-math:cos x) (->nan (inexact (cos x)))) 534;;;; 4.8.10 math:tan 535(define (xpath-math:tan x) (->nan (inexact (tan x)))) 536;;;; 4.8.11 math:asin 537(define (xpath-math:asin x) (->nan (inexact (asin x)))) 538;;;; 4.8.12 math:acos 539(define (xpath-math:acos x) (->nan (inexact (acos x)))) 540;;;; 4.8.13 math:atan 541(define (xpath-math:atan x) (->nan (inexact (atan x)))) 542;;;; 4.8.14 math:atan2 543(define (xpath-math:atan2 x y) (->nan (inexact (atan x y)))) 544 545;;;; 4.9.1 fn:random-number-generator 546(define (xpath-fn:random-number-generator seed) 547 (implementation-restriction-violation 'xpath-fn:random-number-generator 548 "Not supported")) 549 550;;; 5 Functions on strings 551;;;; 5.2.1 fn:codepoints-to-string 552(define (xpath-fn:codepoints-to-string codepoints) 553 (define (integer->xml-char i) 554 (let ((c (integer->char i))) 555 (unless (char-set-contains? +xml:char-set+ c) 556 (xqt-error 'FOCH0001 'xpath-fn:codepoints-to-string 557 "Invalid XML char" c)) 558 c)) 559 (list->string (map integer->xml-char codepoints))) 560 561;;;; 5.2.2 fn:string-to-codepoints 562(define (xpath-fn:string-to-codepoints str) 563 (map char->integer (string->list str))) 564 565 566(define +default-collation+ "default") 567;;;; 5.3.6 fn:compare 568(define xpath-fn:compare 569 (case-lambda 570 ((arg0 arg1) (xpath-fn:compare arg0 arg1 +default-collation+)) 571 ((s0 s1 collation) 572 ;; TODO support collation 573 (unless (string=? collation +default-collation+) 574 (xqt-error 'FOCH0002 'xpath-fn:compare "Not supported" collation)) 575 (string-compare s0 s1 (lambda (_) -1) (lambda (_) 0) (lambda (_) 1))))) 576 577;;;; 5.3.7 fn:codepoint-equal 578(define (xpath-fn:codepoint-equal s1 s2) 579 (if (or (null? s1) (null? s2)) 580 '() 581 (string=? s1 s2))) 582 583;;;; 5.3.8 fn:collation-key 584(define xpath-fn:collation-key 585 (case-lambda 586 ((key) (xpath-fn:collation-key key +default-collation+)) 587 ((key collation) 588 (implementation-restriction-violation 'xpath-fn:collation-key "Not supported yet")))) 589 590;;;; 5.3.9 fn:contains-token 591(define xpath-fn:contains-token 592 (case-lambda 593 ((input token) (xpath-fn:contains-token input token +default-collation+)) 594 ((input token collation) 595 (implementation-restriction-violation 'xpath-fn:collation-token 596 "Not supported yet")))) 597 598;;;; 5.4.1 fn:concat 599(define (xpath-fn:concat s1 s2 . s*) 600 ;; TODO very inefficient... 601 (string-concatenate 602 (map (lambda (e) (atomic->string 'xpath-fn:concat e)) (cons* s1 s2 s*)))) 603 604;;;; 5.4.2 fn:string-join 605(define xpath-fn:string-join 606 (case-lambda 607 ((s*) (xpath-fn:string-join s* "")) 608 ((s* delim) 609 (string-join (map (lambda (e) (atomic->string 'xpath-fn:string-join e)) s*) delim)))) 610 611;;;; 5.4.3 fn:substring 612(define xpath-fn:substring 613 (case-lambda 614 ((src start) 615 (let ((len (string-length src))) 616 (xpath-fn:substring src start (+ (- len start) 1)))) 617 ((src start length) 618 (define s (xpath-fn:round start)) 619 (define l (xpath-fn:round length)) 620 (cond ((null? src) "") 621 ((or (nan? s) (nan? l)) "") 622 (else 623 (let ((start (max 1 s)) 624 (end (max start (+ s l)))) 625 (cond ((nan? end) "") ;; (+ +inf.0 -inf.0) 626 ((infinite? start) "") 627 (else 628 (let* ((s (exact start)) 629 (e (if (infinite? end) 630 ;; handling inifinate is a bit silly here... 631 (if (negative? end) 632 s 633 (+ (- (string-length src) (- s 1)) 1)) 634 (exact end)))) 635 (substring src (- s 1) (- e 1))))))))))) 636 637;;;; 5.4.4 fn:string-length 638(define (xpath-fn:string-length arg) 639 (if (null? arg) 640 0 641 (string-length arg))) 642 643;;;; 5.4.5 fn:normalize-space 644(define (xpath-fn:normalize-space arg) 645 (define (space? c) (memv c '(#\x20 #\x9 #\xD #\xA))) 646 (if (null? arg) 647 "" 648 (let-values (((out e) (open-string-output-port))) 649 ;; TODO a bit inefficient... 650 (define str (string-trim-both arg space?)) 651 ;; TODO maybe should use cursor SRFI for better portability 652 ;; but no plan to make this portable so forget about it for now 653 (let loop ((i 0) (prev-space? #f)) 654 (cond ((= (string-length str) i) (e)) 655 ((space? (string-ref str i)) 656 (unless prev-space? (put-char out #\x20)) 657 (loop (+ i 1) #t)) 658 (else (put-char out (string-ref str i)) (loop (+ i 1) #f))))))) 659 660;;;; 5.4.6 fn:normalize-unicode 661(define xpath-fn:normalize-unicode 662 (case-lambda 663 ((arg) (xpath-fn:normalize-unicode arg "NFC")) 664 ((arg form) 665 (case (string->symbol form) 666 ((NFC) (string-normalize-nfc arg)) 667 ((NFD) (string-normalize-nfd arg)) 668 ((NFKC) (string-normalize-nfkc arg)) 669 ((NFKD) (string-normalize-nfkd arg)) 670 (else (xqt-error 'FOCH0003 'xpath-fn:normalize-unicode 671 "Unsupported normalization" form)))))) 672 673;;;; 5.4.7 fn:upper-case 674(define (xpath-fn:upper-case arg) (string-upcase arg)) 675;;;; 5.4.8 fn:lower-case 676(define (xpath-fn:lower-case arg) (string-downcase arg)) 677 678;;;; 5.4.9 fn:translate 679(define (xpath-fn:translate arg map-s trans-s) 680 (list->string 681 (filter-map 682 (lambda (c) 683 (let ((i (string-index map-s c))) 684 (cond ((and i (< i (string-length trans-s)) (string-ref trans-s i))) 685 ((and i (>= i (string-length trans-s))) #f) 686 (else c)))) (string->list arg)))) 687 688;;;; 5.5.1 fn:contains 689(define xpath-fn:contains 690 (case-lambda 691 ((s1 s2) (xpath-fn:contains s1 s2 +default-collation+)) 692 ((s1 s2 collation) 693 (unless (string=? collation +default-collation+) 694 (xqt-error 'FOCH0004 'xpath-fn:contains "Not supported" collation)) 695 (cond ((and (null? s1) (null? s2))) ;; "" contains "" 696 ((null? s2)) ;; s1 contains "" 697 ((null? s1) #f) ;; "" contains s2 698 (else (and (string-contains s1 s2) #t)))))) 699 700;;;; 5.5.2 fn:starts-with 701(define xpath-fn:starts-with 702 (case-lambda 703 ((s1 s2) (xpath-fn:starts-with s1 s2 +default-collation+)) 704 ((s1 s2 collation) 705 (unless (string=? collation +default-collation+) 706 (xqt-error 'FOCH0004 'xpath-fn:starts-with "Not supported" collation)) 707 (cond ((and (null? s1) (null? s2))) ;; "" starts with "" 708 ((null? s2)) ;; s1 starts with "" 709 ((null? s1) #f) ;; "" starts with s2 710 (else (string-prefix? s2 s1)))))) 711 712;;;; 5.5.3 fn:ends-with 713(define xpath-fn:ends-with 714 (case-lambda 715 ((s1 s2) (xpath-fn:ends-with s1 s2 +default-collation+)) 716 ((s1 s2 collation) 717 (unless (string=? collation +default-collation+) 718 (xqt-error 'FOCH0004 'xpath-fn:ends-with "Not supported" collation)) 719 (cond ((and (null? s1) (null? s2))) ;; "" ends with "" 720 ((null? s2)) ;; s1 ends with "" 721 ((null? s1) #f) ;; "" ends with s2 722 (else (string-suffix? s2 s1)))))) 723 724;;;; 5.5.4 fn:substring-before 725(define xpath-fn:substring-before 726 (case-lambda 727 ((s1 s2) (xpath-fn:substring-before s1 s2 +default-collation+)) 728 ((s1 s2 collation) 729 (unless (string=? collation +default-collation+) 730 (xqt-error 'FOCH0004 'xpath-fn:substring-before "Not supported" collation)) 731 (cond ((and (null? s1) (null? s2)) "") ;; "" substring before "" 732 ((null? s2) "") ;; s1 substring before "" 733 ((null? s1) "") ;; "" substring before s2 734 ((string-contains s1 s2) => (lambda (i) (substring s1 0 i))) 735 (else ""))))) 736 737;;;; 5.5.5 fn:substring-after 738(define xpath-fn:substring-after 739 (case-lambda 740 ((s1 s2) (xpath-fn:substring-after s1 s2 +default-collation+)) 741 ((s1 s2 collation) 742 (unless (string=? collation +default-collation+) 743 (xqt-error 'FOCH0004 'xpath-fn:substring-after "Not supported" collation)) 744 (cond ((and (null? s1) (null? s2)) "") ;; "" substring before "" 745 ((null? s2) "") ;; s1 substring before "" 746 ((null? s1) "") ;; "" substring before s2 747 ((string-contains s1 s2) => 748 (lambda (i) (substring s1 (+ i (string-length s2)) (string-length s1)))) 749 (else ""))))) 750 751;; helper 752(define +regex-flags+ 753 `((#\s . ,DOTALL) 754 (#\m . ,MULTILINE) 755 (#\i . ,CASE-INSENSITIVE) 756 (#\x . ,COMMENTS) 757 (#\q . ,LITERAL))) 758(define (->regex-flag who c) 759 (cond ((assv c +regex-flags+) => cdr) 760 (else (xqt-error 'FORX0001 who "Invalid flag" c)))) 761(define (string-flags->flags who flags) 762 (define (->flag c) (->regex-flag who c)) 763 (fold-left bitwise-ior 0 (map ->flag (string->list flags)))) 764;;;; 5.6.3 fn:matches 765(define xpath-fn:matches 766 (case-lambda 767 ((input pattern) (xpath-fn:matches input pattern "")) 768 ((input pattern flags) 769 (let ((flags (string-flags->flags 'xpath-fn:matches flags))) 770 (guard (e (else (xqt-error 'FORX0002 'xpath-fn:matches "Invalid pattern" pattern))) 771 (looking-at (regex pattern flags) input)))))) 772 773(define (check-pattern who input pattern flags) 774 (when (looking-at (regex pattern flags) "") 775 (xqt-error 'FORX0003 who "Pattern matches empty string" pattern))) 776;;;; 5.6.4 fn:replace 777(define xpath-fn:replace 778 (case-lambda 779 ((input pattern replacement) (xpath-fn:replace input pattern replacement "")) 780 ((input pattern replacement flags) 781 (let ((flags (string-flags->flags 'xpath-fn:replace flags))) 782 (check-pattern 'xpath-fn:replace input pattern flags) 783 ;; TODO not really correct.. 784 (guard (e (else (xqt-error 'FORX0004 'xpath-fn:replace (condition-message e)))) 785 (regex-replace-all (regex pattern flags) input replacement)))))) 786 787;;;; 5.6.5 fn:tokenize 788(define xpath-fn:tokenize 789 (case-lambda 790 ((input) (xpath-fn:tokenize (xpath-fn:normalize-space input) " ")) 791 ((input pattern) (xpath-fn:tokenize input pattern "")) 792 ((input pattern flags) 793 (let ((flags (string-flags->flags 'xpath-fn:tokenize flags))) 794 (check-pattern 'xpath-fn:tokenize input pattern flags) 795 (guard (e (else (xqt-error 'FORX0002 'xpath-fn:tokenize (condition-message e)))) 796 (let ((r (regexp-split (regex pattern flags) input))) 797 (if (null? (cdr r)) 798 (car r) 799 r))))))) 800 801;;;; 5.6.6 fn:analyze-string 802(define xpath-fn:analyze-string 803 (case-lambda 804 ((input pattern) (xpath-fn:analyze-string input pattern "")) 805 ((input pattern flags) 806 (string-flags->flags 'xpath-fn:analyze-string flags) ;; for fun 807 (implementation-restriction-violation 'xpath-fn:analyze-string "Not supported")))) 808 809;;;; 6.1 fn:resolve-uri 810(define not-supplied (list '())) 811(define xpath-fn:resolve-uri 812 (case-lambda 813 ((relative) (xpath-fn:resolve-uri relative not-supplied)) 814 ((relative base) 815 (define (absoluete-iri? uri) 816 (let-values (((scheme specific) (uri-scheme&specific uri))) 817 (and scheme #t))) 818 (cond ((null? relative) '()) 819 ((absoluete-iri? relative) relative) 820 ((eq? not-supplied base) 821 (xqt-error 'FONS0005 xpath-fn:resolve-uri "Base is not provided" relative)) 822 (else (uri-merge base relative)))))) 823 824;;;; 6.2 fn:encode-for-uri 825(define (xpath-fn:encode-for-uri uri-part) 826 (if (null? uri-part) 827 "" 828 (uri-encode-string uri-part))) 829 830;;;; 6.3 fn:iri-to-uri 831(define (xpath-fn:iri-to-uri iri) 832 (if (null? iri) 833 "" 834 (let*-values (((scheme specific) (uri-scheme&specific iri)) 835 ((auth path query frag) (uri-decompose-hierarchical specific))) 836 (define (encode p) (uri-encode-string (uri-decode-string p))) 837 (uri-compose :scheme scheme 838 :authority auth 839 :path (and path 840 (string-join (map encode (string-split path "/")) "/")) 841 :query (and query (uri-encode-string query)) 842 :fragment (and frag (uri-encode-string frag)))))) 843 844;;;; 6.4 fn:escape-html-uri 845(define us-ascii-printables (char-set-intersection char-set:ascii char-set:printing)) 846(define (xpath-fn:escape-html-uri uri) 847 (if (null? uri) 848 "" 849 (uri-encode-string uri :noescape us-ascii-printables))) 850 851;;;; 7.1.1 fn:true 852(define (xpath-fn:true) #t) 853;;;; 7.1.2 fn:false 854(define (xpath-fn:false) #f) 855;;;; 7.2.1 op:boolean-equal 856(define (xpath-op:boolean-equal v1 v2) (boolean=? v1 v2)) 857;;;; 7.2.2 op:boolean-less-than 858(define (xpath-op:boolean-less-than v1 v2) 859 (and (boolean=? v1 #f) (boolean=? v2 #t))) 860;;;; 7.2.3 op:boolean-greater-than 861(define (xpath-op:boolean-greater-than v1 v2) 862 (xpath-op:boolean-less-than v2 v1)) 863;;;; 7.3.1 fn:boolean 864(define (xpath-fn:boolean arg*) 865 (cond ((null? arg*) #f) 866 ((and (pair? arg*) (node? (car arg*)))) 867 ((boolean? arg*) arg*) 868 ((string? arg*) (not (zero? (string-length arg*)))) 869 ((number? arg*) (not (or (zero? arg*) (nan? arg*)))) 870 (else (xqt-error 'FORG0006 'xpath-fn:boolean "Unknown value" arg*)))) 871;;;; 7.3.2 fn:not 872(define (xpath-fn:not arg*) (not (xpath-fn:boolean arg*))) 873 874 875;;;; 8.2.1 op:yearMonthDuration-less-than 876(define (xpath-op:year-month-duration-less-than v1 v2) 877 ;; TODO type check 878 (< (xs:duration-months v1) (xs:duration-months v2))) 879;;;; 8.2.2 op:yearMonthDuration-greater-than 880(define (xpath-op:year-month-duration-greater-than v1 v2) 881 (xpath-op:year-month-duration-less-than v2 v1)) 882;;;; 8.2.3 op:dayTimeDuration-less-than 883(define (xpath-op:day-time-duration-less-than v1 v2) 884 (< (xs:duration-seconds v1) (xs:duration-seconds v2))) 885;;;; 8.2.4 op:dayTimeDuration-greater-than 886(define (xpath-op:day-time-duration-greater-than v1 v2) 887 (xpath-op:day-time-duration-less-than v2 v1)) 888;;;; 8.2.5 op:duration-equal 889(define (xpath-op:duration-equal v1 v2) 890 (unless (and (xs:duration? v1) (xs:duration? v2)) 891 ;; FIXME which error? 892 (assertion-violation 'xpath-op:duration-equal "Invalid arguments" v1 v2)) 893 (and (= (xs:duration-months v1) (xs:duration-months v2)) 894 (= (xs:duration-seconds v1) (xs:duration-seconds v2)))) 895 896;;;; 8.3.1 fn:years-from-duration 897(define (xpath-fn:years-from-duration arg) 898 (if (xs:day-time-duration? arg) 899 0 900 (quotient (xs:duration-months arg) 12))) 901;;;; 8.3.2 fn:months-from-duration 902(define (xpath-fn:months-from-duration arg) 903 (if (xs:day-time-duration? arg) 904 0 905 (remainder (xs:duration-months arg) 12))) 906(define (exact-floor d) (exact (floor d))) 907;;;; 8.3.3 fn:days-from-duration 908(define (xpath-fn:days-from-duration arg) 909 (if (xs:year-month-duration? arg) 910 0 911 (quotient (exact-floor (xs:duration-seconds arg)) 86400))) 912;;;; 8.3.4 fn:hours-from-duration 913(define (xpath-fn:hours-from-duration arg) 914 (if (xs:year-month-duration? arg) 915 0 916 (quotient (remainder (exact-floor (xs:duration-seconds arg)) 86400) 3600))) 917;;;; 8.3.5 fn:minutes-from-duration 918(define (xpath-fn:minutes-from-duration arg) 919 (if (xs:year-month-duration? arg) 920 0 921 (quotient (remainder (exact-floor (xs:duration-seconds arg)) 3600) 60))) 922;;;; 8.3.6 fn:seconds-from-duration 923(define (xpath-fn:seconds-from-duration arg) 924 (if (xs:year-month-duration? arg) 925 0 926 (let-values (((s f) (flinteger-fraction (xs:duration-seconds arg)))) 927 (+ (remainder s 60) f)))) 928 929(define-syntax define-duration-arithmetic-operators 930 (lambda (x) 931 (define (op-name k type op plural) 932 (datum->syntax k 933 (string->symbol (string-append "xpath-op:" op "-" 934 (symbol->string (syntax->datum type)) 935 plural)))) 936 (define (div-by-name k type) 937 (define type-str (symbol->string (syntax->datum type))) 938 (datum->syntax k 939 (string->symbol 940 (string-append "xpath-op:divide-" type-str "-by-" type-str)))) 941 (define (ctr-name k type) 942 (datum->syntax k 943 (string->symbol 944 (string-append "xs:make-" (symbol->string (syntax->datum type)))))) 945 (syntax-case x () 946 ((k type getter) 947 (with-syntax ((add (op-name #'k #'type "add" "s")) 948 (sub (op-name #'k #'type "subtract" "s")) 949 (mul (op-name #'k #'type "multiply" "")) 950 (div (op-name #'k #'type "divide" "")) 951 (div-by (div-by-name #'k #'type)) 952 (make (ctr-name #'k #'type))) 953 #'(begin 954 (define (add v1 v2) (make (+ (getter v1) (getter v2)))) 955 (define (sub v1 v2) (make (- (getter v1) (getter v2)))) 956 (define (mul v1 arg) 957 (when (nan? arg) 958 (xqt-error 'FOCA0005 'mul 959 "Multiplier must be a real number" arg)) 960 (make (exact (ceiling (* (getter v1) arg))))) 961 (define (div v1 arg) 962 (when (nan? arg) 963 (xqt-error 'FOCA0005 'div 964 "Multiplier must be a real number" arg)) 965 (make (exact (xpath-fn:round (/ (getter v1) arg))))) 966 (define (div-by v1 v2) 967 (xpath-op:numeric-divide (getter v1) (getter v2))))))))) 968;;;; 8.4.1 op:add-yearMonthDurations 969;;;; 8.4.2 op:subtract-yearMonthDurations 970;;;; 8.4.3 op:multiply-yearMonthDuration 971;;;; 8.4.4 op:divide-yearMonthDuration 972;;;; 8.4.5 op:divide-yearMonthDuration-by-yearMonthDuration 973(define-duration-arithmetic-operators year-month-duration xs:duration-months) 974;;;; 8.4.6 op:add-dayTimeDurations 975;;;; 8.4.7 op:subtract-dayTimeDurations 976;;;; 8.4.8 op:multiply-dayTimeDuration 977;;;; 8.4.9 op:divide-dayTimeDuration 978;;;; 8.4.10 op:divide-dayTimeDuration-by-dayTimeDuration 979(define-duration-arithmetic-operators day-time-duration xs:duration-seconds) 980 981 982;;;; 9.3.1 fn:dateTime 983(define (xpath-fn:datetime d t) 984 (unless (eqv? (xs:date-timezone-offset d) (xs:time-timezone-offset t)) 985 (xqt-error 'FORG0008 'xpath-fn:datetime 986 "Date and time has different timezones" d t)) 987 (xs:make-datetime (xs:date-year d) (xs:date-month d) (xs:date-day d) 988 (xs:time-hour t) (xs:time-minute t) (xs:time-second t) 989 (xs:date-timezone-offset d))) 990 991(define-syntax define-date-comparison 992 (lambda (x) 993 (define (gen k type) 994 (define name (symbol->string (syntax->datum type))) 995 (datum->syntax k 996 (map (lambda (suffix op) 997 (list (string->symbol (string-append "xpath-op:" name suffix)) 998 (string->symbol (string-append "xs:" name op)))) 999 '("-equal" "-less-than" "-greater-than") 1000 '("-w/o-tz=?" "<?" ">?")))) 1001 (syntax-case x () 1002 ((k type) 1003 (with-syntax ((((name op) ...) (gen #'k #'type))) 1004 #'(begin 1005 (define (name d1 d2) (op d1 d2)) 1006 ...)))))) 1007;;;; 9.4.1 op:dateTime-equal 1008;;;; 9.4.2 op:dateTime-less-than 1009;;;; 9.4.3 op:dateTime-greater-than 1010(define-date-comparison datetime) 1011;;;; 9.4.4 op:date-equal 1012;;;; 9.4.5 op:date-less-than 1013;;;; 9.4.6 op:date-greater-than 1014(define-date-comparison date) 1015;;;; 9.4.7 op:time-equal 1016;;;; 9.4.8 op:time-less-than 1017;;;; 9.4.9 op:time-greater-than 1018(define-date-comparison time) 1019 1020;; we define extra procedures but don't export it ;) 1021;;;; 9.4.10 op:gYearMonth-equal 1022(define-date-comparison g-year-month) 1023;;;; 9.4.11 op:gYear-equal 1024(define-date-comparison g-year) 1025;;;; 9.4.12 op:gMonthDay-equal 1026(define-date-comparison g-month-day) 1027;;;; 9.4.13 op:gMonth-equal 1028(define-date-comparison g-month) 1029;;;; 9.4.14 op:gDay-equal 1030(define-date-comparison g-day) 1031 1032(define-syntax define-date-accessor 1033 (lambda (x) 1034 (define (gen k type prop1 prop2) 1035 (define t (symbol->string (syntax->datum type))) 1036 (define p1 (symbol->string (syntax->datum prop1))) 1037 (define p2 (symbol->string (syntax->datum prop2))) 1038 (datum->syntax k 1039 (list (string->symbol (string-append "xpath-fn:" p2 "-from-" t)) 1040 (string->symbol (string-append "xs:" t "-" p1))))) 1041 (syntax-case x () 1042 ((k type (prop1 prop2) prop* ...) 1043 (with-syntax (((name acc) (gen #'k #'type #'prop1 #'prop2))) 1044 #'(begin 1045 (define (name o) (acc o)) 1046 (k type prop* ...)))) 1047 ((k type prop prop* ...) #'(k type (prop prop) prop* ...)) 1048 ((k type) #'(begin))))) 1049 1050 1051;;;; 9.5.1 fn:year-from-dateTime 1052;;;; 9.5.2 fn:month-from-dateTime 1053;;;; 9.5.3 fn:day-from-dateTime 1054;;;; 9.5.4 fn:hours-from-dateTime 1055;;;; 9.5.5 fn:minutes-from-dateTime 1056;;;; 9.5.6 fn:seconds-from-dateTime 1057(define-date-accessor datetime year month day 1058 (hour hours) (minute minutes) (second seconds)) 1059 1060(define-syntax define-timezone-from-* 1061 (syntax-rules () 1062 ((_ name acc) 1063 (define (name dt) 1064 (let ((tz (acc dt))) 1065 (if (not tz) 1066 '() 1067 (xs:make-day-time-duration (* tz 60)))))))) 1068;;;; 9.5.7 fn:timezone-from-dateTime 1069(define-timezone-from-* xpath-fn:timezone-from-datetime 1070 xs:datetime-timezone-offset) 1071 1072;;;; 9.5.8 fn:year-from-date 1073;;;; 9.5.9 fn:month-from-date 1074;;;; 9.5.10 fn:day-from-date 1075(define-date-accessor date year month day) 1076;;;; 9.5.11 fn:timezone-from-date 1077(define-timezone-from-* xpath-fn:timezone-from-date xs:date-timezone-offset) 1078 1079;;;; 9.5.12 fn:hours-from-time 1080;;;; 9.5.13 fn:minutes-from-time 1081;;;; 9.5.14 fn:seconds-from-time 1082(define-date-accessor time (hour hours) (minute minutes) (second seconds)) 1083;;;; 9.5.15 fn:timezone-from-time 1084(define-timezone-from-* xpath-fn:timezone-from-time xs:time-timezone-offset) 1085 1086;;;; 9.6.1 fn:adjust-dateTime-to-timezone 1087(define (adjust-datetime dt offset) 1088 (if (null? dt) 1089 '() 1090 (let ((zone (xs:datetime-timezone-offset dt))) 1091 (cond ((and (null? offset) (not zone)) dt) 1092 ((and (null? offset) zone) 1093 (xs:make-datetime (xs:datetime-year dt) 1094 (xs:datetime-month dt) 1095 (xs:datetime-day dt) 1096 (xs:datetime-hour dt) 1097 (xs:datetime-minute dt) 1098 (xs:datetime-second dt))) 1099 ((not zone) 1100 (xs:make-datetime (xs:datetime-year dt) 1101 (xs:datetime-month dt) 1102 (xs:datetime-day dt) 1103 (xs:datetime-hour dt) 1104 (xs:datetime-minute dt) 1105 (xs:datetime-second dt) 1106 (div offset 60))) 1107 (else 1108 (let* ((new-off (div offset 60)) 1109 (diff (- zone new-off))) 1110 (xs:make-datetime (xs:datetime-year dt) 1111 (xs:datetime-month dt) 1112 (xs:datetime-day dt) 1113 (xs:datetime-hour dt) 1114 (- (xs:datetime-minute dt) diff) 1115 (xs:datetime-second dt) 1116 new-off))))))) 1117 1118(define xpath-fn:adjust-datetime-to-timezone 1119 (case-lambda 1120 ((dt) 1121 (adjust-datetime dt (timezone-offset (or (*xs:dynamic-timezone*) 1122 (local-timezone))))) 1123 ((dt dtd) 1124 (cond ((null? dtd) (adjust-datetime dt dtd)) 1125 (else 1126 (unless (xs:day-time-duration? dtd) 1127 (assertion-violation 'xpath-fn:adjust-datetime-to-timezone 1128 "DayTimeDuration required" dtd)) 1129 (let ((sec (xs:duration-seconds dtd))) 1130 (when (or (< sec (* -14 3600)) (< (* 14 3600) sec)) 1131 (xqt-error 'FODT0003 'xpath-fn:adjust-datetime-to-timezone 1132 "Range error (-PT14H < n < PT14H)" dtd)) 1133 (adjust-datetime dt sec))))))) 1134 1135;;;; 9.6.2 fn:adjust-date-to-timezone 1136#| 1137* Let $dt be the value of fn:dateTime($arg, xs:time('00:00:00')). 1138* Let $adt be the value of fn:adjust-dateTime-to-timezone($dt, $timezone) 1139* The function returns the value of xs:date($adt) 1140|# 1141(define xpath-fn:adjust-date-to-timezone 1142 (case-lambda 1143 ((d) 1144 (let* ((dt (xs:make-datetime (xs:date-year d) 1145 (xs:date-month d) 1146 (xs:date-day d) 1147 0 0 0 (xs:date-timezone-offset d))) 1148 (adt (xpath-fn:adjust-datetime-to-timezone dt))) 1149 (xs:make-date (xs:datetime-year adt) (xs:datetime-month adt) 1150 (xs:datetime-day adt) 1151 (xs:date-timezone-offset adt)))) 1152 ((d tz) 1153 (let* ((dt (xs:make-datetime (xs:date-year d) 1154 (xs:date-month d) 1155 (xs:date-day d) 1156 0 0 0 (xs:date-timezone-offset d))) 1157 (adt (xpath-fn:adjust-datetime-to-timezone dt tz))) 1158 (xs:make-date (xs:datetime-year adt) (xs:datetime-month adt) 1159 (xs:datetime-day adt) 1160 (xs:date-timezone-offset adt)))))) 1161 1162;;;; 9.6.3 fn:adjust-time-to-timezone 1163#| 1164* Let $dt be the xs:dateTime value fn:dateTime(xs:date('1972-12-31'), $arg). 1165* Let $adt be the value of fn:adjust-dateTime-to-timezone($dt, $timezone) 1166* The function returns the xs:time value xs:time($adt). 1167|# 1168(define xpath-fn:adjust-time-to-timezone 1169 (case-lambda 1170 ((t) 1171 (let* ((dt (xs:make-datetime 1972 12 31 1172 (xs:time-hour t) 1173 (xs:time-minute t) 1174 (xs:time-second t) 1175 (xs:time-timezone-offset t))) 1176 (adt (xpath-fn:adjust-datetime-to-timezone dt))) 1177 (xs:make-time (xs:datetime-hour adt) (xs:datetime-minute adt) 1178 (xs:datetime-second adt) 1179 (xs:date-timezone-offset adt)))) 1180 ((t tz) 1181 (let* ((dt (xs:make-datetime 1972 12 31 1182 (xs:time-hour t) 1183 (xs:time-minute t) 1184 (xs:time-second t) 1185 (xs:time-timezone-offset t))) 1186 (adt (xpath-fn:adjust-datetime-to-timezone dt tz))) 1187 (xs:make-time (xs:datetime-hour adt) (xs:datetime-minute adt) 1188 (xs:datetime-second adt) 1189 (xs:date-timezone-offset adt)))))) 1190 1191;;;; 9.7.2 op:subtract-dateTimes 1192(define (xpath-op:subtract-datetimes dt1 dt2) 1193 (unless (and (xs:datetime? dt1) (xs:datetime? dt2)) 1194 (assertion-violation 'xpath-op:subtract-datetimes "Datetime required" 1195 dt1 dt2)) 1196 (xs:datetime-subtract dt1 dt2)) 1197;;;; 9.7.3 op:subtract-dates 1198(define (xpath-op:subtract-dates d1 d2) 1199 (unless (and (xs:date? d1) (xs:date? d1)) 1200 (assertion-violation 'xpath-op:subtract-dates "Date required" d1 d2)) 1201 (xs:date-subtract d1 d2)) 1202;;;; 9.7.4 op:subtract-times 1203(define (xpath-op:subtract-times t1 t2) 1204 (unless (and (xs:time? t1) (xs:time? t2)) 1205 (assertion-violation 'xpath-op:subtract-dates "Time required" t1 t2)) 1206 (xs:time-subtract t1 t2)) 1207 1208 1209(define-syntax define-date-add/sub-duration 1210 (lambda (x) 1211 (define (gen-name k type op conj) 1212 (define t (symbol->string (syntax->datum type))) 1213 (datum->syntax k 1214 (map string->symbol 1215 (list 1216 (string-append "xpath-op:" op "-year-month-duration-" conj "-" t) 1217 (string-append "xpath-op:" op "-day-time-duration-" conj "-" t) 1218 (string-append "xs:" t "-" op "-duration"))))) 1219 (syntax-case x () 1220 ((k type) 1221 (with-syntax (((ymd-add dt-add d-add) (gen-name #'k #'type "add" "to")) 1222 ((ymd-sub dt-sub d-sub) 1223 (gen-name #'k #'type "subtract" "from"))) 1224 #'(begin 1225 (define (ymd-add dt d) (d-add dt d)) 1226 (define (dt-add dt d) (d-add dt d)) 1227 (define (ymd-sub dt d) (d-sub dt d)) 1228 (define (dt-sub dt d) (d-sub dt d)))))))) 1229 1230;;;; 9.7.5 op:add-yearMonthDuration-to-dateTime 1231;;;; 9.7.6 op:add-dayTimeDuration-to-dateTime 1232;;;; 9.7.7 op:subtract-yearMonthDuration-from-dateTime 1233;;;; 9.7.8 op:subtract-dayTimeDuration-from-dateTime 1234(define-date-add/sub-duration datetime) 1235 1236;;;; 9.7.9 op:add-yearMonthDuration-to-date 1237;;;; 9.7.10 op:add-dayTimeDuration-to-date 1238;;;; 9.7.11 op:subtract-yearMonthDuration-from-date 1239;;;; 9.7.12 op:subtract-dayTimeDuration-from-datew 1240(define-date-add/sub-duration date) 1241 1242;;;; 9.7.13 op:add-dayTimeDuration-to-time 1243;;;; 9.7.14 op:subtract-dayTimeDuration-from-time 1244(define-date-add/sub-duration time) 1245 1246;;;; 9.8.1 fn:format-dateTime 1247;;;; 9.8.2 fn:format-date 1248;;;; 9.8.3 fn:format-time 1249(define (xpath-fn:format-datetime . args) 1250 (implementation-restriction-violation 'xpath-fn:format-datetime 1251 "Not supported yet")) 1252(define (xpath-fn:format-date . args) 1253 (implementation-restriction-violation 'xpath-fn:format-date 1254 "Not supported yet")) 1255(define (xpath-fn:format-time . args) 1256 (implementation-restriction-violation 'xpath-fn:format-time 1257 "Not supported yet")) 1258 1259;;;; 9.9.1 fn:parse-ietf-date 1260;; apparently, the definition doesn't meet with the RFC 5322, so 1261;; we define it separately... damn another date format... 1262;;; S ::= ( x09 | x0A | x0D | x20 )+ 1263(define $xpath:S ($or ($eqv? #\x09) ($eqv? #\x0A) ($eqv? #\x0D) ($eqv? #\x20))) 1264;;; digit ::= [0-9] 1265(define $xpath:digit 1266 ($or ($eqv? #\0) ($eqv? #\1) ($eqv? #\2) ($eqv? #\3) ($eqv? #\4) 1267 ($eqv? #\5) ($eqv? #\6) ($eqv? #\7) ($eqv? #\8) ($eqv? #\9))) 1268;;; hours ::= digit digit? 1269(define $xpath:hours 1270 ($let ((d0 $xpath:digit) 1271 (d1 ($optional $xpath:digit #f))) 1272 ($return (if d1 (string->number (string d0 d1)) (- (char->integer d0) 48))))) 1273;;; minutes ::= digit digit 1274(define $xpath:minutes 1275 ($let ((d0 $xpath:digit) 1276 (d1 $xpath:digit)) 1277 ($return (string->number (string d0 d1))))) 1278;;; seconds ::= digit digit ("." digit+)? 1279(define $xpath:seconds 1280 ($let ((d0 $xpath:digit) 1281 (d1 $xpath:digit) 1282 (d2 ($optional ($seq ($eqv? #\.) ($many $xpath:digit)) #f))) 1283 (if d2 1284 ($return (string->number (apply string d0 d1 #\. d2))) 1285 ($return (string->number (string d0 d1 #\.)))))) 1286;;; year ::= digit digit (digit digit)? 1287(define $xpath:year 1288 ($let ((d0 $xpath:digit) 1289 (d1 $xpath:digit) 1290 (d2-3 ($optional ($repeat $xpath:digit 2) #f))) 1291 ($return (if d2-3 1292 (string->number (apply string d0 d1 d2-3)) 1293 (+ 1900 (string->number (string d0 d1))))))) 1294;;; daynum ::= digit digit? 1295(define $xpath:daynum $xpath:hours) 1296;;; dayname ::= "Mon" | "Tue" | "Wed" | "Thu" | "Fri" | "Sat" | "Sun" | 1297;;; "Monday | "Tuesday" | "Wednesday" | "Thursday" | "Friday" | 1298;;; "Saturday" | "Sunday" 1299(define $xpath:dayname 1300 ($or ($token "Monday") ($token "Tuesday") ($token "Wednesday") 1301 ($token "Thursday") ($token "Friday") ($token "Saturday") 1302 ($token "Sunday") 1303 ($token "Mon") ($token "Tue") ($token "Wed") ($token "Thu") 1304 ($token "Fri") ($token "Sat") ($token "Sun"))) 1305;;; dsep ::= S | (S? "-" S?) 1306(define $xpath:desp 1307 ($or $xpath:S 1308 ($seq ($optional $xpath:S) ($eqv? #\-) ($optional $xpath:S)))) 1309;;; monthname ::= "Jan" | "Feb" | "Mar" | "Apr" | "May" | "Jun" | 1310;;; "Jul" | "Aug" | "Sep" | "Oct" | "Nov" | "Dec" 1311(define $xpath:monthname 1312 ($or ($seq ($token "Jan") ($return 1)) ($seq ($token "Feb") ($return 2)) 1313 ($seq ($token "Mar") ($return 3)) ($seq ($token "Apr") ($return 4)) 1314 ($seq ($token "May") ($return 5)) ($seq ($token "Jun") ($return 6)) 1315 ($seq ($token "Jul") ($return 7)) ($seq ($token "Aug") ($return 8)) 1316 ($seq ($token "Sep") ($return 9)) ($seq ($token "Oct") ($return 10)) 1317 ($seq ($token "Nov") ($return 11)) ($seq ($token "Dec") ($return 12)))) 1318;;; datespec ::= daynum dsep monthname dsep year 1319(define $xpath:datespec 1320 ($let ((d $xpath:daynum) 1321 $xpath:desp 1322 (m $xpath:monthname) 1323 $xpath:desp 1324 (y $xpath:year)) 1325 ($return (list y m d)))) 1326;;; tzoffset ::= ("+"|"-") hours ":"? minutes? 1327(define $xpath:tzoffset 1328 ($let ((s ($or ($eqv? #\+) ($eqv? #\-))) 1329 (h $xpath:hours) 1330 (($optional ($eqv? #\:))) 1331 (m ($optional $xpath:minutes))) 1332 (let ((off (+ (* h 60) m))) ;; offset of XML date... 1333 (if (eqv? #\- s) 1334 ($return (- off)) 1335 ($return off))))) 1336;;; tzname ::= "UT" | "UTC" | "GMT" | "EST" | "EDT" 1337;;; | "CST" | "CDT" | "MST" | "MDT" | "PST" | "PDT" 1338(define $xpath:tzname 1339 ($or ($seq ($token "UT") ($return 0)) ($seq ($token "UTC") ($return 0)) 1340 ($seq ($token "GMT") ($return 0)) 1341 ($seq ($token "EST") ($return -300)) ($seq ($token "EDT") ($return -240)) 1342 ($seq ($token "CST") ($return -360)) ($seq ($token "CDT") ($return -300)) 1343 ($seq ($token "MST") ($return -420)) ($seq ($token "MDT") ($return -360)) 1344 ($seq ($token "PST") ($return -480)) ($seq ($token "PDT") ($return -420))) 1345 ) 1346;;; timezone ::= tzname | tzoffset (S? "(" S? tzname S? ")")? 1347(define $xpath:timezone 1348 ($or $xpath:tzname 1349 ($let ((off $xpath:tzoffset) 1350 (($optional ($let ($xpath:S 1351 (($eqv? #\()) 1352 (n $xpath:tzname) 1353 (($eqv? #\)))) 1354 n) #f))) 1355 ($return off)))) 1356;;; time ::= hours ":" minutes (":" seconds)? (S? timezone)? 1357(define $xpath:time 1358 ($let ((h $xpath:hours) 1359 (($eqv? #\:)) 1360 (m $xpath:minutes) 1361 (s ($optional ($seq ($eqv? #\:) $xpath:seconds) 0)) 1362 (t ($optional ($seq ($optional $xpath:S) $xpath:timezone) #f))) 1363 ($return `(,h ,m ,s ,t)))) 1364;;; asctime ::= monthname dsep daynum S time S year 1365(define $xpath:asctime 1366 ($let ((m $xpath:monthname) 1367 $xpath:desp 1368 (d $xpath:daynum) 1369 $xpath:S 1370 (t $xpath:time) 1371 $xpath:S 1372 (y $xpath:year)) 1373 ($return `(,y ,m ,d ,@t)))) 1374;;; input ::= S? (dayname ","? S)? ((datespec S time) | asctime) S? 1375(define $xpath:input 1376 ($let ((($optional $xpath:S)) 1377 (dow ($optional ($let ((d $xpath:dayname) 1378 (($optional ($eqv? #\,))) 1379 $xpath:S) ($return d)) #f)) 1380 (t ($or ($let ((s $xpath:datespec) 1381 $xpath:S 1382 (t $xpath:time)) 1383 ($return `(,@s ,@t))) 1384 $xpath:asctime)) 1385 (($optional $xpath:S))) 1386 ($return t))) 1387 1388(define (xpath-fn:parse-ietf-date value) 1389 (define lseq (generator->lseq (string->generator value))) 1390 (let-values (((s v nl) ($xpath:input lseq))) 1391 (unless (parse-success? s) 1392 (assertion-violation 'xpath-fn:parse-ietf-date "Invalid format" value)) 1393 (apply xs:make-datetime v))) 1394 1395;;;; 10.1.1 fn:resolve-QName 1396(define (xpath-fn:resolve-qname qname element) 1397 (if (null? qname) 1398 '() 1399 ;; no idea what to do here. finding the prefix? 1400 (implementation-restriction-violation 'xpath-fn:resolve-qname "Not yet"))) 1401 1402;;;; 10.1.2 fn:QName 1403(define (xpath-fn:qname uri name) 1404 (when (or (null? uri) (zero? (string-length uri))) 1405 (xqt-error 'FOCA0002 "Namespace URI must not be empty" uri)) 1406 (cond ((string-index name #\:) => 1407 (lambda (index) 1408 (xs:make-qname uri (substring name (+ index 1) (string-length name)) 1409 (substring name 0 index)))) 1410 (else (xs:make-qname uri name)))) 1411 1412;;;; 10.2.1 op:QName-equal 1413(define (xpath-op:qname-equal qn1 qn2) 1414 (and (equal? (xs:qname-namespace-uri qn1) (xs:qname-namespace-uri qn2)) 1415 (equal? (xs:qname-local-part qn1) (xs:qname-local-part qn2)))) 1416 1417;;;; 10.2.2 fn:prefix-from-QName 1418(define (xpath-fn:prefix-from-qname qn) 1419 (cond ((null? qn) '()) 1420 ((xs:qname-prefix qn) => 1421 (lambda (p) 1422 (if (zero? (string-length p)) 1423 '() 1424 p))))) 1425 1426;;;; 10.2.3 fn:local-name-from-QName 1427(define (xpath-fn:local-name-from-qname qn) 1428 (cond ((null? qn) '()) 1429 ((xs:qname-local-part qn)))) 1430 1431;;;; 10.2.4 fn:namespace-uri-from-QName 1432(define (xpath-fn:namespace-uri-from-qname qn) 1433 (cond ((null? qn) '()) 1434 ((xs:qname-namespace-uri qn)))) 1435 1436;;;; 10.2.5 fn:namespace-uri-for-prefix 1437(define (xpath-fn:namespace-uri-for-prefix prefix element) 1438 (define fixed-up (if (null? prefix) "" prefix)) 1439 (define (prefix=? n) 1440 (and (equal? (namespace-prefix n) fixed-up) 1441 (namespace-uri n))) 1442 (let ((namespaces (node-list->list (element:namespace-nodes element)))) 1443 (cond ((exists prefix=? namespaces)) 1444 (else '())))) 1445 1446;;;; 10.2.6 fn:in-scope-prefixes 1447(define (xpath-fn:in-scope-prefixes element*) 1448 (if (null? element*) 1449 '() 1450 (delete-duplicates 1451 (append-map (lambda (e) 1452 (map namespace-prefix 1453 (node-list->list (element:namespace-nodes e)))) 1454 element*)))) 1455 1456;;;; 11.1.1 op:hexBinary-equal 1457(define xpath-op:hex-binary-equal bytevector=?) 1458;;;; 11.1.2 op:hexBinary-less-than 1459(define xpath-op:hex-binary-less-than bytevector<?) 1460;;;; 11.1.3 op:hexBinary-greater-than 1461(define xpath-op:hex-binary-greater-than bytevector>?) 1462 1463;;;; 11.1.4 op:base64Binary-equal 1464(define xpath-op:base64-binary-equal xs:base64-binary=?) 1465;;;; 11.1.5 op:base64Binary-less-than 1466(define xpath-op:base64-binary-less-than xs:base64-binary<?) 1467;;;; 11.1.6 op:base64Binary-greater-than 1468(define xpath-op:base64-binary-greater-than xs:base64-binary>?) 1469 1470;;;; 12.1 op:NOTATION-equal 1471(define (xpath-op:notation-equal arg1 arg2) 1472 (implementation-restriction-violation 'xpath-op:notation-equal 1473 "Not supported yet")) 1474 1475;;;; 13.1 fn:name 1476(define (xpath-fn:name arg) (xpath-fn:string (xpath-fn:node-name arg))) 1477 1478;;;; 13.2 fn:local-name 1479(define (xpath-fn:local-name arg) 1480 (if (null? arg) 1481 "" 1482 (let ((n (xpath-dm:node-name arg))) 1483 (if (null? n) 1484 "" 1485 (xs:qname-local-part n))))) 1486 1487;;;; 13.3 fn:namespace-uri 1488(define (xpath-fn:namespace-uri arg) 1489 (xs:qname-namespace-uri (xpath-dm:node-name arg))) 1490 1491;;;; 13.4 fn:lang 1492(define (xpath-fn:lang testlang node) 1493 (define lang (string-downcase testlang)) 1494 (define (has-testlang n) 1495 (exists (lambda (attr) 1496 (and (string=? (attr-name attr) "xml:lang") 1497 (string-prefix? lang (string-downcase (attr-value attr))))) 1498 (xpath-dm:attributes n))) 1499 (let ((selector (xml:ancestor-or-self has-testlang))) 1500 ;; (ansestor-or-self::*/@xml:lang)[last()] = testlang 1501 (let ((nl (selector node))) 1502 (not (zero? (node-list-length nl)))))) 1503 1504;;;; 13.5 fn:root 1505(define xpath-fn:root 1506 (let ((selector (xml:ancestor-or-self node?))) 1507 (lambda (arg) 1508 ;; (ansestor-or-self::node())[1] 1509 (let ((node-list (selector arg))) 1510 (node-list:item node-list 0))))) 1511 1512;;;; 13.6 fn:path 1513(define (xpath-fn:path node) 1514 (implementation-restriction-violation 'xpath-fn:path "Not supported yet")) 1515 1516;;;; 13.7 fn:has-children 1517(define (xpath-fn:has-children node) 1518 (and (not (null? node)) 1519 ;; = fn:exists($node/child::node()) 1520 (not (zero? (node-list-length (node-child-nodes node)))))) 1521 1522;;;; 13.8 fn:innermost 1523(define (xpath-fn:innermost nodes) 1524 (implementation-restriction-violation 'xpath-fn:innermost "Not supported yet")) 1525 1526;;;; 13.9 fn:outermost 1527(define (xpath-fn:outermost nodes) 1528 (implementation-restriction-violation 'xpath-fn:outermost "Not supported yet")) 1529 1530 1531;;;; 14.1.1 fn:empty 1532(define (xpath-fn:empty arg) 1533 (or (null? arg) (and (vector? arg) (zero? (vector-length arg))))) 1534 1535;;;; 14.1.2 fn:exists 1536(define (xpath-fn:exists arg*) (not (xpath-fn:empty arg*))) 1537 1538;;;; 14.1.3 fn:head 1539(define (xpath-fn:head arg) 1540 (cond ((null? arg) '()) 1541 ((pair? arg) (car arg)) 1542 (else arg))) 1543 1544;;;; 14.1.4 fn:tail 1545(define (xpath-fn:tail arg) 1546 (cond ((null? arg) '()) 1547 ((pair? arg) (cdr arg)) 1548 (else '()))) 1549 1550;;;; 14.1.5 fn:insert-before 1551(define (xpath-fn:insert-before target position inserts) 1552 ;; lazy implementation 1553 (let-values (((f e) (split-at target (max 0 (- position 1))))) 1554 (if (pair? inserts) 1555 `(,@f ,@inserts ,@e) 1556 `(,@f ,inserts ,@e)))) 1557 1558;;;; 14.1.6 fn:remove 1559(define (xpath-fn:remove target position) 1560 (define p (- position 1)) 1561 (if (negative? p) 1562 target 1563 (let loop ((r '()) (t target) (i 0)) 1564 (cond ((null? t) (reverse! r)) 1565 ((= i p) (loop r (cdr t) (+ i 1))) 1566 (else (loop (cons (car t) r) (cdr t) (+ i 1))))))) 1567 1568;;;; 14.1.7 fn:reverse 1569(define (xpath-fn:reverse args) (if (pair? args) (reverse args) args)) 1570 1571;;;; 14.1.8 fn:subsequence 1572(define xpath-fn:subsequence 1573 (case-lambda 1574 ((l start n) 1575 (define offset (- start 1)) 1576 (take (drop l offset) n)) 1577 ((l start) 1578 (define offset (- start 1)) 1579 (drop l offset)))) 1580 1581;;;; 14.1.9 fn:unordered 1582;; this is still permutation of the input list... 1583(define (xpath-fn:unordered args) args) 1584 1585;;;; 14.2.1 fn:distinct-values 1586(define xpath-fn:distinct-values 1587 (case-lambda 1588 ((args) (delete-duplicates args equal?)) 1589 ((args collation) (xpath-fn:distinct-values args)))) 1590 1591;;;; 14.2.2 fn:index-of 1592(define xpath-fn:index-of 1593 (case-lambda 1594 ((seq search) 1595 (if (pair? seq) 1596 (do ((r '() (if (equal? (car seq) search) (cons i r) r)) 1597 (i 1 (+ i 1)) 1598 (seq seq (cdr seq))) 1599 ((null? seq) (reverse! r))) 1600 '())) 1601 ((seq search collation) (xpath-fn:index-of seq search)))) 1602 1603;;;; 14.2.3 fn:deep-equal 1604(define (%xpath-fn:deep-equal a b) 1605 (cond ((and (null? a) (null? b))) 1606 ((and (pair? a) (pair? b)) 1607 (and (= (length a) (length b)) 1608 (for-all %xpath-fn:deep-equal a b))) 1609 ((equal? a b)) ;; atomic can be compared like this ;) 1610 ((and (xs:base64-binary? a) (xs:base64-binary? b)) 1611 (xs:base64-binary=? a b)) 1612 ((and (xs:base-date? a) (xs:base-date? b)) 1613 ;; TODO check type... 1614 (xs:base-date=? a b)) 1615 ((and (xs:duration? a) (xs:duration? b)) 1616 ;; TODO check type 1617 (and (= (xs:duration-seconds a) (xs:duration-seconds b)) 1618 (= (xs:duration-months a) (xs:duration-months b)))) 1619 ((and (vector? a) (vector? b)) 1620 (vector= %xpath-fn:deep-equal a b)) 1621 ((and (hashtable? a) (hashtable? b)) 1622 (and (= (hashtable-size a) (hashtable-size b)) 1623 (for-all (lambda (k) 1624 (%xpath-fn:deep-equal (hashtable-ref a k #f) 1625 (hashtable-ref b k #f))) 1626 (vector->list (hashtable-keys a))))) 1627 ((and (node? a) (node? b)) 1628 (and (eqv? (node-node-type a) (node-node-type b)) 1629 (cond ((document? a) 1630 (string=? (xpath-dm:string-value a) 1631 (xpath-dm:string-value b))) 1632 ((element? a) 1633 (implementation-restriction-violation 'xpath-fn:deep-equal 1634 "not yet")) 1635 ((attr? a) 1636 (implementation-restriction-violation 'xpath-fn:deep-equal 1637 "not yet")) 1638 ((processing-instruction? a) 1639 (and (xpath-op:qname-equal (xpath-dm:node-name a) 1640 (xpath-dm:node-name b)) 1641 (string=? (xpath-dm:string-value a) 1642 (xpath-dm:string-value b)))) 1643 ((namespace? a) 1644 (and (%xpath-fn:deep-equal (xpath-dm:node-name a) 1645 (xpath-dm:node-name b)) 1646 (string=? (xpath-dm:string-value a) 1647 (xpath-dm:string-value b)))) 1648 ((text? a) 1649 (string=? (xpath-dm:string-value a) 1650 (xpath-dm:string-value b))) 1651 (else #f)))) 1652 ((and (xs:qname? a) (xs:qname? b)) 1653 ;; not sure how it suppose to be 1654 (and (xpath-op:qname-equal a b) 1655 (equal? (xs:qname-prefix a) (xs:qname-prefix b)))) 1656 (else #f))) 1657 1658(define xpath-fn:deep-equal 1659 (case-lambda 1660 ((a b) (%xpath-fn:deep-equal a b)) 1661 ;; ignore collation for now 1662 ((a b collation) (%xpath-fn:deep-equal a b)))) 1663 1664;;;; 14.3.1 fn:zero-or-one 1665(define (xpath-fn:zero-or-one arg) 1666 (cond ((null? arg) arg) 1667 ((and (pair? arg) (null? (cdr arg))) arg) 1668 (else (xqt-error 'FORG0003 'xpath-fn:zero-or-one 1669 "More than one or not a sequence" arg)))) 1670 1671;;;; 14.3.2 fn:one-or-more 1672(define (xpath-fn:one-or-more arg) 1673 (if (and (pair? arg) (not (null? arg))) 1674 arg 1675 (xqt-error 'FORG0004 'xpath-fn:one-or-more "Empty or not a sequence" arg))) 1676 1677;;;; 14.3.3 fn:exactly-one 1678(define (xpath-fn:exactly-one arg) 1679 (if (and (pair? arg) (= 1 (length arg))) 1680 arg 1681 (xqt-error 'FORG0005 'xpath-fn:exactly-one 1682 "Not an exacely one element sequence" arg))) 1683 1684;;;; 14.4.1 fn:count 1685(define (xpath-fn:count arg) 1686 (cond ((pair? arg) (length arg)) 1687 ((null? arg) 0) 1688 (else 1))) 1689 1690;;;; 14.4.2 fn:avg 1691(define (xpath-fn:avg arg) 1692 (cond ((null? arg) arg) 1693 ((for-all number? arg) (/ (fold-left + 0.0 arg) (length arg))) 1694 ((for-all xs:year-month-duration? arg) 1695 (let loop ((m 0) (n 0) (arg arg)) 1696 (if (null? arg) 1697 (xs:make-year-month-duration (/ m n)) 1698 (loop (+ m (xs:duration-months (car arg))) (+ n 1) (cdr arg))))) 1699 ((for-all xs:day-time-duration? arg) 1700 (let loop ((s 0.0) (n 0) (arg arg)) 1701 (if (null? arg) 1702 (xs:make-day-time-duration (/ s n)) 1703 (loop (+ s (xs:duration-seconds (car arg))) (+ n 1) (cdr arg))))) 1704 (else (xqt-error 'FORG0006 'xpath-fn:avg "Invalid type" arg)))) 1705 1706;;;; 14.4.3 fn:max 1707(define (xpath-fn:max arg) 1708 (define (compute-max arg <) 1709 (let loop ((v (car arg)) (arg (cdr arg))) 1710 (cond ((null? arg) v) 1711 ((< v (car arg)) (loop (car arg) (cdr arg))) 1712 (else (loop v (cdr arg)))))) 1713 (cond ((null? arg) arg) 1714 ((vector? arg) (xpath-fn:max (vector->list arg))) 1715 ((for-all number? arg) (apply max arg)) 1716 ((for-all xs:year-month-duration? arg) 1717 (compute-max arg xpath-op:year-month-duration-less-than)) 1718 ((for-all xs:day-time-duration? arg) 1719 (compute-max arg xpath-op:day-time-duration-less-than)) 1720 ((for-all string? arg) (compute-max arg string<)) 1721 ;; a bit lazy 1722 ((for-all xs:base-date? arg) (compute-max arg xs:base-date<?)) 1723 ;; TBD 1724 (else 1725 (xqt-error 'FORG0006 'xpath-fn:min "Invalid type" arg)))) 1726 1727;;;; 14.4.4 fn:min 1728(define (xpath-fn:min arg) 1729 (define (compute-min arg <) 1730 (let loop ((v (car arg)) (arg (cdr arg))) 1731 (cond ((null? arg) v) 1732 ((< (car arg) v) (loop (car arg) (cdr arg))) 1733 (else (loop v (cdr arg)))))) 1734 (cond ((null? arg) arg) 1735 ((vector? arg) (xpath-fn:min (vector->list arg))) 1736 ((for-all number? arg) (apply min arg)) 1737 ((for-all xs:year-month-duration? arg) 1738 (compute-min arg xpath-op:year-month-duration-less-than)) 1739 ((for-all xs:day-time-duration? arg) 1740 (compute-min arg xpath-op:day-time-duration-less-than)) 1741 ((for-all string? arg) (compute-min arg string<)) 1742 ;; a bit lazy 1743 ((for-all xs:base-date? arg) (compute-min arg xs:base-date<?)) 1744 ;; TBD 1745 (else 1746 (xqt-error 'FORG0006 'xpath-fn:min "Invalid type" arg)))) 1747 1748;;;; 14.4.5 fn:sum 1749(define xpath-fn:sum 1750 (case-lambda 1751 ((arg) (xpath-fn:sum arg 0)) 1752 ((arg zero) 1753 (cond ((null? arg) zero) 1754 ((for-all number? arg) (fold-left + zero arg)) 1755 ((for-all xs:year-month-duration? arg) 1756 (let loop ((m 0) (arg arg)) 1757 (if (null? arg) 1758 (xs:make-year-month-duration m) 1759 (loop (+ m (xs:duration-months (car arg))) (cdr arg))))) 1760 ((for-all xs:day-time-duration? arg) 1761 (let loop ((s 0.0) (arg arg)) 1762 (if (null? arg) 1763 (xs:make-day-time-duration s) 1764 (loop (+ s (xs:duration-seconds (car arg))) (cdr arg))))) 1765 (else (xqt-error 'FORG0006 'xpath-fn:sum "Invalid type" arg)))))) 1766 1767;;;; 14.5.1 fn:id 1768(define (xpath-fn:id str node) 1769 (unless (node? node) (xpty0004-error 'xpath-fn:id node)) 1770 (implementation-restriction-violation 'xpath-fn:id "Not yet")) 1771 1772;;;; 14.5.2 fn:element-with-id 1773(define (xpath-fn:element-with-id str node) 1774 (unless (node? node) (xpty0004-error 'xpath-fn:element-with-id node)) 1775 (implementation-restriction-violation 'xpath-fn:element-with-id "Not yet")) 1776 1777;;;; 14.5.3 fn:idref 1778(define (xpath-fn:idref str node) 1779 (unless (node? node) (xpty0004-error 'xpath-fn:idref node)) 1780 (implementation-restriction-violation 'xpath-fn:idref "Not yet")) 1781 1782;;;; 14.5.4 fn:generate-id 1783(define (xpath-fn:generate-id node) 1784 (cond ((null? node) "") 1785 ((not (node? node)) (xpty0004-error 'xpath-fn:generate-id node)) 1786 (else 1787 ;; How to generate? Digest or something? 1788 (implementation-restriction-violation 'xpath-fn:generate-id 1789 "Not yet")))) 1790 1791;;;; 14.6.1 fn:doc 1792(define (xpath-fn:doc uri) 1793 ;; TODO check validity of given URI and if it's not value raise FODC0005 1794 (xqt-error 'FODC0003 'xpath-fn:doc "More or less not supported" uri)) 1795 1796;;;; 14.6.2 fn:doc-available 1797(define (xpath-fn:doc-available uri) #f) ;; not really supported 1798 1799;;;; 14.6.3 fn:collection 1800(define (xpath-fn:collection arg) 1801 (xqt-error 'FODC0003 'xpath-fn:collection "More or less not supported" arg)) 1802 1803;;;; 14.6.4 fn:uri-collection 1804(define (xpath-fn:uri-collection arg) 1805 (xqt-error 'FODC0003 'xpath-fn:uri-collection "More or less not supported" 1806 arg)) 1807 1808;;;; 14.6.5 fn:unparsed-text 1809(define default-transcoder 1810 (make-transcoder (utf-8-codec) (eol-style none))) 1811(define xpath-fn:unparsed-text 1812 (case-lambda 1813 ((href) (call-with-input-file href get-string-all 1814 :transcoder default-transcoder)) 1815 ;; TODO should we care the encoding? 1816 ((href encoding) (call-with-input-file href get-string-all 1817 :transcoder default-transcoder)))) 1818 1819;;;; 14.6.6 fn:unparsed-text-lines 1820(define xpath-fn:unparsed-text-lines 1821 (case-lambda 1822 ((href) (file->list read-line href 1823 :transcoder default-transcoder)) 1824 ;; TODO should we care the encoding? 1825 ((href encoding) (file->list read-line href 1826 :transcoder default-transcoder)))) 1827 1828;;;; 14.6.8 fn:environment-variable 1829(define (xpath-fn:environment-variable name) 1830 (get-environment-variable name)) 1831 1832;;;; 14.6.8 fn:environment-variables 1833(define (xpath-fn:environment-variables) 1834 (map car (get-environment-variables))) 1835 1836;;;; 14.7.1 fn:parse-xml 1837(define (xpath-fn:parse-xml arg) 1838 (guard (e (else (xqt-error 'FODC0006 'xpath-fn:parse-xml 1839 (condition-message e) arg))) 1840 (input-port->dom-tree (open-string-input-port arg)))) 1841 1842;;;; 14.7.2 fn:parse-xml-fragment 1843(define (xpath-fn:parse-xml-fragment arg) 1844 (guard (e (else (xqt-error 'FODC0006 'xpath-fn:parse-xml-fragment 1845 (condition-message e) arg))) 1846 (input-port->tolerant-dom-tree (open-string-input-port arg)))) 1847 1848;;;; 14.7.3 fn:serialize 1849(define default-write-options (make-xml-write-options #f #f)) 1850(define (yes-no-converter v) (string=? "yes" (car v))) 1851(define (yes-no-omit-converter v*) 1852 (define v (car v*)) ;; use first value 1853 (cond ((string=? "yes" v)) 1854 ((string=? "omit" v) '()) 1855 (else #f))) 1856(define (single-value v*) (car v*)) 1857(define (single-string->number v*) (string->number (car v*))) 1858(define +options+ 1859 `(("allow-duplicate-names" . ,yes-no-converter) 1860 ("byte-order-mark" . ,yes-no-converter) 1861 ("cdata-section-elements" . ,single-value) 1862 ("doctype-public" . ,single-value) 1863 ("doctype-system" . ,single-value) 1864 ("encoding" . ,single-value) 1865 ("escape-uri-attribute" . ,yes-no-converter) 1866 ("html-version" . ,single-string->number) 1867 ("include-content-type" . ,yes-no-converter) 1868 ("indent" . ,yes-no-converter) 1869 ("item-separator" . ,values) 1870 ("json-node-output-method" . ,single-value) 1871 ("media-type" . ,single-value) 1872 ("normalization-form" . ,single-value) 1873 ("omit-xml-declaration" . ,yes-no-converter) 1874 ("standalone" . ,yes-no-omit-converter) 1875 ("suppress-indentation" . ,values) 1876 ("undeclare-prefixes" . ,yes-no-converter) 1877 ("use-character-maps" . ,values) ;; FIXME 1878 ("version" . ,single-value))) 1879(define (serialization-parameters->options params) 1880 (define get-elements element:get-elements-by-tag-name-ns) 1881 (define serialization-ns "http://www.w3.org/2010/xslt-xquery-serialization") 1882 (define (get-element-value parameters name conv) 1883 (let ((e (get-elements parameters serialization-ns name))) 1884 (if (zero? (node-list-length e)) 1885 '() 1886 (let* ((v* (filter-map (lambda (e) (element:get-attribute e "value")) 1887 (node-list->list e)))) 1888 (if (null? v*) 1889 '() 1890 (list (string->keyword name) (conv v*))))))) 1891 (define (->options element) 1892 (define (collect&make parameter) 1893 (apply make-xml-write-options #f #f 1894 (append-map 1895 (lambda (name&conv) 1896 (get-element-value parameter (car name&conv) (cdr name&conv))) 1897 +options+))) 1898 (define parameters 1899 (get-elements element serialization-ns "serialization-parameters")) 1900 (if (zero? (node-list-length parameters)) 1901 default-write-options 1902 (collect&make (node-list:item parameters 0)))) 1903 (cond ((null? params) default-write-options) 1904 ((element? params) (->options params)) 1905 ;; TODO how should we handle if the document has more than one child... 1906 ((document? params) (->options (document-document-element params))) 1907 (else default-write-options))) 1908(define xpath-fn:serialize 1909 (case-lambda 1910 ((arg) (xpath-fn:serialize arg '())) 1911 ((arg params) 1912 (define options (serialization-parameters->options params)) 1913 (let-values (((out extract) (open-string-output-port))) 1914 ((make-dom-writer options) arg out) 1915 (extract))))) 1916 1917;; we can't implement context related procedure without context :) 1918;;;; 15.1 fn:position 1919(define (xpath-fn:position) 1920 (xqt-error 'XPDY0002 'xpath-fn:position "No context")) 1921;;;; 15.2 fn:last 1922(define (xpath-fn:last) 1923 (xqt-error 'XPDY0002 'xpath-fn:last "No context")) 1924 1925;;;; 15.3 fn:current-dateTime 1926(define (xpath-fn:current-datetime) 1927 (xs:make-datetime (current-calendar-date) #t)) 1928;;;; 15.4 fn:current-date 1929(define (xpath-fn:current-date) (xs:make-date (current-calendar-date) #t)) 1930;;;; 15.5 fn:current-time 1931(define (xpath-fn:current-time) (xs:make-time (current-calendar-date) #t)) 1932;;;; 15.6 fn:implicit-timezone 1933(define (xpath-fn:implicit-timezone) 1934 (let ((offset (timezone-offset (local-timezone)))) 1935 (xs:make-day-time-duration offset))) 1936;;;; 15.7 fn:default-collation 1937(define (xpath-fn:default-collation) 1938 "http://www.w3.org/2005/xpath-functions/collation/codepoint") 1939;;;; 15.8 fn:default-language 1940(define (xpath-fn:default-language) "en") 1941;;;; 15.9 fn:static-base-uri 1942(define (xpath-fn:static-base-uri) '()) 1943 1944 1945;;;; 16.1.1 fn:function-lookup 1946(define (xpath-fn:function-lookup name arity) 1947 (implementation-restriction-violation 'xpath-fn:function-lookup "not yet")) 1948;;;; 16.1.2 fn:function-name 1949(define (xpath-fn:function-name func) 1950 (implementation-restriction-violation 'xpath-fn:function-name "not yet")) 1951;;;; 16.1.3 fn:function-arity 1952(define (xpath-fn:function-arity func) 1953 (implementation-restriction-violation 'xpath-fn:function-arity "not yet")) 1954 1955;;;; 16.2.1 fn:for-each 1956(define (xpath-fn:for-each seq action) 1957 (append-map (lambda (e) (let ((r (action e))) (if (pair? r) r `(,r)))) seq)) 1958;;;; 16.2.2 fn:filter 1959(define (xpath-fn:filter seq pred) (filter pred seq)) 1960;;;; 16.2.3 fn:fold-left 1961(define (xpath-fn:fold-left seq zero f) (fold-left f zero seq)) 1962;;;; 16.2.4 fn:fold-right 1963(define (xpath-fn:fold-right seq zero f) (fold-right f zero seq)) 1964;;;; 16.2.5 fn:for-each-pair 1965(define (xpath-fn:for-each-pair seq1 seq2 f) 1966 (append-map (lambda (e1 e2) (let ((r (f e1 e2))) (if (pair? r) r `(,r)))) 1967 seq1 seq2)) 1968 1969;;;; 16.2.6 fn:sort 1970(define (deep-less-than a b c) 1971 (define (type=? type? a b) (and (type? a) (type? b))) 1972 (cond ((type=? string? a b) (< (xpath-fn:compare a b c) 0)) 1973 ((type=? number? a b) (xpath-op:numeric-less-than a b)) 1974 ((type=? boolean? a b) (xpath-op:boolean-less-than a b)) 1975 ((type=? xs:year-month-duration? a b) 1976 (xpath-op:year-month-duration-less-than a b)) 1977 ((type=? xs:day-time-duration? a b) 1978 (xpath-op:day-time-duration-less-than a b)) 1979 ((type=? xs:datetime? a b) (xpath-op:datetime-less-than a b)) 1980 ((type=? xs:date? a b) (xpath-op:date-less-than a b)) 1981 ((type=? xs:time? a b) (xpath-op:time-less-than a b)) 1982 ((type=? bytevector? a b) (xpath-op:hex-binary-less-than a b)) 1983 ((type=? xs:base64-binary? a b) 1984 (xpath-op:base64-binary-less-than a b)) 1985 ((type=? pair? a b) 1986 (or (deep-less-than (xpath-fn:head a) (xpath-fn:head b) c) 1987 (deep-less-than (xpath-fn:tail a) (xpath-fn:tail b) c))) 1988 ((type=? vector? a b) 1989 (and (not (zero? (vector-length a))) 1990 (not (zero? (vector-length b))) 1991 (or (deep-less-than (xpath-array:head a) (xpath-array:head b) c) 1992 (deep-less-than (xpath-array:tail a) (xpath-array:tail b) c))) 1993 ) 1994 ((eq? a b) #f) ;; lazy... though this would handle symbol, should we? 1995 (else (xpty0004-error 'deep-less-than `(,a ,b))))) 1996(define xpath-fn:sort 1997 (case-lambda 1998 ((v) (xpath-fn:sort v '())) 1999 ((v c) (xpath-fn:sort v c values)) 2000 ((v c key) 2001 (list-sort 2002 (lambda (a b) (deep-less-than (key a) (key b) c)) v)))) 2003 2004;;;; 16.2.7 fn:apply 2005(define (xpath-fn:apply fn arr) 2006 ;; TODO raise FOAP0001, when arity is not the same 2007 (apply fn (vector->list arr))) 2008 2009;;;; 16.3.1 fn:load-xquery-module 2010(define (xpath-fn:load-xquery-module uri . options) 2011 (implementation-restriction-violation 'xpath-fn:load-xquery-module 2012 "Not supported")) 2013;;;; 16.3.2 fn:transform 2014(define (xpath-fn:transform options) 2015 (implementation-restriction-violation 'xpath-fn:transform 2016 "Not supported")) 2017 2018;;;; 17.1.1 op:same-key 2019(define (xpath-op:same-key key1 key2) 2020 (cond ((and (string? key1) (string? key2)) (string=? key1 key2)) 2021 ((and (number? key1) (number? key2)) 2022 (or (and (nan? key1) (nan? key2)) 2023 (= key1 key2))) 2024 ((and (xs:base-date? key1) (xs:base-date? key2)) 2025 (xs:base-date=? key1 key2)) 2026 ((or (and (boolean? key1) (boolean? key2)) 2027 (and (bytevector? key1) (bytevector? key2)) 2028 (and (xs:base64-binary? key1) (xs:base64-binary? key2)) 2029 (and (xs:duration? key1) (xs:duration? key2)) 2030 ;; TODO notation 2031 ) 2032 (xpath-fn:deep-equal key1 key2)) 2033 (else #f))) 2034(define (xpath-op:hash value) 2035 (unless (xs:any-atomic-type? value) 2036 (assertion-violation 'xpath-op:hash "Invalid type" value)) 2037 ;; for now 2038 (equal-hash value)) 2039 2040;;;;; well define it here for convenience... 2041;; k&v* ::= [key value]* 2042;; this one isn't there but we can use as map{} constructor ;) 2043(define (xpath-fn:map . k&v*) 2044 (do ((r (make-hashtable xpath-op:hash xpath-op:same-key)) 2045 (k&v* k&v* (cddr k&v*))) 2046 ((null? k&v*) r) 2047 (let ((k (car k&v*)) 2048 (v (cadr k&v*))) 2049 (hashtable-set! r k v)))) 2050 2051;;;; 17.1.2 map:merge 2052(define default-operation (lambda (a b) a)) 2053(define *operations* 2054 `(("use-first" . ,default-operation) 2055 ("use-last" . ,(lambda (a b) b)) 2056 ("combine" . ,(lambda (a b) 2057 (if (pair? a) 2058 `(,@a ,b) 2059 (list a b)))) 2060 ("reject" . ,(lambda (a b) 2061 (xqt-error 'FOJS0003 2062 'xpath-map:merge "Duplicate key" a b))) 2063 ("use-any" . ,(lambda (a b) a)))) 2064(define default-operation 2065 (alist->hashtable '(("duplicates" . "use-first")))) 2066(define xpath-map:merge 2067 (case-lambda 2068 ((map*) (xpath-map:merge map* default-operation)) 2069 ((map* options) 2070 (define (get-duplicate-handler op) 2071 (cond ((hashtable-ref op "duplicates" #f) => 2072 (lambda (key) 2073 (cond ((assoc key *operations*) => cdr) 2074 (else (xqt-error 'FOJS0005 'xpath-map:merge 2075 "Non supported key" key))))) 2076 (else default-operation))) 2077 (let ((duplicate-handler (get-duplicate-handler options))) 2078 (do ((r (xpath-fn:map)) (map* map* (cdr map*))) 2079 ((null? map*) r) 2080 (hashtable-for-each 2081 (lambda (k v) 2082 (if (hashtable-contains? r k) 2083 (hashtable-set! r k (duplicate-handler (hashtable-ref r k) v)) 2084 (hashtable-set! r k v))) 2085 (car map*))))))) 2086 2087;;;; 17.1.3 map:size 2088(define (xpath-map:size v) (hashtable-size v)) 2089;;;; 17.1.4 map:keys 2090(define (xpath-map:keys v) (hashtable-keys-list v)) 2091;;;; 17.1.5 map:contains 2092(define (xpath-map:contains v k) (hashtable-contains? v k)) 2093;;;; 17.1.6 map:get 2094(define (xpath-map:get v k) (hashtable-ref v k '())) 2095;;;; 17.1.7 map:find 2096(define (xpath-map:find input* k) 2097 (define (find-inner input k acc) 2098 (cond ((hashtable-contains? input k) 2099 (cons (hashtable-ref input k #f) acc)) 2100 (else acc))) 2101 (do ((r '() (find-inner (car input*) k r)) 2102 (input* input* (cdr input*))) 2103 ((null? input*) (list->vector (reverse! r))))) 2104;;;; 17.1.8 map:put 2105(define (xpath-map:put m k v) 2106 (let ((r (xpath-map:merge (list m)))) 2107 (hashtable-set! r k v) 2108 r)) 2109;;;; 17.1.9 map:entry 2110(define (xpath-map:entry k value) (xpath-fn:map k value)) 2111;;;; 17.1.10 map:remove 2112(define (xpath-map:remove m keys) 2113 (let ((r (xpath-map:merge (list m)))) 2114 (cond ((null? keys)) 2115 ((pair? keys) 2116 (for-each (lambda (k) (hashtable-delete! r k)) keys)) 2117 (else (hashtable-delete! r keys))) 2118 r)) 2119;;;; 17.1.11 map:for-each 2120(define (xpath-map:for-each map action) 2121 (let ((r (hashtable-map action map))) 2122 (if (for-all hashtable? r) 2123 (xpath-map:merge r) 2124 r))) 2125 2126;;;; 17.3.1 array:size 2127(define (xpath-array:size array) (vector-length array)) 2128;;;; 17.3.2 array:get 2129(define (array:check-index who array i) 2130 (unless (<= 1 i (vector-length array)) 2131 (xqt-error 'FOAY0001 'who "Index out of bound" i))) 2132(define (xpath-array:get array i) 2133 (array:check-index 'xpath-array:get array i) 2134 (vector-ref array (- i 1))) 2135;;;; 17.3.3 array:put 2136(define (xpath-array:put array i v) 2137 (array:check-index 'xpath-array:put array i) 2138 (let ((r (vector-copy array))) 2139 (vector-set! r (- i 1) v) 2140 r)) 2141;;;; 17.3.4 array:append 2142(define (xpath-array:append array v) 2143 (vector-append array (vector v))) 2144;;;; 17.3.5 array:subarray 2145(define xpath-array:subarray 2146 (case-lambda 2147 ((array start) 2148 (xpath-array:subarray array start 2149 (max 0 (- (vector-length array) (- start 1))))) 2150 ((array start length) 2151 (unless (<= 1 start (+ (vector-length array) 1)) 2152 (xqt-error 'FOAY0001 'xpath-array:subarray 2153 "Start is less than 1 or greater than size+1" start)) 2154 (when (negative? length) 2155 (xqt-error 'FOAY0002 'xpath-array:subarray "Negative length subarray")) 2156 (vector-copy array (- start 1) (+ (- start 1) length))))) 2157;;;; 17.3.6 array:remove 2158(define (xpath-array:remove array pos*) 2159 (cond ((null? pos*) array) 2160 ((integer? pos*) (xpath-array:remove array (list pos*))) 2161 (else 2162 (for-each (lambda (pos) 2163 (array:check-index xpath-array:remove array pos)) pos*) 2164 (let* ((l (length pos*)) 2165 (ol (vector-length array)) 2166 (size (- ol l)) 2167 (r (make-vector size))) 2168 (let loop ((i 0) (j 0)) 2169 (cond ((= j ol) r) 2170 ((memv (+ j 1) pos*) (loop i (+ j 1))) 2171 (else 2172 (vector-set! r i (vector-ref array j)) 2173 (loop (+ i 1) (+ j 1))))))))) 2174;;;; 17.3.7 array:insert-before 2175(define (xpath-array:insert-before array pos v) 2176 (unless (<= 1 pos (+ (vector-length array) 1)) 2177 (xqt-error 'FOAY0001 'who "Position is less than 1 or greater than size+1" 2178 pos)) 2179 (let* ((len (vector-length array)) 2180 (ind (- pos 1))) 2181 (if (= ind len) 2182 (xpath-array:append array v) 2183 (let ((vec (make-vector (+ len 1)))) 2184 (let loop ((i 0) (j 0)) 2185 (cond ((= j len) vec) 2186 ((= i ind) 2187 (vector-set! vec i v) 2188 (loop (+ i 1) j)) 2189 (else 2190 (vector-set! vec i (vector-ref array j)) 2191 (loop (+ i 1) (+ j 1))))))))) 2192;;;; 17.3.8 array:head 2193(define (xpath-array:head array) (xpath-array:get array 1)) 2194;;;; 17.3.9 array:tail 2195(define (xpath-array:tail array) (xpath-array:remove array 1)) 2196;;;; 17.3.10 array:reverse 2197(define (xpath-array:reverse array) (vector-reverse array)) 2198;;;; 17.3.11 array:join 2199(define (xpath-array:join array*) 2200 (if (vector? array*) 2201 array* 2202 (vector-concatenate array*))) 2203;;;; 17.3.12 array:for-each 2204(define (xpath-array:for-each array action) 2205 (vector-map (lambda (i e) (action e)) array)) 2206;;;; 17.3.13 array:filter 2207(define (xpath-array:filter array action) 2208 (vector-filter action array)) 2209;;;; 17.3.14 array:fold-left 2210(define (xpath-array:fold-left array nil action) 2211 (vector-fold (lambda (i a b) (action a b)) nil array)) 2212;;;; 17.3.15 array:fold-right 2213(define (xpath-array:fold-right array nil action) 2214 (vector-fold-right (lambda (i b a) (action a b)) nil array)) 2215;;;; 17.3.16 array:for-each-pair 2216(define (xpath-array:for-each-pair array1 array2 action) 2217 (vector-map (lambda (i e1 e2) (action e1 e2)) array1 array2)) 2218;;;; 17.3.17 array:sort 2219(define xpath-array:sort 2220 (case-lambda 2221 ((v) (xpath-array:sort v '())) 2222 ((v c) (xpath-array:sort v c values)) 2223 ((v c key) 2224 (vector-sort 2225 (lambda (a b) (deep-less-than (key a) (key b) c)) v)))) 2226;;;; 17.3.18 array:flatten 2227(define (flatten l) 2228 (cond ((null? l) '()) 2229 ((not (pair? l)) (list l)) 2230 (else (append (flatten (car l)) (flatten (cdr l)))))) 2231(define (xpath-array:flatten array*) 2232 (define (->list array*) 2233 (if (vector? array*) 2234 (->list (vector->list array*)) 2235 (map (lambda (e) (if (vector? e) (->list (vector->list e)) e)) array*))) 2236 (flatten (->list array*))) 2237 2238;;;; 17.5.1 fn:parse-json 2239(define default-json-operation (make-eq-hashtable)) 2240(define (xml-array-handler v) (list->vector v)) 2241(define (xml-object-handler opt) 2242 (lambda (v) (apply xpath-fn:map (flatten v)))) 2243(define (xml-null-handler) '()) 2244(define (xml-number-handler v) (inexact v)) 2245(define (xml-string-handler opt) 2246 (define escape? (hashtable-ref opt "escape" #f)) 2247 (define fallback (hashtable-ref opt "fallback" (lambda (s) "\xFFFD;"))) 2248 (define (escape-char c) 2249 (define (pad s) 2250 (let-values (((out e) (open-string-output-port))) 2251 (do ((len (- 4 (string-length s))) (i 0 (+ i 1))) 2252 ((= i len) (put-string out s) (e)) 2253 (put-char out #\0)))) 2254 (string-append "\\u" (pad (number->string (char->integer c) 16)))) 2255 (lambda (v) 2256 (let-values (((out e) (open-string-output-port))) 2257 (do ((len (string-length v)) (i 0 (+ i 1))) 2258 ((= len i) (e)) 2259 (let ((c (string-ref v i))) 2260 (cond ((and escape? (char=? c #\\)) (put-string out "\\\\")) 2261 ;; TODO handle control characters... 2262 ((char-set-contains? +xml:char-set+ c) (put-char out c)) 2263 (escape? (put-string out (escape-char c))) 2264 (else (put-string out (fallback (escape-char c)))))))))) 2265 2266(define xpath-fn:parse-json 2267 (case-lambda 2268 ((text) (xpath-fn:parse-json text default-json-operation)) 2269 ((text options) 2270 ;; TODO setup handlers here 2271 (let ((lseq (generator->lseq (string->generator text)))) 2272 (parameterize ((*json:array-handler* xml-array-handler) 2273 (*json:object-handler* (xml-object-handler options)) 2274 (*json:null-handler* xml-null-handler) 2275 (*json:number-handler* xml-number-handler) 2276 (*json:string-handler* (xml-string-handler options))) 2277 (let-values (((s v nl) (json:parser lseq))) 2278 (if (parse-success? s) 2279 v 2280 (xqt-error 'FOJS0001 'xpath-fn:parse-json "Invalid JSON" text)))))))) 2281;;;; 17.5.2 fn:json-doc 2282(define xpath-fn:json-doc 2283 (case-lambda 2284 ((href) (xpath-fn:json-doc href default-json-operation)) 2285 ((href options) 2286 (let ((t (xpath-fn:unparsed-text href))) 2287 (xpath-fn:parse-json t options))))) 2288 2289;;;; 17.5.3 fn:json-to-xml 2290(define +xpath-functions:namespace+ "http://www.w3.org/2005/xpath-functions") 2291(define (json->xml json) 2292 (define doc (make-xml-document #f)) 2293 (define (make-element doc name) 2294 (document:create-element-ns doc +xpath-functions:namespace+ name)) 2295 (define (create-text-node-w/value doc name val) 2296 (let ((e (make-element doc name)) 2297 (t (document:create-text-node doc val))) 2298 (node:append-child! e t) 2299 e)) 2300 (define (null->xml-node json doc) 2301 (document:create-element-ns doc +xpath-functions:namespace+ "null")) 2302 (define (boolean->xml-node json doc) 2303 (create-text-node-w/value doc "boolean" (if json "true" "false"))) 2304 (define (number->xml-node json doc) 2305 (let ((n (if (integer? json) (exact json) json))) 2306 (create-text-node-w/value doc "number" (number->string n)))) 2307 (define (string->xml-node json doc) 2308 (define escaped? (string-contains json "\\u")) ;; a bit naive 2309 (let ((e (create-text-node-w/value doc "string" json))) 2310 (when escaped? 2311 (element:set-attribute! e "escaped" "true")) 2312 e)) 2313 (define (array->xml-node json doc) 2314 (define e (make-element doc "array")) 2315 (do ((len (vector-length json)) (i 0 (+ i 1))) 2316 ((= len i) e) 2317 (node:append-child! e (json->xml-node (vector-ref json i) doc)))) 2318 (define (object->xml-node json doc) 2319 (define e (make-element doc "map")) 2320 (hashtable-for-each 2321 (lambda (k v) 2322 (let ((v (json->xml-node v doc))) 2323 (element:set-attribute! v "key" k) 2324 (node:append-child! e v))) 2325 json) 2326 e) 2327 (define (json->xml-node json doc) 2328 (cond ((hashtable? json) (object->xml-node json doc)) 2329 ((vector? json) (array->xml-node json doc)) 2330 ((string? json) (string->xml-node json doc)) 2331 ((number? json) (number->xml-node json doc)) 2332 ((boolean? json) (boolean->xml-node json doc)) 2333 ((null? json) (null->xml-node json doc)) 2334 (else (assertion-violation 'json->xml "Unknown type" json)))) 2335 (let ((element (json->xml-node json doc))) 2336 (node:append-child! doc element) 2337 doc)) 2338(define xpath-fn:json-to-xml 2339 (case-lambda 2340 ((text) (xpath-fn:json-to-xml text default-json-operation)) 2341 ((text options) 2342 (let ((json (xpath-fn:parse-json text options))) 2343 (json->xml json))))) 2344 2345;;;; 17.5.4 fn:xml-to-json 2346(define (node->json-text node options) 2347 (define indent? (hashtable-ref options "indent" #f)) 2348 (define *indent-level* (make-parameter 0)) 2349 (define (indent out) 2350 (put-char out #\newline) 2351 (do ((i 0 (+ i 1)) (level (* (*indent-level*) 2))) 2352 ((= i level)) 2353 (put-char out #\space))) 2354 (define (get-tag element) 2355 (let ((ns (element-namespace-uri element))) 2356 (unless (equal? ns +xpath-functions:namespace+) 2357 (xqt-error 'FOJS0006 'xpath-fn:xml-to-json "Not a valid node" element)) 2358 (string->symbol (element-local-name element)))) 2359 (define (node-value node) 2360 (define size (node-list-length (node-child-nodes node))) 2361 (unless (= size 1) 2362 (xqt-error 'FOJS0006 'xpath-fn:xml-to-json "Not a valid node" node)) 2363 (let ((v (node-first-child node))) 2364 (unless (text? v) 2365 (xqt-error 'FOJS0006 'xpath-fn:xml-to-json "Not a valid node" node)) 2366 (node-text-content v))) 2367 ;; indentation happens only array or object ;) 2368 (define (boolean->json-text node out) 2369 (define (->xs:boolean s) 2370 (cond ((member s '("true" "1"))) 2371 ((member s '("false" "0")) #f) 2372 (else (xqt-error 'FOJS0006 2373 'xpath-fn:xml-to-json "Invalid boolean value" s)))) 2374 (put-string out (if (->xs:boolean (node-value node)) "true" "false"))) 2375 (define (number->json-text node out) 2376 (define v (node-value node)) 2377 (unless (string->number v) 2378 (xqt-error 'FOJS0006 'xpath-fn:xml-to-json "Invalid number value" v)) 2379 (put-string out v)) 2380 (define (null->json-text node out) (put-string out "null")) 2381 (define (string->json-text node out) 2382 (put-char out #\") 2383 (put-string out (node-value node)) 2384 (put-char out #\")) 2385 (define (array->json-text node out) 2386 (put-char out #\[) 2387 (parameterize ((*indent-level* (+ (*indent-level*) 1))) 2388 (when indent? (indent out)) 2389 (let ((nl (node-child-nodes node))) 2390 (do ((i 0 (+ i 1)) (l (node-list-length nl))) 2391 ((= i l)) 2392 (->json-text (node-list:item nl i) out) 2393 (unless (= i (- l 1)) 2394 (put-char out #\,) 2395 (when indent? (indent out)))))) 2396 (when indent? (indent out)) 2397 (put-char out #\])) 2398 (define (object->json-text node out) 2399 (put-char out #\{) 2400 (parameterize ((*indent-level* (+ (*indent-level*) 1))) 2401 (when indent? (indent out)) 2402 (let ((nl (node-child-nodes node))) 2403 (do ((i 0 (+ i 1)) (l (node-list-length nl))) 2404 ((= i l)) 2405 (let* ((n (node-list:item nl i)) 2406 (key (element:get-attribute n "key"))) 2407 (put-char out #\") 2408 (put-string out key) 2409 (put-string out "\":") 2410 (when indent? (put-char out #\space)) 2411 (->json-text n out) 2412 (unless (= i (- l 1)) 2413 (put-char out #\,) 2414 (when indent? (indent out))))))) 2415 (when indent? (indent out)) 2416 (put-char out #\})) 2417 (define (->json-text node out) 2418 (case (get-tag node) 2419 ((boolean) (boolean->json-text node out)) 2420 ((number) (number->json-text node out)) 2421 ((null) (null->json-text node out)) 2422 ((string) (string->json-text node out)) 2423 ((array) (array->json-text node out)) 2424 ((map) (object->json-text node out)) 2425 (else (xqt-error 'FOJS0006 'xpath-fn:xml-to-json "Not a valid node" 2426 node)))) 2427 (let-values (((out e) (open-string-output-port))) 2428 (->json-text node out) 2429 (e))) 2430(define xpath-fn:xml-to-json 2431 (case-lambda 2432 ((node) (xpath-fn:xml-to-json node default-json-operation)) 2433 ((node options) 2434 (cond ((document? node) 2435 (node->json-text (document-document-element node) options)) 2436 ((element? node) (node->json-text node options)) 2437 (else (xqt-error 'FOJS0006 'xpath-fn:xml-to-json "Not a valid node" 2438 node)))))) 2439 2440;;; 19 Casting 2441(define (atomic->string who atomic) 2442 (cond ((string? atomic) atomic) 2443 ((null? atomic) "") 2444 ((or (integer? atomic) (flonum? atomic)) (number->string atomic)) 2445 ;; this may loose the original information when the value is 2446 ;; either 0 or 1... 2447 ((boolean? atomic) (if atomic "true" "false")) 2448 (else (xpty0004-error who atomic)))) 2449 2450(define (implementation-restriction-violation who msg) 2451 (raise (condition (make-implementation-restriction-violation) 2452 (make-who-condition who) 2453 (make-message-condition msg)))) 2454 2455) 2456