indent-guide2 (experimental)

indent-guide2.el

;; Usage:
;; (require 'indent-guide2)
;; (indent-guide2-global-mode)

(require 'cl-lib)

(defvar indent-guide2-line-color "#303030")
(defvar indent-guide2-line-dash-length nil)
(defvar indent-guide2-line-char ?\|)
(defvar indent-guide2-line-enable-xpm t)
(defvar indent-guide2-line-char-height (frame-char-height))
(defvar indent-guide2-line-char-width (frame-char-width))

;; + utilities
;;   + image generator

(defvar indent-guide2--image-cache (make-hash-table :test 'equal))
(defun indent-guide2--make-image (length levels char-width char-height &optional stringp)
  "Make a string for overlays."
  (let ((pair (gethash (list char-width char-height length levels) indent-guide2--image-cache)))
    (unless pair
      (let* ((width (* length char-width))
             (positions (mapcar (lambda (p) (+ (* p char-width) (/ char-width 2))) levels))
             (img (create-image
                   (with-temp-buffer
                     (insert "/* XPM */ static char * x[] = {"
                             (format "\"%d %d 2 1\"" width char-height)
                             (format ",\". c %s\"" indent-guide2-line-color)
                             ",\"  c None\"")
                     (dotimes (i char-height)
                       (let ((s (make-string width ?\s)))
                         (unless (and indent-guide2-line-dash-length
                                      (zerop (mod (1+ i) (1+ indent-guide2-line-dash-length))))
                           (dolist (pos positions) (aset s pos ?\.)))
                         (insert (concat ",\"" s "\""))))
                     (insert "}")
                     (buffer-string))
                   'xpm t :ascent 'center))
             (str (let ((s (make-string length ?\s)))
                    (dolist (pos levels) (aset s pos indent-guide2-line-char))
                    (propertize s 'face `(:foreground ,indent-guide2-line-color)))))
        (setq pair (cons str img))
        (puthash (list char-width char-height length levels) pair indent-guide2--image-cache)))
    (cond ((not indent-guide2-line-enable-xpm) (car pair))
          (stringp                            (propertize (car pair) 'display (cdr pair)))
          (t                                  (cdr pair)))))

;;   + indentation parser

(defun indent-guide2--bol-candidates (level)
  "*Internal function for `indent-guide2--bol-regex'*"
  (cond ((<= level 0)
         (list ""))
        ((>= level tab-width)
         (cons (concat "\t" (make-string (- level tab-width) ?\s))
               (cons (make-string level ?\s)
                     (indent-guide2--bol-candidates (1- level)))))
        (t
         (cons (make-string level ?\s)
               (indent-guide2--bol-candidates (1- level))))))

(defvar indent-guide2--bol-regex-cache (make-hash-table :test 'eql))
(defun indent-guide2--bol-regex (base-level)
  "Generate a regex that matches a beginning of level whose
indent width is BASE-LEVEL."
  (or (gethash base-level indent-guide2--bol-regex-cache)
      (let* ((candidates (indent-guide2--bol-candidates (1- base-level)))
             (regex (concat "^" (regexp-opt candidates t) "[^\s\t\n]")))
        (puthash base-level regex indent-guide2--bol-regex-cache)
        regex)))

(defun indent-guide2--get-current-level ()
  "Get the level of the current line."
  (save-excursion
    (back-to-indentation)
    (if (not (eolp))
        (current-column)
      (max (save-excursion
             (skip-chars-forward "\s\t\n")
             (current-column))
           (save-excursion
             (skip-chars-backward "\s\t\n")
             (back-to-indentation)
             (current-column))))))

(defun indent-guide2--beginning-of-level ()
  "Move to the beginning of current indentation level and return
the point. When no such points are found, just return nil."
  (let* ((base-level (indent-guide2--get-current-level))
         (regex (indent-guide2--bol-regex base-level)))
    (unless (zerop base-level)
      (and (search-backward-regexp regex nil t)
           (goto-char (match-end 1))))))

;;   + pixel display

(defun indent-guide2--get-char-size ()
  "Return char size in pixels at pos. Return value is a pair of
the form (WIDTH . HEIGHT)."
  ;; (let* ((p1 (pos-visible-in-window-p (point) nil t))
  ;;        (p2 (and (not (eolp))
  ;;                 (pos-visible-in-window-p (1+ (point)) nil t)))
  ;;        (p3 (save-excursion
  ;;              (and (zerop (forward-line 1))
  ;;                   (pos-visible-in-window-p (point) nil t)))))
  ;;   (cons (if (and p1 p2) (- (car p2) (car p1)) (frame-char-width))
  ;;         (if (and p1 p3) (- (cadr p3) (cadr p1)) (frame-char-height))))
  (cons indent-guide2-line-char-width indent-guide2-line-char-height))

;; + main

(defun indent-guide2--get-old-guides (pos)
  (cl-some (lambda (o) (overlay-get o 'indent-guide2-guides)) (overlays-at pos)))

(defun indent-guide2--get-guides ()
  "*Internal function for `indent-guide2--put-guides'*"
  (or (indent-guide2--get-old-guides (point-at-bol))
      (let ((guides nil))
        (save-excursion
          (while (indent-guide2--beginning-of-level)
            (push (current-column) guides)))
        (cons (indent-guide2--get-current-level) (nreverse guides)))))

;; 最後の行のガイドが古いガイドから変化していたらそれより下も変化する可能性がある

;; *WIP*
(defun indent-guide2--put-guides (b e)
  (interactive "r")
  (let (col guides oldguides)
    (save-excursion
      ;; goto the beginning position
      (goto-char b)
      (beginning-of-line)
      (setq b (point))
      ;; remove old overlays
      (remove-overlays b e 'category 'indent-guide2)
      ;; get initial guides
      (save-excursion
        (setq guides (and (zerop (forward-line -1)) (indent-guide2--get-guides))))
      ;; draw guide lines
      (while (and (progn                ; update `guides'
                    (setq col (indent-guide2--get-current-level))
                    (while (and guides (>= (car guides) col))
                      (setq guides (cdr guides)))
                    (push col guides))
                  (or (< (point) e)
                      (unless (or (null
                                   (setq oldguides (indent-guide2--get-old-guides (point))))
                                  (equal guides oldguides))
                        (dolist (o (overlays-at (point)))
                          (when (eq 'indent-guide2 (overlay-get o 'category))
                            (delete-overlay o)))
                        t))
                  (progn
                    (when (cdr guides)
                      (let* ((bol (point))
                             (ind (progn (back-to-indentation) (point))))
                        (unless (= bol ind)
                          (let* ((size (indent-guide2--get-char-size))
                                 (ov (make-overlay bol ind))
                                 (img (indent-guide2--make-image
                                       (max (- ind bol) (1+ (cadr guides))) (cdr guides)
                                       (car size) (cdr size))))
                            (overlay-put ov 'category 'indent-guide2)
                            (overlay-put ov 'indent-guide2-guides (cl-copy-list guides))
                            (overlay-put ov 'display img)))))
                    ;; (when (cdr guides)
                    ;;   (let* ((size (indent-guide2--get-char-size))
                    ;;          (bol (point))
                    ;;          (ind (progn (back-to-indentation) (point)))
                    ;;          (ov (make-overlay bol ind))
                    ;;          (prop (and (= bol ind) 'before-string))
                    ;;          (img (indent-guide2--make-image
                    ;;                (max (- ind bol) (1+ (cadr guides))) (cdr guides)
                    ;;                (car size) (cdr size) prop)))
                    ;;     (overlay-put ov 'category 'indent-guide2)
                    ;;     (overlay-put ov 'indent-guide2-guides (cl-copy-list guides))
                    ;;     (overlay-put ov (or prop 'display) img)))
                    t)
                  (zerop (forward-line 1)))))))

(defvar indent-guide2--hiden-ovs nil)
(defun indent-guide2--post-command-hook ()
  (dolist (ov indent-guide2--hiden-ovs)
    (when (overlayp ov)
      (overlay-put
       ov
       (overlay-get ov 'indent-guide2-saved-prop)
       (overlay-get ov 'indent-guide2-saved-prop-value))))
  (dolist (ov (overlays-at (point)))
    (when (eq (overlay-get ov 'category) 'indent-guide2)
      (let* ((bs (overlay-get ov 'before-string))
             (d (overlay-get ov 'display))
             (prop (if bs 'before-string 'display)))
        (overlay-put ov prop nil)
        (overlay-put ov 'indent-guide2-saved-prop prop)
        (overlay-put ov 'indent-guide2-saved-prop-value (or bs d)))
      (push ov indent-guide2--hiden-ovs))))

;;;###autoload
(define-minor-mode indent-guide2-mode
  "test"
  :init-value nil
  :lighter " ING"
  :global nil
  (if indent-guide2-mode
      (progn
        (jit-lock-register 'indent-guide2--put-guides)
        (add-hook 'post-command-hook 'indent-guide2--post-command-hook nil t))
    (jit-lock-unregister 'indent-guide2--put-guides)
    (remove-hook 'post-command-hook 'indent-guide2--post-command-hook t)
    (remove-overlays (point-min) (point-max) 'category 'indent-guide2)))

;;;###autoload
(define-globalized-minor-mode indent-guide2-global-mode
  indent-guide2-mode
  (lambda () (indent-guide2-mode 1)))

(provide 'indent-guide2)