idris-ipkg-mode.el

;;; idris-ipkg-mode.el --- Major mode for editing Idris package files -*- lexical-binding: t -*-

;; Copyright (C) 2014

;; Author: David Raymond Christiansen
;; URL: https://github.com/idris-hackers/idris-mode
;; Keywords: languages
;; Package-Requires: ((emacs "24"))


;;; Commentary:

;; This is an Emacs mode for editing Idris packages. It requires the latest
;; version of Idris, and some features may rely on the latest Git version of
;; Idris.

;;; Code:
(require 'ansi-color)
(require 'compile)

(require 'idris-core)
(require 'idris-settings)
(require 'idris-common-utils)
(require 'idris-keys)

;;; Faces

(defface idris-ipkg-keyword-face
  '((t (:inherit font-lock-keyword-face)))
  "The face to highlight Idris package keywords."
  :group 'idris-faces)

(defface idris-ipkg-package-name-face
  '((t (:inherit font-lock-function-name-face)))
  "The face to highlight the name of the package."
  :group 'idris-faces)


;;; Syntax

(defconst idris-ipkg-syntax-table
  (let ((st (make-syntax-table (standard-syntax-table))))
    ;; Strings
    (modify-syntax-entry ?\" "\"" st)
    (modify-syntax-entry ?\\ "/" st)

    ;; Matching {}, but with nested comments
    (modify-syntax-entry ?\{ "(} 1bn" st)
    (modify-syntax-entry ?\} "){ 4bn" st)
    (modify-syntax-entry ?\- "_ 123" st)
    (modify-syntax-entry ?\n ">" st)

    st))

(defconst idris-ipkg-keywords
  '("package"
    "authors"
    "maintainers"
    "license"
    "brief"
    "readme"
    "homepage"
    "sourceloc"
    "bugtracker"
    "options"
    "opts"
    "sourcedir"
    "builddir"
    "outputdir"
    "prebuild"
    "postbuild"
    "preinstall"
    "postinstall"
    "preclean"
    "postclean"
    "version"
    "depends"
    "modules"
    "main"
    "executable"
    "makefile"
    "objs"
    "libs"
    "pkgs"))

(defconst idris-ipkg-font-lock-defaults
  `(,idris-ipkg-keywords))


;;; Completion

(defun idris-ipkg-find-keyword ()
  (let ((start nil)
        (end (point))
        (failure (list nil nil nil)))
    (if (idris-is-ident-char-p (char-before))
        (progn
          (save-excursion
            (while (idris-is-ident-char-p (char-before))
              (backward-char))
            (setq start (point)))
          (if start
              (list (buffer-substring-no-properties start end)
                    start
                    end)
            failure))
      failure)))

(defun idris-ipkg-complete-keyword ()
  "Complete the current .ipkg keyword, if possible."
  (interactive)
  (cl-destructuring-bind (identifier start end) (idris-ipkg-find-keyword)
    (when identifier
      (list start end idris-ipkg-keywords))))

;;; Inserting fields
(defun idris-ipkg-insert-field ()
  "Insert one of the ipkg fields."
  (interactive)
  (let ((field (completing-read "Field: " (remove "package" idris-ipkg-keywords) nil t)))
    (beginning-of-line)
    (while (and (not (looking-at-p "^\\s-*$")) (= (forward-line) 0)))
    (beginning-of-line)
    (when (not (looking-at-p "^\\s-*$")) ;; end of buffer had stuff
      (goto-char (point-max))
      (newline))
    (newline)
    (insert field " = ")
    (let ((p (point)))
      (newline)
      (goto-char p))))

;;; Clickable modules

(defun idris-ipkg-make-files-clickable ()
  "Make all modules with existing files clickable, where clicking opens them."
  (interactive)
  (idris-clear-file-link-overlays 'idris-ipkg-mode)
  (let ((src-dir (idris-ipkg-buffer-src-dir (file-name-directory (buffer-file-name)))))
    ;; Make the sourcedir clickable
    (save-excursion
      (goto-char (point-min))
      (when (and (file-exists-p src-dir)
                 (file-directory-p src-dir)
                 (re-search-forward "^sourcedir\\s-*=\\s-*\\([a-zA-Z/0-9]+\\)" nil t))
        (let ((start (match-beginning 1))
              (end (match-end 1))
              (map (make-sparse-keymap)))
          (define-key map [mouse-2] #'(lambda ()
                                        (interactive)
                                        (dired src-dir)))
          (idris-make-file-link-overlay start end map
                                        (concat "mouse-2: dired " src-dir)))))
    ;; Make the modules clickable
    (save-excursion
      (goto-char (point-min))
      (cl-flet ((mod-link ()
                  (re-search-forward "[a-zA-Z0-9\\.]+" nil t)
                  (let ((beg (match-beginning 0))
                        (end (match-end 0)))
                    (idris-make-module-link beg end src-dir))))
        (when (re-search-forward "^modules\\s-*=\\s-*" nil t)
          (cl-loop initially (mod-link)
                   while (looking-at-p "\\s-*,\\s-*")
                   do (progn (skip-chars-forward " ,\n")
                             (mod-link))))))
    ;; Make the Makefile clickable
    (save-excursion
      (goto-char (point-min))
      (when (re-search-forward "^makefile\\s-*=\\s-*\\([a-zA-Z/0-9]+\\)" nil t)
        (let ((start (match-beginning 1))
              (end (match-end 1))
              (makefile (concat (file-name-as-directory src-dir) (match-string 1))))
        (when (file-exists-p makefile)
          (let ((map (make-sparse-keymap)))
            (define-key map [mouse-2] #'(lambda ()
                                          (interactive)
                                          (find-file makefile)))
            (idris-make-file-link-overlay start end map  "mouse-2: edit makefile"))))))))


(defun idris-ipkg-enable-clickable-files ()
  "Enable setting up clickable modules and makefiles on idle Emacs."
  (interactive)
  (add-hook 'after-save-hook 'idris-ipkg-make-files-clickable)
  (idris-ipkg-make-files-clickable))

;;; finding ipkg files

;; Based on http://www.emacswiki.org/emacs/EmacsTags section "Finding tags files"
;; That page is GPL, so this is OK to include
(defun idris-find-file-upwards (suffix &optional allow-hidden)
  "Recursively searches each parent directory starting from the
directory of the current buffer filename or from
`default-directory' if that's not found, looking for a file with
name ending in SUFFIX.  Returns the paths to the matching files,
or nil if not found."
  (cl-labels
      ((find-file-r (path)
                    (let* ((parent (file-name-directory path))
                           (matching (if parent
                                         (idris-try-directory-files parent t (concat "\\\." suffix "$"))
                                       nil)))
                      (cond
                       (matching matching)
                       ;; The parent of ~ is nil and the parent of / is itself.
                       ;; Thus the terminating condition for not finding the file
                       ;; accounts for both.
                       ((or (null parent) (equal parent (directory-file-name parent))) nil) ; Not found
                       (t (find-file-r (directory-file-name parent))))))) ; Continue
    (let* ((file (buffer-file-name (current-buffer)))
           (dir (if file (file-name-directory file) default-directory)))
      (when dir
        (cl-remove-if #'(lambda (f)
                          (and (not allow-hidden)
                               (string-prefix-p "." (file-name-nondirectory f))))
                      (find-file-r dir))))))

(defun idris-try-directory-files (directory &optional full match nosort)
  "Call `directory-files' with arguments DIRECTORY, FULL, MATCH and NOSORT.
Return the empty list on failure instead of throwing an error.

See the docstring for `directory-files' for the meaning of the
arguments."
  ;; This wrapper is useful because some users can't read all the
  ;; directories above the current working directory. In particular,
  ;; /home is sometimes not readable.
  (condition-case nil
      (directory-files directory full match nosort)
    (error nil)))

(defvar idris-ipkg-build-buffer-name "*idris-build*")

(defun idris-ipkg--compilation-buffer-name-function (_mode)
  "Compute a buffer name for the `idris-mode' compilation buffer."
  idris-ipkg-build-buffer-name)

(defun idris-ipkg--ansi-compile-filter (start)
  "Apply ANSI formatting to the region of the buffer from START to point."
  (save-excursion
    (let ((buffer-read-only nil))
      (ansi-color-apply-on-region start (point)))))

(defun idris-ipkg-command (ipkg-file command)
  "Run a command on IPKG-FILE. The COMMAND can be build, install, or clean."
  ;; Idris must have its working directory in the same place as the ipkg file
  (let ((dir (file-name-directory ipkg-file))
        (file (file-name-nondirectory ipkg-file))
        (opt (cond ((equal command 'build) "--build")
                   ((equal command 'install) "--install")
                   ((equal command 'clean) "--clean")
                   (t (error "Invalid command name %s" command)))))
    (unless dir
      (error "Unable to determine directory for filename '%s'" ipkg-file))
    (let* ((default-directory dir) ; default-directory is a special variable - this starts idris in dir
           (compilation-buffer-name-function
            'idris-ipkg--compilation-buffer-name-function)
           (command (concat idris-interpreter-path " " opt " " file))
           (compilation-filter-hook
            (cons 'idris-ipkg--ansi-compile-filter compilation-filter-hook)))
      (compile command))))

(defun idris-ipkg-build (ipkg-file)
  (interactive (list
                (let ((ipkg-default (idris-find-file-upwards "ipkg")))
                  (if ipkg-default
                      (read-file-name "Package file to build: "
                                      (file-name-directory (car ipkg-default))
                                      (car ipkg-default)
                                      t
                                      (file-name-nondirectory (car ipkg-default)))
                    (read-file-name "Package file to build: " nil nil nil t)))))
  (idris-ipkg-command ipkg-file 'build))

(defun idris-ipkg-install (ipkg-file)
  (interactive (list
                (let ((ipkg-default (idris-find-file-upwards "ipkg")))
                  (if ipkg-default
                      (read-file-name "Package file to install: "
                                      (file-name-directory (car ipkg-default))
                                      (car ipkg-default)
                                      t
                                      (file-name-nondirectory (car ipkg-default)))
                    (read-file-name "Package file to install: " nil nil nil t)))))
  (idris-ipkg-command ipkg-file 'install))

(defun idris-ipkg-clean (ipkg-file)
  (interactive (list
                (let ((ipkg-default (idris-find-file-upwards "ipkg")))
                  (if ipkg-default
                      (read-file-name "Package file to clean: "
                                      (file-name-directory (car ipkg-default))
                                      (car ipkg-default)
                                      t
                                      (file-name-nondirectory (car ipkg-default)))
                    (read-file-name "Package file to clean: " nil nil nil t)))))
  (idris-ipkg-command ipkg-file 'clean))

(defun idris-ipkg-build-quit ()
  (interactive)
  (idris-kill-buffer idris-ipkg-build-buffer-name))

(defun idris-ipkg-buffer-src-dir (basename)
  (save-excursion
    (goto-char (point-min))
    (let ((found
           (re-search-forward "^\\s-*sourcedir\\s-*=\\s-*\\(\\sw+\\)"
                              nil
                              t)))
      (if found
          (let ((subdir (buffer-substring-no-properties (match-beginning 1) (match-end 1))))
            (concat (file-name-directory basename) subdir))
        (file-name-directory basename)))))

(defun idris-ipkg-find-src-dir (&optional ipkg-file)
  (let ((found (or (and ipkg-file (list ipkg-file))
                   (idris-find-file-upwards "ipkg"))))
    (if (not found)
        nil
      (setq ipkg-file (car found))
      ;; Now ipkg-file contains the path to the package
      (with-temp-buffer
        (insert-file-contents ipkg-file)
        (idris-ipkg-buffer-src-dir ipkg-file)))))

(defun idris-ipkg-buffer-cmdline-opts ()
  (save-excursion
    (goto-char (point-min))
    (let ((found
           (re-search-forward "^\\s-*opts\\s-*=\\s-*\"\\([^\"]*\\)\""
                              nil
                              t)))
      (if found
          (buffer-substring-no-properties (match-beginning 1) (match-end 1))
        ""))))

(defun idris-ipkg-find-cmdline-opts (&optional ipkg-file)
  (let ((found (or (and ipkg-file (list ipkg-file))
                   (idris-find-file-upwards "ipkg"))))
    (if (not found)
        nil
      (setq ipkg-file (car found))
      ;; Now ipkg-file contains the path to the package
      (with-temp-buffer
        (insert-file-contents ipkg-file)
        (idris-ipkg-buffer-cmdline-opts)))))

(defun idris-ipkg-flags-for-current-buffer ()
  "Extract the command line options field from the current .ipkg buffer."
  (let ((opts (idris-ipkg-find-cmdline-opts)))
    (if (stringp opts)
        (split-string opts nil t)
      nil)))

(defun idris-ipkg-pkgs-for-current-buffer ()
  "Find the explicit list of packages for the current .ipkg buffer."
  (let ((file (idris-find-file-upwards "ipkg")))
    (when file
      (with-temp-buffer
        (let ((pkgs nil))
          (cl-flet
              ((get-pkg ()
                        (re-search-forward "[a-zA-Z0-9\\._-]+" nil t)
                        (let ((beg (match-beginning 0))
                              (end (match-end 0)))
                          (push (buffer-substring-no-properties beg end) pkgs))))
            (insert-file-contents (car file))
            (goto-char (point-min))
            (when (re-search-forward "^\\s-*pkgs\\s-*=\\s-*" nil t)
              (cl-loop initially (get-pkg)
                       while (looking-at-p "\\s-*,\\s-*")
                       do (progn (skip-chars-forward " ,\n")
                                 (get-pkg)))))
          pkgs)))))

(defun idris-ipkg-pkgs-flags-for-current-buffer ()
  "List of Idris command line options based on the pkgs field of the .ipkg file."
  (let ((pkgs (idris-ipkg-pkgs-for-current-buffer)))
    (cl-loop for pkg in pkgs appending (list "-p" pkg))))

(add-to-list 'idris-command-line-option-functions 'idris-ipkg-flags-for-current-buffer)
(add-to-list 'idris-command-line-option-functions 'idris-ipkg-pkgs-flags-for-current-buffer)

;;; Settings

(defgroup idris-ipkg nil "Idris package mode" :prefix 'idris-ipkg :group 'idris)

(defcustom idris-ipkg-mode-hook '(idris-ipkg-enable-clickable-files)
  "Hook to run when setting up the mode for editing Idris packages."
  :type 'hook
  :options '(idris-ipkg-enable-clickable-files)
  :group 'idris-ipkg)

;;; Mode definition

(defvar idris-ipkg-mode-map (let ((map (make-sparse-keymap)))
                              (cl-loop for keyer
                                       in '(idris-define-ipkg-keys
                                            idris-define-ipkg-editing-keys)
                                       do (funcall keyer map))
                              map)
  "Keymap used for Idris package mode.")

(easy-menu-define idris-ipkg-mode-menu idris-ipkg-mode-map
  "Menu for Idris package mode."
  `("IPkg"
    ["Build package" idris-ipkg-build t]
    ["Install package" idris-ipkg-install t]
    ["Clean package" idris-ipkg-clean t]
    "----------------"
    ["Insert field" idris-ipkg-insert-field t]))

;;;###autoload
(define-derived-mode idris-ipkg-mode prog-mode "Idris Pkg"
  "Major mode for Idris package files.
\\{idris-ipkg-mode-map}
Invokes `idris-ipkg-mode-hook'."
  :group 'idris
  :syntax-table idris-ipkg-syntax-table
  (set (make-local-variable 'font-lock-defaults)
       idris-ipkg-font-lock-defaults)
  (set (make-local-variable 'completion-at-point-functions)
       '(idris-ipkg-complete-keyword)))

;; Make filenames clickable
(add-to-list 'compilation-error-regexp-alist-alist
             `(idris-type-checking
               "Type checking \\(.+\\)$" 1 nil nil 0 1))

(cl-pushnew 'idris-type-checking compilation-error-regexp-alist)

(push '("\\.ipkg$" . idris-ipkg-mode) auto-mode-alist)

(provide 'idris-ipkg-mode)

;;; idris-ipkg-mode.el ends here