
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; MODULE      : db-resource.scm
;; DESCRIPTION : Standard TeXmacs databases
;; COPYRIGHT   : (C) 2014  Joris van der Hoeven
;;
;; This software falls under the GNU general public license version 3 or later.
;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
;; in the root directory or <http://www.gnu.org/licenses/gpl-3.0.html>.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(texmacs-module (database db-resource))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Execution of SQL commands
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(tm-define (db-initialize db)
  (when (not (url-exists? db))
    (sql-exec db "CREATE TABLE props (id text, attr text, val text)")))

(tm-define (db-sql db . l)
  (db-initialize db)
  ;;(display* (apply string-append l) "\n")
  (sql-exec db (apply string-append l)))

(tm-define (db-sql* db . l)
  (with r (apply db-sql (cons db l))
    (with f (lambda (x) (and (pair? x) (car x)))
      (map f (if (null? r) r (cdr r))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Extra subroutines on lists
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (list-even l)
  (if (or (null? l) (null? (cdr l))) l
      (cons (car l) (list-even (cddr l)))))

(define (list-intertwine l1 l2)
  (if (or (null? l1) (null? l2)) (list)
      (cons* (car l1) (car l2) (list-intertwine (cdr l1) (cdr l2)))))

(define (list-even-find l what)
  (cond ((or (null? l) (null? (cdr l))) #f)
        ((== (car l) what) (cadr l))
        (else (list-even-find (cddr l) what))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Basic ressources
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (encode-value val)
  (string-replace val "'" "''"))

(tm-define (db-insert db id attr val . l)
  (db-sql db "INSERT INTO props VALUES ('" id
          "', '" attr "', '" (encode-value val) "')")
  (when (and (nnull? l) (nnull? (cdr l)))
    (apply db-insert (cons* db id l))))

(tm-define (db-remove db id attr val . l)
  (db-sql db "DELETE FROM props WHERE id='" id
          "' AND attr='" attr "', AND val='" (encode-value val) "'")
  (when (and (nnull? l) (nnull? (cdr l)))
    (apply db-remove (cons* db id l))))

(tm-define (db-set db id . l)
  (apply db-reset (cons* db id (list-even l)))
  (apply db-insert (cons* db id l)))

(tm-define (db-reset db id attr . l)
  (db-sql db "DELETE FROM props WHERE id='" id "' AND attr='" attr "'")
  (when (nnull? l)
    (apply db-reset (cons* db id l))))

(tm-define (db-attributes db id)
  (db-sql* db "SELECT DISTINCT attr FROM props WHERE id='" id "'"))

(tm-define (db-get db id attr)
  (db-sql* db "SELECT DISTINCT val FROM props WHERE id='" id
               "' AND attr='" attr "'"))

(tm-define (db-get-first db id attr)
  (with l (db-get db id attr)
    (and (cons? l) (car l))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Searching ressources
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (db-search-join l i)
  (with s (string-append "props AS p" (number->string i))
    (if (null? (cddr l)) s
        (string-append s " JOIN " (db-search-join (cddr l) (+ i 1))))))

(define (db-search-on l i)
  (let* ((attr (car l))
         (val (cadr l)))
    (let* ((pi (string-append "p" (number->string i)))
           (sid (string-append pi ".id=p1.id"))
           (sattr (string-append pi ".attr='" attr "'"))
           (sval (string-append pi ".val='" val "'"))
           (spair (string-append sattr " AND " sval))
           (q (if (= i 1) spair (string-append sid " AND " spair))))
      (if (null? (cddr l)) q
          (string-append q " AND " (db-search-on (cddr l) (+ i 1)))))))

(tm-define (db-search db . l)
  (if (null? l)
      (db-sql* "SELECT DISTINCT id FROM props")
      (let* ((join (db-search-join l 1))
             (on (db-search-on l 1))
             (sep (if (null? (cddr l)) " WHERE " " ON ")))
        (db-sql* db "SELECT DISTINCT p1.id FROM " join sep on))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Bibliographic entries
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(tm-define (biblio-create db . l)
  (let* ((master (create-unique-id))
         (id (create-unique-id)))
    (set! l (cons* "master" master "active" "true" l))
    (apply db-insert (cons* db id l))
    id))

(tm-define (biblio-get db id)
  (let* ((attrs (list-difference (db-attributes db id)
                                 (list "master" "active")))
         (vals (cut db-get-first db id <>)))
    (list-intertwine attrs vals)))

(tm-define (biblio-import-one db . l)
  (let* ((bibid (list-even-find l "id"))
         (ids (if (string? bibid) (db-search db "id" bibid) (list))))
    (display* bibid " -> " ids "\n")
    (when (null? ids)
      (display* "Creating " bibid "\n")
      (apply biblio-create (cons* db l)))))

(define (biblio-field->list field)
  (list (convert (cadr field) "texmacs-stree" "texmacs-snippet")
        (convert (caddr field) "texmacs-stree" "texmacs-snippet")))

(define (biblio-entry->list entry)
  (cons* "id" (caddr entry)
         "type" (cadr entry)
         (append-map biblio-field->list (select (cadddr entry) '(bib-field)))))

(tm-define (biblio-db)
  (string->url "$TEXMACS_HOME_PATH/system/bib/biblio.db"))

(tm-define (biblio-import db bib-file)
  (let* ((bib-s (string-load bib-file))
         (doc (convert bib-s "bibtex-document" "texmacs-stree"))
         (entries (select doc '(body document bib-entry)))
         (l (map biblio-entry->list entries)))
    (for (x l)
      (apply biblio-import-one (cons* db x)))))
