From 16035b9d803bba6efe1fc9665d7f244ba4def6ed Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Fri, 23 Jun 2006 18:49:30 +0000 Subject: [PATCH] Add support for RDF qnames. --- v7/src/xml/rdf-struct.scm | 99 +++++++++++++++++++++++++++++++++++++-- v7/src/xml/xml.pkg | 13 ++++- 2 files changed, 105 insertions(+), 7 deletions(-) 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 -- 2.25.1