From: Chris Hanson Date: Thu, 19 Oct 2006 19:19:20 +0000 (+0000) Subject: Implement support for writing collection syntax. X-Git-Tag: 20090517-FFI~889 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=03971129f6d788ca7f9f6c88b35e6f7366ad8b90;p=mit-scheme.git Implement support for writing collection syntax. --- diff --git a/v7/src/xml/turtle.scm b/v7/src/xml/turtle.scm index 5ae586f80..e991188d8 100644 --- a/v7/src/xml/turtle.scm +++ b/v7/src/xml/turtle.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: turtle.scm,v 1.9 2006/10/19 17:48:24 cph Exp $ +$Id: turtle.scm,v 1.10 2006/10/19 19:19:20 cph Exp $ Copyright 2006 Massachusetts Institute of Technology @@ -85,12 +85,8 @@ USA. (*parser (encapsulate vector->list (seq parse:predicate-object-list-1 - (* (seq parse:ws* - ";" - parse:ws* - parse:predicate-object-list-1)) - (? (seq parse:ws* - ";")))))) + (* (seq parse:ws* ";" parse:ws* parse:predicate-object-list-1)) + (? (seq parse:ws* ";")))))) (define parse:predicate-object-list-1 (*parser @@ -104,10 +100,7 @@ USA. (error #f "Expected whitespace")) (encapsulate vector->list (seq parse:object-required - (* (seq parse:ws* - "," - parse:ws* - parse:object-required)))))))) + (* (seq parse:ws* "," parse:ws* parse:object-required)))))))) (define parse:subject (*parser (alt parse:resource parse:blank))) @@ -148,8 +141,10 @@ USA. parse:ws* (alt ")" (seq parse:object-required - (* (seq parse:ws+ parse:object)) parse:ws* + (* (seq "," + parse:ws* + parse:object-required)) (alt ")" (error #f "Expected close parenthesis")))))))))) @@ -549,7 +544,8 @@ USA. (post-process-collection (cdr resources) prefixes base-uri) (let ((p (make-rdf-bnode))) (values p - (cons* (make-rdf-triple p rdf:first first) + (cons* (make-rdf-triple p rdf:type rdf:List) + (make-rdf-triple p rdf:first first) (make-rdf-triple p rdf:rest rest) (append! triples triples*)))))) (values rdf:nil '()))) @@ -610,49 +606,55 @@ USA. (write-rdf/nt-uri uri port)))) (define (write-properties triples bnodes indentation port) - (let ((triples (sort triples triplestring p1) (uri->string p2)))))) - (define (write-property t bnodes indentation port) (let ((p (rdf-triple-predicate t))) (if (eq? p rdf:type) (write-string "a" port) (write-rdf/turtle-uri p port))) (write-string " " port) - (let ((o (rdf-triple-object t))) - (cond ((uri? o) (write-rdf/turtle-uri o port)) - ((rdf-literal? o) (write-literal o port)) - ((rdf-bnode? o) (write-bnode o bnodes indentation port)) - (else (error "Unknown RDF object:" o)))) + (write-object (rdf-triple-object t) bnodes indentation port) (newline port)) + +(define (write-object o bnodes indentation port) + (cond ((uri? o) + (if (eq? o rdf:nil) + (write-string "()" port) + (write-rdf/turtle-uri o port))) + ((rdf-literal? o) + (write-literal o port)) + ((rdf-bnode? o) + (write-bnode o bnodes indentation port)) + (else + (error "Unknown RDF object:" o)))) (define (write-bnode bnode bnodes indentation port) - (let ((ts - (find-matching-item bnodes - (lambda (ts) - (eq? (rdf-triple-subject (car ts)) bnode))))) - (if ts - (begin - (write-string "[" port) - (newline port) - (write-indentation (+ indentation 1) port) - (write-properties ts bnodes (+ indentation 1) port) - (write-indentation indentation port) - (write-string "]" port)) - (write-rdf/nt-bnode bnode port)))) + (cond ((rdf-list->list bnode bnodes) + => (lambda (items) + (write-string "(" port) + (write-object (car items) bnodes indentation port) + (for-each (lambda (item) + (write-string ", " port) + (write-object item bnodes indentation port)) + (cdr items)) + (write-string ")" port))) + ((find-in-bnodes bnode bnodes) + => (lambda (ts) + (write-string "[" port) + (newline port) + (let ((indentation (+ indentation 1))) + (write-indentation indentation port) + (write-properties ts bnodes indentation port)) + (write-indentation indentation port) + (write-string "]" port))) + (else + (write-rdf/nt-bnode bnode port)))) (define (write-literal literal port) (let ((text (rdf-literal-text literal))) @@ -697,9 +699,33 @@ USA. (lambda (triples) (cons triple triples)) (lambda () '()))) triples) - (split-list (hash-table/datum-list table) + (split-list (sort (map (lambda (ts) (sort ts triplestring a) (uri->string b))) + (define (split-bnodes-by-nrefs bnodes triples) (split-list bnodes (lambda (ts) @@ -710,6 +736,34 @@ USA. (eq? (rdf-triple-object triple) bnode))))) 1)))) +(define (rdf-list->list node bnodes) + (let loop ((node node)) + (if (eq? node rdf:nil) + '() + (let ((ts (find-in-bnodes node bnodes))) + (and ts + (let ((p (bnode->pair ts))) + (and p + (let ((rest (loop (cdr p)))) + (and rest + (cons (car p) rest)))))))))) + +(define (bnode->pair ts) + (and (eq? (rdf-triple-predicate (car ts)) rdf:type) + (eq? (rdf-triple-object (car ts)) rdf:List) + (pair? (cdr ts)) + (eq? (rdf-triple-predicate (cadr ts)) rdf:first) + (pair? (cddr ts)) + (eq? (rdf-triple-predicate (caddr ts)) rdf:rest) + (null? (cdddr ts)) + (cons (rdf-triple-object (cadr ts)) + (rdf-triple-object (caddr ts))))) + +(define (find-in-bnodes bnode bnodes) + (find-matching-item bnodes + (lambda (ts) + (eq? (rdf-triple-subject (car ts)) bnode)))) + (define (split-list items predicate) (let loop ((items items) (true '()) (false '())) (if (pair? items) @@ -729,8 +783,8 @@ USA. (define rdf:type (string->uri "http://www.w3.org/1999/02/22-rdf-syntax-ns#type")) -(define rdf:nil - (string->uri "http://www.w3.org/1999/02/22-rdf-syntax-ns#nil")) +(define rdf:List + (string->uri "http://www.w3.org/1999/02/22-rdf-syntax-ns#List")) (define rdf:first (string->uri "http://www.w3.org/1999/02/22-rdf-syntax-ns#first")) @@ -738,6 +792,9 @@ USA. (define rdf:rest (string->uri "http://www.w3.org/1999/02/22-rdf-syntax-ns#rest")) +(define rdf:nil + (string->uri "http://www.w3.org/1999/02/22-rdf-syntax-ns#nil")) + (define xsd:integer (string->uri "http://www.w3.org/2001/XMLSchema#integer"))