Add support for RDF qnames.

diff --git a/v7/src/xml/rdf-struct.scm b/v7/src/xml/rdf-struct.scm
index 0bbb0d38ca3ff9600cc424c811d5057e4dc77e7e..d767884e4b0e6c2f1b7a792494e507214382dd96 100644 (file)
--- a/v7/src/xml/rdf-struct.scm
+++ b/v7/src/xml/rdf-struct.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: rdf-struct.scm,v 1.9 2006/06/22 19:17:27 cph Exp $
+$Id: rdf-struct.scm,v 1.10 2006/06/23 18:49:28 cph Exp $
 
 Copyright 2006 Massachusetts Institute of Technology
 
@@ -134,20 +134,30 @@ USA.
       (if (not (rdf-literal? o))
          (add o (rdf-index-objects index))))))
 
+(define (canonicalize-rdf-uri uri #!optional caller)
+  (or (rdf-qname->uri uri #f)
+      (->absolute-uri uri caller)))
+
+(define (write-rdf-uri uri port)
+  (let ((qname (uri->rdf-qname uri)))
+    (if qname
+       (write-string (symbol-name qname) port)
+       (write-rdf-uri-ref uri port))))
+
 (define (canonicalize-rdf-subject subject #!optional caller)
   (if (rdf-bnode? subject)
       subject
-      (->absolute-uri subject caller)))
+      (canonicalize-rdf-uri subject caller)))
 
 (define (canonicalize-rdf-predicate predicate #!optional caller)
-  (->absolute-uri predicate caller))
+  (canonicalize-rdf-uri predicate caller))
 
 (define (canonicalize-rdf-object object #!optional caller)
   (cond ((or (rdf-bnode? object)
             (rdf-literal? object))
         object)
        ((string? object) (make-rdf-literal object #f))
-       (else (->absolute-uri object caller))))
+       (else (canonicalize-rdf-uri object caller))))
 
 (define match-bnode-name
   (let* ((name-head
@@ -172,4 +182,83 @@ USA.
 (define (complete-match matcher string)
   (let ((buffer (string->parser-buffer string)))
     (and (matcher buffer)
-        (not (peek-parser-buffer-char buffer)))))
\ No newline at end of file
+        (not (peek-parser-buffer-char buffer)))))
+\f
+;;;; Qnames
+
+(define (register-rdf-qname-prefix name expansion)
+  (guarantee-interned-symbol name 'REGISTER-RDF-QNAME-PREFIX)
+  (if (not (complete-match match-prefix (symbol-name name)))
+      (error:bad-range-argument name 'REGISTER-RDF-QNAME-PREFIX))
+  (let ((p (assq name registered-prefixes))
+       (new
+        (uri->string (->absolute-uri expansion 'REGISTER-RDF-QNAME-PREFIX))))
+    (if p
+       (if (not (string=? (cdr p) new))
+           (begin
+             (warn "RDF prefix override:" name (cdr p) new)
+             (set-cdr! p new)))
+       (set! registered-prefixes
+             (cons (cons name new) registered-prefixes))))
+  name)
+
+(define (uri->rdf-qname uri)
+  (let ((s (uri->string (->absolute-uri uri 'URI->RDF-QNAME))))
+    (let ((p
+          (find-matching-item registered-prefixes
+            (lambda (p)
+              (string-prefix? (cdr p) s)))))
+      (and p
+          (symbol (car p)
+                  (string-tail s (string-length (cdr p))))))))
+
+(define (rdf-qname->uri qname #!optional error?)
+  (let ((maybe-lose
+        (lambda ()
+          (if error? (error:not-rdf-qname qname 'RDF-QNAME->URI))
+          #f)))
+    (if (and (interned-symbol? qname)
+            (complete-match match-qname (symbol-name qname)))
+       (receive (prefix local) (split-qname qname)
+         (let ((p (assq prefix registered-prefixes)))
+           (if p
+               (->absolute-uri (string-append (cdr p) local))
+               (maybe-lose))))
+       (maybe-lose))))
+
+(define (rdf-qname? object)
+  (if (rdf-qname->uri object #f) #t #f))
+
+(define-guarantee rdf-qname "RDF qname")
+
+(define (split-qname qname)
+  (let ((s (symbol-name qname)))
+    (let ((i (fix:+ (string-find-next-char s #\:) 1)))
+      (values (symbol (string-head s i))
+             (string-tail s i)))))
+
+(define match-qname
+  (*matcher (seq match:prefix-name ":" match:name)))
+
+(define match-prefix
+  (*matcher (seq match:prefix-name ":")))
+
+(define (reset-rdf-qname-prefixes)
+  (set! registered-prefixes (default-rdf-prefixes))
+  unspecific)
+
+(define (registered-rdf-prefixes)
+  (alist-copy registered-prefixes))
+
+(define (default-rdf-prefixes)
+  (alist-copy default-prefixes))
+
+(define registered-prefixes)
+
+(define default-prefixes
+  '((rdf: . "http://www.w3.org/1999/02/22-rdf-syntax-ns#")
+    (rdfs: . "http://www.w3.org/2000/01/rdf-schema#")
+    (owl: . "http://www.w3.org/2002/07/owl#")
+    (xsd: . "http://www.w3.org/2001/XMLSchema#")))
+
+(reset-rdf-qname-prefixes)
\ No newline at end of file

diff --git a/v7/src/xml/xml.pkg b/v7/src/xml/xml.pkg
index ec3b47acba3fc80c468b2fc7825ccc6d38c99cca..4585105030740932501a8f81e4ff80c7319bf5d9 100644 (file)
--- a/v7/src/xml/xml.pkg
+++ b/v7/src/xml/xml.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: xml.pkg,v 1.72 2006/06/23 17:20:30 cph Exp $
+$Id: xml.pkg,v 1.73 2006/06/23 18:49:30 cph Exp $
 
 Copyright 2001,2002,2003,2004,2005,2006 Massachusetts Institute of Technology
 
@@ -533,13 +533,16 @@ USA.
          canonicalize-rdf-object
          canonicalize-rdf-predicate
          canonicalize-rdf-subject
+         default-rdf-prefixes
          error:not-rdf-bnode
          error:not-rdf-index
          error:not-rdf-literal
+         error:not-rdf-qname
          error:not-rdf-triple
          guarantee-rdf-bnode
          guarantee-rdf-index
          guarantee-rdf-literal
+         guarantee-rdf-qname
          guarantee-rdf-triple
          make-rdf-bnode
          make-rdf-index
@@ -556,10 +559,16 @@ USA.
          rdf-literal-type
          rdf-literal=?
          rdf-literal?
+         rdf-qname->uri
+         rdf-qname?
          rdf-triple-object
          rdf-triple-predicate
          rdf-triple-subject
-         rdf-triple?)
+         rdf-triple?
+         register-rdf-qname-prefix
+         registered-rdf-prefixes
+         uri->rdf-qname
+         write-rdf-uri)
   (export (runtime rdf)
          %make-rdf-literal
          match-bnode-name