From ed59e1ec947b2b04e94936db749716733e7dbfa5 Mon Sep 17 00:00:00 2001
From: Munyoki Kilyungi
Date: Fri, 21 Jul 2023 14:29:33 +0300
Subject: Make define-dump take extra args as key

Signed-off-by: Munyoki Kilyungi <me@bonfacemunyoki.com>
---
 dump/special-forms.scm | 99 +++++++++++++++++++++++++-------------------------
 1 file changed, 49 insertions(+), 50 deletions(-)

(limited to 'dump')

diff --git a/dump/special-forms.scm b/dump/special-forms.scm
index 1c0b15c..fe9dbe6 100644
--- a/dump/special-forms.scm
+++ b/dump/special-forms.scm
@@ -395,19 +395,10 @@ must be remedied."
                                                #'(schema-triples)))
                     ((triples subject predicate-clauses ...) (triples)
                      (find-clause #'(clauses ...) 'triples)))
-         #`(define* (name db
-			  #:optional
+         #`(define* (name db #:key
                           (dump-metadata? #f)
                           (dump-data? #t)
                           (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)
@@ -529,6 +520,13 @@ The above query results to triples that have the form:
                                                    tables-raw ...)))
                (format #t "```~%~%"))
              (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)))
 	       (sql-for-each (lambda (row)
                                (scm->triples
                                 (map-alist row #,@(field->key #'(predicate-clauses ...)))
@@ -571,43 +569,44 @@ The above query results to triples that have the form:
            (set! outputs o)))
         (list (list 'key value) ...))
        (let ((rdf-path (get-keyword-value outputs #:rdf ""))
-             (doc-path (get-keyword-value outputs #:documentation ""))
-             (prefix-thunk (lambda ()  (for-each
-                                        (match-lambda
-                                          ((k v)
-                                           (begin
-                                             (prefix k v))))
-                                        prefixes))))
-          ;; Dumping the documentation first
-          (call-with-target-database
-           connection
-           (lambda (db)
-             (with-output-to-file       ;
-                 doc-path
-               (lambda ()
-                 (format #t "# ~a" name)
-                 (for-each
-                  (lambda (proc)
-                    (proc db #f #f
-                          (lambda ()  (for-each
-                                        (match-lambda
-                                          ((k v)
-                                           (begin
-                                             (prefix k v #f))))
-                                        prefixes))))
-                  inputs))
-               #:encoding "utf8")
-
-             ;; Dumping the actual data
-             (with-output-to-file
-                 rdf-path
-               (lambda ()
-                 ;; Add the prefixes
-                 (prefix-thunk)
-                 (newline)
-                 (for-each
-                  (lambda (proc)
-                    (proc db #f #t #f))
-                  inputs))
-               #:encoding "utf8"))))))))
-
+             (doc-path (get-keyword-value outputs #:documentation "")))
+         ;; Dumping the documentation first
+         (call-with-target-database
+          connection
+          (lambda (db)
+            (with-output-to-file        ;
+                doc-path
+              (lambda ()
+                (format #t "# ~a" name)
+                (for-each
+                 (lambda (proc)
+                   (proc db
+                         #:dump-metadata? #f
+                         #:dump-data? #f
+                         #:dump-documentation?
+                         (lambda () (for-each
+                                     (match-lambda
+                                       ((k v)
+                                        (begin
+                                          (prefix k v #f))))
+                                     prefixes))))
+                 inputs))
+              #:encoding "utf8")
+
+            ;; Dumping the actual data
+            (with-output-to-file
+                rdf-path
+              (lambda ()
+                ;; Add the prefixes
+                (for-each
+                 (match-lambda
+                   ((k v)
+                    (begin
+                      (prefix k v))))
+                 prefixes)
+                (newline)
+                (for-each
+                 (lambda (proc)
+                   (proc db #:dump-metadata? table-metadata?))
+                 inputs))
+              #:encoding "utf8"))))))))
-- 
cgit v1.2.3