├── docs ├── dired.png └── pbui.png ├── pbui-util.el ├── pbui-org.el ├── pbui-email.el ├── TODO ├── pbui-dired.el ├── pbui-standard-commands.el ├── pbui-calendar.el ├── README.org ├── pbui-contacts-app.el └── pbui.el /docs/dired.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mmontone/pbui/HEAD/docs/dired.png -------------------------------------------------------------------------------- /docs/pbui.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mmontone/pbui/HEAD/docs/pbui.png -------------------------------------------------------------------------------- /pbui-util.el: -------------------------------------------------------------------------------- 1 | (defun inspect-text-properties-at-point () 2 | (interactive) 3 | (inspector-inspect (text-properties-at (point)))) 4 | 5 | (defun inspect-presentation-at-point () 6 | (interactive) 7 | (let ((presentation (presentation-at-point))) 8 | (inspector-inspect presentation))) 9 | -------------------------------------------------------------------------------- /pbui-org.el: -------------------------------------------------------------------------------- 1 | (require 'pbui) 2 | (require 'org) 3 | 4 | (def-presentation-command (org-commands:link-files 5 | :title "Org: Link file(s)" 6 | :condition (lambda (ps) (eql major-mode 'org-mode))) 7 | ((files file)) 8 | (dolist (file files) 9 | (org-insert-link nil file) 10 | (insert " "))) 11 | 12 | (provide 'pbui-org) 13 | -------------------------------------------------------------------------------- /pbui-email.el: -------------------------------------------------------------------------------- 1 | (require 'pbui) 2 | (require 'mml) 3 | 4 | (def-presentation-command (email-commands:attach-files 5 | :title "Attach file(s) to email" 6 | :description "Attach files to email composition" 7 | :condition (lambda (ps) mml-mode)) 8 | ((files file)) 9 | (dolist (file files) 10 | (mml-attach-file file))) 11 | 12 | (def-presentation-command (email-commands:set-email-to-field 13 | :title "Set email message 'to' field" 14 | :description "Set email message 'to' field" 15 | :condition (lambda (ps) mml-mode)) 16 | ((emails email)) 17 | (message-goto-to) 18 | (dolist (email emails) 19 | (insert email) 20 | (insert ", ")) 21 | (delete-region (- (point) 2) (point))) 22 | 23 | (provide 'pbui-email) 24 | -------------------------------------------------------------------------------- /TODO: -------------------------------------------------------------------------------- 1 | - select-all-presentations-alike-at-point: command for selecting all presentations with the same type as the one at point in the buffer. 2 | - implement filtered selection of presentations. the user can select a predicate to use for selecting from a list of presentations. 3 | - select marked text as a presentation. for example, parse some text and create a date, path, etc. when enabled, select-presentation-at-point could fall back to select marked text as presentation, when there's marked text. 4 | - command to reverse the order of selected presentations? 5 | - consider implementing an interaction mode in which a command is selected first, and then its arguments are filled by selecting matching presentations after, like in CLIM. 6 | - consider the possibility of adding options to commands, and let the user select them before running (look at magit-popup library!). 7 | - consider adding a multiplicity option to parameters in commands. for example, (users user :multiple t). 8 | - consider adding an ordered option to commands, that indicates if the command parameters should come in order or not for it to match. 9 | - Dired extension: add Dired directory presentations. 10 | - Consider predicates as types in presentations definitions. '(type-predicate my-app:user-p value user). 11 | - Implement commands UNDO?? 12 | - IDEA: updating presentations. Presentations that listen to some event and redisplay when a change occurs. 13 | - IMPLEMENT UNIT TESTS!! 14 | - Write a TexInfo manual. 15 | - Package and ship accordingly. -------------------------------------------------------------------------------- /pbui-dired.el: -------------------------------------------------------------------------------- 1 | ;;; pbui-dired.el --- Dired patch for PBUI -*- lexical-binding: t -*- 2 | 3 | ;; Copyright (C) 2021 Mariano Montone 4 | 5 | ;; Author: Mariano Montone 6 | ;; URL: https://github.com/mmontone/pbui 7 | ;; Keywords: user-interface 8 | ;; Version: 0.1 9 | ;; Package-Requires: ((emacs "25") (dash "2.19.1")) 10 | 11 | ;; This program is free software; you can redistribute it and/or modify 12 | ;; it under the terms of the GNU General Public License as published by 13 | ;; the Free Software Foundation, either version 3 of the License, or 14 | ;; (at your option) any later version. 15 | 16 | ;; This program is distributed in the hope that it will be useful, 17 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 18 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 19 | ;; GNU General Public License for more details. 20 | 21 | ;; You should have received a copy of the GNU General Public License 22 | ;; along with this program. If not, see . 23 | 24 | ;;; Commentary: 25 | 26 | ;; Patch that makes Dired presentation aware (PBUI). 27 | 28 | ;;; Code: 29 | 30 | (require 'dired) 31 | (require 'pbui) 32 | (require 'pbui-standard-commands) 33 | 34 | ;; dired patch for presentations 35 | 36 | (defun dired-insert-set-properties (beg end) 37 | "Add various text properties to the lines in the region." 38 | (save-excursion 39 | (let ((directory-name (buffer-substring-no-properties 40 | 1 41 | (progn 42 | (goto-char 0) 43 | (end-of-line) 44 | (backward-char) 45 | (point))))) 46 | (goto-char beg) 47 | (while (< (point) end) 48 | (identity 49 | (if (not (dired-move-to-filename)) 50 | (unless (or (looking-at-p "^$") 51 | (looking-at-p dired-subdir-regexp)) 52 | (put-text-property (line-beginning-position) 53 | (1+ (line-end-position)) 54 | 'invisible 'dired-hide-details-information)) 55 | (put-text-property (+ (line-beginning-position) 1) (1- (point)) 56 | 'invisible 'dired-hide-details-detail) 57 | (let* ((filename-start (point)) 58 | (filename-end (progn (dired-move-to-end-of-filename) 59 | (point))) 60 | (filename (buffer-substring-no-properties filename-start filename-end)) 61 | (filepath (string-trim (cl-concatenate 'string directory-name "/" filename)))) 62 | (add-text-properties 63 | filename-start 64 | filename-end 65 | `(mouse-face 66 | highlight 67 | dired-filename t 68 | help-echo "mouse-2: visit this file in other window" 69 | presentation (type ,(if (file-directory-p filepath) 70 | 'directory 71 | 'file) 72 | value ,filepath)))) 73 | (when (< (+ (point) 4) (line-end-position)) 74 | (put-text-property (+ (point) 4) (line-end-position) 75 | 'invisible 'dired-hide-details-link)))) 76 | (forward-line 1))))) 77 | 78 | (provide 'pbui-dired) 79 | 80 | ;;; pbui-dired ends here 81 | -------------------------------------------------------------------------------- /pbui-standard-commands.el: -------------------------------------------------------------------------------- 1 | ;;; pbui-standard-commands.el --- Standard commands for PBUI -*- lexical-binding: t -*- 2 | 3 | ;; Copyright (C) 2021 Mariano Montone 4 | 5 | ;; Author: Mariano Montone 6 | ;; URL: https://github.com/mmontone/pbui 7 | ;; Keywords: user-interface 8 | ;; Version: 0.1 9 | ;; Package-Requires: ((emacs "25") (dash "2.19.1")) 10 | 11 | ;; This program is free software; you can redistribute it and/or modify 12 | ;; it under the terms of the GNU General Public License as published by 13 | ;; the Free Software Foundation, either version 3 of the License, or 14 | ;; (at your option) any later version. 15 | 16 | ;; This program is distributed in the hope that it will be useful, 17 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 18 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 19 | ;; GNU General Public License for more details. 20 | 21 | ;; You should have received a copy of the GNU General Public License 22 | ;; along with this program. If not, see . 23 | 24 | ;;; Commentary: 25 | 26 | ;; A set of standard commands for PBUI. 27 | 28 | ;;; Code: 29 | 30 | (require 'pbui) 31 | 32 | (def-presentation-command (standard-commands:open-files 33 | :title "Open file(s)" 34 | :description "Open file(s) in a new buffer") 35 | ((files file)) 36 | (dolist (file files) 37 | (find-file file))) 38 | 39 | (def-presentation-command (standard-commands:delete-files 40 | :title "Delete file(s)" 41 | :description "Delete file(s)") 42 | ((files file)) 43 | (when (yes-or-no-p (format "Delete the %d selected files?" (length files))) 44 | (dolist (file files) 45 | (delete-file file)) 46 | (message (format "%d files deleted" (length files))))) 47 | 48 | (def-presentation-command (standard-commands:copy-files-to-directory 49 | :title "Copy file(s) to directory" 50 | :description "Copy file(s) to directory") 51 | ((files file) (dir directory)) 52 | (dolist (file files) 53 | (copy-file file 54 | (file-name-concat dir (file-name-nondirectory file)))) 55 | (message (format "%d files copied to %s" (length files) dir))) 56 | 57 | (def-presentation-command (standard-commands:move-files-to-directory 58 | :title "Move file(s) to directory" 59 | :description "Move file(s) to directory") 60 | ((files file) (dir directory)) 61 | (dolist (file files) 62 | (rename-file file 63 | (file-name-concat dir (file-name-nondirectory file)))) 64 | (message (format "%d files moved to %s" (length files) dir))) 65 | 66 | (def-presentation-command (standard-commands:move-files-to-trash 67 | :title "Move file(s) to trash" 68 | :description "Move file(s) to trash") 69 | ((files file)) 70 | (dolist (file files) 71 | (move-file-to-trash file)) 72 | (message (format "%d files moved to trash" (length files)))) 73 | 74 | (def-presentation-command (standard-commands:rename-files 75 | :title "Rename file(s)" 76 | :description "Rename files(s)") 77 | ((files file)) 78 | (dolist (file files) 79 | (let ((newname (read-from-minibuffer "New file name: "))) 80 | (rename-file file newname) 81 | (message "File renamed")))) 82 | 83 | (def-presentation-command (send-email 84 | :title "Send email" 85 | :description "Send email") 86 | 87 | ((emails email)) 88 | (call-process "/usr/bin/xdg-open" nil nil nil 89 | (format "mailto:%s" (s-join "," emails)))) 90 | 91 | (when (featurep 'inspector) 92 | (defun inspect-presentation-at-point () 93 | (interactive) 94 | (let ((presentation (presentation-at-point))) 95 | (when presentation 96 | (inspector-inspect presentation))))) 97 | 98 | 99 | (provide 'pbui-standard-commands) 100 | 101 | ;;; pbui-standard-commands ends here 102 | -------------------------------------------------------------------------------- /pbui-calendar.el: -------------------------------------------------------------------------------- 1 | ;;; pbui-calendar.el --- Calendar patch for PBUI -*- lexical-binding: t -*- 2 | 3 | ;; Copyright (C) 2021 Mariano Montone 4 | 5 | ;; Author: Mariano Montone 6 | ;; URL: https://github.com/mmontone/pbui 7 | ;; Keywords: user-interface 8 | ;; Version: 0.1 9 | ;; Package-Requires: ((emacs "25") (dash "2.19.1")) 10 | 11 | ;; This program is free software; you can redistribute it and/or modify 12 | ;; it under the terms of the GNU General Public License as published by 13 | ;; the Free Software Foundation, either version 3 of the License, or 14 | ;; (at your option) any later version. 15 | 16 | ;; This program is distributed in the hope that it will be useful, 17 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 18 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 19 | ;; GNU General Public License for more details. 20 | 21 | ;; You should have received a copy of the GNU General Public License 22 | ;; along with this program. If not, see . 23 | 24 | ;;; Commentary: 25 | 26 | ;; Patch that makes Calendar presentation aware (PBUI). 27 | 28 | ;;; Code: 29 | 30 | (require 'calendar) 31 | 32 | (defun calendar-generate-month (month year indent) 33 | "Produce a calendar for MONTH, YEAR on the Gregorian calendar. 34 | The calendar is inserted at the top of the buffer in which point is 35 | currently located, but indented INDENT spaces. The indentation is 36 | done from the first character on the line and does not disturb the 37 | first INDENT characters on the line." 38 | (let ((blank-days ; at start of month 39 | (mod 40 | (- (calendar-day-of-week (list month 1 year)) 41 | calendar-week-start-day) 42 | 7)) 43 | (last (calendar-last-day-of-month month year)) 44 | (trunc (min calendar-intermonth-spacing 45 | (1- calendar-left-margin))) 46 | (day 1) 47 | j) 48 | (goto-char (point-min)) 49 | (calendar-move-to-column indent) 50 | (insert 51 | (calendar-dlet ((month month) (year year)) 52 | (calendar-string-spread (list calendar-month-header) 53 | ?\s calendar-month-digit-width))) 54 | (calendar-ensure-newline) 55 | (calendar-insert-at-column indent calendar-intermonth-header trunc) 56 | ;; Use the first N characters of each day to head the columns. 57 | (dotimes (i 7) 58 | (setq j (mod (+ calendar-week-start-day i) 7)) 59 | (insert 60 | (truncate-string-to-width 61 | (propertize (calendar-day-name j 'header t) 62 | 'font-lock-face (if (memq j calendar-weekend-days) 63 | 'calendar-weekend-header 64 | 'calendar-weekday-header)) 65 | calendar-day-header-width nil ?\s) 66 | (make-string (- calendar-column-width calendar-day-header-width) ?\s))) 67 | (calendar-ensure-newline) 68 | (calendar-dlet ((day day) (month month) (year year)) 69 | (calendar-insert-at-column indent calendar-intermonth-text trunc)) 70 | ;; Add blank days before the first of the month. 71 | (insert (make-string (* blank-days calendar-column-width) ?\s)) 72 | ;; Put in the days of the month. 73 | (dotimes (i last) 74 | (setq day (1+ i)) 75 | ;; TODO should numbers be left-justified, centered...? 76 | (insert (propertize 77 | (format (format "%%%dd" calendar-day-digit-width) day) 78 | 'mouse-face 'highlight 79 | 'help-echo (calendar-dlet ((day day) (month month) (year year)) 80 | (eval calendar-date-echo-text t)) 81 | ;; 'date property prevents intermonth text confusing re-searches. 82 | ;; (Tried intangible, it did not really work.) 83 | 'date t 84 | 'presentation (list 'type 'date 85 | 'value (list month day year) 86 | 'printer (lambda (date) 87 | (calendar-iso-date-string 88 | date)))) 89 | (make-string 90 | (- calendar-column-width calendar-day-digit-width) ?\s)) 91 | (when (and (zerop (mod (+ day blank-days) 7)) 92 | (/= day last)) 93 | (calendar-ensure-newline) 94 | (setq day (1+ day)) ; first day of next week 95 | (calendar-dlet ((day day) (month month) (year year)) 96 | (calendar-insert-at-column indent calendar-intermonth-text trunc)))))) 97 | 98 | (provide 'pbui-calendar) 99 | -------------------------------------------------------------------------------- /README.org: -------------------------------------------------------------------------------- 1 | * PBUI 2 | 3 | ** Introduction 4 | 5 | PBUI is a Presentation Based User Interface for Emacs. 6 | 7 | This is work in progress. 8 | 9 | [[file:docs/pbui.png]] 10 | 11 | ** Installation 12 | 13 | #+BEGIN_SRC emacs-lisp 14 | 15 | (push "/home/marian/src/pbui/" load-path) 16 | 17 | (use-package pbui 18 | :bind 19 | (("C- " . pbui-modal-mode)) 20 | :config (progn 21 | (pbui-mode +1) 22 | ;; PBUI commands prefix 23 | (define-key pbui-mode-map (kbd "C-") 'pbui-command-map))) 24 | 25 | #+END_SRC 26 | 27 | ** Presentation Based User Interfaces 28 | 29 | A Presentation Based User Interface provides a uniform way of interacting with domain objects across applications. 30 | 31 | In a PBUI, whenever a domain object is displayed, it gets attached to its printed representation. 32 | Then those domain objects can be selected by the user by clicking on their printed representation, and then run commands that work on the type of objects selected. 33 | 34 | ** Usage 35 | 36 | The way *PBUI* works is by letting the user select the presentations he wants to work on first, then run a command that works over those presentations. 37 | 38 | An example of that could be to first select a bunch of files and a directory, then run some command that works with those arguments, like *Move files to directory* or *Copy files to directory*. 39 | 40 | Use *PBUI* global commands/keybindings or enter *PBUI* modal mode with *C-*. 41 | 42 | 43 | *** PBUI modes 44 | 45 | **** PBUI global mode 46 | 47 | The global mode *pbui-mode* is initialized in *.emacs* init file. It sets up PBUI commands bindings with a prefix key. 48 | 49 | #+begin_src emacs-lisp 50 | ;; Enable PBUI mode globally 51 | (pbui-mode +1) 52 | ;; PBUI commands prefix 53 | (define-key pbui-mode-map (kbd "C-") 'pbui-command-map) 54 | #+end_src 55 | 56 | This mode allows the operation on presentations across Emacs, but doesn't provide any feedback when cursor or mouse move over presentations. 57 | 58 | **** PBUI interactive mode 59 | 60 | The *pbui-interactive-mode* provides the same key bindings as *pbui-mode* but also highlights presentations when moving the text cursor or mouse over them. 61 | 62 | **** PBUI modal mode 63 | 64 | The *pbui-modal-mode* offers a set of "modal" key bindings after it is enabled. 65 | 66 | By default, you can enter the modal mode using *C- *. 67 | 68 | The modal keybindings are: 69 | 70 | *space*: Select/unselect presentation at point. 71 | 72 | *x* : Run commands with the selected presentations as arguments. 73 | 74 | *X* : Ensure presentation at point is selected and run command after. 75 | 76 | *DEL*: Clear the list of selected presentations. 77 | 78 | *n* : Navigate to next presentation in current buffer. 79 | 80 | *b* : Navigate to previous presentation in current buffer. 81 | 82 | *v*: visualize a list of currently selected presentations. 83 | 84 | *ESC* or *q*: exit the PBUI modal mode. 85 | 86 | ** Demo application 87 | 88 | A presentation based demo application is included. It is a contacts management application that uses presentations for displaying contacts data. 89 | 90 | #+BEGIN_SRC emacs-lisp 91 | (require 'pbui-contacts-app) 92 | #+END_SRC 93 | 94 | Then run *contacts-app* Emacs command to start the application. 95 | 96 | Once the application start, enter *PBUI* mode. Select presentations and run commands. 97 | 98 | ** Dired extension 99 | 100 | *PBUI* includes a *Dired* extension that makes Dired presentation based. 101 | 102 | To install: 103 | 104 | #+BEGIN_SRC emacs-lisp 105 | (require 'pbui-dired) 106 | #+END_SRC 107 | 108 | After that, after entering *PBUI* mode, *Dired* files are highlighted as presentations. 109 | 110 | [[file:docs/dired.png]] 111 | 112 | ** Combining presentations from different applications 113 | 114 | A very powerful aspect of Presentation Based User Interfaces is that presentations can be combined between applications. 115 | 116 | As an example, try selecting files in Dired (after enabling *PBUI* mode). Then select some users from the contacts demo application. 117 | Finally hit *x* and choose *Send files by email* command (this needs Thunderbird on Linux at the moment). 118 | 119 | ** Developing Presentation Based applications with PBUI 120 | 121 | Developing Presentation Based applications is as easy as adding some specific text properties to inserted text in our application buffer. That's it. There are no more requirements. 122 | 123 | To make some application Presentation Based aware, there's no need of requiring *PBUI* library, nor define any commands; only requirement is to attach application objects to the inserted text like explained below: 124 | 125 | *** Inserting presentations in buffers 126 | 127 | A presentation associates graphical output with application objects. 128 | In *PBUI* that is done via Emacs text properties; a text property named *presentation* is attached to the inserted buffer text. 129 | The property value is a property list with *type* and *value* keys. *value* can contain any application object; that's the object associated to the presentation. 130 | *type* has the type of the presented object. 131 | 132 | Some examples of this: 133 | 134 | - presentation for an email object: 135 | 136 | #+begin_src emacs-lisp 137 | (insert (propertize "john@mail.com" 'presentation '(type email value "john@mail.com"))) 138 | #+end_src 139 | 140 | - presentation for a file object: 141 | 142 | #+begin_src emacs-lisp 143 | (insert (propertize "/usr/bin/foo" 'presentation '(type file value "/usr/bin/foo"))) 144 | #+end_src 145 | 146 | *** Defining commands 147 | 148 | Presented object are processed using commands that work on those presented objects (presentation commands). 149 | Presentation commands are defined using *def-presentation-command* macro. 150 | Only those command that match the types of the selected presented objects are made available to the user for execution. 151 | 152 | For example, this is the implemention of a presentation command for copying a selected file to a selected directory: 153 | 154 | #+begin_src emacs-lisp 155 | (def-presentation-command (standard-commands:copy-file-to-directory 156 | :title "Copy file to directory" 157 | :description "Copy file to directory") 158 | ((file file) (dir directory)) 159 | (copy-file file dir) 160 | (message "File copied to directory")) 161 | #+end_src 162 | 163 | ** References 164 | - Presentation Based User Interfaces - Ciccarelli, Eugene C. 165 | - User Interface Management Systems: The CLIM Perspective - Ralf Möller. 166 | - An Implementation of CLIM Presentation Types - Timothy Moore. 167 | - Holland, Simon & Oppenheim, Daniel. (1999). Direct Combination.. 262-269. 168 | - [[https://common-lisp.net/project/mcclim][McCLIM]] is a user interface framework for Common Lisp that is presentation based. 169 | -------------------------------------------------------------------------------- /pbui-contacts-app.el: -------------------------------------------------------------------------------- 1 | ;;; pbui-contacts-app.el --- A PBUI demo application -*- lexical-binding: t -*- 2 | 3 | ;; Copyright (C) 2021 Mariano Montone 4 | 5 | ;; Author: Mariano Montone 6 | ;; URL: https://github.com/mmontone/pbui 7 | ;; Keywords: user-interface 8 | ;; Version: 0.1 9 | ;; Package-Requires: ((emacs "25") (dash "2.19.1")) 10 | 11 | ;; This program is free software; you can redistribute it and/or modify 12 | ;; it under the terms of the GNU General Public License as published by 13 | ;; the Free Software Foundation, either version 3 of the License, or 14 | ;; (at your option) any later version. 15 | 16 | ;; This program is distributed in the hope that it will be useful, 17 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 18 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 19 | ;; GNU General Public License for more details. 20 | 21 | ;; You should have received a copy of the GNU General Public License 22 | ;; along with this program. If not, see . 23 | 24 | ;;; Commentary: 25 | 26 | ;; A PBUI demo application. 27 | 28 | ;; Load and then M-x contacts-app to run. 29 | 30 | ;;; Code: 31 | 32 | (require 'request) 33 | (require 's) 34 | (require 'calendar) 35 | (require 'outline) 36 | (require 'pbui) 37 | 38 | (defvar contacts-app:contacts nil) 39 | 40 | (defmacro with-text-properties (properties &rest body) 41 | `(let ((tp-start (point))) 42 | ,@body 43 | (set-text-properties tp-start (point) ,properties))) 44 | 45 | (defun contacts-app:user-fullname (user) 46 | (format "%s %s" (alist-get 'first (alist-get 'name user)) 47 | (alist-get 'last (alist-get 'name user)))) 48 | 49 | (defun contacts-app:user-id (user) 50 | (alist-get 'value (alist-get 'id user))) 51 | 52 | (defun contacts-app:user-email (user) 53 | (alist-get 'email user)) 54 | 55 | (defun contacts-app:phone (user) 56 | (alist-get 'phone user)) 57 | 58 | (defun contacts-app:create-user-birthday-event (user) 59 | (list 'title (format "%s birthday" (contacts-app:user-fullname user)) 60 | 'date (let ((date (parse-time-string (alist-get 'date (alist-get 'dob user))))) 61 | (setf (nth 5 date) (nth 2 (calendar-current-date))) 62 | date) 63 | 'date-string (alist-get 'date (alist-get 'dob user)) 64 | 'description (format "It is %s birthday." (contacts-app:user-fullname user)))) 65 | 66 | (defun contacts-app () 67 | "Contacts application entry point command." 68 | (interactive) 69 | (request "https://randomuser.me/api/?results=50" 70 | :success 71 | (cl-function 72 | (lambda (&key data &allow-other-keys) 73 | (setf contacts-app:contacts (alist-get 'results (json-read-from-string data))) 74 | (contacts-app-create-buffer))))) 75 | 76 | (defun contacts-app-create-buffer () 77 | (let ((buffer (get-buffer-create "*contacts-app*"))) 78 | (with-current-buffer buffer 79 | (cl-loop for user across contacts-app:contacts 80 | do 81 | ;; Heading 82 | (insert "* ") 83 | (with-text-properties 84 | (list 'presentation 85 | (list 'type 'contacts-app:user 86 | 'value user 87 | 'printer 'contacts-app:user-fullname)) 88 | (insert (contacts-app:user-fullname user))) 89 | 90 | (insert " - ") 91 | 92 | (with-text-properties 93 | (list 'presentation 94 | (list 'type 'email 95 | 'value (alist-get 'email user))) 96 | (insert (alist-get 'email user))) 97 | 98 | (newline) 99 | 100 | ;; Body 101 | (insert "- Fullname: " (alist-get 'first (alist-get 'name user)) 102 | " " (alist-get 'last (alist-get 'name user))) 103 | (newline) 104 | (insert "- Email: " (propertize (alist-get 'email user) 105 | 'presentation 106 | (list 'type 'email 107 | 'value (alist-get 'email user)))) 108 | (newline) 109 | (insert "- Phone: " (propertize (alist-get 'phone user) 110 | 'presentation 111 | (list 'type 'phone 112 | 'value (alist-get 'phone user)))) 113 | (newline) 114 | (insert "- Cell: " (propertize (alist-get 'cell user) 115 | 'presentation 116 | (list 'type 'phone 117 | 'value (alist-get 'cell user)))) 118 | 119 | (newline) 120 | (insert "- Birthdate: " 121 | (let ((birthdate (alist-get 'date (alist-get 'dob user)))) 122 | ;;(propertize birthdate 123 | ;; 'presentation 124 | ;; (list 'type 'date 125 | ;; 'value birthdate)) 126 | (propertize birthdate 127 | 'presentation 128 | (list 'type 'calendar-event 129 | 'value (contacts-app:create-user-birthday-event user) 130 | 'printer (lambda (event) 131 | (format "Calendar event - %s" (cl-getf event 'title))))))) 132 | 133 | (newline)) 134 | (outline-mode) 135 | (outline-hide-sublevels 1) 136 | (setq buffer-read-only t)) 137 | (pop-to-buffer buffer))) 138 | 139 | (def-presentation-command (contacts-app:delete-contacts 140 | :title "Delete contacts" 141 | :description "Delete contacts") 142 | ((users contacts-app:user)) 143 | (when (yes-or-no-p (format "Delete %d selected contacts?" 144 | (length users))) 145 | (let ((users-ids (cl-remove-if 'null (mapcar 'contacts-app:user-id users)))) 146 | (setf contacts-app:contacts 147 | (cl-delete-if (lambda (user) 148 | (cl-member (contacts-app:user-id user) 149 | users-ids)) 150 | contacts-app:contacts)) 151 | (let ((buffer (get-buffer "*contacts-app*"))) 152 | (with-current-buffer buffer 153 | (with-write-buffer 154 | (erase-buffer) 155 | (contacts-app-create-buffer)))) 156 | (message "Selected contacts deleted")))) 157 | 158 | (def-presentation-command (contacts-app:send-email 159 | :title "Send email" 160 | :description "Send email to contacts") 161 | 162 | ((users contacts-app:user)) 163 | (call-process "/usr/bin/xdg-open" nil nil nil 164 | (format "mailto:%s" (s-join "," (mapcar 'contacts-app:user-email users))))) 165 | 166 | (def-presentation-command (contacts-app:add-event-to-google-calendar 167 | :title "Add event to Google calendar" 168 | :description "Add event to Google calendar") 169 | ((event calendar-event)) 170 | (call-process "/usr/bin/xdg-open" nil nil nil 171 | (format "http://www.google.com/calendar/render?action=TEMPLATE&text=%s&dates=%s&details=%s&location=%s" 172 | (cl-getf event 'title) 173 | (format "%s%s%s" 174 | (nth 5 (cl-getf event 'date)) 175 | (nth 4 (cl-getf event 'date)) 176 | (nth 3 (cl-getf event 'date))) 177 | (cl-getf event 'description) 178 | ""))) 179 | 180 | (def-presentation-command (contacts-app:send-files-in-email 181 | :title "Send files by email" 182 | :description "Send files by email" 183 | :applyable-when (lambda (args) 184 | (and args 185 | (cl-some (lambda (arg) 186 | (member (cl-getf arg 'type) '(contacts-app:user email))) 187 | args) 188 | (cl-some (lambda (arg) 189 | (eql (cl-getf arg 'type) 'file)) args)))) 190 | ((users contacts-app:user) (emails email) (files file)) 191 | (let ((all-emails (append (mapcar 'contacts-app:user-email users) 192 | emails))) 193 | (call-process "/usr/bin/thunderbird" nil nil nil 194 | "-compose" 195 | (format "to='%s',attachment='%s'" 196 | (s-join "," (mapcar 'contacts-app:user-email users)) 197 | (s-join "," files))))) 198 | 199 | (def-presentation-command (contacts-app:insert-birthday-in-org 200 | :title "Insert birthday in org file" 201 | :description "Insert birthday in org file" 202 | :condition (lambda (ps) (and (featurep 'org) (eql major-mode 'org-mode)))) 203 | ((user contacts-app:user)) 204 | (insert 205 | (format-time-string 206 | (org-time-stamp-format) 207 | (parse-time-string 208 | (alist-get 'date (alist-get 'dob user)))))) 209 | 210 | (def-presentation-command (contacts-app:insert-calendar-event-in-org 211 | :title "Insert calendar event in org file" 212 | :description "Insert calendar event in org file" 213 | :condition (lambda (ps) (and (featurep 'org) (eql major-mode 'org-mode)))) 214 | ((event calendar-event)) 215 | (insert 216 | (format-time-string 217 | (org-time-stamp-format) 218 | (parse-time-string 219 | (cl-getf event 'date-string))))) 220 | 221 | (provide 'pbui-contacts-app) 222 | 223 | ;;; pbui-contacts-app ends here 224 | -------------------------------------------------------------------------------- /pbui.el: -------------------------------------------------------------------------------- 1 | ;;; pbui.el --- Presentation Based User Interface for Emacs -*- lexical-binding: t -*- 2 | 3 | ;; Copyright (C) 2021 Mariano Montone 4 | 5 | ;; Author: Mariano Montone 6 | ;; URL: https://github.com/mmontone/pbui 7 | ;; Keywords: user-interface 8 | ;; Version: 0.1 9 | ;; Package-Requires: ((emacs "25") (dash "2.19.1")) 10 | 11 | ;; This program is free software; you can redistribute it and/or modify 12 | ;; it under the terms of the GNU General Public License as published by 13 | ;; the Free Software Foundation, either version 3 of the License, or 14 | ;; (at your option) any later version. 15 | 16 | ;; This program is distributed in the hope that it will be useful, 17 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 18 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 19 | ;; GNU General Public License for more details. 20 | 21 | ;; You should have received a copy of the GNU General Public License 22 | ;; along with this program. If not, see . 23 | 24 | ;;; Commentary: 25 | 26 | ;; A Presentation Based User Interface for Emacs. 27 | 28 | ;;; Code: 29 | 30 | (require 'cl-lib) 31 | (require 'dash) 32 | 33 | ;;------ Customization -------------------------------------------------- 34 | 35 | (defgroup pbui () 36 | "Group for presentations." 37 | :group 'tools 38 | :group 'convenience 39 | :link '(url-link :tag "GitHub" "https://github.com/mmontone/pbui")) 40 | 41 | (defvar pbui:selected-presentations nil 42 | "The list of currently selected presentations.") 43 | 44 | (defcustom pbui:debug nil 45 | "Debug PBUI." 46 | :type 'boolean 47 | :group 'pbui) 48 | 49 | (defcustom pbui:reset-presentations-after-running-command t 50 | "Whether to reset presentations after running a command or not." 51 | :type 'boolean 52 | :group 'pbui) 53 | 54 | (defcustom pbui:exit-PBUI-modal-mode-after-running-command t 55 | "Wether to exit PBUI modal mode after running a command or not." 56 | :type 'boolean 57 | :group 'pbui) 58 | 59 | ;;------ Faces ----------------------------------------------------------- 60 | 61 | (defface presentation 62 | '((t :box (:line-width 1 :color "gray" :style nil))) 63 | "Face for presentations in PBUI" 64 | :group 'pbui) 65 | 66 | (defface selected-presentation 67 | '((t :box (:line-width 1 :color "gray" :style nil) 68 | :background "lightyellow")) 69 | "Face for presentations" 70 | :group 'pbui) 71 | 72 | (defface presentations-button 73 | '((((type x w32 ns) (class color)) ; Like default mode line 74 | :box (:line-width 2 :style released-button) 75 | :background "lightgrey" :foreground "black")) 76 | "Face for custom buffer buttons if `custom-raised-buttons' is non-nil." 77 | :group 'pbui) 78 | 79 | 80 | ;;------- The command object --------------------------------------------------- 81 | 82 | (defclass pbui:command () 83 | ((name :initarg :name 84 | :accessor pbui:command-name 85 | :type symbol 86 | :documentation "The unique name of the command.") 87 | (title :initarg :title 88 | :accessor pbui:command-title 89 | :type string 90 | :documentation "Title of the command. Appears in completion mini-buffer.") 91 | (description :initarg :description 92 | :type string 93 | :accessor pbui:command-description 94 | :documentation "Description of the command.") 95 | (condition :initarg :condition 96 | :accessor pbui:command-condition 97 | :initform nil 98 | :type (or null function symbol) 99 | :documentation "Predicate function that returns T when command can be applied.") 100 | (matching-predicate :initarg :applyable-when 101 | :accessor matching-predicate 102 | :initform nil 103 | :type (or null function symbol) 104 | :documentation "When present, this function is used for matching the set of selected presentations. Takes the list of selected presentations as parameter.") 105 | (argument-types :initarg :argument-types 106 | :accessor pbui:command-argument-types 107 | :initform nil 108 | :documentation "The type of arguments accepted by this command.") 109 | (handler :initarg :handler 110 | :accessor pbui:command-handler 111 | :type (or function symbol) 112 | :documentation "A function for running the command. Takes instances of ARGUMENT-TYPES as arguments.") 113 | (command-arglist :initarg :command-arglist 114 | :accessor pbui:command-arglist 115 | :documentation "Used internally by PBUI for destructuring and managing command handlers arguments.")) 116 | (:documentation "A command that runs with selected presentations as arguments.")) 117 | 118 | (defun presentation-at-point () 119 | (interactive) 120 | (get-text-property (point) 'presentation)) 121 | 122 | (defun reset-selected-presentations () 123 | (interactive) 124 | (unhighlight-selected-presentations) 125 | (setf pbui:selected-presentations nil) 126 | (pbui:refresh-selected-presentations) 127 | (message "Selected presentations reseted")) 128 | 129 | (defun presentation-selected-p (presentation) 130 | (cl-find presentation pbui:selected-presentations 131 | :key (lambda (sel) (cl-getf sel 'presentation)))) 132 | 133 | (defun presentation-value (presentation) 134 | (cl-getf presentation 'value)) 135 | 136 | (defun presentation-type (presentation) 137 | (cl-getf presentation 'type)) 138 | 139 | (defun ensure-selected-presentation-at-point () 140 | "Ensure that presentation at point is selected." 141 | (interactive) 142 | (let ((presentation (presentation-at-point))) 143 | (if presentation 144 | (when (not (presentation-selected-p presentation)) 145 | (select-presentation-at-point)) 146 | (message "No presentation at point")))) 147 | 148 | (defun toggle-presentation-selected-at-point () 149 | "Toggle presentation selected at cursor." 150 | (interactive) 151 | (let ((presentation (presentation-at-point))) 152 | (if presentation 153 | (if (presentation-selected-p presentation) 154 | (unselect-presentation-at-point) 155 | (select-presentation-at-point)) 156 | (message "No presentation at point")))) 157 | 158 | (defun pbui:goto-selected-presentation (selected-presentation) 159 | (let ((buffer (cl-getf sel 'buffer))) 160 | (when (buffer-live-p buffer) 161 | (switch-to-buffer-other-window buffer) 162 | (with-current-buffer buffer 163 | (goto-char (cl-getf sel 'position)))))) 164 | 165 | (defun pbui:print-presentation (presentation) 166 | (if (cl-getf presentation 'printer) 167 | (funcall (cl-getf presentation 'printer) (cl-getf presentation 'value)) 168 | (cl-getf presentation 'value))) 169 | 170 | (defun pbui:add-selected-presentation (presentation buffer position) 171 | ;; We record the presentation and buffer and position for selected presentations 172 | (let ((selection (list 173 | 'presentation presentation 174 | 'buffer (or buffer (current-buffer)) 175 | 'position (or position (point))))) 176 | (push selection 177 | pbui:selected-presentations) 178 | (pbui:refresh-selected-presentations) 179 | selection)) 180 | 181 | (defun select-presentation-at-point () 182 | "Add the presentation at point to the list of selected presentations." 183 | (interactive) 184 | (let ((presentation (presentation-at-point))) 185 | (if presentation 186 | (let ((selection 187 | (pbui:add-selected-presentation presentation (current-buffer) (point)))) 188 | (pbui:highlight-selected-presentation selection) 189 | (message "Selected: %s" (pbui:print-presentation presentation))) 190 | (message "No presentation at point")))) 191 | 192 | (defun pbui:remove-selected-presentation (presentation) 193 | (setq pbui:selected-presentations (cl-delete presentation pbui:selected-presentations :key (lambda (sel) (cl-getf sel 'presentation)))) 194 | (pbui:refresh-selected-presentations)) 195 | 196 | (defun unselect-presentation-at-point () 197 | "Remove the presentation at point from the list of selected presentations." 198 | (interactive) 199 | (let ((presentation (presentation-at-point))) 200 | (if presentation 201 | (progn 202 | (pbui:remove-selected-presentation presentation) 203 | (unhighlight-presentation-at-point) 204 | (message "Unselected: %s" 205 | (if (cl-getf presentation 'printer) 206 | (funcall (cl-getf presentation 'printer) (cl-getf presentation 'value)) 207 | (cl-getf presentation 'value)))) 208 | (message "No presentation at point")))) 209 | 210 | (defun select-presentation-at-point-and-run-command () 211 | "Add presentation at point and run command after." 212 | (interactive) 213 | (ensure-selected-presentation-at-point) 214 | (call-interactively 'run-presentations-command)) 215 | 216 | (defvar pbui:commands (make-hash-table :test 'equal)) 217 | 218 | (defun pbui:find-command (command-name) 219 | "Find PBUI command named with COMMAND-NAME." 220 | (gethash command-name pbui:commands)) 221 | 222 | (defmacro def-presentation-command (name-and-options args &rest body) 223 | (let ((command-name (if (listp name-and-options) 224 | (cl-first name-and-options) 225 | name-and-options)) 226 | (options (when (listp name-and-options) 227 | (cl-rest name-and-options)))) 228 | `(setf (gethash ',command-name pbui:commands) 229 | (make-instance 'pbui:command 230 | :name ',command-name 231 | :argument-types ',(and (not (cl-getf options :applyable-when)) 232 | (mapcar 'cl-second args)) 233 | :handler (lambda ,(if (eql (cl-first args) '&rest) 234 | args 235 | (mapcar 'cl-first args)) 236 | ,@body) 237 | :command-arglist ',args 238 | ,@options)))) 239 | 240 | (defun pbui:arg-multiple-p (argname) 241 | (cl-member (substring (symbol-name argname) -1) '("s" "*") 242 | :test 'string=)) 243 | 244 | (defun pbui:find-presentations-matching-argument (argspec presentations) 245 | "Find presentations in PRESENTATIONS that match ARGSPEC." 246 | (cl-destructuring-bind (argname argtype) argspec 247 | (cl-flet ((matches-p (p) 248 | (eql (presentation-type p) argtype))) 249 | (if (pbui:arg-multiple-p argname) 250 | ;; a multi-valued argument 251 | (cl-remove-if-not #'matches-p presentations) 252 | ;; a single valued argument 253 | (cl-find-if #'matches-p presentations))))) 254 | 255 | (defun pbui:assign-presentations-to-arguments (command presentations) 256 | "Assign PRESENTATIONS to COMMAND arguments." 257 | (let ((ps (cl-copy-list presentations))) 258 | (cl-loop for argspec in (pbui:command-arglist command) 259 | for matching-ps = (pbui:find-presentations-matching-argument argspec ps) 260 | do (setq ps (cl-set-difference ps matching-ps)) 261 | collect (cons (cl-first argspec) matching-ps)))) 262 | 263 | (defun pbui:command-matches (command presentations) 264 | "Return a list of (argument . presentation) when PRESENTATIONS match COMMAND, and NIL otherwise." 265 | ;; If command has a matching predicate, use it 266 | (if (matching-predicate command) 267 | (if pbui:debug 268 | (funcall (matching-predicate command) presentations) 269 | (ignore-errors (funcall (matching-predicate command) presentations))) 270 | ;; otherwise, a command matches the presentations if there are presentations for every argument in the command 271 | (let ((ps (cl-copy-list presentations))) 272 | (let ((arg-matches 273 | (pbui:assign-presentations-to-arguments command presentations))) 274 | (when (not (cl-position nil (mapcar 'cdr arg-matches))) 275 | arg-matches))))) 276 | 277 | (defun pbui:matching-presentations-commands () 278 | "Return a list of the matching commands for added presentation arguments." 279 | (let ((ps (mapcar (lambda (sel) (cl-getf sel 'presentation)) 280 | pbui:selected-presentations))) 281 | (cl-loop for command in (hash-table-values pbui:commands) 282 | when (and (or (not (pbui:command-condition command)) 283 | (funcall (pbui:command-condition command) ps)) 284 | (pbui:command-matches command ps)) 285 | collect command))) 286 | 287 | (defun pbui:run-command (command) 288 | "Run COMMAND. 289 | It is assumed that COMMAND matches the currently selected presentations. 290 | See: `pbui:command-matches'" 291 | (let ((ps (mapcar (lambda (sel) 292 | (cl-getf sel 'presentation)) 293 | pbui:selected-presentations))) 294 | (if (eql (cl-first (pbui:command-arglist command)) 295 | '&rest) 296 | (apply (pbui:command-handler command) 297 | (mapcar 'presentation-value 298 | (reverse ps))) 299 | ;; else 300 | (let ((arg-values (pbui:assign-presentations-to-arguments command ps))) 301 | (apply (pbui:command-handler command) 302 | (mapcar (lambda (arg-value) 303 | (let ((ps (cdr arg-value))) 304 | (if (pbui:arg-multiple-p (car arg-value)) 305 | (mapcar 'presentation-value ps) 306 | (presentation-value ps)))) 307 | arg-values)))))) 308 | 309 | ;; See: http://www.howardism.org/Technical/Emacs/alt-completing-read.html 310 | (defun alt-completing-read (prompt collection &optional predicate require-match initial-input hist def inherit-input-method) 311 | "Calls `completing-read' but returns the value from COLLECTION. 312 | 313 | Simple wrapper around the `completing-read' function that assumes 314 | the collection is either an alist, or a hash-table, and returns 315 | the _value_ of the choice, not the selected choice. For instance, 316 | give a variable of choices like: 317 | 318 | (defvar favorite-hosts '((\"Glamdring\" . \"192.168.5.12\") 319 | (\"Orcrist\" . \"192.168.5.10\") 320 | (\"Sting\" . \"192.168.5.220\") 321 | (\"Gungnir\" . \"192.168.5.25\"))) 322 | 323 | We can use this function to `interactive' without needing to call 324 | `alist-get' afterwards: 325 | 326 | (defun favorite-ssh (hostname) 327 | \"Start a SSH session to a given HOSTNAME.\" 328 | (interactive (list (alt-completing-read \"Host: \" favorite-hosts))) 329 | (message \"Rockin' and rollin' to %s\" hostname))" 330 | 331 | ;; Yes, Emacs really should have an `alistp' predicate to make this code more readable: 332 | (cl-flet ((assoc-list-p (obj) (and (listp obj) (consp (car obj))))) 333 | 334 | (let* ((choice 335 | (completing-read prompt collection predicate require-match initial-input hist def inherit-input-method)) 336 | (results (cond 337 | ((hash-table-p collection) (gethash choice collection)) 338 | ((assoc-list-p collection) (alist-get choice collection def nil 'equal)) 339 | (t choice)))) 340 | (if (listp results) (cl-first results) results)))) 341 | 342 | (defun pbui:read-command-name () 343 | (alt-completing-read "Command: " 344 | (mapcar (lambda (cmd) 345 | (cons (pbui:command-title cmd) 346 | (pbui:command-name cmd))) 347 | (pbui:matching-presentations-commands)))) 348 | 349 | (defun run-presentations-command (command-name) 350 | "Run a command that matches presentation arguments." 351 | (interactive (list 352 | (when (pbui:matching-presentations-commands) 353 | (pbui:read-command-name)))) 354 | (if (not command-name) 355 | (message (format "No matching command for the selected presentations (%d selected, %d in other buffers). Press v to view all selected presentations." 356 | (length pbui:selected-presentations) 357 | (length (cl-remove-if-not (lambda (sel) (eql (cl-getf sel 'buffer) (current-buffer))) pbui:selected-presentations)))) 358 | (let ((command (gethash command-name pbui:commands))) 359 | (when (null command) 360 | (message "Command not found: %s" command-name)) 361 | (pbui:run-command command) 362 | (when pbui:reset-presentations-after-running-command 363 | (reset-selected-presentations)) 364 | ;; Disable the global presentations mode after running a command 365 | (when (and pbui-modal-mode pbui:exit-PBUI-modal-mode-after-running-command) 366 | (disable-pbui-modal-mode))))) 367 | 368 | (defun presentation (value string &optional type) 369 | "Add presentation properties to STRING. 370 | TYPE is the type of presentation. 371 | VALUE is is the object being presented." 372 | (propertize string 'presentation 373 | (list 'type (or type (type-of value)) 374 | 'value value))) 375 | 376 | (defun present (value string &optional type) 377 | "Create and insert presentation." 378 | (insert (presentation value string type))) 379 | 380 | (defmacro with-write-buffer (&rest body) 381 | (let ((read-only-p (gensym "read-only"))) 382 | `(let ((,read-only-p buffer-read-only)) 383 | (setq buffer-read-only nil) 384 | ,@body 385 | (setq buffer-read-only ,read-only-p)))) 386 | 387 | (defun highlight-presentation-at-point () 388 | "Highlight the presentation at point." 389 | (let ((presentation (presentation-at-point))) 390 | (when presentation 391 | (unless (presentation-selected-p presentation) 392 | (save-excursion 393 | (goto-char (1+ (point))) 394 | (let ((prop (text-property-search-backward 'presentation)) 395 | (prop-next (text-property-search-forward 'presentation))) 396 | (with-write-buffer 397 | (put-text-property (prop-match-beginning prop) 398 | (prop-match-end prop-next) 399 | 'font-lock-face 'presentation)))))))) 400 | 401 | (defun unhighlight-presentation-at-point () 402 | (let ((presentation (presentation-at-point))) 403 | (when presentation 404 | (unless (presentation-selected-p presentation) 405 | (save-excursion 406 | (goto-char (1+ (point))) 407 | (let ((prop (text-property-search-backward 'presentation)) 408 | (prop-next (text-property-search-forward 'presentation))) 409 | (with-write-buffer 410 | (put-text-property (prop-match-beginning prop) 411 | (prop-match-end prop-next) 412 | 'font-lock-face nil)))))))) 413 | 414 | (defun pbui:highlight-selected-presentation (selection) 415 | (let ((buffer (cl-getf selection 'buffer))) 416 | (when (buffer-live-p buffer) 417 | (with-current-buffer buffer 418 | (save-excursion 419 | (goto-char (1+ (cl-getf selection 'position))) 420 | (let ((presentation (presentation-at-point))) 421 | (when presentation 422 | (let ((prop (text-property-search-backward 'presentation)) 423 | (prop-next (text-property-search-forward 'presentation))) 424 | (with-write-buffer 425 | (put-text-property (prop-match-beginning prop) 426 | (prop-match-end prop-next) 427 | 'font-lock-face 'selected-presentation)))))))))) 428 | 429 | (defun pbui:unhighlight-selected-presentation (selection) 430 | (let ((buffer (cl-getf selection 'buffer))) 431 | (when (buffer-live-p buffer) 432 | (with-current-buffer buffer 433 | (save-excursion 434 | (goto-char (1+ (cl-getf selection 'position))) 435 | (let ((prop (text-property-search-backward 'presentation)) 436 | (prop-next (text-property-search-forward 'presentation))) 437 | (with-write-buffer 438 | (put-text-property (prop-match-beginning prop) 439 | (prop-match-end prop-next) 440 | 'font-lock-face nil)))))))) 441 | 442 | (defun unhighlight-selected-presentations () 443 | "Unhighlight the currently selected presentations." 444 | (dolist (sel pbui:selected-presentations) 445 | (pbui:unhighlight-selected-presentation sel))) 446 | 447 | (defun highlight-selected-presentations () 448 | "Highlight the currently selected presentations." 449 | (dolist (sel pbui:selected-presentations) 450 | (pbui:highlight-selected-presentation sel))) 451 | 452 | (defun highlight-presentations-in-buffer () 453 | "Highlight the presentations in current buffer." 454 | (save-excursion 455 | (goto-char 0) 456 | (while (setq prop (text-property-search-forward 'presentation)) 457 | (put-text-property 458 | (prop-match-beginning prop) 459 | (prop-match-end prop) 460 | 'font-lock-face 'presentation)))) 461 | 462 | (defun pbui::map-presentations-in-buffer (func &optional buffer) 463 | "Map FUNC over all presentations in BUFFER. 464 | 465 | If BUFFER is not specified, current buffer is used. 466 | FUNC is passed the presentation object and the text being displayed." 467 | (let ((buf (or buffer (current-buffer)))) 468 | (save-excursion 469 | (goto-char 0) 470 | (while (setq prop (text-property-search-forward 'presentation)) 471 | (funcall func (prop-match-value prop) 472 | (buffer-substring-no-properties 473 | (prop-match-beginning prop) 474 | (prop-match-end prop))))))) 475 | 476 | (defun pbui-select-presentations-in-buffer (pattern) 477 | "Selects the presentations in BUFFER that match PATTERN." 478 | (interactive "sSelect presentations matching: ") 479 | (let (prop (selected 0)) 480 | (save-excursion 481 | (goto-char (point-min)) 482 | (while (setf prop (goto-next-presentation)) 483 | (when (looking-at pattern) 484 | (select-presentation-at-point) 485 | (cl-incf selected)))) 486 | (message "%d presentations selected matching: %s" selected pattern))) 487 | 488 | (defun pbui-unselect-presentations-in-buffer (pattern) 489 | "Unselects the presentations in BUFFER that match PATTERN." 490 | (interactive "sUnselect presentations matching: ") 491 | (let (prop (selected 0)) 492 | (save-excursion 493 | (goto-char (point-min)) 494 | (while (setf prop (goto-next-presentation)) 495 | (when (looking-at pattern) 496 | (unselect-presentation-at-point) 497 | (cl-incf selected)))) 498 | (message "%d presentations unselected matching: %s" selected pattern))) 499 | 500 | (defvar pbui::presentations-overlays nil 501 | "Internal PBUI variable to manage the collection of overlays used for presentations.") 502 | 503 | (defun propertize-presentations-in-buffer () 504 | "Set text properties for presentations in current buffer." 505 | (interactive) 506 | (let ((read-only-p buffer-read-only) 507 | (prop nil)) 508 | (setq buffer-read-only nil) 509 | (save-excursion 510 | (goto-char 0) 511 | (while (setq prop (text-property-search-forward 'presentation)) 512 | (let ((ps-overlay (make-overlay (prop-match-beginning prop) 513 | (prop-match-end prop)))) 514 | (push ps-overlay pbui::presentations-overlays) 515 | (overlay-put ps-overlay 'mouse-face 'highlight) 516 | (overlay-put ps-overlay 'help-echo 517 | (format "%s. 518 | 519 | mouse-2: toggle selection of this presentation" 520 | (pbui:print-presentation (prop-match-value prop)))) 521 | (overlay-put ps-overlay 522 | 'cursor-sensor-functions 523 | (list 524 | (lambda (window pos action) 525 | (save-excursion 526 | (if (eql action 'entered) 527 | (progn 528 | (highlight-presentation-at-point) 529 | (message 530 | (pbui:print-presentation (presentation-at-point)))) 531 | (progn 532 | (goto-char pos) 533 | (unhighlight-presentation-at-point)))) 534 | )))))) 535 | (setq buffer-read-only read-only-p))) 536 | 537 | (defun pbui:highlight-all-buffers () 538 | (dolist (buffer (buffer-list)) 539 | (with-current-buffer buffer 540 | (highlight-presentations-in-buffer)))) 541 | 542 | (defun pbui:clear-all-buffers () 543 | (dolist (buffer (buffer-list)) 544 | (with-current-buffer buffer 545 | (pbui:clear-highlights-in-buffer)))) 546 | 547 | (defun pbui:clear-highlights-in-buffer () 548 | "Clear the highlighted presentations in buffer." 549 | (let ((read-only-p buffer-read-only) 550 | (prop)) 551 | (setq buffer-read-only nil) 552 | (save-excursion 553 | (goto-char 0) 554 | (while (setq prop (text-property-search-forward 'presentation)) 555 | (put-text-property (prop-match-beginning prop) 556 | (prop-match-end prop) 557 | 'font-lock-face nil) 558 | (put-text-property (prop-match-beginning prop) 559 | (prop-match-end prop) 560 | 'mouse-face nil) 561 | (put-text-property (prop-match-beginning prop) 562 | (prop-match-end prop) 563 | 'help-echo nil)) 564 | (goto-char 0) 565 | (while (setq prop (text-property-search-forward 'selected-presentation)) 566 | (put-text-property (prop-match-beginning prop) 567 | (prop-match-end prop) 568 | 'font-lock-face nil)) 569 | (setq buffer-read-only read-only-p)))) 570 | 571 | (defun goto-next-presentation () 572 | (interactive) 573 | (text-property-search-forward 'presentation nil 574 | (lambda (value pvalue) 575 | (eql value pvalue))) 576 | (let ((prop 577 | (text-property-search-forward 'presentation))) 578 | (when prop 579 | (goto-char (prop-match-beginning prop)) 580 | prop))) 581 | 582 | (defun goto-previous-presentation () 583 | (interactive) 584 | (text-property-search-backward 'presentation nil 585 | (lambda (value pvalue) 586 | (eql value pvalue))) 587 | (let ((prop 588 | (text-property-search-backward 'presentation))) 589 | (when prop 590 | (goto-char (prop-match-beginning prop)) 591 | prop))) 592 | 593 | ;;--- PBUI mode ---------------------------------------------------------------- 594 | 595 | (defvar pbui-command-map 596 | (let ((map (make-sparse-keymap))) 597 | (define-key map (kbd "SPC") 'toggle-presentation-selected-at-point) 598 | (define-key map (kbd "X") 'select-presentation-at-point-and-run-command) 599 | (define-key map (kbd "") 'reset-selected-presentations) 600 | (define-key map (kbd "x") 'run-presentations-command) 601 | (define-key map (kbd "v") 'visualize-selected-presentations) 602 | (define-key map (kbd "f") 'goto-next-presentation) 603 | (define-key map (kbd "b") 'goto-previous-presentation) 604 | (define-key map (kbd "n") 'goto-next-presentation) 605 | (define-key map (kbd "p") 'goto-previous-presentation) 606 | map)) 607 | 608 | (fset 'pbui-command-map pbui-command-map) 609 | 610 | (defvar pbui-mode-map 611 | (make-sparse-keymap)) 612 | 613 | (define-minor-mode pbui-mode 614 | "Minor mode with quick keybindings for using presentations." 615 | ;; The initial value. 616 | :init-value nil 617 | ;; The indicator for the mode line. 618 | :lighter " PBUI" 619 | :global t 620 | :group 'pbui 621 | :keymap pbui-mode-map 622 | (if pbui-mode 623 | (pbui:initialize-pbui-mode) 624 | (pbui:release-pbui-mode))) 625 | 626 | (defun pbui:initialize-pbui-mode () 627 | "Initialize PBUI mode." 628 | (propertize-presentations-in-buffer) 629 | (highlight-selected-presentations)) 630 | 631 | (defun pbui:release-pbui-mode () 632 | (unhighlight-selected-presentations) 633 | (pbui:clear-highlights-in-buffer)) 634 | 635 | (easy-menu-define pbui-mode-menu 636 | pbui-mode-map 637 | "Menu for PBUI." 638 | '("PBUI" 639 | ["Visualize selected presentations" visualize-selected-presentations 640 | :help "Popup a buffer with the list of selected presentations"] 641 | ["Next presentation" goto-next-presentation 642 | :help "Search next presentation in buffer"] 643 | ["Previous presentation" goto-previous-presentation 644 | :help "Search previous presentation in buffer"] 645 | "---" 646 | ["Toggle presentation selected at point" toggle-presentation-selected-at-point 647 | :help "Select or unselect presentation at point"] 648 | ["Run command with presentation at point..." select-presentation-at-point-and-run-command 649 | :help "Select the presentation at point and run a command"] 650 | ["Run command..." run-presentations-command 651 | :help "Run command"] 652 | ["Reset selected presentations" reset-selected-presentations 653 | :help "Clear the list of selected presentations"] 654 | ["Enter modal mode" pbui-modal-mode 655 | :help "Enter PBUI modal mode"] 656 | "---" 657 | ["Customize" pbui:customize 658 | :help "Customize presentations mode"])) 659 | 660 | (defun pbui:customize () 661 | (interactive) 662 | (customize-group 'pbui)) 663 | 664 | (defun pbui:draw-selected-presentations () 665 | (setq buffer-read-only nil) 666 | (erase-buffer) 667 | (if (not pbui:selected-presentations) 668 | (insert "There are not presentations selected") 669 | (progn 670 | (dolist (sel pbui:selected-presentations) 671 | (let ((presentation (cl-getf sel 'presentation))) 672 | (insert-button (format "%s [%s]" 673 | (pbui:print-presentation presentation) 674 | (cl-getf presentation 'type)) 675 | 'help-echo "Go to presentation" 676 | 'follow-link t 677 | 'action (lambda (btn) 678 | (ignore btn) 679 | (pbui:goto-selected-presentation sel))) 680 | (insert " ") 681 | (insert-button "delete" 682 | 'help-echo "Remove presentation from the selection list" 683 | 'face 'presentations-button 684 | 'action (lambda (btn) 685 | (ignore btn) 686 | (setq pbui:selected-presentations (cl-delete sel pbui:selected-presentations)) 687 | (pbui:unhighlight-selected-presentation sel) 688 | (pbui:refresh-selected-presentations))) 689 | (newline))) 690 | (newline) 691 | (insert-button "clear all" 692 | 'help-echo "Clear all selected presentations" 693 | 'face 'presentations-button 694 | 'action (lambda (btn) 695 | (ignore btn) 696 | (reset-selected-presentations)))))) 697 | 698 | (defun pbui:refresh-selected-presentations () 699 | (let ((buffer (get-buffer "*selected presentations*"))) 700 | (when buffer 701 | (with-current-buffer buffer 702 | (setq buffer-read-only nil) 703 | (erase-buffer) 704 | (pbui:draw-selected-presentations) 705 | (setq buffer-read-only t))))) 706 | 707 | (defun visualize-selected-presentations () 708 | (interactive) 709 | (if (get-buffer "*selected presentations*") 710 | (progn 711 | (pbui:refresh-selected-presentations) 712 | (switch-to-buffer-other-window "*selected presentations*")) 713 | (let ((buffer (get-buffer-create "*selected presentations*"))) 714 | (with-current-buffer buffer 715 | (pbui:draw-selected-presentations) 716 | (setq buffer-read-only t) 717 | (local-set-key "q" (lambda () (interactive) (kill-buffer buffer))) 718 | (local-set-key "g" 'pbui:refresh-selected-presentations) 719 | (display-buffer buffer))))) 720 | 721 | (defun toggle-presentation-selected-at-point-handler (event) 722 | (interactive "e") 723 | (let ((window (posn-window (event-end event))) 724 | (pos (posn-point (event-end event)))) 725 | (if (not (windowp window)) 726 | (error "No presentation chosen")) 727 | (goto-char pos) 728 | (toggle-presentation-selected-at-point))) 729 | 730 | ;; The interactive PBUI mode 731 | 732 | (defvar pbui-interactive-mode-map 733 | (let ((map (make-sparse-keymap))) 734 | (define-key map (kbd "") 'toggle-presentation-selected-at-point-handler) 735 | ;;(set-keymap-parent map pbui-mode-map) 736 | map)) 737 | 738 | (define-minor-mode pbui-interactive-mode 739 | "A PBUI mode that highlights prensentations in buffers." 740 | :keymap pbui-interactive-mode-map 741 | :global t 742 | (if pbui-interactive-mode 743 | (pbui:initialize-pbui-interactive-mode) 744 | (pbui:release-pbui-interactive-mode))) 745 | 746 | (defun pbui:initialize-pbui-interactive-mode () 747 | (pbui-mode +1) 748 | (cursor-sensor-mode)) 749 | 750 | (defun pbui:release-pbui-interactive-mode () 751 | (cursor-sensor-mode -1) 752 | (dolist (ps-overlay pbui::presentations-overlays) 753 | (delete-overlay ps-overlay))) 754 | 755 | ;; The modal PBUI mode 756 | 757 | (defvar pbui-modal-mode-map 758 | (let ((map (make-sparse-keymap))) 759 | (define-key map (kbd "SPC") 'toggle-presentation-selected-at-point) 760 | (define-key map (kbd "X") 'select-presentation-at-point-and-run-command) 761 | (define-key map (kbd "") 'reset-selected-presentations) 762 | (define-key map (kbd "x") 'run-presentations-command) 763 | (define-key map (kbd "f") 'goto-next-presentation) 764 | (define-key map (kbd "b") 'goto-previous-presentation) 765 | (define-key map (kbd "n") 'goto-next-presentation) 766 | (define-key map (kbd "p") 'goto-previous-presentation) 767 | (define-key map (kbd "") 'disable-pbui-modal-mode) 768 | (define-key map (kbd "") 'toggle-presentation-selected-at-point-handler) 769 | (define-key map (kbd "v") 'visualize-selected-presentations) 770 | map)) 771 | 772 | (easy-menu-define pbui-model-mode-menu 773 | pbui-modal-mode-map 774 | "Menu for modal PBUI." 775 | '("PBUI Modal" 776 | ["Visualize selected presentations" visualize-selected-presentations 777 | :help "Popup a buffer with the list of selected presentations"] 778 | ["Next presentation" goto-next-presentation 779 | :help "Search next presentation in buffer"] 780 | ["Previous presentation" goto-previous-presentation 781 | :help "Search previous presentation in buffer"] 782 | "---" 783 | ["Toggle presentation selected at point" toggle-presentation-selected-at-point 784 | :help "Select or unselect presentation at point"] 785 | ["Run command with presentation at point..." select-presentation-at-point-and-run-command 786 | :help "Select the presentation at point and run a command"] 787 | ["Run command..." run-presentations-command 788 | :help "Run command"] 789 | ["Reset selected presentations" reset-selected-presentations 790 | :help "Clear the list of selected presentations"] 791 | "---" 792 | ["Quit" disable-pbui-modal-mode 793 | :help "Quit PBUI modal mode"])) 794 | 795 | (define-minor-mode pbui-modal-mode 796 | "A PBUI mode with modal key bindings." 797 | ;; The modal key bindings. 798 | :keymap pbui-modal-mode-map 799 | :global t 800 | (if pbui-modal-mode 801 | (pbui:initialize-pbui-modal-mode) 802 | (pbui:release-pbui-modal-mode))) 803 | 804 | (defun disable-pbui-modal-mode () 805 | (interactive) 806 | (pbui-modal-mode -1)) 807 | 808 | (defun pbui:initialize-pbui-modal-mode () 809 | (pbui:initialize-pbui-interactive-mode)) 810 | 811 | (defun pbui:release-pbui-modal-mode () 812 | (pbui:release-pbui-interactive-mode)) 813 | 814 | (add-hook 'buffer-list-update-hook 815 | (lambda () 816 | (when (not (active-minibuffer-window)) 817 | (if pbui-modal-mode 818 | (pbui:initialize-pbui-interactive-mode) 819 | (pbui:release-pbui-interactive-mode))))) 820 | 821 | ;; Disable PBUI minor mode for the minibuffer 822 | 823 | (defvar pbui::modal-mode-was-enabled-p nil 824 | "Internal. Used by PBUI minibuffer enter/leave to know if modal mode should be reestablished or not.") 825 | 826 | (defun pbui::enter-minibuffer () 827 | (setq pbui::modal-mode-was-enabled-p pbui-modal-mode) 828 | (when pbui-modal-mode 829 | (pbui-modal-mode -1))) 830 | 831 | (defun pbui::leave-minibuffer () 832 | (when pbui::modal-mode-was-enabled-p 833 | (pbui-modal-mode))) 834 | 835 | (add-hook 'minibuffer-setup-hook 'pbui::enter-minibuffer) 836 | 837 | (add-hook 'minibuffer-exit-hook 'pbui::leave-minibuffer) 838 | 839 | (provide 'pbui) 840 | 841 | ;;; pbui.el ends here 842 | --------------------------------------------------------------------------------