diff options
Diffstat (limited to 'dump/special-forms.scm')
| -rw-r--r-- | dump/special-forms.scm | 599 |
1 files changed, 0 insertions, 599 deletions
diff --git a/dump/special-forms.scm b/dump/special-forms.scm deleted file mode 100644 index 2650580..0000000 --- a/dump/special-forms.scm +++ /dev/null @@ -1,599 +0,0 @@ -(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 - id - syntax-let - blank-node - map-alist - with-documentation - define-transformer)) - -(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 ) - (define (field->datum x) - (translate-forms - 'field - (lambda (x) - (syntax-case x (field) - ((field (query alias)) - #`(format #f "~a" (syntax->datum #'alias))) - ((field table column) - #`(format #f "~a(~a)" - (syntax->datum #'table) - (syntax->datum #'column))) - ((field table column alias) - #`(format #f "~a(~a)" - (syntax->datum #'table) - (syntax->datum #'alias))))) - x)) - - (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 (id table predicate) - (symbol->string - (string->identifier - "dump" - (string-append - 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-transformer - (lambda (x) - "Define FUNCTION-NAME, a function that dumps a view of the database. - -define-transformer consists of three order-agnostic clauses---tables, -schema-triples and triples---in the form shown below. - -(define-transformer 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 #:key - (metadata? #f) - (data? #t) - (documentation? #f)) - (when metadata? - #,@(let ((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-id:dump) - (set gn-term:createsPredicate 'predicate) - (filter-set gn-term:forSubjectType #,subject-type) - (multiset gn-term: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)))) - #,(id 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 ...)))) - (when documentation? - (format #t "~%## '~a'~%~%" (syntax->datum #'name)) - #,(syntax-case #'schema-triples-clause (schema-triples) - ((schema-triples (triple-subject triple-predicate triple-object) ...) - #`(begin - (when (not (list 'triple-subject ...)) - (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: - -```sql -~a -``` - -The above query results to triples that have the form: - -```text -" - (select-query #,(collect-fields #'(subject predicate-clauses ...)) - (primary-table other-tables ...) - tables-raw ...)) - (for-each (match-lambda - ((predicate . object) - (format #t "~a -> ~a -> ~a ~%" - (if (symbol? #,(field->datum #'subject)) - (symbol->string #,(field->datum #'subject)) - #,(field->datum #'subject)) - predicate - (if (symbol? object) - (symbol->string object) - object)))) - (map-alist - '() - #,@(field->datum #'(predicate-clauses ...)))) - (format #t "```~%Here's an example query:~%~%```sparql~%") - (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 - (min 4 (truncate - (+ (exact-integer-sqrt (length result)) 1))))) - (if (< n 3) - (length result) - n))))) - (format #t "SELECT * WHERE { ~%") - (for-each (match-lambda - ((predicate . object) - (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 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 ...))) - #,(field->assoc-ref #'row #'subject))) - db - (select-query #,(collect-fields #'(subject predicate-clauses ...)) - (primary-table other-tables ...) - tables-raw ...))) - ))) - (_ (error "Invalid define-transformer 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 with-documentation - (syntax-rules () - ((_ (key value) ...) - (let* ((alist `((key . ,value) ...)) - (name (assoc-ref alist 'name)) - (connection (assoc-ref alist 'connection)) - (table-metadata? (assoc-ref alist 'table-metadata?)) - (prefixes (assoc-ref alist 'prefixes)) - (inputs (assoc-ref alist 'inputs)) - (outputs (assoc-ref alist 'outputs)) - (rdf-path (get-keyword-value outputs #:rdf "")) - (doc-path (get-keyword-value outputs #:documentation ""))) - (call-with-target-database - connection - (lambda (db) - (with-output-to-file ; - doc-path - (lambda () - (format #t "# ~a" name) - (for-each - (lambda (proc) - (proc db - #:metadata? #f - #:data? #f - #:documentation? - (lambda () (for-each - (match-lambda - ((k v) - (begin - (prefix k v #f)))) - prefixes)))) - inputs)) - #:encoding "UTF-8") - - ;; 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 #:metadata? table-metadata?)) - inputs)) - #:encoding "UTF-8"))))))) - |