Taylor Bockman
9 years ago
185 changed files with 83153 additions and 4 deletions
@ -0,0 +1 @@
|
||||
(define-package "ag" "20150814.1655" "A front-end for ag ('the silver searcher'), the C ack replacement." '((dash "2.8.0") (s "1.9.0") (cl-lib "0.5"))) |
||||
@ -0,0 +1,617 @@
|
||||
;;; ag.el --- A front-end for ag ('the silver searcher'), the C ack replacement. |
||||
|
||||
;; Copyright (C) 2013-2014 Wilfred Hughes <me@wilfred.me.uk> |
||||
;; |
||||
;; Author: Wilfred Hughes <me@wilfred.me.uk> |
||||
;; Created: 11 January 2013 |
||||
;; Version: 0.47 |
||||
;; Package-Version: 20150814.1655 |
||||
;; Package-Requires: ((dash "2.8.0") (s "1.9.0") (cl-lib "0.5")) |
||||
;;; Commentary: |
||||
|
||||
;; Please see README.md for documentation, or read it online at |
||||
;; https://github.com/Wilfred/ag.el/#agel |
||||
|
||||
;;; 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: |
||||
(eval-when-compile (require 'cl)) ;; dolist, defun*, flet |
||||
(require 'cl-lib) ;; cl-letf |
||||
(require 'dired) ;; dired-sort-inhibit |
||||
(require 'dash) |
||||
(require 's) |
||||
(require 'find-dired) ;; find-dired-filter |
||||
|
||||
(defcustom ag-executable |
||||
"ag" |
||||
"Name of the ag executable to use." |
||||
:type 'string |
||||
:group 'ag) |
||||
|
||||
(defcustom ag-arguments |
||||
(list "--line-number" "--smart-case" "--nogroup" "--column" "--stats" "--") |
||||
"Default arguments passed to ag. |
||||
|
||||
Ag.el requires --nogroup and --column, so we recommend you add any |
||||
additional arguments to the start of this list. |
||||
|
||||
--line-number is required on Window, as otherwise ag will not |
||||
print line numbers when the input is a stream." |
||||
:type '(repeat (string)) |
||||
:group 'ag) |
||||
|
||||
(defcustom ag-highlight-search nil |
||||
"Non-nil means we highlight the current search term in results. |
||||
|
||||
This requires the ag command to support --color-match, which is only in v0.14+" |
||||
:type 'boolean |
||||
:group 'ag) |
||||
|
||||
(defcustom ag-reuse-buffers nil |
||||
"Non-nil means we reuse the existing search results buffer or |
||||
dired results buffer, rather than creating one buffer per unique |
||||
search." |
||||
:type 'boolean |
||||
:group 'ag) |
||||
|
||||
(defcustom ag-reuse-window nil |
||||
"Non-nil means we open search results in the same window, |
||||
hiding the results buffer." |
||||
:type 'boolean |
||||
:group 'ag) |
||||
|
||||
(defcustom ag-project-root-function nil |
||||
"A function to determine the project root for `ag-project'. |
||||
|
||||
If set to a function, call this function with the name of the |
||||
file or directory for which to determine the project root |
||||
directory. |
||||
|
||||
If set to nil, fall back to finding VCS root directories." |
||||
:type '(choice (const :tag "Default (VCS root)" nil) |
||||
(function :tag "Function")) |
||||
:group 'ag) |
||||
|
||||
(defcustom ag-ignore-list nil |
||||
"A list of patterns to ignore when searching." |
||||
:type '(repeat (string)) |
||||
:group 'ag) |
||||
|
||||
(require 'compile) |
||||
|
||||
;; Although ag results aren't exactly errors, we treat them as errors |
||||
;; so `next-error' and `previous-error' work. However, we ensure our |
||||
;; face inherits from `compilation-info-face' so the results are |
||||
;; styled appropriately. |
||||
(defface ag-hit-face '((t :inherit compilation-info)) |
||||
"Face name to use for ag matches." |
||||
:group 'ag) |
||||
|
||||
(defface ag-match-face '((t :inherit match)) |
||||
"Face name to use for ag matches." |
||||
:group 'ag) |
||||
|
||||
(defvar ag-search-finished-hook nil |
||||
"Hook run when ag completes a search in a buffer.") |
||||
|
||||
(defun ag/run-finished-hook (buffer how-finished) |
||||
"Run the ag hook to signal that the search has completed." |
||||
(with-current-buffer buffer |
||||
(run-hooks 'ag-search-finished-hook))) |
||||
|
||||
(defmacro ag/with-patch-function (fun-name fun-args fun-body &rest body) |
||||
"Temporarily override the definition of FUN-NAME whilst BODY is executed. |
||||
|
||||
Assumes FUNCTION is already defined (see http://emacs.stackexchange.com/a/3452/304)." |
||||
`(cl-letf (((symbol-function ,fun-name) |
||||
(lambda ,fun-args ,fun-body))) |
||||
,@body)) |
||||
|
||||
(defun ag/next-error-function (n &optional reset) |
||||
"Open the search result at point in the current window or a |
||||
different window, according to `ag-reuse-window'." |
||||
(if ag-reuse-window |
||||
;; prevent changing the window |
||||
(ag/with-patch-function |
||||
'pop-to-buffer (buffer &rest args) (switch-to-buffer buffer) |
||||
(compilation-next-error-function n reset)) |
||||
|
||||
;; just navigate to the results as normal |
||||
(compilation-next-error-function n reset))) |
||||
|
||||
;; Note that we want to use as tight a regexp as we can to try and |
||||
;; handle weird file names (with colons in them) as well as possible. |
||||
;; E.g. we use [1-9][0-9]* rather than [0-9]+ so as to accept ":034:" |
||||
;; in file names. |
||||
(defvar ag/file-column-pattern |
||||
"^\\(.+?\\):\\([1-9][0-9]*\\):\\([1-9][0-9]*\\):" |
||||
"A regexp pattern that groups output into filename, line number and column number.") |
||||
|
||||
(define-compilation-mode ag-mode "Ag" |
||||
"Ag results compilation mode" |
||||
(set (make-local-variable 'compilation-error-regexp-alist) |
||||
(list 'compilation-ag-nogroup)) |
||||
(set (make-local-variable 'compilation-error-regexp-alist-alist) |
||||
(list (cons 'compilation-ag-nogroup (list ag/file-column-pattern 1 2 3)))) |
||||
(set (make-local-variable 'compilation-error-face) 'ag-hit-face) |
||||
(set (make-local-variable 'next-error-function) #'ag/next-error-function) |
||||
(set (make-local-variable 'compilation-finish-functions) |
||||
#'ag/run-finished-hook) |
||||
(add-hook 'compilation-filter-hook 'ag-filter nil t)) |
||||
|
||||
(define-key ag-mode-map (kbd "p") #'compilation-previous-error) |
||||
(define-key ag-mode-map (kbd "n") #'compilation-next-error) |
||||
(define-key ag-mode-map (kbd "k") '(lambda () (interactive) |
||||
(let (kill-buffer-query-functions) (kill-buffer)))) |
||||
|
||||
(defun ag/buffer-name (search-string directory regexp) |
||||
"Return a buffer name formatted according to ag.el conventions." |
||||
(cond |
||||
(ag-reuse-buffers "*ag search*") |
||||
(regexp (format "*ag search regexp:%s dir:%s*" search-string directory)) |
||||
(:else (format "*ag search text:%s dir:%s*" search-string directory)))) |
||||
|
||||
(defun ag/format-ignore (ignores) |
||||
"Prepend '--ignore' to every item in IGNORES." |
||||
(apply #'append |
||||
(mapcar (lambda (item) (list "--ignore" item)) ignores))) |
||||
|
||||
(defun* ag/search (string directory |
||||
&key (regexp nil) (file-regex nil) (file-type nil)) |
||||
"Run ag searching for the STRING given in DIRECTORY. |
||||
If REGEXP is non-nil, treat STRING as a regular expression." |
||||
(let ((default-directory (file-name-as-directory directory)) |
||||
(arguments ag-arguments) |
||||
(shell-command-switch "-c")) |
||||
(unless regexp |
||||
(setq arguments (cons "--literal" arguments))) |
||||
(if ag-highlight-search |
||||
(setq arguments (append '("--color" "--color-match" "30;43") arguments)) |
||||
(setq arguments (append '("--nocolor") arguments))) |
||||
(when (char-or-string-p file-regex) |
||||
(setq arguments (append `("--file-search-regex" ,file-regex) arguments))) |
||||
(when file-type |
||||
(setq arguments (cons (format "--%s" file-type) arguments))) |
||||
(when ag-ignore-list |
||||
(setq arguments (append (ag/format-ignore ag-ignore-list) arguments))) |
||||
(unless (file-exists-p default-directory) |
||||
(error "No such directory %s" default-directory)) |
||||
(let ((command-string |
||||
(mapconcat #'shell-quote-argument |
||||
(append (list ag-executable) arguments (list string ".")) |
||||
" "))) |
||||
;; If we're called with a prefix, let the user modify the command before |
||||
;; running it. Typically this means they want to pass additional arguments. |
||||
(when current-prefix-arg |
||||
;; Make a space in the command-string for the user to enter more arguments. |
||||
(setq command-string (ag/replace-first command-string " -- " " -- ")) |
||||
;; Prompt for the command. |
||||
(let ((adjusted-point (- (length command-string) (length string) 5))) |
||||
(setq command-string |
||||
(read-from-minibuffer "ag command: " |
||||
(cons command-string adjusted-point))))) |
||||
;; Call ag. |
||||
(compilation-start |
||||
command-string |
||||
#'ag-mode |
||||
`(lambda (mode-name) ,(ag/buffer-name string directory regexp)))))) |
||||
|
||||
(defun ag/dwim-at-point () |
||||
"If there's an active selection, return that. |
||||
Otherwise, get the symbol at point, as a string." |
||||
(cond ((use-region-p) |
||||
(buffer-substring-no-properties (region-beginning) (region-end))) |
||||
((symbol-at-point) |
||||
(substring-no-properties |
||||
(symbol-name (symbol-at-point)))))) |
||||
|
||||
(defun ag/buffer-extension-regex () |
||||
"If the current buffer has an extension, return |
||||
a PCRE pattern that matches files with that extension. |
||||
Returns an empty string otherwise." |
||||
(let ((file-name (buffer-file-name))) |
||||
(if (stringp file-name) |
||||
(format "\\.%s$" (ag/escape-pcre (file-name-extension file-name))) |
||||
""))) |
||||
|
||||
(defun ag/longest-string (&rest strings) |
||||
"Given a list of strings and nils, return the longest string." |
||||
(let ((longest-string nil)) |
||||
(dolist (string strings) |
||||
(cond ((null longest-string) |
||||
(setq longest-string string)) |
||||
((stringp string) |
||||
(when (< (length longest-string) |
||||
(length string)) |
||||
(setq longest-string string))))) |
||||
longest-string)) |
||||
|
||||
(defun ag/replace-first (string before after) |
||||
"Replace the first occurrence of BEFORE in STRING with AFTER." |
||||
(replace-regexp-in-string |
||||
(concat "\\(" (regexp-quote before) "\\)" ".*\\'") |
||||
after string |
||||
nil nil 1)) |
||||
|
||||
(autoload 'vc-git-root "vc-git") |
||||
|
||||
(require 'vc-svn) |
||||
;; Emacs 23.4 doesn't provide vc-svn-root. |
||||
(unless (functionp 'vc-svn-root) |
||||
(defun vc-svn-root (file) |
||||
(vc-find-root file vc-svn-admin-directory))) |
||||
|
||||
(autoload 'vc-hg-root "vc-hg") |
||||
|
||||
(defun ag/project-root (file-path) |
||||
"Guess the project root of the given FILE-PATH. |
||||
|
||||
Use `ag-project-root-function' if set, or fall back to VCS |
||||
roots." |
||||
(if ag-project-root-function |
||||
(funcall ag-project-root-function file-path) |
||||
(or (ag/longest-string |
||||
(vc-git-root file-path) |
||||
(vc-svn-root file-path) |
||||
(vc-hg-root file-path)) |
||||
file-path))) |
||||
|
||||
(defun ag/dired-align-size-column () |
||||
(beginning-of-line) |
||||
(when (looking-at "^ ") |
||||
(forward-char 2) |
||||
(search-forward " " nil t 4) |
||||
(let* ((size-start (point)) |
||||
(size-end (search-forward " " nil t)) |
||||
(width (and size-end (- size-end size-start)))) |
||||
(when (and size-end |
||||
(< width 12) |
||||
(> width 1)) |
||||
(goto-char size-start) |
||||
(insert (make-string (- 12 width) ? )))))) |
||||
|
||||
(defun ag/dired-filter (proc string) |
||||
"Filter the output of ag to make it suitable for `dired-mode'." |
||||
(let ((buf (process-buffer proc)) |
||||
(inhibit-read-only t)) |
||||
(if (buffer-name buf) |
||||
(with-current-buffer buf |
||||
(save-excursion |
||||
(save-restriction |
||||
(widen) |
||||
(let ((beg (point-max))) |
||||
(goto-char beg) |
||||
(insert string) |
||||
(goto-char beg) |
||||
(or (looking-at "^") |
||||
(progn |
||||
(ag/dired-align-size-column) |
||||
(forward-line 1))) |
||||
(while (looking-at "^") |
||||
(insert " ") |
||||
(ag/dired-align-size-column) |
||||
(forward-line 1)) |
||||
(goto-char beg) |
||||
(beginning-of-line) |
||||
|
||||
;; Remove occurrences of default-directory. |
||||
(while (search-forward (concat " " default-directory) nil t) |
||||
(replace-match " " nil t)) |
||||
|
||||
(goto-char (point-max)) |
||||
(if (search-backward "\n" (process-mark proc) t) |
||||
(progn |
||||
(dired-insert-set-properties (process-mark proc) |
||||
(1+ (point))) |
||||
(move-marker (process-mark proc) (1+ (point))))))))) |
||||
(delete-process proc)))) |
||||
|
||||
(defun ag/dired-sentinel (proc state) |
||||
"Update the status/modeline after the process finishes." |
||||
(let ((buf (process-buffer proc)) |
||||
(inhibit-read-only t)) |
||||
(if (buffer-name buf) |
||||
(with-current-buffer buf |
||||
(let ((buffer-read-only nil)) |
||||
(save-excursion |
||||
(goto-char (point-max)) |
||||
(insert "\n ag " state) |
||||
(forward-char -1) ;Back up before \n at end of STATE. |
||||
(insert " at " (substring (current-time-string) 0 19)) |
||||
(forward-char 1) |
||||
(setq mode-line-process |
||||
(concat ":" (symbol-name (process-status proc)))) |
||||
;; Since the buffer and mode line will show that the |
||||
;; process is dead, we can delete it now. Otherwise it |
||||
;; will stay around until M-x list-processes. |
||||
(delete-process proc) |
||||
(force-mode-line-update))) |
||||
(run-hooks 'dired-after-readin-hook) |
||||
(message "%s finished." (current-buffer)))))) |
||||
|
||||
(defun ag/kill-process () |
||||
"Kill the `ag' process running in the current buffer." |
||||
(interactive) |
||||
(let ((ag (get-buffer-process (current-buffer)))) |
||||
(and ag (eq (process-status ag) 'run) |
||||
(eq (process-filter ag) (function find-dired-filter)) |
||||
(condition-case nil |
||||
(delete-process ag) |
||||
(error nil))))) |
||||
|
||||
(defun ag/escape-pcre (regexp) |
||||
"Escape the PCRE-special characters in REGEXP so that it is |
||||
matched literally." |
||||
(let ((alphanum "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789")) |
||||
(apply #'concat |
||||
(mapcar |
||||
(lambda (c) |
||||
(cond |
||||
((not (string-match-p (regexp-quote c) alphanum)) |
||||
(concat "\\" c)) |
||||
(t c))) |
||||
(mapcar #'char-to-string (string-to-list regexp)))))) |
||||
|
||||
;;;###autoload |
||||
(defun ag (string directory) |
||||
"Search using ag in a given DIRECTORY for a given search STRING, |
||||
with STRING defaulting to the symbol under point. |
||||
|
||||
If called with a prefix, prompts for flags to pass to ag." |
||||
(interactive (list (ag/read-from-minibuffer "Search string") |
||||
(read-directory-name "Directory: "))) |
||||
(ag/search string directory)) |
||||
|
||||
;;;###autoload |
||||
(defun ag-files (string file-type directory) |
||||
"Search using ag in a given DIRECTORY for a given search STRING, |
||||
limited to files that match FILE-TYPE. STRING defaults to |
||||
the symbol under point. |
||||
|
||||
If called with a prefix, prompts for flags to pass to ag." |
||||
(interactive (list (ag/read-from-minibuffer "Search string") |
||||
(ag/read-file-type) |
||||
(read-directory-name "Directory: "))) |
||||
(apply #'ag/search string directory file-type)) |
||||
|
||||
;;;###autoload |
||||
(defun ag-regexp (string directory) |
||||
"Search using ag in a given directory for a given regexp. |
||||
The regexp should be in PCRE syntax, not Emacs regexp syntax. |
||||
|
||||
If called with a prefix, prompts for flags to pass to ag." |
||||
(interactive "sSearch regexp: \nDDirectory: ") |
||||
(ag/search string directory :regexp t)) |
||||
|
||||
;;;###autoload |
||||
(defun ag-project (string) |
||||
"Guess the root of the current project and search it with ag |
||||
for the given string. |
||||
|
||||
If called with a prefix, prompts for flags to pass to ag." |
||||
(interactive (list (ag/read-from-minibuffer "Search string"))) |
||||
(ag/search string (ag/project-root default-directory))) |
||||
|
||||
;;;###autoload |
||||
(defun ag-project-files (string file-type) |
||||
"Search using ag for a given search STRING, |
||||
limited to files that match FILE-TYPE. STRING defaults to the |
||||
symbol under point. |
||||
|
||||
If called with a prefix, prompts for flags to pass to ag." |
||||
(interactive (list (ag/read-from-minibuffer "Search string") |
||||
(ag/read-file-type))) |
||||
(apply 'ag/search string (ag/project-root default-directory) file-type)) |
||||
|
||||
(defun ag/read-from-minibuffer (prompt) |
||||
"Read a value from the minibuffer with PROMPT. |
||||
If there's a string at point, offer that as a default." |
||||
(let* ((suggested (ag/dwim-at-point)) |
||||
(final-prompt |
||||
(if suggested |
||||
(format "%s (default %s): " prompt suggested) |
||||
(format "%s: " prompt))) |
||||
;; Ask the user for input, but add `suggested' to the history |
||||
;; so they can use M-n if they want to modify it. |
||||
(user-input (read-from-minibuffer |
||||
final-prompt |
||||
nil nil nil nil suggested))) |
||||
;; Return the input provided by the user, or use `suggested' if |
||||
;; the input was empty. |
||||
(if (> (length user-input) 0) |
||||
user-input |
||||
suggested))) |
||||
|
||||
;;;###autoload |
||||
(defun ag-project-regexp (regexp) |
||||
"Guess the root of the current project and search it with ag |
||||
for the given regexp. The regexp should be in PCRE syntax, not |
||||
Emacs regexp syntax. |
||||
|
||||
If called with a prefix, prompts for flags to pass to ag." |
||||
(interactive (list (ag/read-from-minibuffer "Search regexp"))) |
||||
(ag/search regexp (ag/project-root default-directory) :regexp t)) |
||||
|
||||
(autoload 'symbol-at-point "thingatpt") |
||||
|
||||
;;;###autoload |
||||
(defalias 'ag-project-at-point 'ag-project) |
||||
(make-obsolete 'ag-project-at-point 'ag-project "0.19") |
||||
|
||||
;;;###autoload |
||||
(defalias 'ag-regexp-project-at-point 'ag-project-regexp) |
||||
(make-obsolete 'ag-regexp-project-at-point 'ag-project-regexp "0.46") |
||||
|
||||
;;;###autoload |
||||
(defun ag-dired (dir pattern) |
||||
"Recursively find files in DIR matching PATTERN. |
||||
|
||||
The PATTERN is matched against the full path to the file, not |
||||
only against the file name. |
||||
|
||||
The results are presented as a `dired-mode' buffer with |
||||
`default-directory' being DIR. |
||||
|
||||
See also `ag-dired-regexp'." |
||||
(interactive "DDirectory: \nsFile pattern: ") |
||||
(ag-dired-regexp dir (ag/escape-pcre pattern))) |
||||
|
||||
;;;###autoload |
||||
(defun ag-dired-regexp (dir regexp) |
||||
"Recursively find files in DIR matching REGEXP. |
||||
REGEXP should be in PCRE syntax, not Emacs regexp syntax. |
||||
|
||||
The REGEXP is matched against the full path to the file, not |
||||
only against the file name. |
||||
|
||||
Results are presented as a `dired-mode' buffer with |
||||
`default-directory' being DIR. |
||||
|
||||
See also `find-dired'." |
||||
(interactive "DDirectory: \nsFile regexp: ") |
||||
(let* ((dired-buffers dired-buffers) ;; do not mess with regular dired buffers |
||||
(orig-dir dir) |
||||
(dir (file-name-as-directory (expand-file-name dir))) |
||||
(buffer-name (if ag-reuse-buffers |
||||
"*ag dired*" |
||||
(format "*ag dired pattern:%s dir:%s*" regexp dir))) |
||||
(cmd (concat ag-executable " --nocolor -g '" regexp "' " |
||||
(shell-quote-argument dir) |
||||
" | grep -v '^$' | sed s/\\'/\\\\\\\\\\'/ | xargs -I '{}' ls " |
||||
dired-listing-switches " '{}' &"))) |
||||
(with-current-buffer (get-buffer-create buffer-name) |
||||
(switch-to-buffer (current-buffer)) |
||||
(widen) |
||||
(kill-all-local-variables) |
||||
(if (fboundp 'read-only-mode) |
||||
(read-only-mode -1) |
||||
(setq buffer-read-only nil)) |
||||
(let ((inhibit-read-only t)) (erase-buffer)) |
||||
(setq default-directory dir) |
||||
(run-hooks 'dired-before-readin-hook) |
||||
(shell-command cmd (current-buffer)) |
||||
(insert " " dir ":\n") |
||||
(insert " " cmd "\n") |
||||
(dired-mode dir) |
||||
(let ((map (make-sparse-keymap))) |
||||
(set-keymap-parent map (current-local-map)) |
||||
(define-key map "\C-c\C-k" 'ag/kill-process) |
||||
(use-local-map map)) |
||||
(set (make-local-variable 'dired-sort-inhibit) t) |
||||
(set (make-local-variable 'revert-buffer-function) |
||||
`(lambda (ignore-auto noconfirm) |
||||
(ag-dired-regexp ,orig-dir ,regexp))) |
||||
(if (fboundp 'dired-simple-subdir-alist) |
||||
(dired-simple-subdir-alist) |
||||
(set (make-local-variable 'dired-subdir-alist) |
||||
(list (cons default-directory (point-min-marker))))) |
||||
(let ((proc (get-buffer-process (current-buffer)))) |
||||
(set-process-filter proc #'ag/dired-filter) |
||||
(set-process-sentinel proc #'ag/dired-sentinel) |
||||
;; Initialize the process marker; it is used by the filter. |
||||
(move-marker (process-mark proc) 1 (current-buffer))) |
||||
(setq mode-line-process '(":%s"))))) |
||||
|
||||
;;;###autoload |
||||
(defun ag-project-dired (pattern) |
||||
"Recursively find files in current project matching PATTERN. |
||||
|
||||
See also `ag-dired'." |
||||
(interactive "sFile pattern: ") |
||||
(ag-dired-regexp (ag/project-root default-directory) (ag/escape-pcre pattern))) |
||||
|
||||
;;;###autoload |
||||
(defun ag-project-dired-regexp (regexp) |
||||
"Recursively find files in current project matching REGEXP. |
||||
|
||||
See also `ag-dired-regexp'." |
||||
(interactive "sFile regexp: ") |
||||
(ag-dired-regexp (ag/project-root default-directory) regexp)) |
||||
|
||||
;;;###autoload |
||||
(defun ag-kill-buffers () |
||||
"Kill all `ag-mode' buffers." |
||||
(interactive) |
||||
(dolist (buffer (buffer-list)) |
||||
(when (eq (buffer-local-value 'major-mode buffer) 'ag-mode) |
||||
(kill-buffer buffer)))) |
||||
|
||||
;;;###autoload |
||||
(defun ag-kill-other-buffers () |
||||
"Kill all `ag-mode' buffers other than the current buffer." |
||||
(interactive) |
||||
(let ((current-buffer (current-buffer))) |
||||
(dolist (buffer (buffer-list)) |
||||
(when (and |
||||
(eq (buffer-local-value 'major-mode buffer) 'ag-mode) |
||||
(not (eq buffer current-buffer))) |
||||
(kill-buffer buffer))))) |
||||
|
||||
;; Taken from grep-filter, just changed the color regex. |
||||
(defun ag-filter () |
||||
"Handle match highlighting escape sequences inserted by the ag process. |
||||
This function is called from `compilation-filter-hook'." |
||||
(when ag-highlight-search |
||||
(save-excursion |
||||
(forward-line 0) |
||||
(let ((end (point)) beg) |
||||
(goto-char compilation-filter-start) |
||||
(forward-line 0) |
||||
(setq beg (point)) |
||||
;; Only operate on whole lines so we don't get caught with part of an |
||||
;; escape sequence in one chunk and the rest in another. |
||||
(when (< (point) end) |
||||
(setq end (copy-marker end)) |
||||
;; Highlight ag matches and delete marking sequences. |
||||
(while (re-search-forward "\033\\[30;43m\\(.*?\\)\033\\[[0-9]*m" end 1) |
||||
(replace-match (propertize (match-string 1) |
||||
'face nil 'font-lock-face 'ag-match-face) |
||||
t t)) |
||||
;; Delete all remaining escape sequences |
||||
(goto-char beg) |
||||
(while (re-search-forward "\033\\[[0-9;]*[mK]" end 1) |
||||
(replace-match "" t t))))))) |
||||
|
||||
(defun ag/get-supported-types () |
||||
"Query the ag executable for which file types it recognises." |
||||
(let* ((ag-output (shell-command-to-string (format "%s --list-file-types" ag-executable))) |
||||
(lines (-map #'s-trim (s-lines ag-output))) |
||||
(types (--keep (when (s-starts-with? "--" it) (s-chop-prefix "--" it )) lines)) |
||||
(extensions (--map (s-split " " it) (--filter (s-starts-with? "." it) lines)))) |
||||
(-zip types extensions))) |
||||
|
||||
(defun ag/read-file-type () |
||||
"Prompt the user for a known file type, or let them specify a PCRE regex." |
||||
(let* ((all-types-with-extensions (ag/get-supported-types)) |
||||
(all-types (mapcar 'car all-types-with-extensions)) |
||||
(file-type |
||||
(completing-read "Select file type: " |
||||
(append '("custom (provide a PCRE regex)") all-types))) |
||||
(file-type-extensions |
||||
(cdr (assoc file-type all-types-with-extensions)))) |
||||
(if file-type-extensions |
||||
(list :file-type file-type) |
||||
(list :file-regex |
||||
(read-from-minibuffer "Filenames which match PCRE: " |
||||
(ag/buffer-extension-regex)))))) |
||||
|
||||
(provide 'ag) |
||||
;;; ag.el ends here |
||||
@ -0,0 +1,777 @@
|
||||
(1 |
||||
(ace-window . |
||||
[(0 9 0) |
||||
((avy |
||||
(0 2 0))) |
||||
"Quickly switch windows." single |
||||
((:url . "https://github.com/abo-abo/ace-window") |
||||
(:keywords "window" "location"))]) |
||||
(ack . |
||||
[(1 5) |
||||
nil "interface to ack-like tools" tar |
||||
((:keywords "tools" "processes" "convenience") |
||||
(:url . "https://github.com/leoliu/ack-el"))]) |
||||
(ada-mode . |
||||
[(5 1 8) |
||||
((wisi |
||||
(1 1 1)) |
||||
(cl-lib |
||||
(0 4)) |
||||
(emacs |
||||
(24 2))) |
||||
"major-mode for editing Ada sources" tar |
||||
((:keywords "languages" "ada") |
||||
(:url . "http://stephe-leake.org/emacs/ada-mode/emacs-ada-mode.html"))]) |
||||
(ada-ref-man . |
||||
[(2012 0) |
||||
nil "Ada Reference Manual 2012" tar |
||||
((:keywords "languages" "ada") |
||||
(:url . "http://stephe-leake.org/ada/arm.html"))]) |
||||
(adaptive-wrap . |
||||
[(0 5) |
||||
nil "Smart line-wrapping with wrap-prefix" single |
||||
((:url . "http://elpa.gnu.org/packages/adaptive-wrap.html") |
||||
(:keywords))]) |
||||
(adjust-parens . |
||||
[(3 0) |
||||
nil "Indent and dedent Lisp code, automatically adjust close parens" tar |
||||
((:url . "http://elpa.gnu.org/packages/adjust-parens.html"))]) |
||||
(aggressive-indent . |
||||
[(1 4) |
||||
((emacs |
||||
(24 1)) |
||||
(cl-lib |
||||
(0 5))) |
||||
"Minor mode to aggressively keep your code always indented" single |
||||
((:url . "http://github.com/Malabarba/aggressive-indent-mode") |
||||
(:keywords "indent" "lisp" "maint" "tools"))]) |
||||
(ahungry-theme . |
||||
[(1 0 12) |
||||
((emacs |
||||
(24))) |
||||
"Ahungry color theme for Emacs. Make sure to (load-theme 'ahungry)." tar |
||||
((:keywords "ahungry" "palette" "color" "theme" "emacs" "color-theme" "deftheme") |
||||
(:url . "https://github.com/ahungry/color-theme-ahungry"))]) |
||||
(all . |
||||
[(1 0) |
||||
nil "Edit all lines matching a given regexp" single |
||||
((:url . "http://elpa.gnu.org/packages/all.html") |
||||
(:keywords "matching"))]) |
||||
(ascii-art-to-unicode . |
||||
[(1 9) |
||||
nil "a small artist adjunct" single |
||||
((:url . "http://www.gnuvola.org/software/aa2u/") |
||||
(:keywords "ascii" "unicode" "box-drawing"))]) |
||||
(auctex . |
||||
[(11 88 9) |
||||
nil "Integrated environment for *TeX*" tar |
||||
((:url . "http://www.gnu.org/software/auctex/"))]) |
||||
(aumix-mode . |
||||
[(7) |
||||
nil "run the aumix program in a buffer" single |
||||
((:url . "http://user42.tuxfamily.org/aumix-mode/index.html") |
||||
(:keywords "multimedia" "mixer" "aumix"))]) |
||||
(auto-overlays . |
||||
[(0 10 9) |
||||
nil "Automatic regexp-delimited overlays" tar |
||||
((:keywords "extensions") |
||||
(:url . "http://www.dr-qubit.org/emacs.php"))]) |
||||
(avy . |
||||
[(0 3 0) |
||||
((emacs |
||||
(24 1)) |
||||
(cl-lib |
||||
(0 5))) |
||||
"set-based completion" tar |
||||
((:keywords "point" "location") |
||||
(:url . "https://github.com/abo-abo/avy"))]) |
||||
(beacon . |
||||
[(0 2 1) |
||||
((seq |
||||
(1 9))) |
||||
"Highlight the cursor whenever the window scrolls" single |
||||
((:url . "https://github.com/Malabarba/beacon") |
||||
(:keywords "convenience"))]) |
||||
(bug-hunter . |
||||
[(1 0) |
||||
((seq |
||||
(1 3)) |
||||
(cl-lib |
||||
(0 5))) |
||||
"Hunt down errors in elisp files" single |
||||
((:url . "http://github.com/Malabarba/elisp-bug-hunter") |
||||
(:keywords "lisp"))]) |
||||
(caps-lock . |
||||
[(1 0) |
||||
nil "Caps-lock as a minor mode" single |
||||
((:url . "http://elpa.gnu.org/packages/caps-lock.html") |
||||
(:keywords))]) |
||||
(chess . |
||||
[(2 0 4) |
||||
((cl-lib |
||||
(0 5))) |
||||
"Play chess in GNU Emacs" tar |
||||
((:keywords "games") |
||||
(:url . "http://elpa.gnu.org/packages/chess.html"))]) |
||||
(cl-generic . |
||||
[(0 2) |
||||
nil "Forward cl-generic compatibility for Emacs<25" single |
||||
((:url . "http://elpa.gnu.org/packages/cl-generic.html") |
||||
(:keywords))]) |
||||
(cl-lib . |
||||
[(0 5) |
||||
nil "Properly prefixed CL functions and macros" single |
||||
((:url . "http://elpa.gnu.org/packages/cl-lib.html") |
||||
(:keywords))]) |
||||
(coffee-mode . |
||||
[(0 4 1 1) |
||||
nil "Major mode for CoffeeScript files" single |
||||
((:url . "http://github.com/defunkt/coffee-mode") |
||||
(:keywords "coffeescript" "major" "mode"))]) |
||||
(company . |
||||
[(0 8 12) |
||||
((emacs |
||||
(24 1)) |
||||
(cl-lib |
||||
(0 5))) |
||||
"Modular text completion framework" tar |
||||
((:keywords "abbrev" "convenience" "matching") |
||||
(:url . "http://company-mode.github.io/"))]) |
||||
(company-math . |
||||
[(1 0 1) |
||||
((company |
||||
(0 8 0)) |
||||
(math-symbol-lists |
||||
(1 0))) |
||||
"Completion backends for unicode math symbols and latex tags" single |
||||
((:url . "https://github.com/vspinu/company-math") |
||||
(:keywords "unicode" "symbols" "completion"))]) |
||||
(company-statistics . |
||||
[(0 2 1) |
||||
((emacs |
||||
(24 3)) |
||||
(company |
||||
(0 8 5))) |
||||
"Sort candidates using completion history" tar |
||||
((:keywords "abbrev" "convenience" "matching") |
||||
(:url . "https://github.com/company-mode/company-statistics"))]) |
||||
(context-coloring . |
||||
[(7 1 0) |
||||
((emacs |
||||
(24 3)) |
||||
(js2-mode |
||||
(20150713))) |
||||
"Highlight by scope" single |
||||
((:url . "https://github.com/jacksonrayhamilton/context-coloring") |
||||
(:keywords "convenience" "faces" "tools"))]) |
||||
(crisp . |
||||
[(1 3 4) |
||||
nil "CRiSP/Brief Emacs emulator" single |
||||
((:url . "http://elpa.gnu.org/packages/crisp.html") |
||||
(:keywords "emulations" "brief" "crisp"))]) |
||||
(csv-mode . |
||||
[(1 5) |
||||
nil "Major mode for editing comma/char separated values" single |
||||
((:url . "http://centaur.maths.qmul.ac.uk/Emacs/") |
||||
(:keywords "convenience"))]) |
||||
(darkroom . |
||||
[(0 1) |
||||
((cl-lib |
||||
(0 5))) |
||||
"Remove visual distractions and focus on writing" single |
||||
((:url . "http://elpa.gnu.org/packages/darkroom.html") |
||||
(:keywords "convenience" "emulations"))]) |
||||
(dash . |
||||
[(2 12 0) |
||||
nil "A modern list library for Emacs" tar |
||||
((:keywords "lists") |
||||
(:url . "http://elpa.gnu.org/packages/dash.html"))]) |
||||
(dbus-codegen . |
||||
[(0 1) |
||||
((cl-lib |
||||
(0 5))) |
||||
"Lisp code generation for D-Bus." single |
||||
((:url . "http://elpa.gnu.org/packages/dbus-codegen.html") |
||||
(:keywords "comm" "dbus" "convenience"))]) |
||||
(debbugs . |
||||
[(0 7) |
||||
nil "SOAP library to access debbugs servers" tar |
||||
((:keywords "comm" "hypermedia") |
||||
(:url . "http://elpa.gnu.org/packages/debbugs.html"))]) |
||||
(dict-tree . |
||||
[(0 12 8) |
||||
((trie |
||||
(0 2 5)) |
||||
(tNFA |
||||
(0 1 1)) |
||||
(heap |
||||
(0 3))) |
||||
"Dictionary data structure" single |
||||
((:url . "http://www.dr-qubit.org/emacs.php") |
||||
(:keywords "extensions" "matching" "data structures trie" "tree" "dictionary" "completion" "regexp"))]) |
||||
(diff-hl . |
||||
[(1 8 0) |
||||
((cl-lib |
||||
(0 2))) |
||||
"Highlight uncommitted changes" tar |
||||
((:keywords "vc" "diff") |
||||
(:url . "https://github.com/dgutov/diff-hl"))]) |
||||
(dismal . |
||||
[(1 5) |
||||
((cl-lib |
||||
(0))) |
||||
"Dis Mode Ain't Lotus: Spreadsheet program Emacs" tar |
||||
((:url . "http://elpa.gnu.org/packages/dismal.html"))]) |
||||
(djvu . |
||||
[(0 5) |
||||
nil "Edit and view Djvu files via djvused" single |
||||
((:url . "http://elpa.gnu.org/packages/djvu.html") |
||||
(:keywords "files" "wp"))]) |
||||
(docbook . |
||||
[(0 1) |
||||
nil "Info-like viewer for DocBook" single |
||||
((:url . "http://elpa.gnu.org/packages/docbook.html") |
||||
(:keywords "docs" "help"))]) |
||||
(dts-mode . |
||||
[(0 1 0) |
||||
nil "Major mode for Device Tree source files" single |
||||
((:url . "http://elpa.gnu.org/packages/dts-mode.html") |
||||
(:keywords "languages"))]) |
||||
(easy-kill . |
||||
[(0 9 3) |
||||
((emacs |
||||
(24)) |
||||
(cl-lib |
||||
(0 5))) |
||||
"kill & mark things easily" tar |
||||
((:keywords "killing" "convenience") |
||||
(:url . "https://github.com/leoliu/easy-kill"))]) |
||||
(ediprolog . |
||||
[(1 1) |
||||
nil "Emacs Does Interactive Prolog" single |
||||
((:url . "http://elpa.gnu.org/packages/ediprolog.html") |
||||
(:keywords "languages" "processes"))]) |
||||
(el-search . |
||||
[(0 0 3) |
||||
((emacs |
||||
(25))) |
||||
"Expression based incremental search for emacs-lisp-mode" single |
||||
((:url . "http://elpa.gnu.org/packages/el-search.html") |
||||
(:keywords "lisp"))]) |
||||
(eldoc-eval . |
||||
[(0 1) |
||||
nil "Enable eldoc support when minibuffer is in use." single |
||||
((:url . "http://elpa.gnu.org/packages/eldoc-eval.html") |
||||
(:keywords))]) |
||||
(electric-spacing . |
||||
[(5 0) |
||||
nil "Insert operators with surrounding spaces smartly" single |
||||
((:url . "http://elpa.gnu.org/packages/electric-spacing.html") |
||||
(:keywords))]) |
||||
(enwc . |
||||
[(1 0) |
||||
nil "The Emacs Network Client" tar |
||||
((:keywords "enwc" "network" "wicd" "manager" "nm") |
||||
(:url . "http://elpa.gnu.org/packages/enwc.html"))]) |
||||
(epoch-view . |
||||
[(0 0 1) |
||||
nil "Minor mode to visualize epoch timestamps" single |
||||
((:url . "http://elpa.gnu.org/packages/epoch-view.html") |
||||
(:keywords "data" "timestamp" "epoch" "unix"))]) |
||||
(ergoemacs-mode . |
||||
[(5 14 7 3) |
||||
((emacs |
||||
(24 1)) |
||||
(undo-tree |
||||
(0 6 5))) |
||||
"Emacs mode based on common modern interface and ergonomics." tar |
||||
((:keywords "convenience") |
||||
(:url . "https://github.com/ergoemacs/ergoemacs-mode"))]) |
||||
(f90-interface-browser . |
||||
[(1 1) |
||||
nil "Parse and browse f90 interfaces" single |
||||
((:url . "http://github.com/wence-/f90-iface/") |
||||
(:keywords))]) |
||||
(flylisp . |
||||
[(0 2) |
||||
((emacs |
||||
(24 1)) |
||||
(cl-lib |
||||
(0 4))) |
||||
"Color unbalanced parentheses and parentheses inconsistent with indentation" single |
||||
((:url . "http://elpa.gnu.org/packages/flylisp.html") |
||||
(:keywords))]) |
||||
(fsm . |
||||
[(0 2) |
||||
((emacs |
||||
(24 1)) |
||||
(cl-lib |
||||
(0 5))) |
||||
"state machine library" single |
||||
((:url . "http://elpa.gnu.org/packages/fsm.html") |
||||
(:keywords "extensions"))]) |
||||
(ggtags . |
||||
[(0 8 10) |
||||
((emacs |
||||
(24)) |
||||
(cl-lib |
||||
(0 5))) |
||||
"emacs frontend to GNU Global source code tagging system" single |
||||
((:url . "https://github.com/leoliu/ggtags") |
||||
(:keywords "tools" "convenience"))]) |
||||
(gnorb . |
||||
[(1 1 1) |
||||
((cl-lib |
||||
(0 5))) |
||||
"Glue code between Gnus, Org, and BBDB" tar |
||||
((:keywords "mail" "org" "gnus" "bbdb" "todo" "task") |
||||
(:url . "https://github.com/girzel/gnorb"))]) |
||||
(gnugo . |
||||
[(3 0 0) |
||||
((ascii-art-to-unicode |
||||
(1 5)) |
||||
(xpm |
||||
(1 0 1)) |
||||
(cl-lib |
||||
(0 5))) |
||||
"play GNU Go in a buffer" tar |
||||
((:keywords "games" "processes") |
||||
(:url . "http://www.gnuvola.org/software/gnugo/"))]) |
||||
(heap . |
||||
[(0 3) |
||||
nil "Heap (a.k.a. priority queue) data structure" single |
||||
((:url . "http://www.dr-qubit.org/emacs.php") |
||||
(:keywords "extensions" "data structures" "heap" "priority queue"))]) |
||||
(hydra . |
||||
[(0 13 3) |
||||
((cl-lib |
||||
(0 5))) |
||||
"Make bindings that stick around." tar |
||||
((:keywords "bindings") |
||||
(:url . "https://github.com/abo-abo/hydra"))]) |
||||
(ioccur . |
||||
[(2 4) |
||||
nil "Incremental occur" single |
||||
((:url . "http://elpa.gnu.org/packages/ioccur.html") |
||||
(:keywords))]) |
||||
(iterators . |
||||
[(0 1) |
||||
((emacs |
||||
(25))) |
||||
"Functions for working with iterators" single |
||||
((:url . "http://elpa.gnu.org/packages/iterators.html") |
||||
(:keywords "extensions" "elisp"))]) |
||||
(javaimp . |
||||
[(0 5) |
||||
nil "Add and reorder Java import statements in Maven projects" single |
||||
((:url . "http://elpa.gnu.org/packages/javaimp.html") |
||||
(:keywords "java" "maven" "programming"))]) |
||||
(jgraph-mode . |
||||
[(1 1) |
||||
((cl-lib |
||||
(0 5))) |
||||
"Major mode for Jgraph files" single |
||||
((:url . "http://elpa.gnu.org/packages/jgraph-mode.html") |
||||
(:keywords "tex" "wp"))]) |
||||
(js2-mode . |
||||
[(20150909) |
||||
((emacs |
||||
(24 1)) |
||||
(cl-lib |
||||
(0 5))) |
||||
"Improved JavaScript editing mode" tar |
||||
((:keywords "languages" "javascript") |
||||
(:url . "https://github.com/mooz/js2-mode/"))]) |
||||
(jumpc . |
||||
[(3 0) |
||||
nil "jump to previous insertion points" single |
||||
((:url . "http://elpa.gnu.org/packages/jumpc.html") |
||||
(:keywords))]) |
||||
(landmark . |
||||
[(1 0) |
||||
nil "Neural-network robot that learns landmarks" single |
||||
((:url . "http://elpa.gnu.org/packages/landmark.html") |
||||
(:keywords "games" "neural network" "adaptive search" "chemotaxis"))]) |
||||
(let-alist . |
||||
[(1 0 4) |
||||
nil "Easily let-bind values of an assoc-list by their names" single |
||||
((:url . "http://elpa.gnu.org/packages/let-alist.html") |
||||
(:keywords "extensions" "lisp"))]) |
||||
(lex . |
||||
[(1 1) |
||||
nil "Lexical analyser construction" tar |
||||
((:url . "http://elpa.gnu.org/packages/lex.html"))]) |
||||
(lmc . |
||||
[(1 3) |
||||
nil "Little Man Computer in Elisp" single |
||||
((:url . "http://elpa.gnu.org/packages/lmc.html") |
||||
(:keywords))]) |
||||
(load-dir . |
||||
[(0 0 3) |
||||
nil "Load all Emacs Lisp files in a given directory" single |
||||
((:url . "http://elpa.gnu.org/packages/load-dir.html") |
||||
(:keywords "lisp" "files" "convenience"))]) |
||||
(load-relative . |
||||
[(1 2) |
||||
nil "relative file load (within a multi-file Emacs package)" single |
||||
((:url . "http://github.com/rocky/emacs-load-relative") |
||||
(:keywords "internal"))]) |
||||
(loc-changes . |
||||
[(1 2) |
||||
nil "keep track of positions even after buffer changes" single |
||||
((:url . "http://github.com/rocky/emacs-loc-changes") |
||||
(:keywords))]) |
||||
(markchars . |
||||
[(0 2 0) |
||||
nil "Mark chars fitting certain characteristics" single |
||||
((:url . "http://elpa.gnu.org/packages/markchars.html") |
||||
(:keywords))]) |
||||
(math-symbol-lists . |
||||
[(1 0) |
||||
nil "Lists of Unicode math symbols and latex commands" single |
||||
((:url . "https://github.com/vspinu/math-symbol-lists") |
||||
(:keywords "unicode" "symbols" "mathematics"))]) |
||||
(memory-usage . |
||||
[(0 2) |
||||
nil "Analyze the memory usage of Emacs in various ways" single |
||||
((:url . "http://elpa.gnu.org/packages/memory-usage.html") |
||||
(:keywords "maint"))]) |
||||
(metar . |
||||
[(0 1) |
||||
((cl-lib |
||||
(0 5))) |
||||
"Retrieve and decode METAR weather information" single |
||||
((:url . "http://elpa.gnu.org/packages/metar.html") |
||||
(:keywords "comm"))]) |
||||
(midi-kbd . |
||||
[(0 2) |
||||
((emacs |
||||
(25))) |
||||
"Create keyboard events from Midi input" single |
||||
((:url . "http://elpa.gnu.org/packages/midi-kbd.html") |
||||
(:keywords "convenience" "hardware" "multimedia"))]) |
||||
(minibuffer-line . |
||||
[(0 1) |
||||
nil "Display status info in the minibuffer window" single |
||||
((:url . "http://elpa.gnu.org/packages/minibuffer-line.html") |
||||
(:keywords))]) |
||||
(minimap . |
||||
[(1 2) |
||||
nil "Sidebar showing a \"mini-map\" of a buffer" single |
||||
((:url . "http://elpa.gnu.org/packages/minimap.html") |
||||
(:keywords))]) |
||||
(muse . |
||||
[(3 20) |
||||
nil "Authoring and publishing tool for Emacs" tar |
||||
((:keywords "hypermedia") |
||||
(:url . "http://mwolson.org/projects/EmacsMuse.html"))]) |
||||
(nameless . |
||||
[(0 5 1) |
||||
((emacs |
||||
(24 4))) |
||||
"Hide package namespace in your emacs-lisp code" single |
||||
((:url . "https://github.com/Malabarba/nameless") |
||||
(:keywords "convenience" "lisp"))]) |
||||
(names . |
||||
[(20150723 0) |
||||
((emacs |
||||
(24 1)) |
||||
(cl-lib |
||||
(0 5))) |
||||
"Namespaces for emacs-lisp. Avoid name clobbering without hiding symbols." tar |
||||
((:keywords "extensions" "lisp") |
||||
(:url . "https://github.com/Bruce-Connor/names"))]) |
||||
(nhexl-mode . |
||||
[(0 1) |
||||
nil "Minor mode to edit files via hex-dump format" single |
||||
((:url . "http://elpa.gnu.org/packages/nhexl-mode.html") |
||||
(:keywords "data"))]) |
||||
(nlinum . |
||||
[(1 6) |
||||
nil "Show line numbers in the margin" single |
||||
((:url . "http://elpa.gnu.org/packages/nlinum.html") |
||||
(:keywords "convenience"))]) |
||||
(notes-mode . |
||||
[(1 30) |
||||
nil "Indexing system for on-line note-taking" tar |
||||
((:url . "http://elpa.gnu.org/packages/notes-mode.html"))]) |
||||
(num3-mode . |
||||
[(1 2) |
||||
nil "highlight groups of digits in long numbers" single |
||||
((:url . "http://elpa.gnu.org/packages/num3-mode.html") |
||||
(:keywords "faces" "minor-mode"))]) |
||||
(oauth2 . |
||||
[(0 10) |
||||
nil "OAuth 2.0 Authorization Protocol" single |
||||
((:url . "http://elpa.gnu.org/packages/oauth2.html") |
||||
(:keywords "comm"))]) |
||||
(omn-mode . |
||||
[(1 2) |
||||
nil "Support for OWL Manchester Notation" single |
||||
((:url . "http://elpa.gnu.org/packages/omn-mode.html") |
||||
(:keywords))]) |
||||
(org . |
||||
[(20151005) |
||||
nil "Outline-based notes management and organizer" tar nil]) |
||||
(osc . |
||||
[(0 1) |
||||
nil "Open Sound Control protocol library" single |
||||
((:url . "http://elpa.gnu.org/packages/osc.html") |
||||
(:keywords "comm" "processes" "multimedia"))]) |
||||
(other-frame-window . |
||||
[(1 0 1) |
||||
((emacs |
||||
(24 4))) |
||||
"Minor mode to enable global prefix keys for other frame/window buffer placement" single |
||||
((:url . "http://elpa.gnu.org/packages/other-frame-window.html") |
||||
(:keywords "frame" "window"))]) |
||||
(pabbrev . |
||||
[(4 2 1) |
||||
nil "Predictive abbreviation expansion" single |
||||
((:url . "http://elpa.gnu.org/packages/pabbrev.html") |
||||
(:keywords))]) |
||||
(pinentry . |
||||
[(0 1) |
||||
nil "GnuPG Pinentry server implementation" single |
||||
((:url . "http://elpa.gnu.org/packages/pinentry.html") |
||||
(:keywords "gnupg"))]) |
||||
(poker . |
||||
[(0 1) |
||||
nil "Texas hold'em poker" single |
||||
((:url . "http://elpa.gnu.org/packages/poker.html") |
||||
(:keywords "games"))]) |
||||
(quarter-plane . |
||||
[(0 1) |
||||
nil "Minor mode for quarter-plane style editing" single |
||||
((:url . "http://elpa.gnu.org/packages/quarter-plane.html") |
||||
(:keywords "convenience" "wp"))]) |
||||
(queue . |
||||
[(0 1 1) |
||||
nil "Queue data structure" single |
||||
((:url . "http://www.dr-qubit.org/emacs.php") |
||||
(:keywords "extensions" "data structures" "queue"))]) |
||||
(rainbow-mode . |
||||
[(0 12) |
||||
nil "Colorize color names in buffers" single |
||||
((:url . "http://elpa.gnu.org/packages/rainbow-mode.html") |
||||
(:keywords "faces"))]) |
||||
(register-list . |
||||
[(0 1) |
||||
nil "Interactively list/edit registers" single |
||||
((:url . "http://elpa.gnu.org/packages/register-list.html") |
||||
(:keywords "register"))]) |
||||
(rich-minority . |
||||
[(1 0) |
||||
((cl-lib |
||||
(0 5))) |
||||
"Clean-up and Beautify the list of minor-modes." single |
||||
((:url . "https://github.com/Malabarba/rich-minority") |
||||
(:keywords "mode-line" "faces"))]) |
||||
(rudel . |
||||
[(0 3) |
||||
nil "A collaborative editing framework for Emacs" tar |
||||
((:keywords "rudel" "collaboration") |
||||
(:url . "http://rudel.sourceforge.net/"))]) |
||||
(scroll-restore . |
||||
[(1 0) |
||||
nil "restore original position after scrolling" single |
||||
((:url . "http://elpa.gnu.org/packages/scroll-restore.html") |
||||
(:keywords "scrolling"))]) |
||||
(seq . |
||||
[(1 11) |
||||
nil "Sequence manipulation functions" single |
||||
((:url . "http://elpa.gnu.org/packages/seq.html") |
||||
(:keywords "sequences"))]) |
||||
(shen-mode . |
||||
[(0 1) |
||||
nil "A major mode for editing shen source code" tar |
||||
((:keywords "languages" "shen") |
||||
(:url . "http://elpa.gnu.org/packages/shen-mode.html"))]) |
||||
(sisu-mode . |
||||
[(3 0 3) |
||||
nil "Major mode for SiSU markup text" single |
||||
((:url . "http://elpa.gnu.org/packages/sisu-mode.html") |
||||
(:keywords "text" "processes" "tools"))]) |
||||
(sml-mode . |
||||
[(6 7) |
||||
nil "Major mode for editing (Standard) ML" single |
||||
((:url . "http://elpa.gnu.org/packages/sml-mode.html") |
||||
(:keywords "sml"))]) |
||||
(sokoban . |
||||
[(1 4) |
||||
nil "Implementation of Sokoban for Emacs." tar |
||||
((:keywords "games") |
||||
(:url . "http://elpa.gnu.org/packages/sokoban.html"))]) |
||||
(sotlisp . |
||||
[(1 4 1) |
||||
((emacs |
||||
(24 1))) |
||||
"Write lisp at the speed of thought." single |
||||
((:url . "https://github.com/Malabarba/speed-of-thought-lisp") |
||||
(:keywords "convenience" "lisp"))]) |
||||
(spinner . |
||||
[(1 4) |
||||
nil "Add spinners and progress-bars to the mode-line for ongoing operations" single |
||||
((:url . "https://github.com/Malabarba/spinner.el") |
||||
(:keywords "processes" "mode-line"))]) |
||||
(stream . |
||||
[(1 0) |
||||
((emacs |
||||
(25))) |
||||
"Implementation of streams" single |
||||
((:url . "http://elpa.gnu.org/packages/stream.html") |
||||
(:keywords "stream" "laziness" "sequences"))]) |
||||
(svg . |
||||
[(0 1) |
||||
((emacs |
||||
(25))) |
||||
"svg image creation functions" single |
||||
((:url . "http://elpa.gnu.org/packages/svg.html") |
||||
(:keywords "image"))]) |
||||
(svg-clock . |
||||
[(0 5) |
||||
((svg |
||||
(0 1)) |
||||
(emacs |
||||
(25 0))) |
||||
"Analog clock using Scalable Vector Graphics" single |
||||
((:url . "http://elpa.gnu.org/packages/svg-clock.html") |
||||
(:keywords "demo" "svg" "clock"))]) |
||||
(swiper . |
||||
[(0 5 1) |
||||
((emacs |
||||
(24 1))) |
||||
"Isearch with an overview. Oh, man!" tar |
||||
((:keywords "matching") |
||||
(:url . "https://github.com/abo-abo/swiper"))]) |
||||
(tNFA . |
||||
[(0 1 1) |
||||
((queue |
||||
(0 1))) |
||||
"Tagged non-deterministic finite-state automata" single |
||||
((:url . "http://www.dr-qubit.org/emacs.php") |
||||
(:keywords "extensions" "matching" "data structures tnfa" "nfa" "dfa" "finite state automata" "automata" "regexp"))]) |
||||
(temp-buffer-browse . |
||||
[(1 4) |
||||
nil "temp buffer browse mode" single |
||||
((:url . "http://elpa.gnu.org/packages/temp-buffer-browse.html") |
||||
(:keywords "convenience"))]) |
||||
(test-simple . |
||||
[(1 1) |
||||
((cl-lib |
||||
(0))) |
||||
"Simple Unit Test Framework for Emacs Lisp" single |
||||
((:url . "http://github.com/rocky/emacs-test-simple") |
||||
(:keywords "unit-test"))]) |
||||
(timerfunctions . |
||||
[(1 4 2) |
||||
((cl-lib |
||||
(0 5))) |
||||
"Enhanced versions of some timer.el functions" single |
||||
((:url . "http://elpa.gnu.org/packages/timerfunctions.html") |
||||
(:keywords))]) |
||||
(tiny . |
||||
[(0 1) |
||||
nil "Quickly generate linear ranges in Emacs" tar |
||||
((:keywords "convenience") |
||||
(:url . "https://github.com/abo-abo/tiny"))]) |
||||
(trie . |
||||
[(0 2 6) |
||||
((tNFA |
||||
(0 1 1)) |
||||
(heap |
||||
(0 3))) |
||||
"Trie data structure" single |
||||
((:url . "http://www.dr-qubit.org/emacs.php") |
||||
(:keywords "extensions" "matching" "data structures trie" "ternary search tree" "tree" "completion" "regexp"))]) |
||||
(undo-tree . |
||||
[(0 6 5) |
||||
nil "Treat undo history as a tree" single |
||||
((:url . "http://www.dr-qubit.org/emacs.php") |
||||
(:keywords "convenience" "files" "undo" "redo" "history" "tree"))]) |
||||
(uni-confusables . |
||||
[(0 1) |
||||
nil "Unicode confusables table" tar |
||||
((:url . "http://elpa.gnu.org/packages/uni-confusables.html"))]) |
||||
(vlf . |
||||
[(1 7) |
||||
nil "View Large Files" tar |
||||
((:keywords "large files" "utilities") |
||||
(:url . "https://github.com/m00natic/vlfi"))]) |
||||
(w3 . |
||||
[(4 0 49) |
||||
nil "Fully customizable, largely undocumented web browser for Emacs" tar |
||||
((:keywords "faces" "help" "comm" "news" "mail" "processes" "mouse" "hypermedia") |
||||
(:url . "http://elpa.gnu.org/packages/w3.html"))]) |
||||
(wcheck-mode . |
||||
[(2014 6 21) |
||||
nil "General interface for text checkers" single |
||||
((:url . "https://github.com/tlikonen/wcheck-mode") |
||||
(:keywords "text" "spell" "check" "languages" "ispell"))]) |
||||
(wconf . |
||||
[(0 2 0) |
||||
((emacs |
||||
(24 4))) |
||||
"Minimal window layout manager" single |
||||
((:url . "https://github.com/ilohmar/wconf") |
||||
(:keywords "windows" "frames" "layout"))]) |
||||
(web-server . |
||||
[(0 1 1) |
||||
((emacs |
||||
(24 3))) |
||||
"Emacs Web Server" tar |
||||
((:keywords "http" "server" "network") |
||||
(:url . "https://github.com/eschulte/emacs-web-server"))]) |
||||
(websocket . |
||||
[(1 5) |
||||
nil "Emacs WebSocket client and server" tar |
||||
((:keywords "communication" "websocket" "server") |
||||
(:url . "http://elpa.gnu.org/packages/websocket.html"))]) |
||||
(windresize . |
||||
[(0 1) |
||||
nil "Resize windows interactively" single |
||||
((:url . "http://elpa.gnu.org/packages/windresize.html") |
||||
(:keywords "window"))]) |
||||
(wisi . |
||||
[(1 1 1) |
||||
((cl-lib |
||||
(0 4)) |
||||
(emacs |
||||
(24 2))) |
||||
"Utilities for implementing an indentation/navigation engine using a generalized LALR parser" tar |
||||
((:keywords "parser" "indentation" "navigation") |
||||
(:url . "http://stephe-leake.org/emacs/ada-mode/emacs-ada-mode.html"))]) |
||||
(wpuzzle . |
||||
[(1 1) |
||||
nil "find as many word in a given time" single |
||||
((:url . "http://elpa.gnu.org/packages/wpuzzle.html") |
||||
(:keywords))]) |
||||
(xclip . |
||||
[(1 3) |
||||
nil "use xclip to copy&paste" single |
||||
((:url . "http://elpa.gnu.org/packages/xclip.html") |
||||
(:keywords "convenience" "tools"))]) |
||||
(xelb . |
||||
[(0 2) |
||||
((emacs |
||||
(24 4)) |
||||
(cl-generic |
||||
(0 2))) |
||||
"X protocol Emacs Lisp Binding" tar |
||||
((:keywords "unix") |
||||
(:url . "https://github.com/ch11ng/xelb"))]) |
||||
(xpm . |
||||
[(1 0 3) |
||||
nil "edit XPM images" tar |
||||
((:keywords "multimedia" "xpm") |
||||
(:url . "http://www.gnuvola.org/software/xpm/"))]) |
||||
(yasnippet . |
||||
[(0 8 0) |
||||
nil "Yet another snippet extension for Emacs." tar |
||||
((:keywords "convenience" "emulation") |
||||
(:url . "http://github.com/capitaomorte/yasnippet"))]) |
||||
(ztree . |
||||
[(1 0 2) |
||||
nil "Text mode directory tree" tar |
||||
((:keywords "files" "tools") |
||||
(:url . "https://github.com/fourier/ztree"))])) |
||||
@ -0,0 +1 @@
|
||||
Good signature from 474F05837FBDEF9B GNU ELPA Signing Agent <elpasign@elpa.gnu.org> (trust undefined) created at 2015-10-24T02:05:02-0700 using DSA |
||||
File diff suppressed because one or more lines are too long
@ -0,0 +1,130 @@
|
||||
;;; cider-apropos.el --- Apropos functionality for Clojure -*- lexical-binding: t -*- |
||||
|
||||
;; Copyright © 2014-2015 Jeff Valk, Bozhidar Batsov |
||||
;; |
||||
;; Author: Jeff Valk <jv@jeffvalk.com> |
||||
|
||||
;; This program 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 program 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 program. If not, see <http://www.gnu.org/licenses/>. |
||||
|
||||
;; This file is not part of GNU Emacs. |
||||
|
||||
;;; Commentary: |
||||
|
||||
;; Apropos functionality for Clojure. |
||||
|
||||
;;; Code: |
||||
|
||||
(require 'cider-doc) |
||||
(require 'cider-util) |
||||
(require 'cider-compat) |
||||
|
||||
(require 'cider-client) |
||||
(require 'cider-popup) |
||||
(require 'nrepl-client) |
||||
|
||||
(require 'clojure-mode) |
||||
(require 'apropos) |
||||
(require 'button) |
||||
|
||||
(defconst cider-apropos-buffer "*cider-apropos*") |
||||
|
||||
(push cider-apropos-buffer cider-ancillary-buffers) |
||||
|
||||
(defun cider-apropos-doc (button) |
||||
"Display documentation for the symbol represented at BUTTON." |
||||
(cider-doc-lookup (button-get button 'apropos-symbol))) |
||||
|
||||
(defun cider-apropos-summary (query ns docs-p include-private-p case-sensitive-p) |
||||
"Return a short description for the performed apropos search." |
||||
(concat (if case-sensitive-p "Case-sensitive " "") |
||||
(if docs-p "Documentation " "") |
||||
(format "Apropos for %S" query) |
||||
(if ns (format " in namespace %S" ns) "") |
||||
(if include-private-p |
||||
" (public and private symbols)" |
||||
" (public symbols only)"))) |
||||
|
||||
(defun cider-apropos-highlight (doc query) |
||||
"Return the DOC string propertized to highlight QUERY matches." |
||||
(let ((pos 0)) |
||||
(while (string-match query doc pos) |
||||
(setq pos (match-end 0)) |
||||
(put-text-property (match-beginning 0) |
||||
(match-end 0) |
||||
'font-lock-face apropos-match-face doc))) |
||||
doc) |
||||
|
||||
(defun cider-apropos-result (result query docs-p) |
||||
"Emit a RESULT matching QUERY into current buffer, formatted for DOCS-P." |
||||
(nrepl-dbind-response result (name type doc) |
||||
(let* ((label (capitalize (if (string= type "variable") "var" type))) |
||||
(help (concat "Display doc for this " (downcase label)))) |
||||
(cider-propertize-region (list 'apropos-symbol name |
||||
'action 'cider-apropos-doc |
||||
'help-echo help) |
||||
(insert-text-button name 'type 'apropos-symbol) |
||||
(insert "\n ") |
||||
(insert-text-button label 'type (intern (concat "apropos-" type))) |
||||
(insert ": ") |
||||
(let ((beg (point))) |
||||
(if docs-p |
||||
(insert (cider-apropos-highlight doc query) "\n") |
||||
(insert doc) |
||||
(fill-region beg (point)))) |
||||
(insert "\n"))))) |
||||
|
||||
(declare-function cider-mode "cider-mode") |
||||
|
||||
(defun cider-show-apropos (summary results query docs-p) |
||||
"Show SUMMARY and RESULTS for QUERY in a pop-up buffer, formatted for DOCS-P." |
||||
(with-current-buffer (cider-popup-buffer cider-apropos-buffer t) |
||||
(let ((inhibit-read-only t)) |
||||
(set-syntax-table clojure-mode-syntax-table) |
||||
(apropos-mode) |
||||
(cider-mode) |
||||
(if (boundp 'header-line-format) |
||||
(setq-local header-line-format summary) |
||||
(insert summary "\n\n")) |
||||
(dolist (result results) |
||||
(cider-apropos-result result query docs-p)) |
||||
(goto-char (point-min))))) |
||||
|
||||
;;;###autoload |
||||
(defun cider-apropos (query &optional ns docs-p privates-p case-sensitive-p) |
||||
"Show all symbols whose names match QUERY, a regular expression. |
||||
The search may be limited to the namespace NS, and may optionally search doc |
||||
strings, include private vars, and be case sensitive." |
||||
(interactive |
||||
(if current-prefix-arg |
||||
(list (read-string "Clojure Apropos: ") |
||||
(let ((ns (read-string "Namespace: "))) |
||||
(if (string= ns "") nil ns)) |
||||
(y-or-n-p "Search doc strings? ") |
||||
(y-or-n-p "Include private symbols? ") |
||||
(y-or-n-p "Case-sensitive? ")) |
||||
(list (read-string "Clojure Apropos: ")))) |
||||
(cider-ensure-op-supported "apropos") |
||||
(if-let ((summary (cider-apropos-summary |
||||
query ns docs-p privates-p case-sensitive-p)) |
||||
(results (cider-sync-request:apropos query ns docs-p privates-p case-sensitive-p))) |
||||
(cider-show-apropos summary results query docs-p) |
||||
(message "No apropos matches for %S" query))) |
||||
|
||||
;;;###autoload |
||||
(defun cider-apropos-documentation () |
||||
"Shortcut for (cider-apropos <query> nil t)." |
||||
(interactive) |
||||
(cider-apropos (read-string "Clojure documentation Apropos: ") nil t)) |
||||
|
||||
(provide 'cider-apropos) |
||||
@ -0,0 +1,150 @@
|
||||
;;; cider-browse-ns.el --- CIDER namespace browser |
||||
|
||||
;; Copyright © 2014-2015 John Andrews |
||||
|
||||
;; Author: John Andrews <john.m.andrews@gmail.com> |
||||
|
||||
;; This program 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 program 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 program. If not, see <http://www.gnu.org/licenses/>. |
||||
|
||||
;; This file is not part of GNU Emacs. |
||||
|
||||
;;; Commentary: |
||||
|
||||
;; (cider-browse-ns) |
||||
;; Display a list of all vars in a namespace. |
||||
;; Pressing <enter> will take you to the cider-doc buffer for that var. |
||||
;; Pressing ^ will take you to a list of all namespaces (akin to dired mode) |
||||
|
||||
;; (cider-browse-ns-all) |
||||
;; Explore clojure namespaces by browsing a list of all namespaces. |
||||
;; Pressing enter expands into a list of that namespace's vars as if by |
||||
;; executing the command (cider-browse-ns "my.ns") |
||||
|
||||
;;; Code: |
||||
|
||||
(require 'cider-repl) |
||||
(require 'cider-client) |
||||
(require 'cider-compat) |
||||
|
||||
(defconst cider-browse-ns-buffer "*Browse NS*") |
||||
(defvar-local cider-browse-ns-current-ns nil) |
||||
|
||||
;; Mode Definition |
||||
|
||||
(defvar cider-browse-ns-mode-map |
||||
(let ((map (make-sparse-keymap))) |
||||
(set-keymap-parent map cider-popup-buffer-mode-map) |
||||
(define-key map "d" #'cider-browse-ns--doc-at-point) |
||||
(define-key map "s" #'cider-browse-ns--find-at-point) |
||||
(define-key map [return] #'cider-browse-ns--doc-at-point) |
||||
(define-key map "^" #'cider-browse-ns-all) |
||||
(define-key map "n" #'next-line) |
||||
(define-key map "p" #'previous-line) |
||||
map)) |
||||
|
||||
(defvar cider-browse-ns-mouse-map |
||||
(let ((map (make-sparse-keymap))) |
||||
(define-key map [mouse-1] #'cider-browse-ns--handle-mouse) |
||||
map)) |
||||
|
||||
(define-derived-mode cider-browse-ns-mode special-mode "browse-ns" |
||||
"Major mode for browsing Clojure namespaces. |
||||
|
||||
\\{cider-browse-ns-mode-map}" |
||||
(set-syntax-table clojure-mode-syntax-table) |
||||
(setq buffer-read-only t) |
||||
(setq-local electric-indent-chars nil) |
||||
(setq-local truncate-lines t) |
||||
(setq-local cider-browse-ns-current-ns nil)) |
||||
|
||||
(defun cider-browse-ns--properties (text) |
||||
"Decorate TEXT with a clickable keymap and function face." |
||||
(propertize text |
||||
'font-lock-face 'font-lock-function-name-face |
||||
'mouse-face 'highlight |
||||
'keymap cider-browse-ns-mouse-map)) |
||||
|
||||
(defun cider-browse-ns--list (buffer title items &optional ns noerase) |
||||
"Reset contents of BUFFER. Then display TITLE at the top and ITEMS are indented underneath. |
||||
If NS is non-nil, it is added to each item as the |
||||
`cider-browse-ns-current-ns' text property. If NOERASE is non-nil, the |
||||
contents of the buffer are not reset before inserting TITLE and ITEMS." |
||||
(with-current-buffer buffer |
||||
(cider-browse-ns-mode) |
||||
(let ((inhibit-read-only t)) |
||||
(unless noerase (erase-buffer)) |
||||
(goto-char (point-max)) |
||||
(insert (propertize title 'font-lock-face 'font-lock-type-face) |
||||
"\n") |
||||
(dolist (item items) |
||||
(insert (propertize (concat " " item "\n") |
||||
'cider-browse-ns-current-ns ns))) |
||||
(goto-char (point-min))))) |
||||
|
||||
;; Interactive Functions |
||||
|
||||
;;;###autoload |
||||
(defun cider-browse-ns (namespace) |
||||
"List all NAMESPACE's vars in BUFFER." |
||||
(interactive (list (completing-read "Browse namespace: " (cider-sync-request:ns-list)))) |
||||
(with-current-buffer (cider-popup-buffer cider-browse-ns-buffer t) |
||||
(let ((vars (cider-sync-request:ns-vars namespace))) |
||||
(cider-browse-ns--list (current-buffer) |
||||
namespace |
||||
(mapcar (lambda (var) |
||||
(format "%s" |
||||
(cider-browse-ns--properties var))) |
||||
vars)) |
||||
(setq-local cider-browse-ns-current-ns namespace)))) |
||||
|
||||
;;;###autoload |
||||
(defun cider-browse-ns-all () |
||||
"List all loaded namespaces in BUFFER." |
||||
(interactive) |
||||
(with-current-buffer (cider-popup-buffer cider-browse-ns-buffer t) |
||||
(let ((names (cider-sync-request:ns-list))) |
||||
(cider-browse-ns--list (current-buffer) |
||||
"All loaded namespaces" |
||||
(mapcar (lambda (name) |
||||
(cider-browse-ns--properties name)) |
||||
names)) |
||||
(setq-local cider-browse-ns-current-ns nil)))) |
||||
|
||||
(defun cider-browse-ns--var-at-point () |
||||
(let ((line (thing-at-point 'line))) |
||||
(when (string-match " +\\(.+\\)\n?" line) |
||||
(format "%s/%s" |
||||
(or (get-text-property (point) 'cider-browse-ns-current-ns) |
||||
cider-browse-ns-current-ns) |
||||
(match-string 1 line))))) |
||||
|
||||
(defun cider-browse-ns--doc-at-point () |
||||
"Expand browser according to thing at current point." |
||||
(interactive) |
||||
(when-let ((var (cider-browse-ns--var-at-point))) |
||||
(cider-doc-lookup var))) |
||||
|
||||
(defun cider-browse-ns--find-at-point () |
||||
(interactive) |
||||
(when-let ((var (cider-browse-ns--var-at-point))) |
||||
(cider-find-var current-prefix-arg var))) |
||||
|
||||
(defun cider-browse-ns--handle-mouse (event) |
||||
"Handle mouse click EVENT." |
||||
(interactive "e") |
||||
(cider-browse-ns--doc-at-point)) |
||||
|
||||
(provide 'cider-browse-ns) |
||||
|
||||
;;; cider-browse-ns.el ends here |
||||
@ -0,0 +1,106 @@
|
||||
;;; cider-classpath.el --- Basic Java classpath browser |
||||
|
||||
;; Copyright © 2014-2015 Bozhidar Batsov |
||||
|
||||
;; This program 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 program 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 program. If not, see <http://www.gnu.org/licenses/>. |
||||
|
||||
;; This file is not part of GNU Emacs. |
||||
|
||||
;;; Commentary: |
||||
|
||||
;; Basic Java classpath browser for CIDER. |
||||
|
||||
;;; Code: |
||||
|
||||
(require 'cider-client) |
||||
(require 'cider-popup) |
||||
(require 'cider-compat) |
||||
|
||||
(defvar cider-classpath-buffer "*Classpath*") |
||||
|
||||
(defvar cider-classpath-mode-map |
||||
(let ((map (make-sparse-keymap))) |
||||
(set-keymap-parent map cider-popup-buffer-mode-map) |
||||
(define-key map [return] #'cider-classpath-operate-on-point) |
||||
(define-key map "n" #'next-line) |
||||
(define-key map "p" #'previous-line) |
||||
map)) |
||||
|
||||
(defvar cider-classpath-mouse-map |
||||
(let ((map (make-sparse-keymap))) |
||||
(define-key map [mouse-1] #'cider-classpath-handle-mouse) |
||||
map)) |
||||
|
||||
(define-derived-mode cider-classpath-mode special-mode "classpath" |
||||
"Major mode for browsing the entries in Java's classpath. |
||||
|
||||
\\{cider-classpath-mode-map}" |
||||
(setq buffer-read-only t) |
||||
(setq-local electric-indent-chars nil) |
||||
(setq-local truncate-lines t)) |
||||
|
||||
(defun cider-classpath-list (buffer items) |
||||
"Populate BUFFER with ITEMS." |
||||
(with-current-buffer buffer |
||||
(cider-classpath-mode) |
||||
(let ((inhibit-read-only t)) |
||||
(erase-buffer) |
||||
(dolist (item items) |
||||
(insert item "\n")) |
||||
(goto-char (point-min))))) |
||||
|
||||
(defun cider-classpath-properties (text) |
||||
"Decorate TEXT with a clickable keymap and function face." |
||||
(let ((face (cond |
||||
((not (file-exists-p text)) 'font-lock-warning-face) |
||||
((file-directory-p text) 'dired-directory) |
||||
(t 'default)))) |
||||
(propertize text |
||||
'font-lock-face face |
||||
'mouse-face 'highlight |
||||
'keymap cider-classpath-mouse-map))) |
||||
|
||||
(defun cider-classpath-operate-on-point () |
||||
"Expand browser according to thing at current point." |
||||
(interactive) |
||||
(let* ((bol (line-beginning-position)) |
||||
(eol (line-end-position)) |
||||
(line (buffer-substring-no-properties bol eol))) |
||||
(find-file-other-window line))) |
||||
|
||||
(defun cider-classpath-handle-mouse (event) |
||||
"Handle mouse click EVENT." |
||||
(interactive "e") |
||||
(cider-classpath-operate-on-point)) |
||||
|
||||
;;;###autoload |
||||
(defun cider-classpath () |
||||
"List all classpath entries." |
||||
(interactive) |
||||
(with-current-buffer (cider-popup-buffer cider-classpath-buffer t) |
||||
(cider-classpath-list (current-buffer) |
||||
(mapcar (lambda (name) |
||||
(cider-classpath-properties name)) |
||||
(cider-sync-request:classpath))))) |
||||
|
||||
;;;###autoload |
||||
(defun cider-open-classpath-entry () |
||||
"Open a classpath entry." |
||||
(interactive) |
||||
(when-let ((entry (completing-read "Classpath entries: " (cider-sync-request:classpath)))) |
||||
(find-file-other-window entry))) |
||||
|
||||
(provide 'cider-classpath) |
||||
|
||||
;;; cider-classpath.el ends here |
||||
@ -0,0 +1,225 @@
|
||||
;;; cider-common.el --- Common use functions -*- lexical-binding: t; -*- |
||||
|
||||
;; Copyright (C) 2015 Artur Malabarba |
||||
|
||||
;; Author: Artur Malabarba <bruce.connor.am@gmail.com> |
||||
|
||||
;; This program 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 program 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 program. If not, see <http://www.gnu.org/licenses/>. |
||||
|
||||
;;; Commentary: |
||||
|
||||
;; Common functions that are useful in both Clojure buffers and REPL |
||||
;; buffers. |
||||
|
||||
;;; Code: |
||||
|
||||
(require 'cider-compat) |
||||
(require 'nrepl-client) |
||||
(require 'cider-util) |
||||
|
||||
(defcustom cider-prompt-for-symbol t |
||||
"Controls when to prompt for symbol when a command requires one. |
||||
|
||||
When non-nil, always prompt, and use the symbol at point as the default |
||||
value at the prompt. |
||||
|
||||
When nil, attempt to use the symbol at point for the command, and only |
||||
prompt if that throws an error." |
||||
:type '(choice (const :tag "always" t) |
||||
(const :tag "dwim" nil)) |
||||
:group 'cider |
||||
:package-version '(cider . "0.9.0")) |
||||
|
||||
(defun cider--should-prompt-for-symbol (&optional invert) |
||||
(if invert (not cider-prompt-for-symbol) cider-prompt-for-symbol)) |
||||
|
||||
(defun cider-prompt-for-symbol-function (&optional invert) |
||||
(if (cider--should-prompt-for-symbol invert) |
||||
#'cider-read-symbol-name |
||||
#'cider-try-symbol-at-point)) |
||||
|
||||
(defun cider--kw-to-symbol (kw) |
||||
"Convert the keyword KW to a symbol." |
||||
(when kw |
||||
(replace-regexp-in-string "\\`:+" "" kw))) |
||||
|
||||
(declare-function cider-read-from-minibuffer "cider-interaction") |
||||
|
||||
(defun cider-read-symbol-name (prompt callback) |
||||
"Read a symbol name using PROMPT with a default of the one at point. |
||||
Use CALLBACK as the completing read var callback." |
||||
(funcall callback (cider-read-from-minibuffer |
||||
prompt |
||||
;; if the thing at point is a keyword we treat it as symbol |
||||
(cider--kw-to-symbol (cider-symbol-at-point))))) |
||||
|
||||
(defun cider-try-symbol-at-point (prompt callback) |
||||
"Call CALLBACK with symbol at point. |
||||
On failure, read a symbol name using PROMPT and call CALLBACK with that." |
||||
(condition-case nil (funcall callback (cider--kw-to-symbol (cider-symbol-at-point))) |
||||
('error (funcall callback (cider-read-from-minibuffer prompt))))) |
||||
|
||||
(declare-function cider-jump-to "cider-interaction") |
||||
|
||||
(defun cider--jump-to-loc-from-info (info &optional other-window) |
||||
"Jump to location give by INFO. |
||||
INFO object is returned by `cider-var-info' or `cider-member-info'. |
||||
OTHER-WINDOW is passed to `cider-jamp-to'." |
||||
(let* ((line (nrepl-dict-get info "line")) |
||||
(file (nrepl-dict-get info "file")) |
||||
(name (nrepl-dict-get info "name")) |
||||
(buffer (and file |
||||
(not (cider--tooling-file-p file)) |
||||
(cider-find-file file)))) |
||||
(if buffer |
||||
(cider-jump-to buffer (if line (cons line nil) name) other-window) |
||||
(error "No source location")))) |
||||
|
||||
(declare-function url-filename "url-parse" (cl-x) t) |
||||
|
||||
(defun cider--url-to-file (url) |
||||
"Return the filename from the resource URL. |
||||
Uses `url-generic-parse-url' to parse the url. The filename is extracted and |
||||
then url decoded. If the decoded filename has a Windows device letter followed |
||||
by a colon immediately after the leading '/' then the leading '/' is dropped to |
||||
create a valid path." |
||||
(let ((filename (url-unhex-string (url-filename (url-generic-parse-url url))))) |
||||
(if (string-match "^/\\([a-zA-Z]:/.*\\)" filename) |
||||
(match-string 1 filename) |
||||
filename))) |
||||
|
||||
(defun cider-tramp-prefix (&optional buffer) |
||||
"Use the filename for BUFFER to determine a tramp prefix. |
||||
Defaults to the current buffer. |
||||
Return the tramp prefix, or nil if BUFFER is local." |
||||
(let* ((buffer (or buffer (current-buffer))) |
||||
(name (or (buffer-file-name buffer) |
||||
(with-current-buffer buffer |
||||
default-directory)))) |
||||
(when (tramp-tramp-file-p name) |
||||
(let ((vec (tramp-dissect-file-name name))) |
||||
(tramp-make-tramp-file-name (tramp-file-name-method vec) |
||||
(tramp-file-name-user vec) |
||||
(tramp-file-name-host vec) |
||||
nil))))) |
||||
|
||||
(defun cider--client-tramp-filename (name &optional buffer) |
||||
"Return the tramp filename for path NAME relative to BUFFER. |
||||
If BUFFER has a tramp prefix, it will be added as a prefix to NAME. |
||||
If the resulting path is an existing tramp file, it returns the path, |
||||
otherwise, nil." |
||||
(let* ((buffer (or buffer (current-buffer))) |
||||
(name (concat (cider-tramp-prefix buffer) name))) |
||||
(if (tramp-handle-file-exists-p name) |
||||
name))) |
||||
|
||||
(defun cider--server-filename (name) |
||||
"Return the nREPL server-relative filename for NAME." |
||||
(if (tramp-tramp-file-p name) |
||||
(with-parsed-tramp-file-name name nil |
||||
localname) |
||||
name)) |
||||
|
||||
(defvar cider-from-nrepl-filename-function |
||||
(with-no-warnings |
||||
(if (eq system-type 'cygwin) |
||||
#'cygwin-convert-file-name-from-windows |
||||
#'identity)) |
||||
"Function to translate nREPL namestrings to Emacs filenames.") |
||||
|
||||
(defcustom cider-prefer-local-resources nil |
||||
"Prefer local resources to remote (tramp) ones when both are available." |
||||
:type 'boolean |
||||
:group 'cider) |
||||
|
||||
(defun cider--file-path (path) |
||||
"Return PATH's local or tramp path using `cider-prefer-local-resources'. |
||||
If no local or remote file exists, return nil." |
||||
(let* ((local-path (funcall cider-from-nrepl-filename-function path)) |
||||
(tramp-path (and local-path (cider--client-tramp-filename local-path)))) |
||||
(cond ((equal local-path "") "") |
||||
((and cider-prefer-local-resources (file-exists-p local-path)) |
||||
local-path) |
||||
((and tramp-path (file-exists-p tramp-path)) |
||||
tramp-path) |
||||
((and local-path (file-exists-p local-path)) |
||||
local-path)))) |
||||
|
||||
(declare-function archive-extract "arc-mode") |
||||
(declare-function archive-zip-extract "arc-mode") |
||||
|
||||
(defun cider-find-file (url) |
||||
"Return a buffer visiting the file URL if it exists, or nil otherwise. |
||||
If URL has a scheme prefix, it must represent a fully-qualified file path |
||||
or an entry within a zip/jar archive. If URL doesn't contain a scheme |
||||
prefix and is an absolute path, it is treated as such. Finally, if URL is |
||||
relative, it is expanded within each of the open Clojure buffers till an |
||||
existing file ending with URL has been found." |
||||
(require 'arc-mode) |
||||
(cond ((string-match "^file:\\(.+\\)" url) |
||||
(when-let ((file (cider--url-to-file (match-string 1 url))) |
||||
(path (cider--file-path file))) |
||||
(find-file-noselect path))) |
||||
((string-match "^\\(jar\\|zip\\):\\(file:.+\\)!/\\(.+\\)" url) |
||||
(when-let ((entry (match-string 3 url)) |
||||
(file (cider--url-to-file (match-string 2 url))) |
||||
(path (cider--file-path file)) |
||||
(name (format "%s:%s" path entry))) |
||||
(or (find-buffer-visiting name) |
||||
(if (tramp-tramp-file-p path) |
||||
(progn |
||||
;; Use emacs built in archiving |
||||
(find-file path) |
||||
(goto-char (point-min)) |
||||
;; Make sure the file path is followed by a newline to |
||||
;; prevent eg. clj matching cljs. |
||||
(search-forward (concat entry "\n")) |
||||
;; moves up to matching line |
||||
(forward-line -1) |
||||
(archive-extract) |
||||
(current-buffer)) |
||||
;; Use external zip program to just extract the single file |
||||
(with-current-buffer (generate-new-buffer |
||||
(file-name-nondirectory entry)) |
||||
(archive-zip-extract path entry) |
||||
(set-visited-file-name name) |
||||
(setq-local default-directory (file-name-directory path)) |
||||
(setq-local buffer-read-only t) |
||||
(set-buffer-modified-p nil) |
||||
(set-auto-mode) |
||||
(current-buffer)))))) |
||||
(t (if-let ((path (cider--file-path url))) |
||||
(find-file-noselect path) |
||||
(unless (file-name-absolute-p url) |
||||
(let ((cider-buffers (cider-util--clojure-buffers)) |
||||
(url (file-name-nondirectory url))) |
||||
(or (cl-loop for bf in cider-buffers |
||||
for path = (with-current-buffer bf |
||||
(expand-file-name url)) |
||||
if (and path (file-exists-p path)) |
||||
return (find-file-noselect path)) |
||||
(cl-loop for bf in cider-buffers |
||||
if (string= (buffer-name bf) url) |
||||
return bf)))))))) |
||||
|
||||
(defun cider--open-other-window-p (arg) |
||||
"Test prefix value ARG to see if it indicates displaying results in other window." |
||||
(let ((narg (prefix-numeric-value arg))) |
||||
(pcase narg |
||||
(-1 t) ; - |
||||
(16 t) ; empty empty |
||||
(_ nil)))) |
||||
|
||||
(provide 'cider-common) |
||||
;;; cider-common.el ends here |
||||
@ -0,0 +1,157 @@
|
||||
;;; cider-compat.el --- Functions from newer Emacs versions for compatibility -*- lexical-binding: t -*- |
||||
|
||||
;; Copyright © 2012-2015 Tim King, Phil Hagelberg |
||||
;; Copyright © 2013-2015 Bozhidar Batsov, Hugo Duncan, Steve Purcell |
||||
;; |
||||
|
||||
;; This program 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 program 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 program. If not, see <http://www.gnu.org/licenses/>. |
||||
|
||||
;; This file is not part of GNU Emacs. |
||||
|
||||
;;; Commentary: |
||||
|
||||
;; Pretty much everything here's copied from subr-x for compatibility with |
||||
;; Emacs 24.3 and 24.4. |
||||
|
||||
;;; Code: |
||||
|
||||
(eval-and-compile |
||||
|
||||
(unless (fboundp 'thread-first ) |
||||
|
||||
(defmacro internal--thread-argument (first? &rest forms) |
||||
"Internal implementation for `thread-first' and `thread-last'. |
||||
When Argument FIRST? is non-nil argument is threaded first, else |
||||
last. FORMS are the expressions to be threaded." |
||||
(pcase forms |
||||
(`(,x (,f . ,args) . ,rest) |
||||
`(internal--thread-argument |
||||
,first? ,(if first? `(,f ,x ,@args) `(,f ,@args ,x)) ,@rest)) |
||||
(`(,x ,f . ,rest) `(internal--thread-argument ,first? (,f ,x) ,@rest)) |
||||
(_ (car forms)))) |
||||
|
||||
(defmacro thread-first (&rest forms) |
||||
"Thread FORMS elements as the first argument of their successor. |
||||
Example: |
||||
(thread-first |
||||
5 |
||||
(+ 20) |
||||
(/ 25) |
||||
- |
||||
(+ 40)) |
||||
Is equivalent to: |
||||
(+ (- (/ (+ 5 20) 25)) 40) |
||||
Note how the single `-' got converted into a list before |
||||
threading." |
||||
(declare (indent 1) |
||||
(debug (form &rest [&or symbolp (sexp &rest form)]))) |
||||
`(internal--thread-argument t ,@forms))) |
||||
|
||||
(unless (fboundp 'thread-last ) |
||||
|
||||
(defmacro thread-last (&rest forms) |
||||
"Thread FORMS elements as the last argument of their successor. |
||||
Example: |
||||
(thread-last |
||||
5 |
||||
(+ 20) |
||||
(/ 25) |
||||
- |
||||
(+ 40)) |
||||
Is equivalent to: |
||||
(+ 40 (- (/ 25 (+ 20 5)))) |
||||
Note how the single `-' got converted into a list before |
||||
threading." |
||||
(declare (indent 1) (debug thread-first)) |
||||
`(internal--thread-argument nil ,@forms)))) |
||||
|
||||
|
||||
(eval-and-compile |
||||
|
||||
(unless (fboundp 'internal--listify) |
||||
|
||||
(defsubst internal--listify (elt) |
||||
"Wrap ELT in a list if it is not one." |
||||
(if (not (listp elt)) |
||||
(list elt) |
||||
elt))) |
||||
|
||||
(unless (fboundp 'internal--check-binding) |
||||
|
||||
(defsubst internal--check-binding (binding) |
||||
"Check BINDING is properly formed." |
||||
(when (> (length binding) 2) |
||||
(signal |
||||
'error |
||||
(cons "`let' bindings can have only one value-form" binding))) |
||||
binding)) |
||||
|
||||
(unless (fboundp 'internal--build-binding-value-form) |
||||
|
||||
(defsubst internal--build-binding-value-form (binding prev-var) |
||||
"Build the conditional value form for BINDING using PREV-VAR." |
||||
`(,(car binding) (and ,prev-var ,(cadr binding))))) |
||||
|
||||
(unless (fboundp ' internal--build-binding) |
||||
|
||||
(defun internal--build-binding (binding prev-var) |
||||
"Check and build a single BINDING with PREV-VAR." |
||||
(thread-first |
||||
binding |
||||
internal--listify |
||||
internal--check-binding |
||||
(internal--build-binding-value-form prev-var)))) |
||||
|
||||
(unless (fboundp ' internal--build-bindings) |
||||
|
||||
(defun internal--build-bindings (bindings) |
||||
"Check and build conditional value forms for BINDINGS." |
||||
(let ((prev-var t)) |
||||
(mapcar (lambda (binding) |
||||
(let ((binding (internal--build-binding binding prev-var))) |
||||
(setq prev-var (car binding)) |
||||
binding)) |
||||
bindings))))) |
||||
|
||||
(eval-and-compile |
||||
|
||||
(unless (fboundp 'if-let) |
||||
(defmacro if-let (bindings then &rest else) |
||||
"Process BINDINGS and if all values are non-nil eval THEN, else ELSE. |
||||
Argument BINDINGS is a list of tuples whose car is a symbol to be |
||||
bound and (optionally) used in THEN, and its cadr is a sexp to be |
||||
evalled to set symbol's value. In the special case you only want |
||||
to bind a single value, BINDINGS can just be a plain tuple." |
||||
(declare (indent 2) |
||||
(debug ([&or (&rest (symbolp form)) (symbolp form)] form body))) |
||||
(when (and (<= (length bindings) 2) |
||||
(not (listp (car bindings)))) |
||||
;; Adjust the single binding case |
||||
(setq bindings (list bindings))) |
||||
`(let* ,(internal--build-bindings bindings) |
||||
(if ,(car (internal--listify (car (last bindings)))) |
||||
,then |
||||
,@else))) |
||||
|
||||
(defmacro when-let (bindings &rest body) |
||||
"Process BINDINGS and if all values are non-nil eval BODY. |
||||
Argument BINDINGS is a list of tuples whose car is a symbol to be |
||||
bound and (optionally) used in BODY, and its cadr is a sexp to be |
||||
evalled to set symbol's value. In the special case you only want |
||||
to bind a single value, BINDINGS can just be a plain tuple." |
||||
(declare (indent 1) (debug if-let)) |
||||
(list 'if-let bindings (macroexp-progn body))))) |
||||
|
||||
(provide 'cider-compat) |
||||
;;; cider-compat.el ends here |
||||
@ -0,0 +1,164 @@
|
||||
;;; cider-eldoc.el --- eldoc support for Clojure -*- lexical-binding: t -*- |
||||
|
||||
;; Copyright © 2012-2015 Tim King, Phil Hagelberg |
||||
;; Copyright © 2013-2015 Bozhidar Batsov, Hugo Duncan, Steve Purcell |
||||
;; |
||||
;; Author: Tim King <kingtim@gmail.com> |
||||
;; Phil Hagelberg <technomancy@gmail.com> |
||||
;; Bozhidar Batsov <bozhidar@batsov.com> |
||||
;; Hugo Duncan <hugo@hugoduncan.org> |
||||
;; Steve Purcell <steve@sanityinc.com> |
||||
|
||||
;; This program 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 program 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 program. If not, see <http://www.gnu.org/licenses/>. |
||||
|
||||
;; This file is not part of GNU Emacs. |
||||
|
||||
;;; Commentary: |
||||
|
||||
;; eldoc support for Clojure. |
||||
|
||||
;;; Code: |
||||
|
||||
(require 'cider-client) |
||||
(require 'cider-common) ; for cider-symbol-at-point |
||||
(require 'cider-compat) |
||||
(require 'cider-util) |
||||
|
||||
(require 'cl-lib) |
||||
|
||||
(require 'eldoc) |
||||
|
||||
(defvar cider-extra-eldoc-commands '("yas-expand") |
||||
"Extra commands to be added to eldoc's safe commands list.") |
||||
|
||||
(defvar-local cider-eldoc-last-symbol nil |
||||
"The eldoc information for the last symbol we checked.") |
||||
|
||||
(defun cider-eldoc-format-thing (thing) |
||||
"Format the eldoc THING." |
||||
(propertize thing 'face 'font-lock-function-name-face)) |
||||
|
||||
(defun cider-highlight-args (arglist pos) |
||||
"Format the the function ARGLIST for eldoc. |
||||
POS is the index of the currently highlighted argument." |
||||
(let* ((rest-pos (cider--find-rest-args-position arglist)) |
||||
(i 0)) |
||||
(mapconcat |
||||
(lambda (arg) |
||||
(let ((argstr (format "%s" arg))) |
||||
(if (eq arg '&) |
||||
argstr |
||||
(prog1 |
||||
(if (or (= (1+ i) pos) |
||||
(and rest-pos (> (+ 1 i) rest-pos) |
||||
(> pos rest-pos))) |
||||
(propertize argstr 'face |
||||
'eldoc-highlight-function-argument) |
||||
argstr) |
||||
(setq i (1+ i)))))) arglist " "))) |
||||
|
||||
(defun cider--find-rest-args-position (arglist) |
||||
"Find the position of & in the ARGLIST vector." |
||||
(cl-position '& (append arglist ()))) |
||||
|
||||
(defun cider-highlight-arglist (arglist pos) |
||||
"Format the ARGLIST for eldoc. |
||||
POS is the index of the argument to highlight." |
||||
(concat "[" (cider-highlight-args arglist pos) "]")) |
||||
|
||||
(defun cider-eldoc-format-arglist (arglist pos) |
||||
"Format all the ARGLIST for eldoc. |
||||
POS is the index of current argument." |
||||
(concat "(" |
||||
(mapconcat (lambda (args) (cider-highlight-arglist args pos)) |
||||
arglist |
||||
" ") |
||||
")")) |
||||
|
||||
(defun cider-eldoc-beginning-of-sexp () |
||||
"Move to the beginning of current sexp. |
||||
|
||||
Return the number of nested sexp the point was over or after. " |
||||
(let ((parse-sexp-ignore-comments t) |
||||
(num-skipped-sexps 0)) |
||||
(condition-case _ |
||||
(progn |
||||
;; First account for the case the point is directly over a |
||||
;; beginning of a nested sexp. |
||||
(condition-case _ |
||||
(let ((p (point))) |
||||
(forward-sexp -1) |
||||
(forward-sexp 1) |
||||
(when (< (point) p) |
||||
(setq num-skipped-sexps 1))) |
||||
(error)) |
||||
(while |
||||
(let ((p (point))) |
||||
(forward-sexp -1) |
||||
(when (< (point) p) |
||||
(setq num-skipped-sexps (1+ num-skipped-sexps)))))) |
||||
(error)) |
||||
num-skipped-sexps)) |
||||
|
||||
(defun cider-eldoc-info-in-current-sexp () |
||||
"Return a list of the current sexp and the current argument index." |
||||
(save-excursion |
||||
(let ((argument-index (1- (cider-eldoc-beginning-of-sexp)))) |
||||
;; If we are at the beginning of function name, this will be -1. |
||||
(when (< argument-index 0) |
||||
(setq argument-index 0)) |
||||
;; Don't do anything if current word is inside a string, vector, |
||||
;; hash or set literal. |
||||
(if (member (or (char-after (1- (point))) 0) '(?\" ?\{ ?\[)) |
||||
nil |
||||
(list (cider-symbol-at-point) argument-index))))) |
||||
|
||||
(defun cider-eldoc-arglist (thing) |
||||
"Return the arglist for THING." |
||||
(when (and (cider-nrepl-op-supported-p "eldoc") |
||||
thing |
||||
(not (string= thing "")) |
||||
(not (string-prefix-p ":" thing))) |
||||
;; check if we can used the cached eldoc info |
||||
(if (string= thing (car cider-eldoc-last-symbol)) |
||||
(cdr cider-eldoc-last-symbol) |
||||
(when-let ((eldoc-info (cider-sync-request:eldoc (substring-no-properties thing)))) |
||||
(let ((arglist (nrepl-dict-get eldoc-info "eldoc"))) |
||||
(setq cider-eldoc-last-symbol (cons thing arglist)) |
||||
arglist))))) |
||||
|
||||
(defun cider-eldoc () |
||||
"Backend function for eldoc to show argument list in the echo area." |
||||
(when (and (cider-connected-p) |
||||
;; don't clobber an error message in the minibuffer |
||||
(not (member last-command '(next-error previous-error)))) |
||||
(let* ((info (cider-eldoc-info-in-current-sexp)) |
||||
(thing (car info)) |
||||
(pos (cadr info)) |
||||
(value (cider-eldoc-arglist thing))) |
||||
(when value |
||||
(format "%s: %s" |
||||
(cider-eldoc-format-thing thing) |
||||
(cider-eldoc-format-arglist value pos)))))) |
||||
|
||||
(defun cider-eldoc-setup () |
||||
"Turn on eldoc mode in the current buffer." |
||||
(setq-local eldoc-documentation-function #'cider-eldoc) |
||||
(apply #'eldoc-add-command cider-extra-eldoc-commands)) |
||||
|
||||
(define-obsolete-function-alias 'cider-turn-on-eldoc-mode 'eldoc-mode) |
||||
|
||||
(provide 'cider-eldoc) |
||||
|
||||
;;; cider-eldoc.el ends here |
||||
@ -0,0 +1,112 @@
|
||||
;;; cider-grimoire.el --- Grimoire integration -*- lexical-binding: t -*- |
||||
|
||||
;; Copyright © 2014-2015 Bozhidar Batsov |
||||
;; |
||||
;; Author: Bozhidar Batsov <bozhidar@batsov.com> |
||||
|
||||
;; This program 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 program 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 program. If not, see <http://www.gnu.org/licenses/>. |
||||
|
||||
;; This file is not part of GNU Emacs. |
||||
|
||||
;;; Commentary: |
||||
|
||||
;; A few commands for Grimoire documentation lookup. |
||||
|
||||
;;; Code: |
||||
|
||||
(require 'cider-client) |
||||
(require 'cider-common) |
||||
(require 'cider-compat) |
||||
(require 'cider-popup) |
||||
|
||||
(require 'nrepl-client) |
||||
|
||||
(require 'url-vars) |
||||
|
||||
(defconst cider-grimoire-url "http://conj.io/") |
||||
|
||||
(defun cider-grimoire-replace-special (name) |
||||
"Convert the dashes in NAME to a grimoire friendly format." |
||||
(thread-last name |
||||
(replace-regexp-in-string "\\?" "_QMARK_") |
||||
(replace-regexp-in-string "\\." "_DOT_") |
||||
(replace-regexp-in-string "\\/" "_SLASH_") |
||||
(replace-regexp-in-string "\\(\\`_\\)\\|\\(_\\'\\)" ""))) |
||||
|
||||
(defun cider-grimoire-url (name ns) |
||||
"Generate a grimoire search v0 url from NAME, NS." |
||||
(let ((base-url cider-grimoire-url)) |
||||
(when (and name ns) |
||||
(concat base-url "search/v0/" ns "/" (cider-grimoire-replace-special name) "/")))) |
||||
|
||||
(defun cider-grimoire-web-lookup (symbol) |
||||
"Look up the grimoire documentation for SYMBOL." |
||||
(if-let ((var-info (cider-var-info symbol))) |
||||
(let ((name (nrepl-dict-get var-info "name")) |
||||
(ns (nrepl-dict-get var-info "ns"))) |
||||
(browse-url (cider-grimoire-url name ns))) |
||||
(error "Symbol %s not resolved" symbol))) |
||||
|
||||
;;;###autoload |
||||
(defun cider-grimoire-web (&optional arg) |
||||
"Open grimoire documentation in the default web browser. |
||||
|
||||
Prompts for the symbol to use, or uses the symbol at point, depending on |
||||
the value of `cider-prompt-for-symbol'. With prefix arg ARG, does the |
||||
opposite of what that option dictates." |
||||
(interactive "P") |
||||
(funcall (cider-prompt-for-symbol-function arg) |
||||
"Grimoire doc for" |
||||
#'cider-grimoire-web-lookup)) |
||||
|
||||
(defun cider-create-grimoire-buffer (content) |
||||
"Create a new grimoire buffer with CONTENT." |
||||
(with-current-buffer (cider-popup-buffer "*cider grimoire*" t) |
||||
(read-only-mode -1) |
||||
(insert content) |
||||
(read-only-mode +1) |
||||
(goto-char (point-min)) |
||||
(current-buffer))) |
||||
|
||||
(defun cider-grimoire-lookup (symbol) |
||||
"Look up the grimoire documentation for SYMBOL." |
||||
(if-let ((var-info (cider-var-info symbol))) |
||||
(let ((name (nrepl-dict-get var-info "name")) |
||||
(ns (nrepl-dict-get var-info "ns")) |
||||
(url-request-method "GET") |
||||
(url-request-extra-headers `(("Content-Type" . "text/plain")))) |
||||
(url-retrieve (cider-grimoire-url name ns) |
||||
(lambda (_status) |
||||
;; we need to strip the http header |
||||
(goto-char (point-min)) |
||||
(re-search-forward "^$") |
||||
(delete-region (point-min) (point)) |
||||
(delete-blank-lines) |
||||
;; and create a new buffer with whatever is left |
||||
(pop-to-buffer (cider-create-grimoire-buffer (buffer-string)))))) |
||||
(error "Symbol %s not resolved" symbol))) |
||||
|
||||
;;;###autoload |
||||
(defun cider-grimoire (&optional arg) |
||||
"Open grimoire documentation in a popup buffer. |
||||
|
||||
Prompts for the symbol to use, or uses the symbol at point, depending on |
||||
the value of `cider-prompt-for-symbol'. With prefix arg ARG, does the |
||||
opposite of what that option dictates." |
||||
(interactive "P") |
||||
(funcall (cider-prompt-for-symbol-function arg) |
||||
"Grimoire doc for" |
||||
#'cider-grimoire-lookup)) |
||||
|
||||
(provide 'cider-grimoire) |
||||
@ -0,0 +1,309 @@
|
||||
;;; cider-inspector.el --- Object inspector -*- lexical-binding: t -*- |
||||
|
||||
;; Copyright © 2013-2015 Vital Reactor, LLC |
||||
;; Copyright © 2014-2015 Bozhidar Batsov |
||||
|
||||
;; Author: Ian Eslick <ian@vitalreactor.com> |
||||
;; Bozhidar Batsov <bozhidar@batsov.com> |
||||
|
||||
;; This program 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 program 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 program. If not, see <http://www.gnu.org/licenses/>. |
||||
|
||||
;; This file is not part of GNU Emacs. |
||||
|
||||
;;; Commentary: |
||||
|
||||
;; Clojure object inspector inspired by SLIME. |
||||
|
||||
;;; Code: |
||||
|
||||
(require 'cl-lib) |
||||
(require 'cider-interaction) |
||||
|
||||
;; =================================== |
||||
;; Inspector Key Map and Derived Mode |
||||
;; =================================== |
||||
|
||||
(defconst cider-inspector-buffer "*cider inspect*") |
||||
|
||||
;;; Customization |
||||
(defgroup cider-inspector nil |
||||
"Presentation and behaviour of the cider value inspector." |
||||
:prefix "cider-inspector-" |
||||
:group 'cider |
||||
:package-version '(cider . "0.10.0")) |
||||
|
||||
(defcustom cider-inspector-page-size 32 |
||||
"Default page size in paginated inspector view. |
||||
The page size can be also changed interactively within the inspector." |
||||
:type '(integer :tag "Page size" 32) |
||||
:group 'cider-inspector |
||||
:package-version '(cider . "0.10.0")) |
||||
|
||||
(push cider-inspector-buffer cider-ancillary-buffers) |
||||
|
||||
(defvar cider-inspector-mode-map |
||||
(let ((map (make-sparse-keymap))) |
||||
(set-keymap-parent map cider-popup-buffer-mode-map) |
||||
(define-key map [return] #'cider-inspector-operate-on-point) |
||||
(define-key map "\C-m" #'cider-inspector-operate-on-point) |
||||
(define-key map [mouse-1] #'cider-inspector-operate-on-click) |
||||
(define-key map "l" #'cider-inspector-pop) |
||||
(define-key map "g" #'cider-inspector-refresh) |
||||
;; Page-up/down |
||||
(define-key map [next] #'cider-inspector-next-page) |
||||
(define-key map [prior] #'cider-inspector-prev-page) |
||||
(define-key map " " #'cider-inspector-next-page) |
||||
(define-key map (kbd "M-SPC") #'cider-inspector-prev-page) |
||||
(define-key map (kbd "S-SPC") #'cider-inspector-prev-page) |
||||
(define-key map "s" #'cider-inspector-set-page-size) |
||||
(define-key map [tab] #'cider-inspector-next-inspectable-object) |
||||
(define-key map "\C-i" #'cider-inspector-next-inspectable-object) |
||||
(define-key map [(shift tab)] #'cider-inspector-previous-inspectable-object) ; Emacs translates S-TAB |
||||
(define-key map [backtab] #'cider-inspector-previous-inspectable-object) ; to BACKTAB on X. |
||||
map)) |
||||
|
||||
(define-derived-mode cider-inspector-mode fundamental-mode "Inspector" |
||||
"Major mode for inspecting Clojure data structures. |
||||
|
||||
\\{cider-inspector-mode-map}" |
||||
(set-syntax-table clojure-mode-syntax-table) |
||||
(setq buffer-read-only t) |
||||
(setq-local electric-indent-chars nil) |
||||
(setq-local truncate-lines t)) |
||||
|
||||
;;;###autoload |
||||
(defun cider-inspect (expression) |
||||
"Eval the string EXPRESSION and inspect the result." |
||||
(interactive |
||||
(list (cider-read-from-minibuffer "Inspect value: " |
||||
(cider-sexp-at-point)))) |
||||
(cider-inspect-expr expression (cider-current-ns))) |
||||
|
||||
;; Operations |
||||
(defun cider-inspector--value-handler (_buffer value) |
||||
(cider-make-popup-buffer cider-inspector-buffer 'cider-inspector-mode) |
||||
(cider-irender cider-inspector-buffer value)) |
||||
|
||||
(defun cider-inspector--out-handler (_buffer value) |
||||
(cider-emit-interactive-eval-output value)) |
||||
|
||||
(defun cider-inspector--err-handler (_buffer err) |
||||
(cider-emit-interactive-eval-err-output err)) |
||||
|
||||
(defun cider-inspector--done-handler (buffer) |
||||
(when (get-buffer cider-inspector-buffer) |
||||
(with-current-buffer buffer |
||||
(cider-popup-buffer-display cider-inspector-buffer t)))) |
||||
|
||||
(defun cider-inspector-response-handler (buffer) |
||||
"Create an inspector response handler for BUFFER. |
||||
|
||||
The \"value\" slot of each successive response (if it exists) will be |
||||
rendered into `cider-inspector-buffer'. Once a response is received with a |
||||
\"status\" slot containing \"done\", `cider-inspector-buffer' will be |
||||
displayed. |
||||
|
||||
Used for all inspector nREPL ops." |
||||
(nrepl-make-response-handler buffer |
||||
#'cider-inspector--value-handler |
||||
#'cider-inspector--out-handler |
||||
#'cider-inspector--err-handler |
||||
#'cider-inspector--done-handler)) |
||||
|
||||
(defun cider-inspect-expr (expr ns) |
||||
(cider--prep-interactive-eval expr) |
||||
(cider-nrepl-send-request (append (nrepl--eval-request expr (cider-current-session) ns) |
||||
(list "inspect" "true" |
||||
"page-size" (or cider-inspector-page-size 32))) |
||||
(cider-inspector-response-handler (current-buffer)))) |
||||
|
||||
(defun cider-inspector-pop () |
||||
(interactive) |
||||
(cider-nrepl-send-request (list "op" "inspect-pop" |
||||
"session" (cider-current-session)) |
||||
(cider-inspector-response-handler (current-buffer)))) |
||||
|
||||
(defun cider-inspector-push (idx) |
||||
(cider-nrepl-send-request (list "op" "inspect-push" |
||||
"idx" (number-to-string idx) |
||||
"session" (cider-current-session)) |
||||
(cider-inspector-response-handler (current-buffer)))) |
||||
|
||||
(defun cider-inspector-refresh () |
||||
(interactive) |
||||
(cider-nrepl-send-request (list "op" "inspect-refresh" |
||||
"session" (cider-current-session)) |
||||
(cider-inspector-response-handler (current-buffer)))) |
||||
|
||||
(defun cider-inspector-next-page () |
||||
"Jump to the next page when inspecting a paginated sequence/map. |
||||
|
||||
Does nothing if already on the last page." |
||||
(interactive) |
||||
(cider-nrepl-send-request (list "op" "inspect-next-page" |
||||
"session" (cider-current-session)) |
||||
(cider-inspector-response-handler (current-buffer)))) |
||||
|
||||
(defun cider-inspector-prev-page () |
||||
"Jump to the previous page when expecting a paginated sequence/map. |
||||
|
||||
Does nothing if already on the first page." |
||||
(interactive) |
||||
(cider-nrepl-send-request (list "op" "inspect-prev-page" |
||||
"session" (cider-current-session)) |
||||
(cider-inspector-response-handler (current-buffer)))) |
||||
|
||||
(defun cider-inspector-set-page-size (page-size) |
||||
"Set the page size in pagination mode to the specified value. |
||||
|
||||
Current page will be reset to zero." |
||||
(interactive "nPage size:") |
||||
(cider-nrepl-send-request (list "op" "inspect-set-page-size" |
||||
"session" (cider-current-session) |
||||
"page-size" page-size) |
||||
(cider-inspector-response-handler (current-buffer)))) |
||||
|
||||
;; Render Inspector from Structured Values |
||||
(defun cider-irender (buffer str) |
||||
(with-current-buffer buffer |
||||
(cider-inspector-mode) |
||||
(let ((inhibit-read-only t)) |
||||
(condition-case nil |
||||
(cider-irender* (car (read-from-string str))) |
||||
(error (insert "\nInspector error for: " str)))) |
||||
(goto-char (point-min)))) |
||||
|
||||
(defun cider-irender* (elements) |
||||
(dolist (el elements) |
||||
(cider-irender-el* el))) |
||||
|
||||
(defun cider-irender-el* (el) |
||||
(cond ((symbolp el) (insert (symbol-name el))) |
||||
((stringp el) (insert (propertize el 'font-lock-face 'font-lock-keyword-face))) |
||||
((and (consp el) (eq (car el) :newline)) |
||||
(insert "\n")) |
||||
((and (consp el) (eq (car el) :value)) |
||||
(cider-irender-value (cadr el) (cl-caddr el))) |
||||
(t (message "Unrecognized inspector object: %s" el)))) |
||||
|
||||
(defun cider-irender-value (value idx) |
||||
(cider-propertize-region |
||||
(list 'cider-value-idx idx |
||||
'mouse-face 'highlight) |
||||
(cider-irender-el* (cider-font-lock-as-clojure value)))) |
||||
|
||||
|
||||
;; =================================================== |
||||
;; Inspector Navigation (lifted from SLIME inspector) |
||||
;; =================================================== |
||||
|
||||
(defun cider-find-inspectable-object (direction limit) |
||||
"Find the next/previous inspectable object. |
||||
DIRECTION can be either 'next or 'prev. |
||||
LIMIT is the maximum or minimum position in the current buffer. |
||||
|
||||
Return a list of two values: If an object could be found, the |
||||
starting position of the found object and T is returned; |
||||
otherwise LIMIT and NIL is returned." |
||||
(let ((finder (cl-ecase direction |
||||
(next 'next-single-property-change) |
||||
(prev 'previous-single-property-change)))) |
||||
(let ((prop nil) (curpos (point))) |
||||
(while (and (not prop) (not (= curpos limit))) |
||||
(let ((newpos (funcall finder curpos 'cider-value-idx nil limit))) |
||||
(setq prop (get-text-property newpos 'cider-value-idx)) |
||||
(setq curpos newpos))) |
||||
(list curpos (and prop t))))) |
||||
|
||||
(defun cider-inspector-next-inspectable-object (arg) |
||||
"Move point to the next inspectable object. |
||||
With optional ARG, move across that many objects. |
||||
If ARG is negative, move backwards." |
||||
(interactive "p") |
||||
(let ((maxpos (point-max)) (minpos (point-min)) |
||||
(previously-wrapped-p nil)) |
||||
;; Forward. |
||||
(while (> arg 0) |
||||
(cl-destructuring-bind (pos foundp) |
||||
(cider-find-inspectable-object 'next maxpos) |
||||
(if foundp |
||||
(progn (goto-char pos) (setq arg (1- arg)) |
||||
(setq previously-wrapped-p nil)) |
||||
(if (not previously-wrapped-p) ; cycle detection |
||||
(progn (goto-char minpos) (setq previously-wrapped-p t)) |
||||
(error "No inspectable objects"))))) |
||||
;; Backward. |
||||
(while (< arg 0) |
||||
(cl-destructuring-bind (pos foundp) |
||||
(cider-find-inspectable-object 'prev minpos) |
||||
;; CIDER-OPEN-INSPECTOR inserts the title of an inspector page |
||||
;; as a presentation at the beginning of the buffer; skip |
||||
;; that. (Notice how this problem can not arise in ``Forward.'') |
||||
(if (and foundp (/= pos minpos)) |
||||
(progn (goto-char pos) (setq arg (1+ arg)) |
||||
(setq previously-wrapped-p nil)) |
||||
(if (not previously-wrapped-p) ; cycle detection |
||||
(progn (goto-char maxpos) (setq previously-wrapped-p t)) |
||||
(error "No inspectable objects"))))))) |
||||
|
||||
(defun cider-inspector-previous-inspectable-object (arg) |
||||
"Move point to the previous inspectable object. |
||||
With optional ARG, move across that many objects. |
||||
If ARG is negative, move forwards." |
||||
(interactive "p") |
||||
(cider-inspector-next-inspectable-object (- arg))) |
||||
|
||||
(defun cider-inspector-property-at-point () |
||||
(let* ((properties '(cider-value-idx cider-range-button |
||||
cider-action-number)) |
||||
(find-property |
||||
(lambda (point) |
||||
(cl-loop for property in properties |
||||
for value = (get-text-property point property) |
||||
when value |
||||
return (list property value))))) |
||||
(or (funcall find-property (point)) |
||||
(funcall find-property (1- (point)))))) |
||||
|
||||
(defun cider-inspector-operate-on-point () |
||||
"Invoke the command for the text at point. |
||||
1. If point is on a value then recursivly call the inspector on |
||||
that value. |
||||
2. If point is on an action then call that action. |
||||
3. If point is on a range-button fetch and insert the range." |
||||
(interactive) |
||||
(cl-destructuring-bind (property value) |
||||
(cider-inspector-property-at-point) |
||||
(cl-case property |
||||
(cider-value-idx |
||||
(cider-inspector-push value)) |
||||
;; TODO: range and action handlers |
||||
(t (error "No object at point"))))) |
||||
|
||||
(defun cider-inspector-operate-on-click (event) |
||||
"Move to EVENT's position and operate the part." |
||||
(interactive "@e") |
||||
(let ((point (posn-point (event-end event)))) |
||||
(cond ((and point |
||||
(or (get-text-property point 'cider-value-idx))) |
||||
;; (get-text-property point 'cider-range-button) |
||||
;; (get-text-property point 'cider-action-number))) |
||||
(goto-char point) |
||||
(cider-inspector-operate-on-point)) |
||||
(t |
||||
(error "No clickable part here"))))) |
||||
|
||||
(provide 'cider-inspector) |
||||
|
||||
;;; cider-inspector.el ends here |
||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,208 @@
|
||||
;;; cider-macroexpansion.el --- Macro expansion support -*- lexical-binding: t -*- |
||||
|
||||
;; Copyright © 2012-2015 Tim King, Phil Hagelberg |
||||
;; Copyright © 2013-2015 Bozhidar Batsov, Hugo Duncan, Steve Purcell |
||||
;; |
||||
;; Author: Tim King <kingtim@gmail.com> |
||||
;; Phil Hagelberg <technomancy@gmail.com> |
||||
;; Bozhidar Batsov <bozhidar@batsov.com> |
||||
;; Hugo Duncan <hugo@hugoduncan.org> |
||||
;; Steve Purcell <steve@sanityinc.com> |
||||
|
||||
;; This program 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 program 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 program. If not, see <http://www.gnu.org/licenses/>. |
||||
|
||||
;; This file is not part of GNU Emacs. |
||||
|
||||
;;; Commentary: |
||||
|
||||
;; Macro expansion support. |
||||
|
||||
;;; Code: |
||||
|
||||
(require 'cider-mode) |
||||
(require 'cider-compat) |
||||
|
||||
(defconst cider-macroexpansion-buffer "*cider-macroexpansion*") |
||||
|
||||
(push cider-macroexpansion-buffer cider-ancillary-buffers) |
||||
|
||||
(defcustom cider-macroexpansion-display-namespaces 'tidy |
||||
"Determines if namespaces are displayed in the macroexpansion buffer. |
||||
Possible values are: |
||||
|
||||
'qualified ;=> Vars are fully-qualified in the expansion |
||||
'none ;=> Vars are displayed without namespace qualification |
||||
'tidy ;=> Vars that are :refer-ed or defined in the current namespace are |
||||
displayed with their simple name, non-refered vars from other |
||||
namespaces are refered using the alias for that namespace (if |
||||
defined), other vars are displayed fully qualified." |
||||
:type '(choice (const :tag "Suppress namespaces" none) |
||||
(const :tag "Show fully-qualified namespaces" qualified) |
||||
(const :tag "Show namespace aliases" tidy)) |
||||
:group 'cider |
||||
:package-version '(cider . "0.7.0")) |
||||
|
||||
(defcustom cider-macroexpansion-print-metadata nil |
||||
"Determines if metadata is included in macroexpansion results." |
||||
:type 'boolean |
||||
:group 'cider |
||||
:package-version '(cider . "0.9.0")) |
||||
|
||||
(defun cider-sync-request:macroexpand (expander expr &optional display-namespaces) |
||||
"Macroexpand, using EXPANDER, the given EXPR. |
||||
The default for DISPLAY-NAMESPACES is taken from |
||||
`cider-macroexpansion-display-namespaces'." |
||||
(cider-ensure-op-supported "macroexpand") |
||||
(thread-first (list "op" "macroexpand" |
||||
"expander" expander |
||||
"code" expr |
||||
"ns" (cider-current-ns) |
||||
"display-namespaces" |
||||
(or display-namespaces |
||||
(symbol-name cider-macroexpansion-display-namespaces))) |
||||
(append (when cider-macroexpansion-print-metadata |
||||
(list "print-meta" "true"))) |
||||
(cider-nrepl-send-sync-request) |
||||
(nrepl-dict-get "expansion"))) |
||||
|
||||
(defun cider-macroexpand-undo (&optional arg) |
||||
"Undo the last macroexpansion, using `undo-only'. |
||||
ARG is passed along to `undo-only'." |
||||
(interactive) |
||||
(let ((inhibit-read-only t)) |
||||
(undo-only arg))) |
||||
|
||||
(defvar cider-last-macroexpand-expression nil |
||||
"Specify the last macroexpansion preformed. |
||||
This variable specifies both what was expanded and the expander.") |
||||
|
||||
(defun cider-macroexpand-expr (expander expr) |
||||
"Macroexpand, use EXPANDER, the given EXPR." |
||||
(let* ((expansion (cider-sync-request:macroexpand expander expr))) |
||||
(setq cider-last-macroexpand-expression expr) |
||||
(cider-initialize-macroexpansion-buffer expansion (cider-current-ns)))) |
||||
|
||||
(defun cider-macroexpand-expr-inplace (expander) |
||||
"Substitute the form preceding point with its macroexpansion using EXPANDER." |
||||
(interactive) |
||||
(let* ((expansion (cider-sync-request:macroexpand expander (cider-last-sexp))) |
||||
(bounds (cons (save-excursion (clojure-backward-logical-sexp 1) (point)) (point)))) |
||||
(cider-redraw-macroexpansion-buffer |
||||
expansion (current-buffer) (car bounds) (cdr bounds)))) |
||||
|
||||
(defun cider-macroexpand-again () |
||||
"Repeat the last macroexpansion." |
||||
(interactive) |
||||
(cider-initialize-macroexpansion-buffer cider-last-macroexpand-expression (cider-current-ns))) |
||||
|
||||
;;;###autoload |
||||
(defun cider-macroexpand-1 (&optional prefix) |
||||
"Invoke 'macroexpand-1' on the expression preceding point. |
||||
If invoked with a PREFIX argument, use 'macroexpand' instead of |
||||
'macroexpand-1'." |
||||
(interactive "P") |
||||
(let ((expander (if prefix "macroexpand" "macroexpand-1"))) |
||||
(cider-macroexpand-expr expander (cider-last-sexp)))) |
||||
|
||||
(defun cider-macroexpand-1-inplace (&optional prefix) |
||||
"Perform inplace 'macroexpand-1' on the expression preceding point. |
||||
If invoked with a PREFIX argument, use 'macroexpand' instead of |
||||
'macroexpand-1'." |
||||
(interactive "P") |
||||
(let ((expander (if prefix "macroexpand" "macroexpand-1"))) |
||||
(cider-macroexpand-expr-inplace expander))) |
||||
|
||||
;;;###autoload |
||||
(defun cider-macroexpand-all () |
||||
"Invoke 'clojure.walk/macroexpand-all' on the expression preceding point." |
||||
(interactive) |
||||
(cider-macroexpand-expr "macroexpand-all" (cider-last-sexp))) |
||||
|
||||
(defun cider-macroexpand-all-inplace () |
||||
"Perform inplace 'clojure.walk/macroexpand-all' on the expression preceding point." |
||||
(interactive) |
||||
(cider-macroexpand-expr-inplace "macroexpand-all")) |
||||
|
||||
(defun cider-initialize-macroexpansion-buffer (expansion ns) |
||||
"Create a new Macroexpansion buffer with EXPANSION and namespace NS." |
||||
(pop-to-buffer (cider-create-macroexpansion-buffer)) |
||||
(setq cider-buffer-ns ns) |
||||
(setq buffer-undo-list nil) |
||||
(let ((inhibit-read-only t) |
||||
(buffer-undo-list t)) |
||||
(erase-buffer) |
||||
(insert (format "%s" expansion)) |
||||
(goto-char (point-max)) |
||||
(cider--font-lock-ensure))) |
||||
|
||||
(defun cider-redraw-macroexpansion-buffer (expansion buffer start end) |
||||
"Redraw the macroexpansion with new EXPANSION. |
||||
Text in BUFFER from START to END is replaced with new expansion, |
||||
and point is placed after the expanded form." |
||||
(with-current-buffer buffer |
||||
(let ((buffer-read-only nil)) |
||||
(goto-char start) |
||||
(delete-region start end) |
||||
(insert (format "%s" expansion)) |
||||
(goto-char start) |
||||
(indent-sexp) |
||||
(forward-sexp)))) |
||||
|
||||
(declare-function cider-mode "cider-mode") |
||||
|
||||
(defun cider-create-macroexpansion-buffer () |
||||
"Create a new macroexpansion buffer." |
||||
(with-current-buffer (cider-popup-buffer cider-macroexpansion-buffer t) |
||||
(clojure-mode) |
||||
(cider-mode -1) |
||||
(cider-macroexpansion-mode 1) |
||||
(current-buffer))) |
||||
|
||||
(defvar cider-macroexpansion-mode-map |
||||
(let ((map (make-sparse-keymap))) |
||||
(define-key map (kbd "g") #'cider-macroexpand-again) |
||||
(define-key map (kbd "q") #'cider-popup-buffer-quit-function) |
||||
(define-key map (kbd "d") #'cider-doc) |
||||
(define-key map (kbd "j") #'cider-javadoc) |
||||
(define-key map (kbd ".") #'cider-find-var) |
||||
(easy-menu-define cider-macroexpansion-mode-menu map |
||||
"Menu for CIDER's doc mode" |
||||
'("Macroexpansion" |
||||
["Restart expansion" cider-macroexpand-again] |
||||
["Macroexpand-1" cider-macroexpand-1-inplace] |
||||
["Macroexpand-all" cider-macroexpand-all-inplace] |
||||
["Go to source" cider-find-var] |
||||
["Go to doc" cider-doc] |
||||
["Go to Javadoc" cider-docview-javadoc] |
||||
["Quit" cider-popup-buffer-quit-function])) |
||||
(cl-labels ((redefine-key (from to) |
||||
(dolist (mapping (where-is-internal from cider-mode-map)) |
||||
(define-key map mapping to)))) |
||||
(redefine-key 'cider-macroexpand-1 #'cider-macroexpand-1-inplace) |
||||
(redefine-key 'cider-macroexpand-all #'cider-macroexpand-all-inplace) |
||||
(redefine-key 'advertised-undo #'cider-macroexpand-undo) |
||||
(redefine-key 'undo #'cider-macroexpand-undo)) |
||||
map)) |
||||
|
||||
(define-minor-mode cider-macroexpansion-mode |
||||
"Minor mode for CIDER macroexpansion. |
||||
|
||||
\\{cider-macroexpansion-mode-map}" |
||||
nil |
||||
" Macroexpand" |
||||
cider-macroexpansion-mode-map) |
||||
|
||||
(provide 'cider-macroexpansion) |
||||
|
||||
;;; cider-macroexpansion.el ends here |
||||
@ -0,0 +1,12 @@
|
||||
(define-package "cider" "20151022.28" "Clojure Interactive Development Environment that Rocks" |
||||
'((clojure-mode "5.0.0") |
||||
(pkg-info "0.4") |
||||
(emacs "24.3") |
||||
(queue "0.1.1") |
||||
(spinner "1.4") |
||||
(seq "1.9")) |
||||
:url "http://www.github.com/clojure-emacs/cider" :keywords |
||||
'("languages" "clojure" "cider")) |
||||
;; Local Variables: |
||||
;; no-byte-compile: t |
||||
;; End: |
||||
@ -0,0 +1,122 @@
|
||||
;;; cider-popup.el --- Creating and quitting popup buffers -*- lexical-binding: t; -*- |
||||
|
||||
;; Copyright (C) 2015 Artur Malabarba |
||||
|
||||
;; Author: Artur Malabarba <bruce.connor.am@gmail.com> |
||||
|
||||
;; This program 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 program 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 program. If not, see <http://www.gnu.org/licenses/>. |
||||
|
||||
;;; Code: |
||||
|
||||
(require 'nrepl-client) |
||||
(require 'cider-compat) |
||||
|
||||
(define-minor-mode cider-popup-buffer-mode |
||||
"Mode for CIDER popup buffers" |
||||
nil |
||||
(" cider-tmp") |
||||
'(("q" . cider-popup-buffer-quit-function))) |
||||
|
||||
(defvar-local cider-popup-buffer-quit-function #'cider-popup-buffer-quit |
||||
"The function that is used to quit a temporary popup buffer.") |
||||
|
||||
(defun cider-popup-buffer-quit-function (&optional kill-buffer-p) |
||||
"Wrapper to invoke the function `cider-popup-buffer-quit-function'. |
||||
KILL-BUFFER-P is passed along." |
||||
(interactive) |
||||
(funcall cider-popup-buffer-quit-function kill-buffer-p)) |
||||
|
||||
(defun cider-popup-buffer (name &optional select mode ancillary) |
||||
"Create new popup buffer called NAME. |
||||
If SELECT is non-nil, select the newly created window. |
||||
If major MODE is non-nil, enable it for the popup buffer. |
||||
If ANCILLARY is non-nil, the buffer is added to `cider-ancillary-buffers' |
||||
and automatically removed when killed." |
||||
(thread-first (cider-make-popup-buffer name mode ancillary) |
||||
(cider-popup-buffer-display select))) |
||||
|
||||
(defun cider-popup-buffer-display (buffer &optional select) |
||||
"Display BUFFER. |
||||
If SELECT is non-nil, select the BUFFER." |
||||
(let ((window (get-buffer-window buffer))) |
||||
(when window |
||||
(with-current-buffer buffer |
||||
(set-window-point window (point)))) |
||||
;; If the buffer we are popping up is already displayed in the selected |
||||
;; window, the below `inhibit-same-window' logic will cause it to be |
||||
;; displayed twice - so we early out in this case. Note that we must check |
||||
;; `selected-window', as async request handlers are executed in the context |
||||
;; of the current connection buffer (i.e. `current-buffer' is dynamically |
||||
;; bound to that). |
||||
(unless (eq window (selected-window)) |
||||
;; Non nil `inhibit-same-window' ensures that current window is not covered |
||||
(if select |
||||
(pop-to-buffer buffer `(nil . ((inhibit-same-window . ,pop-up-windows)))) |
||||
(display-buffer buffer `(nil . ((inhibit-same-window . ,pop-up-windows))))))) |
||||
buffer) |
||||
|
||||
(defun cider-popup-buffer-quit (&optional kill) |
||||
"Quit the current (temp) window and bury its buffer using `quit-restore-window'. |
||||
If prefix argument KILL is non-nil, kill the buffer instead of burying it." |
||||
(interactive) |
||||
(quit-restore-window (selected-window) (if kill 'kill 'append))) |
||||
|
||||
(defvar-local cider-popup-output-marker nil) |
||||
|
||||
(defvar cider-ancillary-buffers (list nrepl-message-buffer-name)) |
||||
|
||||
(defun cider-make-popup-buffer (name &optional mode ancillary) |
||||
"Create a temporary buffer called NAME using major MODE (if specified). |
||||
If ANCILLARY is non-nil, the buffer is added to `cider-ancillary-buffers' |
||||
and automatically removed when killed." |
||||
(with-current-buffer (get-buffer-create name) |
||||
(kill-all-local-variables) |
||||
(setq buffer-read-only nil) |
||||
(erase-buffer) |
||||
(when mode |
||||
(funcall mode)) |
||||
(cider-popup-buffer-mode 1) |
||||
(setq cider-popup-output-marker (point-marker)) |
||||
(setq buffer-read-only t) |
||||
(when ancillary |
||||
(add-to-list 'cider-ancillary-buffers name) |
||||
(add-hook 'kill-buffer-hook |
||||
(lambda () (setq cider-ancillary-buffers (remove name cider-ancillary-buffers))) |
||||
nil 'local)) |
||||
(current-buffer))) |
||||
|
||||
(defun cider-emit-into-popup-buffer (buffer value &optional face) |
||||
"Emit into BUFFER the provided VALUE." |
||||
;; Long string output renders emacs unresponsive and users might intentionally |
||||
;; kill the frozen popup buffer. Therefore, we don't re-create the buffer and |
||||
;; silently ignore the output. |
||||
(when (buffer-live-p buffer) |
||||
(with-current-buffer buffer |
||||
(let ((inhibit-read-only t) |
||||
(buffer-undo-list t) |
||||
(moving (= (point) cider-popup-output-marker))) |
||||
(save-excursion |
||||
(goto-char cider-popup-output-marker) |
||||
(let ((value-str (format "%s" value))) |
||||
(when face |
||||
(if (fboundp 'add-face-text-property) |
||||
(add-face-text-property 0 (length value-str) face nil value-str) |
||||
(add-text-properties 0 (length value-str) (list 'face face) value-str))) |
||||
(insert value-str)) |
||||
(indent-sexp) |
||||
(set-marker cider-popup-output-marker (point))) |
||||
(when moving (goto-char cider-popup-output-marker)))))) |
||||
|
||||
(provide 'cider-popup) |
||||
;;; cider-popup.el ends here |
||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,129 @@
|
||||
;;; cider-resolve.el --- Resolve clojure symbols according to current nREPL connection |
||||
|
||||
;; Copyright © 2015 Artur Malabarba |
||||
|
||||
;; Author: Artur Malabarba <bruce.connor.am@gmail.com> |
||||
|
||||
;; This program 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 program 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 program. If not, see <http://www.gnu.org/licenses/>. |
||||
|
||||
;;; Commentary: |
||||
|
||||
;; The ns cache is a dict of namespaces stored in the connection buffer. This |
||||
;; file offers functions to easily get information about variables from this |
||||
;; cache, given the variable's name and the file's namespace. This |
||||
;; functionality is similar to that offered by the `cider-var-info' function |
||||
;; (and others). The difference is that all functions in this file operate |
||||
;; without contacting the server (they still rely on an active connection |
||||
;; buffer, but no messages are actually exchanged). |
||||
|
||||
;; For this reason, the functions here are well suited for very |
||||
;; performance-sentitive operations, such as font-locking or |
||||
;; indentation. Meanwhile, operations like code-jumping are better off |
||||
;; communicating with the middleware, just in the off chance that the cache is |
||||
;; outdated. |
||||
|
||||
;; Below is a typical entry on this cache dict. Note that clojure.core symbols |
||||
;; are excluded from the refers to save space. |
||||
|
||||
;; "cider.nrepl.middleware.track-state" |
||||
;; (dict "aliases" |
||||
;; (dict "cljs" "cider.nrepl.middleware.util.cljs" |
||||
;; "misc" "cider.nrepl.middleware.util.misc" |
||||
;; "set" "clojure.set") |
||||
;; "interns" (dict a |
||||
;; "assoc-state" (dict "arglists" |
||||
;; (("response" |
||||
;; (dict "as" "msg" "keys" |
||||
;; ("session"))))) |
||||
;; "filter-core" (dict "arglists" |
||||
;; (("refers"))) |
||||
;; "make-transport" (dict "arglists" |
||||
;; (((dict "as" "msg" "keys" |
||||
;; ("transport"))))) |
||||
;; "ns-as-map" (dict "arglists" |
||||
;; (("ns"))) |
||||
;; "ns-cache" (dict) |
||||
;; "relevant-meta" (dict "arglists" |
||||
;; (("var"))) |
||||
;; "update-vals" (dict "arglists" |
||||
;; (("m" "f"))) |
||||
;; "wrap-tracker" (dict "arglists" |
||||
;; (("handler")))) |
||||
;; "refers" (dict "set-descriptor!" "#'clojure.tools.nrepl.middleware/set-descriptor!")) |
||||
|
||||
;;; Code: |
||||
|
||||
(require 'cider-client) |
||||
(require 'nrepl-client) |
||||
(require 'cider-util) |
||||
|
||||
(defvar cider-repl-ns-cache) |
||||
|
||||
(defun cider-resolve--get-in (&rest keys) |
||||
"Return (nrepl-dict-get-in cider-repl-ns-cache KEYS)." |
||||
(when cider-connections |
||||
(with-current-buffer (cider-current-connection) |
||||
(nrepl-dict-get-in cider-repl-ns-cache keys)))) |
||||
|
||||
(defun cider-resolve-alias (ns alias) |
||||
"Return the namespace that ALIAS refers to in namespace NS. |
||||
If it doesn't point anywhere, returns ALIAS." |
||||
(or (cider-resolve--get-in ns "aliases" alias) |
||||
alias)) |
||||
|
||||
(defconst cider-resolve--prefix-regexp "\\`\\(?:#'\\)?\\([^/]+\\)/") |
||||
|
||||
(defun cider-resolve-var (ns var) |
||||
"Return a dict of the metadata of a clojure var VAR in namespace NS. |
||||
VAR is a string. |
||||
Return nil only if VAR cannot be resolved." |
||||
(let* ((var-ns (when (string-match cider-resolve--prefix-regexp var) |
||||
(cider-resolve-alias ns (match-string 1 var)))) |
||||
(name (replace-regexp-in-string cider-resolve--prefix-regexp "" var))) |
||||
(or |
||||
(cider-resolve--get-in (or var-ns ns) "interns" name) |
||||
(unless var-ns |
||||
;; If the var had no prefix, it might be referred. |
||||
(if-let ((referal (cider-resolve--get-in ns "refers" name))) |
||||
(cider-resolve-var ns referal) |
||||
;; Or it might be from core. |
||||
(unless (equal ns "clojure.core") |
||||
(cider-resolve-var "clojure.core" name))))))) |
||||
|
||||
(defun cider-resolve-core-ns () |
||||
"Return a dict of the core namespace for current connection. |
||||
This will be clojure.core or cljs.core depending on `cider-repl-type'." |
||||
(when (cider-connected-p) |
||||
(with-current-buffer (cider-current-connection) |
||||
(cider-resolve--get-in (if (equal cider-repl-type "cljs") |
||||
"cljs.core" |
||||
"clojure.core"))))) |
||||
|
||||
(defun cider-resolve-ns-symbols (ns) |
||||
"Return a plist of all valid symbols in NS. |
||||
Each entry's value is the metadata of the var that the symbol refers to. |
||||
NS can be the namespace name, or a dict of the namespace itself." |
||||
(when-let ((dict (if (stringp ns) |
||||
(cider-resolve--get-in ns) |
||||
ns))) |
||||
(nrepl-dbind-response dict (interns refers aliases) |
||||
(append (cdr interns) |
||||
(nrepl-dict-flat-map (lambda (alias namespace) |
||||
(nrepl-dict-flat-map (lambda (sym meta) |
||||
(list (concat alias "/" sym) meta)) |
||||
(cider-resolve--get-in namespace "interns"))) |
||||
aliases))))) |
||||
|
||||
(provide 'cider-resolve) |
||||
;;; cider-resolve.el ends here |
||||
@ -0,0 +1,71 @@
|
||||
;;; cider-scratch.el --- *scratch* buffer for Clojure -*- lexical-binding: t -*- |
||||
|
||||
;; Copyright © 2014-2015 Bozhidar Batsov |
||||
;; |
||||
;; Author: Tim King <kingtim@gmail.com> |
||||
;; Phil Hagelberg <technomancy@gmail.com> |
||||
;; Bozhidar Batsov <bozhidar@batsov.com> |
||||
;; Hugo Duncan <hugo@hugoduncan.org> |
||||
;; Steve Purcell <steve@sanityinc.com> |
||||
|
||||
;; This program 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 program 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 program. If not, see <http://www.gnu.org/licenses/>. |
||||
|
||||
;; This file is not part of GNU Emacs. |
||||
|
||||
;;; Commentary: |
||||
|
||||
;; Imitate Emacs's *scratch* buffer. |
||||
|
||||
;;; Code: |
||||
|
||||
(require 'cider-interaction) |
||||
(require 'clojure-mode) |
||||
|
||||
(defvar cider-clojure-interaction-mode-map |
||||
(let ((map (make-sparse-keymap))) |
||||
(set-keymap-parent map clojure-mode-map) |
||||
(define-key map (kbd "C-j") #'cider-eval-print-last-sexp) |
||||
map)) |
||||
|
||||
(defconst cider-scratch-buffer-name "*cider-scratch*") |
||||
|
||||
;;;###autoload |
||||
(defun cider-scratch () |
||||
"Create a scratch buffer." |
||||
(interactive) |
||||
(pop-to-buffer (cider-find-or-create-scratch-buffer))) |
||||
|
||||
(defun cider-find-or-create-scratch-buffer () |
||||
"Find or create the scratch buffer." |
||||
(or (get-buffer cider-scratch-buffer-name) |
||||
(cider-create-scratch-buffer))) |
||||
|
||||
(define-derived-mode cider-clojure-interaction-mode clojure-mode "Clojure Interaction" |
||||
"Major mode for typing and evaluating Clojure forms. |
||||
Like Lisp mode except that \\[cider-eval-print-last-sexp] evals the Lisp expression |
||||
before point, and prints its value into the buffer, advancing point. |
||||
|
||||
\\{cider-clojure-interaction-mode-map}") |
||||
|
||||
(defun cider-create-scratch-buffer () |
||||
"Create a new scratch buffer." |
||||
(with-current-buffer (get-buffer-create cider-scratch-buffer-name) |
||||
(cider-clojure-interaction-mode) |
||||
(insert ";; This buffer is for Clojure experiments and evaluation.\n" |
||||
";; Press C-j to evaluate the last expression.\n\n") |
||||
(current-buffer))) |
||||
|
||||
(provide 'cider-scratch) |
||||
|
||||
;;; cider-scratch.el ends here |
||||
@ -0,0 +1,154 @@
|
||||
;;; cider-selector.el --- Buffer selection command inspired by SLIME's selector -*- lexical-binding: t -*- |
||||
|
||||
;; Copyright © 2012-2015 Tim King, Phil Hagelberg |
||||
;; Copyright © 2013-2015 Bozhidar Batsov, Hugo Duncan, Steve Purcell |
||||
;; |
||||
;; Author: Tim King <kingtim@gmail.com> |
||||
;; Phil Hagelberg <technomancy@gmail.com> |
||||
;; Bozhidar Batsov <bozhidar@batsov.com> |
||||
;; Hugo Duncan <hugo@hugoduncan.org> |
||||
;; Steve Purcell <steve@sanityinc.com> |
||||
|
||||
;; This program 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 program 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 program. If not, see <http://www.gnu.org/licenses/>. |
||||
|
||||
;; This file is not part of GNU Emacs. |
||||
|
||||
;;; Commentary: |
||||
|
||||
;; Buffer selection command inspired by SLIME's selector. |
||||
|
||||
;;; Code: |
||||
|
||||
(require 'cider-client) |
||||
(require 'cider-interaction) |
||||
|
||||
(defconst cider-selector-help-buffer "*Selector Help*" |
||||
"The name of the selector's help buffer.") |
||||
|
||||
(defvar cider-selector-methods nil |
||||
"List of buffer-selection methods for the `cider-selector' command. |
||||
Each element is a list (KEY DESCRIPTION FUNCTION). |
||||
DESCRIPTION is a one-line description of what the key selects.") |
||||
|
||||
(defvar cider-selector-other-window nil |
||||
"If non-nil use `switch-to-buffer-other-window'.") |
||||
|
||||
(defun cider--recently-visited-buffer (mode) |
||||
"Return the most recently visited buffer whose `major-mode' is MODE. |
||||
Only considers buffers that are not already visible." |
||||
(cl-loop for buffer in (buffer-list) |
||||
when (and (with-current-buffer buffer (eq major-mode mode)) |
||||
(not (string-match-p "^ " (buffer-name buffer))) |
||||
(null (get-buffer-window buffer 'visible))) |
||||
return buffer |
||||
finally (error "Can't find unshown buffer in %S" mode))) |
||||
|
||||
;;;###autoload |
||||
(defun cider-selector (&optional other-window) |
||||
"Select a new buffer by type, indicated by a single character. |
||||
The user is prompted for a single character indicating the method by |
||||
which to choose a new buffer. The `?' character describes then |
||||
available methods. OTHER-WINDOW provides an optional target. |
||||
|
||||
See `def-cider-selector-method' for defining new methods." |
||||
(interactive) |
||||
(message "Select [%s]: " |
||||
(apply #'string (mapcar #'car cider-selector-methods))) |
||||
(let* ((cider-selector-other-window other-window) |
||||
(ch (save-window-excursion |
||||
(select-window (minibuffer-window)) |
||||
(read-char))) |
||||
(method (cl-find ch cider-selector-methods :key #'car))) |
||||
(cond (method |
||||
(funcall (cl-caddr method))) |
||||
(t |
||||
(message "No method for character: ?\\%c" ch) |
||||
(ding) |
||||
(sleep-for 1) |
||||
(discard-input) |
||||
(cider-selector))))) |
||||
|
||||
(defmacro def-cider-selector-method (key description &rest body) |
||||
"Define a new `cider-select' buffer selection method. |
||||
|
||||
KEY is the key the user will enter to choose this method. |
||||
|
||||
DESCRIPTION is a one-line sentence describing how the method |
||||
selects a buffer. |
||||
|
||||
BODY is a series of forms which are evaluated when the selector |
||||
is chosen. The returned buffer is selected with |
||||
`switch-to-buffer'." |
||||
(let ((method `(lambda () |
||||
(let ((buffer (progn ,@body))) |
||||
(cond ((not (get-buffer buffer)) |
||||
(message "No such buffer: %S" buffer) |
||||
(ding)) |
||||
((get-buffer-window buffer) |
||||
(select-window (get-buffer-window buffer))) |
||||
(cider-selector-other-window |
||||
(switch-to-buffer-other-window buffer)) |
||||
(t |
||||
(switch-to-buffer buffer))))))) |
||||
`(setq cider-selector-methods |
||||
(cl-sort (cons (list ,key ,description ,method) |
||||
(cl-remove ,key cider-selector-methods :key #'car)) |
||||
#'< :key #'car)))) |
||||
|
||||
(def-cider-selector-method ?? "Selector help buffer." |
||||
(ignore-errors (kill-buffer cider-selector-help-buffer)) |
||||
(with-current-buffer (get-buffer-create cider-selector-help-buffer) |
||||
(insert "CIDER Selector Methods:\n\n") |
||||
(cl-loop for (key line nil) in cider-selector-methods |
||||
do (insert (format "%c:\t%s\n" key line))) |
||||
(goto-char (point-min)) |
||||
(help-mode) |
||||
(display-buffer (current-buffer) t)) |
||||
(cider-selector) |
||||
(current-buffer)) |
||||
|
||||
(cl-pushnew (list ?4 "Select in other window" (lambda () (cider-selector t))) |
||||
cider-selector-methods :key #'car) |
||||
|
||||
(def-cider-selector-method ?c |
||||
"Most recently visited clojure-mode buffer." |
||||
(cider--recently-visited-buffer 'clojure-mode)) |
||||
|
||||
(def-cider-selector-method ?e |
||||
"Most recently visited emacs-lisp-mode buffer." |
||||
(cider--recently-visited-buffer 'emacs-lisp-mode)) |
||||
|
||||
(def-cider-selector-method ?q "Abort." |
||||
(top-level)) |
||||
|
||||
(def-cider-selector-method ?r |
||||
"Current REPL buffer." |
||||
(cider-current-repl-buffer)) |
||||
|
||||
(def-cider-selector-method ?n |
||||
"Connections browser buffer." |
||||
(cider-connection-browser) |
||||
cider--connection-browser-buffer-name) |
||||
|
||||
(def-cider-selector-method ?m |
||||
"*nrepl-messages* buffer." |
||||
nrepl-message-buffer-name) |
||||
|
||||
(def-cider-selector-method ?x |
||||
"*cider-error* buffer." |
||||
cider-error-buffer) |
||||
|
||||
(provide 'cider-selector) |
||||
|
||||
;;; cider-selector.el ends here |
||||
@ -0,0 +1,610 @@
|
||||
;;; cider-stacktrace.el --- Stacktrace navigator -*- lexical-binding: t -*- |
||||
|
||||
;; Copyright © 2014-2015 Jeff Valk |
||||
|
||||
;; Author: Jeff Valk <jv@jeffvalk.com> |
||||
|
||||
;; This program 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 program 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 program. If not, see <http://www.gnu.org/licenses/>. |
||||
|
||||
;; This file is not part of GNU Emacs. |
||||
|
||||
;;; Commentary: |
||||
|
||||
;; Stacktrace filtering and stack frame source navigation |
||||
|
||||
;;; Code: |
||||
|
||||
(require 'cl-lib) |
||||
(require 'cider-popup) |
||||
(require 'button) |
||||
(require 'easymenu) |
||||
(require 'cider-common) |
||||
(require 'cider-compat) |
||||
(require 'cider-client) |
||||
(require 'cider-util) |
||||
|
||||
(require 'seq) |
||||
|
||||
;; Variables |
||||
|
||||
(defgroup cider-stacktrace nil |
||||
"Stacktrace filtering and navigation." |
||||
:prefix "cider-stacktrace-" |
||||
:group 'cider) |
||||
|
||||
(defcustom cider-stacktrace-fill-column t |
||||
"Fill column for error messages in stacktrace display. |
||||
If nil, messages will not be wrapped. If truthy but non-numeric, |
||||
`fill-column' will be used." |
||||
:type 'list |
||||
:group 'cider-stacktrace |
||||
:package-version '(cider . "0.7.0")) |
||||
|
||||
(defcustom cider-stacktrace-default-filters '(tooling dup) |
||||
"Frame types to omit from initial stacktrace display." |
||||
:type 'list |
||||
:group 'cider-stacktrace |
||||
:package-version '(cider . "0.6.0")) |
||||
|
||||
(defcustom cider-stacktrace-print-length 50 |
||||
"Set the maximum length of sequences in displayed cause data. |
||||
|
||||
This sets the value of Clojure's `*print-length*` when pretty printing the |
||||
`ex-data` map for exception causes in the stacktrace that are instances of |
||||
`IExceptionInfo`. |
||||
|
||||
Be advised that setting this to `nil` will cause the attempted printing of |
||||
infinite data structures." |
||||
:type '(choice integer (const nil)) |
||||
:group 'cider-stacktrace |
||||
:package-version '(cider . "0.9.0")) |
||||
|
||||
(defcustom cider-stacktrace-print-level 50 |
||||
"Set the maximum level of nesting in displayed cause data. |
||||
|
||||
This sets the value of Clojure's `*print-level*` when pretty printing the |
||||
`ex-data` map for exception causes in the stacktrace that are instances of |
||||
`IExceptionInfo`. |
||||
|
||||
Be advised that setting this to `nil` will cause the attempted printing of |
||||
cyclical data structures." |
||||
:type '(choice integer (const nil)) |
||||
:group 'cider-stacktrace |
||||
:package-version '(cider . "0.8.0")) |
||||
|
||||
(defvar cider-stacktrace-detail-max 2 |
||||
"The maximum detail level for causes.") |
||||
|
||||
(defvar-local cider-stacktrace-hidden-frame-count 0) |
||||
(defvar-local cider-stacktrace-filters nil) |
||||
(defvar-local cider-stacktrace-prior-filters nil) |
||||
(defvar-local cider-stacktrace-cause-visibility nil) |
||||
|
||||
(defconst cider-error-buffer "*cider-error*") |
||||
(add-to-list 'cider-ancillary-buffers cider-error-buffer) |
||||
|
||||
;; Faces |
||||
|
||||
(defface cider-stacktrace-error-class-face |
||||
'((t (:inherit font-lock-warning-face))) |
||||
"Face for exception class names" |
||||
:group 'cider-stacktrace |
||||
:package-version '(cider . "0.6.0")) |
||||
|
||||
(defface cider-stacktrace-error-message-face |
||||
'((t (:inherit font-lock-doc-face))) |
||||
"Face for exception messages" |
||||
:group 'cider-stacktrace |
||||
:package-version '(cider . "0.7.0")) |
||||
|
||||
(defface cider-stacktrace-filter-shown-face |
||||
'((t (:inherit button :underline t :weight normal))) |
||||
"Face for filter buttons representing frames currently visible" |
||||
:group 'cider-stacktrace |
||||
:package-version '(cider . "0.6.0")) |
||||
|
||||
(defface cider-stacktrace-filter-hidden-face |
||||
'((t (:inherit button :underline nil :weight normal))) |
||||
"Face for filter buttons representing frames currently filtered out" |
||||
:group 'cider-stacktrace |
||||
:package-version '(cider . "0.6.0")) |
||||
|
||||
(defface cider-stacktrace-face |
||||
'((t (:inherit default))) |
||||
"Face for stack frame text" |
||||
:group 'cider-stacktrace |
||||
:package-version '(cider . "0.6.0")) |
||||
|
||||
(defface cider-stacktrace-ns-face |
||||
'((t (:inherit font-lock-comment-face))) |
||||
"Face for stack frame namespace name" |
||||
:group 'cider-stacktrace |
||||
:package-version '(cider . "0.6.0")) |
||||
|
||||
(defface cider-stacktrace-fn-face |
||||
'((t (:inherit default :weight bold))) |
||||
"Face for stack frame function name" |
||||
:group 'cider-stacktrace |
||||
:package-version '(cider . "0.6.0")) |
||||
|
||||
|
||||
;; Colors & Theme Support |
||||
|
||||
(defvar cider-stacktrace-frames-background-color |
||||
(cider-scale-background-color) |
||||
"Background color for stacktrace frames.") |
||||
|
||||
(defadvice enable-theme (after cider-stacktrace-adapt-to-theme activate) |
||||
"When theme is changed, update `cider-stacktrace-frames-background-color'." |
||||
(setq cider-stacktrace-frames-background-color (cider-scale-background-color))) |
||||
|
||||
|
||||
;; Mode & key bindings |
||||
|
||||
(defvar cider-stacktrace-mode-map |
||||
(let ((map (make-sparse-keymap))) |
||||
(define-key map (kbd "M-p") #'cider-stacktrace-previous-cause) |
||||
(define-key map (kbd "M-n") #'cider-stacktrace-next-cause) |
||||
(define-key map (kbd "M-.") #'cider-stacktrace-jump) |
||||
(define-key map "q" #'cider-popup-buffer-quit-function) |
||||
(define-key map "j" #'cider-stacktrace-toggle-java) |
||||
(define-key map "c" #'cider-stacktrace-toggle-clj) |
||||
(define-key map "r" #'cider-stacktrace-toggle-repl) |
||||
(define-key map "t" #'cider-stacktrace-toggle-tooling) |
||||
(define-key map "d" #'cider-stacktrace-toggle-duplicates) |
||||
(define-key map "a" #'cider-stacktrace-toggle-all) |
||||
(define-key map "1" #'cider-stacktrace-cycle-cause-1) |
||||
(define-key map "2" #'cider-stacktrace-cycle-cause-2) |
||||
(define-key map "3" #'cider-stacktrace-cycle-cause-3) |
||||
(define-key map "4" #'cider-stacktrace-cycle-cause-4) |
||||
(define-key map "5" #'cider-stacktrace-cycle-cause-5) |
||||
(define-key map "0" #'cider-stacktrace-cycle-all-causes) |
||||
(define-key map [tab] #'cider-stacktrace-cycle-current-cause) |
||||
(define-key map [backtab] #'cider-stacktrace-cycle-all-causes) |
||||
(easy-menu-define cider-stacktrace-mode-menu map |
||||
"Menu for CIDER's stacktrace mode" |
||||
'("Stacktrace" |
||||
["Previous cause" cider-stacktrace-previous-cause] |
||||
["Next cause" cider-stacktrace-next-cause] |
||||
"--" |
||||
["Jump to frame source" cider-stacktrace-jump] |
||||
"--" |
||||
["Cycle current cause detail" cider-stacktrace-cycle-current-cause] |
||||
["Cycle cause #1 detail" cider-stacktrace-cycle-cause-1] |
||||
["Cycle cause #2 detail" cider-stacktrace-cycle-cause-2] |
||||
["Cycle cause #3 detail" cider-stacktrace-cycle-cause-3] |
||||
["Cycle cause #4 detail" cider-stacktrace-cycle-cause-4] |
||||
["Cycle cause #5 detail" cider-stacktrace-cycle-cause-5] |
||||
["Cycle all cause detail" cider-stacktrace-cycle-all-causes] |
||||
"--" |
||||
["Show/hide Java frames" cider-stacktrace-toggle-java] |
||||
["Show/hide Clojure frames" cider-stacktrace-toggle-clj] |
||||
["Show/hide REPL frames" cider-stacktrace-toggle-repl] |
||||
["Show/hide tooling frames" cider-stacktrace-toggle-tooling] |
||||
["Show/hide duplicate frames" cider-stacktrace-toggle-duplicates] |
||||
["Show/hide all frames" cider-stacktrace-toggle-all])) |
||||
map)) |
||||
|
||||
(define-derived-mode cider-stacktrace-mode special-mode "Stacktrace" |
||||
"Major mode for filtering and navigating CIDER stacktraces. |
||||
|
||||
\\{cider-stacktrace-mode-map}" |
||||
(setq buffer-read-only t) |
||||
(setq-local truncate-lines t) |
||||
(setq-local electric-indent-chars nil) |
||||
(setq-local cider-stacktrace-prior-filters nil) |
||||
(setq-local cider-stacktrace-hidden-frame-count 0) |
||||
(setq-local cider-stacktrace-filters cider-stacktrace-default-filters) |
||||
(setq-local cider-stacktrace-cause-visibility (make-vector 10 0))) |
||||
|
||||
|
||||
;; Stacktrace filtering |
||||
|
||||
(defun cider-stacktrace-indicate-filters (filters) |
||||
"Update enabled state of filter buttons. |
||||
|
||||
Find buttons with a 'filter property; if filter is a member of FILTERS, or |
||||
if filter is nil ('show all') and the argument list is non-nil, fontify the |
||||
button as disabled. Upon finding text with a 'hidden-count property, stop |
||||
searching and update the hidden count text." |
||||
(with-current-buffer cider-error-buffer |
||||
(save-excursion |
||||
(goto-char (point-min)) |
||||
(let ((inhibit-read-only t) |
||||
(get-face (lambda (hide) |
||||
(if hide |
||||
'cider-stacktrace-filter-hidden-face |
||||
'cider-stacktrace-filter-shown-face)))) |
||||
;; Toggle buttons |
||||
(while (not (or (get-text-property (point) 'hidden-count) (eobp))) |
||||
(let ((button (button-at (point)))) |
||||
(when button |
||||
(let* ((filter (button-get button 'filter)) |
||||
(face (funcall get-face (if filter |
||||
(member filter filters) |
||||
filters)))) |
||||
(button-put button 'face face))) |
||||
(goto-char (or (next-property-change (point)) |
||||
(point-max))))) |
||||
;; Update hidden count |
||||
(when (and (get-text-property (point) 'hidden-count) |
||||
(re-search-forward "[0-9]+" (line-end-position) t)) |
||||
(replace-match |
||||
(number-to-string cider-stacktrace-hidden-frame-count))))))) |
||||
|
||||
(defun cider-stacktrace-apply-filters (filters) |
||||
"Set visibility on stack frames using FILTERS. |
||||
Update `cider-stacktrace-hidden-frame-count' and indicate filters applied. |
||||
Currently collapsed stacktraces are ignored, and do not contribute to the |
||||
hidden count." |
||||
(with-current-buffer cider-error-buffer |
||||
(save-excursion |
||||
(goto-char (point-min)) |
||||
(let ((inhibit-read-only t) |
||||
(hidden 0)) |
||||
(while (not (eobp)) |
||||
(unless (get-text-property (point) 'collapsed) |
||||
(let* ((flags (get-text-property (point) 'flags)) |
||||
(hide (if (seq-intersection filters flags) t nil))) |
||||
(when hide (setq hidden (+ 1 hidden))) |
||||
(put-text-property (point) (line-beginning-position 2) 'invisible hide))) |
||||
(forward-line 1)) |
||||
(setq cider-stacktrace-hidden-frame-count hidden))) |
||||
(cider-stacktrace-indicate-filters filters))) |
||||
|
||||
|
||||
(defun cider-stacktrace-apply-cause-visibility () |
||||
"Apply `cider-stacktrace-cause-visibility' to causes and reapply filters." |
||||
(with-current-buffer cider-error-buffer |
||||
(save-excursion |
||||
(goto-char (point-min)) |
||||
(cl-flet ((next-detail (end) |
||||
(when-let ((pos (next-single-property-change (point) 'detail))) |
||||
(when (< pos end) |
||||
(goto-char pos))))) |
||||
(let ((inhibit-read-only t)) |
||||
;; For each cause... |
||||
(while (cider-stacktrace-next-cause) |
||||
(let* ((num (get-text-property (point) 'cause)) |
||||
(level (elt cider-stacktrace-cause-visibility num)) |
||||
(cause-end (cadr (cider-property-bounds 'cause)))) |
||||
;; For each detail level within the cause, set visibility. |
||||
(while (next-detail cause-end) |
||||
(let* ((detail (get-text-property (point) 'detail)) |
||||
(detail-end (cadr (cider-property-bounds 'detail))) |
||||
(hide (if (> detail level) t nil))) |
||||
(add-text-properties (point) detail-end |
||||
(list 'invisible hide |
||||
'collapsed hide)))))))) |
||||
(cider-stacktrace-apply-filters |
||||
cider-stacktrace-filters)))) |
||||
|
||||
|
||||
;; Interactive functions |
||||
|
||||
(defun cider-stacktrace-previous-cause () |
||||
"Move point to the previous exception cause, if one exists." |
||||
(interactive) |
||||
(with-current-buffer cider-error-buffer |
||||
(when-let ((pos (previous-single-property-change (point) 'cause))) |
||||
(goto-char pos)))) |
||||
|
||||
(defun cider-stacktrace-next-cause () |
||||
"Move point to the next exception cause, if one exists." |
||||
(interactive) |
||||
(with-current-buffer cider-error-buffer |
||||
(when-let ((pos (next-single-property-change (point) 'cause))) |
||||
(goto-char pos)))) |
||||
|
||||
(defun cider-stacktrace-cycle-cause (num &optional level) |
||||
"Update element NUM of `cider-stacktrace-cause-visibility', optionally to LEVEL. |
||||
If LEVEL is not specified, its current value is incremented. When it reaches 3, |
||||
it wraps to 0." |
||||
(let ((level (or level (1+ (elt cider-stacktrace-cause-visibility num))))) |
||||
(aset cider-stacktrace-cause-visibility num (mod level 3)) |
||||
(cider-stacktrace-apply-cause-visibility))) |
||||
|
||||
(defun cider-stacktrace-cycle-all-causes () |
||||
"Cycle the visibility of all exception causes." |
||||
(interactive) |
||||
(with-current-buffer cider-error-buffer |
||||
(save-excursion |
||||
;; Find nearest cause. |
||||
(unless (get-text-property (point) 'cause) |
||||
(cider-stacktrace-next-cause) |
||||
(unless (get-text-property (point) 'cause) |
||||
(cider-stacktrace-previous-cause))) |
||||
;; Cycle its level, and apply that to all causes. |
||||
(let* ((num (get-text-property (point) 'cause)) |
||||
(level (1+ (elt cider-stacktrace-cause-visibility num)))) |
||||
(setq-local cider-stacktrace-cause-visibility |
||||
(make-vector 10 (mod level 3))) |
||||
(cider-stacktrace-apply-cause-visibility))))) |
||||
|
||||
(defun cider-stacktrace-cycle-current-cause () |
||||
"Cycle the visibility of current exception at point, if any." |
||||
(interactive) |
||||
(with-current-buffer cider-error-buffer |
||||
(when-let ((num (get-text-property (point) 'cause))) |
||||
(cider-stacktrace-cycle-cause num)))) |
||||
|
||||
(defun cider-stacktrace-cycle-cause-1 () |
||||
"Cycle the visibility of exception cause #1." |
||||
(interactive) |
||||
(cider-stacktrace-cycle-cause 1)) |
||||
|
||||
(defun cider-stacktrace-cycle-cause-2 () |
||||
"Cycle the visibility of exception cause #2." |
||||
(interactive) |
||||
(cider-stacktrace-cycle-cause 2)) |
||||
|
||||
(defun cider-stacktrace-cycle-cause-3 () |
||||
"Cycle the visibility of exception cause #3." |
||||
(interactive) |
||||
(cider-stacktrace-cycle-cause 3)) |
||||
|
||||
(defun cider-stacktrace-cycle-cause-4 () |
||||
"Cycle the visibility of exception cause #4." |
||||
(interactive) |
||||
(cider-stacktrace-cycle-cause 4)) |
||||
|
||||
(defun cider-stacktrace-cycle-cause-5 () |
||||
"Cycle the visibility of exception cause #5." |
||||
(interactive) |
||||
(cider-stacktrace-cycle-cause 5)) |
||||
|
||||
|
||||
(defun cider-stacktrace-toggle-all () |
||||
"Reset `cider-stacktrace-filters' if present; otherwise restore prior filters." |
||||
(interactive) |
||||
(when cider-stacktrace-filters |
||||
(setq-local cider-stacktrace-prior-filters |
||||
cider-stacktrace-filters)) |
||||
(cider-stacktrace-apply-filters |
||||
(setq cider-stacktrace-filters |
||||
(unless cider-stacktrace-filters ; when current filters are nil, |
||||
cider-stacktrace-prior-filters)))) ; reenable prior filter set |
||||
|
||||
(defun cider-stacktrace-toggle (flag) |
||||
"Update `cider-stacktrace-filters' to add or remove FLAG, and apply filters." |
||||
(cider-stacktrace-apply-filters |
||||
(setq cider-stacktrace-filters |
||||
(if (memq flag cider-stacktrace-filters) |
||||
(remq flag cider-stacktrace-filters) |
||||
(cons flag cider-stacktrace-filters))))) |
||||
|
||||
(defun cider-stacktrace-toggle-java () |
||||
"Toggle display of Java stack frames." |
||||
(interactive) |
||||
(cider-stacktrace-toggle 'java)) |
||||
|
||||
(defun cider-stacktrace-toggle-clj () |
||||
"Toggle display of Clojure stack frames." |
||||
(interactive) |
||||
(cider-stacktrace-toggle 'clj)) |
||||
|
||||
(defun cider-stacktrace-toggle-repl () |
||||
"Toggle display of REPL stack frames." |
||||
(interactive) |
||||
(cider-stacktrace-toggle 'repl)) |
||||
|
||||
(defun cider-stacktrace-toggle-tooling () |
||||
"Toggle display of Tooling stack frames (compiler, nREPL middleware, etc)." |
||||
(interactive) |
||||
(cider-stacktrace-toggle 'tooling)) |
||||
|
||||
(defun cider-stacktrace-toggle-duplicates () |
||||
"Toggle display of stack frames that are duplicates of their descendents." |
||||
(interactive) |
||||
(cider-stacktrace-toggle 'dup)) |
||||
|
||||
|
||||
;; Text button functions |
||||
|
||||
(defun cider-stacktrace-filter (button) |
||||
"Apply filter(s) indicated by the BUTTON." |
||||
(with-temp-message "Filters may also be toggled with the keyboard." |
||||
(let ((flag (button-get button 'filter))) |
||||
(if flag |
||||
(cider-stacktrace-toggle flag) |
||||
(cider-stacktrace-toggle-all))) |
||||
(sit-for 5))) |
||||
|
||||
(defun cider-stacktrace-navigate (button) |
||||
"Navigate to the stack frame source represented by the BUTTON." |
||||
(let* ((var (button-get button 'var)) |
||||
(class (button-get button 'class)) |
||||
(method (button-get button 'method)) |
||||
(info (or (and var (cider-var-info var)) |
||||
(and class method (cider-member-info class method)) |
||||
(nrepl-dict))) |
||||
;; Stacktrace returns more accurate line numbers, but if the function's |
||||
;; line was unreliable, then so is the stacktrace by the same amount. |
||||
;; Set `line-shift' to the number of lines from the beginning of defn. |
||||
(line-shift (- (or (button-get button 'line) 0) |
||||
(or (nrepl-dict-get info "line") 1))) |
||||
;; give priority to `info` files as `info` returns full paths. |
||||
(info (nrepl-dict-put info "file" (or (nrepl-dict-get info "file") |
||||
(button-get button 'file))))) |
||||
(cider--jump-to-loc-from-info info t) |
||||
(forward-line line-shift) |
||||
(back-to-indentation))) |
||||
|
||||
(defun cider-stacktrace-jump (&optional arg) |
||||
"Like `cider-find-var', but uses the stack frame source at point, if available." |
||||
(interactive "P") |
||||
(let ((button (button-at (point)))) |
||||
(if (and button (button-get button 'line)) |
||||
(cider-stacktrace-navigate button) |
||||
(cider-find-var arg)))) |
||||
|
||||
|
||||
;; Rendering |
||||
|
||||
(defun cider-stacktrace-emit-indented (text indent &optional fill) |
||||
"Insert TEXT, and INDENT and optionally FILL the entire block." |
||||
(let ((beg (point))) |
||||
(insert text) |
||||
(goto-char beg) |
||||
(while (not (eobp)) |
||||
(insert indent) |
||||
(forward-line)) |
||||
(when (and fill cider-stacktrace-fill-column) |
||||
(when (and (numberp cider-stacktrace-fill-column)) |
||||
(setq-local fill-column cider-stacktrace-fill-column)) |
||||
(setq-local fill-prefix indent) |
||||
(fill-region beg (point))))) |
||||
|
||||
(defun cider-stacktrace-render-filters (buffer filters) |
||||
"Emit into BUFFER toggle buttons for each of the FILTERS." |
||||
(with-current-buffer buffer |
||||
(insert " Show: ") |
||||
(dolist (filter filters) |
||||
(insert-text-button (car filter) |
||||
'filter (cadr filter) |
||||
'follow-link t |
||||
'action 'cider-stacktrace-filter |
||||
'help-echo (format "Toggle %s stack frames" |
||||
(car filter))) |
||||
(insert " ")) |
||||
(let ((hidden "(0 frames hidden)")) |
||||
(put-text-property 0 (length hidden) 'hidden-count t hidden) |
||||
(insert " " hidden "\n")))) |
||||
|
||||
(defun cider-stacktrace-render-frame (buffer frame) |
||||
"Emit into BUFFER function call site info for the stack FRAME. |
||||
This associates text properties to enable filtering and source navigation." |
||||
(with-current-buffer buffer |
||||
(nrepl-dbind-response frame (file line flags class method name var ns fn) |
||||
(let ((flags (mapcar 'intern flags))) ; strings -> symbols |
||||
(insert-text-button (format "%30s:%5d %s/%s" |
||||
(if (member 'repl flags) "REPL" file) line |
||||
(if (member 'clj flags) ns class) |
||||
(if (member 'clj flags) fn method)) |
||||
'var var 'class class 'method method |
||||
'name name 'file file 'line line |
||||
'flags flags 'follow-link t |
||||
'action 'cider-stacktrace-navigate |
||||
'help-echo "View source at this location" |
||||
'face 'cider-stacktrace-face) |
||||
(save-excursion |
||||
(let ((p4 (point)) |
||||
(p1 (search-backward " ")) |
||||
(p2 (search-forward "/")) |
||||
(p3 (search-forward-regexp "[^/$]+"))) |
||||
(put-text-property p1 p4 'font-lock-face 'cider-stacktrace-ns-face) |
||||
(put-text-property p2 p3 'font-lock-face 'cider-stacktrace-fn-face))) |
||||
(insert "\n"))))) |
||||
|
||||
(defun cider-stacktrace--create-go-to-err-button (beg message) |
||||
"Create a button that jumps to the relevant error. |
||||
|
||||
Buttons span over the region from BEG to current point. |
||||
MESSAGE is parsed to find line, col and buffer name to jump to." |
||||
(when (and message |
||||
(string-match "\\([^:]+\\):\\([^:]+\\):\\([^:]+\\):\\([^:]+\\)\\'" message)) |
||||
(let* ((line (string-to-number (match-string 3 message))) |
||||
(col (string-to-number (match-string 4 message))) |
||||
(buf-name (car (last (split-string (match-string 2 message) "\\/"))))) |
||||
(when buf-name |
||||
(make-button (+ beg 3) |
||||
(point) |
||||
'action (lambda (_button) |
||||
(let ((the-buf-window (get-buffer-window buf-name))) |
||||
(if the-buf-window |
||||
(select-window the-buf-window) |
||||
(switch-to-buffer buf-name))) |
||||
(goto-char (point-min)) |
||||
(forward-line line) |
||||
(move-to-column col t))))))) |
||||
|
||||
(defun cider-stacktrace-render-cause (buffer cause num note) |
||||
"Emit into BUFFER the CAUSE NUM, exception class, message, data, and NOTE." |
||||
(with-current-buffer buffer |
||||
(nrepl-dbind-response cause (class message data stacktrace) |
||||
(let ((indent " ") |
||||
(class-face 'cider-stacktrace-error-class-face) |
||||
(message-face 'cider-stacktrace-error-message-face)) |
||||
(cider-propertize-region `(cause ,num) |
||||
;; Detail level 0: exception class |
||||
(cider-propertize-region '(detail 0) |
||||
(insert (format "%d. " num) |
||||
(propertize note 'font-lock-face 'font-lock-comment-face) " " |
||||
(propertize class 'font-lock-face class-face) |
||||
"\n")) |
||||
;; Detail level 1: message + ex-data |
||||
(cider-propertize-region '(detail 1) |
||||
(let ((beg (point))) |
||||
(cider-stacktrace-emit-indented |
||||
(propertize (or message "(No message)") 'font-lock-face message-face) indent t) |
||||
(cider-stacktrace--create-go-to-err-button beg message)) |
||||
(insert "\n") |
||||
(when data |
||||
(cider-stacktrace-emit-indented |
||||
(cider-font-lock-as-clojure data) indent nil))) |
||||
;; Detail level 2: stacktrace |
||||
(cider-propertize-region '(detail 2) |
||||
(insert "\n") |
||||
(let ((beg (point)) |
||||
(bg `(:background ,cider-stacktrace-frames-background-color))) |
||||
(dolist (frame stacktrace) |
||||
(cider-stacktrace-render-frame buffer frame)) |
||||
(overlay-put (make-overlay beg (point)) 'font-lock-face bg))) |
||||
;; Add line break between causes, even when collapsed. |
||||
(cider-propertize-region '(detail 0) |
||||
(insert "\n"))))))) |
||||
|
||||
(defun cider-stacktrace-initialize (causes) |
||||
"Set and apply CAUSES initial visibility, filters, and cursor position." |
||||
;; Partially display outermost cause if it's a compiler exception (the |
||||
;; description reports reader location of the error). |
||||
(nrepl-dbind-response (car causes) (class) |
||||
(when (equal class "clojure.lang.Compiler$CompilerException") |
||||
(cider-stacktrace-cycle-cause (length causes) 1))) |
||||
;; Fully display innermost cause. This also applies visibility/filters. |
||||
(cider-stacktrace-cycle-cause 1 cider-stacktrace-detail-max) |
||||
;; Move point to first stacktrace frame in displayed cause. If the error |
||||
;; buffer is visible in a window, ensure that window is selected while moving |
||||
;; point, so as to move both the buffer's and the window's point. |
||||
(with-selected-window (or (get-buffer-window cider-error-buffer) |
||||
(selected-window)) |
||||
(with-current-buffer cider-error-buffer |
||||
(goto-char (point-min)) |
||||
(while (cider-stacktrace-next-cause)) |
||||
(goto-char (next-single-property-change (point) 'flags))))) |
||||
|
||||
(defun cider-stacktrace-render (buffer causes) |
||||
"Emit into BUFFER useful stacktrace information for the CAUSES." |
||||
(with-current-buffer buffer |
||||
(let ((inhibit-read-only t)) |
||||
(erase-buffer) |
||||
(insert "\n") |
||||
;; Stacktrace filters |
||||
(cider-stacktrace-render-filters |
||||
buffer |
||||
`(("Clojure" clj) ("Java" java) ("REPL" repl) |
||||
("Tooling" tooling) ("Duplicates" dup) ("All" ,nil))) |
||||
(insert "\n") |
||||
;; Stacktrace exceptions & frames |
||||
(let ((num (length causes))) |
||||
(dolist (cause causes) |
||||
(let ((note (if (= num (length causes)) "Unhandled" "Caused by"))) |
||||
(cider-stacktrace-render-cause buffer cause num note) |
||||
(setq num (1- num)))))) |
||||
(cider-stacktrace-initialize causes) |
||||
(font-lock-refresh-defaults))) |
||||
|
||||
(provide 'cider-stacktrace) |
||||
|
||||
;;; cider-stacktrace.el ends here |
||||
@ -0,0 +1,499 @@
|
||||
;;; cider-test.el --- Test result viewer -*- lexical-binding: t -*- |
||||
|
||||
;; Copyright © 2014-2015 Jeff Valk |
||||
|
||||
;; Author: Jeff Valk <jv@jeffvalk.com> |
||||
|
||||
;; This program 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 program 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 program. If not, see <http://www.gnu.org/licenses/>. |
||||
|
||||
;; This file is not part of GNU Emacs. |
||||
|
||||
;;; Commentary: |
||||
|
||||
;; This provides execution, reporting, and navigation support for Clojure tests, |
||||
;; specifically using the `clojure.test' machinery. This functionality replaces |
||||
;; the venerable `clojure-test-mode' (deprecated in June 2014), and relies on |
||||
;; nREPL middleware for report running and session support. |
||||
|
||||
;;; Code: |
||||
|
||||
(require 'cider-common) |
||||
(require 'cider-client) |
||||
(require 'cider-popup) |
||||
(require 'cider-stacktrace) |
||||
(require 'cider-compat) |
||||
|
||||
(require 'button) |
||||
(require 'easymenu) |
||||
|
||||
;;; Variables |
||||
|
||||
(defgroup cider-test nil |
||||
"Presentation and navigation for test results." |
||||
:prefix "cider-test-" |
||||
:group 'cider) |
||||
|
||||
(defcustom cider-test-show-report-on-success nil |
||||
"Whether to show the `*cider-test-report*` buffer on passing tests." |
||||
:type 'boolean |
||||
:group 'cider-test |
||||
:package-version '(cider . "0.8.0")) |
||||
|
||||
(defcustom cider-auto-select-test-report-buffer t |
||||
"Determines if the test-report buffer should be auto-selected." |
||||
:type 'boolean |
||||
:group 'cider-test |
||||
:package-version '(cider . "0.9.0")) |
||||
|
||||
(defvar cider-test-last-test-ns nil |
||||
"The namespace for which tests were last run.") |
||||
|
||||
(defvar cider-test-last-results nil |
||||
"The results of the last run test.") |
||||
|
||||
(defconst cider-test-report-buffer "*cider-test-report*" |
||||
"Buffer name in which to display test reports.") |
||||
(add-to-list 'cider-ancillary-buffers cider-test-report-buffer) |
||||
|
||||
|
||||
;;; Faces |
||||
;; These are as defined in clojure-test-mode. |
||||
|
||||
(defface cider-test-failure-face |
||||
'((((class color) (background light)) |
||||
:background "orange red") |
||||
(((class color) (background dark)) |
||||
:background "firebrick")) |
||||
"Face for failed tests." |
||||
:group 'cider-test |
||||
:package-version '(cider . "0.7.0")) |
||||
|
||||
(defface cider-test-error-face |
||||
'((((class color) (background light)) |
||||
:background "orange1") |
||||
(((class color) (background dark)) |
||||
:background "orange4")) |
||||
"Face for erring tests." |
||||
:group 'cider-test |
||||
:package-version '(cider . "0.7.0")) |
||||
|
||||
(defface cider-test-success-face |
||||
'((((class color) (background light)) |
||||
:foreground "black" |
||||
:background "green") |
||||
(((class color) (background dark)) |
||||
:foreground "black" |
||||
:background "green")) |
||||
"Face for passing tests." |
||||
:group 'cider-test |
||||
:package-version '(cider . "0.7.0")) |
||||
|
||||
|
||||
;;; Report mode & key bindings |
||||
;; The primary mode of interacting with test results is the report buffer, which |
||||
;; allows navigation among tests, jumping to test definitions, expected/actual |
||||
;; diff-ing, and cause/stacktrace inspection for test errors. |
||||
|
||||
(defvar cider-test-report-mode-map |
||||
(let ((map (make-sparse-keymap))) |
||||
(define-key map (kbd "C-c ,") #'cider-test-run-tests) |
||||
(define-key map (kbd "C-c C-,") #'cider-test-rerun-tests) |
||||
(define-key map (kbd "C-c M-,") #'cider-test-run-test) |
||||
(define-key map (kbd "M-p") #'cider-test-previous-result) |
||||
(define-key map (kbd "M-n") #'cider-test-next-result) |
||||
(define-key map (kbd "M-.") #'cider-test-jump) |
||||
(define-key map (kbd "<backtab>") #'cider-test-previous-result) |
||||
(define-key map (kbd "TAB") #'cider-test-next-result) |
||||
(define-key map (kbd "RET") #'cider-test-jump) |
||||
(define-key map (kbd "t") #'cider-test-jump) |
||||
(define-key map (kbd "d") #'cider-test-ediff) |
||||
(define-key map (kbd "e") #'cider-test-stacktrace) |
||||
(define-key map "q" #'cider-popup-buffer-quit-function) |
||||
(easy-menu-define cider-test-report-mode-menu map |
||||
"Menu for CIDER's test result mode" |
||||
'("Test-Report" |
||||
["Previous result" cider-test-previous-result] |
||||
["Next result" cider-test-next-result] |
||||
"--" |
||||
["Rerun current test" cider-test-run-test] |
||||
["Rerun failed/erring tests" cider-test-rerun-tests] |
||||
["Rerun all tests" cider-test-run-tests] |
||||
"--" |
||||
["Jump to test definition" cider-test-jump] |
||||
["Display test error" cider-test-stacktrace] |
||||
["Display expected/actual diff" cider-test-ediff])) |
||||
map)) |
||||
|
||||
(define-derived-mode cider-test-report-mode fundamental-mode "Test Report" |
||||
"Major mode for presenting Clojure test results. |
||||
|
||||
\\{cider-test-report-mode-map}" |
||||
(setq buffer-read-only t) |
||||
(setq-local truncate-lines t) |
||||
(setq-local electric-indent-chars nil)) |
||||
|
||||
;; Report navigation |
||||
|
||||
(defun cider-test-show-report () |
||||
"Show the test report buffer, if one exists." |
||||
(interactive) |
||||
(if-let ((report-buffer (get-buffer cider-test-report-buffer))) |
||||
(switch-to-buffer report-buffer) |
||||
(message "No test report buffer"))) |
||||
|
||||
(defun cider-test-previous-result () |
||||
"Move point to the previous test result, if one exists." |
||||
(interactive) |
||||
(with-current-buffer (get-buffer cider-test-report-buffer) |
||||
(when-let ((pos (previous-single-property-change (point) 'type))) |
||||
(goto-char pos)))) |
||||
|
||||
(defun cider-test-next-result () |
||||
"Move point to the next test result, if one exists." |
||||
(interactive) |
||||
(with-current-buffer (get-buffer cider-test-report-buffer) |
||||
(when-let ((pos (next-single-property-change (point) 'type))) |
||||
(goto-char pos)))) |
||||
|
||||
(defun cider-test-jump (&optional arg) |
||||
"Like `cider-find-var', but uses the test at point's definition, if available." |
||||
(interactive "P") |
||||
(let ((ns (get-text-property (point) 'ns)) |
||||
(var (get-text-property (point) 'var)) |
||||
(line (get-text-property (point) 'line))) |
||||
(if (and ns var) |
||||
(cider-find-var arg (concat ns "/" var) line) |
||||
(cider-find-var arg)))) |
||||
|
||||
;;; Error stacktraces |
||||
|
||||
(defvar cider-auto-select-error-buffer) |
||||
|
||||
(defun cider-test-stacktrace-for (ns var index) |
||||
"Display stacktrace for the erring NS VAR test with the assertion INDEX." |
||||
(let (causes) |
||||
(cider-nrepl-send-request |
||||
(append |
||||
(list "op" "test-stacktrace" "session" (cider-current-session) |
||||
"ns" ns "var" var "index" index) |
||||
(when cider-stacktrace-print-length |
||||
(list "print-length" cider-stacktrace-print-length)) |
||||
(when cider-stacktrace-print-level |
||||
(list "print-level" cider-stacktrace-print-level))) |
||||
(lambda (response) |
||||
(nrepl-dbind-response response (class status) |
||||
(cond (class (setq causes (cons response causes))) |
||||
(status (when causes |
||||
(cider-stacktrace-render |
||||
(cider-popup-buffer cider-error-buffer |
||||
cider-auto-select-error-buffer) |
||||
(reverse causes)))))))))) |
||||
|
||||
(defun cider-test-stacktrace () |
||||
"Display stacktrace for the erring test at point." |
||||
(interactive) |
||||
(let ((ns (get-text-property (point) 'ns)) |
||||
(var (get-text-property (point) 'var)) |
||||
(index (get-text-property (point) 'index)) |
||||
(err (get-text-property (point) 'error))) |
||||
(if (and err ns var index) |
||||
(cider-test-stacktrace-for ns var index) |
||||
(message "No test error at point")))) |
||||
|
||||
|
||||
;;; Expected vs actual diffing |
||||
|
||||
(defvar cider-test-ediff-buffers nil |
||||
"The expected/actual buffers used to display diff.") |
||||
|
||||
(defun cider-test-ediff () |
||||
"Show diff of the expected vs actual value for the test at point. |
||||
With the actual value, the outermost '(not ...)' s-expression is removed." |
||||
(interactive) |
||||
(let ((expected (get-text-property (point) 'expected)) |
||||
(actual (get-text-property (point) 'actual))) |
||||
(if (and expected actual) |
||||
(let ((expected-buffer (generate-new-buffer " *expected*")) |
||||
(actual-buffer (generate-new-buffer " *actual*"))) |
||||
(with-current-buffer expected-buffer |
||||
(insert expected) |
||||
(clojure-mode)) |
||||
(with-current-buffer actual-buffer |
||||
(insert actual) |
||||
(goto-char (point-min)) |
||||
(forward-char) |
||||
(forward-sexp) |
||||
(forward-whitespace 1) |
||||
(let ((beg (point))) |
||||
(forward-sexp) |
||||
(let ((actual* (buffer-substring beg (point)))) |
||||
(erase-buffer) |
||||
(insert actual*))) |
||||
(clojure-mode)) |
||||
(apply 'ediff-buffers |
||||
(setq cider-test-ediff-buffers |
||||
(list (buffer-name expected-buffer) |
||||
(buffer-name actual-buffer))))) |
||||
(message "No test failure at point")))) |
||||
|
||||
(defun cider-test-ediff-cleanup () |
||||
"Cleanup expected/actual buffers used for diff." |
||||
(interactive) |
||||
(mapc (lambda (b) (when (get-buffer b) (kill-buffer b))) |
||||
cider-test-ediff-buffers)) |
||||
|
||||
(add-hook 'ediff-cleanup-hook #'cider-test-ediff-cleanup) |
||||
|
||||
|
||||
;;; Report rendering |
||||
|
||||
(defun cider-test-type-face (type) |
||||
"Return the font lock face for the test result TYPE." |
||||
(pcase type |
||||
("pass" 'cider-test-success-face) |
||||
("fail" 'cider-test-failure-face) |
||||
("error" 'cider-test-error-face) |
||||
(_ 'default))) |
||||
|
||||
(defun cider-test-render-summary (buffer summary) |
||||
"Emit into BUFFER the report SUMMARY statistics." |
||||
(with-current-buffer buffer |
||||
(nrepl-dbind-response summary (var test pass fail error) |
||||
(insert (format "Ran %d tests, in %d test functions\n" test var)) |
||||
(unless (zerop fail) |
||||
(cider-insert (format "%d failures" fail) 'cider-test-failure-face t)) |
||||
(unless (zerop error) |
||||
(cider-insert (format "%d errors" error) 'cider-test-error-face t)) |
||||
(when (zerop (+ fail error)) |
||||
(cider-insert (format "%d passed" pass) 'cider-test-success-face t)) |
||||
(insert "\n\n")))) |
||||
|
||||
(defun cider-test-render-assertion (buffer test) |
||||
"Emit into BUFFER report detail for the TEST assertion." |
||||
(with-current-buffer buffer |
||||
(nrepl-dbind-response test (var context type message expected actual error) |
||||
(cider-propertize-region (cider-intern-keys (cdr test)) |
||||
(cider-insert (capitalize type) (cider-test-type-face type) nil " in ") |
||||
(cider-insert var 'font-lock-function-name-face t) |
||||
(when context (cider-insert context 'font-lock-doc-face t)) |
||||
(when message (cider-insert message 'font-lock-doc-string-face t)) |
||||
(when expected (cider-insert "expected: " 'font-lock-comment-face nil |
||||
(cider-font-lock-as-clojure expected))) |
||||
(when actual (cider-insert " actual: " 'font-lock-comment-face) |
||||
(if error |
||||
(progn (insert-text-button |
||||
error |
||||
'follow-link t |
||||
'action '(lambda (_button) (cider-test-stacktrace)) |
||||
'help-echo "View causes and stacktrace") |
||||
(insert "\n")) |
||||
(insert (cider-font-lock-as-clojure actual))))) |
||||
(insert "\n")))) |
||||
|
||||
(defun cider-test-render-report (buffer ns summary results) |
||||
"Emit into BUFFER the report for the NS, SUMMARY, and test RESULTS." |
||||
(with-current-buffer buffer |
||||
(let ((inhibit-read-only t)) |
||||
(cider-test-report-mode) |
||||
(cider-insert "Test Summary" 'bold t) |
||||
(cider-insert ns 'font-lock-function-name-face t "\n") |
||||
(cider-test-render-summary buffer summary) |
||||
(nrepl-dbind-response summary (fail error) |
||||
(unless (zerop (+ fail error)) |
||||
(cider-insert "Results" 'bold t "\n") |
||||
(nrepl-dict-map |
||||
(lambda (_var tests) |
||||
(dolist (test tests) |
||||
(nrepl-dbind-response test (type) |
||||
(unless (equal "pass" type) |
||||
(cider-test-render-assertion buffer test))))) |
||||
results))) |
||||
(goto-char (point-min)) |
||||
(current-buffer)))) |
||||
|
||||
|
||||
;;; Summary echo |
||||
|
||||
(defun cider-test-echo-summary (summary) |
||||
"Echo SUMMARY statistics for a test run." |
||||
(nrepl-dbind-response summary (test fail error) |
||||
(message |
||||
(propertize |
||||
(format "Ran %s tests. %s failures, %s errors." test fail error) |
||||
'face (cond ((not (zerop error)) 'cider-test-error-face) |
||||
((not (zerop fail)) 'cider-test-failure-face) |
||||
(t 'cider-test-success-face)))))) |
||||
|
||||
|
||||
;;; Test definition highlighting |
||||
;; On receipt of test results, failing/erring test definitions are highlighted. |
||||
;; Highlights are cleared on the next report run, and may be cleared manually |
||||
;; by the user. |
||||
|
||||
;; NOTE If keybindings specific to test sources are desired, it would be |
||||
;; straightforward to turn this into a `cider-test-mode' minor mode, which we |
||||
;; enable on test sources, much like the legacy `clojure-test-mode'. At present, |
||||
;; though, there doesn't seem to be much value in this, since the report buffer |
||||
;; provides the primary means of interacting with test results. |
||||
|
||||
(defun cider-test-highlight-problem (buffer test) |
||||
"Highlight the BUFFER test definition for the non-passing TEST." |
||||
(with-current-buffer buffer |
||||
(nrepl-dbind-response test (type file line message expected actual) |
||||
;; we have to watch out for vars without proper location metadata |
||||
;; right now everything evaluated interactively lacks this data |
||||
;; TODO: Figure out what to do when the metadata is missing |
||||
(when (and file line (not (cider--tooling-file-p file))) |
||||
(save-excursion |
||||
(goto-char (point-min)) |
||||
(forward-line (1- line)) |
||||
(forward-whitespace 1) |
||||
(forward-char) |
||||
(let ((beg (point))) |
||||
(forward-sexp) |
||||
(let ((overlay (make-overlay beg (point)))) |
||||
(overlay-put overlay 'font-lock-face (cider-test-type-face type)) |
||||
(overlay-put overlay 'type type) |
||||
(overlay-put overlay 'help-echo message) |
||||
(overlay-put overlay 'message message) |
||||
(overlay-put overlay 'expected expected) |
||||
(overlay-put overlay 'actual actual)))))))) |
||||
|
||||
(defun cider-find-var-file (var) |
||||
"Return the buffer visiting the file in which VAR is defined, or nil if |
||||
not found." |
||||
(cider-ensure-op-supported "info") |
||||
(when-let ((info (cider-var-info var)) |
||||
(file (nrepl-dict-get info "file"))) |
||||
(cider-find-file file))) |
||||
|
||||
(defun cider-test-highlight-problems (ns results) |
||||
"Highlight all non-passing tests in the NS test RESULTS." |
||||
(nrepl-dict-map |
||||
(lambda (var tests) |
||||
(when-let ((buffer (cider-find-var-file (concat ns "/" var)))) |
||||
(dolist (test tests) |
||||
(nrepl-dbind-response test (type) |
||||
(unless (equal "pass" type) |
||||
(cider-test-highlight-problem buffer test)))))) |
||||
results)) |
||||
|
||||
(defun cider-test-clear-highlights () |
||||
"Clear highlighting of non-passing tests from the last test run." |
||||
(interactive) |
||||
(when-let ((ns cider-test-last-test-ns)) |
||||
(dolist (var (nrepl-dict-keys cider-test-last-results)) |
||||
(when-let ((buffer (cider-find-var-file (concat ns "/" var)))) |
||||
(with-current-buffer buffer |
||||
(remove-overlays)))))) |
||||
|
||||
|
||||
;;; Test namespaces |
||||
;; Test namespace inference exists to enable DWIM test running functions: the |
||||
;; same "run-tests" function should be able to be used in a source file, and in |
||||
;; its corresponding test namespace. To provide this, we need to map the |
||||
;; relationship between those namespaces. |
||||
|
||||
(defcustom cider-test-infer-test-ns 'cider-test-default-test-ns-fn |
||||
"Function to infer the test namespace for NS. |
||||
The default implementation uses the simple Leiningen convention of appending |
||||
'-test' to the namespace name." |
||||
:type 'symbol |
||||
:group 'cider-test |
||||
:package-version '(cider . "0.7.0")) |
||||
|
||||
(defun cider-test-default-test-ns-fn (ns) |
||||
"For a NS, return the test namespace, which may be the argument itself. |
||||
This uses the Leiningen convention of appending '-test' to the namespace name." |
||||
(when ns |
||||
(let ((suffix "-test")) |
||||
;; string-suffix-p is only available in Emacs 24.4+ |
||||
(if (string-match-p (rx-to-string `(: ,suffix eos) t) ns) |
||||
ns |
||||
(concat ns suffix))))) |
||||
|
||||
|
||||
;;; Test execution |
||||
|
||||
(declare-function cider-emit-interactive-eval-output "cider-interaction") |
||||
(declare-function cider-emit-interactive-eval-err-output "cider-interaction") |
||||
|
||||
(defun cider-test-execute (ns &optional retest tests) |
||||
"Run tests for NS; optionally RETEST failures or run only specified TESTS. |
||||
Upon test completion, results are echoed and a test report is optionally |
||||
displayed. When test failures/errors occur, their sources are highlighted." |
||||
(cider-test-clear-highlights) |
||||
(message "Testing...") |
||||
(cider-nrepl-send-request |
||||
(list "ns" ns "op" (if retest "retest" "test") |
||||
"tests" tests "session" (cider-current-session)) |
||||
(lambda (response) |
||||
(nrepl-dbind-response response (summary results status out err) |
||||
(cond ((member "namespace-not-found" status) |
||||
(message "No tests namespace: %s" ns)) |
||||
(out (cider-emit-interactive-eval-output out)) |
||||
(err (cider-emit-interactive-eval-err-output err)) |
||||
(results |
||||
(nrepl-dbind-response summary (error fail) |
||||
(setq cider-test-last-test-ns ns) |
||||
(setq cider-test-last-results results) |
||||
(cider-test-highlight-problems ns results) |
||||
(cider-test-echo-summary summary) |
||||
(when (or (not (zerop (+ error fail))) |
||||
cider-test-show-report-on-success) |
||||
(cider-test-render-report |
||||
(cider-popup-buffer cider-test-report-buffer |
||||
cider-auto-select-test-report-buffer) |
||||
ns summary results))))))))) |
||||
|
||||
(defun cider-test-rerun-tests () |
||||
"Rerun failed and erring tests from the last tested namespace." |
||||
(interactive) |
||||
(if-let ((ns cider-test-last-test-ns)) |
||||
(cider-test-execute ns t) |
||||
(message "No namespace to retest"))) |
||||
|
||||
(defun cider-test-run-tests (suppress-inference) |
||||
"Run all tests for the current Clojure source or test report context. |
||||
|
||||
With a prefix arg SUPPRESS-INFERENCE it will try to run the tests in the |
||||
current ns." |
||||
(interactive "P") |
||||
(if-let ((ns (if suppress-inference |
||||
(clojure-find-ns) |
||||
(or (funcall cider-test-infer-test-ns (clojure-find-ns)) |
||||
(when (eq major-mode 'cider-test-report-mode) |
||||
cider-test-last-test-ns))))) |
||||
(cider-test-execute ns nil) |
||||
(message "No namespace to test in current context"))) |
||||
|
||||
(defun cider-test-run-test () |
||||
"Run the test at point. |
||||
The test ns/var exist as text properties on report items and on highlighted |
||||
failed/erred test definitions. When not found, a test definition at point |
||||
is searched." |
||||
(interactive) |
||||
(let ((ns (get-text-property (point) 'ns)) |
||||
(var (get-text-property (point) 'var))) |
||||
(if (and ns var) |
||||
(cider-test-execute ns nil (list var)) |
||||
(let ((ns (clojure-find-ns)) |
||||
(def (clojure-find-def))) |
||||
(if (and ns (member (car def) '("deftest" "defspec"))) |
||||
(cider-test-execute ns nil (cdr def)) |
||||
(message "No test at point")))))) |
||||
|
||||
(provide 'cider-test) |
||||
|
||||
;;; cider-test.el ends here |
||||
@ -0,0 +1,383 @@
|
||||
;;; cider-util.el --- Common utility functions that don't belong anywhere else -*- lexical-binding: t -*- |
||||
|
||||
;; Copyright © 2012-2015 Tim King, Phil Hagelberg |
||||
;; Copyright © 2013-2015 Bozhidar Batsov, Hugo Duncan, Steve Purcell |
||||
;; |
||||
;; Author: Tim King <kingtim@gmail.com> |
||||
;; Phil Hagelberg <technomancy@gmail.com> |
||||
;; Bozhidar Batsov <bozhidar@batsov.com> |
||||
;; Hugo Duncan <hugo@hugoduncan.org> |
||||
;; Steve Purcell <steve@sanityinc.com> |
||||
|
||||
;; This program 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 program 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 program. If not, see <http://www.gnu.org/licenses/>. |
||||
|
||||
;; This file is not part of GNU Emacs. |
||||
|
||||
;;; Commentary: |
||||
|
||||
;; Common utility functions that don't belong anywhere else. |
||||
|
||||
;;; Code: |
||||
|
||||
(require 'seq) |
||||
(require 'cl-lib) |
||||
(require 'clojure-mode) |
||||
|
||||
(defalias 'cider-pop-back 'pop-tag-mark) |
||||
(define-obsolete-function-alias 'cider-jump-back 'cider-pop-back "0.10.0") |
||||
|
||||
(defcustom cider-font-lock-max-length 10000 |
||||
"The max length of strings to fontify in `cider-font-lock-as'. |
||||
|
||||
Setting this to nil removes the fontification restriction." |
||||
:group 'cider |
||||
:type 'boolean |
||||
:package-version '(cider . "0.10.0")) |
||||
|
||||
(defun cider-util--hash-keys (hashtable) |
||||
"Return a list of keys in HASHTABLE." |
||||
(let ((keys '())) |
||||
(maphash (lambda (k _v) (setq keys (cons k keys))) hashtable) |
||||
keys)) |
||||
|
||||
(defun cider-util--clojure-buffers () |
||||
"Return a list of all existing `clojure-mode' buffers." |
||||
(seq-filter |
||||
(lambda (buffer) (with-current-buffer buffer (derived-mode-p 'clojure-mode))) |
||||
(buffer-list))) |
||||
|
||||
(defun cider-current-dir () |
||||
"Return the directory of the current buffer." |
||||
(if buffer-file-name |
||||
(file-name-directory buffer-file-name) |
||||
default-directory)) |
||||
|
||||
(defun cider-in-string-p () |
||||
"Return true if point is in a string." |
||||
(let ((beg (save-excursion (beginning-of-defun) (point)))) |
||||
(nth 3 (parse-partial-sexp beg (point))))) |
||||
|
||||
(defun cider-in-comment-p () |
||||
"Return true if point is in a comment." |
||||
(let ((beg (save-excursion (beginning-of-defun) (point)))) |
||||
(nth 4 (parse-partial-sexp beg (point))))) |
||||
|
||||
(defun cider--tooling-file-p (file-name) |
||||
"Return t if FILE-NAME is not a 'real' source file. |
||||
Currently, only check if the relative file name starts with 'form-init' |
||||
which nREPL uses for temporary evaluation file names." |
||||
(let ((fname (file-name-nondirectory file-name))) |
||||
(string-match-p "^form-init" fname))) |
||||
|
||||
;;; Thing at point |
||||
(defun cider-defun-at-point () |
||||
"Return the text of the top-level sexp at point." |
||||
(apply #'buffer-substring-no-properties |
||||
(cider--region-for-defun-at-point))) |
||||
|
||||
(defun cider--region-for-defun-at-point () |
||||
"Return the start and end position of defun at point." |
||||
(save-excursion |
||||
(save-match-data |
||||
(end-of-defun) |
||||
(let ((end (point))) |
||||
(beginning-of-defun) |
||||
(list (point) end))))) |
||||
|
||||
(defun cider-defun-at-point-start-pos () |
||||
"Return the starting position of the current defun." |
||||
(car (cider--region-for-defun-at-point))) |
||||
|
||||
(defun cider-ns-form () |
||||
"Retrieve the ns form." |
||||
(when (clojure-find-ns) |
||||
(save-excursion |
||||
(goto-char (match-beginning 0)) |
||||
(cider-defun-at-point)))) |
||||
|
||||
(defun cider-bounds-of-sexp-at-point () |
||||
"Return the bounds sexp at point as a pair (or nil)." |
||||
(or (and (equal (char-after) ?\() |
||||
(member (char-before) '(?\' ?\, ?\@)) |
||||
;; hide stuff before ( to avoid quirks with '( etc. |
||||
(save-restriction |
||||
(narrow-to-region (point) (point-max)) |
||||
(bounds-of-thing-at-point 'sexp))) |
||||
(bounds-of-thing-at-point 'sexp))) |
||||
|
||||
(defun cider-map-indexed (f list) |
||||
"Return a list of (F index item) for each item in LIST." |
||||
(let ((i 0) |
||||
(out)) |
||||
(dolist (it list (nreverse out)) |
||||
(push (funcall f i it) out) |
||||
(setq i (1+ i))))) |
||||
|
||||
(defun cider-symbol-at-point () |
||||
"Return the name of the symbol at point, otherwise nil." |
||||
(let ((str (or (thing-at-point 'symbol) ""))) |
||||
(if (text-property-any 0 (length str) 'field 'cider-repl-prompt str) |
||||
"" |
||||
str))) |
||||
|
||||
(defun cider-sexp-at-point () |
||||
"Return the sexp at point as a string, otherwise nil." |
||||
(let ((bounds (cider-bounds-of-sexp-at-point))) |
||||
(if bounds |
||||
(buffer-substring-no-properties (car bounds) |
||||
(cdr bounds))))) |
||||
|
||||
(defun cider-sexp-at-point-with-bounds () |
||||
"Return a list containing the sexp at point and its bounds." |
||||
(let ((bounds (cider-bounds-of-sexp-at-point))) |
||||
(if bounds |
||||
(let ((start (car bounds)) |
||||
(end (cdr bounds))) |
||||
(list (buffer-substring-no-properties start end) |
||||
(cons (set-marker (make-marker) start) |
||||
(set-marker (make-marker) end))))))) |
||||
|
||||
(defun cider-last-sexp (&optional bounds) |
||||
"Return the sexp preceding the point. |
||||
If BOUNDS is non-nil, return a list of its starting and ending position |
||||
instead." |
||||
(apply (if bounds #'list #'buffer-substring-no-properties) |
||||
(save-excursion |
||||
(clojure-backward-logical-sexp 1) |
||||
(list (point) |
||||
(progn (clojure-forward-logical-sexp 1) |
||||
(point)))))) |
||||
|
||||
|
||||
;;; Text properties |
||||
|
||||
(defun cider-maybe-intern (name) |
||||
"If NAME is a symbol, return it; otherwise, intern it." |
||||
(if (symbolp name) name (intern name))) |
||||
|
||||
(defun cider-intern-keys (props) |
||||
"Copy plist-style PROPS with any non-symbol keys replaced with symbols." |
||||
(cider-map-indexed (lambda (i x) (if (cl-oddp i) x (cider-maybe-intern x))) props)) |
||||
|
||||
(defmacro cider-propertize-region (props &rest body) |
||||
"Execute BODY and add PROPS to all the text it inserts. |
||||
More precisely, PROPS are added to the region between the point's |
||||
positions before and after executing BODY." |
||||
(declare (indent 1)) |
||||
(let ((start (cl-gensym))) |
||||
`(let ((,start (point))) |
||||
(prog1 (progn ,@body) |
||||
(add-text-properties ,start (point) ,props))))) |
||||
|
||||
(put 'cider-propertize-region 'lisp-indent-function 1) |
||||
|
||||
(defun cider-property-bounds (prop) |
||||
"Return the the positions of the previous and next change to PROP. |
||||
PROP is the name of a text property." |
||||
(let ((end (next-single-char-property-change (point) prop))) |
||||
(list (previous-single-char-property-change end prop) end))) |
||||
|
||||
(defun cider-insert (text &optional face break more-text) |
||||
"Insert TEXT with FACE, optionally followed by a line BREAK and MORE-TEXT." |
||||
(insert (if face (propertize text 'font-lock-face face) text)) |
||||
(when more-text (insert more-text)) |
||||
(when break (insert "\n"))) |
||||
|
||||
;;; Font lock |
||||
|
||||
(defun cider--font-lock-ensure () |
||||
"Call `font-lock-ensure' or `font-lock-fontify-buffer', as appropriate." |
||||
(if (fboundp 'font-lock-ensure) |
||||
(font-lock-ensure) |
||||
(with-no-warnings |
||||
(font-lock-fontify-buffer)))) |
||||
|
||||
(defvar cider--mode-buffers nil |
||||
"A list of buffers for different major modes.") |
||||
|
||||
(defun cider--make-buffer-for-mode (mode) |
||||
"Return a temp buffer using major-mode MODE. |
||||
This buffer is not designed to display anything to the user. For that, use |
||||
`cider-make-popup-buffer' instead." |
||||
(or (cdr (assq mode cider--mode-buffers)) |
||||
(let ((b (generate-new-buffer (format " *cider-temp %s*" mode)))) |
||||
(push (cons mode b) cider--mode-buffers) |
||||
(with-current-buffer b |
||||
;; suppress major mode hooks as we care only about their font-locking |
||||
;; otherwise modes like whitespace-mode and paredit might interfere |
||||
(setq-local delay-mode-hooks t) |
||||
(setq delayed-mode-hooks nil) |
||||
(funcall mode)) |
||||
b))) |
||||
|
||||
(defun cider-font-lock-as (mode string) |
||||
"Use MODE to font-lock the STRING." |
||||
(if (or (null cider-font-lock-max-length) |
||||
(< (length string) cider-font-lock-max-length)) |
||||
(with-current-buffer (cider--make-buffer-for-mode mode) |
||||
(erase-buffer) |
||||
(insert string) |
||||
(font-lock-fontify-region (point-min) (point-max)) |
||||
(buffer-string)) |
||||
string)) |
||||
|
||||
(defun cider-font-lock-region-as (mode beg end &optional buffer) |
||||
"Use MODE to font-lock text between BEG and END. |
||||
|
||||
Unless you specify a BUFFER it will default to the current one." |
||||
(with-current-buffer (or buffer (current-buffer)) |
||||
(let ((text (buffer-substring beg end))) |
||||
(delete-region beg end) |
||||
(goto-char beg) |
||||
(insert (cider-font-lock-as mode text))))) |
||||
|
||||
(defun cider-font-lock-as-clojure (string) |
||||
"Font-lock STRING as Clojure code." |
||||
(cider-font-lock-as 'clojure-mode string)) |
||||
|
||||
;;; Colors |
||||
|
||||
(defun cider-scale-color (color scale) |
||||
"For a COLOR hex string or name, adjust intensity of RGB components by SCALE." |
||||
(let* ((rgb (color-values color)) |
||||
(scaled-rgb (mapcar (lambda (n) |
||||
(format "%04x" (round (+ n (* scale 65535))))) |
||||
rgb))) |
||||
(apply #'concat "#" scaled-rgb))) |
||||
|
||||
(defun cider-scale-background-color () |
||||
"Scale the current background color to get a slighted muted version." |
||||
(let ((color (frame-parameter nil 'background-color)) |
||||
(dark (eq (frame-parameter nil 'background-mode) 'dark))) |
||||
(cider-scale-color color (if dark 0.05 -0.05)))) |
||||
|
||||
(autoload 'pkg-info-version-info "pkg-info.el") |
||||
|
||||
(defvar cider-version) |
||||
|
||||
(defun cider--version () |
||||
"Retrieve CIDER's version." |
||||
(condition-case nil |
||||
(pkg-info-version-info 'cider) |
||||
(error cider-version))) |
||||
|
||||
;;; Strings |
||||
|
||||
(defun cider-string-join (strings &optional separator) |
||||
"Join all STRINGS using SEPARATOR." |
||||
(mapconcat #'identity strings separator)) |
||||
|
||||
(defun cider-join-into-alist (candidates &optional separator) |
||||
"Make an alist from CANDIDATES. |
||||
The keys are the elements joined with SEPARATOR and values are the original |
||||
elements. Useful for `completing-read' when candidates are complex |
||||
objects." |
||||
(mapcar (lambda (el) |
||||
(if (listp el) |
||||
(cons (cider-string-join el (or separator ":")) el) |
||||
(cons el el))) |
||||
candidates)) |
||||
|
||||
(defun cider-namespace-qualified-p (sym) |
||||
"Return t if SYM is namespace-qualified." |
||||
(string-match-p "[^/]+/" sym)) |
||||
|
||||
(defun cider--readme-button (label section-id) |
||||
"Return a button string that links to the online readme. |
||||
LABEL is the displayed string, and SECTION-ID is where it points |
||||
to." |
||||
(with-temp-buffer |
||||
(insert-text-button |
||||
label |
||||
'follow-link t |
||||
'action (lambda (&rest _) (interactive) |
||||
(browse-url (concat "https://github.com/clojure-emacs/cider#" |
||||
section-id)))) |
||||
(buffer-string))) |
||||
|
||||
(defun cider--project-name (dir) |
||||
"Extracts a project name from DIR, possibly nil. |
||||
The project name is the final component of DIR if not nil." |
||||
(when dir |
||||
(file-name-nondirectory (directory-file-name dir)))) |
||||
|
||||
;;; Vectors |
||||
(defun cider--deep-vector-to-list (x) |
||||
"Convert vectors in X to lists. |
||||
If X is a sequence, return a list of `cider--deep-vector-to-list' applied to |
||||
each of its elements. |
||||
Any other value is just returned." |
||||
(if (sequencep x) |
||||
(mapcar #'cider--deep-vector-to-list x) |
||||
x)) |
||||
|
||||
;;; Words of inspiration |
||||
(defun cider-user-first-name () |
||||
"Find the current user's first name." |
||||
(let ((name (if (string= (user-full-name) "") |
||||
(user-login-name) |
||||
(user-full-name)))) |
||||
(string-match "^[^ ]*" name) |
||||
(capitalize (match-string 0 name)))) |
||||
|
||||
(defvar cider-words-of-inspiration |
||||
`("The best way to predict the future is to invent it. -Alan Kay" |
||||
"A point of view is worth 80 IQ points. -Alan Kay" |
||||
"Lisp isn't a language, it's a building material. -Alan Kay" |
||||
"Simple things should be simple, complex things should be possible. -Alan Kay" |
||||
"Everything should be as simple as possible, but not simpler. -Albert Einstein" |
||||
"Measuring programming progress by lines of code is like measuring aircraft building progress by weight. -Bill Gates" |
||||
"Controlling complexity is the essence of computer programming. -Brian Kernighan" |
||||
"The unavoidable price of reliability is simplicity. -C.A.R. Hoare" |
||||
"You're bound to be unhappy if you optimize everything. -Donald Knuth" |
||||
"Simplicity is prerequisite for reliability. -Edsger W. Dijkstra" |
||||
"Elegance is not a dispensable luxury but a quality that decides between success and failure. -Edsger W. Dijkstra" |
||||
"Deleted code is debugged code. -Jeff Sickel" |
||||
"The key to performance is elegance, not battalions of special cases. -Jon Bentley and Doug McIlroy" |
||||
"First, solve the problem. Then, write the code. -John Johnson" |
||||
"Simplicity is the ultimate sophistication. -Leonardo da Vinci" |
||||
"Programming is not about typing... it's about thinking. -Rich Hickey" |
||||
"Design is about pulling things apart. -Rich Hickey" |
||||
"Programmers know the benefits of everything and the tradeoffs of nothing. -Rich Hickey" |
||||
"Code never lies, comments sometimes do. -Ron Jeffries" |
||||
"The true delight is in the finding out rather than in the knowing. -Isaac Asimov" |
||||
"If paredit is not for you, then you need to become the sort of person that paredit is for. -Phil Hagelberg" |
||||
"Express Yourself. -Madonna" |
||||
"Take this REPL, fellow hacker, and may it serve you well." |
||||
"Let the hacking commence!" |
||||
"Hacks and glory await!" |
||||
"Hack and be merry!" |
||||
"Your hacking starts... NOW!" |
||||
"May the Source be with you!" |
||||
"May the Source shine upon thy REPL!" |
||||
"Code long and prosper!" |
||||
"Happy hacking!" |
||||
"nREPL server is up, CIDER REPL is online!" |
||||
"CIDER REPL operational!" |
||||
"Your imagination is the only limit to what you can do with this REPL!" |
||||
"This REPL is yours to command!" |
||||
"Fame is but a hack away!" |
||||
"The REPL is not enough, but it is such a perfect place to start..." |
||||
,(format "%s, this could be the start of a beautiful program." |
||||
(cider-user-first-name))) |
||||
"Scientifically-proven optimal words of hackerish encouragement.") |
||||
|
||||
(defun cider-random-words-of-inspiration () |
||||
"Select a random entry from `cider-words-of-inspiration'." |
||||
(eval (nth (random (length cider-words-of-inspiration)) |
||||
cider-words-of-inspiration))) |
||||
|
||||
(provide 'cider-util) |
||||
|
||||
;;; cider-util.el ends here |
||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1 @@
|
||||
(define-package "clojure-mode" "20151022.27" "Major mode for Clojure code" '((emacs "24.3")) :url "http://github.com/clojure-emacs/clojure-mode" :keywords '("languages" "clojure" "clojurescript" "lisp")) |
||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1 @@
|
||||
(define-package "coffee-mode" "20151019.2009" "Major mode to edit CoffeeScript files in Emacs" '((emacs "24.1") (cl-lib "0.5")) :url "http://github.com/defunkt/coffee-mode" :keywords '("coffeescript" "major" "mode")) |
||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1 @@
|
||||
(define-package "dash" "20151021.113" "A modern list library for Emacs" 'nil :keywords '("lists")) |
||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1 @@
|
||||
(define-package "epl" "20150517.433" "Emacs Package Library" '((cl-lib "0.3")) :url "http://github.com/cask/epl" :keywords '("convenience")) |
||||
@ -0,0 +1,11 @@
|
||||
(define-package "flycheck" "20151022.1349" "On-the-fly syntax checking" |
||||
'((dash "2.4.0") |
||||
(pkg-info "0.4") |
||||
(let-alist "1.0.1") |
||||
(cl-lib "0.3") |
||||
(emacs "24.3")) |
||||
:url "https://www.flycheck.org" :keywords |
||||
'("convenience" "languages" "tools")) |
||||
;; Local Variables: |
||||
;; no-byte-compile: t |
||||
;; End: |
||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -0,0 +1 @@
|
||||
(define-package "flycheck-clojure" "20150831.631" "Flycheck: Clojure support" '((cider "0.8.1") (flycheck "0.22alpha1") (let-alist "1.0.1") (emacs "24")) :url "https://github.com/clojure-emacs/squiggly-clojure") |
||||
@ -0,0 +1,205 @@
|
||||
;;; flycheck-clojure.el --- Flycheck: Clojure support -*- lexical-binding: t; -*- |
||||
|
||||
;; Copyright © 2014 Peter Fraenkel |
||||
;; Copyright (C) 2014 Sebastian Wiesner <swiesner@lunaryorn.com> |
||||
;; |
||||
;; Author: Peter Fraenkel <pnf@podsnap.com> |
||||
;; Sebastian Wiesner <swiesner@lunaryorn.com> |
||||
;; Maintainer: Peter Fraenkel <pnf@podsnap.com> |
||||
;; URL: https://github.com/clojure-emacs/squiggly-clojure |
||||
;; Package-Version: 20150831.631 |
||||
;; Version: 1.1.0 |
||||
;; Package-Requires: ((cider "0.8.1") (flycheck "0.22-cvs1") (let-alist "1.0.1") (emacs "24")) |
||||
|
||||
;; This file is not part of GNU Emacs. |
||||
|
||||
;; This program 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 program 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 program. If not, see <http://www.gnu.org/licenses/>. |
||||
|
||||
;;; Commentary: |
||||
|
||||
;; Add Clojure support to Flycheck. |
||||
;; |
||||
;; Provide syntax checkers to check Clojure code using a running Cider repl. |
||||
;; |
||||
;; Installation: |
||||
;; |
||||
;; (eval-after-load 'flycheck '(flycheck-clojure-setup)) |
||||
|
||||
;;; Code: |
||||
|
||||
(require 'cider-client) |
||||
(require 'flycheck) |
||||
(require 'json) |
||||
(require 'url-parse) |
||||
(eval-when-compile (require 'let-alist)) |
||||
|
||||
;;;###autoload |
||||
(defun flycheck-clojure-parse-cider-errors (value checker) |
||||
"Parse cider errors from JSON VALUE from CHECKER. |
||||
|
||||
Return a list of parsed `flycheck-error' objects." |
||||
;; Parse the nested JSON from Cider. The outer JSON contains the return value |
||||
;; from Cider, and the inner JSON the errors returned by the individual |
||||
;; checker. |
||||
(let ((error-objects (json-read-from-string (json-read-from-string value)))) |
||||
(mapcar (lambda (o) |
||||
(let-alist o |
||||
;; Use the file name reported by the syntax checker, but only if |
||||
;; its absolute, because typed reports relative file names that |
||||
;; are hard to expand correctly, since they are relative to the |
||||
;; source directory (not the project directory). |
||||
(let* ((parsed-file (when .file |
||||
(url-filename |
||||
(url-generic-parse-url .file)))) |
||||
(filename (if (and parsed-file |
||||
(file-name-absolute-p parsed-file)) |
||||
parsed-file |
||||
(buffer-file-name)))) |
||||
(flycheck-error-new-at .line .column (intern .level) .msg |
||||
:checker checker |
||||
:filename filename)))) |
||||
error-objects))) |
||||
|
||||
(defun cider-flycheck-eval (input callback) |
||||
"Send the request INPUT and register the CALLBACK as the response handler. |
||||
Uses the tooling session, with no specified namespace." |
||||
(cider-nrepl-request:eval input callback)) |
||||
|
||||
(defun flycheck-clojure-may-use-cider-checker () |
||||
"Determine whether a cider checker may be used. |
||||
|
||||
Checks for `cider-mode', and a current nREPL connection. |
||||
|
||||
Standard predicate for cider checkers." |
||||
(let ((connection-buffer (cider-default-connection :no-error))) |
||||
(and (bound-and-true-p cider-mode) |
||||
connection-buffer |
||||
(buffer-live-p (get-buffer connection-buffer)) |
||||
(clojure-find-ns)))) |
||||
|
||||
(defun flycheck-clojure-start-cider (checker callback) |
||||
"Start a cider syntax CHECKER with CALLBACK." |
||||
(let ((ns (clojure-find-ns)) |
||||
(form (get checker 'flycheck-clojure-form))) |
||||
(cider-flycheck-eval |
||||
(funcall form ns) |
||||
(nrepl-make-response-handler |
||||
(current-buffer) |
||||
(lambda (buffer value) |
||||
(funcall callback 'finished |
||||
(with-current-buffer buffer |
||||
(flycheck-clojure-parse-cider-errors value checker)))) |
||||
nil ; stdout |
||||
nil ; stderr |
||||
(lambda (_) |
||||
;; If the evaluation completes without returning any value, there has |
||||
;; gone something wrong. Ideally, we'd report *what* was wrong, but |
||||
;; `nrepl-make-response-handler' is close to useless for this :(, |
||||
;; because it just `message's for many status codes that are errors for |
||||
;; us :( |
||||
(funcall callback 'errored "Done with no errors")) |
||||
(lambda (_buffer ex _rootex _sess) |
||||
(funcall callback 'errored |
||||
(format "Form %s of checker %s failed: %s" |
||||
form checker ex)))))) |
||||
) |
||||
|
||||
(defun flycheck-clojure-define-cider-checker (name docstring &rest properties) |
||||
"Define a Cider syntax checker with NAME, DOCSTRING and PROPERTIES. |
||||
|
||||
NAME, DOCSTRING, and PROPERTIES are like for |
||||
`flycheck-define-generic-checker', except that `:start' and |
||||
`:modes' are invalid PROPERTIES. A syntax checker defined with |
||||
this function will always check in `clojure-mode', and only if |
||||
`cider-mode' is enabled. |
||||
|
||||
Instead of `:start', this syntax checker requires a `:form |
||||
FUNCTION' property. FUNCTION takes the current Clojure namespace |
||||
as single argument, and shall return a string containing a |
||||
Clojure form to be sent to Cider to check the current buffer." |
||||
(declare (indent 1) |
||||
(doc-string 2)) |
||||
(let* ((form (plist-get properties :form)) |
||||
(orig-predicate (plist-get properties :predicate))) |
||||
|
||||
(when (plist-get :start properties) |
||||
(error "Checker %s may not have :start" name)) |
||||
(when (plist-get :modes properties) |
||||
(error "Checker %s may not have :modes" name)) |
||||
(unless (functionp form) |
||||
(error ":form %s of %s not a valid function" form name)) |
||||
(apply #'flycheck-define-generic-checker |
||||
name docstring |
||||
:start #'flycheck-clojure-start-cider |
||||
:modes '(clojure-mode) |
||||
:predicate (if orig-predicate |
||||
(lambda () |
||||
(and (flycheck-clojure-may-use-cider-checker) |
||||
(funcall orig-predicate))) |
||||
#'flycheck-clojure-may-use-cider-checker) |
||||
properties) |
||||
|
||||
(put name 'flycheck-clojure-form form))) |
||||
|
||||
(flycheck-clojure-define-cider-checker 'clojure-cider-eastwood |
||||
"A syntax checker for Clojure, using Eastwood in Cider. |
||||
|
||||
See URL `https://github.com/jonase/eastwood' and URL |
||||
`https://github.com/clojure-emacs/cider/' for more information." |
||||
:form (lambda (ns) |
||||
(format "(do (require 'squiggly-clojure.core) (squiggly-clojure.core/check-ew '%s))" |
||||
ns)) |
||||
:next-checkers '(clojure-cider-kibit clojure-cider-typed)) |
||||
|
||||
(flycheck-clojure-define-cider-checker 'clojure-cider-kibit |
||||
"A syntax checker for Clojure, using Kibit in Cider. |
||||
|
||||
See URL `https://github.com/jonase/kibit' and URL |
||||
`https://github.com/clojure-emacs/cider/' for more information." |
||||
:form (lambda (ns) |
||||
(format |
||||
"(do (require 'squiggly-clojure.core) (squiggly-clojure.core/check-kb '%s %s))" |
||||
ns |
||||
;; Escape file name for Clojure |
||||
(flycheck-sexp-to-string (buffer-file-name)))) |
||||
:predicate (lambda () (buffer-file-name)) |
||||
:next-checkers '(clojure-cider-typed)) |
||||
|
||||
(flycheck-clojure-define-cider-checker 'clojure-cider-typed |
||||
"A syntax checker for Clojure, using Typed Clojure in Cider. |
||||
|
||||
See URL `https://github.com/clojure-emacs/cider/' and URL |
||||
`https://github.com/clojure/core.typed' for more information." |
||||
:form (lambda (ns) |
||||
(format |
||||
"(do (require 'squiggly-clojure.core) (squiggly-clojure.core/check-tc '%s))" |
||||
ns))) |
||||
|
||||
;;;###autoload |
||||
(defun flycheck-clojure-setup () |
||||
"Setup Flycheck for Clojure." |
||||
(interactive) |
||||
;; Add checkers in reverse order, because `add-to-list' adds to front. |
||||
(dolist (checker '(clojure-cider-typed |
||||
clojure-cider-kibit |
||||
clojure-cider-eastwood)) |
||||
(add-to-list 'flycheck-checkers checker))) |
||||
|
||||
(provide 'flycheck-clojure) |
||||
|
||||
;; Local Variables: |
||||
;; indent-tabs-mode: nil |
||||
;; End: |
||||
|
||||
;;; flycheck-clojure.el ends here |
||||
@ -0,0 +1,11 @@
|
||||
(define-package "flycheck-haskell" "20151010.340" "Flycheck: Cabal projects and sandboxes" |
||||
'((emacs "24.1") |
||||
(flycheck "0.22") |
||||
(haskell-mode "13.7") |
||||
(dash "2.4.0") |
||||
(let-alist "1.0.1")) |
||||
:url "https://github.com/flycheck/flycheck-haskell" :keywords |
||||
'("tools" "convenience")) |
||||
;; Local Variables: |
||||
;; no-byte-compile: t |
||||
;; End: |
||||
@ -0,0 +1,209 @@
|
||||
-- Copyright (C) 2014, 2015 Sebastian Wiesner <swiesner@lunaryorn.com> |
||||
-- Copyright (C) 2014 Gracjan Polak <gracjanpolak@gmail.com> |
||||
-- Copyright (C) 2015 Michael Alan Dorman <mdorman@ironicdesign.com> |
||||
|
||||
-- This file is not part of GNU Emacs. |
||||
|
||||
-- This program 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 program 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 program. If not, see <http://www.gnu.org/licenses/>. |
||||
|
||||
{-# LANGUAGE CPP #-} |
||||
{-# LANGUAGE TypeSynonymInstances #-} |
||||
{-# LANGUAGE FlexibleInstances #-} |
||||
|
||||
import Control.Arrow (second) |
||||
import Data.List (nub, isPrefixOf) |
||||
import Data.Maybe (listToMaybe) |
||||
#ifdef USE_COMPILER_ID |
||||
import Distribution.Compiler |
||||
(CompilerFlavor(GHC), CompilerId(CompilerId), buildCompilerFlavor) |
||||
#else |
||||
import Distribution.Compiler |
||||
(AbiTag(NoAbiTag), CompilerFlavor(GHC), CompilerId(CompilerId), |
||||
CompilerInfo, buildCompilerFlavor, unknownCompilerInfo) |
||||
#endif |
||||
import Distribution.Package |
||||
(PackageName(..), PackageIdentifier(..), Dependency(..)) |
||||
import Distribution.PackageDescription |
||||
(PackageDescription(..), allBuildInfo, BuildInfo(..), |
||||
usedExtensions, allLanguages, hcOptions, exeName, testEnabled, |
||||
condTestSuites, benchmarkEnabled, condBenchmarks) |
||||
import Distribution.PackageDescription.Configuration |
||||
(finalizePackageDescription, mapTreeData) |
||||
import Distribution.PackageDescription.Parse (readPackageDescription) |
||||
import Distribution.Simple.BuildPaths (defaultDistPref) |
||||
import Distribution.System (buildPlatform) |
||||
import Distribution.Verbosity (silent) |
||||
import Language.Haskell.Extension (Extension(..),Language(..)) |
||||
import System.Environment (getArgs) |
||||
import System.Exit (exitFailure) |
||||
import System.FilePath ((</>),dropFileName,normalise) |
||||
import System.Info (compilerVersion) |
||||
|
||||
data Sexp |
||||
= SList [Sexp] |
||||
| SString String |
||||
| SSymbol String |
||||
|
||||
sym :: String -> Sexp |
||||
sym = SSymbol |
||||
|
||||
instance Show Sexp where |
||||
show (SSymbol s) = s |
||||
show (SString s) = show s -- Poor man's escaping |
||||
show (SList s) = "(" ++ unwords (map show s) ++ ")" |
||||
|
||||
class ToSexp a where |
||||
toSexp :: a -> Sexp |
||||
|
||||
instance ToSexp String where |
||||
toSexp = SString |
||||
|
||||
instance ToSexp Extension where |
||||
toSexp (EnableExtension ext) = toSexp (show ext) |
||||
toSexp (DisableExtension ext) = toSexp ("No" ++ show ext) |
||||
toSexp (UnknownExtension ext) = toSexp ext |
||||
|
||||
instance ToSexp Language where |
||||
toSexp (UnknownLanguage lang) = toSexp lang |
||||
toSexp lang = toSexp (show lang) |
||||
|
||||
instance ToSexp Dependency where |
||||
toSexp (Dependency (PackageName dependency) _) = toSexp dependency |
||||
|
||||
instance ToSexp Sexp where |
||||
toSexp = id |
||||
|
||||
cons :: (ToSexp a, ToSexp b) => a -> [b] -> Sexp |
||||
cons h t = SList (toSexp h : map toSexp t) |
||||
|
||||
getBuildDirectories :: PackageDescription -> FilePath -> [String] |
||||
getBuildDirectories pkgDesc cabalDir = |
||||
case library pkgDesc of |
||||
Just _ -> buildDir : buildDirs |
||||
Nothing -> buildDirs |
||||
where |
||||
distDir = cabalDir </> defaultDistPref |
||||
buildDir = distDir </> "build" |
||||
autogenDir = buildDir </> "autogen" |
||||
executableBuildDir e = buildDir </> exeName e </> (exeName e ++ "-tmp") |
||||
buildDirs = autogenDir : map executableBuildDir (executables pkgDesc) |
||||
|
||||
getSourceDirectories :: [BuildInfo] -> FilePath -> [String] |
||||
getSourceDirectories buildInfo cabalDir = |
||||
map (cabalDir </>) (concatMap hsSourceDirs buildInfo) |
||||
|
||||
allowedOptions :: [String] |
||||
allowedOptions = |
||||
[ "-W" |
||||
, "-w" |
||||
, "-Wall" |
||||
, "-fglasgow-exts" |
||||
, "-fpackage-trust" |
||||
, "-fhelpful-errors" |
||||
, "-F" |
||||
, "-cpp"] |
||||
|
||||
allowedOptionPrefixes :: [String] |
||||
allowedOptionPrefixes = |
||||
[ "-fwarn-" |
||||
, "-fno-warn-" |
||||
, "-fcontext-stack=" |
||||
, "-firrefutable-tuples" |
||||
, "-D" |
||||
, "-U" |
||||
, "-I" |
||||
, "-fplugin=" |
||||
, "-fplugin-opt=" |
||||
, "-pgm" |
||||
, "-opt"] |
||||
|
||||
isAllowedOption :: String -> Bool |
||||
isAllowedOption opt = |
||||
elem opt allowedOptions || any (`isPrefixOf` opt) allowedOptionPrefixes |
||||
|
||||
dumpPackageDescription :: PackageDescription -> FilePath -> Sexp |
||||
dumpPackageDescription pkgDesc cabalFile = |
||||
SList |
||||
[ cons (sym "build-directories") buildDirs |
||||
, cons (sym "source-directories") sourceDirs |
||||
, cons (sym "extensions") exts |
||||
, cons (sym "languages") langs |
||||
, cons (sym "dependencies") deps |
||||
, cons (sym "other-options") otherOptions] |
||||
where |
||||
cabalDir = dropFileName cabalFile |
||||
buildInfo = allBuildInfo pkgDesc |
||||
buildDirs = nub (map normalise (getBuildDirectories pkgDesc cabalDir)) |
||||
sourceDirs = nub (map normalise (getSourceDirectories buildInfo cabalDir)) |
||||
exts = nub (concatMap usedExtensions buildInfo) |
||||
langs = nub (concatMap allLanguages buildInfo) |
||||
thisPackage = (pkgName . package) pkgDesc |
||||
deps = |
||||
nub |
||||
(filter |
||||
(\(Dependency name _) -> |
||||
name /= thisPackage) |
||||
(buildDepends pkgDesc)) |
||||
otherOptions = |
||||
nub (filter isAllowedOption (concatMap (hcOptions GHC) buildInfo)) |
||||
|
||||
dumpCabalConfiguration :: String -> IO () |
||||
dumpCabalConfiguration cabalFile = do |
||||
genericDesc <- readPackageDescription silent cabalFile |
||||
-- This let block is eerily like one in Cabal.Distribution.Simple.Configure |
||||
let enableTest t = |
||||
t |
||||
{ testEnabled = True |
||||
} |
||||
flaggedTests = |
||||
map (second (mapTreeData enableTest)) (condTestSuites genericDesc) |
||||
enableBenchmark bm = |
||||
bm |
||||
{ benchmarkEnabled = True |
||||
} |
||||
flaggedBenchmarks = |
||||
map |
||||
(second (mapTreeData enableBenchmark)) |
||||
(condBenchmarks genericDesc) |
||||
genericDesc' = |
||||
genericDesc |
||||
{ condTestSuites = flaggedTests |
||||
, condBenchmarks = flaggedBenchmarks |
||||
} |
||||
case finalizePackageDescription |
||||
[] |
||||
(const True) |
||||
buildPlatform |
||||
buildCompilerId |
||||
[] |
||||
genericDesc' of |
||||
Left e -> putStrLn $ "Issue with package configuration\n" ++ show e |
||||
Right (pkgDesc,_) -> print (dumpPackageDescription pkgDesc cabalFile) |
||||
|
||||
#ifdef USE_COMPILER_ID |
||||
buildCompilerId :: CompilerId |
||||
buildCompilerId = CompilerId buildCompilerFlavor compilerVersion |
||||
#else |
||||
buildCompilerId :: CompilerInfo |
||||
buildCompilerId = |
||||
unknownCompilerInfo |
||||
(CompilerId buildCompilerFlavor compilerVersion) |
||||
NoAbiTag |
||||
#endif |
||||
|
||||
main :: IO () |
||||
main = do |
||||
args <- getArgs |
||||
let cabalFile = listToMaybe args |
||||
maybe exitFailure dumpCabalConfiguration cabalFile |
||||
@ -0,0 +1,48 @@
|
||||
-- Copyright (C) 2015 Michael Alan Dorman <mdorman@ironicdesign.com> |
||||
|
||||
-- This file is not part of GNU Emacs. |
||||
|
||||
-- This program 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 program 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 program. If not, see <http://www.gnu.org/licenses/>. |
||||
|
||||
import Data.Version (Version (Version)) |
||||
import Distribution.Simple.Utils (cabalVersion) |
||||
import System.Environment (getArgs) |
||||
|
||||
data Mode |
||||
= GHC |
||||
| HLint |
||||
|
||||
define :: Mode -> String -> String |
||||
define GHC def = "-D" ++ def |
||||
define HLint def = "--cpp-define=" ++ def |
||||
|
||||
legacyFlags :: Mode -> [String] |
||||
legacyFlags mode = [define mode "USE_COMPILER_ID"] |
||||
|
||||
isLegacyCabal :: Bool |
||||
isLegacyCabal = cabalVersion < Version [1, 22] [] |
||||
|
||||
getMode :: [String] -> Mode |
||||
getMode ("hlint":_) = HLint |
||||
getMode _ = GHC |
||||
|
||||
main :: IO () |
||||
main = do |
||||
args <- getArgs |
||||
mapM_ putStrLn (flags (getMode args)) |
||||
where |
||||
flags mode = |
||||
if isLegacyCabal |
||||
then legacyFlags mode |
||||
else [] |
||||
@ -0,0 +1 @@
|
||||
(define-package "flycheck-pos-tip" "20140606.510" "Flycheck errors display in tooltip" '((flycheck "0.18") (popup "0.5.0")) :url "https://github.com/flycheck/flycheck-pos-tip" :keywords '("tools" "convenience")) |
||||
@ -0,0 +1,61 @@
|
||||
;;; flycheck-pos-tip.el --- Flycheck errors display in tooltip |
||||
|
||||
;; Copyright (C) 2014 Akiha Senda |
||||
|
||||
;; Author: Akiha Senda <senda.akiha@gmail.com> |
||||
;; URL: https://github.com/flycheck/flycheck-pos-tip |
||||
;; Package-Version: 20140606.510 |
||||
;; Keywords: tools, convenience |
||||
;; Version: 0.0.1 |
||||
;; Package-Requires: ((flycheck "0.18") (popup "0.5.0")) |
||||
|
||||
;; This file is not part of GNU Emacs. |
||||
|
||||
;; This program 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 program 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 program. If not, see <http://www.gnu.org/licenses/>. |
||||
|
||||
;;; Commentary: |
||||
|
||||
;; Add error message display method for Flycheck. |
||||
|
||||
;;;; Setup |
||||
|
||||
;; (eval-after-load 'flycheck |
||||
;; '(custom-set-variables |
||||
;; '(flycheck-display-errors-function #'flycheck-pos-tip-error-messages))) |
||||
|
||||
;;; Code: |
||||
|
||||
(require 'flycheck) |
||||
(require 'popup) |
||||
|
||||
(defgroup flycheck-pos-tip nil |
||||
"Flycheck errors display in tooltip" |
||||
:prefix "flycheck-pos-tip-" |
||||
:group 'flycheck |
||||
:link '(url-link :tag "Github" "https://github.com/flycheck/flycheck-pos-tip")) |
||||
|
||||
;;;###autoload |
||||
(defun flycheck-pos-tip-error-messages (errors) |
||||
"Display the tooltip that the messages of ERRORS. |
||||
|
||||
Concatenate all non-nil messages of ERRORS separated by empty |
||||
lines, and display them with `pos-tip-show-no-propertize', which shows |
||||
the messages in tooltip, depending on the number of lines." |
||||
(-when-let (messages (-keep #'flycheck-error-message errors)) |
||||
(popup-tip |
||||
(mapconcat 'identity messages "\n")))) |
||||
|
||||
(provide 'flycheck-pos-tip) |
||||
|
||||
;;; flycheck-pos-tip.el ends here |
||||
@ -0,0 +1 @@
|
||||
(define-package "flycheck-rust" "20150609.1248" "Flycheck: Rust additions and Cargo support" '((emacs "24.1") (flycheck "0.20") (dash "2.4.0")) :url "https://github.com/flycheck/flycheck-rust" :keywords '("tools" "convenience")) |
||||
@ -0,0 +1,121 @@
|
||||
;;; flycheck-rust.el --- Flycheck: Rust additions and Cargo support -*- lexical-binding: t; -*- |
||||
|
||||
;; Copyright (C) 2014, 2015 Sebastian Wiesner <swiesner@lunaryorn.com> |
||||
|
||||
;; Author: Sebastian Wiesner <swiesner@lunaryorn.com> |
||||
;; URL: https://github.com/flycheck/flycheck-rust |
||||
;; Package-Version: 20150609.1248 |
||||
;; Keywords: tools, convenience |
||||
;; Version: 0.1-cvs |
||||
;; Package-Requires: ((emacs "24.1") (flycheck "0.20") (dash "2.4.0")) |
||||
|
||||
;; This file is not part of GNU Emacs. |
||||
|
||||
;; This program 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 program 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 program. If not, see <http://www.gnu.org/licenses/>. |
||||
|
||||
;;; Commentary: |
||||
|
||||
;; This Flycheck extension configures Flycheck automatically for the current |
||||
;; Cargo project. |
||||
;; |
||||
;; # Setup |
||||
;; |
||||
;; (add-hook 'flycheck-mode-hook #'flycheck-rust-setup) |
||||
;; |
||||
;; # Usage |
||||
;; |
||||
;; Just use Flycheck as usual in your Rust/Cargo projects. |
||||
;; |
||||
;; Note: You must run `cargo build` initially to install all dependencies. If |
||||
;; you add new dependencies to `Cargo.toml` you need to run `cargo build` |
||||
;; again. Otherwise you will see spurious errors about missing crates. |
||||
|
||||
;;; Code: |
||||
|
||||
(require 'dash) |
||||
(require 'flycheck) |
||||
|
||||
(defun flycheck-rust-executable-p (rel-name) |
||||
"Whether REL-NAME denotes an executable. |
||||
|
||||
REL-NAME is the file relative to the Cargo.toml file." |
||||
(or (string= "src/main.rs" rel-name) |
||||
(string-prefix-p "src/bin/" rel-name))) |
||||
|
||||
(defun flycheck-rust-test-p (rel-name) |
||||
"Whether REL-NAME denotes a test. |
||||
|
||||
REL-NAME is the file relative to the Cargo.toml file." |
||||
(string-prefix-p "tests/" rel-name)) |
||||
|
||||
(defun flycheck-rust-bench-p (rel-name) |
||||
"Whether REL-NAME denotes a bench. |
||||
|
||||
REL-NAME is the file relative to the Cargo.toml file." |
||||
(string-prefix-p "benches/" rel-name)) |
||||
|
||||
(defun flycheck-rust-example-p (rel-name) |
||||
"Whether REL-NAME denotes an example. |
||||
|
||||
REL-NAME is the file relative to the Cargo.toml file." |
||||
(string-prefix-p "examples/" rel-name)) |
||||
|
||||
(defun flycheck-rust-project-root () |
||||
"Get the project root for the current buffer. |
||||
|
||||
Return the directory containing the Cargo file, or nil if there |
||||
is none." |
||||
(locate-dominating-file (buffer-file-name) "Cargo.toml")) |
||||
|
||||
(defun flycheck-rust-find-crate-root () |
||||
"Get the crate root (the nearest lib.rs or main.rs) |
||||
relative to the current file." |
||||
(-if-let (lib-crate-dir (locate-dominating-file (buffer-file-name) "lib.rs")) |
||||
(expand-file-name "lib.rs" lib-crate-dir) |
||||
(-when-let (exe-crate-dir (locate-dominating-file (buffer-file-name) "main.rs")) |
||||
(expand-file-name "main.rs" exe-crate-dir)))) |
||||
|
||||
;;;###autoload |
||||
(defun flycheck-rust-setup () |
||||
"Setup Rust in Flycheck. |
||||
|
||||
If the current file is part of a Cargo project, configure |
||||
Flycheck according to the Cargo project layout." |
||||
(interactive) |
||||
(when (buffer-file-name) |
||||
(-when-let (root (flycheck-rust-project-root)) |
||||
(let ((rel-name (file-relative-name (buffer-file-name) root))) |
||||
;; These are valid crate roots as by Cargo's layout |
||||
(unless (or (flycheck-rust-executable-p rel-name) |
||||
(flycheck-rust-test-p rel-name) |
||||
(flycheck-rust-bench-p rel-name) |
||||
(flycheck-rust-example-p rel-name) |
||||
(string= "src/lib.rs" rel-name)) |
||||
;; For other files, the library is either the default library or the |
||||
;; executable |
||||
(setq-local flycheck-rust-crate-root (flycheck-rust-find-crate-root))) |
||||
;; Check tests in libraries and integration tests |
||||
(setq-local flycheck-rust-check-tests |
||||
(not (flycheck-rust-executable-p rel-name))) |
||||
;; Set the crate type |
||||
(setq-local flycheck-rust-crate-type |
||||
(if (flycheck-rust-executable-p rel-name) "bin" "lib")) |
||||
;; Find build libraries |
||||
(setq-local flycheck-rust-library-path |
||||
(list (expand-file-name "target/debug" root) |
||||
(expand-file-name "target/debug/deps" root))))))) |
||||
|
||||
(provide 'flycheck-rust) |
||||
|
||||
;;; flycheck-rust.el ends here |
||||
@ -0,0 +1 @@
|
||||
(define-package "gitignore-mode" "20150330.1048" "Major mode for editing .gitignore files" 'nil :url "https://github.com/magit/git-modes" :keywords '("convenience" "vc" "git")) |
||||
@ -0,0 +1,61 @@
|
||||
;;; gitignore-mode.el --- Major mode for editing .gitignore files -*- lexical-binding: t; -*- |
||||
|
||||
;; Copyright (c) 2012-2013 Sebastian Wiesner |
||||
;; Copyright (C) 2012-2015 The Magit Project Developers |
||||
|
||||
;; Author: Sebastian Wiesner <lunaryorn@gmail.com> |
||||
;; Maintainer: Jonas Bernoulli <jonas@bernoul.li> |
||||
;; Homepage: https://github.com/magit/git-modes |
||||
;; Keywords: convenience vc git |
||||
;; Package-Version: 20150330.1048 |
||||
|
||||
;; 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, 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: |
||||
|
||||
;; A major mode for editing .gitignore files. |
||||
|
||||
;;; Code: |
||||
|
||||
(require 'conf-mode) |
||||
|
||||
(defvar gitignore-mode-font-lock-keywords |
||||
'(("^\\s<.*$" . font-lock-comment-face) |
||||
("^!" . font-lock-negation-char-face) ; Negative pattern |
||||
("/" . font-lock-constant-face) ; Directory separators |
||||
("[*?]" . font-lock-keyword-face) ; Glob patterns |
||||
("\\[.+?\\]" . font-lock-keyword-face))) ; Ranged glob patterns |
||||
|
||||
;;;###autoload |
||||
(define-derived-mode gitignore-mode conf-unix-mode "Gitignore" |
||||
"A major mode for editing .gitignore files." |
||||
(conf-mode-initialize "#") |
||||
;; Disable syntactic font locking, because comments are only valid at |
||||
;; beginning of line. |
||||
(setq font-lock-defaults '(gitignore-mode-font-lock-keywords t t)) |
||||
(set (make-local-variable 'conf-assignment-sign) nil)) |
||||
|
||||
;;;###autoload |
||||
(dolist (pattern (list "/\\.gitignore\\'" |
||||
"/\\.git/info/exclude\\'" |
||||
"/git/ignore\\'")) |
||||
(add-to-list 'auto-mode-alist (cons pattern 'gitignore-mode))) |
||||
|
||||
(provide 'gitignore-mode) |
||||
;; Local Variables: |
||||
;; indent-tabs-mode: nil |
||||
;; End: |
||||
;;; gitignore-mode.el ends here |
||||
Binary file not shown.
Binary file not shown.
@ -0,0 +1,438 @@
|
||||
Haskell Mode NEWS -*- org -*- |
||||
|
||||
This file uses Org mode. Some useful (default) key-bindings: |
||||
- Use "C-c C-n"/"C-c C-p" to jump to next/prev heading |
||||
- Use "<tab>" to expand/collapse nodes |
||||
- Use "<backtab>" to cycle visibility of all nodes |
||||
- Use "C-c C-o" to open links |
||||
|
||||
* Changes in 13.12 |
||||
|
||||
- Added haskell-bot.el |
||||
|
||||
- Added support for cabal repl build targets |
||||
|
||||
- Automatically add import lines via Hoogle |
||||
|
||||
- Automatically add package to cabal file |
||||
|
||||
- Added w3m-haddock.el |
||||
|
||||
- Added debugger mode |
||||
|
||||
- Added preliminary :present support |
||||
|
||||
- Added haskell-sort-imports |
||||
|
||||
- Added haskell-complete-module |
||||
|
||||
- Support if and multi-way if in indentation |
||||
|
||||
- Add support to generate tags on windows |
||||
|
||||
- Add haskell-language-extensions variable |
||||
|
||||
- Improve haskell-simple-indent mode |
||||
|
||||
- Improve test cases |
||||
|
||||
* Changes in 13.10 |
||||
|
||||
- Small fix for haskell-simple-indent: Certain indentation situations |
||||
cause valname-string to be nil, which haskell-trim did not handle |
||||
gracefully (naturally, since nil != ""). |
||||
|
||||
- Luke Hoersten's Shnippet merged in under snippets/. |
||||
|
||||
- haskell-presentation-mode is now a haskell-mode derived mode. |
||||
|
||||
- Small improvement to haskell-process-do-info (works on constructors |
||||
now and underscored names). |
||||
|
||||
- Add haskell-indent-spaces configuration variable. |
||||
|
||||
- The command string to run cabal commands is slightly more |
||||
configurable. See: C-h f haskell-process-do-cabal-format-string |
||||
|
||||
* Changes in 13.8 |
||||
|
||||
See also [[https://github.com/haskell/haskell-mode/compare/v13.07...v13.08][detailed Git history]]. |
||||
|
||||
- Make `haskell-simple-indent-mode' a proper minor mode with `SInd` as |
||||
mode-line lighter |
||||
|
||||
- Support popular "λ> " prompt in inf-haskell by default |
||||
|
||||
- Hide internal `*print-haskell-mode*' buffers |
||||
(used when `haskell-interactive-mode-eval-mode' is active) |
||||
|
||||
- Add tab-completion support for haskell-interactive-mode |
||||
(requires `:complete' command support in GHCi) |
||||
|
||||
- Add support to `haskell-process-do-info` to perform `:browse!` query |
||||
on module name when called on import statement line |
||||
|
||||
- `haskell-decl-scan-mode': |
||||
- New customize group `haskell-decl-scan' |
||||
- New flag `haskell-decl-scan-bindings-as-variables' for controlling |
||||
whether to put value bindings into the "Variables" category. |
||||
- New flag `haskell-decl-scan-add-to-menubar' for controlling |
||||
whether to add "Declarations" menu entry to menu bar. |
||||
- New manual section node `(haskell-mode)haskell-decl-scan-mode' |
||||
|
||||
- Add support for [[http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#lambda-case][LambdaCase]] syntax extension to `haskell-indentation` |
||||
|
||||
- Change `haskell-indentation-mode' to never jump back a whole line |
||||
when pressing DEL. The old behavior can be restored by setting |
||||
`haskell-indentation-delete-backward-jump-line' to t |
||||
|
||||
- New convenience function `haskell-cabal-visit-file' for locating and |
||||
visiting most likely `.cabal` file associated with current buffer |
||||
|
||||
- Add support for [[http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#package-import][PackageImports]] and [[http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#safe-imports-ext][SafeHaskell]] syntax extensions to |
||||
`haskell-decl-scan-mode' parser |
||||
|
||||
- Add `turn-{on,off}-haskell-doc' commands as aliases for the existing |
||||
`turn-{on,off}-haskell-doc-mode' commands |
||||
|
||||
- Add support for "cabal repl" process type to `haskell-interactive-mode' |
||||
|
||||
- Add new Haskell compilation sub-mode and associated `haskell-compile' |
||||
command |
||||
|
||||
* Changes in 13.7 |
||||
|
||||
See also [[https://github.com/haskell/haskell-mode/compare/v13.06...v13.07][detailed Git history]]. |
||||
|
||||
- Convert NEWS (this file) to Org mode style and include NEWS file in |
||||
package and add command for visiting NEWS file |
||||
(M-x haskell-mode-view-news) |
||||
|
||||
- Officially drop support for versions prior to Emacs 23 |
||||
|
||||
- New work-in-progress Info manual for haskell-mode |
||||
|
||||
- Remove deprecated `haskell-{hugs,ghci}' modules |
||||
|
||||
- Font-locking changes: |
||||
- Remove deprecated `turn-on-haskell-font-lock` function |
||||
- Improve font-locking of type-signatures in presence of newlines |
||||
- Use `font-lock-preprocessor-face' instead of the previously used |
||||
`font-lock-warning-face` for CPP directives |
||||
- Use `font-lock-warning-face` instead of the previously used |
||||
`font-lock-preprocessor-face` for Git merge conflict annotations. |
||||
|
||||
- Improvements to `haskell-move-nested' module: |
||||
- Add support for operating on active regions |
||||
- New interactive commands `haskell-move-nested-{left,right}` which |
||||
support numeric prefix arguments for controlling the amount of |
||||
shifting to apply. |
||||
|
||||
- Add `haskell-unicode-input-method.el` to distribution |
||||
(enable with `turn-on-haskell-unicode-input-method`) |
||||
|
||||
- Fix all byte-compilation warnings |
||||
|
||||
- Build-system: |
||||
- For in-place installation, `haskell-site-file.el' is renamed |
||||
to `haskell-mode-autoloads.el` |
||||
- Auto-generate ELPA compatible README file by extracting header of |
||||
haskell-mode.el |
||||
- New "make check" target |
||||
- Add Travis-CI build jobs for testing byte-compilation with |
||||
multiple Emacs versions |
||||
|
||||
- Reorganize customize settings |
||||
- Add new convenience function for browsing all Haskell Mode settings |
||||
(M-x haskell-customize) |
||||
- Add `:link' keywords pointing to the new Info manual |
||||
- Add `:group' keywords to modes to make (M-x customize-mode) work |
||||
- Create new customization groups `haskell-interactive' and `inferior-haskell' |
||||
to clean up namespace |
||||
- Create new customization group `ghc-core` containing the two new |
||||
customization variables `ghc-core-program` and `ghc-core-program-args`. |
||||
|
||||
- Improvements to haskell-interactive-mode |
||||
- Add support for deleting compile messages superseded by recompile/reloads |
||||
(M-x customize-variable RET haskell-interactive-mode-delete-superseded-errors) |
||||
- Fix `C-u M-x haskell-process-do-type` inserting bad signatures |
||||
- Integrate with Emacs' `next-error` subsystem |
||||
- Add "C-c C-f" binding to REPL keymap for enabling `next-error-follow-minor-mode' |
||||
- Add support for `-ferror-spans`-style compile messages |
||||
- Add `-ferror-spans` as default for `haskell-process-args-ghci` |
||||
- Add optional argument to |
||||
`haskell-session-{all,installed,project}-modules' to suppress |
||||
session-creation. This is useful for yasnippet usage, see commit |
||||
517fd7e for an example. |
||||
- Change default for `haskell-process-path-ghci` to a static "ghci" |
||||
- Fix `haskell-interactive-switch` not selecting the REPL window |
||||
- Make `*haskell-process-log*` buffer configurable |
||||
(controlled via new `haskell-process-log` customize option) |
||||
|
||||
* Changes in 13.6 |
||||
|
||||
See also [[https://github.com/haskell/haskell-mode/compare/2_9_1...v13.06][detailed Git history]]. |
||||
|
||||
- Switch to new versioning scheme |
||||
|
||||
- Switch to MELPA/Marmalade based packaging |
||||
|
||||
- Cleanup/refactor build-system |
||||
|
||||
- Enhance `M-x haskell-version` to report more detailed versioning |
||||
information |
||||
|
||||
- Make haskell-interactive-mode emulate comint/eshell history navigation |
||||
(see commit 0e96843 for more details) |
||||
|
||||
- Improvements to haskell-interactive-mode |
||||
- Improve killing/restarting haskell-interactive sessions |
||||
- Improve directory prompting and resolution |
||||
- Fix redundant-import suggest trigger to support qualified imports |
||||
- Detect all abbreviations of an user-inputted ":quit" |
||||
- Fix regexps for recent GHC 7.x compiler messages |
||||
- Customizable commandline args for GHCi |
||||
(M-x customize-variable RET haskell-process-args-ghci) |
||||
- New command to load or reload via prefix argument |
||||
(M-x haskell-process-load-or-reload) |
||||
- Fix haskell-interactive-mode prompt detection |
||||
- Add cabal-ghci as supported process mode |
||||
- Add a customization option for the visibility of multi-line errors |
||||
(M-x customize-variable RET haskell-interactive-mode-hide-multi-line-errors) |
||||
|
||||
- Add forward declarations to reduce Elisp bytecompile warnings |
||||
|
||||
- Improvements to `haskell-indentation` |
||||
- Add support for the UnicodeSyntax tokens `→`, `←`, and `∷`. |
||||
- Indent "=" following data/type/newtype declarations. |
||||
- Align "->"/"→" arrows in types under "::"/"∷" |
||||
- Make customizable whether "<backspace>" deletes indentation too |
||||
(via `haskell-indentation-delete-backward-indentation` and |
||||
`haskell-indentation-delete-indentation`) |
||||
- Properly indent 'rec' keyword, same as 'mdo' |
||||
- Minor optimizations. |
||||
|
||||
- Add support for "'"-prefixed constructors (-> DataKinds) to font-locking |
||||
|
||||
- New experimental haskell session menu mode (M-x haskell-menu) |
||||
|
||||
- Various minor cleanups/fixes/improvements... |
||||
|
||||
* Changes in 2.9.1 |
||||
|
||||
See also [[https://github.com/haskell/haskell-mode/compare/2_9_0...2_9_1][detailed Git history]]. |
||||
|
||||
- Bugfix release adding missing autoload declaration |
||||
|
||||
* Changes in 2.9.0 |
||||
|
||||
See also [[https://github.com/haskell/haskell-mode/compare/2_8_0...2_9_0][detailed Git history]]. |
||||
|
||||
- This is the first release after haskell-mode was migrated to GitHub |
||||
|
||||
- New experimental `haskell-interactive-mode' module implementing a |
||||
new REPL interaction mode for GHCi sessions to eventually replace |
||||
the existing "inf-haskell" mode. |
||||
|
||||
- New `haskell-process-cabal' command for interaction with cabal-install |
||||
|
||||
- New `haskell-checkers' module |
||||
|
||||
- Update haskell-cabal-mode font-lock keywords |
||||
|
||||
- Improve scrolling of hoogle output (haskell-mode.el) |
||||
|
||||
- Derive `haskell-mode` from `prog-mode` for Emacs 24+ |
||||
|
||||
- Add new binding for "<backtab>" to haskell-mode's keymap which |
||||
unindents current line |
||||
|
||||
- New modules `haskell-navigate-imports`, `haskell-sort-imports' and |
||||
`haskell-align-imports' for operating on module import lines in |
||||
Haskell source code |
||||
|
||||
- Add new binding for "C-c C-." to haskell-mode's keymap to sort and |
||||
realign Haskell module imports |
||||
|
||||
- Add new binding for "C-c i" to haskell-mode's keymap to jump back and |
||||
forth from/to the current Haskell module's module import section. |
||||
|
||||
- New `inferior-haskell-kind' function for querying kind via GHCi's ":kind" |
||||
|
||||
- New `inferior-haskell-send-decl' for sending declarations to GHCi |
||||
(bound to "C-x C-d" by default) |
||||
|
||||
- Add new `haskell-doc-use-inf-haskell` customization variable |
||||
|
||||
- Add support for bird-style literate haskell editing and a new |
||||
related customization variable |
||||
`haskell-indentation-birdtrack-extra-space' |
||||
|
||||
- Font locking improvements |
||||
- Add support for Git's merge annotation |
||||
(with `font-lock-preprocessor-face') |
||||
- Improve `import', `foreign import' and `foreign export' font |
||||
locking |
||||
- Add support for `rec', `proc' and `mdo` as keywords |
||||
- Make whitespace within `-- |' and `{- |' optional when possible |
||||
|
||||
- New `haskell-move-nested` module providing utilities for |
||||
interactively {in,de}denting nested "hanging" blocks. |
||||
|
||||
- Add stylish-haskell support |
||||
(enable via `haskell-stylish-on-save` customization variable) |
||||
|
||||
- Add support for generating tags on save |
||||
(enable via `haskell-tags-on-save' customization variable) |
||||
|
||||
- Set sensible dabbrev defaults in haskell-mode |
||||
|
||||
- Added `SCC` pragma insert/delete commands |
||||
(`haskell-mode-insert-scc-at-point` and `haskell-mode-kill-scc-at-point') |
||||
|
||||
- New experimental `haskell-mode-contextual-space' command |
||||
|
||||
- And a couple more cleanups/fixes/improvements... |
||||
|
||||
* Changes in 2.8.0 (since 2.7.0) |
||||
|
||||
See also [[https://github.com/haskell/haskell-mode/compare/2_7_0...2_8_0][detailed Git history]]. |
||||
|
||||
- Minimal indentation support for arrow syntax |
||||
|
||||
- Avoid opening a new inf-haskell window if one is already visible. |
||||
Windows on other virtual desktops or iconified frames don't count. |
||||
|
||||
- Force comint-process-echoes to nil |
||||
|
||||
- Autolaunch haskell-mode for files starting with #!/usr/bin/runghc |
||||
and similar |
||||
|
||||
- Added minimal major mode for parsing GHC core files, courtesy of Johan Tibell. |
||||
There is a corresponding Haskell menu entry. |
||||
|
||||
- Allow configuration of where-clause indentation; M-x customize-group |
||||
haskell-indentation. |
||||
|
||||
* Changes since 2.6.4 |
||||
|
||||
- fill-paragraph (M-q) now only affects comments, and correctly |
||||
handles Haddock commentary. adaptive-fill-mode is turned off, as it |
||||
was interfering. |
||||
|
||||
- Yet more unicode symbols |
||||
|
||||
- Better support for unicode encoding of haskell source files |
||||
|
||||
- mdo correctly indented |
||||
|
||||
- Indentation fixes, fixes to the fixes, and fixes to the fixes to the |
||||
fixes |
||||
|
||||
- New command: M-x haskell-check, calls (by default) hlint on the |
||||
current file. Also bound to C-c C-v. |
||||
|
||||
You can also use the flymake minor mode with this. |
||||
|
||||
* Changes since 2.5.1 |
||||
|
||||
- Parser corrections for haskell-indentation and haskell-decl-scan |
||||
|
||||
- haskell-indentation: Pressing tab in the rightmost position now |
||||
moves to the leftmost, by default with a warning. |
||||
|
||||
- Typo fix: One haskell-indentation variable had ended up in the |
||||
haskell-ntation customize group. |
||||
|
||||
- haskell-hoogle aliased to hoogle, haskell-hayoo aliased to hayoo |
||||
|
||||
- Courtesy of Alex Ott: |
||||
- Additional unicode symbols for font-lock-symbols: () == /= >= <= !! && || sqrt |
||||
- M-x haskell-hayoo search added, opens using browse-url |
||||
- Bug-fix for inferior-haskell-type |
||||
|
||||
- If haskell-indentation errors out, it now fail-safes to inserting |
||||
a literal newline or deleting one character, for return and |
||||
backspace respectively. |
||||
|
||||
* Changes since 2.4: |
||||
|
||||
- haskell-indentation, a new minor mode for indentation. |
||||
|
||||
* Changes since 2.3: |
||||
|
||||
- Update license to GPLv3. |
||||
|
||||
- New derived major mode for .hsc files. |
||||
|
||||
- Removed the C-c C-r binding to reload a file. You can still call |
||||
inferior-haskell-reload-file (and/or bind it to your favorite key, |
||||
including C-c C-r) or you can now use C-u C-c C-l. |
||||
|
||||
- C-c C-d looks up the symbol at point in the Haddock docs. |
||||
|
||||
- Haddock comments are highlighted with font-lock-doc-face if it exists. |
||||
|
||||
- Use `tex' rather than `latex' for haskell-literate. |
||||
|
||||
- inf-haskell.el tries to find the root of the module hierarchy to determine |
||||
the root of a project (either by looking for a Cabal file or relying on |
||||
the `module' declaration line). If all works well, this will make C-c C-l |
||||
automatically switch to the root dir, so that dependencies in other |
||||
directories are automatically found. If it doesn't, complain and/or set |
||||
inferior-haskell-find-project-root to nil. |
||||
|
||||
- The new command haskell-hoogle helps you query Hoogle from Emacs. |
||||
|
||||
* Changes since 2.2: |
||||
|
||||
- Trivial support for Cabal package description files. |
||||
|
||||
- Minor bug fixes. |
||||
|
||||
* Changes since 2.1: |
||||
|
||||
- There are now commands to find type and info of identifiers by querying an |
||||
inferior haskell process. Available under C-c C-t, C-c C-i, and C-c M-. |
||||
|
||||
- Indentation now looks back further, until a line that has no indentation. |
||||
To recover the earlier behavior of stopping at the first empty line |
||||
instead, configure haskell-indent-look-past-empty-line. |
||||
|
||||
- inf-haskell can wait until a file load completes and jump directly to the |
||||
first error, like haskell-ghci and haskell-hugs used to do. See the var |
||||
inferior-haskell-wait-and-jump. |
||||
|
||||
* Changes since 2.0: |
||||
|
||||
- inf-haskell uses ghci if hugs is absent. |
||||
|
||||
- Fix up some binding conflicts (C-c C-o in haskell-doc) |
||||
|
||||
- Many (hopefully minor) changes to the indentation. |
||||
|
||||
- New symbols in haskell-font-lock-symbols-alist. |
||||
|
||||
* Changes since 1.45: |
||||
|
||||
- keybindings C-c <char> have been replaced by C-c C-<char> so as not |
||||
to collide with minor modes. |
||||
|
||||
- The following modules are now automatically activated without having to |
||||
add anything to haskell-mode-hook: |
||||
haskell-font-lock (just turn on global-font-lock-mode). |
||||
haskell-decl-scan (just bind `imenu' to some key). |
||||
|
||||
- In recent Emacsen, haskell-doc hooks into eldoc-mode. |
||||
|
||||
- haskell-hugs and haskell-ghci are superceded by inf-haskell. |
||||
|
||||
- Indentation rules have been improved when using layout inside parens/braces. |
||||
|
||||
- Symbols like -> and \ can be displayed as actual arrows and lambdas. |
||||
See haskell-font-lock-symbols. |
||||
|
||||
- Tweaks to the font-lock settings. Among other things paren-matching |
||||
with things like \(x,y) should work correctly now. |
||||
|
||||
- New maintainer <monnier@gnu.org>. |
||||
@ -0,0 +1,125 @@
|
||||
;;; ghc-core.el --- Syntax highlighting module for GHC Core -*- lexical-binding: t -*- |
||||
|
||||
;; Copyright (C) 2010 Johan Tibell |
||||
|
||||
;; Author: Johan Tibell <johan.tibell@gmail.com> |
||||
|
||||
;; 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, 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 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. |
||||
|
||||
;;; Commentary: |
||||
|
||||
;; Purpose: |
||||
;; |
||||
;; To make it easier to read GHC Core output by providing highlighting |
||||
;; and removal of commonly ignored annotations. |
||||
|
||||
;;; Code: |
||||
(require 'haskell-mode) |
||||
(require 'haskell-font-lock) |
||||
|
||||
;;;###autoload |
||||
(defgroup ghc-core nil |
||||
"Major mode for viewing pretty printed GHC Core output." |
||||
:link '(custom-manual "(haskell-mode)") |
||||
:group 'haskell |
||||
:prefix "ghc-core-") |
||||
|
||||
;;;###autoload |
||||
(defcustom ghc-core-program |
||||
"ghc" |
||||
"Name of the GHC executable (excluding any arguments)." |
||||
:type 'string |
||||
:group 'ghc-core) |
||||
|
||||
;;;###autoload |
||||
(defcustom ghc-core-program-args |
||||
'("-O2") |
||||
"Additional options to be passed to GHC when generating core output. |
||||
GHC (see variable `ghc-core-program') is invoked with the basic |
||||
command line options \"-ddump-simpl -c <source-file>\" |
||||
followed by the additional options defined here. |
||||
|
||||
The following `-ddump-simpl` options might be of interest: |
||||
|
||||
- `-dsuppress-all' |
||||
- `-dsuppress-uniques' |
||||
- `-dsuppress-idinfo' |
||||
- `-dsuppress-module-prefixes' |
||||
- `-dsuppress-type-signatures' |
||||
- `-dsuppress-type-applications' |
||||
- `-dsuppress-coercions' |
||||
|
||||
See `M-x manual-entry RET ghc' for more details." |
||||
:type '(repeat (string :tag "Argument")) |
||||
:group 'ghc-core) |
||||
|
||||
(define-obsolete-variable-alias 'ghc-core-create-options 'ghc-core-program-args |
||||
"haskell-mode 13.7") |
||||
|
||||
(defun ghc-core-clean-region (start end) |
||||
"Remove commonly ignored annotations and namespace prefixes |
||||
in the region between START and END." |
||||
(interactive "r") |
||||
(save-restriction |
||||
(narrow-to-region start end) |
||||
(goto-char (point-min)) |
||||
(while (search-forward-regexp "GHC\.[^\.]*\." nil t) |
||||
(replace-match "" nil t)) |
||||
(goto-char (point-min)) |
||||
(while (flush-lines "^ *GblId *$" nil)) |
||||
(goto-char (point-min)) |
||||
(while (flush-lines "^ *LclId *$" nil)) |
||||
(goto-char (point-min)) |
||||
(while (flush-lines (concat "^ *\\[\\(?:Arity [0-9]+\\|NoCafRefs\\|" |
||||
"Str: DmdType\\|Worker \\)" |
||||
"\\([^]]*\\n?\\).*\\] *$") nil)) |
||||
(goto-char (point-min)) |
||||
(while (search-forward "Main." nil t) (replace-match "" nil t)))) |
||||
|
||||
(defun ghc-core-clean-buffer () |
||||
"Remove commonly ignored annotations and namespace prefixes |
||||
in the current buffer." |
||||
(interactive) |
||||
(ghc-core-clean-region (point-min) (point-max))) |
||||
|
||||
;;;###autoload |
||||
(defun ghc-core-create-core () |
||||
"Compile and load the current buffer as tidy core." |
||||
(interactive) |
||||
(save-buffer) |
||||
(let* ((core-buffer (generate-new-buffer "ghc-core")) |
||||
(neh (lambda () (kill-buffer core-buffer)))) |
||||
(add-hook 'next-error-hook neh) |
||||
(apply #'call-process ghc-core-program nil core-buffer nil |
||||
"-ddump-simpl" "-c" (buffer-file-name) ghc-core-program-args) |
||||
(display-buffer core-buffer) |
||||
(with-current-buffer core-buffer |
||||
(ghc-core-mode)) |
||||
(remove-hook 'next-error-hook neh))) |
||||
|
||||
;;;###autoload |
||||
(add-to-list 'auto-mode-alist '("\\.hcr\\'" . ghc-core-mode)) |
||||
;;;###autoload |
||||
(add-to-list 'auto-mode-alist '("\\.dump-simpl\\'" . ghc-core-mode)) |
||||
|
||||
;;;###autoload |
||||
(define-derived-mode ghc-core-mode haskell-mode "GHC-Core" |
||||
"Major mode for GHC Core files.") |
||||
|
||||
(provide 'ghc-core) |
||||
;;; ghc-core.el ends here |
||||
@ -0,0 +1,68 @@
|
||||
;;; ghci-script-mode.el --- GHCi scripts major mode -*- lexical-binding: t -*- |
||||
|
||||
;; Copyright (c) 2014 Chris Done. All rights reserved. |
||||
|
||||
;; 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, 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 program. If not, see <http://www.gnu.org/licenses/>. |
||||
|
||||
;;; Code: |
||||
|
||||
(require 'haskell) |
||||
|
||||
(defvar ghci-script-mode-keywords |
||||
;; The comment syntax can't be described simply in syntax-table. |
||||
;; We could use font-lock-syntactic-keywords, but is it worth it? |
||||
'(("^[ \t]*--.*" . font-lock-comment-face) |
||||
("^ *\\([^ \t:]+\\):" (1 font-lock-keyword-face)) |
||||
("^:[a-z{]+ *\\+" . font-lock-keyword-face) |
||||
("^:[a-z{]+ " . font-lock-keyword-face))) |
||||
|
||||
;;;###autoload |
||||
(define-derived-mode ghci-script-mode text-mode "GHCi-Script" |
||||
"Major mode for working with .ghci files." |
||||
(set (make-local-variable 'adaptive-fill-mode) nil) |
||||
(set (make-local-variable 'comment-start) "-- ") |
||||
(set (make-local-variable 'comment-padding) 0) |
||||
(set (make-local-variable 'comment-start-skip) "[-{]-[ \t]*") |
||||
(set (make-local-variable 'comment-end) "") |
||||
(set (make-local-variable 'comment-end-skip) "[ \t]*\\(-}\\|\\s>\\)") |
||||
(set (make-local-variable 'indent-line-function) 'haskell-mode-suggest-indent-choice) |
||||
(set (make-local-variable 'font-lock-defaults) |
||||
'(ghci-script-mode-keywords t t nil nil)) |
||||
(set (make-local-variable 'indent-tabs-mode) nil) |
||||
(set (make-local-variable 'tab-width) 8) |
||||
(when (boundp 'electric-indent-inhibit) |
||||
(setq electric-indent-inhibit t)) |
||||
(set (make-local-variable 'dabbrev-case-fold-search) nil) |
||||
(set (make-local-variable 'dabbrev-case-distinction) nil) |
||||
(set (make-local-variable 'dabbrev-case-replace) nil) |
||||
(set (make-local-variable 'dabbrev-abbrev-char-regexp) "\\sw\\|[.]") |
||||
(setq haskell-literate nil)) |
||||
|
||||
;;;###autoload |
||||
(add-to-list 'auto-mode-alist '("\\.ghci\\'" . ghci-script-mode)) |
||||
|
||||
(define-key ghci-script-mode-map (kbd "C-c C-l") 'ghci-script-mode-load) |
||||
|
||||
(defun ghci-script-mode-load () |
||||
"Load the current script file into the GHCi session." |
||||
(interactive) |
||||
(let ((buffer (haskell-session-interactive-buffer (haskell-session))) |
||||
(filename (buffer-file-name))) |
||||
(save-buffer) |
||||
(with-current-buffer buffer |
||||
(set-marker haskell-interactive-mode-prompt-start (point-max)) |
||||
(haskell-interactive-mode-run-expr |
||||
(concat ":script " filename))))) |
||||
|
||||
(provide 'ghci-script-mode) |
||||
@ -0,0 +1,231 @@
|
||||
;;; haskell-align-imports.el --- Align the import lines in a Haskell file -*- lexical-binding: t -*- |
||||
|
||||
;; Copyright (C) 2010 Chris Done |
||||
|
||||
;; Author: Chris Done <chrisdone@gmail.com> |
||||
|
||||
;; This file is not part of GNU Emacs. |
||||
|
||||
;; This program 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 program 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 program. If not, see |
||||
;; <http://www.gnu.org/licenses/>. |
||||
|
||||
;;; Commentary: |
||||
|
||||
;; Consider the following imports list: |
||||
;; |
||||
;; import One |
||||
;; import Two as A |
||||
;; import qualified Three |
||||
;; import qualified Four as PRELUDE |
||||
;; import Five (A) |
||||
;; import Six (A,B) |
||||
;; import qualified Seven (A,B) |
||||
;; import "abc" Eight |
||||
;; import "abc" Nine as TWO |
||||
;; import qualified "abc" Ten |
||||
;; import qualified "defg" Eleven as PRELUDE |
||||
;; import "barmu" Twelve (A) |
||||
;; import "zotconpop" Thirteen (A,B) |
||||
;; import qualified "z" Fourteen (A,B) |
||||
;; import Fifteen hiding (A) |
||||
;; import Sixteen as TWO hiding (A) |
||||
;; import qualified Seventeen hiding (A) |
||||
;; import qualified Eighteen as PRELUDE hiding (A) |
||||
;; import "abc" Nineteen hiding (A) |
||||
;; import "abc" Twenty as TWO hiding (A) |
||||
;; |
||||
;; When haskell-align-imports is run within the same buffer, the |
||||
;; import list is transformed to: |
||||
;; |
||||
;; import "abc" Eight |
||||
;; import qualified Eighteen as PRELUDE hiding (A) |
||||
;; import qualified "defg" Eleven as PRELUDE |
||||
;; import Fifteen hiding (A) |
||||
;; import Five (A) |
||||
;; import qualified Four as PRELUDE |
||||
;; import qualified "z" Fourteen (A,B) |
||||
;; import "abc" Nine as TWO |
||||
;; import "abc" Nineteen hiding (A) |
||||
;; import One |
||||
;; import qualified Seven (A,B) |
||||
;; import qualified Seventeen hiding (A) |
||||
;; import Six (A,B) |
||||
;; import Sixteen as TWO hiding (A) |
||||
;; import qualified "abc" Ten |
||||
;; import "zotconpop" Thirteen (A,B) |
||||
;; import qualified Three |
||||
;; import "barmu" Twelve (A) |
||||
;; import "abc" Twenty as TWO hiding (A) |
||||
;; import Two as A |
||||
;; |
||||
;; If you want everything after module names to be padded out, too, |
||||
;; customize `haskell-align-imports-pad-after-name', and you'll get: |
||||
;; |
||||
;; import One |
||||
;; import Two as A |
||||
;; import qualified Three |
||||
;; import qualified Four as PRELUDE |
||||
;; import Five (A) |
||||
;; import Six (A,B) |
||||
;; import qualified Seven (A,B) |
||||
;; import "abc" Eight |
||||
;; import "abc" Nine as TWO |
||||
;; import qualified "abc" Ten |
||||
;; import qualified "defg" Eleven as PRELUDE |
||||
;; import "barmu" Twelve (A) |
||||
;; import "zotconpop" Thirteen (A,B) |
||||
;; import qualified "z" Fourteen (A,B) |
||||
;; import Fifteen hiding (A) |
||||
;; import Sixteen as TWO hiding (A) |
||||
;; import qualified Seventeen hiding (A) |
||||
;; import qualified Eighteen as PRELUDE hiding (A) |
||||
;; import "abc" Nineteen hiding (A) |
||||
;; import "abc" Twenty as TWO hiding (A) |
||||
|
||||
;;; Code: |
||||
|
||||
(require 'cl-lib) |
||||
|
||||
(defvar haskell-align-imports-regexp |
||||
(concat "^\\(import[ ]+\\)" |
||||
"\\(qualified \\)?" |
||||
"[ ]*\\(\"[^\"]*\" \\)?" |
||||
"[ ]*\\([A-Za-z0-9_.']+\\)" |
||||
"[ ]*\\([ ]*as [A-Z][^ ]*\\)?" |
||||
"[ ]*\\((.*)\\)?" |
||||
"\\([ ]*hiding (.*)\\)?" |
||||
"\\( -- .*\\)?[ ]*$") |
||||
"Regex used for matching components of an import.") |
||||
|
||||
;;;###autoload |
||||
(defcustom haskell-align-imports-pad-after-name |
||||
nil |
||||
"Pad layout after the module name also." |
||||
:type 'boolean |
||||
:group 'haskell-interactive) |
||||
|
||||
;;;###autoload |
||||
(defun haskell-align-imports () |
||||
"Align all the imports in the buffer." |
||||
(interactive) |
||||
(when (haskell-align-imports-line-match) |
||||
(save-excursion |
||||
(goto-char (point-min)) |
||||
(let* ((imports (haskell-align-imports-collect)) |
||||
(padding (haskell-align-imports-padding imports))) |
||||
(mapc (lambda (x) |
||||
(goto-char (cdr x)) |
||||
(delete-region (point) (line-end-position)) |
||||
(insert (haskell-align-imports-chomp |
||||
(haskell-align-imports-fill padding (car x))))) |
||||
imports)))) |
||||
nil) |
||||
|
||||
(defun haskell-align-imports-line-match () |
||||
"Try to match the current line as a regexp." |
||||
(let ((line (buffer-substring-no-properties (line-beginning-position) |
||||
(line-end-position)))) |
||||
(if (string-match "^import " line) |
||||
line |
||||
nil))) |
||||
|
||||
(defun haskell-align-imports-collect () |
||||
"Collect a list of mark / import statement pairs." |
||||
(let ((imports '())) |
||||
(while (not (or (equal (point) (point-max)) (haskell-align-imports-after-imports-p))) |
||||
(let ((line (haskell-align-imports-line-match-it))) |
||||
(when line |
||||
(let ((match |
||||
(haskell-align-imports-merge-parts |
||||
(cl-loop for i from 1 to 8 |
||||
collect (haskell-align-imports-chomp (match-string i line)))))) |
||||
(setq imports (cons (cons match (line-beginning-position)) |
||||
imports))))) |
||||
(forward-line)) |
||||
imports)) |
||||
|
||||
(defun haskell-align-imports-merge-parts (l) |
||||
"Merge together parts of an import statement that shouldn't be separated." |
||||
(let ((parts (apply #'vector l)) |
||||
(join (lambda (ls) |
||||
(cl-reduce (lambda (a b) |
||||
(concat a |
||||
(if (and (> (length a) 0) |
||||
(> (length b) 0)) |
||||
" " |
||||
"") |
||||
b)) |
||||
ls)))) |
||||
(if haskell-align-imports-pad-after-name |
||||
(list (funcall join (list (aref parts 0) |
||||
(aref parts 1) |
||||
(aref parts 2))) |
||||
(aref parts 3) |
||||
(funcall join (list (aref parts 4) |
||||
(aref parts 5) |
||||
(aref parts 6))) |
||||
(aref parts 7)) |
||||
(list (funcall join (list (aref parts 0) |
||||
(aref parts 1) |
||||
(aref parts 2))) |
||||
(funcall join (list (aref parts 3) |
||||
(aref parts 4) |
||||
(aref parts 5) |
||||
(aref parts 6) |
||||
(aref parts 7))))))) |
||||
|
||||
(defun haskell-align-imports-chomp (str) |
||||
"Chomp leading and tailing whitespace from STR." |
||||
(if str |
||||
(replace-regexp-in-string "\\(^[[:space:]\n]*\\|[[:space:]\n]*$\\)" "" |
||||
str) |
||||
"")) |
||||
|
||||
(defun haskell-align-imports-padding (imports) |
||||
"Find the padding for each part of the import statements." |
||||
(if (null imports) |
||||
imports |
||||
(cl-reduce (lambda (a b) (cl-mapcar #'max a b)) |
||||
(mapcar (lambda (x) (mapcar #'length (car x))) |
||||
imports)))) |
||||
|
||||
(defun haskell-align-imports-fill (padding line) |
||||
"Fill an import line using the padding worked out from all statements." |
||||
(mapconcat #'identity |
||||
(cl-mapcar (lambda (pad part) |
||||
(if (> (length part) 0) |
||||
(concat part (make-string (- pad (length part)) ? )) |
||||
(make-string pad ? ))) |
||||
padding |
||||
line) |
||||
" ")) |
||||
|
||||
(defun haskell-align-imports-line-match-it () |
||||
"Try to match the current line as a regexp." |
||||
(let ((line (buffer-substring-no-properties (line-beginning-position) |
||||
(line-end-position)))) |
||||
(if (string-match haskell-align-imports-regexp line) |
||||
line |
||||
nil))) |
||||
|
||||
(defun haskell-align-imports-after-imports-p () |
||||
"Are we after the imports list?" |
||||
(save-excursion |
||||
(goto-char (line-beginning-position)) |
||||
(not (not (search-forward-regexp "\\( = \\|\\<instance\\>\\| :: \\| ∷ \\)" |
||||
(line-end-position) t 1))))) |
||||
|
||||
(provide 'haskell-align-imports) |
||||
|
||||
;;; haskell-align-imports.el ends here |
||||
@ -0,0 +1,974 @@
|
||||
;;; haskell-cabal.el --- Support for Cabal packages -*- lexical-binding: t -*- |
||||
|
||||
;; Copyright (C) 2007, 2008 Stefan Monnier |
||||
|
||||
;; Author: Stefan Monnier <monnier@iro.umontreal.ca> |
||||
|
||||
;; 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, 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 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. |
||||
|
||||
;;; Commentary: |
||||
|
||||
;; Todo: |
||||
|
||||
;; - distinguish continued lines from indented lines. |
||||
;; - indent-line-function. |
||||
;; - outline-minor-mode. |
||||
|
||||
;;; Code: |
||||
|
||||
;; (defun haskell-cabal-extract-fields-from-doc () |
||||
;; (require 'xml) |
||||
;; (with-no-warnings (require 'cl)) |
||||
;; (let ((section (completing-read |
||||
;; "Section: " |
||||
;; '("general-fields" "library" "executable" "buildinfo")))) |
||||
;; (goto-char (point-min)) |
||||
;; (search-forward (concat "<sect3 id=\"" section "\">"))) |
||||
;; (let* ((xml (xml-parse-region |
||||
;; (progn (search-forward "<variablelist>") (match-beginning 0)) |
||||
;; (progn (search-forward "</variablelist>") (point)))) |
||||
;; (varlist (remove-if-not 'consp (cddar xml))) |
||||
;; (syms (mapcar (lambda (entry) (caddr (assq 'literal (assq 'term entry)))) |
||||
;; varlist)) |
||||
;; (fields (mapcar (lambda (sym) (substring-no-properties sym 0 -1)) syms))) |
||||
;; fields)) |
||||
|
||||
(require 'cl-lib) |
||||
(require 'haskell-utils) |
||||
|
||||
(defconst haskell-cabal-general-fields |
||||
;; Extracted with (haskell-cabal-extract-fields-from-doc "general-fields") |
||||
'("name" "version" "cabal-version" "license" "license-file" "copyright" |
||||
"author" "maintainer" "stability" "homepage" "package-url" "synopsis" |
||||
"description" "category" "tested-with" "build-depends" "data-files" |
||||
"extra-source-files" "extra-tmp-files")) |
||||
|
||||
(defconst haskell-cabal-library-fields |
||||
;; Extracted with (haskell-cabal-extract-fields-from-doc "library") |
||||
'("exposed-modules")) |
||||
|
||||
(defconst haskell-cabal-executable-fields |
||||
;; Extracted with (haskell-cabal-extract-fields-from-doc "executable") |
||||
'("executable" "main-is")) |
||||
|
||||
(defconst haskell-cabal-buildinfo-fields |
||||
;; Extracted with (haskell-cabal-extract-fields-from-doc "buildinfo") |
||||
'("buildable" "other-modules" "hs-source-dirs" "extensions" "ghc-options" |
||||
"ghc-prof-options" "hugs-options" "nhc-options" "includes" |
||||
"install-includes" "include-dirs" "c-sources" "extra-libraries" |
||||
"extra-lib-dirs" "cc-options" "ld-options" "frameworks")) |
||||
|
||||
(defvar haskell-cabal-mode-syntax-table |
||||
(let ((st (make-syntax-table))) |
||||
;; The comment syntax can't be described simply in syntax-table. |
||||
;; We could use font-lock-syntactic-keywords, but is it worth it? |
||||
;; (modify-syntax-entry ?- ". 12" st) |
||||
(modify-syntax-entry ?\n ">" st) |
||||
(modify-syntax-entry ?. "w" st) |
||||
(modify-syntax-entry ?- "w" st) |
||||
st)) |
||||
|
||||
(defvar haskell-cabal-font-lock-keywords |
||||
;; The comment syntax can't be described simply in syntax-table. |
||||
;; We could use font-lock-syntactic-keywords, but is it worth it? |
||||
'(("^[ \t]*--.*" . font-lock-comment-face) |
||||
("^ *\\([^ \t:]+\\):" (1 font-lock-keyword-face)) |
||||
("^\\(Library\\)[ \t]*\\({\\|$\\)" (1 font-lock-keyword-face)) |
||||
("^\\(Executable\\|Test-Suite\\|Benchmark\\)[ \t]+\\([^\n \t]*\\)" |
||||
(1 font-lock-keyword-face) (2 font-lock-function-name-face)) |
||||
("^\\(Flag\\)[ \t]+\\([^\n \t]*\\)" |
||||
(1 font-lock-keyword-face) (2 font-lock-constant-face)) |
||||
("^\\(Source-Repository\\)[ \t]+\\(head\\|this\\)" |
||||
(1 font-lock-keyword-face) (2 font-lock-constant-face)) |
||||
("^ *\\(if\\)[ \t]+.*\\({\\|$\\)" (1 font-lock-keyword-face)) |
||||
("^ *\\(}[ \t]*\\)?\\(else\\)[ \t]*\\({\\|$\\)" |
||||
(2 font-lock-keyword-face)))) |
||||
|
||||
(defvar haskell-cabal-buffers nil |
||||
"List of Cabal buffers.") |
||||
|
||||
(defun haskell-cabal-buffers-clean (&optional buffer) |
||||
(let ((bufs ())) |
||||
(dolist (buf haskell-cabal-buffers) |
||||
(if (and (buffer-live-p buf) (not (eq buf buffer)) |
||||
(with-current-buffer buf (derived-mode-p 'haskell-cabal-mode))) |
||||
(push buf bufs))) |
||||
(setq haskell-cabal-buffers bufs))) |
||||
|
||||
(defun haskell-cabal-unregister-buffer () |
||||
(haskell-cabal-buffers-clean (current-buffer))) |
||||
|
||||
;;;###autoload |
||||
(add-to-list 'auto-mode-alist '("\\.cabal\\'" . haskell-cabal-mode)) |
||||
|
||||
(defvar haskell-cabal-mode-map |
||||
(let ((map (make-sparse-keymap))) |
||||
(define-key map (kbd "C-c C-s") 'haskell-cabal-subsection-arrange-lines) |
||||
(define-key map (kbd "C-M-n") 'haskell-cabal-next-section) |
||||
(define-key map (kbd "C-M-p") 'haskell-cabal-previous-section) |
||||
(define-key map (kbd "M-n") 'haskell-cabal-next-subsection) |
||||
(define-key map (kbd "M-p") 'haskell-cabal-previous-subsection) |
||||
(define-key map (kbd "C-<down>") 'haskell-cabal-next-subsection) |
||||
(define-key map (kbd "C-<up>") 'haskell-cabal-previous-subsection) |
||||
(define-key map (kbd "C-c C-f") 'haskell-cabal-find-or-create-source-file) |
||||
(define-key map (kbd "M-g l") 'haskell-cabal-goto-library-section) |
||||
(define-key map (kbd "M-g e") 'haskell-cabal-goto-executable-section) |
||||
(define-key map (kbd "M-g b") 'haskell-cabal-goto-benchmark-section) |
||||
(define-key map (kbd "M-g t") 'haskell-cabal-goto-test-suite-section) |
||||
map)) |
||||
|
||||
;;;###autoload |
||||
(define-derived-mode haskell-cabal-mode fundamental-mode "Haskell-Cabal" |
||||
"Major mode for Cabal package description files." |
||||
(set (make-local-variable 'font-lock-defaults) |
||||
'(haskell-cabal-font-lock-keywords t t nil nil)) |
||||
(add-to-list 'haskell-cabal-buffers (current-buffer)) |
||||
(add-hook 'change-major-mode-hook 'haskell-cabal-unregister-buffer nil 'local) |
||||
(add-hook 'kill-buffer-hook 'haskell-cabal-unregister-buffer nil 'local) |
||||
(set (make-local-variable 'comment-start) "-- ") |
||||
(set (make-local-variable 'comment-start-skip) "\\(^[ \t]*\\)--[ \t]*") |
||||
(set (make-local-variable 'comment-end) "") |
||||
(set (make-local-variable 'comment-end-skip) "[ \t]*\\(\\s>\\|\n\\)") |
||||
(set (make-local-variable 'indent-line-function) 'haskell-cabal-indent-line) |
||||
(setq indent-tabs-mode nil) |
||||
) |
||||
|
||||
(defun haskell-cabal-get-setting (name) |
||||
(save-excursion |
||||
(let ((case-fold-search t)) |
||||
(goto-char (point-min)) |
||||
(when (re-search-forward |
||||
(concat "^[ \t]*" (regexp-quote name) |
||||
":[ \t]*\\(.*\\(\n[ \t]+[ \t\n].*\\)*\\)") |
||||
nil t) |
||||
(let ((val (match-string 1)) |
||||
(start 1)) |
||||
(when (match-end 2) ;Multiple lines. |
||||
;; The documentation is not very precise about what to do about |
||||
;; the \n and the indentation: are they part of the value or |
||||
;; the encoding? I take the point of view that \n is part of |
||||
;; the value (so that values can span multiple lines as well), |
||||
;; and that only the first char in the indentation is part of |
||||
;; the encoding, the rest is part of the value (otherwise, lines |
||||
;; in the value cannot start with spaces or tabs). |
||||
(while (string-match "^[ \t]\\(?:\\.$\\)?" val start) |
||||
(setq start (1+ (match-beginning 0))) |
||||
(setq val (replace-match "" t t val)))) |
||||
val))))) |
||||
|
||||
;;;###autoload |
||||
(defun haskell-cabal-guess-setting (name) |
||||
"Guess the specified setting of this project. |
||||
If there is no valid .cabal file to get the setting from (or |
||||
there is no corresponding setting with that name in the .cabal |
||||
file), then this function returns nil." |
||||
(interactive) |
||||
(when (and name buffer-file-name) |
||||
(let ((cabal-file (haskell-cabal-find-file))) |
||||
(when (and cabal-file (file-readable-p cabal-file)) |
||||
(with-temp-buffer |
||||
(insert-file-contents cabal-file) |
||||
(haskell-cabal-get-setting name)))))) |
||||
|
||||
;;;###autoload |
||||
(defun haskell-cabal-get-dir (&optional use-defaults) |
||||
"Get the Cabal dir for a new project. Various ways of figuring this out, |
||||
and indeed just prompting the user. Do them all." |
||||
(let* ((file (haskell-cabal-find-file)) |
||||
(dir (if file (file-name-directory file) default-directory))) |
||||
(if use-defaults |
||||
dir |
||||
(haskell-utils-read-directory-name |
||||
(format "Cabal dir%s: " (if file (format " (guessed from %s)" (file-relative-name file)) "")) |
||||
dir)))) |
||||
|
||||
(defun haskell-cabal-compute-checksum (dir) |
||||
"Compute MD5 checksum of package description file in DIR. |
||||
Return nil if no Cabal description file could be located via |
||||
`haskell-cabal-find-pkg-desc'." |
||||
(let ((cabal-file (haskell-cabal-find-pkg-desc dir))) |
||||
(when cabal-file |
||||
(with-temp-buffer |
||||
(insert-file-contents cabal-file) |
||||
(md5 (buffer-string)))))) |
||||
|
||||
(defun haskell-cabal-find-file (&optional dir) |
||||
"Search for package description file upwards starting from DIR. |
||||
If DIR is nil, `default-directory' is used as starting point for |
||||
directory traversal. Upward traversal is aborted if file owner |
||||
changes. Uses`haskell-cabal-find-pkg-desc' internally." |
||||
(let ((use-dir (or dir default-directory))) |
||||
(while (and use-dir (not (file-directory-p use-dir))) |
||||
(setq use-dir (file-name-directory (directory-file-name use-dir)))) |
||||
(when use-dir |
||||
(catch 'found |
||||
(let ((user (nth 2 (file-attributes use-dir))) |
||||
;; Abbreviate, so as to stop when we cross ~/. |
||||
(root (abbreviate-file-name use-dir))) |
||||
;; traverse current dir up to root as long as file owner doesn't change |
||||
(while (and root (equal user (nth 2 (file-attributes root)))) |
||||
(let ((cabal-file (haskell-cabal-find-pkg-desc root))) |
||||
(when cabal-file |
||||
(throw 'found cabal-file))) |
||||
|
||||
(let ((proot (file-name-directory (directory-file-name root)))) |
||||
(if (equal proot root) ;; fix-point reached? |
||||
(throw 'found nil) |
||||
(setq root proot)))) |
||||
nil))))) |
||||
|
||||
(defun haskell-cabal-find-pkg-desc (dir &optional allow-multiple) |
||||
"Find a package description file in the directory DIR. |
||||
Returns nil if none or multiple \".cabal\" files were found. If |
||||
ALLOW-MULTIPLE is non nil, in case of multiple \".cabal\" files, |
||||
a list is returned instead of failing with a nil result." |
||||
;; This is basically a port of Cabal's |
||||
;; Distribution.Simple.Utils.findPackageDesc function |
||||
;; http://hackage.haskell.org/packages/archive/Cabal/1.16.0.3/doc/html/Distribution-Simple-Utils.html |
||||
;; but without the exception throwing. |
||||
(let* ((cabal-files |
||||
(cl-remove-if 'file-directory-p |
||||
(cl-remove-if-not 'file-exists-p |
||||
(directory-files dir t ".\\.cabal\\'"))))) |
||||
(cond |
||||
((= (length cabal-files) 1) (car cabal-files)) ;; exactly one candidate found |
||||
(allow-multiple cabal-files) ;; pass-thru multiple candidates |
||||
(t nil)))) |
||||
|
||||
(defun haskell-cabal-find-dir (&optional dir) |
||||
"Like `haskell-cabal-find-file' but returns directory instead. |
||||
See `haskell-cabal-find-file' for meaning of DIR argument." |
||||
(let ((cabal-file (haskell-cabal-find-file dir))) |
||||
(when cabal-file |
||||
(file-name-directory cabal-file)))) |
||||
|
||||
;;;###autoload |
||||
(defun haskell-cabal-visit-file (other-window) |
||||
"Locate and visit package description file for file visited by current buffer. |
||||
This uses `haskell-cabal-find-file' to locate the closest |
||||
\".cabal\" file and open it. This command assumes a common Cabal |
||||
project structure where the \".cabal\" file is in the top-folder |
||||
of the project, and all files related to the project are in or |
||||
below the top-folder. If called with non-nil prefix argument |
||||
OTHER-WINDOW use `find-file-other-window'." |
||||
(interactive "P") |
||||
;; Note: We aren't allowed to rely on haskell-session here (which, |
||||
;; in pathological cases, can have a different .cabal file |
||||
;; associated with the current buffer) |
||||
(if buffer-file-name |
||||
(let ((cabal-file (haskell-cabal-find-file (file-name-directory buffer-file-name)))) |
||||
(if cabal-file |
||||
(if other-window |
||||
(find-file-other-window cabal-file) |
||||
(find-file cabal-file)) |
||||
(error "Could not locate \".cabal\" file for %S" buffer-file-name))) |
||||
(error "Cannot locate \".cabal\" file for buffers not visiting any file"))) |
||||
|
||||
(defvar haskell-cabal-commands |
||||
'("install" |
||||
"update" |
||||
"list" |
||||
"info" |
||||
"upgrade" |
||||
"fetch" |
||||
"unpack" |
||||
"check" |
||||
"sdist" |
||||
"upload" |
||||
"report" |
||||
"init" |
||||
"configure" |
||||
"build" |
||||
"copy" |
||||
"haddock" |
||||
"clean" |
||||
"hscolour" |
||||
"register" |
||||
"test" |
||||
"help" |
||||
"run")) |
||||
|
||||
;;;###autoload |
||||
(defgroup haskell-cabal nil |
||||
"Haskell cabal files" |
||||
:group 'haskell |
||||
) |
||||
|
||||
;;;###autoload |
||||
(defcustom haskell-cabal-list-comma-position |
||||
'before |
||||
"Where to put the comma in lists" |
||||
:safe t |
||||
:group 'haskell-cabal |
||||
:type '(choice (const before) |
||||
(const after))) |
||||
|
||||
(defconst haskell-cabal-section-header-regexp "^[[:alnum:]]" ) |
||||
(defconst haskell-cabal-subsection-header-regexp "^[ \t]*[[:alnum:]]\\w*:") |
||||
(defconst haskell-cabal-comment-regexp "^[ \t]*--") |
||||
(defconst haskell-cabal-empty-regexp "^[ \t]*$") |
||||
(defconst haskell-cabal-conditional-regexp "^[ \t]*\\(\\if\\|else\\|}\\)") |
||||
|
||||
(defun haskell-cabal-classify-line () |
||||
"Classify the current line into 'section-header 'subsection-header 'section-data 'comment and 'empty '" |
||||
(save-excursion |
||||
(beginning-of-line) |
||||
(cond |
||||
((looking-at haskell-cabal-subsection-header-regexp ) 'subsection-header) |
||||
((looking-at haskell-cabal-section-header-regexp) 'section-header) |
||||
((looking-at haskell-cabal-comment-regexp) 'comment) |
||||
((looking-at haskell-cabal-empty-regexp ) 'empty) |
||||
((looking-at haskell-cabal-conditional-regexp ) 'conditional) |
||||
(t 'section-data)))) |
||||
|
||||
(defun haskell-cabal-header-p () |
||||
"Is the current line a section or subsection header?" |
||||
(cl-case (haskell-cabal-classify-line) |
||||
((section-header subsection-header) t))) |
||||
|
||||
(defun haskell-cabal-section-header-p () |
||||
"Is the current line a section or subsection header?" |
||||
(cl-case (haskell-cabal-classify-line) |
||||
((section-header) t))) |
||||
|
||||
|
||||
(defun haskell-cabal-section-beginning () |
||||
"Find the beginning of the current section" |
||||
(save-excursion |
||||
(while (not (or (bobp) (haskell-cabal-section-header-p))) |
||||
(forward-line -1)) |
||||
(point))) |
||||
|
||||
(defun haskell-cabal-beginning-of-section () |
||||
"go to the beginning of the section" |
||||
(interactive) |
||||
(goto-char (haskell-cabal-section-beginning)) |
||||
) |
||||
|
||||
(defun haskell-cabal-section-end () |
||||
"Find the end of the current section" |
||||
(interactive) |
||||
(save-excursion |
||||
(if (re-search-forward "\n\\([ \t]*\n\\)*[[:alnum:]]" nil t) |
||||
(match-beginning 0) |
||||
(point-max)))) |
||||
|
||||
(defun haskell-cabal-end-of-section () |
||||
"go to the end of the section" |
||||
(interactive) |
||||
(goto-char (haskell-cabal-section-end))) |
||||
|
||||
(defun haskell-cabal-next-section () |
||||
"Go to the next extion" |
||||
(interactive) |
||||
(when (haskell-cabal-section-header-p) (forward-line)) |
||||
(while (not (or (eobp) (haskell-cabal-section-header-p))) |
||||
(forward-line))) |
||||
|
||||
(defun haskell-cabal-previous-section () |
||||
"Go to the next extion" |
||||
(interactive) |
||||
(when (haskell-cabal-section-header-p) (forward-line -1)) |
||||
(while (not (or (bobp) (haskell-cabal-section-header-p))) |
||||
(forward-line -1))) |
||||
|
||||
(defun haskell-cabal-subsection-end () |
||||
"find the end of the current subsection" |
||||
(save-excursion |
||||
(haskell-cabal-beginning-of-subsection) |
||||
(forward-line) |
||||
(while (and (not (eobp)) |
||||
(member (haskell-cabal-classify-line) '(empty section-data))) |
||||
(forward-line)) |
||||
(unless (eobp) (forward-line -1)) |
||||
(while (and (equal (haskell-cabal-classify-line) 'empty) |
||||
(not (bobp))) |
||||
(forward-line -1)) |
||||
(end-of-line) |
||||
(point))) |
||||
|
||||
(defun haskell-cabal-end-of-subsection () |
||||
"go to the end of the current subsection" |
||||
(interactive) |
||||
(goto-char (haskell-cabal-subsection-end))) |
||||
|
||||
(defun haskell-cabal-section () |
||||
"Get the name and data of the associated section" |
||||
(save-excursion |
||||
(haskell-cabal-beginning-of-section) |
||||
(when (and (haskell-cabal-section-header-p) |
||||
(looking-at "^\\(\\w+\\)[ \t]*\\(.*\\)$")) |
||||
(list :name (match-string-no-properties 1) |
||||
:value (match-string-no-properties 2) |
||||
:beginning (match-beginning 0) |
||||
:end (haskell-cabal-section-end))))) |
||||
|
||||
|
||||
(defun haskell-cabal-subsection () |
||||
"Get the name and bounds of of the current subsection" |
||||
(save-excursion |
||||
(haskell-cabal-beginning-of-subsection) |
||||
(when (looking-at "\\([ \t]*\\(\\w*\\):\\)[ \t]*") |
||||
(list :name (match-string-no-properties 2) |
||||
:beginning (match-end 0) |
||||
:end (save-match-data (haskell-cabal-subsection-end)) |
||||
:data-start-column (save-excursion (goto-char (match-end 0)) |
||||
(current-column) |
||||
))))) |
||||
|
||||
|
||||
(defun haskell-cabal-section-name (section) |
||||
(plist-get section :name)) |
||||
|
||||
(defun haskell-cabal-section-value (section) |
||||
(plist-get section :value)) |
||||
|
||||
(defun haskell-cabal-section-start (section) |
||||
(plist-get section :beginning)) |
||||
|
||||
(defun haskell-cabal-section-data-start-column (section) |
||||
(plist-get section :data-start-column)) |
||||
|
||||
(defun haskell-cabal-enum-targets () |
||||
"Enumerate .cabal targets." |
||||
(let ((cabal-file (haskell-cabal-find-file))) |
||||
(when (and cabal-file (file-readable-p cabal-file)) |
||||
(with-temp-buffer |
||||
(insert-file-contents cabal-file) |
||||
(haskell-cabal-mode) |
||||
(let (matches) |
||||
(goto-char (point-min)) |
||||
(haskell-cabal-next-section) |
||||
(while (not (eobp)) |
||||
(if (haskell-cabal-source-section-p (haskell-cabal-section)) |
||||
(let ((val (haskell-cabal-section-value (haskell-cabal-section)))) |
||||
(if (string= val "") |
||||
(push "library" matches) |
||||
(push val matches)))) |
||||
(haskell-cabal-next-section)) |
||||
(reverse matches)))))) |
||||
|
||||
(defmacro haskell-cabal-with-subsection (subsection replace &rest funs) |
||||
"Copy subsection data into a temporary buffer, save indentation |
||||
and execute FORMS |
||||
|
||||
If REPLACE is non-nil the subsection data is replaced with the |
||||
resultung buffer-content" |
||||
(let ((section (make-symbol "section")) |
||||
(beg (make-symbol "beg")) |
||||
(end (make-symbol "end")) |
||||
(start-col (make-symbol "start-col")) |
||||
(section-data (make-symbol "section-data"))) |
||||
`(let* ((,section ,subsection) |
||||
(,beg (plist-get ,section :beginning)) |
||||
(,end (plist-get ,section :end)) |
||||
(,start-col (plist-get ,section :data-start-column)) |
||||
(,section-data (buffer-substring ,beg ,end))) |
||||
(save-excursion |
||||
(prog1 |
||||
(with-temp-buffer |
||||
(setq indent-tabs-mode nil) |
||||
(indent-to ,start-col) |
||||
(insert ,section-data) |
||||
(goto-char (point-min)) |
||||
(prog1 |
||||
(progn (haskell-cabal-save-indentation ,@funs)) |
||||
(goto-char (point-min)) |
||||
(when (looking-at (format "[ ]\\{0,%d\\}" (1+ ,start-col))) |
||||
(replace-match "")) |
||||
|
||||
(setq ,section-data (buffer-substring (point-min) (point-max))))) |
||||
,@(when replace |
||||
`((delete-region ,beg ,end) |
||||
(goto-char ,beg) |
||||
(insert ,section-data)))))))) |
||||
|
||||
(defmacro haskell-cabal-each-line (&rest fun) |
||||
"Execute FOMRS on each line" |
||||
`(save-excursion |
||||
(while (< (point) (point-max)) |
||||
,@fun |
||||
(forward-line)))) |
||||
|
||||
(defun haskell-cabal-chomp-line () |
||||
"Remove leading and trailing whitespaces from current line" |
||||
(beginning-of-line) |
||||
(when (looking-at "^[ \t]*\\([^ \t]\\|\\(?:[^ \t].*[^ \t]\\)\\)[ \t]*$") |
||||
(replace-match (match-string 1) nil t) |
||||
t)) |
||||
|
||||
|
||||
(defun haskell-cabal-min-indentation (&optional beg end) |
||||
"Compute largest common whitespace prefix of each line in between BEG and END" |
||||
(save-excursion |
||||
(goto-char (or beg (point-min))) |
||||
(let ((min-indent nil)) |
||||
(while (< (point) (or end (point-max))) |
||||
(let ((indent (current-indentation))) |
||||
(if (and (not (haskell-cabal-ignore-line-p)) |
||||
(or (not min-indent) |
||||
(< indent min-indent))) |
||||
(setq min-indent indent))) |
||||
(forward-line)) |
||||
min-indent))) |
||||
|
||||
(defun haskell-cabal-ignore-line-p () |
||||
"Does line only contain whitespaces and comments?" |
||||
(save-excursion |
||||
(beginning-of-line) |
||||
(looking-at "^[ \t]*\\(?:--.*\\)?$"))) |
||||
|
||||
(defun haskell-cabal-kill-indentation () |
||||
"Remove longest common whitespace prefix from each line" |
||||
(goto-char (point-min)) |
||||
(let ((indent (haskell-cabal-min-indentation))) |
||||
(haskell-cabal-each-line (unless (haskell-cabal-ignore-line-p) |
||||
(delete-char indent)) ) |
||||
indent)) |
||||
|
||||
(defun haskell-cabal-add-indentation (indent) |
||||
(goto-char (point-min)) |
||||
(haskell-cabal-each-line |
||||
(unless (haskell-cabal-ignore-line-p) |
||||
(indent-to indent)))) |
||||
|
||||
|
||||
(defmacro haskell-cabal-save-indentation (&rest funs) |
||||
"Strip indentation from each line, execute FORMS and reinstate indentation |
||||
so that the indentation of the FIRST LINE matches" |
||||
(let ((old-l1-indent (make-symbol "new-l1-indent")) |
||||
(new-l1-indent (make-symbol "old-l1-indent"))) |
||||
`(let ( (,old-l1-indent (save-excursion |
||||
(goto-char (point-min)) |
||||
(current-indentation)))) |
||||
(unwind-protect |
||||
(progn |
||||
(haskell-cabal-kill-indentation) |
||||
,@funs) |
||||
(progn |
||||
(goto-char (point-min)) |
||||
(let ((,new-l1-indent (current-indentation))) |
||||
(haskell-cabal-add-indentation (- ,old-l1-indent |
||||
,new-l1-indent)))))))) |
||||
|
||||
(defun haskell-cabal-strip-list () |
||||
"strip commas from comma-seperated list" |
||||
(goto-char (point-min)) |
||||
;; split list items on single line |
||||
(while (re-search-forward |
||||
"\\([^ \t,\n]\\)[ \t]*,[ \t]*\\([^ \t,\n]\\)" nil t) |
||||
(replace-match "\\1\n\\2" nil nil)) |
||||
(goto-char (point-min)) |
||||
(while (re-search-forward "^\\([ \t]*\\),\\([ \t]*\\)" nil t) |
||||
(replace-match "" nil nil)) |
||||
(goto-char (point-min)) |
||||
(while (re-search-forward ",[ \t]*$" nil t) |
||||
(replace-match "" nil nil)) |
||||
(goto-char (point-min)) |
||||
(haskell-cabal-each-line (haskell-cabal-chomp-line))) |
||||
|
||||
(defun haskell-cabal-listify () |
||||
"Add commas so that buffer contains a comma-seperated list" |
||||
(cl-case haskell-cabal-list-comma-position |
||||
('before |
||||
(goto-char (point-min)) |
||||
(while (haskell-cabal-ignore-line-p) (forward-line)) |
||||
(indent-to 2) |
||||
(forward-line) |
||||
(haskell-cabal-each-line |
||||
(unless (haskell-cabal-ignore-line-p) |
||||
(insert ", ")))) |
||||
('after |
||||
(goto-char (point-max)) |
||||
(while (not (bobp)) |
||||
(unless (haskell-cabal-ignore-line-p) |
||||
(forward-line -1) |
||||
(end-of-line) |
||||
(insert ",") |
||||
(beginning-of-line)))))) |
||||
|
||||
|
||||
|
||||
(defmacro haskell-cabal-with-cs-list (&rest funs) |
||||
"format buffer so that each line contains a list element " |
||||
`(progn |
||||
(save-excursion (haskell-cabal-strip-list)) |
||||
(unwind-protect (progn ,@funs) |
||||
(haskell-cabal-listify)))) |
||||
|
||||
|
||||
(defun haskell-cabal-sort-lines-key-fun () |
||||
(when (looking-at "[ \t]*--[ \t,]*") |
||||
(goto-char (match-end 0))) |
||||
nil) |
||||
|
||||
(defmacro haskell-cabal-save-position (&rest forms) |
||||
"Save position as mark, execute FORMs and go back to mark" |
||||
`(prog2 |
||||
(haskell-cabal-mark) |
||||
(progn ,@forms) |
||||
(haskell-cabal-goto-mark) |
||||
(haskell-cabal-remove-mark))) |
||||
|
||||
(defun haskell-cabal-subsection-arrange-lines () |
||||
"Sort lines of current subsection" |
||||
(interactive) |
||||
(haskell-cabal-save-position |
||||
(haskell-cabal-with-subsection |
||||
(haskell-cabal-subsection) t |
||||
(haskell-cabal-with-cs-list |
||||
(sort-subr nil 'forward-line 'end-of-line |
||||
'haskell-cabal-sort-lines-key-fun) |
||||
)))) |
||||
|
||||
(defun haskell-cabal-subsection-beginning () |
||||
"find the beginning of the current subsection" |
||||
(save-excursion |
||||
(while (and (not (bobp)) |
||||
(not (haskell-cabal-header-p))) |
||||
(forward-line -1)) |
||||
(back-to-indentation) |
||||
(point))) |
||||
|
||||
(defun haskell-cabal-beginning-of-subsection () |
||||
"go to the beginniing of the current subsection" |
||||
(interactive) |
||||
(goto-char (haskell-cabal-subsection-beginning))) |
||||
|
||||
(defun haskell-cabal-next-subsection () |
||||
"go to the next subsection" |
||||
(interactive) |
||||
(if (haskell-cabal-header-p) (forward-line)) |
||||
(while (and (not (eobp)) |
||||
(not (haskell-cabal-header-p))) |
||||
(forward-line)) |
||||
(haskell-cabal-forward-to-line-entry)) |
||||
|
||||
(defun haskell-cabal-previous-subsection () |
||||
"go to the next subsection" |
||||
(interactive) |
||||
(if (haskell-cabal-header-p) (forward-line -1)) |
||||
(while (and (not (bobp)) |
||||
(not (haskell-cabal-header-p))) |
||||
(forward-line -1)) |
||||
(haskell-cabal-forward-to-line-entry) |
||||
) |
||||
|
||||
|
||||
(defun haskell-cabal-find-subsection-by (section pred) |
||||
"Find sunsection with name NAME" |
||||
(save-excursion |
||||
(when section (goto-char (haskell-cabal-section-start section))) |
||||
(let* ((end (if section (haskell-cabal-section-end) (point-max))) |
||||
(found nil)) |
||||
(while (and (< (point) end) |
||||
(not found)) |
||||
(let ((subsection (haskell-cabal-subsection))) |
||||
(when (and subsection (funcall pred subsection)) |
||||
(setq found subsection))) |
||||
(haskell-cabal-next-subsection)) |
||||
found))) |
||||
|
||||
(defun haskell-cabal-find-subsection (section name) |
||||
"Find sunsection with name NAME" |
||||
(let ((downcase-name (downcase name))) |
||||
(haskell-cabal-find-subsection-by |
||||
section |
||||
`(lambda (subsection) |
||||
(string= (downcase (haskell-cabal-section-name subsection)) |
||||
,downcase-name))))) |
||||
|
||||
(defun haskell-cabal-goto-subsection (name) |
||||
(let ((subsection (haskell-cabal-find-subsection (haskell-cabal-section) name))) |
||||
(when subsection |
||||
(goto-char (haskell-cabal-section-start subsection))))) |
||||
|
||||
(defun haskell-cabal-goto-exposed-modules () |
||||
(interactive) |
||||
(haskell-cabal-goto-subsection "exposed-modules")) |
||||
|
||||
(defun haskell-cabal-subsection-entry-list (section name) |
||||
"Get the data of a subsection as a list" |
||||
(let ((subsection (haskell-cabal-find-subsection section name))) |
||||
(when subsection |
||||
(haskell-cabal-with-subsection |
||||
subsection nil |
||||
(haskell-cabal-with-cs-list |
||||
(delete-matching-lines |
||||
(format "\\(?:%s\\)\\|\\(?:%s\\)" |
||||
haskell-cabal-comment-regexp |
||||
haskell-cabal-empty-regexp) |
||||
(point-min) (point-max)) |
||||
(split-string (buffer-substring-no-properties (point-min) (point-max)) |
||||
"\n" t)))))) |
||||
|
||||
(defun haskell-cabal-remove-mark () |
||||
(remove-list-of-text-properties (point-min) (point-max) |
||||
'(haskell-cabal-marker))) |
||||
|
||||
|
||||
(defun haskell-cabal-mark () |
||||
"Mark the current position with the text property haskell-cabal-marker" |
||||
(haskell-cabal-remove-mark) |
||||
(put-text-property (line-beginning-position) (line-end-position) |
||||
'haskell-cabal-marker 'marked-line) |
||||
(put-text-property (point) (1+ (point)) |
||||
'haskell-cabal-marker 'marked)) |
||||
|
||||
|
||||
(defun haskell-cabal-goto-mark () |
||||
"Go to marked line" |
||||
(let ((marked-pos (text-property-any (point-min) (point-max) |
||||
'haskell-cabal-marker |
||||
'marked)) |
||||
(marked-line (text-property-any (point-min) (point-max) |
||||
'haskell-cabal-marker |
||||
'marked-line) ) |
||||
) |
||||
(cond (marked-pos (goto-char marked-pos)) |
||||
(marked-line (goto-char marked-line))))) |
||||
|
||||
(defmacro haskell-cabal-with-subsection-line (replace &rest forms) |
||||
"Mark line and " |
||||
`(progn |
||||
(haskell-cabal-mark) |
||||
(unwind-protect |
||||
(haskell-cabal-with-subsection (haskell-cabal-subsection) ,replace |
||||
(haskell-cabal-goto-mark) |
||||
,@forms) |
||||
(haskell-cabal-remove-mark)))) |
||||
|
||||
|
||||
(defun haskell-cabal-get-line-content () |
||||
(haskell-cabal-with-subsection-line |
||||
nil |
||||
(haskell-cabal-with-cs-list |
||||
(haskell-cabal-goto-mark) |
||||
(buffer-substring-no-properties (line-beginning-position) |
||||
(line-end-position))))) |
||||
|
||||
(defun haskell-cabal-module-to-filename (module) |
||||
(concat (replace-regexp-in-string "[.]" "/" module ) ".hs")) |
||||
|
||||
(defconst haskell-cabal-module-sections '("exposed-modules" "other-modules") |
||||
"List of sections that contain module names" |
||||
) |
||||
|
||||
(defconst haskell-cabal-file-sections |
||||
'("main-is" "c-sources" "data-files" "extra-source-files" |
||||
"extra-doc-files" "extra-tmp-files" ) |
||||
"List of subsections that contain filenames" |
||||
) |
||||
|
||||
(defconst haskell-cabal-source-bearing-sections |
||||
'("library" "executable" "test-suite" "benchmark")) |
||||
|
||||
(defun haskell-cabal-source-section-p (section) |
||||
(not (not (member (downcase (haskell-cabal-section-name section)) |
||||
haskell-cabal-source-bearing-sections)))) |
||||
|
||||
(defun haskell-cabal-line-filename () |
||||
"Expand filename in current line according to the subsection type |
||||
|
||||
Module names in exposed-modules and other-modules are expanded by replacing each dot (.) in the module name with a foward slash (/) and appending \".hs\" |
||||
|
||||
Example: Foo.Bar.Quux ==> Foo/Bar/Quux.hs |
||||
|
||||
Source names from main-is and c-sources sections are left untouched |
||||
|
||||
" |
||||
(let ((entry (haskell-cabal-get-line-content)) |
||||
(subsection (downcase (haskell-cabal-section-name |
||||
(haskell-cabal-subsection))))) |
||||
(cond ((member subsection haskell-cabal-module-sections) |
||||
(haskell-cabal-module-to-filename entry)) |
||||
((member subsection haskell-cabal-file-sections) entry)))) |
||||
|
||||
(defun haskell-cabal-join-paths (&rest args) |
||||
"Crude hack to replace f-join" |
||||
(mapconcat 'identity args "/") |
||||
) |
||||
|
||||
(defun haskell-cabal-find-or-create-source-file () |
||||
"Open the source file this line refers to" |
||||
(interactive) |
||||
(let* ((src-dirs (append (haskell-cabal-subsection-entry-list |
||||
(haskell-cabal-section) "hs-source-dirs") |
||||
'(""))) |
||||
(base-dir (file-name-directory (buffer-file-name))) |
||||
(filename (haskell-cabal-line-filename))) |
||||
(when filename |
||||
(let ((candidates |
||||
(delq nil (mapcar |
||||
(lambda (dir) |
||||
(let ((file (haskell-cabal-join-paths base-dir dir filename))) |
||||
(when (and (file-readable-p file) |
||||
(not (file-directory-p file))) |
||||
file))) |
||||
src-dirs)))) |
||||
(if (null candidates) |
||||
(let* ((src-dir (haskell-cabal-join-paths base-dir (or (car src-dirs) ""))) |
||||
(newfile (haskell-cabal-join-paths src-dir filename)) |
||||
(do-create-p (y-or-n-p (format "Create file %s ?" newfile)))) |
||||
(when do-create-p |
||||
(find-file-other-window newfile ))) |
||||
(find-file-other-window (car candidates))))))) |
||||
|
||||
|
||||
(defun haskell-cabal-find-section-type (type &optional wrap) |
||||
(save-excursion |
||||
(haskell-cabal-next-section) |
||||
(while |
||||
(not |
||||
(or |
||||
(eobp) |
||||
(string= |
||||
(downcase type) |
||||
(downcase (haskell-cabal-section-name (haskell-cabal-section)))))) |
||||
(haskell-cabal-next-section)) |
||||
(if (eobp) |
||||
(if wrap (progn |
||||
(goto-char (point-min)) |
||||
(haskell-cabal-find-section-type type nil) ) |
||||
nil) |
||||
(point)))) |
||||
|
||||
(defun haskell-cabal-goto-section-type (type) |
||||
(let ((section (haskell-cabal-find-section-type type t))) |
||||
(if section (goto-char section) |
||||
(message "No %s section found" type)))) |
||||
|
||||
(defun haskell-cabal-goto-library-section () |
||||
(interactive) |
||||
(haskell-cabal-goto-section-type "library")) |
||||
|
||||
(defun haskell-cabal-goto-test-suite-section () |
||||
(interactive) |
||||
(haskell-cabal-goto-section-type "test-suite")) |
||||
|
||||
(defun haskell-cabal-goto-executable-section () |
||||
(interactive) |
||||
(haskell-cabal-goto-section-type "executable")) |
||||
|
||||
(defun haskell-cabal-goto-benchmark-section () |
||||
(interactive) |
||||
(haskell-cabal-goto-section-type "benchmark")) |
||||
|
||||
|
||||
|
||||
(defun haskell-cabal-line-entry-column () |
||||
"Column at which the line entry starts" |
||||
(save-excursion |
||||
(cl-case (haskell-cabal-classify-line) |
||||
(section-data (beginning-of-line) |
||||
(when (looking-at "[ ]*\\(?:,[ ]*\\)?") |
||||
(goto-char (match-end 0)) |
||||
(current-column))) |
||||
(subsection-header |
||||
(haskell-cabal-section-data-start-column (haskell-cabal-subsection)))))) |
||||
|
||||
(defun haskell-cabal-forward-to-line-entry () |
||||
"go forward to the beginning of the line entry (but never move backwards)" |
||||
(let ((col (haskell-cabal-line-entry-column))) |
||||
(when (and col (< (current-column) col)) |
||||
(beginning-of-line) |
||||
(forward-char col)))) |
||||
|
||||
(defun haskell-cabal-indent-line () |
||||
"Indent current line according to subsection" |
||||
(interactive) |
||||
(cl-case (haskell-cabal-classify-line) |
||||
(section-data |
||||
(save-excursion |
||||
(let ((indent (haskell-cabal-section-data-start-column |
||||
(haskell-cabal-subsection)))) |
||||
(indent-line-to indent) |
||||
(beginning-of-line) |
||||
(when (looking-at "[ ]*\\([ ]\\{2\\},[ ]*\\)") |
||||
(replace-match ", " t t nil 1))))) |
||||
(empty |
||||
(indent-relative))) |
||||
(haskell-cabal-forward-to-line-entry)) |
||||
|
||||
(defun haskell-cabal-map-sections (fun) |
||||
"Execute fun over each section, collecting the result" |
||||
(save-excursion |
||||
(goto-char (point-min)) |
||||
(let ((results nil)) |
||||
(while (not (eobp)) |
||||
(let* ((section (haskell-cabal-section)) |
||||
(result (and section (funcall fun (haskell-cabal-section))))) |
||||
(when section (setq results (cons result results)))) |
||||
(haskell-cabal-next-section)) |
||||
(nreverse results)))) |
||||
|
||||
(defun haskell-cabal-section-add-build-dependency (dependency &optional sort sec) |
||||
"Add a build dependency to the build-depends section" |
||||
(let* ((section (or sec (haskell-cabal-section))) |
||||
(subsection (and section |
||||
(haskell-cabal-find-subsection section "build-depends")))) |
||||
(when subsection |
||||
(haskell-cabal-with-subsection |
||||
subsection t |
||||
(haskell-cabal-with-cs-list |
||||
(insert dependency) |
||||
(insert "\n") |
||||
(when sort |
||||
(goto-char (point-min)) |
||||
(sort-subr nil 'forward-line 'end-of-line |
||||
'haskell-cabal-sort-lines-key-fun))))))) |
||||
|
||||
(defun haskell-cabal-add-build-dependency (dependency &optional sort silent) |
||||
"Add a build dependencies to sections" |
||||
(haskell-cabal-map-sections |
||||
(lambda (section) |
||||
(when (haskell-cabal-source-section-p section) |
||||
(when (or silent |
||||
(y-or-n-p (format "Add dependency %s to %s section %s?" |
||||
dependency |
||||
(haskell-cabal-section-name section) |
||||
(haskell-cabal-section-value section)))) |
||||
(haskell-cabal-section-add-build-dependency dependency sort section) |
||||
nil))))) |
||||
|
||||
(defun haskell-cabal-add-dependency (package &optional version no-prompt |
||||
sort silent) |
||||
"Add PACKAGE (and optionally suffix -VERSION) to the cabal |
||||
file. Prompts the user before doing so. |
||||
|
||||
If VERSION is non-nil it will be appended as a minimum version. |
||||
If NO-PROMPT is nil the minimum-version is read from the minibuffer |
||||
When SORT is non-nil the package entries are sorted afterwards |
||||
If SILENT ist nil the user is prompted for each source-section |
||||
" |
||||
(interactive |
||||
(list (read-from-minibuffer "Package entry: ") |
||||
nil t t nil)) |
||||
(save-window-excursion |
||||
(find-file-other-window (haskell-cabal-find-file)) |
||||
(let ((entry (if no-prompt package |
||||
(read-from-minibuffer |
||||
"Package entry: " |
||||
(concat package (if version (concat " >= " version) "")))))) |
||||
(haskell-cabal-add-build-dependency entry sort silent) |
||||
(when (or silent (y-or-n-p "Save cabal file?")) |
||||
(save-buffer))))) |
||||
|
||||
(provide 'haskell-cabal) |
||||
|
||||
;;; haskell-cabal.el ends here |
||||
@ -0,0 +1,184 @@
|
||||
;;; haskell-checkers.el --- Emacs interface to haskell lint and style checkers -*- lexical-binding: t -*- |
||||
|
||||
;; Copyright (C) 2009-2011 Alex Ott, Liam O'Reilly |
||||
;; |
||||
;; Author: Alex Ott <alexott@gmail.com>, Liam O'Reilly <csliam@swansea.ac.uk> |
||||
;; Keywords: haskell, lint, hlint, style scanner |
||||
;; Requirements: hlint, scan, haskell |
||||
|
||||
;; This file is not part of GNU Emacs. |
||||
|
||||
;; This program 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 2 of the License, or |
||||
;; (at your option) any later version. |
||||
|
||||
;; This program 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 program. If not, see <http://www.gnu.org/licenses/>. |
||||
|
||||
;;; Commentary: |
||||
|
||||
;;; Code: |
||||
|
||||
(require 'compile) |
||||
|
||||
;;;###autoload |
||||
(defgroup haskell-checkers nil |
||||
"Run HLint as inferior of Emacs, parse error messages." |
||||
:group 'haskell) |
||||
|
||||
;;;###autoload |
||||
(defcustom haskell-lint-command "hlint" |
||||
"The default lint command for \\[hlint]." |
||||
:type 'string |
||||
:group 'haskell-checkers) |
||||
|
||||
;;;###autoload |
||||
(defcustom haskell-scan-command "scan" |
||||
"The default scan command for \\[haskell-scan]." |
||||
:type 'string |
||||
:group 'haskell-checkers) |
||||
|
||||
;;;###autoload |
||||
(defcustom haskell-scan-options "" |
||||
"The default options for \\[haskell-scan]." |
||||
:type 'string |
||||
:group 'haskell-checkers) |
||||
|
||||
;;;###autoload |
||||
(defcustom haskell-lint-options "" |
||||
"The default options for \\[hlint]." |
||||
:type 'string |
||||
:group 'haskell-checkers) |
||||
|
||||
;;;###autoload |
||||
(defcustom haskell-checkers-save-files t |
||||
"Save modified files when run checker or not (ask user)" |
||||
:type 'boolean |
||||
:group 'haskell-checkers) |
||||
|
||||
;;;###autoload |
||||
(defcustom haskell-checkers-replace-with-suggestions nil |
||||
"Replace user's code with suggested replacements (hlint only)" |
||||
:type 'boolean |
||||
:group 'haskell-checkers) |
||||
|
||||
;;;###autoload |
||||
(defcustom haskell-checkers-replace-without-ask nil |
||||
"Replace user's code with suggested replacements automatically (hlint only)" |
||||
:type 'boolean |
||||
:group 'haskell-checkers) |
||||
|
||||
;; regex for replace HLint's suggestions |
||||
;; |
||||
;; ^\(.*?\):\([0-9]+\):\([0-9]+\): .* |
||||
;; Found: |
||||
;; \s +\(.*\) |
||||
;; Why not: |
||||
;; \s +\(.*\) |
||||
|
||||
(defvar haskell-lint-regex |
||||
"^\\(.*?\\):\\([0-9]+\\):\\([0-9]+\\): .*[\n\C-m]Found:[\n\C-m]\\s +\\(.*\\)[\n\C-m]Why not:[\n\C-m]\\s +\\(.*\\)[\n\C-m]" |
||||
"Regex for HLint messages") |
||||
|
||||
(defun haskell-checkers-make-short-string (str maxlen) |
||||
(if (< (length str) maxlen) |
||||
str |
||||
(concat (substring str 0 (- maxlen 3)) "..."))) |
||||
|
||||
;; TODO: check, is it possible to adopt it for haskell-scan? |
||||
(defun haskell-lint-replace-suggestions () |
||||
"Perform actual replacement of HLint's suggestions" |
||||
(goto-char (point-min)) |
||||
(while (re-search-forward haskell-lint-regex nil t) |
||||
(let* ((fname (match-string 1)) |
||||
(fline (string-to-number (match-string 2))) |
||||
(old-code (match-string 4)) |
||||
(new-code (match-string 5)) |
||||
(msg (concat "Replace '" (haskell-checkers-make-short-string old-code 30) |
||||
"' with '" (haskell-checkers-make-short-string new-code 30) "'")) |
||||
(bline 0) |
||||
(eline 0) |
||||
(spos 0) |
||||
(new-old-code "")) |
||||
(save-excursion |
||||
(switch-to-buffer (get-file-buffer fname)) |
||||
(goto-char (point-min)) |
||||
(forward-line (1- fline)) |
||||
(beginning-of-line) |
||||
(setq bline (point)) |
||||
(when (or haskell-checkers-replace-without-ask |
||||
(yes-or-no-p msg)) |
||||
(end-of-line) |
||||
(setq eline (point)) |
||||
(beginning-of-line) |
||||
(setq old-code (regexp-quote old-code)) |
||||
(while (string-match "\\\\ " old-code spos) |
||||
(setq new-old-code (concat new-old-code |
||||
(substring old-code spos (match-beginning 0)) |
||||
"\\ *")) |
||||
(setq spos (match-end 0))) |
||||
(setq new-old-code (concat new-old-code (substring old-code spos))) |
||||
(remove-text-properties bline eline '(composition nil)) |
||||
(when (re-search-forward new-old-code eline t) |
||||
(replace-match new-code nil t))))))) |
||||
|
||||
(defun haskell-lint-finish-hook (_buf _msg) |
||||
"Function, that is executed at the end of HLint or scan execution" |
||||
(if haskell-checkers-replace-with-suggestions |
||||
(haskell-lint-replace-suggestions) |
||||
(next-error 1 t))) |
||||
|
||||
(defun haskell-scan-finish-hook (_buf _msg) |
||||
"Function, that is executed at the end of haskell-scan execution" |
||||
(next-error 1 t)) |
||||
|
||||
(defun haskell-scan-make-command (file) |
||||
"Generates command line for scan" |
||||
(concat haskell-scan-command " " haskell-scan-options " \"" file "\"")) |
||||
|
||||
(defun haskell-lint-make-command (file) |
||||
"Generates command line for scan" |
||||
(concat haskell-lint-command " \"/" file "/\"" " " haskell-lint-options)) |
||||
|
||||
(defmacro haskell-checkers-setup (type name) |
||||
"Performs setup of corresponding checker. Receives two arguments: |
||||
type - checker's type (lint or scan) that is expanded into functions and hooks names |
||||
name - user visible name for this mode" |
||||
(let ((nm (concat "haskell-" (symbol-name type)))) |
||||
`(progn |
||||
;;;###autoload |
||||
(defvar ,(intern (concat nm "-setup-hook")) nil |
||||
,(concat "Hook, that will executed before running " name)) |
||||
(defun ,(intern (concat nm "-process-setup")) () |
||||
"Setup compilation variables and buffer for `hlint'." |
||||
(run-hooks ',(intern (concat nm "-setup-hook")))) |
||||
;;;###autoload |
||||
(define-compilation-mode ,(intern (concat nm "-mode")) ,name |
||||
,(concat "Mode to check Haskell source code using " name) |
||||
(set (make-local-variable 'compilation-process-setup-function) |
||||
',(intern (concat nm "-process-setup"))) |
||||
(set (make-local-variable 'compilation-disable-input) t) |
||||
(set (make-local-variable 'compilation-scroll-output) nil) |
||||
(set (make-local-variable 'compilation-finish-functions) |
||||
(list ',(intern (concat nm "-finish-hook"))))) |
||||
;;;###autoload |
||||
(defun ,(intern nm) () |
||||
,(concat "Run " name " for current buffer with haskell source") |
||||
(interactive) |
||||
(save-some-buffers haskell-checkers-save-files) |
||||
(compilation-start (,(intern (concat nm "-make-command")) buffer-file-name) |
||||
',(intern (concat nm "-mode"))))) |
||||
)) |
||||
|
||||
(haskell-checkers-setup lint "HLint") |
||||
(haskell-checkers-setup scan "HScan") |
||||
|
||||
(provide 'haskell-checkers) |
||||
|
||||
;;; haskell-checkers.el ends here |
||||
@ -0,0 +1,65 @@
|
||||
;;; haskell-collapse.el --- Collapse expressions -*- lexical-binding: t -*- |
||||
|
||||
;; Copyright (c) 2014 Chris Done. All rights reserved. |
||||
|
||||
;; 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, 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 program. If not, see <http://www.gnu.org/licenses/>. |
||||
|
||||
;;; Code: |
||||
|
||||
(define-button-type 'haskell-collapse-toggle-button |
||||
'action 'haskell-collapse-toggle-button-callback |
||||
'follow-link t |
||||
'help-echo "Click to expand…") |
||||
|
||||
(defun haskell-collapse (beg end) |
||||
"Collapse." |
||||
(interactive "r") |
||||
(goto-char end) |
||||
(let ((break nil)) |
||||
(while (and (not break) |
||||
(search-backward-regexp "[[({]" beg t 1)) |
||||
(unless (elt (syntax-ppss) 3) |
||||
(let ((orig (point))) |
||||
(haskell-collapse-sexp) |
||||
(goto-char orig) |
||||
(forward-char -1) |
||||
(when (= (point) orig) |
||||
(setq break t))))))) |
||||
|
||||
(defun haskell-collapse-sexp () |
||||
"Collapse the sexp starting at point." |
||||
(let ((beg (point))) |
||||
(forward-sexp) |
||||
(let ((end (point))) |
||||
(let ((o (make-overlay beg end))) |
||||
(overlay-put o 'invisible t) |
||||
(let ((start (point))) |
||||
(insert "…") |
||||
(let ((button (make-text-button start (point) |
||||
:type 'haskell-collapse-toggle-button))) |
||||
(button-put button 'overlay o) |
||||
(button-put button 'hide-on-click t))))))) |
||||
|
||||
(defun haskell-collapse-toggle-button-callback (btn) |
||||
"The callback to toggle the overlay visibility." |
||||
(let ((overlay (button-get btn 'overlay))) |
||||
(when overlay |
||||
(overlay-put overlay |
||||
'invisible |
||||
(not (overlay-get overlay |
||||
'invisible))))) |
||||
(button-put btn 'invisible t) |
||||
(delete-region (button-start btn) (button-end btn))) |
||||
|
||||
(provide 'haskell-collapse) |
||||
@ -0,0 +1,944 @@
|
||||
;;; haskell-commands.el --- Commands that can be run on the process -*- lexical-binding: t -*- |
||||
|
||||
;;; Commentary: |
||||
|
||||
;;; This module provides varoius `haskell-mode' and `haskell-interactive-mode' |
||||
;;; specific commands such as show type signature, show info, haskell process |
||||
;;; commands and etc. |
||||
|
||||
;; Copyright (c) 2014 Chris Done. All rights reserved. |
||||
|
||||
;; 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, 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 program. If not, see <http://www.gnu.org/licenses/>. |
||||
|
||||
;;; Code: |
||||
|
||||
(require 'cl-lib) |
||||
(require 'etags) |
||||
(require 'haskell-compat) |
||||
(require 'haskell-process) |
||||
(require 'haskell-font-lock) |
||||
(require 'haskell-interactive-mode) |
||||
(require 'haskell-session) |
||||
(require 'haskell-presentation-mode) |
||||
(require 'haskell-utils) |
||||
(require 'highlight-uses-mode) |
||||
|
||||
;;;###autoload |
||||
(defun haskell-process-restart () |
||||
"Restart the inferior Haskell process." |
||||
(interactive) |
||||
(haskell-process-reset (haskell-interactive-process)) |
||||
(haskell-process-set (haskell-interactive-process) 'command-queue nil) |
||||
(haskell-process-start (haskell-interactive-session))) |
||||
|
||||
(defun haskell-process-start (session) |
||||
"Start the inferior Haskell process with a given SESSION. |
||||
You can create new session using function `haskell-session-make'." |
||||
(let ((existing-process (get-process (haskell-session-name (haskell-interactive-session))))) |
||||
(when (processp existing-process) |
||||
(haskell-interactive-mode-echo session "Restarting process ...") |
||||
(haskell-process-set (haskell-session-process session) 'is-restarting t) |
||||
(delete-process existing-process))) |
||||
(let ((process (or (haskell-session-process session) |
||||
(haskell-process-make (haskell-session-name session)))) |
||||
(old-queue (haskell-process-get (haskell-session-process session) |
||||
'command-queue))) |
||||
(haskell-session-set-process session process) |
||||
(haskell-process-set-session process session) |
||||
(haskell-process-set-cmd process nil) |
||||
(haskell-process-set (haskell-session-process session) 'is-restarting nil) |
||||
(let ((default-directory (haskell-session-cabal-dir session)) |
||||
(log-and-command (haskell-process-compute-process-log-and-command session (haskell-process-type)))) |
||||
(haskell-session-prompt-set-current-dir session (not haskell-process-load-or-reload-prompt)) |
||||
(haskell-process-set-process |
||||
process |
||||
(progn |
||||
(haskell-process-log (propertize (format "%S" log-and-command))) |
||||
(apply #'start-process (cdr log-and-command))))) |
||||
(progn (set-process-sentinel (haskell-process-process process) 'haskell-process-sentinel) |
||||
(set-process-filter (haskell-process-process process) 'haskell-process-filter)) |
||||
(haskell-process-send-startup process) |
||||
(unless (or (eq 'cabal-repl (haskell-process-type)) |
||||
(eq 'stack-ghci (haskell-process-type))) ;; Both "cabal repl" and "stack ghci" set the proper CWD. |
||||
(haskell-process-change-dir session |
||||
process |
||||
(haskell-session-current-dir session))) |
||||
(haskell-process-set process 'command-queue |
||||
(append (haskell-process-get (haskell-session-process session) |
||||
'command-queue) |
||||
old-queue)) |
||||
process)) |
||||
|
||||
(defun haskell-process-send-startup (process) |
||||
"Send the necessary start messages to haskell PROCESS." |
||||
(haskell-process-queue-command |
||||
process |
||||
(make-haskell-command |
||||
:state process |
||||
|
||||
:go (lambda (process) |
||||
;; We must set the prompt last, so that this command as a |
||||
;; whole produces only one prompt marker as a response. |
||||
(haskell-process-send-string process "Prelude.putStrLn \"\"") |
||||
(haskell-process-send-string process ":set -v1") |
||||
(haskell-process-send-string process ":set prompt \"\\4\"")) |
||||
|
||||
:live (lambda (process buffer) |
||||
(when (haskell-process-consume |
||||
process |
||||
"^\*\*\* WARNING: \\(.+\\) is writable by someone else, IGNORING!$") |
||||
(let ((path (match-string 1 buffer))) |
||||
(haskell-session-modify |
||||
(haskell-process-session process) |
||||
'ignored-files |
||||
(lambda (files) |
||||
(cl-remove-duplicates (cons path files) :test 'string=))) |
||||
(haskell-interactive-mode-compile-warning |
||||
(haskell-process-session process) |
||||
(format "GHCi is ignoring: %s (run M-x haskell-process-unignore)" |
||||
path))))) |
||||
|
||||
:complete (lambda (process _) |
||||
(haskell-interactive-mode-echo |
||||
(haskell-process-session process) |
||||
(concat (nth (random (length haskell-process-greetings)) |
||||
haskell-process-greetings) |
||||
(when haskell-process-show-debug-tips |
||||
" |
||||
If I break, you can: |
||||
1. Restart: M-x haskell-process-restart |
||||
2. Configure logging: C-h v haskell-process-log (useful for debugging) |
||||
3. General config: M-x customize-mode |
||||
4. Hide these tips: C-h v haskell-process-show-debug-tips"))))))) |
||||
|
||||
(defun haskell-commands-process () |
||||
"Get the Haskell session, throws an error if not available." |
||||
(or (haskell-session-process (haskell-session-maybe)) |
||||
(error "No Haskell session/process associated with this |
||||
buffer. Maybe run M-x haskell-session-change?"))) |
||||
|
||||
;;;###autoload |
||||
(defun haskell-process-clear () |
||||
"Clear the current process." |
||||
(interactive) |
||||
(haskell-process-reset (haskell-commands-process)) |
||||
(haskell-process-set (haskell-commands-process) 'command-queue nil)) |
||||
|
||||
;;;###autoload |
||||
(defun haskell-process-interrupt () |
||||
"Interrupt the process (SIGINT)." |
||||
(interactive) |
||||
(interrupt-process (haskell-process-process (haskell-commands-process)))) |
||||
|
||||
(defun haskell-process-reload-with-fbytecode (process module-buffer) |
||||
"Query a PROCESS to reload MODULE-BUFFER with -fbyte-code set. |
||||
Restores -fobject-code after reload finished. |
||||
MODULE-BUFFER is the actual Emacs buffer of the module being loaded." |
||||
(haskell-process-queue-without-filters process ":set -fbyte-code") |
||||
;; We prefix the module's filename with a "*", which asks ghci to |
||||
;; ignore any existing object file and interpret the module. |
||||
;; Dependencies will still use their object files as usual. |
||||
(haskell-process-queue-without-filters |
||||
process |
||||
(format ":load \"*%s\"" |
||||
(replace-regexp-in-string |
||||
"\"" |
||||
"\\\\\"" |
||||
(buffer-file-name module-buffer)))) |
||||
(haskell-process-queue-without-filters process ":set -fobject-code")) |
||||
|
||||
(defvar url-http-response-status) |
||||
(defvar url-http-end-of-headers) |
||||
(defvar haskell-cabal-targets-history nil |
||||
"History list for session targets.") |
||||
|
||||
(defun haskell-process-hayoo-ident (ident) |
||||
;; FIXME Obsolete doc string, CALLBACK is not used. |
||||
"Hayoo for IDENT, return a list of modules asyncronously through CALLBACK." |
||||
;; We need a real/simulated closure, because otherwise these |
||||
;; variables will be unbound when the url-retrieve callback is |
||||
;; called. |
||||
;; TODO: Remove when this code is converted to lexical bindings by |
||||
;; default (Emacs 24.1+) |
||||
(let ((url (format haskell-process-hayoo-query-url (url-hexify-string ident)))) |
||||
(with-current-buffer (url-retrieve-synchronously url) |
||||
(if (= 200 url-http-response-status) |
||||
(progn |
||||
(goto-char url-http-end-of-headers) |
||||
(let* ((res (json-read)) |
||||
(results (assoc-default 'result res))) |
||||
;; TODO: gather packages as well, and when we choose a |
||||
;; given import, check that we have the package in the |
||||
;; cabal file as well. |
||||
(cl-mapcan (lambda (r) |
||||
;; append converts from vector -> list |
||||
(append (assoc-default 'resultModules r) nil)) |
||||
results))) |
||||
(warn "HTTP error %s fetching %s" url-http-response-status url))))) |
||||
|
||||
(defun haskell-process-hoogle-ident (ident) |
||||
"Hoogle for IDENT, return a list of modules." |
||||
(with-temp-buffer |
||||
(let ((hoogle-error (call-process "hoogle" nil t nil "search" "--exact" ident))) |
||||
(goto-char (point-min)) |
||||
(unless (or (/= 0 hoogle-error) |
||||
(looking-at "^No results found") |
||||
(looking-at "^package ")) |
||||
(while (re-search-forward "^\\([^ ]+\\).*$" nil t) |
||||
(replace-match "\\1" nil nil)) |
||||
(cl-remove-if (lambda (a) (string= "" a)) |
||||
(split-string (buffer-string) |
||||
"\n")))))) |
||||
|
||||
(defun haskell-process-haskell-docs-ident (ident) |
||||
"Search with haskell-docs for IDENT, return a list of modules." |
||||
(cl-remove-if-not |
||||
(lambda (a) (string-match "^[[:upper:]][[:alnum:]_'.]+$" a)) |
||||
(split-string |
||||
(with-output-to-string |
||||
(with-current-buffer |
||||
standard-output |
||||
(call-process "haskell-docs" |
||||
nil ; no infile |
||||
t ; output to current buffer (that is string) |
||||
nil ; do not redisplay |
||||
"--modules" ident))) |
||||
"\n"))) |
||||
|
||||
(defun haskell-process-import-modules (process modules) |
||||
"Query PROCESS `:m +' command to import MODULES." |
||||
(when haskell-process-auto-import-loaded-modules |
||||
(haskell-process-queue-command |
||||
process |
||||
(make-haskell-command |
||||
:state (cons process modules) |
||||
:go (lambda (state) |
||||
(haskell-process-send-string |
||||
(car state) |
||||
(format ":m + %s" (mapconcat 'identity (cdr state) " ")))))))) |
||||
|
||||
;;;###autoload |
||||
(defun haskell-describe (ident) |
||||
"Describe the given identifier IDENT." |
||||
(interactive (list (read-from-minibuffer "Describe identifier: " |
||||
(haskell-ident-at-point)))) |
||||
(let ((results (read (shell-command-to-string |
||||
(concat "haskell-docs --sexp " |
||||
ident))))) |
||||
(help-setup-xref (list #'haskell-describe ident) |
||||
(called-interactively-p 'interactive)) |
||||
(save-excursion |
||||
(with-help-window (help-buffer) |
||||
(with-current-buffer (help-buffer) |
||||
(if results |
||||
(cl-loop for result in results |
||||
do (insert (propertize ident 'font-lock-face |
||||
'((:inherit font-lock-type-face |
||||
:underline t))) |
||||
" is defined in " |
||||
(let ((module (cadr (assoc 'module result)))) |
||||
(if module |
||||
(concat module " ") |
||||
"")) |
||||
(cadr (assoc 'package result)) |
||||
"\n\n") |
||||
do (let ((type (cadr (assoc 'type result)))) |
||||
(when type |
||||
(insert (haskell-fontify-as-mode type 'haskell-mode) |
||||
"\n"))) |
||||
do (let ((args (cadr (assoc 'type results)))) |
||||
(cl-loop for arg in args |
||||
do (insert arg "\n")) |
||||
(insert "\n")) |
||||
do (insert (cadr (assoc 'documentation result))) |
||||
do (insert "\n\n")) |
||||
(insert "No results for " ident))))))) |
||||
|
||||
;;;###autoload |
||||
(defun haskell-rgrep (&optional prompt) |
||||
"Grep the effective project for the symbol at point. |
||||
Very useful for codebase navigation. |
||||
|
||||
Prompts for an arbitrary regexp given a prefix arg PROMPT." |
||||
(interactive "P") |
||||
(let ((sym (if prompt |
||||
(read-from-minibuffer "Look for: ") |
||||
(haskell-ident-at-point)))) |
||||
(rgrep sym |
||||
"*.hs" ;; TODO: common Haskell extensions. |
||||
(haskell-session-current-dir (haskell-interactive-session))))) |
||||
|
||||
;;;###autoload |
||||
(defun haskell-process-do-info (&optional prompt-value) |
||||
"Print info on the identifier at point. |
||||
If PROMPT-VALUE is non-nil, request identifier via mini-buffer." |
||||
(interactive "P") |
||||
(let ((at-point (haskell-ident-at-point))) |
||||
(when (or prompt-value at-point) |
||||
(let* ((ident (replace-regexp-in-string |
||||
"^!\\([A-Z_a-z]\\)" |
||||
"\\1" |
||||
(if prompt-value |
||||
(read-from-minibuffer "Info: " at-point) |
||||
at-point))) |
||||
(modname (unless prompt-value |
||||
(haskell-utils-parse-import-statement-at-point))) |
||||
(command (cond |
||||
(modname |
||||
(format ":browse! %s" modname)) |
||||
((string= ident "") ; For the minibuffer input case |
||||
nil) |
||||
(t (format (if (string-match "^[a-zA-Z_]" ident) |
||||
":info %s" |
||||
":info (%s)") |
||||
(or ident |
||||
at-point)))))) |
||||
(when command |
||||
(haskell-process-show-repl-response command)))))) |
||||
|
||||
;;;###autoload |
||||
(defun haskell-process-do-type (&optional insert-value) |
||||
;; FIXME insert value functionallity seems to be missing. |
||||
"Print the type of the given expression. |
||||
|
||||
Given INSERT-VALUE prefix indicates that result type signature |
||||
should be inserted." |
||||
(interactive "P") |
||||
(if insert-value |
||||
(haskell-process-insert-type) |
||||
(let* ((expr |
||||
(if (use-region-p) |
||||
(buffer-substring-no-properties (region-beginning) (region-end)) |
||||
(haskell-ident-at-point))) |
||||
(expr-okay (and expr |
||||
(not (string-match-p "\\`[[:space:]]*\\'" expr)) |
||||
(not (string-match-p "\n" expr))))) |
||||
;; No newlines in expressions, and surround with parens if it |
||||
;; might be a slice expression |
||||
(when expr-okay |
||||
(haskell-process-show-repl-response |
||||
(format |
||||
(if (or (string-match-p "\\`(" expr) |
||||
(string-match-p "\\`[_[:alpha:]]" expr)) |
||||
":type %s" |
||||
":type (%s)") |
||||
expr)))))) |
||||
|
||||
;;;###autoload |
||||
(defun haskell-mode-jump-to-def-or-tag (&optional _next-p) |
||||
;; FIXME NEXT-P arg is not used |
||||
"Jump to the definition. |
||||
Jump to definition of identifier at point by consulting GHCi, or |
||||
tag table as fallback. |
||||
|
||||
Remember: If GHCi is busy doing something, this will delay, but |
||||
it will always be accurate, in contrast to tags, which always |
||||
work but are not always accurate. |
||||
If the definition or tag is found, the location from which you jumped |
||||
will be pushed onto `xref--marker-ring', so you can return to that |
||||
position with `xref-pop-marker-stack'." |
||||
(interactive "P") |
||||
(let ((initial-loc (point-marker)) |
||||
(loc (haskell-mode-find-def (haskell-ident-at-point)))) |
||||
(if loc |
||||
(haskell-mode-handle-generic-loc loc) |
||||
(call-interactively 'haskell-mode-tag-find)) |
||||
(unless (equal initial-loc (point-marker)) |
||||
(xref-push-marker-stack initial-loc)))) |
||||
|
||||
;;;###autoload |
||||
(defun haskell-mode-goto-loc () |
||||
"Go to the location of the thing at point. |
||||
Requires the :loc-at command from GHCi." |
||||
(interactive) |
||||
(let ((loc (haskell-mode-loc-at))) |
||||
(when loc |
||||
(haskell-mode-goto-span loc)))) |
||||
|
||||
(defun haskell-mode-goto-span (span) |
||||
"Jump to the SPAN, whatever file and line and column it needs to get there." |
||||
(xref-push-marker-stack) |
||||
(find-file (expand-file-name (plist-get span :path) |
||||
(haskell-session-cabal-dir (haskell-interactive-session)))) |
||||
(goto-char (point-min)) |
||||
(forward-line (1- (plist-get span :start-line))) |
||||
(forward-char (plist-get span :start-col))) |
||||
|
||||
(defun haskell-process-insert-type () |
||||
"Get the identifer at the point and insert its type. |
||||
Use GHCi's :type if it's possible." |
||||
(let ((ident (haskell-ident-at-point))) |
||||
(when ident |
||||
(let ((process (haskell-interactive-process)) |
||||
(query (format (if (string-match "^[_[:lower:][:upper:]]" ident) |
||||
":type %s" |
||||
":type (%s)") |
||||
ident))) |
||||
(haskell-process-queue-command |
||||
process |
||||
(make-haskell-command |
||||
:state (list process query (current-buffer)) |
||||
:go (lambda (state) |
||||
(haskell-process-send-string (nth 0 state) |
||||
(nth 1 state))) |
||||
:complete (lambda (state response) |
||||
(cond |
||||
;; TODO: Generalize this into a function. |
||||
((or (string-match "^Top level" response) |
||||
(string-match "^<interactive>" response)) |
||||
(message response)) |
||||
(t |
||||
(with-current-buffer (nth 2 state) |
||||
(goto-char (line-beginning-position)) |
||||
(insert (format "%s\n" (replace-regexp-in-string "\n$" "" response))))))))))))) |
||||
|
||||
(defun haskell-mode-find-def (ident) |
||||
;; TODO Check if it possible to exploit `haskell-process-do-info' |
||||
"Find definition location of identifier IDENT. |
||||
Uses the GHCi process to find the location. Returns nil if it |
||||
can't find the identifier or the identifier isn't a string. |
||||
|
||||
Returns: |
||||
|
||||
(library <package> <module>) |
||||
(file <path> <line> <col>) |
||||
(module <name>) |
||||
nil" |
||||
(when (stringp ident) |
||||
(let ((reply (haskell-process-queue-sync-request |
||||
(haskell-interactive-process) |
||||
(format (if (string-match "^[a-zA-Z_]" ident) |
||||
":info %s" |
||||
":info (%s)") |
||||
ident)))) |
||||
(let ((match (string-match "-- Defined \\(at\\|in\\) \\(.+\\)$" reply))) |
||||
(when match |
||||
(let ((defined (match-string 2 reply))) |
||||
(let ((match (string-match "\\(.+?\\):\\([0-9]+\\):\\([0-9]+\\)$" defined))) |
||||
(cond |
||||
(match |
||||
(list 'file |
||||
(expand-file-name (match-string 1 defined) |
||||
(haskell-session-current-dir (haskell-interactive-session))) |
||||
(string-to-number (match-string 2 defined)) |
||||
(string-to-number (match-string 3 defined)))) |
||||
(t |
||||
(let ((match (string-match "`\\(.+?\\):\\(.+?\\)'$" defined))) |
||||
(if match |
||||
(list 'library |
||||
(match-string 1 defined) |
||||
(match-string 2 defined)) |
||||
(let ((match (string-match "`\\(.+?\\)'$" defined))) |
||||
(if match |
||||
(list 'module |
||||
(match-string 1 defined))))))))))))))) |
||||
|
||||
;;;###autoload |
||||
(defun haskell-mode-jump-to-def (ident) |
||||
"Jump to definition of identifier IDENT at point." |
||||
(interactive (list (haskell-ident-at-point))) |
||||
(let ((loc (haskell-mode-find-def ident))) |
||||
(when loc |
||||
(haskell-mode-handle-generic-loc loc)))) |
||||
|
||||
(defun haskell-mode-handle-generic-loc (loc) |
||||
"Either jump to or echo a generic location LOC. |
||||
Either a file or a library." |
||||
(cl-case (car loc) |
||||
(file (haskell-mode-jump-to-loc (cdr loc))) |
||||
(library (message "Defined in `%s' (%s)." |
||||
(elt loc 2) |
||||
(elt loc 1))) |
||||
(module (message "Defined in `%s'." |
||||
(elt loc 1))))) |
||||
|
||||
(defun haskell-mode-loc-at () |
||||
"Get the location at point. |
||||
Requires the :loc-at command from GHCi." |
||||
(let ((pos (or (when (region-active-p) |
||||
(cons (region-beginning) |
||||
(region-end))) |
||||
(haskell-spanable-pos-at-point) |
||||
(cons (point) |
||||
(point))))) |
||||
(when pos |
||||
(let ((reply (haskell-process-queue-sync-request |
||||
(haskell-interactive-process) |
||||
(save-excursion |
||||
(format ":loc-at %s %d %d %d %d %s" |
||||
(buffer-file-name) |
||||
(progn (goto-char (car pos)) |
||||
(line-number-at-pos)) |
||||
(1+ (current-column)) ;; GHC uses 1-based columns. |
||||
(progn (goto-char (cdr pos)) |
||||
(line-number-at-pos)) |
||||
(1+ (current-column)) ;; GHC uses 1-based columns. |
||||
(buffer-substring-no-properties (car pos) |
||||
(cdr pos))))))) |
||||
(if reply |
||||
(if (string-match "\\(.*?\\):(\\([0-9]+\\),\\([0-9]+\\))-(\\([0-9]+\\),\\([0-9]+\\))" |
||||
reply) |
||||
(list :path (match-string 1 reply) |
||||
:start-line (string-to-number (match-string 2 reply)) |
||||
;; ;; GHC uses 1-based columns. |
||||
:start-col (1- (string-to-number (match-string 3 reply))) |
||||
:end-line (string-to-number (match-string 4 reply)) |
||||
;; GHC uses 1-based columns. |
||||
:end-col (1- (string-to-number (match-string 5 reply)))) |
||||
(error (propertize reply 'face 'compilation-error))) |
||||
(error (propertize "No reply. Is :loc-at supported?" |
||||
'face 'compilation-error))))))) |
||||
|
||||
;;;###autoload |
||||
(defun haskell-process-cd (&optional _not-interactive) |
||||
;; FIXME optional arg is not used |
||||
"Change directory." |
||||
(interactive) |
||||
(let* ((session (haskell-interactive-session)) |
||||
(dir (haskell-session-prompt-set-current-dir session))) |
||||
(haskell-process-log |
||||
(propertize (format "Changing directory to %s ...\n" dir) |
||||
'face font-lock-comment-face)) |
||||
(haskell-process-change-dir session |
||||
(haskell-interactive-process) |
||||
dir))) |
||||
|
||||
(defun haskell-session-buffer-default-dir (session &optional buffer) |
||||
"Try to deduce a sensible default directory for SESSION and BUFFER, |
||||
of which the latter defaults to the current buffer." |
||||
(or (haskell-session-get session 'current-dir) |
||||
(haskell-session-get session 'cabal-dir) |
||||
(if (buffer-file-name buffer) |
||||
(file-name-directory (buffer-file-name buffer)) |
||||
"~/"))) |
||||
|
||||
(defun haskell-session-prompt-set-current-dir (session &optional use-default) |
||||
"Prompt for the current directory. |
||||
Return current working directory for SESSION." |
||||
(let ((default (haskell-session-buffer-default-dir session))) |
||||
(haskell-session-set-current-dir |
||||
session |
||||
(if use-default |
||||
default |
||||
(haskell-utils-read-directory-name "Set current directory: " default)))) |
||||
(haskell-session-get session 'current-dir)) |
||||
|
||||
(defun haskell-process-change-dir (session process dir) |
||||
"Change SESSION's current directory. |
||||
Query PROCESS to `:cd` to directory DIR." |
||||
(haskell-process-queue-command |
||||
process |
||||
(make-haskell-command |
||||
:state (list session process dir) |
||||
:go |
||||
(lambda (state) |
||||
(haskell-process-send-string |
||||
(cadr state) (format ":cd %s" (cl-caddr state)))) |
||||
|
||||
:complete |
||||
(lambda (state _) |
||||
(haskell-session-set-current-dir (car state) (cl-caddr state)) |
||||
(haskell-interactive-mode-echo (car state) |
||||
(format "Changed directory: %s" |
||||
(cl-caddr state))))))) |
||||
|
||||
;;;###autoload |
||||
(defun haskell-process-cabal-macros () |
||||
"Send the cabal macros string." |
||||
(interactive) |
||||
(haskell-process-queue-without-filters (haskell-interactive-process) |
||||
":set -optP-include -optPdist/build/autogen/cabal_macros.h")) |
||||
|
||||
(defun haskell-process-do-try-info (sym) |
||||
"Get info of SYM and echo in the minibuffer." |
||||
(let ((process (haskell-interactive-process))) |
||||
(haskell-process-queue-command |
||||
process |
||||
(make-haskell-command |
||||
:state (cons process sym) |
||||
:go (lambda (state) |
||||
(haskell-process-send-string |
||||
(car state) |
||||
(if (string-match "^[A-Za-z_]" (cdr state)) |
||||
(format ":info %s" (cdr state)) |
||||
(format ":info (%s)" (cdr state))))) |
||||
:complete (lambda (_state response) |
||||
(unless (or (string-match "^Top level" response) |
||||
(string-match "^<interactive>" response)) |
||||
(haskell-mode-message-line response))))))) |
||||
|
||||
(defun haskell-process-do-try-type (sym) |
||||
"Get type of SYM and echo in the minibuffer." |
||||
(let ((process (haskell-interactive-process))) |
||||
(haskell-process-queue-command |
||||
process |
||||
(make-haskell-command |
||||
:state (cons process sym) |
||||
:go (lambda (state) |
||||
(haskell-process-send-string |
||||
(car state) |
||||
(if (string-match "^[A-Za-z_]" (cdr state)) |
||||
(format ":type %s" (cdr state)) |
||||
(format ":type (%s)" (cdr state))))) |
||||
:complete (lambda (_state response) |
||||
(unless (or (string-match "^Top level" response) |
||||
(string-match "^<interactive>" response)) |
||||
(haskell-mode-message-line response))))))) |
||||
|
||||
;;;###autoload |
||||
(defun haskell-mode-show-type-at (&optional insert-value) |
||||
"Show type of the thing at point or within active region asynchronously. |
||||
This function requires GHCi-ng and `:set +c` option enabled by |
||||
default (please follow GHCi-ng README available at URL |
||||
`https://github.com/chrisdone/ghci-ng'). |
||||
|
||||
\\<haskell-interactive-mode-map> |
||||
To make this function works sometimes you need to load the file in REPL |
||||
first using command `haskell-process-load-or-reload' bound to |
||||
\\[haskell-process-load-or-reload]. |
||||
|
||||
Optional argument INSERT-VALUE indicates that |
||||
recieved type signature should be inserted (but only if nothing |
||||
happened since function invocation)." |
||||
(interactive "P") |
||||
(let* ((pos (haskell-command-capture-expr-bounds)) |
||||
(req (haskell-utils-compose-type-at-command pos)) |
||||
(process (haskell-interactive-process)) |
||||
(buf (current-buffer)) |
||||
(pos-reg (cons pos (region-active-p)))) |
||||
(haskell-process-queue-command |
||||
process |
||||
(make-haskell-command |
||||
:state (list process req buf insert-value pos-reg) |
||||
:go |
||||
(lambda (state) |
||||
(let* ((prc (car state)) |
||||
(req (nth 1 state))) |
||||
(haskell-utils-async-watch-changes) |
||||
(haskell-process-send-string prc req))) |
||||
:complete |
||||
(lambda (state response) |
||||
(let* ((init-buffer (nth 2 state)) |
||||
(insert-value (nth 3 state)) |
||||
(pos-reg (nth 4 state)) |
||||
(wrap (cdr pos-reg)) |
||||
(min-pos (caar pos-reg)) |
||||
(max-pos (cdar pos-reg)) |
||||
(sig (haskell-utils-reduce-string response)) |
||||
(res-type (haskell-utils-parse-repl-response sig))) |
||||
|
||||
(cl-case res-type |
||||
;; neither popup presentation buffer |
||||
;; nor insert response in error case |
||||
('unknown-command |
||||
(message |
||||
(concat |
||||
"This command requires GHCi-ng. " |
||||
"Please read command description for details."))) |
||||
('option-missing |
||||
(message |
||||
(concat |
||||
"Could not infer type signature. " |
||||
"You need to load file first. " |
||||
"Also :set +c is required. " |
||||
"Please read command description for details."))) |
||||
('interactive-error (message "Wrong REPL response: %s" sig)) |
||||
(otherwise |
||||
(if insert-value |
||||
;; Only insert type signature and do not present it |
||||
(if (= (length haskell-utils-async-post-command-flag) 1) |
||||
(if wrap |
||||
;; Handle region case |
||||
(progn |
||||
(deactivate-mark) |
||||
(save-excursion |
||||
(delete-region min-pos max-pos) |
||||
(goto-char min-pos) |
||||
(insert (concat "(" sig ")")))) |
||||
;; Non-region cases |
||||
(haskell-command-insert-type-signature sig)) |
||||
;; Some commands registered, prevent insertion |
||||
(let* ((rev (reverse haskell-utils-async-post-command-flag)) |
||||
(cs (format "%s" (cdr rev)))) |
||||
(message |
||||
(concat |
||||
"Type signature insertion was prevented. " |
||||
"These commands were registered:" |
||||
cs)))) |
||||
;; Present the result only when response is valid and not asked |
||||
;; to insert result |
||||
(haskell-command-echo-or-present response))) |
||||
|
||||
(haskell-utils-async-stop-watching-changes init-buffer)))))))) |
||||
|
||||
;;;###autoload |
||||
(defun haskell-process-generate-tags (&optional and-then-find-this-tag) |
||||
"Regenerate the TAGS table. |
||||
If optional AND-THEN-FIND-THIS-TAG argument is present it is used with |
||||
function `xref-find-definitions' after new table was generated." |
||||
(interactive) |
||||
(let ((process (haskell-interactive-process))) |
||||
(haskell-process-queue-command |
||||
process |
||||
(make-haskell-command |
||||
:state (cons process and-then-find-this-tag) |
||||
:go (lambda (state) |
||||
(if (eq system-type 'windows-nt) |
||||
(haskell-process-send-string |
||||
(car state) |
||||
(format ":!hasktags --output=\"%s\\TAGS\" -x -e \"%s\"" |
||||
(haskell-session-cabal-dir (haskell-process-session (car state))) |
||||
(haskell-session-cabal-dir (haskell-process-session (car state))))) |
||||
(haskell-process-send-string |
||||
(car state) |
||||
(format ":!cd %s && %s | %s" |
||||
(haskell-session-cabal-dir |
||||
(haskell-process-session (car state))) |
||||
"find . -type f \\( -name '*.hs' -or -name '*.lhs' -or -name '*.hsc' \\) -not \\( -name '#*' -or -name '.*' \\) -print0" |
||||
"xargs -0 hasktags -e -x")))) |
||||
:complete (lambda (state _response) |
||||
(when (cdr state) |
||||
(let ((session-tags |
||||
(haskell-session-tags-filename |
||||
(haskell-process-session (car state))))) |
||||
(add-to-list 'tags-table-list session-tags) |
||||
(setq tags-file-name nil)) |
||||
(xref-find-definitions (cdr state))) |
||||
(haskell-mode-message-line "Tags generated.")))))) |
||||
|
||||
(defun haskell-process-add-cabal-autogen () |
||||
"Add cabal's autogen dir to the GHCi search path. |
||||
Add <cabal-project-dir>/dist/build/autogen/ to GHCi seatch path. |
||||
This allows modules such as 'Path_...', generated by cabal, to be |
||||
loaded by GHCi." |
||||
(unless (eq 'cabal-repl (haskell-process-type)) ;; redundant with "cabal repl" |
||||
(let* |
||||
((session (haskell-interactive-session)) |
||||
(cabal-dir (haskell-session-cabal-dir session)) |
||||
(ghci-gen-dir (format "%sdist/build/autogen/" cabal-dir))) |
||||
(haskell-process-queue-without-filters |
||||
(haskell-interactive-process) |
||||
(format ":set -i%s" ghci-gen-dir))))) |
||||
|
||||
;;;###autoload |
||||
(defun haskell-process-unignore () |
||||
"Unignore any ignored files. |
||||
Do not ignore files that were specified as being ignored by the |
||||
inferior GHCi process." |
||||
(interactive) |
||||
(let ((session (haskell-interactive-session)) |
||||
(changed nil)) |
||||
(if (null (haskell-session-get session |
||||
'ignored-files)) |
||||
(message "Nothing to unignore!") |
||||
(cl-loop for file in (haskell-session-get session |
||||
'ignored-files) |
||||
do (cl-case (read-event |
||||
(propertize (format "Set permissions? %s (y, n, v: stop and view file)" |
||||
file) |
||||
'face 'minibuffer-prompt)) |
||||
(?y |
||||
(haskell-process-unignore-file session file) |
||||
(setq changed t)) |
||||
(?v |
||||
(find-file file) |
||||
(cl-return)))) |
||||
(when (and changed |
||||
(y-or-n-p "Restart GHCi process now? ")) |
||||
(haskell-process-restart))))) |
||||
|
||||
;;;###autoload |
||||
(defun haskell-session-change-target (target) |
||||
"Set the build TARGET for cabal REPL." |
||||
(interactive |
||||
(list |
||||
(completing-read "New build target: " (haskell-cabal-enum-targets) |
||||
nil nil nil 'haskell-cabal-targets-history))) |
||||
(let* ((session haskell-session) |
||||
(old-target (haskell-session-get session 'target))) |
||||
(when session |
||||
(haskell-session-set-target session target) |
||||
(when (and (not (string= old-target target)) |
||||
(y-or-n-p "Target changed, restart haskell process?")) |
||||
(haskell-process-start session))))) |
||||
|
||||
;;;###autoload |
||||
(defun haskell-mode-stylish-buffer () |
||||
"Apply stylish-haskell to the current buffer." |
||||
(interactive) |
||||
(let ((column (current-column)) |
||||
(line (line-number-at-pos))) |
||||
(haskell-mode-buffer-apply-command "stylish-haskell") |
||||
(goto-char (point-min)) |
||||
(forward-line (1- line)) |
||||
(goto-char (+ column (point))))) |
||||
|
||||
(defun haskell-mode-buffer-apply-command (cmd) |
||||
"Execute shell command CMD with current buffer as input and output. |
||||
Use buffer as input and replace the whole buffer with the |
||||
output. If CMD fails the buffer remains unchanged." |
||||
(set-buffer-modified-p t) |
||||
(let* ((chomp (lambda (str) |
||||
(while (string-match "\\`\n+\\|^\\s-+\\|\\s-+$\\|\n+\\'" str) |
||||
(setq str (replace-match "" t t str))) |
||||
str)) |
||||
(_errout (lambda (fmt &rest args) |
||||
(let* ((warning-fill-prefix " ")) |
||||
(display-warning cmd (apply 'format fmt args) :warning)))) |
||||
(filename (buffer-file-name (current-buffer))) |
||||
(cmd-prefix (replace-regexp-in-string " .*" "" cmd)) |
||||
(tmp-file (make-temp-file cmd-prefix)) |
||||
(err-file (make-temp-file cmd-prefix)) |
||||
(default-directory (if (and (boundp 'haskell-session) |
||||
haskell-session) |
||||
(haskell-session-cabal-dir haskell-session) |
||||
default-directory)) |
||||
(_errcode (with-temp-file tmp-file |
||||
(call-process cmd filename |
||||
(list (current-buffer) err-file) nil))) |
||||
(stderr-output |
||||
(with-temp-buffer |
||||
(insert-file-contents err-file) |
||||
(funcall chomp (buffer-substring-no-properties (point-min) (point-max))))) |
||||
(stdout-output |
||||
(with-temp-buffer |
||||
(insert-file-contents tmp-file) |
||||
(buffer-substring-no-properties (point-min) (point-max))))) |
||||
(if (string= "" stderr-output) |
||||
(if (string= "" stdout-output) |
||||
(message "Error: %s produced no output, leaving buffer alone" cmd) |
||||
(save-restriction |
||||
(widen) |
||||
;; command successful, insert file with replacement to preserve |
||||
;; markers. |
||||
(insert-file-contents tmp-file nil nil nil t))) |
||||
(progn |
||||
;; non-null stderr, command must have failed |
||||
(message "Error: %s ended with errors, leaving buffer alone" cmd) |
||||
;; use (warning-minimum-level :debug) to see this |
||||
(display-warning cmd stderr-output :debug))) |
||||
(delete-file tmp-file) |
||||
(delete-file err-file))) |
||||
|
||||
;;;###autoload |
||||
(defun haskell-mode-find-uses () |
||||
"Find use cases of the identifier at point and highlight them all." |
||||
(interactive) |
||||
(let ((spans (haskell-mode-uses-at))) |
||||
(unless (null spans) |
||||
(highlight-uses-mode 1) |
||||
(cl-loop for span in spans |
||||
do (haskell-mode-make-use-highlight span))))) |
||||
|
||||
(defun haskell-mode-make-use-highlight (span) |
||||
"Make a highlight overlay at the given SPAN." |
||||
(save-window-excursion |
||||
(save-excursion |
||||
(haskell-mode-goto-span span) |
||||
(save-excursion |
||||
(highlight-uses-mode-highlight |
||||
(progn |
||||
(goto-char (point-min)) |
||||
(forward-line (1- (plist-get span :start-line))) |
||||
(forward-char (plist-get span :start-col)) |
||||
(point)) |
||||
(progn |
||||
(goto-char (point-min)) |
||||
(forward-line (1- (plist-get span :end-line))) |
||||
(forward-char (plist-get span :end-col)) |
||||
(point))))))) |
||||
|
||||
(defun haskell-mode-uses-at () |
||||
"Get the locations of use cases for the ident at point. |
||||
Requires the :uses command from GHCi." |
||||
(let ((pos (or (when (region-active-p) |
||||
(cons (region-beginning) |
||||
(region-end))) |
||||
(haskell-ident-pos-at-point) |
||||
(cons (point) |
||||
(point))))) |
||||
(when pos |
||||
(let ((reply (haskell-process-queue-sync-request |
||||
(haskell-interactive-process) |
||||
(save-excursion |
||||
(format ":uses %s %d %d %d %d %s" |
||||
(buffer-file-name) |
||||
(progn (goto-char (car pos)) |
||||
(line-number-at-pos)) |
||||
(1+ (current-column)) ;; GHC uses 1-based columns. |
||||
(progn (goto-char (cdr pos)) |
||||
(line-number-at-pos)) |
||||
(1+ (current-column)) ;; GHC uses 1-based columns. |
||||
(buffer-substring-no-properties (car pos) |
||||
(cdr pos))))))) |
||||
(if reply |
||||
(let ((lines (split-string reply "\n" t))) |
||||
(cl-remove-if |
||||
#'null |
||||
(mapcar (lambda (line) |
||||
(if (string-match "\\(.*?\\):(\\([0-9]+\\),\\([0-9]+\\))-(\\([0-9]+\\),\\([0-9]+\\))" |
||||
line) |
||||
(list :path (match-string 1 line) |
||||
:start-line (string-to-number (match-string 2 line)) |
||||
;; ;; GHC uses 1-based columns. |
||||
:start-col (1- (string-to-number (match-string 3 line))) |
||||
:end-line (string-to-number (match-string 4 line)) |
||||
;; GHC uses 1-based columns. |
||||
:end-col (1- (string-to-number (match-string 5 line)))) |
||||
(error (propertize line 'face 'compilation-error)))) |
||||
lines))) |
||||
(error (propertize "No reply. Is :uses supported?" |
||||
'face 'compilation-error))))))) |
||||
|
||||
(defun haskell-command-echo-or-present (msg) |
||||
"Present message in some manner depending on configuration. |
||||
If variable `haskell-process-use-presentation-mode' is NIL it will output |
||||
modified message MSG to echo area." |
||||
(if haskell-process-use-presentation-mode |
||||
(let ((session (haskell-process-session (haskell-interactive-process)))) |
||||
(haskell-presentation-present session msg)) |
||||
(let ((m (haskell-utils-reduce-string msg))) |
||||
(message m)))) |
||||
|
||||
(defun haskell-command-capture-expr-bounds () |
||||
"Capture position bounds of expression at point. |
||||
If there is an active region then it returns region |
||||
bounds. Otherwise it uses `haskell-spanable-pos-at-point` to |
||||
capture identifier bounds. If latter function returns NIL this function |
||||
will return cons cell where min and max positions both are equal |
||||
to point." |
||||
(or (when (region-active-p) |
||||
(cons (region-beginning) |
||||
(region-end))) |
||||
(haskell-spanable-pos-at-point) |
||||
(cons (point) (point)))) |
||||
|
||||
(defun haskell-command-insert-type-signature (signature) |
||||
"Insert type signature. |
||||
In case of active region is present, wrap it by parentheses and |
||||
append SIGNATURE to original expression. Otherwise tries to |
||||
carefully insert SIGNATURE above identifier at point. Removes |
||||
newlines and extra whitespace in signature before insertion." |
||||
(let* ((ident-pos (or (haskell-ident-pos-at-point) |
||||
(cons (point) (point)))) |
||||
(min-pos (car ident-pos)) |
||||
(sig (haskell-utils-reduce-string signature))) |
||||
(save-excursion |
||||
(goto-char min-pos) |
||||
(let ((col (current-column))) |
||||
(insert sig "\n") |
||||
(indent-to col))))) |
||||
|
||||
(provide 'haskell-commands) |
||||
;;; haskell-commands.el ends here |
||||
@ -0,0 +1,70 @@
|
||||
;;; haskell-compat.el --- legacy/compatibility backports for haskell-mode -*- lexical-binding: t -*- |
||||
;; |
||||
;; Filename: haskell-compat.el |
||||
;; Description: legacy/compatibility backports for haskell-mode |
||||
|
||||
;; 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, 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 program. If not, see <http://www.gnu.org/licenses/>. |
||||
|
||||
;;; Commentary: |
||||
|
||||
;;; Code: |
||||
(require 'etags) |
||||
(require 'ring) |
||||
(require 'outline) |
||||
(require 'xref nil t) |
||||
|
||||
(eval-when-compile |
||||
(setq byte-compile-warnings '(not cl-functions obsolete))) |
||||
|
||||
;; Missing in Emacs23, stolen from Emacs24's `subr.el' |
||||
(unless (fboundp 'process-live-p) |
||||
(defun process-live-p (process) |
||||
"Returns non-nil if PROCESS is alive. |
||||
A process is considered alive if its status is `run', `open', |
||||
`listen', `connect' or `stop'." |
||||
(memq (process-status process) |
||||
'(run open listen connect stop)))) |
||||
|
||||
;; Cross-referencing commands have been replaced since Emacs 25.1. |
||||
;; These aliases are required to provide backward compatibility. |
||||
(unless (fboundp 'xref-push-marker-stack) |
||||
(defalias 'xref-pop-marker-stack 'pop-tag-mark) |
||||
|
||||
(defun xref-push-marker-stack (&optional m) |
||||
"Add point to the marker stack." |
||||
(ring-insert find-tag-marker-ring (or m (point-marker))))) |
||||
|
||||
(unless (fboundp 'outline-hide-sublevels) |
||||
(defalias 'outline-hide-sublevels 'hide-sublevels)) |
||||
|
||||
(unless (fboundp 'outline-show-subtree) |
||||
(defalias 'outline-show-subtree 'show-subtree)) |
||||
|
||||
(unless (fboundp 'outline-hide-sublevels) |
||||
(defalias 'outline-hide-sublevels 'hide-sublevels)) |
||||
|
||||
(unless (fboundp 'outline-show-subtree) |
||||
(defalias 'outline-show-subtree 'show-subtree)) |
||||
|
||||
(unless (fboundp 'xref-find-definitions) |
||||
(defun xref-find-definitions (ident) |
||||
(let ((next-p (and (boundp 'xref-prompt-for-identifier) |
||||
xref-prompt-for-identifier))) |
||||
(find-tag ident next-p)))) |
||||
|
||||
(provide 'haskell-compat) |
||||
|
||||
;;; haskell-compat.el ends here |
||||
@ -0,0 +1,163 @@
|
||||
;;; haskell-compile.el --- Haskell/GHC compilation sub-mode -*- lexical-binding: t -*- |
||||
|
||||
;; Copyright (C) 2013 Herbert Valerio Riedel |
||||
|
||||
;; Author: Herbert Valerio Riedel <hvr@gnu.org> |
||||
|
||||
;; 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 program. If not, see <http://www.gnu.org/licenses/>. |
||||
|
||||
;;; Commentary: |
||||
|
||||
;; Simple GHC-centric compilation sub-mode; see info node |
||||
;; `(haskell-mode)compilation' for more information |
||||
|
||||
;;; Code: |
||||
|
||||
(require 'compile) |
||||
(require 'haskell-cabal) |
||||
|
||||
;;;###autoload |
||||
(defgroup haskell-compile nil |
||||
"Settings for Haskell compilation mode" |
||||
:link '(custom-manual "(haskell-mode)compilation") |
||||
:group 'haskell) |
||||
|
||||
;;;###autoload |
||||
(defcustom haskell-compile-cabal-build-command |
||||
"cd %s && cabal build --ghc-option=-ferror-spans" |
||||
"Default build command to use for `haskell-cabal-build' when a cabal file is detected. |
||||
The `%s' placeholder is replaced by the cabal package top folder." |
||||
:group 'haskell-compile |
||||
:type 'string) |
||||
|
||||
;;;###autoload |
||||
(defcustom haskell-compile-cabal-build-alt-command |
||||
"cd %s && cabal clean -s && cabal build --ghc-option=-ferror-spans" |
||||
"Alternative build command to use when `haskell-cabal-build' is called with a negative prefix argument. |
||||
The `%s' placeholder is replaced by the cabal package top folder." |
||||
:group 'haskell-compile |
||||
:type 'string) |
||||
|
||||
;;;###autoload |
||||
(defcustom haskell-compile-command |
||||
"ghc -Wall -ferror-spans -fforce-recomp -c %s" |
||||
"Default build command to use for `haskell-cabal-build' when no cabal file is detected. |
||||
The `%s' placeholder is replaced by the current buffer's filename." |
||||
:group 'haskell-compile |
||||
:type 'string) |
||||
|
||||
;;;###autoload |
||||
(defcustom haskell-compile-ghc-filter-linker-messages |
||||
t |
||||
"Filter out unremarkable \"Loading package...\" linker messages during compilation." |
||||
:group 'haskell-compile |
||||
:type 'boolean) |
||||
|
||||
(defconst haskell-compilation-error-regexp-alist |
||||
`((,(concat |
||||
"^ *\\(?1:[^ \t\r\n]+?\\):" |
||||
"\\(?:" |
||||
"\\(?2:[0-9]+\\):\\(?4:[0-9]+\\)\\(?:-\\(?5:[0-9]+\\)\\)?" ;; "121:1" & "12:3-5" |
||||
"\\|" |
||||
"(\\(?2:[0-9]+\\),\\(?4:[0-9]+\\))-(\\(?3:[0-9]+\\),\\(?5:[0-9]+\\))" ;; "(289,5)-(291,36)" |
||||
"\\)" |
||||
":\\(?6: Warning:\\)?") |
||||
1 (2 . 3) (4 . 5) (6 . nil)) ;; error/warning locus |
||||
|
||||
;; multiple declarations |
||||
("^ \\(?:Declared at:\\| \\) \\(?1:[^ \t\r\n]+\\):\\(?2:[0-9]+\\):\\(?4:[0-9]+\\)$" |
||||
1 2 4 0) ;; info locus |
||||
|
||||
;; this is the weakest pattern as it's subject to line wrapping et al. |
||||
(" at \\(?1:[^ \t\r\n]+\\):\\(?2:[0-9]+\\):\\(?4:[0-9]+\\)\\(?:-\\(?5:[0-9]+\\)\\)?[)]?$" |
||||
1 2 (4 . 5) 0)) ;; info locus |
||||
"Regexps used for matching GHC compile messages. |
||||
See `compilation-error-regexp-alist' for semantics.") |
||||
|
||||
(defvar haskell-compilation-mode-map |
||||
(let ((map (make-sparse-keymap))) |
||||
(set-keymap-parent map compilation-mode-map)) |
||||
"Keymap for `haskell-compilation-mode' buffers. |
||||
This is a child of `compilation-mode-map'.") |
||||
|
||||
(defun haskell-compilation-filter-hook () |
||||
"Local `compilation-filter-hook' for `haskell-compilation-mode'." |
||||
|
||||
(when haskell-compile-ghc-filter-linker-messages |
||||
(delete-matching-lines "^ *Loading package [^ \t\r\n]+ [.]+ linking [.]+ done\\.$" |
||||
(if (boundp 'compilation-filter-start) ;; available since Emacs 24.2 |
||||
(save-excursion (goto-char compilation-filter-start) |
||||
(line-beginning-position)) |
||||
(point-min)) |
||||
(point)))) |
||||
|
||||
(define-compilation-mode haskell-compilation-mode "HsCompilation" |
||||
"Haskell/GHC specific `compilation-mode' derivative. |
||||
This mode provides support for GHC 7.[46]'s compile |
||||
messages. Specifically, also the `-ferror-spans` source location |
||||
format is supported, as well as info-locations within compile |
||||
messages pointing to additional source locations. |
||||
|
||||
See Info node `(haskell-mode)compilation' for more details." |
||||
(set (make-local-variable 'compilation-error-regexp-alist) |
||||
haskell-compilation-error-regexp-alist) |
||||
|
||||
(add-hook 'compilation-filter-hook |
||||
'haskell-compilation-filter-hook nil t) |
||||
) |
||||
|
||||
;;;###autoload |
||||
(defun haskell-compile (&optional edit-command) |
||||
"Compile the Haskell program including the current buffer. |
||||
Tries to locate the next cabal description in current or parent |
||||
folders via `haskell-cabal-find-dir' and if found, invoke |
||||
`haskell-compile-cabal-build-command' from the cabal package root |
||||
folder. If no cabal package could be detected, |
||||
`haskell-compile-command' is used instead. |
||||
|
||||
If prefix argument EDIT-COMMAND is non-nil (and not a negative |
||||
prefix `-'), `haskell-compile' prompts for custom compile |
||||
command. |
||||
|
||||
If EDIT-COMMAND contains the negative prefix argument `-', |
||||
`haskell-compile' calls the alternative command defined in |
||||
`haskell-compile-cabal-build-alt-command' if a cabal package was |
||||
detected. |
||||
|
||||
`haskell-compile' uses `haskell-compilation-mode' which is |
||||
derived from `compilation-mode'. See Info |
||||
node `(haskell-mode)compilation' for more details." |
||||
(interactive "P") |
||||
(save-some-buffers (not compilation-ask-about-save) |
||||
(if (boundp 'compilation-save-buffers-predicate) ;; since Emacs 24.1(?) |
||||
compilation-save-buffers-predicate)) |
||||
(let* ((cabdir (haskell-cabal-find-dir)) |
||||
(command1 (if (eq edit-command '-) |
||||
haskell-compile-cabal-build-alt-command |
||||
haskell-compile-cabal-build-command)) |
||||
(srcname (buffer-file-name)) |
||||
(command (if cabdir |
||||
(format command1 cabdir) |
||||
(if (and srcname (derived-mode-p 'haskell-mode)) |
||||
(format haskell-compile-command srcname) |
||||
command1)))) |
||||
(when (and edit-command (not (eq edit-command '-))) |
||||
(setq command (compilation-read-command command))) |
||||
|
||||
(compilation-start command 'haskell-compilation-mode))) |
||||
|
||||
(provide 'haskell-compile) |
||||
;;; haskell-compile.el ends here |
||||
@ -0,0 +1,133 @@
|
||||
;;; haskell-complete-module.el --- A fast way to complete Haskell module names -*- lexical-binding: t -*- |
||||
|
||||
;; Copyright (c) 2014 Chris Done. All rights reserved. |
||||
|
||||
;; 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, 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 program. If not, see <http://www.gnu.org/licenses/>. |
||||
|
||||
;;; Code: |
||||
|
||||
(require 'cl-lib) |
||||
|
||||
;;;###autoload |
||||
(defcustom haskell-complete-module-preferred |
||||
'() |
||||
"Override ordering of module results by specifying preferred modules." |
||||
:group 'haskell |
||||
:type '(repeat string)) |
||||
|
||||
;;;###autoload |
||||
(defcustom haskell-complete-module-max-display |
||||
10 |
||||
"Maximum items to display in minibuffer." |
||||
:group 'haskell |
||||
:type 'number) |
||||
|
||||
(defun haskell-complete-module-read (prompt candidates) |
||||
"Interactively auto-complete from a list of candidates." |
||||
(let ((stack (list)) |
||||
(pattern "") |
||||
(result nil)) |
||||
(delete-dups candidates) |
||||
(setq candidates |
||||
(sort candidates |
||||
(lambda (a b) |
||||
(let ((a-mem (member a haskell-complete-module-preferred)) |
||||
(b-mem (member b haskell-complete-module-preferred))) |
||||
(cond |
||||
((and a-mem (not b-mem)) |
||||
t) |
||||
((and b-mem (not a-mem)) |
||||
nil) |
||||
(t |
||||
(string< a b))))))) |
||||
(while (not result) |
||||
(let ((key |
||||
(key-description |
||||
(vector |
||||
(read-key |
||||
(concat (propertize prompt 'face 'minibuffer-prompt) |
||||
(propertize pattern 'face 'font-lock-type-face) |
||||
"{" |
||||
(mapconcat #'identity |
||||
(let* ((i 0)) |
||||
(cl-loop for candidate in candidates |
||||
while (<= i haskell-complete-module-max-display) |
||||
do (cl-incf i) |
||||
collect (cond ((> i haskell-complete-module-max-display) |
||||
"...") |
||||
((= i 1) |
||||
(propertize candidate 'face 'ido-first-match-face)) |
||||
(t candidate)))) |
||||
" | ") |
||||
"}")))))) |
||||
(cond |
||||
((string= key "C-g") |
||||
(keyboard-quit)) |
||||
((string= key "DEL") |
||||
(unless (null stack) |
||||
(setq candidates (pop stack))) |
||||
(unless (string= "" pattern) |
||||
(setq pattern (substring pattern 0 -1)))) |
||||
((string= key "RET") |
||||
(setq result (or (car candidates) |
||||
pattern))) |
||||
((string= key "<left>") |
||||
(setq candidates |
||||
(append (last candidates) |
||||
(butlast candidates)))) |
||||
((string= key "<right>") |
||||
(setq candidates |
||||
(append (cdr candidates) |
||||
(list (car candidates))))) |
||||
(t |
||||
(when (string-match "[A-Za-z0-9_'.]+" key) |
||||
(push candidates stack) |
||||
(setq pattern (concat pattern key)) |
||||
(setq candidates (haskell-complete-module pattern candidates))))))) |
||||
result)) |
||||
|
||||
(defun haskell-complete-module (pattern candidates) |
||||
"Filter the CANDIDATES using PATTERN." |
||||
(let ((case-fold-search t)) |
||||
(cl-loop for candidate in candidates |
||||
when (haskell-complete-module-match pattern candidate) |
||||
collect candidate))) |
||||
|
||||
(defun haskell-complete-module-match (pattern text) |
||||
"Match PATTERN against TEXT." |
||||
(string-match (haskell-complete-module-regexp pattern) |
||||
text)) |
||||
|
||||
(defun haskell-complete-module-regexp (pattern) |
||||
"Make a regular expression for the given module pattern. Example: |
||||
|
||||
\"c.m.s\" -> \"^c[^.]*\\.m[^.]*\\.s[^.]*\" |
||||
|
||||
" |
||||
(let ((components (mapcar #'haskell-complete-module-component |
||||
(split-string pattern "\\." t)))) |
||||
(concat "^" |
||||
(mapconcat #'identity |
||||
components |
||||
"\\.")))) |
||||
|
||||
(defun haskell-complete-module-component (component) |
||||
"Make a regular expression for the given component. Example: |
||||
|
||||
\"co\" -> \"c[^.]*o[^.]*\" |
||||
|
||||
" |
||||
(replace-regexp-in-string "\\(.\\)" "\\1[^.]*" component)) |
||||
|
||||
(provide 'haskell-complete-module) |
||||
@ -0,0 +1,266 @@
|
||||
;;; haskell-completions.el --- Haskell Completion package -*- lexical-binding: t -*- |
||||
|
||||
;; Copyright © 2015 Athur Fayzrakhmanov. All rights reserved. |
||||
|
||||
;; This file is part of haskell-mode package. |
||||
;; You can contact with authors using GitHub issue tracker: |
||||
;; https://github.com/haskell/haskell-mode/issues |
||||
|
||||
;; 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, 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 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. |
||||
|
||||
;;; Commentary: |
||||
|
||||
;; This package provides completions related functionality for |
||||
;; Haskell Mode such grab completion prefix at point, and etc.. |
||||
|
||||
;; Some description |
||||
;; ================ |
||||
;; |
||||
;; For major use function `haskell-completions-grab-prefix' is supposed, and |
||||
;; other prefix grabbing functions are used internally by it. So, only this |
||||
;; funciton have prefix minimal length functionality and invokes predicate |
||||
;; function `haskell-completions-can-grab-prefix'. |
||||
|
||||
;;; Code: |
||||
|
||||
(require 'haskell-mode) |
||||
(require 'haskell-process) |
||||
(require 'haskell-interactive-mode) |
||||
|
||||
(defvar haskell-completions-pragma-names |
||||
(list "DEPRECATED" |
||||
"INCLUDE" |
||||
"INCOHERENT" |
||||
"INLINABLE" |
||||
"INLINE" |
||||
"LANGUAGE" |
||||
"LINE" |
||||
"MINIMAL" |
||||
"NOINLINE" |
||||
"NOUNPACK" |
||||
"OPTIONS" |
||||
"OPTIONS_GHC" |
||||
"OVERLAPPABLE" |
||||
"OVERLAPPING" |
||||
"OVERLAPS" |
||||
"RULES" |
||||
"SOURCE" |
||||
"SPECIALIZE" |
||||
"UNPACK" |
||||
"WARNING") |
||||
"A list of supported pragmas. |
||||
This list comes from GHC documentation (URL |
||||
`https://downloads.haskell.org/~ghc/7.10.1/docs/html/users_guide/pragmas.html'. |
||||
") |
||||
|
||||
(defun haskell-completions-can-grab-prefix () |
||||
"Check if the case is appropriate for grabbing completion prefix. |
||||
Returns t if point is either at whitespace character, or at |
||||
punctuation, or at line end and preceeding character is not a |
||||
whitespace or new line, otherwise returns nil. |
||||
|
||||
Returns nil in presense of active region." |
||||
(when (not (region-active-p)) |
||||
(when (looking-at-p (rx (| space line-end punct))) |
||||
(when (not (bobp)) |
||||
(save-excursion |
||||
(backward-char) |
||||
(not (looking-at-p (rx (| space line-end))))))))) |
||||
|
||||
(defun haskell-completions-grab-pragma-prefix () |
||||
"Grab completion prefix for pragma completions. |
||||
Returns a list of form '(prefix-start-position |
||||
prefix-end-position prefix-value prefix-type) for pramga names |
||||
such as WARNING, DEPRECATED, LANGUAGE and etc. Also returns |
||||
completion prefixes for options in case OPTIONS_GHC pragma, or |
||||
language extensions in case of LANGUAGE pragma. Obsolete OPTIONS |
||||
pragma is supported also." |
||||
(when (nth 4 (syntax-ppss)) |
||||
;; We're inside comment |
||||
(let ((p (point)) |
||||
(comment-start (nth 8 (syntax-ppss))) |
||||
(case-fold-search nil) |
||||
prefix-start |
||||
prefix-end |
||||
prefix-type |
||||
prefix-value) |
||||
(save-excursion |
||||
(goto-char comment-start) |
||||
(when (looking-at (rx "{-#" (1+ (| space "\n")))) |
||||
(let ((pragma-start (match-end 0))) |
||||
(when (> p pragma-start) |
||||
;; point stands after `{-#` |
||||
(goto-char pragma-start) |
||||
(when (looking-at (rx (1+ (| upper "_")))) |
||||
;; found suitable sequence for pragma name |
||||
(let ((pragma-end (match-end 0)) |
||||
(pragma-value (match-string-no-properties 0))) |
||||
(if (eq p pragma-end) |
||||
;; point is at the end of (in)complete pragma name |
||||
;; prepare resulting values |
||||
(progn |
||||
(setq prefix-start pragma-start) |
||||
(setq prefix-end pragma-end) |
||||
(setq prefix-value pragma-value) |
||||
(setq prefix-type |
||||
'haskell-completions-pragma-name-prefix)) |
||||
(when (and (> p pragma-end) |
||||
(or (equal "OPTIONS_GHC" pragma-value) |
||||
(equal "OPTIONS" pragma-value) |
||||
(equal "LANGUAGE" pragma-value))) |
||||
;; point is after pragma name, so we need to check |
||||
;; special cases of `OPTIONS_GHC` and `LANGUAGE` pragmas |
||||
;; and provide a completion prefix for possible ghc |
||||
;; option or language extension. |
||||
(goto-char pragma-end) |
||||
(when (re-search-forward |
||||
(rx (* anything) |
||||
(1+ (regexp "\\S-"))) |
||||
p |
||||
t) |
||||
(let* ((str (match-string-no-properties 0)) |
||||
(split (split-string str (rx (| space "\n")) t)) |
||||
(val (car (last split))) |
||||
(end (point))) |
||||
(when (and (equal p end) |
||||
(not (string-match-p "#" val))) |
||||
(setq prefix-value val) |
||||
(backward-char (length val)) |
||||
(setq prefix-start (point)) |
||||
(setq prefix-end end) |
||||
(setq |
||||
prefix-type |
||||
(if (not (equal "LANGUAGE" pragma-value)) |
||||
'haskell-completions-ghc-option-prefix |
||||
'haskell-completions-language-extension-prefix |
||||
))))))))))))) |
||||
(when prefix-value |
||||
(list prefix-start prefix-end prefix-value prefix-type))))) |
||||
|
||||
(defun haskell-completions-grab-identifier-prefix () |
||||
"Grab completion prefix for identifier at point. |
||||
Returns a list of form '(prefix-start-position |
||||
prefix-end-position prefix-value prefix-type) for haskell |
||||
identifier at point depending on result of function |
||||
`haskell-ident-pos-at-point'." |
||||
(let ((pos-at-point (haskell-ident-pos-at-point)) |
||||
(p (point))) |
||||
(when pos-at-point |
||||
(let* ((start (car pos-at-point)) |
||||
(end (cdr pos-at-point)) |
||||
(type 'haskell-completions-identifier-prefix) |
||||
(case-fold-search nil) |
||||
value) |
||||
;; we need end position of result, becase of |
||||
;; `haskell-ident-pos-at-point' ignores trailing whitespace, e.g. the |
||||
;; result will be same for `map|` and `map |` invocations. |
||||
(when (<= p end) |
||||
(setq end p) |
||||
(setq value (buffer-substring-no-properties start end)) |
||||
(when (string-match-p (rx bos upper) value) |
||||
;; we need to check if found identifier is a module name |
||||
(save-excursion |
||||
(goto-char (line-beginning-position)) |
||||
(when (re-search-forward |
||||
(rx "import" |
||||
(? (1+ space) "qualified") |
||||
(1+ space) |
||||
upper |
||||
(1+ (| alnum "."))) |
||||
p ;; bound |
||||
t) ;; no-error |
||||
(if (equal p (point)) |
||||
(setq type 'haskell-completions-module-name-prefix) |
||||
(when (re-search-forward |
||||
(rx (| " as " "(")) |
||||
start |
||||
t) |
||||
;; but uppercase ident could occur after `as` keyword, or in |
||||
;; module imports after opening parenthesis, in this case |
||||
;; restore identifier type again, it's neccessary to |
||||
;; distinguish the means of completions retrieval |
||||
(setq type 'haskell-completions-identifier-prefix)))))) |
||||
(when (nth 8 (syntax-ppss)) |
||||
;; eighth element of syntax-ppss result is string or comment start, |
||||
;; so when it's not nil word at point is inside string or comment, |
||||
;; return special literal prefix type |
||||
(setq type 'haskell-completions-general-prefix)) |
||||
;; finally take in account minlen if given and return the result |
||||
(when value (list start end value type))))))) |
||||
|
||||
(defun haskell-completions-grab-prefix (&optional minlen) |
||||
"Grab prefix at point for possible completion. |
||||
Returns a list of form '(prefix-start-position |
||||
prefix-end-position prefix-value prefix-type) depending on |
||||
situation, e.g. is it needed to complete pragma, module name, |
||||
arbitrary identifier, and etc. Rerurns nil in case it is |
||||
impossible to grab prefix. |
||||
|
||||
If provided optional MINLEN parameter this function will return |
||||
result only if prefix length is not less than MINLEN." |
||||
(when (haskell-completions-can-grab-prefix) |
||||
(let ((prefix (cond |
||||
((haskell-completions-grab-pragma-prefix)) |
||||
((haskell-completions-grab-identifier-prefix))))) |
||||
(cond ((and minlen prefix) |
||||
(when (>= (length (nth 2 prefix)) minlen) |
||||
prefix)) |
||||
(prefix prefix))))) |
||||
|
||||
|
||||
(defun haskell-completions-sync-completions-at-point () |
||||
"A `completion-at-point' function using the current haskell process. |
||||
Returns nil if no completions available." |
||||
(let ((prefix-data (haskell-completions-grab-prefix))) |
||||
(when prefix-data |
||||
(cl-destructuring-bind (beg end pfx typ) prefix-data |
||||
(let ((imp (eql typ 'haskell-completions-module-name-prefix)) |
||||
lst) |
||||
(setq lst |
||||
(cl-case typ |
||||
;; non-interactive completions first |
||||
('haskell-completions-pragma-name-prefix |
||||
haskell-completions-pragma-names) |
||||
('haskell-completions-ghc-option-prefix |
||||
haskell-ghc-supported-options) |
||||
('haskell-completions-language-extension-prefix |
||||
haskell-ghc-supported-extensions) |
||||
(otherwise |
||||
(when (and |
||||
(not (eql typ 'haskell-completions-general-prefix)) |
||||
(haskell-session-maybe) |
||||
(not |
||||
(haskell-process-cmd (haskell-interactive-process)))) |
||||
;; if REPL is available and not busy try to query it |
||||
;; for completions list in case of module name or |
||||
;; identifier prefixes |
||||
(haskell-completions-sync-complete-repl pfx imp))))) |
||||
(when lst |
||||
(list beg end lst))))))) |
||||
|
||||
(defun haskell-completions-sync-complete-repl (prefix &optional import) |
||||
"Return completion list for given PREFIX quering REPL synchronously. |
||||
When optional IMPORT argument is non-nil complete PREFIX |
||||
prepending \"import \" keyword (useful for module names). This |
||||
function is supposed for internal use." |
||||
(haskell-process-get-repl-completions |
||||
(haskell-interactive-process) |
||||
(if import |
||||
(concat "import " prefix) |
||||
prefix))) |
||||
|
||||
(provide 'haskell-completions) |
||||
;;; haskell-completions.el ends here |
||||
@ -0,0 +1,429 @@
|
||||
;;; haskell-customize.el --- Customization settings -*- lexical-binding: t -*- |
||||
|
||||
;; Copyright (c) 2014 Chris Done. All rights reserved. |
||||
|
||||
;; 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, 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 program. If not, see <http://www.gnu.org/licenses/>. |
||||
|
||||
;;; Code: |
||||
|
||||
(require 'cl-lib) |
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
||||
;; Customization variables |
||||
|
||||
;;;###autoload |
||||
(defcustom haskell-process-load-or-reload-prompt nil |
||||
"Nil means there will be no prompts on starting REPL. Defaults will be accepted." |
||||
:type 'boolean |
||||
:group 'haskell-interactive) |
||||
|
||||
;;;###autoload |
||||
(defgroup haskell nil |
||||
"Major mode for editing Haskell programs." |
||||
:link '(custom-manual "(haskell-mode)") |
||||
:group 'languages |
||||
:prefix "haskell-") |
||||
|
||||
(defvar haskell-mode-pkg-base-dir (file-name-directory load-file-name) |
||||
"Package base directory of installed `haskell-mode'. |
||||
Used for locating additional package data files.") |
||||
|
||||
;;;###autoload |
||||
(defcustom haskell-completing-read-function 'ido-completing-read |
||||
"Default function to use for completion." |
||||
:group 'haskell |
||||
:type '(choice |
||||
(function-item :tag "ido" :value ido-completing-read) |
||||
(function-item :tag "helm" :value helm--completing-read-default) |
||||
(function-item :tag "completing-read" :value completing-read) |
||||
(function :tag "Custom function"))) |
||||
|
||||
;;;###autoload |
||||
(defcustom haskell-process-type |
||||
'auto |
||||
"The inferior Haskell process type to use. |
||||
|
||||
When set to 'auto (the default), the directory contents and |
||||
available programs will be used to make a best guess at the |
||||
process type: |
||||
|
||||
If the project directory or one of its parents contains a |
||||
\"cabal.sandbox.config\" file, then cabal-repl will be used. |
||||
|
||||
If there's a \"stack.yaml\" file and the \"stack\" executable can |
||||
be located, then stack-ghci will be used. |
||||
|
||||
Otherwise if there's a *.cabal file, cabal-repl will be used. |
||||
|
||||
If none of the above apply, ghci will be used." |
||||
:type '(choice (const auto) (const ghci) (const cabal-repl) (const stack-ghci)) |
||||
:group 'haskell-interactive) |
||||
|
||||
;;;###autoload |
||||
(defcustom haskell-process-wrapper-function |
||||
#'identity |
||||
"Wrap or transform haskell process commands using this function. |
||||
|
||||
Can be set to a custom function which takes a list of arguments |
||||
and returns a possibly-modified list. |
||||
|
||||
The following example function arranges for all haskell process |
||||
commands to be started in the current nix-shell environment: |
||||
|
||||
(lambda (argv) (append (list \"nix-shell\" \"-I\" \".\" \"--command\" ) |
||||
(list (mapconcat 'identity argv \" \")))) |
||||
|
||||
See Info Node `(emacs)Directory Variables' for a way to set this option on |
||||
a per-project basis." |
||||
:group 'haskell-interactive |
||||
:type '(choice |
||||
(function-item :tag "None" :value identity) |
||||
(function :tag "Custom function"))) |
||||
|
||||
;;;###autoload |
||||
(defcustom haskell-ask-also-kill-buffers |
||||
t |
||||
"Ask whether to kill all associated buffers when a session |
||||
process is killed." |
||||
:type 'boolean |
||||
:group 'haskell-interactive) |
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
||||
;; Configuration |
||||
|
||||
;;;###autoload |
||||
(defcustom haskell-doc-prettify-types t |
||||
"Replace some parts of types with Unicode characters like \"∷\" |
||||
when showing type information about symbols." |
||||
:group 'haskell-doc |
||||
:type 'boolean |
||||
:safe 'booleanp) |
||||
|
||||
(defvar haskell-process-end-hook nil |
||||
"Hook for when the haskell process ends.") |
||||
|
||||
;;;###autoload |
||||
(defgroup haskell-interactive nil |
||||
"Settings for REPL interaction via `haskell-interactive-mode'" |
||||
:link '(custom-manual "(haskell-mode)haskell-interactive-mode") |
||||
:group 'haskell) |
||||
|
||||
;;;###autoload |
||||
(defcustom haskell-process-path-ghci |
||||
"ghci" |
||||
"The path for starting ghci." |
||||
:group 'haskell-interactive |
||||
:type '(choice string (repeat string))) |
||||
|
||||
;;;###autoload |
||||
(defcustom haskell-process-path-cabal |
||||
"cabal" |
||||
"Path to the `cabal' executable." |
||||
:group 'haskell-interactive |
||||
:type '(choice string (repeat string))) |
||||
|
||||
;;;###autoload |
||||
(defcustom haskell-process-path-stack |
||||
"stack" |
||||
"The path for starting stack." |
||||
:group 'haskell-interactive |
||||
:type '(choice string (repeat string))) |
||||
|
||||
;;;###autoload |
||||
(defcustom haskell-process-args-ghci |
||||
'("-ferror-spans") |
||||
"Any arguments for starting ghci." |
||||
:group 'haskell-interactive |
||||
:type '(repeat (string :tag "Argument"))) |
||||
|
||||
;;;###autoload |
||||
(defcustom haskell-process-args-cabal-repl |
||||
'("--ghc-option=-ferror-spans") |
||||
"Additional arguments for `cabal repl' invocation. |
||||
Note: The settings in `haskell-process-path-ghci' and |
||||
`haskell-process-args-ghci' are not automatically reused as `cabal repl' |
||||
currently invokes `ghc --interactive'. Use |
||||
`--with-ghc=<path-to-executable>' if you want to use a different |
||||
interactive GHC frontend; use `--ghc-option=<ghc-argument>' to |
||||
pass additional flags to `ghc'." |
||||
:group 'haskell-interactive |
||||
:type '(repeat (string :tag "Argument"))) |
||||
|
||||
;;;###autoload |
||||
(defcustom haskell-process-args-stack-ghci |
||||
'("--ghc-options=-ferror-spans") |
||||
"Additional arguments for `stack ghci' invocation." |
||||
:group 'haskell-interactive |
||||
:type '(repeat (string :tag "Argument"))) |
||||
|
||||
;;;###autoload |
||||
(defcustom haskell-process-do-cabal-format-string |
||||
":!cd %s && %s" |
||||
"The way to run cabal comands. It takes two arguments -- the directory and the command. |
||||
See `haskell-process-do-cabal' for more details." |
||||
:group 'haskell-interactive |
||||
:type 'string) |
||||
|
||||
;;;###autoload |
||||
(defcustom haskell-process-log |
||||
nil |
||||
"Enable debug logging to \"*haskell-process-log*\" buffer." |
||||
:type 'boolean |
||||
:group 'haskell-interactive) |
||||
|
||||
;;;###autoload |
||||
(defcustom haskell-process-show-debug-tips |
||||
t |
||||
"Show debugging tips when starting the process." |
||||
:type 'boolean |
||||
:group 'haskell-interactive) |
||||
|
||||
;;;###autoload |
||||
(defcustom haskell-notify-p |
||||
nil |
||||
"Notify using notifications.el (if loaded)?" |
||||
:type 'boolean |
||||
:group 'haskell-interactive) |
||||
|
||||
;;;###autoload |
||||
(defcustom haskell-process-suggest-no-warn-orphans |
||||
t |
||||
"Suggest adding -fno-warn-orphans pragma to file when getting orphan warnings." |
||||
:type 'boolean |
||||
:group 'haskell-interactive) |
||||
|
||||
;;;###autoload |
||||
(defcustom haskell-process-suggest-hoogle-imports |
||||
nil |
||||
"Suggest to add import statements using Hoogle as a backend." |
||||
:type 'boolean |
||||
:group 'haskell-interactive) |
||||
|
||||
;;;###autoload |
||||
(defcustom haskell-process-suggest-hayoo-imports |
||||
nil |
||||
"Suggest to add import statements using Hayoo as a backend." |
||||
:type 'boolean |
||||
:group 'haskell-interactive) |
||||
|
||||
;;;###autoload |
||||
(defcustom haskell-process-hayoo-query-url |
||||
"http://hayoo.fh-wedel.de/json/?query=%s" |
||||
"Query url for json hayoo results." |
||||
:type 'string |
||||
:group 'haskell-interactive) |
||||
|
||||
;;;###autoload |
||||
(defcustom haskell-process-suggest-haskell-docs-imports |
||||
nil |
||||
"Suggest to add import statements using haskell-docs as a backend." |
||||
:type 'boolean |
||||
:group 'haskell-interactive) |
||||
|
||||
;;;###autoload |
||||
(defcustom haskell-process-suggest-add-package |
||||
t |
||||
"Suggest to add packages to your .cabal file when Cabal says it |
||||
is a member of the hidden package, blah blah." |
||||
:type 'boolean |
||||
:group 'haskell-interactive) |
||||
|
||||
;;;###autoload |
||||
(defcustom haskell-process-suggest-language-pragmas |
||||
t |
||||
"Suggest adding LANGUAGE pragmas recommended by GHC." |
||||
:type 'boolean |
||||
:group 'haskell-interactive) |
||||
|
||||
;;;###autoload |
||||
(defcustom haskell-process-suggest-remove-import-lines |
||||
nil |
||||
"Suggest removing import lines as warned by GHC." |
||||
:type 'boolean |
||||
:group 'haskell-interactive) |
||||
|
||||
;;;###autoload |
||||
(defcustom haskell-process-suggest-overloaded-strings |
||||
t |
||||
"Suggest adding OverloadedStrings pragma to file when getting type mismatches with [Char]." |
||||
:type 'boolean |
||||
:group 'haskell-interactive) |
||||
|
||||
;;;###autoload |
||||
(defcustom haskell-process-check-cabal-config-on-load |
||||
t |
||||
"Check changes cabal config on loading Haskell files and |
||||
restart the GHCi process if changed.." |
||||
:type 'boolean |
||||
:group 'haskell-interactive) |
||||
|
||||
;;;###autoload |
||||
(defcustom haskell-process-prompt-restart-on-cabal-change |
||||
t |
||||
"Ask whether to restart the GHCi process when the Cabal file |
||||
has changed?" |
||||
:type 'boolean |
||||
:group 'haskell-interactive) |
||||
|
||||
;;;###autoload |
||||
(defcustom haskell-process-auto-import-loaded-modules |
||||
nil |
||||
"Auto import the modules reported by GHC to have been loaded?" |
||||
:type 'boolean |
||||
:group 'haskell-interactive) |
||||
|
||||
;;;###autoload |
||||
(defcustom haskell-process-reload-with-fbytecode |
||||
nil |
||||
"When using -fobject-code, auto reload with -fbyte-code (and |
||||
then restore the -fobject-code) so that all module info and |
||||
imports become available?" |
||||
:type 'boolean |
||||
:group 'haskell-interactive) |
||||
|
||||
;;;###autoload |
||||
(defcustom haskell-process-use-presentation-mode |
||||
nil |
||||
"Use presentation mode to show things like type info instead of |
||||
printing to the message area." |
||||
:type 'boolean |
||||
:group 'haskell-interactive) |
||||
|
||||
;;;###autoload |
||||
(defcustom haskell-process-suggest-restart |
||||
t |
||||
"Suggest restarting the process when it has died" |
||||
:type 'boolean |
||||
:group 'haskell-interactive) |
||||
|
||||
;;;###autoload |
||||
(defcustom haskell-interactive-mode-scroll-to-bottom |
||||
nil |
||||
"Scroll to bottom in the REPL always." |
||||
:type 'boolean |
||||
:group 'haskell-interactive) |
||||
|
||||
;;;###autoload |
||||
(defcustom haskell-interactive-popup-errors |
||||
t |
||||
"Popup errors in a separate buffer." |
||||
:type 'boolean |
||||
:group 'haskell-interactive) |
||||
|
||||
;;;###autoload |
||||
(defcustom haskell-interactive-mode-collapse |
||||
nil |
||||
"Collapse printed results." |
||||
:type 'boolean |
||||
:group 'haskell-interactive) |
||||
|
||||
;;;###autoload |
||||
(defcustom haskell-interactive-types-for-show-ambiguous |
||||
t |
||||
"Show types when there's no Show instance or there's an |
||||
ambiguous class constraint." |
||||
:type 'boolean |
||||
:group 'haskell-interactive) |
||||
|
||||
(defvar haskell-interactive-prompt "λ> " |
||||
"The prompt to use.") |
||||
|
||||
;;;###autoload |
||||
(defcustom haskell-interactive-mode-eval-mode |
||||
nil |
||||
"Use the given mode's font-locking to render some text." |
||||
:type '(choice function (const :tag "None" nil)) |
||||
:group 'haskell-interactive) |
||||
|
||||
;;;###autoload |
||||
(defcustom haskell-interactive-mode-hide-multi-line-errors |
||||
nil |
||||
"Hide collapsible multi-line compile messages by default." |
||||
:type 'boolean |
||||
:group 'haskell-interactive) |
||||
|
||||
;;;###autoload |
||||
(defcustom haskell-interactive-mode-delete-superseded-errors |
||||
t |
||||
"Whether to delete compile messages superseded by recompile/reloads." |
||||
:type 'boolean |
||||
:group 'haskell-interactive) |
||||
|
||||
;;;###autoload |
||||
(defcustom haskell-interactive-mode-include-file-name |
||||
t |
||||
"Include the file name of the module being compiled when |
||||
printing compilation messages." |
||||
:type 'boolean |
||||
:group 'haskell-interactive) |
||||
|
||||
;;;###autoload |
||||
(defcustom haskell-import-mapping |
||||
'() |
||||
"Support a mapping from module to import lines. |
||||
|
||||
E.g. '((\"Data.Map\" . \"import qualified Data.Map as M |
||||
import Data.Map (Map) |
||||
\")) |
||||
|
||||
This will import |
||||
|
||||
import qualified Data.Map as M |
||||
import Data.Map (Map) |
||||
|
||||
when Data.Map is the candidate. |
||||
|
||||
" |
||||
:type '(repeat (cons (string :tag "Module name") |
||||
(string :tag "Import lines"))) |
||||
:group 'haskell-interactive) |
||||
|
||||
;;;###autoload |
||||
(defcustom haskell-language-extensions |
||||
'() |
||||
"Language extensions in use. Should be in format: -XFoo, |
||||
-XNoFoo etc. The idea is that various tools written with HSE (or |
||||
any haskell-mode code that needs to be aware of syntactical |
||||
properties; such as an indentation mode) that don't know what |
||||
extensions to use can use this variable. Examples: hlint, |
||||
hindent, structured-haskell-mode, tool-de-jour, etc. |
||||
|
||||
You can set this per-project with a .dir-locals.el file, in the |
||||
same vein as `haskell-indent-spaces'." |
||||
:group 'haskell |
||||
:type '(repeat 'string)) |
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
||||
;; Accessor functions |
||||
|
||||
(defun haskell-process-type () |
||||
"Return `haskell-process-type', or a guess if that variable is 'auto." |
||||
(if (eq 'auto haskell-process-type) |
||||
(cond |
||||
;; User has explicitly initialized this project with cabal |
||||
((locate-dominating-file default-directory "cabal.sandbox.config") |
||||
'cabal-repl) |
||||
((and (locate-dominating-file default-directory "stack.yaml") |
||||
(executable-find "stack")) |
||||
'stack-ghci) |
||||
((locate-dominating-file |
||||
default-directory |
||||
(lambda (d) |
||||
(cl-find-if (lambda (f) (string-match-p ".\\.cabal\\'" f)) (directory-files d)))) |
||||
'cabal-repl) |
||||
(t 'ghci)) |
||||
haskell-process-type)) |
||||
|
||||
(provide 'haskell-customize) |
||||
@ -0,0 +1,744 @@
|
||||
;;; haskell-debug.el --- Debugging mode via GHCi -*- lexical-binding: t -*- |
||||
|
||||
;; Copyright (c) 2014 Chris Done. All rights reserved. |
||||
|
||||
;; 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, 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 program. If not, see <http://www.gnu.org/licenses/>. |
||||
|
||||
;;; Code: |
||||
|
||||
(require 'cl-lib) |
||||
(require 'haskell-session) |
||||
(require 'haskell-process) |
||||
(require 'haskell-interactive-mode) |
||||
(require 'haskell-font-lock) |
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
||||
;; Configuration |
||||
|
||||
;;;###autoload |
||||
(defgroup haskell-debug nil |
||||
"Settings for debugging support." |
||||
:link '(custom-manual "(haskell-mode)haskell-debug") |
||||
:group 'haskell) |
||||
|
||||
;;;###autoload |
||||
(defface haskell-debug-warning-face |
||||
'((t :inherit 'compilation-warning)) |
||||
"Face for warnings." |
||||
:group 'haskell-debug) |
||||
|
||||
;;;###autoload |
||||
(defface haskell-debug-trace-number-face |
||||
'((t :weight bold :background "#f5f5f5")) |
||||
"Face for numbers in backtrace." |
||||
:group 'haskell-debug) |
||||
|
||||
;;;###autoload |
||||
(defface haskell-debug-newline-face |
||||
'((t :weight bold :background "#f0f0f0")) |
||||
"Face for newlines in trace steps." |
||||
:group 'haskell-debug) |
||||
|
||||
;;;###autoload |
||||
(defface haskell-debug-keybinding-face |
||||
'((t :inherit 'font-lock-type-face :weight bold)) |
||||
"Face for keybindings." |
||||
:group 'haskell-debug) |
||||
|
||||
;;;###autoload |
||||
(defface haskell-debug-heading-face |
||||
'((t :inherit 'font-lock-keyword-face)) |
||||
"Face for headings." |
||||
:group 'haskell-debug) |
||||
|
||||
;;;###autoload |
||||
(defface haskell-debug-muted-face |
||||
'((t :foreground "#999")) |
||||
"Face for muteds." |
||||
:group 'haskell-debug) |
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
||||
;; Mode |
||||
|
||||
(define-derived-mode haskell-debug-mode |
||||
text-mode "Debug" |
||||
"Major mode for debugging Haskell via GHCi.") |
||||
|
||||
(define-key haskell-debug-mode-map (kbd "g") 'haskell-debug/refresh) |
||||
(define-key haskell-debug-mode-map (kbd "s") 'haskell-debug/step) |
||||
(define-key haskell-debug-mode-map (kbd "t") 'haskell-debug/trace) |
||||
(define-key haskell-debug-mode-map (kbd "d") 'haskell-debug/delete) |
||||
(define-key haskell-debug-mode-map (kbd "b") 'haskell-debug/break-on-function) |
||||
(define-key haskell-debug-mode-map (kbd "a") 'haskell-debug/abandon) |
||||
(define-key haskell-debug-mode-map (kbd "c") 'haskell-debug/continue) |
||||
(define-key haskell-debug-mode-map (kbd "p") 'haskell-debug/previous) |
||||
(define-key haskell-debug-mode-map (kbd "n") 'haskell-debug/next) |
||||
(define-key haskell-debug-mode-map (kbd "RET") 'haskell-debug/select) |
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
||||
;; Globals |
||||
|
||||
(defvar haskell-debug-history-cache nil |
||||
"Cache of the tracing history.") |
||||
|
||||
(defvar haskell-debug-bindings-cache nil |
||||
"Cache of the current step's bindings.") |
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
||||
;; Macros |
||||
|
||||
(defmacro haskell-debug-with-breakpoints (&rest body) |
||||
"Breakpoints need to exist to start stepping." |
||||
`(if (haskell-debug-get-breakpoints) |
||||
,@body |
||||
(error "No breakpoints to step into!"))) |
||||
|
||||
(defmacro haskell-debug-with-modules (&rest body) |
||||
"Modules need to exist to do debugging stuff." |
||||
`(if (haskell-debug-get-modules) |
||||
,@body |
||||
(error "No modules loaded!"))) |
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
||||
;; Interactive functions |
||||
|
||||
(defun haskell-debug/select () |
||||
"Select whatever is at point." |
||||
(interactive) |
||||
(cond |
||||
((get-text-property (point) 'break) |
||||
(let ((break (get-text-property (point) 'break))) |
||||
(haskell-debug-highlight (plist-get break :path) |
||||
(plist-get break :span)))) |
||||
((get-text-property (point) 'module) |
||||
(let ((break (get-text-property (point) 'module))) |
||||
(haskell-debug-highlight (plist-get break :path)))))) |
||||
|
||||
(defun haskell-debug/abandon () |
||||
"Abandon the current computation." |
||||
(interactive) |
||||
(haskell-debug-with-breakpoints |
||||
(haskell-process-queue-sync-request (haskell-debug-process) ":abandon") |
||||
(message "Computation abandoned.") |
||||
(setq haskell-debug-history-cache nil) |
||||
(setq haskell-debug-bindings-cache nil) |
||||
(haskell-debug/refresh))) |
||||
|
||||
(defun haskell-debug/continue () |
||||
"Continue the current computation." |
||||
(interactive) |
||||
(haskell-debug-with-breakpoints |
||||
(haskell-process-queue-sync-request (haskell-debug-process) ":continue") |
||||
(message "Computation continued.") |
||||
(setq haskell-debug-history-cache nil) |
||||
(setq haskell-debug-bindings-cache nil) |
||||
(haskell-debug/refresh))) |
||||
|
||||
(defun haskell-debug/break-on-function () |
||||
"Break on function IDENT." |
||||
(interactive) |
||||
(haskell-debug-with-modules |
||||
(let ((ident (read-from-minibuffer "Function: " |
||||
(haskell-ident-at-point)))) |
||||
(haskell-process-queue-sync-request |
||||
(haskell-debug-process) |
||||
(concat ":break " |
||||
ident)) |
||||
(message "Breaking on function: %s" ident) |
||||
(haskell-debug/refresh)))) |
||||
|
||||
(defun haskell-debug/start-step (expr) |
||||
"Start stepping EXPR." |
||||
(interactive (list (read-from-minibuffer "Expression to step through: "))) |
||||
(haskell-debug/step expr)) |
||||
|
||||
(defun haskell-debug/breakpoint-numbers () |
||||
"List breakpoint numbers." |
||||
(interactive) |
||||
(let ((breakpoints (mapcar (lambda (breakpoint) |
||||
(number-to-string (plist-get breakpoint :number))) |
||||
(haskell-debug-get-breakpoints)))) |
||||
(if (null breakpoints) |
||||
(message "No breakpoints.") |
||||
(message "Breakpoint(s): %s" |
||||
(mapconcat #'identity |
||||
breakpoints |
||||
", "))))) |
||||
|
||||
(defun haskell-debug/next () |
||||
"Go to next step to inspect bindings." |
||||
(interactive) |
||||
(haskell-debug-with-breakpoints |
||||
(haskell-debug-navigate "forward"))) |
||||
|
||||
(defun haskell-debug/previous () |
||||
"Go to previous step to inspect the bindings." |
||||
(interactive) |
||||
(haskell-debug-with-breakpoints |
||||
(haskell-debug-navigate "back"))) |
||||
|
||||
(defun haskell-debug/refresh () |
||||
"Refresh the debugger buffer." |
||||
(interactive) |
||||
(with-current-buffer (haskell-debug-buffer-name (haskell-debug-session)) |
||||
(cd (haskell-session-current-dir (haskell-debug-session))) |
||||
(let ((inhibit-read-only t) |
||||
(p (point))) |
||||
(erase-buffer) |
||||
(insert (propertize (concat "Debugging " |
||||
(haskell-session-name (haskell-debug-session)) |
||||
"\n\n") |
||||
'face `((:weight bold)))) |
||||
(let ((modules (haskell-debug-get-modules)) |
||||
(breakpoints (haskell-debug-get-breakpoints)) |
||||
(context (haskell-debug-get-context)) |
||||
(history (haskell-debug-get-history))) |
||||
(unless modules |
||||
(insert (propertize "You have to load a module to start debugging." |
||||
'face |
||||
'haskell-debug-warning-face) |
||||
"\n\n")) |
||||
(haskell-debug-insert-bindings modules breakpoints context) |
||||
(when modules |
||||
(haskell-debug-insert-current-context context history) |
||||
(haskell-debug-insert-breakpoints breakpoints)) |
||||
(haskell-debug-insert-modules modules)) |
||||
(insert "\n") |
||||
(goto-char (min (point-max) p))))) |
||||
|
||||
(defun haskell-debug/delete () |
||||
"Delete whatever's at the point." |
||||
(interactive) |
||||
(cond |
||||
((get-text-property (point) 'break) |
||||
(let ((break (get-text-property (point) 'break))) |
||||
(when (y-or-n-p (format "Delete breakpoint #%d?" |
||||
(plist-get break :number))) |
||||
(haskell-process-queue-sync-request |
||||
(haskell-debug-process) |
||||
(format ":delete %d" |
||||
(plist-get break :number))) |
||||
(haskell-debug/refresh)))))) |
||||
|
||||
(defun haskell-debug/trace () |
||||
"Trace the expression." |
||||
(interactive) |
||||
(haskell-debug-with-modules |
||||
(haskell-debug-with-breakpoints |
||||
(let ((expr (read-from-minibuffer "Expression to trace: " |
||||
(haskell-ident-at-point)))) |
||||
(haskell-process-queue-sync-request |
||||
(haskell-debug-process) |
||||
(concat ":trace " expr)) |
||||
(message "Tracing expression: %s" expr) |
||||
(haskell-debug/refresh))))) |
||||
|
||||
(defun haskell-debug/step (&optional expr) |
||||
"Step into the next function." |
||||
(interactive) |
||||
(haskell-debug-with-breakpoints |
||||
(let* ((breakpoints (haskell-debug-get-breakpoints)) |
||||
(context (haskell-debug-get-context)) |
||||
(string |
||||
(haskell-process-queue-sync-request |
||||
(haskell-debug-process) |
||||
(if expr |
||||
(concat ":step " expr) |
||||
":step")))) |
||||
(cond |
||||
((string= string "not stopped at a breakpoint\n") |
||||
(if haskell-debug-bindings-cache |
||||
(progn (setq haskell-debug-bindings-cache nil) |
||||
(haskell-debug/refresh)) |
||||
(call-interactively 'haskell-debug/start-step))) |
||||
(t (let ((maybe-stopped-at (haskell-debug-parse-stopped-at string))) |
||||
(cond |
||||
(maybe-stopped-at |
||||
(setq haskell-debug-bindings-cache |
||||
maybe-stopped-at) |
||||
(message "Computation paused.") |
||||
(haskell-debug/refresh)) |
||||
(t |
||||
(if context |
||||
(message "Computation finished.") |
||||
(when (y-or-n-p "Computation completed without breaking. Reload the module and retry?") |
||||
(message "Reloading and resetting breakpoints...") |
||||
(haskell-interactive-mode-reset-error (haskell-debug-session)) |
||||
(cl-loop for break in breakpoints |
||||
do (haskell-process-queue-sync-request |
||||
(haskell-debug-process) |
||||
(concat ":load " (plist-get break :path)))) |
||||
(cl-loop for break in breakpoints |
||||
do (haskell-debug-break break)) |
||||
(haskell-debug/step expr))))))))) |
||||
(haskell-debug/refresh))) |
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
||||
;; Internal functions |
||||
|
||||
(defun haskell-debug-session () |
||||
"Get the Haskell session." |
||||
(or (haskell-session-maybe) |
||||
(error "No Haskell session associated with this debug |
||||
buffer. Please just close the buffer and start again."))) |
||||
|
||||
(defun haskell-debug-process () |
||||
"Get the Haskell session." |
||||
(or (haskell-session-process (haskell-session-maybe)) |
||||
(error "No Haskell session associated with this debug |
||||
buffer. Please just close the buffer and start again."))) |
||||
|
||||
(defun haskell-debug-buffer-name (session) |
||||
"The debug buffer name for the current session." |
||||
(format "*debug:%s*" |
||||
(haskell-session-name session))) |
||||
|
||||
(defun haskell-debug-get-breakpoints () |
||||
"Get the list of breakpoints currently set." |
||||
(let ((string (haskell-process-queue-sync-request |
||||
(haskell-debug-process) |
||||
":show breaks"))) |
||||
(if (string= string "No active breakpoints.\n") |
||||
(list) |
||||
(mapcar #'haskell-debug-parse-break-point |
||||
(haskell-debug-split-string string))))) |
||||
|
||||
(defun haskell-debug-get-modules () |
||||
"Get the list of modules currently set." |
||||
(let ((string (haskell-process-queue-sync-request |
||||
(haskell-debug-process) |
||||
":show modules"))) |
||||
(if (string= string "") |
||||
(list) |
||||
(mapcar #'haskell-debug-parse-module |
||||
(haskell-debug-split-string string))))) |
||||
|
||||
(defun haskell-debug-get-context () |
||||
"Get the current context." |
||||
(let ((string (haskell-process-queue-sync-request |
||||
(haskell-debug-process) |
||||
":show context"))) |
||||
(if (string= string "") |
||||
nil |
||||
(haskell-debug-parse-context string)))) |
||||
|
||||
(defun haskell-debug-get-history () |
||||
"Get the step history." |
||||
(let ((string (haskell-process-queue-sync-request |
||||
(haskell-debug-process) |
||||
":history"))) |
||||
(if (or (string= string "") |
||||
(string= string "Not stopped at a breakpoint\n")) |
||||
nil |
||||
(if (string= string "Empty history. Perhaps you forgot to use :trace?\n") |
||||
nil |
||||
(let ((entries (mapcar #'haskell-debug-parse-history-entry |
||||
(cl-remove-if (lambda (line) (or (string= "<end of history>" line) |
||||
(string= "..." line))) |
||||
(haskell-debug-split-string string))))) |
||||
(setq haskell-debug-history-cache |
||||
entries) |
||||
entries))))) |
||||
|
||||
(defun haskell-debug-insert-bindings (modules breakpoints context) |
||||
"Insert a list of bindings." |
||||
(if breakpoints |
||||
(progn (haskell-debug-insert-binding "t" "trace an expression") |
||||
(haskell-debug-insert-binding "s" "step into an expression") |
||||
(haskell-debug-insert-binding "b" "breakpoint" t)) |
||||
(progn |
||||
(when modules |
||||
(haskell-debug-insert-binding "b" "breakpoint")) |
||||
(when breakpoints |
||||
(haskell-debug-insert-binding "s" "step into an expression" t)))) |
||||
(when breakpoints |
||||
(haskell-debug-insert-binding "d" "delete breakpoint")) |
||||
(when context |
||||
(haskell-debug-insert-binding "a" "abandon context") |
||||
(haskell-debug-insert-binding "c" "continue" t)) |
||||
(when context |
||||
(haskell-debug-insert-binding "p" "previous step") |
||||
(haskell-debug-insert-binding "n" "next step" t)) |
||||
(haskell-debug-insert-binding "g" "refresh" t) |
||||
(insert "\n")) |
||||
|
||||
(defun haskell-debug-insert-current-context (context history) |
||||
"Insert the current context." |
||||
(haskell-debug-insert-header "Context") |
||||
(if context |
||||
(haskell-debug-insert-context context history) |
||||
(haskell-debug-insert-debug-finished)) |
||||
(insert "\n")) |
||||
|
||||
(defun haskell-debug-insert-breakpoints (breakpoints) |
||||
"insert the list of breakpoints." |
||||
(haskell-debug-insert-header "Breakpoints") |
||||
(if (null breakpoints) |
||||
(haskell-debug-insert-muted "No active breakpoints.") |
||||
(cl-loop for break in breakpoints |
||||
do (insert (propertize (format "%d" |
||||
(plist-get break :number)) |
||||
'face `((:weight bold)) |
||||
'break break) |
||||
(haskell-debug-muted " - ") |
||||
(propertize (plist-get break :module) |
||||
'break break |
||||
'break break) |
||||
(haskell-debug-muted |
||||
(format " (%d:%d)" |
||||
(plist-get (plist-get break :span) :start-line) |
||||
(plist-get (plist-get break :span) :start-col))) |
||||
"\n"))) |
||||
(insert "\n")) |
||||
|
||||
(defun haskell-debug-insert-modules (modules) |
||||
"Insert the list of modules." |
||||
(haskell-debug-insert-header "Modules") |
||||
(if (null modules) |
||||
(haskell-debug-insert-muted "No loaded modules.") |
||||
(progn (cl-loop for module in modules |
||||
do (insert (propertize (plist-get module :module) |
||||
'module module |
||||
'face `((:weight bold))) |
||||
(haskell-debug-muted " - ") |
||||
(propertize (file-name-nondirectory (plist-get module :path)) |
||||
'module module)) |
||||
do (insert "\n"))))) |
||||
|
||||
(defun haskell-debug-split-string (string) |
||||
"Split GHCi's line-based output, stripping the trailing newline." |
||||
(split-string string "\n" t)) |
||||
|
||||
(defun haskell-debug-parse-context (string) |
||||
"Parse the context." |
||||
(cond |
||||
((string-match "^--> \\(.+\\)\n \\(.+\\)" string) |
||||
(let ((name (match-string 1 string)) |
||||
(stopped (haskell-debug-parse-stopped-at (match-string 2 string)))) |
||||
(list :name name |
||||
:path (plist-get stopped :path) |
||||
:span (plist-get stopped :span)))))) |
||||
|
||||
(defun haskell-debug-insert-binding (binding desc &optional end) |
||||
"Insert a helpful keybinding." |
||||
(insert (propertize binding 'face 'haskell-debug-keybinding-face) |
||||
(haskell-debug-muted " - ") |
||||
desc |
||||
(if end |
||||
"\n" |
||||
(haskell-debug-muted ", ")))) |
||||
|
||||
(defun haskell-debug-insert-header (title) |
||||
"Insert a header title." |
||||
(insert (propertize title |
||||
'face 'haskell-debug-heading-face) |
||||
"\n\n")) |
||||
|
||||
(defun haskell-debug-insert-context (context history) |
||||
"Insert the context and history." |
||||
(when context |
||||
(insert (propertize (plist-get context :name) 'face `((:weight bold))) |
||||
(haskell-debug-muted " - ") |
||||
(file-name-nondirectory (plist-get context :path)) |
||||
(haskell-debug-muted " (stopped)") |
||||
"\n")) |
||||
(when haskell-debug-bindings-cache |
||||
(insert "\n") |
||||
(let ((bindings haskell-debug-bindings-cache)) |
||||
(insert |
||||
(haskell-debug-get-span-string |
||||
(plist-get bindings :path) |
||||
(plist-get bindings :span))) |
||||
(insert "\n\n") |
||||
(cl-loop for binding in (plist-get bindings :types) |
||||
do (insert (haskell-fontify-as-mode binding 'haskell-mode) |
||||
"\n")))) |
||||
(let ((history (or history |
||||
(list (haskell-debug-make-fake-history context))))) |
||||
(when history |
||||
(insert "\n") |
||||
(haskell-debug-insert-history history)))) |
||||
|
||||
(defun haskell-debug-insert-debug-finished () |
||||
"Insert message that no debugging is happening, but if there is |
||||
some old history, then display that." |
||||
(if haskell-debug-history-cache |
||||
(progn (haskell-debug-insert-muted "Finished debugging.") |
||||
(insert "\n") |
||||
(haskell-debug-insert-history haskell-debug-history-cache)) |
||||
(haskell-debug-insert-muted "Not debugging right now."))) |
||||
|
||||
(defun haskell-debug-insert-muted (text) |
||||
"Insert some muted text." |
||||
(insert (haskell-debug-muted text) |
||||
"\n")) |
||||
|
||||
(defun haskell-debug-muted (text) |
||||
"Make some muted text." |
||||
(propertize text 'face 'haskell-debug-muted-face)) |
||||
|
||||
(defun haskell-debug-parse-logged (string) |
||||
"Parse the logged breakpoint." |
||||
(cond |
||||
((string= "no more logged breakpoints\n" string) |
||||
nil) |
||||
((string= "already at the beginning of the history\n" string) |
||||
nil) |
||||
(t |
||||
(with-temp-buffer |
||||
(insert string) |
||||
(goto-char (point-min)) |
||||
(list :path (progn (search-forward " at ") |
||||
(buffer-substring-no-properties |
||||
(point) |
||||
(1- (search-forward ":")))) |
||||
:span (haskell-debug-parse-span |
||||
(buffer-substring-no-properties |
||||
(point) |
||||
(line-end-position))) |
||||
:types (progn (forward-line) |
||||
(haskell-debug-split-string |
||||
(buffer-substring-no-properties |
||||
(point) |
||||
(point-max))))))))) |
||||
|
||||
(defun haskell-debug-parse-stopped-at (string) |
||||
"Parse the location stopped at from the given string. |
||||
|
||||
For example: |
||||
|
||||
Stopped at /home/foo/project/src/x.hs:6:25-36 |
||||
|
||||
" |
||||
(let ((index (string-match "Stopped at \\([^:]+\\):\\(.+\\)\n?" |
||||
string))) |
||||
(when index |
||||
(list :path (match-string 1 string) |
||||
:span (haskell-debug-parse-span (match-string 2 string)) |
||||
:types (cdr (haskell-debug-split-string (substring string index))))))) |
||||
|
||||
(defun haskell-debug-get-span-string (path span) |
||||
"Get the string from the PATH and the SPAN." |
||||
(save-window-excursion |
||||
(find-file path) |
||||
(buffer-substring |
||||
(save-excursion |
||||
(goto-char (point-min)) |
||||
(forward-line (1- (plist-get span :start-line))) |
||||
(forward-char (1- (plist-get span :start-col))) |
||||
(point)) |
||||
(save-excursion |
||||
(goto-char (point-min)) |
||||
(forward-line (1- (plist-get span :end-line))) |
||||
(forward-char (plist-get span :end-col)) |
||||
(point))))) |
||||
|
||||
(defun haskell-debug-make-fake-history (context) |
||||
"Make a fake history item." |
||||
(list :index -1 |
||||
:path (plist-get context :path) |
||||
:span (plist-get context :span))) |
||||
|
||||
(defun haskell-debug-insert-history (history) |
||||
"Insert tracing HISTORY." |
||||
(let ((i (length history))) |
||||
(cl-loop for span in history |
||||
do (let ((string (haskell-debug-get-span-string |
||||
(plist-get span :path) |
||||
(plist-get span :span)))) |
||||
(insert (propertize (format "%4d" i) |
||||
'face 'haskell-debug-trace-number-face) |
||||
" " |
||||
(haskell-debug-preview-span |
||||
(plist-get span :span) |
||||
string |
||||
t) |
||||
"\n") |
||||
(setq i (1- i)))))) |
||||
|
||||
(defun haskell-debug-parse-span (string) |
||||
"Parse a source span from a string. |
||||
|
||||
Examples: |
||||
|
||||
(5,1)-(6,37) |
||||
6:25-36 |
||||
5:20 |
||||
|
||||
People like to make other people's lives interesting by making |
||||
variances in source span notation." |
||||
(cond |
||||
((string-match "\\([0-9]+\\):\\([0-9]+\\)-\\([0-9]+\\)" |
||||
string) |
||||
(list :start-line (string-to-number (match-string 1 string)) |
||||
:start-col (string-to-number (match-string 2 string)) |
||||
:end-line (string-to-number (match-string 1 string)) |
||||
:end-col (string-to-number (match-string 3 string)))) |
||||
((string-match "\\([0-9]+\\):\\([0-9]+\\)" |
||||
string) |
||||
(list :start-line (string-to-number (match-string 1 string)) |
||||
:start-col (string-to-number (match-string 2 string)) |
||||
:end-line (string-to-number (match-string 1 string)) |
||||
:end-col (string-to-number (match-string 2 string)))) |
||||
((string-match "(\\([0-9]+\\),\\([0-9]+\\))-(\\([0-9]+\\),\\([0-9]+\\))" |
||||
string) |
||||
(list :start-line (string-to-number (match-string 1 string)) |
||||
:start-col (string-to-number (match-string 2 string)) |
||||
:end-line (string-to-number (match-string 3 string)) |
||||
:end-col (string-to-number (match-string 4 string)))) |
||||
(t (error "Unable to parse source span from string: %s" |
||||
string)))) |
||||
|
||||
(defun haskell-debug-preview-span (span string &optional collapsed) |
||||
"Make a one-line preview of the given expression." |
||||
(with-temp-buffer |
||||
(haskell-mode) |
||||
(insert string) |
||||
(when (/= 0 (plist-get span :start-col)) |
||||
(indent-rigidly (point-min) |
||||
(point-max) |
||||
1)) |
||||
(if (fboundp 'font-lock-ensure) |
||||
(font-lock-ensure) |
||||
(with-no-warnings (font-lock-fontify-buffer))) |
||||
(when (/= 0 (plist-get span :start-col)) |
||||
(indent-rigidly (point-min) |
||||
(point-max) |
||||
-1)) |
||||
(goto-char (point-min)) |
||||
(if collapsed |
||||
(replace-regexp-in-string |
||||
"\n[ ]*" |
||||
(propertize " " 'face 'haskell-debug-newline-face) |
||||
(buffer-substring (point-min) |
||||
(point-max))) |
||||
(buffer-string)))) |
||||
|
||||
(defun haskell-debug-start (session) |
||||
"Start the debug mode." |
||||
(setq buffer-read-only t) |
||||
(haskell-session-assign session) |
||||
(haskell-debug/refresh)) |
||||
|
||||
(defun haskell-debug () |
||||
"Start the debugger for the current Haskell (GHCi) session." |
||||
(interactive) |
||||
(let ((session (haskell-debug-session))) |
||||
(switch-to-buffer-other-window (haskell-debug-buffer-name session)) |
||||
(unless (eq major-mode 'haskell-debug-mode) |
||||
(haskell-debug-mode) |
||||
(haskell-debug-start session)))) |
||||
|
||||
(defun haskell-debug-break (break) |
||||
"Set BREAK breakpoint in module at line/col." |
||||
(haskell-process-queue-without-filters |
||||
(haskell-debug-process) |
||||
(format ":break %s %s %d" |
||||
(plist-get break :module) |
||||
(plist-get (plist-get break :span) :start-line) |
||||
(plist-get (plist-get break :span) :start-col)))) |
||||
|
||||
(defun haskell-debug-navigate (direction) |
||||
"Navigate in DIRECTION \"back\" or \"forward\"." |
||||
(let ((string (haskell-process-queue-sync-request |
||||
(haskell-debug-process) |
||||
(concat ":" direction)))) |
||||
(let ((bindings (haskell-debug-parse-logged string))) |
||||
(setq haskell-debug-bindings-cache |
||||
bindings) |
||||
(when (not bindings) |
||||
(message "No more %s results!" direction))) |
||||
(haskell-debug/refresh))) |
||||
|
||||
(defun haskell-debug-session-debugging-p (session) |
||||
"Does the session have a debugging buffer open?" |
||||
(not (not (get-buffer (haskell-debug-buffer-name session))))) |
||||
|
||||
(defun haskell-debug-highlight (path &optional span) |
||||
"Highlight the file at span." |
||||
(let ((p (make-overlay |
||||
(line-beginning-position) |
||||
(line-end-position)))) |
||||
(overlay-put p 'face `((:background "#eee"))) |
||||
(with-current-buffer |
||||
(if span |
||||
(save-window-excursion |
||||
(find-file path) |
||||
(current-buffer)) |
||||
(find-file path) |
||||
(current-buffer)) |
||||
(let ((o (when span |
||||
(make-overlay |
||||
(save-excursion |
||||
(goto-char (point-min)) |
||||
(forward-line (1- (plist-get span :start-line))) |
||||
(forward-char (1- (plist-get span :start-col))) |
||||
(point)) |
||||
(save-excursion |
||||
(goto-char (point-min)) |
||||
(forward-line (1- (plist-get span :end-line))) |
||||
(forward-char (plist-get span :end-col)) |
||||
(point)))))) |
||||
(when o |
||||
(overlay-put o 'face `((:background "#eee")))) |
||||
(sit-for 0.5) |
||||
(when o |
||||
(delete-overlay o)) |
||||
(delete-overlay p))))) |
||||
|
||||
(defun haskell-debug-parse-history-entry (string) |
||||
"Parse a history entry." |
||||
(if (string-match "^\\([-0-9]+\\)[ ]+:[ ]+\\([A-Za-z0-9_':]+\\)[ ]+(\\([^:]+\\):\\(.+?\\))$" |
||||
string) |
||||
(list :index (string-to-number (match-string 1 string)) |
||||
:name (match-string 2 string) |
||||
:path (match-string 3 string) |
||||
:span (haskell-debug-parse-span (match-string 4 string))) |
||||
(error "Unable to parse history entry: %s" string))) |
||||
|
||||
(defun haskell-debug-parse-module (string) |
||||
"Parse a module and path. |
||||
|
||||
For example: |
||||
|
||||
X ( /home/foo/X.hs, interpreted ) |
||||
|
||||
" |
||||
(if (string-match "^\\([^ ]+\\)[ ]+( \\([^ ]+?\\), [a-z]+ )$" |
||||
string) |
||||
(list :module (match-string 1 string) |
||||
:path (match-string 2 string)) |
||||
(error "Unable to parse module from string: %s" |
||||
string))) |
||||
|
||||
(defun haskell-debug-parse-break-point (string) |
||||
"Parse a breakpoint number, module and location from a string. |
||||
|
||||
For example: |
||||
|
||||
[13] Main /home/foo/src/x.hs:(5,1)-(6,37) |
||||
|
||||
" |
||||
(if (string-match "^\\[\\([0-9]+\\)\\] \\([^ ]+\\) \\([^:]+\\):\\(.+\\)$" |
||||
string) |
||||
(list :number (string-to-number (match-string 1 string)) |
||||
:module (match-string 2 string) |
||||
:path (match-string 3 string) |
||||
:span (haskell-debug-parse-span (match-string 4 string))) |
||||
(error "Unable to parse breakpoint from string: %s" |
||||
string))) |
||||
|
||||
(provide 'haskell-debug) |
||||
|
||||
;;; haskell-debug.el ends here |
||||
@ -0,0 +1,619 @@
|
||||
;;; haskell-decl-scan.el --- Declaration scanning module for Haskell Mode -*- lexical-binding: t -*- |
||||
|
||||
;; Copyright (C) 2004, 2005, 2007, 2009 Free Software Foundation, Inc. |
||||
;; Copyright (C) 1997-1998 Graeme E Moss |
||||
|
||||
;; Author: 1997-1998 Graeme E Moss <gem@cs.york.ac.uk> |
||||
;; Maintainer: Stefan Monnier <monnier@gnu.org> |
||||
;; Keywords: declarations menu files Haskell |
||||
;; URL: http://cvs.haskell.org/cgi-bin/cvsweb.cgi/fptools/CONTRIB/haskell-modes/emacs/haskell-decl-scan.el?rev=HEAD |
||||
|
||||
;; 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, 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 program. If not, see <http://www.gnu.org/licenses/>. |
||||
|
||||
;;; Commentary: |
||||
|
||||
;; Purpose: |
||||
;; |
||||
;; Top-level declarations are scanned and placed in a menu. Supports |
||||
;; full Latin1 Haskell 1.4 as well as literate scripts. |
||||
;; |
||||
;; |
||||
;; Installation: |
||||
;; |
||||
;; To turn declaration scanning on for all Haskell buffers under the |
||||
;; Haskell mode of Moss&Thorn, add this to .emacs: |
||||
;; |
||||
;; (add-hook 'haskell-mode-hook 'haskell-decl-scan-mode) |
||||
;; |
||||
;; Otherwise, call `haskell-decl-scan-mode'. |
||||
;; |
||||
;; |
||||
;; Customisation: |
||||
;; |
||||
;; M-x customize-group haskell-decl-scan |
||||
;; |
||||
;; |
||||
;; History: |
||||
;; |
||||
;; If you have any problems or suggestions, after consulting the list |
||||
;; below, email gem@cs.york.ac.uk quoting the version of the library |
||||
;; you are using, the version of Emacs you are using, and a small |
||||
;; example of the problem or suggestion. Note that this library |
||||
;; requires a reasonably recent version of Emacs. |
||||
;; |
||||
;; Uses `imenu' under Emacs. |
||||
;; |
||||
;; Version 1.2: |
||||
;; Added support for LaTeX-style literate scripts. |
||||
;; |
||||
;; Version 1.1: |
||||
;; Use own syntax table. Fixed bug for very small buffers. Use |
||||
;; markers instead of pointers (markers move with the text). |
||||
;; |
||||
;; Version 1.0: |
||||
;; Brought over from Haskell mode v1.1. |
||||
;; |
||||
;; |
||||
;; Present Limitations/Future Work (contributions are most welcome!): |
||||
;; |
||||
;; . Declarations requiring information extending beyond starting line |
||||
;; don't get scanned properly, eg. |
||||
;; > class Eq a => |
||||
;; > Test a |
||||
;; |
||||
;; . Comments placed in the midst of the first few lexemes of a |
||||
;; declaration will cause havoc, eg. |
||||
;; > infixWithComments :: Int -> Int -> Int |
||||
;; > x {-nastyComment-} `infixWithComments` y = x + y |
||||
;; but are not worth worrying about. |
||||
;; |
||||
;; . Would be nice to scan other top-level declarations such as |
||||
;; methods of a class, datatype field labels... any more? |
||||
;; |
||||
;; . Support for GreenCard? |
||||
;; |
||||
;; . Re-running (literate-)haskell-imenu should not cause the problems |
||||
;; that it does. The ability to turn off scanning would also be |
||||
;; useful. (Note that re-running (literate-)haskell-mode seems to |
||||
;; cause no problems.) |
||||
|
||||
;; All functions/variables start with |
||||
;; `(turn-(on/off)-)haskell-decl-scan' or `haskell-ds-'. |
||||
|
||||
;; The imenu support is based on code taken from `hugs-mode', |
||||
;; thanks go to Chris Van Humbeeck. |
||||
|
||||
;; Version. |
||||
|
||||
;;; Code: |
||||
|
||||
(require 'cl-lib) |
||||
(require 'haskell-mode) |
||||
(require 'syntax) |
||||
(require 'imenu) |
||||
|
||||
;;;###autoload |
||||
(defgroup haskell-decl-scan nil |
||||
"Haskell declaration scanning (`imenu' support)." |
||||
:link '(custom-manual "(haskell-mode)haskell-decl-scan-mode") |
||||
:group 'haskell |
||||
:prefix "haskell-decl-scan-") |
||||
|
||||
;;;###autoload |
||||
(defcustom haskell-decl-scan-bindings-as-variables nil |
||||
"Whether to put top-level value bindings into a \"Variables\" category." |
||||
:group 'haskell-decl-scan |
||||
:type 'boolean) |
||||
|
||||
;;;###autoload |
||||
(defcustom haskell-decl-scan-add-to-menubar t |
||||
"Whether to add a \"Declarations\" menu entry to menu bar." |
||||
:group 'haskell-decl-scan |
||||
:type 'boolean) |
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
||||
;; General declaration scanning functions. |
||||
|
||||
(defvar haskell-ds-start-keywords-re |
||||
(concat "\\(\\<" |
||||
"class\\|data\\|i\\(mport\\|n\\(fix\\(\\|[lr]\\)\\|stance\\)\\)\\|" |
||||
"module\\|primitive\\|type\\|newtype" |
||||
"\\)\\>") |
||||
"Keywords that may start a declaration.") |
||||
|
||||
(defvar haskell-ds-syntax-table |
||||
(let ((table (copy-syntax-table haskell-mode-syntax-table))) |
||||
(modify-syntax-entry ?\' "w" table) |
||||
(modify-syntax-entry ?_ "w" table) |
||||
(modify-syntax-entry ?\\ "_" table) |
||||
table) |
||||
"Syntax table used for Haskell declaration scanning.") |
||||
|
||||
|
||||
(defun haskell-ds-get-variable (prefix) |
||||
"Return variable involved in value binding or type signature. |
||||
Assumes point is looking at the regexp PREFIX followed by the |
||||
start of a declaration (perhaps in the middle of a series of |
||||
declarations concerning a single variable). Otherwise return nil. |
||||
Point is not changed." |
||||
;; I think I can now handle all declarations bar those with comments |
||||
;; nested before the second lexeme. |
||||
(save-excursion |
||||
(with-syntax-table haskell-ds-syntax-table |
||||
(if (looking-at prefix) (goto-char (match-end 0))) |
||||
;; Keyword. |
||||
(if (looking-at haskell-ds-start-keywords-re) |
||||
nil |
||||
(or ;; Parenthesized symbolic variable. |
||||
(and (looking-at "(\\(\\s_+\\))") (match-string-no-properties 1)) |
||||
;; General case. |
||||
(if (looking-at |
||||
(if (eq ?\( (char-after)) |
||||
;; Skip paranthesised expression. |
||||
(progn |
||||
(forward-sexp) |
||||
;; Repeating this code and avoiding moving point if |
||||
;; possible speeds things up. |
||||
"\\(\\'\\)?\\s-*\\(\\s_+\\|`\\(\\sw+\\)`\\)") |
||||
"\\(\\sw+\\)?\\s-*\\(\\s_+\\|`\\(\\sw+\\)`\\)")) |
||||
(let ((match2 (match-string-no-properties 2))) |
||||
;; Weed out `::', `∷',`=' and `|' from potential infix |
||||
;; symbolic variable. |
||||
(if (member match2 '("::" "∷" "=" "|")) |
||||
;; Variable identifier. |
||||
(match-string-no-properties 1) |
||||
(if (eq (aref match2 0) ?\`) |
||||
;; Infix variable identifier. |
||||
(match-string-no-properties 3) |
||||
;; Infix symbolic variable. |
||||
match2)))) |
||||
;; Variable identifier. |
||||
(and (looking-at "\\sw+") (match-string-no-properties 0))))))) |
||||
|
||||
(defun haskell-ds-move-to-start-regexp (inc regexp) |
||||
"Move to beginning of line that succeeds/precedes (INC = 1/-1) |
||||
current line that starts with REGEXP and is not in `font-lock-comment-face'." |
||||
;; Making this defsubst instead of defun appears to have little or |
||||
;; no effect on efficiency. It is probably not called enough to do |
||||
;; so. |
||||
(while (and (= (forward-line inc) 0) |
||||
(or (not (looking-at regexp)) |
||||
(eq (get-text-property (point) 'face) |
||||
'font-lock-comment-face))))) |
||||
|
||||
(defun haskell-ds-move-to-start-regexp-skipping-comments (inc regexp) |
||||
"Like haskell-ds-move-to-start-regexp, but uses syntax-ppss to |
||||
skip comments" |
||||
(let (p) |
||||
(cl-loop |
||||
do (setq p (point)) |
||||
(haskell-ds-move-to-start-regexp inc regexp) |
||||
while (and (nth 4 (syntax-ppss)) |
||||
(/= p (point)))))) |
||||
|
||||
(defvar literate-haskell-ds-line-prefix "> ?" |
||||
"Regexp matching start of a line of Bird-style literate code. |
||||
Current value is \"> \" as we assume top-level declarations start |
||||
at column 3. Must not contain the special \"^\" regexp as we may |
||||
not use the regexp at the start of a regexp string. Note this is |
||||
only for `imenu' support.") |
||||
|
||||
(defvar haskell-ds-start-decl-re "\\(\\sw\\|(\\)" |
||||
"The regexp that starts a Haskell declaration.") |
||||
|
||||
(defvar literate-haskell-ds-start-decl-re |
||||
(concat literate-haskell-ds-line-prefix haskell-ds-start-decl-re) |
||||
"The regexp that starts a Bird-style literate Haskell declaration.") |
||||
|
||||
(defun haskell-ds-move-to-decl (direction bird-literate fix) |
||||
"General function for moving to the start of a declaration, |
||||
either forwards or backwards from point, with normal or with Bird-style |
||||
literate scripts. If DIRECTION is t, then forward, else backward. If |
||||
BIRD-LITERATE is t, then treat as Bird-style literate scripts, else |
||||
normal scripts. Returns point if point is left at the start of a |
||||
declaration, and nil otherwise, ie. because point is at the beginning |
||||
or end of the buffer and no declaration starts there. If FIX is t, |
||||
then point does not move if already at the start of a declaration." |
||||
;; As `haskell-ds-get-variable' cannot separate an infix variable |
||||
;; identifier out of a value binding with non-alphanumeric first |
||||
;; argument, this function will treat such value bindings as |
||||
;; separate from the declarations surrounding it. |
||||
(let ( ;; The variable typed or bound in the current series of |
||||
;; declarations. |
||||
name |
||||
;; The variable typed or bound in the new declaration. |
||||
newname |
||||
;; Hack to solve hard problem for Bird-style literate scripts |
||||
;; that start with a declaration. We are in the abyss if |
||||
;; point is before start of this declaration. |
||||
abyss |
||||
(line-prefix (if bird-literate literate-haskell-ds-line-prefix "")) |
||||
;; The regexp to match for the start of a declaration. |
||||
(start-decl-re (if bird-literate |
||||
literate-haskell-ds-start-decl-re |
||||
haskell-ds-start-decl-re)) |
||||
(increment (if direction 1 -1)) |
||||
(bound (if direction (point-max) (point-min)))) |
||||
;; Change syntax table. |
||||
(with-syntax-table haskell-ds-syntax-table |
||||
;; move to beginning of line that starts the "current |
||||
;; declaration" (dependent on DIRECTION and FIX), and then get |
||||
;; the variable typed or bound by this declaration, if any. |
||||
(let ( ;; Where point was at call of function. |
||||
(here (point)) |
||||
;; Where the declaration on this line (if any) starts. |
||||
(start (progn |
||||
(beginning-of-line) |
||||
;; Checking the face to ensure a declaration starts |
||||
;; here seems to be the only addition to make this |
||||
;; module support LaTeX-style literate scripts. |
||||
(if (and (looking-at start-decl-re) |
||||
(not (elt (syntax-ppss) 4))) |
||||
(match-beginning 1))))) |
||||
(if (and start |
||||
;; This complicated boolean determines whether we |
||||
;; should include the declaration that starts on the |
||||
;; current line as the "current declaration" or not. |
||||
(or (and (or (and direction (not fix)) |
||||
(and (not direction) fix)) |
||||
(>= here start)) |
||||
(and (or (and direction fix) |
||||
(and (not direction) (not fix))) |
||||
(> here start)))) |
||||
;; If so, we are already at start of the current line, so |
||||
;; do nothing. |
||||
() |
||||
;; If point was before start of a declaration on the first |
||||
;; line of the buffer (possible for Bird-style literate |
||||
;; scripts) then we are in the abyss. |
||||
(if (and start (bobp)) |
||||
(setq abyss t) |
||||
;; Otherwise we move to the start of the first declaration |
||||
;; on a line preceding the current one, skipping comments |
||||
(haskell-ds-move-to-start-regexp-skipping-comments -1 start-decl-re)))) |
||||
;; If we are in the abyss, position and return as appropriate. |
||||
(if abyss |
||||
(if (not direction) |
||||
nil |
||||
(re-search-forward (concat "\\=" line-prefix) nil t) |
||||
(point)) |
||||
;; Get the variable typed or bound by this declaration, if any. |
||||
(setq name (haskell-ds-get-variable line-prefix)) |
||||
(if (not name) |
||||
;; If no such variable, stop at the start of this |
||||
;; declaration if moving backward, or move to the next |
||||
;; declaration if moving forward. |
||||
(if direction |
||||
(haskell-ds-move-to-start-regexp-skipping-comments 1 start-decl-re)) |
||||
;; If there is a variable, find the first |
||||
;; succeeding/preceding declaration that does not type or |
||||
;; bind it. Check for reaching start/end of buffer and |
||||
;; comments. |
||||
(haskell-ds-move-to-start-regexp-skipping-comments increment start-decl-re) |
||||
(while (and (/= (point) bound) |
||||
(and (setq newname (haskell-ds-get-variable line-prefix)) |
||||
(string= name newname))) |
||||
(setq name newname) |
||||
(haskell-ds-move-to-start-regexp-skipping-comments increment start-decl-re)) |
||||
;; If we are going backward, and have either reached a new |
||||
;; declaration or the beginning of a buffer that does not |
||||
;; start with a declaration, move forward to start of next |
||||
;; declaration (which must exist). Otherwise, we are done. |
||||
(if (and (not direction) |
||||
(or (and (looking-at start-decl-re) |
||||
(not (string= name |
||||
;; Note we must not use |
||||
;; newname here as this may |
||||
;; not have been set if we |
||||
;; have reached the beginning |
||||
;; of the buffer. |
||||
(haskell-ds-get-variable |
||||
line-prefix)))) |
||||
(and (not (looking-at start-decl-re)) |
||||
(bobp)))) |
||||
(haskell-ds-move-to-start-regexp-skipping-comments 1 start-decl-re))) |
||||
;; Store whether we are at the start of a declaration or not. |
||||
;; Used to calculate final result. |
||||
(let ((at-start-decl (looking-at start-decl-re))) |
||||
;; If we are at the beginning of a line, move over |
||||
;; line-prefix, if present at point. |
||||
(if (bolp) |
||||
(re-search-forward (concat "\\=" line-prefix) (point-max) t)) |
||||
;; Return point if at the start of a declaration and nil |
||||
;; otherwise. |
||||
(if at-start-decl (point) nil)))))) |
||||
|
||||
(defun haskell-ds-bird-p () |
||||
(and (boundp 'haskell-literate) (eq haskell-literate 'bird))) |
||||
|
||||
(defun haskell-ds-backward-decl () |
||||
"Move backward to the first character that starts a top-level declaration. |
||||
A series of declarations concerning one variable is treated as one |
||||
declaration by this function. So, if point is within a top-level |
||||
declaration then move it to the start of that declaration. If point |
||||
is already at the start of a top-level declaration, then move it to |
||||
the start of the preceding declaration. Returns point if point is |
||||
left at the start of a declaration, and nil otherwise, ie. because |
||||
point is at the beginning of the buffer and no declaration starts |
||||
there." |
||||
(interactive) |
||||
(haskell-ds-move-to-decl nil (haskell-ds-bird-p) nil)) |
||||
|
||||
(defun haskell-ds-forward-decl () |
||||
"As `haskell-ds-backward-decl' but forward." |
||||
(interactive) |
||||
(haskell-ds-move-to-decl t (haskell-ds-bird-p) nil)) |
||||
|
||||
(defun haskell-ds-generic-find-next-decl (bird-literate) |
||||
"Find the name, position and type of the declaration at or after point. |
||||
Return ((NAME . (START-POSITION . NAME-POSITION)) . TYPE) |
||||
if one exists and nil otherwise. The start-position is at the start |
||||
of the declaration, and the name-position is at the start of the name |
||||
of the declaration. The name is a string, the positions are buffer |
||||
positions and the type is one of the symbols \"variable\", \"datatype\", |
||||
\"class\", \"import\" and \"instance\"." |
||||
(let ( ;; The name, type and name-position of the declaration to |
||||
;; return. |
||||
name |
||||
type |
||||
name-pos |
||||
;; Buffer positions marking the start and end of the space |
||||
;; containing a declaration. |
||||
start |
||||
end) |
||||
;; Change to declaration scanning syntax. |
||||
(with-syntax-table haskell-ds-syntax-table |
||||
;; Stop when we are at the end of the buffer or when a valid |
||||
;; declaration is grabbed. |
||||
(while (not (or (eobp) name)) |
||||
;; Move forward to next declaration at or after point. |
||||
(haskell-ds-move-to-decl t bird-literate t) |
||||
;; Start and end of search space is currently just the starting |
||||
;; line of the declaration. |
||||
(setq start (point) |
||||
end (line-end-position)) |
||||
(cond |
||||
;; If the start of the top-level declaration does not begin |
||||
;; with a starting keyword, then (if legal) must be a type |
||||
;; signature or value binding, and the variable concerned is |
||||
;; grabbed. |
||||
((not (looking-at haskell-ds-start-keywords-re)) |
||||
(setq name (haskell-ds-get-variable "")) |
||||
(if name |
||||
(progn |
||||
(setq type 'variable) |
||||
(re-search-forward (regexp-quote name) end t) |
||||
(setq name-pos (match-beginning 0))))) |
||||
;; User-defined datatype declaration. |
||||
((re-search-forward "\\=\\(data\\|newtype\\|type\\)\\>" end t) |
||||
(re-search-forward "=>" end t) |
||||
(if (looking-at "[ \t]*\\(\\sw+\\)") |
||||
(progn |
||||
(setq name (match-string-no-properties 1)) |
||||
(setq name-pos (match-beginning 1)) |
||||
(setq type 'datatype)))) |
||||
;; Class declaration. |
||||
((re-search-forward "\\=class\\>" end t) |
||||
(re-search-forward "=>" end t) |
||||
(if (looking-at "[ \t]*\\(\\sw+\\)") |
||||
(progn |
||||
(setq name (match-string-no-properties 1)) |
||||
(setq name-pos (match-beginning 1)) |
||||
(setq type 'class)))) |
||||
;; Import declaration. |
||||
((looking-at "import[ \t]+\\(?:safe[\t ]+\\)?\\(?:qualified[ \t]+\\)?\\(?:\"[^\"]*\"[\t ]+\\)?\\(\\(?:\\sw\\|.\\)+\\)") |
||||
(setq name (match-string-no-properties 1)) |
||||
(setq name-pos (match-beginning 1)) |
||||
(setq type 'import)) |
||||
;; Instance declaration. |
||||
((re-search-forward "\\=instance[ \t]+" end t) |
||||
(re-search-forward "=>[ \t]+" end t) |
||||
;; The instance "title" starts just after the `instance' (and |
||||
;; any context) and finishes just before the _first_ `where' |
||||
;; if one exists. This solution is ugly, but I can't find a |
||||
;; nicer one---a simple regexp will pick up the last `where', |
||||
;; which may be rare but nevertheless... |
||||
(setq name-pos (point)) |
||||
(setq name (buffer-substring-no-properties |
||||
(point) |
||||
(progn |
||||
;; Look for a `where'. |
||||
(if (re-search-forward "\\<where\\>" end t) |
||||
;; Move back to just before the `where'. |
||||
(progn |
||||
(re-search-backward "\\s-where") |
||||
(point)) |
||||
;; No `where' so move to last non-whitespace |
||||
;; before `end'. |
||||
(progn |
||||
(goto-char end) |
||||
(skip-chars-backward " \t") |
||||
(point)))))) |
||||
;; If we did not manage to extract a name, cancel this |
||||
;; declaration (eg. when line ends in "=> "). |
||||
(if (string-match "^[ \t]*$" name) (setq name nil)) |
||||
(setq type 'instance))) |
||||
;; Move past start of current declaration. |
||||
(goto-char end)) |
||||
;; If we have a valid declaration then return it, otherwise return |
||||
;; nil. |
||||
(if name |
||||
(cons (cons name (cons (copy-marker start t) (copy-marker name-pos t))) |
||||
type) |
||||
nil)))) |
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
||||
;; Declaration scanning via `imenu'. |
||||
|
||||
;;;###autoload |
||||
(defun haskell-ds-create-imenu-index () |
||||
"Function for finding `imenu' declarations in Haskell mode. |
||||
Finds all declarations (classes, variables, imports, instances and |
||||
datatypes) in a Haskell file for the `imenu' package." |
||||
;; Each list has elements of the form `(INDEX-NAME . INDEX-POSITION)'. |
||||
;; These lists are nested using `(INDEX-TITLE . INDEX-ALIST)'. |
||||
(let* ((bird-literate (haskell-ds-bird-p)) |
||||
(index-alist '()) |
||||
(index-class-alist '()) ;; Classes |
||||
(index-var-alist '()) ;; Variables |
||||
(index-imp-alist '()) ;; Imports |
||||
(index-inst-alist '()) ;; Instances |
||||
(index-type-alist '()) ;; Datatypes |
||||
;; Variables for showing progress. |
||||
(bufname (buffer-name)) |
||||
(divisor-of-progress (max 1 (/ (buffer-size) 100))) |
||||
;; The result we wish to return. |
||||
result) |
||||
(goto-char (point-min)) |
||||
;; Loop forwards from the beginning of the buffer through the |
||||
;; starts of the top-level declarations. |
||||
(while (< (point) (point-max)) |
||||
(message "Scanning declarations in %s... (%3d%%)" bufname |
||||
(/ (- (point) (point-min)) divisor-of-progress)) |
||||
;; Grab the next declaration. |
||||
(setq result (haskell-ds-generic-find-next-decl bird-literate)) |
||||
(if result |
||||
;; If valid, extract the components of the result. |
||||
(let* ((name-posns (car result)) |
||||
(name (car name-posns)) |
||||
(posns (cdr name-posns)) |
||||
(start-pos (car posns)) |
||||
(type (cdr result))) |
||||
;; Place `(name . start-pos)' in the correct alist. |
||||
(cl-case type |
||||
(variable |
||||
(setq index-var-alist |
||||
(cl-acons name start-pos index-var-alist))) |
||||
(datatype |
||||
(setq index-type-alist |
||||
(cl-acons name start-pos index-type-alist))) |
||||
(class |
||||
(setq index-class-alist |
||||
(cl-acons name start-pos index-class-alist))) |
||||
(import |
||||
(setq index-imp-alist |
||||
(cl-acons name start-pos index-imp-alist))) |
||||
(instance |
||||
(setq index-inst-alist |
||||
(cl-acons name start-pos index-inst-alist))))))) |
||||
;; Now sort all the lists, label them, and place them in one list. |
||||
(message "Sorting declarations in %s..." bufname) |
||||
(when index-type-alist |
||||
(push (cons "Datatypes" |
||||
(sort index-type-alist 'haskell-ds-imenu-label-cmp)) |
||||
index-alist)) |
||||
(when index-inst-alist |
||||
(push (cons "Instances" |
||||
(sort index-inst-alist 'haskell-ds-imenu-label-cmp)) |
||||
index-alist)) |
||||
(when index-imp-alist |
||||
(push (cons "Imports" |
||||
(sort index-imp-alist 'haskell-ds-imenu-label-cmp)) |
||||
index-alist)) |
||||
(when index-class-alist |
||||
(push (cons "Classes" |
||||
(sort index-class-alist 'haskell-ds-imenu-label-cmp)) |
||||
index-alist)) |
||||
(when index-var-alist |
||||
(if haskell-decl-scan-bindings-as-variables |
||||
(push (cons "Variables" |
||||
(sort index-var-alist 'haskell-ds-imenu-label-cmp)) |
||||
index-alist) |
||||
(setq index-alist (append index-alist |
||||
(sort index-var-alist 'haskell-ds-imenu-label-cmp))))) |
||||
(message "Sorting declarations in %s...done" bufname) |
||||
;; Return the alist. |
||||
index-alist)) |
||||
|
||||
(defun haskell-ds-imenu-label-cmp (el1 el2) |
||||
"Predicate to compare labels in lists from `haskell-ds-create-imenu-index'." |
||||
(string< (car el1) (car el2))) |
||||
|
||||
(defun haskell-ds-imenu () |
||||
"Install `imenu' for Haskell scripts." |
||||
(setq imenu-create-index-function 'haskell-ds-create-imenu-index) |
||||
(when haskell-decl-scan-add-to-menubar |
||||
(imenu-add-to-menubar "Declarations"))) |
||||
|
||||
;; The main functions to turn on declaration scanning. |
||||
;;;###autoload |
||||
(defun turn-on-haskell-decl-scan () |
||||
"Unconditionally activate `haskell-decl-scan-mode'." |
||||
(interactive) |
||||
(haskell-decl-scan-mode)) |
||||
(make-obsolete 'turn-on-haskell-decl-scan |
||||
'haskell-decl-scan-mode |
||||
"2015-07-23") |
||||
|
||||
;;;###autoload |
||||
(define-minor-mode haskell-decl-scan-mode |
||||
"Toggle Haskell declaration scanning minor mode on or off. |
||||
With a prefix argument ARG, enable minor mode if ARG is |
||||
positive, and disable it otherwise. If called from Lisp, enable |
||||
the mode if ARG is omitted or nil, and toggle it if ARG is `toggle'. |
||||
|
||||
See also info node `(haskell-mode)haskell-decl-scan-mode' for |
||||
more details about this minor mode. |
||||
|
||||
Top-level declarations are scanned and listed in the menu item |
||||
\"Declarations\" (if enabled via option |
||||
`haskell-decl-scan-add-to-menubar'). Selecting an item from this |
||||
menu will take point to the start of the declaration. |
||||
|
||||
\\[beginning-of-defun] and \\[end-of-defun] move forward and backward to the start of a declaration. |
||||
|
||||
This may link with `haskell-doc-mode'. |
||||
|
||||
For non-literate and LaTeX-style literate scripts, we assume the |
||||
common convention that top-level declarations start at the first |
||||
column. For Bird-style literate scripts, we assume the common |
||||
convention that top-level declarations start at the third column, |
||||
ie. after \"> \". |
||||
|
||||
Anything in `font-lock-comment-face' is not considered for a |
||||
declaration. Therefore, using Haskell font locking with comments |
||||
coloured in `font-lock-comment-face' improves declaration scanning. |
||||
|
||||
Literate Haskell scripts are supported: If the value of |
||||
`haskell-literate' (set automatically by `literate-haskell-mode') |
||||
is `bird', a Bird-style literate script is assumed. If it is nil |
||||
or `tex', a non-literate or LaTeX-style literate script is |
||||
assumed, respectively. |
||||
|
||||
Invokes `haskell-decl-scan-mode-hook' on activation." |
||||
:group 'haskell-decl-scan |
||||
|
||||
(kill-local-variable 'beginning-of-defun-function) |
||||
(kill-local-variable 'end-of-defun-function) |
||||
(kill-local-variable 'imenu-create-index-function) |
||||
(unless haskell-decl-scan-mode |
||||
;; How can we cleanly remove the "Declarations" menu? |
||||
(when haskell-decl-scan-add-to-menubar |
||||
(local-set-key [menu-bar index] nil))) |
||||
|
||||
(when haskell-decl-scan-mode |
||||
(set (make-local-variable 'beginning-of-defun-function) |
||||
'haskell-ds-backward-decl) |
||||
(set (make-local-variable 'end-of-defun-function) |
||||
'haskell-ds-forward-decl) |
||||
(haskell-ds-imenu))) |
||||
|
||||
|
||||
;; Provide ourselves: |
||||
|
||||
(provide 'haskell-decl-scan) |
||||
|
||||
;;; haskell-decl-scan.el ends here |
||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,589 @@
|
||||
;;; haskell-font-lock.el --- Font locking module for Haskell Mode -*- lexical-binding: t -*- |
||||
|
||||
;; Copyright 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. |
||||
;; Copyright 1997-1998 Graeme E Moss, and Tommy Thorn |
||||
|
||||
;; Author: 1997-1998 Graeme E Moss <gem@cs.york.ac.uk> |
||||
;; 1997-1998 Tommy Thorn <thorn@irisa.fr> |
||||
;; 2003 Dave Love <fx@gnu.org> |
||||
;; Keywords: faces files Haskell |
||||
|
||||
;; 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, 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 program. If not, see <http://www.gnu.org/licenses/>. |
||||
|
||||
|
||||
;;; Code: |
||||
|
||||
(require 'cl-lib) |
||||
(require 'haskell-mode) |
||||
(require 'font-lock) |
||||
|
||||
;;;###autoload |
||||
(defcustom haskell-font-lock-symbols nil |
||||
"Display \\ and -> and such using symbols in fonts. |
||||
|
||||
This may sound like a neat trick, but be extra careful: it changes the |
||||
alignment and can thus lead to nasty surprises w.r.t layout." |
||||
:group 'haskell |
||||
:type 'boolean) |
||||
|
||||
;;;###autoload |
||||
(defcustom haskell-font-lock-symbols-alist |
||||
'(("\\" . "λ") |
||||
("not" . "¬") |
||||
("->" . "→") |
||||
("<-" . "←") |
||||
("=>" . "⇒") |
||||
("()" . "∅") |
||||
("==" . "≡") |
||||
("/=" . "≢") |
||||
(">=" . "≥") |
||||
("<=" . "≤") |
||||
("!!" . "‼") |
||||
("&&" . "∧") |
||||
("||" . "∨") |
||||
("sqrt" . "√") |
||||
("undefined" . "⊥") |
||||
("pi" . "π") |
||||
("~>" . "⇝") ;; Omega language |
||||
;; ("~>" "↝") ;; less desirable |
||||
("-<" . "↢") ;; Paterson's arrow syntax |
||||
;; ("-<" "⤙") ;; nicer but uncommon |
||||
("::" . "∷") |
||||
("." "∘" ; "○" |
||||
;; Need a predicate here to distinguish the . used by |
||||
;; forall <foo> . <bar>. |
||||
haskell-font-lock-dot-is-not-composition) |
||||
("forall" . "∀")) |
||||
"Alist mapping Haskell symbols to chars. |
||||
|
||||
Each element has the form (STRING . COMPONENTS) or (STRING |
||||
COMPONENTS PREDICATE). |
||||
|
||||
STRING is the Haskell symbol. |
||||
COMPONENTS is a representation specification suitable as an argument to |
||||
`compose-region'. |
||||
PREDICATE if present is a function of one argument (the start position |
||||
of the symbol) which should return non-nil if this mapping should |
||||
be disabled at that position." |
||||
:type '(alist string string) |
||||
:group 'haskell) |
||||
|
||||
(defun haskell-font-lock-dot-is-not-composition (start) |
||||
"Return non-nil if the \".\" at START is not a composition operator. |
||||
This is the case if the \".\" is part of a \"forall <tvar> . <type>\"." |
||||
(save-excursion |
||||
(goto-char start) |
||||
(or (re-search-backward "\\<forall\\>[^.\"]*\\=" |
||||
(line-beginning-position) t) |
||||
(not (or |
||||
(string= " " (string (char-after start))) |
||||
(string= " " (string (char-before start)))))))) |
||||
|
||||
;;;###autoload |
||||
(defface haskell-keyword-face |
||||
'((t :inherit font-lock-keyword-face)) |
||||
"Face used to highlight Haskell keywords." |
||||
:group 'haskell) |
||||
|
||||
;;;###autoload |
||||
(defface haskell-constructor-face |
||||
'((t :inherit font-lock-type-face)) |
||||
"Face used to highlight Haskell constructors." |
||||
:group 'haskell) |
||||
|
||||
;; This used to be `font-lock-variable-name-face' but it doesn't result in |
||||
;; a highlighting that's consistent with other modes (it's mostly used |
||||
;; for function defintions). |
||||
(defface haskell-definition-face |
||||
'((t :inherit font-lock-function-name-face)) |
||||
"Face used to highlight Haskell definitions." |
||||
:group 'haskell) |
||||
|
||||
;; This is probably just wrong, but it used to use |
||||
;; `font-lock-function-name-face' with a result that was not consistent with |
||||
;; other major modes, so I just exchanged with `haskell-definition-face'. |
||||
;;;###autoload |
||||
(defface haskell-operator-face |
||||
'((t :inherit font-lock-variable-name-face)) |
||||
"Face used to highlight Haskell operators." |
||||
:group 'haskell) |
||||
|
||||
;;;###autoload |
||||
(defface haskell-pragma-face |
||||
'((t :inherit font-lock-preprocessor-face)) |
||||
"Face used to highlight Haskell pragmas." |
||||
:group 'haskell) |
||||
|
||||
;;;###autoload |
||||
(defface haskell-literate-comment-face |
||||
'((t :inherit font-lock-doc-face)) |
||||
"Face with which to fontify literate comments. |
||||
Inherit from `default' to avoid fontification of them." |
||||
:group 'haskell) |
||||
|
||||
(defun haskell-font-lock-compose-symbol (alist) |
||||
"Compose a sequence of ascii chars into a symbol. |
||||
Regexp match data 0 points to the chars." |
||||
;; Check that the chars should really be composed into a symbol. |
||||
(let* ((start (match-beginning 0)) |
||||
(end (match-end 0)) |
||||
(syntaxes (cond |
||||
((eq (char-syntax (char-after start)) ?w) '(?w)) |
||||
((eq (char-syntax (char-after start)) ?.) '(?.)) |
||||
;; Special case for the . used for qualified names. |
||||
((and (eq (char-after start) ?\.) (= end (1+ start))) |
||||
'(?_ ?\\ ?w)) |
||||
(t '(?_ ?\\)))) |
||||
sym-data) |
||||
(if (or (memq (char-syntax (or (char-before start) ?\ )) syntaxes) |
||||
(memq (char-syntax (or (char-after end) ?\ )) syntaxes) |
||||
(or (elt (syntax-ppss) 3) (elt (syntax-ppss) 4)) |
||||
(and (consp (setq sym-data (cdr (assoc (match-string 0) alist)))) |
||||
(let ((pred (cadr sym-data))) |
||||
(setq sym-data (car sym-data)) |
||||
(funcall pred start)))) |
||||
;; No composition for you. Let's actually remove any composition |
||||
;; we may have added earlier and which is now incorrect. |
||||
(remove-text-properties start end '(composition)) |
||||
;; That's a symbol alright, so add the composition. |
||||
(compose-region start end sym-data))) |
||||
;; Return nil because we're not adding any face property. |
||||
nil) |
||||
|
||||
(defun haskell-font-lock-symbols-keywords () |
||||
(when (and haskell-font-lock-symbols |
||||
haskell-font-lock-symbols-alist |
||||
(fboundp 'compose-region)) |
||||
`((,(regexp-opt (mapcar 'car haskell-font-lock-symbols-alist) t) |
||||
(0 (haskell-font-lock-compose-symbol ',haskell-font-lock-symbols-alist) |
||||
;; In Emacs-21, if the `override' field is nil, the face |
||||
;; expressions is only evaluated if the text has currently |
||||
;; no face. So force evaluation by using `keep'. |
||||
keep))))) |
||||
|
||||
;; The font lock regular expressions. |
||||
(defun haskell-font-lock-keywords-create (literate) |
||||
"Create fontification definitions for Haskell scripts. |
||||
Returns keywords suitable for `font-lock-keywords'." |
||||
(let* (;; Bird-style literate scripts start a line of code with |
||||
;; "^>", otherwise a line of code starts with "^". |
||||
(line-prefix (if (eq literate 'bird) "^> ?" "^")) |
||||
|
||||
(varid "\\b[[:lower:]_][[:alnum:]'_]*\\b") |
||||
;; We allow ' preceding conids because of DataKinds/PolyKinds |
||||
(conid "\\b'?[[:upper:]][[:alnum:]'_]*\\b") |
||||
(modid (concat "\\b" conid "\\(\\." conid "\\)*\\b")) |
||||
(qvarid (concat modid "\\." varid)) |
||||
(qconid (concat modid "\\." conid)) |
||||
(sym "\\s.+") |
||||
|
||||
;; Reserved identifiers |
||||
(reservedid |
||||
(concat "\\<" |
||||
;; `as', `hiding', and `qualified' are part of the import |
||||
;; spec syntax, but they are not reserved. |
||||
;; `_' can go in here since it has temporary word syntax. |
||||
;; (regexp-opt |
||||
;; '("case" "class" "data" "default" "deriving" "do" |
||||
;; "else" "if" "import" "in" "infix" "infixl" |
||||
;; "infixr" "instance" "let" "module" "newtype" "of" |
||||
;; "then" "type" "where" "_") t) |
||||
"\\(_\\|c\\(ase\\|lass\\)\\|d\\(ata\\|e\\(fault\\|riving\\)\\|o\\)\\|else\\|i\\(mport\\|n\\(fix[lr]?\\|stance\\)\\|[fn]\\)\\|let\\|module\\|mdo\\|newtype\\|of\\|rec\\|proc\\|t\\(hen\\|ype\\)\\|where\\)" |
||||
"\\>")) |
||||
|
||||
;; Top-level declarations |
||||
(topdecl-var |
||||
(concat line-prefix "\\(" varid "\\(?:\\s-*,\\s-*" varid "\\)*" "\\)\\s-*" |
||||
;; optionally allow for a single newline after identifier |
||||
;; NOTE: not supported for bird-style .lhs files |
||||
(if (eq literate 'bird) nil "\\([\n]\\s-+\\)?") |
||||
;; A toplevel declaration can be followed by a definition |
||||
;; (=), a type (::) or (∷), a guard, or a pattern which can |
||||
;; either be a variable, a constructor, a parenthesized |
||||
;; thingy, or an integer or a string. |
||||
"\\(" varid "\\|" conid "\\|::\\|∷\\|=\\||\\|\\s(\\|[0-9\"']\\)")) |
||||
(topdecl-var2 |
||||
(concat line-prefix "\\(" varid "\\|" conid "\\)\\s-*`\\(" varid "\\)`")) |
||||
(topdecl-bangpat |
||||
(concat line-prefix "\\(" varid "\\)\\s-*!")) |
||||
(topdecl-sym |
||||
(concat line-prefix "\\(" varid "\\|" conid "\\)\\s-*\\(" sym "\\)")) |
||||
(topdecl-sym2 (concat line-prefix "(\\(" sym "\\))")) |
||||
|
||||
keywords) |
||||
|
||||
(setq keywords |
||||
`(;; NOTICE the ordering below is significant |
||||
;; |
||||
("^#.*$" 0 'font-lock-preprocessor-face t) |
||||
|
||||
,@(haskell-font-lock-symbols-keywords) |
||||
|
||||
(,reservedid 1 'haskell-keyword-face) |
||||
|
||||
;; Special case for `as', `hiding', `safe' and `qualified', which are |
||||
;; keywords in import statements but are not otherwise reserved. |
||||
("\\<import[ \t]+\\(?:\\(safe\\>\\)[ \t]*\\)?\\(?:\\(qualified\\>\\)[ \t]*\\)?\\(?:\"[^\"]*\"[\t ]*\\)?[^ \t\n()]+[ \t]*\\(?:\\(\\<as\\>\\)[ \t]*[^ \t\n()]+[ \t]*\\)?\\(\\<hiding\\>\\)?" |
||||
(1 'haskell-keyword-face nil lax) |
||||
(2 'haskell-keyword-face nil lax) |
||||
(3 'haskell-keyword-face nil lax) |
||||
(4 'haskell-keyword-face nil lax)) |
||||
|
||||
;; Special case for `foreign import' |
||||
;; keywords in foreign import statements but are not otherwise reserved. |
||||
("\\<\\(foreign\\)[ \t]+\\(import\\)[ \t]+\\(?:\\(ccall\\|stdcall\\|cplusplus\\|jvm\\|dotnet\\)[ \t]+\\)?\\(?:\\(safe\\|unsafe\\|interruptible\\)[ \t]+\\)?" |
||||
(1 'haskell-keyword-face nil lax) |
||||
(2 'haskell-keyword-face nil lax) |
||||
(3 'haskell-keyword-face nil lax) |
||||
(4 'haskell-keyword-face nil lax)) |
||||
|
||||
;; Special case for `foreign export' |
||||
;; keywords in foreign export statements but are not otherwise reserved. |
||||
("\\<\\(foreign\\)[ \t]+\\(export\\)[ \t]+\\(?:\\(ccall\\|stdcall\\|cplusplus\\|jvm\\|dotnet\\)[ \t]+\\)?" |
||||
(1 'haskell-keyword-face nil lax) |
||||
(2 'haskell-keyword-face nil lax) |
||||
(3 'haskell-keyword-face nil lax)) |
||||
|
||||
;; Toplevel Declarations. |
||||
;; Place them *before* generic id-and-op highlighting. |
||||
(,topdecl-var (1 'haskell-definition-face)) |
||||
(,topdecl-var2 (2 'haskell-definition-face)) |
||||
(,topdecl-bangpat (1 'haskell-definition-face)) |
||||
(,topdecl-sym (2 (unless (member (match-string 2) '("\\" "=" "->" "→" "<-" "←" "::" "∷" "," ";" "`")) |
||||
'haskell-definition-face))) |
||||
(,topdecl-sym2 (1 (unless (member (match-string 1) '("\\" "=" "->" "→" "<-" "←" "::" "∷" "," ";" "`")) |
||||
'haskell-definition-face))) |
||||
|
||||
;; These four are debatable... |
||||
("(\\(,*\\|->\\))" 0 'haskell-constructor-face) |
||||
("\\[\\]" 0 'haskell-constructor-face) |
||||
|
||||
(,(concat "`" varid "`") 0 'haskell-operator-face) |
||||
(,(concat "`" conid "`") 0 'haskell-operator-face) |
||||
(,(concat "`" qvarid "`") 0 'haskell-operator-face) |
||||
(,(concat "`" qconid "`") 0 'haskell-operator-face) |
||||
|
||||
(,qconid 0 'haskell-constructor-face) |
||||
|
||||
(,conid 0 'haskell-constructor-face) |
||||
|
||||
(,sym 0 (if (and (eq (char-after (match-beginning 0)) ?:) |
||||
(not (member (match-string 0) '("::" "∷")))) |
||||
'haskell-constructor-face |
||||
'haskell-operator-face)))) |
||||
keywords)) |
||||
|
||||
(defvar haskell-font-lock-latex-cache-pos nil |
||||
"Position of cache point used by `haskell-font-lock-latex-cache-in-comment'. |
||||
Should be at the start of a line.") |
||||
(make-variable-buffer-local 'haskell-font-lock-latex-cache-pos) |
||||
|
||||
(defvar haskell-font-lock-latex-cache-in-comment nil |
||||
"If `haskell-font-lock-latex-cache-pos' is outside a |
||||
\\begin{code}..\\end{code} block (and therefore inside a comment), |
||||
this variable is set to t, otherwise nil.") |
||||
(make-variable-buffer-local 'haskell-font-lock-latex-cache-in-comment) |
||||
|
||||
(defun haskell-font-lock-latex-comments (end) |
||||
"Sets `match-data' according to the region of the buffer before end |
||||
that should be commented under LaTeX-style literate scripts." |
||||
(let ((start (point))) |
||||
(if (= start end) |
||||
;; We're at the end. No more to fontify. |
||||
nil |
||||
(if (not (eq start haskell-font-lock-latex-cache-pos)) |
||||
;; If the start position is not cached, calculate the state |
||||
;; of the start. |
||||
(progn |
||||
(setq haskell-font-lock-latex-cache-pos start) |
||||
;; If the previous \begin{code} or \end{code} is a |
||||
;; \begin{code}, then start is not in a comment, otherwise |
||||
;; it is in a comment. |
||||
(setq haskell-font-lock-latex-cache-in-comment |
||||
(if (and |
||||
(re-search-backward |
||||
"^\\(\\(\\\\begin{code}\\)\\|\\(\\\\end{code}\\)\\)$" |
||||
(point-min) t) |
||||
(match-end 2)) |
||||
nil t)) |
||||
;; Restore position. |
||||
(goto-char start))) |
||||
(if haskell-font-lock-latex-cache-in-comment |
||||
(progn |
||||
;; If start is inside a comment, search for next \begin{code}. |
||||
(re-search-forward "^\\\\begin{code}$" end 'move) |
||||
;; Mark start to end of \begin{code} (if present, till end |
||||
;; otherwise), as a comment. |
||||
(set-match-data (list start (point))) |
||||
;; Return point, as a normal regexp would. |
||||
(point)) |
||||
;; If start is inside a code block, search for next \end{code}. |
||||
(if (re-search-forward "^\\\\end{code}$" end t) |
||||
;; If one found, mark it as a comment, otherwise finish. |
||||
(point)))))) |
||||
|
||||
(defconst haskell-basic-syntactic-keywords |
||||
'(;; Character constants (since apostrophe can't have string syntax). |
||||
;; Beware: do not match something like 's-}' or '\n"+' since the first ' |
||||
;; might be inside a comment or a string. |
||||
;; This still gets fooled with "'"'"'"'"'"', but ... oh well. |
||||
("\\Sw\\('\\)\\([^\\'\n]\\|\\\\.[^\\'\n \"}]*\\)\\('\\)" (1 "\"") (3 "\"")) |
||||
;; Deal with instances of `--' which don't form a comment |
||||
("[!#$%&*+./:<=>?@^|~\\]*--[!#$%&*+./:<=>?@^|~\\-]*" (0 (cond ((or (nth 3 (syntax-ppss)) (numberp (nth 4 (syntax-ppss)))) |
||||
;; There are no such instances inside |
||||
;; nestable comments or strings |
||||
nil) |
||||
((string-match "\\`-*\\'" (match-string 0)) |
||||
;; Sequence of hyphens. Do nothing in |
||||
;; case of things like `{---'. |
||||
nil) |
||||
((string-match "\\`[^-]+--.*" (match-string 0)) |
||||
;; Extra characters before comment starts |
||||
".") |
||||
(t ".")))) ; other symbol sequence |
||||
|
||||
;; Implement Haskell Report 'escape' and 'gap' rules. Backslash |
||||
;; inside of a string is escaping unless it is preceeded by |
||||
;; another escaping backslash. There can be whitespace between |
||||
;; those two. |
||||
;; |
||||
;; Backslashes outside of string never escape. |
||||
;; |
||||
;; Note that (> 0 (skip-syntax-backward ".")) this skips over *escaping* |
||||
;; backslashes only. |
||||
("\\\\" (0 (when (save-excursion (and (nth 3 (syntax-ppss)) |
||||
(goto-char (match-beginning 0)) |
||||
(skip-syntax-backward "->") |
||||
(or (not (eq ?\\ (char-before))) |
||||
(> 0 (skip-syntax-backward "."))))) |
||||
"\\"))) |
||||
|
||||
;; QuasiQuotes syntax: [quoter| string |], quoter is unqualified |
||||
;; name, no spaces, string is arbitrary (including newlines), |
||||
;; finishes at the first occurence of |], no escaping is provided. |
||||
;; |
||||
;; The quoter cannot be "e", "t", "d", or "p", since those overlap |
||||
;; with Template Haskell quotations. |
||||
;; |
||||
;; QuasiQuotes opens only when outside of a string or a comment |
||||
;; and closes only when inside a quasiquote. |
||||
;; |
||||
;; (syntax-ppss) returns list with two interesting elements: |
||||
;; nth 3. non-nil if inside a string. (it is the character that will |
||||
;; terminate the string, or t if the string should be terminated |
||||
;; by a generic string delimiter.) |
||||
;; nth 4. nil if outside a comment, t if inside a non-nestable comment, |
||||
;; else an integer (the current comment nesting). |
||||
;; |
||||
;; Note also that we need to do in in a single pass, hence a regex |
||||
;; that covers both the opening and the ending of a quasiquote. |
||||
|
||||
("\\(\\[[[:alnum:]]+\\)?\\(|\\)\\(]\\)?" |
||||
(2 (save-excursion |
||||
(goto-char (match-beginning 0)) |
||||
(if (eq ?\[ (char-after)) |
||||
;; opening case |
||||
(unless (or (nth 3 (syntax-ppss)) |
||||
(nth 4 (syntax-ppss)) |
||||
(member (match-string 1) |
||||
'("[e" "[t" "[d" "[p"))) |
||||
"\"") |
||||
;; closing case |
||||
(when (and (eq ?| (nth 3 (syntax-ppss))) |
||||
(equal "]" (match-string 3)) |
||||
) |
||||
"\""))))) |
||||
)) |
||||
|
||||
(defconst haskell-bird-syntactic-keywords |
||||
(cons '("^[^\n>]" (0 "<")) |
||||
haskell-basic-syntactic-keywords)) |
||||
|
||||
(defconst haskell-latex-syntactic-keywords |
||||
(append |
||||
'(("^\\\\begin{code}\\(\n\\)" 1 "!") |
||||
;; Note: buffer is widened during font-locking. |
||||
("\\`\\(.\\|\n\\)" (1 "!")) ; start comment at buffer start |
||||
("^\\(\\\\\\)end{code}$" 1 "!")) |
||||
haskell-basic-syntactic-keywords)) |
||||
|
||||
(defun haskell-syntactic-face-function (state) |
||||
"`font-lock-syntactic-face-function' for Haskell." |
||||
(cond |
||||
((nth 3 state) 'font-lock-string-face) ; as normal |
||||
;; Else comment. If it's from syntax table, use default face. |
||||
((or (eq 'syntax-table (nth 7 state)) |
||||
(and (eq haskell-literate 'bird) |
||||
(memq (char-before (nth 8 state)) '(nil ?\n)))) |
||||
'haskell-literate-comment-face) |
||||
;; Detect pragmas. A pragma is enclosed in special comment |
||||
;; delimeters {-# .. #-}. |
||||
((save-excursion |
||||
(goto-char (nth 8 state)) |
||||
(and (looking-at "{-#") |
||||
(forward-comment 1) |
||||
(goto-char (- (point) 3)) |
||||
(looking-at "#-}"))) |
||||
'haskell-pragma-face) |
||||
;; Haddock comment start with either "-- [|^*$]" or "{- ?[|^*$]" |
||||
;; (note space optional for nested comments and mandatory for |
||||
;; double dash comments). |
||||
;; |
||||
;; Haddock comment will also continue on next line, provided: |
||||
;; - current line is a double dash haddock comment |
||||
;; - next line is also double dash comment |
||||
;; - there is only whitespace between |
||||
;; |
||||
;; We recognize double dash haddock comments by property |
||||
;; 'font-lock-doc-face attached to newline. In case of bounded |
||||
;; comments newline is outside of comment. |
||||
((save-excursion |
||||
(goto-char (nth 8 state)) |
||||
(or (looking-at "\\(?:{- ?\\|-- \\)[|^*$]") |
||||
(and (looking-at "--") ; are we at double dash comment |
||||
(forward-line -1) ; this is nil on first line |
||||
(eq (get-text-property (line-end-position) 'face) |
||||
'font-lock-doc-face) ; is a doc face |
||||
(forward-line) |
||||
(skip-syntax-forward "-") ; see if there is only whitespace |
||||
(eq (point) (nth 8 state))))) ; we are back in position |
||||
'font-lock-doc-face) |
||||
(t 'font-lock-comment-face))) |
||||
|
||||
(defconst haskell-font-lock-keywords |
||||
(haskell-font-lock-keywords-create nil) |
||||
"Font lock definitions for non-literate Haskell.") |
||||
|
||||
(defconst haskell-font-lock-bird-literate-keywords |
||||
(haskell-font-lock-keywords-create 'bird) |
||||
"Font lock definitions for Bird-style literate Haskell.") |
||||
|
||||
(defconst haskell-font-lock-latex-literate-keywords |
||||
(haskell-font-lock-keywords-create 'latex) |
||||
"Font lock definitions for LaTeX-style literate Haskell.") |
||||
|
||||
;;;###autoload |
||||
(defun haskell-font-lock-choose-keywords () |
||||
(let ((literate (if (boundp 'haskell-literate) haskell-literate))) |
||||
(cl-case literate |
||||
(bird haskell-font-lock-bird-literate-keywords) |
||||
((latex tex) haskell-font-lock-latex-literate-keywords) |
||||
(t haskell-font-lock-keywords)))) |
||||
|
||||
(defun haskell-font-lock-choose-syntactic-keywords () |
||||
(let ((literate (if (boundp 'haskell-literate) haskell-literate))) |
||||
(cl-case literate |
||||
(bird haskell-bird-syntactic-keywords) |
||||
((latex tex) haskell-latex-syntactic-keywords) |
||||
(t haskell-basic-syntactic-keywords)))) |
||||
|
||||
(defun haskell-font-lock-defaults-create () |
||||
"Locally set `font-lock-defaults' for Haskell." |
||||
(set (make-local-variable 'font-lock-defaults) |
||||
'(haskell-font-lock-choose-keywords |
||||
nil nil ((?\' . "w") (?_ . "w")) nil |
||||
(font-lock-syntactic-keywords |
||||
. haskell-font-lock-choose-syntactic-keywords) |
||||
(font-lock-syntactic-face-function |
||||
. haskell-syntactic-face-function) |
||||
;; Get help from font-lock-syntactic-keywords. |
||||
(parse-sexp-lookup-properties . t)))) |
||||
|
||||
;; The main functions. |
||||
(defun turn-on-haskell-font-lock () |
||||
"Turns on font locking in current buffer for Haskell 1.4 scripts. |
||||
|
||||
Changes the current buffer's `font-lock-defaults', and adds the |
||||
following variables: |
||||
|
||||
`haskell-keyword-face' for reserved keywords and syntax, |
||||
`haskell-constructor-face' for data- and type-constructors, class names, |
||||
and module names, |
||||
`haskell-operator-face' for symbolic and alphanumeric operators, |
||||
`haskell-default-face' for ordinary code. |
||||
|
||||
The variables are initialised to the following font lock default faces: |
||||
|
||||
`haskell-keyword-face' `font-lock-keyword-face' |
||||
`haskell-constructor-face' `font-lock-type-face' |
||||
`haskell-operator-face' `font-lock-function-name-face' |
||||
`haskell-default-face' <default face> |
||||
|
||||
Two levels of fontification are defined: level one (the default) |
||||
and level two (more colour). The former does not colour operators. |
||||
Use the variable `font-lock-maximum-decoration' to choose |
||||
non-default levels of fontification. For example, adding this to |
||||
.emacs: |
||||
|
||||
(setq font-lock-maximum-decoration '((haskell-mode . 2) (t . 0))) |
||||
|
||||
uses level two fontification for `haskell-mode' and default level for |
||||
all other modes. See documentation on this variable for further |
||||
details. |
||||
|
||||
To alter an attribute of a face, add a hook. For example, to change |
||||
the foreground colour of comments to brown, add the following line to |
||||
.emacs: |
||||
|
||||
(add-hook 'haskell-font-lock-hook |
||||
(lambda () |
||||
(set-face-foreground 'haskell-comment-face \"brown\"))) |
||||
|
||||
Note that the colours available vary from system to system. To see |
||||
what colours are available on your system, call |
||||
`list-colors-display' from emacs. |
||||
|
||||
To turn font locking on for all Haskell buffers, add this to .emacs: |
||||
|
||||
(add-hook 'haskell-mode-hook 'turn-on-haskell-font-lock) |
||||
|
||||
To turn font locking on for the current buffer, call |
||||
`turn-on-haskell-font-lock'. To turn font locking off in the current |
||||
buffer, call `turn-off-haskell-font-lock'. |
||||
|
||||
Bird-style literate Haskell scripts are supported: If the value of |
||||
`haskell-literate-bird-style' (automatically set by the Haskell mode |
||||
of Moss&Thorn) is non-nil, a Bird-style literate script is assumed. |
||||
|
||||
Invokes `haskell-font-lock-hook' if not nil." |
||||
(haskell-font-lock-defaults-create) |
||||
(run-hooks 'haskell-font-lock-hook) |
||||
(turn-on-font-lock)) |
||||
|
||||
(defun turn-off-haskell-font-lock () |
||||
"Turns off font locking in current buffer." |
||||
(font-lock-mode -1)) |
||||
|
||||
(defun haskell-fontify-as-mode (text mode) |
||||
"Fontify TEXT as MODE, returning the fontified text." |
||||
(with-temp-buffer |
||||
(funcall mode) |
||||
(insert text) |
||||
(if (fboundp 'font-lock-ensure) |
||||
(font-lock-ensure) |
||||
(with-no-warnings (font-lock-fontify-buffer))) |
||||
(buffer-substring (point-min) (point-max)))) |
||||
|
||||
;; Provide ourselves: |
||||
|
||||
(provide 'haskell-font-lock) |
||||
|
||||
;; Local Variables: |
||||
;; coding: utf-8-unix |
||||
;; tab-width: 8 |
||||
;; End: |
||||
|
||||
;;; haskell-font-lock.el ends here |
||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,223 @@
|
||||
;;; haskell-lexeme.el --- haskell lexical tokens -*- coding: utf-8; lexical-binding: t -*- |
||||
|
||||
;; Copyright (C) 2015 Gracjan Polak |
||||
|
||||
;; 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, 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 program. If not, see <http://www.gnu.org/licenses/>. |
||||
|
||||
;;; Commentary: |
||||
|
||||
;;; Code: |
||||
|
||||
(require 'rx) |
||||
|
||||
(unless (category-docstring ?P) |
||||
(define-category ?P "Haskell symbol constituent characters") |
||||
(map-char-table |
||||
#'(lambda (key val) |
||||
(if (or |
||||
(and (consp key) (> (car key) 128)) |
||||
(and (numberp key) (> key 128))) |
||||
(if (member val '(Pc Pd Po Sm Sc Sk So)) |
||||
(modify-category-entry key ?P)))) |
||||
unicode-category-table) |
||||
|
||||
(dolist (key (string-to-list "!#$%&*+./<=>?@^|~\\-")) |
||||
(modify-category-entry key ?P))) |
||||
|
||||
(defconst haskell-lexeme-modid |
||||
"[[:upper:]][[:alnum:]'_]*" |
||||
"Regexp matching a valid Haskell module identifier. |
||||
|
||||
Note that GHC accepts Unicode category UppercaseLetter as a first |
||||
character. Following letters are from Unicode categories |
||||
UppercaseLetter, LowercaseLetter, OtherLetter, TitlecaseLetter, |
||||
ModifierLetter, DecimalNumber, OtherNumber, backslash or |
||||
underscore. |
||||
|
||||
Note that this differs from constructor identifier as the latter |
||||
one can have any number of hash character at the end to |
||||
accommodate MagicHash extension.") |
||||
|
||||
(defconst haskell-lexeme-id |
||||
"[[:alpha:]_][[:alnum:]'_]*#*" |
||||
"Regexp matching a valid Haskell identifier. |
||||
|
||||
GHC accepts a string starting with any alphabetic character or |
||||
underscore followed by any alphanumeric character or underscore |
||||
or apostrophe.") |
||||
|
||||
(defconst haskell-lexeme-sym |
||||
"\\(:?\\cP\\|:\\)+" |
||||
"Regexp matching a valid Haskell variable or constructor symbol. |
||||
|
||||
GHC accepts a string of chars from the set |
||||
[:!#$%&*+./<=>?@^|~\\-] or Unicode category Symbol for chars with |
||||
codes larger than 128 only.") |
||||
|
||||
(defconst haskell-lexeme-modid-opt-prefix |
||||
(concat "\\(?:" haskell-lexeme-modid "\\.\\)*") |
||||
"Regexp matching a valid Haskell module prefix, potentially empty. |
||||
|
||||
Module path prefix is separated by dots and finishes with a |
||||
dot. For path component syntax see `haskell-lexeme-modid'.") |
||||
|
||||
(defconst haskell-lexeme-qid-or-qsym |
||||
(rx-to-string `(: (regexp ,haskell-lexeme-modid-opt-prefix) |
||||
(group (| (regexp ,haskell-lexeme-id) (regexp ,haskell-lexeme-sym) |
||||
)))) |
||||
"Regexp matching a valid qualified identifier or symbol. |
||||
|
||||
Note that (match-string 1) returns the unqualified part.") |
||||
|
||||
(defconst haskell-lexeme-qid |
||||
(rx-to-string `(: (regexp "'*") |
||||
(regexp ,haskell-lexeme-modid-opt-prefix) |
||||
(group (regexp ,haskell-lexeme-id)))) |
||||
"Regexp matching a valid qualified identifier. |
||||
|
||||
Note that (match-string 1) returns the unqualified part.") |
||||
|
||||
(defconst haskell-lexeme-qsym |
||||
(rx-to-string `(: (regexp "'*") |
||||
(regexp ,haskell-lexeme-modid-opt-prefix) |
||||
(group (regexp ,haskell-lexeme-id)))) |
||||
"Regexp matching a valid qualified symbol. |
||||
|
||||
Note that (match-string 1) returns the unqualified part.") |
||||
|
||||
(defconst haskell-lexeme-number |
||||
(rx (| (: (regexp "[0-9]+\\.[0-9]+") (opt (regexp "[eE][-+]?[0-9]+"))) |
||||
(regexp "[0-9]+[eE][-+]?[0-9]+") |
||||
(regexp "0[xX][0-9a-fA-F]+") |
||||
(regexp "0[oO][0-7]+") |
||||
(regexp "[0-9]+"))) |
||||
"Regexp matching a floating point, decimal, octal or hexadecimal number. |
||||
|
||||
Note that negative sign char is not part of a number.") |
||||
|
||||
(defconst haskell-lexeme-char-literal-inside |
||||
(rx (| (regexp "[^\n'\\]") |
||||
(: "\\" |
||||
(| "a" "b" "f" "n" "r" "t" "v" "\\" "\"" "'" |
||||
"NUL" "SOH" "STX" "ETX" "EOT" "ENQ" "ACK" |
||||
"BEL" "BS" "HT" "LF" "VT" "FF" "CR" "SO" "SI" "DLE" |
||||
"DC1" "DC2" "DC3" "DC4" "NAK" "SYN" "ETB" "CAN" |
||||
"EM" "SUB" "ESC" "FS" "GS" "RS" "US" "SP" "DEL" |
||||
(: "^" (regexp "[]A-Z@^_\\[]")))))) |
||||
"Regexp matching an inside of a character literal.") |
||||
|
||||
(defconst haskell-lexeme-char-literal |
||||
(rx-to-string `(: "'" (regexp ,haskell-lexeme-char-literal-inside) "'")) |
||||
"Regexp matching a character literal.") |
||||
|
||||
(defconst haskell-lexeme-string-literal-inside |
||||
(rx (* (| (regexp "[^\n\"\\]") |
||||
(: "\\" |
||||
(| "a" "b" "f" "n" "r" "t" "v" "\\" "\"" "'" "&" |
||||
"NUL" "SOH" "STX" "ETX" "EOT" "ENQ" "ACK" |
||||
"BEL" "BS" "HT" "LF" "VT" "FF" "CR" "SO" "SI" "DLE" |
||||
"DC1" "DC2" "DC3" "DC4" "NAK" "SYN" "ETB" "CAN" |
||||
"EM" "SUB" "ESC" "FS" "GS" "RS" "US" "SP" "DEL" |
||||
(: "^" (regexp "[]A-Z@^_\\[]")) |
||||
(regexp "[ \t\n\r\v\f]*\\\\")))))) |
||||
"Regexp matching an inside of a string literal.") |
||||
|
||||
(defconst haskell-lexeme-string-literal |
||||
(rx-to-string `(: "\"" (regexp ,haskell-lexeme-string-literal-inside) "\"")) |
||||
"Regexp matching a string literal.") |
||||
|
||||
(defun haskell-lexeme-classify-by-first-char (char) |
||||
"Classify token by CHAR. |
||||
|
||||
CHAR is a chararacter that is assumed to be first character of a token." |
||||
(let ((category (get-char-code-property char 'general-category))) |
||||
|
||||
(cond |
||||
((or (member char '(?! ?# ?$ ?% ?& ?* ?+ ?. ?/ ?< ?= ?> ?? ?@ ?^ ?| ?~ ?\\ ?-)) |
||||
(and (> char 127) |
||||
(member category '(Pc Pd Po Sm Sc Sk So)))) |
||||
'varsym) |
||||
((equal char ?:) |
||||
'consym) |
||||
((equal char ?\') |
||||
'char) |
||||
((equal char ?\") |
||||
'string) |
||||
((member category '(Lu Lt)) |
||||
'conid) |
||||
((or (equal char ?_) |
||||
(member category '(Ll Lo))) |
||||
'varsym) |
||||
((and (>= char ?0) (<= char 9)) |
||||
'number) |
||||
((member char '(?\] ?\[ ?\( ?\) ?\{ ?\} ?\` ?\, ?\;)) |
||||
'special)))) |
||||
|
||||
(defun haskell-lexeme-looking-at-token () |
||||
"Like `looking-at' but understands Haskell lexemes. |
||||
|
||||
Moves point forward over whitespace. Returns a symbol describing |
||||
type of Haskell token recognized. Use `match-string', |
||||
`match-beginning' and `match-end' with argument 0 to query match |
||||
result. |
||||
|
||||
Possible results are: |
||||
- 'special: for chars [](){}`,; |
||||
- 'comment: for single line comments |
||||
- 'nested-comment: for multiline comments |
||||
- 'qsymid: for qualified identifiers or symbols |
||||
- 'string: for strings literals |
||||
- 'char: for char literals |
||||
- 'decimal: for decimal, float, hexadecimal and octal number literals |
||||
- 'template-haskell-quote: for a string of apostrophes for template haskell |
||||
|
||||
Note that for qualified symbols (match-string 1) returns the |
||||
unqualified identifier or symbol. Further qualification for |
||||
symbol or identifier can be done with: |
||||
|
||||
(haskell-lexeme-classify-by-first-char (char-after (match-beginning 1))) |
||||
|
||||
See `haskell-lexeme-classify-by-first-char' for details." |
||||
(skip-syntax-forward "->") |
||||
(let |
||||
((case-fold-search nil) |
||||
(point (point-marker))) |
||||
(or |
||||
(and (looking-at "{-") |
||||
(progn |
||||
(save-excursion |
||||
(forward-comment 1) |
||||
(set-match-data (list point (point-marker)))) |
||||
'nested-comment)) |
||||
(and (looking-at haskell-lexeme-char-literal) |
||||
'char) |
||||
(and (looking-at haskell-lexeme-string-literal) |
||||
'string) |
||||
(and (looking-at "[][(){}`,;]") |
||||
'special) |
||||
(and (looking-at haskell-lexeme-qid-or-qsym) |
||||
(if (and (eq (- (match-end 0) (match-beginning 0)) 2) |
||||
(equal (match-string 0) "--")) |
||||
(progn |
||||
(set-match-data (list point (set-marker (make-marker) (line-end-position)))) |
||||
'comment) |
||||
'qsymid)) |
||||
(and (looking-at haskell-lexeme-number) |
||||
'number) |
||||
(and (looking-at "'+") |
||||
'template-haskell-quote)))) |
||||
|
||||
(provide 'haskell-lexeme) |
||||
|
||||
;;; haskell-lexeme.el ends here |
||||
@ -0,0 +1,529 @@
|
||||
;;; haskell-load.el --- Compiling and loading modules in the GHCi process -*- lexical-binding: t -*- |
||||
|
||||
;; Copyright (c) 2014 Chris Done. All rights reserved. |
||||
|
||||
;; 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, 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 program. If not, see <http://www.gnu.org/licenses/>. |
||||
|
||||
;;; Code: |
||||
|
||||
(require 'cl-lib) |
||||
(require 'haskell-process) |
||||
(require 'haskell-interactive-mode) |
||||
(require 'haskell-modules) |
||||
(require 'haskell-commands) |
||||
(require 'haskell-session) |
||||
|
||||
(defun haskell-process-look-config-changes (session) |
||||
"Checks whether a cabal configuration file has |
||||
changed. Restarts the process if that is the case." |
||||
(let ((current-checksum (haskell-session-get session 'cabal-checksum)) |
||||
(new-checksum (haskell-cabal-compute-checksum |
||||
(haskell-session-get session 'cabal-dir)))) |
||||
(when (not (string= current-checksum new-checksum)) |
||||
(haskell-interactive-mode-echo session (format "Cabal file changed: %s" new-checksum)) |
||||
(haskell-session-set-cabal-checksum session |
||||
(haskell-session-get session 'cabal-dir)) |
||||
(unless (and haskell-process-prompt-restart-on-cabal-change |
||||
(not (y-or-n-p "Cabal file changed; restart GHCi process? "))) |
||||
(haskell-process-start (haskell-interactive-session)))))) |
||||
|
||||
(defun haskell-process-live-build (process buffer echo-in-repl) |
||||
"Show live updates for loading files." |
||||
(cond ((haskell-process-consume |
||||
process |
||||
(concat "\\[[ ]*\\([0-9]+\\) of \\([0-9]+\\)\\]" |
||||
" Compiling \\([^ ]+\\)[ ]+" |
||||
"( \\([^ ]+\\), \\([^ ]+\\) )[^\r\n]*[\r\n]+")) |
||||
(haskell-process-echo-load-message process buffer echo-in-repl nil) |
||||
t) |
||||
((haskell-process-consume |
||||
process |
||||
(concat "\\[[ ]*\\([0-9]+\\) of \\([0-9]+\\)\\]" |
||||
" Compiling \\[TH\\] \\([^ ]+\\)[ ]+" |
||||
"( \\([^ ]+\\), \\([^ ]+\\) )[^\r\n]*[\r\n]+")) |
||||
(haskell-process-echo-load-message process buffer echo-in-repl t) |
||||
t) |
||||
((haskell-process-consume process "Loading package \\([^ ]+\\) ... linking ... done.\n") |
||||
(haskell-mode-message-line |
||||
(format "Loading: %s" |
||||
(match-string 1 buffer))) |
||||
t) |
||||
((haskell-process-consume |
||||
process |
||||
"^Preprocessing executables for \\(.+?\\)\\.\\.\\.") |
||||
(let ((msg (format "Preprocessing: %s" (match-string 1 buffer)))) |
||||
(haskell-interactive-mode-echo |
||||
(haskell-process-session process) |
||||
msg) |
||||
(haskell-mode-message-line msg))) |
||||
((haskell-process-consume process "Linking \\(.+?\\) \\.\\.\\.") |
||||
(let ((msg (format "Linking: %s" (match-string 1 buffer)))) |
||||
(haskell-interactive-mode-echo (haskell-process-session process) msg) |
||||
(haskell-mode-message-line msg))) |
||||
((haskell-process-consume process "\nBuilding \\(.+?\\)\\.\\.\\.") |
||||
(let ((msg (format "Building: %s" (match-string 1 buffer)))) |
||||
(haskell-interactive-mode-echo |
||||
(haskell-process-session process) |
||||
msg) |
||||
(haskell-mode-message-line msg))))) |
||||
|
||||
(defun haskell-process-load-complete (session process buffer reload module-buffer &optional cont) |
||||
"Handle the complete loading response. BUFFER is the string of |
||||
text being sent over the process pipe. MODULE-BUFFER is the |
||||
actual Emacs buffer of the module being loaded." |
||||
(when (get-buffer (format "*%s:splices*" (haskell-session-name session))) |
||||
(with-current-buffer (haskell-interactive-mode-splices-buffer session) |
||||
(erase-buffer))) |
||||
(let* ((ok (cond ((haskell-process-consume process "Ok, modules loaded: \\(.+\\)\\.$") t) |
||||
((haskell-process-consume process "Failed, modules loaded: \\(.+\\)\\.$") nil) |
||||
(t (error (message "Unexpected response from haskell process."))))) |
||||
(modules (haskell-process-extract-modules buffer)) |
||||
(cursor (haskell-process-response-cursor process)) |
||||
(warning-count 0)) |
||||
(haskell-process-set-response-cursor process 0) |
||||
(haskell-check-remove-overlays module-buffer) |
||||
(while (haskell-process-errors-warnings module-buffer session process buffer) |
||||
(setq warning-count (1+ warning-count))) |
||||
(haskell-process-set-response-cursor process cursor) |
||||
(if (and (not reload) |
||||
haskell-process-reload-with-fbytecode) |
||||
(haskell-process-reload-with-fbytecode process module-buffer) |
||||
(haskell-process-import-modules process (car modules))) |
||||
(if ok |
||||
(haskell-mode-message-line (if reload "Reloaded OK." "OK.")) |
||||
(haskell-interactive-mode-compile-error session "Compilation failed.")) |
||||
(when cont |
||||
(condition-case e |
||||
(funcall cont ok) |
||||
(error (message "%S" e)) |
||||
(quit nil))))) |
||||
|
||||
(defun haskell-process-suggest-imports (session file modules ident) |
||||
"Given a list of MODULES, suggest adding them to the import section." |
||||
(cl-assert session) |
||||
(cl-assert file) |
||||
(cl-assert ident) |
||||
(let* ((process (haskell-session-process session)) |
||||
(suggested-already (haskell-process-suggested-imports process)) |
||||
(module (cond ((> (length modules) 1) |
||||
(when (y-or-n-p (format "Identifier `%s' not in scope, choose module to import?" |
||||
ident)) |
||||
(haskell-complete-module-read "Module: " modules))) |
||||
((= (length modules) 1) |
||||
(let ((module (car modules))) |
||||
(unless (member module suggested-already) |
||||
(haskell-process-set-suggested-imports process (cons module suggested-already)) |
||||
(when (y-or-n-p (format "Identifier `%s' not in scope, import `%s'?" |
||||
ident |
||||
module)) |
||||
module))))))) |
||||
(when module |
||||
(haskell-process-find-file session file) |
||||
(haskell-add-import module)))) |
||||
|
||||
(defun haskell-process-trigger-suggestions (session msg file line) |
||||
"Trigger prompting to add any extension suggestions." |
||||
(cond ((let ((case-fold-search nil)) |
||||
(or (and (string-match " -X\\([A-Z][A-Za-z]+\\)" msg) |
||||
(not (string-match "\\([A-Z][A-Za-z]+\\) is deprecated" msg))) |
||||
(string-match "Use \\([A-Z][A-Za-z]+\\) to permit this" msg) |
||||
(string-match "Use \\([A-Z][A-Za-z]+\\) to allow" msg) |
||||
(string-match "use \\([A-Z][A-Za-z]+\\)" msg) |
||||
(string-match "You need \\([A-Z][A-Za-z]+\\)" msg))) |
||||
(when haskell-process-suggest-language-pragmas |
||||
(haskell-process-suggest-pragma session "LANGUAGE" (match-string 1 msg) file))) |
||||
((string-match " The \\(qualified \\)?import of[ ][‘`‛]\\([^ ]+\\)['’] is redundant" msg) |
||||
(when haskell-process-suggest-remove-import-lines |
||||
(haskell-process-suggest-remove-import session |
||||
file |
||||
(match-string 2 msg) |
||||
line))) |
||||
((string-match "Warning: orphan instance: " msg) |
||||
(when haskell-process-suggest-no-warn-orphans |
||||
(haskell-process-suggest-pragma session "OPTIONS" "-fno-warn-orphans" file))) |
||||
((or (string-match "against inferred type [‘`‛]\\[Char\\]['’]" msg) |
||||
(string-match "with actual type [‘`‛]\\[Char\\]['’]" msg)) |
||||
(when haskell-process-suggest-overloaded-strings |
||||
(haskell-process-suggest-pragma session "LANGUAGE" "OverloadedStrings" file))) |
||||
((string-match "^Not in scope: .*[‘`‛]\\(.+\\)['’]$" msg) |
||||
(let* ((match1 (match-string 1 msg)) |
||||
(ident (if (string-match "^[A-Za-z0-9_'.]+\\.\\(.+\\)$" match1) |
||||
;; Skip qualification. |
||||
(match-string 1 match1) |
||||
match1))) |
||||
(when haskell-process-suggest-hoogle-imports |
||||
(let ((modules (haskell-process-hoogle-ident ident))) |
||||
(haskell-process-suggest-imports session file modules ident))) |
||||
(when haskell-process-suggest-haskell-docs-imports |
||||
(let ((modules (haskell-process-haskell-docs-ident ident))) |
||||
(haskell-process-suggest-imports session file modules ident))) |
||||
(when haskell-process-suggest-hayoo-imports |
||||
(let ((modules (haskell-process-hayoo-ident ident))) |
||||
(haskell-process-suggest-imports session file modules ident))))) |
||||
((string-match "^[ ]+It is a member of the hidden package [‘`‛]\\([^@\r\n]+\\).*['’].$" msg) |
||||
(when haskell-process-suggest-add-package |
||||
(haskell-process-suggest-add-package session msg))))) |
||||
|
||||
(defun haskell-process-do-cabal (command) |
||||
"Run a Cabal command." |
||||
(let ((process (haskell-interactive-process))) |
||||
(cond |
||||
((let ((child (haskell-process-process process))) |
||||
(not (equal 'run (process-status child)))) |
||||
(message "Process is not running, so running directly.") |
||||
(shell-command (concat "cabal " command) |
||||
(get-buffer-create "*haskell-process-log*") |
||||
(get-buffer-create "*haskell-process-log*")) |
||||
(switch-to-buffer-other-window (get-buffer "*haskell-process-log*"))) |
||||
(t (haskell-process-queue-command |
||||
process |
||||
(make-haskell-command |
||||
:state (list (haskell-interactive-session) process command 0) |
||||
|
||||
:go |
||||
(lambda (state) |
||||
(haskell-process-send-string |
||||
(cadr state) |
||||
(format haskell-process-do-cabal-format-string |
||||
(haskell-session-cabal-dir (car state)) |
||||
(format "%s %s" |
||||
(cl-ecase (haskell-process-type) |
||||
('ghci haskell-process-path-cabal) |
||||
('cabal-repl haskell-process-path-cabal) |
||||
('cabal-ghci haskell-process-path-cabal) |
||||
('stack-ghci haskell-process-path-stack)) |
||||
(cl-caddr state))))) |
||||
|
||||
:live |
||||
(lambda (state buffer) |
||||
(let ((cmd (replace-regexp-in-string "^\\([a-z]+\\).*" |
||||
"\\1" |
||||
(cl-caddr state)))) |
||||
(cond ((or (string= cmd "build") |
||||
(string= cmd "install")) |
||||
(haskell-process-live-build (cadr state) buffer t)) |
||||
(t |
||||
(haskell-process-cabal-live state buffer))))) |
||||
|
||||
:complete |
||||
(lambda (state response) |
||||
(let* ((process (cadr state)) |
||||
(session (haskell-process-session process)) |
||||
(message-count 0) |
||||
(cursor (haskell-process-response-cursor process))) |
||||
;; XXX: what the hell about the rampant code duplication? |
||||
(haskell-process-set-response-cursor process 0) |
||||
(while (haskell-process-errors-warnings nil session process response) |
||||
(setq message-count (1+ message-count))) |
||||
(haskell-process-set-response-cursor process cursor) |
||||
(let ((msg (format "Complete: cabal %s (%s compiler messages)" |
||||
(cl-caddr state) |
||||
message-count))) |
||||
(haskell-interactive-mode-echo session msg) |
||||
(when (= message-count 0) |
||||
(haskell-interactive-mode-echo |
||||
session |
||||
"No compiler messages, dumping complete output:") |
||||
(haskell-interactive-mode-echo session response)) |
||||
(haskell-mode-message-line msg) |
||||
(when (and haskell-notify-p |
||||
(fboundp 'notifications-notify)) |
||||
(notifications-notify |
||||
:title (format "*%s*" (haskell-session-name (car state))) |
||||
:body msg |
||||
:app-name (cl-ecase (haskell-process-type) |
||||
('ghci haskell-process-path-cabal) |
||||
('cabal-repl haskell-process-path-cabal) |
||||
('cabal-ghci haskell-process-path-cabal) |
||||
('stack-ghci haskell-process-path-stack)) |
||||
:app-icon haskell-process-logo))))))))))) |
||||
|
||||
(defun haskell-process-echo-load-message (process buffer echo-in-repl th) |
||||
"Echo a load message." |
||||
(let ((session (haskell-process-session process)) |
||||
(module-name (match-string 3 buffer)) |
||||
(file-name (match-string 4 buffer))) |
||||
(haskell-interactive-show-load-message |
||||
session |
||||
'compiling |
||||
module-name |
||||
(haskell-session-strip-dir session file-name) |
||||
echo-in-repl |
||||
th))) |
||||
|
||||
(defun haskell-process-extract-modules (buffer) |
||||
"Extract the modules from the process buffer." |
||||
(let* ((modules-string (match-string 1 buffer)) |
||||
(modules (split-string modules-string ", "))) |
||||
(cons modules modules-string))) |
||||
|
||||
;;;###autoload |
||||
(defface haskell-error-face |
||||
'((((supports :underline (:style wave))) |
||||
:underline (:style wave :color "#dc322f")) |
||||
(t |
||||
:inherit error)) |
||||
"Face used for marking error lines." |
||||
:group 'haskell-mode) |
||||
|
||||
;;;###autoload |
||||
(defface haskell-warning-face |
||||
'((((supports :underline (:style wave))) |
||||
:underline (:style wave :color "#b58900")) |
||||
(t |
||||
:inherit warning)) |
||||
"Face used for marking warning lines." |
||||
:group 'haskell-mode) |
||||
|
||||
;;;###autoload |
||||
(defface haskell-hole-face |
||||
'((((supports :underline (:style wave))) |
||||
:underline (:style wave :color "#6c71c4")) |
||||
(t |
||||
:inherit warning)) |
||||
"Face used for marking hole lines." |
||||
:group 'haskell-mode) |
||||
|
||||
(defvar haskell-check-error-fringe (propertize "!" 'display '(left-fringe exclamation-mark))) |
||||
(defvar haskell-check-warning-fringe (propertize "?" 'display '(left-fringe question-mark))) |
||||
(defvar haskell-check-hole-fringe (propertize "_" 'display '(left-fringe horizontal-bar))) |
||||
|
||||
(defun haskell-check-overlay-p (ovl) |
||||
(overlay-get ovl 'haskell-check)) |
||||
|
||||
(defun haskell-check-filter-overlays (xs) |
||||
(cl-remove-if-not 'haskell-check-overlay-p xs)) |
||||
|
||||
(defun haskell-check-remove-overlays (buffer) |
||||
(with-current-buffer buffer |
||||
(remove-overlays (point-min) (point-max) 'haskell-check t))) |
||||
|
||||
(defmacro with-overlay-properties (proplist ovl &rest body) |
||||
"Evaluate BODY with names in PROPLIST bound to the values of |
||||
correspondingly-named overlay properties of OVL." |
||||
(let ((ovlvar (cl-gensym "OVL-"))) |
||||
`(let* ((,ovlvar ,ovl) |
||||
,@(mapcar (lambda (p) `(,p (overlay-get ,ovlvar ',p))) proplist)) |
||||
,@body))) |
||||
|
||||
(defun overlay-start> (o1 o2) |
||||
(> (overlay-start o1) (overlay-start o2))) |
||||
(defun overlay-start< (o1 o2) |
||||
(< (overlay-start o1) (overlay-start o2))) |
||||
|
||||
(defun first-overlay-in-if (test beg end) |
||||
(let ((ovls (cl-remove-if-not test (overlays-in beg end)))) |
||||
(cl-first (sort (cl-copy-list ovls) 'overlay-start<)))) |
||||
|
||||
(defun last-overlay-in-if (test beg end) |
||||
(let ((ovls (cl-remove-if-not test (overlays-in beg end)))) |
||||
(cl-first (sort (cl-copy-list ovls) 'overlay-start>)))) |
||||
|
||||
(defun haskell-error-overlay-briefly (ovl) |
||||
(with-overlay-properties (haskell-msg haskell-msg-type) ovl |
||||
(cond ((not (eq haskell-msg-type 'warning)) |
||||
haskell-msg) |
||||
((string-prefix-p "Warning:\n " haskell-msg) |
||||
(cl-subseq haskell-msg 13)) |
||||
(t (error "Invariant failed: a warning message from GHC has unexpected form: %s." haskell-msg))))) |
||||
|
||||
(defun haskell-goto-error-overlay (ovl) |
||||
(cond (ovl |
||||
(goto-char (overlay-start ovl)) |
||||
(haskell-mode-message-line (haskell-error-overlay-briefly ovl))) |
||||
(t |
||||
(message "No further notes from Haskell compiler.")))) |
||||
|
||||
(defun haskell-goto-prev-error () |
||||
(interactive) |
||||
(haskell-goto-error-overlay |
||||
(let ((ovl-at (cl-first (haskell-check-filter-overlays (overlays-at (point)))))) |
||||
(or (last-overlay-in-if 'haskell-check-overlay-p |
||||
(point-min) (if ovl-at (overlay-start ovl-at) (point))) |
||||
ovl-at)))) |
||||
|
||||
(defun haskell-goto-next-error () |
||||
(interactive) |
||||
(haskell-goto-error-overlay |
||||
(let ((ovl-at (cl-first (haskell-check-filter-overlays (overlays-at (point)))))) |
||||
(or (first-overlay-in-if 'haskell-check-overlay-p |
||||
(if ovl-at (overlay-end ovl-at) (point)) (point-max)) |
||||
ovl-at)))) |
||||
|
||||
(defun haskell-check-paint-overlay (buffer error-from-this-file-p line msg file type hole coln) |
||||
(with-current-buffer buffer |
||||
(let (beg end) |
||||
(goto-char (point-min)) |
||||
;; XXX: we can avoid excess buffer walking by relying on the maybe-fact that |
||||
;; GHC sorts error messages by line number, maybe. |
||||
(cond |
||||
(error-from-this-file-p |
||||
(forward-line (1- line)) |
||||
(forward-char (1- coln)) |
||||
(setq beg (point)) |
||||
(if (eq type 'hole) |
||||
(forward-char (length hole)) |
||||
(skip-chars-forward "^[:space:]" (line-end-position))) |
||||
(setq end (point))) |
||||
(t |
||||
(setq beg (point)) |
||||
(forward-line) |
||||
(setq end (point)))) |
||||
(let ((ovl (make-overlay beg end))) |
||||
(overlay-put ovl 'haskell-check t) |
||||
(overlay-put ovl 'haskell-file file) |
||||
(overlay-put ovl 'haskell-msg msg) |
||||
(overlay-put ovl 'haskell-msg-type type) |
||||
(overlay-put ovl 'help-echo msg) |
||||
(overlay-put ovl 'haskell-hole hole) |
||||
(cl-destructuring-bind (face fringe) (cl-case type |
||||
(warning (list 'haskell-warning-face haskell-check-warning-fringe)) |
||||
(hole (list 'haskell-hole-face haskell-check-hole-fringe)) |
||||
(error (list 'haskell-error-face haskell-check-error-fringe))) |
||||
(overlay-put ovl 'before-string fringe) |
||||
(overlay-put ovl 'face face)))))) |
||||
|
||||
(defun haskell-process-errors-warnings (module-buffer session process buffer &optional return-only) |
||||
"Trigger handling type errors or warnings. Either prints the |
||||
messages in the interactive buffer or if CONT is specified, |
||||
passes the error onto that. |
||||
|
||||
When MODULE-BUFFER is non-NIL, paint error overlays." |
||||
(save-excursion |
||||
(cond |
||||
((haskell-process-consume |
||||
process |
||||
"\\(Module imports form a cycle:[ \n]+module [^ ]+ ([^)]+)[[:unibyte:][:nonascii:]]+?\\)\nFailed") |
||||
(let ((err (match-string 1 buffer))) |
||||
(if (string-match "module [`'‘‛]\\([^ ]+\\)['’`] (\\([^)]+\\))" err) |
||||
(let* ((default-directory (haskell-session-current-dir session)) |
||||
(module (match-string 1 err)) |
||||
(file (match-string 2 err)) |
||||
(relative-file-name (file-relative-name file))) |
||||
(unless return-only |
||||
(haskell-interactive-show-load-message |
||||
session |
||||
'import-cycle |
||||
module |
||||
relative-file-name |
||||
nil |
||||
nil) |
||||
(haskell-interactive-mode-compile-error |
||||
session |
||||
(format "%s:1:0: %s" |
||||
relative-file-name |
||||
err))) |
||||
(list :file file :line 1 :col 0 :msg err :type 'error)) |
||||
t))) |
||||
((haskell-process-consume |
||||
process |
||||
(concat "[\r\n]\\([A-Z]?:?[^ \r\n:][^:\n\r]+\\):\\([0-9()-:]+\\):" |
||||
"[ \n\r]+\\([[:unibyte:][:nonascii:]]+?\\)\n[^ ]")) |
||||
(haskell-process-set-response-cursor process |
||||
(- (haskell-process-response-cursor process) 1)) |
||||
(let* ((buffer (haskell-process-response process)) |
||||
(file (match-string 1 buffer)) |
||||
(location-raw (match-string 2 buffer)) |
||||
(error-msg (match-string 3 buffer)) |
||||
(type (cond ((string-match "^Warning:" error-msg) 'warning) |
||||
((string-match "^Splicing " error-msg) 'splice) |
||||
(t 'error))) |
||||
(critical (not (eq type 'warning))) |
||||
;; XXX: extract hole information, pass down to `haskell-check-paint-overlay' |
||||
(final-msg (format "%s:%s: %s" |
||||
(haskell-session-strip-dir session file) |
||||
location-raw |
||||
error-msg)) |
||||
(location (haskell-process-parse-error (concat file ":" location-raw ": x"))) |
||||
(line (plist-get location :line)) |
||||
(col1 (plist-get location :col))) |
||||
(when module-buffer |
||||
(haskell-check-paint-overlay module-buffer (string= (file-truename (buffer-file-name module-buffer)) (file-truename file)) |
||||
line error-msg file type nil col1)) |
||||
(if return-only |
||||
(list :file file :line line :col col1 :msg error-msg :type type) |
||||
(progn (funcall (cl-case type |
||||
(warning 'haskell-interactive-mode-compile-warning) |
||||
(splice 'haskell-interactive-mode-compile-splice) |
||||
(error 'haskell-interactive-mode-compile-error)) |
||||
session final-msg) |
||||
(when critical |
||||
(haskell-mode-message-line final-msg)) |
||||
(haskell-process-trigger-suggestions |
||||
session |
||||
error-msg |
||||
file |
||||
(plist-get (haskell-process-parse-error final-msg) :line)) |
||||
t))))))) |
||||
|
||||
(defun haskell-interactive-show-load-message (session type module-name file-name echo th) |
||||
"Show the '(Compiling|Loading) X' message." |
||||
(let ((msg (concat |
||||
(cl-ecase type |
||||
('compiling |
||||
(if haskell-interactive-mode-include-file-name |
||||
(format "Compiling: %s (%s)" module-name file-name) |
||||
(format "Compiling: %s" module-name))) |
||||
('loading (format "Loading: %s" module-name)) |
||||
('import-cycle (format "Module has an import cycle: %s" module-name))) |
||||
(if th " [TH]" "")))) |
||||
(haskell-mode-message-line msg) |
||||
(when haskell-interactive-mode-delete-superseded-errors |
||||
(haskell-interactive-mode-delete-compile-messages session file-name)) |
||||
(when echo |
||||
(haskell-interactive-mode-echo session msg)))) |
||||
|
||||
;;;###autoload |
||||
(defun haskell-process-reload-devel-main () |
||||
"Reload the module `DevelMain' and then run |
||||
`DevelMain.update'. This is for doing live update of the code of |
||||
servers or GUI applications. Put your development version of the |
||||
program in `DevelMain', and define `update' to auto-start the |
||||
program on a new thread, and use the `foreign-store' package to |
||||
access the running context across :load/:reloads in GHCi." |
||||
(interactive) |
||||
(with-current-buffer (or (get-buffer "DevelMain.hs") |
||||
(if (y-or-n-p "You need to open a buffer named DevelMain.hs. Find now?") |
||||
(ido-find-file) |
||||
(error "No DevelMain.hs buffer."))) |
||||
(let ((session (haskell-interactive-session))) |
||||
(let ((process (haskell-interactive-process))) |
||||
(haskell-process-queue-command |
||||
process |
||||
(make-haskell-command |
||||
:state (list :session session |
||||
:process process |
||||
:buffer (current-buffer)) |
||||
:go (lambda (state) |
||||
(haskell-process-send-string (plist-get state ':process) |
||||
":l DevelMain")) |
||||
:live (lambda (state buffer) |
||||
(haskell-process-live-build (plist-get state ':process) |
||||
buffer |
||||
nil)) |
||||
:complete (lambda (state response) |
||||
(haskell-process-load-complete |
||||
(plist-get state ':session) |
||||
(plist-get state ':process) |
||||
response |
||||
nil |
||||
(plist-get state ':buffer) |
||||
(lambda (ok) |
||||
(when ok |
||||
(haskell-process-queue-without-filters |
||||
(haskell-interactive-process) |
||||
"DevelMain.update") |
||||
(message "DevelMain updated."))))))))))) |
||||
|
||||
(provide 'haskell-load) |
||||
@ -0,0 +1,159 @@
|
||||
;;; haskell-menu.el --- A Haskell sessions menu -*- lexical-binding: t -*- |
||||
|
||||
;; Copyright (C) 2013 Chris Done |
||||
|
||||
;; Author: Chris Done <chrisdone@gmail.com> |
||||
|
||||
;; 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, 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 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. |
||||
|
||||
;;; Commentary: |
||||
|
||||
;;; Todo: |
||||
|
||||
;;; Code: |
||||
|
||||
(require 'cl-lib) |
||||
(require 'haskell-compat) |
||||
(require 'haskell-session) |
||||
(require 'haskell-process) |
||||
(require 'haskell-interactive-mode) |
||||
|
||||
;;;###autoload |
||||
(defcustom haskell-menu-buffer-name "*haskell-menu*" |
||||
"The name of the Haskell session menu buffer" |
||||
:group 'haskell-interactive |
||||
:type 'string) |
||||
|
||||
;;;###autoload |
||||
(defun haskell-menu () |
||||
"Launch the Haskell sessions menu." |
||||
(interactive) |
||||
(or (get-buffer haskell-menu-buffer-name) |
||||
(with-current-buffer (get-buffer-create haskell-menu-buffer-name) |
||||
(haskell-menu-mode))) |
||||
(switch-to-buffer-other-window (get-buffer haskell-menu-buffer-name)) |
||||
(haskell-menu-revert-function nil nil)) |
||||
|
||||
(define-derived-mode haskell-menu-mode special-mode "Haskell Session Menu" |
||||
"Major mode for managing Haskell sessions. |
||||
Each line describes one session. |
||||
Letters do not insert themselves; instead, they are commands." |
||||
(setq buffer-read-only t) |
||||
(set (make-local-variable 'revert-buffer-function) |
||||
'haskell-menu-revert-function) |
||||
(setq truncate-lines t) |
||||
(haskell-menu-revert-function nil t)) |
||||
|
||||
(suppress-keymap haskell-menu-mode-map t) |
||||
(define-key haskell-menu-mode-map (kbd "n") 'next-line) |
||||
(define-key haskell-menu-mode-map (kbd "p") 'previous-line) |
||||
(define-key haskell-menu-mode-map (kbd "RET") 'haskell-menu-mode-ret) |
||||
|
||||
(defun haskell-menu-revert-function (_arg1 _arg2) |
||||
"Function to refresh the display." |
||||
(let ((buffer-read-only nil) |
||||
(orig-line (line-number-at-pos)) |
||||
(orig-col (current-column))) |
||||
(or (eq buffer-undo-list t) |
||||
(setq buffer-undo-list nil)) |
||||
(erase-buffer) |
||||
(haskell-menu-insert-menu) |
||||
(goto-char (point-min)) |
||||
(forward-line (1- orig-line)) |
||||
(forward-char orig-col))) |
||||
|
||||
(defun haskell-menu-insert-menu () |
||||
"Insert the Haskell sessions menu to the current buffer." |
||||
(if (null haskell-sessions) |
||||
(insert "No Haskell sessions.") |
||||
(haskell-menu-tabulate |
||||
(list "Name" "PID" "Time" "RSS" "Cabal directory" "Working directory" "Command") |
||||
(mapcar (lambda (session) |
||||
(let ((process (haskell-process-process (haskell-session-process session)))) |
||||
(cond |
||||
(process |
||||
(let ((id (process-id process))) |
||||
(list (propertize (haskell-session-name session) 'face 'buffer-menu-buffer) |
||||
(if (process-live-p process) (number-to-string id) "-") |
||||
(if (process-live-p process) |
||||
(format-time-string "%H:%M:%S" |
||||
(encode-time (cl-caddr (assoc 'etime (process-attributes id))) |
||||
0 0 0 0 0)) |
||||
"-") |
||||
(if (process-live-p process) |
||||
(concat (number-to-string (/ (cdr (assoc 'rss (process-attributes id))) |
||||
1024)) |
||||
"MB") |
||||
"-") |
||||
(haskell-session-cabal-dir session) |
||||
(haskell-session-current-dir session) |
||||
(mapconcat 'identity (process-command process) " ")))) |
||||
(t (list (propertize (haskell-session-name session) 'face 'buffer-menu-buffer) |
||||
"—" |
||||
"—" |
||||
"—" |
||||
(haskell-session-cabal-dir session) |
||||
(haskell-session-current-dir session)))))) |
||||
haskell-sessions)))) |
||||
|
||||
(defun haskell-menu-tabulate (headings rows) |
||||
"Prints a list of lists as a formatted table to the current buffer." |
||||
(let* ((columns (length headings)) |
||||
(widths (make-list columns 0))) |
||||
;; Calculate column widths. This is kind of hideous. |
||||
(dolist (row rows) |
||||
(setq widths |
||||
(let ((list (list))) |
||||
(dotimes (i columns) |
||||
(setq list (cons (max (nth i widths) |
||||
(1+ (length (nth i row))) |
||||
(1+ (length (nth i headings)))) |
||||
list))) |
||||
(reverse list)))) |
||||
;; Print headings. |
||||
(let ((heading (propertize " " 'display '(space :align-to 0)))) |
||||
(dotimes (i columns) |
||||
(setq heading (concat heading |
||||
(format (concat "%-" (number-to-string (nth i widths)) "s") |
||||
(nth i headings))))) |
||||
(setq header-line-format heading)) |
||||
;; Print tabulated rows. |
||||
(dolist (row rows) |
||||
(dotimes (i columns) |
||||
(insert (format (concat "%-" (number-to-string (nth i widths)) "s") |
||||
(nth i row)))) |
||||
(insert "\n")))) |
||||
|
||||
(defun haskell-menu-mode-ret () |
||||
"Handle RET key." |
||||
(interactive) |
||||
(let* ((name (save-excursion |
||||
(goto-char (line-beginning-position)) |
||||
(buffer-substring-no-properties (point) |
||||
(progn (search-forward " ") |
||||
(forward-char -1) |
||||
(point))))) |
||||
(session (car (cl-remove-if-not (lambda (session) |
||||
(string= (haskell-session-name session) |
||||
name)) |
||||
haskell-sessions)))) |
||||
(switch-to-buffer (haskell-session-interactive-buffer session)))) |
||||
|
||||
(provide 'haskell-menu) |
||||
|
||||
;;; haskell-menu.el ends here |
||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,5 @@
|
||||
(define-package "haskell-mode" "20151024.1154" "A Haskell editing mode" |
||||
'((cl-lib "0.5"))) |
||||
;; Local Variables: |
||||
;; no-byte-compile: t |
||||
;; End: |
||||
File diff suppressed because it is too large
Load Diff
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in new issue