Skip to content

Commit

Permalink
Change: (helm-org-ql.el) Headers, requirements
Browse files Browse the repository at this point in the history 
Preparing for it to be a separate package.
  • Loading branch information
@alphapapa
alphapapa committed Nov 23, 2020
1 parent c3e23c3 commit 92d0e27
Showing 1 changed file with 131 additions and 141 deletions.
272 changes: 131 additions & 141 deletions helm-org-ql.el
View file
Original file line number Diff line number Diff line change
Expand Up @@ -2,6 +2,8 @@

;; Author: Adam Porter <adam@alphapapa.net>
;; URL: https://github.com/alphapapa/org-ql
;; Version: 0.6-pre
;; Package-Requires: ((emacs "26.1") (dash "2.17.0") (s "1.12.0") (helm-org "1.0") (org-ql "0.6-pre"))

;;; Commentary:

Expand All @@ -28,84 +30,72 @@

;;; Code:

(eval-and-compile
;;;; Requirements

(require 'org)
(require 'org-ql)
(require 'org-ql-search)
(require 'cl-lib)
(require 'org)

;;;; Compatibility
(require 'dash)
(require 's)

;; Declare Helm functions since Helm may not be installed.
(declare-function helm "ext:helm")
(declare-function helm-run-after-exit "ext:helm")
(declare-function helm-window "ext:helm-lib")
(declare-function helm-buffer-get "ext:helm-lib")
(declare-function helm-make-source "ext:helm-source")
(declare-function helm-org-goto-marker "ext:helm-org")
(require 'helm)
(require 'helm-org)

;; Silence byte-compiler about variables.
(defvar helm-map)
(defvar helm-pattern)
(defvar helm-input-idle-delay)

(when (require 'helm nil 'noerror)

;; Requirements.
(require 'helm-org)
(require 'org-ql)
(require 'org-ql-search)

;;;; Variables

(defvar helm-org-ql-map
(let ((map (make-sparse-keymap))
(mappings '("C-x C-s" helm-org-ql-save)))
(cl-loop for (key fn) on mappings by #'cddr
do (define-key map (kbd key) fn))
(make-composed-keymap map helm-map))
"Keymap for `helm-org-ql' sessions.
(defvar helm-org-ql-map
(let ((map (make-sparse-keymap))
(mappings '("C-x C-s" helm-org-ql-save)))
(cl-loop for (key fn) on mappings by #'cddr
do (define-key map (kbd key) fn))
(make-composed-keymap map helm-map))
"Keymap for `helm-org-ql' sessions.
Based on `helm-map'.")

(defvar helm-source-org-ql-views
(helm-make-source "Org QL Views" 'helm-source-sync
:candidates (lambda ()
(->> org-ql-views
(-map #'car)
(-sort #'string<)))
:action (list (cons "Show view" #'org-ql-view)))
"Helm source for `org-ql-views'.")
(defvar helm-source-org-ql-views
(helm-make-source "Org QL Views" 'helm-source-sync
:candidates (lambda ()
(->> org-ql-views
(-map #'car)
(-sort #'string<)))
:action (list (cons "Show view" #'org-ql-view)))
"Helm source for `org-ql-views'.")

(with-no-warnings
;; Silence compiler warning: "‘make-variable-buffer-local’ not called at toplevel"
(defvar-local helm-org-ql-buffers-files nil
"Used for `helm-org-ql-save'."))
(with-no-warnings
;; Silence compiler warning: "‘make-variable-buffer-local’ not called at toplevel"
(defvar-local helm-org-ql-buffers-files nil
"Used for `helm-org-ql-save'."))

;;;; Customization

(defgroup helm-org-ql nil
"Options for `helm-org-ql'."
:group 'org-ql)
(defgroup helm-org-ql nil
"Options for `helm-org-ql'."
:group 'org-ql)

(defcustom helm-org-ql-reverse-paths t
"Whether to reverse Org outline paths in `helm-org-ql' results."
:type 'boolean)
(defcustom helm-org-ql-reverse-paths t
"Whether to reverse Org outline paths in `helm-org-ql' results."
:type 'boolean)

(defcustom helm-org-ql-input-idle-delay 0.25
"Seconds to wait after typing stops before running query."
:type 'number)
(defcustom helm-org-ql-input-idle-delay 0.25
"Seconds to wait after typing stops before running query."
:type 'number)

(defcustom helm-org-ql-actions
(list (cons "Show heading in source buffer" 'helm-org-ql-show-marker)
(cons "Show heading in indirect buffer" 'helm-org-ql-show-marker-indirect))
"Alist of actions for `helm-org-ql' commands."
:type '(alist :key-type (string :tag "Description")
:value-type (function :tag "Command")))
(defcustom helm-org-ql-actions
(list (cons "Show heading in source buffer" 'helm-org-ql-show-marker)
(cons "Show heading in indirect buffer" 'helm-org-ql-show-marker-indirect))
"Alist of actions for `helm-org-ql' commands."
:type '(alist :key-type (string :tag "Description")
:value-type (function :tag "Command")))

;;;; Commands

;;;###autoload
(cl-defun helm-org-ql (buffers-files
&key (boolean 'and) (name "helm-org-ql"))
"Display results in BUFFERS-FILES for an `org-ql' non-sexp query using Helm.
(cl-defun helm-org-ql (buffers-files
&key (boolean 'and) (name "helm-org-ql"))
"Display results in BUFFERS-FILES for an `org-ql' non-sexp query using Helm.
Interactively, search the current buffer. Note that this command
only accepts non-sexp, \"plain\" queries.
Expand All @@ -132,99 +122,99 @@ However, quoted strings remain quoted, so this input:
Is transformed into this query:
(and \"something else\" (tags \"funny\"))"
(interactive (list (current-buffer)))
(let ((boolean (if current-prefix-arg 'or boolean))
(helm-input-idle-delay helm-org-ql-input-idle-delay))
(helm :prompt (format "Query (boolean %s): " (-> boolean symbol-name upcase))
:sources (helm-org-ql-source buffers-files :name name))))
(interactive (list (current-buffer)))
(let ((boolean (if current-prefix-arg 'or boolean))
(helm-input-idle-delay helm-org-ql-input-idle-delay))
(helm :prompt (format "Query (boolean %s): " (-> boolean symbol-name upcase))
:sources (helm-org-ql-source buffers-files :name name))))

;;;###autoload
(defun helm-org-ql-agenda-files ()
"Search agenda files with `helm-org-ql', which see."
(interactive)
(helm-org-ql (org-agenda-files) :name "Org Agenda Files"))
(defun helm-org-ql-agenda-files ()
"Search agenda files with `helm-org-ql', which see."
(interactive)
(helm-org-ql (org-agenda-files) :name "Org Agenda Files"))

;;;###autoload
(defun helm-org-ql-org-directory ()
"Search Org files in `org-directory' with `helm-org-ql'."
(interactive)
(helm-org-ql (org-ql-search-directories-files)
:name "Org Directory Files"))

(defun helm-org-ql-show-marker (marker)
"Show heading at MARKER."
(interactive)
;; This function is necessary because `helm-org-goto-marker' calls
;; `re-search-backward' to go backward to the start of a heading,
;; which, when the marker is already at the desired heading, causes
;; it to go to the previous heading. I don't know why it does that.
(switch-to-buffer (marker-buffer marker))
(goto-char marker)
(org-show-entry))

(defun helm-org-ql-show-marker-indirect (marker)
"Show heading at MARKER with `org-tree-to-indirect-buffer'."
(interactive)
(helm-org-ql-show-marker marker)
(org-tree-to-indirect-buffer))

(defun helm-org-ql-save ()
"Show `helm-org-ql' search in an `org-ql-search' buffer."
(interactive)
(let ((buffers-files (with-current-buffer (helm-buffer-get)
helm-org-ql-buffers-files))
(query (org-ql--query-string-to-sexp helm-pattern)))
(helm-run-after-exit #'org-ql-search buffers-files query)))
(defun helm-org-ql-org-directory ()
"Search Org files in `org-directory' with `helm-org-ql'."
(interactive)
(helm-org-ql (org-ql-search-directories-files)
:name "Org Directory Files"))

(defun helm-org-ql-show-marker (marker)
"Show heading at MARKER."
(interactive)
;; This function is necessary because `helm-org-goto-marker' calls
;; `re-search-backward' to go backward to the start of a heading,
;; which, when the marker is already at the desired heading, causes
;; it to go to the previous heading. I don't know why it does that.
(switch-to-buffer (marker-buffer marker))
(goto-char marker)
(org-show-entry))

(defun helm-org-ql-show-marker-indirect (marker)
"Show heading at MARKER with `org-tree-to-indirect-buffer'."
(interactive)
(helm-org-ql-show-marker marker)
(org-tree-to-indirect-buffer))

(defun helm-org-ql-save ()
"Show `helm-org-ql' search in an `org-ql-search' buffer."
(interactive)
(let ((buffers-files (with-current-buffer (helm-buffer-get)
helm-org-ql-buffers-files))
(query (org-ql--query-string-to-sexp helm-pattern)))
(helm-run-after-exit #'org-ql-search buffers-files query)))

;;;###autoload
(defun helm-org-ql-views ()
"Show an `org-ql' view selected with Helm."
(interactive)
(helm :sources helm-source-org-ql-views))
(defun helm-org-ql-views ()
"Show an `org-ql' view selected with Helm."
(interactive)
(helm :sources helm-source-org-ql-views))

;;;; Functions

(cl-defun helm-org-ql-source (buffers-files &key (name "helm-org-ql"))
"Return Helm source named NAME that searches BUFFERS-FILES with `helm-org-ql'."
;; Expansion of `helm-build-sync-source' macro.
(helm-make-source name 'helm-source-sync
:candidates (lambda ()
(let* ((query (org-ql--query-string-to-sexp helm-pattern))
(window-width (window-width (helm-window))))
(when query
(with-current-buffer (helm-buffer-get)
(setq helm-org-ql-buffers-files buffers-files))
(ignore-errors
;; Ignore errors that might be caused by partially typed queries.
(org-ql-select buffers-files query
:action `(helm-org-ql--heading ,window-width))))))
:match #'identity
:fuzzy-match nil
:multimatch nil
:nohighlight t
:volatile t
:keymap helm-org-ql-map
:action helm-org-ql-actions))

(defun helm-org-ql--heading (window-width)
"Return string for Helm for heading at point.
(cl-defun helm-org-ql-source (buffers-files &key (name "helm-org-ql"))
"Return Helm source named NAME that searches BUFFERS-FILES with `helm-org-ql'."
;; Expansion of `helm-build-sync-source' macro.
(helm-make-source name 'helm-source-sync
:candidates (lambda ()
(let* ((query (org-ql--query-string-to-sexp helm-pattern))
(window-width (window-width (helm-window))))
(when query
(with-current-buffer (helm-buffer-get)
(setq helm-org-ql-buffers-files buffers-files))
(ignore-errors
;; Ignore errors that might be caused by partially typed queries.
(org-ql-select buffers-files query
:action `(helm-org-ql--heading ,window-width))))))
:match #'identity
:fuzzy-match nil
:multimatch nil
:nohighlight t
:volatile t
:keymap helm-org-ql-map
:action helm-org-ql-actions))

(defun helm-org-ql--heading (window-width)
"Return string for Helm for heading at point.
WINDOW-WIDTH should be the width of the Helm window."
(font-lock-ensure (point-at-bol) (point-at-eol))
;; TODO: It would be better to avoid calculating the prefix and width
;; at each heading, but there's no easy way to do that once in each
;; buffer, unless we manually called `org-ql' in each buffer, which
;; I'd prefer not to do. Maybe I should add a feature to `org-ql' to
;; call a setup function in a buffer before running queries.
(let* ((prefix (concat (buffer-name) ":"))
(width (- window-width (length prefix)))
(heading (org-get-heading t))
(path (-> (org-get-outline-path)
(org-format-outline-path width nil "")
(org-split-string "")))
(path (if helm-org-ql-reverse-paths
(concat heading "\\" (s-join "\\" (nreverse path)))
(concat (s-join "/" path) "/" heading))))
(cons (concat prefix path) (point-marker))))))
(font-lock-ensure (point-at-bol) (point-at-eol))
;; TODO: It would be better to avoid calculating the prefix and width
;; at each heading, but there's no easy way to do that once in each
;; buffer, unless we manually called `org-ql' in each buffer, which
;; I'd prefer not to do. Maybe I should add a feature to `org-ql' to
;; call a setup function in a buffer before running queries.
(let* ((prefix (concat (buffer-name) ":"))
(width (- window-width (length prefix)))
(heading (org-get-heading t))
(path (-> (org-get-outline-path)
(org-format-outline-path width nil "")
(org-split-string "")))
(path (if helm-org-ql-reverse-paths
(concat heading "\\" (s-join "\\" (nreverse path)))
(concat (s-join "/" path) "/" heading))))
(cons (concat prefix path) (point-marker)))))

;;;; Footer

Expand Down

0 comments on commit 92d0e27

Please sign in to comment.