aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--dump/documentation.scm36
-rw-r--r--dump/special-forms.scm235
2 files changed, 142 insertions, 129 deletions
diff --git a/dump/documentation.scm b/dump/documentation.scm
deleted file mode 100644
index 5228559..0000000
--- a/dump/documentation.scm
+++ /dev/null
@@ -1,36 +0,0 @@
-(define-module (dump documentation)
- #:use-module (srfi srfi-9 gnu)
- #:use-module (srfi srfi-26)
- #:export (dump-configuration
- dump-configuration?
- dump-configuration-triples?
- dump-configuration-table-metadata?
- dump-configuration-path
- call-with-documentation))
-
-
-(define-immutable-record-type <dump-configuration>
- (%dump-configuration triples? table-metadata? path)
- dump-configuration?
- (triples? dump-configuration-triples?)
- (table-metadata? dump-configuration-table-metadata?)
- (path dump-configuration-path))
-
-(define* (dump-configuration
- #:optional
- (triples? #t)
- (table-metadata? #f)
- (path #f))
- "Return a new configuration."
- (%dump-configuration triples? table-metadata? path))
-
-
-(define (call-with-documentation conf proc)
- (let ((port #f)
- (path (dump-configuration-path conf)))
- (when path
- (dynamic-wind
- (lambda ()
- (set! port (open-file path "w")))
- (cut proc port)
- (cut close port)))))
diff --git a/dump/special-forms.scm b/dump/special-forms.scm
index a4d1c12..cc58919 100644
--- a/dump/special-forms.scm
+++ b/dump/special-forms.scm
@@ -5,7 +5,6 @@
#:use-module (dump sql)
#:use-module (dump table)
#:use-module (dump triples)
- #:use-module (dump documentation)
#:export (translate-forms
collect-forms
collect-keys
@@ -19,6 +18,7 @@
syntax-let
blank-node
map-alist
+ dump-with-documentation
define-dump))
(define (key->assoc-ref alist x)
@@ -212,13 +212,13 @@ Example:
((field (query alias))
#`(format #f "~a" (syntax->datum #'alias)))
((field table column)
- #`(format #f "~a.~a"
+ #`(format #f "~a(~a)"
(syntax->datum #'table)
(syntax->datum #'column)))
((field table column alias)
- #`(format #f "~a.~a"
- (syntax->datum table)
- (syntax->datum alias)))))
+ #`(format #f "~a(~a)"
+ (syntax->datum #'table)
+ (syntax->datum #'alias)))))
x))
(define (field->key x)
@@ -396,17 +396,19 @@ must be remedied."
((triples subject predicate-clauses ...) (triples)
(find-clause #'(clauses ...) 'triples)))
#`(define* (name db
- #:optional (dump-configuration
- (dump-configuration)))
- #,(syntax-case #'schema-triples-clause (schema-triples)
- ((schema-triples (triple-subject triple-predicate triple-object) ...)
- #`(for-each triple
- (list 'triple-subject ...)
- (list 'triple-predicate ...)
- (list 'triple-object ...)))
- (_ (error "Invalid schema triples clause:" #'schema-triples-clause)))
- (when (dump-configuration-table-metadata?
- dump-configuration)
+ #:optional
+ (dump-metadata? #f)
+ (dump-data? #f)
+ (dump-documentation? #f))
+ (when dump-data?
+ #,(syntax-case #'schema-triples-clause (schema-triples)
+ ((schema-triples (triple-subject triple-predicate triple-object) ...)
+ #`(for-each triple
+ (list 'triple-subject ...)
+ (list 'triple-predicate ...)
+ (list 'triple-object ...)))
+ (_ (error "Invalid schema triples clause:" #'schema-triples-clause))))
+ (when dump-metadata?
#,@(let ((dump-table (symbol->string (syntax->datum #'primary-table)))
(subject-type (any (lambda (predicate)
(syntax-case predicate (rdf:type)
@@ -420,20 +422,20 @@ must be remedied."
#`(begin
(scm->triples
(map-alist '()
- (set rdf:type 'gn:dump)
- (set gn:createsPredicate 'predicate)
- (filter-set gn:forSubjectType #,subject-type)
- (multiset gn:dependsOn
- '#,(map (lambda (field)
- (match (syntax->datum field)
- ((table-name column-name _ ...)
- (datum->syntax
- x (column-id (symbol->string table-name)
- (symbol->string column-name))))
- (((query alias))
- (datum->syntax
- x (column-id query (symbol->string alias))))))
- (collect-fields predicate-clause))))
+ (set rdf:type 'gn:dump)
+ (set gn:createsPredicate 'predicate)
+ (filter-set gn:forSubjectType #,subject-type)
+ (multiset gn:dependsOn
+ '#,(map (lambda (field)
+ (match (syntax->datum field)
+ ((table-name column-name _ ...)
+ (datum->syntax
+ x (column-id (symbol->string table-name)
+ (symbol->string column-name))))
+ (((query alias))
+ (datum->syntax
+ x (column-id query (symbol->string alias))))))
+ (collect-fields predicate-clause))))
#,(dump-id dump-table (syntax->datum #'predicate)))
;; Automatically create domain triples
;; for predicates.
@@ -441,22 +443,21 @@ must be remedied."
(triple 'predicate 'rdfs:domain #,subject-type))))
(_ (error "Invalid predicate clause:" predicate-clause))))
#'(predicate-clauses ...))))
- (when (dump-configuration-path dump-configuration)
- (let ((out
- (dump-configuration-path
- dump-configuration)))
- (format out "# '~a' Metadata~%~%" (syntax->datum #'name))
- #,(syntax-case #'schema-triples-clause (schema-triples)
- ((schema-triples (triple-subject triple-predicate triple-object) ...)
- #`(begin
- (format out "## Schema Triples for '~a'~%~%" (syntax->datum #'name))
- (for-each (lambda (s p o)
- (format out "~a -> ~a -> ~a~%" s p o))
- (list 'triple-subject ...)
- (list 'triple-predicate ...)
- (list 'triple-object ...))))
- (_ (error "Invalid schema triples clause:" #'schema-triples-clause)))
- (format out "
+
+ (when dump-documentation?
+ (format #t "~%## '~a'~%~%" (syntax->datum #'name))
+ #,(syntax-case #'schema-triples-clause (schema-triples)
+ ((schema-triples (triple-subject triple-predicate triple-object) ...)
+ #`(begin
+ (format #t "## Schema Triples:~%~%```text~%")
+ (for-each (lambda (s p o)
+ (format #t "~a -> ~a -> ~a~%" s p o))
+ (list 'triple-subject ...)
+ (list 'triple-predicate ...)
+ (list 'triple-object ...))
+ (format #t "```")))
+ (_ (error "Invalid schema triples clause:" #'schema-triples-clause)))
+ (format #t "
## Generated Triples:
The following SQL query was executed:
@@ -467,61 +468,109 @@ The following SQL query was executed:
The above query results to triples that have the form:
+```text
"
- (select-query #,(collect-fields #'(subject predicate-clauses ...))
- (primary-table other-tables ...)
- tables-raw ...))
+ (select-query #,(collect-fields #'(subject predicate-clauses ...))
+ (primary-table other-tables ...)
+ tables-raw ...))
+ (for-each (match-lambda
+ ((predicate . object)
+ (format #t "~a -> ~a -> ~a ~%"
+ #,(field->datum #'subject)
+ predicate object)))
+ (map-alist
+ '()
+ #,@(field->datum #'(predicate-clauses ...))))
+ (format #t "```~%Here's an example query:~%~%```sparql~%")
+ (dump-documentation?)
+ (newline)
+ (let* ((result
+ (map-alist (sql-find
+ db
+ (format #f "~a LIMIT 1"
+ (select-query #,(collect-fields #'(subject predicate-clauses ...))
+ (primary-table other-tables ...)
+ tables-raw ...)))
+ #,@(field->key #'(predicate-clauses ...))))
+ (first-n (list-head result
+ (let ((n (truncate
+ (+ (max (exact-integer-sqrt (length result))) 1))))
+ (if (< n 3)
+ (truncate (/ (length result) 2))
+ n)))))
+ (format #t "SELECT ?s ?p ?o WHERE { ~%")
(for-each (match-lambda
((predicate . object)
- (format out "~a -> ~a -> ~a ~%"
- #,(field->datum #'subject)
- predicate object)))
- (map-alist
- '()
- #,@(field->datum #'(predicate-clauses ...))))
- (format out "~%Here's an example query:~%~%")
- (let* ((result
- (map-alist (sql-find
- db
- (format #f "~a LIMIT 1"
- (select-query #,(collect-fields #'(subject predicate-clauses ...))
- (primary-table other-tables ...)
- tables-raw ...)))
- #,@(field->key #'(predicate-clauses ...))))
- (first-n (list-head result (truncate (/ (length result) 2)))))
- (format out "SELECT ?s ?p ?o WHERE { ~%")
- (for-each (match-lambda
- ((predicate . object)
- (format out
- (match object
- ((or (? symbol? object)
- (? (lambda (el) (string-match "^\\[ .* \\]$" el)) object))
- " ?s ~a ~a .~%")
- (_ " ?s ~a \"~a\" .~%"))
- predicate object)))
- first-n)
- (format out " ?s ?p ?o .~%}~%"))
- (format out "~%Expected Result:~%~%")
- (sql-for-each (lambda (row)
- (scm->triples
- (map-alist row #,@(field->key #'(predicate-clauses ...)))
- #,(field->assoc-ref #'row #'subject)
- (lambda (s p o)
- (triple s p o out))))
- db
- (format #f "~a LIMIT 1"
- (select-query #,(collect-fields #'(subject predicate-clauses ...))
- (primary-table other-tables ...)
- tables-raw ...)))
- ;; To clear the buffer
- (force-output out)))
- (when (dump-configuration-triples? dump-configuration)
+ (match object
+ ((or (? symbol? object)
+ (? (lambda (el) (string-match "^\\[ .* \\]$" el)) object))
+ (format #t " ?s ~a ~a .~%" predicate object))
+ ((and (? string? object)
+ (? (lambda (el) (not (string-null? el))) object))
+ (format #t " ?s ~a \"~a\" .~%" predicate object))
+ (_ ""))))
+ first-n)
+ (format #t " ?s ?p ?o .~%}~%```~%"))
+ (format #t "~%Expected Result:~%~%```rdf~%")
(sql-for-each (lambda (row)
(scm->triples
(map-alist row #,@(field->key #'(predicate-clauses ...)))
+ #,(field->assoc-ref #'row #'subject)
+ (lambda (s p o)
+ (triple s p o))))
+ db
+ (format #f "~a LIMIT 1"
+ (select-query #,(collect-fields #'(subject predicate-clauses ...))
+ (primary-table other-tables ...)
+ tables-raw ...)))
+ (format #t "```~%~%"))
+ (when dump-data?
+ (sql-for-each (lambda (row)
+ (scm->triples
+ (map-alist row #,@(field->key #'(predicate-clauses ...)))
#,(field->assoc-ref #'row #'subject)))
db
(select-query #,(collect-fields #'(subject predicate-clauses ...))
(primary-table other-tables ...)
- tables-raw ...))))))
+ tables-raw ...)))
+ )))
(_ (error "Invalid define-dump syntax:" (syntax->datum x))))))
+
+(define (get-keyword-value args keyword default)
+ (let ((kv (memq keyword args)))
+ (if (and kv (>= (length kv) 2))
+ (cadr kv)
+ default)))
+
+(define-syntax dump-with-documentation
+ (syntax-rules ()
+ ((_ (name n)
+ (connection conn)
+ (table-metadata? t?)
+ (prefixes ((pref uri) ...))
+ (inputs (in ...))
+ (outputs out))
+ (let ((rdf-path
+ (get-keyword-value `out #:rdf ""))
+ (doc-path
+ (get-keyword-value `out #:documentation "")))
+ ;; Dumping documentation
+ (call-with-target-database
+ conn
+ (lambda (db)
+ (with-output-to-file ;
+ doc-path
+ (lambda ()
+ (format #t "# ~a" n)
+ (in db #f #f
+ (lambda () (prefix pref uri #f) ...)) ...)
+ #:encoding "utf8")
+ ;; Dumping the actual data
+ (with-output-to-file
+ rdf-path
+ (lambda ()
+ ;; Add the prefixes
+ (prefix pref uri) ...
+ (newline)
+ (in db #f #t #f) ...)
+ #:encoding "utf8")))))))