;;; company-tooltip.el --- Use a real ppup to show company candidates

;;; Commentary:
;;

;;; Code:

(require 'company)

(defun company-tooltip--frame-params (parent-frame)
  `(;; Initial state
    (fullscreen . nil)
    (line-spacing . 0)
    ;; Size
    (min-height . 0)
    (min-width . 0)
    ;; Borders and fringes
    (left-fringe . 0)
    (right-fringe . 0)
    (right-divider-width . 0)
    (bottom-divider-width . 0)
    (border-width . 0)
    (internal-border-width . 0)
    ;; UI components
    (undecorated . t)
    (menu-bar-lines . 0)
    (tool-bar-lines . 0)
    (vertical-scroll-bars . nil)
    (horizontal-scroll-bars . nil)
    ;; Buffers
    (minibuffer . nil)
    (unsplittable . t)
    ;; Appearance
    (cursor-type . nil) ;; FIXME Also use cursor-type and cursor-in-non-selected-windows variables
    (background-color . ,(face-attribute 'company-tooltip :background))
    ;; Behavior
    (delete-before . ,parent-frame)
    (no-focus-on-map . t)
    (skip-taskbar . t)
    (no-other-frame . t)
    (no-accept-focus . t)
    (z-group . above)))

(defvar company-tooltip--frame nil)
(defvar company-tooltip--buffer nil)

(defun company-tooltip--adjust-frame (x y width height)
  "Move company tooltip to X, Y and resize to WIDTH, HEIGHT."
  (set-frame-position company-tooltip--frame x y)
  (set-frame-width company-tooltip--frame width)
  (set-frame-height company-tooltip--frame height))

(defun company-tooltip--ensure-frame (x y width height)
  "Create or return the company tooltip frame.
X, Y, WIDTH, HEIGHT: see `company-tooltip--adjust-frame'."
  (unless (frame-live-p company-tooltip--frame)
    ;; (cl-letf (((symbol-function 'face-set-after-frame-default)
    ;;            (symbol-function 'ignore)))
    (setq company-tooltip--frame (make-frame `((top . ,y)
                                (left . ,x)
                                (width . ,width)
                                (height . ,height)
                                ,@(company-tooltip--frame-params (selected-frame))))))
  (company-tooltip--adjust-frame x y width height)
  ;; (make-frame-visible company-tooltip--frame)
  ;; FIXME raise-frame doesn't work when called right after make-frame-visible
  (raise-frame company-tooltip--frame))

(defvar company-tooltip--map
  (let ((map (make-keymap)))
    ;; FIXME this doesn't cause mouse events to be ignored
    (define-key map [t] 'ignore)
    map))

(define-derived-mode company-tooltip--mode fundamental-mode "tooltip"
  "Major mode for company tooltip frames."
  (setq-local overriding-local-map company-tooltip--map)
  (setq-local truncate-lines t)
  (setq-local mode-line-format nil)
  (setq-local cursor-type nil)
  (setq-local cursor-in-non-selected-windows nil))

;; (kill-buffer "*company-tooltip*")

(defun company-tooltip--ensure-buffer ()
  "Create or return the company tooltip buffer."
  (unless company-tooltip--buffer
    (with-current-buffer (get-buffer-create "*company-tooltip*")
      (company-tooltip--mode)
      (setq company-tooltip--buffer (current-buffer)))))

(defun company-tooltip--set-buffer ()
  "Set buffer of company tooltip frame."
  (company-tooltip--ensure-buffer)
  (set-window-buffer (frame-root-window company-tooltip--frame) company-tooltip--buffer))

(defun company-tooltip--posn-x-y (position)
  "Return X and Y coordinates of bottom-left corner of POSITION."
  (let* ((point-x-y (posn-x-y position))
         (window (posn-window position))
         (win-edges (window-edges window nil t t))
         (win-x-y (cons (nth 0 win-edges) (nth 1 win-edges)))
         (frame-x-y (cons (frame-parameter (selected-frame) 'top)
                          (frame-parameter (selected-frame) 'left))))
    (cons (+ (car point-x-y) (car win-x-y))
          (+ (cdr point-x-y) (cdr win-x-y)
             (line-pixel-height) (window-header-line-height window)))))

(defun company-tooltip--update-1 (width height contents)
  "Update position, WIDTH, HEIGHT, CONTENTS, and visibility of tooltip frame."
  (let* ((x-y (company-tooltip--posn-x-y (save-excursion
                            (backward-char (length company-prefix))
                            (posn-at-point)))))
    (company-tooltip--ensure-frame (car x-y) (cdr x-y) width (abs height))
    (company-tooltip--set-buffer)
    (with-current-buffer company-tooltip--buffer
      (erase-buffer)
      (insert contents))))

(defun company-tooltip--update (height selection)
  "Wrapper around `company-tooltip--update'.
HEIGHT is passed unmodified.  SELECTION is used to compute width
and contents."
  (let* ((lines (company--create-lines selection (abs height)))
         (contents (mapconcat (lambda (l) (concat l "​")) lines "\n")))
    (company-tooltip--update-1 (string-width (car lines)) height contents)))

(defun company-tooltip-show (row column selection)
  (company-tooltip--update (company--pseudo-tooltip-height) selection))

(defun company-tooltip-edit (selection)
  (company-tooltip--update (overlay-get company-pseudo-tooltip-overlay 'company-height) selection))

(defun company-tooltip-hide ()
  (when (frame-live-p company-tooltip--frame)
    ;; FIXME: this should work: (make-frame-invisible company-tooltip--frame)
    (delete-frame company-tooltip--frame)))

(defun company-tooltip--add-advice ()
  (interactive)
  (advice-add 'company-pseudo-tooltip-show :after 'company-tooltip-show)
  (advice-add 'company-pseudo-tooltip-edit :after 'company-tooltip-edit)
  (advice-add 'company-pseudo-tooltip-hide :after 'company-tooltip-hide))

(defun company-tooltip--remove-advice ()
  (interactive)
  (advice-remove 'company-pseudo-tooltip-show 'company-tooltip-show)
  (advice-remove 'company-pseudo-tooltip-edit 'company-tooltip-edit)
  (advice-remove 'company-pseudo-tooltip-hide 'company-tooltip-hide))

(provide 'company-tooltip)
;;; company-tooltip.el ends here