;;; company-flow.el --- Flow backend for company-mode  -*- lexical-binding: t -*-

;; Copyright (C) 2016 by Aaron Jensen

;; Author: Aaron Jensen <aaronjensen@gmail.com>
;; URL: https://github.com/aaronjensen/company-flow
;; Package-Version: 20180225.1359
;; Version: 0.1.0
;; Package-Requires: ((company "0.8.0") (dash "2.13.0"))

;;; Commentary:

;; This package adds support for flow to company. It requires
;; flow to be in your path.

;; To use it, add to your company-backends:

;;   (eval-after-load 'company
;;     '(add-to-list 'company-backends 'company-flow))

;;; License:

;; This file is not part of GNU Emacs.
;; However, it is distributed under the same license.

;; GNU Emacs 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, or (at your option)
;; any later version.

;; GNU Emacs 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 GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.

;;; Code:
(require 'company)
(require 'dash)

(defgroup company-flow ()
  "Flow company backend."
  :group 'company
  :prefix "company-flow-")

(defcustom company-flow-executable "flow"
  "Flow executable to run."
  :group 'company-flow
  :type 'string)
(make-variable-buffer-local 'company-flow-executable)

(defcustom company-flow-modes '(
                                js-mode
                                js-jsx-mode
                                js2-mode
                                js2-jsx-mode
                                rjsx-mode
                                web-mode
                                )
  "List of major modes where company-flow will be providing completions."
  :type '(choice (const :tag "All" nil)
                 (repeat (symbol :tag "Major mode")))
  :group 'company-flow)

(defun company-flow--handle-signal (process _event)
  (when (memq (process-status process) '(signal exit))
    (let ((callback (process-get process 'company-flow-callback))
          (prefix (process-get process 'company-flow-prefix)))
      (if (and (eq (process-status process) 'exit)
               (eq (process-exit-status process) 0))
          (funcall callback (->> process
                                 company-flow--get-output
                                 company-flow--parse-output
                                 ;; Remove nils
                                 (--filter it)))
        (funcall callback nil)))))

(defun company-flow--make-candidate (line)
  "Creates a candidate with a meta property from LINE.

LINE is expected to look like:
registrationSuccess () => {type: 'REGISTRATION_SUCCESS'}"
  (let ((first-space (string-match " " line)))
    (when first-space
      (let ((text (substring line 0 first-space))
            (meta (substring line (+ 1 first-space))))
        (propertize text 'meta meta)))))

(defun company-flow--parse-output (output)
  (when (not (equal output "Error: not enough type information to autocomplete\n"))
    (mapcar 'company-flow--make-candidate
            (split-string output "\n"))))

(defun company-flow--get-output (process)
  "Get the complete output of PROCESS."
  (with-demoted-errors "Error while retrieving process output: %S"
    (let ((pending-output (process-get process 'company-flow-pending-output)))
      (apply #'concat (nreverse pending-output)))))

(defun company-flow--receive-checker-output (process output)
  "Receive a syntax checking PROCESS OUTPUT."
  (push output (process-get process 'company-flow-pending-output)))

(defun company-flow--process-send-buffer (process)
  "Send all contents of current buffer to PROCESS.

Sends all contents of the current buffer to the standard input of
PROCESS, and terminates standard input with EOF."
  (save-restriction
    (widen)
    (process-send-region process (point-min) (point-max)))
  ;; flow requires EOF be on its own line
  (process-send-string process "\n")
  (process-send-eof process))

(defun company-flow--candidates-query (prefix callback)
  (let* ((line (line-number-at-pos (point)))
         (col (+ 1 (current-column)))
         (command (list (executable-find company-flow-executable)
                        "autocomplete"
                        "--quiet"
                        buffer-file-name
                        (number-to-string line)
                        (number-to-string col)))
         (process-connection-type nil)
         (process (apply 'start-process "company-flow" nil command)))
    (set-process-sentinel process #'company-flow--handle-signal)
    (set-process-filter process #'company-flow--receive-checker-output)
    (process-put process 'company-flow-callback callback)
    (process-put process 'company-flow-prefix prefix)
    (company-flow--process-send-buffer process)))

(defun company-flow--prefix ()
  "Grab prefix for flow."
  (and (or (null company-flow-modes)
           (-contains? company-flow-modes major-mode))
       company-flow-executable
       (executable-find company-flow-executable)
       buffer-file-name
       (file-exists-p buffer-file-name)
       (not (company-in-string-or-comment))
       (locate-dominating-file buffer-file-name ".flowconfig")
       (or (company-grab-symbol-cons "\\." 1)
           'stop)))

(defun company-flow--annotation (candidate)
  (format " %s" (get-text-property 0 'meta candidate)))

(defun company-flow--meta (candidate)
  (format "%s: %s" candidate (get-text-property 0 'meta candidate)))

(defvar-local company-flow--debounce-state nil)

(defun company-flow--debounce-callback (prefix callback)
  (lambda (candidates)
    (let ((current-prefix (car company-flow--debounce-state))
          (current-callback (cdr company-flow--debounce-state)))
      (when (and current-prefix
                 (company-flow--string-prefix-p prefix current-prefix))
        (setq company-flow--debounce-state nil)
        (funcall current-callback (all-completions current-prefix candidates))))))

(defun company-flow--prefix-to-string (prefix)
  "Return a string or nil from a prefix.
  `company-grab-symbol-cons' can return (\"prefix\" . t) or just
  \"prefix\", but we only care about the string."
  (if (consp prefix)
      (car prefix)
    prefix))

(defun company-flow--string-prefix-p (a b)
  (string-prefix-p (company-flow--prefix-to-string a) (company-flow--prefix-to-string b)))

(defun company-flow--debounce-async (prefix candidate-fn)
  "Return a function that will properly debounce candidate queries by comparing the
in-flight query's prefix to PREFIX. CANDIDATE-FN should take two arguments, PREFIX
and the typical async callback.

Note that the candidate list provided to the callback by CANDIDATE-FN will be
filtered via `all-completions' with the most current prefix, so it is not necessary
to do this filtering in CANDIDATE-FN.

Use like:

  (cons :async (company-flow--debounce-async arg 'your-query-fn))"
  (lambda (callback)
    (let ((current-prefix (car company-flow--debounce-state)))
      (unless (and current-prefix
                   (company-flow--string-prefix-p prefix current-prefix))
        (funcall candidate-fn prefix (company-flow--debounce-callback prefix callback)))
      (setq company-flow--debounce-state (cons (company-flow--prefix-to-string prefix) callback)))))

;;;###autoload
(defun company-flow (command &optional arg &rest _args)
  (interactive (list 'interactive))
  (pcase command
    (`interactive (company-begin-backend 'company-flow))
    (`prefix (company-flow--prefix))
    (`annotation (company-flow--annotation arg))
    (`meta (company-flow--meta arg))
    (`sorted t)
    (`candidates (cons :async (company-flow--debounce-async arg 'company-flow--candidates-query)))))

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