From: Chris Hanson Date: Thu, 2 Aug 2007 04:40:41 +0000 (+0000) Subject: Implement RDF graph type. Hash cons all structures, including triples X-Git-Tag: 20090517-FFI~480 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=1dc037c9ca720b9fab1be3bcb5ecaf4c5d834aa2;p=mit-scheme.git Implement RDF graph type. Hash cons all structures, including triples and literals. Add event distributor EVENT:NEW-RDF-TRIPLE that is called whenever a new triple is allocated; this is a hook for indexing. --- diff --git a/v7/src/xml/rdf-struct.scm b/v7/src/xml/rdf-struct.scm index a89d9b4a3..aac68d5e4 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.29 2007/08/01 00:15:42 cph Exp $ +$Id: rdf-struct.scm,v 1.30 2007/08/02 04:40:16 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -27,24 +27,50 @@ USA. ;;;; RDF data structures +;;; Interning mechanisms used here hold onto the interned objects +;;; strongly. They should be changed to hold them weakly. + (declare (usual-integrations)) +;;;; Triples + (define-record-type - (%make-rdf-triple subject predicate object) + (%make-rdf-triple subject predicate object index) rdf-triple? (subject rdf-triple-subject) (predicate rdf-triple-predicate) - (object rdf-triple-object)) + (object rdf-triple-object) + (index rdf-triple-index)) (define-guarantee rdf-triple "RDF triple") (define (make-rdf-triple subject predicate object) - (%make-rdf-triple (canonicalize-rdf-subject subject 'MAKE-RDF-TRIPLE) - (canonicalize-rdf-predicate predicate 'MAKE-RDF-TRIPLE) - (canonicalize-rdf-object object 'MAKE-RDF-TRIPLE))) + (let ((subject (canonicalize-rdf-subject subject 'MAKE-RDF-TRIPLE)) + (predicate (canonicalize-rdf-predicate predicate 'MAKE-RDF-TRIPLE)) + (object (canonicalize-rdf-object object 'MAKE-RDF-TRIPLE))) + (hash-table/intern! rdf-triples (vector subject predicate object) + (lambda () + (let ((triple + (%make-rdf-triple subject predicate object (next-index)))) + (event-distributor/invoke! event:new-rdf-triple triple) + triple))))) + +(define (for-each-rdf-triple procedure) + (for-each procedure + (hash-table/datum-list rdf-triples))) + +(define next-index + (let ((counter 0)) + (lambda () + (let ((index counter)) + (set! counter (+ counter 1)) + index)))) + +(define rdf-triples (make-equal-hash-table)) +(define event:new-rdf-triple (make-event-distributor)) (define (canonicalize-rdf-subject subject #!optional caller) - (cond ((rdf-bnode? subject) subject) + (cond ((or (rdf-bnode? subject) (rdf-graph? subject)) subject) ((%decode-bnode-uri subject)) (else (canonicalize-rdf-uri subject caller)))) @@ -61,6 +87,43 @@ USA. (rdf-qname->uri uri) (->absolute-uri uri caller))) +;;;; Graphs + +(define-record-type + (%make-rdf-graph triples) + rdf-graph? + (triples rdf-graph-triples)) + +(define-guarantee rdf-graph "RDF graph") + +(define (make-rdf-graph triples) + (guarantee-list-of-type triples rdf-triple? "list of RDF triples" + 'MAKE-RDF-GRAPH) + (let ((triples + (if (pair? triples) + (let ((head + (cons 'DUMMY + (sort triples + (lambda (t1 t2) + (< (rdf-triple-index t1) + (rdf-triple-index t2))))))) + (let loop ((this (cdr head)) (prev head)) + (let ((next (cdr this))) + (if (pair? next) + (if (eq? (car this) (car next)) + (begin + (set-cdr! prev next) + (loop next prev)) + (loop next this))))) + (cdr head)) + '()))) + (hash-table/intern! rdf-graphs triples + (lambda () + (%make-rdf-graph triples))))) + +(define rdf-graphs + (make-equal-hash-table)) + ;;;; Blank nodes (define-record-type @@ -121,20 +184,42 @@ USA. (define-guarantee rdf-literal "RDF literal") +(define (make-rdf-literal text type) + (guarantee-utf8-string text 'MAKE-RDF-LITERAL) + (let ((type + (if (or (not type) + (language? type)) + type + (->absolute-uri type 'MAKE-RDF-LITERAL)))) + (hash-table/intern! rdf-literals (cons text type) + (lambda () + (%make-rdf-literal text type))))) + +(define rdf-literals + (make-equal-hash-table)) + +(define (rdf-literal-type literal) + (let ((type (%rdf-literal-type literal))) + (and (absolute-uri? type) + type))) + +(define (rdf-literal-language literal) + (let ((type (%rdf-literal-type literal))) + (and (not (absolute-uri? type)) + type))) + (set-record-type-unparser-method! (standard-unparser-method 'RDF-LITERAL (lambda (literal port) (write-char #\space port) (write-rdf/nt-literal literal port)))) -(define (make-rdf-literal text type) - (guarantee-utf8-string text 'RDF-LITERAL) - (%make-rdf-literal text - (if (or (not type) - (and (interned-symbol? type) - (*match-symbol match-language type))) - type - (->absolute-uri type 'RDF-LITERAL)))) +(define (rdf-literal=? l1 l2) + (eq? l1 l2)) + +(define (language? object) + (and (interned-symbol? object) + (*match-symbol match-language object))) (define match-language (let* ((language-head (ascii-range->char-set #x61 #x7B)) @@ -144,20 +229,6 @@ USA. (*matcher (seq (+ (char-set language-head)) (* (seq #\- (+ (char-set language-tail)))))))) - -(define (rdf-literal-type literal) - (let ((type (%rdf-literal-type literal))) - (and (absolute-uri? type) - type))) - -(define (rdf-literal-language literal) - (let ((type (%rdf-literal-type literal))) - (and (not (absolute-uri? type)) - type))) - -(define (rdf-literal=? l1 l2) - (and (string=? (rdf-literal-text l1) (rdf-literal-text l2)) - (eq? (%rdf-literal-type l1) (%rdf-literal-type l2)))) ;;;; Qnames diff --git a/v7/src/xml/xml.pkg b/v7/src/xml/xml.pkg index 1503d267e..f34d6bcfd 100644 --- a/v7/src/xml/xml.pkg +++ b/v7/src/xml/xml.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: xml.pkg,v 1.95 2007/08/01 00:15:44 cph Exp $ +$Id: xml.pkg,v 1.96 2007/08/02 04:40:41 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -536,6 +536,7 @@ USA. (export () *default-rdf-prefix-registry* + @@ -545,18 +546,23 @@ USA. canonicalize-rdf-uri copy-rdf-prefix-registry error:not-rdf-bnode + error:not-rdf-graph error:not-rdf-literal error:not-rdf-prefix error:not-rdf-prefix-registry error:not-rdf-qname error:not-rdf-triple + event:new-rdf-triple + for-each-rdf-triple guarantee-rdf-bnode + guarantee-rdf-graph guarantee-rdf-literal guarantee-rdf-prefix guarantee-rdf-prefix-registry guarantee-rdf-qname guarantee-rdf-triple make-rdf-bnode + make-rdf-graph make-rdf-literal make-rdf-qname make-rdf-triple @@ -566,10 +572,11 @@ USA. port/set-rdf-prefix-registry rdf-bnode-name rdf-bnode? + rdf-graph-triples + rdf-graph? rdf-literal-language rdf-literal-text rdf-literal-type - rdf-literal=? rdf-literal? rdf-prefix-expansion rdf-prefix-registry->alist @@ -615,10 +622,7 @@ USA. write-rdf/turtle write-rdf/turtle-file write-rdf/turtle-literal - write-rdf/turtle-predicate write-rdf/turtle-prefix - write-rdf/turtle-prefixes - write-rdf/turtle-subject write-rdf/turtle-triples write-rdf/turtle-uri) (export (runtime rdf)