source: project/uri-namespaces/trunk/uri-namespaces.scm @ 4643

Last change on this file since 4643 was 4643, checked in by arto, 13 years ago

Imported the uri-namespaces egg (provides facilities for prefixed symbol <-> absolute URI reference conversion).

File size: 5.5 KB
Line 
1;;;; Facilities for prefixed symbol <-> absolute URI reference conversion.
2;;
3;; Copyright (c) 2006-2007 Arto Bendiken <http://bendiken.net/>
4;;
5;; Permission is hereby granted, free of charge, to any person obtaining a copy
6;; of this software and associated documentation files (the "Software"), to
7;; deal in the Software without restriction, including without limitation the
8;; rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
9;; sell copies of the Software, and to permit persons to whom the Software is
10;; furnished to do so, subject to the following conditions:
11;;
12;; The above copyright notice and this permission notice shall be included in
13;; all copies or substantial portions of the Software.
14;;
15;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
16;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
17;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
18;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
19;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
20;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
21;; IN THE SOFTWARE.
22
23(require-extension srfi-1 srfi-13 uri)
24
25(eval-when (compile)
26  (declare
27    (import uri)
28    (export current-uri-namespaces
29            default-uri-namespace
30            register-well-known-uri-namespaces!
31            register-uri-namespaces!
32            register-uri-namespace!
33            unregister-uri-namespace!
34            symbol->uri
35            uri->symbol ) ) )
36
37;;;; Exported parameters
38
39(define current-uri-namespaces
40  (make-parameter '()) )
41
42(define default-uri-namespace
43  (make-parameter (uri "urn:local:")) ) ; This is rather arbitrary.
44
45;;;; Exported procedures
46
47(define (register-well-known-uri-namespaces!)
48  (register-uri-namespaces!
49    xml:   (uri "http://www.w3.org/XML/1998/namespace")
50    xmlns: (uri "http://www.w3.org/2000/xmlns/")
51    xhtml: (uri "http://www.w3.org/1999/xhtml")
52    xlink: (uri "http://www.w3.org/1999/xlink")
53    xsl:   (uri "http://www.w3.org/1999/XSL/Transform")
54    xsd:   (uri "http://www.w3.org/2001/XMLSchema")
55    xsi:   (uri "http://www.w3.org/2001/XMLSchema-instance")
56    svg:   (uri "http://www.w3.org/2000/svg")
57    rdf:   (uri "http://www.w3.org/1999/02/22-rdf-syntax-ns#")
58    rdfs:  (uri "http://www.w3.org/2000/01/rdf-schema#")
59    owl:   (uri "http://www.w3.org/2002/07/owl#")
60    skos:  (uri "http://www.w3.org/2004/02/skos/core#")
61    dc:    (uri "http://purl.org/dc/elements/1.1/")
62    rss:   (uri "http://purl.org/rss/1.0/")
63    foaf:  (uri "http://xmlns.com/foaf/0.1/")
64    ex:    (uri "http://www.example.org/") ) )
65
66(define (register-uri-namespaces! . args)
67  (let loop ((bindings (chop args 2)))
68    (unless (null? bindings)
69      (let* ((binding (car bindings))
70             (prefix  (keyword->symbol (car binding)))
71             (uri     (cadr binding)) )
72        (register-uri-namespace! prefix uri)
73        (loop (cdr bindings)) ) ) ) )
74
75(define (register-uri-namespace! symbol uri)
76  (let ((binding (find-binding-by-prefix symbol)))
77    (if binding
78        (set-cdr! binding uri)
79        (current-uri-namespaces (cons (cons symbol uri)
80                                      (current-uri-namespaces))) ) ) )
81
82(define (unregister-uri-namespace! symbol)
83  (current-uri-namespaces (remove (lambda (binding)
84                            (eq? (car binding) symbol) )
85                          (current-uri-namespaces) ) ) )
86
87(define (symbol->uri symbol #!optional (default unregistered-prefix-error))
88  (let ((parts (string-split (symbol->string symbol) ":")))
89    (cond
90      ((= (length parts) 1) ; unqualified name
91        (expanded-name (default-uri-namespace) (car parts)) )
92      ((= (length parts) 2) ; qualified name
93        (let ((base-uri (find-uri-by-prefix (string->symbol (car parts)))))
94          (if base-uri
95              (expanded-name base-uri (cadr parts))
96              (if (procedure? default) (default symbol) default) ) ) )
97      (else                 ; something else
98        (error 'symbol->uri "not an unqualified or qualified name" symbol) ) ) ) )
99
100(define (uri->symbol uri #!optional (default unregistered-uri-error))
101  (let ((binding (find-prefix-by-uri uri)))
102    (if binding
103        (let* ((base-uri-length (string-length (uri->string (cdr binding))))
104               (uri-string      (string-copy (uri->string uri) base-uri-length))
105               (prefix-string   (symbol->string (car binding))) )
106          (string->symbol (string-append prefix-string ":" uri-string)) )
107        ;; TODO: handle default-uri-namespace.
108        (if (procedure? default) (default uri) default) ) ) )
109
110;;;; Internal helper procedures
111
112(define (unregistered-prefix-error prefix)
113  (error 'symbol->uri "no URI namespace registered for the prefix" prefix) )
114
115(define (unregistered-uri-error uri)
116  (error 'uri->symbol "no URI namespace registered for the URI" uri) )
117
118(define (expanded-name base-uri local-part)
119  (uri (string-append (uri->string base-uri) local-part)) )
120
121(define (find-prefix-by-uri uri)
122  ;; TODO: this should be a longest substring match instead of first substring.
123  (let* ((uri-string (uri->string uri)))
124    (find (lambda (binding)
125            (string-prefix? (uri->string (cdr binding)) uri-string) )
126          (current-uri-namespaces) ) ) )
127
128(define (find-uri-by-prefix prefix)
129  (let ((binding (find-binding-by-prefix prefix)))
130    (if binding (cdr binding) #f) ) )
131
132(define (find-binding-by-prefix prefix)
133  (assq prefix (current-uri-namespaces)) )
134
135(define (keyword->symbol keyword)
136  (string->symbol (keyword->string keyword)) )
Note: See TracBrowser for help on using the repository browser.