From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 23 Jun 2006 18:49:30 +0000 (+0000)
Subject: Add support for RDF qnames.
X-Git-Tag: 20090517-FFI~992
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=16035b9d803bba6efe1fc9665d7f244ba4def6ed;p=mit-scheme.git

Add support for RDF qnames.
---

diff --git a/v7/src/xml/rdf-struct.scm b/v7/src/xml/rdf-struct.scm
index 0bbb0d38c..d767884e4 100644
--- 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)))))
+
+;;;; 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 ec3b47acb..458510503 100644
--- 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