import org-roam elisp as its own library to be used batch
Ryan Rix
parent
0970c1c4ce
commit
2ead0db4ad
|
|
@ -23,3 +23,5 @@ erl_crash.dump
|
|||
arcology-*.tar
|
||||
|
||||
priv/static
|
||||
|
||||
lisp/arcology.db
|
||||
|
|
|
|||
|
|
@ -0,0 +1,34 @@
|
|||
;;; arcology-batch.el --- arcology batch helpers -*- coding: utf-8; lexical-binding: t; -*-
|
||||
|
||||
;; Copyright © 2020 Ryan Rix <ryan@whatthefuck.computer
|
||||
|
||||
;; Author: Ryan Rix <ryan@whatthfuck.computer>
|
||||
;; Version: 1.2.0
|
||||
;; Package-Requires: ((emacs "26.1") (dash "2.13") (f "0.17.2") (s "1.12.0") (org "9.3") (emacsql "3.0.0") (emacsql-sqlite3 "1.0.0"))
|
||||
|
||||
;; This file is NOT part of GNU Emacs.
|
||||
|
||||
;; This program is free software; you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation; either version 3, or (at your option)
|
||||
;; any later version.
|
||||
;;
|
||||
;; This program is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
;;
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with GNU Emacs; see the file COPYING. If not, write to the
|
||||
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, USA.
|
||||
|
||||
;;; Commentary:
|
||||
;;
|
||||
;; This library sets up an `emacs -Q --batch' for arcology database building.
|
||||
;;
|
||||
;;; Code:
|
||||
(load-file "~/org/cce/packaging.el")
|
||||
(add-to-list 'load-path default-directory)
|
||||
|
||||
(setq arcology-directory "~/org/")
|
||||
|
|
@ -0,0 +1,530 @@
|
|||
;;; arcology-db.el --- arcology database API -*- coding: utf-8; lexical-binding: t; -*-
|
||||
|
||||
;; Copyright © 2020 Jethro Kuan <jethrokuan95@gmail.com>
|
||||
|
||||
;; Author: Jethro Kuan <jethrokuan95@gmail.com>
|
||||
;; URL: https://github.com/org-roam/org-roam
|
||||
;; Keywords: org-mode, roam, convenience
|
||||
;; Version: 1.2.0
|
||||
;; Package-Requires: ((emacs "26.1") (dash "2.13") (f "0.17.2") (s "1.12.0") (org "9.3") (emacsql "3.0.0") (emacsql-sqlite3 "1.0.0"))
|
||||
|
||||
;; This file is NOT part of GNU Emacs.
|
||||
|
||||
;; This program is free software; you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation; either version 3, or (at your option)
|
||||
;; any later version.
|
||||
;;
|
||||
;; This program is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
;;
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with GNU Emacs; see the file COPYING. If not, write to the
|
||||
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, USA.
|
||||
|
||||
;;; Commentary:
|
||||
;;
|
||||
;; This library is provides the underlying database api to arcology
|
||||
;;
|
||||
;;; Code:
|
||||
;;;; Library Requires
|
||||
(eval-when-compile (require 'subr-x))
|
||||
(require 'emacsql)
|
||||
(require 'emacsql-sqlite3)
|
||||
(require 'seq)
|
||||
(require 'arcology-macs)
|
||||
|
||||
(defvar arcology-directory)
|
||||
(defvar arcology-verbose)
|
||||
(defvar arcology-file-name)
|
||||
|
||||
(declare-function arcology--arcology-file-p "arcology")
|
||||
(declare-function arcology--extract-titles "arcology")
|
||||
(declare-function arcology--extract-ref "arcology")
|
||||
(declare-function arcology--extract-tags "arcology")
|
||||
(declare-function arcology--extract-headlines "arcology")
|
||||
(declare-function arcology--extract-links "arcology")
|
||||
(declare-function arcology--extract-keywords "arcology")
|
||||
(declare-function arcology--list-all-files "arcology")
|
||||
|
||||
;;;; Options
|
||||
(defcustom arcology-db-location nil
|
||||
"The full path to file where the arcology database is stored.
|
||||
If this is non-nil, the arcology sqlite database is saved here.
|
||||
|
||||
It is the user's responsibility to set this correctly, especially
|
||||
when used with multiple arcology instances."
|
||||
:type 'string
|
||||
:group 'arcology)
|
||||
|
||||
(defconst arcology-db--version 1)
|
||||
|
||||
(defvar arcology-db--connection (make-hash-table :test #'equal)
|
||||
"Database connection to arcology database.")
|
||||
|
||||
;;;; Core Functions
|
||||
(defun arcology-db--get ()
|
||||
"Return the sqlite db file."
|
||||
(or arcology-db-location
|
||||
(expand-file-name "arcology.db" default-directory)))
|
||||
|
||||
(defun arcology-db--get-connection ()
|
||||
"Return the database connection, if any."
|
||||
(gethash (file-truename arcology-directory)
|
||||
arcology-db--connection))
|
||||
|
||||
(defun arcology-db ()
|
||||
"Entrypoint to the arcology sqlite database.
|
||||
Initializes and stores the database, and the database connection.
|
||||
Performs a database upgrade when required."
|
||||
(unless (and (arcology-db--get-connection)
|
||||
(emacsql-live-p (arcology-db--get-connection)))
|
||||
(let* ((db-file (arcology-db--get))
|
||||
(init-db (not (file-exists-p db-file))))
|
||||
(make-directory (file-name-directory db-file) t)
|
||||
(let ((conn (emacsql-sqlite3 db-file)))
|
||||
(set-process-query-on-exit-flag (emacsql-process conn) nil)
|
||||
(puthash (file-truename arcology-directory)
|
||||
conn
|
||||
arcology-db--connection)
|
||||
(when init-db
|
||||
(arcology-db--init conn))
|
||||
(let* ((version (caar (emacsql conn "PRAGMA user_version")))
|
||||
(version (arcology-db--update-maybe conn version)))
|
||||
(cond
|
||||
((> version arcology-db--version)
|
||||
(emacsql-close conn)
|
||||
(user-error
|
||||
"The arcology database was created with a newer arcology version. "
|
||||
"You need to update the arcology package"))
|
||||
((< version arcology-db--version)
|
||||
(emacsql-close conn)
|
||||
(error "BUG: The arcology database scheme changed %s"
|
||||
"and there is no upgrade path")))))))
|
||||
(arcology-db--get-connection))
|
||||
|
||||
;;;; Entrypoint: (arcology-db-query)
|
||||
(defun arcology-db-query (sql &rest args)
|
||||
"Run SQL query on arcology database with ARGS.
|
||||
SQL can be either the emacsql vector representation, or a string."
|
||||
(if (stringp sql)
|
||||
(emacsql (arcology-db) (apply #'format sql args))
|
||||
(apply #'emacsql (arcology-db) sql args)))
|
||||
|
||||
;;;; Schemata
|
||||
(defconst arcology-db--table-schemata
|
||||
'((files
|
||||
[(file :unique :primary-key)
|
||||
(hash :not-null)
|
||||
(meta :not-null)])
|
||||
|
||||
(headlines
|
||||
[(id :unique :primary-key)
|
||||
(file :not-null)])
|
||||
|
||||
(links
|
||||
[(from :not-null)
|
||||
(to :not-null)
|
||||
(type :not-null)
|
||||
(content :not-null)
|
||||
(properties :not-null)])
|
||||
|
||||
(tags
|
||||
[(file :unique :primary-key)
|
||||
tag])
|
||||
|
||||
(titles
|
||||
[(file :not-null)
|
||||
title])
|
||||
|
||||
(refs
|
||||
[(ref :unique :not-null)
|
||||
(file :not-null)
|
||||
(type :not-null)])
|
||||
|
||||
(keywords
|
||||
[(file :not-null)
|
||||
(keyword :not-null)
|
||||
(value :not-null)])))
|
||||
|
||||
(defun arcology-db--init (db)
|
||||
"Initialize database DB with the correct schema and user version."
|
||||
(emacsql-with-transaction db
|
||||
(pcase-dolist (`(,table . ,schema) arcology-db--table-schemata)
|
||||
(emacsql db [:create-table $i1 $S2] table schema))
|
||||
(emacsql db (format "PRAGMA user_version = %s" arcology-db--version))))
|
||||
|
||||
(defun arcology-db--update-maybe (db version)
|
||||
"Upgrades the database schema for DB, if VERSION is old."
|
||||
(emacsql-with-transaction db
|
||||
'ignore
|
||||
(if (< version arcology-db--version)
|
||||
(progn
|
||||
(arcology-message (format "Upgrading the arcology database from version %d to version %d"
|
||||
version arcology-db--version))
|
||||
(arcology-db-build-cache t))))
|
||||
version)
|
||||
|
||||
(defun arcology-db--close (&optional db)
|
||||
"Closes the database connection for database DB.
|
||||
If DB is nil, closes the database connection for the database in
|
||||
the current `arcology-directory'."
|
||||
(unless db
|
||||
(setq db (arcology-db--get-connection)))
|
||||
(when (and db (emacsql-live-p db))
|
||||
(emacsql-close db)))
|
||||
|
||||
(defun arcology-db--close-all ()
|
||||
"Closes all database connections made by arcology."
|
||||
(dolist (conn (hash-table-values arcology-db--connection))
|
||||
(arcology-db--close conn)))
|
||||
|
||||
;;;; Database API
|
||||
;;;;; Initialization
|
||||
(defun arcology-db--initialized-p ()
|
||||
"Whether the cache has been initialized."
|
||||
(and (file-exists-p (arcology-db--get))
|
||||
(> (caar (arcology-db-query [:select (funcall count) :from titles]))
|
||||
0)))
|
||||
|
||||
(defun arcology-db--ensure-built ()
|
||||
"Ensures that arcology cache is built."
|
||||
(unless (arcology-db--initialized-p)
|
||||
(error "[arcology] your cache isn't built yet! Please run arcology-db-build-cache")))
|
||||
|
||||
;;;;; Clearing
|
||||
(defun arcology-db--clear ()
|
||||
"Clears all entries in the caches."
|
||||
(interactive)
|
||||
(when (file-exists-p (arcology-db--get))
|
||||
(dolist (table (mapcar #'car arcology-db--table-schemata))
|
||||
(arcology-db-query `[:delete :from ,table]))))
|
||||
|
||||
(defun arcology-db--clear-file (&optional filepath)
|
||||
"Remove any related links to the file at FILEPATH.
|
||||
This is equivalent to removing the node from the graph."
|
||||
(let ((file (file-truename (or filepath
|
||||
(buffer-file-name (buffer-base-buffer))))))
|
||||
(dolist (table (mapcar #'car arcology-db--table-schemata))
|
||||
(arcology-db-query `[:delete :from ,table
|
||||
:where (= ,(if (eq table 'links) 'from 'file) $s1)]
|
||||
file))))
|
||||
|
||||
;;;;; Insertion
|
||||
(defun arcology-db--insert-meta (file hash meta)
|
||||
"Insert HASH and META for a FILE into the arcology cache."
|
||||
(arcology-db-query
|
||||
[:insert :into files
|
||||
:values $v1]
|
||||
(list (vector file hash meta))))
|
||||
|
||||
(defun arcology-db--insert-links (links)
|
||||
"Insert LINKS into the arcology cache."
|
||||
(arcology-db-query
|
||||
[:insert :into links
|
||||
:values $v1]
|
||||
links))
|
||||
|
||||
(defun arcology-db--insert-titles (file titles)
|
||||
"Insert TITLES for a FILE into the arcology cache."
|
||||
(arcology-db-query
|
||||
[:insert :into titles
|
||||
:values $v1]
|
||||
(list (vector file titles))))
|
||||
|
||||
(defun arcology-db--insert-headlines (headlines)
|
||||
"Insert HEADLINES into the arcology cache."
|
||||
(arcology-db-query
|
||||
[:insert :into headlines
|
||||
:values $v1]
|
||||
headlines))
|
||||
|
||||
(defun arcology-db--insert-tags (file tags)
|
||||
"Insert TAGS for a FILE into the arcology cache."
|
||||
(arcology-db-query
|
||||
[:insert :into tags
|
||||
:values $v1]
|
||||
(list (vector file tags))))
|
||||
|
||||
(defun arcology-db--insert-ref (file ref)
|
||||
"Insert REF for FILE into the arcology cache."
|
||||
(let ((key (cdr ref))
|
||||
(type (car ref)))
|
||||
(arcology-db-query
|
||||
[:insert :into refs :values $v1]
|
||||
(list (vector key file type)))))
|
||||
|
||||
(defun arcology-db--insert-keywords (file keywords)
|
||||
"Insert KEYWORDS for a FILE into the arcology cache."
|
||||
(arcology-db-query
|
||||
[:insert :into keywords
|
||||
:values $v1]
|
||||
(maplist (lambda (keyword)
|
||||
(vector file (caar keyword) (cdar keyword)))
|
||||
keywords)))
|
||||
|
||||
;;;;; Fetching
|
||||
(defun arcology-db--get-current-files ()
|
||||
"Return a hash-table of file to the hash of its file contents."
|
||||
(let* ((current-files (arcology-db-query [:select * :from files]))
|
||||
(ht (make-hash-table :test #'equal)))
|
||||
(dolist (row current-files)
|
||||
(puthash (car row) (cadr row) ht))
|
||||
ht))
|
||||
|
||||
(defun arcology-db--get-titles (file)
|
||||
"Return the titles of FILE from the cache."
|
||||
(caar (arcology-db-query [:select [titles] :from titles
|
||||
:where (= file $s1)]
|
||||
file
|
||||
:limit 1)))
|
||||
|
||||
(defun arcology-db--connected-component (file)
|
||||
"Return all files reachable from/connected to FILE, including the file itself.
|
||||
If the file does not have any connections, nil is returned."
|
||||
(let* ((query "WITH RECURSIVE
|
||||
links_of(file, link) AS
|
||||
(WITH filelinks AS (SELECT * FROM links WHERE \"type\" = '\"file\"'),
|
||||
citelinks AS (SELECT * FROM links
|
||||
JOIN refs ON links.\"to\" = refs.\"ref\"
|
||||
AND links.\"type\" = '\"cite\"')
|
||||
SELECT \"from\", \"to\" FROM filelinks UNION
|
||||
SELECT \"to\", \"from\" FROM filelinks UNION
|
||||
SELECT \"file\", \"from\" FROM citelinks UNION
|
||||
SELECT \"from\", \"file\" FROM citelinks),
|
||||
connected_component(file) AS
|
||||
(SELECT link FROM links_of WHERE file = $s1
|
||||
UNION
|
||||
SELECT link FROM links_of JOIN connected_component USING(file))
|
||||
SELECT * FROM connected_component;")
|
||||
(files (mapcar 'car-safe (emacsql (arcology-db) query file))))
|
||||
files))
|
||||
|
||||
(defun arcology-db--links-with-max-distance (file max-distance)
|
||||
"Return all files connected to FILE in at most MAX-DISTANCE steps.
|
||||
This includes the file itself. If the file does not have any
|
||||
connections, nil is returned."
|
||||
(let* ((query "WITH RECURSIVE
|
||||
links_of(file, link) AS
|
||||
(WITH filelinks AS (SELECT * FROM links WHERE \"type\" = '\"file\"'),
|
||||
citelinks AS (SELECT * FROM links
|
||||
JOIN refs ON links.\"to\" = refs.\"ref\"
|
||||
AND links.\"type\" = '\"cite\"')
|
||||
SELECT \"from\", \"to\" FROM filelinks UNION
|
||||
SELECT \"to\", \"from\" FROM filelinks UNION
|
||||
SELECT \"file\", \"from\" FROM citelinks UNION
|
||||
SELECT \"from\", \"file\" FROM citelinks),
|
||||
-- Links are traversed in a breadth-first search. In order to calculate the
|
||||
-- distance of nodes and to avoid following cyclic links, the visited nodes
|
||||
-- are tracked in 'trace'.
|
||||
connected_component(file, trace) AS
|
||||
(VALUES($s1, json_array($s1))
|
||||
UNION
|
||||
SELECT lo.link, json_insert(cc.trace, '$[' || json_array_length(cc.trace) || ']', lo.link) FROM
|
||||
connected_component AS cc JOIN links_of AS lo USING(file)
|
||||
WHERE (
|
||||
-- Avoid cycles by only visiting each file once.
|
||||
(SELECT count(*) FROM json_each(cc.trace) WHERE json_each.value == lo.link) == 0
|
||||
-- Note: BFS is cut off early here.
|
||||
AND json_array_length(cc.trace) < ($s2 + 1)))
|
||||
SELECT DISTINCT file, min(json_array_length(trace)) AS distance
|
||||
FROM connected_component GROUP BY file ORDER BY distance;")
|
||||
;; In principle the distance would be available in the second column.
|
||||
(files (mapcar 'car-safe (emacsql (arcology-db) query file max-distance))))
|
||||
files))
|
||||
|
||||
;;;;; Updating
|
||||
(defun arcology-db--update-meta ()
|
||||
"Update the metadata of the current buffer into the cache."
|
||||
(let* ((file (file-truename (buffer-file-name)))
|
||||
(attr (file-attributes file))
|
||||
(atime (file-attribute-access-time attr))
|
||||
(mtime (file-attribute-modification-time attr))
|
||||
(hash (secure-hash 'sha1 (current-buffer))))
|
||||
(arcology-db-query [:delete :from files
|
||||
:where (= file $s1)]
|
||||
file)
|
||||
(arcology-db--insert-meta file hash (list :atime atime :mtime mtime))))
|
||||
|
||||
(defun arcology-db--update-titles ()
|
||||
"Update the title of the current buffer into the cache."
|
||||
(let* ((file (file-truename (buffer-file-name)))
|
||||
(title (arcology--extract-titles)))
|
||||
(arcology-db-query [:delete :from titles
|
||||
:where (= file $s1)]
|
||||
file)
|
||||
(arcology-db--insert-titles file title)))
|
||||
|
||||
(defun arcology-db--update-tags ()
|
||||
"Update the tags of the current buffer into the cache."
|
||||
(let ((file (file-truename (buffer-file-name)))
|
||||
(tags (arcology--extract-tags)))
|
||||
(arcology-db-query [:delete :from tags
|
||||
:where (= file $s1)]
|
||||
file)
|
||||
(when tags
|
||||
(arcology-db--insert-tags file tags))))
|
||||
|
||||
(defun arcology-db--update-refs ()
|
||||
"Update the ref of the current buffer into the cache."
|
||||
(let ((file (file-truename (buffer-file-name))))
|
||||
(arcology-db-query [:delete :from refs
|
||||
:where (= file $s1)]
|
||||
file)
|
||||
(when-let ((ref (arcology--extract-ref)))
|
||||
(arcology-db--insert-ref file ref))))
|
||||
|
||||
(defun arcology-db--update-links ()
|
||||
"Update the file links of the current buffer in the cache."
|
||||
(let ((file (file-truename (buffer-file-name))))
|
||||
(arcology-db-query [:delete :from links
|
||||
:where (= from $s1)]
|
||||
file)
|
||||
(when-let ((links (arcology--extract-links)))
|
||||
(arcology-db--insert-links links))))
|
||||
|
||||
(defun arcology-db--update-headlines ()
|
||||
"Update the file headlines of the current buffer into the cache."
|
||||
(let* ((file (file-truename (buffer-file-name))))
|
||||
(arcology-db-query [:delete :from headlines
|
||||
:where (= file $s1)]
|
||||
file)
|
||||
(when-let ((headlines (arcology--extract-headlines)))
|
||||
(arcology-db--insert-headlines headlines))))
|
||||
|
||||
(defun arcology-db--update-keywords ()
|
||||
"Update the keywords of the current buffer in the cache."
|
||||
(let ((file (file-truename (buffer-file-name))))
|
||||
(arcology-db-query [:delete :from keywords
|
||||
:where (= file $s1)]
|
||||
file)
|
||||
(when-let ((keywords (arcology--extract-keywords)))
|
||||
(arcology-db--insert-keywords file keywords))))
|
||||
|
||||
(defun arcology-db--update-file (&optional file-path)
|
||||
"Update arcology cache for FILE-PATH."
|
||||
(when (arcology--arcology-file-p file-path)
|
||||
(let ((buf (or (and file-path
|
||||
(find-file-noselect file-path t))
|
||||
(current-buffer))))
|
||||
(with-current-buffer buf
|
||||
(save-excursion
|
||||
(arcology-db--update-meta)
|
||||
(arcology-db--update-tags)
|
||||
(arcology-db--update-titles)
|
||||
(arcology-db--update-refs)
|
||||
(arcology-db--update-headlines)
|
||||
(arcology-db--update-links)
|
||||
(arcology-db--update-keywords))))))
|
||||
|
||||
(defun arcology-db-build-cache (&optional force)
|
||||
"Build the cache for `arcology-directory'.
|
||||
If FORCE, force a rebuild of the cache from scratch."
|
||||
(interactive "P")
|
||||
(when force (delete-file (arcology-db--get)))
|
||||
(arcology-db--close) ;; Force a reconnect
|
||||
(arcology-db) ;; To initialize the database, no-op if already initialized
|
||||
(let* ((arcology-files (arcology--list-all-files))
|
||||
(current-files (arcology-db--get-current-files))
|
||||
all-files all-headlines all-links all-titles all-refs all-tags all-keywords)
|
||||
;; Two-step building
|
||||
;; First step: Rebuild files and headlines
|
||||
(dolist (file arcology-files)
|
||||
(let* ((attr (file-attributes file))
|
||||
(atime (file-attribute-access-time attr))
|
||||
(mtime (file-attribute-modification-time attr)))
|
||||
(arcology--with-temp-buffer file
|
||||
(let ((contents-hash (secure-hash 'sha1 (current-buffer))))
|
||||
(unless (string= (gethash file current-files)
|
||||
contents-hash)
|
||||
(arcology-db--clear-file file)
|
||||
(push (vector file contents-hash (list :atime atime :mtime mtime))
|
||||
all-files)
|
||||
(when-let (headlines (arcology--extract-headlines file))
|
||||
(push headlines all-headlines)))))))
|
||||
(when all-files
|
||||
(arcology-db-query
|
||||
[:insert :into files
|
||||
:values $v1]
|
||||
all-files))
|
||||
(when all-headlines
|
||||
(arcology-db-query
|
||||
[:insert :into headlines
|
||||
:values $v1]
|
||||
all-headlines))
|
||||
;; Second step: Rebuild the rest
|
||||
(dolist (file arcology-files)
|
||||
(arcology--with-temp-buffer file
|
||||
(let ((contents-hash (secure-hash 'sha1 (current-buffer))))
|
||||
(unless (string= (gethash file current-files)
|
||||
contents-hash)
|
||||
(when-let (links (arcology--extract-links file))
|
||||
(push links all-links))
|
||||
(when-let (tags (arcology--extract-tags file))
|
||||
(push (vector file tags) all-tags))
|
||||
(let ((titles (arcology--extract-titles)))
|
||||
(push (vector file titles)
|
||||
all-titles))
|
||||
(when-let* ((keywords (arcology--extract-keywords)))
|
||||
(mapc (lambda (keyword)
|
||||
(push (vector file (car keyword) (cdr keyword))
|
||||
all-keywords))
|
||||
keywords))
|
||||
(when-let* ((ref (arcology--extract-ref))
|
||||
(type (car ref))
|
||||
(key (cdr ref)))
|
||||
(setq all-refs (cons (vector key file type) all-refs))))
|
||||
(remhash file current-files))))
|
||||
(dolist (file (hash-table-keys current-files))
|
||||
;; These files are no longer around, remove from cache...
|
||||
(arcology-db--clear-file file))
|
||||
(when all-links
|
||||
(arcology-db-query
|
||||
[:insert :into links
|
||||
:values $v1]
|
||||
all-links))
|
||||
(when all-titles
|
||||
(arcology-db-query
|
||||
[:insert :into titles
|
||||
:values $v1]
|
||||
all-titles))
|
||||
(when all-tags
|
||||
(arcology-db-query
|
||||
[:insert :into tags
|
||||
:values $v1]
|
||||
all-tags))
|
||||
(when all-refs
|
||||
(arcology-db-query
|
||||
[:insert :into refs
|
||||
:values $v1]
|
||||
all-refs))
|
||||
(when all-keywords
|
||||
(arcology-db-query
|
||||
[:insert :into keywords
|
||||
:values $v1]
|
||||
all-keywords))
|
||||
(let ((stats (list :files (length all-files)
|
||||
:headlines (length all-headlines)
|
||||
:links (length all-links)
|
||||
:tags (length all-tags)
|
||||
:titles (length all-titles)
|
||||
:refs (length all-refs)
|
||||
:keywords (length all-keywords)
|
||||
:deleted (length (hash-table-keys current-files)))))
|
||||
(arcology-message "files: %s, headlines: %s, links: %s, tags: %s, titles: %s, refs: %s, deleted: %s, keywords: %s"
|
||||
(plist-get stats :files)
|
||||
(plist-get stats :headlines)
|
||||
(plist-get stats :links)
|
||||
(plist-get stats :tags)
|
||||
(plist-get stats :titles)
|
||||
(plist-get stats :refs)
|
||||
(plist-get stats :keywords)
|
||||
(plist-get stats :deleted))
|
||||
stats)))
|
||||
|
||||
(provide 'arcology-db)
|
||||
|
||||
;;; arcology-db.el ends here
|
||||
|
|
@ -0,0 +1,61 @@
|
|||
;;; arcology-macs.el --- Macros/utility functions -*- coding: utf-8; lexical-binding: t; -*-
|
||||
|
||||
;; Copyright © 2020 Jethro Kuan <jethrokuan95@gmail.com>
|
||||
;; Copyright © 2020 Ryan Rix <ryan@whatthfuck.computer>
|
||||
|
||||
;; Author: Ryan Rix <ryan@whatthfuck.computer>
|
||||
;; URL: https://github.com/org-roam/org-roam
|
||||
;; Keywords: org-mode, roam, convenience
|
||||
;; Version: 1.2.0
|
||||
;; Package-Requires: ((emacs "26.1") (dash "2.13") (f "0.17.2") (s "1.12.0") (org "9.3") (emacsql "3.0.0") (emacsql-sqlite3 "1.0.0"))
|
||||
|
||||
;; This file is NOT part of GNU Emacs.
|
||||
|
||||
;; This program is free software; you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation; either version 3, or (at your option)
|
||||
;; any later version.
|
||||
;;
|
||||
;; This program is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
;;
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with GNU Emacs; see the file COPYING. If not, write to the
|
||||
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, USA.
|
||||
|
||||
;;; Commentary:
|
||||
;;
|
||||
;; This library implements macros and utility functions used throughout
|
||||
;; arcology.
|
||||
;;
|
||||
;;
|
||||
;;; Code:
|
||||
;;;; Library Requires
|
||||
|
||||
(defvar arcology-verbose)
|
||||
|
||||
(defmacro arcology--with-temp-buffer (file &rest body)
|
||||
"Execute BODY within a temp buffer.
|
||||
Like `with-temp-buffer', but propagates `arcology-directory'.
|
||||
If FILE, set `arcology-temp-file-name' to file and insert its contents."
|
||||
(declare (indent 1) (debug t))
|
||||
(let ((current-arcology-directory (make-symbol "current-arcology-directory")))
|
||||
`(let ((,current-arcology-directory arcology-directory))
|
||||
(with-temp-buffer
|
||||
(let ((arcology-directory ,current-arcology-directory))
|
||||
(when ,file
|
||||
(insert-file-contents ,file)
|
||||
(setq-local arcology-file-name ,file))
|
||||
,@body)))))
|
||||
|
||||
(defun arcology-message (format-string &rest args)
|
||||
"Pass FORMAT-STRING and ARGS to `message' when `arcology-verbose' is t."
|
||||
(when arcology-verbose
|
||||
(apply #'message `(,(concat "(arcology) " format-string) ,@args))))
|
||||
|
||||
(provide 'arcology-macs)
|
||||
|
||||
;;; arcology-macs.el ends here
|
||||
|
|
@ -0,0 +1,792 @@
|
|||
;;; arcology.el --- Roam Research replica with Org-mode -*- coding: utf-8; lexical-binding: t; -*-
|
||||
|
||||
;; Copyright © 2020 Jethro Kuan <jethrokuan95@gmail.com>
|
||||
|
||||
;; Author: Jethro Kuan <jethrokuan95@gmail.com>
|
||||
;; URL: https://github.com/org-roam/org-roam
|
||||
;; Keywords: org-mode, roam, convenience
|
||||
;; Version: 1.2.0
|
||||
;; Package-Requires: ((emacs "26.1") (dash "2.13") (f "0.17.2") (s "1.12.0") (org "9.3") (emacsql "3.0.0") (emacsql-sqlite3 "1.0.0"))
|
||||
|
||||
;; This file is NOT part of GNU Emacs.
|
||||
|
||||
;; This program is free software; you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation; either version 3, or (at your option)
|
||||
;; any later version.
|
||||
;;
|
||||
;; This program is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
;;
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with GNU Emacs; see the file COPYING. If not, write to the
|
||||
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, USA.
|
||||
|
||||
;;; Commentary:
|
||||
;;
|
||||
;; This library is an attempt at injecting Roam functionality into Org-mode.
|
||||
;; This is achieved primarily through building caches for forward links,
|
||||
;; backward links, and file titles.
|
||||
;;
|
||||
;;
|
||||
;;; Code:
|
||||
;;;; Dependencies
|
||||
(require 'org)
|
||||
(require 'org-element)
|
||||
(require 'org-id)
|
||||
(require 'ob-core) ;for org-babel-parse-header-arguments
|
||||
(require 'ansi-color) ; arcology--list-files strip ANSI color codes
|
||||
(require 'cl-lib)
|
||||
(require 'dash)
|
||||
(require 'f)
|
||||
(require 'rx)
|
||||
(require 's)
|
||||
(require 'seq)
|
||||
(eval-when-compile (require 'subr-x))
|
||||
|
||||
;;;; Features
|
||||
(require 'arcology-macs)
|
||||
(require 'arcology-db)
|
||||
|
||||
;;;; Declarations
|
||||
;; From org-ref-core.el
|
||||
(defvar org-ref-cite-types)
|
||||
(declare-function org-ref-split-and-strip-string "ext:org-ref-utils" (string))
|
||||
;; From org-id.el
|
||||
(defvar org-id-link-to-org-use-id)
|
||||
(declare-function org-id-find-id-in-file "ext:org-id" (id file &optional markerp))
|
||||
|
||||
|
||||
;;;; Customizable variables
|
||||
(defgroup arcology nil
|
||||
"Roam Research replica in Org-mode."
|
||||
:group 'org
|
||||
:prefix "arcology-"
|
||||
:link '(url-link :tag "Github" "https://github.com/org-roam/org-roam")
|
||||
:link '(url-link :tag "Online Manual" "https://org-roam.github.io/org-roam/manual/"))
|
||||
|
||||
(defcustom arcology-file-extensions '("org")
|
||||
"Detected file extensions to include in the arcology ecosystem.
|
||||
The first item in the list is used as the default file extension.
|
||||
While the file extensions may be different, the file format needs
|
||||
to be an `org-mode' file, and it is the user's responsibility to
|
||||
ensure that."
|
||||
:type '(repeat string)
|
||||
:group 'arcology)
|
||||
|
||||
(defcustom arcology-include-type-in-ref-path-completions nil
|
||||
"When t, include the type in ref-path completions.
|
||||
Note that this only affects interactive calls.
|
||||
See `arcology--get-ref-path-completions' for details."
|
||||
:type 'boolean
|
||||
:group 'arcology)
|
||||
|
||||
(defcustom arcology-link-title-format "%s"
|
||||
"The formatter used when inserting arcology links that use their title.
|
||||
Formatter may be a function that takes title as its only argument."
|
||||
:type '(choice
|
||||
(string :tag "String Format" "%s")
|
||||
(function :tag "Custom function"))
|
||||
:group 'arcology)
|
||||
|
||||
(defcustom arcology-list-files-commands
|
||||
(if (member system-type '(windows-nt ms-dos cygwin))
|
||||
nil
|
||||
'(find rg))
|
||||
"Commands that will be used to find arcology files.
|
||||
|
||||
It should be a list of symbols or cons cells representing any of the following
|
||||
supported file search methods.
|
||||
|
||||
The commands will be tried in order until an executable for a command is found.
|
||||
The Elisp implementation is used if no command in the list is found.
|
||||
|
||||
`rg'
|
||||
Use ripgrep as the file search method.
|
||||
Example command: rg /path/to/dir/ --files -g \"*.org\" -g \"*.org.gpg\"
|
||||
|
||||
`find'
|
||||
Use find as the file search method.
|
||||
Example command:
|
||||
find /path/to/dir -type f \( -name \"*.org\" -o -name \"*.org.gpg\" \)
|
||||
|
||||
By default, `executable-find' will be used to look up the path to the
|
||||
executable. If a custom path is required, it can be specified together with the
|
||||
method symbol as a cons cell. For example: '(find (rg . \"/path/to/rg\"))."
|
||||
:type '(set (const :tag "find" find)
|
||||
(const :tag "rg" rg)))
|
||||
|
||||
(defcustom arcology-tag-separator ","
|
||||
"String to use to separate tags when `arcology-tag-sources' is non-nil."
|
||||
:type 'string
|
||||
:group 'arcology)
|
||||
|
||||
(defcustom arcology-tag-sort nil
|
||||
"When non-nil, sort the tags in the completions.
|
||||
When t, sort the tags alphabetically, regardless of case.
|
||||
`arcology-tag-sort' can also be a list of arguments to be applied
|
||||
to `cl-sort'. For example, these are the arguments used when
|
||||
`arcology-tag-sort' is set to t:
|
||||
\('string-lessp :key 'downcase)
|
||||
Only relevant when `arcology-tag-sources' is non-nil."
|
||||
:type '(choice
|
||||
(boolean)
|
||||
(list :tag "Arguments to cl-loop"))
|
||||
:group 'arcology)
|
||||
|
||||
(defcustom arcology-tag-sources '(prop)
|
||||
"Sources to obtain tags from.
|
||||
|
||||
It should be a list of symbols representing any of the following
|
||||
extraction methods:
|
||||
|
||||
`prop'
|
||||
Extract tags from the #+roam_tags property.
|
||||
Tags are space delimited.
|
||||
Tags may contain spaces if they are double-quoted.
|
||||
e.g. #+roam_tags: TAG \"tag with spaces\"
|
||||
|
||||
`all-directories'
|
||||
Extract sub-directories relative to `arcology-directory'.
|
||||
That is, if a file is located at relative path foo/bar/file.org,
|
||||
the file will have tags \"foo\" and \"bar\".
|
||||
|
||||
`last-directory'
|
||||
Extract the last directory relative to `arcology-directory'.
|
||||
That is, if a file is located at relative path foo/bar/file.org,
|
||||
the file will have tag \"bar\"."
|
||||
:type '(set (const :tag "#+roam_tags" PROP)
|
||||
(const :tag "sub-directories" all-directories)
|
||||
(const :tag "parent directory" last-directory)))
|
||||
|
||||
(defcustom arcology-title-sources '((title headline) alias)
|
||||
"The list of sources from which to retrieve a note title.
|
||||
Each element in the list is either:
|
||||
|
||||
1. a symbol -- this symbol corresponds to a title retrieval
|
||||
function, which returns the list of titles for the current buffer
|
||||
2. a list of symbols -- symbols in the list are treated as
|
||||
with (1). The return value of this list is the first symbol in
|
||||
the list returning a non-nil value.
|
||||
|
||||
The return results of the root list are concatenated.
|
||||
|
||||
For example the setting: '((title headline) alias) means the following:
|
||||
|
||||
1. Return the 'title + 'alias, if the title of current buffer is non-empty;
|
||||
2. Or return 'headline + 'alias otherwise.
|
||||
|
||||
The currently supported symbols are:
|
||||
1. 'title: The \"#+title\" property of org file.
|
||||
2. 'alias: The \"#+roam_alias\" property of the org file, using
|
||||
space-delimited strings.
|
||||
3. 'headline: The first headline in the org file."
|
||||
:type '(repeat
|
||||
(choice
|
||||
(repeat symbol)
|
||||
(symbol)))
|
||||
:group 'arcology)
|
||||
|
||||
(defcustom arcology-verbose t
|
||||
"Echo messages that are not errors."
|
||||
:type 'boolean
|
||||
:group 'arcology)
|
||||
|
||||
;;;; Dynamic variables
|
||||
(defvar arcology-last-window nil
|
||||
"Last window `arcology' was called from.")
|
||||
|
||||
(defvar-local arcology-file-name nil
|
||||
"The corresponding file for a temp buffer.
|
||||
This is set by `arcology--with-temp-buffer', to allow throwing of
|
||||
descriptive warnings when certain operations fail (e.g. parsing).")
|
||||
|
||||
(defvar arcology--org-link-file-bracket-re
|
||||
(rx "[[file:" (seq (group (one-or-more (or (not (any "]" "[" "\\"))
|
||||
(seq "\\"
|
||||
(zero-or-more "\\\\")
|
||||
(any "[" "]"))
|
||||
(seq (one-or-more "\\")
|
||||
(not (any "]" "["))))))
|
||||
"]"
|
||||
(zero-or-one (seq "["
|
||||
(group (+? anything))
|
||||
"]"))
|
||||
"]"))
|
||||
"Matches a 'file:' link in double brackets.")
|
||||
|
||||
;;;; Utilities
|
||||
(defun arcology--plist-to-alist (plist)
|
||||
"Return an alist of the property-value pairs in PLIST."
|
||||
(let (res)
|
||||
(while plist
|
||||
(let ((prop (intern (substring (symbol-name (pop plist)) 1 nil)))
|
||||
(val (pop plist)))
|
||||
(push (cons prop val) res)))
|
||||
res))
|
||||
|
||||
(defun arcology--str-to-list (str)
|
||||
"Transform string STR into a list of strings.
|
||||
If STR is nil, return nil.
|
||||
|
||||
This function can throw an error if STR is not a string, or if
|
||||
str is malformed (e.g. missing a closing quote). Callers of this
|
||||
function are expected to catch the error."
|
||||
(when str
|
||||
(unless (stringp str)
|
||||
(signal 'wrong-type-argument `(stringp ,str)))
|
||||
(let* ((str (org-trim str))
|
||||
(format-str ":dummy '(%s)") ;The :dummy key is discarded in the `lst' var below.
|
||||
(items (cdar (org-babel-parse-header-arguments (format format-str str)))))
|
||||
(mapcar (lambda (item)
|
||||
(cond
|
||||
((stringp item)
|
||||
item)
|
||||
((symbolp item)
|
||||
(symbol-name item))
|
||||
((numberp item)
|
||||
(number-to-string item))
|
||||
(t
|
||||
(signal 'wrong-type-argument `((stringp numberp symbolp) ,item))))) items))))
|
||||
|
||||
;;;; File functions and predicates
|
||||
(defun arcology--file-name-extension (filename)
|
||||
"Return file name extension for FILENAME.
|
||||
Like `file-name-extension', but does not strip version number."
|
||||
(save-match-data
|
||||
(let ((file (file-name-nondirectory filename)))
|
||||
(if (and (string-match "\\.[^.]*\\'" file)
|
||||
(not (eq 0 (match-beginning 0))))
|
||||
(substring file (+ (match-beginning 0) 1))))))
|
||||
|
||||
(defun arcology--org-file-p (path)
|
||||
"Check if PATH is pointing to an org file."
|
||||
(let ((ext (arcology--file-name-extension path)))
|
||||
(when (string= ext "gpg") ; Handle encrypted files
|
||||
(setq ext (arcology--file-name-extension (file-name-sans-extension path))))
|
||||
(member ext arcology-file-extensions)))
|
||||
|
||||
(defun arcology--arcology-file-p (&optional file)
|
||||
"Return t if FILE is part of arcology system, nil otherwise.
|
||||
If FILE is not specified, use the current buffer's file-path."
|
||||
(if-let ((path (or file
|
||||
(buffer-file-name))))
|
||||
(save-match-data
|
||||
(and
|
||||
(arcology--org-file-p path)
|
||||
(f-descendant-of-p (file-truename path)
|
||||
(file-truename arcology-directory))))))
|
||||
|
||||
(defun arcology--arcology-headline-p (&optional id)
|
||||
"Return t if ID is part of arcology system, nil otherwise.
|
||||
If ID is not specified, use the ID of the entry at point."
|
||||
(if-let ((id (or id
|
||||
(org-id-get))))
|
||||
(arcology-db-query [:select [file] :from headlines
|
||||
:where (= id $s1)]
|
||||
id)))
|
||||
|
||||
(defun arcology--shell-command-files (cmd)
|
||||
"Run CMD in the shell and return a list of files. If no files are found, an empty list is returned."
|
||||
(--> cmd
|
||||
(shell-command-to-string it)
|
||||
(ansi-color-filter-apply it)
|
||||
(split-string it "\n")
|
||||
(seq-filter #'s-present? it)))
|
||||
|
||||
(defun arcology--list-files-search-globs (exts)
|
||||
"Given EXTS, return a list of search globs.
|
||||
E.g. (\".org\") => (\"*.org\" \"*.org.gpg\")"
|
||||
(append
|
||||
(mapcar (lambda (ext) (s-wrap (concat "*." ext) "\"")) exts)
|
||||
(mapcar (lambda (ext) (s-wrap (concat "*." ext ".gpg") "\"")) exts)))
|
||||
|
||||
(defun arcology--list-files-rg (executable dir)
|
||||
"Return all arcology files located recursively within DIR, using ripgrep, provided as EXECUTABLE."
|
||||
(let* ((globs (arcology--list-files-search-globs arcology-file-extensions))
|
||||
(command (s-join " " `(,executable "-L" ,dir "--files"
|
||||
,@(mapcar (lambda (glob) (concat "-g " glob)) globs)))))
|
||||
(arcology--shell-command-files command)))
|
||||
|
||||
(defun arcology--list-files-find (executable dir)
|
||||
"Return all arcology files located recursively within DIR, using find, provided as EXECUTABLE."
|
||||
(let* ((globs (arcology--list-files-search-globs arcology-file-extensions))
|
||||
(command (s-join " " `(,executable "-L" ,dir "-type f \\("
|
||||
,(s-join " -o " (mapcar (lambda (glob) (concat "-name " glob)) globs)) "\\)"))))
|
||||
(arcology--shell-command-files command)))
|
||||
|
||||
;; Emacs 26 does not have FOLLOW-SYMLINKS in `directory-files-recursively'
|
||||
(defun arcology--directory-files-recursively (dir regexp
|
||||
&optional include-directories predicate
|
||||
follow-symlinks)
|
||||
"Return list of all files under directory DIR whose names match REGEXP.
|
||||
This function works recursively. Files are returned in \"depth
|
||||
first\" order, and files from each directory are sorted in
|
||||
alphabetical order. Each file name appears in the returned list
|
||||
in its absolute form.
|
||||
|
||||
By default, the returned list excludes directories, but if
|
||||
optional argument INCLUDE-DIRECTORIES is non-nil, they are
|
||||
included.
|
||||
|
||||
PREDICATE can be either nil (which means that all subdirectories
|
||||
of DIR are descended into), t (which means that subdirectories that
|
||||
can't be read are ignored), or a function (which is called with
|
||||
the name of each subdirectory, and should return non-nil if the
|
||||
subdirectory is to be descended into).
|
||||
|
||||
If FOLLOW-SYMLINKS is non-nil, symbolic links that point to
|
||||
directories are followed. Note that this can lead to infinite
|
||||
recursion."
|
||||
(let* ((result nil)
|
||||
(files nil)
|
||||
(dir (directory-file-name dir))
|
||||
;; When DIR is "/", remote file names like "/method:" could
|
||||
;; also be offered. We shall suppress them.
|
||||
(tramp-mode (and tramp-mode (file-remote-p (expand-file-name dir)))))
|
||||
(dolist (file (sort (file-name-all-completions "" dir)
|
||||
'string<))
|
||||
(unless (member file '("./" "../"))
|
||||
(if (directory-name-p file)
|
||||
(let* ((leaf (substring file 0 (1- (length file))))
|
||||
(full-file (concat dir "/" leaf)))
|
||||
;; Don't follow symlinks to other directories.
|
||||
(when (and (or (not (file-symlink-p full-file))
|
||||
(and (file-symlink-p full-file)
|
||||
follow-symlinks))
|
||||
;; Allow filtering subdirectories.
|
||||
(or (eq predicate nil)
|
||||
(eq predicate t)
|
||||
(funcall predicate full-file)))
|
||||
(let ((sub-files
|
||||
(if (eq predicate t)
|
||||
(ignore-error file-error
|
||||
(arcology--directory-files-recursively
|
||||
full-file regexp include-directories
|
||||
predicate follow-symlinks))
|
||||
(arcology--directory-files-recursively
|
||||
full-file regexp include-directories
|
||||
predicate follow-symlinks))))
|
||||
(setq result (nconc result sub-files))))
|
||||
(when (and include-directories
|
||||
(string-match regexp leaf))
|
||||
(setq result (nconc result (list full-file)))))
|
||||
(when (string-match regexp file)
|
||||
(push (concat dir "/" file) files)))))
|
||||
(nconc result (nreverse files))))
|
||||
|
||||
(defun arcology--list-files-elisp (dir)
|
||||
"Return all arcology files located recursively within DIR, using elisp."
|
||||
(let ((regex (concat "\\.\\(?:"(mapconcat #'regexp-quote arcology-file-extensions "\\|" )"\\)\\(?:\\.gpg\\)?\\'"))
|
||||
result)
|
||||
(dolist (file (arcology--directory-files-recursively dir regex nil nil t) result)
|
||||
(when (and (file-readable-p file) (arcology--org-file-p file))
|
||||
(push file result)))))
|
||||
|
||||
(defun arcology--list-files (dir)
|
||||
"Return all arcology files located recursively within DIR.
|
||||
Use external shell commands if defined in `arcology-list-files-commands'."
|
||||
(let (path exe)
|
||||
(cl-dolist (cmd arcology-list-files-commands)
|
||||
(pcase cmd
|
||||
(`(,e . ,path)
|
||||
(setq path (executable-find path)
|
||||
exe (symbol-name e)))
|
||||
((pred symbolp)
|
||||
(setq path (executable-find (symbol-name cmd))
|
||||
exe (symbol-name cmd)))
|
||||
(wrong-type
|
||||
(signal 'wrong-type-argument
|
||||
`((consp symbolp)
|
||||
,wrong-type))))
|
||||
(when path (cl-return)))
|
||||
(if-let* ((files (when path
|
||||
(let ((fn (intern (concat "arcology--list-files-" exe))))
|
||||
(unless (fboundp fn) (user-error "%s is not an implemented search method" fn))
|
||||
(funcall fn path (format "\"%s\"" dir)))))
|
||||
(files (seq-filter #'arcology--arcology-file-p files))
|
||||
(files (mapcar #'expand-file-name files))) ; canonicalize names
|
||||
files
|
||||
(arcology--list-files-elisp dir))))
|
||||
|
||||
(defun arcology--list-all-files ()
|
||||
"Return a list of all arcology files within `arcology-directory'."
|
||||
(arcology--list-files (file-truename arcology-directory)))
|
||||
|
||||
;;;; Org extraction functions
|
||||
(defun arcology--extract-global-props (props)
|
||||
"Extract PROPS from the current org buffer.
|
||||
The search terminates when the first property is encountered."
|
||||
(let ((buf (org-element-parse-buffer))
|
||||
res)
|
||||
(dolist (prop props)
|
||||
(let ((p (org-element-map buf 'keyword
|
||||
(lambda (kw)
|
||||
(when (string-equal (org-element-property :key kw) prop)
|
||||
(org-element-property :value kw)))
|
||||
:first-match t)))
|
||||
(push (cons prop p) res)))
|
||||
res))
|
||||
|
||||
(defun arcology--expand-links (content path)
|
||||
"Crawl CONTENT for relative links and expand them.
|
||||
PATH should be the root from which to compute the relativity."
|
||||
(let ((dir (file-name-directory path))
|
||||
(re arcology--org-link-file-bracket-re)
|
||||
link)
|
||||
(with-temp-buffer
|
||||
(insert content)
|
||||
(goto-char (point-min))
|
||||
;; Loop over links
|
||||
(while (re-search-forward re (point-max) t)
|
||||
(goto-char (match-beginning 1))
|
||||
;; Strip 'file:'
|
||||
(setq link (match-string 1))
|
||||
;; Delete relative link
|
||||
(when (f-relative-p link)
|
||||
(delete-region (match-beginning 1)
|
||||
(match-end 1))
|
||||
(insert (expand-file-name
|
||||
(concat dir link)))))
|
||||
(buffer-string))))
|
||||
|
||||
(defun arcology-id-find (id &optional markerp strict)
|
||||
"Return the location of the entry with the id ID.
|
||||
When MARKERP is non-nil, return a marker pointing to theheadline.
|
||||
Otherwise, return a cons formatted as \(file . pos).
|
||||
When STRICT is non-nil, only consider Org-roam’s database."
|
||||
(let ((file (or (caar (arcology-db-query [:select [file]
|
||||
:from headlines
|
||||
:where (= id $s1)]
|
||||
id))
|
||||
(unless strict
|
||||
(org-id-find-id-file id)))))
|
||||
(when file
|
||||
(org-id-find-id-in-file id file markerp))))
|
||||
|
||||
(defun arcology--extract-links (&optional file-path)
|
||||
"Extracts all link items within the current buffer.
|
||||
Link items are of the form:
|
||||
|
||||
[from to type properties]
|
||||
|
||||
This is the format that emacsql expects when inserting into the database.
|
||||
FILE-FROM is typically the buffer file path, but this may not exist, for example
|
||||
in temp buffers. In cases where this occurs, we do know the file path, and pass
|
||||
it as FILE-PATH."
|
||||
(let ((file-path (or file-path
|
||||
(file-truename (buffer-file-name))))
|
||||
links)
|
||||
(org-element-map (org-element-parse-buffer) 'link
|
||||
(lambda (link)
|
||||
(let* ((type (org-element-property :type link))
|
||||
(path (org-element-property :path link))
|
||||
(start (org-element-property :begin link))
|
||||
(id-data (arcology-id-find path))
|
||||
(link-type (cond ((and (string= type "file")
|
||||
(arcology--org-file-p path))
|
||||
"file")
|
||||
((and (string= type "id")
|
||||
id-data)
|
||||
"id")
|
||||
((and
|
||||
(require 'org-ref nil t)
|
||||
(-contains? org-ref-cite-types type))
|
||||
"cite")
|
||||
(t nil))))
|
||||
(when link-type
|
||||
(goto-char start)
|
||||
(let* ((element (org-element-at-point))
|
||||
(begin (or (org-element-property :content-begin element)
|
||||
(org-element-property :begin element)))
|
||||
(content (or (org-element-property :raw-value element)
|
||||
(buffer-substring-no-properties
|
||||
begin
|
||||
(or (org-element-property :content-end element)
|
||||
(org-element-property :end element)))))
|
||||
(content (string-trim content))
|
||||
;; Expand all relative links to absolute links
|
||||
(content (arcology--expand-links content file-path)))
|
||||
(let ((context (list :content content :point begin))
|
||||
(names (pcase link-type
|
||||
("file"
|
||||
(list (file-truename (expand-file-name path (file-name-directory file-path)))))
|
||||
("id"
|
||||
(list (car id-data)))
|
||||
("cite"
|
||||
(org-ref-split-and-strip-string path)))))
|
||||
(seq-do (lambda (name)
|
||||
(push (vector file-path
|
||||
name
|
||||
link-type
|
||||
context)
|
||||
links))
|
||||
names)))))))
|
||||
links))
|
||||
|
||||
(defun arcology--extract-headlines (&optional file-path)
|
||||
"Extract all headlines with IDs within the current buffer.
|
||||
If FILE-PATH is nil, use the current file."
|
||||
(let ((file-path (or file-path
|
||||
(file-truename (buffer-file-name)))))
|
||||
(org-element-map (org-element-parse-buffer) 'node-property
|
||||
(lambda (node-property)
|
||||
(let ((key (org-element-property :key node-property))
|
||||
(value (org-element-property :value node-property)))
|
||||
(when (string= key "ID")
|
||||
(let* ((id value)
|
||||
(data (vector id
|
||||
file-path)))
|
||||
data)))))))
|
||||
|
||||
(defun arcology--extract-titles-title ()
|
||||
"Return title from \"#+title\" of the current buffer."
|
||||
(let* ((prop (arcology--extract-global-props '("TITLE")))
|
||||
(title (cdr (assoc "TITLE" prop))))
|
||||
(when title
|
||||
(list title))))
|
||||
|
||||
(defun arcology--extract-titles-alias ()
|
||||
"Return the aliases from the current buffer.
|
||||
Reads from the \"roam_alias\" property."
|
||||
(let* ((prop (arcology--extract-global-props '("ROAM_ALIAS")))
|
||||
(aliases (cdr (assoc "ROAM_ALIAS" prop))))
|
||||
(condition-case nil
|
||||
(arcology--str-to-list aliases)
|
||||
(error
|
||||
(progn
|
||||
(lwarn '(arcology) :error
|
||||
"Failed to parse aliases for buffer: %s. Skipping"
|
||||
(or arcology-file-name
|
||||
(buffer-file-name)))
|
||||
nil)))))
|
||||
|
||||
(defun arcology--extract-titles-headline ()
|
||||
"Return the first headline of the current buffer."
|
||||
(let ((headline (org-element-map
|
||||
(org-element-parse-buffer)
|
||||
'headline
|
||||
(lambda (h)
|
||||
(org-no-properties (org-element-property :raw-value h)))
|
||||
:first-match t)))
|
||||
(when headline
|
||||
(list headline))))
|
||||
|
||||
(defun arcology--extract-titles (&optional sources nested)
|
||||
"Extract the titles from current buffer using SOURCES.
|
||||
If NESTED, return the first successful result from SOURCES."
|
||||
(let (coll res)
|
||||
(cl-dolist (source (or sources
|
||||
arcology-title-sources))
|
||||
(setq res (if (symbolp source)
|
||||
(funcall (intern (concat "arcology--extract-titles-" (symbol-name source))))
|
||||
(arcology--extract-titles source t)))
|
||||
(when res
|
||||
(if (not nested)
|
||||
(setq coll (nconc coll res))
|
||||
(setq coll res)
|
||||
(cl-return))))
|
||||
coll))
|
||||
|
||||
(defun arcology--extract-tags-all-directories (file)
|
||||
"Extract tags from using the directory path FILE.
|
||||
All sub-directories relative to `arcology-directory' are used as tags."
|
||||
(when-let ((dir-relative (file-name-directory
|
||||
(file-relative-name file arcology-directory))))
|
||||
(f-split dir-relative)))
|
||||
|
||||
(defun arcology--extract-tags-last-directory (file)
|
||||
"Extract tags from using the directory path FILE.
|
||||
The final directory component is used as a tag."
|
||||
(when-let ((dir-relative (file-name-directory
|
||||
(file-relative-name file arcology-directory))))
|
||||
(last (f-split dir-relative))))
|
||||
|
||||
(defun arcology--extract-tags-prop (_file)
|
||||
"Extract tags from the current buffer's \"#roam_tags\" global property."
|
||||
(let* ((prop (cdr (assoc "ROAM_TAGS" (arcology--extract-global-props '("ROAM_TAGS"))))))
|
||||
(condition-case nil
|
||||
(arcology--str-to-list prop)
|
||||
(error
|
||||
(progn
|
||||
(lwarn '(arcology) :error
|
||||
"Failed to parse tags for buffer: %s. Skipping"
|
||||
(or arcology-file-name
|
||||
(buffer-file-name)))
|
||||
nil)))))
|
||||
|
||||
(defun arcology--extract-tags (&optional file)
|
||||
"Extract tags from the current buffer.
|
||||
If file-path FILE, use it to determine the directory tags.
|
||||
Tags are obtained via:
|
||||
|
||||
1. Directory tags: Relative to `arcology-directory': each folder
|
||||
path is considered a tag.
|
||||
2. The key #+roam_tags."
|
||||
(let* ((file (or file (buffer-file-name (buffer-base-buffer))))
|
||||
(tags (mapcan (lambda (source)
|
||||
(funcall (intern (concat "arcology--extract-tags-"
|
||||
(symbol-name source)))
|
||||
file))
|
||||
arcology-tag-sources)))
|
||||
(pcase arcology-tag-sort
|
||||
('nil tags)
|
||||
((pred booleanp) (cl-sort tags 'string-lessp :key 'downcase))
|
||||
(`(,(pred symbolp) . ,_)
|
||||
(apply #'cl-sort (push tags arcology-tag-sort)))
|
||||
(wrong-type (signal 'wrong-type-argument
|
||||
`((booleanp (list symbolp))
|
||||
,wrong-type))))))
|
||||
|
||||
(defun arcology--cite-prefix (ref)
|
||||
"Return the citation prefix of REF, or nil otherwise.
|
||||
The prefixes are defined in `org-ref-cite-types`.
|
||||
Examples:
|
||||
(arcology--cite-prefix \"cite:foo\") -> \"cite:\"
|
||||
(arcology--cite-prefix \"https://google.com\") -> nil"
|
||||
(when (require 'org-ref nil t)
|
||||
(seq-find
|
||||
(lambda (prefix) (s-prefix? prefix ref))
|
||||
(-map (lambda (type) (concat type ":"))
|
||||
org-ref-cite-types))))
|
||||
|
||||
(defun arcology--ref-type (ref)
|
||||
"Determine the type of the REF from the prefix."
|
||||
(let* ((cite-prefix (arcology--cite-prefix ref))
|
||||
(is-website (seq-some
|
||||
(lambda (prefix) (s-prefix? prefix ref))
|
||||
'("http" "https")))
|
||||
(type (cond (cite-prefix "cite")
|
||||
(is-website "website")
|
||||
(t "file"))))
|
||||
type))
|
||||
|
||||
(defun arcology--extract-ref ()
|
||||
"Extract the ref from current buffer and return the type and the key of the ref."
|
||||
(pcase (cdr (assoc "ROAM_KEY"
|
||||
(arcology--extract-global-props '("ROAM_KEY"))))
|
||||
('nil nil)
|
||||
((pred string-empty-p)
|
||||
(user-error "Org property #+roam_key cannot be empty"))
|
||||
(ref
|
||||
(let* ((type (arcology--ref-type ref))
|
||||
(key (cond ((string= "cite" type)
|
||||
(s-chop-prefix (arcology--cite-prefix ref) ref))
|
||||
(t ref))))
|
||||
(cons type key)))))
|
||||
|
||||
(defun arcology--ref-type-p (type)
|
||||
"Return t if the ref from current buffer is TYPE."
|
||||
(let ((current (car (arcology--extract-ref))))
|
||||
(eq current type)))
|
||||
|
||||
;;;; Global Property Caching
|
||||
(defcustom arcology-cached-keywords nil
|
||||
"Keyword properties which will be stored in the arcology db keywords table."
|
||||
:type '(repeat string)
|
||||
:group 'arcology)
|
||||
|
||||
(defun arcology--extract-keywords ()
|
||||
"Extract props specified in [`arcology-cached-keywords'] from current buffer and return the type and the key of the ref."
|
||||
(when arcology-cached-keywords
|
||||
(seq-filter
|
||||
#'cdr
|
||||
(arcology--extract-global-props arcology-cached-keywords))))
|
||||
|
||||
;;;; Title/Path/Slug conversion
|
||||
(defun arcology--path-to-slug (path)
|
||||
"Return a slug from PATH."
|
||||
(-> path
|
||||
(file-relative-name (file-truename arcology-directory))
|
||||
(file-name-sans-extension)))
|
||||
|
||||
(defun arcology--get-title-or-slug (path)
|
||||
"Convert `PATH' to the file title, if it exists. Else, return the path."
|
||||
(or (car (arcology-db--get-titles path))
|
||||
(arcology--path-to-slug path)))
|
||||
|
||||
(defun arcology--title-to-slug (title)
|
||||
"Convert TITLE to a filename-suitable slug."
|
||||
(cl-flet* ((nonspacing-mark-p (char)
|
||||
(eq 'Mn (get-char-code-property char 'general-category)))
|
||||
(strip-nonspacing-marks (s)
|
||||
(apply #'string (seq-remove #'nonspacing-mark-p
|
||||
(ucs-normalize-NFD-string s))))
|
||||
(cl-replace (title pair)
|
||||
(replace-regexp-in-string (car pair) (cdr pair) title)))
|
||||
(let* ((pairs `(("[^[:alnum:][:digit:]]" . "_") ;; convert anything not alphanumeric
|
||||
("__*" . "_") ;; remove sequential underscores
|
||||
("^_" . "") ;; remove starting underscore
|
||||
("_$" . ""))) ;; remove ending underscore
|
||||
(slug (-reduce-from #'cl-replace (strip-nonspacing-marks title) pairs)))
|
||||
(downcase slug))))
|
||||
|
||||
(defun arcology--format-link-title (title)
|
||||
"Return the link title, given the file TITLE."
|
||||
(if (functionp arcology-link-title-format)
|
||||
(funcall arcology-link-title-format title)
|
||||
(format arcology-link-title-format title)))
|
||||
|
||||
(defun arcology--format-link (target &optional description)
|
||||
"Formats an org link for a given file TARGET and link DESCRIPTION."
|
||||
(let* ((here (ignore-errors
|
||||
(-> (or (buffer-base-buffer)
|
||||
(current-buffer))
|
||||
(buffer-file-name)
|
||||
(file-truename)
|
||||
(file-name-directory)))))
|
||||
(org-link-make-string
|
||||
(concat "file:" (if here
|
||||
(file-relative-name target here)
|
||||
target))
|
||||
description)))
|
||||
|
||||
(defun arcology--get-title-path-completions ()
|
||||
"Return an alist for completion.
|
||||
The car is the displayed title for completion, and the cdr is the
|
||||
to the file."
|
||||
(let* ((rows (arcology-db-query [:select [titles:file titles:titles tags:tags files:meta] :from titles
|
||||
:left :join tags
|
||||
:on (= titles:file tags:file)
|
||||
:left :join files
|
||||
:on (= titles:file files:file)]))
|
||||
completions)
|
||||
(seq-sort-by (lambda (x)
|
||||
(plist-get (nth 3 x) :mtime))
|
||||
#'time-less-p
|
||||
rows)
|
||||
(dolist (row rows completions)
|
||||
(pcase-let ((`(,file-path ,titles ,tags) row))
|
||||
(let ((titles (or titles (list (arcology--path-to-slug file-path)))))
|
||||
(dolist (title titles)
|
||||
(let ((k (concat
|
||||
(when tags
|
||||
(format "(%s) " (s-join arcology-tag-separator tags)))
|
||||
title))
|
||||
(v (list :path file-path :title title)))
|
||||
(push (cons k v) completions))))))))
|
||||
|
||||
|
||||
|
||||
;;;###autoload
|
||||
(defun arcology-version (&optional message)
|
||||
"Return `arcology' version.
|
||||
Interactively, or when MESSAGE is non-nil, show in the echo area."
|
||||
(interactive)
|
||||
(let* ((version
|
||||
(with-temp-buffer
|
||||
(insert-file-contents-literally (locate-library "arcology.el"))
|
||||
(goto-char (point-min))
|
||||
(save-match-data
|
||||
(if (re-search-forward "\\(?:;; Version: \\([^z-a]*?$\\)\\)" nil nil)
|
||||
(substring-no-properties (match-string 1))
|
||||
"N/A")))))
|
||||
(if (or message (called-interactively-p 'interactive))
|
||||
(message "%s" version)
|
||||
version)))
|
||||
|
||||
(provide 'arcology)
|
||||
;;; arcology.el ends here
|
||||
Loading…
Reference in New Issue