;;; company-c-headers.el --- Company mode backend for C/C++ header files  -*- lexical-binding: t -*-

;; Copyright (C) 2014 Alastair Rankine

;; Author: Alastair Rankine <alastair@girtby.net>
;; Keywords: development company
;; Package-Version: 20150801.901
;; Package-Requires: ((emacs "24.1") (company "0.8"))

;; This file is not part of GNU Emacs.

;; This file 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 of the License, or
;; (at your option) any later version.

;; This file 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 this file.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:

;; This library enables the completion of C/C++ header file names using Company.
;;
;; To initialize it, just add it to `company-backends':
;;
;; (add-to-list 'company-backends 'company-c-headers)
;;
;; When you type an #include declaration within a supported major mode (see
;; `company-c-headers-modes'), company-c-headers will search for header files
;; within predefined search paths.  company-c-headers can search "system" and
;; "user" paths, depending on the type of #include declaration you type.
;;
;; You will probably want to customize the `company-c-headers-path-user' and
;; `company-c-headers-path-system' variables for your specific needs.

;;; Code:

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

(defgroup company-c-headers nil
  "Completion back-end for C/C++ header files."
  :group 'company)

(defcustom company-c-headers-path-system
  '("/usr/include/" "/usr/local/include/")
  "List of paths to search for system (i.e. angle-bracket
delimited) header files.  Alternatively, a function can be
supplied which returns the path list."
  :type '(choice (repeat directory)
                 function)
  )

(defcustom company-c-headers-path-user
  '(".")
  "List of paths to search for user (i.e. double-quote delimited)
header files.  Alternatively, a function can be supplied which
returns the path list.  Note that paths in
`company-c-headers-path-system' are implicitly appended."
  :type '(choice (repeat directory)
                 function)
  )

(defvar company-c-headers-include-declaration
  (rx
   line-start
   "#" (zero-or-more blank) (or "include" "import")
   (one-or-more blank)
   (submatch
    (in "<\"")
    (zero-or-more (not (in ">\""))))
   )
  "Prefix matching C/C++/ObjC include directives.")

(defvar company-c-headers-modes
  `(
    (c-mode     . ,(rx ".h" line-end))
    (c++-mode   . ,(rx (or (: line-start (one-or-more (in "A-Za-z0-9_")))
                           (or ".h" ".hpp" ".hxx" ".hh"))
                       line-end))
    (objc-mode  . ,(rx ".h" line-end))
    )
  "Assoc list of supported major modes and associated header file names.")

(defun call-if-function (path)
  "If PATH is bound to a function, return the result of calling it.
Otherwise just return the value."
  (if (functionp path)
      (funcall path)
    path))

(defun company-c-headers--candidates-for (prefix dir)
  "Return a list of candidates for PREFIX in directory DIR.
Filters on the appropriate regex for the current major mode."
  (let* ((delim (substring prefix 0 1))
         (fileprefix (substring prefix 1))
         (prefixdir (file-name-directory fileprefix))
         (subdir (and prefixdir (concat (file-name-as-directory dir) prefixdir)))
         (hdrs (cdr (assoc major-mode company-c-headers-modes)))
         candidates)

    ;; If we need to complete inside a subdirectory, use that
    (when (and subdir (file-directory-p subdir))
      (setq dir subdir)
      (setq fileprefix (file-name-nondirectory fileprefix))
      (setq delim (concat delim prefixdir))
      )

    ;; Using a list of completions for this directory, remove those that a) don't match the
    ;; headers regexp, and b) are not directories (except for "." and ".." which ARE removed)
    (setq candidates (cl-remove-if
                      (lambda (F) (and (not (string-match-p hdrs F))
                                       (or (cl-member (directory-file-name F) '("." "..") :test 'equal)
                                           (not (file-directory-p (concat (file-name-as-directory dir) F))))))
                      (file-name-all-completions fileprefix dir)))

    ;; We want to see candidates in alphabetical order per directory
    (setq candidates (sort candidates #'string<))

    ;; Add the delimiter and metadata
    (mapcar (lambda (C) (propertize (concat delim C) 'directory dir)) candidates)
    ))

(defun company-c-headers--candidates (prefix)
  "Return candidates for PREFIX."
  (let ((p (if (equal (aref prefix 0) ?\")
               (call-if-function company-c-headers-path-user)
             (call-if-function company-c-headers-path-system)))
        (next (when (equal (aref prefix 0) ?\")
                (call-if-function company-c-headers-path-system)))
        candidates)
    (while p
      (when (file-directory-p (car p))
        (setq candidates (append candidates (company-c-headers--candidates-for prefix (car p)))))

      (setq p (or (cdr p)
                  (let ((tmp next))
                    (setq next nil)
                    tmp)))
      )
    candidates
    ))

(defun company-c-headers--meta (candidate)
  "Return the metadata associated with CANDIDATE.  Currently just the directory."
  (get-text-property 0 'directory candidate))

(defun company-c-headers--location (candidate)
  "Return the location associated with CANDIDATE."
  (cons (concat (file-name-as-directory (get-text-property 0 'directory candidate))
                (file-name-nondirectory (substring candidate 1)))
        1))

;;;###autoload
(defun company-c-headers (command &optional arg &rest ignored)
  "Company backend for C/C++ header files."
  (interactive (list 'interactive))
  (pcase command
    (`interactive (company-begin-backend 'company-c-headers))
    (`prefix
     (when (and (assoc major-mode company-c-headers-modes)
                (looking-back company-c-headers-include-declaration (line-beginning-position)))
       (match-string-no-properties 1)))
    (`sorted t)
    (`candidates (company-c-headers--candidates arg))
    (`meta (company-c-headers--meta arg))
    (`location (company-c-headers--location arg))
    (`post-completion
     (when (looking-back company-c-headers-include-declaration (line-beginning-position))
       (let ((matched (match-string-no-properties 1)))
         ;; Add a terminating delimiter unless we've completed a directory name
         ;; If pre-existing terminating delimiter already exist, move cursor
         ;; to end of line.
         (unless (equal matched (file-name-as-directory matched))
           (pcase (aref matched 0)
             (?\" (if (looking-at "\"") (end-of-line) (insert "\"")))
             (?<  (if (looking-at ">") (end-of-line) (insert ">"))))))))
    ))

(provide 'company-c-headers)

;;; company-c-headers.el ends here