;;; merlin-company.el --- Merlin and company mode integration.   -*- coding: utf-8 -*-
;; Licensed under the MIT license.

;; Author: Simon Castellan <simon.castellan(_)iuwt.fr>
;;         Frédéric Bour <frederic.bour(_)lakaban.net>
;;         Thomas Refis <thomas.refis(_)gmail.com>
;; Created: 15 May 2015
;; Version: 0.1
;; Keywords: ocaml languages
;; URL: http://github.com/ocaml/merlin

(require 'merlin)
(require 'company)
(require 'cl-lib)

;; (require 'merlin-company) should be enough to get merlin to work within
;; company.
;;
;; If you always want company-mode to be available, consider adding:
;;   (add-hook 'after-init-hook 'global-company-mode)
;; in your .emacs.


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; It would be nice to define a proper (somewhat stable) interface in merlin.el
;; to be used by other modules.

;; Internal functions

(defun merlin-company--get-candidate-type (candidate)
  (get-text-property 0 'merlin-compl-type candidate))

(defun merlin-company--get-candidate-doc (candidate)
  (get-text-property 0 'merlin-compl-doc candidate))

(defun merlin-company--is-module (candidate)
  (string-equal (merlin-company--get-candidate-type candidate) " <module>"))

(defun merlin-company--has-doc (candidate)
  (not (or (string-equal (merlin-company--get-candidate-doc candidate) "")
           (merlin-company--is-module candidate))))

(defun merlin-company--doc-buffer (candidate)
  "Computes the /doc/ of CANDIDATE and returns the buffer where it printed it"
  (cond
    ((merlin-company--has-doc candidate)
     (let* ((doc (merlin-company--get-candidate-doc candidate))
            ; We add (** and *) around documentation so we can reuse the type buffer
            ; without getting some weird highlighting.
            (doc (concat
                   "val " candidate " : "
                   (merlin-company--get-candidate-type candidate)
                   "\n\n(** " doc " *)")))
       (merlin/display-in-type-buffer doc)))

    ((merlin-company--is-module candidate)
     (merlin/display-in-type-buffer
      (merlin/call "type-expression"
                   "-position" (merlin/unmake-point (point))
                   "-expression" (substring-no-properties candidate))))

    (t (merlin/display-in-type-buffer
         (merlin-company--get-candidate-type candidate))))
  (get-buffer merlin-type-buffer-name))

(defun merlin-company--meta (candidate)
  "Computes the information to display in the minibuffer for CANDIDATE"
  (let* ((arg-type (get-text-property 0 'merlin-arg-type candidate))
         (entry-ty (merlin-company--get-candidate-type candidate))
         (default  (if (and merlin-completion-arg-type arg-type)
                     (concat "Expected argument type: " arg-type)
                     entry-ty)))
    (cond
      ((merlin-company--has-doc candidate)
       (concat default " (press F1 to display documentation of " candidate ")"))
      ((merlin-company--is-module candidate)
       (concat "Press F1 to display the signature of module " candidate
               " (successive calls will expand aliases)"))
      (t default))))

;; Public functions
;;;###autoload
(defun merlin-company-backend (command &optional arg &rest ignored)
    (interactive (list 'interactive))
    (when merlin-mode
      (case command
        (interactive (company-begin-backend 'company-my-backend))
        (prefix
         (let* ((bounds (merlin/completion-bounds))
                (result (merlin/buffer-substring (car bounds) (cdr bounds))))
           (when (and (boundp 'company-candidates-cache)
                      (or (string-match-p "\\.$" result)
                          (member '("" "") company-candidates-cache)))
             ;; for some reason, company doesn't always clear its cache
             (setq company-candidates-cache nil))
           result))
        (no-cache t)
        (sorted t)
        (init t)
        (require-match 'never)
        (doc-buffer (merlin-company--doc-buffer arg))
        (location
         (ignore-errors
           (let ((data (merlin/locate arg)))
             (when (listp data)
               (let ((filename (merlin-lookup 'file data (buffer-file-name)))
                     (linum (cdr (assoc 'line (assoc 'pos data)))))
                 (cons filename linum))))))
        (candidates
         (let ((prefix (merlin/completion-prefix arg)))
           (cl-loop for x in (merlin/complete arg)
                    collect
                    (propertize (merlin/completion-entry-text prefix x)
                                'merlin-compl-type
                                (merlin/completion-entry-short-description x)
                                'merlin-arg-type (cdr (assoc 'argument_type x))
                                'merlin-compl-doc (cdr (assoc 'info x))))))
        (post-completion
         (let ((minibuffer-message-timeout nil))
           (minibuffer-message "%s : %s" arg (merlin-company--get-candidate-type arg))))
        (meta (merlin-company--meta arg))
        (annotation
         (concat " : " (merlin-company--get-candidate-type arg))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Register into company-mode ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(eval-after-load 'company
  '(add-to-list 'company-backends 'merlin-company-backend))

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