vimish fold

vf-fold.el

;; :::::::::: parse buffer ::::::::::::::::::::::::::::::::::::::::::::::::::::::
;; working code
(defun vf-parse-buffer-defun ()
  "test buffer parsing"
  (interactive)
  (with-current-buffer
      (progn
        (save-excursion
          (goto-char (point-min))
          (while (not (eobp))
            (message "loop start %s" (line-number-at-pos))

            (if (thing-at-point 'defun)
                (progn
                  (let*((bounds (bounds-of-thing-at-point 'defun))
                        (start (car bounds))
                        (end (cdr bounds))
                        (st (buffer-substring-no-properties start end)))
                    (message "thing bw %s and %s is {%s}" start end st)
                    ;; handle exception
                    (ignore-errors
                      (vf-fold start end))
                    ;; move out of defun
                    (goto-char (+ 1 end))))
              (forward-line )))))))
;; ::::::::::folding ::::::::::::::::::::::::::::::::::::::::::::::::::::::
;; working code
(defun vf-fold (beg end)
  "Fold active region staring at BEG, ending at END.
   Fold such that there is no overlapping"
  (interactive "r")
  (deactivate-mark)
  (save-excursion
  (cl-destructuring-bind (beg . end) (vimish-fold--correct-region beg end)
    (when (< (count-lines beg end) 2)
      (error "Nothing to fold"))
    (dolist (overlay (overlays-in beg end))
      (when (vimish-fold--vimish-overlay-p overlay)
        (let ((ol_beg  (overlay-start overlay))
              (ol_end (overlay-end overlay)))
          (if (not
               (and
                (or
                 ;; if the current overlay is surrounding old overlay
                 (and (>= ol_beg beg)
                      (<= ol_end end))
                 ;; if the current overlay is enclosed in old overlay
                 (and (<= ol_beg beg)
                      (>= ol_end end)))
                (and (/= ol_beg beg) (/= ol_end end) )))

              ;; if block
              (progn
                (goto-char (overlay-start overlay))
                (error "Fold overlaps"))))))
    ;; when none of the folds overlaps
    (progn
      (vimish-fold--read-only t (max 1 (1- beg)) end)
      (let ((overlay (make-overlay beg end nil t nil)))
        (overlay-put overlay 'type 'vimish-fold--folded)
        (overlay-put overlay 'evaporate t)
        (overlay-put overlay 'keymap vimish-fold-folded-keymap)
        (vimish-fold--apply-cosmetic overlay (vimish-fold--get-header beg end)))))))

(evil-vimish-fold/create)

(defun vimish-fold (beg end)
     "Monkey patch vimish fold"
     (vf-fold beg end)
     (deactivate-mark))
;;;###autoload


;; :::::::::: unfold ::::::::::::::::::::::::::::::::::::::::::::::::::::::

(defun vf-folded-p (overlay)
  "Returns true if overlay is a folded vimish fold overlay"
  (eq (overlay-get overlay 'type) 'vimish-fold--folded))

(defun vf-unfold ()
  "Unfolds the top most folded overlay at point"
;;(progn
;;  (goto-line 219)
  ;; init ret_overlay to nil
  (let* ((overlays (seq-filter 'vf-folded-p (overlays-at (point))))
         (ret_overlay (car overlays)))
    ;;(overlays (overlays-in (point-min) (point-max))))
    (dolist (ct_overlay (cdr overlays) ret_overlay)
      ;; select the top (largest) unfolded overlay
      (let ((ctcstart  (overlay-start ct_overlay) )
            (ctend  (overlay-end ct_overlay) )
            (retstart  (overlay-start ret_overlay) )
            (retcend  (overlay-end ret_overlay) ))

          )
      (when (and (<= ctstart retstart)
                 (>= ctend retend)
                 (and (/= ctstart retstart )
                      (/= ctend retend)))
        (setq ret_overlay ct_overlay)))
    (message "ret_overlay %s" ret_overlay)
    (when ret_overlay
      (vimish-fold--unfold ret_overlay))))

;; monkey patch vimish unfold
(defun vimish-fold-unfold ()
  "Delete all `vimish-fold--folded' overlays at point."
  (interactive)
  ;;(mapc #'vimish-fold--unfold (overlays-at (point)))
  (vf-unfold)
  (deactivate-mark))

;;::::::::: test code :::::::::::::
(progn
  (let
        ((s (save-excursion
             (goto-line 215)
             (point)))
       (e (save-excursion
            (goto-line 228)
            (point))))
    (message "s: %s, e:%s, str:%s" s e (buffer-substring-no-properties s e))
    (vf-fold s e)
    ;;(vimish-fold--folds-in s e)
    ))
(require 'color)
;; https://github.com/mariusk/emacs-color
(defun gen-col-list (length s v &optional hval)
  (cl-flet ( (random-float () (/ (random 10000000000) 10000000000.0))
             (mod-float (f) (- f (ffloor f))) )
    (unless hval
      (setq hval (random-float)))
    (let ((golden-ratio-conjugate (/ (- (sqrt 5) 1) 2))
          (h hval)
          (current length)
          (ret-list '()))
      (while (> current 0)
        (setq ret-list
              (append ret-list
                      (list (apply 'color-rgb-to-hex (color-hsl-to-rgb h s v)))))
        (setq h (mod-float (+ h golden-ratio-conjugate)))
        (setq current (- current 1)))
      ret-list)))


(gen-col-list 1 0.85 0.65)

(defun my-color-preview ()
(interactive)
(let ((buffer-name "*font families*"))
  (with-current-buffer (get-buffer-create buffer-name)
    (erase-buffer)
    (dolist (hex-color (gen-col-list 5 0.17 0.93))
      (insert (propertize hex-color 'face (list :background hex-color))
              "\n"))
    (goto-char (point-min)))
  (pop-to-buffer-same-window buffer-name)))

(defun tst-overlay (@beg @end)
  "test overlay"
  (interactive "r")
  (progn
      (overlay-put (make-overlay @beg @end)
                   ;;'face '(:background "green")))
                   ;;'face 'secondary-selection))
                   'face (list :background (car(gen-col-list 1 0.5 0.65)))))
                   ;;'face (list :background "green")))
    (setq mark-active nil))

(message "%s" secondary-selection)
(defun rm-overlay (@beg @end)
  "remove overlays"
  (interactive "r")
  (remove-overlays @beg @end))
;; :::::::::: refold ::::::::::::::::::::::::::::::::::::::::::::::::::::::

;; pathed so that enclosed folds are refolded
(defun vimish-fold--refold (overlay)
  "Refold fold found by its OVERLAY type `vimish-fold--unfolded'."
  (when (eq (overlay-get overlay 'type) 'vimish-fold--unfolded)
    (let* ((beg (overlay-start overlay))
           (end (overlay-end   overlay)))
      (delete-overlay overlay)
      (vf-fold beg end))))

(defun vf-unfolded-p (overlay)
  "Returns true if overlay is a folded vimish fold overlay"
  (eq (overlay-get overlay 'type) 'vimish-fold--unfolded))

(defun vf-refold ()
  "refolds the smallest unfolded overlay at point"
  (interactive)
  ;;(progn
  ;;  (goto-line 219)
  ;; init ret_overlay to nil
  (let* ((overlays (seq-filter 'vf-unfolded-p (overlays-at (point))))
         (ret_overlay (car overlays)))
    (message "refold: overlays %s" overlays)
    (dolist (ct_overlay (cdr overlays) ret_overlay)
      ;; select the smallest unfolded overlay
      (let ((ctstart  (overlay-start ct_overlay) )
            (ctend  (overlay-end ct_overlay) )
            (retstart  (overlay-start ret_overlay) )
            (retend  (overlay-end ret_overlay) ))
      (when (and (>= ctstart retstart)
                 (<= ctend retend)
                 (and (/= ctstart retstart )
                      (/= ctend retend)))
        (setq ret_overlay ct_overlay))))
    (message "refold:ret_overlay %s" ret_overlay)
    (when ret_overlay
      (vimish-fold--refold ret_overlay))))

(defun vimish-fold-refold ()
  "Monkeypatch unfolded fold at point."
  (interactive)
  ;;(mapc #'vimish-fold--refold (overlays-at (point))))
  (vf-refold))

;; :::::::::: unfolded fringe color ::::::::::::::::::::::::::::::::::::::::::::::::::::::
(require 'color)

;; https://github.com/mariusk/emacs-color
(defun gen-col-list (length s v &optional hval)
  (cl-flet ( (random-float () (/ (random 10000000000) 10000000000.0))
             (mod-float (f) (- f (ffloor f))) )
    (unless hval
      (setq hval (random-float)))
    (let ((golden-ratio-conjugate (/ (- (sqrt 5) 1) 2))
          (h hval)
          (current length)
          (ret-list '()))
      (while (> current 0)
        (setq ret-list
              (append ret-list
                      (list (apply 'color-rgb-to-hex (color-hsl-to-rgb h s v)))))
        (setq h (mod-float (+ h golden-ratio-conjugate)))
        (setq current (- current 1)))
      ret-list)))

(defun vimish-fold--setup-fringe (overlay &optional prefix)
  "Setup fringe for OVERLAY according to user settings.

If PREFIX is not NIL, setup fringe for every line."
  (when vimish-fold-indication-mode
    (unless (memq vimish-fold-indication-mode
                  '(left-fringe right-fringe))
      (error "Invalid fringe side: %S"
             vimish-fold-indication-mode))
    (overlay-put overlay 'face (list :background (car(gen-col-list 1 0.17 0.93))))
    (overlay-put overlay (if prefix 'line-prefix 'before-string)
                 (propertize "…"
                             'display
                             (list vimish-fold-indication-mode
                                   'empty-line
                                   'vimish-fold-fringe)))))
;; :::::::::: delete ::::::::::::::::::::::::::::::::::::::::::::::::::::::

;; follow same logic as vf-refold
;; get the smallest possible unfolded fold and delete
;; for deleting a closed fold recursively delete all fold inside it, don't attempt this
(defun vf-delete ()
  "Delete inner most fold at point."
  (interactive)
  (goto-line 167)
  ;; init ret_overlay to nil
  (let ( (ret_overlay 'nil)
         (overlays (seq-filter
                    ()
                    (overlays-at (point))))
         ;;(overlays (overlays-in (point-min) (point-max))))
         (dolist (overlay overlays ret_overlay)
           (message "%s" overlay)
           )))
  (vf-delete)