buffer-layers.el 9.5 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228
  1. ;;; buffer-layers.el --- Layered Buffers for Buffer Management
  2. ;; Copyright (C) 2016 Samuel Flint
  3. ;; Author: Samuel W. Flint <swflint@flintfam.org>
  4. ;; Version: 1.8
  5. ;; Package-Requires: ((cl-lib "0.5"))
  6. ;; Keywords: buffer-management
  7. ;; URL: http://github.com/swflint/buffer-layers
  8. ;;; Commentary:
  9. ;;
  10. ;;; Code:
  11. (require 'cl-lib)
  12. (cl-defstruct buffer-layer
  13. name
  14. files
  15. select
  16. on-apply
  17. on-apply-source
  18. on-remove
  19. on-remove-source)
  20. (defvar *buffer-layers* nil
  21. "List of all defined buffer layers.")
  22. (defvar *buffer-layers-applied* nil
  23. "List of applied buffer-layers.")
  24. (defvar *buffer-layer-definitions* nil
  25. "List of all buffer layer definitions.")
  26. (defvar *buffer-layer-buffers* nil
  27. "List of buffers in loaded buffer layers.")
  28. (defvar *buffer-layer-file* "~/.emacs.d/buffer-layer-definitions.el"
  29. "The file to store buffer layer definitions in.")
  30. (defun buffer-layers-load-definitions-file ()
  31. "Load buffer layer definitions file."
  32. (load *buffer-layer-file* t t)
  33. (message "Loaded Buffer Layer Definitions."))
  34. (defun buffer-layers-applied-p (layer)
  35. "Returns true if LAYER is applied."
  36. (member layer *buffer-layers-applied*))
  37. (defun buffer-layer--get-buffer-layer-definition (layer-name)
  38. (car (cl-remove-if-not (lambda (layer)
  39. (eq layer-name (buffer-layer-name layer))) *buffer-layer-definitions*)))
  40. (defun buffer-layer--generate-buffers-list (layer-name)
  41. (intern (format "*buffer-layer-%s--buffers*" layer-name)))
  42. (cl-defmacro define-buffer-layer (name &key files select on-apply on-remove)
  43. "Define a buffer layer named NAME, taking FILES, RUN-ON-APPLY, RUN-ON-REMOVE and BUFFER-TO-SELECT as keyword arguments."
  44. `(progn
  45. (cl-pushnew ',name *buffer-layers*)
  46. (cl-pushnew (make-buffer-layer :name ',name
  47. :files ',files
  48. :select ,select
  49. :on-apply-source ',on-apply
  50. :on-remove-source ',on-remove
  51. :on-apply (lambda () ,@on-apply)
  52. :on-remove (lambda () ,@on-remove))
  53. *buffer-layer-definitions*
  54. :key #'buffer-layer-name)
  55. (defvar ,(buffer-layer--generate-buffers-list name) nil)
  56. ',name))
  57. (defun buffer-layers-load-layer (name)
  58. (interactive (list (intern (completing-read "Layer Name: "
  59. (cl-remove-if #'(lambda (layer) (member layer *buffer-layers-applied*)) *buffer-layers*)
  60. nil t))))
  61. (let ((layer-definition (buffer-layer--get-buffer-layer-definition name)))
  62. (if (not (buffer-layer-p layer-definition))
  63. (error "Layer Undefined: %s" name)
  64. (let ((files (buffer-layer-files layer-definition))
  65. (select (buffer-layer-select layer-definition))
  66. (on-apply (buffer-layer-on-apply layer-definition))
  67. (buffers-list (buffer-layer--generate-buffers-list name)))
  68. (setf (symbol-value buffers-list) (mapcar #'find-file files))
  69. (funcall on-apply)
  70. (when (stringp select)
  71. (switch-to-buffer select))
  72. (add-to-list '*buffer-layers-applied* name)
  73. (message "Applied buffer layer %s." name)))))
  74. (defalias 'load-buffer-layer 'buffer-layers-load-layer)
  75. (defun buffer-layers-unload-buffer-layer (name)
  76. "Unload Buffer Layer named NAME."
  77. (interactive (list (intern (completing-read "Buffer Layer Name: " *buffer-layers-applied*))))
  78. (let ((layer-definition (buffer-layer--get-buffer-layer-definition name)))
  79. (if (not (buffer-layer-p layer-definition))
  80. (error "Layer Undefined: %s" name)
  81. (let ((buffers-list (buffer-layer--generate-buffers-list name))
  82. (on-remove (buffer-layer-on-remove layer-definition)))
  83. (mapc (lambda (buffer)
  84. (with-current-buffer buffer
  85. (save-buffer)
  86. (kill-buffer buffer)))
  87. (symbol-value buffers-list))
  88. (funcall on-remove)
  89. (setf (symbol-value buffers-list) nil)
  90. (setq *buffer-layers-applied* (delq name *buffer-layers-applied*))
  91. (message "Removed Buffer Layer: %s" name)))))
  92. (defun buffer-layers-list ()
  93. "Produce a list of defined buffer layers."
  94. (interactive)
  95. (when (buffer-live-p "*Buffer Layers*")
  96. (kill-buffer "*Buffer Layers*"))
  97. (with-help-window "*Buffer Layers*"
  98. (with-current-buffer "*Buffer Layers*"
  99. (insert "Defined Buffer Layers:\n\n")
  100. (dolist (layer *buffer-layers*)
  101. (if (not (buffer-layers-applied-p layer))
  102. (insert (format " - %s\n" layer))
  103. (insert (format " - %s (Applied)\n" layer)))
  104. (dolist (buffer (symbol-value (buffer-layer--generate-buffers-list layer)))
  105. (if (null (get-buffer-window-list buffer nil t))
  106. (insert (format " - %s\n" (buffer-name buffer)))
  107. (insert (format " - %s (visible)\n" (buffer-name buffer)))))))))
  108. (defun buffer-layers-unload-all-buffer-layers ()
  109. "Unload all loaded buffer layers."
  110. (interactive)
  111. (dolist (buffer-layer *buffer-layers-applied*)
  112. (buffer-layers-unload-buffer-layer buffer-layer)))
  113. (defun buffer-layers-create-layer (name)
  114. "Create a new layer."
  115. (interactive "SNew Layer Name: ")
  116. (when (not (member name *buffer-layers*))
  117. (pushnew name *buffer-layers*)
  118. (setf (symbol-value (buffer-layer--generate-buffers-list name)) nil)
  119. (pushnew (make-buffer-layer :name name
  120. :on-apply (lambda () nil)
  121. :on-remove (lambda () nil)) *buffer-layer-definitions*)))
  122. (defun buffer-layers-add-file-to-layer (name file)
  123. "Add a file to the layer."
  124. (interactive (list
  125. (intern (completing-read "Layer: " *buffer-layers* nil t))
  126. (read-file-name "File Name: ")))
  127. (let ((layer (buffer-layer--get-buffer-layer-definition name)))
  128. (setf (buffer-layer-files layer) (append (buffer-layer-files layer) (list file)))))
  129. (defun buffer-layers-add-buffer-to-layer (name buffer)
  130. "Add a buffer to the given layer."
  131. (interactive (list
  132. (intern (completing-read "Layer: " *buffer-layers* nil t))
  133. (get-buffer (read-buffer "Buffer: " (current-buffer)))))
  134. (let ((layer (buffer-layer--get-buffer-layer-definition name))
  135. (file (buffer-file-name buffer)))
  136. (setf (buffer-layer-files layer) (append (buffer-layer-files layer) (list file)))))
  137. (defun buffer-layers-edit-load-actions (layer)
  138. "Edit the actions to be preformed on buffer layer load."
  139. (interactive (list (completing-read "Layer: " *buffer-layers* nil t))))
  140. (defun buffer-layers-edit-remove-actions (layer)
  141. "Edit the actions to be preformed on buffer layer removal."
  142. (interactive (list (completing-read "Layer: " *buffer-layers* nil t))))
  143. (defun buffer-layers-set-buffer-to-select (layer)
  144. "Set the buffer to automatically select."
  145. (interactive (list (completing-read "Layer: " *buffer-layers* nil t))))
  146. (defun buffer-layers-save (the-layer)
  147. "Save defined buffer layers."
  148. (interactive)
  149. (insert (format "%S\n\n" (let ((name (buffer-layer-name the-layer))
  150. (files (buffer-layer-files the-layer))
  151. (select (buffer-layer-select the-layer))
  152. (on-apply (buffer-layer-on-apply-source the-layer))
  153. (on-remove (buffer-layer-on-remove-source the-layer)))
  154. `(define-buffer-layer ,name
  155. :files ,files
  156. :select ,select
  157. :on-apply ,on-apply
  158. :on-remove ,on-remove)))))
  159. (defun buffer-layers-save-definitions ()
  160. (with-current-buffer (find-file *buffer-layer-file*)
  161. (kill-region (buffer-end -1) (buffer-end 1))
  162. (mapc #'buffer-layers-save (reverse *buffer-layer-definitions*))
  163. (save-buffer)
  164. (kill-buffer))
  165. (message "Saved Buffer Layer Definitions."))
  166. (defvar buffer-layers-map (make-keymap)
  167. "Keymap for buffer-layer commands.")
  168. (define-key buffer-layers-map (kbd "l") #'buffer-layers-load-layer)
  169. (define-key buffer-layers-map (kbd "L") #'buffer-layers-list)
  170. (define-key buffer-layers-map (kbd "u") #'buffer-layers-unload-buffer-layer)
  171. (define-key buffer-layers-map (kbd "U") #'buffer-layers-unload-all-buffer-layers)
  172. (define-key buffer-layers-map (kbd "c") #'buffer-layers-create-layer)
  173. (define-key buffer-layers-map (kbd "f") #'buffer-layers-add-file-to-layer)
  174. (define-key buffer-layers-map (kbd "b") #'buffer-layers-add-buffer-to-layer)
  175. (define-key buffer-layers-map (kbd "a") #'buffer-layers-edit-load-actions)
  176. (define-key buffer-layers-map (kbd "r") #'buffer-layers-edit-remove-actions)
  177. (define-key buffer-layers-map (kbd "s") #'buffer-layers-set-buffer-to-select)
  178. (define-key buffer-layers-map (kbd "C-s") #'buffer-layers-save)
  179. (define-minor-mode buffer-layers-mode
  180. "A mode for managing layers of buffers."
  181. :lighter " BLM" :global t :variable buffer-layers-mode-p
  182. (if buffer-layers-mode-p
  183. (progn
  184. (buffer-layers-load-definitions-file)
  185. (define-key ctl-x-map (kbd "L") buffer-layers-map)
  186. (add-hook 'kill-emacs-hook #'buffer-layers-unload-all-buffer-layers)
  187. (add-hook 'kill-emacs-hook #'buffer-layers-save-definitions))
  188. (progn
  189. (buffer-layers-save-definitions)
  190. (define-key ctl-x-map (kbd "L") nil)
  191. (remove-hook 'kill-emacs-hook #'buffer-layers-unload-all-buffer-layers)
  192. (remove-hook 'kill-emacs-hook #'buffer-layers-save-definitions))))
  193. (provide 'buffer-layers)
  194. ;;; buffer-layers.el ends here