Otama

otama.el

;;; otama.el --- Org-table as database.

;; Description: Org-table as database.
;; Author:  Yoshinari Nomura <nom@quickhack.net>
;; Created: 2016-02-03
;; Version: 1.0.0
;; Keywords: database, org-mode
;; URL:
;; Package-Requires:

;;;
;;; Commentary:
;;;

;; Otama is a simple org-table based database.
;; It is intended to be a light version of BBDB and helm-friendly.

;;; Code:

(require 'org-element)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Org-element scanner
;;   http://orgmode.org/worg/dev/org-element-api.html

(defun otama--element-tree-from-buffer ()
  "Return org-element tree from current org buffer."
  (org-element-parse-buffer))

(defun otama--element-find-table (title &optional tree)
  "Find table by TITLE in org element TREE.
If TREE is omitted, create it by parsing current buffer.
See also `otama--element-table-title'."
  (catch 'found
    (org-element-map (or tree (otama--element-tree-from-buffer)) 'table
      (lambda (table)
        (if (string= title (otama--element-table-title table))
            (throw 'found table))))))

(defun otama--element-table-title (table)
  "Return title of org TABLE element.
Title is taken from the parent org headline element."
  (let* ((headline (org-element-lineage table '(headline))))
    (substring-no-properties
     (org-element-interpret-data
      (org-element-property
       :title headline)))))

(defun otama--element-table-name (table)
  "Return name of org TABLE element.
Name is taken from #+name: property."
  (org-element-property :name table))

(defun otama--element-table-header-symbols (table)
  "Return the first row of TABLE element as a symbol list."
  (let ((first-row (org-element-map table 'table-row #'identity nil t)))
    (mapcar #'intern (otama--element-table-row-to-strings first-row))))

(defun otama--element-table-rows (table)
  "Return a list of table-row elements from TABLE ignoring first header."
  (delq nil (nthcdr 1
    (org-element-map table 'table-row
      (lambda (row)
        (and (eq (org-element-property :type row) 'standard)
             row))))))

(defun otama--element-table-row-to-strings (table-row)
  "Convert an org TABLE-ROW element to a list of strings."
  (if (eq (org-element-property :type table-row) 'standard)
      (org-element-map table-row 'table-cell
        (lambda (cell) (otama--element-content-string cell)))))

(defun otama--element-content-string (element)
  "Return content of org ELEMENT as a string."
  (buffer-substring-no-properties
   (org-element-property :contents-begin element)
   (org-element-property :contents-end element)))

(defun otama--element-table-at-point ()
  "Return org table element at point.
Returned table element has parents as a part of AST."
  (when (org-at-table-p)
    (catch 'found
      (org-element-map (otama--element-tree-from-buffer) 'table
        (lambda (table)
          (if (<= (org-element-property :begin table)
                  (point)
                  (org-element-property :end table))
              (throw 'found table)))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Org file table editor

(defmacro otama--with-org-file (filename &rest body)
  "With FILENAME, execute the forms in BODY."
  (declare (indent 1))
  `(with-current-buffer (find-file-noselect (expand-file-name filename))
     (save-excursion
       (save-restriction
         (widen)
         (goto-char (point-min))
         ,@body))))

(defun otama--editor-add-table-row (row table-name &optional filename)
  "Add ROW (string list) to TABLE-NAME in org-file.
Target org-file is a file currently visited or FILENAME."
  (otama--with-org-file filename
    (let* ((table (otama--element-find-table table-name))
           (end (org-element-property :contents-end table)))
      (unless end (error "No such table %s" table-name))
      (goto-char end)
      (insert "| " (mapconcat #'identity row " | ") " |\n")
      (org-table-align)
      (save-buffer))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Records

(defun otama--records-from-buffer ()
  "Return all records in current buffer."
  (otama--records-from-tree
   (otama--element-tree-from-buffer)))

(defun otama--records-from-tree (tree)
  "Return all records in org-element TREE."
  (apply 'append
         (org-element-map tree 'table
           (lambda (table)
             (otama--records-from-table table)))))

(defun otama--records-from-table (table)
  "Return all records in org-element TABLE."
  (let ((colnames (otama--element-table-header-symbols table))
        (rows (otama--element-table-rows table)))
    (mapcar (lambda (row)
              (otama--zip
               colnames
               (otama--element-table-row-to-strings row)))
            rows)))

(defun otama--zip (keys values)
  "Make assoc from KEYS and VALUES."
  (if (or (null keys) (null values))
      ()
    (cons (cons (car keys) (car values))
          (otama--zip (cdr keys) (cdr values)))))

(defmacro otama--with-database (database &rest body)
  "With DATABASE, execute the forms in BODY."
  (declare (indent 1))
  `(with-current-buffer (find-file-noselect (otama-db-filename ,database))
     (save-excursion
       (save-restriction
         (widen)
         (goto-char (point-min))
         ,@body))))

(defun otama--add-record-to-table (record table)
  "Add RECORD to TABLE."
  (let ((end (org-element-property :contents-end table))
        (names (otama--element-table-header-symbols table)))
    (goto-char end)
    (insert
     (concat "| "
             (mapconcat (lambda (name)
                          (otama-attribute record name)) names " | ")
             " |\n"))
    (org-table-align)
    ))

;; (defun otama-record-to-strings (record)
;;   "Convert RECORD to string list."
;;   (let ((table (otama--element-find-table (otama-record-table-name record)))
;;         (names (otama--element-table-header-symbols table)))
;;     (mapcar (lambda (name) (otama-attribute record name)) names)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; UI
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;
;; Setup Database
;;;;;;;;;;;;;;;;

;;
;; Use org-tables in org file as database.
;; otama-db is currently just a filename string enclosed by list:
;;
;;   '(filename)
;;
;; It could be a simple string, but in preparation for
;; future enhancement.
;;

(defun otama-db-open (filename)
  "Open org file specified by FILENAME as database."
  (list filename))

(defun otama-db-filename (database)
  "Return filename of DATABASE."
  (expand-file-name
   (if (stringp database) database (car database))))

(defun otama-db-records (database &optional table-name)
  "Return all records in DATABASE.
If TABLE-NAME is non-nil, return records in the table."
  (otama--with-database database
    (otama--records-from-buffer)))

;;;;;;;;;;;;;;;;
;; Lookup Database
;;;;;;;;;;;;;;;;

(defmacro otama-db-select (record table condition &optional database)
  "With setting RECORD from TABLE, find records where CONDITION is true.
REORD is the symbol name of current record that can be referenced
in the condition-clause.  If optional DATABASE is non-nil,
switch current database to DATABASE before the operation."
  (declare (indent 1))
  `(otama--with-database ,database
     (delq nil
           (mapcar (lambda (,record)
                     (and ,condition ,record)
                     (otama-db-records ,table))))))

(defun otama-find (database key value)
  "Find records in DATABASE where KEY == VALUE."
  (let ((records (otama-db-records database)))
    (delq nil
          (mapcar (lambda (record)
                    (and (string= (otama-attribute record key) value)
                         record))
                  records))))

;;;;;;;;;;;;;;;;
;; Insert Database
;;;;;;;;;;;;;;;;

(defun otama-insert (database table-name record)
  "With DATABASE TABLE-NAME, insert RECORD."
  (otama--with-database database
    (let ((table (otama--element-find-table table-name)))
      (otama--add-record-to-table record table)
      (save-buffer))))

;;;;;;;;;;;;;;;;
;; Access record attributes
;;;;;;;;;;;;;;;;

(defun otama-create-record (assoc table)
  "Create record from ASSOC accrding to TABLE."
  (cons (cons 'otama-table-name table) assoc))

(defun otama-record-table-name (record)
  "Return table name of RECORD."
  (cdr (assoc 'otama-table-name record)))

(defun otama-attribute (record key &optional format-string)
  "Return attribute of RECORD specified by KEY.
If optional FORMAT-STRING and attribute is non-nill,
they are applied to `format`."
  (let ((value (cdr (assoc key record))))
    (if (and value (not (string= value "")))
        (format (or format-string "%s") value) "")))

(defun otama-format-record (record format-string &rest keys)
  "Format RECORD by FORMAT-STRING applying KEYS."
  (apply 'format format-string
         (mapcar (lambda (key)
                   (otama-attribute record key))
                 keys)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Helm interface

(defvar mew-otama-db-file "~/prj/private/address-db.org")

(defun otama-helm-real-to-display (real)
  (format "%s %s %s %s"
          (otama-attribute real 'name)
          (otama-attribute real 'mail "<%s>")
          (otama-attribute real 'organization "(%s)")
          (otama-attribute real 'title "- %s")))

(defun otama-helm-entries-and-mew-aliases ()
    (append (otama-helm-db-records)
            (mapcar (lambda (mail)
                      (cons mail (list (cons 'mail mail))))
                    (helm-mew-list-address))))

(defun otama-helm-db-records ()
  (let ((db (otama-db-open mew-otama-db-file)))
    (mapcar (lambda (record)
              (cons (otama-helm-real-to-display record) record))
            (otama-db-records db))))

;; http://wikemacs.org/wiki/How_to_write_helm_extensions#Handling_multiple_selections
(setq otama-helm-source-entries
  (helm-build-sync-source "OTAMA entries"
    :candidates 'otama-helm-db-records
    :migemo t
    :action '(("Insert as org list item" .
               (lambda (candidate)
                 (mapc
                  (lambda (c)
                    (insert (format "+ %s\n" (otama-helm-real-to-display c))))
                  (helm-marked-candidates)))))))

(setq otama-helm-source-entries-mail
  (helm-build-sync-source "OTAMA entries"
    :candidates 'otama-helm-entries-and-mew-aliases
    :migemo t
    :action '(("Insert mail address" .
               (lambda (candidate)
                 (insert
                  (mapconcat (lambda (c) (otama-attribute c 'mail))
                             (helm-marked-candidates) ", ")))))))

(defun otama-helm ()
  (interactive)
  (helm-other-buffer
   'otama-helm-source-entries
   "*Helm OTAMA Entries*"))

(defun otama-helm-insert-mail ()
  (interactive)
  (helm-other-buffer
   'otama-helm-source-entries-mail
   "*Helm OTAMA Entries*"))

(provide 'otama)


;;; Copyright Notice:

;; Copyright (C) 2016 Yoshinari Nomura. All rights reserved.

;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions
;; are met:
;;
;; 1. Redistributions of source code must retain the above copyright
;;    notice, this list of conditions and the following disclaimer.
;; 2. Redistributions in binary form must reproduce the above copyright
;;    notice, this list of conditions and the following disclaimer in the
;;    documentation and/or other materials provided with the distribution.
;; 3. Neither the name of the team nor the names of its contributors
;;    may be used to endorse or promote products derived from this software
;;    without specific prior written permission.
;;
;; THIS SOFTWARE IS PROVIDED BY THE TEAM AND CONTRIBUTORS ``AS IS''
;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
;; FOR A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL
;; THE TEAM OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
;; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
;; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
;; OF THE POSSIBILITY OF SUCH DAMAGE.

;;; otama.el ends here