path: root/bookmark-conf.el

;;; bookmark-conf.el --- My configurations for bookmark  -*- lexical-binding: t; -*-

;; Copyright (C) 2021  Durand

;; Author: Durand <mmemmew@gmail.com>
;; Keywords: convenience

;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program.  If not, see <https://www.gnu.org/licenses/>.

;;; Commentary:

;; My configurations for bookmarks.

;;; Code:

(require 'bookmark)

(autoload 'use-package "basic")

;; dependency of blist

(use-package "ilist" 'ilist)
(require 'ilist)

(use-package "blist" 'blist)
(require 'blist)

;;; Shorter buffer name

(setq blist-buffer-name "*Bookmarks*")

;;; replace the original key-binding

(define-key ctl-x-r-map (vector ?l) #'blist-list-bookmarks)

;;; Customizations

;;;; No strange fringe indicators

(setq bookmark-set-fringe-mark nil)

;;;; HL-LINE

(add-hook 'blist-mode-hook #'hl-line-mode)

;;;; I am not an expert

;; I prefer not being an expert now, as deleting bookmarks is quite
;; dangerous for me, as I start to depend my workflow on these
;; bookmarks.  It might be difficult to restore the bookmark of a PDF
;; file deeply buried somewhere inside my file system, if I
;; accidentally delete it.

(setq blist-expert nil)

;;;; Discard empty groups

(setq blist-discard-empty-p t)

;;;; I love cycling

(setq blist-movement-cycle t)

;;;; Filter groups

;;;;; Features

(setq blist-filter-features (list 'auto 'manual))

;;;;; Fixed groups

;; Now that I have automatic groups, I only need some of these manual
;; groups to keep certain groups in the order I prefer, and placed at
;; the top of the list.

(setq
 blist-filter-groups
 (list
  (cons "PDF" #'blist-pdf-p)
  (cons "C" #'blist-c-p)
  (cons "Gnus" #'blist-gnus-p)
  (cons "ELisp" #'blist-elisp-p)
  (cons "Eshell" #'blist-eshell-p)))

;;;;; Automatic groups

(ilist-dag "durand" blist-filter-default-label
           #'blist-filter-sorter-default
  (save-match-data
    (let* ((handler (bookmark-get-handler element))
           (handler-name (and handler (format "%S" handler)))
           (location (bookmark-location element))
           (capitalize-p t))
      ;; replace repeating parts
      (cond
       ((and handler-name
             (string-match "\\([^z-a]+\\)-jump" handler-name))
        (setq
         handler-name
         (replace-regexp-in-string
          "^durand-" ""
          (match-string 1 handler-name)))))
      (setq handler-name
            (and (stringp handler-name)
                 (replace-regexp-in-string
                  (rx "-bookmark" (zero-or-one "-handler") eos)
                  "" handler-name)))
      ;; Tramp bookmarks
      (cond
       ((and (stringp location)
             (not (string= location ""))
             (file-remote-p location))
        (setq handler-name
              (concat "Tramp - "
                      (format
                       "%s%s"
                       (cond
                        ((file-remote-p location 'user)
                         (concat
                          (file-remote-p location 'user)
                          "@"))
                        (""))
                       (cond
                        ((file-remote-p location 'host))
                        ("")))))
        (setq capitalize-p nil)))
      ;; take case of file extensions
      (cond
       ((and (null handler-name) location
             (string-match "\\.\\([^.]+\\)\\'" location))
        (setq handler-name (match-string 1 location))
        (let ((new-location location))
          (while (and handler-name
                      (durand-member
                       handler-name (list "gpg") #'string=))
            (setq new-location
                  (substring new-location nil (max 0 (1- (match-beginning 1)))))
            (cond
             ((string-match "\\.\\([^.]+\\)\\'" new-location)
              (setq handler-name (match-string 1 new-location)))
             ((setq handler-name nil)))))))
      (cond
       (handler-name
        (cond
         ((<= (length handler-name) 3) (upcase handler-name))
         (capitalize-p (capitalize handler-name))
         (handler-name)))))))

(setq blist-automatic-filter-groups #'ilist-automatic-group-durand)

;;; Don't make numbered backups

(setq bookmark-version-control 'never)

;;; More bookmark groups

;; Some of these are not needed anymore, but I still keep them here as
;; a reference.  Or maybe I just don't want to delete them.

;;;; Gnus group

;; There seems to be only two GNUS bookmark handlers (or one?)
(blist-define-criterion "gnus" "Gnus"
  (memq (bookmark-get-handler bookmark)
        (list #'gnus-summary-bookmark-jump #'gnus-bookmark-jump)))

;;;; EWW group

(blist-define-criterion "eww" "EWW"
  (eq (bookmark-get-handler bookmark) 'durand-eww-bookmark-jump))

;;;; Info group

(blist-define-criterion "info" "Info"
  (eq (bookmark-get-handler bookmark) 'Info-bookmark-jump))

;;;; PDF group

(blist-define-criterion "pdf" "PDF"
  (eq
   (bookmark-get-handler bookmark) 'pdf-view-bookmark-jump-handler))

;;;; Org group

(defvar org-directory)

(blist-define-criterion "org" "Org"
  (let ((location (blist-get-location bookmark)))
    (or
     (string-match-p
      "\\.org$" location)
     (and
      (file-directory-p (or org-directory "/non-existing"))
      (file-in-directory-p location org-directory)))))

;;;; C group

(blist-define-criterion "c" "C"
  ;; `rx' is a macro, so that we don't have to compute the regular
  ;; expression every time we match a line.
  (string-match-p
   (rx
    (or
     (seq ".c"
          (zero-or-one "pp")
          eos)
     (seq ".h"
          (zero-or-one "pp")
          eos)))
   (blist-get-location bookmark)))

;;;; ELisp group

(blist-define-criterion "elisp" "ELisp"
  (string-match-p "\\.el$" (blist-get-location bookmark)))

;;;; External group

(blist-define-criterion "external" "External"
  (eq (bookmark-get-handler bookmark)
      #'durand-external-jump))

;;; Fit annotations buffer to window

(autoload 'durand-fit-window-to-buffer-with-max "common")

(defun durand-bookmark-jump-fit-to-window (&rest _args)
  "Fit the annotations buffer to its window, if needed.
ARGS are ignored."
  (let ((window (get-buffer-window "*Bookmark Annotation*")))
    (cond
     ((and window (windowp window) (window-live-p window))
      (durand-fit-window-to-buffer-with-max
       window)))))

(advice-add #'bookmark-jump
            :after
            #'durand-bookmark-jump-fit-to-window)

;;; Display of the list

(cond
 ((assoc blist-buffer-name display-buffer-alist #'string-match-p)
  (setcdr (assoc blist-buffer-name
                 display-buffer-alist #'string-match-p)
          '((display-buffer-same-window))))
 (t
  (add-to-list 'display-buffer-alist
               `(,(rx bos (eval blist-buffer-name) eos)
                 (display-buffer-same-window)))))

;;; Preserve annotation when overriding it

(defun durand-bookmark-set-preserve-annotation-advice
    (old-function prompt name overwrite-or-push)
  "Preserve the annotation of the old bookmark if we overwrite it.
OLD-FUNCTION should be `bookmark-set-internal'.

PROMPT, NAME are passed to `bookmark-set-internal'.

If OVERWRITE-OR-PUSH is non-nil, we set the overriding new
bookmark to have the same annotations as the old bookmark, if
any."
  ;; if we are not overwriting, we do not modify the behaviour
  (cond
   ((or (not overwrite-or-push) (eq overwrite-or-push 'push))
    (funcall old-function prompt name overwrite-or-push))
   ;; This temporary record only serves the purpose of providing a
   ;; default bookmark.
   ((let* ((temp-record (bookmark-make-record))
           (defaults (bookmark-prop-get temp-record 'defaults))
           (default
             (cond ((consp defaults) (car defaults)) (defaults)))
           (name (or name
                     (read-from-minibuffer
                      (format-prompt prompt default)
                      nil
                      bookmark-minibuffer-read-name-map
                      nil nil defaults)))
           (name (cond ((string= name "") default) (name)))
           (bookmark (bookmark-get-bookmark name t))
           (annotation (cond
                        (bookmark
                         (bookmark-get-annotation bookmark)))))
      (funcall old-function prompt name overwrite-or-push)
      (bookmark-set-annotation bookmark annotation)))))

(advice-add #'bookmark-set-internal
            :around
            #'durand-bookmark-set-preserve-annotation-advice)

;;; Bookmarks for external browsers

(defun durand-set-external-bookmark (url name)
  "Set a bookmark NAME storing URL.
This will be opened by the function `browse-url-default-browser'."
  (bookmark-store
   name
   (list
    (cons 'location url)
    (cons 'handler #'durand-external-jump))
   nil))

(autoload 'browse-url-default-browser "browse-url")

(defun durand-external-jump (bookmark)
  "Jump to the external BOOKMARK.
BOOKMARK should be set by `durand-set-external-bookmark'."
  (let* ((location (bookmark-prop-get bookmark 'location))
         (reporter (make-progress-reporter
                    (format "Opening %s..." location))))
    (browse-url-default-browser location)
    (progress-reporter-done reporter)))

(mapc
 (lambda (cons-cell)
   (durand-set-external-bookmark (car cons-cell) (cdr cons-cell)))
 (list
  (cons
   "https://www.youtube.com"
   "(External) YouTube")
  (cons
   "https://www.gmail.com"
   "(External) GMail")
  (cons
   "https://www.facebook.com"
   "(External) Facebook")
  (cons
   "https://protesilaos.com"
   "(External) prot")
  (cons
   "https://wmail1.cc.ntu.edu.tw/rc/?_task=mail&_mbox=INBOX"
   "(External) NTU mail")
  (cons
   "https://dictionary.christian-steinert.de/#home"
   "(External) tibdict")
  ;; "https://wmail1.cc.ntu.edu.tw/index.php?url=https%3A%2F%2Fwmail1.cc.ntu.edu.tw%2F"
  (cons
   "https://cool.ntu.edu.tw"
   "(External) cool ITA")
  ))

;;; A much quicker alternative to `bookmark-write-file'

(defun durand-bookmark-write-file (file)
  "Write `bookmark-alist' to FILE.
Modified by Durand to use `print' instead of `pp'.
-- 2022-07-16 13:09:22.777148"
  (let ((reporter (make-progress-reporter
		   (format "Saving bookmarks to file %s..." file))))
    (with-current-buffer (get-buffer-create " *Bookmarks*")
      (goto-char (point-min))
      (delete-region (point-min) (point-max))
      (let ((coding-system-for-write
	     (or coding-system-for-write
		 bookmark-file-coding-system 'utf-8-emacs))
	    (print-length nil)
	    (print-level nil)
	    ;; See bug #12503 for why we bind `print-circle'.  Users
	    ;; can define their own bookmark types, which can result in
	    ;; arbitrary Lisp objects being stored in bookmark records,
	    ;; and some users create objects containing circularities.
	    (print-circle t))
	(insert "(")
	;; Rather than a single call to `pp' we make one per bookmark.
	;; Apparently `pp' has a poor algorithmic complexity, so this
	;; scales a lot better.  bug#4485.
        ;;
        ;; Using print is better.  Durand -- 2022-07-16 13:10:25.084726
	(dolist (i bookmark-alist) (print i (current-buffer)))
	(insert ")\n")
	;; Make sure the specified encoding can safely encode the
	;; bookmarks.  If it cannot, suggest utf-8-emacs as default.
	(with-coding-priority '(utf-8-emacs)
	  (setq coding-system-for-write
		(select-safe-coding-system (point-min) (point-max)
					   (list t coding-system-for-write))))
	(goto-char (point-min))
	(bookmark-insert-file-format-version-stamp coding-system-for-write)
	(let ((version-control
	       (cond
		((null bookmark-version-control) nil)
		((eq 'never bookmark-version-control) 'never)
		((eq 'nospecial bookmark-version-control) version-control)
		(t t))))
	  (condition-case nil
              ;; There was a stretch of time (about 15 years) when we
              ;; used `write-region' below instead of `write-file',
              ;; before going back to `write-file' again.  So if you're
              ;; considering changing it to `write-region', please see
              ;; https://debbugs.gnu.org/cgi/bugreport.cgi?bug=12507.
              ;; That bug tells the story of how we first started using
              ;; `write-region' in 2005...
              ;;
              ;;   commit a506054af7cd86a63fda996056c09310966f32ef
              ;;   Author:     Karl Fogel <kfogel@red-bean.com>
              ;;   AuthorDate: Sat Nov 12 20:30:22 2005 +0000
              ;;
              ;;       (bookmark-write-file): Don't visit the
              ;;       destination file, just write the data to it
              ;;       using write-region.  This is similar to
              ;;       2005-05-29T08:36:26Z!rms@gnu.org of saveplace.el,
              ;;       but with an additional change to avoid visiting
              ;;       the  file in the first place.
              ;;
              ;; ...and of how further inquiry led us to investigate (in
              ;; 2012 and then again in 2020) and eventually decide that
              ;; matching the saveplace.el change doesn't make sense for
              ;; bookmark.el.  Therefore we reverted to `write-file',
              ;; which means numbered backups may now be created,
              ;; depending on `bookmark-version-control' as per above.
	      (write-file file)
	    (file-error (message "Can't write %s" file)))
	  (setq bookmark-file-coding-system coding-system-for-write)
	  (kill-buffer (current-buffer))
	  (progress-reporter-done reporter))))))

(advice-add #'bookmark-write-file :override #'durand-bookmark-write-file)


(provide 'bookmark-conf)
;;; bookmark-conf.el ends here