path: root/eb.el

;;; eb --- Episode Browser development functions for Emacs

;;; Commentary:

;;; Code:

(require 'cl-lib)

;;;###autoload
(defgroup eb nil
  "Episode Browser development package."
  :prefix "eb-")

;; Disable ucs-utils (used by back-button-mode), which causes lag.
(when (and (equal system-type 'windows-nt)
	   (require 'back-button nil t)
	   (require 'ucs-utils nil t))
  (defun ucs-utils-char (name fallback &optional test)
    (or (if (version< emacs-version "26")
            (cdr (assoc-string name (ucs-names) t))
          (char-from-name name t))
	fallback)))

;; Truncate dired headers minor mode.

(defvar eb--truncate-dired-headers--keywords
  (list
   '("^. \\(.*/\\)\\(.+\\)\\(:\\)\n"
     (1 (list 'face dired-header-face 'invisible 'eb--truncate-dired-headers--invisible))
     (2 (list 'face dired-header-face)))))

(font-lock-add-keywords 'dired-mode eb--truncate-dired-headers--keywords)

;;;###autoload
(define-minor-mode eb--dired-truncate-headers-mode
  "Show only last path component in `dired' header lines."
  :lighter ""
  (if eb--dired-truncate-headers-mode
      (add-to-invisibility-spec 'eb--truncate-dired-headers--invisible)
    (remove-from-invisibility-spec 'eb--truncate-dired-headers--invisible)))

;; Fleeting minor mode.

(defvar eb--fleeting--buffer nil)
(defvar eb--fleeting--window nil)
(defvar-local eb--fleeting--close nil)
(defvar-local eb--fleeting--direction nil)

;;;###autoload
(define-minor-mode eb--fleeting-minor-mode
  "Minor mode for transient buffer selection pop-up windows."
  :lighter ""
  (if eb--fleeting-minor-mode
      (let ((refit (lambda (window) (let ((fit-window-to-buffer-horizontally t))
				      (fit-window-to-buffer window)))))
	(funcall refit (get-buffer-window))
	(run-with-idle-timer 0 nil refit (get-buffer-window)))
    (eval eb--fleeting--close)))

(defmacro eb--fleeting-window (dir buffer &optional open close)
  (declare (indent 2))
  `(progn
     (let ((buffer ,buffer)
	   (cwd default-directory))
       (if (equal buffer (window-buffer))
	   (progn
	     (eb--fleeting-minor-mode -1)
	     (quit-window)
	     nil)
	 (when eb--fleeting-minor-mode
	   (eb--fleeting-minor-mode -1)
	   (quit-window))
	 (display-buffer-in-direction buffer '((direction . ,dir)))
	 (let ((window (get-buffer-window buffer)))
	   (select-window window)
	   (with-current-buffer buffer
	     (setq default-directory cwd)
	     (setq eb--fleeting--close ',close)
	     ,open
	     (eb--fleeting-minor-mode 1)
	     (setq eb--fleeting--direction ',dir))
	   window)))))

(defun eb--fleeting--main-window (&optional fleeting-buffer fleeting-window)
  (setq fleeting-buffer (or fleeting-buffer (current-buffer)))
  (setq fleeting-window (or fleeting-window (selected-window)))
  (with-current-buffer fleeting-buffer
    (let ((dir (cl-case eb--fleeting--direction
		 ('up 'below)
		 ('down 'above)
		 ('left 'right)
		 ('right 'left))))
      (window-in-direction dir fleeting-window))))

(defun eb--fleeting--pre-command-hook ()
  (setq eb--fleeting--buffer (and eb--fleeting-minor-mode (current-buffer)))
  (setq eb--fleeting--window (and eb--fleeting-minor-mode (get-buffer-window))))
(add-hook 'pre-command-hook #'eb--fleeting--pre-command-hook)

(defun eb--fleeting--window-hook (&rest r)
  (let ((fleeting-buffer eb--fleeting--buffer)
	(fleeting-window eb--fleeting--window)
	(buffer (window-buffer))
	(window (selected-window)))
    (when (and fleeting-buffer
	       fleeting-window
	       (not (equal window (minibuffer-window))))
      (cond
       ((and (equal fleeting-window window)
	     (equal fleeting-buffer buffer))
	(with-current-buffer fleeting-buffer
	  (eb--fleeting-minor-mode -1)))
       ((and (equal fleeting-window window)
	     (not (equal fleeting-buffer buffer)))
	(with-current-buffer fleeting-buffer
	  (eb--fleeting-minor-mode -1))
	(bury-buffer fleeting-buffer)
	(setq eb--fleeting--window nil)
	(select-window (eb--fleeting--main-window fleeting-buffer fleeting-window))
	(switch-to-buffer buffer)
	(delete-window fleeting-window))
       (t
	(with-current-buffer fleeting-buffer
	  (eb--fleeting-minor-mode -1))
	(when (get-buffer-window fleeting-buffer)
	  (delete-window fleeting-window)))))))
(add-hook 'window-configuration-change-hook #'eb--fleeting--window-hook)
(add-hook 'window-selection-change-functions #'eb--fleeting--window-hook)

;; Development tool bar functions.

;;;###autoload
(defun eb-quit-or-bury ()
  "Quit window or bury buffer."
  (interactive)
  (if (window-parameter (selected-window) 'quit-restore)
      (quit-window)
    (bury-buffer)))

(defvar eb--last-seconds 0)
(defvar eb--last-window-configuration nil)

;;;###autoload
(defun eb-quit-or-bury-or-delete-other-windows ()
  "Quit window or bury buffer. If activated twice in rapid
succession, delete other windows instead."
  (interactive)
  (let ((seconds (car (time-convert nil 100))))
    (if (< (- seconds eb--last-seconds) 20)
	(progn
	  (set-window-configuration eb--last-window-configuration)
	  (delete-other-windows))
      (setq eb--last-window-configuration (current-window-configuration))
      (if (window-parameter (selected-window) 'quit-restore)
	  (quit-window)
	(bury-buffer)))
    (setq eb--last-seconds seconds)))

;;;###autoload
(defun eb-exhume-buffer ()
  "Switch to last buffer in the buffer list."
  (interactive)
  (switch-to-buffer (last-buffer)))

(defvar-local eb--list-buffers nil)
(defvar-local eb--bookmarks nil)

;;;###autoload
(defun eb-list-buffers (&optional arg all)
  "List project buffers. By default, only file buffers are shown."
  (interactive "P")
  (require 'projectile)
  (eb--fleeting-window up (list-buffers-noselect
			   (not arg)
			   (when (and (not all) (projectile-project-p))
			     (if arg
				 (projectile-project-buffers)
			       (mapcan
				(lambda (b) (and (buffer-file-name b) (list b)))
				(projectile-project-buffers)))))))

;;;###autoload
(defun eb-list-buffers-all (&optional arg)
  "List all buffers. By default, only file buffers are shown."
  (interactive "P")
  (eb-list-buffers nil t))

;;;###autoload
(defun eb-bookmarks ()
  "Show bookmarks."
  (interactive)
  (require 'bookmark)
  (bookmark-maybe-load-default-file)
  (eb--fleeting-window up (get-buffer-create bookmark-bmenu-buffer)
    (progn (bookmark-bmenu-mode)
	   (bookmark-bmenu--revert)
	   (bookmark-bmenu-list))))

(defvar eb--dired-truncate-lines--orig nil)
(defvar eb--dired-hide-details-mode--orig nil)
(defvar eb--dired-truncate-headers-mode--orig nil)

;;;###autoload
(defun eb-dired (&optional arg dir)
  "Open the root of the current project in `dired'."
  (interactive "P")
  (require 'projectile)
  (setq dir (or dir (projectile-project-root)))
  (let ((fit-window-to-buffer-horizontally t)
	(buffer (dired-noselect dir)))
    (if arg
	(switch-to-buffer buffer)
      (eb--fleeting-window left buffer
	(progn
	  (setq default-directory dir)
	  (setq eb--dired-truncate-lines--orig truncate-lines)
	  (setq eb--dired-hide-details-mode--orig dired-hide-details-mode)
	  (setq eb--dired-truncate-headers-mode--orig eb--dired-truncate-headers-mode)
	  (toggle-truncate-lines 1)
	  (dired-hide-details-mode 1)
	  (eb--dired-truncate-headers-mode 1)
	  (message "")
	  (revert-buffer))
	(progn
	  (when (not eb--dired-truncate-lines--orig) (toggle-truncate-lines -1))
	  (when (not eb--dired-hide-details-mode--orig) (dired-hide-details-mode -1))
	  (when (not eb--dired-truncate-headers-mode--orig) (eb--dired-truncate-headers-mode -1))
	  (message ""))))))

;;;###autoload
(defun eb-dired-here (&optional arg)
  "Open the current working directory in `dired'."
  (interactive "P")
  (eb-dired arg default-directory))

;;;###autoload
(defun eb-grep ()
  "Grep project."
  (interactive)
  (require 'projectile)
  (if (projectile-project-p)
      (call-interactively #'projectile-grep)
    (call-interactively #'grep)))

;;;###autoload
(defcustom eb-system "vs2019"
  "Build system."
  :group 'eb
  :type '(radio (const "mingw") (const "vs2019")))

;;;###autoload
(defcustom eb-vs-toolset "v142"
  "Visual Studio toolset."
  :group 'eb
  :type '(radio (const "v142") (const "v141_xp")))

;;;###autoload
(defcustom eb-vs-platform "x64"
  "Visual Studio platform."
  :group 'eb
  :type '(radio (const "Win32") (const "x64")))

;;;###autoload
(defcustom eb-vs-config "Debug"
  "Visual Studio configuration."
  :group 'eb
  :type '(radio (const "Debug") (const "Release")))

;;;###autoload
(defcustom eb-cwd "b"
  "Working directory for executable."
  :group 'eb
  :type 'directory)

(defun eb--cmake-path ()
  (require 'projectile)
  (cond
   ((string-equal eb-system "mingw")
    (concat (projectile-project-root) "/b/mingw/"))
   ((string-equal eb-system "vs2019")
    (concat (projectile-project-root) "/b/vs2019-" eb-vs-toolset "-" eb-vs-platform "/"))
   (t (error "eb-system `%s' not supported" eb-system))))

(defun eb--exe ()
  (cond
   ((string-equal eb-system "mingw")
    (concat (eb--cmake-path) "EpisodeBrowser.exe"))
   ((string-equal eb-system "vs2019")
    (concat (eb--cmake-path) eb-vs-config "/EpisodeBrowser.exe"))
   (t (error "eb-system `%s' not supported" eb-system))))

;;;###autoload
(defun eb-run ()
  "Launch built executable, displaying its output in a buffer."
  (interactive)
  (require 'projectile)
  (let ((buf (get-buffer-create "*eb-run*"))
	(exe (eb--exe))
	(default-directory eb-cwd))
    (with-current-buffer buf
      (compilation-mode))
    (start-process "EpisodeBrowser" buf exe)
    (when (and (eq major-mode 'compilation-mode)
	       (window-parameter (selected-window) 'quit-restore))
      (quit-window))
    (display-buffer buf)))

;;;###autoload
(defun eb-compile ()
  "Compile project without prompt. Use `eb-system'."
  (interactive)
  (require 'projectile)
  (when (and (eq major-mode 'compilation-mode)
	     (window-parameter (selected-window) 'quit-restore))
    (quit-window))
  (if (projectile-project-p)
      (let ((compilation-read-command nil)
	    (command (concat "make SYSTEM=" eb-system
			     " VS_CONFIG=" eb-vs-config
			     " VS_TOOLSET=" eb-vs-toolset
			     " VS_PLATFORM=" eb-vs-platform)))
	(projectile--run-project-cmd command nil
                                     :show-prompt nil
                                     :prompt-prefix "Compile command: "
                                     :save-buffers t
                                     :use-comint-mode projectile-compile-use-comint-mode))
    (call-interactively #'compile))
  (with-current-buffer "*compilation*"
    (when (eql (point) (point-min))
      (goto-char (point-max)))))

;;;###autoload
(defun eb-vs ()
  "Open project in Visual Studio."
  (interactive)
  (w32-shell-execute "open" (concat (eb--cmake-path) "EpisodeBrowser.sln")))

;;;###autoload
(defun eb-check ()
  "Toggle `flycheck-list-errors'."
  (interactive)
  (require 'flycheck)
  (catch 'found
	 (dolist (win (window-list))
	   (with-selected-window win
	     (when (eq major-mode 'flycheck-error-list-mode)
	       (bury-buffer (window-buffer win))
	       (delete-window win)
	       (throw 'found t))))
	 (funcall #'flycheck-list-errors)))

;;;###autoload
(defun eb-vc ()
  "Open version control for project."
  (interactive)
  (require 'projectile)
  (when eb--list-buffers (quit-window))
  (projectile-vc (or (projectile-project-root) default-directory)))

;;;###autoload
(defun eb-customize ()
  "Customize group `eb'."
  (interactive)
  (customize-group 'eb))

(defvar-local eb-tool-bar-mode--old-map nil)

;;;###autoload
(define-minor-mode eb-tool-bar-mode
  "Episode Browser development tool bar."
  :lighter " EB"
  (if eb-tool-bar-mode
      (progn
	(setq eb-tool-bar-mode--old-map tool-bar-map)
	(when (require 'back-button nil t)
	  (setq-local back-button-mode-lighter nil)
	  (back-button-mode 1)
	  (assq-delete-all 'back-button-mode minor-mode-map-alist))
	(let ((map (make-sparse-keymap)))

	  ;; Windows, buffers and files.
	  (tool-bar-local-item "cancel" #'eb-quit-or-bury-or-delete-other-windows 'quit-or-bury map
			       :label "Bury" :help "Bury buffer or window (double-click to delete other windows)")
	  (define-key map [(shift quit-or-bury)] #'eb-exhume-buffer)
	  (define-key map [(control quit-or-bury)] #'delete-other-windows)
	  (tool-bar-local-item "index" #'eb-list-buffers 'list-buffers map
			       :label "Buffers" :help "Show project buffers")
	  (define-key map [(shift list-buffers)] #'eb-list-buffers-all)
	  (tool-bar-local-item "diropen" #'eb-dired 'dired map
			       :label "Root" :help "Browse project root")
	  (define-key map [(shift dired)] #'eb-dired-here)
	  (tool-bar-local-item "next-page" #'eb-bookmarks 'bookmarks map
			       :label "Bookmarks" :help "Show bookmarks")
	  (tool-bar-local-item "search-replace" #'eb-grep 'grep map
			       :label "Grep" :help "Grep project")

	  ;; Compilation and version control.
	  (define-key-after map [separator-1] menu-bar-separator)
	  (tool-bar-local-item "newsticker/next-item" #'eb-run 'run map
			       :label "Run" :help "Run executable")
	  (tool-bar-local-item "refresh" #'eb-compile 'compile map
			       :label "Compile" :help "Compile project")
	  (define-key map [(shift compile)] #'eb-vs)
	  (tool-bar-local-item "spell" #'eb-check 'check map
			       :label "Check" :help "Check warnings and errors")
	  (define-key map [(shift check)] #'flycheck-buffer)
	  (define-key map [(control check)] #'flycheck-mode)
	  (tool-bar-local-item "mail/inbox" #'eb-vc 'vc map
			       :label "Version Control" :help "Open project version control")

	  ;; Mark control.
	  (when (require 'back-button nil t)
	    (define-key-after map [separator-2] menu-bar-separator)
	    (tool-bar-local-item "left-arrow" #'back-button-global-backward 'previous-mark map
				 :label "Previous Mark" :help "Go to previous mark")
	    (define-key map [(shift previous-mark)] #'back-button-local-backward)
	    (tool-bar-local-item "mpc/add" #'back-button-push-mark-local-and-global 'push-mark map
				 :label "Push Mark" :help "Push mark")
	    (define-key map [(shift push-mark)] #'back-button-push-mark)
	    (tool-bar-local-item "right-arrow" #'back-button-global-forward 'next-mark map
				 :label "Next Mark" :help "Go to next mark")
	    (define-key map [(shift next-mark)] #'back-button-local-forward))

	  ;; Miscellaneous.
	  (define-key-after map [separator-3] menu-bar-separator)
	  (tool-bar-local-item "preferences" #'eb-customize 'customize map
			       :label "Customize" :help "Customize user options")

	  (setq-local tool-bar-map map)))
    (setq-local tool-bar-map eb-tool-bar-mode--old-map)
    (back-button-mode 0)))

;;;###autoload
(define-global-minor-mode global-eb-tool-bar-mode eb-tool-bar-mode
  (lambda () (eb-tool-bar-mode 1))
  :group 'eb)

(provide 'eb)
;;; eb.el ends here