ndwarshuis
/
emacs-config
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

dashify org-sql

This commit is contained in:
ndwarshuis 2019-01-02 17:54:58 -05:00
parent 1e0048a16a
commit 32a2bd101d
1 changed files with 345 additions and 330 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

559
conf.org
View File

@ -6,6 +6,7 @@ This is my personal emacs config. It is quite massive. Please use the table of c
- [[#for-new-users][for new users]] - [[#for-new-users][for new users]]
- [[#config-structure][config structure]] - [[#config-structure][config structure]]
- [[#library][library]] - [[#library][library]]
- [[#external][external]]
- [[#macros][macros]] - [[#macros][macros]]
- [[#functions][functions]] - [[#functions][functions]]
- [[#interactive][interactive]] - [[#interactive][interactive]]
@ -71,6 +72,14 @@ Once loaded, the =init.el= pulls in another file called =conf.el= with the funct
Using an org file like this offers several advantages. First, org files are foldable in emacs which makes navigation easy. Second, they allow code snippets (the bit that actually go into =conf.el=) which allows for explanatory prose to be written around them, making documentation easy and clear. Third, =org-mode= has an automatic table of contents through the =toc-org= package, which makes naviagation even easier. Fourth, github itself is awesome enough to recognize org files as valid markdown and will render all the text, code snippets, headers, and table of contents in the nice html that you are reading now if on github. The result is a nearly self-documenting, self-organizing configuration that is easy to maintain and also easy to view for other users. Using the =init.el= itself would just have plain eLisp, which gets cluttered quickly. Some people break the =init.el= down into multiple files to keep everything sane, but I personally think it is easier to use one giant file that itself can be folded and abstracted to reduce the clutter. Using an org file like this offers several advantages. First, org files are foldable in emacs which makes navigation easy. Second, they allow code snippets (the bit that actually go into =conf.el=) which allows for explanatory prose to be written around them, making documentation easy and clear. Third, =org-mode= has an automatic table of contents through the =toc-org= package, which makes naviagation even easier. Fourth, github itself is awesome enough to recognize org files as valid markdown and will render all the text, code snippets, headers, and table of contents in the nice html that you are reading now if on github. The result is a nearly self-documenting, self-organizing configuration that is easy to maintain and also easy to view for other users. Using the =init.el= itself would just have plain eLisp, which gets cluttered quickly. Some people break the =init.el= down into multiple files to keep everything sane, but I personally think it is easier to use one giant file that itself can be folded and abstracted to reduce the clutter.
* library * library
This is code that is used generally throughout the emacs config This is code that is used generally throughout the emacs config
** external
*** dash
#+BEGIN_SRC emacs-lisp
(use-package dash
:ensure t
:config
(setq dash-enable-fontlock t))
#+END_SRC
** macros ** macros
#+BEGIN_SRC emacs-lisp #+BEGIN_SRC emacs-lisp
;; lovingly stolen from aaron harris ;; lovingly stolen from aaron harris
@ -776,7 +785,6 @@ Org has several extensions in the form of loadable modules. =org-protocol= is us
(require 'org-agenda) (require 'org-agenda)
(require 'org-protocol) (require 'org-protocol)
(require 'org-habit) (require 'org-habit)
(require 'dash)
#+END_SRC #+END_SRC
*** directory *** directory
I keep all my org files in one place. I keep all my org files in one place.
@ -2684,17 +2692,6 @@ Org mode is great and all, but in many cases, text files just won't cut it. Hard
These are =org-mode=-agnostic functions that pertain to sql. They are basically just simple interfaces for shell commands. These are =org-mode=-agnostic functions that pertain to sql. They are basically just simple interfaces for shell commands.
#+BEGIN_SRC emacs-lisp #+BEGIN_SRC emacs-lisp
(require 'sql) (require 'sql)
;;(require 'dash)
(defmacro nd/org-sql-> (&rest body)
(let ((result (pop body)))
(dolist (form body result)
(setq result (append (list (car form) result) (cdr form))))))
(defmacro nd/org-sql->> (&rest body)
(let ((result (pop body)))
(dolist (form body result)
(setq result (append form (list result))))))
;; this needs a better home :/ ;; this needs a better home :/
(defun nd/alist-put (alist prop value &optional front) (defun nd/alist-put (alist prop value &optional front)
@ -2724,29 +2721,26 @@ t, add to the front of current values list instead of the back."
(-slice plist 1 nil 2)) (-slice plist 1 nil 2))
;; SQL string parsing functions ;; SQL string parsing functions
(defun nd/sql-to-plist (out &rest cols) (defun nd/sql-to-plist (out cols)
"Parse SQL output string OUT to an plist representing the data. "Parse SQL output string OUT to an plist representing the data.
COLS are the column names as symbols used to obtain OUT." COLS are the column names as symbols used to obtain OUT."
(unless (equal out "") (unless (equal out "")
(let* ((out-trim (string-trim out)) (-->
(row-data (split-string out-trim "\n")) out
(cell-data (mapcar (lambda (s) (split-string s "|")) row-data))) (string-trim it)
(mapcar (lambda (d) (cl-mapcan #'list cols d)) cell-data)))) (split-string it "\n")
(mapcar (lambda (s) (split-string s "|")) it)
(mapcar (lambda (s) (-interleave cols s)) it))))
;; sql to string functions ;; sql to string functions
(defun nd/sql-escape-text (txt) (defun nd/sql-escape-text (txt)
"Escape and quote TXT in order to insert into sqlite db via 'insert'. "Escape and quote TXT in order to insert into sqlite db via 'insert'.
This assumes the insertion command will be run on a shell where the This assumes the insertion command will be run on a shell where the
sql command string is in double quotes." sql command string is in double quotes."
(nd/org-sql->> (->> txt
txt
(replace-regexp-in-string "'" "''") (replace-regexp-in-string "'" "''")
(replace-regexp-in-string "\n" "'||char(10)||'") (replace-regexp-in-string "\n" "'||char(10)||'")
(format "'%s'"))) (format "'%s'")))
;; (let* ((new-txt (replace-regexp-in-string "'" "''" txt))
;; (new-txt (replace-regexp-in-string "\n" "'||char(10)||'" new-txt)))
;; ;; (new-txt (replace-regexp-in-string "\"" "\\\"" new-txt nil t)))
;; (concat "'" new-txt "'")))
(defun nd/sql-to-string (entry) (defun nd/sql-to-string (entry)
"Convert ENTRY to a string suitable for insertion into SQLite db. "Convert ENTRY to a string suitable for insertion into SQLite db.
@ -2759,56 +2753,61 @@ any other symbols to their symbol name."
(defun nd/sql-kw-to-colname (kw) (defun nd/sql-kw-to-colname (kw)
"Return string representation of KW for column in sql database." "Return string representation of KW for column in sql database."
(substring (symbol-name kw) 1)) (--> kw (symbol-name it) (substring it 1)))
(defun nd/sql-plist-concat (plist &optional sep) (defun nd/sql-plist-concat (plist &optional sep)
"Concatenate a PLIST to string to be used in a SQL statement. "Concatenate a PLIST to string to be used in a SQL statement.
Returns a string formatted like 'prop1 = value1 SEP prop2 = value2' Returns a string formatted like 'prop1 = value1 SEP prop2 = value2'
from a plist like '(:prop1 value1 :prop2 value2)." from a plist like '(:prop1 value1 :prop2 value2)."
(let* ((sep (or sep ",")) (let ((sep (or sep ","))
(keys (plist-get-keys plist)) (keys (->> plist
(keys (mapcar #'nd/sql-kw-to-colname keys)) plist-get-keys
(vals (nd/sql-plist-get-vals plist)) (mapcar #'nd/sql-kw-to-colname)))
(vals (mapcar #'nd/sql-to-string vals)) (vals (->> plist
(str (mapcar* (lambda (k v) (format "%s=%s" k v)) keys vals))) nd/sql-plist-get-vals
(string-join str sep))) (mapcar #'nd/sql-to-string))))
(-some-->
(--zip-with (format "%s=%s" it other) keys vals)
(string-join it sep))))
;; SQL formatting functions ;; SQL formatting functions
(defun nd/org-sql-fmt-insert (tbl-name tbl-data) (defun nd/org-sql-fmt-insert (tbl-name tbl-data)
"Format SQL insert command from TBL-NAME and TBL-DATA." "Format SQL insert command from TBL-NAME and TBL-DATA."
(let* ((col-names (plist-get-keys tbl-data)) (let ((col-names (-->
(col-names (mapcar (lambda (s) (substring (symbol-name s) 1)) col-names)) tbl-data
(col-names (string-join col-names ",")) (plist-get-keys it)
(col-values (nd/sql-plist-get-vals tbl-data)) (mapcar #'nd/sql-kw-to-colname it)
(col-values (mapcar #'nd/sql-to-string col-values)) (string-join it ",")))
(col-values (string-join col-values ","))) (col-values (-->
tbl-data
(nd/sql-plist-get-vals it)
(mapcar #'nd/sql-to-string it)
(string-join it ","))))
(format "insert into %s (%s) values (%s);" (symbol-name tbl-name) (format "insert into %s (%s) values (%s);" (symbol-name tbl-name)
col-names col-values ))) col-names col-values)))
(defun nd/org-sql-fmt-update (tbl-name update) (defun nd/org-sql-fmt-update (tbl-name update)
"Format SQL update command from TBL-NAME, UPDATE, and CONDS." "Format SQL update command from TBL-NAME, UPDATE, and CONDS."
(let ((upd-str (nd/sql-plist-concat (car update))) (let ((upd-str (->> update car nd/sql-plist-concat))
(conds-str (nd/sql-plist-concat (cdr update) " and "))) (conds-str (--> update (car it) (nd/sql-plist-concat it " and "))))
(format "update %s set %s where %s;" (symbol-name tbl-name) (format "update %s set %s where %s;" (symbol-name tbl-name)
upd-str conds-str))) upd-str conds-str)))
(defun nd/org-sql-fmt-delete (tbl-name conds) (defun nd/org-sql-fmt-delete (tbl-name conds)
"Format SQL update command from TBL-NAME and CONDS." "Format SQL update command from TBL-NAME and CONDS."
(let ((conds-str (nd/sql-plist-concat conds " and "))) (--> conds
(format "delete from %s where %s;" (symbol-name tbl-name) conds-str))) (nd/sql-plist-concat it " and ")
(format "delete from %s where %s;" (symbol-name tbl-name) it)))
(defun nd/org-sql-fmt-trans (sql-str) (defun nd/org-sql-fmt-trans (sql-str)
"Format SQL transaction from list of SQL commands as strings SQL-STR." "Format SQL transaction from list of SQL commands as strings SQL-STR."
(when sql-str (-some->> sql-str
(nd/org-sql->> sql-str
(-flatten) (-flatten)
(string-join) (string-join)
(format "begin transaction; %s commit;")))) (format "begin transaction; %s commit;")))
(defun nd/org-sql-fmt-multi (tbl fun) (defun nd/org-sql-fmt-multi (tbl fun)
(let ((name (car tbl)) (--map (funcall fun (car tbl) it) (cdr tbl)))
(data (cdr tbl)))
(mapcar (lambda (r) (funcall fun name r)) data)))
(defun nd/org-sql-fmt-inserts (tbl) (defun nd/org-sql-fmt-inserts (tbl)
(nd/org-sql-fmt-multi tbl #'nd/org-sql-fmt-insert)) (nd/org-sql-fmt-multi tbl #'nd/org-sql-fmt-insert))
@ -2823,15 +2822,13 @@ from a plist like '(:prop1 value1 :prop2 value2)."
"Creates a SQL statement for setting pragmas in PLIST. "Creates a SQL statement for setting pragmas in PLIST.
PLIST contains the pragmas as the properties and their intended PLIST contains the pragmas as the properties and their intended
values as the property values." values as the property values."
(let ((pragmas (nd/org-sql->> (let ((pragmas (->> plist
plist plist-get-keys
(plist-get-keys)
(mapcar #'nd/sql-kw-to-colname)))) (mapcar #'nd/sql-kw-to-colname))))
(nd/org-sql->> (->> plist
plist nd/sql-plist-get-vals
(nd/sql-plist-get-vals) (--zip-with (format "PRAGMA %s=%s;" it other) pragmas)
(mapcar* (lambda (p v) (format "PRAGMA %s=%s;" p v)) pragmas) string-join)))
(string-join))))
;; SQL command abstractions ;; SQL command abstractions
(defconst nd/org-sql-default-pragma (defconst nd/org-sql-default-pragma
@ -2863,11 +2860,11 @@ exist) to or instead of (if they already exist) those in
(if (not pragma) (if (not pragma)
nd/org-sql-default-pragma nd/org-sql-default-pragma
(let ((all-props (let ((all-props
(nd/org-sql->> (->>
nd/org-sql-default-pragma nd/org-sql-default-pragma
(plist-get-keys) plist-get-keys
(append (plist-get-keys pragma)) (append (plist-get-keys pragma))
(delete-dups))) delete-dups))
(getv (getv
(lambda (p) (lambda (p)
(or (plist-get pragma p) (or (plist-get pragma p)
@ -2875,24 +2872,36 @@ exist) to or instead of (if they already exist) those in
(mapcan (lambda (p) `(,p ,(funcall getv p))) all-props)))) (mapcan (lambda (p) `(,p ,(funcall getv p))) all-props))))
(defun nd/org-sql-set-pragma (&optional pragma) (defun nd/org-sql-set-pragma (&optional pragma)
(nd/org-sql->> (->> pragma
pragma nd/org-sql-pragma-merge-default
(nd/org-sql-pragma-merge-default) nd/org-sql-fmt-pragma
(nd/org-sql-fmt-pragma) nd/sql-cmd))
(nd/sql-cmd)))
(defun nd/sql-cmd (cmd) (defun nd/sql-cmd (cmd)
"Execute SQL string CMD in SQLi buffer given by `nd/org-sql-buffer'. "Execute SQL string CMD in SQLi buffer given by `nd/org-sql-buffer'.
If buffer process not running, it is started automatically." If buffer process not running, it is started automatically. Returns
the output of CMD as given by the running SQL shell."
(when cmd (when cmd
;; (when (not (sql-find-sqli-buffer 'sqlite)) ;; (when (not (sql-find-sqli-buffer 'sqlite))
;; (nd/org-sql-open-connection)) ;; (nd/org-sql-open-connection))
(nd/with-advice (nd/with-advice
;; this function will throw a "regex too long error" ;; this function will throw a "regex too long error"
((#'looking-at :override #'ignore)) ((#'looking-at :override #'ignore))
(sql-redirect nd/org-sql-buffer cmd nd/org-sql-debug-buffer)))) ;; TODO add a debug option here so the temp buffer is not
;; thrown away
(let ((temp-buf "*SQL: Out*")
(get-output
(lambda (b)
(with-current-buffer b
(let ((out (buffer-substring-no-properties
(point-min)
(point-max))))
(kill-buffer b)
out)))))
(sql-redirect-one nd/org-sql-buffer cmd temp-buf nil)
(->> temp-buf (funcall get-output) string-trim)))))
(defun nd/sql-select (db tbl-name cols &optional conds) (defun nd/sql-select (db tbl-name &optional cols conds)
"Select columns from TBL-NAME in DB where COLS is the list of columns. "Select columns from TBL-NAME in DB where COLS is the list of columns.
If COLS is nil, all columns will be returned. Columns is expected as If COLS is nil, all columns will be returned. Columns is expected as
a list of keywords like ':col1' and :col2'. CONDS, if supplied, is a list of keywords like ':col1' and :col2'. CONDS, if supplied, is
@ -2900,27 +2909,27 @@ a plist of conditions to test in the select statement. (currently
joined by AND)" joined by AND)"
(let* ((colnames (let* ((colnames
(if (not cols) "*" (if (not cols) "*"
(string-join (--> cols
(mapcar (lambda (s) (substring (symbol-name s) 1)) cols) (mapcar #'nd/sql-kw-to-colname it)
","))) (string-join it ","))))
(tbl-str (symbol-name tbl-name)) (tbl-str (symbol-name tbl-name))
(cmd (if (not conds) (cmd (if (not conds)
(format "select %s from %s;" colnames tbl-str) (format "select %s from %s;" colnames tbl-str)
(let ((conds-str (nd/sql-plist-concat conds " and "))) (--> conds
(nd/sql-plist-concat it " and ")
(format "select %s from %s where %s;" colnames (format "select %s from %s where %s;" colnames
tbl-str conds-str)))) tbl-str it)))))
(out (nd/sql-cmd db cmd))) (--> cmd (nd/sql-cmd it) (nd/sql-to-plist it cols))))
(apply #'nd/sql-to-plist out cols)))
(defun nd/sql-delete (db tbl-name conds) (defun nd/sql-delete (db tbl-name conds)
"Delete records from TBL-NAME in DB where CONDS are true. "Delete records from TBL-NAME in DB where CONDS are true.
CONDS is a plist of column names and values, '(:col1 val1 :col2 val2)', CONDS is a plist of column names and values, '(:col1 val1 :col2 val2)',
where values will be deleted if the listed columns have the listed where values will be deleted if the listed columns have the listed
values (AND condition)." values (AND condition)."
(let* ((conds-str (nd/sql-plist-concat " and ")) (--> conds
(cmd (format "delete from %s where %s;" (nd/sql-plist-concat it " and ")
(symbol-name tbl-name) conds-str))) (format "delete from %s where %s;" (symbol-name tbl-name) it)
(nd/sql-cmd db cmd))) (nd/sql-cmd db it)))
(defun nd/sql-update (db tbl-name update conds) (defun nd/sql-update (db tbl-name update conds)
"Update records in TBL-NAME in DB with UPDATE where CONDS are true. "Update records in TBL-NAME in DB with UPDATE where CONDS are true.
@ -2928,19 +2937,20 @@ VALUES is a plist containing the columns and new values as
'(col1: newval1 col2: newval2) and CONDS is a similar plist '(col1: newval1 col2: newval2) and CONDS is a similar plist
where columns in UPDATE will be updated if values matching those in where columns in UPDATE will be updated if values matching those in
CONDS are found (AND condition)." CONDS are found (AND condition)."
(let* ((upd-str (nd/sql-plist-concat update)) (let ((conds-str (nd/sql-plist-to-condition conds " and ")))
(conds-str (nd/sql-plist-to-condition conds " and ")) (--> update
(cmd (format "update %s set %s where %s;" (nd/sql-plist-concat it)
(symbol-name tbl-name) upd-str conds-str))) (format "update %s set %s where %s;"
(nd/sql-cmd db cmd))) (symbol-name tbl-name) it conds-str)
(nd/sql-cmd db it))))
(defun nd/sql-insert (db tbl-name tbl-data) ;; (defun nd/sql-insert (db tbl-name tbl-data)
"Insert list TBL-DATA into TBL-NAME in sqlite database DB." ;; "Insert list TBL-DATA into TBL-NAME in sqlite database DB."
(nd/sql-cmd db (nd/sql-construct-insertion tbl-name tbl-data))) ;; (nd/sql-cmd db (nd/sql-construct-insertion tbl-name tbl-data)))
(defun nd/sql-insert-multi (db all-data) ;; (defun nd/sql-insert-multi (db all-data)
"Insert ALL-DATA into sqlite DB." ;; "Insert ALL-DATA into sqlite DB."
(nd/sql-cmd db (nd/sql-construct-insert-transaction all-data))) ;; (nd/sql-cmd db (nd/sql-construct-insert-transaction all-data)))
#+END_SRC #+END_SRC
**** org parsing function **** org parsing function
Basic functions to parse org strings Basic functions to parse org strings
@ -2967,12 +2977,10 @@ throw an error if the string is not recognized."
(defun nd/org-ts-format-to-iso (ts) (defun nd/org-ts-format-to-iso (ts)
"Return org timestamp TS to as string in ISO 8601 format. "Return org timestamp TS to as string in ISO 8601 format.
If TS is nil or TS cannot be understood, nil will be returned." If TS is nil or TS cannot be understood, nil will be returned."
(when ts (-some-->
;; org-parse-time-string (used in org-2ft) does not save match data ts
(let ((ft (save-match-data (org-2ft ts)))) (save-match-data (org-2ft it))
;; assume that nobody is going to need jan 1 1970 (when (> it 0) (format-time-string "%Y-%m-%dT%H:%M:00" it))))
(when (> ft 0)
(format-time-string "%Y-%m-%dT%H:%M:00" ft)))))
#+END_SRC #+END_SRC
**** org sql schemas **** org sql schemas
so the emacs sql frontend apparently complains about newlines :( so the emacs sql frontend apparently complains about newlines :(
@ -2995,11 +3003,15 @@ These are functions that operate on org-element objects to parse for insertion i
(defun nd/org-element-timestamp-raw (prop obj &optional iso) (defun nd/org-element-timestamp-raw (prop obj &optional iso)
"Return the raw-value of the timestamp PROP in OBJ if exists. "Return the raw-value of the timestamp PROP in OBJ if exists.
If ISO is t, return the timestamp in ISO 8601 format." If ISO is t, return the timestamp in ISO 8601 format."
(when obj (-some--> obj
(let ((ts (org-element-property prop obj))) (org-element-property prop it)
(when ts (org-element-property :raw-value it)
(let ((raw-ts (org-element-property :raw-value ts))) (if iso (nd/org-ts-format-to-iso it) it)))
(if iso (nd/org-ts-format-to-iso raw-ts) raw-ts)))))) ;; (when obj
;; (let ((ts (org-element-property prop obj)))
;; (when ts
;; (let ((raw-ts (org-element-property :raw-value ts)))
;; (if iso (nd/org-ts-format-to-iso raw-ts) raw-ts))))))
;; TODO this is entirely redundant and can be replaced with assoc ;; TODO this is entirely redundant and can be replaced with assoc
;; (defun nd/org-element-find-type (type obj) ;; (defun nd/org-element-find-type (type obj)
@ -3048,9 +3060,10 @@ Returns '/' delimited path of headlines or nil if obj is in a toplevel
headline." headline."
(let ((parent-hl (nd/org-element-get-parent-headline obj))) (let ((parent-hl (nd/org-element-get-parent-headline obj)))
(if parent-hl (if parent-hl
(let* ((txt (org-element-property :raw-value parent-hl)) (--> parent-hl
(new-acc (concat "/" txt acc))) (org-element-property :raw-value it)
(nd/org-element-get-parent-tree parent-hl new-acc)) (concat "/" it acc)
(nd/org-element-get-parent-tree parent-hl it))
acc))) acc)))
(defun nd/org-element-get-parent-tags (obj &optional acc) (defun nd/org-element-get-parent-tags (obj &optional acc)
@ -3058,7 +3071,7 @@ headline."
ACC is treated as a set; therefore no duplicates are retained." ACC is treated as a set; therefore no duplicates are retained."
(let ((parent-hl (nd/org-element-get-parent-headline obj))) (let ((parent-hl (nd/org-element-get-parent-headline obj)))
(if parent-hl (if parent-hl
(let* ((tags (nd/org-sql->> (let* ((tags (->>
parent-hl parent-hl
(org-element-property :tags) (org-element-property :tags)
(mapcar #'nd/strip-string))) (mapcar #'nd/strip-string)))
@ -3076,9 +3089,9 @@ parent until found or return nil if unfruitful."
(let ((prop-val (org-element-property prop obj))) (let ((prop-val (org-element-property prop obj)))
(or (or
prop-val prop-val
(let ((parent (org-element-property :parent obj))) (->> obj
(nd/org-element-property-inherited prop parent)))))) (org-element-property :parent)
(nd/org-element-property-inherited prop))))))
#+END_SRC #+END_SRC
**** org sql constants and variables **** org sql constants and variables
#+BEGIN_SRC emacs-lisp #+BEGIN_SRC emacs-lisp
@ -3121,12 +3134,12 @@ and cdr is the match data."
"Return `org-todo-keywords' as string list w/o selectors. "Return `org-todo-keywords' as string list w/o selectors.
Will likely match the value of `org-todo-keywords-1' in many cases, Will likely match the value of `org-todo-keywords-1' in many cases,
but this has the advantage of being always available and comprehensive." but this has the advantage of being always available and comprehensive."
(nd/org-sql->> (->>
org-todo-keywords org-todo-keywords
(copy-tree) copy-tree
(mapcan #'cdr) (mapcan #'cdr)
(remove "|") (remove "|")
(mapcar (lambda (s) (replace-regexp-in-string "(.*)" "" s))))) (--map (replace-regexp-in-string "(.*)" "" it))))
(defun nd/org-log-note-headings-matcher () (defun nd/org-log-note-headings-matcher ()
"Convert `org-log-note-headings' to a regex matcher. "Convert `org-log-note-headings' to a regex matcher.
@ -3134,31 +3147,28 @@ See `org-log-note-headings' for escape sequences that are matched
and replaces by regexps that match what would be inserted in place and replaces by regexps that match what would be inserted in place
of the escapes." of the escapes."
(let* ((escapes '("%u" "%U" "%t" "%T" "%d" "%D" "%s" "%S")) (let* ((escapes '("%u" "%U" "%t" "%T" "%d" "%D" "%s" "%S"))
(todo-list (nd/org-todo-keywords-stripped)) (ts-or-todo-regexp
(todo-regexp (mapconcat #'regexp-quote todo-list "\\|")) (-->
(ts-or-todo-regexp (format "\"\\(%s\\|%s\\)\"" (nd/org-todo-keywords-stripped)
org-ts-regexp-inactive (mapconcat #'regexp-quote it "\\|")
todo-regexp)) (format "\"\\(%s\\|%s\\)\"" org-ts-regexp-inactive it)))
(org-ts-regexp-cap (format "\\(%s\\)" org-ts-regexp)) (ts-regexp (format "\\(%s\\)" org-ts-regexp))
(org-ts-regexp-inactive-cap (format "\\(%s\\)" org-ts-regexp-inactive)) (ts-ia-regexp (format "\\(%s\\)" org-ts-regexp-inactive))
(re-no-pad-alist (mapcar* #'cons escapes escapes)) (re-no-pad-alist (-zip-pair escapes escapes))
(re-match-alist (re-match-alist
(nd/org-sql->> (->>
(list ".*" (list "\\(.*\\)"
".*" "\\(.*\\)"
org-ts-regexp-inactive-cap ts-ia-regexp
org-ts-regexp-cap ts-regexp
org-ts-regexp-inactive-cap ts-ia-regexp
org-ts-regexp-cap ts-regexp
ts-or-todo-regexp ts-or-todo-regexp
ts-or-todo-regexp) ts-or-todo-regexp)
(mapcar (lambda (s) (concat "[[:space:]]*" s "[[:space:]]*"))) (--map (concat "[[:space:]]*" it "[[:space:]]*"))
(mapcar* #'cons escapes))) (-zip-pair escapes)))
(apply2note (apply2note
(lambda (n f) (lambda (n f) (cons (car n) (funcall f (cdr n)))))
(let ((note-type (car n))
(note-str (cdr n)))
(cons note-type (funcall f note-str)))))
(replace-esc (replace-esc
(lambda (n re) (lambda (n re)
(funcall apply2note (funcall apply2note
@ -3169,15 +3179,15 @@ of the escapes."
(funcall apply2note (funcall apply2note
n n
(lambda (s) (replace-regexp-in-string "\s+" " " s)))))) (lambda (s) (replace-regexp-in-string "\s+" " " s))))))
(nd/org-sql->> (->>
org-log-note-headings org-log-note-headings
;; remove padding information by replacing all escape sequences ;; remove padding information by replacing all escape sequences
;; with their non-padded version and then removing extra spaces ;; with their non-padded version and then removing extra spaces
(mapcar (lambda (n) (funcall replace-esc n re-no-pad-alist))) (--map (funcall replace-esc it re-no-pad-alist))
(mapcar (lambda (n) (funcall shrink-space n))) (--map (funcall shrink-space it))
;; replace all escape sequences with regexps that match ;; replace all escape sequences with regexps that match
;; the data to be inserted via the escape sequences ;; the data to be inserted via the escape sequences
(mapcar (lambda (n) (funcall replace-esc n re-match-alist))) (--map (funcall replace-esc it re-match-alist))
;; filter out anything that is blank (eg default clock-in) ;; filter out anything that is blank (eg default clock-in)
(seq-filter (lambda (s) (not (equal (cdr s) ""))))))) (seq-filter (lambda (s) (not (equal (cdr s) "")))))))
@ -3188,32 +3198,32 @@ escape sequences.")
#+END_SRC #+END_SRC
**** org sql partioning functions **** org sql partioning functions
#+BEGIN_SRC emacs-lisp #+BEGIN_SRC emacs-lisp
(defun nd/org-sql-partion-headling-section (contents &optional acc) ;; (defun nd/org-sql-partion-headling-section (contents &optional acc)
"Partition list of org-elements CONTENTS into accumulator ACC. ;; "Partition list of org-elements CONTENTS into accumulator ACC.
When finished return ACC. ACC will hold an alist structured as described ;; When finished return ACC. ACC will hold an alist structured as described
in `nd/org-element-partition-headline', except this function does not ;; in `nd/org-element-partition-headline', except this function does not
deal with the subheadings or headline-properties." ;; deal with the subheadings or headline-properties."
(if (not contents) ;; (if (not contents)
acc ;; acc
(let* ((cur (car contents)) ;; (let* ((cur (car contents))
(rem (cdr contents)) ;; (rem (cdr contents))
(type (org-element-type cur)) ;; (type (org-element-type cur))
(acc* ;; (acc*
(cond ;; (cond
((eq type 'planning) ;; ((eq type 'planning)
(nd/alist-put acc :planning cur)) ;; (nd/alist-put acc :planning cur))
((eq type 'property-drawer) ;; ((eq type 'property-drawer)
;; TODO maybe filter for non-node-props here??? ;; ;; TODO maybe filter for non-node-props here???
(let ((node-props (org-element-contents cur))) ;; (let ((node-props (org-element-contents cur)))
(nd/alist-put acc :node-props node-props))) ;; (nd/alist-put acc :node-props node-props)))
((eq type 'drawer) ;; ((eq type 'drawer)
(let ((name (org-element-property :drawer-name cur))) ;; (let ((name (org-element-property :drawer-name cur)))
(if (equal name org-log-into-drawer) ;; (if (equal name org-log-into-drawer)
(let ((lb-contents (org-element-contents cur))) ;; (let ((lb-contents (org-element-contents cur)))
(nd/alist-put acc :logbook lb-contents)) ;; (nd/alist-put acc :logbook lb-contents))
(nd/alist-put acc :hl-contents cur)))) ;; (nd/alist-put acc :hl-contents cur))))
(t (nd/alist-put acc :hi-contents cur))))) ;; (t (nd/alist-put acc :hi-contents cur)))))
(nd/org-sql-partion-headling-section rem acc*)))) ;; (nd/org-sql-partion-headling-section rem acc*))))
(defun nd/org-sql-partition-headline (headline fp) (defun nd/org-sql-partition-headline (headline fp)
"For org-element HEADLINE and file path FP, return an alist. "For org-element HEADLINE and file path FP, return an alist.
@ -3233,16 +3243,12 @@ are missing, nil will be returned."
(unless headline (error "No headline given")) (unless headline (error "No headline given"))
(unless fp (error "No file path given")) (unless fp (error "No file path given"))
(let* ((hl-contents (org-element-contents headline)) (let* ((hl-contents (org-element-contents headline))
(section (assoc 'section hl-contents)) (section (->> hl-contents (assoc 'section) org-element-contents))
(section (org-element-contents section))
(subheadlines (if section (cdr hl-contents) hl-contents))) (subheadlines (if section (cdr hl-contents) hl-contents)))
`((:headline . ,headline) `((:headline . ,headline)
(:filepath . ,fp) (:filepath . ,fp)
(:section . ,section) (:section . ,section)
(:subheadlines . ,subheadlines)))) (:subheadlines . ,subheadlines))))
;; (when section
;; (let ((sec-contents (org-element-contents section)))
;; (nd/org-sql-partion-headling-section sec-contents hl-part)))))
(defun nd/org-sql-partition-item (item hl-part) (defun nd/org-sql-partition-item (item hl-part)
"Parse an org-element ITEM which is assumed to be part of a logbook. "Parse an org-element ITEM which is assumed to be part of a logbook.
@ -3265,15 +3271,15 @@ Anatomy of a logbook item (non-clocking):
- another header-text linebreak - another header-text linebreak
The header text is solely used for determining :type and :match-data." The header text is solely used for determining :type and :match-data."
(let* ((paragraph (assoc 'paragraph item)) (let* ((contents (->> item (assoc 'paragraph) org-element-contents))
(contents (org-element-contents paragraph)) (header-text (->> contents
;; split entry into right / left components via linebreak (nd/org-element-split-by-type 'line-break)
(left (nd/org-element-split-by-type 'line-break contents)) org-element-interpret-data
(right (nd/org-element-split-by-type 'line-break contents t)) nd/strip-string))
(header-text (string-trim (substring-no-properties (note-text (--> contents
(org-element-interpret-data left)))) (nd/org-element-split-by-type 'line-break it t)
(note-text (string-trim (substring-no-properties org-element-interpret-data
(org-element-interpret-data right)))) nd/strip-string))
(header-match (nd/org-logbook-match-header header-text))) (header-match (nd/org-logbook-match-header header-text)))
`((:item . ,item) `((:item . ,item)
(:hl-part . ,hl-part) (:hl-part . ,hl-part)
@ -3320,8 +3326,9 @@ nothing is added if a match is not found."
:state_new state-new))) :state_new state-new)))
(nd/alist-put acc 'state_changes state-data))) (nd/alist-put acc 'state_changes state-data)))
((memq type '(reschedule delschedule redeadline deldeadline)) ((memq type '(reschedule delschedule redeadline deldeadline))
(let* ((time-old (nd/org-ts-format-to-iso (let* ((time-old (->> header-text
(match-string 1 header-text))) (match-string 1)
nd/org-ts-format-to-iso))
(planning-kw (if (memq type '(reschedule delschedule)) (planning-kw (if (memq type '(reschedule delschedule))
:scheduled :scheduled
:deadline)) :deadline))
@ -3347,11 +3354,13 @@ ITEM-PART is a partitioned logbook item as described in
(cond (cond
((memq type '(done note refile)) 1) ((memq type '(done note refile)) 1)
((memq type '(reschedule delschedule redeadline deldeadline)) 3) ((memq type '(reschedule delschedule redeadline deldeadline)) 3)
((eq type 'state) 5))) ((eq type 'state) 5))))
(header-text (alist-get :header-text item-part)))
(when time-index (when time-index
(set-match-data (alist-get :match-data item-part)) (set-match-data (alist-get :match-data item-part))
(nd/org-ts-format-to-iso (match-string time-index header-text))))) (->> item-part
(alist-get :header-text)
(match-string time-index)
nd/org-ts-format-to-iso))))
(defun nd/org-sql-extract-lb-entry (acc item-part) (defun nd/org-sql-extract-lb-entry (acc item-part)
"Add data from logbook entry ITEM-PART to accumulator ACC. "Add data from logbook entry ITEM-PART to accumulator ACC.
@ -3372,8 +3381,7 @@ ITEM-PART is a partitioned logbook item as described in
:time_logged time-logged :time_logged time-logged
:header hdr-text :header hdr-text
:note note-text))) :note note-text)))
(nd/org-sql-> (-> acc
acc
(nd/alist-put 'logbook logbook-data) (nd/alist-put 'logbook logbook-data)
(nd/org-sql-extract-lb-header item-part)))) (nd/org-sql-extract-lb-header item-part))))
@ -3383,10 +3391,10 @@ Return value will be a list of two elements if range and one if not."
(when ts (when ts
(let ((split (let ((split
(lambda (ts &optional end) (lambda (ts &optional end)
(nd/org-ts-format-to-iso (->>
(org-element-property (org-timestamp-split-range ts end)
:raw-value (org-element-property :raw-value)
(org-timestamp-split-range ts end)))))) nd/org-ts-format-to-iso))))
(if (eq (org-element-property :type ts) 'inactive-range) (if (eq (org-element-property :type ts) 'inactive-range)
(let ((start (funcall split ts)) (let ((start (funcall split ts))
(end (funcall split ts t))) (end (funcall split ts t)))
@ -3403,8 +3411,9 @@ added to the clock, else add it as a normal logbook entry."
(fp (alist-get :filepath hl-part)) (fp (alist-get :filepath hl-part))
(hl-offset (org-element-property :begin hl)) (hl-offset (org-element-property :begin hl))
(cl-offset (org-element-property :begin clock)) (cl-offset (org-element-property :begin clock))
(ts-obj (org-element-property :value clock)) (ts-range (->> clock
(ts-range (nd/org-logbook-parse-timestamp-range ts-obj)) (org-element-property :value)
nd/org-logbook-parse-timestamp-range))
(start (car ts-range)) (start (car ts-range))
(end (cdr ts-range)) (end (cdr ts-range))
(clock-data (list :file_path fp (clock-data (list :file_path fp
@ -3417,16 +3426,16 @@ added to the clock, else add it as a normal logbook entry."
(let* ((item-part (nd/org-sql-partition-item item hl-part)) (let* ((item-part (nd/org-sql-partition-item item hl-part))
(item-type (alist-get :type item-part))) (item-type (alist-get :type item-part)))
(if item-type (if item-type
;; if we know the type, add the clock and note ;; if we know the type, add the clock and note separately
;; separately (-> acc
(nd/org-sql->
acc
(nd/alist-put 'clocking clock-data) (nd/alist-put 'clocking clock-data)
(nd/org-sql-extract-lb-entry item-part)) (nd/org-sql-extract-lb-entry item-part))
;; else add it with the clocking table ;; else add it with the clocking table
(let* ((hdr-text (alist-get :header-text item-part)) (->> item-part
(clock-data* `(,@clock-data :clock_note ,hdr-text))) (alist-get :header-text)
(nd/alist-put acc 'clocking clock-data*))))))) (list :clock_note)
(append clock-data)
(nd/alist-put acc 'clocking)))))))
(defun nd/org-sql-extract-lb-items (acc items hl-part) (defun nd/org-sql-extract-lb-items (acc items hl-part)
"Add data from logbook ITEMS to accumulator ACC. "Add data from logbook ITEMS to accumulator ACC.
@ -3434,8 +3443,9 @@ HL-PART is an object as returned by `nd/org-sql-partition-headline'
and represents the headline surrounding the items." and represents the headline surrounding the items."
(let ((from (let ((from
(lambda (acc item hl-part) (lambda (acc item hl-part)
(let ((item-part (nd/org-sql-partition-item item hl-part))) (->> hl-part
(nd/org-sql-extract-lb-entry acc item-part))))) (nd/org-sql-partition-item item)
(nd/org-sql-extract-lb-entry acc)))))
(nd/org-sql-extract acc from items hl-part))) (nd/org-sql-extract acc from items hl-part)))
(defun nd/org-sql-extract-lb-one (acc entry hl-part) (defun nd/org-sql-extract-lb-one (acc entry hl-part)
@ -3447,8 +3457,9 @@ and represents the headline surrounding the entry."
((eq type 'clock) ((eq type 'clock)
(nd/org-sql-extract-lb-clock acc entry hl-part)) (nd/org-sql-extract-lb-clock acc entry hl-part))
((eq type 'plain-list) ((eq type 'plain-list)
(let ((items (org-element-contents entry))) (--> entry
(nd/org-sql-extract-lb-items acc items hl-part))) (org-element-contents it)
(nd/org-sql-extract-lb-items acc it hl-part)))
;; TODO add an "UNKNOWN" logbook parser ;; TODO add an "UNKNOWN" logbook parser
(t acc)))) (t acc))))
@ -3461,28 +3472,32 @@ will check if the first item in ENTRY2 is part of the clock."
(let* ((items (org-element-contents entry2)) (let* ((items (org-element-contents entry2))
(first-item (car items)) (first-item (car items))
(rem-items (cdr items))) (rem-items (cdr items)))
(nd/org-sql-> (-> acc
acc
(nd/org-sql-extract-lb-clock entry1 hl-part first-item) (nd/org-sql-extract-lb-clock entry1 hl-part first-item)
(nd/org-sql-extract-lb-items rem-items hl-part)))) (nd/org-sql-extract-lb-items rem-items hl-part))))
(defun nd/org-sql-find-logbook (contents) ;; (defun nd/org-sql-find-logbook (contents)
"Find the logbook drawer given CONTENTS from section of org headline. ;; "Find the logbook drawer given CONTENTS from section of org headline.
Returns a list of the contents in the logbook. Note this assumes ;; Returns a list of the contents in the logbook. Note this assumes
the `org-log-into-drawer' is set and that there is one drawer per ;; the `org-log-into-drawer' is set and that there is one drawer per
headline matching this value. Additional logbook drawers will be ;; headline matching this value. Additional logbook drawers will be
ignored." ;; ignored."
(org-element-contents ;; (org-element-contents
(rassoc-if ;; (rassoc-if
(lambda (e) ;; (lambda (e)
(equal org-log-into-drawer (plist-get (car e) :drawer-name))) ;; (equal org-log-into-drawer (plist-get (car e) :drawer-name)))
contents))) ;; contents)))
(defun nd/org-sql-extract-lb (acc hl-part) (defun nd/org-sql-extract-lb (acc hl-part)
"Add logbook data from HL-PART and add to accumulator ACC. "Add logbook data from HL-PART and add to accumulator ACC.
HL-PART is an object as returned by `nd/org-sql-partition-headline'." HL-PART is an object as returned by `nd/org-sql-partition-headline'."
(let* ((sec (alist-get :section hl-part)) (let* ((lb-contents
(lb-contents (nd/org-sql-find-logbook sec))) (->>
hl-part
(alist-get :section)
(--first (equal org-log-into-drawer
(org-element-property :drawer-name it)))
org-element-contents)))
(while lb-contents (while lb-contents
;; Need two of the next entries here because clocks may ;; Need two of the next entries here because clocks may
;; have notes associated with them, but the only ;; have notes associated with them, but the only
@ -3507,14 +3522,15 @@ HL-PART is an object as returned by `nd/org-sql-partition-headline'."
"If TXT is a timestamp, return it in ISO 8601 format. "If TXT is a timestamp, return it in ISO 8601 format.
Otherwise return it unchanged." Otherwise return it unchanged."
;; assume the iso parser to return nil on failure ;; assume the iso parser to return nil on failure
(nd/org-sql-> txt (nd/org-ts-format-to-iso) (or txt))) (-> txt nd/org-ts-format-to-iso (or txt)))
(defun nd/org-sql-extract-properties (acc hl-part) (defun nd/org-sql-extract-properties (acc hl-part)
"Add properties data from HL-PART and add to accumulator ACC. "Add properties data from HL-PART and add to accumulator ACC.
HL-PART is an object as returned by `nd/org-sql-partition-headline'." HL-PART is an object as returned by `nd/org-sql-partition-headline'."
(let* ((sec (alist-get :section hl-part)) (let ((node-props (->> hl-part
(prop-drawer (assoc 'property-drawer sec)) (alist-get :section)
(node-props (org-element-contents prop-drawer)) (assoc 'property-drawer)
org-element-contents))
(from (from
(lambda (acc np hl-part) (lambda (acc np hl-part)
(let ((key (org-element-property :key np))) (let ((key (org-element-property :key np)))
@ -3524,8 +3540,9 @@ HL-PART is an object as returned by `nd/org-sql-partition-headline'."
(fp (alist-get :filepath hl-part)) (fp (alist-get :filepath hl-part))
(hl-offset (org-element-property :begin hl)) (hl-offset (org-element-property :begin hl))
(np-offset (org-element-property :begin np)) (np-offset (org-element-property :begin np))
(val (org-element-property :value np)) (val (->> np
(val (nd/org-sql-parse-ts-maybe val)) (org-element-property :value)
nd/org-sql-parse-ts-maybe))
(prop-data (list :file_path fp (prop-data (list :file_path fp
:headline_offset hl-offset :headline_offset hl-offset
:property_offset np-offset :property_offset np-offset
@ -3541,14 +3558,14 @@ HL-PART is an object as returned by `nd/org-sql-partition-headline'."
HL-PART is an object as returned by `nd/org-sql-partition-headline'." HL-PART is an object as returned by `nd/org-sql-partition-headline'."
(let* ((hl (alist-get :headline hl-part)) (let* ((hl (alist-get :headline hl-part))
;; first retrieve tags and strip text props and whitespace ;; first retrieve tags and strip text props and whitespace
(tags (nd/org-sql->> hl (tags (->> hl
(org-element-property :tags) (org-element-property :tags)
(mapcar #'nd/strip-string))) (mapcar #'nd/strip-string)))
;; split-string returns nil if it gets "" ;; split-string returns nil if it gets ""
(i-tags (nd/org-sql-> (i-tags (->
(org-element-property :ARCHIVE_ITAGS hl) (org-element-property :ARCHIVE_ITAGS hl)
(or "") (or "")
(split-string))) split-string))
;; then retrieve i-tags, optionally going up to parents ;; then retrieve i-tags, optionally going up to parents
(i-tags (when nd/org-sql-use-tag-inheritance (i-tags (when nd/org-sql-use-tag-inheritance
(nd/org-element-get-parent-tags hl i-tags))) (nd/org-element-get-parent-tags hl i-tags)))
@ -3563,8 +3580,7 @@ HL-PART is an object as returned by `nd/org-sql-partition-headline'."
:tag tag :tag tag
:inherited i))) :inherited i)))
(nd/alist-put acc 'tags tags-data))))) (nd/alist-put acc 'tags tags-data)))))
(nd/org-sql-> (-> acc
acc
(nd/org-sql-extract from tags hl-part) (nd/org-sql-extract from tags hl-part)
(nd/org-sql-extract from i-tags hl-part t)))) (nd/org-sql-extract from i-tags hl-part t))))
@ -3580,11 +3596,10 @@ HL-PART is an object as returned by `nd/org-sql-partition-headline'."
(hl-offset (org-element-property :begin hl)) (hl-offset (org-element-property :begin hl))
(ln-offset (org-element-property :begin ln)) (ln-offset (org-element-property :begin ln))
(ln-path (org-element-property :path ln)) (ln-path (org-element-property :path ln))
(ln-text (nd/org-sql->> (ln-text (->> ln
ln org-element-contents
(org-element-contents) org-element-interpret-data
(org-element-interpret-data) nd/strip-string))
(nd/strip-string)))
(ln-type (org-element-property :type ln)) (ln-type (org-element-property :type ln))
(ln-data (list :file_path fp (ln-data (list :file_path fp
:headline_offset hl-offset :headline_offset hl-offset
@ -3603,14 +3618,18 @@ HL-PART is an object as returned by `nd/org-sql-partition-headline'."
(offset (org-element-property :begin hl)) (offset (org-element-property :begin hl))
(rxv-tp (nd/org-element-get-parent-tree hl)) (rxv-tp (nd/org-element-get-parent-tree hl))
(hl-txt (org-element-property :raw-value hl)) (hl-txt (org-element-property :raw-value hl))
(t-created (org-element-property :CREATED hl)) (t-created (->> hl
(t-created (nd/org-ts-format-to-iso t-created)) (org-element-property :CREATED)
nd/org-ts-format-to-iso))
(t-closed (nd/org-element-timestamp-raw :closed hl t)) (t-closed (nd/org-element-timestamp-raw :closed hl t))
(t-scheduled (nd/org-element-timestamp-raw :scheduled hl t)) (t-scheduled (nd/org-element-timestamp-raw :scheduled hl t))
(t-deadline (nd/org-element-timestamp-raw :deadline hl t)) (t-deadline (nd/org-element-timestamp-raw :deadline hl t))
(kw (nd/strip-string (org-element-property :todo-keyword hl))) (kw (->> hl
(effort (org-element-property :EFFORT hl)) (org-element-property :todo-keyword)
(effort (nd/org-effort-to-int effort t)) nd/strip-string))
(effort (--> hl
(org-element-property :EFFORT it)
(nd/org-effort-to-int it t)))
(priority (org-element-property :priority hl)) (priority (org-element-property :priority hl))
;; TODO, add contents somehow ;; TODO, add contents somehow
;; (hl-contents (plist-get hl-part :hl-contents)) ;; (hl-contents (plist-get hl-part :hl-contents))
@ -3639,7 +3658,7 @@ FP is the path to the file containing the headlines."
(lambda (acc hl fp) (lambda (acc hl fp)
(let* ((hl-part (nd/org-sql-partition-headline hl fp)) (let* ((hl-part (nd/org-sql-partition-headline hl fp))
(hl-sub (alist-get :subheadlines hl-part))) (hl-sub (alist-get :subheadlines hl-part)))
(nd/org-sql-> acc (-> acc
(nd/org-sql-extract-hl-meta hl-part) (nd/org-sql-extract-hl-meta hl-part)
(nd/org-sql-extract-links hl-part) (nd/org-sql-extract-links hl-part)
(nd/org-sql-extract-tags hl-part) (nd/org-sql-extract-tags hl-part)
@ -3653,43 +3672,42 @@ FP is the path to the file containing the headlines."
The results are accumulated in ACC which is returned on exit." The results are accumulated in ACC which is returned on exit."
(let* ((fp (car cell)) (let* ((fp (car cell))
(md5sum (cdr cell)) (md5sum (cdr cell))
(buf (find-file-noselect fp t)) (fsize (->> fp file-attributes file-attribute-size))
(tree (with-current-buffer buf (headlines (-->
(org-element-parse-buffer))) fp
(attr (file-attributes fp)) (find-file-noselect it t)
(fsize (file-attribute-size attr)) (with-current-buffer it (org-element-parse-buffer))
(contents (org-element-contents tree)) (org-element-contents it)
(headlines (if (assoc 'section contents) (if (assoc 'section it) (cdr it) it)))
(cdr contents)
contents))
(file-data (list :file_path fp (file-data (list :file_path fp
:md5 md5sum :md5 md5sum
:size fsize))) :size fsize)))
(nd/org-sql-> (-> acc
acc
(nd/alist-put 'files file-data) (nd/alist-put 'files file-data)
(nd/org-sql-extract-hl headlines fp)))) (nd/org-sql-extract-hl headlines fp))))
(defun nd/org-sql-mk-insert (cell acc) (defun nd/org-sql-mk-insert (cell acc)
(nd/org-sql->> (plist-get acc 'insert) (->> (plist-get acc 'insert)
(nd/org-sql-extract-file cell) (nd/org-sql-extract-file cell)
(plist-put acc 'insert))) (plist-put acc 'insert)))
(defun nd/org-sql-mk-update (cell acc) (defun nd/org-sql-mk-update (cell acc)
(let ((updt-acc (plist-get acc 'update))) (let ((updt-acc (plist-get acc 'update)))
(nd/org-sql->> `((:file_path ,(car cell)) . (:md5 ,(cdr cell))) (->> `((:file_path ,(car cell)) . (:md5 ,(cdr cell)))
(nd/alist-put updt-acc 'files) (nd/alist-put updt-acc 'files)
(plist-put acc 'update)))) (plist-put acc 'update))))
(defun nd/org-sql-mk-delete (cell acc) (defun nd/org-sql-mk-delete (cell acc)
(let ((dlt-acc (plist-get acc 'delete))) (let ((dlt-acc (plist-get acc 'delete)))
(nd/org-sql->> `(:file_path ,(car cell)) (->> `(:file_path ,(car cell))
(nd/alist-put dlt-acc 'files) (nd/alist-put dlt-acc 'files)
(plist-put acc 'delete)))) (plist-put acc 'delete))))
(defun nd/org-sql-get-updates (cell fp-qry acc) (defun nd/org-sql-get-updates (cell fp-qry acc)
"Returns cell where the car is accumulator ACC and cdr is current fp-qry." "Returns cell where the car is accumulator ACC and cdr is current fp-qry."
;; if perfect match, do nothing ;; if perfect match, do nothing
;; TODO can probs rewrite this in a clearer way using partitioning
;; from dash
(if (find cell fp-qry :test #'equal) (if (find cell fp-qry :test #'equal)
(cons acc (remove cell fp-qry)) (cons acc (remove cell fp-qry))
(let* ((match-cells (let* ((match-cells
@ -3728,10 +3746,10 @@ The results are accumulated in ACC which is returned on exit."
(defun nd/org-sql-compare-files (fp-dsk fp-qry) (defun nd/org-sql-compare-files (fp-dsk fp-qry)
(let (acc) (let (acc)
(while fp-dsk (while fp-dsk
(let* ((cur (car fp-dsk)) (let ((found (--> fp-dsk
(rem (cdr fp-dsk)) (car it)
(found (nd/org-sql-get-updates cur fp-qry acc))) (nd/org-sql-get-updates it fp-qry acc))))
(setq fp-dsk rem (setq fp-dsk (cdr fp-dsk)
acc (car found) acc (car found)
fp-qry (cdr found)))) fp-qry (cdr found))))
(if fp-qry (nd/org-sql-mk-delete fp-qry acc)) acc)) (if fp-qry (nd/org-sql-mk-delete fp-qry acc)) acc))
@ -3741,21 +3759,19 @@ The results are accumulated in ACC which is returned on exit."
"A list of org files or directories to put into sql database.") "A list of org files or directories to put into sql database.")
(defun nd/org-sql-files () (defun nd/org-sql-files ()
(nd/org-sql->> (->>
nd/org-sql-files nd/org-sql-files
(mapcar (lambda (f) (if (file-directory-p f) (--map (if (file-directory-p it)
(directory-files f t "\\`.*\\.org\\(_archive\\)?\\'") (directory-files it t "\\`.*\\.org\\(_archive\\)?\\'")
(list f)))) (list it)))
(apply #'append))) (apply #'append)))
(defun nd/org-sql-files-from-disk () (defun nd/org-sql-files-from-disk ()
"Return alist of metadata for filepaths PATHS." "Return alist of metadata for filepaths PATHS."
(let ((paths (nd/org-sql-files)) (let ((cons-md5
(cons-md5
(lambda (fp) (lambda (fp)
(let* ((fp-buf (find-file-noselect fp t))) (--> fp (find-file-noselect it t) (md5 it) (cons fp it)))))
(cons fp (md5 fp-buf)))))) (->> (nd/org-sql-files) (--map (funcall cons-md5 it)))))
(mapcar (lambda (p) (funcall cons-md5 p)) paths)))
(defun nd/org-sql-files-from-db () (defun nd/org-sql-files-from-db ()
"Get all files and their metadata from the database. "Get all files and their metadata from the database.
@ -3764,23 +3780,22 @@ the plist of metadata."
;; TODO should probably make the table recreate itself if it is ;; TODO should probably make the table recreate itself if it is
;; corrupted or missing ;; corrupted or missing
(when (file-exists-p nd/org-sqlite-db-path) (when (file-exists-p nd/org-sqlite-db-path)
(nd/org-sql->> '(:file_path :md5) (->> '(:file_path :md5)
(nd/sql-select nd/org-sqlite-db-path 'files) (nd/sql-select nd/org-sqlite-db-path 'files)
(mapcar #'nd/sql-plist-get-vals) (mapcar #'nd/sql-plist-get-vals)
(mapcar (lambda (q) (cons (car q) (car (cdr q)))))))) (--map (cons (car it) (cadr it))))))
(defun nd/org-sql-get-transactions () (defun nd/org-sql-get-transactions ()
(let ((fp-dsk (nd/org-sql-files-from-disk)) (let ((fp-dsk (nd/org-sql-files-from-disk))
(map-trns (map-trns
(lambda (op fun trans) (lambda (op fun trans)
(nd/org-sql->> (->>
(plist-get trans op) (plist-get trans op)
(mapcar (lambda (s) (funcall fun s))) (--map (funcall fun it))
(nd/org-sql-fmt-trans) nd/org-sql-fmt-trans
(plist-put trans op))))) (plist-put trans op)))))
(nd/org-sql->> (->>
;; (nd/org-sql-files-from-db) (nd/org-sql-files-from-db)
nil
(nd/org-sql-compare-files fp-dsk) (nd/org-sql-compare-files fp-dsk)
(funcall map-trns 'insert #'nd/org-sql-fmt-inserts) (funcall map-trns 'insert #'nd/org-sql-fmt-inserts)
(funcall map-trns 'update #'nd/org-sql-fmt-updates) (funcall map-trns 'update #'nd/org-sql-fmt-updates)
@ -3790,7 +3805,7 @@ the plist of metadata."
"Make a sqlite database for org files if it does not exist already." "Make a sqlite database for org files if it does not exist already."
;; (unless (file-exists-p nd/org-sqlite-db-path) ;; (unless (file-exists-p nd/org-sqlite-db-path)
;; (process-file-shell-command (concat "touch " nd/org-sqlite-db-path)) ;; (process-file-shell-command (concat "touch " nd/org-sqlite-db-path))
(nd/org-sql->> nd/org-sql-schemas (nd/sql-cmd))) (->> nd/org-sql-schemas (mapcar #'nd/sql-cmd)))
(defun nd/org-archive-to-db (&optional show-err) (defun nd/org-archive-to-db (&optional show-err)
"Transfer archive files to sqlite database." "Transfer archive files to sqlite database."