;; macros from https://github.com/weirdNox/dotfiles/blob/master/config/.emacs.d/config.org#hooks
(defun nox-unquote (exp)
  "Return EXP unquoted."
  (declare (pure t) (side-effect-free t))
  (while (memq (car-safe exp) '(quote function))
    (setq exp (cadr exp)))
  exp)

(defun nox-enlist (exp)
  "Return EXP wrapped in a list, or as-is if already a list."
  (declare (pure t) (side-effect-free t))
  (if (listp exp) exp (list exp)))

(defun nox-resolve-hook-forms (hooks)
  (declare (pure t) (side-effect-free t))
  (cl-loop with quoted-p = (eq (car-safe hooks) 'quote)
           for hook in (nox-enlist (nox-unquote hooks))
           if (eq (car-safe hook) 'quote)
           collect (cadr hook)
           else if quoted-p
           collect hook
           else collect (intern (format "%s-hook" (symbol-name hook)))))

(defmacro add-hook! (&rest args)
  "A convenience macro for `add-hook'. Takes, in order:

   1. Optional properties :local and/or :append, which will make the hook
      buffer-local or append to the list of hooks (respectively),
   2. The hooks: either an unquoted major mode, an unquoted list of major-modes,
      a quoted hook variable or a quoted list of hook variables. If unquoted, the
      hooks will be resolved by appending -hook to each symbol.
   3. A function, list of functions, or body forms to be wrapped in a lambda.

Examples:
    (add-hook! 'some-mode-hook 'enable-something)   (same as `add-hook')
    (add-hook! some-mode '(enable-something and-another))
    (add-hook! '(one-mode-hook second-mode-hook) 'enable-something)
    (add-hook! (one-mode second-mode) 'enable-something)
    (add-hook! :append (one-mode second-mode) 'enable-something)
    (add-hook! :local (one-mode second-mode) 'enable-something)
    (add-hook! (one-mode second-mode) (setq v 5) (setq a 2))
    (add-hook! :append :local (one-mode second-mode) (setq v 5) (setq a 2))

Body forms can access the hook's arguments through the let-bound variable `args'."
  (declare (indent defun) (debug t))
  (let ((hook-fn 'add-hook)
        append-p local-p)
    (while (keywordp (car args))
      (pcase (pop args)
        (:append (setq append-p t))
        (:local  (setq local-p t))
        (:remove (setq hook-fn 'remove-hook))))
    (let ((hooks (nox-resolve-hook-forms (pop args)))
          (funcs (let ((arg (car args)))
                   (if (memq (car-safe arg) '(quote function))
                       (if (cdr-safe (cadr arg))
                           (cadr arg)
                         (list (cadr arg)))
                     (list args))))
          forms)
      (dolist (fn funcs)
        (setq fn (if (symbolp fn)
                     `(function ,fn)
                   `(lambda (&rest _) ,@args)))
        (dolist (hook hooks)
          (push (if (eq hook-fn 'remove-hook)
                    `(remove-hook ',hook ,fn ,local-p)
                  `(add-hook ',hook ,fn ,append-p ,local-p))
                forms)))
      `(progn ,@(if append-p (nreverse forms) forms)))))

(defun string-display-width (string &optional mode)
  "Calculate diplayed column width of STRING.
Optional MODE specifies major mode used for display."
  (with-temp-buffer
    (with-silent-modifications
      (setf (buffer-string) string))
    (when (fboundp mode)
      (funcall mode)
      (font-lock-fontify-buffer))
    (current-column)))

(defun string-display-truncate (string num &optional mode hide-p ellipsis)
  "Trim displayed STRING to NUM columns.
Optional MODE specifies major mode used for display.
Non-nil HIDE-P means that the string should be trimmed by hiding the trailing part with text properties.
Optional ELLIPSIS string is shown in place of the hidden/deleted part of the string."
  (with-temp-buffer
    (with-silent-modifications
      (setf (buffer-string) string))
    (when (fboundp mode)
      (funcall mode)
      (font-lock-fontify-buffer))
    (when (> (current-column) num)
      (move-to-column num)
      (with-silent-modifications
	(if hide-p
	    (progn
	      (if (stringp ellipsis)
		  (put-text-property (point) (point-max) 'display ellipsis)
		(put-text-property (point) (point-max) 'invisible t))
              (put-text-property (point) (point-max) 'truncated t))
	  (kill-line)
          (when (stringp ellipsis) (insert ellipsis)))))
    (buffer-string)))
    
(defun org-agenda-fix-tag-alignment ()
  "Use 'display :align-to instead of spaces in agenda."
  (goto-char (point-min))
  (setq-local word-wrap nil) ; tags would be moved to next line if `word-wrap'` is non-nil and `truncate-lines' is nil
  (while (re-search-forward org-tag-group-re nil 'noerror)
    (put-text-property (match-beginning 0) (match-beginning 1) 'display `(space . (:align-to (- right (,(string-display-pixel-width (match-string 1)))))))))

(defun org-agenda-adaptive-fill-function ()
  "Fill to the beginning of headline in agenda."
  (save-excursion
    (when-let ((txt (get-text-property (line-beginning-position) 'txt)))
      (search-forward (substring txt 0 10))
      (goto-char (match-beginning 0))
      (when-let ((re (get-text-property (line-beginning-position) 'org-todo-regexp)))
	(re-search-forward re (line-end-position) 't)
        (re-search-forward org-priority-regexp (line-end-position) 't))
      (make-string (current-column) ?\ ))))

(defun org-agenda-truncate-headings (&rest _)
  "Truncate agenda headings to fit the WINDOW width."
  (with-silent-modifications
    (save-excursion
      ;; indent wrapped lines to the position below the begining of the heading string
      (setq-local adaptive-fill-function #'org-agenda-adaptive-fill-function)

      ;; (setq-local truncate-lines nil)
      ;; (adaptive-wrap-prefix-mode +1)

      ;; cleanup earlier truncation
      (let ((pos (point-min))
	    next)
	(while (and (setq pos (next-single-char-property-change pos 'truncated nil (point-max)))
		    (setq next (next-single-char-property-change pos 'truncated nil (point-max)))
		    (get-text-property pos 'truncated))
	  (remove-text-properties pos next '(truncated nil invisible nil display nil))))

      (let ((pos (point-min))
	    next)
	(while (and (setq pos (next-single-char-property-change pos 'org-agenda-afterline nil (point-max)))
		    (setq next (next-single-char-property-change pos 'org-agenda-afterline nil (point-max)))
		    (get-text-property pos 'org-agenda-afterline))
	  (setf (buffer-substring pos next) "")))

      (goto-char (point-min))
      (let ((window-width (window-width))
	    (ellipsis "…")
	    (gap "  "))
	(while (and (setf (point) (next-single-char-property-change (point) 'org-hd-marker nil (point-max)))
		    (< (point) (point-max)))
	  (let* ((tag-width (when (re-search-forward org-tag-group-re (point-at-eol) 'noerror)
			      (string-display-width (match-string 1))))
		 (beg (point-at-bol))
		 (end (if tag-width (match-beginning 0) (point-at-eol)))
		 (tag-width (or tag-width 0)))
	    (setf (buffer-substring beg end)
		  (string-display-truncate (buffer-substring beg end)
					   (- window-width
					      tag-width
					      (string-display-width (s-concat ellipsis gap)))
					   nil 'hide ellipsis))
	    (goto-char (next-single-char-property-change (point-at-bol) 'truncated nil (point-at-eol)))
	    (let ((truncated-string (buffer-substring (point) (next-single-char-property-change (point) 'truncated nil (point-at-eol)))))
	      (unless (seq-empty-p truncated-string)
		(remove-text-properties 0 (length truncated-string) '(truncated nil invisible nil display nil) truncated-string)
		(add-text-properties 0 (length truncated-string) '(org-agenda-afterline t) truncated-string)
		(end-of-line)
		(insert (apply #'propertize ellipsis
			       (text-properties-at 0 truncated-string)))
		(insert truncated-string)))
            (end-of-line)))))))

(add-hook! 'org-agenda-finalize-hook #'org-agenda-fix-tag-alignment)
(add-hook! :append 'org-agenda-finalize-hook #'org-agenda-truncate-headings)
(add-hook! 'org-agenda-finalize-hook (add-hook! :local 'window-configuration-change-hook #'org-agenda-truncate-headings))