Re-organize dumping macros and associated functions

Signed-off-by: Munyoki Kilyungi <me@bonfacemunyoki.com>

1 files changed, 430 insertions, 0 deletions

diff --git a/dump/special-forms.scm b/dump/special-forms.scm
new file mode 100644
index 0000000..9b295ba
--- /dev/null
+++ b/dump/special-forms.scm
@@ -0,0 +1,430 @@
+(define-module (dump special-forms)
+  #:use-module (srfi srfi-1)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-26)
+  #:use-module (dump sql)
+  #:use-module (dump table)
+  #:use-module (dump triples)
+  #:export (translate-forms
+            collect-forms
+            collect-keys
+            field->key
+            field->assoc-ref
+            collect-fields
+            find-clause
+            remove-namespace
+            column-id
+            dump-id
+            syntax-let
+            blank-node
+            define-dump))
+
+(define (key->assoc-ref alist x)
+  "Recursively translate (key k) forms in source X to (assoc-ref ALIST
+k) forms."
+  (translate-forms 'key
+                   ;; (syntax-rules (key)
+                   ;;   ((key k) (assoc-ref alist k)))
+                   (lambda (x)
+                     (syntax-case x (key)
+                       ((key k) #`(assoc-ref #,alist 'k))))
+                   x))
+
+(define (alist-delete* alist keys)
+  "Delete entries from ALIST whose key is equal (in the sense of
+equal?) to any in KEYS, a list."
+  (remove (match-lambda
+            ((key . value)
+             (member key keys))
+            (x (error "malformed alist element" x)))
+          alist))
+
+(define (translate-forms from translator x)
+  "Recursively pass (FROM ...) forms in source X to TRANSLATOR, and
+replace them with the return value."
+  (syntax-case x ()
+    ;; Handle translation base case.
+    ((head tail ...) (eq? (syntax->datum #'head)
+                          from)
+     (translator x))
+    ;; Recurse.
+    ((head tail ...)
+     (cons (translate-forms from translator #'head)
+           (map (cut translate-forms from translator <>)
+                #'(tail ...))))
+    ;; Handle leaf base case.
+    (leaf #'leaf)))
+
+(define (collect-forms target x)
+  "Recursively collect (TARGET ...) forms in source X and return them
+as a list."
+  (syntax-case x ()
+    ;; Handle collection base case.
+    ((head tail ...) (eq? (syntax->datum #'head)
+                          target)
+     (list x))
+    ;; Recurse.
+    ((head tail ...)
+     (append (collect-forms target #'head)
+             (append-map (cut collect-forms target <>) #'(tail ...))))
+    ;; Handle leaf base case.
+    (leaf (list))))
+
+(define (collect-keys x)
+  "Recursively collect (key k) forms from source X and return as a
+list of all K."
+  (map (syntax-rules (key)
+         ((key k) 'k))
+       (collect-forms 'key x)))
+
+(define-syntax map-alist
+  (lambda (x)
+    "Transform (aka map) ALIST, an association list, into another
+association list. The returned association list may contain multiple
+associations for the same key. equal? is used in all association list
+key comparisons.
+
+Syntax:
+
+(map-alist alist
+  (verb key expression) ...
+  (else=> proc))
+
+VERB must be one of set, filter-set, multiset and remove.
+
+For the set VERB, KEY is set to the result of evaluating
+EXPRESSION. Multiple set verbs on the same key will result in multiple
+associations for that key.
+
+For the filter-set VERB, KEY is set to the result of evaluating
+EXPRESSION only if that result is not #f.
+
+For the multiset VERB, EXPRESSION must return a list and KEY is
+associated multiple times once with each element of the returned list.
+
+For the remove VERB, KEY is discarded.
+
+EXPRESSIONs must reference elements of ALIST using (key k) forms where
+K is the key to be referenced from ALIST. K must not be quoted. That
+is, if K is the symbol 'bar, it must be referenced as (key bar), not
+as (key 'bar).
+
+The else=> clause is optional.
+
+If the else=> clause is present, PROC is passed all pairs of ALIST
+that are not set by an earlier (verb key expression) action. PROC must
+return #f or a pair to replace its input pair. If PROC returns #f,
+that pair is discarded.
+
+If the else=> clause is absent, all unset pairs are discarded.
+
+Example:
+
+(map-alist '((\"foo\" . 1)
+             (bar . 2)
+             (foobar . 5)
+             (fubar . 3))
+  (set spam (1+ (key \"foo\")))
+  (set ham (* 2 (key bar)))
+  (set eggs (* 3 (key bar)))
+  (set aal (+ (key \"foo\")
+              (key bar)))
+  (multiset vel (iota (* 2 (key bar))))
+  (remove foobar)
+  (else=> (match-lambda
+            ((key . value)
+             (cons key (expt 2 value))))))
+=> ((spam . 2) (ham . 4) (eggs . 6) (aal . 3)
+    (vel . 0) (vel . 1) (vel . 2) (vel . 3) (fubar . 8))"
+    (syntax-case x ()
+      ((_ alist actions ...)
+       ;; TODO: Check that all actions are valid.
+       #`(let ((evaluated-alist alist))
+           (append (remove (match-lambda
+                             ;; Filter out results of filter-set actions.
+                             ((key . #f)
+                              (member key '#,(filter-map (lambda (action)
+                                                           (syntax-case action (filter-set)
+                                                             ((filter-set key expression) #'key)
+                                                             (_ #f)))
+                                                         #'(actions ...))))
+                             (_ #f))
+                           ;; Do set and filter-set.
+                           `#,(filter-map (lambda (action)
+                                            (syntax-case action (set filter-set)
+                                              ((set key expression)
+                                               #`(key . ,#,(key->assoc-ref #'evaluated-alist #'expression)))
+                                              ((filter-set key expression)
+                                               #`(key . ,#,(key->assoc-ref #'evaluated-alist #'expression)))
+                                              (_ #f)))
+                                          #'(actions ...)))
+                   ;; Do multiset.
+                   #,@(filter-map (lambda (action)
+                                    (syntax-case action (multiset)
+                                      ((multiset key expression)
+                                       #`(map (cut cons 'key <>)
+                                              #,(key->assoc-ref #'evaluated-alist #'expression)))
+                                      (_ #f)))
+                                  #'(actions ...))
+                   ;; Apply else=> procedure on unspecified keys. If
+                   ;; no else=> procedure is specified, delete
+                   ;; unspecified keys.
+                   (filter-map #,(or (any (lambda (action)
+                                            (syntax-case action (else=>)
+                                              ((else=> proc) #'proc)
+                                              (_ #f)))
+                                          #'(actions ...))
+                                     #'(const #f))
+                               ;; The unspecified part of the input
+                               ;; alist
+                               (alist-delete* evaluated-alist
+                                              (list
+                                               ;; Keys that were referenced
+                                               #,@(append-map (lambda (action)
+                                                                (syntax-case action ()
+                                                                  ((_ key expression)
+                                                                   (collect-keys #'expression))
+                                                                  (_ '())))
+                                                              #'(actions ...))
+                                               ;; Keys that were deleted
+                                               #,@(filter-map (lambda (action)
+                                                                (syntax-case action (remove)
+                                                                  ((remove key) #''key)
+                                                                  (_ #f)))
+                                                              #'(actions ...))
+                                               ;; Keys that were set
+                                               #,@(filter-map (lambda (action)
+                                                                (syntax-case action ()
+                                                                  ((_ key expression) #''key)
+                                                                  (_ #f)))
+                                                              #'(actions ...)))))))))))
+
+
+
+(eval-when (expand load eval)
+  (define (field->key x)
+    (translate-forms 'field
+                     (lambda (x)
+                       #`(key #,(symbol->string
+                                 (syntax->datum
+                                  ((syntax-rules (field)
+                                     ((field (query alias)) alias)
+                                     ((field table column) column)
+                                     ((field table column alias) alias))
+                                   x)))))
+                     x))
+
+  (define (field->assoc-ref alist x)
+    "Recursively translate field references in source X to (assoc-ref
+ALIST field-name) forms."
+    (translate-forms 'field
+                     (lambda (x)
+                       #`(assoc-ref #,alist
+                                    #,(symbol->string
+                                       (syntax->datum
+                                        ((syntax-rules (field)
+                                           ((field (query alias)) alias)
+                                           ((field table column) column)
+                                           ((field table column alias) alias))
+                                         x)))))
+                     x))
+
+  (define (collect-fields x)
+    (map (syntax-rules (field)
+           ((field reference ...)
+            (reference ...)))
+         (collect-forms 'field x)))
+
+  (define (find-clause clauses key)
+    "Find (KEY ...) clause among CLAUSES, a list of syntax forms."
+    (find (lambda (x)
+            (syntax-case x ()
+              ((clause-key _ ...)
+               (eq? (syntax->datum #'clause-key)
+                    key))))
+          clauses))
+
+  (define (remove-namespace str)
+    "Remove RDF namespace prefix from STR."
+    (substring str (1+ (string-index str #\:))))
+
+  (define (column-id table-name column-name)
+    (string->identifier
+     "field" (string-append
+              ;; We downcase table names in identifiers. So, we
+              ;; distinguish between the user and User tables.
+              (if (string=? table-name "User")
+                  "user2" table-name)
+              "__" column-name)))
+
+  (define (dump-id dump-table predicate)
+    (symbol->string
+     (string->identifier
+      "dump"
+      (string-append
+       dump-table "_" (remove-namespace (symbol->string predicate)))))))
+
+(define-syntax blank-node
+  (syntax-rules ()
+    "Allow having set and multiset within the context of a blank-node"
+    [(_ (op predicate object) ...)
+     (let [(node (string-join
+                  (filter-map (match-lambda
+                                ((pred . obj)
+                                 (match obj
+                                   ((and (?  string? obj)
+                                         (?  string-null? obj))
+                                    #f)
+                                   ((?  symbol? obj)
+                                    (format #f "~a ~a" pred (symbol->string obj)))
+                                   (_
+                                    (format #f "~a ~s" pred obj)))))
+                              (map-alist '()
+                                (op predicate object) ...))
+                  " ; "))]
+       (if (string-null? node)
+           ""
+           (format #f "[ ~a ]" node)))]))
+
+(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)
+    "Define FUNCTION-NAME, a function that dumps a view of the database.
+
+define-dump consists of three order-agnostic clauses---tables,
+schema-triples and triples---in the form shown below.
+
+(define-dump function-name
+  (tables (table ...) raw-forms ...)
+  (schema-triples
+   (subject predicate object) ...)
+  (triples subject
+    (verb predicate object) ...))
+
+The tables clause specifies the database tables to be joined to
+construct the view to be dumped. TABLE must be either of the form
+TABLE-NAME or of the form (JOIN-OPERATOR TABLE-NAME
+RAW-CONDITION). TABLE-NAME must, obviously, be the name of the
+table. JOIN-OPERATOR must be one of join, left-join and
+inner-join. RAW-CONDITION should be the join condition as a raw
+string. This is usually something like
+\"USING (SpeciesId)\". RAW-FORMS are expressions that must evaluate to
+strings to be appended to the SQL query.
+
+The schema-triples clause specifies the list of triples to be written
+once when the dump starts.
+
+The triples clause specifies the triples to be dumped once for each
+row in the view. All triples have a common SUBJECT. The (verb
+predicate object) clauses are described below.
+
+VERB must either be set or multiset. For the set VERB, a single triple
+(SUBJECT PREDICATE OBJECT-VALUE) is written where OBJECT-VALUE is the
+result of evaluating OBJECT. For the multiset VERB, OBJECT must
+evaluate to a list, and a triple (SUBJECT PREDICATE
+OBJECT-VALUE-ELEMENT) is created for each element OBJECT-VALUE-ELEMENT
+of that list.
+
+The SUBJECT and OBJECT expressions in the triples clause must
+reference database fields using a (field TABLE COLUMN) clause where
+TABLE and COLUMN refer to the table and column of the field being
+referenced. Database fields can also be referenced using (field TABLE
+COLUMN ALIAS) where ALIAS is an alias for that column in the SQL
+query. Specification of ALIAS is indeed a leak in the abstraction, and
+must be remedied."
+    (syntax-case x (tables schema-triples triples)
+      ((_ name clauses ...)
+       (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 #:optional (table-metadata? #f))
+             #,(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 table-metadata?
+               #,@(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))))
+                                                           (((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.
+                                  (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))))))