aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorArun Isaac2021-12-24 11:25:26 +0530
committerArun Isaac2021-12-24 13:55:24 +0530
commita477b952473fa36d6a06268a7045057a0cdfa62c (patch)
tree41de9d500a9a5d81b1360fe6ea2d2a2501f3b3c6
parent4cab24d18cbf218ba1c59223425a3e41ab4fad54 (diff)
downloadgn-transform-databases-a477b952473fa36d6a06268a7045057a0cdfa62c.tar.gz
Introduce syntax-let abstraction.
* dump.scm (syntax-let): New macro. (define-dump): Use syntax-let. * .dir-locals.el (scheme-mode): Indent syntax-let correctly.
-rw-r--r--.dir-locals.el3
-rwxr-xr-xdump.scm149
2 files changed, 92 insertions, 60 deletions
diff --git a/.dir-locals.el b/.dir-locals.el
index 2fe8b32..6e83303 100644
--- a/.dir-locals.el
+++ b/.dir-locals.el
@@ -6,4 +6,5 @@
(scheme-mode
(eval put 'map-alist 'scheme-indent-function 1)
(eval put 'set-table-columns 'scheme-indent-function 1)
- (eval put 'triples 'scheme-indent-function 1)))
+ (eval put 'triples 'scheme-indent-function 1)
+ (eval put 'syntax-let 'scheme-indent-function 1)))
diff --git a/dump.scm b/dump.scm
index a2379f2..433e087 100755
--- a/dump.scm
+++ b/dump.scm
@@ -217,69 +217,100 @@ ALIST field-name) forms."
(string-append
dump-table "_" (remove-namespace (symbol->string predicate))))))
+(define-syntax syntax-let
+ (syntax-rules ()
+ "Like match-let, but for syntax.
+
+(syntax-let ((pattern literals expression))
+ body ...)
+≡
+(syntax-case expression ()
+ (pattern literals
+ body ...))
+
+literals is optional. So,
+
+(syntax-let ((pattern expression))
+ body ...)
+≡
+(syntax-case expression ()
+ (pattern
+ body ...))
+"
+ ((_ () body ...)
+ (begin body ...))
+ ((_ ((pattern expression)
+ bindings ...)
+ body ...)
+ (syntax-case expression ()
+ (pattern
+ (syntax-let (bindings ...)
+ body ...))))
+ ((_ ((pattern literals expression)
+ bindings ...)
+ body ...)
+ (syntax-case expression literals
+ (pattern
+ (syntax-let (bindings ...)
+ body ...))))))
+
(define-syntax define-dump
(lambda (x)
(syntax-case x (tables schema-triples triples)
((_ name clauses ...)
- (let ((tables-clause (find-clause #'(clauses ...) 'tables))
- (schema-triples-clause (or (find-clause #'(clauses ...) 'schema-triples)
- #'(schema-triples)))
- (triples-clause (find-clause #'(clauses ...) 'triples)))
- (syntax-case triples-clause (triples)
- ((triples subject predicate-clauses ...)
- (let ((fields (collect-fields #'(subject predicate-clauses ...))))
- #`(define (name db)
- #,(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)))
- #,@(let ((dump-table (syntax-case tables-clause (tables)
- ((tables (primary-table _ ...) _ ...)
- (symbol->string (syntax->datum #'primary-table)))
- (_ (error "Invalid tables clause:" (syntax->datum tables-clause)))))
- (subject-type (any (lambda (predicate)
- (syntax-case predicate (rdf:type)
- ((_ rdf:type type) #'type)
- (_ #f)))
- #'(predicate-clauses ...))))
- (map (lambda (predicate-clause)
- (syntax-case predicate-clause ()
- ((_ predicate _)
- ;; Dump metadata about the dump itself.
- #`(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))))))
- (collect-fields predicate-clause))))
- #,(dump-id dump-table (syntax->datum #'predicate)))
- ;; Automatically create domain
- ;; triples for predicates.
- (when #,subject-type
- (triple 'predicate 'rdfs:domain #,subject-type))))
- (_ (error "Invalid predicate clause:" predicate-clause))))
- #'(predicate-clauses ...)))
- (sql-for-each (lambda (row)
- (scm->triples
- (map-alist row #,@(field->key #'(predicate-clauses ...)))
- #,(field->assoc-ref #'row #'subject)))
- db
- #,(syntax-case tables-clause (tables)
- ((tables tables-spec raw ...)
- #`(select-query #,fields tables-spec raw ...))
- (_ (error "Invalid tables clause:" (syntax->datum tables-clause))))))))
- (_ (error "Invalid triples clause:" triples-clause)))))
+ (syntax-let (((tables (primary-table other-tables ...) tables-raw ...) (tables)
+ (find-clause #'(clauses ...) 'tables))
+ (schema-triples-clause (or (find-clause #'(clauses ...) 'schema-triples)
+ #'(schema-triples)))
+ ((triples subject predicate-clauses ...) (triples)
+ (find-clause #'(clauses ...) 'triples)))
+ #`(define (name db)
+ #,(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)))
+ #,@(let ((dump-table (symbol->string (syntax->datum #'primary-table)))
+ (subject-type (any (lambda (predicate)
+ (syntax-case predicate (rdf:type)
+ ((_ rdf:type type) #'type)
+ (_ #f)))
+ #'(predicate-clauses ...))))
+ (map (lambda (predicate-clause)
+ (syntax-case predicate-clause ()
+ ((_ predicate _)
+ ;; Dump metadata about the dump itself.
+ #`(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))))))
+ (collect-fields predicate-clause))))
+ #,(dump-id dump-table (syntax->datum #'predicate)))
+ ;; Automatically create domain triples
+ ;; for predicates.
+ (when #,subject-type
+ (triple 'predicate 'rdfs:domain #,subject-type))))
+ (_ (error "Invalid predicate clause:" predicate-clause))))
+ #'(predicate-clauses ...)))
+ (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 ...)))))
(_ (error "Invalid define-dump syntax:" (syntax->datum x))))))
(define binomial-name->species-id